Remove initial-quot feature
parent
75276855ae
commit
29327a787c
|
@ -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
|
|
@ -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 )
|
||||
|
|
|
@ -80,7 +80,6 @@ IN: bootstrap.syntax
|
|||
">>"
|
||||
"call-next-method"
|
||||
"initial:"
|
||||
"initial-quot:"
|
||||
"read-only"
|
||||
"call("
|
||||
"execute("
|
||||
|
|
|
@ -141,12 +141,4 @@ TUPLE: parsing-corner-case x ;
|
|||
"USE: classes.tuple.parser.tests T{ parsing-corner-case {"
|
||||
" 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
|
||||
] [ error>> unexpected-eof? ] must-fail-with
|
|
@ -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
|
||||
|
|
|
@ -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* ]
|
||||
|
|
|
@ -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?
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in New Issue