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

Conflicts:

	extra/semantic-db/semantic-db.factor

core/alien/compiler/compiler.factor

@@ -270,7 +270,7 @@ M: no-such-symbol compiler-error-type
     pop-literal nip >>library
     pop-literal nip >>return
     ! Quotation which coerces parameters to required types
-    dup param-prep-quot f infer-quot
+    dup param-prep-quot recursive-state get infer-quot
     ! Set ABI
     dup library>> library [ abi>> ] [ "cdecl" ] if* >>abi
     ! Add node to IR
@@ -278,7 +278,7 @@ M: no-such-symbol compiler-error-type
     ! Magic #: consume exactly the number of inputs
     dup 0 alien-invoke-stack
     ! Quotation which coerces return value to required type
-    return-prep-quot f infer-quot
+    return-prep-quot recursive-state get infer-quot
 ] "infer" set-word-prop
 
 M: #alien-invoke generate-node
@@ -306,13 +306,13 @@ M: alien-indirect-error summary
     pop-parameters >>parameters
     pop-literal nip >>return
     ! Quotation which coerces parameters to required types
-    dup param-prep-quot [ dip ] curry f infer-quot
+    dup param-prep-quot [ dip ] curry recursive-state get infer-quot
     ! Add node to IR
     dup node,
     ! Magic #: consume the function pointer, too
     dup 1 alien-invoke-stack
     ! Quotation which coerces return value to required type
-    return-prep-quot f infer-quot
+    return-prep-quot recursive-state get infer-quot
 ] "infer" set-word-prop
 
 M: #alien-indirect generate-node
@@ -345,7 +345,7 @@ M: alien-callback-error summary
 
 : callback-bottom ( node -- )
     xt>> [ word-xt drop <alien> ] curry
-    f infer-quot ;
+    recursive-state get infer-quot ;
 
 \ alien-callback [
     4 ensure-values

core/bootstrap/compiler/compiler.factor

@@ -18,6 +18,8 @@ IN: bootstrap.compiler
 
 enable-compiler
 
+: compile-uncompiled [ compiled? not ] filter compile ;
+
 nl
 "Compiling..." write flush
 
@@ -42,38 +44,38 @@ nl
     find-pair-next namestack*
 
     bitand bitor bitxor bitnot
-} compile
+} compile-uncompiled
 
 "." write flush
 
 {
-    + 1+ 1- 2/ < <= > >= shift min
+    + 1+ 1- 2/ < <= > >= shift
-} compile
+} compile-uncompiled
 
 "." write flush
 
 {
     new-sequence nth push pop peek
-} compile
+} compile-uncompiled
 
 "." write flush
 
 {
     hashcode* = get set
-} compile
+} compile-uncompiled
 
 "." write flush
 
 {
     . lines
-} compile
+} compile-uncompiled
 
 "." write flush
 
 {
     malloc calloc free memcpy
-} compile
+} compile-uncompiled
 
-vocabs [ words [ compiled? not ] filter compile "." write flush ] each
+vocabs [ words compile-uncompiled "." write flush ] each
 
 " done" print flush

core/bootstrap/image/image-tests.factor

@@ -1,5 +1,22 @@
 IN: bootstrap.image.tests
-USING: bootstrap.image bootstrap.image.private tools.test ;
+USING: bootstrap.image bootstrap.image.private tools.test
+kernel math ;
 
 \ ' must-infer
 \ write-image must-infer
+
+[ f ] [ { 1 2 3 } [ 1 2 3 ] eql? ] unit-test
+
+[ t ] [ [ 1 2 3 ] [ 1 2 3 ] eql? ] unit-test
+
+[ f ] [ [ 2drop 0 ] [ 2drop 0.0 ] eql? ] unit-test
+
+[ t ] [ [ 2drop 0 ] [ 2drop 0 ] eql? ] unit-test
+
+[ f ] [ \ + [ 2drop 0 ] eql? ] unit-test
+
+[ f ] [ 3 [ 0 1 2 ] eql? ] unit-test
+
+[ f ] [ 3 3.0 eql? ] unit-test
+
+[ t ] [ 4.0 4.0 eql? ] unit-test

core/bootstrap/image/image.factor

@@ -8,7 +8,7 @@ splitting growable classes classes.builtin classes.tuple
 classes.tuple.private words.private io.binary io.files vocabs
 vocabs.loader source-files definitions debugger float-arrays
 quotations.private sequences.private combinators
-io.encodings.binary math.order ;
+io.encodings.binary math.order accessors ;
 IN: bootstrap.image
 
 : my-arch ( -- arch )
@@ -31,6 +31,43 @@ IN: bootstrap.image
 
 <PRIVATE
 
+! Object cache; we only consider numbers equal if they have the
+! same type
+TUPLE: id obj ;
+
+C: <id> id
+
+M: id hashcode* obj>> hashcode* ;
+
+GENERIC: (eql?) ( obj1 obj2 -- ? )
+
+: eql? ( obj1 obj2 -- ? )
+    [ (eql?) ] [ [ class ] bi@ = ] 2bi and ;
+
+M: integer (eql?) = ;
+
+M: sequence (eql?)
+    over sequence? [
+        2dup [ length ] bi@ =
+        [ [ eql? ] 2all? ] [ 2drop f ] if
+    ] [ 2drop f ] if ;
+
+M: object (eql?) = ;
+
+M: id equal?
+    over id? [ [ obj>> ] bi@ eql? ] [ 2drop f ] if ;
+
+SYMBOL: objects
+
+: (objects) <id> objects get ; inline
+
+: lookup-object ( obj -- n/f ) (objects) at ;
+
+: put-object ( n obj -- ) (objects) set-at ;
+
+: cache-object ( obj quot -- value )
+    >r (objects) r> [ obj>> ] prepose cache ; inline
+
 ! Constants
 
 : image-magic HEX: 0f0e0d0c ; inline
@@ -61,9 +98,6 @@ IN: bootstrap.image
 ! The image being constructed; a vector of word-size integers
 SYMBOL: image
 
-! Object cache
-SYMBOL: objects
-
 ! Image output format
 SYMBOL: big-endian
 
@@ -187,7 +221,9 @@ GENERIC: ' ( obj -- ptr )
     2tri ;
 
 M: bignum '
-    bignum tag-number dup [ emit-bignum ] emit-object ;
+    [
+        bignum tag-number dup [ emit-bignum ] emit-object
+    ] cache-object ;
 
 ! Fixnums
 
@@ -202,9 +238,11 @@ M: fixnum '
 ! Floats
 
 M: float '
+    [
         float tag-number dup [
             align-here double>bits emit-64
-    ] emit-object ;
+        ] emit-object
+    ] cache-object ;
 
 ! Special objects
 
@@ -243,7 +281,7 @@ M: f '
         ] bi
         \ word type-number object tag-number
         [ emit-seq ] emit-object
-    ] keep objects get set-at ;
+    ] keep put-object ;
 
 : word-error ( word msg -- * )
     [ % dup word-vocabulary % " " % word-name % ] "" make throw ;
@@ -252,7 +290,7 @@ M: f '
     [ target-word ] keep or ;
 
 : fixup-word ( word -- offset )
-    transfer-word dup objects get at
+    transfer-word dup lookup-object
     [ ] [ "Not in image: " word-error ] ?if ;
 
 : fixup-words ( -- )
@@ -286,7 +324,7 @@ M: wrapper '
 M: string '
     #! We pool strings so that each string is only written once
     #! to the image
-    objects get [ emit-string ] cache ;
+    [ emit-string ] cache-object ;
 
 : assert-empty ( seq -- )
     length 0 assert= ;
@@ -311,12 +349,12 @@ M: float-array ' float-array emit-dummy-array ;
 
 : emit-tuple ( tuple -- pointer )
     dup class word-name "tombstone" =
-    [ objects get [ (emit-tuple) ] cache ] [ (emit-tuple) ] if ;
+    [ [ (emit-tuple) ] cache-object ] [ (emit-tuple) ] if ;
 
 M: tuple ' emit-tuple ;
 
 M: tuple-layout '
