More work on lisp macros
parent
1824e1c413
commit
0fa6dc12f2
extra/lisp
|
@ -15,9 +15,6 @@ DEFER: lisp-var?
|
||||||
DEFER: macro-expand
|
DEFER: macro-expand
|
||||||
DEFER: define-lisp-macro
|
DEFER: define-lisp-macro
|
||||||
|
|
||||||
ERROR: no-such-var variable-name ;
|
|
||||||
M: no-such-var summary drop "No such variable" ;
|
|
||||||
|
|
||||||
! Functions to convert s-exps to quotations
|
! Functions to convert s-exps to quotations
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
: convert-body ( cons -- quot )
|
: convert-body ( cons -- quot )
|
||||||
|
@ -51,7 +48,7 @@ M: no-such-var summary drop "No such variable" ;
|
||||||
|
|
||||||
: rest-lambda ( body vars -- quot )
|
: rest-lambda ( body vars -- quot )
|
||||||
"&rest" swap [ index ] [ remove ] 2bi
|
"&rest" swap [ index ] [ remove ] 2bi
|
||||||
swapd localize-lambda <lambda>
|
swapd localize-lambda <lambda> lambda-rewrite call
|
||||||
'[ , cut '[ @ , seq>list ] call , call ] ;
|
'[ , cut '[ @ , seq>list ] call , call ] ;
|
||||||
|
|
||||||
: normal-lambda ( body vars -- quot )
|
: normal-lambda ( body vars -- quot )
|
||||||
|
@ -92,11 +89,8 @@ PRIVATE>
|
||||||
[ 1quotation ]
|
[ 1quotation ]
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
: compile-form ( lisp-ast -- quot )
|
|
||||||
convert-form lambda-rewrite call ; inline
|
|
||||||
|
|
||||||
: macro-expand ( cons -- quot )
|
: macro-expand ( cons -- quot )
|
||||||
uncons [ list>seq [ ] like ] [ lookup-macro lambda-rewrite call ] bi* call compile-form call ;
|
uncons [ list>seq >quotation ] [ lookup-macro ] bi* call convert-form call ;
|
||||||
|
|
||||||
: lisp-string>factor ( str -- quot )
|
: lisp-string>factor ( str -- quot )
|
||||||
lisp-expr compile-form ;
|
lisp-expr compile-form ;
|
||||||
|
@ -108,6 +102,9 @@ PRIVATE>
|
||||||
|
|
||||||
SYMBOL: lisp-env
|
SYMBOL: lisp-env
|
||||||
SYMBOL: macro-env
|
SYMBOL: macro-env
|
||||||
|
|
||||||
|
ERROR: no-such-var variable-name ;
|
||||||
|
M: no-such-var summary drop "No such variable" ;
|
||||||
|
|
||||||
: init-env ( -- )
|
: init-env ( -- )
|
||||||
H{ } clone lisp-env set
|
H{ } clone lisp-env set
|
||||||
|
@ -128,11 +125,8 @@ SYMBOL: macro-env
|
||||||
: lisp-var? ( lisp-symbol -- ? )
|
: lisp-var? ( lisp-symbol -- ? )
|
||||||
dup lisp-symbol? [ name>> lisp-env get key? ] [ drop f ] if ;
|
dup lisp-symbol? [ name>> lisp-env get key? ] [ drop f ] if ;
|
||||||
|
|
||||||
: funcall-arg-list ( args -- newargs )
|
|
||||||
[ ] [ dup \ funcall = [ drop 2 cut* [ funcall ] compose call ] when suffix ] reduce ;
|
|
||||||
|
|
||||||
: funcall ( quot sym -- * )
|
: funcall ( quot sym -- * )
|
||||||
[ funcall-arg-list ] dip
|
[ 1array [ call ] with-datastack >quotation ] dip
|
||||||
dup lisp-symbol? [ lookup-var ] when curry call ; inline
|
dup lisp-symbol? [ lookup-var ] when curry call ; inline
|
||||||
|
|
||||||
: define-primitive ( name vocab word -- )
|
: define-primitive ( name vocab word -- )
|
||||||
|
|
Loading…
Reference in New Issue