Merge git://factorcode.org/git/factor

core/alien/c-types/c-types.factor

@@ -1,9 +1,10 @@
-! Copyright (C) 2004, 2007 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: byte-arrays float-arrays arrays generator.registers assocs
+USING: bit-arrays byte-arrays float-arrays arrays
-kernel kernel.private libc math namespaces parser sequences
+generator.registers assocs kernel kernel.private libc math
-strings words assocs splitting math.parser cpu.architecture
+namespaces parser sequences strings words assocs splitting
-alien alien.accessors quotations system compiler.units ;
+math.parser cpu.architecture alien alien.accessors quotations
+system compiler.units ;
 IN: alien.c-types
 
 TUPLE: c-type
@@ -109,10 +110,12 @@ M: c-type stack-size c-type-size ;
 
 GENERIC: byte-length ( seq -- n ) flushable
 
-M: float-array byte-length length "double" heap-size * ;
+M: bit-array byte-length length 7 + -3 shift ;
 
 M: byte-array byte-length length ;
 
+M: float-array byte-length length "double" heap-size * ;
+
 : c-getter ( name -- quot )
     c-type c-type-getter [
         [ "Cannot read struct fields with type" throw ]

core/bootstrap/image/image.factor

@@ -203,7 +203,14 @@ M: f '
 
 ! Words
 
+DEFER: emit-word
+
+: emit-generic ( generic -- )
+    dup "default-method" word-prop method-word emit-word
+    "methods" word-prop [ nip method-word emit-word ] assoc-each ;
+
 : emit-word ( word -- )
+    dup generic? [ dup emit-generic ] when
     [
         dup hashcode ' ,
         dup word-name ' ,
@@ -224,7 +231,7 @@ M: f '
     [ % dup word-vocabulary % " " % word-name % ] "" make throw ;
 
 : transfer-word ( word -- word )
-    dup target-word [ ] [ word-name no-word ] ?if ;
+    dup target-word swap or ;
 
 : fixup-word ( word -- offset )
     transfer-word dup objects get at
@@ -248,7 +255,7 @@ M: wrapper '
     emit-seq ;
 
 : pack-string ( string -- newstr )
-    dup length 1+ bootstrap-cell align 0 pad-right ;
+    dup length bootstrap-cell align 0 pad-right ;
 
 : emit-string ( string -- ptr )
     string type-number object tag-number [
@@ -285,17 +292,20 @@ M: float-array ' float-array emit-dummy-array ;
     ] emit-object ;
 
 : emit-tuple ( obj -- pointer )
-    objects get [
+    [
         [ tuple>array unclip transfer-word , % ] { } make
         tuple type-number dup emit-array
-    ] cache ; inline
+    ]
+    ! Hack
+    over class word-name "tombstone" =
+    [ objects get swap cache ] [ call ] if ;
 
 M: tuple ' emit-tuple ;
 
 M: tombstone '
     delegate
     "((tombstone))" "((empty))" ? "hashtables.private" lookup
-    word-def first emit-tuple ;
+    word-def first objects get [ emit-tuple ] cache ;
 
 M: array '
     array type-number object tag-number emit-array ;
@@ -313,41 +323,6 @@ M: quotation '
         ] emit-object
     ] cache ;
 
-! Vectors and sbufs
-
-M: vector '
-    dup length swap underlying '
-    tuple type-number tuple tag-number [
-        4 emit-fixnum
-        vector ' emit
-        f ' emit
-        emit ! array ptr
-        emit-fixnum ! length
-    ] emit-object ;
-
-M: sbuf '
-    dup length swap underlying '
-    tuple type-number tuple tag-number [
-        4 emit-fixnum
-        sbuf ' emit
-        f ' emit
-        emit ! array ptr
-        emit-fixnum ! length
-    ] emit-object ;
-
-! Hashes
-
-M: hashtable '
-    [ hash-array ' ] keep
-    tuple type-number tuple tag-number [
-        5 emit-fixnum
-        hashtable ' emit
-        f ' emit
-        dup hash-count emit-fixnum
-        hash-deleted emit-fixnum
-        emit ! array ptr
-    ] emit-object ;
-
 ! Curries
 
 M: curry '

core/bootstrap/primitives.factor

@@ -118,11 +118,11 @@ H{ } clone update-map set
 H{ } clone typemap set
 num-types get f <array> builtins set
 
-! These symbols are needed by the code that executes below
+! Forward definitions
-{
+"object" "kernel" create t "class" set-word-prop
-    { "object" "kernel" }
+"object" "kernel" create union-class "metaclass" set-word-prop
-    { "null" "kernel" }
+
-} [ create drop ] assoc-each
+"null" "kernel" create drop
 
 "fixnum" "math" create "fixnum?" "math" create { } define-builtin
 "fixnum" "math" create ">fixnum" "math" create 1quotation "coercer" set-word-prop

core/bootstrap/stage1.factor

@@ -32,6 +32,7 @@ vocabs.loader system ;
 
     "io.streams.c" require
     "vocabs.loader" require
+    
     "syntax" require
     "bootstrap.layouts" require
 

core/bootstrap/stage2.factor

@@ -15,7 +15,7 @@ IN: bootstrap.stage2
     vm file-name windows? [ "." split1 drop ] when
     ".image" append "output-image" set-global
 
-    "math tools help compiler ui ui.tools io" "include" set-global
+    "math help compiler tools ui ui.tools io" "include" set-global
     "" "exclude" set-global
 
     parse-command-line

core/classes/classes.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2004, 2007 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: classes
 USING: arrays definitions assocs kernel

core/classes/union/union.factor

@@ -1,19 +1,34 @@
-! Copyright (C) 2004, 2007 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: words sequences kernel assocs combinators classes
-generic.standard namespaces arrays ;
+generic.standard namespaces arrays math quotations ;
 IN: classes.union
 
 PREDICATE: class union-class
     "metaclass" word-prop union-class eq? ;
 
 ! Union classes for dispatch on multiple classes.
+: small-union-predicate-quot ( members -- quot )
+    dup empty? [
+        drop [ drop f ]
+    ] [
+        unclip first "predicate" word-prop swap
+        [ >r "predicate" word-prop [ dup ] swap append r> ]
+        assoc-map alist>quot
+    ] if ;
+
+: big-union-predicate-quot ( members -- quot )
+    [ small-union-predicate-quot ] [ dup ]
+    class-hash-dispatch-quot ;
+
 : union-predicate-quot ( members -- quot )
-    0 (dispatch#) [
+    [ [ drop t ] ] { } map>assoc
-        [ [ drop t ] ] { } map>assoc
+    dup length 4 <= [
-        object bootstrap-word [ drop f ] 2array add*
+        small-union-predicate-quot
-        single-combination
+    ] [
-    ] with-variable ;
+        flatten-methods
+        big-union-predicate-quot
+    ] if ;
 
 : define-union-predicate ( class -- )
     dup predicate-word

core/compiler/compiler.factor

@@ -26,7 +26,7 @@ IN: compiler
     >r dupd save-effect r>
     f pick compiler-error
     over compiled-unxref
-    over word-vocabulary [ compiled-xref ] [ 2drop ] if ;
+    compiled-xref ;
 
 : compile-succeeded ( word -- effect dependencies )
     [

core/compiler/test/alien.factor

@@ -270,6 +270,16 @@ FUNCTION: double ffi_test_35 test-struct-11 x int y ;
     3 ffi_test_35
 ] unit-test
 
+C-STRUCT: test-struct-12 { "int" "a" } { "double" "x" } ;
+
+: make-struct-12
+    "test-struct-12" <c-object>
+    [ set-test-struct-12-x ] keep ;
+
+FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
+
+[ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test
+
 ! Test callbacks
 
 : callback-1 "void" { } "cdecl" [ ] alien-callback ;

core/definitions/definitions-tests.factor

@@ -11,7 +11,7 @@ SYMBOL: generic-1
 [
     generic-1 T{ combination-1 } define-generic
 
-    [ ] <method> object \ generic-1 define-method
+    [ ] object \ generic-1 define-method
 ] with-compilation-unit
 
 [ ] [

core/effects/effects.factor

@@ -42,12 +42,16 @@ M: integer (stack-picture) drop "object" ;
     ] "" make ;
 
 : stack-effect ( word -- effect/f )
-    dup symbol? [
+    {
-        drop 0 1 <effect>
+        { [ dup symbol? ] [ drop 0 1 <effect> ] }
-    ] [
+        { [ dup "parent-generic" word-prop ] [
-        { "declared-effect" "inferred-effect" }
+            "parent-generic" word-prop stack-effect
-        swap word-props [ at ] curry map [ ] find nip
+        ] }
-    ] if ;
+        { [ t ] [
+            { "declared-effect" "inferred-effect" }
+            swap word-props [ at ] curry map [ ] find nip
+        ] }
+    } cond ;
 
 M: effect clone
     [ effect-in clone ] keep effect-out clone <effect> ;

core/generator/generator.factor

@@ -154,9 +154,17 @@ M: #if generate-node
         ] generate-1
     ] keep ;
 
+: tail-dispatch? ( node -- ? )
+    #! Is the dispatch a jump to a tail call to a word?
+    dup #call? swap node-successor #return? and ;
+
 : dispatch-branches ( node -- )
     node-children [
-        compiling-word get dispatch-branch %dispatch-label
+        dup tail-dispatch? [
+            node-param
+        ] [
+            compiling-word get dispatch-branch
+        ] if %dispatch-label
     ] each ;
 
 M: #dispatch generate-node

core/generic/generic-docs.factor

@@ -1,6 +1,6 @@
 USING: help.markup help.syntax generic.math generic.standard
 words classes definitions kernel alien combinators sequences 
-math ;
+math quotations ;
 IN: generic
 
 ARTICLE: "method-order" "Method precedence"
@@ -125,16 +125,12 @@ HELP: method
 { $description "Looks up a method definition." }
 { $class-description "Instances of this class are methods. A method consists of a quotation together with a source location where it was defined." } ;
 
-{ method method-def method-loc define-method POSTPONE: M: } related-words
+{ method define-method POSTPONE: M: } related-words
 
 HELP: <method>
 { $values { "def" "a quotation" } { "method" "a new method definition" } }
 { $description "Creates a new  "{ $link method } " instance." } ;
 
-HELP: sort-methods
-{ $values { "assoc" "an assoc mapping classes to methods" } { "newassoc" "an association list mapping classes to quotations" } }
-{ $description "Outputs a sequence of pairs, where the first element of each pair is a class and the second element is the corresponding method quotation. The methods are sorted by class order; see " { $link sort-classes } "." } ;
-
 HELP: methods
 { $values { "word" generic } { "assoc" "an association list mapping classes to quotations" } }
 { $description "Outputs a sequence of pairs, where the first element of each pair is a class and the second element is the corresponding method quotation. The methods are sorted by class order; see " { $link sort-classes } "." } ;
@@ -154,7 +150,7 @@ HELP: with-methods
 $low-level-note ;
 
 HELP: define-method
-{ $values { "method" "an instance of " { $link method } } { "class" class } { "generic" generic } }
+{ $values { "method" quotation } { "class" class } { "generic" generic } }
 { $description "Defines a method. This is the runtime equivalent of " { $link POSTPONE: M: } "." } ;
 
 HELP: implementors

core/generic/generic.factor

@@ -5,12 +5,7 @@ definitions kernel.private classes classes.private
 quotations arrays vocabs ;
 IN: generic
 
-PREDICATE: word generic "combination" word-prop >boolean ;
+! Method combination protocol
-
-M: generic definer drop f f ;
-
-M: generic definition drop f ;
-
 GENERIC: perform-combination ( word combination -- quot )
 
 M: object perform-combination
@@ -22,27 +17,22 @@ M: object perform-combination
     #! the method will throw an error. We don't want that.
     nip [ "Invalid method combination" throw ] curry [ ] like ;
 
+GENERIC: method-prologue ( class combination -- quot )
+
+M: object method-prologue 2drop [ ] ;
+
+GENERIC: make-default-method ( generic combination -- method )
+
+PREDICATE: word generic "combination" word-prop >boolean ;
+
+M: generic definer drop f f ;
+
+M: generic definition drop f ;
+
 : make-generic ( word -- )
     dup dup "combination" word-prop perform-combination define ;
 
-: init-methods ( word -- )
+TUPLE: method word def specializer generic loc ;
-     dup "methods" word-prop
-     H{ } assoc-like
-     "methods" set-word-prop ;
-
-: define-generic ( word combination -- )
-    dupd "combination" set-word-prop
-    dup init-methods make-generic ;
-
-TUPLE: method loc def ;
-
-: <method> ( def -- method )
-    { set-method-def } \ method construct ;
-
-M: f method-def ;
-M: f method-loc ;
-M: quotation method-def ;
-M: quotation method-loc drop f ;
 
 : method ( class generic -- method/f )
     "methods" word-prop at ;
@@ -53,12 +43,10 @@ PREDICATE: pair method-spec
 : order ( generic -- seq )
     "methods" word-prop keys sort-classes ;
 
-: sort-methods ( assoc -- newassoc )
-    [ keys sort-classes ] keep
-    [ dupd at method-def 2array ] curry map ;
-
 : methods ( word -- assoc )
-    "methods" word-prop sort-methods ;
+    "methods" word-prop
+    [ keys sort-classes ] keep
+    [ dupd at method-word ] curry { } map>assoc ;
 
 TUPLE: check-method class generic ;
 
@@ -71,19 +59,41 @@ TUPLE: check-method class generic ;
     swap [ "methods" word-prop swap call ] keep make-generic ;
     inline
 
-: define-method ( method class generic -- )
+: method-word-name ( class word -- string )
-    >r bootstrap-word r> check-method
+    word-name "/" rot word-name 3append ;
+
+: make-method-def ( quot word combination -- quot )
+    "combination" word-prop method-prologue swap append ;
+
+: <method-word> ( quot class generic -- word )
+    [ make-method-def ] 2keep
+    [ method-word-name f <word> dup ] keep
+    "parent-generic" set-word-prop
+    dup rot define ;
+
+: <method> ( quot class generic -- method )
+    check-method
+    [ <method-word> ] 3keep f \ method construct-boa ;
+
+: define-method ( quot class generic -- )
+    >r bootstrap-word r>
+    [ <method> ] 2keep
     [ set-at ] with-methods ;
 
+: define-default-method ( generic combination -- )
+    dupd make-default-method object bootstrap-word pick <method>
+    "default-method" set-word-prop ;
+
 ! Definition protocol
 M: method-spec where
-    dup first2 method method-loc [ ] [ second where ] ?if ;
+    dup first2 method [ method-loc ] [ second where ] ?if ;
 
 M: method-spec set-where first2 method set-method-loc ;
 
 M: method-spec definer drop \ M: \ ; ;
 
-M: method-spec definition first2 method method-def ;
+M: method-spec definition
+    first2 method dup [ method-def ] when ;
 
 : forget-method ( class generic -- )
     check-method [ delete-at ] with-methods ;
@@ -109,3 +119,14 @@ M: class forget* ( class -- )
 
 M: assoc update-methods ( assoc -- )
     implementors* [ make-generic ] each ;
+
+: init-methods ( word -- )
+     dup "methods" word-prop
+     H{ } assoc-like
+     "methods" set-word-prop ;
+
+: define-generic ( word combination -- )
+    2dup "combination" set-word-prop
+    dupd define-default-method
+    dup init-methods
+    make-generic ;

core/generic/math/math.factor

@@ -38,9 +38,13 @@ TUPLE: no-math-method left right generic ;
 : no-math-method ( left right generic -- * )
     \ no-math-method construct-boa throw ;
 
+: default-math-method ( generic -- quot )
+    [ no-math-method ] curry [ ] like ;
+
 : applicable-method ( generic class -- quot )
-    over method method-def
+    over method
-    [ ] [ [ no-math-method ] curry [ ] like ] ?if ;
+    [ method-word word-def ]
+    [ default-math-method ] ?if ;
 
 : object-method ( generic -- quot )
     object bootstrap-word applicable-method ;
@@ -66,6 +70,9 @@ TUPLE: no-math-method left right generic ;
 
 TUPLE: math-combination ;
 