-    objects get [
+    [
         [
             {
                 [ layout-hashcode , ]
@@ -328,12 +366,12 @@ M: tuple-layout '
         ] { } make [ ' ] map
         \ tuple-layout type-number
         object tag-number [ emit-seq ] emit-object
-    ] cache ;
+    ] cache-object ;
 
 M: tombstone '
     delegate
     "((tombstone))" "((empty))" ? "hashtables.private" lookup
-    word-def first objects get [ emit-tuple ] cache ;
+    word-def first [ emit-tuple ] cache-object ;
 
 ! Arrays
 M: array '
@@ -343,7 +381,7 @@ M: array '
 ! Quotations
 
 M: quotation '
-    objects get [
+    [
         quotation-array '
         quotation type-number object tag-number [
             emit ! array
@@ -351,7 +389,7 @@ M: quotation '
             0 emit ! xt
             0 emit ! code
         ] emit-object
-    ] cache ;
+    ] cache-object ;
 
 ! End of the image
 

core/combinators/combinators-docs.factor

@@ -95,7 +95,7 @@ HELP: case
     "If there is no case matching " { $snippet "obj" } ", the default case is taken. If the last element of " { $snippet "cases" } " is a quotation, the quotation is called with " { $snippet "obj" } " on the stack. Otherwise, a " { $link no-cond } " error is rasied."
     $nl
     "The following two phrases are equivalent:"
-    { $code "{ { X [ Y ] } { Y [ T ] } } case" }
+    { $code "{ { X [ Y ] } { Z [ T ] } } case" }
     { $code "dup X = [ drop Y ] [ dup Z = [ drop T ] [ no-case ] if ] if" }
 }
 { $examples

core/debugger/debugger.factor

@@ -97,10 +97,10 @@ M: relative-overflow summary
 
 : assert-depth ( quot -- )
     >r datastack r> swap slip >r datastack r>
-    2dup [ length ] compare sgn {
+    2dup [ length ] compare {
-        { -1 [ trim-datastacks nip relative-underflow ] }
+        { +lt+ [ trim-datastacks nip relative-underflow ] }
-        { 0 [ 2drop ] }
+        { +eq+ [ 2drop ] }
-        { 1 [ trim-datastacks drop relative-overflow ] }
+        { +gt+ [ trim-datastacks drop relative-overflow ] }
     } case ; inline
 
 : expired-error. ( obj -- )

core/generic/math/math.factor

@@ -23,7 +23,7 @@ PREDICATE: math-class < class
     } cond ;
     
 : math-class-max ( class class -- class )
-    [ [ math-precedence ] compare 0 > ] most ;
+    [ [ math-precedence ] compare +gt+ eq? ] most ;
 
 : (math-upgrade) ( max class -- quot )
     dupd = [ drop [ ] ] [ "coercer" word-prop [ ] or ] if ;

core/heaps/heaps.factor

@@ -92,11 +92,11 @@ M: priority-queue heap-size ( heap -- n )
 
 GENERIC: heap-compare ( pair1 pair2 heap -- ? )
 
-: (heap-compare) drop [ entry-key ] compare 0 ; inline
+: (heap-compare) drop [ entry-key ] compare ; inline
 
-M: min-heap heap-compare (heap-compare) > ;
+M: min-heap heap-compare (heap-compare) +gt+ eq? ;
 
-M: max-heap heap-compare (heap-compare) < ;
+M: max-heap heap-compare (heap-compare) +lt+ eq? ;
 
 : heap-bounds-check? ( m heap -- ? )
     heap-size >= ; inline

core/inference/backend/backend.factor

@@ -60,7 +60,7 @@ M: object value-literal \ literal-expected inference-warning ;
 : value-vector ( n -- vector ) [ drop <computed> ] V{ } map-as ;
 
 : add-inputs ( seq stack -- n stack )
-    tuck [ length ] compare dup 0 >
+    tuck [ length ] bi@ - dup 0 >
     [ dup value-vector [ swapd push-all ] keep ]
     [ drop 0 swap ] if ;
 

core/kernel/kernel-docs.factor

@@ -1,5 +1,5 @@
 USING: generic help.markup help.syntax math memory
-namespaces sequences kernel.private layouts sorting classes
+namespaces sequences kernel.private layouts classes
 kernel.private vectors combinators quotations strings words
 assocs arrays math.order ;
 IN: kernel
@@ -241,7 +241,7 @@ ARTICLE: "conditionals" "Conditionals and logic"
 "See " { $link "combinators" } " for forms which abstract away common patterns involving multiple nested branches."
 { $see-also "booleans" "bitwise-arithmetic" both? either? } ;
 
-ARTICLE: "equality" "Equality and comparison testing"
+ARTICLE: "equality" "Equality"
 "There are two distinct notions of ``sameness'' when it comes to objects. You can test if two references point to the same object (" { $emphasis "identity comparison" } "), or you can test if two objects are equal in a domain-specific sense, usually by being instances of the same class, and having equal slot values (" { $emphasis "value comparison" } "). Both notions of equality are equality relations in the mathematical sense."
 $nl
 "Identity comparison:"
@@ -250,15 +250,8 @@ $nl
 { $subsection = }
 "Custom value comparison methods:"
 { $subsection equal? }
+"Utility class:"
 { $subsection identity-tuple }
-"Some types of objects also have an intrinsic order allowing sorting using " { $link natural-sort } ":"
-{ $subsection <=> }
-{ $subsection compare }
-"Utilities for comparing objects:"
-{ $subsection after? }
-{ $subsection before? }
-{ $subsection after=? }
-{ $subsection before=? }
 "An object can be cloned; the clone has distinct identity but equal value:"
 { $subsection clone } ;
 
@@ -393,8 +386,6 @@ HELP: identity-tuple
     { $unchecked-example "T{ foo } dup clone = ." "f" }
 } ;
 
-{ <=> compare natural-sort sort-keys sort-values } related-words
-
 HELP: clone
 { $values { "obj" object } { "cloned" "a new object" } }
 { $contract "Outputs a new object equal to the given object. This is not guaranteed to actually copy the object; it does nothing with immutable objects, and does not copy words either. However, sequences and tuples can be cloned to obtain a shallow copy of the original." } ;

core/math/floats/floats.factor

@@ -6,8 +6,6 @@ IN: math.floats.private
 M: fixnum >float fixnum>float ;
 M: bignum >float bignum>float ;
 
-M: float zero? dup 0.0 float= swap -0.0 float= or ;
-
 M: float >fixnum float>fixnum ;
 M: float >bignum float>bignum ;
 M: float >float ;
@@ -22,4 +20,7 @@ M: float + float+ ;
 M: float - float- ;
 M: float * float* ;
 M: float / float/f ;
+M: float /f float/f ;
 M: float mod float-mod ;
+
+M: real abs dup 0 < [ neg ] when ;

core/math/integers/integers-tests.factor

@@ -1,5 +1,5 @@
-USING: kernel math namespaces prettyprint
+USING: kernel math math.functions namespaces prettyprint
-math.private continuations tools.test sequences ;
+math.private continuations tools.test sequences random ;
 IN: math.integers.tests
 
 [ "-8" ] [ -8 unparse ] unit-test
@@ -191,3 +191,31 @@ unit-test
 [ f ] [ -128 power-of-2? ] unit-test
 [ f ] [ 0 power-of-2? ] unit-test
 [ t ] [ 1 power-of-2? ] unit-test
+
+: ratio>float [ >bignum ] bi@ /f ;
+
+[ 5. ] [ 5 1 ratio>float ] unit-test
+[ 4. ] [ 4 1 ratio>float ] unit-test
+[ 2. ] [ 2 1 ratio>float ] unit-test
+[ .5 ] [ 1 2 ratio>float ] unit-test
+[ .75 ] [ 3 4 ratio>float ] unit-test
+[ 1. ] [ 2000 2^ 2000 2^ 1+ ratio>float ] unit-test
+[ -1. ] [ 2000 2^ neg 2000 2^ 1+ ratio>float ] unit-test
+[ 0.4 ] [ 6 15 ratio>float ] unit-test
+
+[ HEX: 3fe553522d230931 ]
+[ 61967020039 92984792073 ratio>float double>bits ] unit-test
+
+: random-integer
+    32 random-bits
+    1 random zero? [ neg ] when
+    1 random zero? [ >bignum ] when ;
+
+[ t ] [
+    1000 [
+        drop
+        random-integer
+        random-integer
+        [ >float / ] [ /f ] 2bi 0.1 ~
+    ] all?
+] unit-test

core/math/integers/integers.factor

@@ -1,4 +1,5 @@
 ! Copyright (C) 2004, 2007 Slava Pestov.
+! Copyright (C) 2008, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel kernel.private sequences
 sequences.private math math.private combinators ;
@@ -22,6 +23,8 @@ M: fixnum + fixnum+ ;
 M: fixnum - fixnum- ;
 M: fixnum * fixnum* ;
 M: fixnum /i fixnum/i ;
+M: fixnum /f >r >float r> >float float/f ;
+
 M: fixnum mod fixnum-mod ;
 
 M: fixnum /mod fixnum/mod ;
@@ -67,4 +70,57 @@ M: bignum bitnot bignum-bitnot ;
 M: bignum bit? bignum-bit? ;
 M: bignum (log2) bignum-log2 ;
 
-M: integer zero? 0 number= ;
+! Converting ratios to floats. Based on FLOAT-RATIO from
+! sbcl/src/code/float.lisp, which has the following license:
+
+! "The software is in the public domain and is
+! provided with absolutely no warranty."
+
+! First step: pre-scaling
+: twos ( x -- y ) dup 1- bitxor log2 ; inline
+
+: scale-denonimator ( den -- scaled-den scale' )
+    dup twos neg [ shift ] keep ; inline
+
+: pre-scale ( num den -- scale shifted-num scaled-den )
+    2dup [ log2 ] bi@ -
+    tuck [ neg 54 + shift ] [ >r scale-denonimator r> + ] 2bi*
+    -rot ; inline
+
+! Second step: loop
+: shift-mantissa ( scale mantissa -- scale' mantissa' )
+    [ 1+ ] [ 2/ ] bi* ; inline
+
+: /f-loop ( scale mantissa den -- scale' fraction-and-guard rem )
+    [ 2dup /i log2 53 > ]
+    [ >r shift-mantissa r> ]
+    [ ] while /mod ; inline
+
+! Third step: post-scaling
+: unscaled-float ( mantissa -- n )
+    52 2^ 1- bitand 1022 52 shift bitor bits>double ; inline
+
+: scale-float ( scale mantissa -- float' )
+    >r dup 0 < [ neg 2^ recip ] [ 2^ ] if r> * ; inline
+
+: post-scale ( scale mantissa -- n )
+    2/ dup log2 52 > [ shift-mantissa ] when
+    unscaled-float scale-float ; inline
+
+! Main word
+: /f-abs ( m n -- f )
+    over zero? [
+        2drop 0.0
+    ] [
+        dup zero? [
+            2drop 1.0/0.0
+        ] [
+            pre-scale
+            /f-loop over odd?
+            [ zero? [ 1+ ] unless ] [ drop ] if
+            post-scale
+        ] if
+    ] if ; inline
+
+M: bignum /f ( m n -- f )
+    [ [ abs ] bi@ /f-abs ] [ [ 0 < ] bi@ xor ] 2bi [ neg ] when ;

core/math/math.factor

@@ -21,6 +21,7 @@ MATH: +   ( x y -- z ) foldable
 MATH: -   ( x y -- z ) foldable
 MATH: *   ( x y -- z ) foldable
 MATH: /   ( x y -- z ) foldable
+MATH: /f  ( x y -- z ) foldable
 MATH: /i  ( x y -- z ) foldable
 MATH: mod ( x y -- z ) foldable
 
@@ -33,6 +34,8 @@ GENERIC# shift 1 ( x n -- y ) foldable
 GENERIC: bitnot ( x -- y ) foldable
 GENERIC# bit? 1 ( x n -- ? ) foldable
 
+GENERIC: abs ( x -- y ) foldable
+
 <PRIVATE
 
 GENERIC: (log2) ( x -- n ) foldable
@@ -46,10 +49,7 @@ PRIVATE>
         (log2)
     ] if ; foldable
 
-GENERIC: zero? ( x -- ? ) foldable
+: zero? ( x -- ? ) 0 number= ; inline
-
-M: object zero? drop f ;
-
 : 1+ ( x -- y ) 1 + ; inline
 : 1- ( x -- y ) 1 - ; inline
 : 2/ ( x -- y ) -1 shift ; inline
@@ -60,8 +60,6 @@ M: object zero? drop f ;
 
 : ?1+ [ 1+ ] [ 0 ] if* ; inline
 
-: /f  ( x y -- z ) >r >float r> >float float/f ; inline
-
 : rem ( x y -- z ) tuck mod over + swap mod ; foldable
 
 : 2^ ( n -- 2^n ) 1 swap shift ; inline

core/math/order/order-docs.factor

@@ -0,0 +1,94 @@
+USING: help.markup help.syntax kernel math quotations
+math.private words ;
+IN: math.order
+
+HELP: <=>
+{ $values { "obj1" object } { "obj2" object } { "symbol" symbol } }
+{ $contract
+    "Compares two objects using an intrinsic total order, for example, the natural order for real numbers and lexicographic order for strings."
+    $nl
+    "The output value is one of the following:"
+    { $list
+        { { $link +lt+ } " - indicating that " { $snippet "obj1" } " precedes " { $snippet "obj2" } }
+        { { $link +eq+ } " - indicating that " { $snippet "obj1" } " is equal to " { $snippet "obj2" } }
+        { { $link +gt+ } " - indicating that " { $snippet "obj1" } " follows " { $snippet "obj2" } }
+    }
+} ;
+
+HELP: +lt+
+{ $description "Returned by " { $link <=> } " when the first object is strictly less than the second object." } ;
+
+HELP: +eq+
+{ $description "Returned by " { $link <=> } " when the first object is equal to the second object." } ;
+
+HELP: +gt+
+{ $description "Returned by " { $link <=> } " when the first object is strictly greater than the second object." } ;
+
+HELP: invert-comparison
+{ $values { "symbol" "a comparison symbol, +lt+, +eq+, or +gt+" }
+          { "new-symbol" "a comparison symbol, +lt+, +eq+, or +gt+" } }
+{ $description "Invert the comparison symbol returned by " { $link <=> } ". The output for the symbol " { $snippet "+eq+" } " is itself." }
+{ $examples
+    { $example "USING: math.order prettyprint ;" "+lt+ invert-comparison ." "+gt+" } } ;
+
+HELP: compare
+{ $values { "obj1" object } { "obj2" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- newobj )" } } { "symbol" "a comparison symbol, +lt+, +eq+, or +gt+" } }
+{ $description "Compares the results of applying the quotation to both objects via " { $link <=> } "." }
+{ $examples { $example "USING: kernel math.order prettyprint sequences ;" "\"hello\" \"hi\" [ length ] compare ." "+gt+" }
+} ;
+
+HELP: max
+{ $values { "x" real } { "y" real } { "z" real } }
+{ $description "Outputs the greatest of two real numbers." } ;
+
+HELP: min
+{ $values { "x" real } { "y" real } { "z" real } }
+{ $description "Outputs the smallest of two real numbers." } ;
+
+HELP: between?
+{ $values { "x" real } { "y" real } { "z" real } { "?" "a boolean" } }
+{ $description "Tests if " { $snippet "x" } " is in the interval " { $snippet "[y,z]" } "." }
+{ $notes "As per the closed interval notation, the end-points are included in the interval." } ;
+
+HELP: before?
+{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
+{ $description "Tests if " { $snippet "obj1" } " comes before " { $snippet "obj2" } " using an intrinsic total order." }
+{ $notes "Implemented using " { $link <=> } "." } ;
+
+HELP: after?
+{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
+{ $description "Tests if " { $snippet "obj1" } " comes after " { $snippet "obj2" } " using an intrinsic total order." }
+{ $notes "Implemented using " { $link <=> } "." } ;
+
+HELP: before=?
+{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
+{ $description "Tests if " { $snippet "obj1" } " comes before or equals " { $snippet "obj2" } " using an intrinsic total order." }
+{ $notes "Implemented using " { $link <=> } "." } ;
+
+HELP: after=?
+{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
+{ $description "Tests if " { $snippet "obj1" } " comes after or equals " { $snippet "obj2" } " using an intrinsic total order." }
+{ $notes "Implemented using " { $link <=> } "." } ;
+
+{ before? after? before=? after=? } related-words
+
+HELP: [-]
+{ $values { "x" real } { "y" real } { "z" real } }
+{ $description "Subtracts " { $snippet "y" } " from " { $snippet "x" } ". If the result is less than zero, outputs zero." } ;
+
+ARTICLE: "math.order" "Ordered objects"
+"Some classes have an intrinsic order amongst instances:"
+{ $subsection <=> }
+{ $subsection compare }
+{ $subsection invert-comparison }
+"The above words return one of the following symbols:"
+{ $subsection +lt+ }
+{ $subsection +eq+ }
+{ $subsection +gt+ }
+"Utilities for comparing objects:"
+{ $subsection after? }
+{ $subsection before? }
+{ $subsection after=? }
+{ $subsection before=? } ;
+
+ABOUT: "math.order"

core/math/order/order-tests.factor

@@ -0,0 +1,9 @@
+USING: kernel math.order tools.test ;
+IN: math.order.tests
+
+[ +lt+ ] [ "ab" "abc" <=> ] unit-test
+[ +gt+ ] [ "abc" "ab" <=> ] unit-test
+[ +lt+ ] [ 3 4 <=> ] unit-test
+[ +eq+ ] [ 4 4 <=> ] unit-test
+[ +gt+ ] [ 4 3 <=> ] unit-test
+

core/math/order/order.factor

@@ -0,0 +1,45 @@
+! Copyright (C) 2008 Slava Pestov, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math ;
+IN: math.order
+
+SYMBOL: +lt+
+SYMBOL: +eq+
+SYMBOL: +gt+
+
+GENERIC: <=> ( obj1 obj2 -- symbol )
+
+: (<=>) ( a b -- symbol )
+    2dup < [ 2drop +lt+ ] [ number= +eq+ +gt+ ? ] if ; inline
+
+: invert-comparison ( symbol -- new-symbol )
+    #! Can't use case, index or nth here
+    dup +lt+ eq? [ drop +gt+ ] [ +eq+ eq? +eq+ +lt+ ? ] if ;
+
+M: real <=> (<=>) ;
+M: integer <=> (<=>) ;
+
+GENERIC: before? ( obj1 obj2 -- ? )
+GENERIC: after? ( obj1 obj2 -- ? )
+GENERIC: before=? ( obj1 obj2 -- ? )
+GENERIC: after=? ( obj1 obj2 -- ? )
+
+M: object before? ( obj1 obj2 -- ? ) <=> +lt+ eq? ;
+M: object after? ( obj1 obj2 -- ? ) <=> +gt+ eq? ;
+M: object before=? ( obj1 obj2 -- ? ) <=> +gt+ eq? not ;
+M: object after=? ( obj1 obj2 -- ? ) <=> +lt+ eq? not ;
+
+M: real before? ( obj1 obj2 -- ? ) < ;
+M: real after? ( obj1 obj2 -- ? ) > ;
+M: real before=? ( obj1 obj2 -- ? ) <= ;
+M: real after=? ( obj1 obj2 -- ? ) >= ;
+
+: min ( x y -- z ) [ before? ] most ; inline 
+: max ( x y -- z ) [ after? ] most ; inline
+
+: between? ( x y z -- ? )
+    pick after=? [ after=? ] [ 2drop f ] if ; inline
+
+: [-] ( x y -- z ) - 0 max ; inline
+
+: compare ( obj1 obj2 quot -- symbol ) bi@ <=> ; inline

core/sorting/sorting-docs.factor

@@ -62,3 +62,5 @@ HELP: binsearch*
 { $description "Variant of " { $link binsearch } " which outputs the found element rather than its index in the sequence."
 $nl
 "Outputs " { $link f } " if the sequence is empty. If the sequence has at least one element, this word always outputs a sequence element." } ;
+
+{ <=> compare natural-sort sort-keys sort-values } related-words

core/sorting/sorting-tests.factor

@@ -19,10 +19,10 @@ unit-test
 
 [ 3 ] [ { 1 2 3 4 } midpoint ] unit-test
 
-[ f ] [ 3 { } [ - ] binsearch ] unit-test
+[ f ] [ 3 { } [ <=> ] binsearch ] unit-test
-[ 0 ] [ 3 { 3 } [ - ] binsearch ] unit-test
+[ 0 ] [ 3 { 3 } [ <=> ] binsearch ] unit-test
-[ 1 ] [ 2 { 1 2 3 } [ - ] binsearch ] unit-test
+[ 1 ] [ 2 { 1 2 3 } [ <=> ] binsearch ] unit-test
-[ 3 ] [ 4 { 1 2 3 4 5 6 } [ - ] binsearch ] unit-test
+[ 3 ] [ 4 { 1 2 3 4 5 6 } [ <=> ] binsearch ] unit-test
-[ 1 ] [ 3.5 { 1 2 3 4 5 6 7 8 } [ - ] binsearch ] unit-test
+[ 2 ] [ 3.5 { 1 2 3 4 5 6 7 8 } [ <=> ] binsearch ] unit-test
-[ 3 ] [ 5.5 { 1 2 3 4 5 6 7 8 } [ - ] binsearch ] unit-test
+[ 4 ] [ 5.5 { 1 2 3 4 5 6 7 8 } [ <=> ] binsearch ] unit-test
-[ 10 ] [ 10 20 >vector [ - ] binsearch ] unit-test
+[ 10 ] [ 10 20 >vector [ <=> ] binsearch ] unit-test

core/sorting/sorting.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2005, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays kernel math sequences vectors math.order
-sequences sequences.private growable ;
+sequences sequences.private growable math.order ;
 IN: sorting
 
 DEFER: sort
@@ -17,7 +17,7 @@ DEFER: sort
     dup slice-from 1+ swap set-slice-from ; inline
 
 : smallest ( iter1 iter2 quot -- elt )
-    >r over this over this r> call 0 <
+    >r over this over this r> call +lt+ eq?
     -rot ? [ this ] keep next ; inline
 
 : (merge) ( iter1 iter2 quot accum -- )
@@ -58,13 +58,13 @@ PRIVATE>
     [ midpoint@ ] keep nth-unsafe ; inline
 
 : partition ( seq n -- slice )
-    1 < swap halves ? ; inline
+    +gt+ eq? not swap halves ? ; inline
 
 : (binsearch) ( elt quot seq -- i )
     dup length 1 <= [
         slice-from 2nip
     ] [
-        [ midpoint swap call ] 3keep roll dup zero?
+        [ midpoint swap call ] 3keep roll dup +eq+ eq?
         [ drop dup slice-from swap midpoint@ + 2nip ]
         [ partition (binsearch) ] if
     ] if ; inline

extra/builder/release/branch/branch.factor

@@ -21,7 +21,7 @@ IN: builder.release.branch
   {
     "scp"
     my-boot-image-name
-    "factorcode.org:/var/www/factorcode.org/newsite/images/clean"
+    { "factorcode.org:/var/www/factorcode.org/newsite/images/clean/" platform }
   }
   to-strings
   try-process ;

extra/bunny/bunny.factor

@@ -4,7 +4,7 @@ opengl.glu shuffle http.client vectors namespaces ui.gadgets
 ui.gadgets.canvas ui.render ui splitting combinators tools.time
 system combinators.lib float-arrays continuations
 opengl.demo-support multiline ui.gestures bunny.fixed-pipeline
-bunny.cel-shaded bunny.outlined bunny.model ;
+bunny.cel-shaded bunny.outlined bunny.model accessors ;
 IN: bunny
 
 TUPLE: bunny-gadget model geom draw-seq draw-n ;
@@ -13,38 +13,33 @@ TUPLE: bunny-gadget model geom draw-seq draw-n ;
     0.0 0.0 0.375 <demo-gadget>
     maybe-download read-model {
         set-delegate
-        set-bunny-gadget-model
+        (>>model)
     } bunny-gadget construct ;
 
 : bunny-gadget-draw ( gadget -- draw )
-    { bunny-gadget-draw-n bunny-gadget-draw-seq }
+    { draw-n>> draw-seq>> }
     get-slots nth ;
 
 : bunny-gadget-next-draw ( gadget -- )
-    dup { bunny-gadget-draw-seq bunny-gadget-draw-n }
+    dup { draw-seq>> draw-n>> }
     get-slots
     1+ swap length mod
-    swap [ set-bunny-gadget-draw-n ] keep relayout-1 ;
+    >>draw-n relayout-1 ;
 
 M: bunny-gadget graft* ( gadget -- )
     GL_DEPTH_TEST glEnable
-    dup bunny-gadget-model <bunny-geom>
+    dup model>> <bunny-geom> >>geom
-    over {
+    dup
     [ <bunny-fixed-pipeline> ]
     [ <bunny-cel-shaded> ]
-        [ <bunny-outlined> ]
+    [ <bunny-outlined> ] tri 3array
-    } map-call-with [ ] filter
+    [ ] filter >>draw-seq
-    0
+    0 >>draw-n
-    roll {
+    drop ;
-        set-bunny-gadget-geom
-        set-bunny-gadget-draw-seq
-        set-bunny-gadget-draw-n
-    } set-slots ;
 
 M: bunny-gadget ungraft* ( gadget -- )
-    { bunny-gadget-geom bunny-gadget-draw-seq } get-slots
+    [ geom>> [ dispose ] when* ]
-    [ [ dispose ] when* ] each
+    [ draw-seq>> [ [ dispose ] when* ] each ] bi ;
-    [ dispose ] when* ;
 
 M: bunny-gadget draw-gadget* ( gadget -- )
     0.15 0.15 0.15 1.0 glClearColor
@@ -52,7 +47,7 @@ M: bunny-gadget draw-gadget* ( gadget -- )
     dup demo-gadget-set-matrices
     GL_MODELVIEW glMatrixMode
     0.02 -0.105 0.0 glTranslatef
-    { bunny-gadget-geom bunny-gadget-draw } get-slots
+    { geom>> bunny-gadget-draw } get-slots
     draw-bunny ;
 
 M: bunny-gadget pref-dim* ( gadget -- dim )

extra/bunny/cel-shaded/cel-shaded.factor

@@ -1,5 +1,5 @@
 USING: arrays bunny.model continuations kernel multiline opengl opengl.shaders
-    opengl.capabilities opengl.gl sequences sequences.lib ;
+    opengl.capabilities opengl.gl sequences sequences.lib accessors ;
 IN: bunny.cel-shaded
 
 STRING: vertex-shader-source
@@ -68,11 +68,12 @@ TUPLE: bunny-cel-shaded program ;
 : <bunny-cel-shaded> ( gadget -- draw )
     drop
     cel-shading-supported? [
+        bunny-cel-shaded new
         vertex-shader-source <vertex-shader> check-gl-shader
         cel-shaded-fragment-shader-lib-source <fragment-shader> check-gl-shader
         cel-shaded-fragment-shader-main-source <fragment-shader> check-gl-shader
         3array <gl-program> check-gl-program
-        { set-bunny-cel-shaded-program } bunny-cel-shaded construct
+        >>program
     ] [ f ] if ;
 
 : (draw-cel-shaded-bunny) ( geom program -- )
@@ -85,8 +86,8 @@ TUPLE: bunny-cel-shaded program ;
     } [ bunny-geom ] with-gl-program ;
 
 M: bunny-cel-shaded draw-bunny
-    bunny-cel-shaded-program (draw-cel-shaded-bunny) ;
+    program>> (draw-cel-shaded-bunny) ;
 
 M: bunny-cel-shaded dispose
-    bunny-cel-shaded-program delete-gl-program ;
+    program>> delete-gl-program ;
 

extra/bunny/fixed-pipeline/fixed-pipeline.factor

@@ -6,7 +6,7 @@ TUPLE: bunny-fixed-pipeline ;
 
 : <bunny-fixed-pipeline> ( gadget -- draw )
     drop
-    { } bunny-fixed-pipeline construct ;
+    bunny-fixed-pipeline new ;
 
 M: bunny-fixed-pipeline draw-bunny
     drop

extra/bunny/model/model.factor

@@ -2,7 +2,7 @@ USING: alien alien.c-types arrays sequences math math.vectors
 math.matrices math.parser io io.files kernel opengl opengl.gl
 opengl.glu io.encodings.ascii opengl.capabilities shuffle
 http.client vectors splitting tools.time system combinators
-float-arrays continuations namespaces sequences.lib ;
+float-arrays continuations namespaces sequences.lib accessors ;
 IN: bunny.model
 
 : numbers ( str -- seq )
@@ -85,24 +85,24 @@ M: bunny-dlist bunny-geom
     bunny-dlist-list glCallList ;
 
 M: bunny-buffers bunny-geom
-    dup {
+    dup { array>> element-array>> } get-slots [
-        bunny-buffers-array
-        bunny-buffers-element-array
-    } get-slots [
         { GL_VERTEX_ARRAY GL_NORMAL_ARRAY } [
             GL_DOUBLE 0 0 buffer-offset glNormalPointer
-            dup bunny-buffers-nv "double" heap-size * buffer-offset
+            [
+                nv>> "double" heap-size * buffer-offset
                 3 GL_DOUBLE 0 roll glVertexPointer
-            bunny-buffers-ni
+            ] [
+                ni>>
                 GL_TRIANGLES swap GL_UNSIGNED_INT 0 buffer-offset glDrawElements
+            ] bi
         ] all-enabled-client-state
     ] with-array-element-buffers ;
 
 M: bunny-dlist dispose
-    bunny-dlist-list delete-dlist ;
+    list>> delete-dlist ;
 
 M: bunny-buffers dispose
-    { bunny-buffers-array bunny-buffers-element-array } get-slots
+    { array>> element-array>> } get-slots
     delete-gl-buffer delete-gl-buffer ;
 
 : <bunny-geom> ( model -- geom )

extra/bunny/outlined/outlined.factor

@@ -1,6 +1,7 @@
 USING: arrays bunny.model bunny.cel-shaded continuations kernel
 math multiline opengl opengl.shaders opengl.framebuffers
-opengl.gl opengl.capabilities sequences ui.gadgets combinators ;
+opengl.gl opengl.capabilities sequences ui.gadgets combinators
+accessors ;
 IN: bunny.outlined
 
 STRING: outlined-pass1-fragment-shader-main-source
@@ -139,9 +140,9 @@ TUPLE: bunny-outlined
 : <bunny-outlined> ( gadget -- draw )
     outlining-supported? [
         pass1-program pass2-program {
-            set-bunny-outlined-gadget
+            (>>gadget)
-            set-bunny-outlined-pass1-program
+            (>>pass1-program)
-            set-bunny-outlined-pass2-program
+            (>>pass2-program)
         } bunny-outlined construct
     ] [ drop f ] if ;
 
@@ -169,35 +170,33 @@ TUPLE: bunny-outlined
     ] with-framebuffer ;
 
 : dispose-framebuffer ( draw -- )
-    dup bunny-outlined-framebuffer-dim [
+    dup framebuffer-dim>> [
         {
-            [ bunny-outlined-framebuffer    [ delete-framebuffer ] when* ]
+            [ framebuffer>>    [ delete-framebuffer ] when* ]
-            [ bunny-outlined-color-texture  [ delete-texture ] when* ]
+            [ color-texture>>  [ delete-texture ] when* ]
-            [ bunny-outlined-normal-texture [ delete-texture ] when* ]
+            [ normal-texture>> [ delete-texture ] when* ]
-            [ bunny-outlined-depth-texture  [ delete-texture ] when* ]
+            [ depth-texture>>  [ delete-texture ] when* ]
-            [ f swap set-bunny-outlined-framebuffer-dim ]
+            [ f >>framebuffer-dim drop ]
         } cleave
     ] [ drop ] if ;
 
 : remake-framebuffer-if-needed ( draw -- )
-    dup bunny-outlined-gadget rect-dim
+    dup [ gadget>> dim>> ] [ framebuffer-dim>> ] bi
-    over bunny-outlined-framebuffer-dim
     over =
-    [ 2drop ]
+    [ 2drop ] [
+        [ dup dispose-framebuffer dup ] dip {
             [
-        swap dup dispose-framebuffer >r
+                GL_RGBA16F_ARB GL_RGBA (framebuffer-texture)
-        dup GL_RGBA16F_ARB GL_RGBA (framebuffer-texture)
+                [ >>color-texture drop ] keep
-        swap dup GL_RGBA16F_ARB GL_RGBA (framebuffer-texture)
+            ] [
-        swap dup GL_DEPTH_COMPONENT32 GL_DEPTH_COMPONENT (framebuffer-texture)
+                GL_RGBA16F_ARB GL_RGBA (framebuffer-texture)
-        swap >r
+                [ >>normal-texture drop ] keep
-        [ (make-framebuffer) ] 3keep
+            ] [ 
-        r> r> {
+                GL_DEPTH_COMPONENT32 GL_DEPTH_COMPONENT (framebuffer-texture)
-            set-bunny-outlined-framebuffer
+                [ >>depth-texture drop ] keep
-            set-bunny-outlined-color-texture
+            ]
-            set-bunny-outlined-normal-texture
+        } 2cleave
-            set-bunny-outlined-depth-texture
+        (make-framebuffer) >>framebuffer drop
-            set-bunny-outlined-framebuffer-dim
-        } set-slots
     ] if ;
 
 : clear-framebuffer ( -- )
@@ -209,31 +208,34 @@ TUPLE: bunny-outlined
     GL_COLOR_BUFFER_BIT glClear ;
 
 : (pass1) ( geom draw -- )
-    dup bunny-outlined-framebuffer [
+    dup framebuffer>> [
         clear-framebuffer
         { GL_COLOR_ATTACHMENT0_EXT GL_COLOR_ATTACHMENT1_EXT } set-draw-buffers
-        bunny-outlined-pass1-program (draw-cel-shaded-bunny)
+        pass1-program>> (draw-cel-shaded-bunny)
     ] with-framebuffer ;
 
 : (pass2) ( draw -- )
-    init-matrices
+    init-matrices {
-    dup bunny-outlined-color-texture GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit
+        [ color-texture>>  GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit ]
-    dup bunny-outlined-normal-texture GL_TEXTURE_2D GL_TEXTURE1 bind-texture-unit
+        [ normal-texture>> GL_TEXTURE_2D GL_TEXTURE1 bind-texture-unit ]
-    dup bunny-outlined-depth-texture GL_TEXTURE_2D GL_TEXTURE2 bind-texture-unit
+        [ depth-texture>>  GL_TEXTURE_2D GL_TEXTURE2 bind-texture-unit ]
-    bunny-outlined-pass2-program {
+        [
+            pass2-program>> {
                 { "colormap"   [ 0 glUniform1i ] }
                 { "normalmap"  [ 1 glUniform1i ] }
                 { "depthmap"   [ 2 glUniform1i ] }
                 { "line_color" [ 0.1 0.0 0.1 1.0 glUniform4f ] }
-    } [ { -1.0 -1.0 } { 1.0 1.0 } rect-vertices ] with-gl-program ;
+            } [ { -1.0 -1.0 } { 1.0 1.0 } rect-vertices ]
+            with-gl-program
+        ]
+    } cleave ;
 
 M: bunny-outlined draw-bunny
-    dup remake-framebuffer-if-needed
+    [ remake-framebuffer-if-needed ]
-    [ (pass1) ] keep (pass2) ;
+    [ (pass1) ]
+    [ (pass2) ] tri ;
 
 M: bunny-outlined dispose
-    {
+    [ pass1-program>> [ delete-gl-program ] when* ]
-        [ bunny-outlined-pass1-program [ delete-gl-program ] when* ]
+    [ pass2-program>> [ delete-gl-program ] when* ]
-        [ bunny-outlined-pass2-program [ delete-gl-program ] when* ]
+    [ dispose-framebuffer ] tri ;
-        [ dispose-framebuffer ]
-    } cleave ;

extra/calendar/calendar-tests.factor

@@ -131,16 +131,16 @@ IN: calendar.tests
 [ t ] [ 2004 1 1 23 0 0 9+1/2 hours <timestamp> >gmt
         2004 1 1 13 30 0 instant <timestamp> = ] unit-test
 
-[ 0 ] [ 2004 1 1 13 30 0 instant <timestamp>
+[ +eq+ ] [ 2004 1 1 13 30 0 instant <timestamp>
         2004 1 1 12 30 0 -1 hours <timestamp> <=> ] unit-test
 
-[ 1 ] [ 2004 1 1 13 30 0 instant <timestamp>
+[ +gt+ ] [ 2004 1 1 13 30 0 instant <timestamp>
         2004 1 1 12 30 0 instant <timestamp> <=> ] unit-test
 
-[ -1 ] [ 2004 1 1 12 30 0 instant <timestamp>
+[ +lt+ ] [ 2004 1 1 12 30 0 instant <timestamp>
         2004 1 1 13 30 0 instant <timestamp> <=> ] unit-test
 
-[ 1 ] [ 2005 1 1 12 30 0 instant <timestamp>
+[ +gt+ ] [ 2005 1 1 12 30 0 instant <timestamp>
         2004 1 1 13 30 0 instant <timestamp> <=> ] unit-test
 
 [ t ] [ now timestamp>millis millis - 1000 < ] unit-test

extra/calendar/format/format.factor

@@ -87,10 +87,10 @@ M: timestamp year. ( timestamp -- )
     [ hh ] [ mm ] bi ;
 
 : write-gmt-offset ( gmt-offset -- )
-    dup instant <=> sgn {
+    dup instant <=> {
-        {  0 [ drop "GMT" write ] }
+        { +eq+ [ drop "GMT" write ] }
-        { -1 [ "-" write before (write-gmt-offset) ] }
+        { +lt+ [ "-" write before (write-gmt-offset) ] }
-        {  1 [ "+" write (write-gmt-offset) ] }
+        { +gt+ [ "+" write (write-gmt-offset) ] }
     } case ;
 
 : timestamp>rfc822 ( timestamp -- str )
@@ -118,10 +118,10 @@ M: timestamp year. ( timestamp -- )
     [ hh ":" write ] [ mm ] bi ;
 
 : write-rfc3339-gmt-offset ( duration -- )
-    dup instant <=> sgn {
+    dup instant <=> {
-        {  0 [ drop "Z" write ] }
+        { +eq+ [ drop "Z" write ] }
-        { -1 [ "-" write before (write-rfc3339-gmt-offset) ] }
+        { +lt+ [ "-" write before (write-rfc3339-gmt-offset) ] }
-        {  1 [ "+" write (write-rfc3339-gmt-offset) ] }
+        { +gt+ [ "+" write (write-rfc3339-gmt-offset) ] }
     } case ;
     
 : (timestamp>rfc3339) ( timestamp -- )

extra/csv/authors.txt

@@ -0,0 +1 @@
+Phil Dawes

extra/csv/csv-docs.factor

@@ -0,0 +1,14 @@
+USING: help.syntax help.markup kernel prettyprint sequences ;
+IN: csv
+
+HELP: csv
+{ $values { "stream" "a stream" }
+          { "rows" "an array of arrays of fields" } } 
+{ $description "parses a csv stream into an array of row arrays"
+} ;
+
+HELP: csv-row
+{ $values { "stream" "a stream" }
+          { "row" "an array of fields" } } 
+{ $description "parses a row from a csv stream"
+} ;

extra/csv/csv-tests.factor

@@ -0,0 +1,61 @@
+USING: io.streams.string csv tools.test shuffle ;
+IN: csv.tests
+
+! I like to name my unit tests
+: named-unit-test ( name output input -- ) 
+  nipd unit-test ; inline
+
+! tests nicked from the wikipedia csv article
+! http://en.wikipedia.org/wiki/Comma-separated_values
+
+"Fields are separated by commas"
+[ { { "1997" "Ford" "E350" } } ] 
+[ "1997,Ford,E350" <string-reader> csv ] named-unit-test
+
+"ignores whitespace before and after elements. n.b.specifically prohibited by RFC 4180, which states, 'Spaces are considered part of a field and should not be ignored.'"
+[ { { "1997" "Ford" "E350" } } ]
+[ "1997,   Ford   , E350" <string-reader> csv ] named-unit-test
+
+"keeps spaces in quotes"
+[ { { "1997" "Ford" "E350" "Super, luxurious truck" } } ]
+[ "1997,Ford,E350,\"Super, luxurious truck\"" <string-reader> csv ] named-unit-test
+
+"double quotes mean escaped in quotes"
+[ { { "1997" "Ford" "E350" "Super \"luxurious\" truck" } } ]
+[ "1997,Ford,E350,\"Super \"\"luxurious\"\" truck\"" 
+  <string-reader> csv ] named-unit-test
+
+"Fields with embedded line breaks must be delimited by double-quote characters."
+[ { { "1997" "Ford" "E350" "Go get one now\nthey are going fast" } } ]
+[ "1997,Ford,E350,\"Go get one now\nthey are going fast\""
+  <string-reader> csv ] named-unit-test
+
+"Fields with leading or trailing spaces must be delimited by double-quote characters. (See comment about leading and trailing spaces above)"
+[ { { "1997" "Ford" "E350" "  Super luxurious truck    " } } ]
+[ "1997,Ford,E350,\"  Super luxurious truck    \""
+  <string-reader> csv ] named-unit-test
+
+"Fields may always be delimited by double-quote characters, whether necessary or not."
+[ { { "1997" "Ford" "E350" } } ]
+[ "\"1997\",\"Ford\",\"E350\"" <string-reader> csv ] named-unit-test
+
+"The first record in a csv file may contain column names in each of the fields."
+[ { { "Year" "Make" "Model" } 
+    { "1997" "Ford" "E350" }
+    { "2000" "Mercury" "Cougar" } } ]
+[ "Year,Make,Model\n1997,Ford,E350\n2000,Mercury,Cougar" 
+   <string-reader> csv ] named-unit-test
+
+
+   
+! !!!!!!!!  other tests
+   
+[ { { "Phil Dawes" } } ] 
+[ "\"Phil Dawes\"" <string-reader> csv ] unit-test
+
+[ { { "1" "2" "3" } { "4" "5" "6" } } ] 
+[ "1,2,3\n4,5,6\n" <string-reader> csv ] unit-test
+
+"trims leading and trailing whitespace - n.b. this isn't really conformant, but lots of csv seems to assume this"
+[ { { "foo yeah" "bah" "baz" } } ] 
+[ "  foo yeah  , bah ,baz\n" <string-reader> csv ] named-unit-test

extra/csv/csv.factor

@@ -0,0 +1,60 @@
+! Copyright (C) 2007, 2008 Phil Dawes
+! See http://factorcode.org/license.txt for BSD license.
+
+! Simple CSV Parser
+! Phil Dawes phil@phildawes.net
+
+USING: kernel sequences io namespaces combinators
+unicode.categories ;
+IN: csv
+
+DEFER: quoted-field
+
+: not-quoted-field ( -- endchar )
+  ",\"\n" read-until   ! "
+  dup
+  { { CHAR: "   [ drop drop quoted-field ] }  ! " 
+    { CHAR: ,   [ swap % ] } 
+    { CHAR: \n  [ swap % ] }    
+    { f         [ swap % ] }       ! eof
+  } case ;
+  
+: maybe-escaped-quote ( -- endchar )
+  read1 
+  dup
+  { { CHAR: "   [ , quoted-field ] }     ! " is an escaped quote
+    { CHAR: \s  [ drop not-quoted-field ] } 
+    { CHAR: \t  [ drop not-quoted-field ] } 
+    [ drop ]
+  } case ;
+
+! trims whitespace from either end of string
+: trim-whitespace ( str -- str )
+  [ blank? ] trim ; inline
+  
+: quoted-field ( -- endchar )
+  "\"" read-until                                 ! "
+  drop % maybe-escaped-quote ;
+
+: field ( -- sep string )
+  [ not-quoted-field ] "" make trim-whitespace ;
+
+: (row) ( -- sep )
+  field , 
+  dup CHAR: , = [ drop (row) ] when ;
+
+: row ( -- eof? array[string] )
+  [ (row) ] { } make ;
+
+: append-if-row-not-empty ( row -- )
+  dup { "" } = [ drop ] [ , ] if ;
+
+: (csv) ( -- )
+  row append-if-row-not-empty
+  [ (csv) ] when ;
+
+: csv-row ( stream -- row )
+  [ row nip ] with-stream ;
+
+: csv ( stream -- rows )
+  [ [ (csv) ] { } make ] with-stream ;

extra/csv/summary.txt

@@ -0,0 +1 @@
+CSV parser

extra/db/db.factor

@@ -35,7 +35,6 @@ HOOK: db-close db ( handle -- )
         handle>> db-close
     ] with-variable ;
 
-! TUPLE: sql sql in-params out-params ;
 TUPLE: statement handle sql in-params out-params bind-params bound? type ;
 TUPLE: simple-statement < statement ;
 TUPLE: prepared-statement < statement ;

extra/db/postgresql/lib/lib.factor

@@ -154,7 +154,7 @@ M: postgresql-malloc-destructor dispose ( obj -- )
 : postgresql-column-typed ( handle row column type -- obj )
     dup array? [ first ] when
     {
-        { +native-id+ [ pq-get-number ] }
+        { +db-assigned-id+ [ pq-get-number ] }
         { +random-id+ [ pq-get-number ] }
         { INTEGER [ pq-get-number ] }
         { BIG-INTEGER [ pq-get-number ] }

extra/db/postgresql/postgresql.factor

@@ -6,6 +6,7 @@ sequences debugger db db.postgresql.lib db.postgresql.ffi
 db.tuples db.types tools.annotations math.ranges
 combinators sequences.lib classes locals words tools.walker
 namespaces.lib accessors random db.queries ;
+USE: tools.walker
 IN: db.postgresql
 
 TUPLE: postgresql-db < db
@@ -48,7 +49,8 @@ M: literal-bind postgresql-bind-conversion ( tuple literal-bind -- obj )
     nip value>> <low-level-binding> ;
 
 M: generator-bind postgresql-bind-conversion ( tuple generate-bind -- obj )
-    nip singleton>> eval-generator <low-level-binding> ;
+    dup generator-singleton>> eval-generator
+    [ swap slot-name>> rot set-slot-named ] [ <low-level-binding> ] bi ;
 
 M: postgresql-statement bind-tuple ( tuple statement -- )
     tuck in-params>>
@@ -158,7 +160,7 @@ M: postgresql-db bind# ( spec obj -- )
 M: postgresql-db create-sql-statement ( class -- seq )
     [
         [ create-table-sql , ] keep
-        dup db-columns find-primary-key native-id?
+        dup db-columns find-primary-key db-assigned-id-spec?
         [ create-function-sql , ] [ drop ] if
     ] { } make ;
 
@@ -179,11 +181,11 @@ M: postgresql-db create-sql-statement ( class -- seq )
 M: postgresql-db drop-sql-statement ( class -- seq )
     [
         [ drop-table-sql , ] keep
-        dup db-columns find-primary-key native-id?
+        dup db-columns find-primary-key db-assigned-id-spec?
         [ drop-function-sql , ] [ drop ] if
     ] { } make ;
 
-M: postgresql-db <insert-native-statement> ( class -- statement )
+M: postgresql-db <insert-db-assigned-statement> ( class -- statement )
     [
         "select add_" 0% 0%
         "(" 0%
@@ -193,7 +195,7 @@ M: postgresql-db <insert-native-statement> ( class -- statement )
         ");" 0%
     ] query-make ;
 
-M: postgresql-db <insert-nonnative-statement> ( class -- statement )
+M: postgresql-db <insert-user-assigned-statement> ( class -- statement )
     [
         "insert into " 0% 0%
         "(" 0%
@@ -204,8 +206,10 @@ M: postgresql-db <insert-nonnative-statement> ( class -- statement )
         [ ", " 0% ] [
             dup type>> +random-id+ = [
                 [
-                    drop bind-name%
+                    bind-name%
-                    f random-id-generator
+                    slot-name>>
+                    f
+                    random-id-generator
                 ] [ type>> ] bi <generator-bind> 1,
             ] [
                 bind%
@@ -219,8 +223,8 @@ M: postgresql-db insert-tuple* ( tuple statement -- )
 
 M: postgresql-db persistent-table ( -- hashtable )
     H{
-        { +native-id+ { "integer" "serial primary key" f } }
+        { +db-assigned-id+ { "integer" "serial primary key" f } }
-        { +assigned-id+ { f f "primary key" } }
+        { +user-assigned-id+ { f f "primary key" } }
         { +random-id+ { "bigint" "bigint primary key" f } }
         { TEXT { "text" "text" f } }
         { VARCHAR { "varchar" "varchar" f } }

extra/db/queries/queries.factor

@@ -15,7 +15,7 @@ GENERIC: where ( specs obj -- )
 
 : query-make ( class quot -- )
     >r sql-props r>
-    [ 0 sql-counter rot with-variable ] { "" { } { } } nmake
+    [ 0 sql-counter rot with-variable ";" 0% ] { "" { } { } } nmake
     <simple-statement> maybe-make-retryable ; inline
 
 M: db begin-transaction ( -- ) "BEGIN" sql-command ;
@@ -35,14 +35,6 @@ M: db <update-tuple-statement> ( class -- statement )
         where-primary-key%
     ] query-make ;
 
-M: db <delete-tuple-statement> ( specs table -- sql )
-    [
-        "delete from " 0% 0%
-        " where " 0%
-        find-primary-key
-        dup column-name>> 0% " = " 0% bind%
-    ] query-make ;
-
 M: random-id-generator eval-generator ( singleton -- obj )
     drop
     system-random-generator get [
@@ -52,18 +44,40 @@ M: random-id-generator eval-generator ( singleton -- obj )
 : interval-comparison ( ? str -- str )
     "from" = " >" " <" ? swap [ "= " append ] when ;
 
+: fp-infinity? ( float -- ? )
+    dup float? [
+        double>bits -52 shift 11 2^ 1- [ bitand ] keep =
+    ] [
+        drop f
+    ] if ;
+
+: (infinite-interval?) ( interval -- ?1 ?2 )
+    [ from>> ] [ to>> ] bi
+    [ first fp-infinity? ] bi@ ;
+
+: double-infinite-interval? ( obj -- ? )
+    dup interval? [ (infinite-interval?) and ] [ drop f ] if ;
+
+: infinite-interval? ( obj -- ? )
+    dup interval? [ (infinite-interval?) or ] [ drop f ] if ;
+
 : where-interval ( spec obj from/to -- )
+    over first fp-infinity? [
+        3drop
+    ] [
         pick column-name>> 0%
         >r first2 r> interval-comparison 0%
-    bind# ;
+        bind#
+    ] if ;
 
 : in-parens ( quot -- )
     "(" 0% call ")" 0% ; inline
 
 M: interval where ( spec obj -- )
     [
-        [ from>> "from" where-interval " and " 0% ]
+        [ from>> "from" where-interval ] [
-        [ to>> "to" where-interval ] 2bi
+            nip infinite-interval? [ " and " 0% ] unless
+        ] [ to>> "to" where-interval ] 2tri
     ] in-parens ;
 
 M: sequence where ( spec obj -- )
@@ -80,12 +94,29 @@ M: integer where ( spec obj -- ) object-where ;
 
 M: string where ( spec obj -- ) object-where ;
 
+: filter-slots ( tuple specs -- specs' )
+    [
+        slot-name>> swap get-slot-named
+        dup double-infinite-interval? [ drop f ] when
+    ] with filter ;
+
 : where-clause ( tuple specs -- )
+    dupd filter-slots
+    dup empty? [
+        2drop
+    ] [
         " where " 0% [
             " and " 0%
         ] [
             2dup slot-name>> swap get-slot-named where
-    ] interleave drop ;
+        ] interleave drop
+    ] if ;
+
+M: db <delete-tuples-statement> ( tuple table -- sql )
+    [
+        "delete from " 0% 0%
+        where-clause
+    ] query-make ;
 
 M: db <select-by-slots-statement> ( tuple class -- statement )
     [
@@ -94,7 +125,5 @@ M: db <select-by-slots-statement> ( tuple class -- statement )
         [ dup column-name>> 0% 2, ] interleave
 
         " from " 0% 0%
-        dupd
+        where-clause
-        [ slot-name>> swap get-slot-named ] with filter
-        dup empty? [ 2drop ] [ where-clause ] if ";" 0%
     ] query-make ;

extra/db/sql/sql.factor

@@ -1,7 +1,6 @@
 USING: kernel parser quotations classes.tuple words math.order
 namespaces.lib namespaces sequences arrays combinators
 prettyprint strings math.parser sequences.lib math symbols ;
-USE: tools.walker
 IN: db.sql
 
 SYMBOLS: insert update delete select distinct columns from as

extra/db/sqlite/lib/lib.factor

@@ -4,7 +4,7 @@ USING: alien.c-types arrays assocs kernel math math.parser
 namespaces sequences db.sqlite.ffi db combinators
 continuations db.types calendar.format serialize
 io.streams.byte-array byte-arrays io.encodings.binary
-tools.walker io.backend ;
+io.backend ;
 IN: db.sqlite.lib
 
 : sqlite-error ( n -- * )
@@ -106,7 +106,7 @@ IN: db.sqlite.lib
             object>bytes
             sqlite-bind-blob-by-name
         ] }
-        { +native-id+ [ sqlite-bind-int-by-name ] }
+        { +db-assigned-id+ [ sqlite-bind-int-by-name ] }
         { +random-id+ [ sqlite-bind-int64-by-name ] }
         { NULL [ sqlite-bind-null-by-name ] }
         [ no-sql-type ]
@@ -132,7 +132,7 @@ IN: db.sqlite.lib
 : sqlite-column-typed ( handle index type -- obj )
     dup array? [ first ] when
     {
-        { +native-id+ [ sqlite3_column_int64  ] }
+        { +db-assigned-id+ [ sqlite3_column_int64  ] }
         { +random-id+ [ sqlite3-column-uint64 ] }
         { INTEGER [ sqlite3_column_int ] }
         { BIG-INTEGER [ sqlite3_column_int64 ] }

extra/db/sqlite/sqlite.factor

@@ -79,8 +79,10 @@ M: literal-bind sqlite-bind-conversion ( tuple literal-bind -- array )
     <sqlite-low-level-binding> ;
 
 M: generator-bind sqlite-bind-conversion ( tuple generate-bind -- array )
-    nip [ key>> ] [ singleton>> eval-generator ] [ type>> ] tri
+    tuck
-    <sqlite-low-level-binding> ;
+    [ generator-singleton>> eval-generator tuck ] [ slot-name>> ] bi
+    rot set-slot-named
+    >r [ key>> ] [ type>> ] bi r> swap <sqlite-low-level-binding> ;
 
 M: sqlite-statement bind-tuple ( tuple statement -- )
     [
@@ -129,19 +131,20 @@ M: sqlite-db create-sql-statement ( class -- statement )
 M: sqlite-db drop-sql-statement ( class -- statement )
     [ "drop table " 0% 0% ";" 0% drop ] query-make ;
 
-M: sqlite-db <insert-native-statement> ( tuple -- statement )
+M: sqlite-db <insert-db-assigned-statement> ( tuple -- statement )
     [
         "insert into " 0% 0%
         "(" 0%
-        maybe-remove-id
+        remove-db-assigned-id
         dup [ ", " 0% ] [ column-name>> 0% ] interleave
         ") values(" 0%
         [ ", " 0% ] [
             dup type>> +random-id+ = [
+                [ slot-name>> ]
                 [
                     column-name>> ":" prepend dup 0%
                     random-id-generator
-                ] [ type>> ] bi <generator-bind> 1,
+                ] [ type>> ] tri <generator-bind> 1,
             ] [
                 bind%
             ] if
@@ -149,8 +152,8 @@ M: sqlite-db <insert-native-statement> ( tuple -- statement )
         ");" 0%
     ] query-make ;
 
-M: sqlite-db <insert-nonnative-statement> ( tuple -- statement )
+M: sqlite-db <insert-user-assigned-statement> ( tuple -- statement )
-    <insert-native-statement> ;
+    <insert-db-assigned-statement> ;
 
 M: sqlite-db bind# ( spec obj -- )
     >r
@@ -163,8 +166,8 @@ M: sqlite-db bind% ( spec -- )
 
 M: sqlite-db persistent-table ( -- assoc )
     H{
-        { +native-id+ { "integer primary key" "integer primary key" "primary key" } }
+        { +db-assigned-id+ { "integer primary key" "integer primary key" "primary key" } }
-        { +assigned-id+ { f f "primary key" } }
+        { +user-assigned-id+ { f f "primary key" } }
         { +random-id+ { "integer primary key" "integer primary key" "primary key" } }
         { INTEGER { "integer" "integer" "primary key" } }
         { BIG-INTEGER { "bigint" "bigint" } }

extra/db/tuples/tuples-tests.factor

@@ -2,8 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: io.files kernel tools.test db db.tuples classes
 db.types continuations namespaces math math.ranges
-prettyprint tools.walker calendar sequences db.sqlite
+prettyprint calendar sequences db.sqlite math.intervals
-math.intervals db.postgresql accessors random math.bitfields.lib ;
+db.postgresql accessors random math.bitfields.lib ;
 IN: db.tuples.tests
 
 TUPLE: person the-id the-name the-number the-real
@@ -21,7 +21,7 @@ ts date time blob factor-blob ;
         set-person-factor-blob
     } person construct ;
 
-: <assigned-person> ( id name age real ts date time blob factor-blob -- person )
+: <user-assigned-person> ( id name age real ts date time blob factor-blob -- person )
     <person> [ set-person-the-id ] keep ;
 
 SYMBOL: person1
@@ -30,6 +30,7 @@ SYMBOL: person3
 SYMBOL: person4
 
 : test-tuples ( -- )
+    [ ] [ person recreate-table ] unit-test
     [ ] [ person ensure-table ] unit-test
     [ ] [ person drop-table ] unit-test
     [ ] [ person create-table ] unit-test
@@ -67,7 +68,7 @@ SYMBOL: person4
     ] [ T{ person f f f 10 3.14 } select-tuples ] unit-test
 
 
-    [ ] [ person1 get delete-tuple ] unit-test
+    [ ] [ person1 get delete-tuples ] unit-test
     [ f ] [ T{ person f 1 } select-tuple ] unit-test
 
     [ ] [ person3 get insert-tuple ] unit-test
@@ -106,10 +107,10 @@ SYMBOL: person4
 
     [ ] [ person drop-table ] unit-test ;
 
-: native-person-schema ( -- )
+: db-assigned-person-schema ( -- )
     person "PERSON"
     {
-        { "the-id" "ID" +native-id+ }
+        { "the-id" "ID" +db-assigned-id+ }
         { "the-name" "NAME" { VARCHAR 256 } +not-null+ }
         { "the-number" "AGE" INTEGER { +default+ 0 } }
         { "the-real" "REAL" DOUBLE { +default+ 0.3 } }
@@ -132,10 +133,10 @@ SYMBOL: person4
         T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } }
         f H{ { 1 2 } { 3 4 } { 5 "lol" } } <person> person4 set ;
 
-: assigned-person-schema ( -- )
+: user-assigned-person-schema ( -- )
     person "PERSON"
     {
-        { "the-id" "ID" INTEGER +assigned-id+ }
+        { "the-id" "ID" INTEGER +user-assigned-id+ }
         { "the-name" "NAME" { VARCHAR 256 } +not-null+ }
         { "the-number" "AGE" INTEGER { +default+ 0 } }
         { "the-real" "REAL" DOUBLE { +default+ 0.3 } }
@@ -145,27 +146,27 @@ SYMBOL: person4
         { "blob" "B" BLOB }
         { "factor-blob" "FB" FACTOR-BLOB }
     } define-persistent
-    1 "billy" 10 3.14 f f f f f <assigned-person> person1 set
+    1 "billy" 10 3.14 f f f f f <user-assigned-person> person1 set
-    2 "johnny" 10 3.14 f f f f f <assigned-person> person2 set
+    2 "johnny" 10 3.14 f f f f f <user-assigned-person> person2 set
     3 "teddy" 10 3.14
         T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
         T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
         T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } }
         B{ 115 116 111 114 101 105 110 97 98 108 111 98 }
-        f <assigned-person> person3 set
+        f <user-assigned-person> person3 set
     4 "eddie" 10 3.14
         T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
         T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
         T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } }
-        f H{ { 1 2 } { 3 4 } { 5 "lol" } } <assigned-person> person4 set ;
+        f H{ { 1 2 } { 3 4 } { 5 "lol" } } <user-assigned-person> person4 set ;
 
 TUPLE: paste n summary author channel mode contents timestamp annotations ;
 TUPLE: annotation n paste-id summary author mode contents ;
 
-: native-paste-schema ( -- )
+: db-assigned-paste-schema ( -- )
     paste "PASTE"
     {
-        { "n" "ID" +native-id+ }
+        { "n" "ID" +db-assigned-id+ }
         { "summary" "SUMMARY" TEXT }
         { "author" "AUTHOR" TEXT }
         { "channel" "CHANNEL" TEXT }
@@ -177,7 +178,7 @@ TUPLE: annotation n paste-id summary author mode contents ;
 
     annotation "ANNOTATION"
     {
-        { "n" "ID" +native-id+ }
+        { "n" "ID" +db-assigned-id+ }
         { "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "n" } }
         { "summary" "SUMMARY" TEXT }
         { "author" "AUTHOR" TEXT }
@@ -210,7 +211,7 @@ TUPLE: serialize-me id data ;
 : test-serialize ( -- )
     serialize-me "SERIALIZED"
     {
-        { "id" "ID" +native-id+ }
+        { "id" "ID" +db-assigned-id+ }
         { "data" "DATA" FACTOR-BLOB }
     } define-persistent
     [ serialize-me drop-table ] [ drop ] recover
@@ -226,7 +227,7 @@ TUPLE: exam id name score ;
 : test-intervals ( -- )
     exam "EXAM"
     {
-        { "id" "ID" +native-id+ }
+        { "id" "ID" +db-assigned-id+ }
         { "name" "NAME" TEXT }
         { "score" "SCORE" INTEGER }
     } define-persistent
@@ -292,6 +293,46 @@ TUPLE: exam id name score ;
         }
     ] [
         T{ exam f T{ range f 1 3 1 } } select-tuples
+    ] unit-test
+
+    [
+        {
+            T{ exam f 2 "Stan" 80 }
+            T{ exam f 3 "Kenny" 60 }
+            T{ exam f 4 "Cartman" 41 }
+        }
+    ] [
+        T{ exam f T{ interval f { 2 t } { 1.0/0.0 f } } } select-tuples
+    ] unit-test
+
+    [
+        {
+            T{ exam f 1 "Kyle" 100 }
+        }
+    ] [
+        T{ exam f T{ interval f { -1.0/0.0 t } { 2 f } } } select-tuples
+    ] unit-test
+
+    [
+        {
+            T{ exam f 1 "Kyle" 100 }
+            T{ exam f 2 "Stan" 80 }
+            T{ exam f 3 "Kenny" 60 }
+            T{ exam f 4 "Cartman" 41 }
+        }
+    ] [
+        T{ exam f T{ interval f { -1.0/0.0 t } { 1/0. f } } } select-tuples
+    ] unit-test
+    
+    [
+        {
+            T{ exam f 1 "Kyle" 100 }
+            T{ exam f 2 "Stan" 80 }
+            T{ exam f 3 "Kenny" 60 }
+            T{ exam f 4 "Cartman" 41 }
+        }
+    ] [
+        T{ exam } select-tuples
     ] unit-test ;
 
 TUPLE: bignum-test id m n o ;
@@ -304,7 +345,7 @@ TUPLE: bignum-test id m n o ;
 : test-bignum
     bignum-test "BIGNUM_TEST"
     {
-        { "id" "ID" +native-id+ }
+        { "id" "ID" +db-assigned-id+ }
         { "m" "M" BIG-INTEGER }
         { "n" "N" UNSIGNED-BIG-INTEGER }
         { "o" "O" SIGNED-BIG-INTEGER }
@@ -328,9 +369,9 @@ C: <secret> secret
         { "message" "MESSAGE" TEXT }
     } define-persistent
 
-    [ ] [ secret ensure-table ] unit-test
+    [ ] [ secret recreate-table ] unit-test
 
-    [ ] [ f "kilroy was here" <secret> insert-tuple ] unit-test
+    [ t ] [ f "kilroy was here" <secret> [ insert-tuple ] keep n>> integer? ] unit-test
 
     [ ] [ f "kilroy was here2" <secret> insert-tuple ] unit-test
 
@@ -345,17 +386,17 @@ C: <secret> secret
         T{ secret } select-tuples length 3 =
     ] unit-test ;
 
-[ native-person-schema test-tuples ] test-sqlite
+[ db-assigned-person-schema test-tuples ] test-sqlite
-[ assigned-person-schema test-tuples ] test-sqlite
+[ user-assigned-person-schema test-tuples ] test-sqlite
-[ assigned-person-schema test-repeated-insert ] test-sqlite
+[ user-assigned-person-schema test-repeated-insert ] test-sqlite
 [ test-bignum ] test-sqlite
 [ test-serialize ] test-sqlite
 [ test-intervals ] test-sqlite
 [ test-random-id ] test-sqlite
 
-[ native-person-schema test-tuples ] test-postgresql
+[ db-assigned-person-schema test-tuples ] test-postgresql
-[ assigned-person-schema test-tuples ] test-postgresql
+[ user-assigned-person-schema test-tuples ] test-postgresql
-[ assigned-person-schema test-repeated-insert ] test-postgresql
+[ user-assigned-person-schema test-repeated-insert ] test-postgresql
 [ test-bignum ] test-postgresql
 [ test-serialize ] test-postgresql
 [ test-intervals ] test-postgresql
@@ -377,7 +418,7 @@ TUPLE: does-not-persist ;
 \ bind-tuple must-infer
 \ insert-tuple must-infer
 \ update-tuple must-infer
-\ delete-tuple must-infer
+\ delete-tuples must-infer
 \ select-tuple must-infer
 \ define-persistent must-infer
 \ ensure-table must-infer

extra/db/tuples/tuples.factor

@@ -3,7 +3,7 @@
 USING: arrays assocs classes db kernel namespaces
 classes.tuple words sequences slots math accessors
 math.parser io prettyprint db.types continuations
-mirrors sequences.lib tools.walker combinators.lib ;
+mirrors sequences.lib combinators.lib ;
 IN: db.tuples
 
 : define-persistent ( class table columns -- )
@@ -37,15 +37,10 @@ SYMBOL: sql-counter
 HOOK: create-sql-statement db ( class -- obj )
 HOOK: drop-sql-statement db ( class -- obj )
 
-HOOK: <insert-native-statement> db ( class -- obj )
+HOOK: <insert-db-assigned-statement> db ( class -- obj )
-HOOK: <insert-nonnative-statement> db ( class -- obj )
+HOOK: <insert-user-assigned-statement> db ( class -- obj )
-
 HOOK: <update-tuple-statement> db ( class -- obj )
-HOOK: <update-tuples-statement> db ( class -- obj )
+HOOK: <delete-tuples-statement> db ( tuple class -- obj )
-
-HOOK: <delete-tuple-statement> db ( class -- obj )
-HOOK: <delete-tuples-statement> db ( class -- obj )
-
 HOOK: <select-by-slots-statement> db ( tuple class -- tuple )
 
 HOOK: insert-tuple* db ( tuple statement -- )
@@ -65,7 +60,7 @@ SINGLETON: retryable
     [ bind-params>> ] [ in-params>> ] bi
     [
         dup generator-bind? [
-            singleton>> eval-generator >>value
+            generator-singleton>> eval-generator >>value
         ] [
             drop
         ] if
@@ -113,35 +108,38 @@ M: retryable execute-statement* ( statement type -- )
 : drop-table ( class -- )
     drop-sql-statement [ execute-statement ] with-disposals ;
 
-: ensure-table ( class -- )
+: recreate-table ( class -- )
     [
         drop-sql-statement make-nonthrowable
         [ execute-statement ] with-disposals
     ] [ create-table ] bi ;
 
-: insert-native ( tuple -- )
+: ensure-table ( class -- )
+    [ create-table ] curry ignore-errors ;
+
+: insert-db-assigned-statement ( tuple -- )
     dup class
-    db get db-insert-statements [ <insert-native-statement> ] cache
+    db get db-insert-statements [ <insert-db-assigned-statement> ] cache
     [ bind-tuple ] 2keep insert-tuple* ;
 
-: insert-nonnative ( tuple -- )
+: insert-user-assigned-statement ( tuple -- )
     dup class
-    db get db-insert-statements [ <insert-nonnative-statement> ] cache
+    db get db-insert-statements [ <insert-user-assigned-statement> ] cache
     [ bind-tuple ] keep execute-statement ;
 
 : insert-tuple ( tuple -- )
-    dup class db-columns find-primary-key nonnative-id?
+    dup class db-columns find-primary-key db-assigned-id-spec?
-    [ insert-nonnative ] [ insert-native ] if ;
+    [ insert-db-assigned-statement ] [ insert-user-assigned-statement ] if ;
 
 : update-tuple ( tuple -- )
     dup class
     db get db-update-statements [ <update-tuple-statement> ] cache
     [ bind-tuple ] keep execute-statement ;
 
-: delete-tuple ( tuple -- )
+: delete-tuples ( tuple -- )
-    dup class
+    dup dup class <delete-tuples-statement> [
-    db get db-delete-statements [ <delete-tuple-statement> ] cache
+        [ bind-tuple ] keep execute-statement
-    [ bind-tuple ] keep execute-statement ;
+    ] with-disposal ;
 
 : select-tuples ( tuple -- tuples )
     dup dup class <select-by-slots-statement> [

extra/db/types/types.factor

@@ -2,8 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays assocs db kernel math math.parser
 sequences continuations sequences.deep sequences.lib
-words namespaces tools.walker slots slots.private classes
+words namespaces slots slots.private classes mirrors
-mirrors classes.tuple combinators calendar.format symbols
+classes.tuple combinators calendar.format symbols
 classes.singleton accessors quotations random ;
 IN: db.types
 
@@ -15,18 +15,17 @@ TUPLE: sql-spec class slot-name column-name type primary-key modifiers ;
 TUPLE: literal-bind key type value ;
 C: <literal-bind> literal-bind
 
-TUPLE: generator-bind key singleton type ;
+TUPLE: generator-bind slot-name key generator-singleton type ;
 C: <generator-bind> generator-bind
 SINGLETON: random-id-generator
 
 TUPLE: low-level-binding value ;
 C: <low-level-binding> low-level-binding
 
-SINGLETON: +native-id+
+SINGLETON: +db-assigned-id+
-SINGLETON: +assigned-id+
+SINGLETON: +user-assigned-id+
 SINGLETON: +random-id+
-UNION: +primary-key+ +native-id+ +assigned-id+ +random-id+ ;
+UNION: +primary-key+ +db-assigned-id+ +user-assigned-id+ +random-id+ ;
-UNION: +nonnative-id+ +random-id+ +assigned-id+ ;
 
 SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+
 +foreign-id+ +has-many+ ;
@@ -43,11 +42,11 @@ SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+
 : primary-key? ( spec -- ? )
     primary-key>> +primary-key+? ;
 
-: native-id? ( spec -- ? )
+: db-assigned-id-spec? ( spec -- ? )
-    primary-key>> +native-id+? ;
+    primary-key>> +db-assigned-id+? ;
 
-: nonnative-id? ( spec -- ? )
+: assigned-id-spec? ( spec -- ? )
-    primary-key>> +nonnative-id+? ;
+    primary-key>> +user-assigned-id+? ;
 
 : normalize-spec ( spec -- )
     dup type>> dup +primary-key+? [
@@ -82,8 +81,8 @@ FACTOR-BLOB NULL ;
 : number>string* ( n/str -- str )
     dup number? [ number>string ] when ;
 
-: maybe-remove-id ( specs -- obj )
+: remove-db-assigned-id ( specs -- obj )
-    [ +native-id+? not ] filter ;
+    [ +db-assigned-id+? not ] filter ;
 
 : remove-relations ( specs -- newcolumns )
     [ relation? not ] filter ;

extra/help/handbook/handbook.factor

@@ -104,6 +104,7 @@ $nl
 ARTICLE: "objects" "Objects"
 "An " { $emphasis "object" } " is any datum which may be identified. All values are objects in Factor. Each object carries type information, and types are checked at runtime; Factor is dynamically typed."
 { $subsection "equality" }
+{ $subsection "math.order" }
 { $subsection "classes" }
 { $subsection "tuples" }
 { $subsection "generic" }

extra/help/help-docs.factor

@@ -113,7 +113,7 @@ ARTICLE: "help" "Help system"
 "The help system maintains documentation written in a simple markup language, along with cross-referencing and search. Documentation can either exist as free-standing " { $emphasis "articles" } " or be associated with words."
 { $subsection "browsing-help" }
 { $subsection "writing-help" }
-{ $subsection "help.lint" }
+{ $vocab-subsection "Help lint tool" "help.lint" }
 { $subsection "help-impl" } ;
 
 IN: help

extra/http/http-tests.factor

@@ -134,8 +134,7 @@ read-response-test-1' 1array [
 
 ! Live-fire exercise
 USING: http.server http.server.static http.server.sessions
-http.server.sessions.storage.db http.server.actions
+http.server.actions http.server.auth.login http.server.db http.client
-http.server.auth.login http.server.db http.client
 io.server io.files io io.encodings.ascii
 accessors namespaces threads ;
 
@@ -194,8 +193,7 @@ test-db [
         <dispatcher>
             <action> <protected>
             <login>
-            <session-manager>
+            <sessions>
-                sessions-in-db >>sessions
             "" add-responder
             add-quit-action
             <dispatcher>
@@ -225,8 +223,7 @@ test-db [
         <dispatcher>
             <action> [ "text/plain" <content> [ "Hi" write ] >>body ] >>display
             <login>
-            <session-manager>
+            <sessions>
-                sessions-in-db >>sessions
             "" add-responder
             add-quit-action
         test-db <db-persistence>

extra/http/http.factor

@@ -329,7 +329,8 @@ SYMBOL: max-post-request
     [ host>> ] [ port>> ] bi <inet> ;
 
 : request-host ( request -- string )
-    [ host>> ] [ drop ":" ] [ port>> number>string ] tri 3append ;
+    [ host>> ] [ port>> ] bi
+    dup 80 = [ drop ] [ ":" swap number>string 3append ] if ;
 
 : write-request-header ( request -- request )
     dup header>> >hashtable

extra/http/server/auth/admin/admin.factor

@@ -0,0 +1,152 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences accessors namespaces combinators
+locals db.tuples
+http.server.templating.chloe
+http.server.boilerplate
+http.server.auth.providers
+http.server.auth.providers.db
+http.server.auth.login
+http.server.forms
+http.server.components.inspector
+http.server.components
+http.server.validators
+http.server.sessions
+http.server.actions
+http.server.crud
+http.server ;
+IN: http.server.auth.admin
+
+: admin-template ( name -- template )
+    "resource:extra/http/server/auth/admin/" swap ".xml" 3append <chloe> ;
+
+: <new-user-form> ( -- form )
+    "user" <form>
+        "new-user" admin-template >>edit-template
+        "username" <string> add-field
+        "realname" <string> add-field
+        "new-password" <password> t >>required add-field
+        "verify-password" <password> t >>required add-field
+        "email" <email> add-field ;
+
+: <edit-user-form> ( -- form )
+    "user" <form>
+        "edit-user" admin-template >>edit-template
+        "user-summary" admin-template >>summary-template
+        "username" <string> hidden >>renderer add-field
+        "realname" <string> add-field
+        "new-password" <password> add-field
+        "verify-password" <password> add-field
+        "email" <email> add-field
+        "profile" <inspector> add-field ;
+
+: <user-list-form> ( -- form )
+    "user-list" <form>
+        "user-list" admin-template >>view-template
+        "list" <edit-user-form> +unordered+ <list> add-field ;
+
+:: <new-user-action> ( form ctor next -- action )
+    <action>
+        [
+            blank-values
+
+            "username" get ctor call
+
+            {
+                [ username>> "username" set-value ]
+                [ realname>> "realname" set-value ]
+                [ email>> "email" set-value ]
+                [ profile>> "profile" set-value ]
+            } cleave
+        ] >>init
+
+        [ form edit-form ] >>display
+
+        [
+            blank-values
+
+            form validate-form
+
+            same-password-twice
+
+            user new "username" value >>username select-tuple [
+                user-exists? on
+                validation-failed
+            ] when
+
+            "username" value <user>
+                "realname" value >>realname
+                "email" value >>email
+                "new-password" value >>password
+                H{ } clone >>profile
+
+            insert-tuple
+
+            next f <standard-redirect>
+        ] >>submit ;
+    
+:: <edit-user-action> ( form ctor next -- action )
+    <action>
+        { { "username" [ v-required ] } } >>get-params
+
+        [
+            blank-values
+
+            "username" get ctor call select-tuple
+
+            {
+                [ username>> "username" set-value ]
+                [ realname>> "realname" set-value ]
+                [ email>> "email" set-value ]
+                [ profile>> "profile" set-value ]
+            } cleave
+        ] >>init
+
+        [ form edit-form ] >>display
+
+        [
+            blank-values
+
+            form validate-form
+
+            "username" value <user> select-tuple
+                "realname" value >>realname
+                "email" value >>email
+
+            { "new-password" "verify-password" }
+            [ value empty? ] all? [
+                same-password-twice
+                "new-password" value >>password
+            ] unless
+
+            update-tuple
+
+            next f <standard-redirect>
+        ] >>submit ;
+
+:: <delete-user-action> ( ctor next -- action )
+    <action>
+        { { "username" [ ] } } >>post-params
+
+        [
+            "username" get
+            [ <user> select-tuple 1 >>deleted update-tuple ]
+            [ logout-all-sessions ]
+            bi
+
+            next f <standard-redirect>
+        ] >>submit ;
+
+TUPLE: user-admin < dispatcher ;
+
+:: <user-admin> ( -- responder )
+    [let | ctor [ [ <user> ] ] |
+        user-admin new-dispatcher
+            <user-list-form> ctor <list-action> "" add-responder
+            <new-user-form> ctor "$user-admin" <new-user-action> "new" add-responder
+            <edit-user-form> ctor "$user-admin" <edit-user-action> "edit" add-responder
+            ctor "$user-admin" <delete-user-action> "delete" add-responder
+        <boilerplate>
+            "admin" admin-template >>template
+        <protected>
+    ] ;

extra/http/server/auth/admin/admin.xml

@@ -0,0 +1,24 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+	<t:style include="resource:extra/http/server/auth/admin/admin.css" />
+
+	<div class="navbar">
+		  <t:a t:href="$user-admin">List Users</t:a>
+		| <t:a t:href="$user-admin/new">Add User</t:a>
+
+		<t:if t:code="http.server.auth.login:allow-edit-profile?">
+			| <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
+		</t:if>
+
+		<t:form t:action="$login/logout" t:flow="begin" class="inline">
+			| <button type="submit" class="link-button link">Logout</button>
+		</t:form>
+	</div>
+
+	<h1><t:write-title /></h1>
+
+	<t:call-next-template />
+
+</t:chloe>

extra/http/server/auth/admin/edit-user.xml

@@ -0,0 +1,60 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+	<t:title>Edit User</t:title>
+
+	<t:form t:action="$user-admin/edit">
+
+	<t:edit t:component="username" />
+
+	<table>
+	
+	<tr>
+		<th class="field-label">User name:</th>
+		<td><t:view t:component="username" /></td>
+	</tr>
+	
+	<tr>
+		<th class="field-label">Real name:</th>
+		<td><t:edit t:component="realname" /></td>
+	</tr>
+	
+	<tr>
+		<th class="field-label">New password:</th>
+		<td><t:edit t:component="new-password" /></td>
+	</tr>
+	
+	<tr>
+		<th class="field-label">Verify:</th>
+		<td><t:edit t:component="verify-password" /></td>
+	</tr>
+	
+	<tr>
+		<th class="field-label">E-mail:</th>
+		<td><t:edit t:component="email" /></td>
+	</tr>
+	
+	<tr>
+		<th class="field-label">Profile:</th>
+		<td><t:view t:component="profile" /></td>
+	</tr>
+
+	</table>
+	
+	<p>
+		<button type="submit" class="link-button link">Update</button>
+
+		<t:if t:var="http.server.auth.login:password-mismatch?">
+			<t:error>passwords do not match</t:error>
+		</t:if>
+	</p>
+
+	</t:form>
+
+	<t:form t:action="$user-admin/delete">
+		<t:edit t:component="username" />
+
+		<button type="submit" class="link-button link">Delete</button>
+	</t:form>
+</t:chloe>

extra/http/server/auth/admin/new-user.xml

@@ -0,0 +1,51 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+	<t:title>New User</t:title>
+
+	<t:form t:action="$user-admin/new">
+
+	<table>
+	
+	<tr>
+		<th class="field-label">User name:</th>
+		<td><t:edit t:component="username" /></td>
+	</tr>
+	
+	<tr>
+		<th class="field-label">Real name:</th>
+		<td><t:edit t:component="realname" /></td>
+	</tr>
+	
+	<tr>
+		<th class="field-label">New password:</th>
+		<td><t:edit t:component="new-password" /></td>
+	</tr>
+	
+	<tr>
+		<th class="field-label">Verify:</th>
+		<td><t:edit t:component="verify-password" /></td>
+	</tr>
+	
+	<tr>
+		<th class="field-label">E-mail:</th>
+		<td><t:edit t:component="email" /></td>
+	</tr>
+
+	</table>
+	
+	<p>
+		<button type="submit" class="link-button link">Create</button>
+
+		<t:if t:var="http.server.auth.login:user-exists?">
+				<t:error>username taken</t:error>
+		</t:if>
+
+		<t:if t:var="http.server.auth.login:password-mismatch?">
+			<t:error>passwords do not match</t:error>
+		</t:if>
+	</p>
+
+	</t:form>
+</t:chloe>

extra/http/server/auth/admin/user-list.xml

@@ -0,0 +1,9 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+	<t:title>Users</t:title>
+
+	<t:summary t:component="list" />
+
+</t:chloe>

extra/http/server/auth/admin/user-summary.xml

@@ -0,0 +1,9 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+	<t:a t:href="$user-admin/edit" t:query="username">
+		<t:view t:component="username" />
+	</t:a>
+
+</t:chloe>

extra/http/server/auth/auth.factor

@@ -7,7 +7,6 @@ http.server.auth.providers ;
 IN: http.server.auth
 
 SYMBOL: logged-in-user
-SYMBOL: user-profile-changed?
 
 GENERIC: init-user-profile ( responder -- )
 
@@ -19,16 +18,18 @@ M: dispatcher init-user-profile
 M: filter-responder init-user-profile
     responder>> init-user-profile ;
 
-: uid ( -- string ) logged-in-user sget username>> ;
+: profile ( -- assoc ) logged-in-user get profile>> ;
 
-: profile ( -- assoc ) logged-in-user sget profile>> ;
+: user-changed ( -- )
+    logged-in-user get t >>changed? drop ;
 
 : uget ( key -- value )
     profile at ;
 
 : uset ( value key -- )
-    profile set-at user-profile-changed? on ;
+    profile set-at
+    user-changed ;
 
 : uchange ( quot key -- )
     profile swap change-at
-    user-profile-changed? on ; inline
+    user-changed ; inline

extra/http/server/auth/login/edit-profile.xml

@@ -4,7 +4,7 @@
 
 	<t:title>Edit Profile</t:title>
 
-	<t:form t:action="edit-profile">
+	<t:form t:action="$login/edit-profile">
 
 	<table>
 	

extra/http/server/auth/login/login.factor

@@ -35,9 +35,7 @@ TUPLE: user-saver user ;
 C: <user-saver> user-saver
 
 M: user-saver dispose
-    user-profile-changed? get [
+    user>> dup changed?>> [ users update-user ] [ drop ] if ;
-        user>> users update-user
-    ] [ drop ] if ;
 
 : save-user-after ( user -- )
     <user-saver> add-always-destructor ;
@@ -59,7 +57,7 @@ M: user-saver dispose
             add-field ;
 
 : successful-login ( user -- response )
-    logged-in-user sset
+    username>> set-uid
     "$login" end-flow ;
 
 :: <login-action> ( -- action )
@@ -125,11 +123,11 @@ SYMBOL: user-exists?
 
                 same-password-twice
 
-                <user>
+                "username" value <user>
-                    "username" value >>username
                     "realname" value >>realname
                     "new-password" value >>password
                     "email" value >>email
+                    H{ } clone >>profile
 
                 users new-user [
                     user-exists? on
@@ -160,7 +158,7 @@ SYMBOL: user-exists?
             [
                 blank-values
 
-                logged-in-user sget
+                logged-in-user get
                 [ username>> "username" set-value ]
                 [ realname>> "realname" set-value ]
                 [ email>> "email" set-value ]
@@ -175,7 +173,7 @@ SYMBOL: user-exists?
 
                 form validate-form
 
-                logged-in-user sget
+                logged-in-user get
 
                 { "password" "new-password" "verify-password" }
                 [ value empty? ] all? [
@@ -190,9 +188,9 @@ SYMBOL: user-exists?
                 "realname" value >>realname
                 "email" value >>email
 
-                drop
+                t >>changed?
 
-                user-profile-changed? on
+                drop
 
                 "$login" end-flow
             ] >>submit
@@ -330,7 +328,7 @@ SYMBOL: lost-password-from
 : <logout-action> ( -- action )
     <action>
         [
-            f logged-in-user sset
+            f set-uid
             "$login/login" end-flow
         ] >>submit ;
 
@@ -345,8 +343,9 @@ C: <protected> protected
     "$login/login" f <standard-redirect> ;
 
 M: protected call-responder* ( path responder -- response )
-    logged-in-user sget dup [
+    uid dup [
-        save-user-after
+        users get-user
+        [ logged-in-user set ] [ save-user-after ] bi
         call-next-method
     ] [
         3drop show-login-page

extra/http/server/auth/providers/assoc/assoc-tests.factor

@@ -6,17 +6,17 @@ namespaces accessors kernel ;
 <users-in-memory> "provider" set
 
 [ t ] [
-    <user>
+    "slava" <user>
-        "slava" >>username
         "foobar" >>password
         "slava@factorcode.org" >>email
+        H{ } clone >>profile
     "provider" get new-user
     username>> "slava" =
 ] unit-test
 
 [ f ] [
-    <user>
+    "slava" <user>
-        "slava" >>username
+        H{ } clone >>profile
     "provider" get new-user
 ] unit-test
 

extra/http/server/auth/providers/db/db-tests.factor

@@ -6,22 +6,24 @@ io.files accessors kernel ;
 
 users-in-db "provider" set
 
+[ "auth-test.db" temp-file delete-file ] ignore-errors
+
 "auth-test.db" temp-file sqlite-db [
 
     init-users-table
 
     [ t ] [
-        <user>
+        "slava" <user>
-            "slava" >>username
             "foobar" >>password
             "slava@factorcode.org" >>email
+            H{ } clone >>profile
             "provider" get new-user
             username>> "slava" =
     ] unit-test
 
     [ f ] [
-        <user>
+        "slava" <user>
-            "slava" >>username
+            H{ } clone >>profile
         "provider" get new-user
     ] unit-test
 

extra/http/server/auth/providers/db/db.factor

@@ -7,31 +7,28 @@ IN: http.server.auth.providers.db
 
 user "USERS"
 {
-    { "username" "USERNAME" { VARCHAR 256 } +assigned-id+ }
+    { "username" "USERNAME" { VARCHAR 256 } +user-assigned-id+ }
     { "realname" "REALNAME" { VARCHAR 256 } }
     { "password" "PASSWORD" { VARCHAR 256 } +not-null+ }
     { "email" "EMAIL" { VARCHAR 256 } }
     { "ticket" "TICKET" { VARCHAR 256 } }
     { "profile" "PROFILE" FACTOR-BLOB }
+    { "deleted" "DELETED" INTEGER +not-null+ }
 } define-persistent
 
 : init-users-table user ensure-table ;
 
 SINGLETON: users-in-db
 
-: find-user ( username -- user )
-    <user>
-        swap >>username
-    select-tuple ;
-
 M: users-in-db get-user
-    drop
+    drop <user> select-tuple ;
-    find-user ;
 
 M: users-in-db new-user
     drop
     [
-        dup username>> find-user [
+        user new
+            over username>> >>username
+        select-tuple [
             drop f
         ] [
             dup insert-tuple

extra/http/server/auth/providers/providers.factor

@@ -4,9 +4,12 @@ USING: kernel accessors random math.parser locals
 sequences math crypto.sha2 ;
 IN: http.server.auth.providers
 
-TUPLE: user username realname password email ticket profile ;
+TUPLE: user username realname password email ticket profile deleted changed? ;
 
-: <user> user new H{ } clone >>profile ;
+: <user> ( username -- user )
+    user new
+        swap >>username
+        0 >>deleted ;
 
 GENERIC: get-user ( username provider -- user/f )
 

extra/http/server/components/components.factor

@@ -30,8 +30,6 @@ TUPLE: hidden < field ;
 
 : hidden ( -- renderer ) T{ hidden f "hidden" } ; inline
 
-M: hidden render-view* 2drop ;
-
 ! Component protocol
 SYMBOL: components
 

extra/http/server/components/inspector/inspector.factor

@@ -0,0 +1,17 @@
+! Copyright (C) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: splitting kernel io sequences inspector accessors
+http.server.components ;
+IN: http.server.components.inspector
+
+SINGLETON: inspector-renderer
+
+M: inspector-renderer render-view*
+    drop describe ;
+
+TUPLE: inspector < component ;
+
+M: inspector component-string drop ;
+
+: <inspector> ( id -- component )
+    inspector inspector-renderer new-component ;

extra/http/server/crud/crud.factor

@@ -51,7 +51,7 @@ IN: http.server.crud
         { { "id" [ v-number ] } } >>post-params
 
         [
-            "id" get ctor call delete-tuple
+            "id" get ctor call delete-tuples
 
             next f <standard-redirect>
         ] >>submit ;

extra/http/server/sessions/sessions-tests.factor

@@ -1,16 +1,12 @@
 IN: http.server.sessions.tests
 USING: tools.test http http.server.sessions
-http.server.sessions.storage http.server.sessions.storage.db
 http.server.actions http.server math namespaces kernel accessors
 prettyprint io.streams.string io.files splitting destructors
 sequences db db.sqlite continuations ;
 
 : with-session
     [
-        >r
+        >r [ save-session-after ] [ session set ] bi r> call
-        [ session-manager get swap save-session-after ]
-        [ \ session set ] bi
-        r> call
     ] with-destructors ; inline
 
 TUPLE: foo ;
@@ -31,18 +27,18 @@ M: foo call-responder*
             "id" get session-id-key set-query-param
             "/" >>path
         request set
-        { } session-manager get call-responder
+        { } sessions get call-responder
         [ write-response-body drop ] with-string-writer
     ] with-destructors ;
 
-: session-manager-mock-test
+: sessions-mock-test
     [
         <request>
             "GET" >>method
             "cookies" get >>cookies
             "/" >>path
         request set
-        { } session-manager get call-responder
+        { } sessions get call-responder
         [ write-response-body drop ] with-string-writer
     ] with-destructors ;
 
@@ -60,14 +56,15 @@ M: foo call-responder*
     init-sessions-table
 
     [ ] [
-        <foo> <session-manager>
+        <foo> <sessions>
-            sessions-in-db >>sessions
+        sessions set
-        session-manager set
     ] unit-test
 
     [
+        [ ] [
             empty-session
                 123 >>id session set
+        ] unit-test
 
         [ ] [ 3 "x" sset ] unit-test
 
@@ -81,39 +78,38 @@ M: foo call-responder*
     ] with-scope
 
     [ t ] [
-        session-manager get begin-session id>>
+        begin-session id>>
-        session-manager get sessions>> get-session session?
+        get-session session?
     ] unit-test
 
     [ { 5 0 } ] [
         [
-            session-manager get begin-session
+            begin-session
             dup [ 5 "a" sset ] with-session
             dup [ "a" sget , ] with-session
             dup [ "x" sget , ] with-session
-            id>> session-manager get sessions>> delete-session
+            drop
         ] { } make
     ] unit-test
 
     [ 0 ] [
-        session-manager get begin-session id>>
+        begin-session id>>
-        session-manager get sessions>> get-session [ "x" sget ] with-session
+        get-session [ "x" sget ] with-session
     ] unit-test
 
     [ { 5 0 } ] [
         [
-            session-manager get begin-session id>>
+            begin-session id>>
-            dup session-manager get sessions>> get-session [ 5 "a" sset ] with-session
+            dup get-session [ 5 "a" sset ] with-session
-            dup session-manager get sessions>> get-session [ "a" sget , ] with-session
+            dup get-session [ "a" sget , ] with-session
-            dup session-manager get sessions>> get-session [ "x" sget , ] with-session
+            dup get-session [ "x" sget , ] with-session
-            session-manager get sessions>> delete-session
+            drop
         ] { } make
     ] unit-test
 
     [ ] [
-        <foo> <session-manager>
+        <foo> <sessions>
-            sessions-in-db >>sessions
+        sessions set
-        session-manager set
     ] unit-test
 
     [
@@ -121,7 +117,7 @@ M: foo call-responder*
         "GET" >>method
         "/" >>path
         request set
-        { "etc" } session-manager get call-responder response set
+        { "etc" } sessions get call-responder response set
         [ "1" ] [ [ response get write-response-body drop ] with-string-writer ] unit-test
         response get
     ] with-destructors
@@ -129,9 +125,9 @@ M: foo call-responder*
 
     [ ] [ response get cookies>> "cookies" set ] unit-test
 
-    [ "2" ] [ session-manager-mock-test ] unit-test
+    [ "2" ] [ sessions-mock-test ] unit-test
-    [ "3" ] [ session-manager-mock-test ] unit-test
+    [ "3" ] [ sessions-mock-test ] unit-test
-    [ "4" ] [ session-manager-mock-test ] unit-test
+    [ "4" ] [ sessions-mock-test ] unit-test
 
     [
         [ ] [
@@ -142,8 +138,7 @@ M: foo call-responder*
             request set
 
             [
-                { } <exiting-action> <session-manager>
+                { } <exiting-action> <sessions>
-                    sessions-in-db >>sessions
                 call-responder
             ] with-destructors response set
         ] unit-test

extra/http/server/sessions/sessions.factor

@@ -1,21 +1,40 @@
 ! Copyright (C) 2008 Doug Coleman, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: assocs kernel math.parser namespaces random
+USING: assocs kernel math.intervals math.parser namespaces
-accessors quotations hashtables sequences continuations
+random accessors quotations hashtables sequences continuations
-fry calendar combinators destructors
+fry calendar combinators destructors alarms
-http
+db db.tuples db.types
-http.server
+http http.server html.elements ;
-http.server.sessions.storage
-http.server.sessions.storage.null
-html.elements ;
 IN: http.server.sessions
 
-TUPLE: session id expires namespace changed? ;
+TUPLE: session id expires uid namespace changed? ;
 
 : <session> ( id -- session )
     session new
         swap >>id ;
 
+session "SESSIONS"
+{
+    { "id" "ID" +random-id+ system-random-generator }
+    { "expires" "EXPIRES" TIMESTAMP +not-null+ }
+    { "uid" "UID" { VARCHAR 255 } }
+    { "namespace" "NAMESPACE" FACTOR-BLOB }
+} define-persistent
+
+: get-session ( id -- session )
+    dup [ <session> select-tuple ] when ;
+
+: init-sessions-table session ensure-table ;
+
+: start-expiring-sessions ( db seq -- )
+    '[
+        , , [
+            session new
+                -1.0/0.0 now [a,b] >>expires
+            delete-tuples
+        ] with-db
+    ] 5 minutes every drop ;
+
 GENERIC: init-session* ( responder -- )
 
 M: object init-session* drop ;
@@ -24,12 +43,11 @@ M: dispatcher init-session* default>> init-session* ;
 
 M: filter-responder init-session* responder>> init-session* ;
 
-TUPLE: session-manager < filter-responder sessions timeout domain ;
+TUPLE: sessions < filter-responder timeout domain ;
 
-: <session-manager> ( responder -- responder' )
+: <sessions> ( responder -- responder' )
-    session-manager new
+    sessions new
         swap >>responder
-        null-sessions >>sessions
         20 minutes >>timeout ;
 
 : (session-changed) ( session -- )
@@ -50,11 +68,17 @@ TUPLE: session-manager < filter-responder sessions timeout domain ;
     [ namespace>> swap change-at ] keep
     (session-changed) ; inline
 
-: init-session ( session managed -- )
+: uid ( -- uid )
-    >r session r> '[ , init-session* ] with-variable ;
+    session get uid>> ;
+
+: set-uid ( uid -- )
+    session get [ (>>uid) ] [ (session-changed) ] bi ;
+
+: init-session ( session -- )
+    session [ sessions get init-session* ] with-variable ;
 
 : cutoff-time ( -- time )
-    session-manager get timeout>> from-now timestamp>millis ;
+    sessions get timeout>> from-now ;
 
 : touch-session ( session -- )
     cutoff-time >>expires drop ;
@@ -64,57 +88,50 @@ TUPLE: session-manager < filter-responder sessions timeout domain ;
         H{ } clone >>namespace
         dup touch-session ;
 
-: begin-session ( responder -- session )
+: begin-session ( -- session )
-    >r empty-session r>
+    empty-session [ init-session ] [ insert-tuple ] [ ] tri ;
-    [ init-session ]
-    [ sessions>> new-session ]
-    [ drop ]
-    2tri ;
 
 ! Destructor
-TUPLE: session-saver manager session ;
+TUPLE: session-saver session ;
 
 C: <session-saver> session-saver
 
 M: session-saver dispose
-    [ session>> ] [ manager>> sessions>> ] bi
+    session>> dup changed?>> [
-    over changed?>> [
+        [ touch-session ] [ update-tuple ] bi
-        [ drop touch-session ] [ update-session ] 2bi
+    ] [ drop ] if ;
-    ] [ 2drop ] if ;
 
-: save-session-after ( manager session -- )
+: save-session-after ( session -- )
     <session-saver> add-always-destructor ;
 
-: existing-session ( path manager session -- response )
+: existing-session ( path session -- response )
-    [ nip session set ]
+    [ session set ] [ save-session-after ] bi
-    [ save-session-after ]
+    sessions get responder>> call-responder ;
-    [ drop responder>> ] 2tri
-    call-responder ;
 
 : session-id-key "factorsessid" ;
 
-: cookie-session-id ( -- id/f )
+: cookie-session-id ( request -- id/f )
-    request get session-id-key get-cookie
+    session-id-key get-cookie
     dup [ value>> string>number ] when ;
 
-: post-session-id ( -- id/f )
+: post-session-id ( request -- id/f )
-    session-id-key request get post-data>> at string>number ;
+    session-id-key swap post-data>> at string>number ;
 
 : request-session-id ( -- id/f )
-    request get method>> {
+    request get dup method>> {
         { "GET" [ cookie-session-id ] }
         { "HEAD" [ cookie-session-id ] }
         { "POST" [ post-session-id ] }
     } case ;
 
-: request-session ( responder -- session/f )
+: request-session ( -- session/f )
-    >r request-session-id r> sessions>> get-session ;
+    request-session-id get-session ;
 
 : <session-cookie> ( id -- cookie )
     session-id-key <cookie>
-        "$session-manager" resolve-base-path >>path
+        "$sessions" resolve-base-path >>path
-        session-manager get timeout>> from-now >>expires
+        sessions get timeout>> from-now >>expires
-        session-manager get domain>> >>domain ;
+        sessions get domain>> >>domain ;
 
 : put-session-cookie ( response -- response' )
     session get id>> number>string <session-cookie> put-cookie ;
@@ -126,8 +143,11 @@ M: session-saver dispose
         session get id>> number>string =value
     input/> ;
 
-M: session-manager call-responder* ( path responder -- response )
+M: sessions call-responder* ( path responder -- response )
     [ session-form-field ] add-form-hook
-    dup session-manager set
+    sessions set
-    dup request-session [ dup begin-session ] unless*
+    request-session [ begin-session ] unless*
     existing-session put-session-cookie ;
+
+: logout-all-sessions ( uid -- )
+    session new swap >>uid delete-tuples ;

extra/http/server/sessions/storage/db/db.factor

@@ -1,40 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: assocs accessors kernel http.server.sessions.storage
-http.server.sessions http.server db db.tuples db.types math.parser
-math.intervals fry random calendar sequences alarms ;
-IN: http.server.sessions.storage.db
-
-SINGLETON: sessions-in-db
-
-session "SESSIONS"
-{
-    ! { "id" "ID" +random-id+ system-random-generator }
-    { "id" "ID" INTEGER +native-id+ }
-    { "expires" "EXPIRES" BIG-INTEGER +not-null+ }
-    { "namespace" "NAMESPACE" FACTOR-BLOB }
-} define-persistent
-
-: init-sessions-table session ensure-table ;
-
-M: sessions-in-db get-session ( id storage -- session/f )
-    drop dup [ <session> select-tuple ] when ;
-
-M: sessions-in-db update-session ( session storage -- )
-    drop update-tuple ;
-
-M: sessions-in-db delete-session ( id storage -- )
-    drop <session> delete-tuple ;
-
-M: sessions-in-db new-session ( session storage -- )
-    drop insert-tuple ;
-
-: expired-sessions ( -- session )
-    f <session>
-    USE: math now timestamp>millis [ 60 60 * 1000 * - ] keep [a,b] >>expires
-    select-tuples ;
-
-: start-expiring-sessions ( db seq -- )
-    '[
-        , , [ expired-sessions [ delete-tuple ] each ] with-db
-    ] 5 minutes every drop ;

extra/http/server/sessions/storage/null/null.factor

@@ -1,16 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel http.server.sessions.storage ;
-IN: http.server.sessions.storage.null
-
-SINGLETON: null-sessions
-
-: null-sessions-error "No session storage installed" throw ;
-
-M: null-sessions get-session null-sessions-error ;
-
-M: null-sessions update-session null-sessions-error ;
-
-M: null-sessions delete-session null-sessions-error ;
-
-M: null-sessions new-session null-sessions-error ;

extra/http/server/sessions/storage/storage.factor

@@ -1,12 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: calendar ;
-IN: http.server.sessions.storage
-
-GENERIC: get-session ( id storage -- session )
-
-GENERIC: update-session ( session storage -- )
-
-GENERIC: delete-session ( id storage -- )
-
-GENERIC: new-session ( session storage -- )

extra/locals/locals-docs.factor

@@ -120,9 +120,11 @@ $nl
 "Another limitation is that closure conversion does not descend into arrays, hashtables or other types of literals. For example, the following does not work:"
 { $code
     ":: bad-cond-usage ( a -- ... )"
+    "    {"
     "        { [ a 0 < ] [ ... ] }"
     "        { [ a 0 > ] [ ... ] }"
-    "    { [ a 0 = ] [ ... ] } ;"
+    "        { [ a 0 = ] [ ... ] }"
+    "    } cond ;"
 } ;
 
 ARTICLE: "locals" "Local variables and lexical closures"

extra/locals/locals.factor

@@ -81,16 +81,24 @@ C: <quote> quote
 UNION: special local quote local-word local-reader local-writer ;
 
 : load-locals-quot ( args -- quot )
+    dup empty? [
+        drop [ ]
+    ] [
         dup [ local-reader? ] contains? [
             <reversed> [
                 local-reader? [ 1array >r ] [ >r ] ?
             ] map concat
         ] [
             length [ load-locals ] curry >quotation
+        ] if
     ] if ;
 
 : drop-locals-quot ( args -- quot )
-    length [ drop-locals ] curry ;
+    dup empty? [
+        drop [ ]
+    ] [
+        length [ drop-locals ] curry
+    ] if ;
 
 : point-free-body ( quot args -- newquot )
     >r 1 head-slice* r> [ localize ] curry map concat ;

extra/math/functions/functions.factor

@@ -80,10 +80,6 @@ M: integer (^)
         -rot (^mod)
     ] if ; foldable
 
-GENERIC: abs ( x -- y ) foldable
-
-M: real abs dup 0 < [ neg ] when ;
-
 GENERIC: absq ( x -- y ) foldable
 
 M: real absq sq ;

extra/math/ratios/ratios.factor

@@ -47,5 +47,6 @@ M: ratio - 2dup scale - -rot ratio+d / ;
 M: ratio * 2>fraction * >r * r> / ;
 M: ratio / scale / ;
 M: ratio /i scale /i ;
+M: ratio /f scale /f ;
 M: ratio mod 2dup >r >r /i r> r> rot * - ;
 M: ratio /mod [ /i ] 2keep mod ;

extra/multi-methods/multi-methods.factor

@@ -73,7 +73,7 @@ SYMBOL: total
 ! Part II: Topologically sorting specializers
 : maximal-element ( seq quot -- n elt )
     dupd [
-        swapd [ call 0 < ] 2curry filter empty?
+        swapd [ call +lt+ = ] 2curry filter empty?
     ] 2curry find [ "Topological sort failed" throw ] unless* ;
     inline
 
@@ -82,16 +82,16 @@ SYMBOL: total
     [ dupd maximal-element >r over delete-nth r> ] curry
     [ ] unfold nip ; inline
 
-: classes< ( seq1 seq2 -- -1/0/1 )
+: classes< ( seq1 seq2 -- lt/eq/gt )
     [
         {
-            { [ 2dup eq? ] [ 0 ] }
+            { [ 2dup eq? ] [ +eq+ ] }
-            { [ 2dup [ class< ] 2keep swap class< and ] [ 0 ] }
+            { [ 2dup [ class< ] 2keep swap class< and ] [ +eq+ ] }
-            { [ 2dup class< ] [ -1 ] }
+            { [ 2dup class< ] [ +lt+ ] }
-            { [ 2dup swap class< ] [ 1 ] }
+            { [ 2dup swap class< ] [ +gt+ ] }
-            [ 0 ]
+            [ +eq+ ]
         } cond 2nip
-    ] 2map [ zero? not ] find nip 0 or ;
+    ] 2map [ zero? not ] find nip +eq+ or ;
 
 : sort-methods ( alist -- alist' )
     [ [ first ] bi@ classes< ] topological-sort ;

extra/multi-methods/tests/topological-sort.factor

@@ -6,14 +6,14 @@ IN: multi-methods.tests
     { 6 4 5 1 3 2 } [ <=> ] topological-sort
 ] unit-test
 
-[ -1 ] [
+[ +lt+ ] [
     { fixnum array } { number sequence } classes<
 ] unit-test
 
-[ 0 ] [
+[ +eq+ ] [
     { number sequence } { number sequence } classes<
 ] unit-test
 
-[ 1 ] [
+[ +gt+ ] [
     { object object } { number sequence } classes<
 ] unit-test

extra/opengl/demo-support/demo-support.factor

@@ -1,18 +1,11 @@
 USING: arrays combinators.lib kernel math math.functions
 math.order math.vectors namespaces opengl opengl.gl sequences ui
-ui.gadgets ui.gestures ui.render ;
+ui.gadgets ui.gestures ui.render accessors ;
 IN: opengl.demo-support
 
-: NEAR-PLANE 1.0 64.0 / ; inline
-: FAR-PLANE 4.0 ; inline
 : FOV 2.0 sqrt 1+ ; inline
 : MOUSE-MOTION-SCALE 0.5 ; inline
-: MOUSE-DISTANCE-SCALE 1.0 64.0 / ; inline
 : KEY-ROTATE-STEP 1.0 ; inline
-: KEY-DISTANCE-STEP 1.0 64.0 / ; inline
-: DIMS { 640 480 } ; inline
-
-: FOV-RATIO ( -- fov ) DIMS dup first2 min v/n ;
 
 SYMBOL: last-drag-loc
 
@@ -20,7 +13,20 @@ TUPLE: demo-gadget yaw pitch distance ;
 
 : <demo-gadget> ( yaw pitch distance -- gadget )
     demo-gadget construct-gadget 
-    [ { set-demo-gadget-yaw set-demo-gadget-pitch set-demo-gadget-distance } set-slots ] keep ;
+    [ { (>>yaw) (>>pitch) (>>distance) } set-slots ] keep ;
+
+GENERIC: far-plane ( gadget -- z )
+GENERIC: near-plane ( gadget -- z )
+GENERIC: distance-step ( gadget -- dz )
+
+M: demo-gadget far-plane ( gadget -- z )
+    drop 4.0 ;
+M: demo-gadget near-plane ( gadget -- z )
+    drop 1.0 64.0 / ;
+M: demo-gadget distance-step ( gadget -- dz )
+    drop 1.0 64.0 / ;
+
+: fov-ratio ( gadget -- fov ) dim>> dup first2 min v/n ;
 
 : yaw-demo-gadget ( yaw gadget -- )
     [ [ demo-gadget-yaw + ] keep set-demo-gadget-yaw ] keep relayout-1 ;
@@ -32,26 +38,31 @@ TUPLE: demo-gadget yaw pitch distance ;
     [ [ demo-gadget-distance + ] keep set-demo-gadget-distance ] keep relayout-1 ;
 
 M: demo-gadget pref-dim* ( gadget -- dim )
-    drop DIMS ;
+    drop { 640 480 } ;
 
 : -+ ( x -- -x x )
     dup neg swap ;
 
-: demo-gadget-frustum ( -- -x x -y y near far )
+: demo-gadget-frustum ( gadget -- -x x -y y near far )
-    FOV-RATIO NEAR-PLANE FOV / v*n
+    [ near-plane ] [ far-plane ] [ fov-ratio ] tri [
-    first2 [ -+ ] bi@ NEAR-PLANE FAR-PLANE ;
+        nip swap FOV / v*n
+        first2 [ -+ ] bi@
+    ] 3keep drop ;
 
 : demo-gadget-set-matrices ( gadget -- )
+    GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
+    [
         GL_PROJECTION glMatrixMode
         glLoadIdentity
         demo-gadget-frustum glFrustum
-    GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
+    ] [
         GL_MODELVIEW glMatrixMode
         glLoadIdentity
-    [ >r 0.0 0.0 r> demo-gadget-distance neg glTranslatef ]
+        [ >r 0.0 0.0 r> distance>> neg glTranslatef ]
-    [ demo-gadget-pitch 1.0 0.0 0.0 glRotatef ]
+        [ pitch>> 1.0 0.0 0.0 glRotatef ]
-    [ demo-gadget-yaw   0.0 1.0 0.0 glRotatef ]
+        [ yaw>>   0.0 1.0 0.0 glRotatef ]
-    tri ;
+        tri
+    ] bi ;
 
 : reset-last-drag-rel ( -- )
     { 0 0 } last-drag-loc set-global ;
@@ -66,11 +77,11 @@ demo-gadget H{
     { T{ key-down f f "RIGHT" } [ KEY-ROTATE-STEP     swap yaw-demo-gadget ] }
     { T{ key-down f f "DOWN"  } [ KEY-ROTATE-STEP neg swap pitch-demo-gadget ] }
     { T{ key-down f f "UP"    } [ KEY-ROTATE-STEP     swap pitch-demo-gadget ] }
-    { T{ key-down f f "="     } [ KEY-DISTANCE-STEP neg swap zoom-demo-gadget ] }
+    { T{ key-down f f "="     } [ dup distance-step neg swap zoom-demo-gadget ] }
-    { T{ key-down f f "-"     } [ KEY-DISTANCE-STEP     swap zoom-demo-gadget ] }
+    { T{ key-down f f "-"     } [ dup distance-step     swap zoom-demo-gadget ] }
     
     { T{ button-down f f 1 }    [ drop reset-last-drag-rel ] }
     { T{ drag f 1 }             [ drag-yaw-pitch rot [ pitch-demo-gadget ] keep yaw-demo-gadget ] }
-    { T{ mouse-scroll }         [ scroll-direction get second MOUSE-DISTANCE-SCALE * swap zoom-demo-gadget ] }
+    { T{ mouse-scroll }         [ scroll-direction get second over distance-step * swap zoom-demo-gadget ] }
 } set-gestures
 

extra/peg/ebnf/ebnf-tests.factor

@@ -1,15 +1,16 @@
 ! Copyright (C) 2007 Chris Double.
 ! See http://factorcode.org/license.txt for BSD license.
 !
-USING: kernel tools.test peg peg.ebnf words math math.parser sequences ;
+USING: kernel tools.test peg peg.ebnf words math math.parser 
+       sequences accessors ;
 IN: peg.ebnf.tests
 
 { T{ ebnf-non-terminal f "abc" } } [
-  "abc" 'non-terminal' parse parse-result-ast 
+  "abc" 'non-terminal' parse ast>> 
 ] unit-test
 
 { T{ ebnf-terminal f "55" } } [
-  "'55'" 'terminal' parse parse-result-ast 
+  "'55'" 'terminal' parse ast>> 
 ] unit-test
 
 {
@@ -20,7 +21,7 @@ IN: peg.ebnf.tests
      }
   } 
 } [
-  "digit = '1' | '2'" 'rule' parse parse-result-ast
+  "digit = '1' | '2'" 'rule' parse ast>>
 ] unit-test
 
 {
@@ -31,7 +32,7 @@ IN: peg.ebnf.tests
      }
   }   
 } [
-  "digit = '1' '2'" 'rule' parse parse-result-ast
+  "digit = '1' '2'" 'rule' parse ast>>
 ] unit-test
 
 {
@@ -44,20 +45,22 @@ IN: peg.ebnf.tests
      }
   } 
 } [
-  "one two | three" 'choice' parse parse-result-ast
+  "one two | three" 'choice' parse ast>>
 ] unit-test
 
 {
   T{ ebnf-sequence f
      V{ 
        T{ ebnf-non-terminal f "one" }
+       T{ ebnf-whitespace f
          T{ ebnf-choice f
             V{ T{ ebnf-non-terminal f "two" } T{ ebnf-non-terminal f "three" } }
          }
        }
      }
+  } 
 } [
-  "one (two | three)" 'choice' parse parse-result-ast
+  "one {two | three}" 'choice' parse ast>>
 ] unit-test
 
 {
@@ -77,7 +80,7 @@ IN: peg.ebnf.tests
      }
   } 
 } [
-  "one ((two | three) four)*" 'choice' parse parse-result-ast
+  "one ((two | three) four)*" 'choice' parse ast>>
 ] unit-test
 
 {
@@ -89,43 +92,43 @@ IN: peg.ebnf.tests
      }
   } 
 } [
-  "one ( two )? three" 'choice' parse parse-result-ast
+  "one ( two )? three" 'choice' parse ast>>
 ] unit-test
 
 { "foo" } [
-  "\"foo\"" 'identifier' parse parse-result-ast
+  "\"foo\"" 'identifier' parse ast>>
 ] unit-test
 
 { "foo" } [
-  "'foo'" 'identifier' parse parse-result-ast
+  "'foo'" 'identifier' parse ast>>
 ] unit-test
 
 { "foo" } [
-  "foo" 'non-terminal' parse parse-result-ast ebnf-non-terminal-symbol
+  "foo" 'non-terminal' parse ast>> ebnf-non-terminal-symbol
 ] unit-test
 
 { "foo" } [
-  "foo]" 'non-terminal' parse parse-result-ast ebnf-non-terminal-symbol
+  "foo]" 'non-terminal' parse ast>> ebnf-non-terminal-symbol
 ] unit-test
 
 { V{ "a" "b" } } [
-  "ab" [EBNF foo='a' 'b' EBNF] call parse-result-ast 
+  "ab" [EBNF foo='a' 'b' EBNF] call ast>> 
 ] unit-test
 
 { V{ 1 "b" } } [
-  "ab" [EBNF foo=('a')[[ drop 1 ]] 'b' EBNF] call parse-result-ast 
+  "ab" [EBNF foo=('a')[[ drop 1 ]] 'b' EBNF] call ast>> 
 ] unit-test
 
 { V{ 1 2 } } [
-  "ab" [EBNF foo=('a') [[ drop 1 ]] ('b') [[ drop 2 ]] EBNF] call parse-result-ast 
+  "ab" [EBNF foo=('a') [[ drop 1 ]] ('b') [[ drop 2 ]] EBNF] call ast>> 
 ] unit-test
 
 { CHAR: A } [
-  "A" [EBNF foo=[A-Z] EBNF] call parse-result-ast 
+  "A" [EBNF foo=[A-Z] EBNF] call ast>> 
 ] unit-test
 
 { CHAR: Z } [
-  "Z" [EBNF foo=[A-Z] EBNF] call parse-result-ast 
+  "Z" [EBNF foo=[A-Z] EBNF] call ast>> 
 ] unit-test
 
 { f } [
@@ -133,7 +136,7 @@ IN: peg.ebnf.tests
 ] unit-test
 
 { CHAR: 0 } [
-  "0" [EBNF foo=[^A-Z] EBNF] call parse-result-ast 
+  "0" [EBNF foo=[^A-Z] EBNF] call ast>> 
 ] unit-test
 
 { f } [
@@ -145,31 +148,31 @@ IN: peg.ebnf.tests
 ] unit-test
 
 { V{ "1" "+" "foo" } } [
-  "1+1" [EBNF foo='1' '+' '1' [[ drop "foo" ]] EBNF] call parse-result-ast
+  "1+1" [EBNF foo='1' '+' '1' [[ drop "foo" ]] EBNF] call ast>>
 ] unit-test
 
 { "foo" } [
-  "1+1" [EBNF foo='1' '+' '1' => [[ drop "foo" ]] EBNF] call parse-result-ast
+  "1+1" [EBNF foo='1' '+' '1' => [[ drop "foo" ]] EBNF] call ast>>
 ] unit-test
 
 { "foo" } [
-  "1+1" [EBNF foo='1' '+' '1' => [[ drop "foo" ]] | '1' '-' '1' => [[ drop "bar" ]] EBNF] call parse-result-ast
+  "1+1" [EBNF foo='1' '+' '1' => [[ drop "foo" ]] | '1' '-' '1' => [[ drop "bar" ]] EBNF] call ast>>
 ] unit-test
 
 { "bar" } [
-  "1-1" [EBNF foo='1' '+' '1' => [[ drop "foo" ]] | '1' '-' '1' => [[ drop "bar" ]] EBNF] call parse-result-ast
+  "1-1" [EBNF foo='1' '+' '1' => [[ drop "foo" ]] | '1' '-' '1' => [[ drop "bar" ]] EBNF] call ast>>
 ] unit-test
 
 { 6 } [
-  "4+2" [EBNF num=[0-9] => [[ digit> ]] foo=num:x '+' num:y => [[ drop x y + ]] EBNF] call parse-result-ast
+  "4+2" [EBNF num=[0-9] => [[ digit> ]] foo=num:x '+' num:y => [[ drop x y + ]] EBNF] call ast>>
 ] unit-test
 
 { 6 } [
-  "4+2" [EBNF foo=[0-9]:x '+' [0-9]:y => [[ drop x digit> y digit> + ]] EBNF] call parse-result-ast
+  "4+2" [EBNF foo=[0-9]:x '+' [0-9]:y => [[ drop x digit> y digit> + ]] EBNF] call ast>>
 ] unit-test
 
 { 10 } [
-  { 1 2 3 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ drop x y + ]] | num EBNF] call parse-result-ast
+  { 1 2 3 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ drop x y + ]] | num EBNF] call ast>>
 ] unit-test
 
 { f } [
@@ -177,7 +180,7 @@ IN: peg.ebnf.tests
 ] unit-test
 
 { 3 } [
-  { 1 2 "a" 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ drop x y + ]] | num EBNF] call parse-result-ast
+  { 1 2 "a" 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ drop x y + ]] | num EBNF] call ast>>
 ] unit-test
 
 { f } [
@@ -185,44 +188,44 @@ IN: peg.ebnf.tests
 ] unit-test
 
 { V{ "a" " " "b" } } [
-  "a b" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF] call parse-result-ast
+  "a b" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF] call ast>>
 ] unit-test
 
 { V{ "a" "\t" "b" } } [
-  "a\tb" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF] call parse-result-ast 
+  "a\tb" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF] call ast>> 
 ] unit-test
 
 { V{ "a" "\n" "b" } } [
-  "a\nb" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF] call parse-result-ast
+  "a\nb" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF] call ast>>
 ] unit-test
 
 { V{ "a" f "b" } } [
-  "ab" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] call parse-result-ast
+  "ab" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] call ast>>
 ] unit-test
 
 { V{ "a" " " "b" } } [
-  "a b" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] call parse-result-ast
+  "a b" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] call ast>>
 ] unit-test
 
 
 { V{ "a" "\t" "b" } } [
-  "a\tb" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] call parse-result-ast
+  "a\tb" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] call ast>>
 ] unit-test
 
 { V{ "a" "\n" "b" } } [
-  "a\nb" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] call parse-result-ast
+  "a\nb" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] call ast>>
 ] unit-test
 
 { V{ "a" "b" } } [
-  "ab" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF] call parse-result-ast
+  "ab" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF] call ast>>
 ] unit-test
 
 { V{ "a" "b" } } [
-  "a\tb" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF] call parse-result-ast
+  "a\tb" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF] call ast>>
 ] unit-test
 
 { V{ "a" "b" } } [
-  "a\nb" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF] call parse-result-ast
+  "a\nb" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF] call ast>>
 ] unit-test
 
 { f } [
@@ -232,19 +235,19 @@ IN: peg.ebnf.tests
 { V{ V{ 49 } "+" V{ 49 } } } [ 
   #! Test direct left recursion. 
   #! Using packrat, so first part of expr fails, causing 2nd choice to be used  
-  "1+1" [EBNF num=([0-9])+ expr=expr "+" num | num EBNF] call parse-result-ast
+  "1+1" [EBNF num=([0-9])+ expr=expr "+" num | num EBNF] call ast>>
 ] unit-test
 
 { V{ V{ V{ 49 } "+" V{ 49 } } "+" V{ 49 } } } [ 
   #! Test direct left recursion. 
   #! Using packrat, so first part of expr fails, causing 2nd choice to be used  
-  "1+1+1" [EBNF num=([0-9])+ expr=expr "+" num | num EBNF] call parse-result-ast
+  "1+1+1" [EBNF num=([0-9])+ expr=expr "+" num | num EBNF] call ast>>
 ] unit-test
 
 { V{ V{ V{ 49 } "+" V{ 49 } } "+" V{ 49 } } } [ 
   #! Test indirect left recursion. 
   #! Using packrat, so first part of expr fails, causing 2nd choice to be used  
-  "1+1+1" [EBNF num=([0-9])+ x=expr expr=x "+" num | num EBNF] call parse-result-ast
+  "1+1+1" [EBNF num=([0-9])+ x=expr expr=x "+" num | num EBNF] call ast>>
 ] unit-test
 
 { t } [
@@ -277,23 +280,88 @@ main = Primary
 ;EBNF 
 
 { "this" } [
-  "this" primary parse-result-ast
+  "this" primary ast>>
 ] unit-test
 
 { V{ "this" "." "x" } } [
-  "this.x" primary parse-result-ast
+  "this.x" primary ast>>
 ] unit-test
 
 { V{ V{ "this" "." "x" } "." "y" } } [
-  "this.x.y" primary parse-result-ast
+  "this.x.y" primary ast>>
 ] unit-test
 
 { V{ V{ "this" "." "x" } "." "m" "(" ")" } } [
-  "this.x.m()" primary parse-result-ast
+  "this.x.m()" primary ast>>
 ] unit-test
 
 { V{ V{ V{ "x" "[" "i" "]" } "[" "j" "]" } "." "y" } } [
-  "x[i][j].y" primary parse-result-ast
+  "x[i][j].y" primary ast>>
 ] unit-test
 
 'ebnf' compile must-infer
+
+{ V{ V{ "a" "b" } "c" } } [
+  "abc" [EBNF a="a" "b" foo=(a "c") EBNF] call ast>>
+] unit-test
+
+{ V{ V{ "a" "b" } "c" } } [
+  "abc" [EBNF a="a" "b" foo={a "c"} EBNF] call ast>>
+] unit-test
+
+{ V{ V{ "a" "b" } "c" } } [
+  "abc" [EBNF a="a" "b" foo=a "c" EBNF] call ast>>
+] unit-test
+
+{ f } [
+  "a bc" [EBNF a="a" "b" foo=(a "c") EBNF] call 
+] unit-test
+
+{ f } [
+  "a bc" [EBNF a="a" "b" foo=a "c" EBNF] call 
+] unit-test
+
+{ f } [
+  "a bc" [EBNF a="a" "b" foo={a "c"} EBNF] call
+] unit-test
+
+{ f } [
+  "ab c" [EBNF a="a" "b" foo=a "c" EBNF] call 
+] unit-test
+
+{ V{ V{ "a" "b" } "c" } } [
+  "ab c" [EBNF a="a" "b" foo={a "c"} EBNF] call ast>>
+] unit-test
+
+{ f } [
+  "ab c" [EBNF a="a" "b" foo=(a "c") EBNF] call 
+] unit-test
+
+{ f } [
+  "a b c" [EBNF a="a" "b" foo=a "c" EBNF] call 
+] unit-test
+
+{ f } [
+  "a b c" [EBNF a="a" "b" foo=(a "c") EBNF] call 
+] unit-test
+
+{ f } [
+  "a b c" [EBNF a="a" "b" foo={a "c"} EBNF] call 
+] unit-test
+
+{ V{ V{ V{ "a" "b" } "c" } V{ V{ "a" "b" } "c" } } } [
+  "ab cab c" [EBNF a="a" "b" foo={a "c"}* EBNF] call ast>>
+] unit-test
+
+{ V{ } } [
+  "ab cab c" [EBNF a="a" "b" foo=(a "c")* EBNF] call ast>>
+] unit-test
+
+{ V{ V{ V{ "a" "b" } "c" } V{ V{ "a" "b" } "c" } } } [
+  "ab c ab c" [EBNF a="a" "b" foo={a "c"}* EBNF] call ast>>
+] unit-test
+
+{ V{ } } [
+  "ab c ab c" [EBNF a="a" "b" foo=(a "c")* EBNF] call ast>>
+] unit-test
+

extra/peg/ebnf/ebnf.factor

@@ -17,6 +17,7 @@ TUPLE: ebnf-sequence elements ;
 TUPLE: ebnf-repeat0 group ;
 TUPLE: ebnf-repeat1 group ;
 TUPLE: ebnf-optional group ;
+TUPLE: ebnf-whitespace group ;
 TUPLE: ebnf-rule symbol elements ;
 TUPLE: ebnf-action parser code ;
 TUPLE: ebnf-var parser name ;
@@ -34,6 +35,7 @@ C: <ebnf-sequence> ebnf-sequence
 C: <ebnf-repeat0> ebnf-repeat0
 C: <ebnf-repeat1> ebnf-repeat1
 C: <ebnf-optional> ebnf-optional
+C: <ebnf-whitespace> ebnf-whitespace
 C: <ebnf-rule> ebnf-rule
 C: <ebnf-action> ebnf-action
 C: <ebnf-var> ebnf-var
@@ -84,6 +86,7 @@ C: <ebnf> ebnf
       [ dup CHAR: + = ]
       [ dup CHAR: ? = ]
       [ dup CHAR: : = ]
+      [ dup CHAR: ~ = ]
     } || not nip    
   ] satisfy repeat1 [ >string <ebnf-non-terminal> ] action ;
 
