factor: Rename ``M\ array generic`` to ``m: { array generic }``.
The problem with M\ is that it has an arity of 1 where we need it to have arity 2. Also, for multimethods, the \ disables parsing of the array that follows, e.g. ``M\ { string string } multimethod-name`` parses as ``M\ {`` and leaves the rest unparsed. This is obviously wrong. An alternative syntax that should be implement and looks ok is ``m{ array generic }``modern-harvey2
parent
8e14c52dd1
commit
cada003d7f
|
@ -227,7 +227,7 @@ IN: compiler.cfg.builder.tests
|
|||
] when
|
||||
|
||||
! Regression. Make sure everything is inlined correctly
|
||||
{ f } [ M\ hashtable set-at [ { [ ##call? ] [ word>> \ set-slot eq? ] } 1&& ] contains-insn? ] unit-test
|
||||
{ f } [ m: { hashtable set-at } [ { [ ##call? ] [ word>> \ set-slot eq? ] } 1&& ] contains-insn? ] unit-test
|
||||
|
||||
! Regression. Make sure branch splitting works.
|
||||
{ 2 } [ [ 1 2 ? ] [ ##return? ] count-insns ] unit-test
|
||||
|
|
|
@ -12,7 +12,7 @@ IN: compiler.tests.optimizer
|
|||
GENERIC: xyz ( obj -- obj )
|
||||
M: array xyz xyz ;
|
||||
|
||||
[ t ] [ M\ array xyz word-optimized? ] unit-test
|
||||
[ t ] [ m: { array xyz } word-optimized? ] unit-test
|
||||
|
||||
! Test predicate inlining
|
||||
: pred-test-1 ( a -- b c )
|
||||
|
|
|
@ -5,4 +5,4 @@ TUPLE: bad ;
|
|||
|
||||
M: bad length 1 2 3 ;
|
||||
|
||||
[ ] [ [ M\ bad length forget ] with-compilation-unit ] unit-test
|
||||
[ ] [ [ m: { bad length } forget ] with-compilation-unit ] unit-test
|
||||
|
|
|
@ -252,7 +252,7 @@ M: quotation bad-effect-test call ; inline
|
|||
[ bad-effect-test* ] [ not-compiled? ] must-fail-with
|
||||
|
||||
! Don't want compiler error to stick around
|
||||
[ ] [ [ M\ quotation bad-effect-test forget ] with-compilation-unit ] unit-test
|
||||
[ ] [ [ m: { quotation bad-effect-test } forget ] with-compilation-unit ] unit-test
|
||||
|
||||
! Make sure time bombs literalize
|
||||
[ [ \ + call ] compile-call ] [ no-method? ] must-fail-with
|
||||
|
|
|
@ -302,17 +302,17 @@ CONSTANT: lookup-table-at-max 256
|
|||
: diff-quot ( seq -- quot: ( seq' -- seq'' ) )
|
||||
[ tester ] keep '[ members [ @ ] reject _ set-like ] ;
|
||||
|
||||
M\ sets:set diff [ diff-quot ] 1 define-partial-eval
|
||||
m: { sets:set diff } [ diff-quot ] 1 define-partial-eval
|
||||
|
||||
: intersect-quot ( seq -- quot: ( seq' -- seq'' ) )
|
||||
[ tester ] keep '[ members _ filter _ set-like ] ;
|
||||
|
||||
M\ sets:set intersect [ intersect-quot ] 1 define-partial-eval
|
||||
m: { sets:set intersect } [ intersect-quot ] 1 define-partial-eval
|
||||
|
||||
: intersects?-quot ( seq -- quot: ( seq' -- seq'' ) )
|
||||
tester '[ members _ any? ] ;
|
||||
|
||||
M\ sets:set intersects? [ intersects?-quot ] 1 define-partial-eval
|
||||
m: { sets:set intersects? } [ intersects?-quot ] 1 define-partial-eval
|
||||
|
||||
: bit-quot ( #call -- quot/f )
|
||||
in-d>> second value-info interval>> 0 fixnum-bits [a,b] interval-subset?
|
||||
|
|
|
@ -7,6 +7,6 @@ GENERIC: blahblah ( a b c -- )
|
|||
|
||||
M: hashtable blahblah 2nip [ 1 + ] change-count drop ;
|
||||
|
||||
HINTS: M\ hashtable blahblah { object fixnum object } { object word object } ;
|
||||
HINTS: m: { hashtable blahblah } { object fixnum object } { object word object } ;
|
||||
|
||||
{ t } [ M\ hashtable blahblah { count>> count<< } inlined? ] unit-test
|
||||
{ t } [ m: { hashtable blahblah } { count>> count<< } inlined? ] unit-test
|
||||
|
|
|
@ -135,10 +135,10 @@ set-specializer
|
|||
|
||||
\ base> { string fixnum } set-specializer
|
||||
|
||||
M\ hashtable at*
|
||||
m: { hashtable at* }
|
||||
{ { fixnum object } { word object } }
|
||||
set-specializer
|
||||
|
||||
M\ hashtable set-at
|
||||
m: { hashtable set-at }
|
||||
{ { object fixnum object } { object word object } }
|
||||
set-specializer
|
||||
|
|
|
@ -383,7 +383,7 @@ GENERIC: lambda-method-forget-test ( a -- b )
|
|||
|
||||
M:: integer lambda-method-forget-test ( a -- b ) a ;
|
||||
|
||||
{ } [ [ M\ integer lambda-method-forget-test forget ] with-compilation-unit ] unit-test
|
||||
{ } [ [ m: { integer lambda-method-forget-test } forget ] with-compilation-unit ] unit-test
|
||||
|
||||
{ 10 } [ 10 |[ A | { [ A ] } ] call first call ] unit-test
|
||||
|
||||
|
|
|
@ -61,8 +61,10 @@ M: word pprint*
|
|||
|
||||
M: method pprint*
|
||||
<block
|
||||
[ \ M\ pprint-word "method-class" word-prop pprint* ]
|
||||
\ \m: pprint-word \ \{ pprint-word
|
||||
[ "method-class" word-prop pprint* ]
|
||||
[ "method-generic" word-prop pprint-word ] bi
|
||||
\ \} pprint-word
|
||||
block> ;
|
||||
|
||||
: pprint-prefixed-number ( n quot: ( n -- n' ) pre -- )
|
||||
|
|
|
@ -287,7 +287,7 @@ GENERIC: generic-see-test-with-f ( obj -- obj )
|
|||
M: f generic-see-test-with-f ;
|
||||
|
||||
{ "USING: prettyprint.tests ;\nM: f generic-see-test-with-f ;\n" } [
|
||||
[ M\ f generic-see-test-with-f see ] with-string-writer
|
||||
[ m: { f generic-see-test-with-f } see ] with-string-writer
|
||||
] unit-test
|
||||
|
||||
PREDICATE: predicate-see-test < integer even? ;
|
||||
|
@ -314,7 +314,7 @@ GENERIC: ended-up-ballin' ( a -- b )
|
|||
M: started-out-hustlin' ended-up-ballin' ; inline
|
||||
|
||||
{ "USING: prettyprint.tests ;\nM: started-out-hustlin' ended-up-ballin' ; inline\n" } [
|
||||
[ M\ started-out-hustlin' ended-up-ballin' see ] with-string-writer
|
||||
[ m: { started-out-hustlin' ended-up-ballin' } see ] with-string-writer
|
||||
] unit-test
|
||||
|
||||
TUPLE: tuple-with-declared-slot { x integer } ;
|
||||
|
@ -400,13 +400,13 @@ TUPLE: bob a b ;
|
|||
TUPLE: har a ;
|
||||
GENERIC: harhar ( obj -- obj )
|
||||
M: maybe{ har } harhar ;
|
||||
M: integer harhar M\ integer harhar drop ;
|
||||
M: integer harhar m: { integer harhar } drop ;
|
||||
{
|
||||
"USING: prettyprint.tests ;
|
||||
M: maybe{ har } harhar ;
|
||||
|
||||
USING: kernel math prettyprint.tests ;
|
||||
M: integer harhar M\\ integer harhar drop ;\n"
|
||||
M: integer harhar m: { integer harhar } drop ;\n"
|
||||
} [
|
||||
[ \ harhar see-methods ] with-string-writer
|
||||
] unit-test
|
||||
|
|
|
@ -14,7 +14,7 @@ M: unix-random dispose reader>> dispose ;
|
|||
|
||||
M: unix-random random-bytes* ( n tuple -- byte-array )
|
||||
reader>> stream-read ;
|
||||
HINTS: M\ unix-random random-bytes* { fixnum unix-random } ;
|
||||
HINTS: m: { unix-random random-bytes* } { fixnum unix-random } ;
|
||||
|
||||
[
|
||||
"/dev/random" <unix-random> &dispose secure-random-generator set-global
|
||||
|
|
|
@ -47,7 +47,7 @@ GENERIC: blah-generic ( a -- b )
|
|||
|
||||
M: string blah-generic ;
|
||||
|
||||
{ } [ M\ string blah-generic watch ] unit-test
|
||||
{ } [ m: { string blah-generic } watch ] unit-test
|
||||
|
||||
{ "hi" } [ "hi" blah-generic ] unit-test
|
||||
|
||||
|
|
|
@ -51,7 +51,7 @@ M: sequence generic-forget-test-2 = ;
|
|||
] unit-test
|
||||
|
||||
{ } [
|
||||
[ M\ sequence generic-forget-test-2 forget ] with-compilation-unit
|
||||
[ m: { sequence generic-forget-test-2 } forget ] with-compilation-unit
|
||||
] unit-test
|
||||
|
||||
{ f } [
|
||||
|
|
|
@ -62,4 +62,4 @@ M: object (flatten-tree) , ;
|
|||
{ 0 1 } { 2 0 1 } { { "a" "b" "c" "d" } { "e" "f" "g" } { { "h" "i" } "j" } } gadgets-in-range
|
||||
] unit-test
|
||||
|
||||
[ M\ array children>> forget ] with-compilation-unit
|
||||
[ m: { array children>> } forget ] with-compilation-unit
|
||||
|
|
|
@ -18,7 +18,7 @@ M: a x drop a ;
|
|||
{ a } [ T{ a2 } x ] unit-test
|
||||
|
||||
{ t } [ T{ a3 } c? ] unit-test
|
||||
{ t } [ T{ a3 } \ x effective-method M\ c x eq? nip ] unit-test
|
||||
{ t } [ T{ a3 } \ x effective-method m: { c x } eq? nip ] unit-test
|
||||
{ c } [ T{ a3 } x ] unit-test
|
||||
|
||||
! More complex case
|
||||
|
|
|
@ -133,9 +133,9 @@ M: forget-robustness forget-robustness-generic ;
|
|||
M: integer forget-robustness-generic ;
|
||||
|
||||
[
|
||||
[ ] [ \ forget-robustness-generic forget ] unit-test
|
||||
[ ] [ \ forget-robustness forget ] unit-test
|
||||
[ ] [ M\ forget-robustness forget-robustness-generic forget ] unit-test
|
||||
[ ] [ m: { forget-robustness-generic } forget ] unit-test
|
||||
[ ] [ m: { forget-robustness } forget ] unit-test
|
||||
[ ] [ m: { forget-robustness forget-robustness-generic } forget ] unit-test
|
||||
] with-compilation-unit
|
||||
|
||||
! rapido found this one
|
||||
|
|
|
@ -49,7 +49,7 @@ $nl
|
|||
"Low-level method constructor:"
|
||||
{ $subsections <method> }
|
||||
"Methods may be pushed on the stack with a literal syntax:"
|
||||
{ $subsections postpone: \M\ }
|
||||
{ $subsections postpone: \m: }
|
||||
{ $see-also "see" } ;
|
||||
|
||||
ARTICLE: "method-combination" "Custom method combination"
|
||||
|
@ -126,10 +126,10 @@ HELP: define-generic
|
|||
{ $description "Defines a generic word. A method combination is an object which responds to the " { $link perform-combination } " generic word." }
|
||||
{ $contract "The method combination quotation is called each time the generic word has to be updated (for example, when a method is added), and thus must be side-effect free." } ;
|
||||
|
||||
HELP: M\
|
||||
{ $syntax "M\\ class generic" }
|
||||
HELP: \m:
|
||||
{ $syntax "m: { class generic }" }
|
||||
{ $description "Pushes a method on the stack." }
|
||||
{ $examples { $code "M\\ fixnum + see" } { $code "USING: ui.gadgets.editors ui.render ;" "M\\ editor draw-gadget* edit" } } ;
|
||||
{ $examples { $code "m: { fixnum + } see" } { $code "USING: ui.gadgets.editors ui.render ;" "m: { editor draw-gadget* } edit" } } ;
|
||||
|
||||
HELP: method
|
||||
{ $class-description "The class of method bodies, which are words with special word properties set." } ;
|
||||
|
@ -177,7 +177,7 @@ HELP: (call-next-method)
|
|||
"The " { $link postpone: call-next-method } " word parses into this word. The following are equivalent:"
|
||||
{ $code
|
||||
"M: class generic call-next-method ;"
|
||||
"M: class generic M\\ class generic (call-next-method) ;"
|
||||
"M: class generic m: { class generic } (call-next-method) ;"
|
||||
}
|
||||
} ;
|
||||
|
||||
|
|
|
@ -27,7 +27,7 @@ M: growable call-next-hooker call-next-method "growable " prepend ;
|
|||
] unit-test
|
||||
|
||||
{ t } [
|
||||
{ } \ nth effective-method nip M\ sequence nth eq?
|
||||
{ } \ nth effective-method nip m: { sequence nth } eq?
|
||||
] unit-test
|
||||
|
||||
{ t } [
|
||||
|
|
|
@ -398,7 +398,7 @@ GENERIC: forget-test ( a -- b )
|
|||
|
||||
M: integer forget-test 3 + ;
|
||||
|
||||
{ } [ "IN: generic.standard.tests USE: math FORGET: M\\ integer forget-test" eval( -- ) ] unit-test
|
||||
{ } [ "IN: generic.standard.tests USE: math FORGET: m: { integer forget-test }" eval( -- ) ] unit-test
|
||||
|
||||
{ { } } [
|
||||
\ + all-dependencies-of keys [ method? ] filter
|
||||
|
@ -412,13 +412,13 @@ GENERIC: flushable-generic ( a -- b ) flushable
|
|||
M: integer flushable-generic ;
|
||||
|
||||
{ t } [ \ flushable-generic flushable? ] unit-test
|
||||
{ t } [ M\ integer flushable-generic flushable? ] unit-test
|
||||
{ t } [ m: { integer flushable-generic } flushable? ] unit-test
|
||||
|
||||
GENERIC: non-flushable-generic ( a -- b )
|
||||
M: integer non-flushable-generic ; flushable
|
||||
|
||||
{ f } [ \ non-flushable-generic flushable? ] unit-test
|
||||
{ t } [ M\ integer non-flushable-generic flushable? ] unit-test
|
||||
{ t } [ m: { integer non-flushable-generic } flushable? ] unit-test
|
||||
|
||||
! method-for-object, method-for-class, effective-method
|
||||
GENERIC: foozul ( a -- b )
|
||||
|
@ -426,7 +426,7 @@ M: reversed foozul ;
|
|||
M: integer foozul ;
|
||||
M: slice foozul ;
|
||||
|
||||
{ } [ reversed \ foozul method-for-class M\ reversed foozul assert= ] unit-test
|
||||
{ } [ reversed \ foozul method-for-class m: { reversed foozul } assert= ] unit-test
|
||||
{ } [ { 1 2 3 } <reversed> \ foozul method-for-object M\ reversed foozul assert= ] unit-test
|
||||
{ } [ { 1 2 3 } <reversed> \ foozul effective-method M\ reversed foozul assert= drop ] unit-test
|
||||
|
||||
|
|
|
@ -116,6 +116,7 @@ IN: bootstrap.syntax
|
|||
"postpone:" [ scan-syntax-word suffix! ] define-core-syntax
|
||||
"\\" [ scan-word <wrapper> suffix! ] define-core-syntax
|
||||
"M\\" [ scan-word scan-word lookup-method <wrapper> suffix! ] define-core-syntax
|
||||
"m:" [ scan-object first2 lookup-method <wrapper> suffix! ] define-core-syntax
|
||||
"inline" [ last-word make-inline ] define-core-syntax
|
||||
"recursive" [ last-word make-recursive ] define-core-syntax
|
||||
"foldable" [ last-word make-foldable ] define-core-syntax
|
||||
|
|
|
@ -79,7 +79,7 @@ C: <sphere> sphere
|
|||
M: sphere intersect-scene ( hit ray sphere -- hit )
|
||||
[ [ sphere-n normalize ] keep <hit> nip ] if-ray-sphere ;
|
||||
|
||||
HINTS: M\ sphere intersect-scene { hit ray sphere } ;
|
||||
HINTS: m: { sphere intersect-scene } { hit ray sphere } ;
|
||||
|
||||
TUPLE: group < sphere { objs array read-only } ;
|
||||
|
||||
|
@ -92,7 +92,7 @@ TUPLE: group < sphere { objs array read-only } ;
|
|||
M: group intersect-scene ( hit ray group -- hit )
|
||||
[ drop objs>> [ intersect-scene ] with each ] if-ray-sphere ;
|
||||
|
||||
HINTS: M\ group intersect-scene { hit ray group } ;
|
||||
HINTS: m: { group intersect-scene } { hit ray group } ;
|
||||
|
||||
CONSTANT: initial-hit T{ hit f double-array{ 0.0 0.0 0.0 } 1/0. }
|
||||
|
||||
|
|
Loading…
Reference in New Issue