diff --git a/extra/combinators/lib/lib.factor b/extra/combinators/lib/lib.factor index a838b246e4..da13901ab7 100755 --- a/extra/combinators/lib/lib.factor +++ b/extra/combinators/lib/lib.factor @@ -63,8 +63,8 @@ MACRO: napply ( n -- ) ! short circuiting words ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! : short-circuit ( quots quot default -- quot ) -! 1quotation -rot { } map>assoc alist>quot ; +: short-circuit ( quots quot default -- quot ) + 1quotation -rot { } map>assoc alist>quot ; ! MACRO: && ( quots -- ? ) ! [ [ not ] append [ f ] ] t short-circuit ; diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor index 705c2d070b..ef1f575972 100755 --- a/extra/inverse/inverse.factor +++ b/extra/inverse/inverse.factor @@ -77,7 +77,7 @@ UNION: explicit-inverse normal-inverse math-inverse pop-inverse ; { [ word? ] [ primitive? not ] [ { "inverse" "math-inverse" "pop-inverse" } [ word-prop ] with contains? not - ] } <-&& ; + ] } 1&& ; : (flatten) ( quot -- ) [ dup flattenable? [ word-def (flatten) ] [ , ] if ] each ; diff --git a/extra/lcs/lcs.factor b/extra/lcs/lcs.factor index e5155a786e..06c33505ca 100755 --- a/extra/lcs/lcs.factor +++ b/extra/lcs/lcs.factor @@ -56,7 +56,7 @@ TUPLE: trace-state old new table i j ; { [ i>> 0 > ] [ j>> 0 > ] [ [ old-nth ] [ new-nth ] bi = ] - } <-&& ; + } 1&& ; : do-retain ( state -- state ) dup old-nth retain boa , diff --git a/extra/lisp/lisp-tests.factor b/extra/lisp/lisp-tests.factor index 14b91aa58b..8dc3b65ffe 100644 --- a/extra/lisp/lisp-tests.factor +++ b/extra/lisp/lisp-tests.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008 James Cash ! See http://factorcode.org/license.txt for BSD license. -USING: lisp lisp.parser tools.test sequences math kernel parser arrays ; +USING: lisp lisp.parser tools.test sequences math kernel parser arrays lists +quotations ; IN: lisp.test @@ -13,33 +14,36 @@ IN: lisp.test "+" "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 + + [ seq>list ] "##list" lisp-define + + "define" "lisp" "defun" define-primitive + + "(lambda (&rest xs) xs)" lisp-string>factor "list" lisp-define + { 5 } [ - [ 2 3 ] "+" funcall + ! [ 2 3 ] "+" funcall + "(+ 2 3)" lisp-eval ] unit-test { 8.3 } [ - [ 10.4 2.1 ] "-" funcall + ! [ 10.4 2.1 ] "-" funcall + "(- 10.4 2.1)" lisp-eval ] unit-test { 3 } [ "((lambda (x y) (+ x y)) 1 2)" lisp-eval ] unit-test - { 42 } [ - "((lambda (x y z) (+ x (- y z))) 40 3 1)" lisp-eval - ] 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 } [ - "(if #t 1 2)" lisp-eval - ] unit-test +! { 42 } [ +! "((lambda (x y z) (+ x (- y z))) 40 3 1)" lisp-eval +! ] unit-test { "b" } [ "(cond (#f \"a\") (#t \"b\"))" lisp-eval @@ -49,8 +53,28 @@ IN: lisp.test "(begin (+ 1 4))" lisp-eval ] unit-test - { 3 } [ - "((lambda (x) (if x (begin (+ 1 2)) (- 3 5))) #t)" lisp-eval + { { 1 2 3 4 5 } } [ + "(list 1 2 3 4 5)" lisp-eval list>seq ] unit-test + { { 1 2 { 3 { 4 } 5 } } } [ + "(list 1 2 (list 3 (list 4) 5))" lisp-eval cons>seq + ] unit-test + + { T{ lisp-symbol f "if" } } [ + "(defmacro if (pred tr fl) (list (quote cond) (list (list pred tr) (list t fl))))" lisp-eval + ] unit-test + + { t } [ + T{ lisp-symbol f "if" } lisp-macro? + ] unit-test + +! { 1 } [ +! "(if #t 1 2)" lisp-eval +! ] unit-test + +! { 3 } [ +! "((lambda (x) (if x (begin (+ 1 2)) (- 3 5))) #t)" lisp-eval +! ] unit-test + ] with-interactive-vocabs diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor index 425ee27bb7..e3d942d390 100644 --- a/extra/lisp/lisp.factor +++ b/extra/lisp/lisp.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 James Cash ! See http://factorcode.org/license.txt for BSD license. USING: kernel peg sequences arrays strings combinators.lib -namespaces combinators math locals locals.private accessors +namespaces combinators math locals locals.private locals.backend accessors vectors syntax lisp.parser assocs parser sequences.lib words quotations fry lists inspector ; IN: lisp @@ -11,19 +11,23 @@ DEFER: funcall DEFER: lookup-var DEFER: lookup-macro DEFER: lisp-macro? +DEFER: lisp-var? DEFER: macro-expand 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 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : convert-body ( cons -- quot ) [ ] [ convert-form compose ] foldl ; inline : convert-begin ( cons -- quot ) - cdr [ convert-form ] [ ] lmap-as '[ , [ funcall ] each ] ; + cdr [ convert-form ] [ ] lmap-as '[ , [ call ] each ] ; : convert-cond ( cons -- quot ) - cdr [ 2car [ convert-form ] bi@ [ '[ @ funcall ] ] dip 2array ] + cdr [ 2car [ convert-form ] bi@ [ '[ @ call ] ] dip 2array ] { } lmap-as '[ , cond ] ; : convert-general-form ( cons -- quot ) @@ -32,49 +36,33 @@ DEFER: define-lisp-macro ! words for convert-lambda > , at ] [ ] bi or ] traverse ; + { + { [ dup list? ] [ [ lisp-symbol? ] pick '[ [ name>> , at ] [ ] bi or ] traverse ] } + { [ dup lisp-symbol? ] [ name>> over at ] } + [ ] + } cond ; -: localize-lambda ( body vars -- newbody newvars ) +: localize-lambda ( body vars -- newvars newbody ) make-locals dup push-locals swap [ swap localize-body convert-form swap pop-locals ] dip swap ; -: split-lambda ( cons -- body-cons vars-seq ) - 3car -rot nip [ name>> ] lmap>array ; inline +: split-lambda ( cons -- body-cons vars-seq ) + cdr uncons [ car ] [ [ name>> ] lmap>array ] bi* ; inline : rest-lambda ( body vars -- quot ) "&rest" swap [ index ] [ remove ] 2bi - localize-lambda - '[ , cut '[ @ , ] , compose ] ; + swapd localize-lambda + '[ , cut '[ @ , seq>list ] call , call ] ; : normal-lambda ( body vars -- quot ) - localize-lambda '[ , compose ] ; + localize-lambda lambda-rewrite [ compose call ] compose 1quotation ; PRIVATE> : convert-lambda ( cons -- quot ) split-lambda "&rest" over member? [ rest-lambda ] [ normal-lambda ] if ; : convert-quoted ( cons -- quot ) - cdr 1quotation ; - -: convert-unquoted ( cons -- quot ) - "unquote not valid outside of quasiquote!" throw ; - -: convert-unquoted-splicing ( cons -- quot ) - "unquote-splicing not valid outside of quasiquote!" throw ; - -> "unquote" equal? dup ] } && nip ] - [ cadr ] traverse ; - -: quasiquote-unquote-splicing ( cons -- newcons ) - [ { [ dup list? ] [ dup cdr [ cons? ] [ car cons? ] bi and ] - [ dup cadr car lisp-symbol? ] [ cadr car name>> "unquote-splicing" equal? dup ] } && nip ] - [ dup cadr cdr >>cdr ] traverse ; -PRIVATE> - -: convert-quasiquoted ( cons -- newcons ) - quasiquote-unquote quasiquote-unquote-splicing ; + cadr 1quotation ; : convert-defmacro ( cons -- quot ) cdr [ car ] keep [ convert-lambda ] [ car name>> ] bi define-lisp-macro 1quotation ; @@ -84,9 +72,6 @@ PRIVATE> { { "lambda" [ convert-lambda ] } { "defmacro" [ convert-defmacro ] } { "quote" [ convert-quoted ] } - { "unquote" [ convert-unquoted ] } - { "unquote-splicing" [ convert-unquoted-splicing ] } - { "quasiquote" [ convert-quasiquoted ] } { "begin" [ convert-begin ] } { "cond" [ convert-cond ] } [ drop convert-general-form ] @@ -102,6 +87,7 @@ PRIVATE> : convert-form ( lisp-form -- quot ) { { [ dup cons? ] [ convert-list-form ] } + { [ dup lisp-var? ] [ lookup-var 1quotation ] } { [ dup lisp-symbol? ] [ '[ , lookup-var ] ] } [ 1quotation ] } cond ; @@ -109,11 +95,8 @@ PRIVATE> : compile-form ( lisp-ast -- quot ) convert-form lambda-rewrite call ; inline -: macro-call ( lambda -- cons ) - call ; inline - : macro-expand ( cons -- quot ) - uncons [ list>seq [ ] like ] [ lookup-macro macro-call compile-form ] bi* ; + uncons [ list>seq [ ] like ] [ lookup-macro lambda-rewrite call ] bi* call compile-form call ; : lisp-string>factor ( str -- quot ) lisp-expr parse-result-ast compile-form ; @@ -125,9 +108,6 @@ PRIVATE> SYMBOL: lisp-env SYMBOL: macro-env - -ERROR: no-such-var variable-name ; -M: no-such-var summary drop "No such variable" ; : init-env ( -- ) H{ } clone lisp-env set @@ -136,17 +116,27 @@ 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 ; + : lisp-get ( name -- word ) dup lisp-env get at [ ] [ no-such-var ] ?if ; : lookup-var ( lisp-symbol -- quot ) name>> lisp-get ; +: lisp-var? ( lisp-symbol -- ? ) + 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 -- * ) - dup lisp-symbol? [ lookup-var ] when call ; inline + [ funcall-arg-list ] dip + dup lisp-symbol? [ lookup-var ] when curry call ; inline : define-primitive ( name vocab word -- ) - swap lookup 1quotation '[ , compose call ] swap lisp-define ; + swap lookup 1quotation '[ , compose call ] swap lisp-define ; ! '[ , compose call ] swap lisp-define ; : lookup-macro ( lisp-symbol -- lambda ) name>> macro-env get at ; diff --git a/extra/lisp/parser/parser.factor b/extra/lisp/parser/parser.factor index 1e37193d3a..8fadb00e65 100644 --- a/extra/lisp/parser/parser.factor +++ b/extra/lisp/parser/parser.factor @@ -34,6 +34,6 @@ string = dquote ( escaped | !(dquote) . )* dquote => [[ second >string ]] atom = number | identifier | string -list-item = _ ( atom | s-expression ) _ => [[ second ]] s-expression = LPAREN (list-item)* RPAREN => [[ second seq>cons ]] +list-item = _ ( atom | s-expression ) _ => [[ second ]] ;EBNF \ No newline at end of file diff --git a/extra/lists/lazy/examples/examples-tests.factor b/extra/lists/lazy/examples/examples-tests.factor index c088f1d9a7..04886e2c1c 100644 --- a/extra/lists/lazy/examples/examples-tests.factor +++ b/extra/lists/lazy/examples/examples-tests.factor @@ -1,4 +1,4 @@ -USING: lists.lazy.examples lazy-lists tools.test ; +USING: lists.lazy.examples lists.lazy tools.test ; IN: lists.lazy.examples.tests [ { 1 3 5 7 } ] [ 4 odds ltake list>array ] unit-test diff --git a/extra/lists/lists-tests.factor b/extra/lists/lists-tests.factor index cdc51b76e8..4a08a4d1e3 100644 --- a/extra/lists/lists-tests.factor +++ b/extra/lists/lists-tests.factor @@ -63,4 +63,8 @@ IN: lists.tests { { 3 4 { 5 6 { 7 } } } } [ { 1 2 { 3 4 { 5 } } } seq>cons [ atom? ] [ 2 + ] traverse cons>seq +] unit-test + +{ { 1 2 3 4 5 6 } } [ + { 1 2 3 } seq>list { 4 5 6 } seq>list lappend list>seq ] unit-test \ No newline at end of file diff --git a/extra/lists/lists.factor b/extra/lists/lists.factor index 13d77f757a..613d75c4ae 100644 --- a/extra/lists/lists.factor +++ b/extra/lists/lists.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Chris Double & James Cash +! Copyright (C) 2008 James Cash ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences accessors math arrays vectors classes words locals ; @@ -75,6 +75,9 @@ M: object nil? drop f ; : lreverse ( list -- newlist ) nil [ swap cons ] foldl ; +: lappend ( list1 list2 -- newlist ) + [ lreverse ] dip [ swap cons ] foldl ; + : seq>list ( seq -- list ) nil [ swap cons ] reduce ; diff --git a/extra/math/text/english/english.factor b/extra/math/text/english/english.factor index 3030f28d04..500e08f79d 100755 --- a/extra/math/text/english/english.factor +++ b/extra/math/text/english/english.factor @@ -26,7 +26,7 @@ IN: math.text.english SYMBOL: and-needed? : set-conjunction ( seq -- ) - first { [ dup 100 < ] [ dup 0 > ] } && and-needed? set drop ; + first { [ dup 100 < ] [ dup 0 > ] } 0&& and-needed? set drop ; : negative-text ( n -- str ) 0 < "Negative " "" ? ; diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index 8a3a06c58d..fc10a65024 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -87,7 +87,7 @@ C: ebnf [ dup CHAR: ? = ] [ dup CHAR: : = ] [ dup CHAR: ~ = ] - } || not nip + } 0|| not nip ] satisfy repeat1 [ >string ] action ; : 'terminal' ( -- parser ) diff --git a/extra/project-euler/014/014.factor b/extra/project-euler/014/014.factor index 32b1aa5549..ef8ef8c0f7 100644 --- a/extra/project-euler/014/014.factor +++ b/extra/project-euler/014/014.factor @@ -59,7 +59,7 @@ PRIVATE> diff --git a/extra/project-euler/021/021.factor b/extra/project-euler/021/021.factor index d8f81717af..e6eadba264 100644 --- a/extra/project-euler/021/021.factor +++ b/extra/project-euler/021/021.factor @@ -27,7 +27,7 @@ IN: project-euler.021 : amicable? ( n -- ? ) dup sum-proper-divisors - { [ 2dup = not ] [ 2dup sum-proper-divisors = ] } && 2nip ; + { [ 2dup = not ] [ 2dup sum-proper-divisors = ] } 0&& 2nip ; : euler021 ( -- answer ) 10000 [1,b] [ dup amicable? [ drop 0 ] unless ] sigma ; diff --git a/extra/project-euler/036/036.factor b/extra/project-euler/036/036.factor index 153901ce6d..fbf6376eb3 100644 --- a/extra/project-euler/036/036.factor +++ b/extra/project-euler/036/036.factor @@ -27,7 +27,7 @@ IN: project-euler.036 : both-bases? ( n -- ? ) { [ dup palindrome? ] - [ dup >bin dup reverse = ] } && nip ; + [ dup >bin dup reverse = ] } 0&& nip ; PRIVATE> diff --git a/extra/project-euler/043/043.factor b/extra/project-euler/043/043.factor index 41e378e531..0c51146656 100644 --- a/extra/project-euler/043/043.factor +++ b/extra/project-euler/043/043.factor @@ -47,7 +47,7 @@ IN: project-euler.043 [ 5 4 pick subseq-divisible? ] [ 3 3 pick subseq-divisible? ] [ 2 2 pick subseq-divisible? ] - } && nip ; + } 0&& nip ; PRIVATE> diff --git a/extra/project-euler/052/052.factor b/extra/project-euler/052/052.factor index 3f6487fb3e..6c4b605bd9 100644 --- a/extra/project-euler/052/052.factor +++ b/extra/project-euler/052/052.factor @@ -29,7 +29,7 @@ IN: project-euler.052 [ number>digits natural-sort ] map all-equal? ; : candidate? ( n -- ? ) - { [ dup odd? ] [ dup 3 mod zero? ] } && nip ; + { [ dup odd? ] [ dup 3 mod zero? ] } 0&& nip ; : next-all-same ( x n -- n ) dup candidate? [ diff --git a/extra/xmode/marker/marker.factor b/extra/xmode/marker/marker.factor index a921e6a022..7d82842327 100755 --- a/extra/xmode/marker/marker.factor +++ b/extra/xmode/marker/marker.factor @@ -19,7 +19,7 @@ strings regexp splitting parser-combinators ascii unicode.case ; dup [ dupd matches? ] [ drop f ] if ] unless* ] - } && nip ; + } 0&& nip ; : mark-number ( keyword -- id ) keyword-number? DIGIT and ; @@ -50,7 +50,7 @@ M: rule match-position drop position get ; [ over matcher-at-line-start? over zero? implies ] [ over matcher-at-whitespace-end? over whitespace-end get = implies ] [ over matcher-at-word-start? over last-offset get = implies ] - } && 2nip ; + } 0&& 2nip ; : rest-of-line ( -- str ) line get position get tail-slice ; @@ -273,7 +273,7 @@ M: mark-previous-rule handle-rule-start [ check-end-delegate ] [ check-every-rule ] [ check-word-break ] - } || drop + } 0|| drop position inc mark-token-loop