steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Bruno Deferrari 2008-09-11 02:12:59 -03:00
parent 4022e1b236 61a1625880
commit 5dad0c278a
52 changed files with 913 additions and 681 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
Factor.app/Contents/Frameworks/libfreetype.6.dylib Normal file → Executable file
View File

Binary file not shown.

16
basis/base64/base64.factor
View File

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

2
basis/bootstrap/image/image.factor
View File

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

63
basis/cocoa/messages/messages.factor
View File

@ -4,7 +4,8 @@ USING: accessors alien alien.c-types alien.strings
arrays assocs combinators compiler kernel
math namespaces parser prettyprint prettyprint.sections
quotations sequences strings words cocoa.runtime io macros
memoize debugger io.encodings.ascii effects compiler.generator ;
memoize debugger io.encodings.ascii effects compiler.generator
libc libc.private ;
IN: cocoa.messages
: make-sender ( method function -- quot )
@ -36,7 +37,7 @@ super-message-senders global [ H{ } assoc-like ] change-at
: <super> ( receiver -- super )
"objc-super" <c-object> [
>r dup objc-object-isa objc-class-super-class r>
>r dup object_getClass class_getSuperclass r>
set-objc-super-class
] keep
[ set-objc-super-receiver ] keep ;
@ -101,11 +102,6 @@ MACRO: (send) ( selector super? -- quot )
: objc-meta-class ( string -- class )
\ objc_getMetaClass (objc-class) ;
: method-arg-type ( method i -- type )
f <void*> 0 <int> over
>r method_getArgumentInfo drop
r> *void* ascii alien>string ;
SYMBOL: objc>alien-types
H{
@ -134,12 +130,21 @@ SYMBOL: alien>objc-types
objc>alien-types get [ swap ] assoc-map
! A hack...
H{
{ "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 <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 ;
@ -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 ;

72
basis/cocoa/runtime/runtime.factor
View File

@ -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 ) ;

99
basis/cocoa/subclassing/subclassing.factor
View File

@ -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* ;
: <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 [
@ -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 ;

41
basis/cocoa/types/types.factor
View File

@ -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" }

4
basis/compiler/generator/generator.factor
View File

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

23
basis/compiler/tests/alien.factor
View File

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

5
basis/compiler/tree/branch-fusion/branch-fusion.factor
View File

@ -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' ) ;

5
basis/compiler/tree/loop/inversion/inversion.factor
View File

@ -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' ) ;

19
basis/compiler/tree/optimizer/optimizer.factor
View File

@ -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 ;

8
basis/core-foundation/core-foundation.factor
View File

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

2
basis/cpu/architecture/architecture.factor
View File

@ -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 ;

28
basis/db/db-docs.factor
View File

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

85
basis/db/db.factor
View File

@ -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 <simple-statement> [ default-query ] with-disposal ;
@ -145,3 +127,20 @@ HOOK: rollback-transaction db ( -- )
[ sql-command ] each
! ] with-transaction
] if ;
SYMBOL: in-transaction
HOOK: begin-transaction db ( -- )
HOOK: commit-transaction db ( -- )
HOOK: rollback-transaction db ( -- )
M: db begin-transaction ( -- ) "BEGIN" sql-command ;
M: db commit-transaction ( -- ) "COMMIT" sql-command ;
M: db rollback-transaction ( -- ) "ROLLBACK" sql-command ;
: in-transaction? ( -- ? ) in-transaction get ;
: with-transaction ( quot -- )
t in-transaction [
begin-transaction
[ ] [ rollback-transaction ] cleanup commit-transaction
] with-variable ;

23
basis/db/postgresql/postgresql.factor
View File

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

14
basis/db/queries/queries.factor
View File

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

20
basis/db/sql/sql.factor
View File

@ -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 -- )
{

7
basis/db/sqlite/sqlite.factor
View File

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

6
basis/db/tuples/tuples-docs.factor
View File

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

30
basis/db/tuples/tuples.factor
View File

@ -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: <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' )
@ -48,12 +48,12 @@ HOOK: <count-statement> db ( tuple class groups -- n )
HOOK: insert-tuple* db ( tuple statement -- )
GENERIC: eval-generator ( singleton -- obj )
GENERIC: eval-generator ( singleton -- object )
: resulting-tuple ( class row out-params -- tuple )
: resulting-tuple ( exemplar-tuple row out-params -- tuple )
rot class new [
[
>r slot-name>> r> set-slot-named
[ slot-name>> ] dip set-slot-named
] curry 2each
] keep ;
@ -65,10 +65,10 @@ GENERIC: eval-generator ( singleton -- obj )
: query-modify-tuple ( tuple statement -- )
[ query-results [ sql-row-typed ] with-disposal ] keep
out-params>> rot [
>r slot-name>> r> set-slot-named
[ slot-name>> ] dip set-slot-named
] curry 2each ;
: with-disposals ( seq quot -- )
: with-disposals ( object quotation -- )
over sequence? [
[ with-disposal ] curry each
] [
@ -121,7 +121,7 @@ GENERIC: eval-generator ( singleton -- obj )
[ [ bind-tuple ] [ query-tuples ] 2bi ] with-disposal ;
: query ( tuple query -- tuples )
>r dup dup class r> <query> do-select ;
[ dup dup class ] dip <query> do-select ;
: select-tuples ( tuple -- tuples )
dup dup class <select-by-slots-statement> do-select ;

79
basis/db/types/types-docs.factor
View File

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

24
basis/db/types/types.factor
View File

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

13
basis/farkup/farkup-tests.factor
View File

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

10
basis/farkup/farkup.factor
View File

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

8
basis/random/random-docs.factor
View File

@ -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" } }

8
basis/random/random-tests.factor
View File

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

9
basis/random/random.factor
View File

@ -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 ;

11
basis/smtp/smtp-docs.factor
View File

@ -20,8 +20,7 @@ HELP: <email>
HELP: send-email
{ $values { "email" email } }
{ $description "Sends an " { $link email } " object to an STMP server stored in the " { $link smtp-server } " variable. The required slots are " { $snippet "from" } " and " { $snippet "to" } "." }
{ $description "Sends an " { $link email } " object to an STMP server stored in the " { $link smtp-server } " variable. The required slots are " { $slot "from" } " and " { $slot "to" } "." }
{ $examples
{ $unchecked-example "USING: accessors smtp ;"
"<email>"
@ -37,9 +36,5 @@ HELP: send-email
} ;
ARTICLE: "smtp" "SMTP Client Library"
"Start by creating a new email object:"
{ $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 } ;

1
basis/ui/cocoa/views/views.factor
View File

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

6
core/kernel/kernel-tests.factor
View File

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

191
core/sequences/sequences-docs.factor
View File

@ -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 }"
}
} ;