@@ -134,9 +137,15 @@ DEFER: 'choice'
   #! Parse a group of choices, with a suffix indicating
   #! the type of group (repeat0, repeat1, etc) and
   #! an quot that is the action that produces the AST.
+  2dup
+  [
     "(" [ 'choice' sp ] delay ")" syntax-pack 
     swap 2seq  
-  [ first ] rot compose action ;
+    [ first ] rot compose action ,
+    "{" [ 'choice' sp ] delay "}" syntax-pack 
+    swap 2seq  
+    [ first <ebnf-whitespace> ] rot compose action ,
+  ] choice* ;
   
 : 'group' ( -- parser )
   #! A grouping with no suffix. Used for precedence.
@@ -238,9 +247,15 @@ GENERIC: (transform) ( ast -- parser )
 
 SYMBOL: parser
 SYMBOL: main
+SYMBOL: ignore-ws
 
 : transform ( ast -- object )
-  H{ } clone dup dup [ parser set swap (transform) main set ] bind ;
+  H{ } clone dup dup [ 
+    f ignore-ws set 
+    parser set 
+    swap (transform) 
+    main set 
+  ] bind ;
 
 M: ebnf (transform) ( ast -- parser )
   rules>> [ (transform) ] map peek ;
@@ -252,7 +267,13 @@ M: ebnf-rule (transform) ( ast -- parser )
   ] keep ;
 
 M: ebnf-sequence (transform) ( ast -- parser )