+M: math-combination make-default-method
+    drop default-math-method ;
+
 M: math-combination perform-combination
     drop
     \ over [

core/generic/standard/standard.factor

@@ -8,6 +8,10 @@ IN: generic.standard
 
 TUPLE: standard-combination # ;
 
+M: standard-combination method-prologue
+    standard-combination-# object
+    <array> swap add [ declare ] curry ;
+
 C: <standard-combination> standard-combination
 
 SYMBOL: (dispatch#)
@@ -31,10 +35,10 @@ TUPLE: no-method object generic ;
 : no-method ( object generic -- * )
     \ no-method construct-boa throw ;
 
-: error-method ( word -- method )
+: error-method ( word --  quot )
     picker swap [ no-method ] curry append ;
 
-: empty-method ( word -- method )
+: empty-method ( word -- quot )
     [
         picker % [ delegate dup ] %
         unpicker over add ,
@@ -65,13 +69,15 @@ TUPLE: no-method object generic ;
     ] if ;
 
 : default-method ( word -- pair )
-    empty-method object bootstrap-word swap 2array ;
+    "default-method" word-prop method-word
+    object bootstrap-word swap 2array ;
 
 : method-alist>quot ( alist base-class -- quot )
     bootstrap-word swap simplify-alist
     class-predicates alist>quot ;
 
 : small-generic ( methods -- def )
+    [ 1quotation ] assoc-map
     object method-alist>quot ;
 
 : hash-methods ( methods -- buckets )
@@ -83,9 +89,12 @@ TUPLE: no-method object generic ;
         ] if
     ] distribute-buckets ;
 
+: class-hash-dispatch-quot ( methods quot picker -- quot )
+    >r >r hash-methods r> map
+    hash-dispatch-quot r> [ class-hash ] rot 3append ;
+
 : big-generic ( methods -- quot )
-    hash-methods [ small-generic ] map
+    [ small-generic ] picker class-hash-dispatch-quot ;
-    hash-dispatch-quot picker [ class-hash ] rot 3append ;
 
 : vtable-class ( n -- class )
     type>class [ hi-tag bootstrap-word ] unless* ;
@@ -100,7 +109,8 @@ TUPLE: no-method object generic ;
 
 : build-type-vtable ( alist-seq -- alist-seq )
     dup length [
-        vtable-class swap simplify-alist
+        vtable-class
+        swap [ word-def ] assoc-map simplify-alist
         class-predicates alist>quot
     ] 2map ;
 
@@ -137,30 +147,35 @@ TUPLE: no-method object generic ;
 : standard-methods ( word -- alist )
     dup methods swap default-method add* ;
 
+M: standard-combination make-default-method
+    standard-combination-# (dispatch#)
+    [ empty-method ] with-variable ;
+
 M: standard-combination perform-combination
     standard-combination-# (dispatch#) [
         [ standard-methods ] keep "inline" word-prop
         [ small-generic ] [ single-combination ] if
     ] with-variable ;
 
-: default-hook-method ( word -- pair )
-    error-method object bootstrap-word swap 2array ;
-
-: hook-methods ( word -- methods )
-    dup methods [ [ drop ] swap append ] assoc-map
-    swap default-hook-method add* ;
-
 TUPLE: hook-combination var ;
 
 C: <hook-combination> hook-combination
 
-M: hook-combination perform-combination
+M: hook-combination method-prologue
+    2drop [ drop ] ;
+
+: with-hook ( combination quot -- quot' )
     0 (dispatch#) [
-        [
+        swap slip
-            hook-combination-var [ get ] curry %
+        hook-combination-var [ get ] curry
-            hook-methods single-combination %
+        swap append
-        ] [ ] make
+    ] with-variable ; inline
-    ] with-variable ;
+
+M: hook-combination make-default-method
+    [ error-method ] with-hook ;
+
+M: hook-combination perform-combination
+    [ standard-methods single-combination ] with-hook ;
 
 : define-simple-generic ( word -- )
     T{ standard-combination f 0 } define-generic ;

core/inference/backend/backend.factor

@@ -9,9 +9,13 @@ IN: inference.backend
 : recursive-label ( word -- label/f )
     recursive-state get at ;
 
+: inline? ( word -- ? )
+    dup "parent-generic" word-prop
+    [ inline? ] [ "inline" word-prop ] ?if ;
+
 : local-recursive-state ( -- assoc )
     recursive-state get dup keys
-    [ dup word? [ "inline" word-prop ] when not ] find drop
+    [ dup word? [ inline? ] when not ] find drop
     [ head-slice ] when* ;
 
 : inline-recursive-label ( word -- label/f )
@@ -157,7 +161,7 @@ TUPLE: too-many-r> ;
     meta-d get push-all ;
 
 : if-inline ( word true false -- )
-    >r >r dup "inline" word-prop r> r> if ; inline
+    >r >r dup inline? r> r> if ; inline
 
 : consume/produce ( effect node -- )
     over effect-in over consume-values
@@ -331,7 +335,7 @@ TUPLE: unbalanced-branches-error quots in out ;
     #merge node, ; inline
 
 : make-call-node ( word effect -- )
-    swap dup "inline" word-prop
+    swap dup inline?
     over dup recursive-label eq? not and [
         meta-d get clone -rot
         recursive-label #call-label [ consume/produce ] keep

core/io/crc32/crc32-docs.factor

@@ -2,16 +2,16 @@ USING: help.markup help.syntax math ;
 IN: io.crc32
 
 HELP: crc32
-{ $values { "seq" "a sequence" } { "n" integer } }
+{ $values { "seq" "a sequence of bytes" } { "n" integer } }
 { $description "Computes the CRC32 checksum of a sequence of bytes." } ;
 
-HELP: file-crc32
+HELP: lines-crc32
-{ $values { "path" "a pathname string" } { "n" integer } }
+{ $values { "lines" "a sequence of strings" } { "n" integer } }
-{ $description "Computes the CRC32 checksum of a file's contents." } ;
+{ $description "Computes the CRC32 checksum of a sequence of lines of bytes." } ;
 
 ARTICLE: "io.crc32" "CRC32 checksum calculation"
 "The CRC32 checksum algorithm provides a quick but unreliable way to detect changes in data."
 { $subsection crc32 }
-{ $subsection file-crc32 } ;
+{ $subsection lines-crc32 } ;
 
 ABOUT: "io.crc32"

core/io/crc32/crc32.factor

@@ -23,8 +23,6 @@ IN: io.crc32
 : crc32 ( seq -- n )
     >r HEX: ffffffff dup r> [ (crc32) ] each bitxor ;
 
-: file-crc32 ( path -- n ) file-contents crc32 ;
-
 : lines-crc32 ( seq -- n )
     HEX: ffffffff tuck [
         [ (crc32) ] each CHAR: \n (crc32)

core/io/streams/c/c.factor

@@ -74,3 +74,10 @@ M: object <file-writer>
 
 M: object <file-appender>
     "ab" fopen <c-writer> <plain-writer> ;
+
+: show ( msg -- )
+    #! A word which directly calls primitives. It is used to
+    #! print stuff from contexts where the I/O system would
+    #! otherwise not work (tools.deploy.shaker, the I/O
+    #! multiplexer thread).
+    "\r\n" append stdout-handle fwrite stdout-handle fflush ;

core/optimizer/backend/backend.factor

@@ -245,11 +245,19 @@ M: #dispatch optimize-node*
 : dispatching-class ( node word -- class )
     [ dispatch# node-class# ] keep specific-method ;
 
+: flat-length ( seq -- n )
+    [
+        dup quotation? over array? or
+        [ flat-length ] [ drop 1 ] if
+    ] map sum ;
+
 : will-inline-method ( node word -- method-spec/t quot/t )
     #! t indicates failure
     tuck dispatching-class dup [
         swap [ 2array ] 2keep
-        method method-def
+        method method-word
+        dup word-def flat-length 5 >=
+        [ 1quotation ] [ word-def ] if
     ] [
         2drop t t
     ] if ;

core/slots/slots.factor

@@ -10,7 +10,7 @@ TUPLE: slot-spec type name offset reader writer ;
 C: <slot-spec> slot-spec
 
 : define-typecheck ( class generic quot -- )
-    <method> over define-simple-generic -rot define-method ;
+    over define-simple-generic -rot define-method ;
 
 : define-slot-word ( class slot word quot -- )
     rot >fixnum add* define-typecheck ;

core/source-files/source-files.factor

@@ -17,7 +17,7 @@ uses definitions ;
 
 : (source-modified?) ( path modified checksum -- ? )
     pick file-modified rot [ 0 or ] 2apply >
-    [ swap file-crc32 number= not ] [ 2drop f ] if ;
+    [ swap file-lines lines-crc32 = not ] [ 2drop f ] if ;
 
 : source-modified? ( path -- ? )
     dup source-files get at [

core/syntax/syntax.factor

@@ -126,7 +126,7 @@ IN: bootstrap.syntax
         f set-word
         location >r
         scan-word bootstrap-word scan-word
-        [ parse-definition <method> -rot define-method ] 2keep
+        [ parse-definition -rot define-method ] 2keep
         2array r> remember-definition
     ] define-syntax
 

core/words/words.factor

@@ -154,7 +154,8 @@ SYMBOL: changed-words
     } reset-props ;
 
 : reset-generic ( word -- )
-    dup reset-word { "methods" "combination" } reset-props ;
+    dup reset-word
+    { "methods" "combination" "default-method" } reset-props ;
 
 : gensym ( -- word )
     "G:" \ gensym counter number>string append f <word> ;

extra/assocs/lib/lib.factor

@@ -1,9 +1,6 @@
-USING: assocs kernel vectors sequences ;
+USING: assocs kernel vectors sequences namespaces ;
 IN: assocs.lib
 
-: insert-at ( value key assoc -- )
-    [ ?push ] change-at ;
-
 : >set ( seq -- hash )
     [ dup ] H{ } map>assoc ;
 
@@ -19,5 +16,19 @@ IN: assocs.lib
 : at-default ( key assoc -- value/key )
     dupd at [ nip ] when* ;
 
-: at-peek ( key assoc -- value ? )
+: insert-at ( value key assoc -- )
-    at* dup >r [ peek ] when r> ;
+    [ ?push ] change-at ;
+
+: peek-at* ( key assoc -- obj ? )
+    at* dup [ >r peek r> ] when ;
+
+: peek-at ( key assoc -- obj )
+    peek-at* drop ;
+
+: >multi-assoc ( assoc -- new-assoc )
+    [ 1vector ] assoc-map ;
+
+: multi-assoc-each ( assoc quot -- )
+    [ with each ] curry assoc-each ; inline
+
+: insert ( value variable -- ) namespace insert-at ;

extra/automata/automata.factor

@@ -1,6 +1,6 @@
 
 USING: kernel math math.parser random arrays hashtables assocs sequences
-       vars strings.lib ;
+       vars ;
 
 IN: automata
 
@@ -108,4 +108,4 @@ last-line> height> [ drop step-capped-line dup ] map >bitmap >last-line ;
 
 ! : start-loop ( -- ) t >loop-flag [ loop ] in-thread ;
 
-! : stop-loop ( -- ) f >loop-flag ;
+! : stop-loop ( -- ) f >loop-flag ;

extra/benchmark/dispatch5/dispatch5.factor

@@ -0,0 +1,77 @@
+USING: classes kernel sequences vocabs math ;
+IN: benchmark.dispatch5
+
+MIXIN: g
+
+TUPLE: x1 ;
+INSTANCE: x1 g
+TUPLE: x2 ;
+INSTANCE: x2 g
+TUPLE: x3 ;
+INSTANCE: x3 g
+TUPLE: x4 ;
+INSTANCE: x4 g
+TUPLE: x5 ;
+INSTANCE: x5 g
+TUPLE: x6 ;
+INSTANCE: x6 g
+TUPLE: x7 ;
+INSTANCE: x7 g
+TUPLE: x8 ;
+INSTANCE: x8 g
+TUPLE: x9 ;
+INSTANCE: x9 g
+TUPLE: x10 ;
+INSTANCE: x10 g
+TUPLE: x11 ;
+INSTANCE: x11 g
+TUPLE: x12 ;
+INSTANCE: x12 g
+TUPLE: x13 ;
+INSTANCE: x13 g
+TUPLE: x14 ;
+INSTANCE: x14 g
+TUPLE: x15 ;
+INSTANCE: x15 g
+TUPLE: x16 ;
+INSTANCE: x16 g
+TUPLE: x17 ;
+INSTANCE: x17 g
+TUPLE: x18 ;
+INSTANCE: x18 g
+TUPLE: x19 ;
+INSTANCE: x19 g
+TUPLE: x20 ;
+INSTANCE: x20 g
+TUPLE: x21 ;
+INSTANCE: x21 g
+TUPLE: x22 ;
+INSTANCE: x22 g
+TUPLE: x23 ;
+INSTANCE: x23 g
+TUPLE: x24 ;
+INSTANCE: x24 g
+TUPLE: x25 ;
+INSTANCE: x25 g
+TUPLE: x26 ;
+INSTANCE: x26 g
+TUPLE: x27 ;
+INSTANCE: x27 g
+TUPLE: x28 ;
+INSTANCE: x28 g
+TUPLE: x29 ;
+INSTANCE: x29 g
+TUPLE: x30 ;
+INSTANCE: x30 g
+
+: my-classes ( -- seq )
+    "benchmark.dispatch5" words [ tuple-class? ] subset ;
+
+: a-bunch-of-objects ( -- seq )
+    my-classes [ construct-empty ] map ;
+
+: dispatch-benchmark ( -- )
+    1000000 a-bunch-of-objects
+    [ f [ g? or ] reduce drop ] curry times ;
+
+MAIN: dispatch-benchmark

extra/db/db.factor

@@ -0,0 +1,104 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays assocs classes continuations kernel math
+namespaces sequences sequences.lib tuples words ;
+IN: db
+
+TUPLE: db handle ;
+C: <db> db ( handle -- obj )
+
+! HOOK: db-create db ( str -- )
+! HOOK: db-drop db ( str -- )
+GENERIC: db-open ( db -- )
+GENERIC: db-close ( db -- )
+
+TUPLE: statement sql params handle bound? ;
+
+TUPLE: simple-statement ;
+TUPLE: prepared-statement ;
+
+HOOK: <simple-statement> db ( str -- statement )
+HOOK: <prepared-statement> db ( str -- statement )
+
+GENERIC: prepare-statement ( statement -- )
+GENERIC: bind-statement* ( obj statement -- )
+GENERIC: rebind-statement ( obj statement -- )
+
+GENERIC: execute-statement ( statement -- )
+
+: bind-statement ( obj statement -- )
+    2dup dup statement-bound? [
+        rebind-statement
+    ] [
+        bind-statement*
+    ] if
+    tuck set-statement-params
+    t swap set-statement-bound? ;
+
+TUPLE: result-set sql params handle n max ;
+
+GENERIC: query-results ( query -- result-set )
+
+GENERIC: #rows ( result-set -- n )
+GENERIC: #columns ( result-set -- n )
+GENERIC# row-column 1 ( result-set n -- obj )
+GENERIC: advance-row ( result-set -- ? )
+
+: init-result-set ( result-set -- )
+    dup #rows over set-result-set-max
+    -1 swap set-result-set-n ;
+
+: <result-set> ( query handle tuple -- result-set )
+    >r >r { statement-sql statement-params } get-slots r>
+    {
+        set-result-set-sql
+        set-result-set-params
+        set-result-set-handle
+    } result-set construct r> construct-delegate ;
+
+: sql-row ( result-set -- seq )
+    dup #columns [ row-column ] with map ;
+
+: query-each ( statement quot -- )
+    over advance-row [
+        2drop
+    ] [
+        [ call ] 2keep query-each
+    ] if ; inline
+
+: query-map ( statement quot -- seq )
+    accumulator >r query-each r> { } like ; inline
+
+: with-db ( db quot -- )
+    [
+        over db-open
+        [ db swap with-variable ] curry with-disposal
+    ] with-scope ;
+
+: do-query ( query -- result-set )
+    query-results [ [ sql-row ] query-map ] with-disposal ;
+
+: do-bound-query ( obj query -- rows )
+    [ bind-statement ] keep do-query ;
+
+: do-bound-command ( obj query -- )
+    [ bind-statement ] keep execute-statement ;
+
+: sql-query ( sql -- rows )
+    <simple-statement> [ do-query ] with-disposal ;
+
+: sql-command ( sql -- )
+    <simple-statement> [ execute-statement ] with-disposal ;
+
+SYMBOL: in-transaction
+HOOK: begin-transaction db ( -- )
+HOOK: commit-transaction db ( -- )
+HOOK: rollback-transaction db ( -- )
+
+: in-transaction? ( -- ? ) in-transaction get ;
+
+: with-transaction ( quot -- )
+    t in-transaction [
+        begin-transaction
+        [ ] [ rollback-transaction ] cleanup commit-transaction
+    ] with-variable ;

extra/db/postgresql/ffi/ffi.factor

@@ -1,12 +1,10 @@
 ! Copyright (C) 2007 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-
 ! adapted from libpq-fe.h version 7.4.7
-! tested on debian linux with postgresql 7.4.7
+! tested on debian linux with postgresql 8.1
-! Updated to 8.1
 
 USING: alien alien.syntax combinators system ;
-IN: postgresql.libpq
+IN: db.postgresql.ffi
 
 <<
 "postgresql" {
@@ -17,45 +15,44 @@ IN: postgresql.libpq
 >>
 
 ! ConnSatusType
-: CONNECTION_OK                                         HEX: 0 ; inline
+: CONNECTION_OK                     HEX: 0 ; inline
-: CONNECTION_BAD                                        HEX: 1 ; inline
+: CONNECTION_BAD                    HEX: 1 ; inline
-: CONNECTION_STARTED                            HEX: 2 ; inline
+: CONNECTION_STARTED                HEX: 2 ; inline
-: CONNECTION_MADE                                       HEX: 3 ; inline
+: CONNECTION_MADE                   HEX: 3 ; inline
-: CONNECTION_AWAITING_RESPONSE          HEX: 4 ; inline
+: CONNECTION_AWAITING_RESPONSE      HEX: 4 ; inline
-: CONNECTION_AUTH_OK                            HEX: 5 ; inline
+: CONNECTION_AUTH_OK                HEX: 5 ; inline
-: CONNECTION_SETENV                                     HEX: 6 ; inline
+: CONNECTION_SETENV                 HEX: 6 ; inline
-: CONNECTION_SSL_STARTUP                        HEX: 7 ; inline
+: CONNECTION_SSL_STARTUP            HEX: 7 ; inline
-: CONNECTION_NEEDED                                     HEX: 8 ; inline
+: CONNECTION_NEEDED                 HEX: 8 ; inline
 
 ! PostgresPollingStatusType
-: PGRES_POLLING_FAILED                          HEX: 0 ; inline
+: PGRES_POLLING_FAILED              HEX: 0 ; inline
-: PGRES_POLLING_READING                         HEX: 1 ; inline
+: PGRES_POLLING_READING             HEX: 1 ; inline
-: PGRES_POLLING_WRITING                         HEX: 2 ; inline
+: PGRES_POLLING_WRITING             HEX: 2 ; inline
-: PGRES_POLLING_OK                                      HEX: 3 ; inline
+: PGRES_POLLING_OK                  HEX: 3 ; inline
-: PGRES_POLLING_ACTIVE                          HEX: 4 ; inline
+: PGRES_POLLING_ACTIVE              HEX: 4 ; inline
 
 ! ExecStatusType;
-: PGRES_EMPTY_QUERY                             HEX: 0 ; inline
+: PGRES_EMPTY_QUERY                 HEX: 0 ; inline
-: PGRES_COMMAND_OK                                      HEX: 1 ; inline
+: PGRES_COMMAND_OK                  HEX: 1 ; inline
-: PGRES_TUPLES_OK                                       HEX: 2 ; inline
+: PGRES_TUPLES_OK                   HEX: 2 ; inline
-: PGRES_COPY_OUT                                        HEX: 3 ; inline
+: PGRES_COPY_OUT                    HEX: 3 ; inline
-: PGRES_COPY_IN                                         HEX: 4 ; inline
+: PGRES_COPY_IN                     HEX: 4 ; inline
-: PGRES_BAD_RESPONSE                            HEX: 5 ; inline
+: PGRES_BAD_RESPONSE                HEX: 5 ; inline
-: PGRES_NONFATAL_ERROR                          HEX: 6 ; inline
+: PGRES_NONFATAL_ERROR              HEX: 6 ; inline
-: PGRES_FATAL_ERROR                                     HEX: 7 ; inline
+: PGRES_FATAL_ERROR                 HEX: 7 ; inline
 
 ! PGTransactionStatusType;
-: PQTRANS_IDLE                                          HEX: 0 ; inline
+: PQTRANS_IDLE                      HEX: 0 ; inline
-: PQTRANS_ACTIVE                                        HEX: 1 ; inline
+: PQTRANS_ACTIVE                    HEX: 1 ; inline
-: PQTRANS_INTRANS                                       HEX: 2 ; inline
+: PQTRANS_INTRANS                   HEX: 2 ; inline
-: PQTRANS_INERROR                                       HEX: 3 ; inline
+: PQTRANS_INERROR                   HEX: 3 ; inline
-: PQTRANS_UNKNOWN                                       HEX: 4 ; inline
+: PQTRANS_UNKNOWN                   HEX: 4 ; inline
 
 ! PGVerbosity;
-: PQERRORS_TERSE                                        HEX: 0 ; inline
+: PQERRORS_TERSE                    HEX: 0 ; inline
-: PQERRORS_DEFAULT                                      HEX: 1 ; inline
+: PQERRORS_DEFAULT                  HEX: 1 ; inline
-: PQERRORS_VERBOSE                                      HEX: 2 ; inline
+: PQERRORS_VERBOSE                  HEX: 2 ; inline
-
 
 TYPEDEF: int size_t
 TYPEDEF: int ConnStatusType
@@ -81,7 +78,6 @@ LIBRARY: postgresql
 
 
 ! Exported functions of libpq
-! ===   in fe-connect.c ===
 
 ! make a new client connection to the backend
 ! Asynchronous (non-blocking)
@@ -91,12 +87,12 @@ FUNCTION: PostgresPollingStatusType PQconnectPoll ( PGconn* conn ) ;
 ! Synchronous (blocking)
 FUNCTION: PGconn* PQconnectdb ( char* conninfo ) ;
 FUNCTION: PGconn* PQsetdbLogin ( char* pghost, char* pgport,
-                         char* pgoptions, char* pgtty,
+             char* pgoptions, char* pgtty,
-                         char* dbName,
+             char* dbName,
-                         char* login, char* pwd ) ;
+             char* login, char* pwd ) ;
 
 : PQsetdb ( M_PGHOST M_PGPORT M_PGOPT M_PGTTY M_DBNAME -- PGconn* )
-        f f PQsetdbLogin ;
+    f f PQsetdbLogin ;
 
 ! close the current connection and free the PGconn data structure
 FUNCTION: void PQfinish ( PGconn* conn ) ;
@@ -112,7 +108,7 @@ FUNCTION: void PQconninfoFree ( PQconninfoOption* connOptions ) ;
 ! parameters
 !
 ! Asynchronous (non-blocking)
-FUNCTION: int   PQresetStart ( PGconn* conn ) ;
+FUNCTION: int    PQresetStart ( PGconn* conn ) ;
 FUNCTION: PostgresPollingStatusType PQresetPoll ( PGconn* conn ) ;
 
 ! Synchronous (blocking)
@@ -125,7 +121,7 @@ FUNCTION: PGcancel* PQgetCancel ( PGconn* conn ) ;
 FUNCTION: void PQfreeCancel ( PGcancel* cancel ) ;
 
 ! issue a cancel request
-FUNCTION: int   PQrequestCancel ( PGconn* conn ) ;
+FUNCTION: int    PQrequestCancel ( PGconn* conn ) ;
 
 ! Accessor functions for PGconn objects
 FUNCTION: char* PQdb ( PGconn* conn ) ;
@@ -138,14 +134,14 @@ FUNCTION: char* PQoptions ( PGconn* conn ) ;
 FUNCTION: ConnStatusType PQstatus ( PGconn* conn ) ;
 FUNCTION: PGTransactionStatusType PQtransactionStatus ( PGconn* conn ) ;
 FUNCTION: char* PQparameterStatus ( PGconn* conn,
-                                  char* paramName ) ;
+                  char* paramName ) ;
-FUNCTION: int   PQprotocolVersion ( PGconn* conn ) ;
+FUNCTION: int PQprotocolVersion ( PGconn* conn ) ;
-FUNCTION: int   PQServerVersion ( PGconn* conn ) ;
+! FUNCTION: int PQServerVersion ( PGconn* conn ) ;
 FUNCTION: char* PQerrorMessage ( PGconn* conn ) ;
-FUNCTION: int   PQsocket ( PGconn* conn ) ;
+FUNCTION: int PQsocket ( PGconn* conn ) ;
-FUNCTION: int   PQbackendPID ( PGconn* conn ) ;
+FUNCTION: int PQbackendPID ( PGconn* conn ) ;
-FUNCTION: int   PQclientEncoding ( PGconn* conn ) ;
+FUNCTION: int PQclientEncoding ( PGconn* conn ) ;
-FUNCTION: int   PQsetClientEncoding ( PGconn* conn, char* encoding ) ;
+FUNCTION: int PQsetClientEncoding ( PGconn* conn, char* encoding ) ;
 
 ! May not be compiled into libpq
 ! Get the SSL structure associated with a connection
@@ -156,7 +152,7 @@ FUNCTION: void PQinitSSL ( int do_init ) ;
 
 ! Set verbosity for PQerrorMessage and PQresultErrorMessage
 FUNCTION: PGVerbosity PQsetErrorVerbosity ( PGconn* conn,
-        PGVerbosity verbosity ) ;
+    PGVerbosity verbosity ) ;
 
 ! Enable/disable tracing
 FUNCTION: void PQtrace ( PGconn* conn, FILE* debug_port ) ;