8
core/sequences/sequences.factor
View File

@ -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
: <flat-slice> ( seq -- slice )
dup slice? [ { } like ] when 0 over length rot <slice> ;

2
extra/benchmark/mandel/colors/colors.factor
View File

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

43
extra/benchmark/mandel/mandel.factor
View File

@ -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 <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 ;

12
extra/benchmark/mandel/params/params.factor
View File

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

53
extra/lisp/lisp-tests.factor
View File

@ -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 } [
<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

64
extra/lisp/lisp.factor
View File

@ -3,7 +3,7 @@
USING: kernel peg sequences arrays strings combinators.lib
namespaces combinators math locals locals.private locals.backend accessors
vectors syntax lisp.parser assocs parser sequences.lib words
quotations fry lists summary combinators.short-circuit continuations ;
quotations fry lists summary combinators.short-circuit continuations multiline ;
IN: lisp
DEFER: convert-form
@ -46,7 +46,7 @@ DEFER: define-lisp-macro
: rest-lambda ( body vars -- quot )
"&rest" swap [ remove ] [ index ] 2bi
[ localize-lambda <lambda> lambda-rewrite call ] dip
swap '[ , cut '[ @ , seq>list ] call , call call ] ;
swap '[ , cut '[ @ , seq>list ] call , call call ] 1quotation ;
: normal-lambda ( body vars -- quot )
localize-lambda <lambda> lambda-rewrite '[ @ compose call call ] 1quotation ;
@ -59,18 +59,20 @@ PRIVATE>
cadr 1quotation ;
: convert-defmacro ( cons -- quot )
cdr [ car ] keep [ convert-lambda ] [ car name>> ] bi define-lisp-macro 1quotation ;
cdr [ convert-lambda ] [ car name>> ] bi define-lisp-macro [ ] ;
: macro-expand ( cons -- quot )
uncons [ list>seq >quotation ] [ lookup-macro ] bi* call call ;
: (expand-macros) ( cons -- cons )
<PRIVATE
: (expand-macros) ( cons -- cons )
[ dup list? [ (expand-macros) dup car lisp-macro? [ macro-expand ] when ] when ] lmap ;
: 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 ] ;
@ -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
;
: <LISP
"LISP>" parse-multiline-string define-lisp-builtins
lisp-string>factor parsed \ call parsed ; parsing

4
extra/random/blum-blum-shub/blum-blum-shub-tests.factor
View File

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

13
extra/roman/roman.factor
View File

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

16
extra/webapps/ip/ip.factor Normal file
View File

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

7
extra/webapps/ip/ip.xml Normal file
View File

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

73
extra/webapps/wiki/wiki-common.xml
View File

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

7
extra/webapps/wiki/wiki.css
View File

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

