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

Working on adding a <LISP word

db4
James Cash 2008-09-03 10:21:27 -04:00
parent 0037734cfa
commit be4e613861
2 changed files with 34 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
extra/lisp/lisp-tests.factor
View File

@ -5,29 +5,6 @@ quotations ;
IN: lisp.test IN: lisp.test
: define-lisp-builtins ( -- )
init-env
f "#f" lisp-define
t "#t" lisp-define
"+" "math" "+" define-primitive
"-" "math" "-" define-primitive
"<" "math" "<" define-primitive
">" "math" ">" define-primitive
"cons" "lists" "cons" define-primitive
"car" "lists" "car" define-primitive
"cdr" "lists" "cdr" define-primitive
"append" "lists" "lappend" define-primitive
"nil" "lists" "nil" define-primitive
"nil?" "lists" "nil?" define-primitive
"define" "lisp" "defun" define-primitive
"(lambda (&rest xs) xs)" lisp-string>factor "list" lisp-define
;
[ [
define-lisp-builtins define-lisp-builtins
@ -75,10 +52,6 @@ IN: lisp.test
"(begin (+ 5 6) (+ 1 4))" lisp-eval "(begin (+ 5 6) (+ 1 4))" lisp-eval
] unit-test ] unit-test
{ T{ lisp-symbol f "if" } } [
"(defmacro if (pred tr fl) (list (quote cond) (list pred tr) (list (quote #t) fl)))" lisp-eval
] unit-test
{ t } [ { t } [
T{ lisp-symbol f "if" } lisp-macro? T{ lisp-symbol f "if" } lisp-macro?
] unit-test ] unit-test

42
extra/lisp/lisp.factor
View File

@ -59,18 +59,20 @@ PRIVATE>
cadr 1quotation ; cadr 1quotation ;
: convert-defmacro ( cons -- quot ) : convert-defmacro ( cons -- quot )
cdr [ car ] keep [ convert-lambda ] [ car name>> ] bi define-lisp-macro 1quotation ; cdr [ convert-lambda ] [ car name>> ] bi define-lisp-macro [ ] ;
: macro-expand ( cons -- quot ) : macro-expand ( cons -- quot )
uncons [ list>seq >quotation ] [ lookup-macro ] bi* call call ; uncons [ list>seq >quotation ] [ lookup-macro ] bi* call call ;
: (expand-macros) ( cons -- cons ) <PRIVATE
: (expand-macros) ( cons -- cons )
[ dup list? [ (expand-macros) dup car lisp-macro? [ macro-expand ] when ] when ] lmap ; [ dup list? [ (expand-macros) dup car lisp-macro? [ macro-expand ] when ] when ] lmap ;
PRIVATE>
: expand-macros ( cons -- cons )
: expand-macros ( cons -- cons )
dup list? [ (expand-macros) dup car lisp-macro? [ macro-expand ] when ] when ; dup list? [ (expand-macros) dup car lisp-macro? [ macro-expand ] when ] when ;
: convert-begin ( cons -- quot ) : convert-begin ( cons -- quot )
cdr [ convert-form ] [ ] lmap-as [ 1 tail* ] [ but-last ] bi cdr [ convert-form ] [ ] lmap-as [ 1 tail* ] [ but-last ] bi
[ '[ { } , with-datastack drop ] ] map prepend '[ , [ call ] each ] ; [ '[ { } , with-datastack drop ] ] map prepend '[ , [ call ] each ] ;
@ -86,7 +88,7 @@ PRIVATE>
: convert-list-form ( cons -- quot ) : convert-list-form ( cons -- quot )
dup car dup car
{ {
{ [ dup lisp-symbol? ] [ form-dispatch ] } { [ dup lisp-symbol? ] [ form-dispatch ] }
[ drop convert-general-form ] [ drop convert-general-form ]
} cond ; } cond ;
@ -147,3 +149,27 @@ M: no-such-var summary drop "No such variable" ;
: 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 ;
: define-lisp-builtins ( -- )
init-env
f "#f" lisp-define
t "#t" lisp-define
"+" "math" "+" define-primitive
"-" "math" "-" define-primitive
"<" "math" "<" define-primitive
">" "math" ">" define-primitive
"cons" "lists" "cons" define-primitive
"car" "lists" "car" define-primitive
"cdr" "lists" "cdr" define-primitive
"append" "lists" "lappend" define-primitive
"nil" "lists" "nil" define-primitive
"nil?" "lists" "nil?" define-primitive
"define" "lisp" "defun" define-primitive
"(lambda (&rest xs) xs)" lisp-string>factor "list" lisp-define
"(defmacro if (pred tr fl) (list (quote cond) (list pred tr) (list (quote #t) fl)))" lisp-eval
;