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

Merge branch 'master' of git://factorcode.org/git/jamesnvc

db4
Slava Pestov 2008-08-27 05:47:48 -05:00
parent 15a005359d 25593873e9
commit 408199e423
3 changed files with 110 additions and 95 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -5,14 +5,16 @@ quotations ;
IN: lisp.test IN: lisp.test
[ : define-lisp-builtins ( -- )
init-env init-env
[ f ] "#f" lisp-define f "#f" lisp-define
[ t ] "#t" lisp-define t "#t" lisp-define
"+" "math" "+" define-primitive "+" "math" "+" define-primitive
"-" "math" "-" define-primitive "-" "math" "-" define-primitive
"<" "math" "<" define-primitive
">" "math" ">" define-primitive
"cons" "lists" "cons" define-primitive "cons" "lists" "cons" define-primitive
"car" "lists" "car" define-primitive "car" "lists" "car" define-primitive
@ -21,36 +23,40 @@ IN: lisp.test
"nil" "lists" "nil" define-primitive "nil" "lists" "nil" define-primitive
"nil?" "lists" "nil?" define-primitive "nil?" "lists" "nil?" define-primitive
[ seq>list ] "##list" lisp-define
"define" "lisp" "defun" define-primitive "define" "lisp" "defun" define-primitive
"(lambda (&rest xs) xs)" lisp-string>factor "list" lisp-define "(lambda (&rest xs) xs)" lisp-string>factor "list" lisp-define
;
[
define-lisp-builtins
{ 5 } [ { 5 } [
! [ 2 3 ] "+" <lisp-symbol> funcall "(+ 2 3)" lisp-eval
"(+ 2 3)" lisp-eval
] unit-test ] unit-test
{ 8.3 } [ { 8.3 } [
! [ 10.4 2.1 ] "-" <lisp-symbol> funcall "(- 10.4 2.1)" lisp-eval
"(- 10.4 2.1)" lisp-eval
] unit-test ] unit-test
{ 3 } [ { 3 } [
"((lambda (x y) (+ x y)) 1 2)" lisp-eval "((lambda (x y) (+ x y)) 1 2)" lisp-eval
] unit-test ] unit-test
! { 42 } [ { 42 } [
! "((lambda (x y z) (+ x (- y z))) 40 3 1)" lisp-eval "((lambda (x y z) (+ x (- y z))) 40 3 1)" lisp-eval
! ] unit-test ] unit-test
{ "b" } [ { "b" } [
"(cond (#f \"a\") (#t \"b\"))" lisp-eval "(cond (#f \"a\") (#t \"b\"))" lisp-eval
] unit-test ] unit-test
{ 5 } [ { "b" } [
"(begin (+ 1 4))" lisp-eval "(cond ((< 1 2) \"b\") (#t \"a\"))" lisp-eval
] unit-test
{ +nil+ } [
"(list)" lisp-eval
] unit-test ] unit-test
{ { 1 2 3 4 5 } } [ { { 1 2 3 4 5 } } [
@ -61,20 +67,28 @@ IN: lisp.test
"(list 1 2 (list 3 (list 4) 5))" lisp-eval cons>seq "(list 1 2 (list 3 (list 4) 5))" lisp-eval cons>seq
] unit-test ] unit-test
{ 5 } [
"(begin (+ 1 4))" lisp-eval
] unit-test
{ 5 } [
"(begin (+ 5 6) (+ 1 4))" lisp-eval
] unit-test
{ T{ lisp-symbol f "if" } } [ { T{ lisp-symbol f "if" } } [
"(defmacro if (pred tr fl) (list (quote cond) (list (list pred tr) (list t fl))))" lisp-eval "(defmacro if (pred tr fl) (list (quote cond) (list pred tr) (list (quote #t) fl)))" lisp-eval
] unit-test ] unit-test
{ t } [ { t } [
T{ lisp-symbol f "if" } lisp-macro? T{ lisp-symbol f "if" } lisp-macro?
] unit-test ] unit-test
! { 1 } [ { 1 } [
! "(if #t 1 2)" lisp-eval "(if #t 1 2)" lisp-eval
! ] unit-test ] unit-test
! { 3 } [ ! { 3 } [
! "((lambda (x) (if x (begin (+ 1 2)) (- 3 5))) #t)" lisp-eval ! "((lambda (x) (if x (+ 1 2) (- 3 5))) #t)" lisp-eval
! ] unit-test ! ] unit-test
] with-interactive-vocabs ] with-interactive-vocabs

