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

extra/lisp/lisp-tests.factor

@@ -7,8 +7,8 @@ IN: lisp.test
 [
     init-env
     
-    "#f" [ f ] lisp-define
-    "#t" [ t ] lisp-define
+    [ f ] "#f" lisp-define
+    [ t ] "#t" lisp-define
     
     "+" "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
     ] 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

extra/lisp/lisp.factor

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

extra/lists/lazy/examples/examples.factor

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

extra/lists/lazy/lazy-docs.factor

@@ -115,7 +115,7 @@ HELP: lmerge
 { $values { "list1" "a list" } { "list2" "a list" } { "result" "lazy list merging list1 and list2" } }
 { $description "Return the result of merging the two lists in a lazy manner." } 
 { $examples
-  { $example "USING: lazy-lists prettyprint ;" "{ 1 2 3 } >list { 4 5 6 } >list lmerge list>array ." "{ 1 4 2 5 3 6 }" }
+  { $example "USING: lists.lazy prettyprint ;" "{ 1 2 3 } >list { 4 5 6 } >list lmerge list>array ." "{ 1 4 2 5 3 6 }" }
 } ;
 
 HELP: lcontents
@@ -127,4 +127,3 @@ HELP: llines
 { $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." } 
 { $see-also lcontents } ;
-

extra/lists/lists-docs.factor

@@ -19,8 +19,8 @@ HELP: cdr
 { $description "Returns the tail of the list." } ;
     
 HELP: nil 
-{ $values { "cons" "An empty cons" } }
-{ $description "Returns a representation of an empty list" } ;
+{ $values { "symbol" "The empty cons (+nil+)" } }
+{ $description "Returns a symbol representing the empty list" } ;
 
 HELP: nil? 
 { $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." } ;
     
 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." } ;
     
 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." } ;
     
 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" } }
 { $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." } ;

extra/lists/lists.factor

@@ -8,7 +8,7 @@ IN: lists
 MIXIN: list
 GENERIC: car   ( cons -- car )
 GENERIC: cdr   ( cons -- cdr )
-GENERIC: nil?   ( cons -- ?   )
+GENERIC: nil?  ( object -- ?   )
     
 TUPLE: cons car cdr ;
 
@@ -26,7 +26,7 @@ M: object nil? drop f ;
     
 : atom? ( obj -- ? ) [ list? ] [ nil? ] bi or not ;
 
-: nil ( -- +nil+ ) +nil+ ; 
+: nil ( -- symbol ) +nil+ ; 
     
 : uncons ( cons -- cdr car )
     [ cdr ] [ car ] bi ;
@@ -61,9 +61,9 @@ M: object nil? drop f ;
 : lmap ( list quot -- result )
     over nil? [ drop ] [ (leach) lmap cons ] if ; inline
 
-: foldl ( list ident quot -- result ) swapd leach ; inline
+: foldl ( list identity quot -- result ) swapd leach ; inline
 
-: foldr ( list ident quot -- result )
+: foldr ( list identity quot -- result )
     pick nil? [ [ drop ] [ ] [ drop ] tri* ] [
         [ [ cdr ] 2dip foldr ] [ nip [ car ] dip ] 3bi
         call

extra/persistent-vectors/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

extra/persistent-vectors/persistent-vectors-docs.factor

@@ -0,0 +1,53 @@
+USING: help.markup help.syntax kernel math sequences ;
+IN: persistent-vectors
+
+HELP: new-nth
+{ $values { "val" object } { "i" integer } { "seq" sequence } { "seq'" sequence } }
+{ $contract "Persistent analogue of " { $link set-nth } ". Outputs a new sequence with the " { $snippet "i" } "th element replaced by " { $snippet "val" } "." }
+{ $notes "This operation runs in " { $snippet "O(log_32 n)" } " time on " { $link persistent-vector } " instances and " { $snippet "O(n)" } " time on all other sequences." } ;
+
+HELP: ppush
+{ $values { "val" object } { "seq" sequence } { "seq'" sequence } }
+{ $contract "Persistent analogue of " { $link push } ". Outputs a new sequence with all elements of " { $snippet "seq" } " together with " { $snippet "val" } " added at the end." }
+{ $notes "This operation runs in amortized " { $snippet "O(1)" } " time on " { $link persistent-vector } " instances and " { $snippet "O(n)" } " time on all other sequences." } ;
+
+HELP: ppop
+{ $values { "seq" sequence } { "seq'" sequence } }
+{ $contract "Persistent analogue of " { $link pop* } ". Outputs a new sequence with all elements of " { $snippet "seq" } " except for the final element." }
+{ $notes "This operation runs in amortized " { $snippet "O(1)" } " time on " { $link persistent-vector } " instances and " { $snippet "O(n)" } " time on all other sequences." } ;
+
+HELP: PV{
+{ $syntax "elements... }" }
+{ $description "Parses a literal " { $link persistent-vector } "." } ;
+
+HELP: >persistent-vector
+{ $values { "seq" sequence } { "pvec" persistent-vector } }
+{ $description "Creates a " { $link persistent-vector } " with the same elements as " { $snippet "seq" } "." } ;
+
+HELP: persistent-vector
+{ $class-description "The class of persistent vectors." } ;
+
+HELP: pempty
+{ $values { "pvec" persistent-vector } }
+{ $description "Outputs an empty " { $link persistent-vector } "." } ;
+
+ARTICLE: "persistent-vectors" "Persistent vectors"
+"A " { $emphasis "persistent vector" } " differs from an ordinary vector (" { $link "vectors" } ") in that it is immutable, and all operations yield new persistent vectors instead of modifying inputs. Unlike immutable operations on ordinary sequences, persistent vector operations are efficient and run in sub-linear time."
+$nl
+"The class of persistent vectors:"
+{ $subsection persistent-vector }
+"Persistent vectors support the immutable sequence protocol, namely as " { $link length } " and " { $link nth } ", and so can be used with most sequence words (" { $link "sequences" } ")."
+$nl
+"In addition to standard sequence operations, persistent vectors implement efficient operations specific to them. They run in sub-linear time on persistent vectors, and degrate to linear-time algorithms on ordinary sequences:"
+{ $subsection new-nth }
+{ $subsection ppush }
+{ $subsection ppop }
+"The empty persistent vector, used for building up all other persistent vectors:"
+{ $subsection pempty }
+"Converting a sequence into a persistent vector:"
+{ $subsection >persistent-vector }
+"Persistent vectors have a literal syntax:"
+{ $subsection POSTPONE: PV{ }
+"This implementation of persistent vectors is based on the " { $snippet "clojure.lang.PersistentVector" } " class from Rich Hickey's Clojure language for the JVM (" { $url "http://clojure.org" } ")." ;
+
+ABOUT: "persistent-vectors"

extra/persistent-vectors/persistent-vectors-tests.factor

@@ -0,0 +1,63 @@
+IN: persistent-vectors.tests
+USING: tools.test persistent-vectors sequences kernel arrays
+random namespaces vectors math math.order ;
+
+\ new-nth must-infer
+\ ppush must-infer
+\ ppop must-infer
+
+[ 0 ] [ pempty length ] unit-test
+
+[ 1 ] [ 3 pempty ppush length ] unit-test
+
+[ 3 ] [ 3 pempty ppush first ] unit-test
+
+[ PV{ 3 1 3 3 7 } ] [
+    pempty { 3 1 3 3 7 } [ swap ppush ] each
+] unit-test
+
+[ { 3 1 3 3 7 } ] [
+    pempty { 3 1 3 3 7 } [ swap ppush ] each >array
+] unit-test
+
+{ 100 1060 2000 10000 100000 1000000 } [
+    [ t ] swap [ dup >persistent-vector sequence= ] curry unit-test
+] each
+
+[ ] [ 10000 [ drop 16 random-bits ] PV{ } map-as "1" set ] unit-test
+[ ] [ "1" get >vector "2" set ] unit-test
+
+[ t ] [
+    3000 [
+        drop
+        16 random-bits 10000 random
+        [ "1" [ new-nth ] change ]
+        [ "2" [ new-nth ] change ] 2bi
+        "1" get "2" get sequence=
+    ] all?
+] unit-test
+
+[ PV{ } ppop ] [ empty-error? ] must-fail-with
+
+[ t ] [ PV{ 3 } ppop empty? ] unit-test
+
+[ PV{ 3 7 } ] [ PV{ 3 7 6 } ppop ] unit-test
+
+[ PV{ 3 7 6 5 } ] [ 5 PV{ 3 7 6 } ppush ] unit-test
+
+[ ] [ PV{ } "1" set ] unit-test
+[ ] [ V{ } clone "2" set ] unit-test
+
+[ t ] [
+    100 [
+        drop
+        100 random [
+            16 random-bits [ "1" [ ppush ] change ] [ "2" get push ] bi
+        ] times
+        100 random "1" get length min [
+            "1" [ ppop ] change
+            "2" get pop*
+        ] times
+        "1" get "2" get sequence=
+    ] all?
+] unit-test

extra/persistent-vectors/persistent-vectors.factor

@@ -0,0 +1,183 @@
+! Based on Clojure's PersistentVector by Rich Hickey.
+
+USING: math accessors kernel sequences.private sequences arrays
+combinators parser prettyprint.backend ;
+IN: persistent-vectors
+
+ERROR: empty-error pvec ;
+
+GENERIC: ppush ( val seq -- seq' )
+
+M: sequence ppush swap suffix ;
+
+GENERIC: ppop ( seq -- seq' )
+
+M: sequence ppop 1 head* ;
+
+GENERIC: new-nth ( val i seq -- seq' )
+
+M: sequence new-nth clone [ set-nth ] keep ;
+
+TUPLE: persistent-vector count root tail ;
+
+M: persistent-vector length count>> ;
+
+<PRIVATE
+
+TUPLE: node children level ;
+
+: node-size 32 ; inline
+
+: node-mask node-size mod ; inline
+
+: node-shift -5 * shift ; inline
+
+: node-nth ( i node -- obj )
+    [ node-mask ] [ children>> ] bi* nth ; inline
+
+: body-nth ( i node -- i node' )
+    dup level>> [
+        dupd [ level>> node-shift ] keep node-nth
+    ] times ; inline
+
+: tail-offset ( pvec -- n )
+    [ count>> ] [ tail>> children>> length ] bi - ;
+
+M: persistent-vector nth-unsafe
+    2dup tail-offset >=
+    [ tail>> ] [ root>> body-nth ] if
+    node-nth ;
+
+: node-add ( val node -- node' )
+    clone [ ppush ] change-children ;
+
+: ppush-tail ( val pvec -- pvec' )
+    [ node-add ] change-tail ;
+
+: full? ( node -- ? )
+    children>> length node-size = ;
+
+: 1node ( val level -- node )
+    node new
+        swap >>level
+        swap 1array >>children ;
+
+: 2node ( first second -- node )
+    [ 2array ] [ drop level>> 1+ ] 2bi node boa ;
+
+: new-child ( new-child node -- node' expansion/f )
+    dup full? [ tuck level>> 1node ] [ node-add f ] if ;
+
+: new-last ( val seq -- seq' )
+    [ length 1- ] keep new-nth ;
+
+: node-set-last ( child node -- node' )
+    clone [ new-last ] change-children ;
+
+: (ppush-new-tail) ( tail node -- node' expansion/f )
+    dup level>> 1 = [
+        new-child
+    ] [
+        tuck children>> peek (ppush-new-tail)
+        [ swap new-child ] [ swap node-set-last f ] ?if
+    ] if ;
+
+: do-expansion ( pvec root expansion/f -- pvec )
+    [ 2node ] when* >>root ;
+
+: ppush-new-tail ( val pvec -- pvec' )
+    [ ] [ tail>> ] [ root>> ] tri
+    (ppush-new-tail) do-expansion
+    swap 0 1node >>tail ;
+
+M: persistent-vector ppush ( val pvec -- pvec' )
+    clone
+    dup tail>> full?
+    [ ppush-new-tail ] [ ppush-tail ] if
+    [ 1+ ] change-count ;
+
+: node-set-nth ( val i node -- node' )
+    clone [ new-nth ] change-children ;
+
+: node-change-nth ( i node quot -- node' )
+    [ clone ] dip [
+        [ clone ] dip [ change-nth ] 2keep drop
+    ] curry change-children ; inline
+
+: (new-nth) ( val i node -- node' )
+    dup level>> 0 = [
+        [ node-mask ] dip node-set-nth
+    ] [
+        [ dupd level>> node-shift node-mask ] keep
+        [ (new-nth) ] node-change-nth
+    ] if ;
+
+M: persistent-vector new-nth ( obj i pvec -- pvec' )
+    2dup count>> = [ nip ppush ] [
+        clone
+        2dup tail-offset >= [
+            [ node-mask ] dip
+            [ node-set-nth ] change-tail
+        ] [
+            [ (new-nth) ] change-root
+        ] if
+    ] if ;
+
+: (ppop-contraction) ( node -- node' tail' )
+    clone [ unclip-last swap ] change-children swap ;
+
+: ppop-contraction ( node -- node' tail' )
+    [ (ppop-contraction) ] [ level>> 1 = ] bi swap and ;
+
+: (ppop-new-tail) ( root -- root' tail' )
+    dup level>> 1 > [
+        dup children>> peek (ppop-new-tail) over children>> empty?
+        [ 2drop ppop-contraction ] [ [ swap node-set-last ] dip ] if
+    ] [
+        ppop-contraction
+    ] if ;
+
+: ppop-tail ( pvec -- pvec' )
+    [ clone [ ppop ] change-children ] change-tail ;
+
+: ppop-new-tail ( pvec -- pvec' )
+    dup root>> (ppop-new-tail)
+    [
+        dup [ level>> 1 > ] [ children>> length 1 = ] bi and 
+        [ children>> first ] when
+    ] dip
+    [ >>root ] [ >>tail ] bi* ;
+
+PRIVATE>
+
+: pempty ( -- pvec )
+    T{ persistent-vector f 0 T{ node f { } 1 } T{ node f { } 0 } } ; inline
+
+M: persistent-vector ppop ( pvec -- pvec' )
+    dup count>> {
+        { 0 [ empty-error ] }
+        { 1 [ drop pempty ] }
+        [
+            [
+                clone
+                dup tail>> children>> length 1 >
+                [ ppop-tail ] [ ppop-new-tail ] if
+            ] dip 1- >>count
+        ]
+    } case ;
+
+M: persistent-vector like
+    drop pempty [ swap ppush ] reduce ;
+
+M: persistent-vector equal?
+    over persistent-vector? [ sequence= ] [ 2drop f ] if ;
+
+: >persistent-vector ( seq -- pvec ) pempty like ; inline
+
+: PV{ \ } [ >persistent-vector ] parse-literal ; parsing
+
+M: persistent-vector pprint-delims drop \ PV{ \ } ;
+
+M: persistent-vector >pprint-sequence ;
+
+INSTANCE: persistent-vector immutable-sequence

extra/persistent-vectors/summary.txt

@@ -0,0 +1 @@
+Immutable vectors with O(log_32 n) random access and amortized O(1) push/pop

extra/persistent-vectors/tags.txt

@@ -0,0 +1 @@
+collections

extra/yahoo/yahoo-docs.factor

@@ -2,5 +2,5 @@ USING: help.syntax help.markup ;
 IN: yahoo
 
 HELP: search-yahoo
-{ $values { "search" "a string" } { "num" "a positive integer" } { "seq" "sequence of arrays of length 3" } }
-{ $description "Uses Yahoo's REST API to search for the query specified in the search string, getting the number of answers specified. Returns a sequence of 3arrays, { title url summary }, each of which is a string." } ;
+{ $values { "search" search } { "seq" "sequence of arrays of length 3" } }
+{ $description "Uses Yahoo's REST API to search for the specified query, getting the number of answers specified. Returns a sequence of " { $link result } " instances." } ;