-  elements>> [ (transform) ] map seq [ dup length 1 = [ first ] when ] action ;
+  #! If ignore-ws is set then each element of the sequence
+  #! ignores leading whitespace. This is not inherited by
+  #! subelements of the sequence.
+  elements>> [ 
+    f ignore-ws [ (transform) ] with-variable
+    ignore-ws get [ sp ] when
+  ] map seq [ dup length 1 = [ first ] when ] action ;
 
 M: ebnf-choice (transform) ( ast -- parser )
   options>> [ (transform) ] map choice ;
@@ -282,6 +303,9 @@ M: ebnf-repeat1 (transform) ( ast -- parser )
 M: ebnf-optional (transform) ( ast -- parser )
   transform-group optional ;
 
+M: ebnf-whitespace (transform) ( ast -- parser )
+  t ignore-ws [ transform-group ] with-variable ;
+
 GENERIC: build-locals ( code ast -- code )
 
 M: ebnf-sequence build-locals ( code ast -- code )

extra/peg/expr/expr.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Chris Double.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel arrays strings math.parser sequences
-peg peg.ebnf peg.parsers memoize math ;
+peg peg.ebnf peg.parsers memoize math accessors ;
 IN: peg.expr
 
 EBNF: expr 
@@ -20,5 +20,5 @@ exp      =   exp "+" fac    => [[ first3 nip + ]]
 ;EBNF
 
 : eval-expr ( string -- number )
