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

Fixing bugs in extra/lisp, adding <LISP ... LISP>

db4
James Cash 2008-09-08 23:37:38 -04:00
parent 1faba13945
commit b24a7ee3c4
1 changed files with 19 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
extra/lisp/lisp.factor
View File

@ -3,7 +3,7 @@
USING: kernel peg sequences arrays strings combinators.lib USING: kernel peg sequences arrays strings combinators.lib
namespaces combinators math locals locals.private locals.backend accessors namespaces combinators math locals locals.private locals.backend accessors
vectors syntax lisp.parser assocs parser sequences.lib words 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 IN: lisp
DEFER: convert-form DEFER: convert-form
@ -46,7 +46,7 @@ DEFER: define-lisp-macro
: rest-lambda ( body vars -- quot ) : rest-lambda ( body vars -- quot )
"&rest" swap [ remove ] [ index ] 2bi "&rest" swap [ remove ] [ index ] 2bi
[ localize-lambda <lambda> lambda-rewrite call ] dip [ 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 ) : normal-lambda ( body vars -- quot )
localize-lambda <lambda> lambda-rewrite '[ @ compose call call ] 1quotation ; localize-lambda <lambda> lambda-rewrite '[ @ compose call call ] 1quotation ;
@ -122,8 +122,8 @@ M: no-such-var summary drop "No such variable" ;
: lisp-define ( quot name -- ) : lisp-define ( quot name -- )
lisp-env get set-at ; lisp-env get set-at ;
: defun ( name quot -- name ) : define-lisp-var ( lisp-symbol body -- )
over name>> lisp-define ; swap name>> lisp-define ;
: lisp-get ( name -- word ) : lisp-get ( name -- word )
lisp-env get at ; lisp-env get at ;
@ -135,8 +135,7 @@ M: no-such-var summary drop "No such variable" ;
dup lisp-symbol? [ name>> lisp-env get key? ] [ drop f ] if ; dup lisp-symbol? [ name>> lisp-env get key? ] [ drop f ] if ;
: funcall ( quot sym -- * ) : funcall ( quot sym -- * )
[ 1array [ call ] with-datastack >quotation ] dip [ 1array [ call ] with-datastack >quotation ] dip curry call ; inline
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 ; swap lookup 1quotation '[ , compose call ] swap lisp-define ;
@ -150,7 +149,7 @@ 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 ( -- ) : define-lisp-builtins ( -- )
init-env init-env
f "#f" lisp-define f "#f" lisp-define
@ -168,8 +167,17 @@ M: no-such-var summary drop "No such variable" ;
"nil" "lists" "nil" define-primitive "nil" "lists" "nil" define-primitive
"nil?" "lists" "nil?" define-primitive "nil?" "lists" "nil?" define-primitive
"define" "lisp" "defun" 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
"(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 "(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