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

Macros almost working

db4
James Cash 2008-06-05 18:15:05 -04:00
parent 35e2bb8711
commit 60db47acf4
1 changed files with 32 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

56
extra/lisp/lisp.factor
View File

@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel peg sequences arrays strings combinators.lib USING: kernel peg sequences arrays strings combinators.lib
namespaces combinators math locals locals.private accessors namespaces combinators math locals locals.private accessors
vectors syntax lisp.parser assocs parser sequences.lib words quotations vectors syntax lisp.parser assocs parser sequences.lib words
fry lists inspector ; quotations fry lists inspector ;
IN: lisp IN: lisp
DEFER: convert-form DEFER: convert-form
@ -11,15 +11,13 @@ DEFER: funcall
DEFER: lookup-var DEFER: lookup-var
DEFER: lisp-macro? DEFER: lisp-macro?
DEFER: lookup-macro DEFER: lookup-macro
DEFER: macro-call DEFER: macro-expand
DEFER: define-lisp-macro
! Functions to convert s-exps to quotations ! Functions to convert s-exps to quotations
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: convert-body ( cons -- quot ) : convert-body ( cons -- quot )
[ ] [ convert-form compose ] foldl ; inline [ ] [ convert-form compose ] foldl ; inline
: convert-if ( cons -- quot )
cdr 3car [ convert-form ] tri@ '[ @ , , if ] ;
: convert-begin ( cons -- quot ) : convert-begin ( cons -- quot )
cdr [ convert-form ] [ ] lmap-as '[ , [ funcall ] each ] ; cdr [ convert-form ] [ ] lmap-as '[ , [ funcall ] each ] ;
@ -34,13 +32,11 @@ DEFER: macro-call
! words for convert-lambda ! words for convert-lambda
<PRIVATE <PRIVATE
: localize-body ( assoc body -- assoc newbody ) : localize-body ( assoc body -- assoc newbody )
dupd [ dup lisp-symbol? [ tuck name>> swap at swap or ] [ lisp-symbol? ] pick '[ [ name>> , at ] [ ] bi or ] traverse ;
[ dup cons? [ localize-body ] when nip ] if
] with lmap>array ;
: localize-lambda ( body vars -- newbody newvars ) : localize-lambda ( body vars -- newbody newvars )
make-locals dup push-locals swap make-locals dup push-locals swap
[ swap localize-body seq>cons convert-form swap pop-locals ] dip swap ; [ swap localize-body convert-form swap pop-locals ] dip swap ;
: split-lambda ( cons -- body-cons vars-seq ) : split-lambda ( cons -- body-cons vars-seq )
3car -rot nip [ name>> ] lmap>array ; inline 3car -rot nip [ name>> ] lmap>array ; inline
@ -67,24 +63,24 @@ PRIVATE>
[ { [ dup list? ] [ car dup lisp-symbol? ] [ name>> "unquote" equal? dup ] } && nip ] [ { [ dup list? ] [ car dup lisp-symbol? ] [ name>> "unquote" equal? dup ] } && nip ]
[ cadr ] traverse ; [ cadr ] traverse ;
: form-dispatch ( lisp-symbol -- quot ) : convert-defmacro ( cons -- quot )
cdr [ car ] keep [ convert-lambda ] [ car name>> ] bi define-lisp-macro 1quotation ;
: form-dispatch ( cons lisp-symbol -- quot )
name>> name>>
{ { "lambda" [ convert-lambda ] } { { "lambda" [ convert-lambda ] }
{ "defmacro" [ convert-defmacro ] }
{ "quote" [ convert-quoted ] } { "quote" [ convert-quoted ] }
{ "unquote" [ convert-unquoted ] } { "unquote" [ convert-unquoted ] }
{ "quasiquote" [ convert-quasiquoted ] } { "quasiquote" [ convert-quasiquoted ] }
{ "if" [ convert-if ] }
{ "begin" [ convert-begin ] } { "begin" [ convert-begin ] }
{ "cond" [ convert-cond ] } { "cond" [ convert-cond ] }
[ drop convert-general-form ] [ drop convert-general-form ]
} case ; } case ;
: macro-expand ( cons -- quot )
uncons lookup-macro macro-call convert-form ;
: convert-list-form ( cons -- quot ) : convert-list-form ( cons -- quot )
dup car dup car
{ { [ dup lisp-macro? ] [ macro-expand ] } { { [ dup lisp-macro? ] [ drop macro-expand ] }
{ [ dup lisp-symbol? ] [ form-dispatch ] } { [ dup lisp-symbol? ] [ form-dispatch ] }
[ drop convert-general-form ] [ drop convert-general-form ]
} cond ; } cond ;
@ -96,8 +92,17 @@ PRIVATE>
[ 1quotation ] [ 1quotation ]
} cond ; } cond ;
: compile-form ( lisp-ast -- quot )
convert-form lambda-rewrite call ; inline
: macro-call ( lambda -- cons )
call ;
: macro-expand ( cons -- quot )
uncons lookup-macro macro-call compile-form ;
: lisp-string>factor ( str -- quot ) : lisp-string>factor ( str -- quot )
lisp-expr parse-result-ast convert-form lambda-rewrite call ; lisp-expr parse-result-ast compile-form ;
: lisp-eval ( str -- * ) : lisp-eval ( str -- * )
lisp-string>factor call ; lisp-string>factor call ;
@ -105,7 +110,7 @@ PRIVATE>
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: lisp-env SYMBOL: lisp-env
ERROR: no-such-var var ; ERROR: no-such-var variable-name ;
SYMBOL: macro-env SYMBOL: macro-env
@ -115,8 +120,8 @@ M: no-such-var summary drop "No such variable" ;
H{ } clone lisp-env set H{ } clone lisp-env set
H{ } clone macro-env set ; H{ } clone macro-env set ;
: lisp-define ( name quot -- ) : lisp-define ( quot name -- )
swap lisp-env get set-at ; lisp-env get set-at ;
: lisp-get ( name -- word ) : lisp-get ( name -- word )
dup lisp-env get at [ ] [ no-such-var ] ?if ; dup lisp-env get at [ ] [ no-such-var ] ?if ;
@ -128,10 +133,13 @@ M: no-such-var summary drop "No such variable" ;
dup lisp-symbol? [ lookup-var ] when call ; inline dup lisp-symbol? [ lookup-var ] when call ; inline
: define-primitive ( name vocab word -- ) : define-primitive ( name vocab word -- )
swap lookup 1quotation '[ , compose call ] lisp-define ; swap lookup 1quotation '[ , compose call ] swap lisp-define ;
: lookup-macro ( lisp-symbol -- macro ) : lookup-macro ( lisp-symbol -- lambda )
name>> macro-env get at ; name>> macro-env get at ;
: define-lisp-macro ( quot name -- )
macro-env get set-at ;
: lisp-macro? ( car -- ? ) : lisp-macro? ( car -- ? )
dup lisp-symbol? [ name>> macro-env get key? ] [ drop f ] if ; dup lisp-symbol? [ name>> macro-env get key? ] [ drop f ] if ;