-  expr parse-result-ast ;
+  expr ast>> ;
 

extra/peg/peg-tests.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2007 Chris Double.
 ! See http://factorcode.org/license.txt for BSD license.
 !
-USING: kernel tools.test strings namespaces arrays sequences peg peg.private accessors words math ;
+USING: kernel tools.test strings namespaces arrays sequences 
+       peg peg.private accessors words math accessors ;
 IN: peg.tests
 
 { f } [
@@ -10,7 +11,7 @@ IN: peg.tests
 
 { "begin" "end" } [
   "beginend" "begin" token parse 
-  { parse-result-ast parse-result-remaining } get-slots
+  { ast>> remaining>> } get-slots
   >string
 ] unit-test
 
@@ -23,11 +24,11 @@ IN: peg.tests
 ] unit-test
 
 { CHAR: a } [
-  "abcd" CHAR: a CHAR: z range parse parse-result-ast
+  "abcd" CHAR: a CHAR: z range parse ast>>
 ] unit-test
 
 { CHAR: z } [
-  "zbcd" CHAR: a CHAR: z range parse parse-result-ast
+  "zbcd" CHAR: a CHAR: z range parse ast>>
 ] unit-test
 
 { f } [
@@ -35,15 +36,15 @@ IN: peg.tests
 ] unit-test
 
 { V{ "g" "o" } } [
-  "good" "g" token "o" token 2array seq parse parse-result-ast
+  "good" "g" token "o" token 2array seq parse ast>>
 ] unit-test
 
 { "a" } [
-  "abcd" "a" token "b" token 2array choice parse parse-result-ast
+  "abcd" "a" token "b" token 2array choice parse ast>>
 ] unit-test
 
 { "b" } [
-  "bbcd" "a" token "b" token 2array choice parse parse-result-ast
+  "bbcd" "a" token "b" token 2array choice parse ast>>
 ] unit-test
 
 { f } [
@@ -55,15 +56,15 @@ IN: peg.tests
 ] unit-test
 
 { 0 } [
-  "" "a" token repeat0 parse parse-result-ast length
+  "" "a" token repeat0 parse ast>> length
 ] unit-test
 
 { 0 } [
-  "b" "a" token repeat0 parse parse-result-ast length
+  "b" "a" token repeat0 parse ast>> length
 ] unit-test
 
 { V{ "a" "a" "a" } } [
-  "aaab" "a" token repeat0 parse parse-result-ast 
+  "aaab" "a" token repeat0 parse ast>> 
 ] unit-test
 
 { f } [
@@ -75,15 +76,15 @@ IN: peg.tests
 ] unit-test
 
 { V{ "a" "a" "a" } } [
-  "aaab" "a" token repeat1 parse parse-result-ast
+  "aaab" "a" token repeat1 parse ast>>
 ] unit-test
 
 { V{ "a" "b" } } [ 
-  "ab" "a" token optional "b" token 2array seq parse parse-result-ast 
+  "ab" "a" token optional "b" token 2array seq parse ast>> 
 ] unit-test
 
 { V{ f "b" } } [ 
-  "b" "a" token optional "b" token 2array seq parse parse-result-ast 
+  "b" "a" token optional "b" token 2array seq parse ast>> 
 ] unit-test
 
 { f } [ 
@@ -91,7 +92,7 @@ IN: peg.tests
 ] unit-test
 
 { V{ CHAR: a CHAR: b } } [
-  "ab" "a" token ensure CHAR: a CHAR: z range dup 3array seq parse parse-result-ast
+  "ab" "a" token ensure CHAR: a CHAR: z range dup 3array seq parse ast>>
 ] unit-test
 
 { f } [
@@ -123,11 +124,11 @@ IN: peg.tests
 ] unit-test
 
 { 1 } [
-  "a" "a" token [ drop 1 ] action parse parse-result-ast 
+  "a" "a" token [ drop 1 ] action parse ast>> 
 ] unit-test
 
 { V{ 1 1 } } [
-  "aa" "a" token [ drop 1 ] action dup 2array seq parse parse-result-ast 
+  "aa" "a" token [ drop 1 ] action dup 2array seq parse ast>> 
 ] unit-test
 
 { f } [
@@ -139,19 +140,19 @@ IN: peg.tests
 ] unit-test
 
 { CHAR: a } [ 
-  "a" [ CHAR: a = ] satisfy parse parse-result-ast
+  "a" [ CHAR: a = ] satisfy parse ast>>
 ] unit-test
 
 { "a" } [
-  "    a" "a" token sp parse parse-result-ast
+  "    a" "a" token sp parse ast>>
 ] unit-test
 
 { "a" } [
-  "a" "a" token sp parse parse-result-ast
+  "a" "a" token sp parse ast>>
 ] unit-test
 
 { V{ "a" } } [
-  "[a]" "[" token hide "a" token "]" token hide 3array seq parse parse-result-ast
+  "[a]" "[" token hide "a" token "]" token hide 3array seq parse ast>>
 ] unit-test
 
 { f } [
@@ -164,8 +165,8 @@ IN: peg.tests
     [ "1" token , "-" token , "1" token , ] seq* ,
     [ "1" token , "+" token , "1" token , ] seq* ,
   ] choice* 
