Remove initial-quot feature

db4
Slava Pestov 2009-06-15 13:07:15 -05:00
parent 75276855ae
commit 29327a787c
8 changed files with 22 additions and 109 deletions

View File

@ -328,10 +328,3 @@ C: <ro-box> ro-box
TUPLE: empty-tuple ;
[ ] [ [ empty-tuple boa layout-of ] count-unboxed-allocations drop ] unit-test
! Make sure that initial-quot: doesn't inhibit unboxing
TUPLE: initial-quot-tuple { x read-only initial-quot: [ 0 ] } ;
[ 1 ] [
[ initial-quot-tuple new x>> ] count-unboxed-allocations
] unit-test

View File

@ -11,17 +11,18 @@ combinators.short-circuit ;
IN: io.servers.connection
TUPLE: threaded-server
{ name initial: "server" }
{ log-level initial: DEBUG }
secure insecure
{ secure-config initial-quot: [ <secure-config> ] }
{ sockets initial-quot: [ V{ } clone ] }
name
log-level
secure
insecure
secure-config
sockets
max-connections
semaphore
{ timeout initial-quot: [ 1 minutes ] }
timeout
encoding
{ handler initial: [ "No handler quotation" throw ] }
{ ready initial-quot: [ <flag> ] } ;
handler
ready ;
: local-server ( port -- addrspec ) "localhost" swap <inet> ;
@ -29,6 +30,13 @@ encoding
: new-threaded-server ( encoding class -- threaded-server )
new
"server" >>name
DEBUG >>log-level
<secure-config> >>secure-config
V{ } clone >>sockets
1 minutes >>timeout
[ "No handler quotation" throw ] >>handler
<flag> >>ready
swap >>encoding ;
: <threaded-server> ( encoding -- threaded-server )

View File

@ -80,7 +80,6 @@ IN: bootstrap.syntax
">>"
"call-next-method"
"initial:"
"initial-quot:"
"read-only"
"call("
"execute("

View File

@ -142,11 +142,3 @@ TUPLE: parsing-corner-case x ;
" x 3 }"
} "\n" join eval( -- tuple )
] [ error>> unexpected-eof? ] must-fail-with
[ ] [
<" USE: sequences
IN: classes.tuple.tests
TUPLE: book { name initial-quot: [ "Lord of the " "Rings" append ] } ;">
eval( -- )
] unit-test

View File

@ -729,50 +729,3 @@ DEFER: redefine-tuple-twice
[ ] [ "IN: classes.tuple.tests TUPLE: redefine-tuple-twice ;" eval( -- ) ] unit-test
[ t ] [ \ redefine-tuple-twice symbol? ] unit-test
TUPLE: lucky-number { n initial-quot: [ 64 random-bits ] } ;
SLOT: winner?
[ t ] [ lucky-number new n>> integer? ] unit-test
: compiled-lucky-number ( -- tuple ) lucky-number new ;
[ t ] [ compiled-lucky-number n>> integer? ] unit-test
! Reshaping initial-quot:
lucky-number new dup n>> 2array "luckiest-number" set
[ t ] [ "luckiest-number" get first2 [ n>> ] dip = ] unit-test
[ ] [ "USING: accessors random ; IN: classes.tuple.tests TUPLE: lucky-number { n initial-quot: [ 64 random-bits ] } { winner? initial-quot: [ t ] } ;" eval( -- ) ] unit-test
[ t ] [ "luckiest-number" get first2 [ n>> ] dip = ] unit-test
[ t ] [ "luckiest-number" get first winner?>> ] unit-test
! invalid-quot: together with type declaration
TUPLE: decl-initial-quot { x integer initial-quot: [ 1 ] } ;
[ t ] [ decl-initial-quot new x>> integer? ] unit-test
: compiled-decl-initial-quot ( -- tuple ) decl-initial-quot new ;
[ t ] [ compiled-decl-initial-quot x>> integer? ] unit-test
! invalid-quot: with read-only
TUPLE: read-only-initial-quot { x integer read-only initial-quot: [ 1 ] } ;
[ t ] [ read-only-initial-quot new x>> integer? ] unit-test
: compiled-read-only-initial-quot ( -- tuple ) read-only-initial-quot new ;
[ t ] [ compiled-read-only-initial-quot x>> integer? ] unit-test
! Specifying both initial: and initial-quot: should fail
2 [
[
"IN: classes.tuple.test TUPLE: redundant-decl { x initial: 0 initial-quot: [ 0 ] } ;"
eval( -- )
]
[ error>> duplicate-initial-values? ]
must-fail-with
] times

