">>"
"call-next-method"
"initial:"
+ "initial-quot:"
"read-only"
"call("
"execute("
IN: classes.tuple.parser.tests
USING: accessors classes.tuple.parser lexer words classes
sequences math kernel slots tools.test parser compiler.units
-arrays classes.tuple eval ;
+arrays classes.tuple eval multiline ;
TUPLE: test-1 ;
" 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
+
+[ ] [
+ <" IN: classes.tuple.tests
+ TUPLE: monster { hp virtual } ;">
+ eval( -- )
+] unit-test
PRIVATE>
+: initial-value ( slot -- obj )
+ dup initial>> [
+ nip
+ ] [
+ dup initial-quot>> [
+ nip call( -- obj )
+ ] [
+ drop f
+ ] if*
+ ] if* ;
+
: initial-values ( class -- slots )
- all-slots [ initial>> ] map ;
+ all-slots [ initial-value ] map ;
: pad-slots ( slots class -- slots' class )
[ initial-values over length tail append ] keep ; inline
: compute-slot-permutation ( new-slots old-slots -- triples )
[ [ [ name>> ] map ] bi@ [ index ] curry map ]
[ drop [ class>> ] map ]
- [ drop [ initial>> ] map ]
+ [ drop [ initial-value ] map ]
2tri 3array flip ;
: update-slot ( old-values n class initial -- value )
USING: arrays byte-arrays kernel kernel.private math namespaces
make sequences strings effects generic generic.standard
classes classes.algebra slots.private combinators accessors
-words sequences.private assocs alien quotations hashtables ;
+words sequences.private assocs alien quotations hashtables summary ;
IN: slots
-TUPLE: slot-spec name offset class initial read-only ;
+TUPLE: slot-spec name offset class initial initial-quot read-only ;
PREDICATE: reader < word "reader" word-prop ;
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
ERROR: bad-initial-value name ;
+ERROR: duplicate-initial-values slot ;
+
+M: duplicate-initial-values summary
+ drop "Slots can either define initial: or initial-quot:, but not both" ;
+
+: 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?
] define-core-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