-  "1-1" over parse parse-result-ast swap
+  "1-1" over parse ast>> swap
-  "1+1" swap parse parse-result-ast
+  "1+1" swap parse ast>>
 ] unit-test
 
 : expr ( -- parser ) 
@@ -174,7 +175,7 @@ IN: peg.tests
   [ expr ] delay "+" token "1" token 3seq "1" token 2choice ;
 
 { V{ V{ "1" "+" "1" } "+" "1" } } [
-  "1+1+1" expr parse parse-result-ast   
+  "1+1+1" expr parse ast>>   
 ] unit-test
 
 { t } [
@@ -189,6 +190,6 @@ IN: peg.tests
 ] unit-test
 
 { CHAR: B } [
-  "B" [ drop t ] satisfy [ 66 >= ] semantic parse parse-result-ast
+  "B" [ drop t ] satisfy [ 66 >= ] semantic parse ast>>
 ] unit-test
 

extra/peg/pl0/pl0-tests.factor

@@ -1,43 +1,44 @@
 ! Copyright (C) 2007 Chris Double.
 ! See http://factorcode.org/license.txt for BSD license.
 !
-USING: kernel tools.test peg peg.ebnf peg.pl0 multiline sequences ;
+USING: kernel tools.test peg peg.ebnf peg.pl0 
+       multiline sequences accessors ;
 IN: peg.pl0.tests
 
 { t } [
-  "CONST foo = 1;" "block" \ pl0 rule parse parse-result-remaining empty? 
+  "CONST foo = 1;" "block" \ pl0 rule parse remaining>> empty? 
 ] unit-test
 
 { t } [
-  "VAR foo;" "block" \ pl0 rule parse parse-result-remaining empty?
+  "VAR foo;" "block" \ pl0 rule parse remaining>> empty?
 ] unit-test
 
 { t } [
-  "VAR foo,bar , baz;" "block" \ pl0 rule parse parse-result-remaining empty? 
+  "VAR foo,bar , baz;" "block" \ pl0 rule parse remaining>> empty? 
 ] unit-test
 
 { t } [
-  "foo := 5" "statement" \ pl0 rule parse parse-result-remaining empty? 
+  "foo := 5" "statement" \ pl0 rule parse remaining>> empty? 
 ] unit-test
 
 { t } [
-  "BEGIN foo := 5 END" "statement" \ pl0 rule parse parse-result-remaining empty? 
+  "BEGIN foo := 5 END" "statement" \ pl0 rule parse remaining>> empty? 
 ] unit-test
 
 { t } [
-  "IF 1=1 THEN foo := 5" "statement" \ pl0 rule parse parse-result-remaining empty? 
+  "IF 1=1 THEN foo := 5" "statement" \ pl0 rule parse remaining>> empty? 
 ] unit-test
 
 { t } [
-  "WHILE 1=1 DO foo := 5" "statement" \ pl0 rule parse parse-result-remaining empty? 
+  "WHILE 1=1 DO foo := 5" "statement" \ pl0 rule parse remaining>> empty? 
 ] unit-test
 
 { t } [
-  "WHILE ODD 1 DO foo := 5" "statement" \ pl0 rule parse parse-result-remaining empty? 
+  "WHILE ODD 1 DO foo := 5" "statement" \ pl0 rule parse remaining>> empty? 
 ] unit-test
 
 { t } [
-  "PROCEDURE square; BEGIN squ:=x*x END" "block" \ pl0 rule parse parse-result-remaining empty? 
+  "PROCEDURE square; BEGIN squ:=x*x END" "block" \ pl0 rule parse remaining>> empty? 
 ] unit-test
 
 { t } [
@@ -57,7 +58,7 @@ BEGIN
       x := x + 1;
    END
 END.
-"> pl0 parse-result-remaining empty?
+"> pl0 remaining>> empty?
 ] unit-test
 
 { f } [
@@ -123,5 +124,5 @@ BEGIN
   y := 36;
   CALL gcd;
 END.
-  "> pl0 parse-result-remaining empty?
+  "> pl0 remaining>> empty?
 ] unit-test