143
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 ; quotations fry lists summary combinators.short-circuit continuations ;
IN: lisp IN: lisp
DEFER: convert-form DEFER: convert-form
@ -12,78 +12,85 @@ DEFER: lookup-var
DEFER: lookup-macro DEFER: lookup-macro
DEFER: lisp-macro? DEFER: lisp-macro?
DEFER: lisp-var? DEFER: lisp-var?
DEFER: macro-expand
DEFER: define-lisp-macro 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 ! Functions to convert s-exps to quotations
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: convert-body ( cons -- quot ) : convert-body ( cons -- quot )
[ ] [ convert-form compose ] foldl ; inline [ ] [ convert-form compose ] foldl ; inline
: convert-begin ( cons -- quot ) : convert-cond ( cons -- quot )
cdr [ convert-form ] [ ] lmap-as '[ , [ call ] each ] ; cdr [ 2car [ convert-form ] bi@ 2array ]
{ } lmap-as '[ , cond ] ;
: convert-cond ( cons -- quot )
cdr [ 2car [ convert-form ] bi@ [ '[ @ call ] ] dip 2array ]
{ } lmap-as '[ , cond ] ;
: convert-general-form ( cons -- quot ) : convert-general-form ( cons -- quot )
uncons [ convert-body ] [ convert-form ] bi* '[ , @ funcall ] ; uncons [ convert-body ] [ convert-form ] bi* '[ , @ funcall ] ;
! words for convert-lambda ! words for convert-lambda
<PRIVATE <PRIVATE
: localize-body ( assoc body -- assoc newbody ) : localize-body ( assoc body -- newbody )
{ {
{ [ dup list? ] [ [ lisp-symbol? ] pick '[ [ name>> , at ] [ ] bi or ] traverse ] } { [ dup list? ] [ [ lisp-symbol? ] rot '[ [ name>> , at ] [ ] bi or ] traverse ] }
{ [ dup lisp-symbol? ] [ name>> over at ] } { [ dup lisp-symbol? ] [ name>> swap at ] }
[ ] [ nip ]
} cond ; } cond ;
: localize-lambda ( body vars -- newvars newbody ) : localize-lambda ( body vars -- newvars newbody )
make-locals dup push-locals swap swap [ make-locals dup push-locals ] dip
[ swap localize-body convert-form swap pop-locals ] dip swap ; dupd [ localize-body convert-form ] with lmap>array
>quotation swap pop-locals ;
: split-lambda ( cons -- body-cons vars-seq ) : split-lambda ( cons -- body-cons vars-seq )
cdr uncons [ car ] [ [ name>> ] lmap>array ] bi* ; inline cdr uncons [ name>> ] lmap>array ; inline
: rest-lambda ( body vars -- quot ) : rest-lambda ( body vars -- quot )
"&rest" swap [ index ] [ remove ] 2bi "&rest" swap [ remove ] [ index ] 2bi
swapd localize-lambda <lambda> [ localize-lambda <lambda> lambda-rewrite call ] dip
'[ , cut '[ @ , seq>list ] call , call ] ; swap '[ , cut '[ @ , seq>list ] call , call call ] ;
: normal-lambda ( body vars -- quot ) : normal-lambda ( body vars -- quot )
localize-lambda <lambda> lambda-rewrite [ compose call ] compose 1quotation ; localize-lambda <lambda> lambda-rewrite '[ @ compose call call ] 1quotation ;
PRIVATE> PRIVATE>
: convert-lambda ( cons -- quot ) : convert-lambda ( cons -- quot )
split-lambda "&rest" over member? [ rest-lambda ] [ normal-lambda ] if ; split-lambda "&rest" over member? [ rest-lambda ] [ normal-lambda ] if ;
: convert-quoted ( cons -- quot ) : convert-quoted ( cons -- quot )
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 [ car ] keep [ convert-lambda ] [ car name>> ] bi define-lisp-macro 1quotation ;
: macro-expand ( cons -- quot )
uncons [ list>seq >quotation ] [ lookup-macro ] bi* call call ;
: (expand-macros) ( cons -- cons )
[ dup list? [ (expand-macros) dup car lisp-macro? [ macro-expand ] when ] when ] lmap ;
: expand-macros ( cons -- cons )
dup list? [ (expand-macros) dup car lisp-macro? [ macro-expand ] when ] when ;
: convert-begin ( cons -- quot )
cdr [ convert-form ] [ ] lmap-as [ 1 tail* ] [ but-last ] bi
[ '[ { } , with-datastack drop ] ] map prepend '[ , [ call ] each ] ;
: form-dispatch ( cons lisp-symbol -- quot ) : form-dispatch ( cons lisp-symbol -- quot )
name>> name>>
{ { "lambda" [ convert-lambda ] } { { "lambda" [ convert-lambda ] }
{ "defmacro" [ convert-defmacro ] } { "defmacro" [ convert-defmacro ] }
{ "quote" [ convert-quoted ] } { "quote" [ convert-quoted ] }
{ "begin" [ convert-begin ] }
{ "cond" [ convert-cond ] } { "cond" [ convert-cond ] }
{ "begin" [ convert-begin ] }
[ drop convert-general-form ] [ drop convert-general-form ]
} case ; } case ;
: convert-list-form ( cons -- quot ) : convert-list-form ( cons -- quot )
dup car dup car
{ { [ dup lisp-macro? ] [ drop macro-expand ] } {
{ [ dup lisp-symbol? ] [ form-dispatch ] } { [ dup lisp-symbol? ] [ form-dispatch ] }
[ drop convert-general-form ] [ drop convert-general-form ]
} cond ; } cond ;
: convert-form ( lisp-form -- quot ) : convert-form ( lisp-form -- quot )
{ {
{ [ dup cons? ] [ convert-list-form ] } { [ dup cons? ] [ convert-list-form ] }
@ -91,58 +98,52 @@ PRIVATE>
{ [ dup lisp-symbol? ] [ '[ , lookup-var ] ] } { [ dup lisp-symbol? ] [ '[ , lookup-var ] ] }
[ 1quotation ] [ 1quotation ]
} cond ; } cond ;
: compile-form ( lisp-ast -- quot )
convert-form lambda-rewrite call ; inline
: macro-expand ( cons -- quot )
uncons [ list>seq [ ] like ] [ lookup-macro lambda-rewrite call ] bi* call compile-form call ;
: lisp-string>factor ( str -- quot ) : lisp-string>factor ( str -- quot )
lisp-expr compile-form ; lisp-expr expand-macros convert-form ;
: lisp-eval ( str -- * ) : lisp-eval ( str -- * )
lisp-string>factor call ; lisp-string>factor call ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: lisp-env SYMBOL: lisp-env
SYMBOL: macro-env SYMBOL: macro-env
ERROR: no-such-var variable-name ;
M: no-such-var summary drop "No such variable" ;
: init-env ( -- ) : init-env ( -- )
H{ } clone lisp-env set H{ } clone lisp-env set
H{ } clone macro-env set ; H{ } clone macro-env set ;
: lisp-define ( quot name -- ) : lisp-define ( quot name -- )
lisp-env get set-at ; lisp-env get set-at ;
: defun ( name quot -- name ) : defun ( name quot -- name )
over name>> lisp-define ; over name>> lisp-define ;
: lisp-get ( name -- word ) : lisp-get ( name -- word )
dup lisp-env get at [ ] [ no-such-var ] ?if ; lisp-env get at ;
: lookup-var ( lisp-symbol -- quot ) : lookup-var ( lisp-symbol -- quot )
name>> lisp-get ; [ name>> ] [ lisp-var? ] bi [ lisp-get ] [ no-such-var ] if ;
: lisp-var? ( lisp-symbol -- ? ) : lisp-var? ( lisp-symbol -- ? )
dup lisp-symbol? [ name>> lisp-env get key? ] [ drop f ] if ; dup lisp-symbol? [ name>> lisp-env get key? ] [ drop f ] if ;
: funcall-arg-list ( args -- newargs )
[ ] [ dup \ funcall = [ drop 2 cut* [ funcall ] compose call ] when suffix ] reduce ;
: funcall ( quot sym -- * ) : funcall ( quot sym -- * )
[ funcall-arg-list ] dip [ 1array [ call ] with-datastack >quotation ] dip
dup lisp-symbol? [ lookup-var ] when 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 ; ! '[ , compose call ] swap lisp-define ; swap lookup 1quotation '[ , compose call ] swap lisp-define ;
: lookup-macro ( lisp-symbol -- lambda ) : lookup-macro ( lisp-symbol -- lambda )
name>> macro-env get at ; name>> macro-env get at ;
: define-lisp-macro ( quot name -- ) : define-lisp-macro ( quot name -- )
macro-env get set-at ; macro-env get set-at ;
: 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 ;

2
extra/lists/lists.factor
View File

@ -100,7 +100,7 @@ M: object nil? drop f ;
[ lmap>array ] dip like ; [ lmap>array ] dip like ;
: cons>seq ( cons -- array ) : cons>seq ( cons -- array )
[ dup cons? [ cons>seq ] when ] lmap>array ; [ dup cons? [ cons>seq ] when dup nil? [ drop { } ] when ] lmap>array ;
: list>seq ( list -- array ) : list>seq ( list -- array )
[ ] lmap>array ; [ ] lmap>array ;