@@ -171,11 +167,11 @@ FUNCTION: void PQuntrace ( PGconn* conn ) ;
 
 ! Override default notice handling routines
 ! FUNCTION: PQnoticeReceiver PQsetNoticeReceiver ( PGconn* conn,
-                                        ! PQnoticeReceiver proc,
+                    ! PQnoticeReceiver proc,
-                                        ! void* arg ) ;
+                    ! void* arg ) ;
 ! FUNCTION: PQnoticeProcessor PQsetNoticeProcessor ( PGconn* conn,
-                                        ! PQnoticeProcessor proc,
+                    ! PQnoticeProcessor proc,
-                                        ! void* arg ) ;
+                    ! void* arg ) ;
 ! END BROKEN
 
 ! === in fe-exec.c ===
@@ -183,83 +179,83 @@ FUNCTION: void PQuntrace ( PGconn* conn ) ;
 ! Simple synchronous query
 FUNCTION: PGresult* PQexec ( PGconn* conn, char* query ) ;
 FUNCTION: PGresult* PQexecParams ( PGconn* conn,
-                         char* command,
+             char* command,
-                         int nParams,
+             int nParams,
-                         Oid* paramTypes,
+             Oid* paramTypes,
-                         char** paramValues,
+             char** paramValues,
-                         int* paramLengths,
+             int* paramLengths,
-                         int* paramFormats,
+             int* paramFormats,
-                         int resultFormat ) ;
+             int resultFormat ) ;
 FUNCTION: PGresult* PQprepare ( PGconn* conn, char* stmtName,
         char* query, int nParams,
         Oid* paramTypes ) ;
 FUNCTION: PGresult* PQexecPrepared ( PGconn* conn,
-                         char* stmtName,
+             char* stmtName,
-                         int nParams,
+             int nParams,
-                         char** paramValues,
+             char** paramValues,
-                         int* paramLengths,
+             int* paramLengths,
-                         int* paramFormats,
+             int* paramFormats,
-                         int resultFormat ) ;
+             int resultFormat ) ;
 
 ! Interface for multiple-result or asynchronous queries
 FUNCTION: int PQsendQuery ( PGconn* conn, char* query ) ;
 FUNCTION: int PQsendQueryParams ( PGconn* conn,
-                                  char* command,
+                  char* command,
-                                  int nParams,
+                  int nParams,
-                                  Oid* paramTypes,
+                  Oid* paramTypes,
-                                  char** paramValues,
+                  char** paramValues,
-                                  int* paramLengths,
+                  int* paramLengths,
-                                  int* paramFormats,
+                  int* paramFormats,
-                                  int resultFormat ) ;
+                  int resultFormat ) ;
 FUNCTION: PGresult* PQsendPrepare ( PGconn* conn, char* stmtName,
             char* query, int nParams,
             Oid* paramTypes ) ;
 FUNCTION: int PQsendQueryPrepared ( PGconn* conn,
-                                  char* stmtName,
+                  char* stmtName,
-                                  int nParams,
+                  int nParams,
-                                  char** paramValues,
+                  char** paramValues,
-                                  int *paramLengths,
+                  int *paramLengths,
-                                  int *paramFormats,
+                  int *paramFormats,
-                                  int resultFormat ) ;
+                  int resultFormat ) ;
 FUNCTION: PGresult* PQgetResult ( PGconn* conn ) ;
 
 ! Routines for managing an asynchronous query
-FUNCTION: int   PQisBusy ( PGconn* conn ) ;
+FUNCTION: int    PQisBusy ( PGconn* conn ) ;
-FUNCTION: int   PQconsumeInput ( PGconn* conn ) ;
+FUNCTION: int    PQconsumeInput ( PGconn* conn ) ;
 
 ! LISTEN/NOTIFY support
 FUNCTION: PGnotify* PQnotifies ( PGconn* conn ) ;
 
 ! Routines for copy in/out
-FUNCTION: int   PQputCopyData ( PGconn* conn, char* buffer, int nbytes ) ;
+FUNCTION: int    PQputCopyData ( PGconn* conn, char* buffer, int nbytes ) ;
-FUNCTION: int   PQputCopyEnd ( PGconn* conn, char* errormsg ) ;
+FUNCTION: int    PQputCopyEnd ( PGconn* conn, char* errormsg ) ;
-FUNCTION: int   PQgetCopyData ( PGconn* conn, char** buffer, int async ) ;
+FUNCTION: int    PQgetCopyData ( PGconn* conn, char** buffer, int async ) ;
 
 ! Deprecated routines for copy in/out
-FUNCTION: int   PQgetline ( PGconn* conn, char* string, int length ) ;
+FUNCTION: int    PQgetline ( PGconn* conn, char* string, int length ) ;
-FUNCTION: int   PQputline ( PGconn* conn, char* string ) ;
+FUNCTION: int    PQputline ( PGconn* conn, char* string ) ;
-FUNCTION: int   PQgetlineAsync ( PGconn* conn, char* buffer, int bufsize ) ;
+FUNCTION: int    PQgetlineAsync ( PGconn* conn, char* buffer, int bufsize ) ;
-FUNCTION: int   PQputnbytes ( PGconn* conn, char* buffer, int nbytes ) ;
+FUNCTION: int    PQputnbytes ( PGconn* conn, char* buffer, int nbytes ) ;
-FUNCTION: int   PQendcopy ( PGconn* conn ) ;
+FUNCTION: int    PQendcopy ( PGconn* conn ) ;
 
 ! Set blocking/nonblocking connection to the backend
-FUNCTION: int   PQsetnonblocking ( PGconn* conn, int arg ) ;
+FUNCTION: int    PQsetnonblocking ( PGconn* conn, int arg ) ;
-FUNCTION: int   PQisnonblocking ( PGconn* conn ) ;
+FUNCTION: int    PQisnonblocking ( PGconn* conn ) ;
 
 ! Force the write buffer to be written (or at least try)
-FUNCTION: int   PQflush ( PGconn* conn ) ;
+FUNCTION: int    PQflush ( PGconn* conn ) ;
 
 ! 
 ! * "Fast path" interface --- not really recommended for application
 ! * use
 !
 FUNCTION: PGresult* PQfn ( PGconn* conn,
-         int fnid,
+     int fnid,
-         int* result_buf,
+     int* result_buf,
-         int* result_len,
+     int* result_len,
-         int result_is_int,
+     int result_is_int,
-         PQArgBlock* args,
+     PQArgBlock* args,
-         int nargs ) ;
+     int nargs ) ;
 
 ! Accessor functions for PGresult objects
 FUNCTION: ExecStatusType PQresultStatus ( PGresult* res ) ;
@@ -313,7 +309,7 @@ FUNCTION: uchar* PQunescapeBytea ( uchar* strtext,
 ! These forms are deprecated!
 FUNCTION: size_t PQescapeString ( void* to, char* from, size_t length ) ;
 FUNCTION: uchar* PQescapeBytea ( uchar* bintext, size_t binlen,
-                          size_t* bytealen ) ;
+              size_t* bytealen ) ;
 
 ! === in fe-print.c ===
 
