! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math sequences io.binary splitting grouping ;
+USING: kernel math sequences io.binary splitting grouping
+accessors ;
IN: base64
<PRIVATE
-: count-end ( seq quot -- count )
- >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 ;
} nth ;
: encode3 ( seq -- seq )
- be> 4 <reversed> [ -6 * shift HEX: 3f bitand ch>base64 ] with B{ } map-as ;
+ be> 4 <reversed> [
+ -6 * shift HEX: 3f bitand ch>base64
+ ] with B{ } map-as ;
: decode4 ( str -- str )
0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ;
: >base64-rem ( str -- str )
- [ 3 0 pad-right encode3 ] [ length 1+ ] bi head 4 CHAR: = pad-right ;
+ [ 3 0 pad-right encode3 ] [ length 1+ ] bi
+ head-slice 4 CHAR: = pad-right ;
PRIVATE>
: base64> ( base64 -- str )
#! input length must be a multiple of 4
[ 4 <groups> [ decode4 ] map concat ]
- [ [ CHAR: = = not ] count-end ]
+ [ [ CHAR: = = ] count-end ]
bi head* ;
[
[
{
- [ hashcode , ]
+ [ hashcode <fake-bignum> , ]
[ name>> , ]
[ vocabulary>> , ]
[ def>> , ]
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 )
: <super> ( receiver -- super )
"objc-super" <c-object> [
- >r dup objc-object-isa objc-class-super-class r>
+ >r dup object_getClass class_getSuperclass r>
set-objc-super-class
] keep
[ set-objc-super-receiver ] keep ;
: objc-meta-class ( string -- class )
\ objc_getMetaClass (objc-class) ;
-: method-arg-type ( method i -- type )
- f <void*> 0 <int> over
- >r method_getArgumentInfo drop
- r> *void* ascii alien>string ;
-
SYMBOL: objc>alien-types
H{
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
: 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 <displaced-alien> ;
-
-: (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 <void*> (register-objc-methods) ;
+ 0 <uint> [ class_copyMethodList ] keep *uint
+ (register-objc-methods) (free) ;
: class-exists? ( string -- class ) objc_getClass >boolean ;
] curry try ;
: root-class ( class -- root )
- dup objc-class-super-class [ root-class ] [ ] ?if ;
+ dup class_getSuperclass [ root-class ] [ ] ?if ;
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 ;
: 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: Class objc_getMetaClass ( char* class ) ;
+
+FUNCTION: Protocol objc_getProtocol ( char* class ) ;
+
+FUNCTION: Class objc_allocateClassPair ( Class superclass, char* name, size_t extraBytes ) ;
+FUNCTION: void objc_registerClassPair ( Class cls ) ;
+
+FUNCTION: id class_createInstance ( Class class, uint additionalByteCount ) ;
-FUNCTION: objc-class* objc_getMetaClass ( char* class ) ;
+FUNCTION: id class_createInstanceFromZone ( Class class, uint additionalByteCount, void* zone ) ;
-FUNCTION: objc-class* objc_getProtocol ( char* class ) ;
+FUNCTION: Method class_getInstanceMethod ( Class class, SEL selector ) ;
-FUNCTION: void objc_addClass ( objc-class* class ) ;
+FUNCTION: Method class_getClassMethod ( Class class, SEL selector ) ;
-FUNCTION: id class_createInstance ( objc-class* class, uint additionalByteCount ) ;
+FUNCTION: Method* class_copyMethodList ( Class class, uint* outCount ) ;
-FUNCTION: id class_createInstanceFromZone ( objc-class* class, uint additionalByteCount, void* zone ) ;
+FUNCTION: Class class_getSuperclass ( Class cls ) ;
-C-STRUCT: objc-method
- { "SEL" "name" }
- { "char*" "types" }
- { "void*" "imp" } ;
+FUNCTION: char class_addMethod ( Class class, SEL name, void* imp, void* types ) ;
-FUNCTION: objc-method* class_getInstanceMethod ( objc-class* class, SEL selector ) ;
+FUNCTION: char class_addProtocol ( Class class, Protocol protocol ) ;
-FUNCTION: objc-method* class_getClassMethod ( objc-class* class, SEL selector ) ;
+FUNCTION: uint method_getNumberOfArguments ( Method method ) ;
-C-STRUCT: objc-method-list
- { "void*" "obsolete" }
- { "int" "count" } ;
+FUNCTION: uint method_getSizeOfArguments ( Method method ) ;
-FUNCTION: objc-method-list* class_nextMethodList ( objc-class* class, void** iterator ) ;
+FUNCTION: uint method_getArgumentInfo ( Method method, int argIndex, char** type, int* offset ) ;
-FUNCTION: void class_addMethods ( objc-class* class, objc-method-list* methodList ) ;
+FUNCTION: void* method_copyReturnType ( Method method ) ;
-FUNCTION: void class_removeMethods ( objc-class* class, objc-method-list* methodList ) ;
+FUNCTION: void* method_copyArgumentType ( Method method, uint index ) ;
-FUNCTION: uint method_getNumberOfArguments ( objc-method* method ) ;
+FUNCTION: void* method_getTypeEncoding ( Method method ) ;
-FUNCTION: uint method_getSizeOfArguments ( objc-method* method ) ;
+FUNCTION: SEL method_getName ( Method method ) ;
-FUNCTION: uint method_getArgumentInfo ( objc-method* method, int argIndex, char** type, int* offset ) ;
+FUNCTION: void* method_setImplementation ( Method method, void* imp ) ;
-C-STRUCT: objc-protocol-list
- { "void*" "next" }
- { "int" "count" }
- { "objc-class*" "class" } ;
+FUNCTION: Class object_getClass ( id object ) ;
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* ;
-: <empty-method-list> ( 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 ;
-: <method-list> ( methods -- alien )
- dup length dup <empty-method-list> -rot
- [ pick method-list@ objc-method-nth init-method ] 2each ;
-
-: define-objc-methods ( class methods -- )
- <method-list> class_addMethods ;
-
-: <objc-class> ( name info -- class )
- "objc-class" malloc-object
- [ set-objc-class-info ] keep
- [ >r ascii malloc-string r> set-objc-class-name ] keep ;
-
-: <protocol-list> ( name -- protocol-list )
- "objc-protocol-list" malloc-object
- 1 over set-objc-protocol-list-count
- swap objc-protocol over set-objc-protocol-list-class ;
-
-! The Objective C object model is a bit funny.
-! Every class has a metaclass.
-
-! The superclass of the metaclass of X is the metaclass of the
-! superclass of X.
-
-! The metaclass of the metaclass of X is the metaclass of the
-! root class of X.
-: meta-meta-class ( class -- class ) root-class objc-class-isa ;
-
-: copy-instance-size ( class -- )
- dup objc-class-super-class objc-class-instance-size
- swap set-objc-class-instance-size ;
-
-: <meta-class> ( superclass name -- class )
- CLS_META <objc-class>
- [ >r dup objc-class-isa r> set-objc-class-super-class ] keep
- [ >r meta-meta-class r> set-objc-class-isa ] keep
- dup copy-instance-size ;
-
-: set-protocols ( protocols class -- )
- swap {
- { [ dup empty? ] [ 2drop ] }
- { [ dup length 1 = ] [
- first <protocol-list>
- swap set-objc-class-protocols
- ] }
- } cond ;
-
-: <new-class> ( protocols metaclass superclass name -- class )
- CLS_CLASS <objc-class>
- [ set-objc-class-super-class ] keep
- [ set-objc-class-isa ] keep
- [ set-protocols ] keep
- dup copy-instance-size ;
+: add-protocols ( protocols class -- )
+ swap [ objc-protocol class_addProtocol drop ] with each ;
: (define-objc-class) ( protocols superclass name imeth -- )
- >r
- >r objc-class r>
- [ <meta-class> ] 2keep <new-class> dup objc_addClass
- r> <method-list> class_addMethods ;
+ -rot
+ [ objc-class ] dip 0 objc_allocateClassPair
+ [ add-methods ] [ add-protocols ] [ objc_registerClassPair ]
+ tri ;
: encode-types ( return types -- encoding )
swap prefix [
[ 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 ;
! 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
[ NSRect-x ] keep NSRect-y ;
C-STRUCT: NSPoint
- { "float" "x" }
- { "float" "y" } ;
+ { "CGFloat" "x" }
+ { "CGFloat" "y" } ;
TYPEDEF: NSPoint _NSPoint
TYPEDEF: NSPoint CGPoint
[ set-NSPoint-x ] keep ;
C-STRUCT: NSSize
- { "float" "w" }
- { "float" "h" } ;
+ { "CGFloat" "w" }
+ { "CGFloat" "h" } ;
TYPEDEF: NSSize _NSSize
TYPEDEF: NSPoint CGPoint
[ set-NSSize-w ] keep ;
C-STRUCT: NSRange
- { "uint" "location" }
- { "uint" "length" } ;
+ { "NSUInteger" "location" }
+ { "NSUInteger" "length" } ;
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" }
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
C-STRUCT: test-struct-12 { "int" "a" } { "double" "x" } ;
-: make-struct-12
+: make-struct-12 ( x -- alien )
"test-struct-12" <c-object>
[ set-test-struct-12-x ] keep ;
[ 1 ] [ callback-9 ffi_test_37 ] unit-test
[ 7 ] [ callback-9 ffi_test_37 ] unit-test
+
+C-STRUCT: test_struct_13
+{ "float" "x1" }
+{ "float" "x2" }
+{ "float" "x3" }
+{ "float" "x4" }
+{ "float" "x5" }
+{ "float" "x6" } ;
+
+: make-test-struct-13 ( -- alien )
+ "test_struct_13" <c-object>
+ 1.0 over set-test_struct_13-x1
+ 2.0 over set-test_struct_13-x2
+ 3.0 over set-test_struct_13-x3
+ 4.0 over set-test_struct_13-x4
+ 5.0 over set-test_struct_13-x5
+ 6.0 over set-test_struct_13-x6 ;
+
+FUNCTION: int ffi_test_39 ( long a, long b, test_struct_13 s ) ;
+
+[ 21 ] [ 12347 12347 make-test-struct-13 ffi_test_39 ] unit-test
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-IN: compiler.tree.branch-fusion
-
-: fuse-branches ( nodes -- nodes' ) ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-IN: compiler.tree.loop.inversion
-
-: invert-loops ( nodes -- nodes' ) ;
! 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
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 ;
! 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
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
dup <CFBundle> [
CFBundleLoadExecutable drop
] [
- "Cannot load bundled named " prepend throw
+ "Cannot load bundle named " prepend throw
] ?if ;
TUPLE: CFRelease-destructor alien disposed ;
M: stack-params param-reg drop ;
+M: stack-params param-regs drop f ;
+
GENERIC: v>operand ( obj -- operand )
M: integer v>operand tag-fixnum ;
{ $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
HELP: result-set
{ $description } ;
-HELP: construct-statement
+HELP: new-statement
{ $values { "sql" string } { "in" sequence } { "out" sequence } { "class" class } { "statement" statement } }
{ $description "Makes a new statement object from the given parameters." } ;
HELP: <simple-statement>
-{ $values { "string" string } { "in" sequence } { "out" sequence } }
+{ $values { "string" string } { "in" sequence } { "out" sequence }
+ { "statement" statement } }
{ $description "Makes a new simple statement object from the given parameters." } ;
HELP: <prepared-statement>
-{ $values { "string" string } { "in" sequence } { "out" sequence } }
+{ $values { "string" string } { "in" sequence } { "out" sequence }
+ { "statement" statement } }
{ $description "Makes a new prepared statement object from the given parameters." } ;
HELP: prepare-statement
{ $description "" } ;
HELP: query-results
-{ $values { "query" object } { "statement" statement } }
+{ $values { "query" object }
+ { "result-set" result-set }
+}
{ $description "" } ;
HELP: #rows
{ $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
;
HELP: more-rows?
-{ $values { "result-set" result-set } { "column" integer } }
+{ $values { "result-set" result-set } { "?" "a boolean" } }
;
HELP: execute-statement*
"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 ;
"> }
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 -- )
} 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
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 -- )
[ 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 ;
: default-query ( query -- result-set )
query-results [ [ sql-row ] query-map ] with-disposal ;
-: do-bound-query ( obj query -- rows )
- [ bind-statement ] keep default-query ;
+: sql-query ( sql -- rows )
+ f f <simple-statement> [ default-query ] with-disposal ;
-: do-bound-command ( obj query -- )
- [ bind-statement ] keep execute-statement ;
+: sql-command ( sql -- )
+ dup string? [
+ f f <simple-statement> [ execute-statement ] with-disposal
+ ] [
+ ! [
+ [ 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 -- )
begin-transaction
[ ] [ rollback-transaction ] cleanup commit-transaction
] with-variable ;
-
-: sql-query ( sql -- rows )
- f f <simple-statement> [ default-query ] with-disposal ;
-
-: sql-command ( sql -- )
- dup string? [
- f f <simple-statement> [ execute-statement ] with-disposal
- ] [
- ! [
- [ sql-command ] each
- ! ] with-transaction
- ] if ;
M: postgresql-statement bind-statement* ( statement -- )
drop ;
-GENERIC: postgresql-bind-conversion ( tuple obj -- low-level-binding )
+GENERIC: postgresql-bind-conversion ( tuple object -- low-level-binding )
-M: sql-spec postgresql-bind-conversion ( tuple spec -- obj )
+M: sql-spec postgresql-bind-conversion ( tuple spec -- object )
slot-name>> swap get-slot-named <low-level-binding> ;
-M: literal-bind postgresql-bind-conversion ( tuple literal-bind -- obj )
+M: literal-bind postgresql-bind-conversion ( tuple literal-bind -- object )
nip value>> <low-level-binding> ;
-M: generator-bind postgresql-bind-conversion ( tuple generate-bind -- obj )
+M: generator-bind postgresql-bind-conversion ( tuple generate-bind -- object )
dup generator-singleton>> eval-generator
[ swap slot-name>> rot set-slot-named ] [ <low-level-binding> ] bi ;
: 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 ;
] [
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 -- )
>>handle drop ;
M: postgresql-db <simple-statement> ( sql in out -- statement )
- postgresql-statement construct-statement ;
+ postgresql-statement new-statement ;
M: postgresql-db <prepared-statement> ( sql in out -- statement )
<simple-statement> dup prepare-statement ;
M: postgresql-db bind% ( spec -- )
bind-name% 1, ;
-M: postgresql-db bind# ( spec obj -- )
+M: postgresql-db bind# ( spec object -- )
>r bind-name% f swap type>> r> <literal-bind> 1, ;
: create-table-sql ( class -- statement )
{ 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 ] }
swap [ slot-name>> = ] with find nip
column-name>> paren append
] }
- [ "no compound found" 3array throw ]
+ [ drop no-compound-found ]
} case ;
[ 0 sql-counter rot with-variable ] curry { "" { } { } } nmake
<simple-statement> maybe-make-retryable ; inline
-M: db begin-transaction ( -- ) "BEGIN" sql-command ;
-M: db commit-transaction ( -- ) "COMMIT" sql-command ;
-M: db rollback-transaction ( -- ) "ROLLBACK" sql-command ;
-
: where-primary-key% ( specs -- )
" where " 0%
find-primary-key dup column-name>> 0% " = " 0% bind% ;
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 )
: 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' )
[ third 1, \ ? 0, ] tri
] each ;
-USE: multiline
-/*
HOOK: sql-create db ( object -- )
M: db sql-create ( object -- )
drop
! 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, ;
{ \ max [ sql-max ] }
[ sql% [ sql% ] each ]
} case ;
-*/
-: sql-array% ( array -- ) drop ;
ERROR: no-sql-match ;
: sql% ( obj -- )
{
<prepared-statement> ;
M: sqlite-db <prepared-statement> ( str in out -- obj )
- sqlite-statement construct-statement ;
+ sqlite-statement new-statement ;
: sqlite-maybe-prepare ( statement -- statement )
dup handle>> [
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 ;
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 )
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
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 -- )
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: <insert-db-assigned-statement> db ( class -- obj )
-HOOK: <insert-user-assigned-statement> db ( class -- obj )
-HOOK: <update-tuple-statement> db ( class -- obj )
-HOOK: <delete-tuples-statement> db ( tuple class -- obj )
+HOOK: <insert-db-assigned-statement> db ( class -- object )
+HOOK: <insert-user-assigned-statement> db ( class -- object )
+HOOK: <update-tuple-statement> db ( class -- object )
+HOOK: <delete-tuples-statement> db ( tuple class -- object )
HOOK: <select-by-slots-statement> db ( tuple class -- tuple )
TUPLE: query group order offset limit ;
HOOK: <query> db ( tuple class query -- statement' )
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 ;
: 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
] [
[ [ bind-tuple ] [ query-tuples ] 2bi ] with-disposal ;
: query ( tuple query -- tuples )
- >r dup dup class r> <query> do-select ;
+ [ dup dup class ] dip <query> do-select ;
: select-tuples ( tuple -- tuples )
dup dup class <select-by-slots-statement> do-select ;
{ $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 "" } ;
{ $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 "" } ;
{ $description "" } ;
HELP: +user-assigned-id+
-{ $description "" } ;
+{ $description "The user is responsible for choosing a primary key for tuples inserted with this database type. Keys must be unique or else the database will throw an error. Usually it is better to use a " { $link +db-assigned-id+ } "." } ;
HELP: <generator-bind>
{ $description "" } ;
{ $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 "" } ;
{ $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 "" } ;
{ "?" "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 "" } ;
{ "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 }
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"
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+? ;
(lookup-type) second
] if ;
-: single-quote ( string -- new-string )
- "'" swap "'" 3append ;
-
-: double-quote ( string -- new-string )
- "\"" swap "\"" 3append ;
-
: paren ( string -- new-string )
"(" swap ")" 3append ;
: set-slot-named ( value name obj -- )
tuck offset-of-slot set-slot ;
-
-: tuple>filled-slots ( tuple -- alist )
- <mirror> [ nip ] assoc-filter ;
-
-: tuple>params ( specs tuple -- obj )
- [
- >r [ type>> ] [ slot-name>> ] bi r>
- get-slot-named swap
- ] curry { } map>assoc ;
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
[
"<p>Feature comparison:</p><table><tr><td>a</td><td>Factor</td><td>Java</td><td>Lisp</td></tr><tr><td>Coolness</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Badass</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Enterprise</td><td>Yes</td><td>Yes</td><td>No</td></tr><tr><td>Kosher</td><td>Yes</td><td>No</td><td>Yes</td></tr></table>"
] [ "Feature comparison:\n\n|a|Factor|Java|Lisp|\n|Coolness|Yes|No|No|\n|Badass|Yes|No|No|\n|Enterprise|Yes|Yes|No|\n|Kosher|Yes|No|Yes|\n" convert-farkup ] unit-test
+
+[
+ "<p>This wiki is written in <a href='Factor'>Factor</a> and is hosted on a <a href='http://linode.com'>http://linode.com</a> virtual server.</p>"
+] [
+ "This wiki is written in [[Factor]] and is hosted on a [[http://linode.com|http://linode.com]] virtual server."
+ convert-farkup
+] unit-test
+
+[ "<p><a href='a'>a</a> <a href='b'>c</a></p>" ] [ "[[a]] [[b|c]]" convert-farkup ] unit-test
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
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" } }
-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
[ 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
! 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
: 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 ;
HELP: send-email
{ $values { "email" email } }
-{ $description "Sends an " { $link email } " object to an STMP server stored in the " { $link smtp-server } " variable. The required slots are " { $snippet "from" } " and " { $snippet "to" } "." }
-
+{ $description "Sends an " { $link email } " object to an STMP server stored in the " { $link smtp-server } " variable. The required slots are " { $slot "from" } " and " { $slot "to" } "." }
{ $examples
{ $unchecked-example "USING: accessors smtp ;"
"<email>"
} ;
ARTICLE: "smtp" "SMTP Client Library"
-"Start by creating a new email object:"
-{ $subsection <email> }
-"Set the " { $snippet "from" } " slot to a " { $link string } "." $nl
-"Set the recipient fields, " { $snippet "to" } ", " { $snippet "cc" } ", and " { $snippet "bcc" } ", to arrays of strings."
-"Set the " { $snippet "subject" } " to a " { $link string } "." $nl
-"Set the " { $snippet "body" } " to a " { $link string } "." $nl ;
+"Sending an email:"
+{ $subsection send-email } ;
{ +protocols+ { "NSTextInput" } }
}
-! Rendering
! Rendering
{ "drawRect:" "void" { "id" "SEL" "id" "NSRect" }
[ 3drop window relayout-1 ]
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
[ 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
ARTICLE: "sequences-appending" "Appending sequences"
{ $subsection append }
+{ $subsection prepend }
{ $subsection 3append }
{ $subsection concat }
{ $subsection join }
{ $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:"
{ $subsection each }
{ $subsection reduce }
{ $subsection interleave }
+{ $subsection replicate }
+{ $subsection replicate-as }
"Mapping:"
{ $subsection map }
{ $subsection map-as }
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" } }
{ $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." } ;
"{ 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 }
"{ 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 }
"{ 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 }"
+ }
+} ;
: 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
[ 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
: <flat-slice> ( seq -- slice )
dup slice? [ { } like ] when 0 over length rot <slice> ;
] with map ;
: color-map ( -- map )
- nb-iter max-color min <color-map> ; foldable
+ max-iterations max-color min <color-map> ; foldable
+! 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
[ 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
-
-:: 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
+: count-iterations ( z max-iterations step-quot test-quot -- #iters )
+ '[ drop @ dup @ ] find-last-integer nip ; 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 <byte-vector>
- [ ppm-header ] [ render ] [ B{ } like ] tri ;
+ [ building [ ppm-header render ] with-variable ] [ B{ } like ] bi ;
: mandel-main ( -- )
mandel "mandel.ppm" temp-file binary set-file-contents ;
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
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
"(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
"(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 } [
+ <LISP (begin (+ 1 2) (+ 9 1)) LISP>
+ ] unit-test
+
+ { 4 } [
+ <LISP ((lambda (x y) (if x (+ 1 y) (+ 2 y))) #t 3) LISP>
+ ] unit-test
] with-interactive-vocabs
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
: rest-lambda ( body vars -- quot )
"&rest" swap [ remove ] [ index ] 2bi
[ localize-lambda <lambda> lambda-rewrite call ] dip
- swap '[ , cut '[ @ , seq>list ] call , call call ] ;
+ swap '[ , cut '[ @ , seq>list ] call , call call ] 1quotation ;
: normal-lambda ( body vars -- quot )
localize-lambda <lambda> lambda-rewrite '[ @ compose call call ] 1quotation ;
cadr 1quotation ;
: convert-defmacro ( cons -- quot )
- cdr [ car ] keep [ convert-lambda ] [ car name>> ] bi define-lisp-macro 1quotation ;
+ cdr [ convert-lambda ] [ car name>> ] bi define-lisp-macro [ ] ;
: macro-expand ( cons -- quot )
uncons [ list>seq >quotation ] [ lookup-macro ] bi* call call ;
-
-: (expand-macros) ( cons -- cons )
+
+<PRIVATE
+: (expand-macros) ( cons -- cons )
[ dup list? [ (expand-macros) dup car lisp-macro? [ macro-expand ] when ] when ] lmap ;
-
-: expand-macros ( cons -- cons )
+PRIVATE>
+
+: 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 ] ;
: convert-list-form ( cons -- quot )
dup car
- {
+ {
{ [ dup lisp-symbol? ] [ form-dispatch ] }
[ drop convert-general-form ]
} cond ;
: 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 ;
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 ;
: lisp-macro? ( car -- ? )
dup lisp-symbol? [ name>> macro-env get key? ] [ drop f ] if ;
+
+: define-lisp-builtins ( -- )
+ init-env
+
+ f "#f" lisp-define
+ t "#t" lisp-define
+
+ "+" "math" "+" define-primitive
+ "-" "math" "-" define-primitive
+ "<" "math" "<" define-primitive
+ ">" "math" ">" define-primitive
+
+ "cons" "lists" "cons" define-primitive
+ "car" "lists" "car" define-primitive
+ "cdr" "lists" "cdr" define-primitive
+ "append" "lists" "lappend" define-primitive
+ "nil" "lists" "nil" define-primitive
+ "nil?" "lists" "nil?" define-primitive
+
+ "set" "lisp" "define-lisp-var" define-primitive
+
+ "(lambda (&rest xs) xs)" lisp-string>factor first "list" lisp-define
+ "(defmacro setq (var val) (list (quote set) (list (quote quote) var) val))" lisp-eval
+
+ <" (defmacro defun (name vars &rest body)
+ (list (quote setq) name (list (quote lambda) vars body))) "> lisp-eval
+
+ "(defmacro if (pred tr fl) (list (quote cond) (list pred tr) (list (quote #t) fl)))" lisp-eval
+ ;
+
+: <LISP
+ "LISP>" parse-multiline-string define-lisp-builtins
+ lisp-string>factor parsed \ call parsed ; parsing
\ No newline at end of file
] unit-test
-[ 887708070 ] [
+[ 70576473 ] [
T{ blum-blum-shub f 590695557939 811977232793 } clone [
32 random-bits
little-endian? [ <uint> reverse *uint ] unless
] with-random
] unit-test
-[ 5726770047455156646 ] [
+[ 5570804936418322777 ] [
T{ blum-blum-shub f 590695557939 811977232793 } clone [
64 random-bits
little-endian? [ <ulonglong> 4 group [ reverse ] map concat *ulonglong ] unless
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-
USING: arrays assocs kernel math math.order math.vectors namespaces
quotations sequences sequences.lib sequences.private strings unicode.case ;
IN: roman
<PRIVATE
-
: roman-digits ( -- seq )
{ "m" "cm" "d" "cd" "c" "xc" "l" "xl" "x" "ix" "v" "iv" "i" } ;
: roman-values ( -- seq )
{ 1000 900 500 400 100 90 50 40 10 9 5 4 1 } ;
-TUPLE: roman-range-error n ;
+ERROR: roman-range-error n ;
: roman-range-check ( n -- )
- dup 1 3999 between? [
- drop
- ] [
- roman-range-error boa throw
- ] if ;
+ dup 1 3999 between? [ drop ] [ roman-range-error ] if ;
: roman<= ( ch1 ch2 -- ? )
[ 1string roman-digits index ] bi@ >= ;
] [
first2 swap -
] if ;
-
PRIVATE>
: >roman ( n -- str )
] map sum ;
<PRIVATE
-
: 2roman> ( str1 str2 -- m n )
[ roman> ] bi@ ;
: binary-roman-op ( str1 str2 quot -- str3 )
>r 2roman> r> call >roman ; inline
-
PRIVATE>
: roman+ ( str1 str2 -- str3 )
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors furnace.actions http.server.dispatchers
+html.forms io.servers.connection namespaces prettyprint ;
+IN: webapps.ip
+
+TUPLE: ip-app < dispatcher ;
+
+: <display-ip-action> ( -- action )
+ <page-action>
+ [ remote-address get host>> "ip" set-value ] >>init
+ { ip-app "ip" } >>template ;
+
+: <ip-app> ( -- dispatcher )
+ ip-app new-dispatcher
+ <display-ip-action> "" add-responder ;
--- /dev/null
+<?xml version='1.0' ?>
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+<html>
+ <body>Your IP address is: <t:label t:name="ip" />
+ </body>
+</html>
+</t:chloe>
<t:style t:include="resource:extra/webapps/wiki/wiki.css" />
- <div class="navbar">
+ <table width="100%">
+ <tr>
+ <t:if t:value="sidebar">
+ <td valign="top" style="width: 210px;">
+ <div class="sidebar">
+ <t:bind t:name="sidebar">
+ <h2>
+ <t:a t:href="$wiki/view" t:query="title">
+ <t:label t:name="title" />
+ </t:a>
+ </h2>
- <t:a t:href="$wiki">Front Page</t:a>
- | <t:a t:href="$wiki/articles">All Articles</t:a>
- | <t:a t:href="$wiki/changes">Recent Changes</t:a>
- | <t:a t:href="$wiki/random">Random Article</t:a>
+ <t:html t:name="html" />
+ </t:bind>
+ </div>
+ </td>
+ </t:if>
- <t:if t:code="furnace.auth:logged-in?">
+ <td valign="top">
- <t:if t:code="furnace.auth.features.edit-profile:allow-edit-profile?">
- | <t:a t:href="$realm/edit-profile" t:aside="begin">Edit Profile</t:a>
- </t:if>
+ <div class="navbar">
- | <t:button t:action="$login-realm/logout" t:aside="begin" class="link-button link">Logout</t:button>
+ <t:a t:href="$wiki">Front Page</t:a>
+ | <t:a t:href="$wiki/articles">All Articles</t:a>
+ | <t:a t:href="$wiki/changes">Recent Changes</t:a>
+ | <t:a t:href="$wiki/random">Random Article</t:a>
- </t:if>
+ <t:if t:code="furnace.auth:logged-in?">
- </div>
+ <t:if t:code="furnace.auth.features.edit-profile:allow-edit-profile?">
+ | <t:a t:href="$realm/edit-profile" t:aside="begin">Edit Profile</t:a>
+ </t:if>
- <h1><t:write-title /></h1>
+ | <t:button t:action="$login-realm/logout" t:aside="begin" class="link-button link">Logout</t:button>
- <table width="100%">
- <tr>
- <td> <t:call-next-template /> </td>
- <t:if t:value="sidebar">
- <td valign="top">
- <t:bind t:name="sidebar">
- <h2>
- <t:a t:href="$wiki/view" t:query="title">
- <t:label t:name="title" />
- </t:a>
- </h2>
-
- <t:html t:name="html" />
- </t:bind>
- </td>
- </t:if>
+ </t:if>
+
+ </div>
+
+ <h1><t:write-title /></h1>
+
+ <t:call-next-template />
+
+ </td>
</tr>
<t:if t:value="footer">
<tr>
- <td>
+ <td colspan="2">
<t:bind t:name="footer">
<small>
<t:html t:name="html" />
border-width: 1px 1px 0 0;
}
+.sidebar {
+ padding: 4px;
+ margin: 4px;
+ border: 1px dashed grey;
+ background: #f5f1fd;
+ width: 200px;
+}
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 ;
}
.navbar {
- background-color: #eee;
+ background-color: #eeeee0;
padding: 5px;
border: 1px solid #ccc;
}
: 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- ;
matches ;
: <dfa-traverser> ( text regexp -- match )
- [ dfa-table>> ] [ traversal-flags>> ] bi
+ [ dfa-table>> ] [ dfa-traversal-flags>> ] bi
dfa-traverser new
swap >>traversal-flags
swap [ start-state>> >>current-state ] keep
namespaces threads shuffle opengl arrays ui.gadgets.worlds\r
combinators math.parser ui.gadgets ui.render opengl.gl ui\r
continuations io.files hints combinators.lib sequences.lib\r
- io.encodings.binary debugger math.order ;\r
+ io.encodings.binary debugger math.order accessors ;\r
\r
IN: ogg.player\r
\r
gadget ;\r
\r
: init-vorbis ( player -- )\r
- dup player-oy ogg_sync_init drop\r
- dup player-vi vorbis_info_init\r
- player-vc vorbis_comment_init ;\r
+ dup oy>> ogg_sync_init drop\r
+ dup vi>> vorbis_info_init\r
+ vc>> vorbis_comment_init ;\r
\r
: init-theora ( player -- )\r
- dup player-ti theora_info_init\r
- player-tc theora_comment_init ;\r
+ dup ti>> theora_info_init\r
+ tc>> theora_comment_init ;\r
\r
: init-sound ( player -- )\r
init-openal check-error\r
- 1 gen-buffers check-error over set-player-buffers\r
- 2 "uint" <c-array> over set-player-buffer-indexes\r
- 1 gen-sources check-error first swap set-player-source ;\r
+ 1 gen-buffers check-error >>buffers\r
+ 2 "uint" <c-array> >>buffer-indexes\r
+ 1 gen-sources check-error first >>source drop ;\r
\r
: <player> ( stream -- player )\r
- { set-player-stream } player construct\r
- 0 over set-player-vorbis\r
- 0 over set-player-theora\r
- 0 over set-player-video-time\r
- 0 over set-player-video-granulepos\r
- f over set-player-video-ready?\r
- f over set-player-audio-full?\r
- 0 over set-player-audio-index\r
- 0 over set-player-start-time\r
- audio-buffer-size "short" <c-array> over set-player-audio-buffer\r
- 0 over set-player-audio-granulepos\r
- f over set-player-playing?\r
- "ogg_packet" malloc-object over set-player-op\r
- "ogg_sync_state" malloc-object over set-player-oy\r
- "ogg_page" malloc-object over set-player-og\r
- "ogg_stream_state" malloc-object over set-player-vo\r
- "vorbis_info" malloc-object over set-player-vi\r
- "vorbis_dsp_state" malloc-object over set-player-vd\r
- "vorbis_block" malloc-object over set-player-vb\r
- "vorbis_comment" malloc-object over set-player-vc\r
- "ogg_stream_state" malloc-object over set-player-to\r
- "theora_info" malloc-object over set-player-ti\r
- "theora_comment" malloc-object over set-player-tc\r
- "theora_state" malloc-object over set-player-td\r
- "yuv_buffer" <c-object> over set-player-yuv\r
- "ogg_stream_state" <c-object> over set-player-temp-state\r
- dup init-sound\r
- dup init-vorbis\r
- dup init-theora ;\r
+ player new\r
+ swap >>stream\r
+ 0 >>vorbis\r
+ 0 >>theora\r
+ 0 >>video-time\r
+ 0 >>video-granulepos\r
+ f >>video-ready?\r
+ f >>audio-full?\r
+ 0 >>audio-index\r
+ 0 >>start-time\r
+ audio-buffer-size "short" <c-array> >>audio-buffer\r
+ 0 >>audio-granulepos\r
+ f >>playing?\r
+ "ogg_packet" malloc-object >>op\r
+ "ogg_sync_state" malloc-object >>oy\r
+ "ogg_page" malloc-object >>og\r
+ "ogg_stream_state" malloc-object >>vo\r
+ "vorbis_info" malloc-object >>vi\r
+ "vorbis_dsp_state" malloc-object >>vd\r
+ "vorbis_block" malloc-object >>vb\r
+ "vorbis_comment" malloc-object >>vc\r
+ "ogg_stream_state" malloc-object >>to\r
+ "theora_info" malloc-object >>ti\r
+ "theora_comment" malloc-object >>tc\r
+ "theora_state" malloc-object >>td\r
+ "yuv_buffer" <c-object> >>yuv\r
+ "ogg_stream_state" <c-object> >>temp-state\r
+ dup init-sound\r
+ dup init-vorbis\r
+ dup init-theora ;\r
\r
: num-channels ( player -- channels )\r
- player-vi vorbis_info-channels ;\r
+ vi>> vorbis_info-channels ;\r
\r
: al-channel-format ( player -- format )\r
- num-channels 1 = [ AL_FORMAT_MONO16 ] [ AL_FORMAT_STEREO16 ] if ;\r
+ num-channels 1 = AL_FORMAT_MONO16 AL_FORMAT_STEREO16 ? ;\r
\r
: get-time ( player -- time )\r
- dup player-start-time zero? [\r
- millis over set-player-start-time\r
+ dup start-time>> zero? [\r
+ millis >>start-time\r
] when\r
- player-start-time millis swap - 1000.0 /f ;\r
+ start-time>> millis swap - 1000.0 /f ;\r
\r
: clamp ( n -- n )\r
255 min 0 max ; inline\r
pick yuv_buffer-y_width >fixnum\r
[ yuv>rgb-pixel ] each-with4 ; inline\r
\r
-: yuv>rgb ( rgb yuv -- )\r
+: yuv>rgb ( rgb yuv -- )\r
0 -rot\r
dup yuv_buffer-y_height >fixnum\r
[ yuv>rgb-row ] each-with2\r
HINTS: yuv>rgb byte-array byte-array ;\r
\r
: process-video ( player -- player )\r
- dup player-gadget [\r
- dup { player-td player-yuv } get-slots theora_decode_YUVout drop\r
- dup player-rgb over player-yuv yuv>rgb\r
- dup player-gadget relayout-1 yield\r
+ dup gadget>> [\r
+ {\r
+ [ [ td>> ] [ yuv>> ] bi theora_decode_YUVout drop ]\r
+ [ [ rgb>> ] [ yuv>> ] bi yuv>rgb ]\r
+ [ gadget>> relayout-1 yield ]\r
+ [ ]\r
+ } cleave\r
] when ;\r
\r
: num-audio-buffers-processed ( player -- player n )\r
- dup player-source AL_BUFFERS_PROCESSED 0 <uint>\r
+ dup source>> AL_BUFFERS_PROCESSED 0 <uint>\r
[ alGetSourcei check-error ] keep *uint ;\r
\r
: append-new-audio-buffer ( player -- player )\r
- dup player-buffers 1 gen-buffers append over set-player-buffers\r
- [ [ player-buffers second ] keep al-channel-format ] keep\r
- [ player-audio-buffer dup length ] keep\r
- [ player-vi vorbis_info-rate alBufferData check-error ] keep\r
- [ player-source 1 ] keep\r
- [ player-buffers second <uint> alSourceQueueBuffers check-error ] keep ;\r
+ dup buffers>> 1 gen-buffers append >>buffers\r
+ [ [ buffers>> second ] keep al-channel-format ] keep\r
+ [ audio-buffer>> dup length ] keep\r
+ [ vi>> vorbis_info-rate alBufferData check-error ] keep\r
+ [ source>> 1 ] keep\r
+ [ buffers>> second <uint> alSourceQueueBuffers check-error ] keep ;\r
\r
: fill-processed-audio-buffer ( player n -- player )\r
#! n is the number of audio buffers processed\r
- over >r >r dup player-source r> pick player-buffer-indexes\r
+ over >r >r dup source>> r> pick buffer-indexes>>\r
[ alSourceUnqueueBuffers check-error ] keep\r
*uint dup r> swap >r al-channel-format rot\r
- [ player-audio-buffer dup length ] keep\r
- [ player-vi vorbis_info-rate alBufferData check-error ] keep\r
- [ player-source 1 ] keep\r
+ [ audio-buffer>> dup length ] keep\r
+ [ vi>> vorbis_info-rate alBufferData check-error ] keep\r
+ [ source>> 1 ] keep\r
r> <uint> swap >r alSourceQueueBuffers check-error r> ;\r
\r
: append-audio ( player -- player bool )\r
num-audio-buffers-processed {\r
- { [ over player-buffers length 1 = over zero? and ] [ drop append-new-audio-buffer t ] }\r
- { [ over player-buffers length 2 = over zero? and ] [ yield drop f ] }\r
+ { [ over buffers>> length 1 = over zero? and ] [ drop append-new-audio-buffer t ] }\r
+ { [ over buffers>> length 2 = over zero? and ] [ yield drop f ] }\r
[ fill-processed-audio-buffer t ]\r
} cond ;\r
\r
: start-audio ( player -- player bool )\r
- [ [ player-buffers first ] keep al-channel-format ] keep\r
- [ player-audio-buffer dup length ] keep\r
- [ player-vi vorbis_info-rate alBufferData check-error ] keep\r
- [ player-source 1 ] keep\r
- [ player-buffers first <uint> alSourceQueueBuffers check-error ] keep\r
- [ player-source alSourcePlay check-error ] keep\r
- t over set-player-playing? t ;\r
+ [ [ buffers>> first ] keep al-channel-format ] keep\r
+ [ audio-buffer>> dup length ] keep\r
+ [ vi>> vorbis_info-rate alBufferData check-error ] keep\r
+ [ source>> 1 ] keep\r
+ [ buffers>> first <uint> alSourceQueueBuffers check-error ] keep\r
+ [ source>> alSourcePlay check-error ] keep\r
+ t >>playing? t ;\r
\r
: process-audio ( player -- player bool )\r
- dup player-playing? [ append-audio ] [ start-audio ] if ;\r
+ dup playing?>> [ append-audio ] [ start-audio ] if ;\r
\r
: read-bytes-into ( dest size stream -- len )\r
#! Read the given number of bytes from a stream\r
4096 ; inline\r
\r
: sync-buffer ( player -- buffer size player )\r
- [ player-oy buffer-size ogg_sync_buffer buffer-size ] keep ;\r
+ [ oy>> buffer-size ogg_sync_buffer buffer-size ] keep ;\r
\r
: stream-into-buffer ( buffer size player -- len player )\r
- [ player-stream read-bytes-into ] keep ;\r
+ [ stream>> read-bytes-into ] keep ;\r
\r
: confirm-buffer ( len player -- player eof? )\r
- [ player-oy swap ogg_sync_wrote check-not-negative ] 2keep swap zero? ;\r
+ [ oy>> swap ogg_sync_wrote check-not-negative ] 2keep swap zero? ;\r
\r
: buffer-data ( player -- player eof? )\r
#! Take some compressed bitstream data and sync it for\r
\r
: queue-page ( player -- player )\r
#! Push a page into the stream for packetization\r
- [ { player-vo player-og } get-slots ogg_stream_pagein drop ] keep\r
- [ { player-to player-og } get-slots ogg_stream_pagein drop ] keep ;\r
+ [ [ vo>> ] [ og>> ] bi ogg_stream_pagein drop ]\r
+ [ [ to>> ] [ og>> ] bi ogg_stream_pagein drop ]\r
+ [ ] tri ;\r
\r
: retrieve-page ( player -- player bool )\r
#! Sync the streams and get a page. Return true if a page was\r
#! successfully retrieved.\r
- dup { player-oy player-og } get-slots ogg_sync_pageout 0 > ;\r
+ dup [ oy>> ] [ og>> ] bi ogg_sync_pageout 0 > ;\r
\r
: standard-initial-header? ( player -- player bool )\r
- dup player-og ogg_page_bos zero? not ;\r
+ dup og>> ogg_page_bos zero? not ;\r
\r
: ogg-stream-init ( player -- state player )\r
#! Init the encode/decode logical stream state\r
- [ player-temp-state ] keep\r
- [ player-og ogg_page_serialno ogg_stream_init check-not-negative ] 2keep ;\r
+ [ temp-state>> ] keep\r
+ [ og>> ogg_page_serialno ogg_stream_init check-not-negative ] 2keep ;\r
\r
: ogg-stream-pagein ( state player -- state player )\r
#! Add the incoming page to the stream state\r
- [ player-og ogg_stream_pagein drop ] 2keep ;\r
+ [ og>> ogg_stream_pagein drop ] 2keep ;\r
\r
: ogg-stream-packetout ( state player -- state player )\r
- [ player-op ogg_stream_packetout drop ] 2keep ;\r
+ [ op>> ogg_stream_packetout drop ] 2keep ;\r
\r
: decode-packet ( player -- state player )\r
ogg-stream-init ogg-stream-pagein ogg-stream-packetout ;\r
\r
: theora-header? ( player -- player bool )\r
#! Is the current page a theora header?\r
- dup { player-ti player-tc player-op } get-slots theora_decode_header 0 >= ;\r
+ dup [ ti>> ] [ tc>> ] [ op>> ] tri theora_decode_header 0 >= ;\r
\r
: is-theora-packet? ( player -- player bool )\r
- dup player-theora zero? [ theora-header? ] [ f ] if ;\r
+ dup theora>> zero? [ theora-header? ] [ f ] if ;\r
\r
: copy-to-theora-state ( state player -- player )\r
#! Copy the state to the theora state structure in the player\r
- [ player-to swap dup length memcpy ] keep ;\r
+ [ to>> swap dup length memcpy ] keep ;\r
\r
: handle-initial-theora-header ( state player -- player )\r
- copy-to-theora-state 1 over set-player-theora ;\r
+ copy-to-theora-state 1 >>theora ;\r
\r
: vorbis-header? ( player -- player bool )\r
#! Is the current page a vorbis header?\r
- dup { player-vi player-vc player-op } get-slots vorbis_synthesis_headerin 0 >= ;\r
+ dup [ vi>> ] [ vc>> ] [ op>> ] tri vorbis_synthesis_headerin 0 >= ;\r
\r
: is-vorbis-packet? ( player -- player bool )\r
- dup player-vorbis zero? [ vorbis-header? ] [ f ] if ;\r
+ dup vorbis>> zero? [ vorbis-header? ] [ f ] if ;\r
\r
: copy-to-vorbis-state ( state player -- player )\r
#! Copy the state to the vorbis state structure in the player\r
- [ player-vo swap dup length memcpy ] keep ;\r
+ [ vo>> swap dup length memcpy ] keep ;\r
\r
: handle-initial-vorbis-header ( state player -- player )\r
- copy-to-vorbis-state 1 over set-player-vorbis ;\r
+ copy-to-vorbis-state 1 >>vorbis ;\r
\r
: handle-initial-unknown-header ( state player -- player )\r
swap ogg_stream_clear drop ;\r
#! Return true if we need to decode vorbis due to there being\r
#! vorbis headers read from the stream but we don't have them all\r
#! yet.\r
- dup player-vorbis 1 2 between? not ;\r
+ dup vorbis>> 1 2 between? not ;\r
\r
: have-required-theora-headers? ( player -- player bool )\r
#! Return true if we need to decode theora due to there being\r
#! theora headers read from the stream but we don't have them all\r
#! yet.\r
- dup player-theora 1 2 between? not ;\r
+ dup theora>> 1 2 between? not ;\r
\r
: get-remaining-vorbis-header-packet ( player -- player bool )\r
- dup { player-vo player-op } get-slots ogg_stream_packetout {\r
+ dup [ vo>> ] [ op>> ] bi ogg_stream_packetout {\r
{ [ dup 0 < ] [ "Error parsing vorbis stream; corrupt stream?" throw ] }\r
{ [ dup zero? ] [ drop f ] }\r
{ [ t ] [ drop t ] }\r
} cond ;\r
\r
: get-remaining-theora-header-packet ( player -- player bool )\r
- dup { player-to player-op } get-slots ogg_stream_packetout {\r
+ dup [ to>> ] [ op>> ] bi ogg_stream_packetout {\r
{ [ dup 0 < ] [ "Error parsing theora stream; corrupt stream?" throw ] }\r
{ [ dup zero? ] [ drop f ] }\r
{ [ t ] [ drop t ] }\r
} cond ;\r
\r
: decode-remaining-vorbis-header-packet ( player -- player )\r
- dup { player-vi player-vc player-op } get-slots vorbis_synthesis_headerin zero? [\r
+ dup [ vi>> ] [ vc>> ] [ op>> ] tri vorbis_synthesis_headerin zero? [\r
"Error parsing vorbis stream; corrupt stream?" throw\r
] unless ;\r
\r
: decode-remaining-theora-header-packet ( player -- player )\r
- dup { player-ti player-tc player-op } get-slots theora_decode_header zero? [\r
+ dup [ ti>> ] [ tc>> ] [ op>> ] tri theora_decode_header zero? [\r
"Error parsing theora stream; corrupt stream?" throw\r
] unless ;\r
\r
: increment-vorbis-header-count ( player -- player )\r
- dup player-vorbis 1+ over set-player-vorbis ;\r
+ [ 1+ ] change-vorbis ;\r
\r
: increment-theora-header-count ( player -- player )\r
- dup player-theora 1+ over set-player-theora ;\r
+ [ 1+ ] change-theora ;\r
\r
: parse-remaining-vorbis-headers ( player -- player )\r
have-required-vorbis-headers? not [\r
] when ;\r
\r
: tear-down-vorbis ( player -- player )\r
- dup player-vi vorbis_info_clear\r
- dup player-vc vorbis_comment_clear ;\r
+ dup vi>> vorbis_info_clear\r
+ dup vc>> vorbis_comment_clear ;\r
\r
: tear-down-theora ( player -- player )\r
- dup player-ti theora_info_clear\r
- dup player-tc theora_comment_clear ;\r
+ dup ti>> theora_info_clear\r
+ dup tc>> theora_comment_clear ;\r
\r
: init-vorbis-codec ( player -- player )\r
- dup { player-vd player-vi } get-slots vorbis_synthesis_init drop\r
- dup { player-vd player-vb } get-slots vorbis_block_init drop ;\r
+ dup [ vd>> ] [ vi>> ] bi vorbis_synthesis_init drop\r
+ dup [ vd>> ] [ vb>> ] bi vorbis_block_init drop ;\r
\r
: init-theora-codec ( player -- player )\r
- dup { player-td player-ti } get-slots theora_decode_init drop\r
- dup player-ti theora_info-frame_width over player-ti theora_info-frame_height\r
- 4 * * <byte-array> over set-player-rgb ;\r
+ dup [ td>> ] [ ti>> ] bi theora_decode_init drop\r
+ dup ti>> theora_info-frame_width over ti>> theora_info-frame_height\r
+ 4 * * <byte-array> >>rgb ;\r
\r
\r
: display-vorbis-details ( player -- player )\r
[\r
"Ogg logical stream " %\r
- dup player-vo ogg_stream_state-serialno #\r
+ dup vo>> ogg_stream_state-serialno #\r
" is Vorbis " %\r
- dup player-vi vorbis_info-channels #\r
+ dup vi>> vorbis_info-channels #\r
" channel " %\r
- dup player-vi vorbis_info-rate #\r
+ dup vi>> vorbis_info-rate #\r
" Hz audio." %\r
] "" make print ;\r
\r
: display-theora-details ( player -- player )\r
[\r
"Ogg logical stream " %\r
- dup player-to ogg_stream_state-serialno #\r
+ dup to>> ogg_stream_state-serialno #\r
" is Theora " %\r
- dup player-ti theora_info-width #\r
+ dup ti>> theora_info-width #\r
"x" %\r
- dup player-ti theora_info-height #\r
+ dup ti>> theora_info-height #\r
" " %\r
- dup player-ti theora_info-fps_numerator\r
- over player-ti theora_info-fps_denominator /f #\r
+ dup ti>> theora_info-fps_numerator\r
+ over ti>> theora_info-fps_denominator /f #\r
" fps video" %\r
] "" make print ;\r
\r
: initialize-decoder ( player -- player )\r
- dup player-vorbis zero? [ tear-down-vorbis ] [ init-vorbis-codec display-vorbis-details ] if\r
- dup player-theora zero? [ tear-down-theora ] [ init-theora-codec display-theora-details ] if ;\r
+ dup vorbis>> zero? [ tear-down-vorbis ] [ init-vorbis-codec display-vorbis-details ] if\r
+ dup theora>> zero? [ tear-down-theora ] [ init-theora-codec display-theora-details ] if ;\r
\r
: sync-pages ( player -- player )\r
retrieve-page [\r
] when ;\r
\r
: audio-buffer-not-ready? ( player -- player bool )\r
- dup player-vorbis zero? not over player-audio-full? not and ;\r
+ dup vorbis>> zero? not over audio-full?>> not and ;\r
\r
: pending-decoded-audio? ( player -- player pcm len bool )\r
- f <void*> 2dup >r player-vd r> vorbis_synthesis_pcmout dup 0 > ;\r
+ f <void*> 2dup >r vd>> r> vorbis_synthesis_pcmout dup 0 > ;\r
\r
: buffer-space-available ( player -- available )\r
- audio-buffer-size swap player-audio-index - ;\r
+ audio-buffer-size swap audio-index>> - ;\r
\r
: samples-to-read ( player available len -- numread )\r
>r swap num-channels / r> min ;\r
: each-with3 ( obj obj obj seq quot -- ) 3 each-withn ; inline\r
\r
: add-to-buffer ( player val -- )\r
- over player-audio-index pick player-audio-buffer set-short-nth\r
- dup player-audio-index 1+ swap set-player-audio-index ;\r
+ over audio-index>> pick audio-buffer>> set-short-nth\r
+ [ 1+ ] change-audio-index drop ;\r
\r
: get-audio-value ( pcm sample channel -- value )\r
rot *void* void*-nth float-nth ;\r
pick [ buffer-space-available swap ] keep -rot samples-to-read\r
pick over >r >r process-samples r> r> swap\r
! numread player\r
- dup player-audio-index audio-buffer-size = [\r
- t over set-player-audio-full?\r
+ dup audio-index>> audio-buffer-size = [\r
+ t >>audio-full?\r
] when\r
- dup player-vd vorbis_dsp_state-granulepos dup 0 >= [\r
+ dup vd>> vorbis_dsp_state-granulepos dup 0 >= [\r
! numtoread player granulepos\r
#! This is wrong: fix\r
- pick - over set-player-audio-granulepos\r
+ pick - >>audio-granulepos\r
] [\r
! numtoread player granulepos\r
- pick + over set-player-audio-granulepos\r
+ pick + >>audio-granulepos\r
] if\r
- [ player-vd swap vorbis_synthesis_read drop ] keep ;\r
+ [ vd>> swap vorbis_synthesis_read drop ] keep ;\r
\r
: no-pending-audio ( player -- player bool )\r
#! No pending audio. Is there a pending packet to decode.\r
- dup { player-vo player-op } get-slots ogg_stream_packetout 0 > [\r
- dup { player-vb player-op } get-slots vorbis_synthesis 0 = [\r
- dup { player-vd player-vb } get-slots vorbis_synthesis_blockin drop\r
+ dup [ vo>> ] [ op>> ] bi ogg_stream_packetout 0 > [\r
+ dup [ vb>> ] [ op>> ] bi vorbis_synthesis 0 = [\r
+ dup [ vd>> ] [ vb>> ] bi vorbis_synthesis_blockin drop\r
] when\r
t\r
] [\r
] when ;\r
\r
: video-buffer-not-ready? ( player -- player bool )\r
- dup player-theora zero? not over player-video-ready? not and ;\r
+ dup theora>> zero? not over video-ready?>> not and ;\r
\r
: decode-video ( player -- player )\r
video-buffer-not-ready? [\r
- dup { player-to player-op } get-slots ogg_stream_packetout 0 > [\r
- dup { player-td player-op } get-slots theora_decode_packetin drop\r
- dup player-td theora_state-granulepos over set-player-video-granulepos\r
- dup { player-td player-video-granulepos } get-slots theora_granule_time\r
- over set-player-video-time\r
- t over set-player-video-ready?\r
+ dup [ to>> ] [ op>> ] bi ogg_stream_packetout 0 > [\r
+ dup [ td>> ] [ op>> ] bi theora_decode_packetin drop\r
+ dup td>> theora_state-granulepos >>video-granulepos\r
+ dup [ td>> ] [ video-granulepos>> ] bi theora_granule_time\r
+ >>video-time\r
+ t >>video-ready?\r
decode-video\r
] when\r
] when ;\r
get-more-header-data sync-pages\r
decode-audio\r
decode-video\r
- dup player-audio-full? [\r
+ dup audio-full?>> [\r
process-audio [\r
- f over set-player-audio-full?\r
- 0 over set-player-audio-index\r
+ f >>audio-full?\r
+ 0 >>audio-index\r
] when\r
] when\r
- dup player-video-ready? [\r
- dup player-video-time over get-time - dup 0.0 < [\r
+ dup video-ready?>> [\r
+ dup video-time>> over get-time - dup 0.0 < [\r
-0.1 > [ process-video ] when\r
- f over set-player-video-ready?\r
+ f >>video-ready?\r
] [\r
drop\r
] if\r
decode ;\r
\r
: free-malloced-objects ( player -- player )\r
- [ player-op free ] keep\r
- [ player-oy free ] keep\r
- [ player-og free ] keep\r
- [ player-vo free ] keep\r
- [ player-vi free ] keep\r
- [ player-vd free ] keep\r
- [ player-vb free ] keep\r
- [ player-vc free ] keep\r
- [ player-to free ] keep\r
- [ player-ti free ] keep\r
- [ player-tc free ] keep\r
- [ player-td free ] keep ;\r
+ {\r
+ [ op>> free ]\r
+ [ oy>> free ]\r
+ [ og>> free ]\r
+ [ vo>> free ]\r
+ [ vi>> free ]\r
+ [ vd>> free ]\r
+ [ vb>> free ]\r
+ [ vc>> free ]\r
+ [ to>> free ]\r
+ [ ti>> free ]\r
+ [ tc>> free ]\r
+ [ td>> free ]\r
+ [ ]\r
+ } cleave ;\r
\r
\r
: unqueue-openal-buffers ( player -- player )\r
[\r
\r
- num-audio-buffers-processed over player-source rot player-buffer-indexes swapd\r
+ num-audio-buffers-processed over source>> rot buffer-indexes>> swapd\r
alSourceUnqueueBuffers check-error\r
] keep ;\r
\r
: delete-openal-buffers ( player -- player )\r
[\r
- player-buffers [\r
+ buffers>> [\r
1 swap <uint> alDeleteBuffers check-error\r
] each\r
] keep ;\r
\r
: delete-openal-source ( player -- player )\r
- [ player-source 1 swap <uint> alDeleteSources check-error ] keep ;\r
+ [ source>> 1 swap <uint> alDeleteSources check-error ] keep ;\r
\r
: cleanup ( player -- player )\r
free-malloced-objects\r
\r
: wait-for-sound ( player -- player )\r
#! Waits for the openal to finish playing remaining sounds\r
- dup player-source AL_SOURCE_STATE 0 <int> [ alGetSourcei check-error ] keep\r
+ dup source>> AL_SOURCE_STATE 0 <int> [ alGetSourcei check-error ] keep\r
*int AL_PLAYING = [\r
100 sleep\r
wait-for-sound\r
] when ;\r
\r
-TUPLE: theora-gadget player ;\r
+TUPLE: theora-gadget < gadget player ;\r
\r
: <theora-gadget> ( player -- gadget )\r
- theora-gadget construct-gadget\r
- [ set-theora-gadget-player ] keep ;\r
+ theora-gadget new-gadget\r
+ swap >>player ;\r
\r
M: theora-gadget pref-dim*\r
- theora-gadget-player\r
- player-ti dup theora_info-width swap theora_info-height 2array ;\r
+ player>>\r
+ ti>> dup theora_info-width swap theora_info-height 2array ;\r
\r
M: theora-gadget draw-gadget* ( gadget -- )\r
0 0 glRasterPos2i\r
1.0 -1.0 glPixelZoom\r
GL_UNPACK_ALIGNMENT 1 glPixelStorei\r
[ pref-dim* first2 GL_RGB GL_UNSIGNED_BYTE ] keep\r
- theora-gadget-player player-rgb glDrawPixels ;\r
+ player>> rgb>> glDrawPixels ;\r
\r
: initialize-gui ( gadget -- )\r
"Theora Player" open-window ;\r
parse-initial-headers\r
parse-remaining-headers\r
initialize-decoder\r
- dup player-gadget [ initialize-gui ] when*\r
+ dup gadget>> [ initialize-gui ] when*\r
[ decode ] try\r
wait-for-sound\r
cleanup\r
\r
: play-theora-stream ( stream -- )\r
<player>\r
- dup <theora-gadget> over set-player-gadget\r
+ dup <theora-gadget> >>gadget\r
play-ogg ;\r
\r
: play-theora-file ( filename -- )\r
binary <file-reader> play-theora-stream ;\r
-\r
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;
+}
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);
projects / factor.git / commitdiff