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

extra/combinators/lib/lib.factor

@@ -63,8 +63,8 @@ MACRO: napply ( n -- )
 ! short circuiting words
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-! : short-circuit ( quots quot default -- quot )
+: short-circuit ( quots quot default -- quot )
-!   1quotation -rot { } map>assoc <reversed> alist>quot ;
+    1quotation -rot { } map>assoc <reversed> alist>quot ;
 
 ! MACRO: && ( quots -- ? )
 !     [ [ not ] append [ f ] ] t short-circuit ;

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 ;

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 ,

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 ] "+" <lisp-symbol> funcall
+      ! [ 2 3 ] "+" <lisp-symbol> funcall
+      "(+ 2 3)" lisp-eval
     ] unit-test
     
     { 8.3 } [
-     [ 10.4 2.1 ] "-" <lisp-symbol> funcall
+     ! [ 10.4 2.1 ] "-" <lisp-symbol> funcall
+     "(- 10.4 2.1)" lisp-eval
     ] unit-test
     
     { 3 } [
       "((lambda (x y) (+ x y)) 1 2)" lisp-eval
     ] 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
-    
-    { 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
     
     { "b" } [
       "(cond (#f \"a\") (#t \"b\"))" lisp-eval
@@ -49,8 +53,28 @@ IN: lisp.test
       "(begin (+ 1 4))" lisp-eval
     ] unit-test
     
-    { 3 } [
+    { { 1 2 3 4 5 } } [
-       "((lambda (x) (if x (begin (+ 1 2)) (- 3 5))) #t)" lisp-eval
+        "(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

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  
 <PRIVATE  
 : localize-body ( assoc body -- assoc newbody )  
-    [ lisp-symbol? ] pick '[ [ name>> , 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
+    cdr uncons [ car ] [ [ name>> ] lmap>array ] bi* ; inline
     
 : rest-lambda ( body vars -- quot )
     "&rest" swap [ index ] [ remove ] 2bi
-    localize-lambda <lambda>
+    swapd localize-lambda <lambda>
-    '[ , cut '[ @ , ] , compose ] ;
+    '[ , cut '[ @ , seq>list ] call , call ] ;
     
 : normal-lambda ( body vars -- quot )
-    localize-lambda <lambda> '[ , compose ] ;
+    localize-lambda <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 ;
+    cadr 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 ;
-    
-<PRIVATE    
-: quasiquote-unquote ( cons -- newcons )
-    [ { [ dup list? ] [ car dup lisp-symbol? ] [ name>> "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 ;
     
 : 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 ;
@@ -126,9 +109,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
     H{ } clone macro-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 ;

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

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

extra/lists/lists-tests.factor

@@ -64,3 +64,7 @@ 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

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 )    
     <reversed> nil [ swap cons ] reduce ;
     

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 " "" ? ;

extra/peg/ebnf/ebnf.factor

@@ -87,7 +87,7 @@ C: <ebnf> ebnf
       [ dup CHAR: ? = ]
       [ dup CHAR: : = ]
       [ dup CHAR: ~ = ]
-    } || not nip    
+    } 0|| not nip    
   ] satisfy repeat1 [ >string <ebnf-non-terminal> ] action ;
 
 : 'terminal' ( -- parser )

extra/project-euler/014/014.factor

@@ -59,7 +59,7 @@ PRIVATE>
 <PRIVATE
 
 : worth-calculating? ( n -- ? )
-    { [ dup 1- 3 mod zero? ] [ dup 1- 3 / even? ] } && nip ;
+    { [ dup 1- 3 mod zero? ] [ dup 1- 3 / even? ] } 0&& nip ;
 
 PRIVATE>
 

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 ;

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>
 

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>
 

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? [

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