extra/peg/pl0/pl0.factor

@@ -7,52 +7,22 @@ IN: peg.pl0
 #! Grammar for PL/0 based on http://en.wikipedia.org/wiki/PL/0
 
 EBNF: pl0 
-_ = (" " | "\t" | "\n")* => [[ drop ignore ]]
 
-BEGIN       = "BEGIN" _
+block       =  { "CONST" ident "=" number { "," ident "=" number }* ";" }? 
-CALL        = "CALL" _
+               { "VAR" ident { "," ident }* ";" }? 
-CONST       = "CONST" _
+               { "PROCEDURE" ident ";" { block ";" }? }* statement 
-DO          = "DO" _
+statement   =  {  ident ":=" expression 
-END         = "END" _
+                | "CALL" ident 
-IF          = "IF" _
+                | "BEGIN" statement { ";" statement }* "END" 
-THEN        = "THEN" _
+                | "IF" condition "THEN" statement 
-ODD         = "ODD" _
+                | "WHILE" condition "DO" statement }?  
-PROCEDURE   = "PROCEDURE" _
+condition   =  { "ODD" expression }
-VAR         = "VAR" _
+             | { expression ("=" | "#" | "<=" | "<" | ">=" | ">") expression }
-WHILE       = "WHILE" _
+expression  = {"+" | "-"}? term { {"+" | "-"} term }* 
-EQ          = "=" _
+term        = factor { {"*" | "/"} factor }* 
-LTEQ        = "<=" _
+factor      = ident | number | "(" expression ")"
-LT          = "<" _
+ident       = (([a-zA-Z])+)   => [[ >string ]]
-GT          = ">" _
-GTEQ        = ">=" _
-NEQ         = "#" _
-COMMA       = "," _
-SEMICOLON   = ";" _
-ASSIGN      = ":=" _
-
-ADD         = "+" _
-SUBTRACT    = "-" _
-MULTIPLY    = "*" _
-DIVIDE      = "/" _
-
-LPAREN      = "(" _
-RPAREN      = ")" _
-
-block       =  ( CONST ident EQ number ( COMMA ident EQ number )* SEMICOLON )? 
-               ( VAR ident ( COMMA ident )* SEMICOLON )? 
-               ( PROCEDURE ident SEMICOLON ( block SEMICOLON )? )* statement 
-statement   =  (  ident ASSIGN expression 
-                | CALL ident 
-                | BEGIN statement ( SEMICOLON statement )* END 
-                | IF condition THEN statement 
-                | WHILE condition DO statement )?  
-condition   =  ODD expression 
-             | expression (EQ | NEQ | LTEQ | LT | GTEQ | GT) expression
-expression  = (ADD | SUBTRACT)? term ( (ADD | SUBTRACT) term )* _
-term        = factor ( (MULTIPLY | DIVIDE) factor )* 
-factor      = ident | number | LPAREN expression RPAREN
-ident       = (([a-zA-Z])+) _ => [[ >string ]]
 digit       = ([0-9])         => [[ digit> ]]
-number      = ((digit)+) _    => [[ 10 digits>integer ]]
+number      = (digit)+        => [[ 10 digits>integer ]]
-program     = _ block "."
+program     = { block "." }
 ;EBNF

extra/semantic-db/semantic-db.factor

@@ -11,7 +11,7 @@ C: <node> node
 
 node "node"
 {
-    { "id" "id" +native-id+ +autoincrement+ }
+    { "id" "id" +db-assigned-id+ +autoincrement+ }
     { "content" "content" TEXT }
 } define-persistent
 

extra/sequences/lib/lib.factor

@@ -66,9 +66,9 @@ MACRO: firstn ( n -- )
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: higher ( a b quot -- c ) [ compare 0 > ] curry most ; inline
+: higher ( a b quot -- c ) [ compare +gt+ eq? ] curry most ; inline
 
-: lower  ( a b quot -- c ) [ compare 0 < ] curry most ; inline
+: lower  ( a b quot -- c ) [ compare +lt+ eq? ] curry most ; inline
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 

extra/spheres/authors.txt

@@ -0,0 +1 @@
+Joe Groff

extra/spheres/spheres.factor