2
extra/websites/concatenative/concatenative.factor
View File

@ -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 ;

2
extra/websites/concatenative/page.css
View File

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

2
unfinished/regexp2/regexp2.factor
View File

@ -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- ;

2
unfinished/regexp2/traversal/traversal.factor
View File

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

341
unmaintained/ogg/player/player.factor
View File

@ -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" <c-array> over set-player-buffer-indexes
1 gen-sources check-error first swap set-player-source ;
1 gen-buffers check-error >>buffers
2 "uint" <c-array> >>buffer-indexes
1 gen-sources check-error first >>source drop ;
: <player> ( 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" <c-array> 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" <c-object> over set-player-yuv
"ogg_stream_state" <c-object> 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" <c-array> >>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" <c-object> >>yuv
"ogg_stream_state" <c-object> >>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 <uint>
dup source>> AL_BUFFERS_PROCESSED 0 <uint>
[ alGetSourcei check-error ] keep *uint ;
: append-new-audio-buffer ( player -- player )
dup player-buffers 1 gen-buffers append over set-player-buffers
[ [ 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 <uint> 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 <uint> alSourceQueueBuffers check-error ] keep ;
: fill-processed-audio-buffer ( player n -- player )
#! n is the number of audio buffers processed
over >r >r dup player-source r> pick player-buffer-indexes
over >r >r dup source>> r> pick buffer-indexes>>
[ alSourceUnqueueBuffers check-error ] keep
*uint dup r> swap >r al-channel-format rot
[ player-audio-buffer dup length ] keep
[ 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> <uint> swap >r alSourceQueueBuffers check-error r> ;
: append-audio ( player -- player bool )
num-audio-buffers-processed {
{ [ over player-buffers length 1 = over zero? and ] [ drop append-new-audio-buffer t ] }
{ [ over 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 <uint> 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 <uint> 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 * * <byte-array> 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 * * <byte-array> >>rgb ;
: display-vorbis-details ( player -- player )
[
"Ogg logical stream " %
dup player-vo ogg_stream_state-serialno #
dup vo>> ogg_stream_state-serialno #
" is Vorbis " %
dup player-vi vorbis_info-channels #
dup vi>> vorbis_info-channels #
" channel " %
dup player-vi vorbis_info-rate #
dup vi>> vorbis_info-rate #
" Hz audio." %
] "" make print ;
: display-theora-details ( player -- player )
[
"Ogg logical stream " %
dup player-to ogg_stream_state-serialno #
dup to>> ogg_stream_state-serialno #
" is Theora " %
dup player-ti theora_info-width #
dup ti>> theora_info-width #
"x" %
dup player-ti theora_info-height #
dup ti>> theora_info-height #
" " %
dup player-ti theora_info-fps_numerator
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 <void*> 2dup >r player-vd r> vorbis_synthesis_pcmout dup 0 > ;
f <void*> 2dup >r vd>> r> vorbis_synthesis_pcmout dup 0 > ;
: buffer-space-available ( player -- available )
audio-buffer-size swap player-audio-index - ;
audio-buffer-size swap audio-index>> - ;
: samples-to-read ( player available len -- numread )
>r swap num-channels / r> min ;
@ -442,8 +447,8 @@ HINTS: yuv>rgb byte-array byte-array ;
: each-with3 ( obj obj obj seq quot -- ) 3 each-withn ; inline
: add-to-buffer ( player val -- )
over player-audio-index pick player-audio-buffer set-short-nth
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 <uint> alDeleteBuffers check-error
] each
] keep ;
: delete-openal-source ( player -- player )
[ player-source 1 swap <uint> alDeleteSources check-error ] keep ;
[ source>> 1 swap <uint> alDeleteSources check-error ] keep ;
: cleanup ( player -- player )
free-malloced-objects
@ -572,28 +580,28 @@ HINTS: yuv>rgb byte-array byte-array ;
: wait-for-sound ( player -- player )
#! Waits for the openal to finish playing remaining sounds
dup player-source AL_SOURCE_STATE 0 <int> [ alGetSourcei check-error ] keep
dup source>> AL_SOURCE_STATE 0 <int> [ alGetSourcei check-error ] keep
*int AL_PLAYING = [
100 sleep
wait-for-sound
] when ;
TUPLE: theora-gadget player ;
TUPLE: theora-gadget < gadget player ;
: <theora-gadget> ( player -- gadget )
theora-gadget construct-gadget
[ 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 -- )
<player>
dup <theora-gadget> over set-player-gadget
dup <theora-gadget> >>gadget
play-ogg ;
: play-theora-file ( filename -- )
binary <file-reader> play-theora-stream ;

7
vm/ffi_test.c
View File

@ -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;
}

4
vm/ffi_test.h
View File

@ -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);