Merge branch 'master' of git://factorcode.org/git/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/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.factor

@@ -42,4 +42,4 @@ M: real after=? ( obj1 obj2 -- ? ) >= ;
 
 : [-] ( x y -- z ) - 0 max ; inline
 
-: compare ( obj1 obj2 quot -- n ) bi@ <=> ; inline
+: compare ( obj1 obj2 quot -- symbol ) bi@ <=> ; inline

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
@@ -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/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-tuple-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
@@ -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

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-tuple-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,25 +108,28 @@ 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
@@ -139,9 +137,9 @@ M: retryable execute-statement* ( statement type -- )
     [ bind-tuple ] keep execute-statement ;
 
 : delete-tuple ( tuple -- )
-    dup class
+    dup dup class <delete-tuple-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/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

@@ -194,7 +194,7 @@ test-db [
         <dispatcher>
             <action> <protected>
             <login>
-            <session-manager>
+            <sessions>
                 sessions-in-db >>sessions
             "" add-responder
             add-quit-action
@@ -225,7 +225,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

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

@@ -7,7 +7,7 @@ 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 } }

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,13 +1,10 @@
 ! 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? ;
@@ -16,6 +13,28 @@ TUPLE: session id expires namespace changed? ;
     session new
         swap >>id ;
 
+session "SESSIONS"
+{
+    { "id" "ID" +random-id+ system-random-generator }
+    { "expires" "EXPIRES" BIG-INTEGER +not-null+ }
+    { "namespace" "NAMESPACE" FACTOR-BLOB }
+} define-persistent
+
+: get-session ( id -- session )
+    dup [ <session> select-tuple ] when ;
+
+: init-sessions-table session ensure-table ;
+
+: expired-sessions ( -- session )
+    f <session>
+        -1.0/0.0 now timestamp>millis [a,b] >>expires
+    select-tuples ;
+
+: start-expiring-sessions ( db seq -- )
+    '[
+        , , [ expired-sessions [ delete-tuple ] each ] 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,11 @@ TUPLE: session-manager < filter-responder sessions timeout domain ;
     [ namespace>> swap change-at ] keep
     (session-changed) ; inline
 
-: init-session ( session managed -- )
+: init-session ( session -- )
-    >r session r> '[ , init-session* ] with-variable ;
+    session [ sessions get init-session* ] with-variable ;
 
 : cutoff-time ( -- time )
-    session-manager get timeout>> from-now timestamp>millis ;
+    sessions get timeout>> from-now timestamp>millis ;
 
 : touch-session ( session -- )
     cutoff-time >>expires drop ;
@@ -64,57 +82,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 +137,8 @@ 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 ;

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/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/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

@@ -12,7 +12,7 @@ TUPLE: node id content ;
 
 node "node"
 {
-    { "id" "id" +native-id+ +autoincrement+ }
+    { "id" "id" +db-assigned-id+ +autoincrement+ }
     { "content" "content" TEXT }
 } define-persistent
 
@@ -53,7 +53,7 @@ TUPLE: arc id relation subject object ;
 
 arc "arc"
 {
-    { "id" "id" INTEGER +assigned-id+ } ! foreign key to node table?
+    { "id" "id" INTEGER +user-assigned-id+ } ! foreign key to node table?
     { "relation" "relation" INTEGER +not-null+ }
     { "subject" "subject" INTEGER +not-null+ }
     { "object" "object" INTEGER +not-null+ }

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/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

@@ -47,7 +47,7 @@ IN: webapps.factor-website
     <boilerplate>
         "page" factor-template >>template
     <flows>
-    <session-manager>
+    <sessions>
         sessions-in-db >>sessions
     test-db <db-persistence> ;
 

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+ }

extra/webapps/planet/planet.factor

@@ -27,7 +27,7 @@ M: blog link-href www-url>> ;
 
 blog "BLOGS"
 {
-    { "id" "ID" INTEGER +native-id+ }
+    { "id" "ID" INTEGER +db-assigned-id+ }
     { "name" "NAME" { VARCHAR 256 } +not-null+ }
     { "www-url" "WWWURL" { VARCHAR 256 } +not-null+ }
     { "feed-url" "FEEDURL" { VARCHAR 256 } +not-null+ }

extra/webapps/todo/todo.factor

@@ -15,7 +15,7 @@ TUPLE: todo uid id priority summary description ;
 todo "TODO"
 {
     { "uid" "UID" { VARCHAR 256 } +not-null+ }
-    { "id" "ID" +native-id+ }
+    { "id" "ID" +db-assigned-id+ }
     { "priority" "PRIORITY" INTEGER +not-null+ }
     { "summary" "SUMMARY" { VARCHAR 256 } +not-null+ }
     { "description" "DESCRIPTION" { VARCHAR 256 } }

extra/windows/com/syntax/syntax.factor

@@ -57,7 +57,7 @@ unless
 
 : family-tree ( definition -- definitions )
     dup parent>> [ family-tree ] [ { } ] if*
-    swap add ;
+    swap suffix ;
 
 : family-tree-functions ( definition -- functions )
     dup parent>> [ family-tree-functions ] [ { } ] if*

extra/windows/ole32/ole32.factor

@@ -1,5 +1,6 @@
 USING: alien alien.syntax alien.c-types alien.strings math
-kernel sequences windows windows.types combinators.lib ;
+kernel sequences windows windows.types combinators.lib
+math.order ;
 IN: windows.ole32
 
 LIBRARY: ole32