@@ -0,0 +1,284 @@
+USING: kernel opengl.demo-support opengl.gl opengl.shaders opengl.framebuffers
+opengl multiline ui.gadgets accessors sequences ui.render ui math 
+arrays arrays.lib combinators ;
+IN: spheres
+
+STRING: plane-vertex-shader
+varying vec3 object_position;
+void
+main()
+{
+    object_position = gl_Vertex.xyz;
+    gl_Position = ftransform();
+}
+;
+
+STRING: plane-fragment-shader
+varying vec3 object_position;
+void
+main()
+{
+    float distance_factor = (gl_FragCoord.z * 0.5 + 0.5);
+    distance_factor = pow(distance_factor, 500.0)*0.5;
+    
+    gl_FragColor = fract((floor(0.125*object_position.x)+floor(0.125*object_position.z)) * 0.5) == 0.0
+        ? vec4(1.0, 1.0 - distance_factor, 1.0 - distance_factor, 1.0)
+        : vec4(1.0, distance_factor, distance_factor, 1.0);
+}
+;
+
+STRING: sphere-vertex-shader
+attribute vec3 center;
+attribute float radius;
+attribute vec4 surface_color;
+varying float vradius;
+varying vec3 sphere_position;
+varying vec4 world_position, vcolor;
+
+void
+main()
+{
+    world_position = gl_ModelViewMatrix * vec4(center, 1);
+    sphere_position = gl_Vertex.xyz;
+    
+    gl_Position = gl_ProjectionMatrix * (world_position + vec4(sphere_position * radius, 0));
+    
+    vcolor = surface_color;
+    vradius = radius;
+}
+;
+
+STRING: sphere-solid-color-fragment-shader
+uniform vec3 light_position;
+varying vec4 vcolor;
+
+const vec4 ambient = vec4(0.25, 0.2, 0.25, 1.0);
+const vec4 diffuse = vec4(0.75, 0.8, 0.75, 1.0);
+
+vec4
+sphere_color(vec3 point, vec3 normal)
+{
+    vec3 transformed_light_position = (gl_ModelViewMatrix * vec4(light_position, 1)).xyz;
+    vec3 direction = normalize(transformed_light_position - point);
+    float d = max(0.0, dot(normal, direction));
+    
+    return ambient * vcolor + diffuse * vec4(d * vcolor.rgb, vcolor.a);
+}
+;
+
+STRING: sphere-texture-fragment-shader
+uniform samplerCube surface_texture;
+
+vec4
+sphere_color(vec3 point, vec3 normal)
+{
+    vec3 reflect = reflect(normalize(point), normal);
+    return textureCube(surface_texture, reflect * gl_NormalMatrix);
+}
+;
+
+STRING: sphere-main-fragment-shader
+varying float vradius;
+varying vec3 sphere_position;
+varying vec4 world_position;
+
+vec4 sphere_color(vec3 point, vec3 normal);
+
+void
+main()
+{
+	float radius = length(sphere_position);
+	if(radius > 1.0) discard;
+	
+	vec3 surface = sphere_position + vec3(0.0, 0.0, sqrt(1.0 - radius*radius));
+	vec4 world_surface = world_position + vec4(surface * vradius, 0);
+	vec4 transformed_surface = gl_ProjectionMatrix * world_surface;
+	
+    gl_FragDepth = (transformed_surface.z/transformed_surface.w + 1.0) * 0.5;
+	gl_FragColor = sphere_color(world_surface.xyz, surface);
+}
+;
+
+TUPLE: spheres-gadget
+    plane-program solid-sphere-program texture-sphere-program
+    reflection-framebuffer reflection-depthbuffer
+    reflection-texture ;
+
+: <spheres-gadget> ( -- gadget )
+    20.0 10.0 20.0 <demo-gadget>
+    { set-delegate } spheres-gadget construct ;
+
+M: spheres-gadget near-plane ( gadget -- z )
+    drop 1.0 ;
+M: spheres-gadget far-plane ( gadget -- z )
+    drop 512.0 ;
+M: spheres-gadget distance-step ( gadget -- dz )
+    drop 0.5 ;
+
+: (reflection-dim) ( -- w h )
+    512 512 ;
+
+: (make-reflection-texture) ( -- texture )
+    gen-texture [
+        GL_TEXTURE_CUBE_MAP swap glBindTexture
+        GL_TEXTURE_CUBE_MAP GL_TEXTURE_MAG_FILTER GL_LINEAR glTexParameteri
+        GL_TEXTURE_CUBE_MAP GL_TEXTURE_MIN_FILTER GL_LINEAR glTexParameteri
+        GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_S GL_CLAMP glTexParameteri
+        GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_T GL_CLAMP glTexParameteri
+        GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_R GL_CLAMP glTexParameteri
+        GL_TEXTURE_CUBE_MAP_POSITIVE_X
+        GL_TEXTURE_CUBE_MAP_POSITIVE_Y
+        GL_TEXTURE_CUBE_MAP_POSITIVE_Z
+        GL_TEXTURE_CUBE_MAP_NEGATIVE_X
+        GL_TEXTURE_CUBE_MAP_NEGATIVE_Y
+        GL_TEXTURE_CUBE_MAP_NEGATIVE_Z 6 narray
+        [ 0 GL_RGBA8 (reflection-dim) 0 GL_RGBA GL_UNSIGNED_BYTE f glTexImage2D ]
+        each
+    ] keep ;
+
+: (make-reflection-depthbuffer) ( -- depthbuffer )
+    gen-renderbuffer [
+        GL_RENDERBUFFER_EXT swap glBindRenderbufferEXT
+        GL_RENDERBUFFER_EXT GL_DEPTH_COMPONENT32 (reflection-dim) glRenderbufferStorageEXT
+    ] keep ;
+
+: (make-reflection-framebuffer) ( depthbuffer -- framebuffer )
+    gen-framebuffer dup [
+        swap >r
+        GL_FRAMEBUFFER_EXT GL_DEPTH_ATTACHMENT_EXT GL_RENDERBUFFER_EXT r>
+        glFramebufferRenderbufferEXT
+    ] with-framebuffer ;
+
+: (plane-program) ( -- program )
+    plane-vertex-shader plane-fragment-shader <simple-gl-program> ;
+: (solid-sphere-program) ( -- program )
+    sphere-vertex-shader <vertex-shader> check-gl-shader
+    sphere-solid-color-fragment-shader <fragment-shader> check-gl-shader
+    sphere-main-fragment-shader <fragment-shader> check-gl-shader
+    3array <gl-program> check-gl-program ;
+: (texture-sphere-program) ( -- program )
+    sphere-vertex-shader <vertex-shader> check-gl-shader
+    sphere-texture-fragment-shader <fragment-shader> check-gl-shader
+    sphere-main-fragment-shader <fragment-shader> check-gl-shader
+    3array <gl-program> check-gl-program ;
+
+M: spheres-gadget graft* ( gadget -- )
+    (plane-program) >>plane-program
+    (solid-sphere-program) >>solid-sphere-program
+    (texture-sphere-program) >>texture-sphere-program
+    (make-reflection-texture) >>reflection-texture
+    (make-reflection-depthbuffer) [ >>reflection-depthbuffer ] keep
+    (make-reflection-framebuffer) >>reflection-framebuffer
+    drop ;
+
+M: spheres-gadget ungraft* ( gadget -- )
+    {
+        [ reflection-framebuffer>> [ delete-framebuffer ] when* ]
+        [ reflection-depthbuffer>> [ delete-renderbuffer ] when* ]
+        [ reflection-texture>> [ delete-texture ] when* ]
+        [ solid-sphere-program>> [ delete-gl-program ] when* ]
+        [ texture-sphere-program>> [ delete-gl-program ] when* ]
+        [ plane-program>> [ delete-gl-program ] when* ]
+    } cleave ;
+
+M: spheres-gadget pref-dim* ( gadget -- dim )
+    drop { 640 480 } ;
+    
+: (draw-sphere) ( program center radius surfacecolor -- )
+    roll
+    [ [ "center" glGetAttribLocation swap first3 glVertexAttrib3f ] curry ]
+    [ [ "radius" glGetAttribLocation swap glVertexAttrib1f ] curry ]
+    [ [ "surface_color" glGetAttribLocation swap first4 glVertexAttrib4f ] curry ]
+    tri tri*
+    { -1.0 -1.0 } { 1.0 1.0 } rect-vertices ;
+
+: sphere-scene ( gadget -- )
+    GL_DEPTH_BUFFER_BIT GL_COLOR_BUFFER_BIT bitor glClear
+    [
+        solid-sphere-program>> dup {
+            { "light_position" [ 0.0 0.0 100.0 glUniform3f ] }
+        } [
+            {
+                [ {  7.0  0.0  0.0 } 1.0 { 1.0 0.0 0.0 1.0 } (draw-sphere) ]
+                [ { -7.0  0.0  0.0 } 1.0 { 0.0 1.0 0.0 1.0 } (draw-sphere) ]
+                [ {  0.0  0.0  7.0 } 1.0 { 0.0 0.0 1.0 1.0 } (draw-sphere) ]
+                [ {  0.0  0.0 -7.0 } 1.0 { 1.0 1.0 0.0 1.0 } (draw-sphere) ]
+                [ {  0.0  7.0  0.0 } 1.0 { 1.0 0.0 1.0 1.0 } (draw-sphere) ]
+                [ {  0.0 -7.0  0.0 } 1.0 { 0.0 1.0 1.0 1.0 } (draw-sphere) ]
+            } cleave
+        ] with-gl-program
+    ] [
+        plane-program>> { } [
+            GL_QUADS [
+                -1000.0 -30.0  1000.0 glVertex3f
+                -1000.0 -30.0 -1000.0 glVertex3f
+                 1000.0 -30.0 -1000.0 glVertex3f
+                 1000.0 -30.0  1000.0 glVertex3f
+            ] do-state
+        ] with-gl-program
+    ] bi ;
+
+: reflection-frustum ( gadget -- -x x -y y near far )
+    [ near-plane ] [ far-plane ] bi [
+        drop dup [ -+ ] bi@
+    ] 2keep ;
+
+: (reflection-face) ( gadget face -- )
+    swap reflection-texture>> >r >r
+    GL_FRAMEBUFFER_EXT
+    GL_COLOR_ATTACHMENT0_EXT
+    r> r> 0 glFramebufferTexture2DEXT
+    check-framebuffer ;
+
+: (draw-reflection-texture) ( gadget -- )
+    dup reflection-framebuffer>> [ {
+        [ drop 0 0 (reflection-dim) glViewport ]
+        [
+            GL_PROJECTION glMatrixMode
+            glLoadIdentity
+            reflection-frustum glFrustum
+            GL_MODELVIEW glMatrixMode
+            glLoadIdentity
+            180.0 0.0 0.0 1.0 glRotatef
+        ]
+        [ GL_TEXTURE_CUBE_MAP_NEGATIVE_Z (reflection-face) ]
+        [ sphere-scene ]
+        [ GL_TEXTURE_CUBE_MAP_POSITIVE_X (reflection-face)
+          90.0 0.0 1.0 0.0 glRotatef ]
+        [ sphere-scene ]
+        [ GL_TEXTURE_CUBE_MAP_POSITIVE_Z (reflection-face)
+          90.0 0.0 1.0 0.0 glRotatef glPushMatrix ]
+        [ sphere-scene ]
+        [ GL_TEXTURE_CUBE_MAP_NEGATIVE_X (reflection-face)
+          90.0 0.0 1.0 0.0 glRotatef ]
+        [ sphere-scene ]
+        [ GL_TEXTURE_CUBE_MAP_NEGATIVE_Y (reflection-face)
+          glPopMatrix glPushMatrix -90.0 1.0 0.0 0.0 glRotatef ]
+        [ sphere-scene ]
+        [ GL_TEXTURE_CUBE_MAP_POSITIVE_Y (reflection-face)
+          glPopMatrix 90.0 1.0 0.0 0.0 glRotatef ]
+        [ sphere-scene ]
+        [ dim>> 0 0 rot first2 glViewport ]
+    } cleave ] with-framebuffer ;
+
+M: spheres-gadget draw-gadget* ( gadget -- )
+    GL_DEPTH_TEST glEnable
+    GL_SCISSOR_TEST glDisable
+    0.15 0.15 1.0 1.0 glClearColor {
+        [ (draw-reflection-texture) ]
+        [ demo-gadget-set-matrices ]
+        [ sphere-scene ]
+        [ reflection-texture>> GL_TEXTURE_CUBE_MAP GL_TEXTURE0 bind-texture-unit ]
+        [
+            texture-sphere-program>> dup {
+                { "surface_texture" [ 0 glUniform1i ] }
+            } [
+                { 0.0 0.0 0.0 } 4.0 { 1.0 0.0 0.0 1.0 } (draw-sphere)
+            ] with-gl-program
+        ]
+    } cleave ;
+
+: spheres-window ( -- )
+    [ <spheres-gadget> "Spheres" open-window ] with-ui ;
+
+MAIN: spheres-window

extra/spheres/summary.txt

@@ -0,0 +1 @@
+Draw pixel-perfect spheres using GLSL shaders

extra/spheres/tags.txt

@@ -0,0 +1,2 @@
+opengl
+glsl

extra/symbols/symbols.factor

@@ -1,9 +1,14 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: parser sequences words kernel ;
+USING: parser sequences words kernel classes.singleton ;
 IN: symbols
 
 : SYMBOLS:
     ";" parse-tokens
     [ create-in dup reset-generic define-symbol ] each ;
     parsing
+
+: SINGLETONS:
+    ";" parse-tokens
+    [ create-class-in dup save-location define-singleton-class ] each ;
+    parsing

extra/tools/vocabs/monitor/monitor.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: threads io.files io.monitors init kernel
 vocabs vocabs.loader tools.vocabs namespaces continuations
-sequences splitting assocs command-line ;
+sequences splitting assocs command-line concurrency.messaging io.backend sets ;
 IN: tools.vocabs.monitor
 
 : vocab-dir>vocab-name ( path -- vocab )
@@ -22,17 +22,20 @@ IN: tools.vocabs.monitor
 : path>vocab ( path -- vocab )
     chop-vocab-root path>vocab-name vocab-dir>vocab-name ;
 
-: monitor-loop ( monitor -- )
+: monitor-loop ( -- )
     #! On OS X, monitors give us the full path, so we chop it
     #! off if its there.
-    dup next-change drop path>vocab changed-vocab
+    receive first path>vocab changed-vocab
     reset-cache
     monitor-loop ;
 
+: add-monitor-for-path ( path -- ) 
+    normalize-path dup exists? [ t my-mailbox (monitor) ] when drop ;
+    
 : monitor-thread ( -- )
     [
         [
-            "" resource-path t <monitor>
+            vocab-roots get prune [ add-monitor-for-path ] each
             
             H{ } clone changed-vocabs set-global
             vocabs [ changed-vocab ] each

extra/tools/walker/walker.factor

@@ -259,3 +259,8 @@ SYMBOL: +stopped+
     ] 3curry
     "Walker on " self thread-name append spawn
     [ associate-thread ] keep ;
+
+! For convenience
+IN: syntax
+
+: B break ;

extra/trees/splay/splay.factor

@@ -30,13 +30,13 @@ INSTANCE: splay tree-mixin
     drop dup node-right swapd r> swap ;
 
 : cmp ( key node -- obj node -1/0/1 )
-    2dup node-key <=> ;
+    2dup node-key key-side ;
 
 : lcmp ( key node -- obj node -1/0/1 ) 
-    2dup node-left node-key <=> ;
+    2dup node-left node-key key-side ;
 
 : rcmp ( key node -- obj node -1/0/1 ) 
-    2dup node-right node-key <=> ;
+    2dup node-right node-key key-side ;
 
 DEFER: (splay)
 

extra/trees/trees.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel generic math sequences arrays io namespaces
 prettyprint.private kernel.private assocs random combinators
-parser prettyprint.backend math.order ;
+parser prettyprint.backend math.order accessors ;
 IN: trees
 
 MIXIN: tree-mixin
@@ -25,19 +25,24 @@ TUPLE: node key value left right ;
 
 SYMBOL: current-side
 
-: left -1 ; inline
+: left ( -- symbol ) -1 ; inline
-: right 1 ; inline
+: right ( -- symbol ) 1 ; inline
 
-: go-left? ( -- ? ) current-side get left = ;
+: key-side ( k1 k2 -- n )
+    <=> {
+        { +lt+ [ -1 ] }
+        { +eq+ [ 0 ] }
+        { +gt+ [ 1 ] }
+    } case ;
 
-: inc-count ( tree -- )
+: go-left? ( -- ? ) current-side get left eq? ;
-    dup tree-count 1+ swap set-tree-count ;
 
-: dec-count ( tree -- )
+: inc-count ( tree -- ) [ 1+ ] change-count drop ;
-    dup tree-count 1- swap set-tree-count ;
+
+: dec-count ( tree -- ) [ 1- ] change-count drop ;
 
 : node-link@ ( node ? -- node )
-    go-left? xor [ node-left ] [ node-right ] if ;
+    go-left? xor [ left>> ] [ right>> ] if ;
 : set-node-link@ ( left parent ? -- ) 
     go-left? xor [ set-node-left ] [ set-node-right ] if ;
 
@@ -47,19 +52,16 @@ SYMBOL: current-side
 : set-node+link ( child node -- ) t set-node-link@ ;
 
 : with-side ( side quot -- ) [ swap current-side set call ] with-scope ; inline
-: with-other-side ( quot -- ) current-side get neg swap with-side ; inline
+: with-other-side ( quot -- )
+    current-side get neg swap with-side ; inline
 : go-left ( quot -- ) left swap with-side ; inline
 : go-right ( quot -- ) right swap with-side ; inline
 
 : change-root ( tree quot -- )
-    swap [ tree-root swap call ] keep set-tree-root ; inline
+    swap [ root>> swap call ] keep set-tree-root ; inline
 
 : leaf? ( node -- ? )
-    dup node-left swap node-right or not ;
+    [ left>> ] [ right>> ] bi or not ;
-
-: key-side ( k1 k2 -- side )
-    #! side is -1 if k1 < k2, 0 if they are equal, or 1 if k1 > k2
-    <=> sgn ;
 
 : random-side ( -- side ) left right 2array random ;
 
@@ -76,11 +78,11 @@ SYMBOL: current-side
     ] [ drop f f ] if* ;
 
 M: tree at* ( key tree -- value ? )
-    tree-root node-at* ;
+    root>> node-at* ;
 
 : node-set ( value key node -- node )
-    2dup node-key key-side dup zero? [
+    2dup key>> key-side dup 0 eq? [
-        drop nip [ set-node-value ] keep
+        drop nip swap >>value
     ] [
         [
             [ node-link [ node-set ] [ swap <node> ] if* ] keep
@@ -93,12 +95,12 @@ M: tree set-at ( value key tree -- )
 
 : valid-node? ( node -- ? )
     [
-        dup dup node-left [ node-key swap node-key before? ] when* >r
+        dup dup left>> [ node-key swap node-key before? ] when* >r
-        dup dup node-right [ node-key swap node-key after? ] when* r> and swap
+        dup dup right>> [ node-key swap node-key after? ] when* r> and swap
-        dup node-left valid-node? swap node-right valid-node? and and
+        dup left>> valid-node? swap right>> valid-node? and and
     ] [ t ] if* ;
 
-: valid-tree? ( tree -- ? ) tree-root valid-node? ;
+: valid-tree? ( tree -- ? ) root>> valid-node? ;
 
 : tree-call ( node call -- )
     >r [ node-key ] keep node-value r> call ; inline
@@ -107,20 +109,20 @@ M: tree set-at ( value key tree -- )
     {
         { [ over not ] [ 2drop f f f ] }
         { [ [
-              >r node-left r> find-node
+              >r left>> r> find-node
             ] 2keep rot ]
           [ 2drop t ] }
         { [ >r 2nip r> [ tree-call ] 2keep rot ]
           [ drop [ node-key ] keep node-value t ] }
-        [ >r node-right r> find-node ]
+        [ >r right>> r> find-node ]
     } cond ; inline
 
 M: tree-mixin assoc-find ( tree quot -- key value ? )
-    >r tree-root r> find-node ;
+    >r root>> r> find-node ;
 
 M: tree-mixin clear-assoc
-    0 over set-tree-count
+    0 >>count
-    f swap set-tree-root ;
+    f >>root drop ;
 
 : copy-node-contents ( new old -- )
     dup node-key pick set-node-key node-value swap set-node-value ;
@@ -158,22 +160,22 @@ DEFER: delete-node
 
 : delete-node ( node -- node )
     #! delete this node, returning its replacement
-    dup node-left [
+    dup left>> [
-        dup node-right [
+        dup right>> [
             delete-node-with-two-children
         ] [
-            node-left ! left but no right
+            left>> ! left but no right
         ] if
     ] [
-        dup node-right [
+        dup right>> [
-            node-right ! right but not left
+            right>> ! right but not left
         ] [
             drop f ! no children
         ] if
     ] if ;
 
 : delete-bst-node ( key node -- node )
-    2dup node-key key-side dup zero? [
+    2dup node-key key-side dup 0 eq? [
         drop nip delete-node
     ] [
         [ tuck node-link delete-bst-node over set-node-link ] with-side
@@ -197,7 +199,7 @@ M: tree-mixin assoc-like drop dup tree? [ >tree ] unless ;
 
 M: tree pprint-delims drop \ TREE{ \ } ;
 
-M: tree-mixin assoc-size tree-count ;
+M: tree-mixin assoc-size count>> ;
 M: tree-mixin clone dup assoc-clone-like ;
 M: tree-mixin >pprint-sequence >alist ;
 M: tree-mixin pprint-narrow? drop t ;

extra/ui/gadgets/gadgets.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays hashtables kernel models math namespaces sequences
 quotations math.vectors combinators sorting vectors dlists
-models threads concurrency.flags ;
+models threads concurrency.flags math.order ;
 IN: ui.gadgets
 
 SYMBOL: ui-notify-flag
@@ -106,7 +106,7 @@ GENERIC: children-on ( rect/point gadget -- seq )
 M: gadget children-on nip gadget-children ;
 
 : (fast-children-on) ( dim axis gadgets -- i )
-    swapd [ rect-loc v- over v. ] binsearch nip ;
+    swapd [ rect-loc v- over v. 0 <=> ] binsearch nip ;
 
 : fast-children-on ( rect axis children -- from to )
     3dup

extra/update/update.factor

@@ -22,7 +22,8 @@ IN: update
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 : remote-clean-image ( -- url )
-  "http://factorcode.org/images/clean/" my-boot-image-name append ;
+  { "http://factorcode.org/images/clean/" platform "/" my-boot-image-name }
+  to-string ;
 
 : download-clean-image ( -- ) remote-clean-image download ;
 

extra/usa-cities/usa-cities.factor

@@ -0,0 +1,53 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.files io.encodings.ascii sequences sequences.lib
+math.parser combinators kernel memoize csv symbols inspector
+words accessors math.order sorting ;
+IN: usa-cities
+
+SINGLETONS: AK AL AR AS AZ CA CO CT DC DE FL GA HI IA ID IL IN
+KS KY LA MA MD ME MI MN MO MS MT NC ND NE NH NJ NM NV NY OH OK
+OR PA PR RI SC SD TN TX UT VA VI VT WA WI WV WY ;
+
+: states ( -- seq )
+    {
+        AK AL AR AS AZ CA CO CT DC DE FL GA HI IA ID IL IN KS KY
+        LA MA MD ME MI MN MO MS MT NC ND NE NH NJ NM NV NY OH OK
+        OR PA PR RI SC SD TN TX UT VA VI VT WA WI WV WY
+    } ; inline
+
+ERROR: no-such-state name ;
+
+M: no-such-state summary drop "No such state" ;
+
+MEMO: string>state ( string -- state )
+    dup states [ word-name = ] with find nip
+    [ ] [ no-such-state ] ?if ;
+
+TUPLE: city
+first-zip name state latitude longitude gmt-offset dst-offset ;
+
+MEMO: cities ( -- seq )
+    "resource:extra/usa-cities/zipcode.csv" ascii <file-reader>
+    csv rest-slice [
+        7 firstn {
+            [ string>number ]
+            [ ]
+            [ string>state ]
+            [ string>number ]
+            [ string>number ]
+            [ string>number ]
+            [ string>number ]
+        } spread city boa
+    ] map ;
+
+MEMO: cities-named ( name -- cities )
+    cities [ name>> = ] with filter ;
+
+MEMO: cities-named-in ( name state -- cities )
+    cities [
+        tuck [ name>> = ] [ state>> = ] 2bi* and
+    ] with with filter ;
+
+: find-zip-code ( code -- city )
+    cities [ first-zip>> <=> ] binsearch* ;

extra/webapps/counter/counter.factor

@@ -0,0 +1,29 @@
+USING: math kernel accessors http.server http.server.actions
+http.server.sessions http.server.templating.fhtml locals ;
+IN: webapps.counter
+
+SYMBOL: count
+
+TUPLE: counter-app < dispatcher ;
+
+M: counter-app init-session*
+    drop 0 count sset ;
+
+:: <counter-action> ( quot -- action )
+    <action> [
+        count quot schange
+        "" f <standard-redirect>
+    ] >>display ;
+
+: <display-action> ( -- action )
+    <action> [
+        "text/html" <content>
+           "resource:extra/webapps/counter/counter.fhtml" <fhtml> >>body
+    ] >>display ;
+
+: <counter-app> ( -- responder )
+    counter-app new-dispatcher
+        [ 1+ ] <counter-action> "inc" add-responder
+        [ 1- ] <counter-action> "dec" add-responder
+        <display-action> "" add-responder
+    <sessions> ;

extra/webapps/counter/counter.fhtml

@@ -0,0 +1,10 @@
+<% USING: io math.parser http.server.sessions webapps.counter ; %>
+
+<html>
+    <body>
+        <h1><% count sget number>string write %></h1>
+
+        <a href="inc">++</a>
+        <a href="dec">--</a>
+    </body>
+</html>

extra/webapps/factor-website/factor-website.factor

@@ -6,9 +6,9 @@ http.server
 http.server.db
 http.server.flows
 http.server.sessions
+http.server.auth.admin
 http.server.auth.login
 http.server.auth.providers.db
-http.server.sessions.storage.db
 http.server.boilerplate
 http.server.templating.chloe
 webapps.pastebin
@@ -16,7 +16,7 @@ webapps.planet
 webapps.todo ;
 IN: webapps.factor-website
 
-: test-db "test.db" resource-path sqlite-db ;
+: test-db "resource:test.db" sqlite-db ;
 
 : factor-template ( path -- template )
     "resource:extra/webapps/factor-website/" swap ".xml" 3append <chloe> ;
@@ -39,6 +39,7 @@ IN: webapps.factor-website
         <todo-list> "todo" add-responder
         <pastebin> "pastebin" add-responder
         <planet-factor> "planet" add-responder
+        <user-admin> "user-admin" add-responder
     <login>
         users-in-db >>users
         allow-registration
@@ -47,8 +48,7 @@ IN: webapps.factor-website
     <boilerplate>
         "page" factor-template >>template
     <flows>
-    <session-manager>
+    <sessions>
-        sessions-in-db >>sessions
     test-db <db-persistence> ;
 
 : init-factor-website ( -- )

extra/webapps/pastebin/pastebin.factor

@@ -24,7 +24,7 @@ TUPLE: paste id summary author mode date contents annotations captcha ;
 
 paste "PASTE"
 {
-    { "id" "ID" INTEGER +native-id+ }
+    { "id" "ID" INTEGER +db-assigned-id+ }
     { "summary" "SUMMARY" { VARCHAR 256 } +not-null+ }
     { "author" "AUTHOR" { VARCHAR 256 } +not-null+ }
     { "mode" "MODE" { VARCHAR 256 } +not-null+ }
@@ -43,7 +43,7 @@ TUPLE: annotation aid id summary author mode contents date captcha ;
 
 annotation "ANNOTATION"
 {
-    { "aid" "AID" INTEGER +native-id+ }
+    { "aid" "AID" INTEGER +db-assigned-id+ }
     { "id" "ID" INTEGER +not-null+ }
     { "summary" "SUMMARY" { VARCHAR 256 } +not-null+ }
     { "author" "AUTHOR" { VARCHAR 256 } +not-null+ }
@@ -197,9 +197,9 @@ annotation "ANNOTATION"
         { { "id" [ v-number ] } } >>post-params
 
         [
-            "id" get ctor call delete-tuple
+            "id" get ctor call delete-tuples
 
-            "id" get f <annotation> select-tuples [ delete-tuple ] each
+            "id" get f <annotation> delete-tuples
 
             next f <permanent-redirect>
         ] >>submit ;
@@ -209,7 +209,7 @@ annotation "ANNOTATION"
         { { "id" [ v-number ] } { "aid" [ v-number ] } } >>post-params
 
         [
-            "id" get "aid" get ctor call delete-tuple
+            "id" get "aid" get ctor call delete-tuples
 
             "id" get next <id-redirect>
         ] >>submit ;