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

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

db4
Doug Coleman 2009-09-08 13:22:52 -05:00
parent 55f2185532 2d46cfdf9e
commit 942fb7b048
1565 changed files with 40573 additions and 13952 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
Factor.app/Contents/Resources/English.lproj/Factor.nib/info.nib generated
View File

@ -3,15 +3,13 @@
<plist version="1.0">
<dict>
<key>IBFramework Version</key>
<string>629</string>
<string>677</string>
<key>IBOldestOS</key>
<integer>5</integer>
<key>IBOpenObjects</key>
<array>
<integer>305</integer>
</array>
<array/>
<key>IBSystem Version</key>
<string>9G55</string>
<string>9J61</string>
<key>targetFramework</key>
<string>IBCocoaFramework</string>
</dict>

BIN
Factor.app/Contents/Resources/English.lproj/Factor.nib/keyedobjects.nib generated
View File

Binary file not shown.

49
Factor.app/Contents/Resources/English.lproj/MiniFactor.nib/classes.nib generated
View File

@ -1,17 +1,32 @@
{
IBClasses = (
{
ACTIONS = {
newFactorWorkspace = id;
runFactorFile = id;
saveFactorImage = id;
saveFactorImageAs = id;
showFactorHelp = id;
};
CLASS = FirstResponder;
LANGUAGE = ObjC;
SUPERCLASS = NSObject;
}
);
IBVersion = 1;
}
<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
<plist version="1.0">
<dict>
<key>IBClasses</key>
<array>
<dict>
<key>ACTIONS</key>
<dict>
<key>newFactorWorkspace</key>
<string>id</string>
<key>runFactorFile</key>
<string>id</string>
<key>saveFactorImage</key>
<string>id</string>
<key>saveFactorImageAs</key>
<string>id</string>
<key>showFactorHelp</key>
<string>id</string>
</dict>
<key>CLASS</key>
<string>FirstResponder</string>
<key>LANGUAGE</key>
<string>ObjC</string>
<key>SUPERCLASS</key>
<string>NSObject</string>
</dict>
</array>
<key>IBVersion</key>
<string>1</string>
</dict>
</plist>

19
Factor.app/Contents/Resources/English.lproj/MiniFactor.nib/info.nib generated
View File

@ -1,21 +1,18 @@
<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE plist PUBLIC "-//Apple Computer//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
<plist version="1.0">
<dict>
<key>IBDocumentLocation</key>
<string>1266 155 525 491 0 0 2560 1578 </string>
<key>IBEditorPositions</key>
<dict>
<key>29</key>
<string>326 905 270 44 0 0 2560 1578 </string>
</dict>
<key>IBFramework Version</key>
<string>439.0</string>
<string>677</string>
<key>IBOldestOS</key>
<integer>5</integer>
<key>IBOpenObjects</key>
<array>
<integer>29</integer>
<integer>293</integer>
</array>
<key>IBSystem Version</key>
<string>8R218</string>
<string>9J61</string>
<key>targetFramework</key>
<string>IBCocoaFramework</string>
</dict>
</plist>

BIN
Factor.app/Contents/Resources/English.lproj/MiniFactor.nib/keyedobjects.nib generated
View File

Binary file not shown.

7
README.txt
View File

@ -55,10 +55,13 @@ For X11 support, you need recent development libraries for libc,
Pango, X11, and OpenGL. On a Debian-derived Linux distribution
(like Ubuntu), you can use the following line to grab everything:
sudo apt-get install libc6-dev libpango-1.0-dev libx11-dev
sudo apt-get install libc6-dev libpango1.0-dev libx11-dev libgl1-mesa-dev
Note that if you are using a proprietary OpenGL driver, you should
probably leave out the last package in the list.
If your DISPLAY environment variable is set, the UI will start
automatically:
automatically when you run Factor:
./factor

2
basis/alarms/alarms-tests.factor
View File

@ -1,6 +1,6 @@
IN: alarms.tests
USING: alarms alarms.private kernel calendar sequences
tools.test threads concurrency.count-downs ;
IN: alarms.tests
[ ] [
1 <count-down>

14
basis/alarms/alarms.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays calendar combinators generic init
kernel math namespaces sequences heaps boxes threads
quotations assocs math.order ;
USING: accessors assocs boxes calendar
combinators.short-circuit fry heaps init kernel math.order
namespaces quotations threads ;
IN: alarms
TUPLE: alarm
@ -21,21 +21,21 @@ SYMBOL: alarm-thread
ERROR: bad-alarm-frequency frequency ;
: check-alarm ( frequency/f -- frequency/f )
dup [ duration? ] [ not ] bi or [ bad-alarm-frequency ] unless ;
dup { [ duration? ] [ not ] } 1|| [ bad-alarm-frequency ] unless ;
: <alarm> ( quot time frequency -- alarm )
check-alarm <box> alarm boa ;
: register-alarm ( alarm -- )
dup dup time>> alarms get-global heap-push*
swap entry>> >box
[ dup time>> alarms get-global heap-push* ]
[ entry>> >box ] bi
notify-alarm-thread ;
: alarm-expired? ( alarm now -- ? )
[ time>> ] dip before=? ;
: reschedule-alarm ( alarm -- )
dup [ swap interval>> time+ now max ] change-time register-alarm ;
dup '[ _ interval>> time+ now max ] change-time register-alarm ;
: call-alarm ( alarm -- )
[ entry>> box> drop ]

7
basis/alien/arrays/arrays-docs.factor Normal file → Executable file
View File

@ -4,4 +4,9 @@ USING: help.syntax help.markup byte-arrays alien.c-types ;
ARTICLE: "c-arrays" "C arrays"
"C arrays are allocated in the same manner as other C data; see " { $link "c-byte-arrays" } " and " { $link "malloc" } "."
$nl
"C type specifiers for array types are documented in " { $link "c-types-specs" } "." ;
"C type specifiers for array types are documented in " { $link "c-types-specs" } "."
$nl
"Specialized sequences are provided for accessing memory as an array of primitive type values. These sequences are implemented in the " { $vocab-link "specialized-arrays" } " vocabulary set. They can also be loaded and constructed through their primitive C types:"
{ $subsection require-c-array }
{ $subsection <c-array> }
{ $subsection <c-direct-array> } ;

26
basis/alien/arrays/arrays.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.strings alien.c-types alien.accessors alien.structs
arrays words sequences math kernel namespaces fry libc cpu.architecture
io.encodings.utf8 ;
io.encodings.utf8 accessors ;
IN: alien.arrays
UNION: value-type array struct-type ;
@ -11,7 +11,12 @@ M: array c-type ;
M: array c-type-class drop object ;
M: array heap-size unclip [ product ] [ heap-size ] bi* * ;
M: array c-type-boxed-class drop object ;
: array-length ( seq -- n )
[ dup word? [ def>> call( -- object ) ] when ] [ * ] map-reduce ;
M: array heap-size unclip [ array-length ] [ heap-size ] bi* * ;
M: array c-type-align first c-type-align ;
@ -27,11 +32,15 @@ M: array box-return drop "void*" box-return ;
M: array stack-size drop "void*" stack-size ;
M: array c-type-boxer-quot drop [ ] ;
M: array c-type-boxer-quot
unclip
[ array-length ]
[ [ require-c-array ] keep ] bi*
[ <c-direct-array> ] 2curry ;
M: array c-type-unboxer-quot drop [ >c-ptr ] ;
M: value-type c-type-reg-class drop int-regs ;
M: value-type c-type-rep drop int-rep ;
M: value-type c-type-getter
drop [ swap <displaced-alien> ] ;
@ -45,8 +54,9 @@ PREDICATE: string-type < pair
M: string-type c-type ;
M: string-type c-type-class
drop object ;
M: string-type c-type-class drop object ;
M: string-type c-type-boxed-class drop object ;
M: string-type heap-size
drop "void*" heap-size ;
@ -72,8 +82,8 @@ M: string-type box-return
M: string-type stack-size
drop "void*" stack-size ;
M: string-type c-type-reg-class
drop int-regs ;
M: string-type c-type-rep
drop int-rep ;
M: string-type c-type-boxer
drop "void*" c-type-boxer ;

26
basis/alien/c-types/c-types-docs.factor Normal file → Executable file
View File

@ -1,7 +1,7 @@
IN: alien.c-types
USING: alien help.syntax help.markup libc kernel.private
byte-arrays math strings hashtables alien.syntax alien.strings sequences
io.encodings.string debugger destructors ;
io.encodings.string debugger destructors vocabs.loader ;
HELP: <c-type>
{ $values { "type" hashtable } }
@ -49,11 +49,10 @@ HELP: c-setter
{ $errors "Throws an error if the type does not exist." } ;
HELP: <c-array>
{ $values { "n" "a non-negative integer" } { "type" "a C type" } { "array" byte-array } }
{ $values { "len" "a non-negative integer" } { "c-type" "a C type" } { "array" byte-array } }
{ $description "Creates a byte array large enough to hold " { $snippet "n" } " values of a C type." }
{ $errors "Throws an error if the type does not exist or the requested size is negative." } ;
{ <c-array> malloc-array } related-words
{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, a " { $link specialized-array-vocab-not-loaded } " error will be thrown. The vocabulary can be loaded with a " { $link POSTPONE: USING: } " form as usual, or with the " { $link require-c-array } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary set for details on the underlying sequence type constructed." }
{ $errors "Throws an error if the type does not exist, the necessary specialized array vocabulary is not loaded, or the requested size is negative." } ;
HELP: <c-object>
{ $values { "type" "a C type" } { "array" byte-array } }
@ -73,9 +72,10 @@ HELP: byte-array>memory
HELP: malloc-array
{ $values { "n" "a non-negative integer" } { "type" "a C type" } { "alien" alien } }
{ $description "Allocates an unmanaged memory block large enough to hold " { $snippet "n" } " values of a C type." }
{ $description "Allocates an unmanaged memory block large enough to hold " { $snippet "n" } " values of a C type, then wraps the memory in a sequence object using " { $link <c-direct-array> } "." }
{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, a " { $link specialized-array-vocab-not-loaded } " error will be thrown. The vocabulary can be loaded with a " { $link POSTPONE: USING: } " form as usual, or with the " { $link require-c-array } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary set for details on the underlying sequence type constructed." }
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
{ $errors "Throws an error if the type does not exist, if the requested size is negative, or if memory allocation fails." } ;
{ $errors "Throws an error if the type does not exist, if the requested size is negative, if a direct specialized array class appropriate to the type is not loaded, or if memory allocation fails." } ;
HELP: malloc-object
{ $values { "type" "a C type" } { "alien" alien } }
@ -89,6 +89,8 @@ HELP: malloc-byte-array
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
{ $errors "Throws an error if memory allocation fails." } ;
{ <c-array> <c-direct-array> malloc-array } related-words
HELP: box-parameter
{ $values { "n" integer } { "ctype" string } }
{ $description "Generates code for converting a C value stored at offset " { $snippet "n" } " from the top of the stack into a Factor object to be pushed on the data stack." }
@ -128,6 +130,16 @@ HELP: malloc-string
}
} ;
HELP: require-c-array
{ $values { "c-type" "a C type" } }
{ $description { $link require } "s any unloaded vocabularies needed to construct a specialized array of " { $snippet "c-type" } " using the " { $link <c-array> } " or " { $link <c-direct-array> } " vocabularies." }
{ $notes "This word must be called inside a compilation unit. See the " { $vocab-link "specialized-arrays" } " vocabulary set for details on the underlying sequence types loaded." } ;
HELP: <c-direct-array>
{ $values { "alien" c-ptr } { "len" integer } { "c-type" "a C type" } { "array" "a specialized direct array" } }
{ $description "Constructs a new specialized array of length " { $snippet "len" } " and element type " { $snippet "c-type" } " over the range of memory referenced by " { $snippet "alien" } "." }
{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, a " { $link specialized-array-vocab-not-loaded } " error will be thrown. The vocabulary can be loaded with a " { $link POSTPONE: USING: } " form as usual, or with the " { $link require-c-array } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary set for details on the underlying sequence type constructed." } ;
ARTICLE: "c-strings" "C strings"
"C string types are arrays with shape " { $snippet "{ \"char*\" encoding }" } ", where " { $snippet "encoding" } " is an encoding descriptor. The type " { $snippet "\"char*\"" } " is an alias for " { $snippet "{ \"char*\" utf8 }" } ". See " { $link "encodings-descriptors" } " for information about encoding descriptors."
$nl

4
basis/alien/c-types/c-types-tests.factor
View File

@ -1,10 +1,10 @@
IN: alien.c-types.tests
USING: alien alien.syntax alien.c-types kernel tools.test
sequences system libc alien.strings io.encodings.utf8 ;
IN: alien.c-types.tests
CONSTANT: xyz 123
[ { "blah" 123 } ] [ { "blah" xyz } expand-constants ] unit-test
[ 492 ] [ { "int" xyz } heap-size ] unit-test
[ -1 ] [ -1 <char> *char ] unit-test
[ -1 ] [ -1 <short> *short ] unit-test

211
basis/alien/c-types/c-types.factor
View File

