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

basis/base64/base64.factor

@@ -1,12 +1,13 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math sequences io.binary splitting grouping ;
+USING: kernel math sequences io.binary splitting grouping
+accessors ;
 IN: base64
 
 <PRIVATE
 
-: count-end ( seq quot -- count )
+: count-end ( seq quot -- n )
-    >r [ length ] keep r> find-last drop dup [ - 1- ] [ 2drop 0 ] if ; inline
+    trim-right-slice [ seq>> length ] [ to>> ] bi - ; inline
 
 : ch>base64 ( ch -- ch )
     "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" nth ;
@@ -21,13 +22,16 @@ IN: base64
     } nth ;
 
 : encode3 ( seq -- seq )
-    be> 4 <reversed> [ -6 * shift HEX: 3f bitand ch>base64 ] with B{ } map-as ;
+    be> 4 <reversed> [
+        -6 * shift HEX: 3f bitand ch>base64
+    ] with B{ } map-as ;
 
 : decode4 ( str -- str )
     0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ;
 
 : >base64-rem ( str -- str )
-    [ 3 0 pad-right encode3 ] [ length 1+ ] bi head 4 CHAR: = pad-right ;
+    [ 3 0 pad-right encode3 ] [ length 1+ ] bi
+    head-slice 4 CHAR: = pad-right ;
 
 PRIVATE>
 
@@ -42,5 +46,5 @@ PRIVATE>
 : base64> ( base64 -- str )
     #! input length must be a multiple of 4
     [ 4 <groups> [ decode4 ] map concat ]
-    [ [ CHAR: = = not ] count-end ]
+    [ [ CHAR: = = ] count-end ]
     bi head* ;

basis/bootstrap/image/image.factor