@@ -332,30 +328,28 @@ FUNCTION: void PQprintTuples ( PGresult* res,
                           int printAttName,
                           int terseOutput,      
                           int width ) ; 
-                                                
 ! === in fe-lobj.c ===
 
 ! Large-object access routines
-FUNCTION: int   lo_open ( PGconn* conn, Oid lobjId, int mode ) ;
+FUNCTION: int    lo_open ( PGconn* conn, Oid lobjId, int mode ) ;
-FUNCTION: int   lo_close ( PGconn* conn, int fd ) ;
+FUNCTION: int    lo_close ( PGconn* conn, int fd ) ;
-FUNCTION: int   lo_read ( PGconn* conn, int fd, char* buf, size_t len ) ;
+FUNCTION: int    lo_read ( PGconn* conn, int fd, char* buf, size_t len ) ;
-FUNCTION: int   lo_write ( PGconn* conn, int fd, char* buf, size_t len ) ;
+FUNCTION: int    lo_write ( PGconn* conn, int fd, char* buf, size_t len ) ;
-FUNCTION: int   lo_lseek ( PGconn* conn, int fd, int offset, int whence ) ;
+FUNCTION: int    lo_lseek ( PGconn* conn, int fd, int offset, int whence ) ;
-FUNCTION: Oid   lo_creat ( PGconn* conn, int mode ) ;
+FUNCTION: Oid    lo_creat ( PGconn* conn, int mode ) ;
-! FUNCTION: Oid lo_creat ( PGconn* conn, Oid lobjId ) ;
+! FUNCTION: Oid    lo_creat ( PGconn* conn, Oid lobjId ) ;
-FUNCTION: int   lo_tell ( PGconn* conn, int fd ) ;
+FUNCTION: int    lo_tell ( PGconn* conn, int fd ) ;
-FUNCTION: int   lo_unlink ( PGconn* conn, Oid lobjId ) ;
+FUNCTION: int    lo_unlink ( PGconn* conn, Oid lobjId ) ;
-FUNCTION: Oid   lo_import ( PGconn* conn, char* filename ) ;
+FUNCTION: Oid    lo_import ( PGconn* conn, char* filename ) ;
-FUNCTION: int   lo_export ( PGconn* conn, Oid lobjId, char* filename ) ;
+FUNCTION: int    lo_export ( PGconn* conn, Oid lobjId, char* filename ) ;
 
 ! === in fe-misc.c ===
 
 ! Determine length of multibyte encoded char at *s
-FUNCTION: int   PQmblen ( uchar* s, int encoding ) ;
+FUNCTION: int    PQmblen ( uchar* s, int encoding ) ;
 
 ! Determine display length of multibyte encoded char at *s
-FUNCTION: int   PQdsplen ( uchar* s, int encoding ) ;
+FUNCTION: int    PQdsplen ( uchar* s, int encoding ) ;
 
 ! Get encoding id from environment variable PGCLIENTENCODING
-FUNCTION: int   PQenv2encoding ( ) ;
+FUNCTION: int    PQenv2encoding ( ) ;
-

extra/db/postgresql/lib/lib.factor

@@ -0,0 +1,44 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays continuations db io kernel math namespaces
+quotations sequences db.postgresql.ffi alien alien.c-types ;
+IN: db.postgresql.lib
+
+: postgresql-result-error-message ( res -- str/f )
+    dup zero? [
+        drop f
+    ] [
+        PQresultErrorMessage [ CHAR: \n = ] right-trim
+    ] if ;
+
+: postgres-result-error ( res -- )
+    postgresql-result-error-message [ throw ] when* ;
+
+: postgresql-error-message ( -- str )
+    db get db-handle PQerrorMessage [ CHAR: \n = ] right-trim ;
+
+: postgresql-error ( res -- res )
+    dup [ postgresql-error-message throw ] unless ;
+
+: postgresql-result-ok? ( n -- ? )
+    PQresultStatus
+    PGRES_COMMAND_OK PGRES_TUPLES_OK 2array member? ;
+
+: connect-postgres ( host port pgopts pgtty db user pass -- conn )
+    PQsetdbLogin
+    dup PQstatus zero? [ postgresql-error-message throw ] unless ;
+
+: do-postgresql-statement ( statement -- res )
+    db get db-handle swap statement-sql PQexec dup postgresql-result-ok? [
+        dup postgresql-result-error-message swap PQclear throw
+    ] unless ;
+
+: do-postgresql-bound-statement ( statement -- res )
+    >r db get db-handle r>
+    [ statement-sql ] keep
+    [ statement-params length f ] keep
+    statement-params [ malloc-char-string ] map >c-void*-array
+    f f 0 PQexecParams
+    dup postgresql-result-ok? [
+        dup postgresql-result-error-message swap PQclear throw
+    ] unless ;

extra/db/postgresql/postgresql-tests.factor

@@ -0,0 +1,110 @@
+! You will need to run  'createdb factor-test' to create the database.
+! Set username and password in  the 'connect' word.
+
+USING: kernel db.postgresql alien continuations io prettyprint
+sequences namespaces tools.test db ;
+IN: temporary
+
+IN: scratchpad
+: test-db ( -- postgresql-db )
+    "localhost" "postgres" "" "factor-test" <postgresql-db> ;
+IN: temporary
+
+[ ] [ test-db [ ] with-db ] unit-test
+
+[ ] [
+    test-db [
+        [ "drop table person;" sql-command ] catch drop
+        "create table person (name varchar(30), country varchar(30));"
+            sql-command
+
+        "insert into person values('John', 'America');" sql-command
+        "insert into person values('Jane', 'New Zealand');" sql-command
+    ] with-db
+] unit-test
+
+[
+    {
+        { "John" "America" }
+        { "Jane" "New Zealand" }
+    }
+] [
+    test-db [
+        "select * from person" sql-query
+    ] with-db
+] unit-test
+
+[
+    { { "John" "America" } }
+] [
+    test-db [
+        "select * from person where name = $1 and country = $2"
+        <simple-statement> [
+            { "Jane" "New Zealand" }
+            over do-bound-query
+
+            { { "Jane" "New Zealand" } } =
+            [ "test fails" throw ] unless
+
+            { "John" "America" }
+            swap do-bound-query
+        ] with-disposal
+    ] with-db
+] unit-test
+
+[
+    {
+        { "John" "America" }
+        { "Jane" "New Zealand" }
+    }
+] [ test-db [ "select * from person" sql-query ] with-db ] unit-test
+
+[
+] [
+    test-db [
+        "insert into person(name, country) values('Jimmy', 'Canada')"
+        sql-command
+    ] with-db
+] unit-test
+
+[
+    {
+        { "John" "America" }
+        { "Jane" "New Zealand" }
+        { "Jimmy" "Canada" }
+    }
+] [ test-db [ "select * from person" sql-query ] with-db ] unit-test
+
+[
+    test-db [
+        [
+            "insert into person(name, country) values('Jose', 'Mexico')" sql-command
+            "insert into person(name, country) values('Jose', 'Mexico')" sql-command
+            "oops" throw
+        ] with-transaction
+    ] with-db
+] unit-test-fails
+
+[ 3 ] [
+    test-db [
+        "select * from person" sql-query length
+    ] with-db
+] unit-test
+
+[
+] [
+    test-db [
+        [
+            "insert into person(name, country) values('Jose', 'Mexico')"
+            sql-command
+            "insert into person(name, country) values('Jose', 'Mexico')"
+            sql-command
+        ] with-transaction
+    ] with-db
+] unit-test
+
+[ 5 ] [
+    test-db [
+        "select * from person" sql-query length
+    ] with-db
+] unit-test

extra/db/postgresql/postgresql.factor

@@ -0,0 +1,105 @@
+! Copyright (C) 2007, 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays assocs alien alien.syntax continuations io
+kernel math namespaces prettyprint quotations
+sequences debugger db db.postgresql.lib db.postgresql.ffi ;
+IN: db.postgresql
+
+TUPLE: postgresql-db host port pgopts pgtty db user pass ;
+TUPLE: postgresql-statement ;
+TUPLE: postgresql-result-set ;
+: <postgresql-statement> ( statement -- postgresql-statement )
+    postgresql-statement construct-delegate ;
+
+: <postgresql-db> ( host user pass db -- obj )
+    {
+        set-postgresql-db-host
+        set-postgresql-db-user
+        set-postgresql-db-pass
+        set-postgresql-db-db
+    } postgresql-db construct ;
+
+M: postgresql-db db-open ( db -- )
+    dup {
+        postgresql-db-host
+        postgresql-db-port
+        postgresql-db-pgopts
+        postgresql-db-pgtty
+        postgresql-db-db
+        postgresql-db-user
+        postgresql-db-pass
+    } get-slots connect-postgres <db> swap set-delegate ;
+
+M: postgresql-db dispose ( db -- )
+    db-handle PQfinish ;
+
+: with-postgresql ( host ust pass db quot -- )
+    >r <postgresql-db> r> with-disposal ;
+
+M: postgresql-statement bind-statement* ( seq statement -- )
+    set-statement-params ;
+
+M: postgresql-statement rebind-statement ( seq statement -- )
+    bind-statement* ;
+
+M: postgresql-result-set #rows ( result-set -- n )
+    result-set-handle PQntuples ;
+
+M: postgresql-result-set #columns ( result-set -- n )
+    result-set-handle PQnfields ;
+
+M: postgresql-result-set row-column ( result-set n -- obj )
+    >r dup result-set-handle swap result-set-n r> PQgetvalue ;
+
+M: postgresql-statement execute-statement ( statement -- )
+    query-results dispose ;
+
+: increment-n ( result-set -- n )
+    dup result-set-n 1+ dup rot set-result-set-n ;
+
+M: postgresql-statement query-results ( query -- result-set )
+    dup statement-params [
+        over [ bind-statement ] keep
+        do-postgresql-bound-statement
+    ] [
+        dup do-postgresql-statement
+    ] if*
+    postgresql-result-set <result-set>
+    dup init-result-set ;
+
+M: postgresql-result-set advance-row ( result-set -- ? )
+    dup increment-n swap result-set-max >= ;
+
+M: postgresql-statement dispose ( query -- )
+    dup statement-handle PQclear
+    f swap set-statement-handle ;
+
+M: postgresql-result-set dispose ( result-set -- )
+    dup result-set-handle PQclear
+    0 0 f roll {
+        set-result-set-n set-result-set-max set-result-set-handle
+    } set-slots ;
+
+M: postgresql-statement prepare-statement ( statement -- )
+    [
+        >r db get db-handle "" r>
+        dup statement-sql swap statement-params
+        length f PQprepare postgresql-error
+    ] keep set-statement-handle ;
+
+M: postgresql-db <simple-statement> ( sql -- statement )
+    { set-statement-sql } statement construct
+    <postgresql-statement> ;
+
+M: postgresql-db <prepared-statement> ( sql -- statement )
+    { set-statement-sql } statement construct
+    <postgresql-statement> ;
+
+M: postgresql-db begin-transaction ( -- )
+    "BEGIN" sql-command ;
+
+M: postgresql-db commit-transaction ( -- )
+    "COMMIT" sql-command ;
+
+M: postgresql-db rollback-transaction ( -- )
+    "ROLLBACK" sql-command ;

extra/db/sqlite/authors.txt

@@ -0,0 +1,2 @@
+Chris Double
+Doug Coleman

extra/db/sqlite/ffi/ffi.factor

@@ -0,0 +1,130 @@
+! Copyright (C) 2005 Chris Double, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+!
+! An interface to the sqlite database. Tested against sqlite v3.1.3.
+
+! Not all functions have been wrapped yet. Only those directly involving
+! executing SQL calls and obtaining results.
+
+USING: alien compiler kernel math namespaces sequences strings alien.syntax
+    system combinators ;
+IN: db.sqlite.ffi
+
+<<
+    "sqlite" {
+        { [ winnt? ]  [ "sqlite3.dll" ] }
+        { [ macosx? ] [ "/usr/lib/libsqlite3.dylib" ] }
+        { [ unix? ]  [ "libsqlite3.so" ] }
+    } cond "cdecl" add-library >>
+
+! Return values from sqlite functions
+: SQLITE_OK           0   ; inline ! Successful result
+: SQLITE_ERROR        1   ; inline ! SQL error or missing database
+: SQLITE_INTERNAL     2   ; inline ! An internal logic error in SQLite 
+: SQLITE_PERM         3   ; inline ! Access permission denied 
+: SQLITE_ABORT        4   ; inline ! Callback routine requested an abort 
+: SQLITE_BUSY         5   ; inline ! The database file is locked 
+: SQLITE_LOCKED       6   ; inline ! A table in the database is locked 
+: SQLITE_NOMEM        7   ; inline ! A malloc() failed 
+: SQLITE_READONLY     8   ; inline ! Attempt to write a readonly database 
+: SQLITE_INTERRUPT    9   ; inline ! Operation terminated by sqlite_interrupt() 
+: SQLITE_IOERR       10   ; inline ! Some kind of disk I/O error occurred 
+: SQLITE_CORRUPT     11   ; inline ! The database disk image is malformed 
+: SQLITE_NOTFOUND    12   ; inline ! (Internal Only) Table or record not found 
+: SQLITE_FULL        13   ; inline ! Insertion failed because database is full 
+: SQLITE_CANTOPEN    14   ; inline ! Unable to open the database file 
+: SQLITE_PROTOCOL    15   ; inline ! Database lock protocol error 
+: SQLITE_EMPTY       16   ; inline ! (Internal Only) Database table is empty 
+: SQLITE_SCHEMA      17   ; inline ! The database schema changed 
+: SQLITE_TOOBIG      18   ; inline ! Too much data for one row of a table 
+: SQLITE_CONSTRAINT  19   ; inline ! Abort due to contraint violation 
+: SQLITE_MISMATCH    20   ; inline ! Data type mismatch 
+: SQLITE_MISUSE      21   ; inline ! Library used incorrectly 
+: SQLITE_NOLFS       22   ; inline ! Uses OS features not supported on host 
+: SQLITE_AUTH        23   ; inline ! Authorization denied 
+: SQLITE_FORMAT      24   ; inline ! Auxiliary database format error
+: SQLITE_RANGE       25   ; inline ! 2nd parameter to sqlite3_bind out of range
+: SQLITE_NOTADB      26   ; inline ! File opened that is not a database file
+
+: sqlite-error-messages ( -- seq ) {
+    "Successful result"
+    "SQL error or missing database"
+    "An internal logic error in SQLite"
+    "Access permission denied"
+    "Callback routine requested an abort"
+    "The database file is locked"
+    "A table in the database is locked"
+    "A malloc() failed"
+    "Attempt to write a readonly database"
+    "Operation terminated by sqlite_interrupt()"
+    "Some kind of disk I/O error occurred"
+    "The database disk image is malformed"
+    "(Internal Only) Table or record not found"
+    "Insertion failed because database is full"
+    "Unable to open the database file"
+    "Database lock protocol error"
+    "(Internal Only) Database table is empty"
+    "The database schema changed"
+    "Too much data for one row of a table"
+    "Abort due to contraint violation"
+    "Data type mismatch"
+    "Library used incorrectly"
+    "Uses OS features not supported on host"
+    "Authorization denied"
+    "Auxiliary database format error"
+    "2nd parameter to sqlite3_bind out of range"
+    "File opened that is not a database file"
+} ;
+
+: SQLITE_ROW         100  ; inline ! sqlite_step() has another row ready 
+: SQLITE_DONE        101  ; inline ! sqlite_step() has finished executing 
+
+! Return values from the sqlite3_column_type function
+: SQLITE_INTEGER     1 ; inline
+: SQLITE_FLOAT       2 ; inline
+: SQLITE_TEXT        3 ; inline
+: SQLITE_BLOB        4 ; inline
+: SQLITE_NULL        5 ; inline
+
+! Values for the 'destructor' parameter of the 'bind' routines. 
+: SQLITE_STATIC      0  ; inline
+: SQLITE_TRANSIENT   -1 ; inline
+
+: SQLITE_OPEN_READONLY         HEX: 00000001 ; inline
+: SQLITE_OPEN_READWRITE        HEX: 00000002 ; inline
+: SQLITE_OPEN_CREATE           HEX: 00000004 ; inline
+: SQLITE_OPEN_DELETEONCLOSE    HEX: 00000008 ; inline
+: SQLITE_OPEN_EXCLUSIVE        HEX: 00000010 ; inline
+: SQLITE_OPEN_MAIN_DB          HEX: 00000100 ; inline
+: SQLITE_OPEN_TEMP_DB          HEX: 00000200 ; inline
+: SQLITE_OPEN_TRANSIENT_DB     HEX: 00000400 ; inline
+: SQLITE_OPEN_MAIN_JOURNAL     HEX: 00000800 ; inline
+: SQLITE_OPEN_TEMP_JOURNAL     HEX: 00001000 ; inline
+: SQLITE_OPEN_SUBJOURNAL       HEX: 00002000 ; inline
+: SQLITE_OPEN_MASTER_JOURNAL   HEX: 00004000 ; inline
+
+
+TYPEDEF: void sqlite3
+TYPEDEF: void sqlite3_stmt
+
+LIBRARY: sqlite
+FUNCTION: int sqlite3_open ( char* filename, void* ppDb ) ;
+FUNCTION: int sqlite3_close ( sqlite3* pDb ) ;
+FUNCTION: int sqlite3_prepare ( sqlite3* pDb, char* zSql, int nBytes, void* ppStmt, void* pzTail ) ;
+FUNCTION: int sqlite3_finalize ( sqlite3_stmt* pStmt ) ;
+FUNCTION: int sqlite3_reset ( sqlite3_stmt* pStmt ) ;
+FUNCTION: int sqlite3_step ( sqlite3_stmt* pStmt ) ;
+FUNCTION: int sqlite3_last_insert_rowid ( sqlite3* pStmt ) ;
+FUNCTION: int sqlite3_bind_blob ( sqlite3_stmt* pStmt, int index, void* ptr, int len, int destructor ) ;
+FUNCTION: int sqlite3_bind_int ( sqlite3_stmt* pStmt, int index, int n ) ;
+FUNCTION: int sqlite3_bind_null ( sqlite3_stmt* pStmt, int n ) ;
+FUNCTION: int sqlite3_bind_text ( sqlite3_stmt* pStmt, int index, char* text, int len, int destructor ) ;
+FUNCTION: int sqlite3_bind_parameter_index ( sqlite3_stmt* pStmt, char* name ) ;
+FUNCTION: int sqlite3_column_count ( sqlite3_stmt* pStmt ) ;
+FUNCTION: void* sqlite3_column_blob ( sqlite3_stmt* pStmt, int col ) ;
+FUNCTION: int sqlite3_column_bytes ( sqlite3_stmt* pStmt, int col ) ;
+FUNCTION: char* sqlite3_column_decltype ( sqlite3_stmt* pStmt, int col ) ;
+FUNCTION: int sqlite3_column_int ( sqlite3_stmt* pStmt, int col ) ;
+FUNCTION: int sqlite3_column_name ( sqlite3_stmt* pStmt, int col ) ;
+FUNCTION: char* sqlite3_column_text ( sqlite3_stmt* pStmt, int col ) ;
+FUNCTION: int sqlite3_column_type ( sqlite3_stmt* pStmt, int col ) ;

