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

db4
Slava Pestov 2008-06-05 18:07:19 -05:00
commit 3b26266dc4
5 changed files with 48 additions and 33 deletions

View File

@ -7,8 +7,8 @@ IN: lisp.test
[ [
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
@ -31,6 +31,14 @@ IN: lisp.test
"((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
{ T{ lisp-symbol f "if" } } [
"(defmacro if (pred tr fl) (quasiquote (cond ((unquote pred) (unquote tr)) (#t (unquote fl)))))" lisp-eval
] unit-test
{ t } [
T{ lisp-symbol f "if" } lisp-macro?
] unit-test
{ 1 } [ { 1 } [
"(if #t 1 2)" lisp-eval "(if #t 1 2)" lisp-eval
] unit-test ] unit-test

View File

@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel peg sequences arrays strings combinators.lib USING: kernel peg sequences arrays strings combinators.lib
namespaces combinators math locals locals.private accessors namespaces combinators math locals locals.private accessors
vectors syntax lisp.parser assocs parser sequences.lib words quotations vectors syntax lisp.parser assocs parser sequences.lib words
fry lists inspector ; quotations fry lists inspector ;
IN: lisp IN: lisp
DEFER: convert-form DEFER: convert-form
@ -11,15 +11,13 @@ DEFER: funcall
DEFER: lookup-var DEFER: lookup-var
DEFER: lisp-macro? DEFER: lisp-macro?
DEFER: lookup-macro DEFER: lookup-macro
DEFER: macro-call DEFER: macro-expand
DEFER: define-lisp-macro
! 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-if ( cons -- quot )
cdr 3car [ convert-form ] tri@ '[ @ , , if ] ;
: convert-begin ( cons -- quot ) : convert-begin ( cons -- quot )
cdr [ convert-form ] [ ] lmap-as '[ , [ funcall ] each ] ; cdr [ convert-form ] [ ] lmap-as '[ , [ funcall ] each ] ;
@ -34,13 +32,11 @@ DEFER: macro-call
! words for convert-lambda ! words for convert-lambda
<PRIVATE <PRIVATE
: localize-body ( assoc body -- assoc newbody ) : localize-body ( assoc body -- assoc newbody )
dupd [ dup lisp-symbol? [ tuck name>> swap at swap or ] [ lisp-symbol? ] pick '[ [ name>> , at ] [ ] bi or ] traverse ;
[ dup cons? [ localize-body ] when nip ] if
] with lmap>array ;
: localize-lambda ( body vars -- newbody newvars ) : localize-lambda ( body vars -- newbody newvars )
make-locals dup push-locals swap make-locals dup push-locals swap
[ swap localize-body seq>cons convert-form swap pop-locals ] dip swap ; [ swap localize-body convert-form swap pop-locals ] dip swap ;
: split-lambda ( cons -- body-cons vars-seq ) : split-lambda ( cons -- body-cons vars-seq )
3car -rot nip [ name>> ] lmap>array ; inline 3car -rot nip [ name>> ] lmap>array ; inline
@ -67,24 +63,24 @@ PRIVATE>
[ { [ dup list? ] [ car dup lisp-symbol? ] [ name>> "unquote" equal? dup ] } && nip ] [ { [ dup list? ] [ car dup lisp-symbol? ] [ name>> "unquote" equal? dup ] } && nip ]
[ cadr ] traverse ; [ cadr ] traverse ;
: form-dispatch ( lisp-symbol -- quot ) : convert-defmacro ( cons -- quot )
cdr [ car ] keep [ convert-lambda ] [ car name>> ] bi define-lisp-macro 1quotation ;
: form-dispatch ( cons lisp-symbol -- quot )
name>> name>>
{ { "lambda" [ convert-lambda ] } { { "lambda" [ convert-lambda ] }
{ "defmacro" [ convert-defmacro ] }
{ "quote" [ convert-quoted ] } { "quote" [ convert-quoted ] }
{ "unquote" [ convert-unquoted ] } { "unquote" [ convert-unquoted ] }
{ "quasiquote" [ convert-quasiquoted ] } { "quasiquote" [ convert-quasiquoted ] }
{ "if" [ convert-if ] }
{ "begin" [ convert-begin ] } { "begin" [ convert-begin ] }
{ "cond" [ convert-cond ] } { "cond" [ convert-cond ] }
[ drop convert-general-form ] [ drop convert-general-form ]
} case ; } case ;
: macro-expand ( cons -- quot )
uncons lookup-macro macro-call convert-form ;
: convert-list-form ( cons -- quot ) : convert-list-form ( cons -- quot )
dup car dup car
{ { [ dup lisp-macro? ] [ macro-expand ] } { { [ 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 ;
@ -96,8 +92,17 @@ PRIVATE>
[ 1quotation ] [ 1quotation ]
} cond ; } cond ;
: compile-form ( lisp-ast -- quot )
convert-form lambda-rewrite call ; inline
: macro-call ( lambda -- cons )
call ;
: macro-expand ( cons -- quot )
uncons lookup-macro macro-call compile-form ;
: lisp-string>factor ( str -- quot ) : lisp-string>factor ( str -- quot )
lisp-expr parse-result-ast convert-form lambda-rewrite call ; lisp-expr parse-result-ast compile-form ;
: lisp-eval ( str -- * ) : lisp-eval ( str -- * )
lisp-string>factor call ; lisp-string>factor call ;
@ -105,7 +110,7 @@ PRIVATE>
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: lisp-env SYMBOL: lisp-env
ERROR: no-such-var var ; ERROR: no-such-var variable-name ;
SYMBOL: macro-env SYMBOL: macro-env
@ -115,8 +120,8 @@ M: no-such-var summary drop "No such variable" ;
H{ } clone lisp-env set H{ } clone lisp-env set
H{ } clone macro-env set ; H{ } clone macro-env set ;
: lisp-define ( name quot -- ) : lisp-define ( quot name -- )
swap lisp-env get set-at ; lisp-env get set-at ;
: lisp-get ( name -- word ) : lisp-get ( name -- word )
dup lisp-env get at [ ] [ no-such-var ] ?if ; dup lisp-env get at [ ] [ no-such-var ] ?if ;
@ -128,10 +133,13 @@ M: no-such-var summary drop "No such variable" ;
dup lisp-symbol? [ lookup-var ] when call ; inline dup lisp-symbol? [ lookup-var ] when call ; inline
: define-primitive ( name vocab word -- ) : define-primitive ( name vocab word -- )
swap lookup 1quotation '[ , compose call ] lisp-define ; swap lookup 1quotation '[ , compose call ] swap lisp-define ;
: lookup-macro ( lisp-symbol -- macro ) : lookup-macro ( lisp-symbol -- lambda )
name>> macro-env get at ; name>> macro-env get at ;
: define-lisp-macro ( quot name -- )
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 ;

View File

@ -2,8 +2,8 @@
! Copyright (C) 2004 Chris Double. ! Copyright (C) 2004 Chris Double.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: lazy-lists math kernel sequences quotations ; USING: lists.lazy math kernel sequences quotations ;
IN: lazy-lists.examples IN: lists.lazy.examples
: naturals 0 lfrom ; : naturals 0 lfrom ;
: positives 1 lfrom ; : positives 1 lfrom ;

View File

@ -127,4 +127,3 @@ HELP: llines
{ $values { "stream" "a stream" } { "result" "a list" } } { $values { "stream" "a stream" } { "result" "a list" } }
{ $description "Returns a lazy list of all lines in the file. " { $link car } " returns the next lines in the file, " { $link cdr } " returns the remaining lines as a lazy list. " { $link nil? } " indicates end of file." } { $description "Returns a lazy list of all lines in the file. " { $link car } " returns the next lines in the file, " { $link cdr } " returns the remaining lines as a lazy list. " { $link nil? } " indicates end of file." }
{ $see-also lcontents } ; { $see-also lcontents } ;

View File

@ -19,8 +19,8 @@ HELP: cdr
{ $description "Returns the tail of the list." } ; { $description "Returns the tail of the list." } ;
HELP: nil HELP: nil
{ $values { "cons" "An empty cons" } } { $values { "symbol" "The empty cons (+nil+)" } }
{ $description "Returns a representation of an empty list" } ; { $description "Returns a symbol representing the empty list" } ;
HELP: nil? HELP: nil?
{ $values { "cons" "a cons object" } { "?" "a boolean" } } { $values { "cons" "a cons object" } { "?" "a boolean" } }
@ -85,7 +85,7 @@ HELP: list>seq
{ $description "Turns the given cons object into an array, maintaing order." } ; { $description "Turns the given cons object into an array, maintaing order." } ;
HELP: seq>list HELP: seq>list
{ $values { "array" "an array object" } { "list" "a cons object" } } { $values { "seq" "a sequence" } { "list" "a cons object" } }
{ $description "Turns the given array into a cons object, maintaing order." } ; { $description "Turns the given array into a cons object, maintaing order." } ;
HELP: cons>seq HELP: cons>seq
@ -97,7 +97,7 @@ HELP: seq>cons
{ $description "Recursively turns the given sequence into a cons object, maintaing order and also converting nested lists." } ; { $description "Recursively turns the given sequence into a cons object, maintaing order and also converting nested lists." } ;
HELP: traverse HELP: traverse
{ $values { " list" "a cons object" } { "pred" } { "a quotation with stack effect ( list/elt -- ? )" } { $values { "list" "a cons object" } { "pred" "a quotation with stack effect ( list/elt -- ? )" }
{ "quot" "a quotation with stack effect ( list/elt -- result)" } { "result" "a new cons object" } } { "quot" "a quotation with stack effect ( list/elt -- result)" } { "result" "a new cons object" } }
{ $description "Recursively traverses the list object, replacing any elements (which can themselves be sublists) that pred" { $description "Recursively traverses the list object, replacing any elements (which can themselves be sublists) that pred"
" returns true for with the result of applying quot to." } ; " returns true for with the result of applying quot to." } ;