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

core/generic/standard/engines/engines.factor

@@ -1,16 +1,16 @@
-USING: assocs kernel namespaces quotations generic math
+! Copyright (C) 2008 Slava Pestov.
-sequences combinators words classes.algebra ;
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs kernel kernel.private namespaces quotations
+generic math sequences combinators words classes.algebra arrays
+;
 IN: generic.standard.engines
 
 SYMBOL: default
 SYMBOL: assumed
+SYMBOL: (dispatch#)
 
 GENERIC: engine>quot ( engine -- quot )
 
-M: quotation engine>quot ;
-
-M: method-body engine>quot 1quotation ;
-
 : engines>quots ( assoc -- assoc' )
     [ engine>quot ] assoc-map ;
 
@@ -36,8 +36,6 @@ M: method-body engine>quot 1quotation ;
         r> execute r> pick set-at
     ] if ; inline
 
-SYMBOL: (dispatch#)
-
 : (picker) ( n -- quot )
     {
         { 0 [ [ dup ] ] }

core/generic/standard/engines/predicate/predicate.factor

@@ -1,6 +1,8 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
 USING: generic.standard.engines generic namespaces kernel
-sequences classes.algebra accessors words combinators
+kernel.private sequences classes.algebra accessors words
-assocs ;
+combinators assocs arrays ;
 IN: generic.standard.engines.predicate
 
 TUPLE: predicate-dispatch-engine methods ;
@@ -24,8 +26,13 @@ C: <predicate-dispatch-engine> predicate-dispatch-engine
 : sort-methods ( assoc -- assoc' )
     >alist [ keys sort-classes ] keep extract-keys ;
 
+: methods-with-default ( engine -- assoc )
+    methods>> clone default get object bootstrap-word pick set-at ;
+
 M: predicate-dispatch-engine engine>quot
-    methods>> clone
+    methods-with-default
-    default get object bootstrap-word pick set-at engines>quots
+    engines>quots
-    sort-methods prune-redundant-predicates
+    sort-methods
-    class-predicates alist>quot ;
+    prune-redundant-predicates
+    class-predicates
+    alist>quot ;

core/generic/standard/standard.factor

@@ -10,7 +10,16 @@ IN: generic.standard
 
 GENERIC: dispatch# ( word -- n )
 
-M: word dispatch# "combination" word-prop dispatch# ;
+M: generic dispatch#
+    "combination" word-prop dispatch# ;
+
+GENERIC: method-declaration ( class generic -- quot )
+
+M: generic method-declaration
+    "combination" word-prop method-declaration ;
+
+M: quotation engine>quot
+    assumed get generic get method-declaration prepend ;
 
 : unpickers
     {
@@ -135,6 +144,9 @@ M: standard-combination perform-combination
 
 M: standard-combination dispatch# #>> ;
 
+M: standard-combination method-declaration
+    dispatch# object <array> swap prefix [ declare ] curry [ ] like ;
+
 M: standard-combination next-method-quot*
     [
         single-next-method-quot picker prepend
@@ -157,6 +169,8 @@ PREDICATE: hook-generic < generic
 
 M: hook-combination dispatch# drop 0 ;
 
+M: hook-combination method-declaration 2drop [ ] ;
+
 M: hook-generic extra-values drop 1 ;
 
 M: hook-generic effective-method

core/optimizer/inlining/inlining.factor

@@ -191,6 +191,10 @@ DEFER: (flat-length)
 : apply-identities ( node -- node/f )
     dup find-identity f splice-quot ;
 
+: splice-word-def ( #call word def -- node )
+    [ drop +inlined+ depends-on ] [ swap 1array ] 2bi
+    splice-quot ;
+
 : optimistic-inline? ( #call -- ? )
     dup node-param "specializer" word-prop dup [
         >r node-input-classes r> specialized-length tail*
@@ -199,22 +203,20 @@ DEFER: (flat-length)
         2drop f
     ] if ;
 
-: splice-word-def ( #call word -- node )
+: already-inlined? ( #call -- ? )
-    dup +inlined+ depends-on
+    [ param>> ] [ history>> ] bi memq? ;
-    dup def>> swap 1array splice-quot ;
 
 : optimistic-inline ( #call -- node )
-    dup node-param over node-history memq? [
+    dup already-inlined? [ drop t ] [
-        drop t
+        dup param>> dup def>> splice-word-def
-    ] [
-        dup node-param splice-word-def
     ] if ;
 
 : should-inline? ( word -- ? )
     flat-length 11 <= ;
 
 : method-body-inline? ( #call -- ? )
-    node-param dup method-body? [ should-inline? ] [ drop f ] if ;
+    param>> dup [ method-body? ] [ "default" word-prop not ] bi and
+    [ should-inline? ] [ drop f ] if ;
 
 M: #call optimize-node*
     {

core/optimizer/specializers/specializers.factor

@@ -18,13 +18,6 @@ IN: optimizer.specializers
         unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
     ] if ;
 
-: tag-specializer ( quot -- newquot )
-    [
-        [ dup tag ] %
-        num-tags get swap <array> ,
-        \ dispatch ,
-    ] [ ] make ;
-
 : specializer-cases ( quot word -- default alist )
     dup [ array? ] all? [ 1array ] unless [
         [ make-specializer ] keep
@@ -39,11 +32,7 @@ IN: optimizer.specializers
     method-declaration [ declare ] curry prepend ;
 
 : specialize-quot ( quot specializer -- quot' )
-    dup { number } = [
+    specializer-cases alist>quot ;
-        drop tag-specializer
-    ] [
-        specializer-cases alist>quot
-    ] if ;
 
 : standard-method? ( method -- ? )
     dup method-body? [

extra/io/unix/backend/backend.factor

@@ -168,7 +168,7 @@ M: stdin dispose
 
 : wait-for-stdin ( stdin -- n )
     [ control>> CHAR: X over io:stream-write1 io:stream-flush ]
-    [ size>> "size_t" heap-size swap io:stream-read *uint ]
+    [ size>> "ssize_t" heap-size swap io:stream-read *int ]
     bi ;
 
 :: refill-stdin ( buffer stdin size -- )

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

@@ -27,10 +27,6 @@ HELP: >persistent-vector
 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
@@ -42,12 +38,12 @@ $nl
 { $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{ }
+"The empty persistent vector, written " { $snippet "PV{ }" } ", is used for building up all other persistent vectors."
+$nl
 "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

@@ -1,23 +1,23 @@
 IN: persistent-vectors.tests
-USING: tools.test persistent-vectors sequences kernel arrays
+USING: accessors tools.test persistent-vectors sequences kernel
-random namespaces vectors math math.order ;
+arrays random namespaces vectors math math.order ;
 
 \ new-nth must-infer
 \ ppush must-infer
 \ ppop must-infer
 
-[ 0 ] [ pempty length ] unit-test
+[ 0 ] [ PV{ } length ] unit-test
 
-[ 1 ] [ 3 pempty ppush length ] unit-test
+[ 1 ] [ 3 PV{ } ppush length ] unit-test
 
-[ 3 ] [ 3 pempty ppush first ] unit-test
+[ 3 ] [ 3 PV{ } ppush first ] unit-test
 
 [ PV{ 3 1 3 3 7 } ] [
-    pempty { 3 1 3 3 7 } [ swap ppush ] each
+    PV{ } { 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
+    PV{ } { 3 1 3 3 7 } [ swap ppush ] each >array
 ] unit-test
 
 { 100 1060 2000 10000 100000 1000000 } [
@@ -52,6 +52,16 @@ random namespaces vectors math math.order ;
 
 [ ] [ PV{ } 10000 [ push/pop-test ] times drop ] unit-test
 
+[ PV{ } ] [
+    PV{ }
+    10000 [ 1 swap ppush ] times
+    10000 [ ppop ] times
+] unit-test
+
+[ t ] [
+    10000 >persistent-vector 752 [ ppop ] times dup length sequence=
+] unit-test
+
 [ t ] [
     100 [
         drop

extra/persistent-vectors/persistent-vectors.factor

@@ -4,6 +4,12 @@ USING: math accessors kernel sequences.private sequences arrays
 combinators combinators.short-circuit parser prettyprint.backend ;
 IN: persistent-vectors
 
+<PRIVATE
+
+TUPLE: node { children array } { level fixnum } ;
+
+PRIVATE>
+
 ERROR: empty-error pvec ;
 
 GENERIC: ppush ( val seq -- seq' )
@@ -18,14 +24,13 @@ GENERIC: new-nth ( val i seq -- seq' )
 
 M: sequence new-nth clone [ set-nth ] keep ;
 
-TUPLE: persistent-vector count root tail ;
+TUPLE: persistent-vector
+{ count fixnum }
+{ root node initial: T{ node f { } 1 } }
+{ tail node initial: T{ node f { } 0 } } ;
 
 M: persistent-vector length count>> ;
 
-<PRIVATE
-
-TUPLE: node children level ;
-
 : node-size 32 ; inline
 
 : node-mask node-size mod ; inline
@@ -33,12 +38,12 @@ TUPLE: node children level ;
 : node-shift -5 * shift ; inline
 
 : node-nth ( i node -- obj )
-    [ node-mask ] [ children>> ] bi* nth ; inline
+    [ node-mask ] [ children>> ] bi* nth ;
 
 : body-nth ( i node -- i node' )
     dup level>> [
         dupd [ level>> node-shift ] keep node-nth
-    ] times ; inline
+    ] times ;
 
 : tail-offset ( pvec -- n )
     [ count>> ] [ tail>> children>> length ] bi - ;
@@ -58,9 +63,7 @@ M: persistent-vector nth-unsafe
     children>> length node-size = ;
 
 : 1node ( val level -- node )
-    node new
+    [ 1array ] dip node boa ;
-        swap >>level
-        swap 1array >>children ;
 
 : 2node ( first second -- node )
     [ 2array ] [ drop level>> 1+ ] 2bi node boa ;
@@ -123,6 +126,10 @@ M: persistent-vector new-nth ( obj i pvec -- pvec' )
         ] if
     ] if ;
 
+! The pop code is really convoluted. I don't understand Rich Hickey's
+! original code. It uses a 'Box' out parameter which is passed around
+! inside a recursive function, and gets mutated along the way to boot.
+! Super-confusing.
 : ppop-tail ( pvec -- pvec' )
     [ clone [ ppop ] change-children ] change-tail ;
 
@@ -137,10 +144,12 @@ M: persistent-vector new-nth ( obj i pvec -- pvec' )
 
 : (ppop-new-tail) ( root -- root' tail' )
     dup level>> 1 > [
-        dup children>> peek (ppop-new-tail) over
+        dup children>> peek (ppop-new-tail) [
-        [ [ swap node-set-last ] dip ]
+            dup
-        [ 2drop ppop-contraction ]
+            [ swap node-set-last ]
+            [ drop ppop-contraction drop ]
             if
+        ] dip
     ] [
         ppop-contraction
     ] if ;
@@ -159,13 +168,10 @@ M: persistent-vector new-nth ( obj i pvec -- pvec' )
 
 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 ] }
+        { 1 [ drop T{ persistent-vector } ] }
         [
             [
                 clone
@@ -176,12 +182,13 @@ M: persistent-vector ppop ( pvec -- pvec' )
     } case ;
 
 M: persistent-vector like
-    drop pempty [ swap ppush ] reduce ;
+    drop T{ persistent-vector } [ swap ppush ] reduce ;
 
 M: persistent-vector equal?
     over persistent-vector? [ sequence= ] [ 2drop f ] if ;
 
-: >persistent-vector ( seq -- pvec ) pempty like ; inline
+: >persistent-vector ( seq -- pvec )
+    T{ persistent-vector } like ;
 
 : PV{ \ } [ >persistent-vector ] parse-literal ; parsing
 

vm/os-unix.c

@@ -339,7 +339,7 @@ void *stdin_loop(void *arg)
 
 		for(;;)
 		{
-			size_t bytes = read(0,buf,sizeof(buf));
+			ssize_t bytes = read(0,buf,sizeof(buf));
 			if(bytes < 0)
 			{
 				if(errno == EINTR)