extra/db/sqlite/lib/lib.factor

@@ -0,0 +1,85 @@
+! Copyright (C) 2008 Chris Double, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types assocs kernel math math.parser sequences
+db.sqlite.ffi ;
+IN: db.sqlite.lib
+
+TUPLE: sqlite-error n message ;
+
+: sqlite-check-result ( result -- )
+    dup SQLITE_OK = [
+        drop
+    ] [
+        dup sqlite-error-messages nth
+        sqlite-error construct-boa throw
+    ] if ;
+
+: sqlite-open ( filename -- db )
+    "void*" <c-object>
+    [ sqlite3_open sqlite-check-result ] keep *void* ;
+
+: sqlite-close ( db -- )
+    sqlite3_close sqlite-check-result ;
+
+: sqlite-last-insert-rowid ( db -- rowid )
+    sqlite3_last_insert_rowid ;
+
+: sqlite-prepare ( db sql -- statement )
+    #! TODO: Support multiple statements in the SQL string.
+    dup length "void*" <c-object> "void*" <c-object>
+    [ sqlite3_prepare sqlite-check-result ] 2keep
+    drop *void* ;
+
+: sqlite-bind-text ( statement index text -- )
+    dup number? [ number>string ] when
+    dup length SQLITE_TRANSIENT sqlite3_bind_text sqlite-check-result ;
+
+: sqlite-bind-parameter-index ( statement name -- index )
+    sqlite3_bind_parameter_index ;
+
+: sqlite-bind-text-by-name ( statement name text -- )
+    >r dupd sqlite-bind-parameter-index r> sqlite-bind-text ;
+
+: sqlite-bind-assoc ( statement assoc -- )
+    swap [
+        -rot sqlite-bind-text-by-name
+    ] curry assoc-each ;
+
+: sqlite-finalize ( statement -- )
+    sqlite3_finalize sqlite-check-result ;
+
+: sqlite-reset ( statement -- )
+    sqlite3_reset sqlite-check-result ;
+
+: sqlite-#columns ( query -- int )
+    sqlite3_column_count ;
+
+: sqlite-column ( statement index -- string )
+    sqlite3_column_text ;
+
+: sqlite-row ( statement -- seq )
+    dup sqlite-#columns [ sqlite-column ] with map ;
+
+! 2dup sqlite3_column_type .
+! SQLITE_INTEGER     1
+! SQLITE_FLOAT       2
+! SQLITE_TEXT        3
+! SQLITE_BLOB        4
+! SQLITE_NULL        5
+
+: step-complete? ( step-result -- bool )
+    dup SQLITE_ROW =  [
+        drop f
+    ] [
+        dup SQLITE_DONE = [ drop t ] [ sqlite-check-result t ] if
+    ] if ;
+
+: sqlite-step ( prepared -- )
+    dup sqlite3_step step-complete? [
+        drop
+    ] [
+        sqlite-step
+    ] if ;
+
+: sqlite-next ( prepared -- ? )
+    sqlite3_step step-complete? ;

extra/db/sqlite/sqlite-tests.factor

@@ -0,0 +1,110 @@
+USING: io io.files io.launcher kernel namespaces
+prettyprint tools.test db.sqlite db db.sql sequences
+continuations ;
+IN: temporary
+
+! "sqlite3 -init test.txt test.db"
+
+IN: scratchpad
+: test.db "extra/db/sqlite/test.db" resource-path ;
+
+IN: temporary
+: (create-db) ( -- str )
+    [
+        "sqlite3 -init " %
+        test.db %
+        " " %
+        test.db %
+    ] "" make ;
+
+: create-db ( -- ) (create-db) run-process drop ;
+
+[ ] [ test.db delete-file ] unit-test
+
+[ ] [ create-db ] unit-test
+
+[
+    {
+        { "John" "America" }
+        { "Jane" "New Zealand" }
+    }
+] [
+    test.db [
+        "select * from person" sql-query
+    ] with-sqlite
+] unit-test
+
+[
+    { { "John" "America" } }
+] [
+    test.db [
+        "select * from person where name = :name and country = :country"
+        <simple-statement> [
+            { { ":name" "Jane" } { ":country" "New Zealand" } }
+            over do-bound-query
+
+            { { "Jane" "New Zealand" } } =
+            [ "test fails" throw ] unless
+
+            { { ":name" "John" } { ":country" "America" } }
+            swap do-bound-query
+        ] with-disposal
+    ] with-sqlite
+] unit-test
+
+[
+    {
+        { "1" "John" "America" }
+        { "2" "Jane" "New Zealand" }
+    }
+] [ test.db [ "select rowid, * from person" sql-query ] with-sqlite ] unit-test
+
+[
+] [
+    test.db [
+        "insert into person(name, country) values('Jimmy', 'Canada')"
+        sql-command
+    ] with-sqlite
+] unit-test
+
+[
+    {
+        { "1" "John" "America" }
+        { "2" "Jane" "New Zealand" }
+        { "3" "Jimmy" "Canada" }
+    }
+] [ test.db [ "select rowid, * from person" sql-query ] with-sqlite ] unit-test
+
+[
+    test.db [
+        [
+            "insert into person(name, country) values('Jose', 'Mexico')" sql-command
+            "insert into person(name, country) values('Jose', 'Mexico')" sql-command
+            "oops" throw
+        ] with-transaction
+    ] with-sqlite
+] unit-test-fails
+
+[ 3 ] [
+    test.db [
+        "select * from person" sql-query length
+    ] with-sqlite
+] unit-test
+
+[
+] [
+    test.db [
+        [
+            "insert into person(name, country) values('Jose', 'Mexico')"
+            sql-command
+            "insert into person(name, country) values('Jose', 'Mexico')"
+            sql-command
+        ] with-transaction
+    ] with-sqlite
+] unit-test
+
+[ 5 ] [
+    test.db [
+        "select * from person" sql-query length
+    ] with-sqlite
+] unit-test

extra/db/sqlite/sqlite.factor

@@ -0,0 +1,74 @@
+! Copyright (C) 2005, 2008 Chris Double, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien arrays assocs classes compiler db db.sql
+hashtables io.files kernel math math.parser namespaces
+prettyprint sequences strings tuples alien.c-types
+continuations db.sqlite.lib db.sqlite.ffi ;
+IN: db.sqlite
+
+TUPLE: sqlite-db path ;
+C: <sqlite-db> sqlite-db
+
+M: sqlite-db db-open ( db -- )
+    dup sqlite-db-path sqlite-open <db>
+    swap set-delegate ;
+
+M: sqlite-db dispose ( obj -- )
+    dup db-handle sqlite-close
+    f over set-db-handle
+    f swap set-delegate ;
+
+: with-sqlite ( path quot -- )
+    >r <sqlite-db> r> with-db ; inline
+
+TUPLE: sqlite-statement ;
+C: <sqlite-statement> sqlite-statement
+
+TUPLE: sqlite-result-set ;
+: <sqlite-result-set> ( query -- sqlite-result-set )
+    dup statement-handle sqlite-result-set <result-set> ;
+
+M: sqlite-db <simple-statement> ( str -- obj )
+    <prepared-statement> ;
+
+M: sqlite-db <prepared-statement> ( str -- obj )
+    db get db-handle over sqlite-prepare
+    { set-statement-sql set-statement-handle } statement construct
+    <sqlite-statement> [ set-delegate ] keep ;
+
+M: sqlite-statement dispose ( statement -- )
+    statement-handle sqlite-finalize ;
+
+M: sqlite-result-set dispose ( result-set -- )
+    f swap set-result-set-handle ;
+
+M: sqlite-statement bind-statement* ( assoc statement -- )
+    statement-handle swap sqlite-bind-assoc ;
+
+M: sqlite-statement rebind-statement ( assoc statement -- )
+    dup statement-handle sqlite-reset
+    statement-handle swap sqlite-bind-assoc ;
+
+M: sqlite-statement execute-statement ( statement -- )
+    statement-handle sqlite-next drop ;
+
+M: sqlite-result-set #columns ( result-set -- n )
+    result-set-handle sqlite-#columns ;
+
+M: sqlite-result-set row-column ( result-set n -- obj )
+    >r result-set-handle r> sqlite-column ;
+
+M: sqlite-result-set advance-row ( result-set -- handle ? )
+    result-set-handle sqlite-next ;
+
+M: sqlite-statement query-results ( query -- result-set )
+    dup statement-handle sqlite-result-set <result-set> ;
+
+M: sqlite-db begin-transaction ( -- )
+    "BEGIN" sql-command ;
+
+M: sqlite-db commit-transaction ( -- )
+    "COMMIT" sql-command ;
+
+M: sqlite-db rollback-transaction ( -- )
+    "ROLLBACK" sql-command ;

extra/db/sqlite/test.txt

@@ -0,0 +1,3 @@
+create table person (name varchar(30), country varchar(30));
+insert into person values('John', 'America');
+insert into person values('Jane', 'New Zealand');

extra/delegate/delegate.factor

@@ -27,7 +27,7 @@ M: tuple-class group-words
     swap [ slot-spec-writer ] map append ;
 
 : define-consult-method ( word class quot -- )
-    pick add <method> spin define-method ;
+    pick add spin define-method ;
 
 : define-consult ( class group quot -- )
     >r group-words r>

extra/http/client/client.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs http kernel math math.parser namespaces sequences
 io io.sockets io.streams.string io.files strings splitting
-continuations ;
+continuations assocs.lib ;
 IN: http.client
 
 : parse-host ( url -- host port )
@@ -44,7 +44,7 @@ DEFER: http-get-stream
     #! Should this support Location: headers that are
     #! relative URLs?
     pick 100 /i 3 = [
-        dispose "Location" swap at nip http-get-stream
+        dispose "location" swap peek-at nip http-get-stream
     ] when ;
 
 : http-get-stream ( url -- code headers stream )

extra/http/http.factor

@@ -1,11 +1,12 @@
 ! Copyright (C) 2003, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: hashtables io kernel math namespaces math.parser assocs
-sequences strings splitting ascii io.utf8 ;
+sequences strings splitting ascii io.utf8 assocs.lib
+namespaces unicode.case ;
 IN: http
 
 : header-line ( line -- )
-    ": " split1 dup [ swap set ] [ 2drop ] if ;
+    ": " split1 dup [ swap >lower insert ] [ 2drop ] if ;
 
 : (read-header) ( -- )
     readln dup
@@ -71,4 +72,3 @@ IN: http
             hash>query %
         ] if
     ] "" make ;
-

extra/http/server/responders/responders.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays assocs hashtables html html.elements splitting
 http io kernel math math.parser namespaces parser sequences
-strings io.server ;
+strings io.server vectors assocs.lib ;
 
 IN: http.server.responders
 
@@ -10,8 +10,11 @@ IN: http.server.responders
 SYMBOL: vhosts
 SYMBOL: responders
 
+: >header ( value key -- multi-hash )
+    H{ } clone [ insert-at ] keep ;
+
 : print-header ( alist -- )
-    [ swap write ": " write print ] assoc-each nl ;
+    [ swap write ": " write print ] multi-assoc-each nl ;
 
 : response ( msg -- ) "HTTP/1.0 " write print ;
 
@@ -20,7 +23,7 @@ SYMBOL: responders
 
 : error-head ( error -- )
     dup log-error response
-    H{ { "Content-Type" "text/html" } } print-header nl ;
+    H{ { "Content-Type" V{ "text/html" } } } print-header nl ;
 
 : httpd-error ( error -- )
     #! This must be run from handle-request
@@ -36,7 +39,7 @@ SYMBOL: responders
 
 : serving-content ( mime -- )
     "200 Document follows" response
-    "Content-Type" associate print-header ;
+    "Content-Type" >header print-header ;
 
 : serving-html "text/html" serving-content ;
 
@@ -46,7 +49,7 @@ SYMBOL: responders
 : serving-text "text/plain" serving-content ;
 
 : redirect ( to response -- )
-    response "Location" associate print-header ;
+    response "Location" >header print-header ;
 
 : permanent-redirect ( to -- )
     "301 Moved Permanently" redirect ;
@@ -84,14 +87,14 @@ SYMBOL: max-post-request
 : log-headers ( hash -- )
     [
         drop {
-            "User-Agent"
+            "user-agent"
-            "Referer"
+            "referer"
-            "X-Forwarded-For"
+            "x-forwarded-for"
-            "Host"
+            "host"
         } member?
     ] assoc-subset [
         ": " swap 3append log-message
-    ] assoc-each ;
+    ] multi-assoc-each ;
 
 : prepare-url ( url -- url )
     #! This is executed in the with-request namespace.
@@ -122,7 +125,8 @@ SYMBOL: max-post-request
 
 : query-param ( key -- value ) "query" get at ;
 
-: header-param ( key -- value ) "header" get at ;
+: header-param ( key -- value )
+    "header" get peek-at ;
 
 : host ( -- string )
     #! The host the current responder was called from.
@@ -130,7 +134,7 @@ SYMBOL: max-post-request
 
 : add-responder ( responder -- )
     #! Add a responder object to the list.
-    "responder" over at  responders get set-at ;
+    "responder" over at responders get set-at ;
 
 : make-responder ( quot -- )
     #! quot has stack effect ( url -- )

extra/io/buffers/buffers.factor

@@ -14,7 +14,7 @@ TUPLE: buffer size ptr fill pos ;
     dup buffer-ptr free  f swap set-buffer-ptr ;
 
 : buffer-reset ( n buffer -- )
-    [ set-buffer-fill ] keep 0 swap set-buffer-pos ;
+    0 swap { set-buffer-fill set-buffer-pos } set-slots ;
 
 : buffer-consume ( n buffer -- )
     [ buffer-pos + ] keep