@ -5,7 +5,7 @@ namespaces make parser sequences strings words splitting math.parser
cpu.architecture alien alien.accessors alien.strings quotations
layouts system compiler.units io io.files io.encodings.binary
io.streams.memory accessors combinators effects continuations fry
classes ;
classes vocabs vocabs.loader ;
IN: alien.c-types
DEFER: <int>
@ -13,17 +13,24 @@ DEFER: *char
: little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
TUPLE: c-type
TUPLE: abstract-c-type
{ class class initial: object }
boxer
{ boxed-class class initial: object }
{ boxer-quot callable }
unboxer
{ unboxer-quot callable }
{ getter callable }
{ setter callable }
{ reg-class initial: int-regs }
size
align
array-class
array-constructor
(array)-constructor
direct-array-constructor ;
TUPLE: c-type < abstract-c-type
boxer
unboxer
{ rep initial: int-rep }
stack-align? ;
: <c-type> ( -- type )
@ -68,12 +75,88 @@ M: string c-type ( name -- type )
] ?if
] if ;
: ?require-word ( word/pair -- )
dup word? [ drop ] [ first require ] ?if ;
! These words being foldable means that words need to be
! recompiled if a C type is redefined. Even so, folding the
! size facilitates some optimizations.
GENERIC: heap-size ( type -- size ) foldable
M: string heap-size c-type heap-size ;
M: abstract-c-type heap-size size>> ;
GENERIC: require-c-array ( c-type -- )
M: object require-c-array
drop ;
M: c-type require-c-array
array-class>> ?require-word ;
M: string require-c-array
c-type require-c-array ;
M: array require-c-array
first c-type require-c-array ;
ERROR: specialized-array-vocab-not-loaded vocab word ;
: c-array-constructor ( c-type -- word )
array-constructor>> dup array?
[ first2 specialized-array-vocab-not-loaded ] when ; foldable
: c-(array)-constructor ( c-type -- word )
(array)-constructor>> dup array?
[ first2 specialized-array-vocab-not-loaded ] when ; foldable
: c-direct-array-constructor ( c-type -- word )
direct-array-constructor>> dup array?
[ first2 specialized-array-vocab-not-loaded ] when ; foldable
GENERIC: <c-array> ( len c-type -- array )
M: object <c-array>
c-array-constructor execute( len -- array ) ; inline
M: string <c-array>
c-type <c-array> ; inline
M: array <c-array>
first c-type <c-array> ; inline
GENERIC: (c-array) ( len c-type -- array )
M: object (c-array)
c-(array)-constructor execute( len -- array ) ; inline
M: string (c-array)
c-type (c-array) ; inline
M: array (c-array)
first c-type (c-array) ; inline
GENERIC: <c-direct-array> ( alien len c-type -- array )
M: object <c-direct-array>
c-direct-array-constructor execute( alien len -- array ) ; inline
M: string <c-direct-array>
c-type <c-direct-array> ; inline
M: array <c-direct-array>
first c-type <c-direct-array> ; inline
: malloc-array ( n type -- alien )
[ heap-size calloc ] [ <c-direct-array> ] 2bi ; inline
: (malloc-array) ( n type -- alien )
[ heap-size * malloc ] [ <c-direct-array> ] 2bi ; inline
GENERIC: c-type-class ( name -- class )
M: c-type c-type-class class>> ;
M: abstract-c-type c-type-class class>> ;
M: string c-type-class c-type c-type-class ;
GENERIC: c-type-boxed-class ( name -- class )
M: abstract-c-type c-type-boxed-class boxed-class>> ;
M: string c-type-boxed-class c-type c-type-boxed-class ;
GENERIC: c-type-boxer ( name -- boxer )
M: c-type c-type-boxer boxer>> ;
@ -82,7 +165,7 @@ M: string c-type-boxer c-type c-type-boxer ;
GENERIC: c-type-boxer-quot ( name -- quot )
M: c-type c-type-boxer-quot boxer-quot>> ;
M: abstract-c-type c-type-boxer-quot boxer-quot>> ;
M: string c-type-boxer-quot c-type c-type-boxer-quot ;
@ -94,15 +177,15 @@ M: string c-type-unboxer c-type c-type-unboxer ;
GENERIC: c-type-unboxer-quot ( name -- quot )
M: c-type c-type-unboxer-quot unboxer-quot>> ;
M: abstract-c-type c-type-unboxer-quot unboxer-quot>> ;
M: string c-type-unboxer-quot c-type c-type-unboxer-quot ;
GENERIC: c-type-reg-class ( name -- reg-class )
GENERIC: c-type-rep ( name -- rep )
M: c-type c-type-reg-class reg-class>> ;
M: c-type c-type-rep rep>> ;
M: string c-type-reg-class c-type c-type-reg-class ;
M: string c-type-rep c-type c-type-rep ;
GENERIC: c-type-getter ( name -- quot )
@ -118,7 +201,7 @@ M: string c-type-setter c-type c-type-setter ;
GENERIC: c-type-align ( name -- n )
M: c-type c-type-align align>> ;
M: abstract-c-type c-type-align align>> ;
M: string c-type-align c-type c-type-align ;
@ -129,13 +212,11 @@ M: c-type c-type-stack-align? stack-align?>> ;
M: string c-type-stack-align? c-type c-type-stack-align? ;
: c-type-box ( n type -- )
dup c-type-reg-class
swap c-type-boxer [ "No boxer" throw ] unless*
[ c-type-rep ] [ c-type-boxer [ "No boxer" throw ] unless* ] bi
%box ;
: c-type-unbox ( n ctype -- )
dup c-type-reg-class
swap c-type-unboxer [ "No unboxer" throw ] unless*
[ c-type-rep ] [ c-type-unboxer [ "No unboxer" throw ] unless* ] bi
%unbox ;
GENERIC: box-parameter ( n ctype -- )
@ -162,15 +243,6 @@ M: c-type unbox-return f swap c-type-unbox ;
M: string unbox-return c-type unbox-return ;
! These words being foldable means that words need to be
! recompiled if a C type is redefined. Even so, folding the
! size facilitates some optimizations.
GENERIC: heap-size ( type -- size ) foldable
M: string heap-size c-type heap-size ;
M: c-type heap-size size>> ;
GENERIC: stack-size ( type -- size ) foldable
M: string stack-size c-type stack-size ;
@ -179,9 +251,9 @@ M: c-type stack-size size>> cell align ;
GENERIC: byte-length ( seq -- n ) flushable
M: byte-array byte-length length ;
M: byte-array byte-length length ; inline
M: f byte-length drop 0 ;
M: f byte-length drop 0 ; inline
: c-getter ( name -- quot )
c-type-getter [
@ -196,17 +268,17 @@ M: f byte-length drop 0 ;
[ "Cannot write struct fields with this type" throw ]
] unless* ;
: <c-array> ( n type -- array )
heap-size * <byte-array> ; inline
: <c-object> ( type -- array )
1 swap <c-array> ; inline
heap-size <byte-array> ; inline
: malloc-array ( n type -- alien )
heap-size calloc ; inline
: (c-object) ( type -- array )
heap-size (byte-array) ; inline
: malloc-object ( type -- alien )
1 swap malloc-array ; inline
1 swap heap-size calloc ; inline
: (malloc-object) ( type -- alien )
heap-size malloc ; inline
: malloc-byte-array ( byte-array -- alien )
dup byte-length [ nip malloc dup ] 2keep memcpy ;
@ -224,7 +296,7 @@ M: memory-stream stream-read
] [ [ + ] change-index drop ] 2bi ;
: byte-array>memory ( byte-array base -- )
swap dup byte-length memcpy ;
swap dup byte-length memcpy ; inline
: array-accessor ( type quot -- def )
[
@ -269,23 +341,38 @@ M: long-long-type box-return ( type -- )
[ define-out ]
tri ;
: expand-constants ( c-type -- c-type' )
dup array? [
unclip [
[
dup word? [
def>> call( -- object )
] when
] map
] dip prefix
] when ;
: malloc-file-contents ( path -- alien len )
binary file-contents [ malloc-byte-array ] [ length ] bi ;
: if-void ( type true false -- )
pick "void" = [ drop nip call ] [ nip call ] if ; inline
: ?lookup ( vocab word -- word/pair )
over vocab [ swap lookup ] [ 2array ] if ;
: set-array-class* ( c-type vocab-stem type-stem -- c-type )
{
[
[ "specialized-arrays." prepend ]
[ "-array" append ] bi* ?lookup >>array-class
]
[
[ "specialized-arrays." prepend ]
[ "<" "-array>" surround ] bi* ?lookup >>array-constructor
]
[
[ "specialized-arrays." prepend ]
[ "(" "-array)" surround ] bi* ?lookup >>(array)-constructor
]
[
[ "specialized-arrays." prepend ]
[ "<direct-" "-array>" surround ] bi* ?lookup >>direct-array-constructor
]
} 2cleave ;
: set-array-class ( c-type stem -- c-type )
dup set-array-class* ;
CONSTANT: primitive-types
{
"char" "uchar"
@ -300,6 +387,7 @@ CONSTANT: primitive-types
[
<c-type>
c-ptr >>class
c-ptr >>boxed-class
[ alien-cell ] >>getter
[ [ >c-ptr ] 2dip set-alien-cell ] >>setter
bootstrap-cell >>size
@ -307,106 +395,127 @@ CONSTANT: primitive-types
[ >c-ptr ] >>unboxer-quot
"box_alien" >>boxer
"alien_offset" >>unboxer
"alien" "void*" set-array-class*
"void*" define-primitive-type
<long-long-type>
integer >>class
integer >>boxed-class
[ alien-signed-8 ] >>getter
[ set-alien-signed-8 ] >>setter
8 >>size
8 >>align
"box_signed_8" >>boxer
"to_signed_8" >>unboxer
"longlong" set-array-class
"longlong" define-primitive-type
<long-long-type>
integer >>class
integer >>boxed-class
[ alien-unsigned-8 ] >>getter
[ set-alien-unsigned-8 ] >>setter
8 >>size
8 >>align
"box_unsigned_8" >>boxer
"to_unsigned_8" >>unboxer
"ulonglong" set-array-class
"ulonglong" define-primitive-type
<c-type>
integer >>class
integer >>boxed-class
[ alien-signed-cell ] >>getter
[ set-alien-signed-cell ] >>setter
bootstrap-cell >>size
bootstrap-cell >>align
"box_signed_cell" >>boxer
"to_fixnum" >>unboxer
"long" set-array-class
"long" define-primitive-type
<c-type>
integer >>class
integer >>boxed-class
[ alien-unsigned-cell ] >>getter
[ set-alien-unsigned-cell ] >>setter
bootstrap-cell >>size
bootstrap-cell >>align
"box_unsigned_cell" >>boxer
"to_cell" >>unboxer
"ulong" set-array-class
"ulong" define-primitive-type
<c-type>
integer >>class
integer >>boxed-class
[ alien-signed-4 ] >>getter
[ set-alien-signed-4 ] >>setter
4 >>size
4 >>align
"box_signed_4" >>boxer
"to_fixnum" >>unboxer
"int" set-array-class
"int" define-primitive-type
<c-type>
integer >>class
integer >>boxed-class
[ alien-unsigned-4 ] >>getter
[ set-alien-unsigned-4 ] >>setter
4 >>size
4 >>align
"box_unsigned_4" >>boxer
"to_cell" >>unboxer
"uint" set-array-class
"uint" define-primitive-type
<c-type>
fixnum >>class
fixnum >>boxed-class
[ alien-signed-2 ] >>getter
[ set-alien-signed-2 ] >>setter
2 >>size
2 >>align
"box_signed_2" >>boxer
"to_fixnum" >>unboxer
"short" set-array-class
"short" define-primitive-type
<c-type>
fixnum >>class
fixnum >>boxed-class
[ alien-unsigned-2 ] >>getter
[ set-alien-unsigned-2 ] >>setter
2 >>size
2 >>align
"box_unsigned_2" >>boxer
"to_cell" >>unboxer
"ushort" set-array-class
"ushort" define-primitive-type
<c-type>
fixnum >>class
fixnum >>boxed-class
[ alien-signed-1 ] >>getter
[ set-alien-signed-1 ] >>setter
1 >>size
1 >>align
"box_signed_1" >>boxer
"to_fixnum" >>unboxer
"char" set-array-class
"char" define-primitive-type
<c-type>
fixnum >>class
fixnum >>boxed-class
[ alien-unsigned-1 ] >>getter
[ set-alien-unsigned-1 ] >>setter
1 >>size
1 >>align
"box_unsigned_1" >>boxer
"to_cell" >>unboxer
"uchar" set-array-class
"uchar" define-primitive-type
<c-type>
@ -416,33 +525,39 @@ CONSTANT: primitive-types
1 >>align
"box_boolean" >>boxer
"to_boolean" >>unboxer
"bool" set-array-class
"bool" define-primitive-type
<c-type>
float >>class
float >>boxed-class
[ alien-float ] >>getter
[ [ >float ] 2dip set-alien-float ] >>setter
4 >>size
4 >>align
"box_float" >>boxer
"to_float" >>unboxer
single-float-regs >>reg-class
single-float-rep >>rep
[ >float ] >>unboxer-quot
"float" set-array-class
"float" define-primitive-type
<c-type>
float >>class
float >>boxed-class
[ alien-double ] >>getter
[ [ >float ] 2dip set-alien-double ] >>setter
8 >>size
8 >>align
"box_double" >>boxer
"to_double" >>unboxer
double-float-regs >>reg-class
double-float-rep >>rep
[ >float ] >>unboxer-quot
"double" set-array-class
"double" define-primitive-type
"long" "ptrdiff_t" typedef
"long" "intptr_t" typedef
"ulong" "size_t" typedef
] with-compilation-unit

17
basis/alien/complex/complex-tests.factor
View File

@ -1,18 +1,21 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test alien.complex kernel alien.c-types alien.syntax
namespaces ;
USING: accessors tools.test alien.complex classes.struct kernel
alien.c-types alien.syntax namespaces math ;
IN: alien.complex.tests
C-STRUCT: complex-holder
{ "complex-float" "z" } ;
STRUCT: complex-holder
{ z complex-float } ;
: <complex-holder> ( z -- alien )
"complex-holder" <c-object>
[ set-complex-holder-z ] keep ;
complex-holder <struct-boa> ;
[ ] [
C{ 1.0 2.0 } <complex-holder> "h" set
] unit-test
[ C{ 1.0 2.0 } ] [ "h" get complex-holder-z ] unit-test
[ C{ 1.0 2.0 } ] [ "h" get z>> ] unit-test
[ number ] [ "complex-float" c-type-boxed-class ] unit-test
[ number ] [ "complex-double" c-type-boxed-class ] unit-test

2
basis/alien/complex/complex.factor
View File

@ -10,4 +10,4 @@ IN: alien.complex
! This overrides the fact that small structures are never returned
! in registers on NetBSD, Linux and Solaris running on 32-bit x86.
"complex-float" c-type t >>return-in-registers? drop
>>
>>

4
basis/alien/complex/functor/functor-tests.factor
View File

@ -1,4 +0,0 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test alien.complex.functor ;
IN: alien.complex.functor.tests

25
basis/alien/complex/functor/functor.factor
View File

@ -1,35 +1,32 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.structs alien.c-types math math.functions sequences
arrays kernel functors vocabs.parser namespaces accessors
quotations ;
USING: accessors alien alien.structs alien.c-types classes.struct math
math.functions sequences arrays kernel functors vocabs.parser
namespaces quotations ;
IN: alien.complex.functor
FUNCTOR: define-complex-type ( N T -- )
T-real DEFINES ${T}-real
T-imaginary DEFINES ${T}-imaginary
set-T-real DEFINES set-${T}-real
set-T-imaginary DEFINES set-${T}-imaginary
T-class DEFINES-CLASS ${T}
<T> DEFINES <${T}>
*T DEFINES *${T}
WHERE
STRUCT: T-class { real N } { imaginary N } ;
: <T> ( z -- alien )
>rect T <c-object> [ set-T-imaginary ] [ set-T-real ] [ ] tri ; inline
>rect T-class <struct-boa> >c-ptr ;
: *T ( alien -- z )
[ T-real ] [ T-imaginary ] bi rect> ; inline
T-class memory>struct [ real>> ] [ imaginary>> ] bi rect> ; inline
T current-vocab
{ { N "real" } { N "imaginary" } }
define-struct
T c-type
T-class c-type
<T> 1quotation >>unboxer-quot
*T 1quotation >>boxer-quot
number >>boxed-class
T set-array-class
drop
;FUNCTOR

4
basis/alien/destructors/destructors-tests.factor
View File

@ -1,4 +0,0 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test alien.destructors ;
IN: alien.destructors.tests

9
basis/alien/destructors/destructors.factor
View File

@ -4,7 +4,7 @@ USING: functors destructors accessors kernel parser words
effects generalizations sequences ;
IN: alien.destructors
SLOT: alien
TUPLE: alien-destructor alien ;
FUNCTOR: define-destructor ( F -- )
@ -16,11 +16,12 @@ N [ F stack-effect out>> length ]
WHERE
TUPLE: F-destructor alien disposed ;
TUPLE: F-destructor < alien-destructor ;
: <F-destructor> ( alien -- destructor ) f F-destructor boa ; inline
: <F-destructor> ( alien -- destructor )
F-destructor boa ; inline
M: F-destructor dispose* alien>> F N ndrop ;
M: F-destructor dispose alien>> F N ndrop ;
: &F ( alien -- alien ) dup <F-destructor> &dispose drop ; inline

6
basis/alien/fortran/fortran.factor
View File

@ -357,15 +357,15 @@ M: character-type (<fortran-result>)
: (shuffle-map) ( return parameters -- ret par )
[
fortran-ret-type>c-type length swap "void" = [ 1+ ] unless
fortran-ret-type>c-type length swap "void" = [ 1 + ] unless
letters swap head [ "ret" swap suffix ] map
] [
[ fortran-arg-type>c-type nip length 1+ ] map letters swap zip
[ fortran-arg-type>c-type nip length 1 + ] map letters swap zip
[ first2 letters swap head [ "" 2sequence ] with map ] map concat
] bi* ;
: (fortran-in-shuffle) ( ret par -- seq )
[ [ second ] bi@ <=> ] sort append ;
[ second ] sort-with append ;
: (fortran-out-shuffle) ( ret par -- seq )
append ;

13
basis/alien/libraries/libraries-docs.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.syntax assocs help.markup
help.syntax io.backend kernel namespaces ;
help.syntax io.backend kernel namespaces strings ;
IN: alien.libraries
HELP: <library>
@ -15,7 +15,7 @@ HELP: libraries
{ $description "A global hashtable that keeps a list of open libraries. Use the " { $link add-library } " word to construct a library and add it with a single call." } ;
HELP: library
{ $values { "name" "a string" } { "library" assoc } }
{ $values { "name" string } { "library" assoc } }
{ $description "Looks up a library by its logical name. The library object is a hashtable with the following keys:"
{ $list
{ { $snippet "name" } " - the full path of the C library binary" }
@ -40,11 +40,11 @@ HELP: dlclose ( dll -- )
{ $description "Closes a DLL handle created by " { $link dlopen } ". This word might not be implemented on all platforms." } ;
HELP: load-library
{ $values { "name" "a string" } { "dll" "a DLL handle" } }
{ $values { "name" string } { "dll" "a DLL handle" } }
{ $description "Loads a library by logical name and outputs a handle which may be passed to " { $link dlsym } " or " { $link dlclose } ". If the library is already loaded, returns the existing handle." } ;
HELP: add-library
{ $values { "name" "a string" } { "path" "a string" } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } }
{ $values { "name" string } { "path" string } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } }
{ $description "Defines a new logical library named " { $snippet "name" } " located in the file system at " { $snippet "path" } "and the specified ABI." }
{ $notes "Because the entire source file is parsed before top-level forms are executed, " { $link add-library } " cannot be used in the same file as " { $link POSTPONE: FUNCTION: } " definitions from that library. The " { $link add-library } " call will happen too late, after compilation, and the alien calls will not work."
$nl
@ -59,9 +59,14 @@ $nl
}
"Note the parse time evaluation with " { $link POSTPONE: << } "." } ;
HELP: remove-library
{ $values { "name" string } }
{ $description "Unloads a library and removes it from the internal list of libraries. The " { $snippet "name" } " parameter should be a name that was previously passed to " { $link add-library } ". If no library with that name exists, this word does nothing." } ;
ARTICLE: "loading-libs" "Loading native libraries"
"Before calling a C library, you must associate its path name on disk with a logical name which Factor uses to identify the library:"
{ $subsection add-library }
{ $subsection remove-library }
"Once a library has been defined, you can try loading it to see if the path name is correct:"
{ $subsection load-library }
"If the compiler cannot load a library, or cannot resolve a symbol in a library, a linkage error is reported using the compiler error mechanism (see " { $link "compiler-errors" } "). Once you install the right library, reload the source file containing the " { $link add-library } " form to force the compiler to try loading the library again." ;

10
basis/alien/libraries/libraries-tests.factor Normal file
View File

@ -0,0 +1,10 @@
USING: alien.libraries alien.syntax tools.test kernel ;
IN: alien.libraries.tests
[ f ] [ DLL" fadfasdfsada" dll-valid? ] unit-test
[ f ] [ "does not exist" DLL" fadsfasfdsaf" dlsym ] unit-test
[ ] [ "doesnotexist" dlopen dlclose ] unit-test
[ "fdasfsf" dll-valid? drop ] must-fail

13
basis/alien/libraries/libraries.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.strings assocs io.backend kernel namespaces ;
USING: accessors alien alien.strings assocs io.backend
kernel namespaces destructors ;
IN: alien.libraries
: dlopen ( path -- dll ) native-string>alien (dlopen) ;
@ -21,5 +22,13 @@ TUPLE: library path abi dll ;
: load-library ( name -- dll )
library dup [ dll>> ] when ;
M: dll dispose dlclose ;
M: library dispose dll>> [ dispose ] when* ;
: remove-library ( name -- )
libraries get delete-at* [ dispose ] [ drop ] if ;
: add-library ( name path abi -- )
<library> swap libraries get set-at ;
[ 2drop remove-library ]
[ <library> swap libraries get set-at ] 3bi ;

20
basis/alien/parser/parser.factor
View File

@ -1,18 +1,30 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays assocs effects grouping kernel
parser sequences splitting words fry locals lexer namespaces ;
parser sequences splitting words fry locals lexer namespaces
summary math ;
IN: alien.parser
: normalize-c-arg ( type name -- type' name' )
[ length ]
[
[ CHAR: * = ] trim-head
[ length - CHAR: * <array> append ] keep
] bi ;
: parse-arglist ( parameters return -- types effect )
[ 2 group unzip [ "," ?tail drop ] map ]
[
2 group [ first2 normalize-c-arg 2array ] map
unzip [ "," ?tail drop ] map
]
[ [ { } ] [ 1array ] if-void ]
bi* <effect> ;
: function-quot ( return library function types -- quot )
'[ _ _ _ _ alien-invoke ] ;
:: make-function ( return library function parameters -- word quot effect )
:: make-function ( return! library function! parameters -- word quot effect )
return function normalize-c-arg function! return!
function create-in dup reset-generic
return library function
parameters return parse-arglist [ function-quot ] dip ;

6
basis/alien/structs/fields/fields.factor
View File

@ -7,16 +7,16 @@ IN: alien.structs.fields
TUPLE: field-spec name offset type reader writer ;
: reader-word ( class name vocab -- word )
[ "-" glue ] dip create ;
[ "-" glue ] dip create dup make-deprecated ;
: writer-word ( class name vocab -- word )
[ [ swap "set-" % % "-" % % ] "" make ] dip create ;
[ [ swap "set-" % % "-" % % ] "" make ] dip create dup make-deprecated ;
: <field-spec> ( struct-name vocab type field-name -- spec )
field-spec new
0 >>offset
swap >>name
swap expand-constants >>type
swap >>type
3dup name>> swap reader-word >>reader
3dup name>> swap writer-word >>writer
2nip ;

4
basis/alien/structs/structs-docs.factor
View File

@ -23,11 +23,11 @@ $nl
}
"C structure objects can be allocated by calling " { $link <c-object> } " or " { $link malloc-object } "."
$nl
"Arrays of C structures can be created by calling " { $link <c-array> } " or " { $link malloc-array } ". Elements can be read and written using words named " { $snippet { $emphasis "type" } "-nth" } " and " { $snippet "set-" { $emphasis "type" } "-nth" } "; these words are automatically generated by " { $link POSTPONE: C-STRUCT: } "." ;
"Arrays of C structures can be created with the " { $vocab-link "struct-arrays" } " vocabulary." ;
ARTICLE: "c-unions" "C unions"
"A " { $snippet "union" } " in C defines a type large enough to hold its largest member. This is usually used to allocate a block of memory which can hold one of several types of values."
{ $subsection POSTPONE: C-UNION: }
"C union objects can be allocated by calling " { $link <c-object> } " or " { $link malloc-object } "."
$nl
"Arrays of C unions can be created by calling " { $link <c-array> } " or " { $link malloc-array } ". Elements can be read and written using words named " { $snippet { $emphasis "type" } "-nth" } " and " { $snippet "set-" { $emphasis "type" } "-nth" } "; these words are automatically generated by " { $link POSTPONE: C-UNION: } "." ;
"Arrays of C unions can be created with the " { $vocab-link "struct-arrays" } " vocabulary." ;

2
basis/alien/structs/structs-tests.factor
View File

@ -1,6 +1,6 @@
IN: alien.structs.tests
USING: alien alien.syntax alien.c-types kernel tools.test
sequences system libc words vocabs namespaces layouts ;
IN: alien.structs.tests
C-STRUCT: bar
{ "int" "x" }

37
basis/alien/structs/structs.factor
View File

@ -6,30 +6,12 @@ alien.c-types alien.structs.fields cpu.architecture math.order
quotations byte-arrays ;
IN: alien.structs
TUPLE: struct-type
size
align
fields
{ boxer-quot callable }
{ unboxer-quot callable }
{ getter callable }
{ setter callable }
return-in-registers? ;
TUPLE: struct-type < abstract-c-type fields return-in-registers? ;
M: struct-type c-type ;
M: struct-type heap-size size>> ;
M: struct-type c-type-class drop byte-array ;
M: struct-type c-type-align align>> ;
M: struct-type c-type-stack-align? drop f ;
M: struct-type c-type-boxer-quot boxer-quot>> ;
M: struct-type c-type-unboxer-quot unboxer-quot>> ;
: if-value-struct ( ctype true false -- )
[ dup value-struct? ] 2dip '[ drop "void*" @ ] if ; inline
@ -53,9 +35,10 @@ M: struct-type stack-size
: c-struct? ( type -- ? ) (c-type) struct-type? ;
: (define-struct) ( name size align fields -- )
[ [ align ] keep ] dip
struct-type new
: (define-struct) ( name size align fields class -- )
[ [ align ] keep ] 2dip new
byte-array >>class
byte-array >>boxed-class
swap >>fields
swap >>align
swap >>size
@ -71,14 +54,16 @@ M: struct-type stack-size
[ 2drop ] [ make-fields ] 3bi
[ struct-offsets ] keep
[ [ type>> ] map compute-struct-align ] keep
[ (define-struct) ] keep
[ define-field ] each ;
[ struct-type (define-struct) ] keep
[ define-field ] each ; deprecated
: define-union ( name members -- )
[ expand-constants ] map
[ [ heap-size ] [ max ] map-reduce ] keep
compute-struct-align f (define-struct) ;
compute-struct-align f struct-type (define-struct) ; deprecated
: offset-of ( field struct -- offset )
c-types get at fields>>
[ name>> = ] with find nip offset>> ;
USE: vocabs.loader
"struct-arrays" require

4
basis/alien/syntax/syntax-docs.factor
View File

@ -1,6 +1,6 @@
IN: alien.syntax
USING: alien alien.c-types alien.parser alien.structs
help.markup help.syntax ;
classes.struct help.markup help.syntax ;
HELP: DLL"
{ $syntax "DLL\" path\"" }
@ -55,12 +55,14 @@ HELP: TYPEDEF:
{ $notes "This word differs from " { $link typedef } " in that it runs at parse time, to ensure correct ordering of operations when loading source files. Words defined in source files are compiled before top-level forms are run, so if a source file defines C binding words and uses " { $link typedef } ", the type alias won't be available at compile time." } ;
HELP: C-STRUCT:
{ $deprecated "New code should use " { $link "classes.struct" } ". See the " { $link POSTPONE: STRUCT: } " word." }
{ $syntax "C-STRUCT: name pairs... ;" }
{ $values { "name" "a new C type name" } { "pairs" "C type / field name string pairs" } }
{ $description "Defines a C struct layout and accessor words." }
{ $notes "C type names are documented in " { $link "c-types-specs" } "." } ;
HELP: C-UNION:
{ $deprecated "New code should use " { $link "classes.struct" } ". See the " { $link POSTPONE: UNION-STRUCT: } " word." }
{ $syntax "C-UNION: name members... ;" }
{ $values { "name" "a new C type name" } { "members" "a sequence of C types" } }
{ $description "Defines a new C type sized to fit its largest member." }

8
basis/alien/syntax/syntax.factor
View File

@ -22,17 +22,19 @@ SYNTAX: TYPEDEF:
scan scan typedef ;
SYNTAX: C-STRUCT:
scan current-vocab parse-definition define-struct ;
scan current-vocab parse-definition define-struct ; deprecated
SYNTAX: C-UNION:
scan parse-definition define-union ;
scan parse-definition define-union ; deprecated
SYNTAX: C-ENUM:
";" parse-tokens
[ [ create-in ] dip define-constant ] each-index ;
ERROR: no-such-symbol name library ;
: address-of ( name library -- value )
load-library dlsym [ "No such symbol" throw ] unless* ;
2dup load-library dlsym [ 2nip ] [ no-such-symbol ] if* ;
SYNTAX: &:
scan "c-library" get '[ _ _ address-of ] over push-all ;

2
basis/ascii/ascii-tests.factor
View File

@ -10,7 +10,7 @@ IN: ascii.tests
[ 4 ] [
0 "There are Four Upper Case characters"
[ LETTER? [ 1+ ] when ] each
[ LETTER? [ 1 + ] when ] each
] unit-test
[ t f ] [ CHAR: \s ascii? 400 ascii? ] unit-test

4
basis/base64/base64.factor
View File

@ -34,7 +34,7 @@ SYMBOL: column
: write1-lines ( ch -- )
write1
column get [
1+ [ 76 = [ crlf ] when ]
1 + [ 76 = [ crlf ] when ]
[ 76 mod column set ] bi
] when* ;
@ -48,7 +48,7 @@ SYMBOL: column
: encode-pad ( seq n -- )
[ 3 0 pad-tail binary [ encode3 ] with-byte-writer ]
[ 1+ ] bi* head-slice 4 CHAR: = pad-tail write-lines ; inline
[ 1 + ] bi* head-slice 4 CHAR: = pad-tail write-lines ; inline
: decode4 ( seq -- )
[ 0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ]

14
basis/biassocs/biassocs-tests.factor
View File

@ -1,5 +1,5 @@
USING: biassocs assocs namespaces tools.test hashtables kernel ;
IN: biassocs.tests
USING: biassocs assocs namespaces tools.test ;
<bihash> "h" set
@ -29,4 +29,14 @@ H{ { "a" "A" } { "b" "B" } } "a" set
[ "A" ] [ "a" "b" get at ] unit-test
[ "a" ] [ "A" "b" get value-at ] unit-test
[ "a" ] [ "A" "b" get value-at ] unit-test
[ ] [ H{ { 1 2 } } >biassoc "h" set ] unit-test
[ ] [ "h" get clone "g" set ] unit-test
[ ] [ 3 4 "g" get set-at ] unit-test
[ H{ { 1 2 } } ] [ "h" get >hashtable ] unit-test
[ H{ { 1 2 } { 4 3 } } ] [ "g" get >hashtable ] unit-test

5
basis/biassocs/biassocs.factor
View File

@ -43,4 +43,7 @@ M: biassoc new-assoc
INSTANCE: biassoc assoc
: >biassoc ( assoc -- biassoc )
T{ biassoc } assoc-clone-like ;
T{ biassoc } assoc-clone-like ;
M: biassoc clone
[ from>> ] [ to>> ] bi [ clone ] bi@ biassoc boa ;

10
basis/binary-search/binary-search-tests.factor
View File

@ -1,5 +1,5 @@
IN: binary-search.tests
USING: binary-search math.order vectors kernel tools.test ;
IN: binary-search.tests
[ f ] [ 3 { } [ <=> ] with search drop ] unit-test
[ 0 ] [ 3 { 3 } [ <=> ] with search drop ] unit-test
@ -9,7 +9,7 @@ USING: binary-search math.order vectors kernel tools.test ;
[ 4 ] [ 5.5 { 1 2 3 4 5 6 7 8 } [ <=> ] with search drop ] unit-test
[ 10 ] [ 10 20 >vector [ <=> ] with search drop ] unit-test
[ t ] [ "hello" { "alligrator" "cat" "fish" "hello" "ikarus" "java" } sorted-member? ] unit-test
[ 3 ] [ "hey" { "alligrator" "cat" "fish" "hello" "ikarus" "java" } sorted-index ] unit-test
[ f ] [ "hello" { "alligrator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test
[ f ] [ "zebra" { "alligrator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test
[ t ] [ "hello" { "alligator" "cat" "fish" "hello" "ikarus" "java" } sorted-member? ] unit-test
[ 3 ] [ "hey" { "alligator" "cat" "fish" "hello" "ikarus" "java" } sorted-index ] unit-test
[ f ] [ "hello" { "alligator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test
[ f ] [ "zebra" { "alligator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test

43
basis/bit-arrays/bit-arrays.factor
View File

@ -27,46 +27,63 @@ TUPLE: bit-array
[ [ length bits>cells ] keep ] dip swap underlying>>
'[ 2 shift [ _ _ ] dip set-alien-unsigned-4 ] each ; inline
: clean-up ( bit-array -- )
! Zero bits after the end.
dup underlying>> empty? [ drop ] [
[
[ underlying>> length 8 * ] [ length ] bi -
8 swap - -1 swap shift bitnot
]
[ underlying>> last bitand ]
[ underlying>> set-last ]
tri
] if ; inline
PRIVATE>
: <bit-array> ( n -- bit-array )
dup bits>bytes <byte-array> bit-array boa ; inline
M: bit-array length length>> ;
M: bit-array length length>> ; inline
M: bit-array nth-unsafe
[ >fixnum ] [ underlying>> ] bi* byte/bit bit? ;
[ >fixnum ] [ underlying>> ] bi* byte/bit bit? ; inline
M: bit-array set-nth-unsafe
[ >fixnum ] [ underlying>> ] bi*
[ byte/bit set-bit ] 2keep
swap n>byte set-alien-unsigned-1 ;
swap n>byte set-alien-unsigned-1 ; inline
: clear-bits ( bit-array -- ) 0 (set-bits) ;
GENERIC: clear-bits ( bit-array -- )
: set-bits ( bit-array -- ) -1 (set-bits) ;
M: bit-array clear-bits 0 (set-bits) ; inline
GENERIC: set-bits ( bit-array -- )
M: bit-array set-bits -1 (set-bits) ; inline
M: bit-array clone
[ length>> ] [ underlying>> clone ] bi bit-array boa ;
[ length>> ] [ underlying>> clone ] bi bit-array boa ; inline
: >bit-array ( seq -- bit-array )
T{ bit-array f 0 B{ } } clone-like ; inline
M: bit-array like drop dup bit-array? [ >bit-array ] unless ;
M: bit-array like drop dup bit-array? [ >bit-array ] unless ; inline
M: bit-array new-sequence drop <bit-array> ;
M: bit-array new-sequence drop <bit-array> ; inline
M: bit-array equal?
over bit-array? [ sequence= ] [ 2drop f ] if ;
over bit-array? [ [ underlying>> ] bi@ sequence= ] [ 2drop f ] if ;
M: bit-array resize
[ drop ] [
[ bits>bytes ] [ underlying>> ] bi*
resize-byte-array
] 2bi
bit-array boa ;
bit-array boa
dup clean-up ; inline
M: bit-array byte-length length 7 + -3 shift ;
M: bit-array byte-length length 7 + -3 shift ; inline
SYNTAX: ?{ \ } [ >bit-array ] parse-literal ;
@ -74,10 +91,10 @@ SYNTAX: ?{ \ } [ >bit-array ] parse-literal ;
dup 0 = [
<bit-array>
] [
[ log2 1+ <bit-array> 0 ] keep
[ log2 1 + <bit-array> 0 ] keep
[ dup 0 = ] [
[ pick underlying>> pick set-alien-unsigned-1 ] keep
[ 1+ ] [ -8 shift ] bi*
[ 1 + ] [ -8 shift ] bi*
] until 2drop
] if ;

0
unmaintained/multi-methods/authors.txt → basis/bit-sets/authors.txt Executable file → Normal file
View File

17
basis/bit-sets/bit-sets-tests.factor Normal file
View File

@ -0,0 +1,17 @@
USING: bit-sets tools.test bit-arrays ;
IN: bit-sets.tests
[ ?{ t f t f t f } ] [
?{ t f f f t f }
?{ f f t f t f } bit-set-union
] unit-test
[ ?{ f f f f t f } ] [
?{ t f f f t f }
?{ f f t f t f } bit-set-intersect
] unit-test
[ ?{ t f t f f f } ] [
?{ t t t f f f }
?{ f t f f t t } bit-set-diff
] unit-test

31
basis/bit-sets/bit-sets.factor Normal file
View File

@ -0,0 +1,31 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences byte-arrays bit-arrays math hints ;
IN: bit-sets
<PRIVATE
: bit-set-map ( seq1 seq2 quot -- seq )
[ 2drop length>> ]
[
[
[ [ length ] bi@ assert= ]
[ [ underlying>> ] bi@ ] 2bi
] dip 2map
] 3bi bit-array boa ; inline
PRIVATE>
: bit-set-union ( seq1 seq2 -- seq ) [ bitor ] bit-set-map ;
HINTS: bit-set-union bit-array bit-array ;
: bit-set-intersect ( seq1 seq2 -- seq ) [ bitand ] bit-set-map ;
HINTS: bit-set-intersect bit-array bit-array ;
: bit-set-diff ( seq1 seq2 -- seq ) [ bitnot bitand ] bit-set-map ;
HINTS: bit-set-diff bit-array bit-array ;
: bit-set-subset? ( seq1 seq2 -- ? ) dupd bit-set-intersect = ;

1
basis/bit-sets/summary.txt Normal file
View File

@ -0,0 +1 @@
Efficient bitwise operations on bit arrays

4
basis/bit-vectors/bit-vectors-docs.factor
View File

@ -22,11 +22,11 @@ HELP: bit-vector
{ $description "The class of resizable bit vectors. See " { $link "bit-vectors" } " for information." } ;
HELP: <bit-vector>
{ $values { "n" "a positive integer specifying initial capacity" } { "bit-vector" bit-vector } }
{ $values { "capacity" "a positive integer specifying initial capacity" } { "vector" bit-vector } }
{ $description "Creates a new bit vector that can hold " { $snippet "n" } " bits before resizing." } ;
HELP: >bit-vector
{ $values { "seq" "a sequence" } { "bit-vector" bit-vector } }
{ $values { "seq" "a sequence" } { "vector" bit-vector } }
{ $description "Outputs a freshly-allocated bit vector with the same elements as a given sequence." } ;
HELP: ?V{

2
basis/bit-vectors/bit-vectors-tests.factor
View File

@ -1,5 +1,5 @@
IN: bit-vectors.tests
USING: tools.test bit-vectors vectors sequences kernel math ;
IN: bit-vectors.tests
[ 0 ] [ 123 <bit-vector> length ] unit-test

31
basis/bit-vectors/bit-vectors.factor
View File

@ -1,38 +1,15 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel kernel.private math sequences
sequences.private growable bit-arrays prettyprint.custom
parser accessors ;
parser accessors vectors.functor classes.parser ;
IN: bit-vectors
TUPLE: bit-vector
{ underlying bit-array initial: ?{ } }
{ length array-capacity } ;
: <bit-vector> ( n -- bit-vector )
<bit-array> 0 bit-vector boa ; inline
: >bit-vector ( seq -- bit-vector )
T{ bit-vector f ?{ } 0 } clone-like ;
M: bit-vector like
drop dup bit-vector? [
dup bit-array?
[ dup length bit-vector boa ] [ >bit-vector ] if
] unless ;
M: bit-vector new-sequence
drop [ <bit-array> ] [ >fixnum ] bi bit-vector boa ;
M: bit-vector equal?
over bit-vector? [ sequence= ] [ 2drop f ] if ;
M: bit-array new-resizable drop <bit-vector> ;
INSTANCE: bit-vector growable
<< "bit-vector" create-class-in \ bit-array \ <bit-array> define-vector >>
SYNTAX: ?V{ \ } [ >bit-vector ] parse-literal ;
M: bit-vector contract 2drop ;
M: bit-vector >pprint-sequence ;
M: bit-vector pprint-delims drop \ ?V{ \ } ;
M: bit-vector pprint* pprint-object ;

1
basis/bitstreams/bitstreams-tests.factor
View File

@ -5,7 +5,6 @@ grouping compression.lzw multiline byte-arrays io.encodings.binary
io.streams.byte-array ;
IN: bitstreams.tests
[ BIN: 1111111111 ]
[
B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>

35
basis/bitstreams/bitstreams.factor
View File

@ -1,10 +1,10 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.accessors assocs byte-arrays combinators
constructors destructors fry io io.binary io.encodings.binary
io.streams.byte-array kernel locals macros math math.ranges
multiline sequences sequences.private vectors byte-vectors
combinators.short-circuit math.bitwise ;
destructors fry io io.binary io.encodings.binary io.streams.byte-array
kernel locals macros math math.ranges multiline sequences
sequences.private vectors byte-vectors combinators.short-circuit
math.bitwise ;
IN: bitstreams
TUPLE: widthed { bits integer read-only } { #bits integer read-only } ;
@ -36,8 +36,12 @@ TUPLE: bit-writer
TUPLE: msb0-bit-reader < bit-reader ;
TUPLE: lsb0-bit-reader < bit-reader ;
CONSTRUCTOR: msb0-bit-reader ( bytes -- bs ) ;
CONSTRUCTOR: lsb0-bit-reader ( bytes -- bs ) ;
: <msb0-bit-reader> ( bytes -- bs )
msb0-bit-reader new swap >>bytes ; inline
: <lsb0-bit-reader> ( bytes -- bs )
lsb0-bit-reader new swap >>bytes ; inline
TUPLE: msb0-bit-writer < bit-writer ;
TUPLE: lsb0-bit-writer < bit-writer ;
@ -56,13 +60,20 @@ TUPLE: lsb0-bit-writer < bit-writer ;
GENERIC: peek ( n bitstream -- value )
GENERIC: poke ( value n bitstream -- )
: get-abp ( bitstream -- abp )
[ byte-pos>> 8 * ] [ bit-pos>> + ] bi ; inline
: set-abp ( abp bitstream -- )
[ 8 /mod ] dip [ (>>bit-pos) ] [ (>>byte-pos) ] bi ; inline
: seek ( n bitstream -- )
{
[ byte-pos>> 8 * ]
[ bit-pos>> + + 8 /mod ]
[ (>>bit-pos) ]
[ (>>byte-pos) ]
} cleave ; inline
[ get-abp + ] [ set-abp ] bi ; inline
: (align) ( n m -- n' )
[ /mod 0 > [ 1 + ] when ] [ * ] bi ; inline
: align ( n bitstream -- )
[ get-abp swap (align) ] [ set-abp ] bi ; inline
: read ( n bitstream -- value )
[ peek ] [ seek ] 2bi ; inline

128
basis/bootstrap/compiler/compiler.factor
View File

@ -6,11 +6,14 @@ classes.private arrays hashtables vectors classes.tuple sbufs
hashtables.private sequences.private math classes.tuple.private
growable namespaces.private assocs words command-line vocabs io
io.encodings.string libc splitting math.parser memory compiler.units
math.order compiler.tree.builder compiler.tree.optimizer
compiler.cfg.optimizer ;
FROM: compiler => enable-optimizer compile-word ;
math.order quotations quotations.private assocs.private ;
FROM: compiler => enable-optimizer ;
IN: bootstrap.compiler
"profile-compiler" get [
"bootstrap.compiler.timing" require
] when
! Don't bring this in when deploying, since it will store a
! reference to 'eval' in a global variable
"deploy-vocab" get "staging" get or [
@ -32,90 +35,87 @@ gc
: compile-unoptimized ( words -- )
[ optimized? not ] filter compile ;
nl
"Compiling..." write flush
"debug-compiler" get [
nl
"Compiling..." write flush
! Compile a set of words ahead of the full compile.
! This set of words was determined semi-empirically
! using the profiler. It improves bootstrap time
! significantly, because frequenly called words
! which are also quick to compile are replaced by
! compiled definitions as soon as possible.
{
not
! Compile a set of words ahead of the full compile.
! This set of words was determined semi-empirically
! using the profiler. It improves bootstrap time
! significantly, because frequenly called words
! which are also quick to compile are replaced by
! compiled definitions as soon as possible.
{
not ?
array? hashtable? vector?
tuple? sbuf? tombstone?
2over roll -roll
array-nth set-array-nth
array? hashtable? vector?
tuple? sbuf? tombstone?
curry? compose? callable?
quotation?
wrap probe
curry compose uncurry
namestack*
} compile-unoptimized
array-nth set-array-nth length>>
"." write flush
wrap probe
{
bitand bitor bitxor bitnot
} compile-unoptimized
namestack*
"." write flush
layout-of
} compile-unoptimized
{
+ 1+ 1- 2/ < <= > >= shift
} compile-unoptimized
"." write flush
"." write flush
{
bitand bitor bitxor bitnot
} compile-unoptimized
{
new-sequence nth push pop last flip
} compile-unoptimized
"." write flush
"." write flush
{
+ 2/ < <= > >= shift
} compile-unoptimized
{
hashcode* = get set
} compile-unoptimized
"." write flush
"." write flush
{
new-sequence nth push pop last flip
} compile-unoptimized
{
memq? split harvest sift cut cut-slice start index clone
set-at reverse push-all class number>string string>number
} compile-unoptimized
"." write flush
"." write flush
{
hashcode* = equal? assoc-stack (assoc-stack) get set
} compile-unoptimized
{
lines prefix suffix unclip new-assoc update
word-prop set-word-prop 1array 2array 3array ?nth
} compile-unoptimized
"." write flush
"." write flush
{
memq? split harvest sift cut cut-slice start index clone
set-at reverse push-all class number>string string>number
like clone-like
} compile-unoptimized
{
malloc calloc free memcpy
} compile-unoptimized
"." write flush
"." write flush
{
lines prefix suffix unclip new-assoc update
word-prop set-word-prop 1array 2array 3array ?nth
} compile-unoptimized
{ build-tree } compile-unoptimized
"." write flush
"." write flush
{
malloc calloc free memcpy
} compile-unoptimized
{ optimize-tree } compile-unoptimized
"." write flush
"." write flush
vocabs [ words compile-unoptimized "." write flush ] each
{ optimize-cfg } compile-unoptimized
" done" print flush
"." write flush
{ compile-word } compile-unoptimized
"." write flush
vocabs [ words compile-unoptimized "." write flush ] each
" done" print flush
] unless

42
basis/bootstrap/compiler/timing/timing.factor Normal file
View File

@ -0,0 +1,42 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel make sequences tools.annotations tools.crossref ;
QUALIFIED: compiler.cfg.builder
QUALIFIED: compiler.cfg.linear-scan
QUALIFIED: compiler.cfg.mr
QUALIFIED: compiler.cfg.optimizer
QUALIFIED: compiler.cfg.stacks.finalize
QUALIFIED: compiler.cfg.stacks.global
QUALIFIED: compiler.codegen
QUALIFIED: compiler.tree.builder
QUALIFIED: compiler.tree.optimizer
IN: bootstrap.compiler.timing
: passes ( word -- seq )
def>> uses [ vocabulary>> "compiler." head? ] filter ;
: high-level-passes ( -- seq ) \ compiler.tree.optimizer:optimize-tree passes ;
: low-level-passes ( -- seq ) \ compiler.cfg.optimizer:optimize-cfg passes ;
: machine-passes ( -- seq ) \ compiler.cfg.mr:build-mr passes ;
: linear-scan-passes ( -- seq ) \ compiler.cfg.linear-scan:(linear-scan) passes ;
: all-passes ( -- seq )
[
\ compiler.tree.builder:build-tree ,
\ compiler.tree.optimizer:optimize-tree ,
high-level-passes %
\ compiler.cfg.builder:build-cfg ,
\ compiler.cfg.stacks.global:compute-global-sets ,
\ compiler.cfg.stacks.finalize:finalize-stack-shuffling ,
\ compiler.cfg.optimizer:optimize-cfg ,
low-level-passes %
\ compiler.cfg.mr:build-mr ,
machine-passes %
linear-scan-passes %
\ compiler.codegen:generate ,
] { } make ;
all-passes [ [ reset ] [ add-timing ] bi ] each

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

@ -1,6 +1,6 @@
IN: bootstrap.image.tests
USING: bootstrap.image bootstrap.image.private tools.test
kernel math ;
IN: bootstrap.image.tests
[ f ] [ { 1 2 3 } [ 1 2 3 ] eql? ] unit-test

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

@ -38,11 +38,11 @@ IN: bootstrap.image
! Object cache; we only consider numbers equal if they have the
! same type
TUPLE: id obj ;
TUPLE: eql-wrapper obj ;
C: <id> id
C: <eql-wrapper> eql-wrapper
M: id hashcode* obj>> hashcode* ;
M: eql-wrapper hashcode* obj>> hashcode* ;
GENERIC: (eql?) ( obj1 obj2 -- ? )
@ -62,19 +62,27 @@ M: sequence (eql?)
M: object (eql?) = ;
M: id equal?
over id? [ [ obj>> ] bi@ eql? ] [ 2drop f ] if ;
M: eql-wrapper equal?
over eql-wrapper? [ [ obj>> ] bi@ eql? ] [ 2drop f ] if ;
TUPLE: eq-wrapper obj ;
C: <eq-wrapper> eq-wrapper
M: eq-wrapper equal?
over eq-wrapper? [ [ obj>> ] bi@ eq? ] [ 2drop f ] if ;
SYMBOL: objects
: (objects) ( obj -- id assoc ) <id> objects get ; inline
: cache-eql-object ( obj quot -- value )
[ <eql-wrapper> objects get ] dip '[ obj>> @ ] cache ; inline
: lookup-object ( obj -- n/f ) (objects) at ;
: cache-eq-object ( obj quot -- value )
[ <eq-wrapper> objects get ] dip '[ obj>> @ ] cache ; inline
: put-object ( n obj -- ) (objects) set-at ;
: lookup-object ( obj -- n/f ) <eq-wrapper> objects get at ;
: cache-object ( obj quot -- value )
[ (objects) ] dip '[ obj>> @ ] cache ; inline
: put-object ( n obj -- ) <eq-wrapper> objects get set-at ;
! Constants
@ -234,7 +242,7 @@ GENERIC: ' ( obj -- ptr )
: bignum-bits ( -- n ) bootstrap-cell-bits 2 - ;
: bignum-radix ( -- n ) bignum-bits 2^ 1- ;
: bignum-radix ( -- n ) bignum-bits 2^ 1 - ;
: bignum>seq ( n -- seq )
#! n is positive or zero.
@ -244,7 +252,7 @@ GENERIC: ' ( obj -- ptr )
: emit-bignum ( n -- )
dup dup 0 < [ neg ] when bignum>seq
[ nip length 1+ emit-fixnum ]
[ nip length 1 + emit-fixnum ]
[ drop 0 < 1 0 ? emit ]
[ nip emit-seq ]
2tri ;
@ -252,7 +260,7 @@ GENERIC: ' ( obj -- ptr )
M: bignum '
[
bignum [ emit-bignum ] emit-object
] cache-object ;
] cache-eql-object ;
! Fixnums
@ -277,7 +285,7 @@ M: float '
float [
align-here double>bits emit-64
] emit-object
] cache-object ;
] cache-eql-object ;
! Special objects
@ -340,7 +348,7 @@ M: word ' ;
! Wrappers
M: wrapper '
wrapped>> ' wrapper [ emit ] emit-object ;
[ wrapped>> ' wrapper [ emit ] emit-object ] cache-eql-object ;
! Strings
: native> ( object -- object )
@ -379,7 +387,7 @@ M: wrapper '
M: string '
#! We pool strings so that each string is only written once
#! to the image
[ emit-string ] cache-object ;
[ emit-string ] cache-eql-object ;
: assert-empty ( seq -- )
length 0 assert= ;
@ -390,10 +398,12 @@ M: string '
] bi* ;
M: byte-array '
byte-array [
dup length emit-fixnum
pad-bytes emit-bytes
] emit-object ;
[
byte-array [
dup length emit-fixnum
pad-bytes emit-bytes
] emit-object
] cache-eq-object ;
! Tuples
ERROR: tuple-removed class ;
@ -408,20 +418,22 @@ ERROR: tuple-removed class ;
: emit-tuple ( tuple -- pointer )
dup class name>> "tombstone" =
[ [ (emit-tuple) ] cache-object ] [ (emit-tuple) ] if ;
[ [ (emit-tuple) ] cache-eql-object ]
[ [ (emit-tuple) ] cache-eq-object ]
if ;
M: tuple ' emit-tuple ;
M: tombstone '
state>> "((tombstone))" "((empty))" ?
"hashtables.private" lookup def>> first
[ emit-tuple ] cache-object ;
[ emit-tuple ] cache-eql-object ;
! Arrays
: emit-array ( array -- offset )
[ ' ] map array [ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ;
M: array ' emit-array ;
M: array ' [ emit-array ] cache-eq-object ;
! This is a hack. We need to detect arrays which are tuple
! layout arrays so that they can be internalized, but making
@ -438,7 +450,7 @@ M: tuple-layout-array '
[
[ dup integer? [ <fake-bignum> ] when ] map
emit-array
] cache-object ;
] cache-eql-object ;
! Quotations
@ -452,7 +464,7 @@ M: quotation '
0 emit ! xt
0 emit ! code
] emit-object
] cache-object ;
] cache-eql-object ;
! End of the image

6
basis/bootstrap/image/upload/upload.factor
View File

@ -9,9 +9,9 @@ IN: bootstrap.image.upload
SYMBOL: upload-images-destination
: destination ( -- dest )
upload-images-destination get
"slava@factorcode.org:/var/www/factorcode.org/newsite/images/latest/"
or ;
upload-images-destination get
"slava@factorcode.org:/var/www/factorcode.org/newsite/images/latest/"
or ;
: checksums ( -- temp ) "checksums.txt" temp-file ;

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

@ -2,4 +2,4 @@ USING: vocabs vocabs.loader kernel ;
"math.ratios" require
"math.floats" require
"math.complex" require
"math.complex" require

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

@ -8,12 +8,14 @@ IN: bootstrap.tools
"tools.crossref"
"tools.errors"
"tools.deploy"
"tools.destructors"
"tools.disassembler"
"tools.memory"
"tools.profiler"
"tools.test"
"tools.time"
"tools.threads"
"tools.deprecation"
"vocabs.hierarchy"
"vocabs.refresh"
"vocabs.refresh.monitor"

2
basis/boxes/boxes-tests.factor
View File

@ -1,5 +1,5 @@
IN: boxes.tests
USING: boxes namespaces tools.test accessors ;
IN: boxes.tests
[ ] [ <box> "b" set ] unit-test

2
basis/byte-arrays/hex/authors.txt Normal file
View File

@ -0,0 +1,2 @@
Maxim Savchenko
Slava Pestov

8
basis/byte-arrays/hex/hex-docs.factor Normal file
View File

@ -0,0 +1,8 @@
! Copyright (C) 2009 Maxim Savchenko, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: byte-arrays.hex
USING: byte-arrays help.markup help.syntax ;
HELP: HEX{
{ $syntax "HEX{ 0123 45 67 89abcdef }" }
{ $description "Constructs a " { $link byte-array } " from data specified in hexadecimal format. Whitespace between the curly braces is ignored." } ;

10
basis/byte-arrays/hex/hex.factor Normal file
View File

@ -0,0 +1,10 @@
! Copyright (C) 2009 Maxim Savchenko, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: grouping lexer ascii parser sequences kernel math.parser ;
IN: byte-arrays.hex
SYNTAX: HEX{
"}" parse-tokens "" join
[ blank? not ] filter
2 group [ hex> ] B{ } map-as
parsed ;

4
basis/cache/cache-tests.factor vendored
View File

@ -1,4 +0,0 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test cache ;
IN: cache.tests

8
basis/cache/cache.factor vendored
View File

@ -3,10 +3,10 @@
USING: kernel assocs math accessors destructors fry sequences ;
IN: cache
TUPLE: cache-assoc assoc max-age disposed ;
TUPLE: cache-assoc < disposable assoc max-age ;
: <cache-assoc> ( -- cache )
H{ } clone 10 f cache-assoc boa ;
cache-assoc new-disposable H{ } clone >>assoc 10 >>max-age ;
<PRIVATE
@ -38,6 +38,6 @@ PRIVATE>
: purge-cache ( cache -- )
dup max-age>> '[
[ nip [ 1+ ] change-age age>> _ >= ] assoc-partition
[ nip [ 1 + ] change-age age>> _ >= ] assoc-partition
[ values dispose-each ] dip
] change-assoc drop ;
] change-assoc drop ;

4
basis/cairo/cairo-tests.factor
View File

@ -1,8 +1,8 @@
IN: cairo.tests
USING: cairo tools.test math.rectangles accessors ;
IN: cairo.tests
[ { 10 20 } ] [
{ 10 20 } [
{ 0 1 } { 3 4 } <rect> fill-rect
] make-bitmap-image dim>>
] unit-test
] unit-test

3
basis/cairo/cairo.factor
View File

@ -31,7 +31,8 @@ ERROR: cairo-error message ;
<cairo> &cairo_destroy
@
] make-memory-bitmap
BGRA >>component-order ; inline
BGRA >>component-order
ubyte-components >>component-type ; inline
: dummy-cairo ( -- cr )
#! Sometimes we want a dummy context; eg with Pango, we want

2
basis/cairo/ffi/ffi.factor
View File

@ -896,7 +896,7 @@ FUNCTION: cairo_status_t
cairo_pattern_get_rgba ( cairo_pattern_t* pattern, double* red, double* green, double* blue, double* alpha ) ;
FUNCTION: cairo_status_t
cairo_pattern_get_surface ( cairo_pattern_t* pattern, cairo_surface_t* *surface ) ;
cairo_pattern_get_surface ( cairo_pattern_t* pattern, cairo_surface_t** surface ) ;
FUNCTION: cairo_status_t
cairo_pattern_get_color_stop_rgba ( cairo_pattern_t* pattern, int index, double* offset, double* red, double* green, double* blue, double* alpha ) ;

6
basis/calendar/calendar-docs.factor
View File

@ -20,14 +20,14 @@ HELP: <date>
{ $values { "year" integer } { "month" integer } { "day" integer } { "timestamp" timestamp } }
{ $description "Returns a timestamp object representing the start of the specified day in your current timezone." }
{ $examples
{ $example "USING: calendar prettyprint ;"
"2010 12 25 <date> >gmt midnight ."
{ $example "USING: accessors calendar prettyprint ;"
"2010 12 25 <date> instant >>gmt-offset ."
"T{ timestamp { year 2010 } { month 12 } { day 25 } }"
}
} ;
HELP: month-names
{ $values { "array" array } }
{ $values { "value" object } }
{ $description "Returns an array with the English names of all the months." }
{ $warning "Do not use this array for looking up a month name directly. Use month-name instead." } ;

27
basis/calendar/calendar.factor
View File

@ -34,25 +34,25 @@ C: <timestamp> timestamp
: <date> ( year month day -- timestamp )
0 0 0 gmt-offset-duration <timestamp> ;
ERROR: not-a-month n ;
ERROR: not-a-month ;
M: not-a-month summary
drop "Months are indexed starting at 1" ;
<PRIVATE
: check-month ( n -- n )
dup zero? [ not-a-month ] when ;
[ not-a-month ] when-zero ;
PRIVATE>
: month-names ( -- array )
CONSTANT: month-names
{
"January" "February" "March" "April" "May" "June"
"July" "August" "September" "October" "November" "December"
} ;
}
: month-name ( n -- string )
check-month 1- month-names nth ;
check-month 1 - month-names nth ;
CONSTANT: month-abbreviations
{
@ -61,7 +61,7 @@ CONSTANT: month-abbreviations
}
: month-abbreviation ( n -- string )
check-month 1- month-abbreviations nth ;
check-month 1 - month-abbreviations nth ;
CONSTANT: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 }
@ -113,7 +113,7 @@ CONSTANT: day-abbreviations3
100 b * d + 4800 -
m 10 /i + m 3 +
12 m 10 /i * -
e 153 m * 2 + 5 /i - 1+ ;
e 153 m * 2 + 5 /i - 1 + ;
GENERIC: easter ( obj -- obj' )
@ -186,9 +186,6 @@ GENERIC: +second ( timestamp x -- timestamp )
{ [ day>> 29 = ] [ month>> 2 = ] [ leap-year? not ] } 1&&
[ 3 >>month 1 >>day ] when ;
: unless-zero ( n quot -- )
[ dup zero? [ drop ] ] dip if ; inline
M: integer +year ( timestamp n -- timestamp )
[ [ + ] curry change-year adjust-leap-year ] unless-zero ;
@ -196,7 +193,7 @@ M: real +year ( timestamp n -- timestamp )
[ float>whole-part swapd days-per-year * +day swap +year ] unless-zero ;
: months/years ( n -- months years )
12 /rem dup zero? [ drop 1- 12 ] when swap ; inline
12 /rem [ 1 - 12 ] when-zero swap ; inline
M: integer +month ( timestamp n -- timestamp )
[ over month>> + months/years [ >>month ] dip +year ] unless-zero ;
@ -371,10 +368,10 @@ M: duration time-
#! http://web.textfiles.com/computers/formulas.txt
#! good for any date since October 15, 1582
[
dup 2 <= [ [ 1- ] [ 12 + ] bi* ] when
dup 2 <= [ [ 1 - ] [ 12 + ] bi* ] when
[ dup [ 4 /i + ] [ 100 /i - ] [ 400 /i + ] tri ] dip
[ 1+ 3 * 5 /i + ] keep 2 * +
] dip 1+ + 7 mod ;
[ 1 + 3 * 5 /i + ] keep 2 * +
] dip 1 + + 7 mod ;
GENERIC: days-in-year ( obj -- n )
@ -395,7 +392,7 @@ M: timestamp days-in-year ( timestamp -- n ) year>> days-in-year ;
year leap-year? [
year month day <date>
year 3 1 <date>
after=? [ 1+ ] when
after=? [ 1 + ] when
] when ;
: day-of-year ( timestamp -- n )

14
basis/calendar/format/format.factor
View File

@ -68,8 +68,8 @@ M: array month. ( pair -- )
[ (days-in-month) day-abbreviations2 " " join print ] 2tri
over " " <repetition> concat write
[
[ 1+ day. ] keep
1+ + 7 mod zero? [ nl ] [ bl ] if
[ 1 + day. ] keep
1 + + 7 mod zero? [ nl ] [ bl ] if
] with each nl ;
M: timestamp month. ( timestamp -- )
@ -78,7 +78,7 @@ M: timestamp month. ( timestamp -- )
GENERIC: year. ( obj -- )
M: integer year. ( n -- )
12 [ 1+ 2array month. nl ] with each ;
12 [ 1 + 2array month. nl ] with each ;
M: timestamp year. ( timestamp -- )
year>> year. ;
@ -162,7 +162,7 @@ M: timestamp year. ( timestamp -- )
: read-rfc3339-seconds ( s -- s' ch )
"+-Z" read-until [
[ string>number ] [ length 10 swap ^ ] bi / +
[ string>number ] [ length 10^ ] bi / +
] dip ;
: (rfc3339>timestamp) ( -- timestamp )
@ -201,7 +201,7 @@ ERROR: invalid-timestamp-format ;
"," read-token day-abbreviations3 member? check-timestamp drop
read1 CHAR: \s assert=
read-sp checked-number >>day
read-sp month-abbreviations index 1+ check-timestamp >>month
read-sp month-abbreviations index 1 + check-timestamp >>month
read-sp checked-number >>year
":" read-token checked-number >>hour
":" read-token checked-number >>minute
@ -220,7 +220,7 @@ ERROR: invalid-timestamp-format ;
"," read-token check-day-name
read1 CHAR: \s assert=
"-" read-token checked-number >>day
"-" read-token month-abbreviations index 1+ check-timestamp >>month
"-" read-token month-abbreviations index 1 + check-timestamp >>month
read-sp checked-number >>year
":" read-token checked-number >>hour
":" read-token checked-number >>minute
@ -233,7 +233,7 @@ ERROR: invalid-timestamp-format ;
: (cookie-string>timestamp-2) ( -- timestamp )
timestamp new
read-sp check-day-name
read-sp month-abbreviations index 1+ check-timestamp >>month
read-sp month-abbreviations index 1 + check-timestamp >>month
read-sp checked-number >>day
":" read-token checked-number >>hour
":" read-token checked-number >>minute

15
basis/calendar/unix/unix.factor
View File

@ -1,28 +1,27 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.syntax arrays calendar
kernel math unix unix.time namespaces system ;
kernel math unix unix.time unix.types namespaces system
accessors classes.struct ;
IN: calendar.unix
: timeval>seconds ( timeval -- seconds )
[ timeval-sec seconds ] [ timeval-usec microseconds ] bi
time+ ;
[ sec>> seconds ] [ usec>> microseconds ] bi time+ ;
: timeval>unix-time ( timeval -- timestamp )
timeval>seconds since-1970 ;
: timespec>seconds ( timespec -- seconds )
[ timespec-sec seconds ] [ timespec-nsec nanoseconds ] bi
time+ ;
[ sec>> seconds ] [ nsec>> nanoseconds ] bi time+ ;
: timespec>unix-time ( timespec -- timestamp )
timespec>seconds since-1970 ;
: get-time ( -- alien )
f time <uint> localtime ;
f time <time_t> localtime tm memory>struct ;
: timezone-name ( -- string )
get-time tm-zone ;
get-time zone>> ;
M: unix gmt-offset ( -- hours minutes seconds )
get-time tm-gmtoff 3600 /mod 60 /mod ;
get-time gmtoff>> 3600 /mod 60 /mod ;

14
basis/calendar/windows/windows.factor
View File

@ -1,15 +1,13 @@
USING: calendar namespaces alien.c-types system
windows.kernel32 kernel math combinators windows.errors ;
windows.kernel32 kernel math combinators windows.errors
accessors classes.struct ;
IN: calendar.windows
M: windows gmt-offset ( -- hours minutes seconds )
"TIME_ZONE_INFORMATION" <c-object>
TIME_ZONE_INFORMATION <struct>
dup GetTimeZoneInformation {
{ TIME_ZONE_ID_INVALID [ win32-error-string throw ] }
{ TIME_ZONE_ID_UNKNOWN [ TIME_ZONE_INFORMATION-Bias ] }
{ TIME_ZONE_ID_STANDARD [ TIME_ZONE_INFORMATION-Bias ] }
{ TIME_ZONE_ID_DAYLIGHT [
[ TIME_ZONE_INFORMATION-Bias ]
[ TIME_ZONE_INFORMATION-DaylightBias ] bi +
] }
{ TIME_ZONE_ID_UNKNOWN [ Bias>> ] }
{ TIME_ZONE_ID_STANDARD [ Bias>> ] }
{ TIME_ZONE_ID_DAYLIGHT [ [ Bias>> ] [ DaylightBias>> ] bi + ] }
} case neg 60 /mod 0 ;

2
basis/channels/examples/examples.factor
View File

@ -7,7 +7,7 @@ locals sequences ;
IN: channels.examples
: (counter) ( channel n -- )
[ swap to ] 2keep 1+ (counter) ;
[ swap to ] 2keep 1 + (counter) ;
: counter ( channel -- )
2 (counter) ;

1
basis/checksums/fnv1/authors.txt Normal file
View File

@ -0,0 +1 @@
Alaric Snell-Pym

67
basis/checksums/fnv1/fnv1-docs.factor Normal file
View File

@ -0,0 +1,67 @@
USING: help.markup help.syntax ;
IN: checksums.fnv1
HELP: fnv1-32
{ $class-description "Fowler-Noll-Vo checksum algorithm, v1, 32-bit." } ;
HELP: fnv1a-32
{ $class-description "Fowler-Noll-Vo checksum algorithm, v1a, 32-bit." } ;
HELP: fnv1-64
{ $class-description "Fowler-Noll-Vo checksum algorithm, v1, 64-bit." } ;
HELP: fnv1a-64
{ $class-description "Fowler-Noll-Vo checksum algorithm, v1a, 64-bit." } ;
HELP: fnv1-128
{ $class-description "Fowler-Noll-Vo checksum algorithm, v1, 128-bit." } ;
HELP: fnv1a-128
{ $class-description "Fowler-Noll-Vo checksum algorithm, v1a, 128-bit." } ;
HELP: fnv1-256
{ $class-description "Fowler-Noll-Vo checksum algorithm, v1, 256-bit." } ;
HELP: fnv1a-256
{ $class-description "Fowler-Noll-Vo checksum algorithm, v1a, 256-bit." } ;
HELP: fnv1-512
{ $class-description "Fowler-Noll-Vo checksum algorithm, v1, 512-bit." } ;
HELP: fnv1a-512
{ $class-description "Fowler-Noll-Vo checksum algorithm, v1a, 512-bit." } ;
HELP: fnv1-1024
{ $class-description "Fowler-Noll-Vo checksum algorithm, v1, 1024-bit." } ;
HELP: fnv1a-1024
{ $class-description "Fowler-Noll-Vo checksum algorithm, v1a, 1024-bit." } ;
ARTICLE: "checksums.fnv1" "Fowler-Noll-Vo checksum"
"The Fowler-Noll-Vo checksum algorithm is another simple and fast checksum. It comes in 32, 64, 128, 256, 512 and 1024-bit versions, each in 1 and 1a variants. The 1a variants tend to produce a slightly better result. See http://en.wikipedia.org/wiki/Fowler_Noll_Vo_hash for more details."
{ $subsection fnv1-32 }
{ $subsection fnv1a-32 }
{ $subsection fnv1-64 }
{ $subsection fnv1a-64 }
{ $subsection fnv1-128 }
{ $subsection fnv1a-128 }
{ $subsection fnv1-256 }
{ $subsection fnv1a-256 }
{ $subsection fnv1-512 }
{ $subsection fnv1a-512 }
{ $subsection fnv1-1024 }
{ $subsection fnv1a-1024 }
;
ABOUT: "checksums.fnv1"

41
basis/checksums/fnv1/fnv1-tests.factor Normal file
View File

@ -0,0 +1,41 @@
USING: checksums.fnv1 checksums strings tools.test ;
IN: checksums.fnv1.tests
! A few test vectors taken from http://www.isthe.com/chongo/src/fnv/test_fnv.c
[ HEX: 811c9dc5 ] [ "" fnv1-32 checksum-bytes ] unit-test
[ HEX: 811c9dc5 ] [ "" fnv1a-32 checksum-bytes ] unit-test
[ HEX: cbf29ce484222325 ] [ "" fnv1-64 checksum-bytes ] unit-test
[ HEX: cbf29ce484222325 ] [ "" fnv1a-64 checksum-bytes ] unit-test
[ HEX: 050c5d7e ] [ "a" fnv1-32 checksum-bytes ] unit-test
[ HEX: e40c292c ] [ "a" fnv1a-32 checksum-bytes ] unit-test
[ HEX: af63bd4c8601b7be ] [ "a" fnv1-64 checksum-bytes ] unit-test
[ HEX: af63dc4c8601ec8c ] [ "a" fnv1a-64 checksum-bytes ] unit-test
[ HEX: 050c5d7d ] [ "b" fnv1-32 checksum-bytes ] unit-test
[ HEX: e70c2de5 ] [ "b" fnv1a-32 checksum-bytes ] unit-test
[ HEX: af63bd4c8601b7bd ] [ "b" fnv1-64 checksum-bytes ] unit-test
[ HEX: af63df4c8601f1a5 ] [ "b" fnv1a-64 checksum-bytes ] unit-test
[ HEX: 31f0b262 ] [ "foobar" fnv1-32 checksum-bytes ] unit-test
[ HEX: bf9cf968 ] [ "foobar" fnv1a-32 checksum-bytes ] unit-test
[ HEX: 340d8765a4dda9c2 ] [ "foobar" fnv1-64 checksum-bytes ] unit-test
[ HEX: 85944171f73967e8 ] [ "foobar" fnv1a-64 checksum-bytes ] unit-test
! I couldn't find any test vectors for 128, 256, 512, or 1024 versions of FNV1 hashes.
! So, just to check that your maths works the same as my maths, here's a few samples computed on my laptop.
! So they may be right or wrong, but either way, them failing is cause for concern somewhere...
[ 3897470310 ] [ "Hello, world!" fnv1-32 checksum-bytes ] unit-test
[ 3985698964 ] [ "Hello, world!" fnv1a-32 checksum-bytes ] unit-test
[ 7285062107457560934 ] [ "Hello, world!" fnv1-64 checksum-bytes ] unit-test
[ 4094109891673226228 ] [ "Hello, world!" fnv1a-64 checksum-bytes ] unit-test
[ 281580511747867177735318995358496831158 ] [ "Hello, world!" fnv1-128 checksum-bytes ] unit-test
[ 303126633380056630368940439484674414572 ] [ "Hello, world!" fnv1a-128 checksum-bytes ] unit-test
[ 104295939182568077644846978685759236849634734810631820736486253421270219742822 ] [ "Hello, world!" fnv1-256 checksum-bytes ] unit-test
[ 9495445728692795332446740615588417456874414534608540692485745371050033741380 ] [ "Hello, world!" fnv1a-256 checksum-bytes ] unit-test
[ 3577308325596719252093726711895047340166329831006673109476042102918876665433235513101496175651226507162015890004121912850661561110326527625579463564626958 ] [ "Hello, world!" fnv1-512 checksum-bytes ] unit-test
[ 3577308325596719162840652138474318309664256091923081930027929425092517582111473988451078821416039944023089883981242376700859598441397004715365740906054208 ] [ "Hello, world!" fnv1a-512 checksum-bytes ] unit-test
[ 52692754922840008511959888105094366091401994235075816792707658326855733053286986999719949898492311786648795846192078757217437117165934438286601534984230194601365788544275827382423366672856972872132009691615382991251544423521887009322211754219117294019951276080952271766377222613325328591830596794468813260226 ] [ "Hello, world!" fnv1-1024 checksum-bytes ] unit-test
[ 52692754922840008511959888105094366091401994235075816792707658326855804920671100511873485674717442819607149127986090276849364757610838433887624184145636764448608707614141109841761957788887305179569455221243999538336208648824673027111352338809582124430199044921035232455717748500524777795242051756321605065326 ] [ "Hello, world!" fnv1a-1024 checksum-bytes ] unit-test

104
basis/checksums/fnv1/fnv1.factor Normal file
View File

@ -0,0 +1,104 @@
! Copyright (C) 2009 Alaric Snell-Pym
! See http://factorcode.org/license.txt for BSD license.
USING: checksums classes.singleton kernel math math.ranges
math.vectors sequences ;
IN: checksums.fnv1
SINGLETON: fnv1-32
SINGLETON: fnv1a-32
SINGLETON: fnv1-64
SINGLETON: fnv1a-64
SINGLETON: fnv1-128
SINGLETON: fnv1a-128
SINGLETON: fnv1-256
SINGLETON: fnv1a-256
SINGLETON: fnv1-512
SINGLETON: fnv1a-512
SINGLETON: fnv1-1024
SINGLETON: fnv1a-1024
CONSTANT: fnv1-32-prime 16777619
CONSTANT: fnv1-64-prime 1099511628211
CONSTANT: fnv1-128-prime 309485009821345068724781371
CONSTANT: fnv1-256-prime 374144419156711147060143317175368453031918731002211
CONSTANT: fnv1-512-prime 35835915874844867368919076489095108449946327955754392558399825615420669938882575126094039892345713852759
CONSTANT: fnv1-1024-prime 5016456510113118655434598811035278955030765345404790744303017523831112055108147451509157692220295382716162651878526895249385292291816524375083746691371804094271873160484737966720260389217684476157468082573
CONSTANT: fnv1-32-mod HEX: ffffffff
CONSTANT: fnv1-64-mod HEX: ffffffffffffffff
CONSTANT: fnv1-128-mod HEX: ffffffffffffffffffffffffffffffff
CONSTANT: fnv1-256-mod HEX: ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
CONSTANT: fnv1-512-mod HEX: ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
CONSTANT: fnv1-1024-mod HEX: ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
CONSTANT: fnv1-32-basis HEX: 811c9dc5
CONSTANT: fnv1-64-basis HEX: cbf29ce484222325
CONSTANT: fnv1-128-basis HEX: 6c62272e07bb014262b821756295c58d
CONSTANT: fnv1-256-basis HEX: dd268dbcaac550362d98c384c4e576ccc8b1536847b6bbb31023b4c8caee0535
CONSTANT: fnv1-512-basis HEX: b86db0b1171f4416dca1e50f309990acac87d059c90000000000000000000d21e948f68a34c192f62ea79bc942dbe7ce182036415f56e34bac982aac4afe9fd9
CONSTANT: fnv1-1024-basis HEX: 5f7a76758ecc4d32e56d5a591028b74b29fc4223fdada16c3bf34eda3674da9a21d9000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000004c6d7eb6e73802734510a555f256cc005ae556bde8cc9c6a93b21aff4b16c71ee90b3
M: fnv1-32 checksum-bytes ( bytes checksum -- value )
drop
fnv1-32-basis swap
[ swap fnv1-32-prime * bitxor fnv1-32-mod bitand ] each ;
M: fnv1a-32 checksum-bytes ( bytes checksum -- value )
drop
fnv1-32-basis swap
[ bitxor fnv1-32-prime * fnv1-32-mod bitand ] each ;
M: fnv1-64 checksum-bytes ( bytes checksum -- value )
drop
fnv1-64-basis swap
[ swap fnv1-64-prime * bitxor fnv1-64-mod bitand ] each ;
M: fnv1a-64 checksum-bytes ( bytes checksum -- value )
drop
fnv1-64-basis swap
[ bitxor fnv1-64-prime * fnv1-64-mod bitand ] each ;
M: fnv1-128 checksum-bytes ( bytes checksum -- value )
drop
fnv1-128-basis swap
[ swap fnv1-128-prime * bitxor fnv1-128-mod bitand ] each ;
M: fnv1a-128 checksum-bytes ( bytes checksum -- value )
drop
fnv1-128-basis swap
[ bitxor fnv1-128-prime * fnv1-128-mod bitand ] each ;
M: fnv1-256 checksum-bytes ( bytes checksum -- value )
drop
fnv1-256-basis swap
[ swap fnv1-256-prime * bitxor fnv1-256-mod bitand ] each ;
M: fnv1a-256 checksum-bytes ( bytes checksum -- value )
drop
fnv1-256-basis swap
[ bitxor fnv1-256-prime * fnv1-256-mod bitand ] each ;
M: fnv1-512 checksum-bytes ( bytes checksum -- value )
drop
fnv1-512-basis swap
[ swap fnv1-512-prime * bitxor fnv1-512-mod bitand ] each ;
M: fnv1a-512 checksum-bytes ( bytes checksum -- value )
drop
fnv1-512-basis swap
[ bitxor fnv1-512-prime * fnv1-512-mod bitand ] each ;
M: fnv1-1024 checksum-bytes ( bytes checksum -- value )
drop
fnv1-1024-basis swap
[ swap fnv1-1024-prime * bitxor fnv1-1024-mod bitand ] each ;
M: fnv1a-1024 checksum-bytes ( bytes checksum -- value )
drop
fnv1-1024-basis swap
[ bitxor fnv1-1024-prime * fnv1-1024-mod bitand ] each ;

1
basis/checksums/fnv1/summary.txt Normal file
View File

@ -0,0 +1 @@
Fowler-Noll-Vo checksum algorithm

4
basis/checksums/md5/md5-tests.factor
View File

@ -1,6 +1,8 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: byte-arrays checksums checksums.md5 io.encodings.binary
io.streams.byte-array kernel math namespaces tools.test ;
IN: checksums.md5.tests
[ "d41d8cd98f00b204e9800998ecf8427e" ] [ "" >byte-array md5 checksum-bytes hex-string ] unit-test
[ "0cc175b9c0f1b6a831c399e269772661" ] [ "a" >byte-array md5 checksum-bytes hex-string ] unit-test

8
basis/checksums/openssl/openssl.factor
View File

@ -19,13 +19,13 @@ C: <openssl-checksum> openssl-checksum
<PRIVATE
TUPLE: evp-md-context handle ;
TUPLE: evp-md-context < disposable handle ;
: <evp-md-context> ( -- ctx )
"EVP_MD_CTX" <c-object>
dup EVP_MD_CTX_init evp-md-context boa ;
evp-md-context new-disposable
"EVP_MD_CTX" <c-object> dup EVP_MD_CTX_init >>handle ;
M: evp-md-context dispose
M: evp-md-context dispose*
handle>> EVP_MD_CTX_cleanup drop ;
: with-evp-md-context ( quot -- )

104
basis/checksums/sha/sha.factor
View File

@ -1,10 +1,10 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel splitting grouping math sequences namespaces make
io.binary math.bitwise checksums checksums.common
sbufs strings combinators.smart math.ranges fry combinators
accessors locals checksums.stream multiline literals
generalizations ;
USING: accessors checksums checksums.common checksums.stream
combinators combinators.smart fry generalizations grouping
io.binary kernel literals locals make math math.bitwise
math.ranges multiline namespaces sbufs sequences
sequences.private splitting strings ;
IN: checksums.sha
SINGLETON: sha1
@ -230,21 +230,21 @@ M: sha-256 initialize-checksum-state drop <sha-256-state> ;
: prepare-M-256 ( n seq -- )
{
[ [ 16 - ] dip nth ]
[ [ 15 - ] dip nth s0-256 ]
[ [ 7 - ] dip nth ]
[ [ 2 - ] dip nth s1-256 w+ w+ w+ ]
[ [ 16 - ] dip nth-unsafe ]
[ [ 15 - ] dip nth-unsafe s0-256 ]
[ [ 7 - ] dip nth-unsafe ]
[ [ 2 - ] dip nth-unsafe s1-256 w+ w+ w+ ]
[ ]
} 2cleave set-nth ; inline
} 2cleave set-nth-unsafe ; inline
: prepare-M-512 ( n seq -- )
{
[ [ 16 - ] dip nth ]
[ [ 15 - ] dip nth s0-512 ]
[ [ 7 - ] dip nth ]
[ [ 2 - ] dip nth s1-512 w+ w+ w+ ]
[ [ 16 - ] dip nth-unsafe ]
[ [ 15 - ] dip nth-unsafe s0-512 ]
[ [ 7 - ] dip nth-unsafe ]
[ [ 2 - ] dip nth-unsafe s1-512 w+ w+ w+ ]
[ ]
} 2cleave set-nth ; inline
} 2cleave set-nth-unsafe ; inline
: ch ( x y z -- x' )
[ bitxor bitand ] keep bitxor ; inline
@ -258,36 +258,36 @@ M: sha-256 initialize-checksum-state drop <sha-256-state> ;
GENERIC: pad-initial-bytes ( string sha2 -- padded-string )
:: T1-256 ( n M H sha2 -- T1 )
n M nth
n sha2 K>> nth +
n M nth-unsafe
n sha2 K>> nth-unsafe +
e H slice3 ch w+
e H nth S1-256 w+
h H nth w+ ; inline
e H nth-unsafe S1-256 w+
h H nth-unsafe w+ ; inline
: T2-256 ( H -- T2 )
[ a swap nth S0-256 ]
[ a swap nth-unsafe S0-256 ]
[ a swap slice3 maj w+ ] bi ; inline
:: T1-512 ( n M H sha2 -- T1 )
n M nth
n sha2 K>> nth +
n M nth-unsafe
n sha2 K>> nth-unsafe +
e H slice3 ch w+
e H nth S1-512 w+
h H nth w+ ; inline
e H nth-unsafe S1-512 w+
h H nth-unsafe w+ ; inline
: T2-512 ( H -- T2 )
[ a swap nth S0-512 ]
[ a swap nth-unsafe S0-512 ]
[ a swap slice3 maj w+ ] bi ; inline
: update-H ( T1 T2 H -- )
h g pick exchange
g f pick exchange
f e pick exchange
pick d pick nth w+ e pick set-nth
d c pick exchange
c b pick exchange
b a pick exchange
[ w+ a ] dip set-nth ; inline
h g pick exchange-unsafe
g f pick exchange-unsafe
f e pick exchange-unsafe
pick d pick nth-unsafe w+ e pick set-nth-unsafe
d c pick exchange-unsafe
c b pick exchange-unsafe
b a pick exchange-unsafe
[ w+ a ] dip set-nth-unsafe ; inline
: prepare-message-schedule ( seq sha2 -- w-seq )
[ word-size>> <sliced-groups> [ be> ] map ]
@ -309,7 +309,7 @@ M: sha2-short checksum-block
[ [ block-size>> ] [ H>> clone ] [ ] tri process-chunk ] bi ;
: seq>byte-array ( seq n -- string )
'[ _ >be ] map B{ } join ;
'[ _ >be ] map B{ } concat-as ;
: sha1>checksum ( sha2 -- bytes )
H>> 4 seq>byte-array ;
@ -342,16 +342,14 @@ M: sha-256 checksum-stream ( stream checksum -- byte-array )
drop
[ <sha-256-state> ] dip add-checksum-stream get-checksum ;
: sha1-W ( t seq -- )
{
[ [ 3 - ] dip nth ]
[ [ 8 - ] dip nth bitxor ]
[ [ 14 - ] dip nth bitxor ]
[ [ 16 - ] dip nth bitxor 1 bitroll-32 ]
[ [ 3 - ] dip nth-unsafe ]
[ [ 8 - ] dip nth-unsafe bitxor ]
[ [ 14 - ] dip nth-unsafe bitxor ]
[ [ 16 - ] dip nth-unsafe bitxor 1 bitroll-32 ]
[ ]
} 2cleave set-nth ;
} 2cleave set-nth-unsafe ;
: prepare-sha1-message-schedule ( seq -- w-seq )
4 <sliced-groups> [ be> ] map
@ -368,11 +366,11 @@ M: sha-256 checksum-stream ( stream checksum -- byte-array )
} case ;
:: inner-loop ( n H W K -- temp )
a H nth :> A
b H nth :> B
c H nth :> C
d H nth :> D
e H nth :> E
a H nth-unsafe :> A
b H nth-unsafe :> B
c H nth-unsafe :> C
d H nth-unsafe :> D
e H nth-unsafe :> E
[
A 5 bitroll-32
@ -380,19 +378,19 @@ M: sha-256 checksum-stream ( stream checksum -- byte-array )
E
n K nth
n K nth-unsafe
n W nth
n W nth-unsafe
] sum-outputs 32 bits ;
:: process-sha1-chunk ( bytes H W K state -- )
80 [
H W K inner-loop
d H nth e H set-nth
c H nth d H set-nth
b H nth 30 bitroll-32 c H set-nth
a H nth b H set-nth
a H set-nth
d H nth-unsafe e H set-nth-unsafe
c H nth-unsafe d H set-nth-unsafe
b H nth-unsafe 30 bitroll-32 c H set-nth-unsafe
a H nth-unsafe b H set-nth-unsafe
a H set-nth-unsafe
] each
state [ H [ w+ ] 2map ] change-H drop ; inline

1
basis/circular/circular-tests.factor
View File

@ -2,6 +2,7 @@
! See http;//factorcode.org/license.txt for BSD license
USING: arrays kernel tools.test sequences sequences.private
circular strings ;
IN: circular.tests
[ 0 ] [ { 0 1 2 3 4 } <circular> 0 swap virtual@ drop ] unit-test
[ 2 ] [ { 0 1 2 3 4 } <circular> 2 swap virtual@ drop ] unit-test

5
basis/circular/circular.factor
View File

@ -43,16 +43,15 @@ TUPLE: growing-circular < circular length ;
M: growing-circular length length>> ;
<PRIVATE
: full? ( circular -- ? )
[ length ] [ seq>> length ] bi = ;
: set-last ( elt seq -- )
[ length 1- ] keep set-nth ;
PRIVATE>
: push-growing-circular ( elt circular -- )
dup full? [ push-circular ]
[ [ 1+ ] change-length set-last ] if ;
[ [ 1 + ] change-length set-last ] if ;
: <growing-circular> ( capacity -- growing-circular )
{ } new-sequence 0 0 growing-circular boa ;

120
basis/classes/struct/prettyprint/prettyprint.factor Normal file
View File

@ -0,0 +1,120 @@
! (c)Joe Groff bsd license
USING: accessors alien alien.c-types arrays assocs classes
classes.struct combinators combinators.short-circuit continuations
fry kernel libc make math math.parser mirrors prettyprint.backend
prettyprint.custom prettyprint.sections see.private sequences
slots strings summary words ;
IN: classes.struct.prettyprint
<PRIVATE
: struct-definer-word ( class -- word )
struct-slots dup length 2 >=
[ second offset>> 0 = \ UNION-STRUCT: \ STRUCT: ? ]
[ drop \ STRUCT: ] if ;
: struct>assoc ( struct -- assoc )
[ class struct-slots ] [ struct-slot-values ] bi zip ;
: pprint-struct-slot ( slot -- )
<flow \ { pprint-word
{
[ name>> text ]
[ c-type>> dup string? [ text ] [ pprint* ] if ]
[ read-only>> [ \ read-only pprint-word ] when ]
[ initial>> [ \ initial: pprint-word pprint* ] when* ]
} cleave
\ } pprint-word block> ;
: pprint-struct ( struct -- )
[
[ \ S{ ] dip
[ class ]
[ struct>assoc [ [ name>> ] dip ] assoc-map ] bi
\ } (pprint-tuple)
] ?pprint-tuple ;
: pprint-struct-pointer ( struct -- )
\ S@ [ [ class pprint-word ] [ >c-ptr pprint* ] bi ] pprint-prefix ;
PRIVATE>
M: struct-class see-class*
<colon dup struct-definer-word pprint-word dup pprint-word
<block struct-slots [ pprint-struct-slot ] each
block> pprint-; block> ;
M: struct pprint-delims
drop \ S{ \ } ;
M: struct >pprint-sequence
[ class ] [ struct-slot-values ] bi class-slot-sequence ;
M: struct pprint*
[ pprint-struct ]
[ pprint-struct-pointer ] pprint-c-object ;
M: struct summary
[
dup class name>> %
" struct of " %
byte-length #
" bytes " %
] "" make ;
TUPLE: struct-mirror { object read-only } ;
C: <struct-mirror> struct-mirror
: get-struct-slot ( struct slot -- value present? )
over class struct-slots slot-named
[ name>> reader-word execute( struct -- value ) t ]
[ drop f f ] if* ;
: set-struct-slot ( value struct slot -- )
over class struct-slots slot-named
[ name>> writer-word execute( value struct -- ) ]
[ 2drop ] if* ;
: reset-struct-slot ( struct slot -- )
over class struct-slots slot-named
[ [ initial>> swap ] [ name>> writer-word ] bi execute( value struct -- ) ]
[ drop ] if* ;
: reset-struct-slots ( struct -- )
dup class struct-prototype
dup byte-length memcpy ;
M: struct-mirror at*
object>> {
{ [ over "underlying" = ] [ nip >c-ptr t ] }
{ [ over { [ array? ] [ length 1 >= ] } 1&& ] [ swap first get-struct-slot ] }
[ 2drop f f ]
} cond ;
M: struct-mirror set-at
object>> {
{ [ over "underlying" = ] [ 3drop ] }
{ [ over array? ] [ swap first set-struct-slot ] }
[ 3drop ]
} cond ;
M: struct-mirror delete-at
object>> {
{ [ over "underlying" = ] [ 2drop ] }
{ [ over array? ] [ swap first reset-struct-slot ] }
[ 2drop ]
} cond ;
M: struct-mirror clear-assoc
object>> reset-struct-slots ;
M: struct-mirror >alist ( mirror -- alist )
object>> [
[ drop "underlying" ] [ >c-ptr ] bi 2array 1array
] [
'[
_ struct>assoc
[ [ [ name>> ] [ c-type>> ] bi 2array ] dip ] assoc-map
] [ drop { } ] recover
] bi append ;
M: struct make-mirror <struct-mirror> ;
INSTANCE: struct-mirror assoc

115
basis/classes/struct/struct-docs.factor Normal file
View File

@ -0,0 +1,115 @@
! (c)Joe Groff bsd license
USING: alien classes help.markup help.syntax kernel libc
quotations slots ;
IN: classes.struct
HELP: <struct-boa>
{ $values
{ "class" class }
}
{ $description "This macro implements " { $link boa } " for " { $link struct } " classes. A struct of the given class is constructed, and its slots are initialized using values off the top of the datastack." } ;
HELP: (struct)
{ $values
{ "class" class }
{ "struct" struct }
}
{ $description "Allocates garbage-collected heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are left uninitialized; in most cases, the " { $link <struct> } " word, which initializes the struct's slots with their initial values, should be used instead." } ;
{ (struct) (malloc-struct) } related-words
HELP: <struct>
{ $values
{ "class" class }
{ "struct" struct }
}
{ $description "Allocates garbage-collected heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are initialized with the initial values specified in the struct definition." } ;
{ <struct> <struct-boa> malloc-struct memory>struct } related-words
HELP: STRUCT:
{ $syntax "STRUCT: class { slot type } { slot type } ... ;" }
{ $values { "class" "a new " { $link struct } " class to define" } { "slots" "a list of slot specifiers" } }
{ $description "Defines a new " { $link struct } " type. The syntax is nearly identical to " { $link POSTPONE: TUPLE: } "; however, there are some additional restrictions on struct types:"
{ $list
{ "Struct classes cannot have a superclass defined." }
{ "The slots of a struct must all have a type declared. The type must be a C type." }
{ { $link read-only } " slots on structs are not enforced, though they may be declared." }
} } ;
HELP: S{
{ $syntax "S{ class slots... }" }
{ $values { "class" "a " { $link struct } " class word" } { "slots" "slot values" } }
{ $description "Marks the beginning of a literal struct. The syntax is identical to tuple literal syntax with " { $link POSTPONE: T{ } { $snippet " }" } "; either the assoc syntax (that is, " { $snippet "S{ class { slot value } { slot value } ... }" } ") or the simple syntax (" { $snippet "S{ class f value value ... }" } ") can be used." } ;
HELP: S@
{ $syntax "S@ class alien" }
{ $values { "class" "a " { $link struct } " class word" } { "alien" "a literal alien" } }
{ $description "Marks the beginning of a literal struct at a specific C address. The prettyprinter uses this syntax when the memory backing a struct object is invalid. This syntax should not generally be used in source code." } ;
{ POSTPONE: S{ POSTPONE: S@ } related-words
HELP: UNION-STRUCT:
{ $syntax "UNION-STRUCT: class { slot type } { slot type } ... ;" }
{ $values { "class" "a new " { $link struct } " class to define" } { "slots" "a list of slot specifiers" } }
{ $description "Defines a new " { $link struct } " type where all of the slots share the same storage. See " { $link POSTPONE: STRUCT: } " for details on the syntax." } ;
HELP: define-struct-class
{ $values
{ "class" class } { "slots" "a sequence of " { $link struct-slot-spec } "s" }
}
{ $description "Defines a new " { $link struct } " class. This is the runtime equivalent of the " { $link POSTPONE: STRUCT: } " syntax." } ;
HELP: define-union-struct-class
{ $values
{ "class" class } { "slots" "a sequence of " { $link struct-slot-spec } "s" }
}
{ $description "Defines a new " { $link struct } " class where all of the slots share the same storage. This is the runtime equivalent of the " { $link POSTPONE: UNION-STRUCT: } " syntax." } ;
HELP: malloc-struct
{ $values
{ "class" class }
{ "struct" struct }
}
{ $description "Allocates unmanaged C heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are initialized to their initial values. The struct should be " { $link free } "d when it is no longer needed." } ;
HELP: (malloc-struct)
{ $values
{ "class" class }
{ "struct" struct }
}
{ $description "Allocates unmanaged C heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are left uninitialized; to initialize the allocated memory with the slots' initial values, use " { $link malloc-struct } ". The struct should be " { $link free } "d when it is no longer needed." } ;
HELP: memory>struct
{ $values
{ "ptr" c-ptr } { "class" class }
{ "struct" struct }
}
{ $description "Constructs a new " { $link struct } " of the specified " { $snippet "class" } " at the memory location referenced by " { $snippet "ptr" } ". The referenced memory is unchanged." } ;
HELP: struct
{ $class-description "The parent class of all struct types." } ;
{ struct POSTPONE: STRUCT: POSTPONE: UNION-STRUCT: } related-words
HELP: struct-class
{ $class-description "The metaclass of all " { $link struct } " classes." } ;
ARTICLE: "classes.struct" "Struct classes"
{ $link struct } " classes are similar to " { $link tuple } "s, but their slots exhibit value semantics, and they are backed by a contiguous structured block of memory. Structs can be used for structured access to C memory or Factor byte arrays and for passing struct values in and out of the FFI. Struct types are defined using a syntax similar to tuple syntax:"
{ $subsection POSTPONE: STRUCT: }
"Structs can be allocated with " { $link new } "- and " { $link boa } "-like constructor words. Additional words are provided for building structs from C memory and from existing buffers:"
{ $subsection <struct> }
{ $subsection <struct-boa> }
{ $subsection malloc-struct }
{ $subsection memory>struct }
"When the contents of a struct will be immediately reset, faster primitive words are available that will create a struct without initializing its contents:"
{ $subsection (struct) }
{ $subsection (malloc-struct) }
"Structs have literal syntax like tuples:"
{ $subsection POSTPONE: S{ }
"Union structs are also supported, which behave like structs but share the same memory for all the type's slots."
{ $subsection POSTPONE: UNION-STRUCT: }
;
ABOUT: "classes.struct"

348
basis/classes/struct/struct-tests.factor Executable file
View File

@ -0,0 +1,348 @@
! (c)Joe Groff bsd license
USING: accessors alien alien.c-types alien.libraries
alien.structs.fields alien.syntax ascii assocs byte-arrays
classes.struct classes.tuple.private combinators
compiler.tree.debugger compiler.units destructors
io.encodings.utf8 io.pathnames io.streams.string kernel libc
literals math mirrors multiline namespaces prettyprint
prettyprint.config see sequences specialized-arrays.char
specialized-arrays.int specialized-arrays.ushort
struct-arrays system tools.test ;
IN: classes.struct.tests
<<
: libfactor-ffi-tests-path ( -- string )
"resource:" (normalize-path)
{
{ [ os winnt? ] [ "libfactor-ffi-test.dll" ] }
{ [ os macosx? ] [ "libfactor-ffi-test.dylib" ] }
{ [ os unix? ] [ "libfactor-ffi-test.so" ] }
} cond append-path ;
"f-cdecl" libfactor-ffi-tests-path "cdecl" add-library
"f-stdcall" libfactor-ffi-tests-path "stdcall" add-library
>>
SYMBOL: struct-test-empty
[ [ struct-test-empty { } define-struct-class ] with-compilation-unit ]
[ struct-must-have-slots? ] must-fail-with
STRUCT: struct-test-foo
{ x char }
{ y int initial: 123 }
{ z bool } ;
STRUCT: struct-test-bar
{ w ushort initial: HEX: ffff }
{ foo struct-test-foo } ;
[ 12 ] [ struct-test-foo heap-size ] unit-test
[ 12 ] [ struct-test-foo <struct> byte-length ] unit-test
[ 16 ] [ struct-test-bar heap-size ] unit-test
[ 123 ] [ struct-test-foo <struct> y>> ] unit-test
[ 123 ] [ struct-test-bar <struct> foo>> y>> ] unit-test
[ 1 2 3 t ] [
1 2 3 t struct-test-foo <struct-boa> struct-test-bar <struct-boa>
{
[ w>> ]
[ foo>> x>> ]
[ foo>> y>> ]
[ foo>> z>> ]
} cleave
] unit-test
[ 7654 ] [ S{ struct-test-foo f 98 7654 f } y>> ] unit-test
[ 7654 ] [ S{ struct-test-foo { y 7654 } } y>> ] unit-test
[ {
{ "underlying" B{ 98 0 0 98 127 0 0 127 0 0 0 0 } }
{ { "x" "char" } 98 }
{ { "y" "int" } HEX: 7F00007F }
{ { "z" "bool" } f }
} ] [
B{ 98 0 0 98 127 0 0 127 0 0 0 0 } struct-test-foo memory>struct
make-mirror >alist
] unit-test
[ { { "underlying" f } } ] [
f struct-test-foo memory>struct
make-mirror >alist
] unit-test
[ 55 t ] [ S{ struct-test-foo { x 55 } } make-mirror { "x" "char" } swap at* ] unit-test
[ 55 t ] [ S{ struct-test-foo { y 55 } } make-mirror { "y" "int" } swap at* ] unit-test
[ t t ] [ S{ struct-test-foo { z t } } make-mirror { "z" "bool" } swap at* ] unit-test
[ f t ] [ S{ struct-test-foo { z f } } make-mirror { "z" "bool" } swap at* ] unit-test
[ f f ] [ S{ struct-test-foo } make-mirror { "nonexist" "bool" } swap at* ] unit-test
[ f f ] [ S{ struct-test-foo } make-mirror "nonexist" swap at* ] unit-test
[ f t ] [ f struct-test-foo memory>struct make-mirror "underlying" swap at* ] unit-test
[ S{ struct-test-foo { x 3 } { y 2 } { z f } } ] [
S{ struct-test-foo { x 1 } { y 2 } { z f } }
[ make-mirror [ 3 { "x" "char" } ] dip set-at ] keep
] unit-test
[ S{ struct-test-foo { x 1 } { y 5 } { z f } } ] [
S{ struct-test-foo { x 1 } { y 2 } { z f } }
[ make-mirror [ 5 { "y" "int" } ] dip set-at ] keep
] unit-test
[ S{ struct-test-foo { x 1 } { y 2 } { z t } } ] [
S{ struct-test-foo { x 1 } { y 2 } { z f } }
[ make-mirror [ t { "z" "bool" } ] dip set-at ] keep
] unit-test
[ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [
S{ struct-test-foo { x 1 } { y 2 } { z f } }
[ make-mirror [ "nonsense" "underlying" ] dip set-at ] keep
] unit-test
[ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [
S{ struct-test-foo { x 1 } { y 2 } { z f } }
[ make-mirror [ "nonsense" "nonexist" ] dip set-at ] keep
] unit-test
[ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [
S{ struct-test-foo { x 1 } { y 2 } { z f } }
[ make-mirror [ "nonsense" { "nonexist" "int" } ] dip set-at ] keep
] unit-test
[ S{ struct-test-foo { x 1 } { y 123 } { z f } } ] [
S{ struct-test-foo { x 1 } { y 2 } { z f } }
[ make-mirror { "y" "int" } swap delete-at ] keep
] unit-test
[ S{ struct-test-foo { x 0 } { y 2 } { z f } } ] [
S{ struct-test-foo { x 1 } { y 2 } { z f } }
[ make-mirror { "x" "char" } swap delete-at ] keep
] unit-test
[ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [
S{ struct-test-foo { x 1 } { y 2 } { z f } }
[ make-mirror { "nonexist" "char" } swap delete-at ] keep
] unit-test
[ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [
S{ struct-test-foo { x 1 } { y 2 } { z f } }
[ make-mirror "underlying" swap delete-at ] keep
] unit-test
[ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [
S{ struct-test-foo { x 1 } { y 2 } { z f } }
[ make-mirror "nonsense" swap delete-at ] keep
] unit-test
[ S{ struct-test-foo { x 0 } { y 123 } { z f } } ] [
S{ struct-test-foo { x 1 } { y 2 } { z t } }
[ make-mirror clear-assoc ] keep
] unit-test
UNION-STRUCT: struct-test-float-and-bits
{ f float }
{ bits uint } ;
[ 1.0 ] [ struct-test-float-and-bits <struct> 1.0 float>bits >>bits f>> ] unit-test
[ 4 ] [ struct-test-float-and-bits heap-size ] unit-test
[ 123 ] [ [ struct-test-foo malloc-struct &free y>> ] with-destructors ] unit-test
STRUCT: struct-test-string-ptr
{ x char* } ;
[ "hello world" ] [
[
struct-test-string-ptr <struct>
"hello world" utf8 malloc-string &free >>x
x>>
] with-destructors
] unit-test
[ "S{ struct-test-foo { x 0 } { y 7654 } { z f } }" ]
[
[
boa-tuples? off
c-object-pointers? off
struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer
] with-scope
] unit-test
[ "S@ struct-test-foo B{ 0 0 0 0 0 0 0 0 0 0 0 0 }" ]
[
[
c-object-pointers? on
12 <byte-array> struct-test-foo memory>struct [ pprint ] with-string-writer
] with-scope
] unit-test
[ "S{ struct-test-foo f 0 7654 f }" ]
[
[
boa-tuples? on
c-object-pointers? off
struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer
] with-scope
] unit-test
[ "S@ struct-test-foo f" ]
[
[
c-object-pointers? off
f struct-test-foo memory>struct [ pprint ] with-string-writer
] with-scope
] unit-test
[ <" USING: classes.struct ;
IN: classes.struct.tests
STRUCT: struct-test-foo
{ x char initial: 0 } { y int initial: 123 } { z bool } ;
"> ]
[ [ struct-test-foo see ] with-string-writer ] unit-test
[ <" USING: classes.struct ;
IN: classes.struct.tests
UNION-STRUCT: struct-test-float-and-bits
{ f float initial: 0.0 } { bits uint initial: 0 } ;
"> ]
[ [ struct-test-float-and-bits see ] with-string-writer ] unit-test
[ {
T{ field-spec
{ name "x" }
{ offset 0 }
{ type "char" }
{ reader x>> }
{ writer (>>x) }
}
T{ field-spec
{ name "y" }
{ offset 4 }
{ type "int" }
{ reader y>> }
{ writer (>>y) }
}
T{ field-spec
{ name "z" }
{ offset 8 }
{ type "bool" }
{ reader z>> }
{ writer (>>z) }
}
} ] [ "struct-test-foo" c-type fields>> ] unit-test
[ {
T{ field-spec
{ name "f" }
{ offset 0 }
{ type "float" }
{ reader f>> }
{ writer (>>f) }
}
T{ field-spec
{ name "bits" }
{ offset 0 }
{ type "uint" }
{ reader bits>> }
{ writer (>>bits) }
}
} ] [ "struct-test-float-and-bits" c-type fields>> ] unit-test
STRUCT: struct-test-equality-1
{ x int } ;
STRUCT: struct-test-equality-2
{ y int } ;
[ t ] [
[
struct-test-equality-1 <struct> 5 >>x
struct-test-equality-1 malloc-struct &free 5 >>x =
] with-destructors
] unit-test
[ f ] [
[
struct-test-equality-1 <struct> 5 >>x
struct-test-equality-2 malloc-struct &free 5 >>y =
] with-destructors
] unit-test
[ t ] [
[
struct-test-equality-1 <struct> 5 >>x
struct-test-equality-1 malloc-struct &free 5 >>x
[ hashcode ] bi@ =
] with-destructors
] unit-test
STRUCT: struct-test-ffi-foo
{ x int }
{ y int } ;
LIBRARY: f-cdecl
FUNCTION: int ffi_test_11 ( int a, struct-test-ffi-foo b, int c ) ;
[ 14 ] [ 1 2 3 struct-test-ffi-foo <struct-boa> 4 ffi_test_11 ] unit-test
STRUCT: struct-test-array-slots
{ x int }
{ y ushort[6] initial: ushort-array{ 2 3 5 7 11 13 } }
{ z int } ;
[ 11 ] [ struct-test-array-slots <struct> y>> 4 swap nth ] unit-test
[ t ] [
struct-test-array-slots <struct>
[ y>> [ 8 3 ] dip set-nth ]
[ y>> ushort-array{ 2 3 5 8 11 13 } sequence= ] bi
] unit-test
STRUCT: struct-test-optimization
{ x { "int" 3 } } { y int } ;
[ t ] [ [ struct-test-optimization memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
[ t ] [
[ 3 struct-test-optimization <direct-struct-array> third y>> ]
{ <tuple> <tuple-boa> memory>struct y>> } inlined?
] unit-test
[ t ] [ [ struct-test-optimization memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
[ t ] [
[ struct-test-optimization memory>struct x>> second ]
{ memory>struct x>> <direct-int-array> <tuple> <tuple-boa> } inlined?
] unit-test
[ f ] [ [ memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
[ t ] [
[ struct-test-optimization <struct> struct-test-optimization <struct> [ x>> ] bi@ ]
{ x>> } inlined?
] unit-test
! Test cloning structs
STRUCT: clone-test-struct { x int } { y char[3] } ;
[ 1 char-array{ 9 1 1 } ] [
clone-test-struct <struct>
1 >>x char-array{ 9 1 1 } >>y
clone
[ x>> ] [ y>> >char-array ] bi
] unit-test
[ t 1 char-array{ 9 1 1 } ] [
[
clone-test-struct malloc-struct &free
1 >>x char-array{ 9 1 1 } >>y
clone
[ >c-ptr byte-array? ] [ x>> ] [ y>> >char-array ] tri
] with-destructors
] unit-test
STRUCT: struct-that's-a-word { x int } ;
: struct-that's-a-word ( -- ) "OOPS" throw ;
[ -77 ] [ S{ struct-that's-a-word { x -77 } } clone x>> ] unit-test

323
basis/classes/struct/struct.factor Executable file
View File

@ -0,0 +1,323 @@
! (c)Joe Groff bsd license
USING: accessors alien alien.c-types alien.structs
alien.structs.fields arrays byte-arrays classes classes.parser
classes.tuple classes.tuple.parser classes.tuple.private
combinators combinators.short-circuit combinators.smart
definitions functors.backend fry generalizations generic.parser
kernel kernel.private lexer libc locals macros make math math.order
parser quotations sequences slots slots.private struct-arrays vectors
words compiler.tree.propagation.transforms specialized-arrays.uchar ;
FROM: slots => reader-word writer-word ;
IN: classes.struct
! struct class
ERROR: struct-must-have-slots ;
TUPLE: struct
{ (underlying) c-ptr read-only } ;
TUPLE: struct-slot-spec < slot-spec
c-type ;
PREDICATE: struct-class < tuple-class \ struct subclass-of? ;
: struct-slots ( struct-class -- slots )
"struct-slots" word-prop ;
! struct allocation
M: struct >c-ptr
2 slot { c-ptr } declare ; inline
M: struct equal?
{
[ [ class ] bi@ = ]
[ [ >c-ptr ] [ [ >c-ptr ] [ byte-length ] bi ] bi* memory= ]
} 2&& ; inline
M: struct hashcode*
[ >c-ptr ] [ byte-length ] bi <direct-uchar-array> hashcode* ; inline
: struct-prototype ( class -- prototype ) "prototype" word-prop ; foldable
: memory>struct ( ptr class -- struct )
! This is sub-optimal if the class is not literal, but gets
! optimized down to efficient code if it is.
'[ _ boa ] call( ptr -- struct ) ; inline
<PRIVATE
: (init-struct) ( class with-prototype: ( prototype -- alien ) sans-prototype: ( class -- alien ) -- alien )
'[ dup struct-prototype _ _ ?if ] keep memory>struct ; inline
PRIVATE>
: (malloc-struct) ( class -- struct )
[ heap-size malloc ] keep memory>struct ; inline
: malloc-struct ( class -- struct )
[ >c-ptr malloc-byte-array ] [ 1 swap heap-size calloc ] (init-struct) ; inline
: (struct) ( class -- struct )
[ heap-size (byte-array) ] keep memory>struct ; inline
: <struct> ( class -- struct )
[ >c-ptr clone ] [ heap-size <byte-array> ] (init-struct) ; inline
MACRO: <struct-boa> ( class -- quot: ( ... -- struct ) )
[
[ <wrapper> \ (struct) [ ] 2sequence ]
[
struct-slots
[ length \ ndip ]
[ [ name>> setter-word 1quotation ] map \ spread ] bi
] bi
] [ ] output>sequence ;
<PRIVATE
: pad-struct-slots ( values class -- values' class )
[ struct-slots [ initial>> ] map over length tail append ] keep ;
: (reader-quot) ( slot -- quot )
[ c-type>> c-type-getter-boxer ]
[ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
: (writer-quot) ( slot -- quot )
[ c-type>> c-setter ]
[ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
: (boxer-quot) ( class -- quot )
'[ _ memory>struct ] ;
: (unboxer-quot) ( class -- quot )
drop [ >c-ptr ] ;
PRIVATE>
M: struct-class boa>object
swap pad-struct-slots
[ <struct> ] [ struct-slots ] bi
[ [ (writer-quot) call( value struct -- ) ] with 2each ] curry keep ;
! Struct slot accessors
GENERIC: struct-slot-values ( struct -- sequence )
M: struct-class reader-quot
nip (reader-quot) ;
M: struct-class writer-quot
nip (writer-quot) ;
! c-types
<PRIVATE
: struct-slot-values-quot ( class -- quot )
struct-slots
[ name>> reader-word 1quotation ] map
\ cleave [ ] 2sequence
\ output>array [ ] 2sequence ;
: define-inline-method ( class generic quot -- )
[ create-method-in ] dip [ define ] [ drop make-inline ] 2bi ;
: (define-struct-slot-values-method) ( class -- )
[ \ struct-slot-values ] [ struct-slot-values-quot ] bi
define-inline-method ;
: clone-underlying ( struct -- byte-array )
[ >c-ptr ] [ byte-length ] bi memory>byte-array ; inline
: (define-clone-method) ( class -- )
[ \ clone ]
[ \ clone-underlying swap literalize \ memory>struct [ ] 3sequence ] bi
define-inline-method ;
: slot>field ( slot -- field )
field-spec new swap {
[ name>> >>name ]
[ offset>> >>offset ]
[ c-type>> >>type ]
[ name>> reader-word >>reader ]
[ name>> writer-word >>writer ]
} cleave ;
: define-struct-for-class ( class -- )
[
{
[ name>> ]
[ "struct-size" word-prop ]
[ "struct-align" word-prop ]
[ struct-slots [ slot>field ] map ]
} cleave
struct-type (define-struct)
] [
{
[ name>> c-type ]
[ (unboxer-quot) >>unboxer-quot ]
[ (boxer-quot) >>boxer-quot ]
[ >>boxed-class ]
} cleave drop
] bi ;
: align-offset ( offset class -- offset' )
c-type-align align ;
: struct-offsets ( slots -- size )
0 [
[ c-type>> align-offset ] keep
[ (>>offset) ] [ c-type>> heap-size + ] 2bi
] reduce ;
: union-struct-offsets ( slots -- size )
[ 0 >>offset c-type>> heap-size ] [ max ] map-reduce ;
: struct-align ( slots -- align )
[ c-type>> c-type-align ] [ max ] map-reduce ;
PRIVATE>
M: struct-class c-type
name>> c-type ;
M: struct-class c-type-align
"struct-align" word-prop ;
M: struct-class c-type-getter
drop [ swap <displaced-alien> ] ;
M: struct-class c-type-setter
[ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri
'[ @ swap @ _ memcpy ] ;
M: struct-class c-type-boxer-quot
(boxer-quot) ;
M: struct-class c-type-unboxer-quot
(unboxer-quot) ;
M: struct-class heap-size
"struct-size" word-prop ;
M: struct byte-length
class "struct-size" word-prop ; foldable
! class definition
<PRIVATE
: make-struct-prototype ( class -- prototype )
[ heap-size <byte-array> ]
[ memory>struct ]
[ struct-slots ] tri
[
[ initial>> ]
[ (writer-quot) ] bi
over [ swapd [ call( value struct -- ) ] curry keep ] [ 2drop ] if
] each ;
: (struct-methods) ( class -- )
[ (define-struct-slot-values-method) ]
[ (define-clone-method) ]
bi ;
: (struct-word-props) ( class slots size align -- )
[
[ "struct-slots" set-word-prop ]
[ define-accessors ] 2bi
]
[ "struct-size" set-word-prop ]
[ "struct-align" set-word-prop ] tri-curry*
[ tri ] 3curry
[ dup make-struct-prototype "prototype" set-word-prop ]
[ (struct-methods) ] tri ;
: check-struct-slots ( slots -- )
[ c-type>> c-type drop ] each ;
: redefine-struct-tuple-class ( class -- )
[ dup class? [ forget-class ] [ drop ] if ] [ struct f define-tuple-class ] bi ;
: (define-struct-class) ( class slots offsets-quot -- )
[
[ struct-must-have-slots ]
[ drop redefine-struct-tuple-class ] if-empty
]
swap '[
make-slots dup
[ check-struct-slots ] _ [ struct-align [ align ] keep ] tri
(struct-word-props)
]
[ drop define-struct-for-class ] 2tri ; inline
PRIVATE>
: define-struct-class ( class slots -- )
[ struct-offsets ] (define-struct-class) ;
: define-union-struct-class ( class slots -- )
[ union-struct-offsets ] (define-struct-class) ;
ERROR: invalid-struct-slot token ;
: struct-slot-class ( c-type -- class' )
c-type c-type-boxed-class
dup \ byte-array = [ drop \ c-ptr ] when ;
: <struct-slot-spec> ( name c-type attributes -- slot-spec )
[ struct-slot-spec new ] 3dip
[ >>name ]
[ [ >>c-type ] [ struct-slot-class >>class ] bi ]
[ [ dup empty? ] [ peel-off-attributes ] until drop ] tri* ;
<PRIVATE
: scan-c-type ( -- c-type )
scan dup "{" = [ drop \ } parse-until >array ] when ;
: parse-struct-slot ( -- slot )
scan scan-c-type \ } parse-until <struct-slot-spec> ;
: parse-struct-slots ( slots -- slots' more? )
scan {
{ ";" [ f ] }
{ "{" [ parse-struct-slot over push t ] }
[ invalid-struct-slot ]
} case ;
: parse-struct-definition ( -- class slots )
CREATE-CLASS 8 <vector> [ parse-struct-slots ] [ ] while >array ;
PRIVATE>
SYNTAX: STRUCT:
parse-struct-definition define-struct-class ;
SYNTAX: UNION-STRUCT:
parse-struct-definition define-union-struct-class ;
SYNTAX: S{
scan-word dup struct-slots parse-tuple-literal-slots parsed ;
SYNTAX: S@
scan-word scan-object swap memory>struct parsed ;
! functor support
<PRIVATE
: scan-c-type` ( -- c-type/param )
scan dup "{" = [ drop \ } parse-until >array ] [ >string-param ] if ;
: parse-struct-slot` ( accum -- accum )
scan-string-param scan-c-type` \ } parse-until
[ <struct-slot-spec> over push ] 3curry over push-all ;
: parse-struct-slots` ( accum -- accum more? )
scan {
{ ";" [ f ] }
{ "{" [ parse-struct-slot` t ] }
[ invalid-struct-slot ]
} case ;
PRIVATE>
FUNCTOR-SYNTAX: STRUCT:
scan-param parsed
[ 8 <vector> ] over push-all
[ parse-struct-slots` ] [ ] while
[ >array define-struct-class ] over push-all ;
USING: vocabs vocabs.loader ;
"prettyprint" vocab [ "classes.struct.prettyprint" require ] when

2
basis/cocoa/application/application.factor
View File

@ -18,7 +18,7 @@ NSApplicationDelegateReplyFailure ;
: NSApp ( -- app ) NSApplication -> sharedApplication ;
: NSAnyEventMask ( -- mask ) HEX: ffffffff ; inline
CONSTANT: NSAnyEventMask HEX: ffffffff
FUNCTION: void NSBeep ( ) ;

2
basis/cocoa/callbacks/callbacks.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2005, 2006 Kevin Reid.
! See http://factorcode.org/license.txt for BSD license.
IN: cocoa.callbacks
USING: assocs kernel namespaces cocoa cocoa.classes
cocoa.subclassing debugger ;
IN: cocoa.callbacks
SYMBOL: callbacks

2
basis/cocoa/cocoa-tests.factor
View File

@ -1,7 +1,7 @@
IN: cocoa.tests
USING: cocoa cocoa.messages cocoa.subclassing cocoa.types
compiler kernel namespaces cocoa.classes tools.test memory
compiler.units math core-graphics.types ;
IN: cocoa.tests
CLASS: {
{ +superclass+ "NSObject" }

1
basis/cocoa/cocoa.factor
View File

@ -60,6 +60,7 @@ SYNTAX: IMPORT: scan [ ] import-objc-class ;
"NSOpenGLPixelFormat"
"NSOpenGLView"
"NSOpenPanel"
"NSPanel"
"NSPasteboard"
"NSPropertyListSerialization"
"NSResponder"

19
basis/cocoa/enumeration/enumeration.factor Normal file → Executable file
View File

@ -1,27 +1,28 @@
! Copyright (C) 2008 Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel cocoa cocoa.types alien.c-types locals math
sequences vectors fry libc destructors
specialized-arrays.direct.alien ;
USING: accessors kernel classes.struct cocoa cocoa.types alien.c-types
locals math sequences vectors fry libc destructors ;
IN: cocoa.enumeration
<< "id" require-c-array >>
CONSTANT: NS-EACH-BUFFER-SIZE 16
: with-enumeration-buffers ( quot -- )
'[
"NSFastEnumerationState" malloc-object &free
NSFastEnumerationState malloc-struct &free
NS-EACH-BUFFER-SIZE "id" malloc-array &free
NS-EACH-BUFFER-SIZE
@
] with-destructors ; inline
:: (NSFastEnumeration-each) ( object quot: ( elt -- ) state stackbuf count -- )
object state stackbuf count -> countByEnumeratingWithState:objects:count:
dup 0 = [ drop ] [
state NSFastEnumerationState-itemsPtr [ stackbuf ] unless*
swap <direct-void*-array> quot each
object state stackbuf count -> countByEnumeratingWithState:objects:count: :> items-count
items-count 0 = [
state itemsPtr>> [ items-count "id" <c-direct-array> ] [ stackbuf ] if* :> items
items-count iota [ items nth quot call ] each
object quot state stackbuf count (NSFastEnumeration-each)
] if ; inline recursive
] unless ; inline recursive
: NSFastEnumeration-each ( object quot -- )
[ (NSFastEnumeration-each) ] with-enumeration-buffers ; inline

31
basis/cocoa/messages/messages.factor Normal file → Executable file
View File

@ -1,11 +1,11 @@
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.strings arrays assocs
continuations combinators compiler compiler.alien stack-checker kernel
math namespaces make quotations sequences strings words
cocoa.runtime io macros memoize io.encodings.utf8 effects libc
libc.private lexer init core-foundation fry generalizations
specialized-arrays.direct.alien ;
classes.struct continuations combinators compiler compiler.alien
stack-checker kernel math namespaces make quotations sequences
strings words cocoa.runtime io macros memoize io.encodings.utf8
effects libc libc.private lexer init core-foundation fry
generalizations specialized-arrays.alien ;
IN: cocoa.messages
: make-sender ( method function -- quot )
@ -31,11 +31,8 @@ super-message-senders [ H{ } clone ] initialize
bi ;
: <super> ( receiver -- super )
"objc-super" <c-object> [
[ dup object_getClass class_getSuperclass ] dip
set-objc-super-class
] keep
[ set-objc-super-receiver ] keep ;
[ ] [ object_getClass class_getSuperclass ] bi
objc-super <struct-boa> ;
TUPLE: selector name object ;
@ -158,12 +155,16 @@ objc>alien-types get [ swap ] assoc-map
} case
assoc-union alien>objc-types set-global
: internal-cocoa-type? ( c-type -- ? )
[ "?" = ] [ first CHAR: _ = ] bi or ;
: warn-c-type ( c-type -- )
dup internal-cocoa-type?
[ drop ] [ "Warning: no such C type: " write print ] if ;
: objc-struct-type ( i string -- ctype )
[ CHAR: = ] 2keep index-from swap subseq
dup c-types get key? [
"Warning: no such C type: " write dup print
drop "void*"
] unless ;
dup c-types get key? [ warn-c-type "void*" ] unless ;
ERROR: no-objc-type name ;
@ -172,7 +173,7 @@ ERROR: no-objc-type name ;
[ ] [ no-objc-type ] ?if ;
: (parse-objc-type) ( i string -- ctype )
[ [ 1+ ] dip ] [ nth ] 2bi {
[ [ 1 + ] dip ] [ nth ] 2bi {
{ [ dup "rnNoORV" member? ] [ drop (parse-objc-type) ] }
{ [ dup CHAR: ^ = ] [ 3drop "void*" ] }
{ [ dup CHAR: { = ] [ drop objc-struct-type ] }

4
basis/cocoa/plists/plists-tests.factor
View File

@ -1,7 +1,7 @@
IN: cocoa.plists.tests
USING: tools.test cocoa.plists colors kernel hashtables
core-foundation.utilities core-foundation destructors
assocs cocoa.enumeration ;
IN: cocoa.plists.tests
[
[ V{ } ] [ H{ } >cf &CFRelease [ ] NSFastEnumeration-map ] unit-test
@ -37,4 +37,4 @@ assocs cocoa.enumeration ;
[ 3.5 ] [
3.5 >cf &CFRelease plist>
] unit-test
] with-destructors
] with-destructors

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

@ -1,6 +1,6 @@
! Copyright (C) 2006, 2007 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax ;
USING: alien.syntax classes.struct ;
IN: cocoa.runtime
TYPEDEF: void* SEL
@ -17,9 +17,9 @@ TYPEDEF: void* Class
TYPEDEF: void* Method
TYPEDEF: void* Protocol
C-STRUCT: objc-super
{ "id" "receiver" }
{ "Class" "class" } ;
STRUCT: objc-super
{ receiver id }
{ class Class } ;
CONSTANT: CLS_CLASS HEX: 1
CONSTANT: CLS_META HEX: 2

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

@ -1,7 +1,7 @@
! Copyright (C) 2006, 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types alien.syntax combinators kernel layouts
core-graphics.types ;
classes.struct core-graphics.types ;
IN: cocoa.types
TYPEDEF: long NSInteger
@ -16,9 +16,9 @@ TYPEDEF: NSSize _NSSize
TYPEDEF: CGRect NSRect
TYPEDEF: NSRect _NSRect
C-STRUCT: NSRange
{ "NSUInteger" "location" }
{ "NSUInteger" "length" } ;
STRUCT: NSRange
{ location NSUInteger }
{ length NSUInteger } ;
TYPEDEF: NSRange _NSRange
@ -27,13 +27,11 @@ TYPEDEF: int long32
TYPEDEF: uint ulong32
TYPEDEF: void* unknown_type
: <NSRange> ( length location -- size )
"NSRange" <c-object>
[ set-NSRange-length ] keep
[ set-NSRange-location ] keep ;
: <NSRange> ( location length -- size )
NSRange <struct-boa> ;
C-STRUCT: NSFastEnumerationState
{ "ulong" "state" }
{ "id*" "itemsPtr" }
{ "ulong*" "mutationsPtr" }
{ "ulong[5]" "extra" } ;
STRUCT: NSFastEnumerationState
{ state ulong }
{ itemsPtr id* }
{ mutationsPtr ulong* }
{ extra ulong[5] } ;

4
basis/cocoa/views/views.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2006, 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: specialized-arrays.int arrays kernel math namespaces make
USING: arrays kernel math namespaces make
cocoa cocoa.messages cocoa.classes core-graphics
core-graphics.types sequences continuations accessors ;
IN: cocoa.views
@ -58,6 +58,6 @@ CONSTANT: NSOpenGLCPSwapInterval 222
: mouse-location ( view event -- loc )
[
-> locationInWindow f -> convertPoint:fromView:
[ CGPoint-x ] [ CGPoint-y ] bi
[ x>> ] [ y>> ] bi
] [ drop -> frame CGRect-h ] 2bi
swap - [ >integer ] bi@ 2array ;

4
basis/cocoa/windows/windows-docs.factor
View File

@ -2,11 +2,11 @@ USING: help.markup help.syntax ;
IN: cocoa.windows
HELP: <NSWindow>
{ $values { "rect" "an " { $snippet "NSRect" } } { "window" "an " { $snippet "NSWindow" } } }
{ $values { "rect" "an " { $snippet "NSRect" } } { "style" "a style mask" } { "class" "an Objective-C class" } { "window" "an " { $snippet "NSWindow" } } }
{ $description "Creates a new " { $snippet "NSWindow" } " with the specified dimensions." } ;
HELP: <ViewWindow>
{ $values { "view" "an " { $snippet "NSView" } } { "rect" "an " { $snippet "NSRect" } } { "window" "an " { $snippet "NSWindow" } } }
{ $values { "view" "an " { $snippet "NSView" } } { "rect" "an " { $snippet "NSRect" } } { "style" "a style mask" } { "window" "an " { $snippet "NSWindow" } } }
{ $description "Creates a new " { $snippet "NSWindow" } " with the specified dimensions, containing the given view." } ;
ARTICLE: "cocoa-window-utils" "Cocoa window utilities"

29
basis/cocoa/windows/windows.factor
View File

@ -4,36 +4,37 @@ USING: arrays kernel math cocoa cocoa.messages cocoa.classes
sequences math.bitwise ;
IN: cocoa.windows
! Window styles
CONSTANT: NSBorderlessWindowMask 0
CONSTANT: NSTitledWindowMask 1
CONSTANT: NSClosableWindowMask 2
CONSTANT: NSMiniaturizableWindowMask 4
CONSTANT: NSResizableWindowMask 8
! Additional panel-only styles
CONSTANT: NSUtilityWindowMask 16
CONSTANT: NSDocModalWindowMask 64
CONSTANT: NSNonactivatingPanelMask 128
CONSTANT: NSHUDWindowMask HEX: 1000
CONSTANT: NSBackingStoreRetained 0
CONSTANT: NSBackingStoreNonretained 1
CONSTANT: NSBackingStoreBuffered 2
: standard-window-type ( -- n )
{
NSTitledWindowMask
NSClosableWindowMask
NSMiniaturizableWindowMask
NSResizableWindowMask
} flags ; inline
: <NSWindow> ( rect -- window )
NSWindow -> alloc swap
standard-window-type NSBackingStoreBuffered 1
: <NSWindow> ( rect style class -- window )
[ -> alloc ] curry 2dip NSBackingStoreBuffered 1
-> initWithContentRect:styleMask:backing:defer: ;
: <ViewWindow> ( view rect -- window )
<NSWindow> [ swap -> setContentView: ] keep
: class-for-style ( style -- NSWindow/NSPanel )
HEX: 1ff0 bitand zero? NSWindow NSPanel ? ;
: <ViewWindow> ( view rect style -- window )
dup class-for-style <NSWindow> [ swap -> setContentView: ] keep
dup dup -> contentView -> setInitialFirstResponder:
dup 1 -> setAcceptsMouseMovedEvents:
dup 0 -> setReleasedWhenClosed: ;
: window-content-rect ( window -- rect )
[ NSWindow ] dip
dup -> class swap
[ -> frame ] [ -> styleMask ] bi
-> contentRectForFrameRect:styleMask: ;

8
basis/colors/constants/constants.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel assocs math math.parser memoize
io.encodings.ascii io.files lexer parser
colors sequences splitting combinators.smart ascii ;
USING: kernel assocs math math.parser memoize io.encodings.utf8
io.files lexer parser colors sequences splitting
combinators.smart ascii ;
IN: colors.constants
<PRIVATE
@ -19,7 +19,7 @@ IN: colors.constants
[ parse-color ] H{ } map>assoc ;
MEMO: rgb.txt ( -- assoc )
"resource:basis/colors/constants/rgb.txt" ascii file-lines parse-rgb.txt ;
"resource:basis/colors/constants/rgb.txt" utf8 file-lines parse-rgb.txt ;
PRIVATE>

4
basis/colors/hsv/hsv-tests.factor
View File

@ -1,5 +1,5 @@
IN: colors.hsv.tests
USING: accessors kernel colors colors.hsv tools.test math ;
IN: colors.hsv.tests
: hsv>rgb ( h s v -- r g b )
[ 360 * ] 2dip
@ -25,4 +25,4 @@ USING: accessors kernel colors colors.hsv tools.test math ;
[ 5/6 5/36 5/6 ] [ 5/6 5/6 5/6 hsv>rgb ] unit-test
[ 1/6 0 1/6 ] [ 5/6 1 1/6 hsv>rgb ] unit-test
[ 0.5 ] [ 180 0.1 0.2 0.5 <hsva> alpha>> ] unit-test
[ 0.5 ] [ 180 0.1 0.2 0.5 <hsva> alpha>> ] unit-test

2
basis/columns/columns-tests.factor
View File

@ -1,5 +1,5 @@
IN: columns.tests
USING: columns sequences kernel namespaces arrays tools.test math ;
IN: columns.tests
! Columns
{ { 1 2 3 } { 4 5 6 } { 7 8 9 } } [ clone ] map "seq" set

48
basis/combinators/short-circuit/short-circuit-docs.factor
View File

@ -1,62 +1,46 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax io.streams.string quotations
math ;
math kernel ;
IN: combinators.short-circuit
HELP: 0&&
{ $values
{ "quots" "a sequence of quotations" }
{ "quot" quotation } }
{ $description "Returns true if every quotation in the sequence of quotations returns true." } ;
{ $values { "quots" "a sequence of quotations with stack effect " { $snippet "( -- )" } } { "?" "the result of the last quotation, or " { $link f } } }
{ $description "If every quotation in the sequence outputs a true value, outputs the result of the last quotation, otherwise outputs " { $link f } "." } ;
HELP: 0||
{ $values
{ "quots" "a sequence of quotations" }
{ "quot" quotation } }
{ $description "Returns true if any quotation in the sequence returns true." } ;
{ $values { "quots" "a sequence of quotations with stack effect " { $snippet "( -- )" } } { "?" "the first true result, or " { $link f } } }
{ $description "If every quotation in the sequence outputs " { $link f } ", outputs " { $link f } ", otherwise outputs the result of the first quotation that did not yield " { $link f } "." } ;
HELP: 1&&
{ $values
{ "quots" "a sequence of quotations" }
{ "quot" quotation } }
{ $description "Returns true if every quotation in the sequence of quotations returns true. Each quotation gets the same element from the datastack and must output a boolean." } ;
{ $values { "obj" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj -- )" } } { "?" "the result of the last quotation, or " { $link f } } }
{ $description "If every quotation in the sequence outputs a true value, outputs the result of the last quotation, otherwise outputs " { $link f } "." } ;
HELP: 1||
{ $values
{ "quots" "a sequence of quotations" }
{ "quot" quotation } }
{ $values { "obj" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj -- )" } } { "?" "the first true result, or " { $link f } } }
{ $description "Returns true if any quotation in the sequence returns true. Each quotation takes the same element from the datastack and must return a boolean." } ;
HELP: 2&&
{ $values
{ "quots" "a sequence of quotations" }
{ "quot" quotation } }
{ $description "Returns true if every quotation in the sequence of quotations returns true. Each quotation gets the same two elements from the datastack and must output a boolean." } ;
{ $values { "obj1" object } { "obj2" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj1 obj2 -- )" } } { "?" "the result of the last quotation, or " { $link f } } }
{ $description "If every quotation in the sequence outputs a true value, outputs the result of the last quotation, otherwise outputs " { $link f } "." } ;
HELP: 2||
{ $values
{ "quots" "a sequence of quotations" }
{ "quot" quotation } }
{ $values { "obj1" object } { "obj2" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj1 obj2 -- )" } } { "?" "the first true result, or " { $link f } } }
{ $description "Returns true if any quotation in the sequence returns true. Each quotation takes the same two elements from the datastack and must return a boolean." } ;
HELP: 3&&
{ $values
{ "quots" "a sequence of quotations" }
{ "quot" quotation } }
{ $description "Returns true if every quotation in the sequence of quotations returns true. Each quotation gets the same three elements from the datastack and must output a boolean." } ;
{ $values { "obj1" object } { "obj2" object } { "obj3" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj1 obj2 obj3 -- )" } } { "?" "the result of the last quotation, or " { $link f } } }
{ $description "If every quotation in the sequence outputs a true value, outputs the result of the last quotation, otherwise outputs " { $link f } "." } ;
HELP: 3||
{ $values
{ "quots" "a sequence of quotations" }
{ "quot" quotation } }
{ $values { "obj1" object } { "obj2" object } { "obj3" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj1 obj2 obj3 -- )" } } { "?" "the first true result, or " { $link f } } }
{ $description "Returns true if any quotation in the sequence returns true. Each quotation takes the same three elements from the datastack and must return a boolean." } ;
HELP: n&&
{ $values
{ "quots" "a sequence of quotations" } { "N" integer }
{ "quots" "a sequence of quotations" } { "n" integer }
{ "quot" quotation } }
{ $description "A macro that rewrites the code to pass " { $snippet "n" } " parameters from the stack to each AND quotation." } ;
{ $description "A macro that rewrites the code to pass " { $snippet "n" } " parameters from the stack to each quotation, evaluating the result in the same manner as " { $link 0&& } "." } ;
HELP: n||
{ $values

39
basis/combinators/short-circuit/short-circuit-tests.factor
View File

@ -1,32 +1,25 @@
USING: kernel math tools.test combinators.short-circuit ;
IN: combinators.short-circuit.tests
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
[ 3 ] [ { [ 1 ] [ 2 ] [ 3 ] } 0&& ] unit-test
[ 5 ] [ 3 { [ 0 > ] [ odd? ] [ 2 + ] } 1&& ] unit-test
[ 30 ] [ 10 20 { [ + 0 > ] [ - even? ] [ + ] } 2&& ] unit-test
: must-be-t ( in -- ) [ t ] swap unit-test ;
: must-be-f ( in -- ) [ f ] swap unit-test ;
[ f ] [ { [ 1 ] [ f ] [ 3 ] } 0&& ] unit-test
[ f ] [ 3 { [ 0 > ] [ even? ] [ 2 + ] } 1&& ] unit-test
[ f ] [ 10 20 { [ + 0 > ] [ - odd? ] [ + ] } 2&& ] unit-test
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
[ "factor" ] [ { [ 10 0 < ] [ f ] [ "factor" ] } 0|| ] unit-test
[ 11 ] [ 10 { [ odd? ] [ 100 > ] [ 1 + ] } 1|| ] unit-test
[ 30 ] [ 10 20 { [ + odd? ] [ + 100 > ] [ + ] } 2|| ] unit-test
[ f ] [ { [ 10 0 < ] [ f ] [ 0 1 = ] } 0|| ] unit-test
[ { [ 1 ] [ 2 ] [ 3 ] } 0&& 3 = ] must-be-t
[ 3 { [ 0 > ] [ odd? ] [ 2 + ] } 1&& 5 = ] must-be-t
[ 10 20 { [ + 0 > ] [ - even? ] [ + ] } 2&& 30 = ] must-be-t
: compiled-&& ( a -- ? ) { [ 0 > ] [ even? ] [ 2 + ] } 1&& ;
[ { [ 1 ] [ f ] [ 3 ] } 0&& 3 = ] must-be-f
[ 3 { [ 0 > ] [ even? ] [ 2 + ] } 1&& ] must-be-f
[ 10 20 { [ + 0 > ] [ - odd? ] [ + ] } 2&& 30 = ] must-be-f
[ f ] [ 3 compiled-&& ] unit-test
[ 4 ] [ 2 compiled-&& ] unit-test
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
[ { [ 10 0 < ] [ f ] [ "factor" ] } 0|| "factor" = ] must-be-t
[ 10 { [ odd? ] [ 100 > ] [ 1 + ] } 1|| 11 = ] must-be-t
[ 10 20 { [ + odd? ] [ + 100 > ] [ + ] } 2|| 30 = ] must-be-t
[ { [ 10 0 < ] [ f ] [ 0 1 = ] } 0|| ] must-be-f
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: compiled-|| ( a b -- ? ) { [ + odd? ] [ + 100 > ] [ + ] } 2|| ;
[ 30 ] [ 10 20 compiled-|| ] unit-test
[ 2 ] [ 1 1 compiled-|| ] unit-test

30
basis/combinators/short-circuit/short-circuit.factor
View File

@ -12,10 +12,17 @@ MACRO:: n&& ( quots n -- quot )
n '[ _ nnip ] suffix 1array
[ cond ] 3append ;
MACRO: 0&& ( quots -- quot ) '[ _ 0 n&& ] ;
MACRO: 1&& ( quots -- quot ) '[ _ 1 n&& ] ;
MACRO: 2&& ( quots -- quot ) '[ _ 2 n&& ] ;
MACRO: 3&& ( quots -- quot ) '[ _ 3 n&& ] ;
<PRIVATE
: unoptimized-&& ( quots quot -- ? )
[ [ call dup ] ] dip call [ nip ] prepose [ f ] 2dip all? swap and ; inline
PRIVATE>
: 0&& ( quots -- ? ) [ ] unoptimized-&& ;
: 1&& ( obj quots -- ? ) [ with ] unoptimized-&& ;
: 2&& ( obj1 obj2 quots -- ? ) [ with with ] unoptimized-&& ;
: 3&& ( obj1 obj2 obj3 quots -- ? ) [ with with with ] unoptimized-&& ;
MACRO:: n|| ( quots n -- quot )
[ f ] quots [| q |
@ -27,7 +34,14 @@ MACRO:: n|| ( quots n -- quot )
n '[ drop _ ndrop t ] [ f ] 2array suffix 1array
[ cond ] 3append ;
MACRO: 0|| ( quots -- quot ) '[ _ 0 n|| ] ;
MACRO: 1|| ( quots -- quot ) '[ _ 1 n|| ] ;
MACRO: 2|| ( quots -- quot ) '[ _ 2 n|| ] ;
MACRO: 3|| ( quots -- quot ) '[ _ 3 n|| ] ;
<PRIVATE
: unoptimized-|| ( quots quot -- ? )
[ [ call ] ] dip call map-find drop ; inline
PRIVATE>
: 0|| ( quots -- ? ) [ ] unoptimized-|| ;
: 1|| ( obj quots -- ? ) [ with ] unoptimized-|| ;
: 2|| ( obj1 obj2 quots -- ? ) [ with with ] unoptimized-|| ;
: 3|| ( obj1 obj2 obj3 quots -- ? ) [ with with with ] unoptimized-|| ;

34
basis/combinators/short-circuit/smart/smart-tests.factor
View File

@ -1,32 +1,18 @@
USING: kernel math tools.test combinators.short-circuit.smart ;
IN: combinators.short-circuit.smart.tests
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
[ t ] [ { [ 1 ] [ 2 ] [ 3 ] } && 3 = ] unit-test
[ t ] [ 3 { [ 0 > ] [ odd? ] [ 2 + ] } && 5 = ] unit-test
[ t ] [ 10 20 { [ + 0 > ] [ - even? ] [ + ] } && 30 = ] unit-test
: must-be-t ( in -- ) [ t ] swap unit-test ;
: must-be-f ( in -- ) [ f ] swap unit-test ;
[ f ] [ { [ 1 ] [ f ] [ 3 ] } && 3 = ] unit-test
[ f ] [ 3 { [ 0 > ] [ even? ] [ 2 + ] } && ] unit-test
[ f ] [ 10 20 { [ + 0 > ] [ - odd? ] [ + ] } && 30 = ] unit-test
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
[ t ] [ { [ 10 0 < ] [ f ] [ "factor" ] } || "factor" = ] unit-test
[ { [ 1 ] [ 2 ] [ 3 ] } && 3 = ] must-be-t
[ 3 { [ 0 > ] [ odd? ] [ 2 + ] } && 5 = ] must-be-t
[ 10 20 { [ + 0 > ] [ - even? ] [ + ] } && 30 = ] must-be-t
[ t ] [ 10 { [ odd? ] [ 100 > ] [ 1 + ] } || 11 = ] unit-test
[ { [ 1 ] [ f ] [ 3 ] } && 3 = ] must-be-f
[ 3 { [ 0 > ] [ even? ] [ 2 + ] } && ] must-be-f
[ 10 20 { [ + 0 > ] [ - odd? ] [ + ] } && 30 = ] must-be-f
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
[ { [ 10 0 < ] [ f ] [ "factor" ] } || "factor" = ] must-be-t
[ 10 { [ odd? ] [ 100 > ] [ 1 + ] } || 11 = ] must-be-t
[ 10 20 { [ + odd? ] [ + 100 > ] [ + ] } || 30 = ] must-be-t
[ { [ 10 0 < ] [ f ] [ 0 1 = ] } || ] must-be-f
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
[ t ] [ 10 20 { [ + odd? ] [ + 100 > ] [ + ] } || 30 = ] unit-test
[ f ] [ { [ 10 0 < ] [ f ] [ 0 1 = ] } || ] unit-test

Some files were not shown because too many files have changed in this diff Show More