diff --git a/Factor.app/Contents/Frameworks/libfreetype.6.dylib b/Factor.app/Contents/Frameworks/libfreetype.6.dylib old mode 100644 new mode 100755 index 5147d44386..381e74bf18 Binary files a/Factor.app/Contents/Frameworks/libfreetype.6.dylib and b/Factor.app/Contents/Frameworks/libfreetype.6.dylib differ diff --git a/basis/base64/base64.factor b/basis/base64/base64.factor index 747cfa1128..7097de6c6e 100644 --- a/basis/base64/base64.factor +++ b/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 r [ length ] keep r> find-last drop dup [ - 1- ] [ 2drop 0 ] if ; inline +: count-end ( seq quot -- n ) + 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 [ -6 * shift HEX: 3f bitand ch>base64 ] with B{ } map-as ; + be> 4 [ + -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 [ decode4 ] map concat ] - [ [ CHAR: = = not ] count-end ] + [ [ CHAR: = = ] count-end ] bi head* ; diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index 9c99ed5cdb..edfd82dae2 100755 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -280,7 +280,7 @@ M: f ' [ [ { - [ hashcode , ] + [ hashcode , ] [ name>> , ] [ vocabulary>> , ] [ def>> , ] diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor index ea7280b5a6..7be649416c 100755 --- a/basis/cocoa/messages/messages.factor +++ b/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 : ( receiver -- super ) "objc-super" [ - >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 0 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{ - { "NSPoint" "{_NSPoint=ff}" } - { "NSRect" "{_NSRect=ffff}" } - { "NSSize" "{_NSSize=ff}" } - { "NSRange" "{_NSRange=II}" } -} assoc-union alien>objc-types set-global +"ptrdiff_t" heap-size { + { 4 [ H{ + { "NSPoint" "{_NSPoint=ff}" } + { "NSRect" "{_NSRect=ffff}" } + { "NSSize" "{_NSSize=ff}" } + { "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! - objc-method-types parse-objc-type ; + method_copyReturnType + [ 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 ) - "objc-method-list" heap-size swap ; - -: (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) ( methods count -- methods ) + over [ void*-nth register-objc-method ] curry each ; : register-objc-methods ( class -- ) - f (register-objc-methods) ; + 0 [ 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 ; diff --git a/basis/cocoa/runtime/runtime.factor b/basis/cocoa/runtime/runtime.factor index 7bfc31bc44..3451ce5e6e 100644 --- a/basis/cocoa/runtime/runtime.factor +++ b/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 - { "SEL" "name" } - { "char*" "types" } - { "void*" "imp" } ; +FUNCTION: Method class_getInstanceMethod ( Class class, SEL selector ) ; -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 - { "void*" "obsolete" } - { "int" "count" } ; +FUNCTION: Class class_getSuperclass ( Class cls ) ; -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 - { "void*" "next" } - { "int" "count" } - { "objc-class*" "class" } ; +FUNCTION: void* method_copyArgumentType ( Method method, uint index ) ; + +FUNCTION: void* method_getTypeEncoding ( Method method ) ; + +FUNCTION: SEL method_getName ( Method method ) ; + +FUNCTION: void* method_setImplementation ( Method method, void* imp ) ; + +FUNCTION: Class object_getClass ( id object ) ; diff --git a/basis/cocoa/subclassing/subclassing.factor b/basis/cocoa/subclassing/subclassing.factor index 6b3e1d330e..1ee39c35d5 100755 --- a/basis/cocoa/subclassing/subclassing.factor +++ b/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 -- ) - >r first3 r> - [ >r execute r> set-objc-method-imp ] keep - [ >r ascii malloc-string r> set-objc-method-types ] keep - >r sel_registerName r> set-objc-method-name ; +: init-method ( method -- sel imp types ) + first3 swap + [ sel_registerName ] [ execute ] [ ascii string>alien ] + tri* ; -: ( n -- alien ) - "objc-method-list" heap-size - "objc-method" heap-size pick * + 1 calloc - [ set-objc-method-list-count ] keep ; +: add-methods ( methods class -- ) + swap + [ init-method class_addMethod drop ] with each ; -: ( methods -- alien ) - dup length dup -rot - [ pick method-list@ objc-method-nth init-method ] 2each ; - -: define-objc-methods ( class methods -- ) - class_addMethods ; - -: ( name info -- class ) - "objc-class" malloc-object - [ set-objc-class-info ] keep - [ >r ascii malloc-string r> set-objc-class-name ] keep ; - -: ( 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 ; - -: ( superclass name -- class ) - CLS_META - [ >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 - swap set-objc-class-protocols - ] } - } cond ; - -: ( protocols metaclass superclass name -- class ) - CLS_CLASS - [ set-objc-class-super-class ] keep - [ set-objc-class-isa ] keep - [ set-protocols ] keep - dup copy-instance-size ; +: add-protocols ( protocols class -- ) + swap [ objc-protocol class_addProtocol drop ] with each ; : (define-objc-class) ( protocols superclass name imeth -- ) - >r - >r objc-class r> - [ ] 2keep dup objc_addClass - r> class_addMethods ; + -rot + [ objc-class ] dip 0 objc_allocateClassPair + [ add-methods ] [ add-protocols ] [ objc_registerClassPair ] + 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 ; diff --git a/basis/cocoa/types/types.factor b/basis/cocoa/types/types.factor index dbaf311da2..6e65bc1a72 100644 --- a/basis/cocoa/types/types.factor +++ b/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" } - { "float" "y" } - { "float" "w" } - { "float" "h" } ; + { "CGFloat" "x" } + { "CGFloat" "y" } + { "CGFloat" "w" } + { "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" } - { "float" "y" } ; + { "CGFloat" "x" } + { "CGFloat" "y" } ; TYPEDEF: NSPoint _NSPoint TYPEDEF: NSPoint CGPoint @@ -35,8 +42,8 @@ TYPEDEF: NSPoint CGPoint [ set-NSPoint-x ] keep ; C-STRUCT: NSSize - { "float" "w" } - { "float" "h" } ; + { "CGFloat" "w" } + { "CGFloat" "h" } ; TYPEDEF: NSSize _NSSize TYPEDEF: NSPoint CGPoint @@ -47,8 +54,8 @@ TYPEDEF: NSPoint CGPoint [ set-NSSize-w ] keep ; C-STRUCT: NSRange - { "uint" "location" } - { "uint" "length" } ; + { "NSUInteger" "location" } + { "NSUInteger" "length" } ; TYPEDEF: NSRange _NSRange @@ -58,12 +65,12 @@ TYPEDEF: NSRange _NSRange [ set-NSRange-location ] keep ; C-STRUCT: CGAffineTransform - { "float" "a" } - { "float" "b" } - { "float" "c" } - { "float" "d" } - { "float" "tx" } - { "float" "ty" } ; + { "CGFloat" "a" } + { "CGFloat" "b" } + { "CGFloat" "c" } + { "CGFloat" "d" } + { "CGFloat" "tx" } + { "CGFloat" "ty" } ; C-STRUCT: NSFastEnumerationState { "ulong" "state" } diff --git a/basis/compiler/generator/generator.factor b/basis/compiler/generator/generator.factor index 46be0d5962..da120ce432 100755 --- a/basis/compiler/generator/generator.factor +++ b/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 diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index 18f7f67787..e44ae681ff 100755 --- a/basis/compiler/tests/alien.factor +++ b/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" [ 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" + 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 diff --git a/basis/compiler/tree/branch-fusion/branch-fusion.factor b/basis/compiler/tree/branch-fusion/branch-fusion.factor deleted file mode 100644 index b1078c85fb..0000000000 --- a/basis/compiler/tree/branch-fusion/branch-fusion.factor +++ /dev/null @@ -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' ) ; diff --git a/basis/compiler/tree/loop/inversion/inversion.factor b/basis/compiler/tree/loop/inversion/inversion.factor deleted file mode 100644 index 719fc4ad70..0000000000 --- a/basis/compiler/tree/loop/inversion/inversion.factor +++ /dev/null @@ -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' ) ; diff --git a/basis/compiler/tree/optimizer/optimizer.factor b/basis/compiler/tree/optimizer/optimizer.factor index 593c13b277..aafc7f137b 100644 --- a/basis/compiler/tree/optimizer/optimizer.factor +++ b/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 - ! compute-def-use - ! dup check-nodes - ; + check-optimizer? get [ + compute-def-use + dup check-nodes + ] when + finalize ; diff --git a/basis/core-foundation/core-foundation.factor b/basis/core-foundation/core-foundation.factor index 5c3ccf6c80..00bf73e9dd 100644 --- a/basis/core-foundation/core-foundation.factor +++ b/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 dup [ CFBundleLoadExecutable drop ] [ - "Cannot load bundled named " prepend throw + "Cannot load bundle named " prepend throw ] ?if ; TUPLE: CFRelease-destructor alien disposed ; diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index d15c5a30ab..fc11e0a731 100755 --- a/basis/cpu/architecture/architecture.factor +++ b/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 ; diff --git a/basis/db/db-docs.factor b/basis/db/db-docs.factor index 9c3a643ef0..f8e3956b3e 100644 --- a/basis/db/db-docs.factor +++ b/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: -{ $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: -{ $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 ; "> } diff --git a/basis/db/db.factor b/basis/db/db.factor index 26141ec62c..eac22a2999 100755 --- a/basis/db/db.factor +++ b/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 ; - -: construct-statement ( sql in out class -- statement ) +: new-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 [ 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 ; diff --git a/basis/db/postgresql/postgresql.factor b/basis/db/postgresql/postgresql.factor index d833063b51..ae31b168cb 100755 --- a/basis/db/postgresql/postgresql.factor +++ b/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 ; -M: literal-bind postgresql-bind-conversion ( tuple literal-bind -- obj ) +M: literal-bind postgresql-bind-conversion ( tuple literal-bind -- object ) nip value>> ; -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 ] [ ] 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 ( sql in out -- statement ) - postgresql-statement construct-statement ; + postgresql-statement new-statement ; M: postgresql-db ( sql in out -- statement ) dup prepare-statement ; @@ -121,7 +121,7 @@ M: postgresql-db ( 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> 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 ; diff --git a/basis/db/queries/queries.factor b/basis/db/queries/queries.factor index 023ef3d9a8..ede7612942 100644 --- a/basis/db/queries/queries.factor +++ b/basis/db/queries/queries.factor @@ -50,10 +50,6 @@ M: retryable execute-statement* ( statement type -- ) [ 0 sql-counter rot with-variable ] curry { "" { } { } } nmake 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 ( 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 ( 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' ) diff --git a/basis/db/sql/sql.factor b/basis/db/sql/sql.factor index 2496ac6f3a..ba0673ae24 100755 --- a/basis/db/sql/sql.factor +++ b/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 -- ) { diff --git a/basis/db/sqlite/sqlite.factor b/basis/db/sqlite/sqlite.factor index dc8104ba00..1eb9b566d3 100755 --- a/basis/db/sqlite/sqlite.factor +++ b/basis/db/sqlite/sqlite.factor @@ -27,7 +27,7 @@ M: sqlite-db ( str in out -- obj ) ; M: sqlite-db ( 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 ) diff --git a/basis/db/tuples/tuples-docs.factor b/basis/db/tuples/tuples-docs.factor index 42e9cdb928..ed605da25f 100644 --- a/basis/db/tuples/tuples-docs.factor +++ b/basis/db/tuples/tuples-docs.factor @@ -82,9 +82,9 @@ HELP: count-tuples HELP: query { $values - { "tuple" null } { "query" null } - { "tuples" null } } -{ $description "" } ; + { "tuple" tuple } { "query" query } + { "tuples" "a sequence of tuples" } } +{ $description "Allows for queries with group by, order by, limit, and offset clauses. " } ; { select-tuple select-tuples count-tuples query } related-words diff --git a/basis/db/tuples/tuples.factor b/basis/db/tuples/tuples.factor index 9c8f595e68..3c3bae3adc 100755 --- a/basis/db/tuples/tuples.factor +++ b/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: drop-sql-statement db ( class -- obj ) +HOOK: create-sql-statement db ( class -- object ) +HOOK: drop-sql-statement db ( class -- object ) -HOOK: db ( class -- obj ) -HOOK: db ( class -- obj ) -HOOK: db ( class -- obj ) -HOOK: db ( tuple class -- obj ) +HOOK: db ( class -- object ) +HOOK: db ( class -- object ) +HOOK: db ( class -- object ) +HOOK: db ( tuple class -- object ) HOOK: db ( tuple class -- tuple ) TUPLE: query group order offset limit ; HOOK: db ( tuple class query -- statement' ) @@ -48,12 +48,12 @@ HOOK: 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> do-select ; + [ dup dup class ] dip do-select ; : select-tuples ( tuple -- tuples ) dup dup class do-select ; diff --git a/basis/db/types/types-docs.factor b/basis/db/types/types-docs.factor index 687ce7b991..9300a68f2e 100644 --- a/basis/db/types/types-docs.factor +++ b/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: { $description "" } ; @@ -55,22 +55,22 @@ HELP: { $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" diff --git a/basis/db/types/types.factor b/basis/db/types/types.factor index c7fbcd859e..24344acbf7 100755 --- a/basis/db/types/types.factor +++ b/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 ) - [ nip ] assoc-filter ; - -: tuple>params ( specs tuple -- obj ) - [ - >r [ type>> ] [ slot-name>> ] bi r> - get-slot-named swap - ] curry { } map>assoc ; diff --git a/basis/farkup/farkup-tests.factor b/basis/farkup/farkup-tests.factor index 0280c1a08d..e25fa34960 100644 --- a/basis/farkup/farkup-tests.factor +++ b/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 [ "

Feature comparison:

aFactorJavaLisp
CoolnessYesNoNo
BadassYesNoNo
EnterpriseYesYesNo
KosherYesNoYes
" ] [ "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 + +[ + "

This wiki is written in Factor and is hosted on a http://linode.com virtual server.

" +] [ + "This wiki is written in [[Factor]] and is hosted on a [[http://linode.com|http://linode.com]] virtual server." + convert-farkup +] unit-test + +[ "

a c

" ] [ "[[a]] [[b|c]]" convert-farkup ] unit-test diff --git a/basis/farkup/farkup.factor b/basis/farkup/farkup.factor index 154ab0db00..4d6ac127ad 100644 --- a/basis/farkup/farkup.factor +++ b/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 diff --git a/basis/random/random-docs.factor b/basis/random/random-docs.factor index a8a214dcc7..74751328d5 100644 --- a/basis/random/random-docs.factor +++ b/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" } } diff --git a/basis/random/random-tests.factor b/basis/random/random-tests.factor index eed4bf2e13..89c0c02c4a 100644 --- a/basis/random/random-tests.factor +++ b/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 diff --git a/basis/random/random.factor b/basis/random/random.factor index 133bf93b61..515c464a5a 100755 --- a/basis/random/random.factor +++ b/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 - random-bytes byte-array>bignum swap mod + length dup log2 7 + 8 /i 1+ + [ random-bytes byte-array>bignum ] + [ 3 shift 2^ ] bi / * >integer ] keep nth ] if-empty ; diff --git a/basis/smtp/smtp-docs.factor b/basis/smtp/smtp-docs.factor index e30b3fcc27..435b04504d 100644 --- a/basis/smtp/smtp-docs.factor +++ b/basis/smtp/smtp-docs.factor @@ -20,8 +20,7 @@ HELP: 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 ;" "" @@ -37,9 +36,5 @@ HELP: send-email } ; ARTICLE: "smtp" "SMTP Client Library" -"Start by creating a new email object:" -{ $subsection } -"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 ; +"Sending an email:" +{ $subsection send-email } ; diff --git a/basis/ui/cocoa/views/views.factor b/basis/ui/cocoa/views/views.factor index 1dcb62bcd9..45ab8ac0ce 100755 --- a/basis/ui/cocoa/views/views.factor +++ b/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 ] diff --git a/core/kernel/kernel-tests.factor b/core/kernel/kernel-tests.factor index 5cb4abc2e9..8a51d45447 100755 --- a/core/kernel/kernel-tests.factor +++ b/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 diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index 16d16c3e77..5c0dbf7985 100755 --- a/core/sequences/sequences-docs.factor +++ b/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 }" + } +} ; diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 9be2db3fd7..dbb24c3168 100755 --- a/core/sequences/sequences.factor +++ b/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 ) - [ but-last-slice ] [ peek ] bi ; +: unclip-last-slice ( seq -- butlast last ) + [ but-last-slice ] [ peek ] bi ; inline : ( seq -- slice ) dup slice? [ { } like ] when 0 over length rot ; diff --git a/extra/benchmark/mandel/colors/colors.factor b/extra/benchmark/mandel/colors/colors.factor index 848fbae01e..7bbb25a47d 100644 --- a/extra/benchmark/mandel/colors/colors.factor +++ b/extra/benchmark/mandel/colors/colors.factor @@ -16,4 +16,4 @@ IN: benchmark.mandel.colors ] with map ; : color-map ( -- map ) - nb-iter max-color min ; foldable + max-iterations max-color min ; foldable diff --git a/extra/benchmark/mandel/mandel.factor b/extra/benchmark/mandel/mandel.factor index a40b123ed3..e87765499b 100755 --- a/extra/benchmark/mandel/mandel.factor +++ b/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 -io.encodings.binary benchmark.mandel.params +math.parser sequences byte-arrays byte-vectors io.files +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 -- ) - height [ - 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 +: count-iterations ( z max-iterations step-quot test-quot -- #iters ) + '[ drop @ dup @ ] find-last-integer nip ; inline -:: ppm-header ( accum -- ) - "P6\n" accum push-all - width number>string accum push-all - " " accum push-all - height number>string accum push-all - "\n255\n" accum push-all ; inline +: pixel ( c -- iterations ) + [ C{ 0.0 0.0 } max-iterations ] dip + '[ sq , + ] [ absq 4.0 >= ] count-iterations ; inline + +: color ( iterations -- color ) + [ 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 - [ 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 ; diff --git a/extra/benchmark/mandel/params/params.factor b/extra/benchmark/mandel/params/params.factor index 3fcfe1d3ef..c40d3c1f2d 100644 --- a/extra/benchmark/mandel/params/params.factor +++ b/extra/benchmark/mandel/params/params.factor @@ -1,8 +1,8 @@ IN: benchmark.mandel.params -: max-color 360 ; inline -: zoom-fact 0.8 ; inline -: width 640 ; inline -: height 480 ; inline -: nb-iter 40 ; inline -: center -0.65 ; inline +: max-color 360 ; inline +: zoom-fact 0.8 ; inline +: width 640 ; inline +: height 480 ; inline +: max-iterations 40 ; inline +: center -0.65 ; inline diff --git a/extra/lisp/lisp-tests.factor b/extra/lisp/lisp-tests.factor index 7458926799..48f6419d30 100644 --- a/extra/lisp/lisp-tests.factor +++ b/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 } [ -! "((lambda (x) (if x (+ 1 2) (- 3 5))) #t)" lisp-eval -! ] unit-test + { 3 } [ + "((lambda (x) (if x (+ 1 2) (- 3 5))) #t)" lisp-eval + ] 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 } [ + + ] unit-test + + { 4 } [ + + ] unit-test ] with-interactive-vocabs diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor index 22bcd6905b..e004af8655 100644 --- a/extra/lisp/lisp.factor +++ b/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-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-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 ) + + + +: 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 ) - over name>> lisp-define ; + +: define-lisp-var ( lisp-symbol body -- ) + 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 - dup lisp-symbol? [ lookup-var ] when curry call ; inline + [ 1array [ call ] with-datastack >quotation ] dip 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 + ; + +: " parse-multiline-string define-lisp-builtins + lisp-string>factor parsed \ call parsed ; parsing \ No newline at end of file diff --git a/extra/random/blum-blum-shub/blum-blum-shub-tests.factor b/extra/random/blum-blum-shub/blum-blum-shub-tests.factor index 2a1af53232..9ace53ab25 100644 --- a/extra/random/blum-blum-shub/blum-blum-shub-tests.factor +++ b/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? [ reverse *uint ] unless ] with-random ] unit-test -[ 5726770047455156646 ] [ +[ 5570804936418322777 ] [ T{ blum-blum-shub f 590695557939 811977232793 } clone [ 64 random-bits little-endian? [ 4 group [ reverse ] map concat *ulonglong ] unless diff --git a/extra/roman/roman.factor b/extra/roman/roman.factor index 71b5d69693..aefe86328d 100644 --- a/extra/roman/roman.factor +++ b/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 = ; @@ -39,7 +33,6 @@ TUPLE: roman-range-error n ; ] [ first2 swap - ] if ; - PRIVATE> : >roman ( n -- str ) @@ -55,13 +48,11 @@ PRIVATE> ] map sum ; ( str1 str2 -- m n ) [ roman> ] bi@ ; : binary-roman-op ( str1 str2 quot -- str3 ) >r 2roman> r> call >roman ; inline - PRIVATE> : roman+ ( str1 str2 -- str3 ) diff --git a/extra/webapps/ip/ip.factor b/extra/webapps/ip/ip.factor new file mode 100644 index 0000000000..7124d4a5c4 --- /dev/null +++ b/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 ; + +: ( -- action ) + + [ remote-address get host>> "ip" set-value ] >>init + { ip-app "ip" } >>template ; + +: ( -- dispatcher ) + ip-app new-dispatcher + "" add-responder ; diff --git a/extra/webapps/ip/ip.xml b/extra/webapps/ip/ip.xml new file mode 100644 index 0000000000..c8529c27ce --- /dev/null +++ b/extra/webapps/ip/ip.xml @@ -0,0 +1,7 @@ + + + + Your IP address is: + + + diff --git a/extra/webapps/wiki/wiki-common.xml b/extra/webapps/wiki/wiki-common.xml index 89a0f17706..978551a638 100644 --- a/extra/webapps/wiki/wiki-common.xml +++ b/extra/webapps/wiki/wiki-common.xml @@ -8,48 +8,55 @@ -
- - Front Page - | All Articles - | Recent Changes - | Random Article - - - - - | Edit Profile - - - | Logout - - - -
- -

- - - + + -
- -

- - - -

- - - + 		+
+ +

+ + + +

+ + + +
+ +
+ + Front Page + | All Articles + | Recent Changes + | Random Article + + + + + | Edit Profile + + + | Logout + + + +
+ +

+ + + +
+ diff --git a/extra/webapps/wiki/wiki.css b/extra/webapps/wiki/wiki.css index 83ec918e3b..67000ae63c 100644 --- a/extra/webapps/wiki/wiki.css +++ b/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; +} diff --git a/extra/websites/concatenative/concatenative.factor b/extra/websites/concatenative/concatenative.factor index 5e94e4e88a..e37f7d4c3f 100644 --- a/extra/websites/concatenative/concatenative.factor +++ b/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 ; diff --git a/extra/websites/concatenative/page.css b/extra/websites/concatenative/page.css index 49e26883ad..8115627742 100644 --- a/extra/websites/concatenative/page.css +++ b/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; } diff --git a/unfinished/regexp2/regexp2.factor b/unfinished/regexp2/regexp2.factor index efc5c660de..24221baeb6 100644 --- a/unfinished/regexp2/regexp2.factor +++ b/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- ; diff --git a/unfinished/regexp2/traversal/traversal.factor b/unfinished/regexp2/traversal/traversal.factor index a5db2cdaa8..0bc304bfe0 100644 --- a/unfinished/regexp2/traversal/traversal.factor +++ b/unfinished/regexp2/traversal/traversal.factor @@ -18,7 +18,7 @@ TUPLE: dfa-traverser matches ; : ( 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 diff --git a/unmaintained/ogg/player/player.factor b/unmaintained/ogg/player/player.factor index 251206f1d1..2204aa441e 100755 --- a/unmaintained/ogg/player/player.factor +++ b/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 player-vi vorbis_info_init - player-vc vorbis_comment_init ; + dup oy>> ogg_sync_init drop + dup vi>> vorbis_info_init + vc>> vorbis_comment_init ; : init-theora ( player -- ) - dup player-ti theora_info_init - player-tc theora_comment_init ; + dup ti>> theora_info_init + tc>> theora_comment_init ; : init-sound ( player -- ) init-openal check-error - 1 gen-buffers check-error over set-player-buffers - 2 "uint" over set-player-buffer-indexes - 1 gen-sources check-error first swap set-player-source ; + 1 gen-buffers check-error >>buffers + 2 "uint" >>buffer-indexes + 1 gen-sources check-error first >>source drop ; : ( stream -- player ) - { set-player-stream } player construct - 0 over set-player-vorbis - 0 over set-player-theora - 0 over set-player-video-time - 0 over set-player-video-granulepos - f over set-player-video-ready? - f over set-player-audio-full? - 0 over set-player-audio-index - 0 over set-player-start-time - audio-buffer-size "short" over set-player-audio-buffer - 0 over set-player-audio-granulepos - f over set-player-playing? - "ogg_packet" malloc-object over set-player-op - "ogg_sync_state" malloc-object over set-player-oy - "ogg_page" malloc-object over set-player-og - "ogg_stream_state" malloc-object over set-player-vo - "vorbis_info" malloc-object over set-player-vi - "vorbis_dsp_state" malloc-object over set-player-vd - "vorbis_block" malloc-object over set-player-vb - "vorbis_comment" malloc-object over set-player-vc - "ogg_stream_state" malloc-object over set-player-to - "theora_info" malloc-object over set-player-ti - "theora_comment" malloc-object over set-player-tc - "theora_state" malloc-object over set-player-td - "yuv_buffer" over set-player-yuv - "ogg_stream_state" over set-player-temp-state - dup init-sound - dup init-vorbis - dup init-theora ; + player new + swap >>stream + 0 >>vorbis + 0 >>theora + 0 >>video-time + 0 >>video-granulepos + f >>video-ready? + f >>audio-full? + 0 >>audio-index + 0 >>start-time + audio-buffer-size "short" >>audio-buffer + 0 >>audio-granulepos + f >>playing? + "ogg_packet" malloc-object >>op + "ogg_sync_state" malloc-object >>oy + "ogg_page" malloc-object >>og + "ogg_stream_state" malloc-object >>vo + "vorbis_info" malloc-object >>vi + "vorbis_dsp_state" malloc-object >>vd + "vorbis_block" malloc-object >>vb + "vorbis_comment" malloc-object >>vc + "ogg_stream_state" malloc-object >>to + "theora_info" malloc-object >>ti + "theora_comment" malloc-object >>tc + "theora_state" malloc-object >>td + "yuv_buffer" >>yuv + "ogg_stream_state" >>temp-state + dup init-sound + 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? [ - millis over set-player-start-time + dup start-time>> zero? [ + 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 { player-td player-yuv } get-slots theora_decode_YUVout drop - dup player-rgb over player-yuv yuv>rgb - dup player-gadget relayout-1 yield + dup gadget>> [ + { + [ [ td>> ] [ yuv>> ] bi theora_decode_YUVout drop ] + [ [ 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 + dup source>> AL_BUFFERS_PROCESSED 0 [ alGetSourcei check-error ] keep *uint ; : append-new-audio-buffer ( player -- player ) - dup player-buffers 1 gen-buffers append over set-player-buffers - [ [ player-buffers second ] keep al-channel-format ] keep - [ player-audio-buffer dup length ] keep - [ player-vi vorbis_info-rate alBufferData check-error ] keep - [ player-source 1 ] keep - [ player-buffers second alSourceQueueBuffers check-error ] keep ; + dup buffers>> 1 gen-buffers append >>buffers + [ [ buffers>> second ] keep al-channel-format ] keep + [ audio-buffer>> dup length ] keep + [ vi>> vorbis_info-rate alBufferData check-error ] keep + [ source>> 1 ] keep + [ buffers>> second 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 - [ player-vi vorbis_info-rate alBufferData check-error ] keep - [ player-source 1 ] keep + [ audio-buffer>> dup length ] keep + [ vi>> vorbis_info-rate alBufferData check-error ] keep + [ source>> 1 ] keep r> 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 player-buffers length 2 = over zero? and ] [ yield drop f ] } + { [ over buffers>> length 1 = over zero? and ] [ drop append-new-audio-buffer t ] } + { [ 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 - [ player-audio-buffer dup length ] keep - [ player-vi vorbis_info-rate alBufferData check-error ] keep - [ player-source 1 ] keep - [ player-buffers first alSourceQueueBuffers check-error ] keep - [ player-source alSourcePlay check-error ] keep - t over set-player-playing? t ; + [ [ buffers>> first ] keep al-channel-format ] keep + [ audio-buffer>> dup length ] keep + [ vi>> vorbis_info-rate alBufferData check-error ] keep + [ source>> 1 ] keep + [ buffers>> first alSourceQueueBuffers check-error ] keep + [ source>> alSourcePlay check-error ] keep + 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 - [ { player-to player-og } get-slots ogg_stream_pagein drop ] keep ; + [ [ vo>> ] [ og>> ] bi ogg_stream_pagein drop ] + [ [ 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 - [ player-og ogg_page_serialno ogg_stream_init check-not-negative ] 2keep ; + [ temp-state>> ] keep + [ 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 player-vc vorbis_comment_clear ; + dup vi>> vorbis_info_clear + dup vc>> vorbis_comment_clear ; : tear-down-theora ( player -- player ) - dup player-ti theora_info_clear - dup player-tc theora_comment_clear ; + dup ti>> theora_info_clear + dup tc>> theora_comment_clear ; : init-vorbis-codec ( player -- player ) - dup { player-vd player-vi } get-slots vorbis_synthesis_init drop - dup { player-vd player-vb } get-slots vorbis_block_init drop ; + dup [ vd>> ] [ vi>> ] bi vorbis_synthesis_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 player-ti theora_info-frame_width over player-ti theora_info-frame_height - 4 * * over set-player-rgb ; + dup [ td>> ] [ ti>> ] bi theora_decode_init drop + dup ti>> theora_info-frame_width over ti>> theora_info-frame_height + 4 * * >>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 - over player-ti theora_info-fps_denominator /f # + dup ti>> theora_info-fps_numerator + 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 player-theora zero? [ tear-down-theora ] [ init-theora-codec display-theora-details ] if ; + dup vorbis>> zero? [ tear-down-vorbis ] [ init-vorbis-codec display-vorbis-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 2dup >r player-vd r> vorbis_synthesis_pcmout dup 0 > ; + f 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 - dup player-audio-index 1+ swap set-player-audio-index ; + over audio-index>> pick audio-buffer>> set-short-nth + [ 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 = [ - t over set-player-audio-full? + dup audio-index>> audio-buffer-size = [ + 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 { player-vb player-op } get-slots vorbis_synthesis 0 = [ - dup { player-vd player-vb } get-slots vorbis_synthesis_blockin drop + dup [ vo>> ] [ op>> ] bi ogg_stream_packetout 0 > [ + dup [ vb>> ] [ op>> ] bi vorbis_synthesis 0 = [ + 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 { player-td player-op } get-slots theora_decode_packetin drop - dup player-td theora_state-granulepos over set-player-video-granulepos - dup { player-td player-video-granulepos } get-slots theora_granule_time - over set-player-video-time - t over set-player-video-ready? + dup [ to>> ] [ op>> ] bi ogg_stream_packetout 0 > [ + dup [ td>> ] [ op>> ] bi theora_decode_packetin drop + dup td>> theora_state-granulepos >>video-granulepos + dup [ td>> ] [ video-granulepos>> ] bi theora_granule_time + >>video-time + 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? - 0 over set-player-audio-index + f >>audio-full? + 0 >>audio-index ] when ] when - dup player-video-ready? [ - dup player-video-time over get-time - dup 0.0 < [ + dup video-ready?>> [ + 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 - [ player-og free ] keep - [ player-vo free ] keep - [ player-vi free ] keep - [ player-vd free ] keep - [ player-vb free ] keep - [ player-vc free ] keep - [ player-to free ] keep - [ player-ti free ] keep - [ player-tc free ] keep - [ player-td free ] keep ; + { + [ op>> free ] + [ oy>> free ] + [ og>> free ] + [ vo>> free ] + [ vi>> free ] + [ vd>> free ] + [ vb>> free ] + [ vc>> free ] + [ to>> free ] + [ ti>> free ] + [ 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 alDeleteBuffers check-error ] each ] keep ; : delete-openal-source ( player -- player ) - [ player-source 1 swap alDeleteSources check-error ] keep ; + [ source>> 1 swap 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 [ alGetSourcei check-error ] keep + dup source>> AL_SOURCE_STATE 0 [ alGetSourcei check-error ] keep *int AL_PLAYING = [ 100 sleep wait-for-sound ] when ; -TUPLE: theora-gadget player ; +TUPLE: theora-gadget < gadget player ; : ( player -- gadget ) - theora-gadget construct-gadget - [ set-theora-gadget-player ] keep ; + theora-gadget new-gadget + swap >>player ; M: theora-gadget pref-dim* - theora-gadget-player - player-ti dup theora_info-width swap theora_info-height 2array ; + player>> + 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 -- ) - dup over set-player-gadget + dup >>gadget play-ogg ; : play-theora-file ( filename -- ) binary play-theora-stream ; - diff --git a/vm/ffi_test.c b/vm/ffi_test.c index 5cdfbb2a9e..44a14f21f5 100755 --- a/vm/ffi_test.c +++ b/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; +} diff --git a/vm/ffi_test.h b/vm/ffi_test.h index 0f51092d25..779cb97857 100755 --- a/vm/ffi_test.h +++ b/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);