steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

macros: check macro effect is real-macro-effect.

db4
John Benediktsson 2015-07-19 11:16:19 -07:00
parent 4cda3fe7c4
commit 86c81bedfb
2 changed files with 8 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/macros/macros-tests.factor
View File

@ -20,7 +20,7 @@ unit-test
{ f } [ \ see-test macro? ] unit-test { f } [ \ see-test macro? ] unit-test
{ } [ "USING: macros stack-checker kernel ; IN: hanging-macro MACRO: c ( quot -- ) infer drop [ ] ;" eval( -- ) ] unit-test { } [ "USING: macros stack-checker kernel ; IN: hanging-macro MACRO: c ( quot -- quot ) infer drop [ ] ;" eval( -- ) ] unit-test
{ } [ "USING: macros kernel ; IN: hanging-macro : a ( -- ) [ a ] c ;" eval( -- ) ] unit-test { } [ "USING: macros kernel ; IN: hanging-macro : a ( -- ) [ a ] c ;" eval( -- ) ] unit-test
{ } [ [ "hanging-macro" forget-vocab ] with-compilation-unit ] unit-test { } [ [ "hanging-macro" forget-vocab ] with-compilation-unit ] unit-test

9
basis/macros/macros.factor
View File

@ -9,13 +9,18 @@ IN: macros
: real-macro-effect ( effect -- effect' ) : real-macro-effect ( effect -- effect' )
in>> { "quot" } <effect> ; in>> { "quot" } <effect> ;
: check-macro-effect ( word effect -- )
[ real-macro-effect ] keep 2dup effect=
[ 3drop ] [ bad-stack-effect ] if ;
PRIVATE> PRIVATE>
: define-macro ( word definition effect -- ) : define-macro ( word definition effect -- )
real-macro-effect { {
[ nip check-macro-effect ]
[ [
[ '[ _ _ call-effect ] ] keep [ '[ _ _ call-effect ] ] keep
[ memoize-quot '[ @ call ] ] keep [ memoize-quot ] keep
define-declared define-declared
] ]
[ drop "macro" set-word-prop ] [ drop "macro" set-word-prop ]