extra/io/launcher/launcher-docs.factor

@@ -116,6 +116,15 @@ HELP: run-detached
     "The output value can be passed to " { $link wait-for-process } " to get an exit code."
 } ;
 
+HELP: kill-process
+{ $values { "process" process } }
+{ $description "Kills a running process. Does nothing if the process has already exited." } ;
+
+HELP: kill-process*
+{ $values { "handle" "a process handle" } }
+{ $contract "Kills a running process." }
+{ $notes "User code should call " { $link kill-process } " intead." } ;
+
 HELP: process
 { $class-description "A class representing an active or finished process."
 $nl
@@ -166,6 +175,8 @@ $nl
 "The following words are used to launch processes:"
 { $subsection run-process }
 { $subsection run-detached }
+"Stopping processes:"
+{ $subsection kill-process }
 "Redirecting standard input and output to a pipe:"
 { $subsection <process-stream> }
 { $subsection with-process-stream }

extra/io/launcher/launcher.factor

@@ -84,6 +84,11 @@ HOOK: run-process* io-backend ( desc -- handle )
 : run-detached ( desc -- process )
     >descriptor H{ { +detached+ t } } union run-process ;
 
+HOOK: kill-process* io-backend ( handle -- )
+
+: kill-process ( process -- )
+    process-handle [ kill-process* ] when* ;
+
 HOOK: process-stream* io-backend ( desc -- stream process )
 
 TUPLE: process-stream process ;

extra/io/monitor/monitor.factor

@@ -1,11 +1,39 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: io.backend kernel continuations ;
+USING: io.backend kernel continuations namespaces sequences
+assocs hashtables sorting arrays ;
 IN: io.monitor
 
+<PRIVATE
+
+TUPLE: monitor queue closed? ;
+
+: check-monitor ( monitor -- )
+    monitor-closed? [ "Monitor closed" throw ] when ;
+
+: (monitor) ( delegate -- monitor )
+    H{ } clone {
+        set-delegate
+        set-monitor-queue
+    } monitor construct ;
+
+HOOK: fill-queue io-backend ( monitor -- )
+
+: changed-file ( changed path -- )
+    namespace [ append ] change-at ;
+
+: dequeue-change ( assoc -- path changes )
+    delete-any prune natural-sort >array ;
+
+PRIVATE>
+
 HOOK: <monitor> io-backend ( path recursive? -- monitor )
 
-HOOK: next-change io-backend ( monitor -- path changes )
+: next-change ( monitor -- path changed )
+    dup check-monitor
+    dup monitor-queue dup assoc-empty? [
+        drop dup fill-queue next-change
+    ] [ nip dequeue-change ] if ;
 
 SYMBOL: +add-file+
 SYMBOL: +remove-file+

extra/io/unix/backend/backend.factor

@@ -14,9 +14,9 @@ TUPLE: io-task port callbacks ;
 
 : io-task-fd io-task-port port-handle ;
 
-: <io-task> ( port continuation class -- task )
+: <io-task> ( port continuation/f class -- task )
-    >r 1vector io-task construct-boa r> construct-delegate ;
+    >r [ 1vector ] [ V{ } clone ] if* io-task construct-boa
-    inline
+    r> construct-delegate ; inline
 
 TUPLE: input-task ;
 
@@ -194,7 +194,7 @@ TUPLE: mx-port mx ;
 TUPLE: mx-task ;
 
 : <mx-task> ( port -- task )
-    f io-task construct-boa mx-task construct-delegate ;
+    f mx-task <io-task> ;
 
 M: mx-task do-io-task
     io-task-port mx-port-mx 0 swap wait-for-events f ;

extra/io/unix/launcher/launcher.factor

@@ -57,7 +57,8 @@ MEMO: 'arguments' ( -- parser )
 : setup-redirection ( -- )
     +stdin+ get read-flags 0 redirect
     +stdout+ get write-flags 1 redirect
-    +stderr+ get write-flags 2 redirect ;
+    +stderr+ get dup +stdout+ eq?
+    [ drop 1 2 dup2 io-error ] [ write-flags 2 redirect ] if ;
 
 : spawn-process ( -- )
     [
@@ -74,6 +75,9 @@ M: unix-io run-process* ( desc -- pid )
         [ spawn-process ] [ ] with-fork <process>
     ] with-descriptor ;
 
+M: unix-io kill-process* ( pid -- )
+    SIGTERM kill io-error ;
+
 : open-pipe ( -- pair )
     2 "int" <c-array> dup pipe zero?
     [ 2 c-int-array> ] [ drop f ] if ;

extra/io/unix/linux/linux.factor

@@ -1,15 +1,142 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
+USING: kernel io.backend io.monitor io.monitor.private io.files
+io.buffers io.nonblocking io.unix.backend io.unix.select
+io.unix.launcher unix.linux.inotify assocs namespaces threads
+continuations init math alien.c-types alien ;
 IN: io.unix.linux
-USING: io.backend io.unix.backend io.unix.launcher io.unix.select
-namespaces kernel assocs unix.process init ;
 
 TUPLE: linux-io ;
 
 INSTANCE: linux-io unix-io
 
+TUPLE: linux-monitor path wd callback ;
+
+: <linux-monitor> ( path wd -- monitor )
+    f (monitor) {
+        set-linux-monitor-path
+        set-linux-monitor-wd
+        set-delegate
+    } linux-monitor construct ;
+
+TUPLE: inotify watches ;
+
+: watches ( -- assoc ) inotify get-global inotify-watches ;
+
+: wd>monitor ( wd -- monitor ) watches at ;
+
+: wd>path ( wd -- path ) wd>monitor linux-monitor-path ;
+
+: <inotify> ( -- port )
+    H{ } clone
+    inotify_init dup io-error inotify <buffered-port>
+    { set-inotify-watches set-delegate } inotify construct ;
+
+: inotify-fd inotify get-global port-handle ;
+
+: (add-watch) ( path mask -- wd )
+    inotify-fd -rot inotify_add_watch dup io-error ;
+
+: check-existing ( wd -- )
+    watches key? [
+        "Cannot open multiple monitors for the same file" throw
+    ] when ;
+
+: add-watch ( path mask -- monitor )
+    dupd (add-watch)
+    dup check-existing
+    [ <linux-monitor> dup ] keep watches set-at ;
+
+: remove-watch ( monitor -- )
+    dup linux-monitor-wd watches delete-at
+    linux-monitor-wd inotify-fd swap inotify_rm_watch io-error ;
+
+M: linux-io <monitor> ( path recursive? -- monitor )
+    drop IN_CHANGE_EVENTS add-watch ;
+
+: notify-callback ( monitor -- )
+    dup linux-monitor-callback
+    f rot set-linux-monitor-callback
+    [ schedule-thread ] when* ;
+
+M: linux-io fill-queue ( monitor -- )
+    dup linux-monitor-callback [
+        "Cannot wait for changes on the same file from multiple threads" throw
+    ] when
+    [ swap set-linux-monitor-callback stop ] callcc0
+    check-monitor ;
+
+M: linux-monitor dispose ( monitor -- )
+    dup check-monitor
+    t over set-monitor-closed?
+    dup notify-callback
+    remove-watch ;
+
+: ?flag ( n mask symbol -- n )
+    pick rot bitand 0 > [ , ] [ drop ] if ;
+
+: parse-action ( mask -- changed )
+    [
+        IN_CREATE +add-file+ ?flag
+        IN_DELETE +remove-file+ ?flag
+        IN_DELETE_SELF +remove-file+ ?flag
+        IN_MODIFY +modify-file+ ?flag
+        IN_ATTRIB +modify-file+ ?flag
+        IN_MOVED_FROM +rename-file+ ?flag
+        IN_MOVED_TO +rename-file+ ?flag
+        IN_MOVE_SELF +rename-file+ ?flag
+        drop
+    ] { } make ;
+
+: parse-file-notify ( buffer -- changed path )
+    {
+        inotify-event-wd
+        inotify-event-name
+        inotify-event-mask
+    } get-slots
+    parse-action -rot alien>char-string >r wd>path r> path+ ;
+
+: events-exhausted? ( i buffer -- ? )
+    buffer-fill >= ;
+
+: inotify-event@ ( i buffer -- alien )
+    buffer-ptr <displaced-alien> ;
+
+: next-event ( i buffer -- i buffer )
+    2dup inotify-event@
+    inotify-event-len "inotify-event" heap-size +
+    swap >r + r> ;
+
+: parse-file-notifications ( i buffer -- )
+    2dup events-exhausted? [ 2drop ] [
+        2dup inotify-event@ dup inotify-event-wd wd>monitor [
+            monitor-queue [
+                parse-file-notify changed-file
+            ] bind
+        ] keep notify-callback
+        next-event parse-file-notifications
+    ] if ;
+
+: read-notifications ( port -- )
+    dup refill drop
+    0 over parse-file-notifications
+    0 swap buffer-reset ;
+
+TUPLE: inotify-task ;
+
+: <inotify-task> ( port -- task )
+    f inotify-task <input-task> ;
+
+: init-inotify ( mx -- )
+    <inotify>
+    dup inotify set-global
+    <inotify-task> swap register-io-task ;
+
+M: inotify-task do-io-task ( task -- )
+    io-task-port read-notifications f ;
+
 M: linux-io init-io ( -- )
-    <select-mx> mx set-global ;
+    <select-mx> dup mx set-global init-inotify ;
 
 T{ linux-io } set-io-backend
 

extra/io/windows/launcher/launcher.factor

@@ -48,10 +48,10 @@ TUPLE: CreateProcess-args
     } get-slots CreateProcess win32-error=0/f ;
 
 : escape-argument ( str -- newstr )
-    [ [ dup CHAR: " = [ CHAR: \\ , ] when , ] each ] "" make ;
+    CHAR: \s over member? [ "\"" swap "\"" 3append ] when ;
 
 : join-arguments ( args -- cmd-line )
-    " " join ;
+    [ escape-argument ] map " " join ;
 
 : app-name/cmd-line ( -- app-name cmd-line )
     +command+ get [
@@ -122,8 +122,7 @@ TUPLE: CreateProcess-args
     +stderr+ get
     dup +stdout+ eq? [
         drop
-        CreateProcess-args-lpStartupInfo
+        CreateProcess-args-lpStartupInfo STARTUPINFO-hStdOutput
-        STARTUPINFO-hStdOutput
     ] [
         GENERIC_WRITE CREATE_ALWAYS redirect
         swap inherited-stderr ?closed
@@ -162,6 +161,10 @@ M: windows-io run-process* ( desc -- handle )
         ] with-descriptor
     ] with-destructors ;
 
+M: windows-io kill-process* ( handle -- )
+    PROCESS_INFORMATION-hProcess
+    255 TerminateProcess win32-error=0/f ;
+
 : dispose-process ( process-information -- )
     #! From MSDN: "Handles in PROCESS_INFORMATION must be closed
     #! with CloseHandle when they are no longer needed."

extra/io/windows/nt/monitor/monitor.factor

@@ -3,12 +3,10 @@
 USING: alien.c-types destructors io.windows
 io.windows.nt.backend kernel math windows windows.kernel32
 windows.types libc assocs alien namespaces continuations
-io.monitor io.nonblocking io.buffers io.files io sequences
+io.monitor io.monitor.private io.nonblocking io.buffers io.files
-hashtables sorting arrays combinators ;
+io sequences hashtables sorting arrays combinators ;
 IN: io.windows.nt.monitor
 
-TUPLE: monitor path recursive? queue closed? ;
-
 : open-directory ( path -- handle )
     FILE_LIST_DIRECTORY
     share-mode
@@ -22,23 +20,26 @@ TUPLE: monitor path recursive? queue closed? ;
     dup add-completion
     f <win32-file> ;
 
+TUPLE: win32-monitor path recursive? ;
+
+: <win32-monitor> ( path recursive? port -- monitor )
+    (monitor) {
+        set-win32-monitor-path
+        set-win32-monitor-recursive?
+        set-delegate
+    } win32-monitor construct ;
+
 M: windows-nt-io <monitor> ( path recursive? -- monitor )
     [
-        >r dup open-directory monitor <buffered-port> r> {
+        over open-directory win32-monitor <buffered-port>
-            set-monitor-path
+        <win32-monitor>
-            set-delegate
-            set-monitor-recursive?
-        } monitor construct
     ] with-destructors ;
 
-: check-closed ( monitor -- )
-    port-type closed eq? [ "Monitor closed" throw ] when ;
-
 : begin-reading-changes ( monitor -- overlapped )
     dup port-handle win32-file-handle
     over buffer-ptr
     pick buffer-size
-    roll monitor-recursive? 1 0 ?
+    roll win32-monitor-recursive? 1 0 ?
     FILE_NOTIFY_CHANGE_ALL
     0 <uint>
     (make-overlapped)
@@ -49,6 +50,7 @@ M: windows-nt-io <monitor> ( path recursive? -- monitor )
         [
             dup begin-reading-changes
             swap [ save-callback ] 2keep
+            dup check-monitor ! we may have closed it...
             get-overlapped-result
         ] with-port-timeout
     ] with-destructors ;
@@ -63,30 +65,20 @@ M: windows-nt-io <monitor> ( path recursive? -- monitor )
         { [ t ] [ +modify-file+ ] }
     } cond nip ;
 
-: changed-file ( directory buffer -- changed path )
+: parse-file-notify ( directory buffer -- changed path )
     {
         FILE_NOTIFY_INFORMATION-FileName
         FILE_NOTIFY_INFORMATION-FileNameLength
         FILE_NOTIFY_INFORMATION-Action
-    } get-slots >r memory>u16-string path+ r> parse-action swap ;
+    } get-slots parse-action 1array -rot
+    memory>u16-string path+ ;
 
 : (changed-files) ( directory buffer -- )
-    2dup changed-file namespace [ swap add ] change-at
+    2dup parse-file-notify changed-file
     dup FILE_NOTIFY_INFORMATION-NextEntryOffset dup zero?
     [ 3drop ] [ swap <displaced-alien> (changed-files) ] if ;
 
-: changed-files ( directory buffer len -- assoc )
+M: windows-nt-io fill-queue ( monitor -- )
-    [ zero? [ 2drop ] [ (changed-files) ] if ] H{ } make-assoc ;
+    dup win32-monitor-path over buffer-ptr pick read-changes
-
+    [ zero? [ 2drop ] [ (changed-files) ] if ] H{ } make-assoc
-: fill-queue ( monitor -- )
-    dup monitor-path over buffer-ptr pick read-changes
-    changed-files
     swap set-monitor-queue ;
-
-M: windows-nt-io next-change ( monitor -- path changes )
-    dup check-closed
-    dup monitor-queue dup assoc-empty? [
-        drop dup fill-queue next-change
-    ] [
-        nip delete-any prune natural-sort >array
-    ] if ;

extra/partial-apply/partial-apply.factor

@@ -0,0 +1,26 @@
+
+USING: kernel sequences quotations math parser
+       shuffle combinators.cleave combinators.lib sequences.lib ;
+
+IN: partial-apply
+
+! Basic conceptual implementation. Todo: get it to compile.
+
+: apply-n ( obj quot i -- quot ) 1+ [ -nrot ] curry swap compose curry ;
+
+SYMBOL: _
+
+SYMBOL: ~
+
+: blank-positions ( quot -- seq )
+  [ length 2 - ] [ _ indices ] bi [ - ] map-with ;
+  
+: partial-apply ( pattern -- quot )
+  [ blank-positions length nrev ]
+  [ peek 1quotation ]
+  [ blank-positions ]
+  tri
+  [ apply-n ] each ;
+
+: $[ \ ] [ >quotation ] parse-literal \ partial-apply parsed ; parsing
+

extra/postgresql/postgresql-tests.factor

