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

Merge git://factorcode.org/git/jamesnvc into new_lisp

db4
Slava Pestov 2008-09-09 03:29:26 -05:00
parent a3d1379b8c c25abc5d00
commit 1e643e7cc1
2 changed files with 72 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -5,29 +5,6 @@ quotations ;
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
@ -75,10 +52,6 @@ IN: lisp.test
"(begin (+ 5 6) (+ 1 4))" lisp-eval
] 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{ lisp-symbol f "if" } lisp-macro?
] unit-test
@ -87,8 +60,28 @@ IN: lisp.test
"(if #t 1 2)" lisp-eval
] unit-test
! { 3 } [
! "((lambda (x) (if x (+ 1 2) (- 3 5))) #t)" lisp-eval
! ] unit-test
{ 3 } [
"((lambda (x) (if x (+ 1 2) (- 3 5))) #t)" lisp-eval
] unit-test
{ { 5 4 3 } } [
"((lambda (x &rest xs) (cons x xs)) 5 4 3)" lisp-eval cons>seq
] unit-test
{ { 5 } } [
"((lambda (x &rest xs) (cons x xs)) 5)" lisp-eval cons>seq
] unit-test
{ { 1 2 3 4 } } [
"((lambda (&rest xs) xs) 1 2 3 4)" lisp-eval cons>seq
] unit-test
{ 10 } [
<LISP (begin (+ 1 2) (+ 9 1)) LISP>
] unit-test
{ 4 } [
<LISP ((lambda (x y) (if x (+ 1 y) (+ 2 y))) #t 3) LISP>
] unit-test
] with-interactive-vocabs

64
extra/lisp/lisp.factor
View File

@ -3,7 +3,7 @@
USING: kernel peg sequences arrays strings combinators.lib
namespaces combinators math locals locals.private locals.backend accessors
vectors syntax lisp.parser assocs parser sequences.lib words
quotations fry lists summary combinators.short-circuit continuations ;
quotations fry lists summary combinators.short-circuit continuations multiline ;
IN: lisp
DEFER: convert-form
@ -46,7 +46,7 @@ DEFER: define-lisp-macro
: rest-lambda ( body vars -- quot )
"&rest" swap [ remove ] [ index ] 2bi
[ localize-lambda <lambda> lambda-rewrite call ] dip
swap '[ , cut '[ @ , seq>list ] call , call call ] ;
swap '[ , cut '[ @ , seq>list ] call , call call ] 1quotation ;
: normal-lambda ( body vars -- quot )
localize-lambda <lambda> lambda-rewrite '[ @ compose call call ] 1quotation ;
@ -59,18 +59,20 @@ PRIVATE>
cadr 1quotation ;
: 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 )
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 ;
: expand-macros ( cons -- cons )
PRIVATE>
: expand-macros ( cons -- cons )
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
[ '[ { } , with-datastack drop ] ] map prepend '[ , [ call ] each ] ;
@ -86,7 +88,7 @@ PRIVATE>
: convert-list-form ( cons -- quot )
dup car
{
{
{ [ dup lisp-symbol? ] [ form-dispatch ] }
[ drop convert-general-form ]
} cond ;
@ -119,9 +121,9 @@ M: no-such-var summary drop "No such variable" ;
: lisp-define ( quot name -- )
lisp-env get set-at ;
: defun ( name quot -- name )
over name>> lisp-define ;
: define-lisp-var ( lisp-symbol body -- )
swap name>> lisp-define ;
: lisp-get ( name -- word )
lisp-env get at ;
@ -133,8 +135,7 @@ M: no-such-var summary drop "No such variable" ;
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
[ 1array [ call ] with-datastack >quotation ] dip curry call ; inline
: define-primitive ( name vocab word -- )
swap lookup 1quotation '[ , compose call ] swap lisp-define ;
@ -147,3 +148,36 @@ M: no-such-var summary drop "No such variable" ;
: lisp-macro? ( car -- ? )
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
"set" "lisp" "define-lisp-var" define-primitive
"(lambda (&rest xs) xs)" lisp-string>factor first "list" lisp-define
"(defmacro setq (var val) (list (quote set) (list (quote quote) var) val))" lisp-eval
<" (defmacro defun (name vars &rest body)
(list (quote setq) name (list (quote lambda) vars body))) "> lisp-eval
"(defmacro if (pred tr fl) (list (quote cond) (list pred tr) (list (quote #t) fl)))" lisp-eval
;
: <LISP
"LISP>" parse-multiline-string define-lisp-builtins
lisp-string>factor parsed \ call parsed ; parsing