@@ -280,7 +280,7 @@ M: f '
         [
             [
                 {
-                    [ hashcode , ]
+                    [ hashcode <fake-bignum> , ]
                     [ name>> , ]
                     [ vocabulary>> , ]
                     [ def>> , ]

basis/cocoa/messages/messages.factor

@@ -4,7 +4,8 @@ USING: accessors alien alien.c-types alien.strings
 arrays assocs combinators compiler kernel
 math namespaces parser prettyprint prettyprint.sections
 quotations sequences strings words cocoa.runtime io macros
-memoize debugger io.encodings.ascii effects compiler.generator ;
+memoize debugger io.encodings.ascii effects compiler.generator
+libc libc.private ;
 IN: cocoa.messages
 
 : make-sender ( method function -- quot )
@@ -36,7 +37,7 @@ super-message-senders global [ H{ } assoc-like ] change-at
 
 : <super> ( receiver -- super )
     "objc-super" <c-object> [
-        >r dup objc-object-isa objc-class-super-class r>
+        >r dup object_getClass class_getSuperclass r>
         set-objc-super-class
     ] keep
     [ set-objc-super-receiver ] keep ;
@@ -101,11 +102,6 @@ MACRO: (send) ( selector super? -- quot )
 : objc-meta-class ( string -- class )
     \ objc_getMetaClass (objc-class) ;
 
-: method-arg-type ( method i -- type )
-    f <void*> 0 <int> over
-    >r method_getArgumentInfo drop
-    r> *void* ascii alien>string ;
-
 SYMBOL: objc>alien-types
 
 H{
@@ -134,12 +130,21 @@ SYMBOL: alien>objc-types
 
 objc>alien-types get [ swap ] assoc-map
 ! A hack...
-H{
+"ptrdiff_t" heap-size {
-    { "NSPoint" "{_NSPoint=ff}" }
+    { 4 [ H{
-    { "NSRect" "{_NSRect=ffff}" }
+        { "NSPoint" "{_NSPoint=ff}" }
-    { "NSSize" "{_NSSize=ff}" }
+        { "NSRect" "{_NSRect=ffff}" }
-    { "NSRange" "{_NSRange=II}" }
+        { "NSSize" "{_NSSize=ff}" }
-} assoc-union alien>objc-types set-global
+        { "NSRange" "{_NSRange=II}" }
+    } ] }
+    { 8 [ H{
+        { "NSPoint" "{_NSPoint=dd}" }
+        { "NSRect" "{_NSRect=dddd}" }
+        { "NSSize" "{_NSSize=dd}" }
+        { "NSRange" "{_NSRange=QQ}" }
+    } ] }
+} case
+assoc-union alien>objc-types set-global
 
 : objc-struct-type ( i string -- ctype )
     2dup CHAR: = -rot index-from swap subseq
@@ -159,34 +164,32 @@ H{
 
 : parse-objc-type ( string -- ctype ) 0 swap (parse-objc-type) ;
 
+: method-arg-type ( method i -- type )
+    method_copyArgumentType
+    [ ascii alien>string parse-objc-type ] keep
+    (free) ;
+
 : method-arg-types ( method -- args )
     dup method_getNumberOfArguments
-    [ method-arg-type parse-objc-type ] with map ;
+    [ method-arg-type ] with map ;
 
 : method-return-type ( method -- ctype )
-    #! Undocumented hack! Apple does not support this feature!
+    method_copyReturnType
-    objc-method-types parse-objc-type ;
+    [ ascii alien>string parse-objc-type ] keep
+    (free) ;
 
 : register-objc-method ( method -- )
     dup method-return-type over method-arg-types 2array
     dup cache-stubs
-    swap objc-method-name sel_getName
+    swap method_getName sel_getName
     objc-methods get set-at ;
 
-: method-list@ ( ptr -- ptr )
+: (register-objc-methods) ( methods count -- methods )
-    "objc-method-list" heap-size swap <displaced-alien> ;
+    over [ void*-nth register-objc-method ] curry each ;
-
-: (register-objc-methods) ( objc-class iterator -- )
-    2dup class_nextMethodList [
-        dup objc-method-list-count swap method-list@ [
-            objc-method-nth register-objc-method
-        ] curry each (register-objc-methods)
-    ] [
-        2drop
-    ] if* ;
 
 : register-objc-methods ( class -- )
-    f <void*> (register-objc-methods) ;
+    0 <uint> [ class_copyMethodList ] keep *uint 
+    (register-objc-methods) (free) ;
 
 : class-exists? ( string -- class ) objc_getClass >boolean ;
 
@@ -209,4 +212,4 @@ H{
     ] curry try ;
 
 : root-class ( class -- root )
-    dup objc-class-super-class [ root-class ] [ ] ?if ;
+    dup class_getSuperclass [ root-class ] [ ] ?if ;

basis/cocoa/runtime/runtime.factor

@@ -13,9 +13,13 @@ FUNCTION: bool sel_isMapped ( SEL aSelector ) ;
 
 FUNCTION: SEL sel_registerName ( char* str ) ;
 
+TYPEDEF: void* Class
+TYPEDEF: void* Method
+TYPEDEF: void* Protocol
+
 C-STRUCT: objc-super
     { "id" "receiver" }
-    { "void*" "class" } ;
+    { "Class" "class" } ;
 
 : CLS_CLASS        HEX: 1   ;
 : CLS_META         HEX: 2   ;
@@ -27,61 +31,47 @@ C-STRUCT: objc-super
 : CLS_NEED_BIND    HEX: 80  ;
 : CLS_METHOD_ARRAY HEX: 100 ;
 
-C-STRUCT: objc-class
-    { "void*" "isa" }
-    { "void*" "super-class" }
-    { "char*" "name" }
-    { "long" "version" }
-    { "long" "info" }
-    { "long" "instance-size" }
-    { "void*" "ivars" }
-    { "void*" "methodLists" }
-    { "void*" "cache" }
-    { "void*" "protocols" } ;
-
-C-STRUCT: objc-object
-    { "objc-class*" "isa" } ;
-
 FUNCTION: int objc_getClassList ( void* buffer, int bufferLen ) ;
 
-FUNCTION: objc-class* objc_getClass ( char* class ) ;
+FUNCTION: Class objc_getClass ( char* class ) ;
 
-FUNCTION: objc-class* objc_getMetaClass ( char* class ) ;
+FUNCTION: Class objc_getMetaClass ( char* class ) ;
 
-FUNCTION: objc-class* objc_getProtocol ( char* class ) ;
+FUNCTION: Protocol objc_getProtocol ( char* class ) ;
 
-FUNCTION: void objc_addClass ( objc-class* class ) ;
+FUNCTION: Class objc_allocateClassPair ( Class superclass, char* name, size_t extraBytes ) ;
+FUNCTION: void objc_registerClassPair ( Class cls ) ;
 
-FUNCTION: id class_createInstance ( objc-class* class, uint additionalByteCount ) ;
+FUNCTION: id class_createInstance ( Class class, uint additionalByteCount ) ;
 
-FUNCTION: id class_createInstanceFromZone ( objc-class* class, uint additionalByteCount, void* zone ) ;
+FUNCTION: id class_createInstanceFromZone ( Class class, uint additionalByteCount, void* zone ) ;
 
-C-STRUCT: objc-method
+FUNCTION: Method class_getInstanceMethod ( Class class, SEL selector ) ;
-    { "SEL" "name" }
-    { "char*" "types" }
-    { "void*" "imp" } ;
 
-FUNCTION: objc-method* class_getInstanceMethod ( objc-class* class, SEL selector ) ;
+FUNCTION: Method class_getClassMethod ( Class class, SEL selector ) ;
 
-FUNCTION: objc-method* class_getClassMethod ( objc-class* class, SEL selector ) ;
+FUNCTION: Method* class_copyMethodList ( Class class, uint* outCount ) ;
 
-C-STRUCT: objc-method-list
+FUNCTION: Class class_getSuperclass ( Class cls ) ;
-    { "void*" "obsolete" }
-    { "int" "count" } ;
 
-FUNCTION: objc-method-list* class_nextMethodList ( objc-class* class, void** iterator ) ;
+FUNCTION: char class_addMethod ( Class class, SEL name, void* imp, void* types ) ;
 
-FUNCTION: void class_addMethods ( objc-class* class, objc-method-list* methodList ) ;
+FUNCTION: char class_addProtocol ( Class class, Protocol protocol ) ;
 
-FUNCTION: void class_removeMethods ( objc-class* class, objc-method-list* methodList ) ;
+FUNCTION: uint method_getNumberOfArguments ( Method method ) ;
 
-FUNCTION: uint method_getNumberOfArguments ( objc-method* method ) ;
+FUNCTION: uint method_getSizeOfArguments ( Method method ) ;
 
-FUNCTION: uint method_getSizeOfArguments ( objc-method* method ) ;
+FUNCTION: uint method_getArgumentInfo ( Method method, int argIndex, char** type, int* offset ) ;
 
-FUNCTION: uint method_getArgumentInfo ( objc-method* method, int argIndex, char** type, int* offset ) ;
+FUNCTION: void* method_copyReturnType ( Method method ) ;
 
-C-STRUCT: objc-protocol-list
+FUNCTION: void* method_copyArgumentType ( Method method, uint index ) ;
-    { "void*" "next" }
+
-    { "int" "count" }
+FUNCTION: void* method_getTypeEncoding ( Method method ) ;
-    { "objc-class*" "class" } ;
+
+FUNCTION: SEL method_getName ( Method method ) ;
+
+FUNCTION: void* method_setImplementation ( Method method, void* imp ) ; 
+
+FUNCTION: Class object_getClass ( id object ) ;

basis/cocoa/subclassing/subclassing.factor

@@ -3,78 +3,27 @@
 USING: alien alien.c-types alien.strings arrays assocs
 combinators compiler hashtables kernel libc math namespaces
 parser sequences words cocoa.messages cocoa.runtime
-compiler.units io.encodings.ascii ;
+compiler.units io.encodings.ascii generalizations
+continuations ;
 IN: cocoa.subclassing
 
-: init-method ( method alien -- )
+: init-method ( method -- sel imp types )
-    >r first3 r>
+    first3 swap
-    [ >r execute r> set-objc-method-imp ] keep
+    [ sel_registerName ] [ execute ] [ ascii string>alien ]
-    [ >r ascii malloc-string r> set-objc-method-types ] keep
+    tri* ;
-    >r sel_registerName r> set-objc-method-name ;
 
-: <empty-method-list> ( n -- alien )
+: add-methods ( methods class -- )
-    "objc-method-list" heap-size
+    swap
-    "objc-method" heap-size pick * + 1 calloc
+    [ init-method class_addMethod drop ] with each ;
-    [ set-objc-method-list-count ] keep ;
 
-: <method-list> ( methods -- alien )
+: add-protocols ( protocols class -- )
-    dup length dup <empty-method-list> -rot
+    swap [ objc-protocol class_addProtocol drop ] with each ;
-    [ pick method-list@ objc-method-nth init-method ] 2each ;
-
-: define-objc-methods ( class methods -- )
-    <method-list> class_addMethods ;
-
-: <objc-class> ( name info -- class )
-    "objc-class" malloc-object
-    [ set-objc-class-info ] keep
-    [ >r ascii malloc-string r> set-objc-class-name ] keep ;
-
-: <protocol-list> ( name -- protocol-list )
-    "objc-protocol-list" malloc-object
-    1 over set-objc-protocol-list-count
-    swap objc-protocol over set-objc-protocol-list-class ;
-
-! The Objective C object model is a bit funny.
-! Every class has a metaclass.
-
-! The superclass of the metaclass of X is the metaclass of the
-! superclass of X.
-
-! The metaclass of the metaclass of X is the metaclass of the
-! root class of X.
-: meta-meta-class ( class -- class ) root-class objc-class-isa ;
-
-: copy-instance-size ( class -- )
-    dup objc-class-super-class objc-class-instance-size
-    swap set-objc-class-instance-size ;
-
-: <meta-class> ( superclass name -- class )
-    CLS_META <objc-class>
-    [ >r dup objc-class-isa r> set-objc-class-super-class ] keep
-    [ >r meta-meta-class r> set-objc-class-isa ] keep
-    dup copy-instance-size ;
-
-: set-protocols ( protocols class -- )
-    swap {
-        { [ dup empty? ] [ 2drop ] }
-        { [ dup length 1 = ] [
-            first <protocol-list>
-            swap set-objc-class-protocols
-        ] }
-    } cond ;
-
-: <new-class> ( protocols metaclass superclass name -- class )
-    CLS_CLASS <objc-class>
-    [ set-objc-class-super-class ] keep
-    [ set-objc-class-isa ] keep
-    [ set-protocols ] keep
-    dup copy-instance-size ;
 
 : (define-objc-class) ( protocols superclass name imeth -- )
-    >r
+    -rot
-    >r objc-class r>
+    [ objc-class ] dip 0 objc_allocateClassPair
-    [ <meta-class> ] 2keep <new-class> dup objc_addClass
+    [ add-methods ] [ add-protocols ] [ objc_registerClassPair ]
-    r> <method-list> class_addMethods ;
+    tri ;
 
 : encode-types ( return types -- encoding )
     swap prefix [
@@ -91,9 +40,25 @@ IN: cocoa.subclassing
         [ first4 prepare-method 3array ] map
     ] with-compilation-unit ;
 
+: types= ( a b -- ? )
+    [ ascii alien>string ] bi@ = ;
+
+: (verify-method-type) ( class sel types -- )
+    [ class_getInstanceMethod method_getTypeEncoding ]
+    dip types=
+    [ "Objective-C method types cannot be changed once defined" throw ]
+    unless ;
+: verify-method-type ( class sel imp types -- class sel imp types )
+    4 ndup nip (verify-method-type) ;
+
+: (redefine-objc-method) ( class method -- )
+    init-method ! verify-method-type
+    drop
+    [ class_getInstanceMethod ] dip method_setImplementation drop ;
+    
 : redefine-objc-methods ( imeth name -- )
     dup class-exists? [
-        objc_getClass swap define-objc-methods
+        objc_getClass swap [ (redefine-objc-method) ] with each
     ] [
         2drop
     ] if ;

basis/cocoa/types/types.factor

@@ -1,13 +1,20 @@
 ! Copyright (C) 2006, 2007 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types alien.syntax kernel ;
+USING: alien.c-types alien.syntax combinators kernel ;
 IN: cocoa.types
 
+TYPEDEF: long NSInteger
+TYPEDEF: ulong NSUInteger
+<< "ptrdiff_t" heap-size {
+    { 4 [ "float" ] }
+    { 8 [ "double" ] }
+} case "CGFloat" typedef >>
+
 C-STRUCT: NSRect
-    { "float" "x" }
+    { "CGFloat" "x" }
-    { "float" "y" }
+    { "CGFloat" "y" }
-    { "float" "w" }
+    { "CGFloat" "w" }
-    { "float" "h" } ;
+    { "CGFloat" "h" } ;
 
 TYPEDEF: NSRect _NSRect
 TYPEDEF: NSRect CGRect
@@ -23,8 +30,8 @@ TYPEDEF: NSRect CGRect
     [ NSRect-x ] keep NSRect-y ;
 
 C-STRUCT: NSPoint
-    { "float" "x" }
+    { "CGFloat" "x" }
-    { "float" "y" } ;
+    { "CGFloat" "y" } ;
 
 TYPEDEF: NSPoint _NSPoint
 TYPEDEF: NSPoint CGPoint
@@ -35,8 +42,8 @@ TYPEDEF: NSPoint CGPoint
     [ set-NSPoint-x ] keep ;
 
 C-STRUCT: NSSize
-    { "float" "w" }
+    { "CGFloat" "w" }
-    { "float" "h" } ;
+    { "CGFloat" "h" } ;
 
 TYPEDEF: NSSize _NSSize
 TYPEDEF: NSPoint CGPoint
@@ -47,8 +54,8 @@ TYPEDEF: NSPoint CGPoint
     [ set-NSSize-w ] keep ;
 
 C-STRUCT: NSRange
-    { "uint" "location" }
+    { "NSUInteger" "location" }
-    { "uint" "length" } ;
+    { "NSUInteger" "length" } ;
 
 TYPEDEF: NSRange _NSRange
 
@@ -58,12 +65,12 @@ TYPEDEF: NSRange _NSRange
     [ set-NSRange-location ] keep ;
 
 C-STRUCT: CGAffineTransform
-    { "float" "a" }
+    { "CGFloat" "a" }
-    { "float" "b" }
+    { "CGFloat" "b" }
-    { "float" "c" }
+    { "CGFloat" "c" }
-    { "float" "d" }
+    { "CGFloat" "d" }
-    { "float" "tx" }
+    { "CGFloat" "tx" }
-    { "float" "ty" } ;
+    { "CGFloat" "ty" } ;
 
 C-STRUCT: NSFastEnumerationState
     { "ulong" "state" }

basis/compiler/generator/generator.factor

@@ -325,12 +325,16 @@ M: single-float-regs reg-size drop 4 ;
 
 M: double-float-regs reg-size drop 8 ;
 
+M: stack-params reg-size drop "void*" heap-size ;
+
 GENERIC: reg-class-variable ( register-class -- symbol )
 
 M: reg-class reg-class-variable ;
 
 M: float-regs reg-class-variable drop float-regs ;
 
+M: stack-params reg-class-variable drop stack-params ;
+
 GENERIC: inc-reg-class ( register-class -- )
 
 M: reg-class inc-reg-class

basis/compiler/tests/alien.factor

@@ -279,7 +279,7 @@ FUNCTION: double ffi_test_35 test-struct-11 x int y ;
 
 C-STRUCT: test-struct-12 { "int" "a" } { "double" "x" } ;
 
-: make-struct-12
+: make-struct-12 ( x -- alien )
     "test-struct-12" <c-object>
     [ set-test-struct-12-x ] keep ;
 
@@ -380,3 +380,24 @@ FUNCTION: int ffi_test_37 ( void* func ) ;
 [ 1 ] [ callback-9 ffi_test_37 ] unit-test
 
 [ 7 ] [ callback-9 ffi_test_37 ] unit-test
+
+C-STRUCT: test_struct_13
+{ "float" "x1" }
+{ "float" "x2" }
+{ "float" "x3" }
+{ "float" "x4" }
+{ "float" "x5" }
+{ "float" "x6" } ;
+
+: make-test-struct-13 ( -- alien )
+    "test_struct_13" <c-object>
+        1.0 over set-test_struct_13-x1
+        2.0 over set-test_struct_13-x2
+        3.0 over set-test_struct_13-x3
+        4.0 over set-test_struct_13-x4
+        5.0 over set-test_struct_13-x5
+        6.0 over set-test_struct_13-x6 ;
+
+FUNCTION: int ffi_test_39 ( long a, long b, test_struct_13 s ) ;
+
+[ 21 ] [ 12347 12347 make-test-struct-13 ffi_test_39 ] unit-test

basis/compiler/tree/branch-fusion/branch-fusion.factor

@@ -1,5 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-IN: compiler.tree.branch-fusion
-
-: fuse-branches ( nodes -- nodes' ) ;

basis/compiler/tree/loop/inversion/inversion.factor

@@ -1,5 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-IN: compiler.tree.loop.inversion
-
-: invert-loops ( nodes -- nodes' ) ;

basis/compiler/tree/optimizer/optimizer.factor

@@ -1,6 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: compiler.tree.normalization
+USING: kernel namespaces
+compiler.tree.normalization
 compiler.tree.propagation
 compiler.tree.cleanup
 compiler.tree.escape-analysis
@@ -9,26 +10,24 @@ compiler.tree.def-use
 compiler.tree.dead-code
 compiler.tree.strength-reduction
 compiler.tree.loop.detection
-compiler.tree.loop.inversion
-compiler.tree.branch-fusion
 compiler.tree.finalization
 compiler.tree.checker ;
 IN: compiler.tree.optimizer
 
+SYMBOL: check-optimizer?
+
 : optimize-tree ( nodes -- nodes' )
     normalize
     propagate
     cleanup
     detect-loops
-    ! invert-loops
-    ! fuse-branches
     escape-analysis
     unbox-tuples
     compute-def-use
     remove-dead-code
-    finalize
     ! strength-reduce
-    ! USE: kernel
+    check-optimizer? get [
-    ! compute-def-use
+        compute-def-use
-    ! dup check-nodes
+        dup check-nodes
-    ;
+    ] when
+    finalize ;

basis/core-foundation/core-foundation.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2006, 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types alien.strings alien.syntax kernel
-math sequences io.encodings.utf16 destructors accessors ;
+math sequences io.encodings.utf16 destructors accessors combinators ;
 IN: core-foundation
 
 TYPEDEF: void* CFAllocatorRef
@@ -17,10 +17,10 @@ TYPEDEF: void* CFURLRef
 TYPEDEF: void* CFUUIDRef
 TYPEDEF: void* CFTypeRef
 TYPEDEF: bool Boolean
-TYPEDEF: int CFIndex
+TYPEDEF: long CFIndex
 TYPEDEF: int SInt32
 TYPEDEF: uint UInt32
-TYPEDEF: uint CFTypeID
+TYPEDEF: ulong CFTypeID
 TYPEDEF: double CFTimeInterval
 TYPEDEF: double CFAbsoluteTime
 
@@ -137,7 +137,7 @@ M: f <CFNumber>
     dup <CFBundle> [
         CFBundleLoadExecutable drop
     ] [
-        "Cannot load bundled named " prepend throw
+        "Cannot load bundle named " prepend throw
     ] ?if ;
 
 TUPLE: CFRelease-destructor alien disposed ;

basis/cpu/architecture/architecture.factor

@@ -150,6 +150,8 @@ HOOK: %alien-indirect cpu ( -- )
 
 M: stack-params param-reg drop ;
 
+M: stack-params param-regs drop f ;
+
 GENERIC: v>operand ( obj -- operand )
 
 M: integer v>operand tag-fixnum ;

basis/db/db-docs.factor

@@ -12,11 +12,11 @@ HELP: new-db
 { $description "Creates a new database object from a given class." } ;
 
 HELP: make-db*
-{ $values { "seq" sequence } { "db" object } { "db" object } }
+{ $values { "object" object } { "db" object } { "db" object } }
 { $description "Takes a sequence of parameters specific to each database and a class name of the database, and constructs a new database object." } ;
 
 HELP: make-db
-{ $values { "seq" sequence } { "class" class } { "db" db } }
+{ $values { "object" object } { "class" class } { "db" db } }
 { $description "Takes a sequence of parameters specific to each database and a class name of the database, and constructs a new database object." } ;
 
 HELP: db-open
@@ -47,16 +47,18 @@ HELP: prepared-statement
 HELP: result-set
 { $description } ;
 
-HELP: construct-statement
+HELP: new-statement
 { $values { "sql" string } { "in" sequence } { "out" sequence } { "class" class } { "statement" statement } }
 { $description "Makes a new statement object from the given parameters." } ;
 
 HELP: <simple-statement>
-{ $values { "string" string } { "in" sequence } { "out" sequence } }
+{ $values { "string" string } { "in" sequence } { "out" sequence }
+    { "statement" statement } }
 { $description "Makes a new simple statement object from the given parameters." } ;
 
 HELP: <prepared-statement>
-{ $values { "string" string } { "in" sequence } { "out" sequence } }
+{ $values { "string" string } { "in" sequence } { "out" sequence }
+    { "statement" statement } }
 { $description "Makes a new prepared statement object from the given parameters." } ;
 
 HELP: prepare-statement
@@ -76,7 +78,9 @@ HELP: bind-tuple
 { $description "" } ;
 
 HELP: query-results
-{ $values { "query" object } { "statement" statement } }
+{ $values { "query" object }
+    { "result-set" result-set }
+}
 { $description "" } ;
 
 HELP: #rows
@@ -88,11 +92,14 @@ HELP: #columns
 { $description "Returns the number of columns in a result set." } ;
 
 HELP: row-column
-{ $values { "result-set" result-set } { "column" integer } }
+{ $values { "result-set" result-set } { "column" integer }
+    { "obj" object }
+}
 { $description "" } ;
 
 HELP: row-column-typed
-{ $values { "result-set" result-set } { "column" integer } }
+{ $values { "result-set" result-set } { "column" integer }
+    { "sql" "sql" } }
 { $description "" } ;
 
 HELP: advance-row
@@ -100,7 +107,7 @@ HELP: advance-row
 ;
 
 HELP: more-rows?
-{ $values { "result-set" result-set } { "column" integer } }
+{ $values { "result-set" result-set } { "?" "a boolean" } }
 ;
 
 HELP: execute-statement*
@@ -143,8 +150,9 @@ ARTICLE: "db-custom-database-combinators" "Custom database combinators"
 
 "Make a " { $snippet "with-" } " word to open, close, and use your database."
 { $code <"
+USING: db.sqlite db io.files ;
 : with-my-database ( quot -- )
-    { "my-database.db" temp-file } 
+    { "my-database.db" temp-file } sqlite-db rot with-db ;
 "> }
 
 

basis/db/db.factor

@@ -17,9 +17,9 @@ TUPLE: db
         H{ } clone >>update-statements
         H{ } clone >>delete-statements ; inline
 
-GENERIC: make-db* ( seq db -- db )
+GENERIC: make-db* ( object db -- db )
 
-: make-db ( seq class -- db ) new-db make-db* ;
+: make-db ( object class -- db ) new-db make-db* ;
 
 GENERIC: db-open ( db -- db )
 HOOK: db-close db ( handle -- )
@@ -36,13 +36,33 @@ HOOK: db-close db ( handle -- )
         } cleave
     ] with-variable ;
 
+TUPLE: result-set sql in-params out-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 column -- obj )
+GENERIC# row-column-typed 1 ( result-set column -- sql )
+GENERIC: advance-row ( result-set -- )
+GENERIC: more-rows? ( result-set -- ? )
+
+: init-result-set ( result-set -- )
+    dup #rows >>max
+    0 >>n drop ;
+
+: new-result-set ( query handle class -- result-set )
+    new
+        swap >>handle
+        >r [ sql>> ] [ in-params>> ] [ out-params>> ] tri r>
+        swap >>out-params
+        swap >>in-params
+        swap >>sql ;
+
 TUPLE: statement handle sql in-params out-params bind-params bound? type retries ;
 TUPLE: simple-statement < statement ;
 TUPLE: prepared-statement < statement ;
 
-TUPLE: result-set sql in-params out-params handle n max ;
+: new-statement ( sql in out class -- statement )
-
-: construct-statement ( sql in out class -- statement )
     new
         swap >>out-params
         swap >>in-params
@@ -54,13 +74,6 @@ GENERIC: prepare-statement ( statement -- )
 GENERIC: bind-statement* ( statement -- )
 GENERIC: low-level-bind ( statement -- )
 GENERIC: bind-tuple ( tuple statement -- )
-GENERIC: query-results ( query -- result-set )
-GENERIC: #rows ( result-set -- n )
-GENERIC: #columns ( result-set -- n )
-GENERIC# row-column 1 ( result-set column -- obj )
-GENERIC# row-column-typed 1 ( result-set column -- sql )
-GENERIC: advance-row ( result-set -- )
-GENERIC: more-rows? ( result-set -- ? )
 
 GENERIC: execute-statement* ( statement type -- )
 
@@ -79,18 +92,6 @@ M: object execute-statement* ( statement type -- )
     [ bind-statement* ] keep
     t >>bound? drop ;
 
-: init-result-set ( result-set -- )
-    dup #rows >>max
-    0 >>n drop ;
-
-: construct-result-set ( query handle class -- result-set )
-    new
-        swap >>handle
-        >r [ sql>> ] [ in-params>> ] [ out-params>> ] tri r>
-        swap >>out-params
-        swap >>in-params
-        swap >>sql ;
-
 : sql-row ( result-set -- seq )
     dup #columns [ row-column ] with map ;
 
@@ -115,25 +116,6 @@ M: object execute-statement* ( statement type -- )
 : default-query ( query -- result-set )
     query-results [ [ sql-row ] query-map ] with-disposal ;
 
-: do-bound-query ( obj query -- rows )
-    [ bind-statement ] keep default-query ;
-
-: do-bound-command ( obj query -- )
-    [ bind-statement ] keep execute-statement ;
-
-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 ;
-
 : sql-query ( sql -- rows )
     f f <simple-statement> [ default-query ] with-disposal ;
 
@@ -145,3 +127,20 @@ HOOK: rollback-transaction db ( -- )
             [ sql-command ] each
         ! ] with-transaction
     ] if ;
+
+SYMBOL: in-transaction
+HOOK: begin-transaction db ( -- )
+HOOK: commit-transaction db ( -- )
+HOOK: rollback-transaction db ( -- )
+
+M: db begin-transaction ( -- ) "BEGIN" sql-command ;
+M: db commit-transaction ( -- ) "COMMIT" sql-command ;
+M: db rollback-transaction ( -- ) "ROLLBACK" sql-command ;
+
+: in-transaction? ( -- ? ) in-transaction get ;
+
+: with-transaction ( quot -- )
+    t in-transaction [
+        begin-transaction
+        [ ] [ rollback-transaction ] cleanup commit-transaction
+    ] with-variable ;

basis/db/postgresql/postgresql.factor

@@ -40,15 +40,15 @@ M: postgresql-db dispose ( db -- )
 M: postgresql-statement bind-statement* ( statement -- )
     drop ;
 
-GENERIC: postgresql-bind-conversion ( tuple obj -- low-level-binding )
+GENERIC: postgresql-bind-conversion ( tuple object -- low-level-binding )
 
-M: sql-spec postgresql-bind-conversion ( tuple spec -- obj )
+M: sql-spec postgresql-bind-conversion ( tuple spec -- object )
     slot-name>> swap get-slot-named <low-level-binding> ;
 
-M: literal-bind postgresql-bind-conversion ( tuple literal-bind -- obj )
+M: literal-bind postgresql-bind-conversion ( tuple literal-bind -- object )
     nip value>> <low-level-binding> ;
 
-M: generator-bind postgresql-bind-conversion ( tuple generate-bind -- obj )
+M: generator-bind postgresql-bind-conversion ( tuple generate-bind -- object )
     dup generator-singleton>> eval-generator
     [ swap slot-name>> rot set-slot-named ] [ <low-level-binding> ] bi ;
 
@@ -66,10 +66,10 @@ M: postgresql-result-set #columns ( result-set -- n )
 : result-handle-n ( result-set -- handle n )
     [ handle>> ] [ n>> ] bi ;
 
-M: postgresql-result-set row-column ( result-set column -- obj )
+M: postgresql-result-set row-column ( result-set column -- object )
     >r result-handle-n r> pq-get-string ;
 
-M: postgresql-result-set row-column-typed ( result-set column -- obj )
+M: postgresql-result-set row-column-typed ( result-set column -- object )
     dup pick out-params>> nth type>>
     >r >r result-handle-n r> r> postgresql-column-typed ;
 
@@ -80,7 +80,7 @@ M: postgresql-statement query-results ( query -- result-set )
     ] [
         dup do-postgresql-statement
     ] if*
-    postgresql-result-set construct-result-set
+    postgresql-result-set new-result-set
     dup init-result-set ;
 
 M: postgresql-result-set advance-row ( result-set -- )
@@ -109,7 +109,7 @@ M: postgresql-statement prepare-statement ( statement -- )
     >>handle drop ;
 
 M: postgresql-db <simple-statement> ( sql in out -- statement )
-    postgresql-statement construct-statement ;
+    postgresql-statement new-statement ;
 
 M: postgresql-db <prepared-statement> ( sql in out -- statement )
     <simple-statement> dup prepare-statement ;
@@ -121,7 +121,7 @@ M: postgresql-db <prepared-statement> ( sql in out -- statement )
 M: postgresql-db bind% ( spec -- )
     bind-name% 1, ;
 
-M: postgresql-db bind# ( spec obj -- )
+M: postgresql-db bind# ( spec object -- )
     >r bind-name% f swap type>> r> <literal-bind> 1, ;
 
 : create-table-sql ( class -- statement )
@@ -251,7 +251,8 @@ M: postgresql-db persistent-table ( -- hashtable )
         { random-generator { f f f } }
     } ;
 
-M: postgresql-db compound ( str obj -- str' )
+ERROR: no-compound-found string object ;
+M: postgresql-db compound ( string object -- string' )
     over {
         { "default" [ first number>string join-space ] }
         { "varchar" [ first number>string paren append ] }
@@ -260,5 +261,5 @@ M: postgresql-db compound ( str obj -- str' )
                 swap [ slot-name>> = ] with find nip
                 column-name>> paren append
             ] }
-        [ "no compound found" 3array throw ]
+        [ drop no-compound-found ]
     } case ;

basis/db/queries/queries.factor

@@ -50,10 +50,6 @@ M: retryable execute-statement* ( statement type -- )
     [ 0 sql-counter rot with-variable ] curry { "" { } { } } nmake
     <simple-statement> maybe-make-retryable ; inline
 
-M: db begin-transaction ( -- ) "BEGIN" sql-command ;
-M: db commit-transaction ( -- ) "COMMIT" sql-command ;
-M: db rollback-transaction ( -- ) "ROLLBACK" sql-command ;
-
 : where-primary-key% ( specs -- )
     " where " 0%
     find-primary-key dup column-name>> 0% " = " 0% bind% ;
@@ -70,7 +66,7 @@ M: db <update-tuple-statement> ( class -- statement )
 M: random-id-generator eval-generator ( singleton -- obj )
     drop
     system-random-generator get [
-        63 [ 2^ random ] keep 1 - set-bit
+        63 [ random-bits ] keep 1- set-bit
     ] with-random ;
 
 : interval-comparison ( ? str -- str )
@@ -154,22 +150,22 @@ M: db <select-by-slots-statement> ( tuple class -- statement )
 
 : do-group ( tuple groups -- )
     [
-        ", " join " group by " prepend append
+        ", " join " group by " swap 3append
     ] curry change-sql drop ;
 
 : do-order ( tuple order -- )
     [
-        ", " join " order by " prepend append
+        ", " join " order by " swap 3append
     ] curry change-sql drop ;
 
 : do-offset ( tuple n -- )
     [
-        number>string " offset " prepend append
+        number>string " offset " swap 3append
     ] curry change-sql drop ;
 
 : do-limit ( tuple n -- )
     [
-        number>string " limit " prepend append
+        number>string " limit " swap 3append
     ] curry change-sql drop ;
 
 : make-query ( tuple query -- tuple' )

basis/db/sql/sql.factor

@@ -30,8 +30,6 @@ DEFER: sql%
         [ third 1, \ ? 0, ] tri
     ] each ;
 
-USE: multiline
-/*
 HOOK: sql-create db ( object -- )
 M: db sql-create ( object -- )
     drop
@@ -97,35 +95,35 @@ M: db sql-limit ( object -- )
 ! M: db sql-subselectselect ( object -- )
     ! "(select" sql% sql% ")" sql% ;
 
-GENERIC: sql-table db ( object -- )
+HOOK: sql-table db ( object -- )
 M: db sql-table ( object -- )
     sql% ;
 
-GENERIC: sql-set db ( object -- )
+HOOK: sql-set db ( object -- )
 M: db sql-set ( object -- )
     "set" "," sql-interleave ;
 
-GENERIC: sql-values db ( object -- )
+HOOK: sql-values db ( object -- )
 M: db sql-values ( object -- )
     "values(" sql% "," (sql-interleave) ")" sql% ;
 
-GENERIC: sql-count db ( object -- )
+HOOK: sql-count db ( object -- )
 M: db sql-count ( object -- )
     "count" sql-function, ;
 
-GENERIC: sql-sum db ( object -- )
+HOOK: sql-sum db ( object -- )
 M: db sql-sum ( object -- )
     "sum" sql-function, ;
 
-GENERIC: sql-avg db ( object -- )
+HOOK: sql-avg db ( object -- )
 M: db sql-avg ( object -- )
     "avg" sql-function, ;
 
-GENERIC: sql-min db ( object -- )
+HOOK: sql-min db ( object -- )
 M: db sql-min ( object -- )
     "min" sql-function, ;
 
-GENERIC: sql-max db ( object -- )
+HOOK: sql-max db ( object -- )
 M: db sql-max ( object -- )
     "max" sql-function, ;
 
@@ -156,9 +154,7 @@ M: db sql-max ( object -- )
         { \ max [ sql-max ] }
         [ sql% [ sql% ] each ]
     } case ;
-*/
 
-: sql-array% ( array -- ) drop ;
 ERROR: no-sql-match ;
 : sql% ( obj -- )
     {

basis/db/sqlite/sqlite.factor

@@ -27,7 +27,7 @@ M: sqlite-db <simple-statement> ( str in out -- obj )
     <prepared-statement> ;
 
 M: sqlite-db <prepared-statement> ( str in out -- obj )
-    sqlite-statement construct-statement ;
+    sqlite-statement new-statement ;
 
 : sqlite-maybe-prepare ( statement -- statement )
     dup handle>> [
@@ -42,9 +42,6 @@ M: sqlite-statement dispose ( statement -- )
 M: sqlite-result-set dispose ( result-set -- )
     f >>handle drop ;
 
-: reset-statement ( statement -- )
-    sqlite-maybe-prepare handle>> sqlite-reset ;
-
 : reset-bindings ( statement -- )
     sqlite-maybe-prepare
     handle>> [ sqlite3_reset drop ] [ sqlite3_clear_bindings drop ] bi ;
@@ -112,7 +109,7 @@ M: sqlite-result-set more-rows? ( result-set -- ? )
 
 M: sqlite-statement query-results ( query -- result-set )
     sqlite-maybe-prepare
-    dup handle>> sqlite-result-set construct-result-set
+    dup handle>> sqlite-result-set new-result-set
     dup advance-row ;
 
 M: sqlite-db create-sql-statement ( class -- statement )

basis/db/tuples/tuples-docs.factor

@@ -82,9 +82,9 @@ HELP: count-tuples
 
 HELP: query
 { $values
-     { "tuple" null } { "query" null }
+     { "tuple" tuple } { "query" query }
-     { "tuples" null } }
+     { "tuples" "a sequence of tuples" } }
-{ $description "" } ;
+{ $description "Allows for queries with group by, order by, limit, and offset clauses.  " } ;
 
 { select-tuple select-tuples count-tuples query } related-words
 

basis/db/tuples/tuples.factor

@@ -15,13 +15,13 @@ IN: db.tuples
 
 ERROR: not-persistent class ;
 
-: db-table ( class -- obj )
+: db-table ( class -- object )
     dup "db-table" word-prop [ ] [ not-persistent ] ?if ;
 
-: db-columns ( class -- obj )
+: db-columns ( class -- object )
     superclasses [ "db-columns" word-prop ] map concat ;
 
-: db-relations ( class -- obj )
+: db-relations ( class -- object )
     "db-relations" word-prop ;
 
 : set-primary-key ( key tuple -- )
@@ -34,13 +34,13 @@ SYMBOL: sql-counter
     sql-counter [ inc ] [ get ] bi number>string ;
 
 ! returns a sequence of prepared-statements
-HOOK: create-sql-statement db ( class -- obj )
+HOOK: create-sql-statement db ( class -- object )
-HOOK: drop-sql-statement db ( class -- obj )
+HOOK: drop-sql-statement db ( class -- object )
 
-HOOK: <insert-db-assigned-statement> db ( class -- obj )
+HOOK: <insert-db-assigned-statement> db ( class -- object )
-HOOK: <insert-user-assigned-statement> db ( class -- obj )
+HOOK: <insert-user-assigned-statement> db ( class -- object )
-HOOK: <update-tuple-statement> db ( class -- obj )
+HOOK: <update-tuple-statement> db ( class -- object )
-HOOK: <delete-tuples-statement> db ( tuple class -- obj )
+HOOK: <delete-tuples-statement> db ( tuple class -- object )
 HOOK: <select-by-slots-statement> db ( tuple class -- tuple )
 TUPLE: query group order offset limit ;
 HOOK: <query> db ( tuple class query -- statement' )
@@ -48,12 +48,12 @@ HOOK: <count-statement> db ( tuple class groups -- n )
 
 HOOK: insert-tuple* db ( tuple statement -- )
 
-GENERIC: eval-generator ( singleton -- obj )
+GENERIC: eval-generator ( singleton -- object )
 
-: resulting-tuple ( class row out-params -- tuple )
+: resulting-tuple ( exemplar-tuple row out-params -- tuple )
     rot class new [
         [
-            >r slot-name>> r> set-slot-named
+            [ slot-name>> ] dip set-slot-named
         ] curry 2each
     ] keep ;
 
@@ -65,10 +65,10 @@ GENERIC: eval-generator ( singleton -- obj )
 : query-modify-tuple ( tuple statement -- )
     [ query-results [ sql-row-typed ] with-disposal ] keep
     out-params>> rot [
-        >r slot-name>> r> set-slot-named
+        [ slot-name>> ] dip set-slot-named
     ] curry 2each ;
 
-: with-disposals ( seq quot -- )
+: with-disposals ( object quotation -- )
     over sequence? [
         [ with-disposal ] curry each
     ] [
@@ -121,7 +121,7 @@ GENERIC: eval-generator ( singleton -- obj )
     [ [ bind-tuple ] [ query-tuples ] 2bi ] with-disposal ;
 
 : query ( tuple query -- tuples )
-    >r dup dup class r> <query> do-select ;
+    [ dup dup class ] dip <query> do-select ;
 
 : select-tuples ( tuple -- tuples )
     dup dup class <select-by-slots-statement> do-select ;

basis/db/types/types-docs.factor

@@ -13,7 +13,7 @@ HELP: +autoincrement+
 { $description "" } ;
 
 HELP: +db-assigned-id+
-{ $description "" } ;
+{ $description "The database assigns a primary key to the object.  The primary key is most likely a big integer, but is database-dependent." } ;
 
 HELP: +default+
 { $description "" } ;
@@ -34,7 +34,7 @@ HELP: +primary-key+
 { $description "" } ;
 
 HELP: +random-id+
-{ $description "" } ;
+{ $description "Factor chooses a random number and tries to insert the tuple into the database with this number as its primary key.  The default number of retries to find a unique random number is 10, though in practice it will almost certainly succeed on the first try." } ;
 
 HELP: +serial+
 { $description "" } ;
@@ -43,7 +43,7 @@ HELP: +unique+
 { $description "" } ;
 
 HELP: +user-assigned-id+
-{ $description "" } ;
+{ $description "The user is responsible for choosing a primary key for tuples inserted with this database type.  Keys must be unique or else the database will throw an error.  Usually it is better to use a " { $link +db-assigned-id+ } "." } ;
 
 HELP: <generator-bind>
 { $description "" } ;
@@ -55,22 +55,22 @@ HELP: <low-level-binding>
 { $description "" } ;
 
 HELP: BIG-INTEGER
-{ $description "" } ;
+{ $description "A 64-bit integer." } ;
 
 HELP: BLOB
-{ $description "" } ;
+{ $description "A serialized Factor object.  The database library automatically serializes the object for a SQL insert or update and deserializes it on a tuple query." } ;
 
 HELP: BOOLEAN
-{ $description "" } ;
+{ $description "Either true or false." } ;
 
 HELP: DATE
-{ $description "" } ;
+{ $description "A date without a time component." } ;
 
 HELP: DATETIME
-{ $description "" } ;
+{ $description "A date and a time." } ;
 
 HELP: DOUBLE
-{ $description "" } ;
+{ $description "Corresponds to Factor's 64bit floating-point numbers." } ;
 
 HELP: FACTOR-BLOB
 { $description "" } ;
@@ -85,7 +85,7 @@ HELP: REAL
 { $description "" } ;
 
 HELP: SIGNED-BIG-INTEGER
-{ $description "" } ;
+{ $description "For portability, if a number is known to be 64bit and signed, then this datatype may be used.  Some databases, like SQLite, cannot store arbitrary bignums as BIGINT types.  If storing arbitrary bignums, use " { $link FACTOR-BLOB } "." } ;
 
 HELP: TEXT
 { $description "" } ;
@@ -133,24 +133,12 @@ HELP: db-assigned-id-spec?
      { "?" "a boolean" } }
 { $description "" } ;
 
-HELP: double-quote
-{ $values
-     { "string" string }
-     { "new-string" null } }
-{ $description "" } ;
-
 HELP: find-primary-key
 { $values
      { "specs" null }
      { "obj" object } }
 { $description "" } ;
 
-HELP: find-random-generator
-{ $values
-     { "seq" sequence }
-     { "obj" object } }
-{ $description "" } ;
-
 HELP: generator-bind
 { $description "" } ;
 
@@ -266,12 +254,6 @@ HELP: set-slot-named
      { "value" null } { "name" null } { "obj" object } }
 { $description "" } ;
 
-HELP: single-quote
-{ $values
-     { "string" string }
-     { "new-string" null } }
-{ $description "" } ;
-
 HELP: spec>tuple
 { $values
      { "class" class } { "spec" null }
@@ -281,23 +263,38 @@ HELP: spec>tuple
 HELP: sql-spec
 { $description "" } ;
 
-HELP: tuple>filled-slots
-{ $values
-     { "tuple" null }
-     { "alist" "an array of key/value pairs" } }
-{ $description "" } ;
-
-HELP: tuple>params
-{ $values
-     { "specs" null } { "tuple" null }
-     { "obj" object } }
-{ $description "" } ;
-
 HELP: unknown-modifier
 { $description "" } ;
 
 ARTICLE: "db.types" "Database types"
-"The " { $vocab-link "db.types" } " vocabulary maps Factor types to database types."
+"The " { $vocab-link "db.types" } " vocabulary maps Factor types to database types." $nl
+"Primary keys:"
+{ $subsection +db-assigned-id+ }
+{ $subsection +user-assigned-id+ }
+{ $subsection +random-id+ }
+"Null and boolean types:"
+{ $subsection NULL }
+{ $subsection BOOLEAN }
+"Text types:"
+{ $subsection VARCHAR }
+{ $subsection TEXT }
+"Number types:"
+{ $subsection INTEGER }
+{ $subsection BIG-INTEGER }
+{ $subsection SIGNED-BIG-INTEGER }
+{ $subsection UNSIGNED-BIG-INTEGER }
+{ $subsection DOUBLE }
+{ $subsection REAL }
+"Calendar types:"
+{ $subsection DATE }
+{ $subsection DATETIME }
+{ $subsection TIME }
+{ $subsection TIMESTAMP }
+"Arbitrary Factor objects:"
+{ $subsection BLOB }
+{ $subsection FACTOR-BLOB }
+"Factor URLs:"
+{ $subsection URL }
 ;
 
 ABOUT: "db.types"

basis/db/types/types.factor

@@ -30,15 +30,6 @@ UNION: +primary-key+ +db-assigned-id+ +user-assigned-id+ +random-id+ ;
 SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+
 +foreign-id+ +has-many+ ;
 
-: find-random-generator ( seq -- obj )
-    [
-        {
-            random-generator
-            system-random-generator
-            secure-random-generator
-        } member?
-    ] find nip [ system-random-generator ] unless* ;
-
 : primary-key? ( spec -- ? )
     primary-key>> +primary-key+? ;
 
@@ -122,12 +113,6 @@ ERROR: no-sql-type ;
         (lookup-type) second
     ] if ;
 
-: single-quote ( string -- new-string )
-    "'" swap "'" 3append ;
-
-: double-quote ( string -- new-string )
-    "\"" swap "\"" 3append ;
-
 : paren ( string -- new-string )
     "(" swap ")" 3append ;
 
@@ -150,12 +135,3 @@ HOOK: bind# db ( spec obj -- )
 
 : set-slot-named ( value name obj -- )
     tuck offset-of-slot set-slot ;
-
-: tuple>filled-slots ( tuple -- alist )
-    <mirror> [ nip ] assoc-filter ;
-
-: tuple>params ( specs tuple -- obj )
-    [
-        >r [ type>> ] [ slot-name>> ] bi r>
-        get-slot-named swap
-    ] curry { } map>assoc ;

basis/farkup/farkup-tests.factor

@@ -3,6 +3,10 @@
 USING: farkup kernel peg peg.ebnf tools.test namespaces ;
 IN: farkup.tests
 
+relative-link-prefix off
+disable-images? off
+link-no-follow? off
+
 [ "Baz" ] [ "Foo/Bar/Baz" simple-link-title ] unit-test
 [ "Baz" ] [ "Baz" simple-link-title ] unit-test
 
@@ -105,3 +109,12 @@ IN: farkup.tests
 [
     "<p>Feature comparison:</p><table><tr><td>a</td><td>Factor</td><td>Java</td><td>Lisp</td></tr><tr><td>Coolness</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Badass</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Enterprise</td><td>Yes</td><td>Yes</td><td>No</td></tr><tr><td>Kosher</td><td>Yes</td><td>No</td><td>Yes</td></tr></table>"
 ] [ "Feature comparison:\n\n|a|Factor|Java|Lisp|\n|Coolness|Yes|No|No|\n|Badass|Yes|No|No|\n|Enterprise|Yes|Yes|No|\n|Kosher|Yes|No|Yes|\n" convert-farkup ] unit-test
+
+[
+    "<p>This wiki is written in <a href='Factor'>Factor</a> and is hosted on a <a href='http://linode.com'>http://linode.com</a> virtual server.</p>"
+] [
+    "This wiki is written in [[Factor]] and is hosted on a [[http://linode.com|http://linode.com]] virtual server."
+    convert-farkup
+] unit-test
+
+[ "<p><a href='a'>a</a> <a href='b'>c</a></p>" ] [ "[[a]] [[b|c]]" convert-farkup ] unit-test

basis/farkup/farkup.factor

@@ -67,15 +67,17 @@ inline-code   = "%" (!("%" | nl).)+ "%"
 
 escaped-char  = "\" .                => [[ second ]]
 
-image-link       = "[[image:" (!("|") .)+  "|" (!("]]").)+ "]]"
+link-content     = (!("|"|"]").)+
+
+image-link       = "[[image:" link-content  "|" link-content "]]"
                     => [[ [ second >string ] [ fourth >string ] bi image boa ]]
-                  | "[[image:" (!("]").)+ "]]"
+                  | "[[image:" link-content "]]"
                     => [[ second >string f image boa ]]
 
-simple-link      = "[[" (!("|]" | "]]") .)+ "]]"
+simple-link      = "[[" link-content "]]"
     => [[ second >string dup simple-link-title link boa ]]
 
-labelled-link    = "[[" (!("|") .)+ "|" (!("]]").)+ "]]"
+labelled-link    = "[[" link-content "|" link-content "]]"
     => [[ [ second >string ] [ fourth >string ] bi link boa ]]
 
 link             = image-link | labelled-link | simple-link

basis/random/random-docs.factor

@@ -27,7 +27,13 @@ HELP: random
 
 HELP: random-bytes
 { $values { "n" "an integer" } { "byte-array" "a random integer" } }
-{ $description "Outputs an integer with n bytes worth of bits." } ;
+{ $description "Outputs an integer with n bytes worth of bits." }
+{ $examples 
+    { $unchecked-example "USING: prettyprint random ;"
+               "5 random-bytes ."
+               "B{ 135 50 185 119 240 }"
+    }
+} ;
 
 HELP: random-bits
 { $values { "n" "an integer" } { "r" "a random integer" } }

basis/random/random-tests.factor

@@ -1,4 +1,5 @@
-USING: random sequences tools.test kernel ;
+USING: random sequences tools.test kernel math math.functions
+sets ;
 IN: random.tests
 
 [ 4 ] [ 4 random-bytes length ] unit-test
@@ -9,3 +10,8 @@ IN: random.tests
 
 [ 2 ] [ V{ 10 20 30 } [ delete-random drop ] keep length ] unit-test
 [ V{ } [ delete-random drop ] keep length ] must-fail
+
+[ t ] [ 10000 [ 0 [ drop 187 random + ] reduce ] keep / 2 * 187 10 ~ ] unit-test
+[ t ] [ 10000 [ 0 [ drop 400 random + ] reduce ] keep / 2 * 400 10 ~ ] unit-test
+
+[ t ] [ 1000 [ 400 random ] replicate prune length 256 > ] unit-test

basis/random/random.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien.c-types kernel math namespaces sequences
 io.backend io.binary combinators system vocabs.loader
-summary ;
+summary math.bitwise ;
 IN: random
 
 SYMBOL: system-random-generator
@@ -29,15 +29,16 @@ M: f random-32* ( obj -- * ) no-random-number-generator ;
 
 : random-bytes ( n -- byte-array )
     [
-        dup 4 rem zero? [ 1+ ] unless
+        dup 3 mask zero? [ 1+ ] unless
         random-generator get random-bytes*
     ] keep head ;
 
 : random ( seq -- elt )
     [ f ] [
         [
-            length dup log2 7 + 8 /i
+            length dup log2 7 + 8 /i 1+
-            random-bytes byte-array>bignum swap mod
+            [ random-bytes byte-array>bignum ]
+            [ 3 shift 2^ ] bi / * >integer
         ] keep nth
     ] if-empty ;
 

basis/smtp/smtp-docs.factor

@@ -20,8 +20,7 @@ HELP: <email>
 
 HELP: send-email
 { $values { "email" email } }
-{ $description "Sends an " { $link email } " object to an STMP server stored in the " { $link smtp-server } " variable.  The required slots are " { $snippet "from" } " and " { $snippet "to" } "." }
+{ $description "Sends an " { $link email } " object to an STMP server stored in the " { $link smtp-server } " variable.  The required slots are " { $slot "from" } " and " { $slot "to" } "." }
-
 { $examples
     { $unchecked-example "USING: accessors smtp ;"
     "<email>"
@@ -37,9 +36,5 @@ HELP: send-email
 } ;
 
 ARTICLE: "smtp" "SMTP Client Library"
-"Start by creating a new email object:"
+"Sending an email:"
-{ $subsection <email> }
+{ $subsection send-email } ;
-"Set the " { $snippet "from" } " slot to a " { $link string } "." $nl
-"Set the recipient fields, " { $snippet "to" } ", " { $snippet "cc" } ", and " { $snippet "bcc" } ", to arrays of strings."
-"Set the " { $snippet "subject" } " to a " { $link string } "." $nl
-"Set the " { $snippet "body" } " to a " { $link string } "." $nl ;

basis/ui/cocoa/views/views.factor

@@ -127,7 +127,6 @@ CLASS: {
     { +protocols+ { "NSTextInput" } }
 }
 
-! Rendering
 ! Rendering
 { "drawRect:" "void" { "id" "SEL" "id" "NSRect" }
     [ 3drop window relayout-1 ]

core/kernel/kernel-tests.factor

@@ -1,6 +1,7 @@
 USING: arrays byte-arrays kernel kernel.private math memory
 namespaces sequences tools.test math.private quotations
-continuations prettyprint io.streams.string debugger assocs ;
+continuations prettyprint io.streams.string debugger assocs
+sequences.private ;
 IN: kernel.tests
 
 [ 0 ] [ f size ] unit-test
@@ -118,7 +119,8 @@ IN: kernel.tests
 
 [ total-failure-1 ] must-fail
 
-! From combinators.lib
 [ 1 1 2 2 3 3 ] [ 1 2 3 [ dup ] tri@ ] unit-test
 [ 1 4 9 ] [ 1 2 3 [ sq ] tri@ ] unit-test
 [ [ sq ] tri@ ] must-infer
+
+[ 4 ] [ 1 { [ 1 ] [ 2 ] } dispatch sq ] unit-test

core/sequences/sequences-docs.factor

@@ -81,6 +81,7 @@ ARTICLE: "sequences-reshape" "Reshaping sequences"
 
 ARTICLE: "sequences-appending" "Appending sequences"
 { $subsection append }
+{ $subsection prepend }
 { $subsection 3append }
 { $subsection concat }
 { $subsection join }
@@ -100,6 +101,7 @@ ARTICLE: "sequences-slices" "Subsequences and slices"
 { $subsection but-last }
 "Taking a sequence apart into a head and a tail:"
 { $subsection unclip }
+{ $subsection unclip-last }
 { $subsection cut }
 { $subsection cut* }
 "A " { $emphasis "slice" } " is a virtual sequence which presents as view of a subsequence of an underlying sequence:"
@@ -124,6 +126,8 @@ ARTICLE: "sequences-combinators" "Sequence combinators"
 { $subsection each }
 { $subsection reduce }
 { $subsection interleave }
+{ $subsection replicate }
+{ $subsection replicate-as }
 "Mapping:"
 { $subsection map }
 { $subsection map-as }
@@ -871,12 +875,43 @@ HELP: push-all
 HELP: append
 { $values { "seq1" sequence } { "seq2" sequence } { "newseq" sequence } }
 { $description "Outputs a new sequence of the same type as " { $snippet "seq1" } " consisting of the elements of " { $snippet "seq1" } " followed by " { $snippet "seq2" } "." }
-{ $errors "Throws an error if " { $snippet "seq2" } " contains elements not permitted in sequences of the same class as " { $snippet "seq1" } "." } ;
+{ $errors "Throws an error if " { $snippet "seq2" } " contains elements not permitted in sequences of the same class as " { $snippet "seq1" } "." }
+{ $examples 
+    { $example "USING: prettyprint sequences ;"
+        "{ 1 2 } B{ 3 4 } append ."
+        "{ 1 2 3 4 }"
+    }
+    { $example "USING: prettyprint sequences strings ;"
+        "\"go\" \"ing\" append ."
+        "\"going\""
+    }
+} ;
+
+HELP: prepend
+{ $values { "seq1" sequence } { "seq2" sequence } { "newseq" sequence } }
+{ $description "Outputs a new sequence of the same type as " { $snippet "seq2" } " consisting of the elements of " { $snippet "seq2" } " followed by " { $snippet "seq1" } "." }
+{ $errors "Throws an error if " { $snippet "seq1" } " contains elements not permitted in sequences of the same class as " { $snippet "seq2" } "." }
+{ $examples 
+    { $example "USING: prettyprint sequences ;"
+        "{ 1 2 } B{ 3 4 } prepend ."
+        "B{ 3 4 1 2 }"
+    }
+    { $example "USING: prettyprint sequences strings ;"
+        "\"go\" \"car\" prepend ."
+        "\"cargo\""
+    }
+} ;
 
 HELP: 3append
 { $values { "seq1" sequence } { "seq2" sequence } { "seq3" sequence } { "newseq" sequence } }
 { $description "Outputs a new sequence consisting of the elements of " { $snippet "seq1" } ", " { $snippet "seq2" } " and " { $snippet "seq3" } " in turn." }
-{ $errors "Throws an error if " { $snippet "seq2" } " or " { $snippet "seq3" } " contain elements not permitted in sequences of the same class as " { $snippet "seq1" } "." } ;
+{ $errors "Throws an error if " { $snippet "seq2" } " or " { $snippet "seq3" } " contain elements not permitted in sequences of the same class as " { $snippet "seq1" } "." }
+{ $examples
+    { $example "USING: prettyprint sequences ;"
+        "\"a\" \"b\" \"c\" 3append ."
+        "\"abc\""
+    }
+} ;
 
 HELP: subseq
 { $values { "from" "a non-negative integer" } { "to" "a non-negative integer" } { "seq" sequence } { "subseq" "a new sequence" } }
@@ -1004,6 +1039,17 @@ HELP: unclip-slice
 { $values { "seq" sequence } { "rest" slice } { "first" object } }
 { $description "Outputs a tail sequence and the first element of " { $snippet "seq" } "; the tail sequence consists of all elements of " { $snippet "seq" } " but the first. Unlike " { $link unclip } ", this word does not make a copy of the input sequence, and runs in constant time." } ;
 
+HELP: unclip-last
+{ $values { "seq" sequence } { "butlast" sequence } { "last" object } }
+{ $description "Outputs a head sequence and the last element of " { $snippet "seq" } "; the head sequence consists of all elements of " { $snippet "seq" } " but the last." }
+{ $examples
+    { $example "USING: prettyprint sequences ;" "{ 1 2 3 } unclip-last prefix ." "{ 3 1 2 }" }
+} ;
+
+HELP: unclip-last-slice
+{ $values { "seq" sequence } { "butlast" slice } { "last" object } }
+{ $description "Outputs a head sequence and the last element of " { $snippet "seq" } "; the head sequence consists of all elements of " { $snippet "seq" } " but the last Unlike " { $link unclip-last } ", this word does not make a copy of the input sequence, and runs in constant time." } ;
+
 HELP: sum
 { $values { "seq" "a sequence of numbers" } { "n" "a number" } }
 { $description "Outputs the sum of all elements of " { $snippet "seq" } ". Outputs zero given an empty sequence." } ;
@@ -1072,6 +1118,16 @@ HELP: trim-left
            "{ 1 2 3 0 0 }"
 } ;
 
+HELP: trim-left-slice
+{ $values
+     { "seq" sequence } { "quot" quotation }
+     { "slice" slice } }
+{ $description "Removes elements starting from the left side of a sequence if they match a predicate. Once an element does not match, the test stops and the rest of the sequence is left on the stack as a slice" }
+{ $example "" "USING: prettyprint math sequences ;"
+           "{ 0 0 1 2 3 0 0 } [ zero? ] trim-left-slice ."
+           "T{ slice { from 2 } { to 7 } { seq { 0 0 1 2 3 0 0 } } }"
+} ;
+
 HELP: trim-right
 { $values
      { "seq" sequence } { "quot" quotation }
@@ -1082,6 +1138,16 @@ HELP: trim-right
            "{ 0 0 1 2 3 }"
 } ;
 
+HELP: trim-right-slice
+{ $values
+     { "seq" sequence } { "quot" quotation }
+     { "slice" slice } }
+{ $description "Removes elements starting from the right side of a sequence if they match a predicate. Once an element does not match, the test stops and the rest of the sequence is left on the stack as a slice." }
+{ $example "" "USING: prettyprint math sequences ;"
+           "{ 0 0 1 2 3 0 0 } [ zero? ] trim-right-slice ."
+           "T{ slice { from 0 } { to 5 } { seq { 0 0 1 2 3 0 0 } } }"
+} ;
+
 HELP: trim
 { $values
      { "seq" sequence } { "quot" quotation }
@@ -1092,4 +1158,123 @@ HELP: trim
            "{ 1 2 3 }"
 } ;
 
-{ trim-left trim-right trim } related-words
+HELP: trim-slice
+{ $values
+     { "seq" sequence } { "quot" quotation }
+     { "slice" slice } }
+{ $description "Removes elements starting from the left and right sides of a sequence if they match a predicate. Once an element does not match, the test stops and the rest of the sequence is left on the stack as a slice." }
+{ $example "" "USING: prettyprint math sequences ;"
+           "{ 0 0 1 2 3 0 0 } [ zero? ] trim-slice ."
+           "T{ slice { from 2 } { to 5 } { seq { 0 0 1 2 3 0 0 } } }"
+} ;
+
+{ trim trim-slice trim-left trim-left-slice trim-right trim-right-slice } related-words
+
+HELP: sift
+{ $values
+     { "seq" sequence }
+     { "newseq" sequence } }
+ { $description "Outputs a new sequence with all instance of " { $link f  } " removed." }
+ { $examples 
+    { $example "USING: prettyprint sequences ;"
+        "{ \"a\" 3 { } f } sift ."
+        "{ \"a\" 3 { } }"
+    }
+} ;
+
+HELP: harvest
+{ $values
+     { "seq" sequence }
+     { "newseq" sequence } }
+{ $description "Outputs a new sequence with all empty sequences removed." }
+{ $examples 
+    { $example "USING: prettyprint sequences ;"
+               "{ { } { 2 3 } { 5 } { } } harvest ."
+               "{ { 2 3 } { 5 } }"
+    }
+} ;
+
+{ filter sift harvest } related-words
+
+HELP: set-first
+{ $values
+     { "first" object } { "seq" sequence } }
+{ $description "Sets the first element of a sequence." }
+{ $examples 
+    { $example "USING: prettyprint kernel sequences ;"
+        "{ 1 2 3 4  } 5 over set-first ."
+        "{ 5 2 3 4 }"
+    }
+} ;
+
+HELP: set-second
+{ $values
+     { "second" object } { "seq" sequence } }
+{ $description "Sets the second element of a sequence." }
+{ $examples 
+    { $example "USING: prettyprint kernel sequences ;"
+        "{ 1 2 3 4  } 5 over set-second ."
+        "{ 1 5 3 4 }"
+    }
+} ;
+
+HELP: set-third
+{ $values
+     { "third" object } { "seq" sequence } }
+{ $description "Sets the third element of a sequence." }
+{ $examples 
+    { $example "USING: prettyprint kernel sequences ;"
+        "{ 1 2 3 4  } 5 over set-third ."
+        "{ 1 2 5 4 }"
+    }
+} ;
+
+HELP: set-fourth
+{ $values
+     { "fourth" object } { "seq" sequence } }
+{ $description "Sets the fourth element of a sequence." }
+{ $examples 
+    { $example "USING: prettyprint kernel sequences ;"
+        "{ 1 2 3 4  } 5 over set-fourth ."
+        "{ 1 2 3 5 }"
+    }
+} ;
+
+{ set-first set-second set-third set-fourth } related-words
+
+HELP: replicate
+{ $values
+     { "seq" sequence } { "quot" quotation }
+     { "newseq" sequence } }
+{ $description "Calls the quotation for every element of the sequence in order. However, the element is not passed to the quotation -- it is dropped, and the quotation produces an element of its own that is collected into a sequence of the same class as the input sequence." }
+{ $examples 
+    { $unchecked-example "USING: prettyprint kernel sequences ;"
+        "5 [ 100 random ] replicate ."
+        "{ 52 10 45 81 30 }"
+    }
+} ;
+
+HELP: replicate-as
+{ $values
+     { "seq" sequence } { "quot" quotation } { "exemplar" sequence }
+     { "newseq" sequence } }
+{ $description "Calls the quotation for every element of the sequence in order. However, the element is not passed to the quotation -- it is dropped, and the quotation produces an element of its own that is collected into a sequence of the same class as the exemplar sequence." }
+{ $examples 
+    { $unchecked-example "USING: prettyprint kernel sequences ;"
+        "5 [ 100 random ] B{ } replicate-as ."
+        "B{ 44 8 2 33 18 }"
+    }
+} ;
+{ replicate replicate-as } related-words
+
+HELP: partition
+{ $values
+     { "seq" sequence } { "quot" quotation }
+     { "trueseq" sequence } { "falseseq" sequence } }
+     { $description "Calls a predicate quotation on each element of the input sequence.  If the test yields true, the element is added to " { $snippet "trueseq" } "; if false, it's added to " { $snippet "falseseq" } "." }
+{ $examples 
+    { $example "USING: prettyprint kernel math sequences ;"
+        "{ 1 2 3 4 5 } [ even? ] partition [ . ] bi@"
+        "{ 2 4 }\n{ 1 3 5 }"
+    }
+} ;

core/sequences/sequences.factor

@@ -74,7 +74,7 @@ INSTANCE: immutable-sequence sequence
 : set-array-nth ( elt n array -- )
     swap 2 fixnum+fast set-slot ; inline
 
-: dispatch ( n array -- ) array-nth (call) ;
+: dispatch ( n array -- ) array-nth call ;
 
 GENERIC: resize ( n seq -- newseq ) flushable
 
@@ -739,10 +739,10 @@ PRIVATE>
     [ but-last ] [ peek ] bi ;
 
 : unclip-slice ( seq -- rest first )
-    [ rest-slice ] [ first ] bi ;
+    [ rest-slice ] [ first ] bi ; inline
 
-: unclip-last-slice ( seq -- butfirst last )
+: unclip-last-slice ( seq -- butlast last )
-    [ but-last-slice ] [ peek ] bi ;
+    [ but-last-slice ] [ peek ] bi ; inline
 
 : <flat-slice> ( seq -- slice )
     dup slice? [ { } like ] when 0 over length rot <slice> ;

extra/benchmark/mandel/colors/colors.factor

@@ -16,4 +16,4 @@ IN: benchmark.mandel.colors
     ] with map ;
 
 : color-map ( -- map )
-    nb-iter max-color min <color-map> ; foldable
+    max-iterations max-color min <color-map> ; foldable

extra/benchmark/mandel/mandel.factor

@@ -1,16 +1,11 @@
+! Copyright (C) 2005, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
 USING: arrays io kernel math math.functions math.order
-math.parser sequences locals byte-arrays byte-vectors io.files
+math.parser sequences byte-arrays byte-vectors io.files
-io.encodings.binary benchmark.mandel.params
+io.encodings.binary fry namespaces benchmark.mandel.params
 benchmark.mandel.colors ;
 IN: benchmark.mandel
 
-: iter ( c z nb-iter -- x )
-    dup 0 <= [ 2nip ] [
-        over absq 4.0 >= [ 2nip ] [
-            >r sq dupd + r> 1- iter
-        ] if
-    ] if ; inline recursive
-
 : x-inc width  200000 zoom-fact * / ; inline
 : y-inc height 150000 zoom-fact * / ; inline
 
@@ -19,27 +14,27 @@ IN: benchmark.mandel
     [ y-inc * center imaginary-part y-inc height 2 / * - + >float ] bi*
     rect> ; inline
 
-:: render ( accum -- )
+: count-iterations ( z max-iterations step-quot test-quot -- #iters )
-    height [
+    '[ drop @ dup @ ] find-last-integer nip ; inline
-        width swap [
-            c C{ 0.0 0.0 } nb-iter iter dup zero?
-            [ drop B{ 0 0 0 } ] [ color-map [ length mod ] keep nth ] if
-            accum push-all
-        ] curry each
-    ] each ; inline
 
-:: ppm-header ( accum -- )
+: pixel ( c -- iterations )
-    "P6\n" accum push-all
+    [ C{ 0.0 0.0 } max-iterations ] dip
-    width number>string accum push-all
+    '[ sq , + ] [ absq 4.0 >= ] count-iterations ; inline
-    " " accum push-all
+
-    height number>string accum push-all
+: color ( iterations -- color )
-    "\n255\n" accum push-all ; inline
+    [ color-map [ length mod ] keep nth ] [ B{ 0 0 0 } ] if* ; inline
+
+: render ( -- )
+    height [ width swap '[ , c pixel color % ] each ] each ; inline
+
+: ppm-header ( -- )
+    "P6\n" % width # " " % height # "\n255\n" % ; inline
 
 : buf-size ( -- n ) width height * 3 * 100 + ; inline
 
 : mandel ( -- data )
     buf-size <byte-vector>
-    [ ppm-header ] [ render ] [ B{ } like ] tri ;
+    [ building [ ppm-header render ] with-variable ] [ B{ } like ] bi ;
 
 : mandel-main ( -- )
     mandel "mandel.ppm" temp-file binary set-file-contents ;

extra/benchmark/mandel/params/params.factor

@@ -1,8 +1,8 @@
 IN: benchmark.mandel.params
 
-: max-color 360   ; inline
+: max-color       360   ; inline
-: zoom-fact 0.8   ; inline
+: zoom-fact       0.8   ; inline
-: width     640   ; inline
+: width           640   ; inline
-: height    480   ; inline
+: height          480   ; inline
-: nb-iter   40    ; inline
+: max-iterations  40    ; inline
-: center    -0.65 ; inline
+: center         -0.65  ; inline

extra/lisp/lisp-tests.factor

@@ -5,29 +5,6 @@ quotations ;
 
 IN: lisp.test
 
-: define-lisp-builtins (  --  )    
-   init-env
-    
-    f "#f" lisp-define
-    t "#t" lisp-define
-    
-    "+" "math" "+" define-primitive
-    "-" "math" "-" define-primitive
-    "<" "math" "<" define-primitive
-    ">" "math" ">" define-primitive
-    
-    "cons" "lists" "cons" define-primitive
-    "car" "lists" "car" define-primitive
-    "cdr" "lists" "cdr" define-primitive
-    "append" "lists" "lappend" define-primitive
-    "nil" "lists" "nil" define-primitive
-    "nil?" "lists" "nil?" define-primitive
-    
-    "define" "lisp" "defun" define-primitive
-    
-    "(lambda (&rest xs) xs)" lisp-string>factor "list" lisp-define
-   ;     
-    
 [
     define-lisp-builtins
     
@@ -75,10 +52,6 @@ IN: lisp.test
         "(begin (+ 5 6) (+ 1 4))" lisp-eval
     ] unit-test
     
-    { T{ lisp-symbol f "if" } } [
-        "(defmacro if (pred tr fl) (list (quote cond) (list pred tr) (list (quote #t) fl)))" lisp-eval
-    ] unit-test
-    
     { t } [
         T{ lisp-symbol f "if" } lisp-macro?
     ] unit-test
@@ -87,8 +60,28 @@ IN: lisp.test
         "(if #t 1 2)" lisp-eval
     ] unit-test
     
-!     { 3 } [
+    { 3 } [
-!         "((lambda (x) (if x (+ 1 2) (- 3 5))) #t)" lisp-eval
+        "((lambda (x) (if x (+ 1 2) (- 3 5))) #t)" lisp-eval
-!     ] unit-test
+    ] unit-test
+    
+    { { 5 4 3 } } [
+        "((lambda (x &rest xs) (cons x xs)) 5 4 3)" lisp-eval cons>seq
+    ] unit-test
+    
+    { { 5 } } [
+        "((lambda (x &rest xs) (cons x xs)) 5)" lisp-eval cons>seq
+    ] unit-test
+    
+    { { 1 2 3 4 } } [
+        "((lambda (&rest xs) xs) 1 2 3 4)" lisp-eval cons>seq
+    ] unit-test
+    
+    { 10 } [
+        <LISP (begin (+ 1 2) (+ 9 1)) LISP>
+    ] unit-test
+    
+    { 4 } [
+        <LISP ((lambda (x y) (if x (+ 1 y) (+ 2 y))) #t 3) LISP>
+    ] unit-test
     
 ] with-interactive-vocabs

extra/lisp/lisp.factor

@@ -3,7 +3,7 @@
 USING: kernel peg sequences arrays strings combinators.lib
 namespaces combinators math locals locals.private locals.backend accessors
 vectors syntax lisp.parser assocs parser sequences.lib words
-quotations fry lists summary combinators.short-circuit continuations ;
+quotations fry lists summary combinators.short-circuit continuations multiline ;
 IN: lisp
 
 DEFER: convert-form
@@ -46,7 +46,7 @@ DEFER: define-lisp-macro
 : rest-lambda ( body vars -- quot )
     "&rest" swap [ remove ] [ index ] 2bi
     [ localize-lambda <lambda> lambda-rewrite call ] dip
-    swap '[ , cut '[ @ , seq>list ] call , call call ] ;
+    swap '[ , cut '[ @ , seq>list ] call , call call ] 1quotation ;
 
 : normal-lambda ( body vars -- quot )
     localize-lambda <lambda> lambda-rewrite '[ @ compose call call ] 1quotation ;
@@ -59,18 +59,20 @@ PRIVATE>
     cadr 1quotation ;
 
 : convert-defmacro ( cons -- quot )
-    cdr [ car ] keep [ convert-lambda ] [ car name>> ] bi define-lisp-macro 1quotation ;
+    cdr [ convert-lambda ] [ car name>> ] bi define-lisp-macro [ ] ;
 
 : macro-expand ( cons -- quot )
     uncons [ list>seq >quotation ] [ lookup-macro ] bi* call call ;
-    
+
-: (expand-macros) ( cons -- cons )    
+<PRIVATE
+: (expand-macros) ( cons -- cons )
     [ dup list? [ (expand-macros) dup car lisp-macro? [ macro-expand ] when ] when ] lmap ;
-    
+PRIVATE>
-: expand-macros ( cons -- cons )    
+
+: expand-macros ( cons -- cons )
     dup list? [ (expand-macros) dup car lisp-macro? [ macro-expand ] when ] when ;
-    
+
-: convert-begin ( cons -- quot )    
+: convert-begin ( cons -- quot )
     cdr [ convert-form ] [ ] lmap-as [ 1 tail* ] [ but-last ] bi
     [ '[ { } , with-datastack drop ] ] map prepend '[ , [ call ] each ] ;
 
@@ -86,7 +88,7 @@ PRIVATE>
 
 : convert-list-form ( cons -- quot )
     dup car
-    { 
+    {
       { [ dup lisp-symbol? ] [ form-dispatch ] }
      [ drop convert-general-form ]
     } cond ;
@@ -119,9 +121,9 @@ M: no-such-var summary drop "No such variable" ;
 
 : lisp-define ( quot name -- )
     lisp-env get set-at ;
-
+    
-: defun ( name quot -- name )
+: define-lisp-var ( lisp-symbol body --  )
-    over name>> lisp-define ;
+    swap name>> lisp-define ;
 
 : lisp-get ( name -- word )
     lisp-env get at ;
@@ -133,8 +135,7 @@ M: no-such-var summary drop "No such variable" ;
     dup lisp-symbol? [ name>> lisp-env get key? ] [ drop f ] if ;
 
 : funcall ( quot sym -- * )
-    [ 1array [ call ] with-datastack >quotation ] dip
+    [ 1array [ call ] with-datastack >quotation ] dip curry call ; inline
-    dup lisp-symbol? [ lookup-var ] when curry call ; inline
 
 : define-primitive ( name vocab word -- )
     swap lookup 1quotation '[ , compose call ] swap lisp-define ;
@@ -147,3 +148,36 @@ M: no-such-var summary drop "No such variable" ;
 
 : lisp-macro? ( car -- ? )
     dup lisp-symbol? [ name>> macro-env get key? ] [ drop f ] if ;
+
+: define-lisp-builtins ( -- )
+   init-env
+
+   f "#f" lisp-define
+   t "#t" lisp-define
+
+   "+" "math" "+" define-primitive
+   "-" "math" "-" define-primitive
+   "<" "math" "<" define-primitive
+   ">" "math" ">" define-primitive
+
+   "cons" "lists" "cons" define-primitive
+   "car" "lists" "car" define-primitive
+   "cdr" "lists" "cdr" define-primitive
+   "append" "lists" "lappend" define-primitive
+   "nil" "lists" "nil" define-primitive
+   "nil?" "lists" "nil?" define-primitive
+
+   "set" "lisp" "define-lisp-var" define-primitive
+    
+   "(lambda (&rest xs) xs)" lisp-string>factor first "list" lisp-define
+   "(defmacro setq (var val) (list (quote set) (list (quote quote) var) val))" lisp-eval
+    
+   <" (defmacro defun (name vars &rest body)
+        (list (quote setq) name (list (quote lambda) vars body))) "> lisp-eval
+    
+   "(defmacro if (pred tr fl) (list (quote cond) (list pred tr) (list (quote #t) fl)))" lisp-eval
+   ;
+
+: <LISP 
+    "LISP>" parse-multiline-string define-lisp-builtins
+    lisp-string>factor parsed \ call parsed ; parsing

extra/random/blum-blum-shub/blum-blum-shub-tests.factor

@@ -8,14 +8,14 @@ IN: blum-blum-shub.tests
 ] unit-test
 
 
-[ 887708070 ] [
+[ 70576473 ] [
     T{ blum-blum-shub f 590695557939 811977232793 } clone [
         32 random-bits
         little-endian? [ <uint> reverse *uint ] unless
     ] with-random
 ] unit-test
 
-[ 5726770047455156646 ] [
+[ 5570804936418322777 ] [
     T{ blum-blum-shub f 590695557939 811977232793 } clone [
         64 random-bits
         little-endian? [ <ulonglong> 4 group [ reverse ] map concat *ulonglong ] unless

extra/roman/roman.factor

@@ -1,26 +1,20 @@
 ! Copyright (C) 2007 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-
 USING: arrays assocs kernel math math.order math.vectors namespaces
 quotations sequences sequences.lib sequences.private strings unicode.case ;
 IN: roman
 
 <PRIVATE
-
 : roman-digits ( -- seq )
     { "m" "cm" "d" "cd" "c" "xc" "l" "xl" "x" "ix" "v" "iv" "i" } ;
 
 : roman-values ( -- seq )
     { 1000 900 500 400 100 90 50 40 10 9 5 4 1 } ;
 
-TUPLE: roman-range-error n ;
+ERROR: roman-range-error n ;
 
 : roman-range-check ( n -- )
-    dup 1 3999 between? [
+    dup 1 3999 between? [ drop ] [ roman-range-error ] if ;
-        drop
-    ] [
-        roman-range-error boa throw
-    ] if ;
 
 : roman<= ( ch1 ch2 -- ? )
     [ 1string roman-digits index ] bi@ >= ;
@@ -39,7 +33,6 @@ TUPLE: roman-range-error n ;
     ] [
         first2 swap -
     ] if ;
-
 PRIVATE>
 
 : >roman ( n -- str )
@@ -55,13 +48,11 @@ PRIVATE>
     ] map sum ;
 
 <PRIVATE
-
 : 2roman> ( str1 str2 -- m n )
     [ roman> ] bi@ ;
 
 : binary-roman-op ( str1 str2 quot -- str3 )
     >r 2roman> r> call >roman ; inline
-
 PRIVATE>
 
 : roman+ ( str1 str2 -- str3 )

extra/webapps/ip/ip.factor

@@ -0,0 +1,16 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors furnace.actions http.server.dispatchers
+html.forms io.servers.connection namespaces prettyprint ;
+IN: webapps.ip
+
+TUPLE: ip-app < dispatcher ;
+
+: <display-ip-action> ( -- action )
+    <page-action>
+        [ remote-address get host>> "ip" set-value ] >>init
+        { ip-app "ip" } >>template ;
+
+: <ip-app> ( -- dispatcher )
+    ip-app new-dispatcher
+        <display-ip-action> "" add-responder ;

extra/webapps/ip/ip.xml

@@ -0,0 +1,7 @@
+<?xml version='1.0' ?>
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+<html>
+	<body>Your IP address is: <t:label t:name="ip" />
+	</body>
+</html>
+</t:chloe>

extra/webapps/wiki/wiki-common.xml

@@ -8,48 +8,55 @@
 
 	<t:style t:include="resource:extra/webapps/wiki/wiki.css" />
 
-	<div class="navbar">
-
-		<t:a t:href="$wiki">Front Page</t:a>
-		| <t:a t:href="$wiki/articles">All Articles</t:a>
-		| <t:a t:href="$wiki/changes">Recent Changes</t:a>
-		| <t:a t:href="$wiki/random">Random Article</t:a>
-
-		<t:if t:code="furnace.auth:logged-in?">
-
-			<t:if t:code="furnace.auth.features.edit-profile:allow-edit-profile?">
-				| <t:a t:href="$realm/edit-profile" t:aside="begin">Edit Profile</t:a>
-			</t:if>
-
-			| <t:button t:action="$login-realm/logout" t:aside="begin" class="link-button link">Logout</t:button>
-
-		</t:if>
-
-	</div>
-
-	<h1><t:write-title /></h1>
-
 	<table width="100%">
 		<tr>
-			<td> <t:call-next-template /> </td>
 			<t:if t:value="sidebar">
-				<td valign="top">
+				<td valign="top" style="width: 210px;">
-					<t:bind t:name="sidebar">
+					<div class="sidebar">
-						<h2>
+						<t:bind t:name="sidebar">
-							<t:a t:href="$wiki/view" t:query="title">
+							<h2>
-								<t:label t:name="title" />
+								<t:a t:href="$wiki/view" t:query="title">
-							</t:a>
+									<t:label t:name="title" />
-						</h2>
+								</t:a>
-		
+							</h2>
-						<t:html t:name="html" />
+
-					</t:bind>
+							<t:html t:name="html" />
+						</t:bind>
+					</div>
 				</td>
 			</t:if>
+
+			<td valign="top">
+
+				<div class="navbar">
+
+					<t:a t:href="$wiki">Front Page</t:a>
+					| <t:a t:href="$wiki/articles">All Articles</t:a>
+					| <t:a t:href="$wiki/changes">Recent Changes</t:a>
+					| <t:a t:href="$wiki/random">Random Article</t:a>
+
+					<t:if t:code="furnace.auth:logged-in?">
+
+						<t:if t:code="furnace.auth.features.edit-profile:allow-edit-profile?">
+							| <t:a t:href="$realm/edit-profile" t:aside="begin">Edit Profile</t:a>
+						</t:if>
+
+						| <t:button t:action="$login-realm/logout" t:aside="begin" class="link-button link">Logout</t:button>
+
+					</t:if>
+
+				</div>
+
+				<h1><t:write-title /></h1>
+
+				<t:call-next-template />
+
+			</td>
 		</tr>
 
 		<t:if t:value="footer">
 			<tr>
-				<td>
+				<td colspan="2">
 					<t:bind t:name="footer">
 						<small>
 							<t:html t:name="html" />

extra/webapps/wiki/wiki.css

@@ -38,3 +38,10 @@
     border-width: 1px 1px 0 0;
 }
 
+.sidebar {
+    padding: 4px;
+    margin: 4px;
+    border: 1px dashed grey;
+    background: #f5f1fd;
+    width: 200px;
+}

extra/websites/concatenative/concatenative.factor

@@ -84,6 +84,8 @@ SYMBOL: dh-file
     common-configuration ;
 
 : init-production ( -- )
+    f dh-file set-global
+    f key-password set-global
     "/home/slava/cert/host.pem" key-file set-global
     common-configuration ;
 

extra/websites/concatenative/page.css

@@ -32,7 +32,7 @@ a:hover, .link:hover {
 }
 
 .navbar {
-	background-color: #eee;
+	background-color: #eeeee0;
 	padding: 5px;
 	border: 1px solid #ccc;
 }

unfinished/regexp2/regexp2.factor

@@ -29,7 +29,7 @@ IN: regexp2
 
 : matches? ( string regexp -- ? )
     dupd match
-    [ [ length ] [ range-length 1- ] bi* = ] [ drop f ] if* ;
+    [ [ length ] [ length>> 1- ] bi* = ] [ drop f ] if* ;
 
 : match-head ( string regexp -- end ) match length>> 1- ;
 

unfinished/regexp2/traversal/traversal.factor

@@ -18,7 +18,7 @@ TUPLE: dfa-traverser
     matches ;
 
 : <dfa-traverser> ( text regexp -- match )
-    [ dfa-table>> ] [ traversal-flags>> ] bi
+    [ dfa-table>> ] [ dfa-traversal-flags>> ] bi
     dfa-traverser new
         swap >>traversal-flags
         swap [ start-state>> >>current-state ] keep

unmaintained/ogg/player/player.factor

@@ -15,7 +15,7 @@ USING: kernel alien ogg ogg.vorbis ogg.theora io byte-arrays
        namespaces threads shuffle opengl arrays ui.gadgets.worlds
        combinators math.parser ui.gadgets ui.render opengl.gl ui
        continuations io.files hints combinators.lib sequences.lib
-       io.encodings.binary debugger math.order ;
+       io.encodings.binary debugger math.order accessors ;
 
 IN: ogg.player
 
@@ -30,62 +30,63 @@ TUPLE: player stream temp-state
        gadget ;
 
 : init-vorbis ( player -- )
-    dup player-oy ogg_sync_init drop
+    dup oy>> ogg_sync_init drop
-    dup player-vi vorbis_info_init
+    dup vi>> vorbis_info_init
-    player-vc vorbis_comment_init ;
+    vc>> vorbis_comment_init ;
 
 : init-theora ( player -- )
-    dup player-ti theora_info_init
+    dup ti>> theora_info_init
-    player-tc theora_comment_init ;
+    tc>> theora_comment_init ;
 
 : init-sound ( player -- )
     init-openal check-error
-    1 gen-buffers check-error over set-player-buffers
+    1 gen-buffers check-error >>buffers
-    2 "uint" <c-array> over set-player-buffer-indexes
+    2 "uint" <c-array> >>buffer-indexes
-    1 gen-sources check-error first swap set-player-source ;
+    1 gen-sources check-error first >>source drop ;
 
 : <player> ( stream -- player )
-    { set-player-stream } player construct
+    player new
-    0 over set-player-vorbis
+        swap >>stream
-    0 over set-player-theora
+        0 >>vorbis
-    0 over set-player-video-time
+        0 >>theora
-    0 over set-player-video-granulepos
+        0 >>video-time
-    f over set-player-video-ready?
+        0 >>video-granulepos
-    f over set-player-audio-full?
+        f >>video-ready?
-    0 over set-player-audio-index
+        f >>audio-full?
-    0 over set-player-start-time
+        0 >>audio-index
-    audio-buffer-size "short" <c-array> over set-player-audio-buffer
+        0 >>start-time
-    0 over set-player-audio-granulepos
+        audio-buffer-size "short" <c-array> >>audio-buffer
-    f over set-player-playing?
+        0 >>audio-granulepos
-    "ogg_packet" malloc-object over set-player-op
+        f >>playing?
-    "ogg_sync_state" malloc-object over set-player-oy
+        "ogg_packet" malloc-object >>op
-    "ogg_page" malloc-object over set-player-og
+        "ogg_sync_state" malloc-object >>oy
-    "ogg_stream_state" malloc-object over set-player-vo
+        "ogg_page" malloc-object >>og
-    "vorbis_info" malloc-object over set-player-vi
+        "ogg_stream_state" malloc-object >>vo
-    "vorbis_dsp_state" malloc-object over set-player-vd
+        "vorbis_info" malloc-object >>vi
-    "vorbis_block" malloc-object over set-player-vb
+        "vorbis_dsp_state" malloc-object >>vd
-    "vorbis_comment" malloc-object over set-player-vc
+        "vorbis_block" malloc-object >>vb
-    "ogg_stream_state" malloc-object over set-player-to
+        "vorbis_comment" malloc-object >>vc
-    "theora_info" malloc-object over set-player-ti
+        "ogg_stream_state" malloc-object >>to
-    "theora_comment" malloc-object over set-player-tc
+        "theora_info" malloc-object >>ti
-    "theora_state" malloc-object over set-player-td
+        "theora_comment" malloc-object >>tc
-    "yuv_buffer" <c-object> over set-player-yuv
+        "theora_state" malloc-object >>td
-    "ogg_stream_state" <c-object> over set-player-temp-state
+        "yuv_buffer" <c-object> >>yuv
-    dup init-sound
+        "ogg_stream_state" <c-object> >>temp-state
-    dup init-vorbis
+        dup init-sound
-    dup init-theora ;
+        dup init-vorbis
+        dup init-theora ;
 
 : num-channels ( player -- channels )
-    player-vi vorbis_info-channels ;
+    vi>> vorbis_info-channels ;
 
 : al-channel-format ( player -- format )
-    num-channels 1 = [ AL_FORMAT_MONO16 ] [ AL_FORMAT_STEREO16 ] if ;
+    num-channels 1 = AL_FORMAT_MONO16 AL_FORMAT_STEREO16 ? ;
 
 : get-time ( player -- time )
-    dup player-start-time zero? [
+    dup start-time>> zero? [
-        millis over set-player-start-time
+        millis >>start-time
     ] when
-    player-start-time millis swap - 1000.0 /f ;
+    start-time>> millis swap - 1000.0 /f ;
 
 : clamp ( n -- n )
     255 min 0 max ; inline
@@ -138,7 +139,7 @@ TUPLE: player stream temp-state
     pick yuv_buffer-y_width >fixnum
     [ yuv>rgb-pixel ] each-with4 ; inline
 
-: yuv>rgb ( rgb yuv  -- )
+: yuv>rgb ( rgb yuv -- )
     0 -rot
     dup yuv_buffer-y_height >fixnum
     [ yuv>rgb-row ] each-with2
@@ -147,52 +148,55 @@ TUPLE: player stream temp-state
 HINTS: yuv>rgb byte-array byte-array ;
 
 : process-video ( player -- player )
-    dup player-gadget [
+    dup gadget>> [
-        dup { player-td player-yuv } get-slots theora_decode_YUVout drop
+        {
-        dup player-rgb over player-yuv yuv>rgb
+            [ [ td>> ] [ yuv>> ] bi theora_decode_YUVout drop ]
-        dup player-gadget relayout-1 yield
+            [ [ rgb>> ] [ yuv>> ] bi yuv>rgb ]
+            [ gadget>> relayout-1 yield ]
+            [ ]
+        } cleave
     ] when ;
 
 : num-audio-buffers-processed ( player -- player n )
-    dup player-source AL_BUFFERS_PROCESSED 0 <uint>
+    dup source>> AL_BUFFERS_PROCESSED 0 <uint>
     [ alGetSourcei check-error ] keep *uint ;
 
 : append-new-audio-buffer ( player -- player )
-    dup player-buffers 1 gen-buffers append over set-player-buffers
+    dup buffers>> 1 gen-buffers append >>buffers
-    [ [ player-buffers second ] keep al-channel-format ] keep
+    [ [ buffers>> second ] keep al-channel-format ] keep
-    [ player-audio-buffer dup length  ] keep
+    [ audio-buffer>> dup length  ] keep
-    [ player-vi vorbis_info-rate alBufferData check-error ]  keep
+    [ vi>> vorbis_info-rate alBufferData check-error ]  keep
-    [ player-source 1 ] keep
+    [ source>> 1 ] keep
-    [ player-buffers second <uint> alSourceQueueBuffers check-error ] keep ;
+    [ buffers>> second <uint> alSourceQueueBuffers check-error ] keep ;
 
 : fill-processed-audio-buffer ( player n -- player )
     #! n is the number of audio buffers processed
-    over >r >r dup player-source r> pick player-buffer-indexes
+    over >r >r dup source>> r> pick buffer-indexes>>
     [ alSourceUnqueueBuffers check-error ] keep
     *uint dup r> swap >r al-channel-format rot
-    [ player-audio-buffer dup length  ] keep
+    [ audio-buffer>> dup length  ] keep
-    [ player-vi vorbis_info-rate alBufferData check-error ]  keep
+    [ vi>> vorbis_info-rate alBufferData check-error ]  keep
-    [ player-source 1 ] keep
+    [ source>> 1 ] keep
     r> <uint> swap >r alSourceQueueBuffers check-error r> ;
 
 : append-audio ( player -- player bool )
     num-audio-buffers-processed {
-        { [ over player-buffers length 1 = over zero? and ] [ drop append-new-audio-buffer t ] }
+        { [ over buffers>> length 1 = over zero? and ] [ drop append-new-audio-buffer t ] }
-        { [ over player-buffers length 2 = over zero? and ] [ yield drop f ] }
+        { [ over buffers>> length 2 = over zero? and ] [ yield drop f ] }
         [ fill-processed-audio-buffer t ]
     } cond ;
 
 : start-audio ( player -- player bool )
-    [ [ player-buffers first ] keep al-channel-format ] keep
+    [ [ buffers>> first ] keep al-channel-format ] keep
-    [ player-audio-buffer dup length ] keep
+    [ audio-buffer>> dup length ] keep
-    [ player-vi vorbis_info-rate alBufferData check-error ]  keep
+    [ vi>> vorbis_info-rate alBufferData check-error ]  keep
-    [ player-source 1 ] keep
+    [ source>> 1 ] keep
-    [ player-buffers first <uint> alSourceQueueBuffers check-error ] keep
+    [ buffers>> first <uint> alSourceQueueBuffers check-error ] keep
-    [ player-source alSourcePlay check-error ] keep
+    [ source>> alSourcePlay check-error ] keep
-    t over set-player-playing? t ;
+    t >>playing? t ;
 
 : process-audio ( player -- player bool )
-    dup player-playing? [ append-audio ] [ start-audio ] if ;
+    dup playing?>> [ append-audio ] [ start-audio ] if ;
 
 : read-bytes-into ( dest size stream -- len )
     #! Read the given number of bytes from a stream
@@ -206,13 +210,13 @@ HINTS: yuv>rgb byte-array byte-array ;
     4096 ; inline
 
 : sync-buffer ( player -- buffer size player )
-    [ player-oy buffer-size ogg_sync_buffer buffer-size ] keep ;
+    [ oy>> buffer-size ogg_sync_buffer buffer-size ] keep ;
 
 : stream-into-buffer ( buffer size player -- len player )
-    [ player-stream read-bytes-into ] keep ;
+    [ stream>> read-bytes-into ] keep ;
 
 : confirm-buffer ( len player -- player eof? )
-  [ player-oy swap ogg_sync_wrote check-not-negative ] 2keep swap zero? ;
+  [ oy>> swap ogg_sync_wrote check-not-negative ] 2keep swap zero? ;
 
 : buffer-data ( player -- player eof? )
     #! Take some compressed bitstream data and sync it for
@@ -221,59 +225,60 @@ HINTS: yuv>rgb byte-array byte-array ;
 
 : queue-page ( player -- player )
     #! Push a page into the stream for packetization
-    [ { player-vo player-og } get-slots ogg_stream_pagein drop ] keep
+    [ [ vo>> ] [ og>> ] bi ogg_stream_pagein drop ]
-    [ { player-to player-og } get-slots ogg_stream_pagein drop ] keep ;
+    [ [ to>> ] [ og>> ] bi ogg_stream_pagein drop ]
+    [ ] tri ;
 
 : retrieve-page ( player -- player bool )
     #! Sync the streams and get a page. Return true if a page was
     #! successfully retrieved.
-    dup { player-oy player-og } get-slots ogg_sync_pageout 0 > ;
+    dup [ oy>> ] [ og>> ] bi ogg_sync_pageout 0 > ;
 
 : standard-initial-header? ( player -- player bool )
-    dup player-og ogg_page_bos zero? not ;
+    dup og>> ogg_page_bos zero? not ;
 
 : ogg-stream-init ( player -- state player )
     #! Init the encode/decode logical stream state
-    [ player-temp-state ] keep
+    [ temp-state>> ] keep
-    [ player-og ogg_page_serialno ogg_stream_init check-not-negative ] 2keep ;
+    [ og>> ogg_page_serialno ogg_stream_init check-not-negative ] 2keep ;
 
 : ogg-stream-pagein ( state player -- state player )
     #! Add the incoming page to the stream state
-    [ player-og ogg_stream_pagein drop ] 2keep ;
+    [ og>> ogg_stream_pagein drop ] 2keep ;
 
 : ogg-stream-packetout ( state player -- state player )
-    [ player-op ogg_stream_packetout drop ] 2keep ;
+    [ op>> ogg_stream_packetout drop ] 2keep ;
 
 : decode-packet ( player -- state player )
     ogg-stream-init ogg-stream-pagein ogg-stream-packetout ;
 
 : theora-header? ( player -- player bool )
     #! Is the current page a theora header?
-    dup { player-ti player-tc player-op } get-slots theora_decode_header 0 >= ;
+    dup [ ti>> ] [ tc>> ] [ op>> ] tri theora_decode_header 0 >= ;
 
 : is-theora-packet? ( player -- player bool )
-    dup player-theora zero? [ theora-header? ] [ f ] if ;
+    dup theora>> zero? [ theora-header? ] [ f ] if ;
 
 : copy-to-theora-state ( state player -- player )
     #! Copy the state to the theora state structure in the player
-    [ player-to swap dup length memcpy ] keep ;
+    [ to>> swap dup length memcpy ] keep ;
 
 : handle-initial-theora-header ( state player -- player )
-    copy-to-theora-state 1 over set-player-theora ;
+    copy-to-theora-state 1 >>theora ;
 
 : vorbis-header? ( player -- player bool )
     #! Is the current page a vorbis header?
-    dup { player-vi player-vc player-op } get-slots vorbis_synthesis_headerin 0 >= ;
+    dup [ vi>> ] [ vc>> ] [ op>> ] tri vorbis_synthesis_headerin 0 >= ;
 
 : is-vorbis-packet? ( player -- player bool )
-    dup player-vorbis zero? [ vorbis-header? ] [ f ] if ;
+    dup vorbis>> zero? [ vorbis-header? ] [ f ] if ;
 
 : copy-to-vorbis-state ( state player -- player )
     #! Copy the state to the vorbis state structure in the player
-    [ player-vo swap dup length memcpy ] keep ;
+    [ vo>> swap dup length memcpy ] keep ;
 
 : handle-initial-vorbis-header ( state player -- player )
-    copy-to-vorbis-state 1 over set-player-vorbis ;
+    copy-to-vorbis-state 1 >>vorbis ;
 
 : handle-initial-unknown-header ( state player -- player )
     swap ogg_stream_clear drop ;
@@ -308,43 +313,43 @@ HINTS: yuv>rgb byte-array byte-array ;
     #! Return true if we need to decode vorbis due to there being
     #! vorbis headers read from the stream but we don't have them all
     #! yet.
-    dup player-vorbis 1 2 between? not ;
+    dup vorbis>> 1 2 between? not ;
 
 : have-required-theora-headers? ( player -- player bool )
     #! Return true if we need to decode theora due to there being
     #! theora headers read from the stream but we don't have them all
     #! yet.
-    dup player-theora 1 2 between? not ;
+    dup theora>> 1 2 between? not ;
 
 : get-remaining-vorbis-header-packet ( player -- player bool )
-    dup { player-vo player-op } get-slots ogg_stream_packetout {
+    dup [ vo>> ] [ op>> ] bi ogg_stream_packetout {
         { [ dup 0 <   ] [ "Error parsing vorbis stream; corrupt stream?" throw ] }
         { [ dup zero? ] [ drop f ] }
         { [ t     ] [ drop t ] }
     } cond ;
 
 : get-remaining-theora-header-packet ( player -- player bool )
-    dup { player-to player-op } get-slots ogg_stream_packetout {
+    dup [ to>> ] [ op>> ] bi ogg_stream_packetout {
         { [ dup 0 <   ] [ "Error parsing theora stream; corrupt stream?" throw ] }
         { [ dup zero? ] [ drop f ] }
         { [ t     ] [ drop t ] }
     } cond ;
 
 : decode-remaining-vorbis-header-packet ( player -- player )
-    dup { player-vi player-vc player-op } get-slots vorbis_synthesis_headerin zero? [
+    dup [ vi>> ] [ vc>> ] [ op>> ] tri vorbis_synthesis_headerin zero? [
         "Error parsing vorbis stream; corrupt stream?" throw
     ] unless ;
 
 : decode-remaining-theora-header-packet ( player -- player )
-    dup { player-ti player-tc player-op } get-slots theora_decode_header zero? [
+    dup [ ti>> ] [ tc>> ] [ op>> ] tri theora_decode_header zero? [
         "Error parsing theora stream; corrupt stream?" throw
     ] unless ;
 
 : increment-vorbis-header-count ( player -- player )
-    dup player-vorbis 1+ over set-player-vorbis ;
+    [ 1+ ] change-vorbis ;
 
 : increment-theora-header-count ( player -- player )
-    dup player-theora 1+ over set-player-theora ;
+    [ 1+ ] change-theora ;
 
 : parse-remaining-vorbis-headers ( player -- player )
     have-required-vorbis-headers? not [
@@ -376,51 +381,51 @@ HINTS: yuv>rgb byte-array byte-array ;
     ] when ;
 
 : tear-down-vorbis ( player -- player )
-    dup player-vi vorbis_info_clear
+    dup vi>> vorbis_info_clear
-    dup player-vc vorbis_comment_clear ;
+    dup vc>> vorbis_comment_clear ;
 
 : tear-down-theora ( player -- player )
-    dup player-ti theora_info_clear
+    dup ti>> theora_info_clear
-    dup player-tc theora_comment_clear ;
+    dup tc>> theora_comment_clear ;
 
 : init-vorbis-codec ( player -- player )
-    dup { player-vd player-vi } get-slots vorbis_synthesis_init drop
+    dup [ vd>> ] [ vi>> ] bi vorbis_synthesis_init drop
-    dup { player-vd player-vb } get-slots vorbis_block_init drop ;
+    dup [ vd>> ] [ vb>> ] bi vorbis_block_init drop ;
 
 : init-theora-codec ( player -- player )
-    dup { player-td player-ti } get-slots theora_decode_init drop
+    dup [ td>> ] [ ti>> ] bi theora_decode_init drop
-    dup player-ti theora_info-frame_width over player-ti theora_info-frame_height
+    dup ti>> theora_info-frame_width over ti>> theora_info-frame_height
-    4 * * <byte-array> over set-player-rgb ;
+    4 * * <byte-array> >>rgb ;
 
 
 : display-vorbis-details ( player -- player )
     [
         "Ogg logical stream " %
-        dup player-vo ogg_stream_state-serialno #
+        dup vo>> ogg_stream_state-serialno #
         " is Vorbis " %
-        dup player-vi vorbis_info-channels #
+        dup vi>> vorbis_info-channels #
         " channel " %
-        dup player-vi vorbis_info-rate #
+        dup vi>> vorbis_info-rate #
         " Hz audio." %
     ] "" make print ;
 
 : display-theora-details ( player -- player )
     [
         "Ogg logical stream " %
-        dup player-to ogg_stream_state-serialno #
+        dup to>> ogg_stream_state-serialno #
         " is Theora " %
-        dup player-ti theora_info-width #
+        dup ti>> theora_info-width #
         "x" %
-        dup player-ti theora_info-height #
+        dup ti>> theora_info-height #
         " " %
-        dup player-ti theora_info-fps_numerator
+        dup ti>> theora_info-fps_numerator
-        over player-ti theora_info-fps_denominator /f #
+        over ti>> theora_info-fps_denominator /f #
         " fps video" %
     ] "" make print ;
 
 : initialize-decoder ( player -- player )
-    dup player-vorbis zero? [ tear-down-vorbis ] [ init-vorbis-codec display-vorbis-details ] if
+    dup vorbis>> zero? [ tear-down-vorbis ] [ init-vorbis-codec display-vorbis-details ] if
-    dup player-theora zero? [ tear-down-theora ] [ init-theora-codec display-theora-details ] if ;
+    dup theora>> zero? [ tear-down-theora ] [ init-theora-codec display-theora-details ] if ;
 
 : sync-pages ( player -- player )
     retrieve-page [
@@ -428,13 +433,13 @@ HINTS: yuv>rgb byte-array byte-array ;
     ] when ;
 
 : audio-buffer-not-ready? ( player -- player bool )
-    dup player-vorbis zero? not over player-audio-full? not and ;
+    dup vorbis>> zero? not over audio-full?>> not and ;
 
 : pending-decoded-audio? ( player -- player pcm len bool )
-    f <void*> 2dup >r player-vd r> vorbis_synthesis_pcmout dup 0 > ;
+    f <void*> 2dup >r vd>> r> vorbis_synthesis_pcmout dup 0 > ;
 
 : buffer-space-available ( player -- available )
-    audio-buffer-size swap player-audio-index - ;
+    audio-buffer-size swap audio-index>> - ;
 
 : samples-to-read ( player available len -- numread )
     >r swap num-channels / r> min ;
@@ -442,8 +447,8 @@ HINTS: yuv>rgb byte-array byte-array ;
 : each-with3 ( obj obj obj seq quot -- ) 3 each-withn ; inline
 
 : add-to-buffer ( player val -- )
-    over player-audio-index pick player-audio-buffer set-short-nth
+    over audio-index>> pick audio-buffer>> set-short-nth
-    dup player-audio-index 1+ swap set-player-audio-index ;
+    [ 1+ ] change-audio-index drop ;
 
 : get-audio-value ( pcm sample channel -- value )
     rot *void* void*-nth float-nth ;
@@ -462,24 +467,24 @@ HINTS: yuv>rgb byte-array byte-array ;
     pick [ buffer-space-available swap ] keep -rot samples-to-read
     pick over >r >r process-samples r> r> swap
     ! numread player
-    dup player-audio-index audio-buffer-size = [
+    dup audio-index>> audio-buffer-size = [
-        t over set-player-audio-full?
+        t >>audio-full?
     ] when
-    dup player-vd vorbis_dsp_state-granulepos dup 0 >= [
+    dup vd>> vorbis_dsp_state-granulepos dup 0 >= [
         ! numtoread player granulepos
         #! This is wrong: fix
-        pick - over set-player-audio-granulepos
+        pick - >>audio-granulepos
     ] [
         ! numtoread player granulepos
-        pick + over set-player-audio-granulepos
+        pick + >>audio-granulepos
     ] if
-    [ player-vd swap vorbis_synthesis_read drop ] keep ;
+    [ vd>> swap vorbis_synthesis_read drop ] keep ;
 
 : no-pending-audio ( player -- player bool )
     #! No pending audio. Is there a pending packet to decode.
-    dup { player-vo player-op } get-slots ogg_stream_packetout 0 > [
+    dup [ vo>> ] [ op>> ] bi ogg_stream_packetout 0 > [
-        dup { player-vb player-op } get-slots vorbis_synthesis 0 = [
+        dup [ vb>> ] [ op>> ] bi vorbis_synthesis 0 = [
-            dup { player-vd player-vb } get-slots vorbis_synthesis_blockin drop
+            dup [ vd>> ] [ vb>> ] bi vorbis_synthesis_blockin drop
         ] when
         t
     ] [
@@ -498,16 +503,16 @@ HINTS: yuv>rgb byte-array byte-array ;
     ] when ;
 
 : video-buffer-not-ready? ( player -- player bool )
-    dup player-theora zero? not over player-video-ready? not and ;
+    dup theora>> zero? not over video-ready?>> not and ;
 
 : decode-video ( player -- player )
     video-buffer-not-ready? [
-        dup { player-to player-op } get-slots ogg_stream_packetout 0 > [
+        dup [ to>> ] [ op>> ] bi ogg_stream_packetout 0 > [
-            dup { player-td player-op } get-slots theora_decode_packetin drop
+            dup [ td>> ] [ op>> ] bi theora_decode_packetin drop
-            dup player-td theora_state-granulepos over set-player-video-granulepos
+            dup td>> theora_state-granulepos >>video-granulepos
-            dup { player-td player-video-granulepos } get-slots theora_granule_time
+            dup [ td>> ] [ video-granulepos>> ] bi theora_granule_time
-            over set-player-video-time
+            >>video-time
-            t over set-player-video-ready?
+            t >>video-ready?
             decode-video
         ] when
     ] when ;
@@ -516,16 +521,16 @@ HINTS: yuv>rgb byte-array byte-array ;
     get-more-header-data sync-pages
     decode-audio
     decode-video
-    dup player-audio-full? [
+    dup audio-full?>> [
         process-audio [
-            f over set-player-audio-full?
+            f >>audio-full?
-            0 over set-player-audio-index
+            0 >>audio-index
         ] when
     ] when
-    dup player-video-ready? [
+    dup video-ready?>> [
-        dup player-video-time over get-time - dup 0.0 < [
+        dup video-time>> over get-time - dup 0.0 < [
             -0.1 > [ process-video ] when
-            f over set-player-video-ready?
+            f >>video-ready?
         ] [
             drop
         ] if
@@ -533,36 +538,39 @@ HINTS: yuv>rgb byte-array byte-array ;
     decode ;
 
 : free-malloced-objects ( player -- player )
-    [ player-op free ] keep
+    {
-    [ player-oy free ] keep
+        [ op>> free ]
-    [ player-og free ] keep
+        [ oy>> free ]
-    [ player-vo free ] keep
+        [ og>> free ]
-    [ player-vi free ] keep
+        [ vo>> free ]
-    [ player-vd free ] keep
+        [ vi>> free ]
-    [ player-vb free ] keep
+        [ vd>> free ]
-    [ player-vc free ] keep
+        [ vb>> free ]
-    [ player-to free ] keep
+        [ vc>> free ]
-    [ player-ti free ] keep
+        [ to>> free ]
-    [ player-tc free ] keep
+        [ ti>> free ]
-    [ player-td free ] keep ;
+        [ tc>> free ]
+        [ td>> free ]
+        [ ]
+    } cleave ;
 
 
 : unqueue-openal-buffers ( player -- player )
     [
 
-        num-audio-buffers-processed over player-source rot player-buffer-indexes swapd
+        num-audio-buffers-processed over source>> rot buffer-indexes>> swapd
         alSourceUnqueueBuffers check-error
     ] keep ;
 
 : delete-openal-buffers ( player -- player )
     [
-        player-buffers [
+        buffers>> [
             1 swap <uint> alDeleteBuffers check-error
         ] each
     ] keep ;
 
 : delete-openal-source ( player -- player )
-    [ player-source 1 swap <uint> alDeleteSources check-error ] keep ;
+    [ source>> 1 swap <uint> alDeleteSources check-error ] keep ;
 
 : cleanup ( player -- player )
     free-malloced-objects
@@ -572,28 +580,28 @@ HINTS: yuv>rgb byte-array byte-array ;
 
 : wait-for-sound ( player -- player )
     #! Waits for the openal to finish playing remaining sounds
-    dup player-source AL_SOURCE_STATE 0 <int> [ alGetSourcei check-error ] keep
+    dup source>> AL_SOURCE_STATE 0 <int> [ alGetSourcei check-error ] keep
     *int AL_PLAYING = [
         100 sleep
         wait-for-sound
     ] when ;
 
-TUPLE: theora-gadget player ;
+TUPLE: theora-gadget < gadget player ;
 
 : <theora-gadget> ( player -- gadget )
-  theora-gadget construct-gadget
+    theora-gadget new-gadget
-  [ set-theora-gadget-player ] keep ;
+        swap >>player ;
 
 M: theora-gadget pref-dim*
-    theora-gadget-player
+    player>>
-    player-ti dup theora_info-width swap theora_info-height 2array ;
+    ti>> dup theora_info-width swap theora_info-height 2array ;
 
 M: theora-gadget draw-gadget* ( gadget -- )
     0 0 glRasterPos2i
     1.0 -1.0 glPixelZoom
     GL_UNPACK_ALIGNMENT 1 glPixelStorei
     [ pref-dim* first2 GL_RGB GL_UNSIGNED_BYTE ] keep
-    theora-gadget-player player-rgb glDrawPixels ;
+    player>> rgb>> glDrawPixels ;
 
 : initialize-gui ( gadget -- )
     "Theora Player" open-window ;
@@ -602,7 +610,7 @@ M: theora-gadget draw-gadget* ( gadget -- )
     parse-initial-headers
     parse-remaining-headers
     initialize-decoder
-    dup player-gadget [ initialize-gui ] when*
+    dup gadget>> [ initialize-gui ] when*
     [ decode ] try
     wait-for-sound
     cleanup
@@ -616,9 +624,8 @@ M: theora-gadget draw-gadget* ( gadget -- )
 
 : play-theora-stream ( stream -- )
     <player>
-    dup <theora-gadget> over set-player-gadget
+    dup <theora-gadget> >>gadget
     play-ogg ;
 
 : play-theora-file ( filename -- )
     binary <file-reader> play-theora-stream ;
-

vm/ffi_test.c

@@ -274,4 +274,9 @@ unsigned long long ffi_test_38(unsigned long long x, unsigned long long y)
 	return x * y;
 }
 
-
+int ffi_test_39(long a, long b, struct test_struct_13 s)
+{
+	printf("ffi_test_39(%ld,%ld,%f,%f,%f,%f,%f,%f)\n",a,b,s.x1,s.x2,s.x3,s.x4,s.x5,s.x6);
+	if(a != b) abort();
+	return s.x1 + s.x2 + s.x3 + s.x4 + s.x5 + s.x6;
+}

vm/ffi_test.h

@@ -67,3 +67,7 @@ DLLEXPORT void ffi_test_36_point_5(void);
 DLLEXPORT int ffi_test_37(int (*f)(int, int, int));
 
 DLLEXPORT unsigned long long ffi_test_38(unsigned long long x, unsigned long long y);
+
+struct test_struct_13 { float x1, x2, x3, x4, x5, x6; };
+
+DLLEXPORT int ffi_test_39(long a, long b, struct test_struct_13 s);