@@ -1,42 +0,0 @@
-! You will need to run  'createdb factor-test' to create the database.
-! Set username and password in  the 'connect' word.
-
-IN: postgresql-test
-USING: kernel postgresql alien continuations io prettyprint
-sequences namespaces ;
-
-
-: test-connection ( host port pgopts pgtty db user pass -- bool )
-    [ [ ] with-postgres ] catch "Error connecting!" "Connected!" ? print ;
-
-! just a basic demo
-
-"localhost" "" "" "" "test" "postgres" "" [
-    "drop table animal" do-command
-
-    "create table animal (id serial not null primary key, species varchar(256), name varchar(256), age integer)" do-command
-    "insert into animal (species, name, age) values ('lion', 'Mufasa', 5)"
-    do-command
-
-    "select * from animal where name = 'Mufasa'" [ ] do-query
-    "select * from animal where name = 'Mufasa'"
-    [
-        result>seq length 1 = [ "...there can only be one Mufasa..." throw ] unless
-    ] do-query
-
-    "insert into animal (species, name, age) values ('lion', 'Simba', 1)"
-    do-command
-
-    "select * from animal" 
-    [
-          "Animal table:" print
-          result>seq print-table
-    ] do-query
-
-    ! intentional errors
-    ! [ "select asdf from animal"
-    ! [ ] do-query ] catch [ "caught: " write print ] when*
-    ! "select asdf from animal" [ ] do-query 
-    ! "aofijweafew" do-command
-] with-postgres
-

extra/postgresql/postgresql.factor

@@ -1,61 +0,0 @@
-! Copyright (C) 2007 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-
-! adapted from libpq-fe.h version 7.4.7
-! tested on debian linux with postgresql 7.4.7
-
-USING: arrays alien alien.syntax continuations io
-kernel math namespaces postgresql.libpq prettyprint
-quotations sequences debugger ;
-IN: postgresql
-
-SYMBOL: db
-SYMBOL: query-res
-
-: connect-postgres ( host port pgopts pgtty db user pass -- conn )
-    PQsetdbLogin
-    dup PQstatus zero? [ "couldn't connect to database" throw ] unless ;
-
-: with-postgres ( host port pgopts pgtty db user pass quot -- )
-    [ >r connect-postgres db set r>
-    [ db get PQfinish ] [ ] cleanup ] with-scope ; inline
-
-: postgres-error ( ret -- ret )
-    dup zero? [ PQresultErrorMessage throw ] when ;
-
-: (do-query) ( PGconn query -- PGresult* )
-    ! For queries that do not return rows, PQexec() returns PGRES_COMMAND_OK
-    ! For queries that return rows, PQexec() returns PGRES_TUPLES_OK
-    PQexec
-    dup PQresultStatus PGRES_COMMAND_OK =
-    over PQresultStatus PGRES_TUPLES_OK =
-    or [
-        [ PQresultErrorMessage CHAR: \n swap remove ] keep PQclear throw
-    ] unless ;
-
-: (do-command) ( PGconn query -- PGresult* )
-    [ (do-query) ] catch
-    [
-        swap
-        "non-fatal error: " print
-        "\tQuery: " write "'" write write "'" print
-        "\t" write print
-    ] when* drop ;
-
-: do-command ( str -- )
-    1quotation \ (do-command) add db get swap call ;
-
-: prepare ( str quot word -- conn quot )
-    rot 1quotation swap append swap append db get swap ;
-
-: do-query ( str quot -- )
-    [ (do-query) query-res set ] prepare catch
-    [ rethrow ] [ query-res get PQclear ] if* ;
-
-: result>seq ( -- seq )
-    query-res get [ PQnfields ] keep PQntuples
-    [ swap [ query-res get -rot PQgetvalue ] with map ] with map ;
-
-: print-table ( seq -- )
-    [ [ write bl ] each "\n" write ] each ;
-

extra/project-euler/032/032.factor

@@ -1,7 +1,7 @@
 ! Copyright (c) 2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: combinators.lib hashtables kernel math math.combinatorics math.parser
-    math.ranges project-euler.common sequences sorting ;
+    math.ranges project-euler.common sequences ;
 IN: project-euler.032
 
 ! http://projecteuler.net/index.php?section=problems&id=32
@@ -63,9 +63,6 @@ PRIVATE>
 : source-032a ( -- seq )
     50 [1,b] 2000 [1,b] cartesian-product ;
 
-: pandigital? ( n -- ? )
-    number>string natural-sort "123456789" = ;
-
 ! multiplicand/multiplier/product
 : mmp ( pair -- n )
     first2 2dup * [ number>string ] 3apply 3append 10 string>integer ;

extra/project-euler/037/037.factor

@@ -0,0 +1,52 @@
+! Copyright (c) 2008 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math math.parser math.primes sequences ;
+IN: project-euler.037
+
+! http://projecteuler.net/index.php?section=problems&id=37
+
+! DESCRIPTION
+! -----------
+
+! The number 3797 has an interesting property. Being prime itself, it is
+! possible to continuously remove digits from left to right, and remain prime
+! at each stage: 3797, 797, 97, and 7. Similarly we can work from right to
+! left: 3797, 379, 37, and 3.
+
+! Find the sum of the only eleven primes that are both truncatable from left to
+! right and right to left.
+
+! NOTE: 2, 3, 5, and 7 are not considered to be truncatable primes.
+
+
+! SOLUTION
+! --------
+
+<PRIVATE
+
+: r-trunc? ( n -- ? )
+    10 /i dup 0 > [
+        dup prime? [ r-trunc? ] [ drop f ] if
+    ] [
+        drop t
+    ] if ;
+
+: reverse-digits ( n -- m )
+    number>string reverse 10 string>integer ;
+
+: l-trunc? ( n -- ? )
+    reverse-digits 10 /i reverse-digits dup 0 > [
+        dup prime? [ l-trunc? ] [ drop f ] if
+    ] [
+        drop t
+    ] if ;
+
+PRIVATE>
+
+: euler037 ( -- answer )
+    23 1000000 primes-between [ r-trunc? ] subset [ l-trunc? ] subset sum ;
+
+! [ euler037 ] 100 ave-time
+! 768 ms run / 9 ms GC ave time - 100 trials
+
+MAIN: euler037

extra/project-euler/038/038.factor

@@ -0,0 +1,55 @@
+! Copyright (c) 2008 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math math.parser math.ranges project-euler.common sequences ;
+IN: project-euler.038
+
+! http://projecteuler.net/index.php?section=problems&id=38
+
+! DESCRIPTION
+! -----------
+
+! Take the number 192 and multiply it by each of 1, 2, and 3:
+
+!     192 × 1 = 192
+!     192 × 2 = 384
+!     192 × 3 = 576
+
+! By concatenating each product we get the 1 to 9 pandigital, 192384576. We
+! will call 192384576 the concatenated product of 192 and (1,2,3)
+
+! The same can be achieved by starting with 9 and multiplying by 1, 2, 3, 4,
+! and 5, giving the pandigital, 918273645, which is the concatenated product of
+! 9 and (1,2,3,4,5).
+
+! What is the largest 1 to 9 pandigital 9-digit number that can be formed as
+! the concatenated product of an integer with (1,2, ... , n) where n > 1?
+
+
+! SOLUTION
+! --------
+
+! Only need to search 4-digit numbers starting with 9 since a 2-digit number
+! starting with 9 would produce 8 or 11 digits, and a 3-digit number starting
+! with 9 would produce 7 or 11 digits.
+
+<PRIVATE
+
+: (concat-product) ( accum n multiplier -- m )
+    pick length 8 > [
+        2drop 10 swap digits>integer
+    ] [
+        [ * number>digits over push-all ] 2keep 1+ (concat-product)
+    ] if ;
+
+: concat-product ( n -- m )
+    V{ } clone swap 1 (concat-product) ;
+
+PRIVATE>
+
+: euler038 ( -- answer )
+    9123 9876 [a,b] [ concat-product ] map [ pandigital? ] subset supremum ;
+
+! [ euler038 ] 100 ave-time
+! 37 ms run / 1 ms GC ave time - 100 trials
+
+MAIN: euler038

extra/project-euler/039/039.factor

@@ -0,0 +1,65 @@
+! Copyright (c) 2008 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays combinators.lib kernel math math.ranges namespaces
+    project-euler.common sequences ;
+IN: project-euler.039
+
+! http://projecteuler.net/index.php?section=problems&id=39
+
+! DESCRIPTION
+! -----------
+
+! If p is the perimeter of a right angle triangle with integral length sides,
+! {a,b,c}, there are exactly three solutions for p = 120.
+
+!     {20,48,52}, {24,45,51}, {30,40,50}
+
+! For which value of p < 1000, is the number of solutions maximised?
+
+
+! SOLUTION
+! --------
+
+! Algorithm adapted from http://mathworld.wolfram.com/PythagoreanTriple.html
+! Identical implementation as problem #75
+
+! Basically, this makes an array of 1000 zeros, recursively creates primitive
+! triples using the three transforms and then increments the array at index
+! [a+b+c] by one for each triple's sum AND its multiples under 1000 (to account
+! for non-primitive triples). The answer is just the index that has the highest
+! number.
+
+SYMBOL: p-count
+
+<PRIVATE
+
+: max-p ( -- n )
+    p-count get length ;
+
+: adjust-p-count ( n -- )
+    max-p 1- over <range> p-count get
+    [ [ 1+ ] change-nth ] curry each ;
+
+: (count-perimeters) ( seq -- )
+    dup sum max-p < [
+        dup sum adjust-p-count
+        [ u-transform ] keep [ a-transform ] keep d-transform
+        [ (count-perimeters) ] 3apply
+    ] [
+        drop
+    ] if ;
+
+: count-perimeters ( n -- )
+    0 <array> p-count set { 3 4 5 } (count-perimeters) ;
+
+PRIVATE>
+
+: euler039 ( -- answer )
+    [
+        1000 count-perimeters p-count get [ supremum ] keep index
+    ] with-scope ;
+
+! [ euler039 ] 100 ave-time
+! 2 ms run / 0 ms GC ave time - 100 trials
+
+MAIN: euler039

extra/project-euler/040/040.factor

@@ -0,0 +1,51 @@
+! Copyright (c) 2008 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math math.parser sequences strings ;
+IN: project-euler.040
+
+! http://projecteuler.net/index.php?section=problems&id=40
+
+! DESCRIPTION
+! -----------
+
+! An irrational decimal fraction is created by concatenating the positive
+! integers:
+
+!     0.123456789101112131415161718192021...
+
+! It can be seen that the 12th digit of the fractional part is 1.
+
+! If dn represents the nth digit of the fractional part, find the value of the
+! following expression.
+
+!     d1 × d10 × d100 × d1000 × d10000 × d100000 × d1000000
+
+
+! SOLUTION
+! --------
+
+<PRIVATE
+
+: (concat-upto) ( n limit str -- str )
+    2dup length > [
+        pick number>string over push-all rot 1+ -rot (concat-upto)
+    ] [
+        2nip
+    ] if ;
+
+: concat-upto ( n -- str )
+    SBUF" " clone 1 -rot (concat-upto) ;
+
+: nth-integer ( n str -- m )
+    [ 1- ] dip nth 1string 10 string>integer ;
+
+PRIVATE>
+
+: euler040 ( -- answer )
+    1000000 concat-upto { 1 10 100 1000 10000 100000 1000000 }
+    [ swap nth-integer ] with map product ;
+
+! [ euler040 ] 100 ave-time
+! 1002 ms run / 43 ms GC ave time - 100 trials
+
+MAIN: euler040

extra/project-euler/075/075.factor

@@ -0,0 +1,78 @@
+! Copyright (c) 2008 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays combinators.lib kernel math math.ranges namespaces
+    project-euler.common sequences ;
+IN: project-euler.075
+
+! http://projecteuler.net/index.php?section=problems&id=75
+
+! DESCRIPTION
+! -----------
+
+! It turns out that 12 cm is the smallest length of wire can be bent to form a
+! right angle triangle in exactly one way, but there are many more examples.
+
+!     12 cm: (3,4,5)
+!     24 cm: (6,8,10)
+!     30 cm: (5,12,13)
+!     36 cm: (9,12,15)
+!     40 cm: (8,15,17)
+!     48 cm: (12,16,20)
+
+! In contrast, some lengths of wire, like 20 cm, cannot be bent to form a right
+! angle triangle, and other lengths allow more than one solution to be found;
+! for example, using 120 cm it is possible to form exactly three different
+! right angle triangles.
+
+!     120 cm: (30,40,50), (20,48,52), (24,45,51)
+
+! Given that L is the length of the wire, for how many values of L ≤ 1,000,000
+! can exactly one right angle triangle be formed?
+
+
+! SOLUTION
+! --------
+
+! Algorithm adapted from http://mathworld.wolfram.com/PythagoreanTriple.html
+! Identical implementation as problem #39
+
+! Basically, this makes an array of 1000000 zeros, recursively creates
+! primitive triples using the three transforms and then increments the array at
+! index [a+b+c] by one for each triple's sum AND its multiples under 1000000
+! (to account for non-primitive triples). The answer is just the total number
+! of indexes that are equal to one.
+
+SYMBOL: p-count
+
+<PRIVATE
+
+: max-p ( -- n )
+    p-count get length ;
+
+: adjust-p-count ( n -- )
+    max-p 1- over <range> p-count get
+    [ [ 1+ ] change-nth ] curry each ;
+
+: (count-perimeters) ( seq -- )
+    dup sum max-p < [
+        dup sum adjust-p-count
+        [ u-transform ] keep [ a-transform ] keep d-transform
+        [ (count-perimeters) ] 3apply
+    ] [
+        drop
+    ] if ;
+
+: count-perimeters ( n -- )
+    0 <array> p-count set { 3 4 5 } (count-perimeters) ;
+
+PRIVATE>
+
+: euler075 ( -- answer )
+    [
+        1000000 count-perimeters p-count get [ 1 = ] count
+    ] with-scope ;
+
+! [ euler075 ] 100 ave-time
+! 1873 ms run / 123 ms GC ave time - 100 trials
+
+MAIN: euler075

extra/project-euler/common/common.factor

@@ -1,5 +1,6 @@
 USING: arrays combinators.lib kernel math math.functions math.miller-rabin
-    math.parser math.primes.factors math.ranges namespaces sequences ;
+    math.matrices math.parser math.primes.factors math.ranges namespaces
+    sequences sorting ;
 IN: project-euler.common
 
 ! A collection of words used by more than one Project Euler solution
@@ -12,9 +13,11 @@ IN: project-euler.common
 ! log10 - #25, #134
 ! max-path - #18, #67
 ! number>digits - #16, #20, #30, #34
+! pandigital? - #32, #38
 ! propagate-all - #18, #67
 ! sum-proper-divisors - #21
 ! tau* - #12
+! [uad]-transform - #39, #75
 
 
 : nth-pair ( n seq -- nth next )
@@ -44,6 +47,9 @@ IN: project-euler.common
         dup perfect-square? [ sqrt >fixnum neg , ] [ drop ] if
     ] { } make sum ;
 
+: transform ( triple matrix -- new-triple )
+    [ 1array ] dip m. first ;
+
 PRIVATE>
 
 : cartesian-product ( seq1 seq2 -- seq1xseq2 )
@@ -67,6 +73,9 @@ PRIVATE>
 : number>digits ( n -- seq )
     number>string string>digits ;
 
+: pandigital? ( n -- ? )
+    number>string natural-sort "123456789" = ;
+
 ! Not strictly needed, but it is nice to be able to dump the triangle after the
 ! propagation
 : propagate-all ( triangle -- newtriangle )
@@ -97,3 +106,12 @@ PRIVATE>
     dup sqrt >fixnum [1,b] [
         dupd mod zero? [ [ 2 + ] dip ] when
     ] each drop * ;
+
+! These transforms are for generating primitive Pythagorean triples
+: u-transform ( triple -- new-triple )
+    { { 1 2 2 } { -2 -1 -2 } { 2 2 3 } } transform ;
+: a-transform ( triple -- new-triple )
+    { { 1 2 2 } { 2 1 2 } { 2 2 3 } } transform ;
+: d-transform ( triple -- new-triple )
+    { { -1 -2 -2 } { 2 1 2 } { 2 2 3 } } transform ;
+

extra/project-euler/project-euler.factor

@@ -1,7 +1,7 @@
 ! Copyright (c) 2007, 2008 Aaron Schaefer, Samuel Tardieu.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: definitions io io.files kernel math.parser sequences vocabs
+USING: definitions io io.files kernel math math.parser project-euler.ave-time
-    vocabs.loader project-euler.ave-time project-euler.common math
+    sequences vocabs vocabs.loader
     project-euler.001 project-euler.002 project-euler.003 project-euler.004
     project-euler.005 project-euler.006 project-euler.007 project-euler.008
     project-euler.009 project-euler.010 project-euler.011 project-euler.012
@@ -11,8 +11,9 @@ USING: definitions io io.files kernel math.parser sequences vocabs
     project-euler.025 project-euler.026 project-euler.027 project-euler.028
     project-euler.029 project-euler.030 project-euler.031 project-euler.032
     project-euler.033 project-euler.034 project-euler.035 project-euler.036