View File

@ -50,9 +50,6 @@ M: tuple class layout-of 2 slot { word } declare ;
PRIVATE>
: initial-quots? ( class -- ? )
all-slots [ initial-quot>> ] any? ;
: initial-values ( class -- slots )
all-slots [ initial>> ] map ;
@ -149,21 +146,12 @@ ERROR: bad-superclass class ;
: define-boa-check ( class -- )
dup boa-check-quot "boa-check" set-word-prop ;
: tuple-initial-quots-quot ( class -- quot )
all-slots [ initial-quot>> ] filter
[
[
[ initial-quot>> % \ over , ] [ offset>> , ] bi \ set-slot ,
] each
] [ ] make f like ;
: tuple-prototype ( class -- prototype )
[ initial-values ] [ over [ ] any? ] [ initial-quots? or ] tri
[ initial-values ] keep over [ ] any?
[ slots>tuple ] [ 2drop f ] if ;
: define-tuple-prototype ( class -- )
dup [ tuple-prototype ] [ tuple-initial-quots-quot ] bi 2array
dup [ ] any? [ drop f ] unless "prototype" set-word-prop ;
dup tuple-prototype "prototype" set-word-prop ;
: prepare-slots ( slots superclass -- slots' )
[ make-slots ] [ class-size 2 + ] bi* finalize-slots ;
@ -185,16 +173,10 @@ ERROR: bad-superclass class ;
: define-tuple-layout ( class -- )
dup make-tuple-layout "layout" set-word-prop ;
: calculate-initial-value ( slot-spec -- value )
dup initial>> [ ] [
dup initial-quot>>
[ call( -- obj ) ] [ drop f ] ?if
] ?if ;
: compute-slot-permutation ( new-slots old-slots -- triples )
[ [ [ name>> ] map ] bi@ [ index ] curry map ]
[ drop [ class>> ] map ]
[ drop [ calculate-initial-value ] map ]
[ drop [ initial>> ] map ]
2tri 3array flip ;
: update-slot ( old-values n class initial -- value )
@ -358,11 +340,7 @@ M: tuple tuple-hashcode
M: tuple hashcode* tuple-hashcode ;
M: tuple-class new
dup "prototype" word-prop [
first2 [ (clone) ] dip [ call( obj -- obj ) ] when*
] [
tuple-layout <tuple>
] ?if ;
dup "prototype" word-prop [ (clone) ] [ tuple-layout <tuple> ] ?if ;
M: tuple-class boa
[ "boa-check" word-prop [ call ] when* ]

View File

@ -6,7 +6,7 @@ classes classes.algebra slots.private combinators accessors
words sequences.private assocs alien quotations hashtables ;
IN: slots
TUPLE: slot-spec name offset class initial initial-quot read-only ;
TUPLE: slot-spec name offset class initial read-only ;
PREDICATE: reader < word "reader" word-prop ;
@ -190,7 +190,6 @@ ERROR: bad-slot-attribute key ;
dup empty? [
unclip {
{ initial: [ [ first >>initial ] [ rest ] bi ] }
{ initial-quot: [ [ first >>initial-quot ] [ rest ] bi ] }
{ read-only [ [ t >>read-only ] dip ] }
[ bad-slot-attribute ]
} case
@ -198,14 +197,7 @@ ERROR: bad-slot-attribute key ;
ERROR: bad-initial-value name ;
ERROR: duplicate-initial-values slot ;
: check-duplicate-initial-values ( slot-spec -- slot-spec )
dup [ initial>> ] [ initial-quot>> ] bi and
[ duplicate-initial-values ] when ;
: check-initial-value ( slot-spec -- slot-spec )
check-duplicate-initial-values
dup initial>> [
[ ] [
dup [ initial>> ] [ class>> ] bi instance?

View File

@ -246,8 +246,6 @@ IN: bootstrap.syntax
"initial:" "syntax" lookup define-symbol
"initial-quot:" "syntax" lookup define-symbol
"read-only" "syntax" lookup define-symbol
"call(" [ \ call-effect parse-call( ] define-core-syntax