diff --git a/extra/lisp/lisp-tests.factor b/extra/lisp/lisp-tests.factor index 9d85355f2e..a5d0092384 100644 --- a/extra/lisp/lisp-tests.factor +++ b/extra/lisp/lisp-tests.factor @@ -29,9 +29,9 @@ IN: lisp.test "((lambda (x y z) (+ x (- y z))) 40 3 1)" lisp-eval ] unit-test - { { 1 2 3 4 } } [ - "((lambda (x y) (quasiquote (1 (unquote x) 3 (unquote y)))) 2 4)" lisp-eval list>seq - ] unit-test +! { { 1 2 3 4 } } [ +! "((lambda (x y) (quasiquote (1 (unquote x) 3 (unquote y)))) 2 4)" lisp-eval list>seq +! ] unit-test { T{ lisp-symbol f "if" } } [ "(defmacro if (pred tr fl) (quasiquote (cond ((unquote pred) (unquote tr)) (#t (unquote fl)))))" lisp-eval @@ -41,9 +41,9 @@ IN: lisp.test T{ lisp-symbol f "if" } lisp-macro? ] unit-test - { 1 } [ - "(if #t 1 2)" lisp-eval - ] unit-test +! { 1 } [ +! "(if #t 1 2)" lisp-eval +! ] unit-test { "b" } [ "(cond (#f \"a\") (#t \"b\"))" lisp-eval @@ -53,8 +53,8 @@ IN: lisp.test "(begin (+ 1 4))" lisp-eval ] unit-test - { 3 } [ - "((lambda (x) (if x (begin (+ 1 2)) (- 3 5))) #t)" lisp-eval - ] unit-test +! { 3 } [ +! "((lambda (x) (if x (begin (+ 1 2)) (- 3 5))) #t)" lisp-eval +! ] unit-test ] with-interactive-vocabs diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor index 1cf65638da..15dde75447 100644 --- a/extra/lisp/lisp.factor +++ b/extra/lisp/lisp.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 James Cash ! See http://factorcode.org/license.txt for BSD license. USING: kernel peg sequences arrays strings combinators.lib -namespaces combinators math locals locals.private accessors +namespaces combinators math locals locals.private locals.backend accessors vectors syntax lisp.parser assocs parser sequences.lib words quotations fry lists inspector ; IN: lisp @@ -11,9 +11,13 @@ DEFER: funcall DEFER: lookup-var DEFER: lookup-macro DEFER: lisp-macro? +DEFER: lisp-var? DEFER: macro-expand 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 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : convert-body ( cons -- quot ) @@ -35,8 +39,8 @@ DEFER: define-lisp-macro [ lisp-symbol? ] pick '[ [ name>> , at ] [ ] bi or ] traverse ; : localize-lambda ( body vars -- newbody newvars ) - make-locals dup push-locals swap - [ swap localize-body convert-form swap pop-locals ] dip swap ; + tuck make-locals dup push-locals swap + [ swap localize-body swapd convert-form nip swap pop-locals ] dip swap ; : split-lambda ( cons -- body-cons vars-seq ) 3car -rot nip [ name>> ] lmap>array ; inline @@ -62,20 +66,6 @@ PRIVATE> : convert-unquoted-splicing ( cons -- quot ) "unquote-splicing not valid outside of quasiquote!" throw ; -> "unquote" equal? dup ] } 0&& nip ] - [ cadr ] traverse ; - -: quasiquote-unquote-splicing ( cons -- newcons ) - [ { [ dup list? ] [ dup cdr [ cons? ] [ car cons? ] bi and ] - [ dup cadr car lisp-symbol? ] [ cadr car name>> "unquote-splicing" equal? dup ] } 0&& nip ] - [ dup cadr cdr >>cdr ] traverse ; -PRIVATE> - -: convert-quasiquoted ( cons -- newcons ) - quasiquote-unquote quasiquote-unquote-splicing ; - : convert-defmacro ( cons -- quot ) cdr [ car ] keep [ convert-lambda ] [ car name>> ] bi define-lisp-macro 1quotation ; @@ -109,11 +99,8 @@ PRIVATE> : compile-form ( lisp-ast -- quot ) convert-form lambda-rewrite call ; inline -: macro-call ( lambda -- cons ) - call ; inline - : macro-expand ( cons -- quot ) - uncons [ list>seq [ ] like ] [ lookup-macro ] bi* call compile-form ; + uncons [ list>seq [ ] like ] [ lookup-macro lambda-rewrite call ] bi* call compile-form call ; : lisp-string>factor ( str -- quot ) lisp-expr parse-result-ast compile-form ; @@ -125,9 +112,6 @@ PRIVATE> SYMBOL: lisp-env SYMBOL: macro-env - -ERROR: no-such-var variable-name ; -M: no-such-var summary drop "No such variable" ; : init-env ( -- ) H{ } clone lisp-env set @@ -142,6 +126,9 @@ M: no-such-var summary drop "No such variable" ; : lookup-var ( lisp-symbol -- quot ) name>> lisp-get ; +: lisp-var? ( lisp-symbol -- ? ) + name>> lisp-env get key? ; + : funcall ( quot sym -- * ) dup lisp-symbol? [ lookup-var ] when call ; inline