-    project-euler.067 project-euler.134 project-euler.169 project-euler.173
+    project-euler.037 project-euler.038 project-euler.039 project-euler.040
-    project-euler.175 ;
+    project-euler.067 project-euler.075 project-euler.134 project-euler.169
+    project-euler.173 project-euler.175 ;
 IN: project-euler
 
 <PRIVATE

extra/sequences/lib/lib.factor

@@ -140,3 +140,16 @@ PRIVATE>
 : ?second ( seq -- second/f ) 1 swap ?nth ; inline
 : ?third ( seq -- third/f ) 2 swap ?nth ; inline
 : ?fourth ( seq -- fourth/f ) 3 swap ?nth ; inline
+
+: accumulator ( quot -- quot vec )
+    V{ } clone [ [ push ] curry compose ] keep ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! List the positions of obj in seq
+
+: indices ( seq obj -- seq )
+  >r dup length swap r>
+  [ = [ ] [ drop f ] if ] curry
+  2map
+  [ ] subset ;

extra/shuffle/shuffle.factor

@@ -30,3 +30,8 @@ MACRO: ntuck ( n -- ) 2 + [ dup , -nrot ] bake ;
 : 4drop ( a b c d -- ) 3drop drop ; inline
 
 : tuckd ( x y z -- z x y z ) 2 ntuck ; inline
+
+MACRO: nrev ( n -- quot )
+  [ 1+ ] map
+  reverse
+  [ [ -nrot ] curry ] map concat ;

extra/tools/crossref/crossref.factor

@@ -14,8 +14,7 @@ IN: tools.crossref
 
 : (method-usage) ( word generic -- methods )
     tuck methods
-    [ second quot-uses key? ] with subset
+    [ second uses member? ] with subset keys
-    0 <column>
     swap [ 2array ] curry map ;
 
 : method-usage ( word seq -- methods )

extra/tools/deploy/backend/backend.factor

@@ -16,8 +16,11 @@ IN: tools.deploy.backend
 : copy-lines ( stream -- )
     [ (copy-lines) ] with-disposal ;
 
-: run-with-output ( descriptor -- )
+: run-with-output ( arguments -- )
-    <process-stream>
+    [
+        +arguments+ set
+        +stdout+ +stderr+ set
+    ] H{ } make-assoc <process-stream>
     dup duplex-stream-out dispose
     copy-lines ;
 

extra/tools/deploy/shaker/shaker.factor

@@ -8,11 +8,6 @@ debugger io.streams.c io.streams.duplex io.files io.backend
 quotations words.private tools.deploy.config compiler.units ;
 IN: tools.deploy.shaker
 
-: show ( msg -- )
-    #! Use primitives directly so that we can print stuff even
-    #! after most of the image has been stripped away
-    "\r\n" append stdout-handle fwrite stdout-handle fflush ;
-
 : strip-init-hooks ( -- )
     "Stripping startup hooks" show
     "command-line" init-hooks get delete-at

extra/unicode/case/case.factor

@@ -1,6 +1,6 @@
 USING: kernel unicode.data sequences sequences.next namespaces
 assocs.lib unicode.normalize math unicode.categories combinators
-assocs ;
+assocs strings splitting ;
 IN: unicode.case
 
 : ch>lower ( ch -- lower ) simple-lower at-default ;

extra/unix/linux/inotify/inotify.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax ;
+USING: alien.syntax math math.bitfields ;
 IN: unix.linux.inotify
 
 C-STRUCT: inotify-event
@@ -8,7 +8,7 @@ C-STRUCT: inotify-event
     { "uint" "mask" }    ! watch mask
     { "uint" "cookie" }  ! cookie to synchronize two events
     { "uint" "len" }     ! length (including nulls) of name
-    { "char[1]" "name" } ! stub for possible name
+    { "char[0]" "name" } ! stub for possible name
     ;
 
 : IN_ACCESS HEX: 1 ; inline         ! File was accessed
@@ -37,6 +37,13 @@ C-STRUCT: inotify-event
 : IN_ISDIR HEX: 40000000 ; inline      ! event occurred against dir
 : IN_ONESHOT HEX: 80000000 ; inline    ! only send event once
 
+: IN_CHANGE_EVENTS
+    {
+        IN_MODIFY IN_ATTRIB IN_MOVED_FROM
+        IN_MOVED_TO IN_DELETE IN_CREATE IN_DELETE_SELF
+        IN_MOVE_SELF
+    } flags ; foldable
+
 : IN_ALL_EVENTS
     {
         IN_ACCESS IN_MODIFY IN_ATTRIB IN_CLOSE_WRITE
@@ -45,6 +52,6 @@ C-STRUCT: inotify-event
         IN_MOVE_SELF
     } flags ; foldable
 
-FUNCTION: int inotify_init ( void ) ;
+FUNCTION: int inotify_init ( ) ;
-FUNCTION: int inotify_add_watch ( int fd, char* name, u32 mask  ) ;
+FUNCTION: int inotify_add_watch ( int fd, char* name, uint mask  ) ;
-FUNCTION: int inotify_rm_watch ( int fd, u32 wd ) ;
+FUNCTION: int inotify_rm_watch ( int fd, uint wd ) ;

extra/unix/linux/linux.factor

@@ -1,10 +1,8 @@
-! Copyright (C) 2005 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: unix
 USING: alien.syntax ;
 
-TYPEDEF: ulong off_t
-
 ! Linux.
 
 : O_RDONLY  HEX: 0000 ; inline

extra/unix/solaris/solaris.factor

@@ -3,8 +3,6 @@
 IN: unix
 USING: alien.syntax system kernel ;
 
-TYPEDEF: ulong off_t
-
 ! Solaris.
 
 : O_RDONLY  HEX: 0000 ; inline

extra/unix/unix.factor

@@ -19,11 +19,13 @@ TYPEDEF: uint time_t
 TYPEDEF: uint uid_t
 TYPEDEF: ulong size_t
 TYPEDEF: ulong u_long
-TYPEDEF: ulonglong off_t
 TYPEDEF: ushort mode_t
 TYPEDEF: ushort nlink_t
 TYPEDEF: void* caddr_t
 
+TYPEDEF: ulong off_t
+TYPEDEF-IF: bsd? ulonglong off_t
+
 C-STRUCT: tm
     { "int" "sec" }    ! Seconds: 0-59 (K&R says 0-61?)
     { "int" "min" }    ! Minutes: 0-59
@@ -168,9 +170,10 @@ FUNCTION: time_t time ( time_t* t ) ;
 FUNCTION: int unlink ( char* path ) ;
 FUNCTION: int utimes ( char* path, timeval[2] times ) ;
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: SIGKILL 9 ; inline
-! wait and waitpid
+: SIGTERM 15 ; inline
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+FUNCTION: int kill ( pid_t pid, int sig ) ;
 
 ! Flags for waitpid
 

extra/windows/kernel32/kernel32.factor

@@ -707,7 +707,19 @@ FUNCTION: BOOL DeleteFileW ( LPCTSTR lpFileName ) ;
 ! FUNCTION: DosPathToSessionPathA
 ! FUNCTION: DosPathToSessionPathW
 ! FUNCTION: DuplicateConsoleHandle
-! FUNCTION: DuplicateHandle
+
+FUNCTION: BOOL DuplicateHandle (
+    HANDLE hSourceProcessHandle,
+    HANDLE hSourceHandle,
+    HANDLE hTargetProcessHandle,
+    LPHANDLE lpTargetHandle,
+    DWORD dwDesiredAccess,
+    BOOL bInheritHandle,
+    DWORD dwOptions ) ;
+
+: DUPLICATE_CLOSE_SOURCE 1 ;
+: DUPLICATE_SAME_ACCESS 2 ;
+
 ! FUNCTION: EncodePointer
 ! FUNCTION: EncodeSystemPointer
 ! FUNCTION: EndUpdateResourceA
@@ -1453,7 +1465,7 @@ FUNCTION: DWORD SleepEx ( DWORD dwMilliSeconds, BOOL bAlertable ) ;
 FUNCTION: BOOL SystemTimeToFileTime ( SYSTEMTIME* lpSystemTime, LPFILETIME lpFileTime ) ;
 ! FUNCTION: SystemTimeToTzSpecificLocalTime
 ! FUNCTION: TerminateJobObject
-! FUNCTION: TerminateProcess
+FUNCTION: BOOL TerminateProcess ( HANDLE hProcess, DWORD uExit ) ;
 ! FUNCTION: TerminateThread
 ! FUNCTION: TermsrvAppInstallMode
 ! FUNCTION: Thread32First

extra/x11/windows/windows.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2005, 2006 Eduardo Cavazos and Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types hashtables kernel math math.vectors
+USING: alien alien.c-types hashtables kernel math math.vectors math.bitfields
 namespaces sequences x11.xlib x11.constants x11.glx ;
 IN: x11.windows
 
@@ -12,7 +12,6 @@ IN: x11.windows
     XCreateColormap ;
 
 : event-mask ( -- n )
-<<<<<<< HEAD:extra/x11/windows/windows.factor
     {
         ExposureMask
         StructureNotifyMask
@@ -26,19 +25,6 @@ IN: x11.windows
         LeaveWindowMask
         PropertyChangeMask
     } flags ;
-=======
-    ExposureMask
-    StructureNotifyMask bitor
-    KeyPressMask bitor
-    KeyReleaseMask bitor
-    ButtonPressMask     bitor
-    ButtonReleaseMask bitor
-    PointerMotionMask bitor
-    FocusChangeMask bitor
-    EnterWindowMask bitor
-    LeaveWindowMask bitor
-    PropertyChangeMask bitor ;
->>>>>>> a05c18152b59073c49aa313ba685516310ec74a8:extra/x11/windows/windows.factor
 
 : window-attributes ( visinfo -- attributes )
     "XSetWindowAttributes" <c-object>

extra/x11/xlib/xlib.factor

@@ -12,7 +12,7 @@
 ! and note the section.
 
 USING: kernel arrays alien alien.c-types alien.syntax
-math words sequences namespaces continuations ;
+math math.bitfields words sequences namespaces continuations ;
 IN: x11.xlib
 
 LIBRARY: xlib
@@ -1078,16 +1078,16 @@ FUNCTION: Status XWithdrawWindow (
 
 ! 17.1.7 - Setting and Reading the WM_NORMAL_HINTS Property
 
-: USPosition	1 0 shift ; inline
+: USPosition    1 0 shift ; inline
-: USSize	1 1 shift ; inline
+: USSize        1 1 shift ; inline
-: PPosition	1 2 shift ; inline
+: PPosition     1 2 shift ; inline
-: PSize		1 3 shift ; inline
+: PSize         1 3 shift ; inline
-: PMinSize	1 4 shift ; inline
+: PMinSize      1 4 shift ; inline
-: PMaxSize	1 5 shift ; inline
+: PMaxSize      1 5 shift ; inline
-: PResizeInc	1 6 shift ; inline
+: PResizeInc    1 6 shift ; inline
-: PAspect	1 7 shift ; inline
+: PAspect       1 7 shift ; inline
-: PBaseSize	1 8 shift ; inline
+: PBaseSize     1 8 shift ; inline
-: PWinGravity	1 9 shift ; inline
+: PWinGravity   1 9 shift ; inline
 : PAllHints 
     { PPosition PSize PMinSize PMaxSize PResizeInc PAspect } flags ; foldable
 

misc/factor.sh

@@ -289,7 +289,7 @@ install_libraries() {
 }
 
 usage() {
-        echo "usage: $0 install|install-x11|self-update|quick-update|update|bootstrap"
+        echo "usage: $0 install|install-x11|self-update|quick-update|update|bootstrap|wget-bootstrap"
 }
 
 case "$1" in
@@ -299,5 +299,6 @@ case "$1" in
         quick-update) update; refresh_image ;;
         update) update; update_bootstrap ;;
         bootstrap) get_config_info; bootstrap ;;
+        wget-bootstrap) get_config_info; delete_boot_images; get_boot_image; bootstrap ;;
         *) usage ;;
 esac

vm/ffi_test.c

@@ -245,3 +245,8 @@ double ffi_test_35(struct test_struct_11 x, int y)
 {
 	return (x.x + x.y) * y;
 }
+
+double ffi_test_36(struct test_struct_12 x)
+{
+	return x.x;
+}

vm/ffi_test.h

@@ -57,3 +57,7 @@ struct test_struct_10 { float x; int y; };
 DLLEXPORT double ffi_test_34(struct test_struct_10 x, int y);
 struct test_struct_11 { int x; int y; };
 DLLEXPORT double ffi_test_35(struct test_struct_11 x, int y);
+
+struct test_struct_12 { int a; double x; };
+
+DLLEXPORT double ffi_test_36(struct test_struct_12 x);

vm/os-genunix.c

@@ -13,6 +13,7 @@ void init_signals(void)
 void early_init(void) { }
 
 #define SUFFIX ".image"
+#define SUFFIX_LEN 6
 
 const char *default_image_path(void)
 {
@@ -21,7 +22,14 @@ const char *default_image_path(void)
 	if(!path)
 		return "factor.image";
 
-	char *new_path = safe_realloc(path,PATH_MAX + strlen(SUFFIX) + 1);
+	/* We can't call strlen() here because with gcc 4.1.2 this
-	strcat(new_path,SUFFIX); 
+	causes an internal compiler error. */
+	int len = 0;
+	const char *iter = path;
+	while(*iter) { len++; iter++; }
+
+	char *new_path = safe_malloc(PATH_MAX + SUFFIX_LEN + 1);
+	memcpy(new_path,path,len + 1);
+	memcpy(new_path + len,SUFFIX,SUFFIX_LEN + 1);
 	return new_path;
 }

vm/os-linux.h

@@ -1,3 +1,5 @@
+#include <sys/syscall.h>
+
 #define UNKNOWN_TYPE_P(file) ((file)->d_type == DT_UNKNOWN)
 #define DIRECTORY_P(file) ((file)->d_type == DT_DIR)
 

vm/types.c

@@ -463,16 +463,10 @@ F_STRING* allot_string_internal(CELL capacity)
 {
 	F_STRING *string = allot_object(STRING_TYPE,string_size(capacity));
 
-	/* strings are null-terminated in memory, even though they also
-	have a length field. The null termination allows us to add
-	the sizeof(F_STRING) to a Factor string to get a C-style
-	char* string for C library calls. */
 	string->length = tag_fixnum(capacity);
 	string->hashcode = F;
 	string->aux = F;
 
-	set_string_nth(string,capacity,0);
-
 	return string;
 }
 
@@ -645,14 +639,7 @@ F_BYTE_ARRAY *allot_c_string(CELL capacity, CELL size)
 	} \
 	type *to_##type##_string(F_STRING *s, bool check) \
 	{ \
-		if(sizeof(type) == sizeof(char)) \
+		return (type*)(string_to_##type##_alien(s,check) + 1); \
-		{ \
-			if(check && !check_string(s,sizeof(type))) \
-				general_error(ERROR_C_STRING,tag_object(s),F,NULL); \
-			return (type*)(s + 1); \
-		} \
-		else \
-			return (type*)(string_to_##type##_alien(s,check) + 1); \
 	} \
 	type *unbox_##type##_string(void) \
 	{ \

vm/types.h

@@ -11,7 +11,7 @@ INLINE CELL string_capacity(F_STRING* str)
 
 INLINE CELL string_size(CELL size)
 {
-	return sizeof(F_STRING) + size + 1;
+	return sizeof(F_STRING) + size;
 }
 
 DEFINE_UNTAG(F_BYTE_ARRAY,BYTE_ARRAY_TYPE,byte_array)

vm/utilities.c

@@ -8,13 +8,6 @@ void *safe_malloc(size_t size)
 	return ptr;
 }
 
-void *safe_realloc(const void *ptr, size_t size)
-{
-	void *new_ptr = realloc((void *)ptr,size);
-	if(!new_ptr) fatal_error("Out of memory in safe_realloc", 0);
-	return new_ptr;
-}
-
 F_CHAR *safe_strdup(const F_CHAR *str)
 {
 	F_CHAR *ptr = STRDUP(str);

vm/utilities.h

@@ -1,3 +1,2 @@
 void *safe_malloc(size_t size);
-void *safe_realloc(const void *ptr, size_t size);
 F_CHAR *safe_strdup(const F_CHAR *str);