From 5fc2942893e7f08e47dbce90af861865d96993cc Mon Sep 17 00:00:00 2001 From: James Cash Date: Wed, 2 Jul 2008 23:54:06 -0400 Subject: [PATCH] Minor changes --- extra/lisp/lisp.factor | 72 +++++++++++++++++++++--------------------- 1 file changed, 36 insertions(+), 36 deletions(-) diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor index ebec272cf1..19226cb595 100644 --- a/extra/lisp/lisp.factor +++ b/extra/lisp/lisp.factor @@ -13,22 +13,22 @@ DEFER: lookup-macro DEFER: lisp-macro? DEFER: lisp-var? DEFER: define-lisp-macro - + ! Functions to convert s-exps to quotations ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : convert-body ( cons -- quot ) [ ] [ convert-form compose ] foldl ; inline - -: convert-cond ( cons -- quot ) + +: convert-cond ( cons -- quot ) cdr [ 2car [ convert-form ] bi@ 2array ] { } lmap-as '[ , cond ] ; - + : convert-general-form ( cons -- quot ) uncons [ convert-body ] [ convert-form ] bi* '[ , @ funcall ] ; -! words for convert-lambda -> , at ] [ ] bi or ] traverse ] } { [ dup lisp-symbol? ] [ name>> over at ] } @@ -38,31 +38,31 @@ DEFER: define-lisp-macro : localize-lambda ( body vars -- newvars newbody ) make-locals dup push-locals swap [ swap localize-body convert-form swap pop-locals ] dip swap ; - + : split-lambda ( cons -- body-cons vars-seq ) cdr uncons [ car ] [ [ name>> ] lmap>array ] bi* ; inline - + : rest-lambda ( body vars -- quot ) "&rest" swap [ index ] [ remove ] 2bi swapd localize-lambda lambda-rewrite call '[ , cut '[ @ , seq>list ] call , call ] ; - + : normal-lambda ( body vars -- quot ) localize-lambda lambda-rewrite [ compose call ] compose 1quotation ; PRIVATE> - -: convert-lambda ( cons -- quot ) + +: convert-lambda ( cons -- quot ) split-lambda "&rest" over member? [ rest-lambda ] [ normal-lambda ] if ; - -: convert-quoted ( cons -- quot ) + +: convert-quoted ( cons -- quot ) cadr 1quotation ; - + : convert-defmacro ( cons -- quot ) cdr [ car ] keep [ convert-lambda ] [ car name>> ] bi define-lisp-macro 1quotation ; - + : macro-expand ( cons -- quot ) uncons [ list>seq >quotation ] [ lookup-macro ] bi* call convert-form ; - + : form-dispatch ( cons lisp-symbol -- quot ) name>> { { "lambda" [ convert-lambda ] } @@ -71,14 +71,14 @@ PRIVATE> { "cond" [ convert-cond ] } [ drop convert-general-form ] } case ; - -: convert-list-form ( cons -- quot ) + +: convert-list-form ( cons -- quot ) dup car { { [ dup lisp-macro? ] [ drop macro-expand ] } - { [ dup lisp-symbol? ] [ form-dispatch ] } + { [ dup lisp-symbol? ] [ form-dispatch ] } [ drop convert-general-form ] } cond ; - + : convert-form ( lisp-form -- quot ) { { [ dup cons? ] [ convert-list-form ] } @@ -86,18 +86,18 @@ PRIVATE> { [ dup lisp-symbol? ] [ '[ , lookup-var ] ] } [ 1quotation ] } cond ; - + : lisp-string>factor ( str -- quot ) lisp-expr compile-form ; : lisp-eval ( str -- * ) - lisp-string>factor call ; - + lisp-string>factor call ; + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! SYMBOL: lisp-env SYMBOL: macro-env - + ERROR: no-such-var variable-name ; M: no-such-var summary drop "No such variable" ; @@ -107,31 +107,31 @@ M: no-such-var summary drop "No such variable" ; : lisp-define ( quot name -- ) lisp-env get set-at ; - -: defun ( name quot -- name ) + +: defun ( name quot -- name ) over name>> lisp-define ; - + : lisp-get ( name -- word ) lisp-env get at ; - + : lookup-var ( lisp-symbol -- quot ) [ name>> ] [ lisp-var? ] bi [ lisp-get ] [ no-such-var ] if ; - + : lisp-var? ( lisp-symbol -- ? ) dup lisp-symbol? [ name>> lisp-env get key? ] [ drop f ] if ; - + : funcall ( quot sym -- * ) [ 1array [ call ] with-datastack >quotation ] dip dup lisp-symbol? [ lookup-var ] when curry call ; inline - -: define-primitive ( name vocab word -- ) + +: define-primitive ( name vocab word -- ) swap lookup 1quotation '[ , compose call ] swap lisp-define ; - + : lookup-macro ( lisp-symbol -- lambda ) name>> macro-env get at ; - + : define-lisp-macro ( quot name -- ) macro-env get set-at ; - + : lisp-macro? ( car -- ? ) dup lisp-symbol? [ name>> macro-env get key? ] [ drop f ] if ;