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

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

db4
Daniel Ehrenberg 2009-02-08 21:18:10 -06:00
parent 0e8986176f b529df9652
commit 25dc79d0e8
49 changed files with 1311 additions and 249 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
README.txt
View File

@ -116,16 +116,22 @@ Now if $DISPLAY is set, running ./factor will start the UI.
* Running Factor on Windows XP/Vista
The Factor runtime is compiled into two binaries:
factor.com - a Windows console application
factor.exe - a Windows native application, without a console
If you did not download the binary package, you can bootstrap Factor in
the command prompt:
the command prompt using the console application:
factor.exe -i=boot.<cpu>.image
factor.com -i=boot.<cpu>.image
Once bootstrapped, double-clicking factor.exe starts the Factor UI.
Once bootstrapped, double-clicking factor.exe or factor.com starts
the Factor UI.
To run the listener in the command prompt:
factor.exe -run=listener
factor.com -run=listener
* The Factor FAQ

1
basis/endian/authors.txt Executable file
View File

@ -0,0 +1 @@
Doug Coleman

7
basis/endian/endian-tests.factor Executable file
View File

@ -0,0 +1,7 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces tools.test endian ;
IN: endian.tests
[ t ] [ [ endianness get big-endian = ] with-big-endian ] unit-test
[ t ] [ [ endianness get little-endian = ] with-little-endian ] unit-test

67
basis/endian/endian.factor Executable file
View File

@ -0,0 +1,67 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types namespaces io.binary fry
kernel math ;
IN: endian
SINGLETONS: big-endian little-endian ;
: native-endianness ( -- class )
1 <int> *char 0 = big-endian little-endian ? ;
: >signed ( x n -- y )
2dup neg 1+ shift 1 = [ 2^ - ] [ drop ] if ;
native-endianness \ native-endianness set-global
SYMBOL: endianness
\ native-endianness get-global endianness set-global
HOOK: >native-endian native-endianness ( obj n -- str )
M: big-endian >native-endian >be ;
M: little-endian >native-endian >le ;
HOOK: unsigned-native-endian> native-endianness ( obj -- str )
M: big-endian unsigned-native-endian> be> ;
M: little-endian unsigned-native-endian> le> ;
: signed-native-endian> ( obj n -- str )
[ unsigned-native-endian> ] dip >signed ;
HOOK: >endian endianness ( obj n -- str )
M: big-endian >endian >be ;
M: little-endian >endian >le ;
HOOK: endian> endianness ( seq -- n )
M: big-endian endian> be> ;
M: little-endian endian> le> ;
HOOK: unsigned-endian> endianness ( obj -- str )
M: big-endian unsigned-endian> be> ;
M: little-endian unsigned-endian> le> ;
: signed-endian> ( obj n -- str )
[ unsigned-endian> ] dip >signed ;
: with-endianness ( endian quot -- )
[ endianness ] dip with-variable ; inline
: with-big-endian ( quot -- )
big-endian swap with-endianness ; inline
: with-little-endian ( quot -- )
little-endian swap with-endianness ; inline
: with-native-endian ( quot -- )
\ native-endianness get-global swap with-endianness ; inline

2
basis/furnace/utilities/utilities-docs.factor
View File

@ -27,7 +27,7 @@ HELP: hidden-form-field
{ $example
"USING: furnace.utilities io ;"
"\"bar\" \"foo\" hidden-form-field nl"
"<input type='hidden' name='foo' value='bar'/>"
"<input type=\"hidden\" value=\"bar\" name=\"foo\"/>"
}
} ;

52
basis/generalizations/generalizations-docs.factor
View File

@ -30,6 +30,10 @@ HELP: narray
{ nsequence narray } related-words
HELP: nsum
{ $values { "n" integer } }
{ $description "Adds the top " { $snippet "n" } " stack values." } ;
HELP: firstn
{ $values { "n" integer } }
{ $description "A generalization of " { $link first } ", "
@ -238,6 +242,11 @@ HELP: ncleave
}
} ;
HELP: nspread
{ $values { "quots" "a sequence of quotations" } { "n" integer } }
{ $description "A generalization of " { $link spread } " that can work for any quotation arity."
} ;
HELP: mnswap
{ $values { "m" integer } { "n" integer } }
{ $description "Swaps the top " { $snippet "m" } " stack elements with the " { $snippet "n" } " elements directly underneath." }
@ -250,6 +259,17 @@ HELP: mnswap
}
} ;
HELP: nweave
{ $values { "n" integer } }
{ $description "Copies the top " { $snippet "n" } " stack elements underneath each one of the " { $snippet "n" } " elements below." }
{ $examples
{ $example
"USING: arrays kernel generalizations prettyprint ;"
"\"e1\" \"e2\" \"o1\" \"o2\" 2 nweave [ 3array ] 3dip 3array 2array ."
"{ { \"e1\" \"o1\" \"o2\" } { \"e2\" \"o1\" \"o2\" } }"
}
} ;
HELP: n*quot
{ $values
{ "n" integer } { "seq" sequence }
@ -299,18 +319,14 @@ HELP: ntuck
}
{ $description "A generalization of " { $link tuck } " that can work for any stack depth. The top item will be copied and placed " { $snippet "n" } " items down on the stack." } ;
ARTICLE: "generalizations" "Generalized shuffle words and combinators"
"The " { $vocab-link "generalizations" } " vocabulary defines a number of stack shuffling words and combinators for use in "
"macros where the arity of the input quotations depends on an "
"input parameter."
$nl
"Generalized sequence operations:"
ARTICLE: "sequence-generalizations" "Generalized sequence operations"
{ $subsection narray }
{ $subsection nsequence }
{ $subsection firstn }
{ $subsection nappend }
{ $subsection nappend-as }
"Generated stack shuffle operations:"
{ $subsection nappend-as } ;
ARTICLE: "shuffle-generalizations" "Generalized shuffle words"
{ $subsection ndup }
{ $subsection npick }
{ $subsection nrot }
@ -319,14 +335,28 @@ $nl
{ $subsection ndrop }
{ $subsection ntuck }
{ $subsection mnswap }
"Generalized combinators:"
{ $subsection nweave } ;
ARTICLE: "combinator-generalizations" "Generalized combinators"
{ $subsection ndip }
{ $subsection nslip }
{ $subsection nkeep }
{ $subsection napply }
{ $subsection ncleave }
"Generalized quotation construction:"
{ $subsection nspread } ;
ARTICLE: "other-generalizations" "Additional generalizations"
{ $subsection ncurry }
{ $subsection nwith } ;
{ $subsection nwith }
{ $subsection nsum } ;
ARTICLE: "generalizations" "Generalized shuffle words and combinators"
"The " { $vocab-link "generalizations" } " vocabulary defines a number of stack shuffling words and combinators for use in "
"macros where the arity of the input quotations depends on an "
"input parameter."
{ $subsection "sequence-generalizations" }
{ $subsection "shuffle-generalizations" }
{ $subsection "combinator-generalizations" }
{ $subsection "other-generalizations" } ;
ABOUT: "generalizations"

9
basis/generalizations/generalizations-tests.factor
View File

@ -53,3 +53,12 @@ IN: generalizations.tests
[ 4 nappend ] must-infer
[ 4 { } nappend-as ] must-infer
[ 17 ] [ 3 1 3 3 7 5 nsum ] unit-test
{ 4 1 } [ 4 nsum ] must-infer-as
[ "e1" "o1" "o2" "e2" "o1" "o2" ] [ "e1" "e2" "o1" "o2" 2 nweave ] unit-test
{ 3 5 } [ 2 nweave ] must-infer-as
[ { 0 1 2 } { 3 5 4 } { 7 8 6 } ]
[ 9 [ ] each { [ 3array ] [ swap 3array ] [ rot 3array ] } 3 nspread ] unit-test

19
basis/generalizations/generalizations.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2007, 2008 Chris Double, Doug Coleman, Eduardo
! Copyright (C) 2007, 2009 Chris Double, Doug Coleman, Eduardo
! Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences sequences.private math combinators
@ -23,6 +23,9 @@ MACRO: nsequence ( n seq -- )
MACRO: narray ( n -- )
'[ _ { } nsequence ] ;
MACRO: nsum ( n -- )
1- [ + ] n*quot ;
MACRO: firstn ( n -- )
dup zero? [ drop [ drop ] ] [
[ [ '[ [ _ ] dip nth-unsafe ] ] map ]
@ -70,11 +73,23 @@ MACRO: ncleave ( quots n -- )
[ '[ _ '[ _ _ nkeep ] ] map [ ] join ] [ '[ _ ndrop ] ] bi
compose ;
MACRO: nspread ( quots n -- )
over empty? [ 2drop [ ] ] [
[ [ but-last ] dip ]
[ [ peek ] dip ] 2bi
swap
'[ [ _ _ nspread ] _ ndip @ ]
] if ;
MACRO: napply ( quot n -- )
swap <repetition> spread>quot ;
MACRO: mnswap ( m n -- )
1+ '[ _ -nrot ] <repetition> spread>quot ;
1+ '[ _ -nrot ] swap '[ _ _ napply ] ;
MACRO: nweave ( n -- )
[ dup <reversed> [ '[ _ _ mnswap ] ] with map ] keep
'[ _ _ ncleave ] ;
: nappend-as ( n exemplar -- seq )
[ narray concat ] dip like ; inline

2
basis/html/templates/chloe/chloe-docs.factor
View File

@ -261,7 +261,7 @@ $nl
ARTICLE: "html.templates.chloe.extend.components.example" "An example of a custom Chloe component"
"As an example, let's develop a custom Chloe component which renders an image stored in a form value. Since the component does not require any configuration, we can define a singleton class:"
{ $code "SINGLETON: image" }
"Now we define a method on the " { $link render* } " generic word which renders the image using " { $vocab-link "xml.literals" } ":"
"Now we define a method on the " { $link render* } " generic word which renders the image using " { $link { "xml.syntax" "literals" } } ":"
{ $code "M: image render* 2drop [XML <img src=<-> /> XML] ;" }
"Finally, we can define a Chloe component:"
{ $code "COMPONENT: image" }

21
basis/io/backend/unix/unix.factor
View File

@ -46,6 +46,15 @@ M: fd cancel-operation ( fd -- )
2bi
] if ;
M: unix seek-handle ( n seek-type handle -- )
swap {
{ io:seek-absolute [ SEEK_SET ] }
{ io:seek-relative [ SEEK_CUR ] }
{ io:seek-end [ SEEK_END ] }
[ io:bad-seek-type ]
} case
[ fd>> swap ] dip lseek io-error ;
SYMBOL: +retry+ ! just try the operation again without blocking
SYMBOL: +input+
SYMBOL: +output+
@ -84,8 +93,8 @@ M: fd refill
fd>> over buffer>> [ buffer-end ] [ buffer-capacity ] bi read
{
{ [ dup 0 >= ] [ swap buffer>> n>buffer f ] }
{ [ err_no EINTR = ] [ 2drop +retry+ ] }
{ [ err_no EAGAIN = ] [ 2drop +input+ ] }
{ [ errno EINTR = ] [ 2drop +retry+ ] }
{ [ errno EAGAIN = ] [ 2drop +input+ ] }
[ (io-error) ]
} cond ;
@ -104,8 +113,8 @@ M: fd drain
over buffer>> buffer-consume
buffer>> buffer-empty? f +output+ ?
] }
{ [ err_no EINTR = ] [ 2drop +retry+ ] }
{ [ err_no EAGAIN = ] [ 2drop +output+ ] }
{ [ errno EINTR = ] [ 2drop +retry+ ] }
{ [ errno EAGAIN = ] [ 2drop +output+ ] }
[ (io-error) ]
} cond ;
@ -143,7 +152,7 @@ M: stdin dispose*
stdin data>> handle-fd buffer buffer-end size read
dup 0 < [
drop
err_no EINTR = [ buffer stdin size refill-stdin ] [ (io-error) ] if
errno EINTR = [ buffer stdin size refill-stdin ] [ (io-error) ] if
] [
size = [ "Error reading stdin pipe" throw ] unless
size buffer n>buffer
@ -177,7 +186,7 @@ TUPLE: mx-port < port mx ;
: multiplexer-error ( n -- n )
dup 0 < [
err_no [ EAGAIN = ] [ EINTR = ] bi or
errno [ EAGAIN = ] [ EINTR = ] bi or
[ drop 0 ] [ (io-error) ] if
] when ;

18
basis/io/backend/windows/nt/nt.factor
View File

@ -82,6 +82,24 @@ M: winnt init-io ( -- )
H{ } clone pending-overlapped set-global
windows.winsock:init-winsock ;
ERROR: invalid-file-size n ;
: handle>file-size ( handle -- n )
0 <ulonglong> [ GetFileSizeEx win32-error=0/f ] keep *ulonglong ;
ERROR: seek-before-start n ;
: set-seek-ptr ( n handle -- )
[ dup 0 < [ seek-before-start ] when ] dip (>>ptr) ;
M: winnt seek-handle ( n seek-type handle -- )
swap {
{ seek-absolute [ set-seek-ptr ] }
{ seek-relative [ [ ptr>> + ] keep set-seek-ptr ] }
{ seek-end [ [ handle>> handle>file-size + ] keep set-seek-ptr ] }
[ bad-seek-type ]
} case ;
: file-error? ( n -- eof? )
zero? [
GetLastError {

12
basis/io/ports/ports.factor
View File

@ -120,6 +120,18 @@ M: output-port stream-write
HOOK: (wait-to-write) io-backend ( port -- )
HOOK: seek-handle os ( n seek-type handle -- )
M: input-port stream-seek ( n seek-type stream -- )
[ check-disposed ]
[ buffer>> 0 swap buffer-reset ]
[ handle>> seek-handle ] tri ;
M: output-port stream-seek ( n seek-type stream -- )
[ check-disposed ]
[ stream-flush ]
[ handle>> seek-handle ] tri ;
GENERIC: shutdown ( handle -- )
M: object shutdown drop ;

2
basis/io/sockets/secure/unix/unix.factor
View File

@ -15,7 +15,7 @@ M: ssl-handle handle-fd file>> handle-fd ;
ERR_get_error dup zero? [
drop
{
{ -1 [ err_no ECONNRESET = [ premature-close ] [ (io-error) ] if ] }
{ -1 [ errno ECONNRESET = [ premature-close ] [ (io-error) ] if ] }
{ 0 [ premature-close ] }
} case
] [ nip (ssl-error) ] if ;

14
basis/io/sockets/unix/unix.factor
View File

@ -37,8 +37,8 @@ M: object (get-remote-address) ( handle local -- sockaddr )
dup handle>> handle-fd f 0 write
{
{ [ 0 = ] [ drop ] }
{ [ err_no EAGAIN = ] [ dup +output+ wait-for-port wait-to-connect ] }
{ [ err_no EINTR = ] [ wait-to-connect ] }
{ [ errno EAGAIN = ] [ dup +output+ wait-for-port wait-to-connect ] }
{ [ errno EINTR = ] [ wait-to-connect ] }
[ (io-error) ]
} cond ;
@ -46,7 +46,7 @@ M: object establish-connection ( client-out remote -- )
[ drop ] [ [ handle>> handle-fd ] [ make-sockaddr/size ] bi* connect ] 2bi
{
{ [ 0 = ] [ drop ] }
{ [ err_no EINPROGRESS = ] [
{ [ errno EINPROGRESS = ] [
[ +output+ wait-for-port ] [ wait-to-connect ] bi
] }
[ (io-error) ]
@ -78,8 +78,8 @@ M: object (accept) ( server addrspec -- fd sockaddr )
2dup do-accept
{
{ [ over 0 >= ] [ [ 2nip <fd> init-fd ] dip ] }
{ [ err_no EINTR = ] [ 2drop (accept) ] }
{ [ err_no EAGAIN = ] [
{ [ errno EINTR = ] [ 2drop (accept) ] }
{ [ errno EAGAIN = ] [
2drop
[ drop +input+ wait-for-port ]
[ (accept) ]
@ -121,10 +121,10 @@ M: unix (receive) ( datagram -- packet sockaddr )
:: do-send ( packet sockaddr len socket datagram -- )
socket handle-fd packet dup length 0 sockaddr len sendto
0 < [
err_no EINTR = [
errno EINTR = [
packet sockaddr len socket datagram do-send
] [
err_no EAGAIN = [
errno EAGAIN = [
datagram +output+ wait-for-port
packet sockaddr len socket datagram do-send
] [

10
basis/libc/libc.factor
View File

@ -2,10 +2,16 @@
! Copyright (C) 2007, 2008 Slava Pestov
! Copyright (C) 2007, 2008 Doug Coleman
! See http://factorcode.org/license.txt for BSD license.
USING: alien assocs continuations destructors kernel
namespaces accessors sets summary ;
USING: alien assocs continuations destructors
kernel namespaces accessors sets summary ;
IN: libc
: errno ( -- int )
"int" "factor" "err_no" { } alien-invoke ;
: clear-errno ( -- )
"void" "factor" "clear_err_no" { } alien-invoke ;
<PRIVATE
: (malloc) ( size -- alien )

3
basis/mime/multipart/multipart.factor
View File

@ -42,7 +42,7 @@ ERROR: end-of-stream multipart ;
[ t >>end-of-stream? ] if* ;
: maybe-fill-bytes ( multipart -- multipart )
dup bytes>> [ fill-bytes ] unless ;
dup bytes>> length 256 < [ fill-bytes ] when ;
: split-bytes ( bytes separator -- leftover-bytes safe-to-dump )
dupd [ length ] bi@ 1- - short cut-slice swap ;
@ -65,6 +65,7 @@ ERROR: end-of-stream multipart ;
[ dump-until-separator ] with-string-writer ;
: read-header ( multipart -- multipart )
maybe-fill-bytes
dup bytes>> "--\r\n" sequence= [
t >>end-of-stream?
] [

38
basis/pack/pack.factor
View File

@ -5,33 +5,9 @@ io.binary io.streams.string kernel math math.parser namespaces
make parser prettyprint quotations sequences strings vectors
words macros math.functions math.bitwise fry generalizations
combinators.smart io.streams.byte-array io.encodings.binary
math.vectors combinators multiline ;
math.vectors combinators multiline endian ;
IN: pack
SYMBOL: big-endian
: big-endian? ( -- ? )
1 <int> *char zero? ;
<PRIVATE
: set-big-endian ( -- )
big-endian? big-endian set ; inline
PRIVATE>
: >signed ( x n -- y )
2dup neg 1+ shift 1 = [ 2^ - ] [ drop ] if ;
: >endian ( obj n -- str )
big-endian get [ >be ] [ >le ] if ; inline
: unsigned-endian> ( obj -- str )
big-endian get [ be> ] [ le> ] if ; inline
: signed-endian> ( obj n -- str )
[ unsigned-endian> ] dip >signed ;
GENERIC: >n-byte-array ( obj n -- byte-array )
M: integer >n-byte-array ( m n -- byte-array ) >endian ;
@ -124,13 +100,13 @@ PRIVATE>
[ ch>packed-length ] sigma ;
: pack-native ( seq str -- seq )
[ set-big-endian pack ] with-scope ; inline
'[ _ _ pack ] with-native-endian ; inline
: pack-be ( seq str -- seq )
[ big-endian on pack ] with-scope ; inline
'[ _ _ pack ] with-big-endian ; inline
: pack-le ( seq str -- seq )
[ big-endian off pack ] with-scope ; inline
'[ _ _ pack ] with-little-endian ; inline
<PRIVATE
@ -146,13 +122,13 @@ MACRO: unpack ( str -- quot )
PRIVATE>
: unpack-native ( seq str -- seq )
[ set-big-endian unpack ] with-scope ; inline
'[ _ _ unpack ] with-native-endian ; inline
: unpack-be ( seq str -- seq )
[ big-endian on unpack ] with-scope ; inline
'[ _ _ unpack ] with-big-endian ; inline
: unpack-le ( seq str -- seq )
[ big-endian off unpack ] with-scope ; inline
'[ _ _ unpack ] with-little-endian ; inline
ERROR: packed-read-fail str bytes ;

13
basis/unix/unix.factor
View File

@ -17,6 +17,10 @@ CONSTANT: MAP_FILE 0
CONSTANT: MAP_SHARED 1
CONSTANT: MAP_PRIVATE 2
CONSTANT: SEEK_SET 0
CONSTANT: SEEK_CUR 1
CONSTANT: SEEK_END 2
: MAP_FAILED ( -- alien ) -1 <alien> ; inline
CONSTANT: NGROUPS_MAX 16
@ -37,18 +41,13 @@ C-STRUCT: group
{ "int" "gr_gid" }
{ "char**" "gr_mem" } ;
LIBRARY: factor
FUNCTION: void clear_err_no ( ) ;
FUNCTION: int err_no ( ) ;
LIBRARY: libc
FUNCTION: char* strerror ( int errno ) ;
ERROR: unix-error errno message ;
: (io-error) ( -- * ) err_no dup strerror unix-error ;
: (io-error) ( -- * ) errno dup strerror unix-error ;
: io-error ( n -- ) 0 < [ (io-error) ] when ;
@ -61,7 +60,7 @@ MACRO:: unix-system-call ( quot -- )
n ndup quot call dup 0 < [
drop
n narray
err_no dup strerror
errno dup strerror
word unix-system-call-error
] [
n nnip

2
basis/windows/kernel32/kernel32.factor
View File

@ -1235,7 +1235,7 @@ ALIAS: GetFileAttributesEx GetFileAttributesExW
FUNCTION: BOOL GetFileInformationByHandle ( HANDLE hFile, LPBY_HANDLE_FILE_INFORMATION lpFileInformation ) ;
FUNCTION: DWORD GetFileSize ( HANDLE hFile, LPDWORD lpFileSizeHigh ) ;
! FUNCTION: GetFileSizeEx
FUNCTION: BOOL GetFileSizeEx ( HANDLE hFile, PLARGE_INTEGER lpFileSize ) ;
FUNCTION: BOOL GetFileTime ( HANDLE hFile, LPFILETIME lpCreationTime, LPFILETIME lpLastAccessTime, LPFILETIME lpLastWriteTime ) ;
FUNCTION: DWORD GetFileType ( HANDLE hFile ) ;
! FUNCTION: GetFirmwareEnvironmentVariableA

1
basis/zlib/authors.txt Executable file
View File

@ -0,0 +1 @@
Doug Coleman

1
basis/zlib/ffi/authors.txt Executable file
View File

@ -0,0 +1 @@
Doug Coleman

30
basis/zlib/ffi/ffi.factor Executable file
View File

@ -0,0 +1,30 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.syntax combinators system ;
IN: zlib.ffi
<< "zlib" {
{ [ os winnt? ] [ "zlib1.dll" ] }
{ [ os macosx? ] [ "libz.dylib" ] }
{ [ os unix? ] [ "libz.so" ] }
} cond "cdecl" add-library >>
LIBRARY: zlib
CONSTANT: Z_OK 0
CONSTANT: Z_STREAM_END 1
CONSTANT: Z_NEED_DICT 2
CONSTANT: Z_ERRNO -1
CONSTANT: Z_STREAM_ERROR -2
CONSTANT: Z_DATA_ERROR -3
CONSTANT: Z_MEM_ERROR -4
CONSTANT: Z_BUF_ERROR -5
CONSTANT: Z_VERSION_ERROR -6
TYPEDEF: void Bytef
TYPEDEF: ulong uLongf
TYPEDEF: ulong uLong
FUNCTION: int compress ( Bytef* dest, uLongf* destLen, Bytef* source, uLong sourceLen ) ;
FUNCTION: int compress2 ( Bytef* dest, uLongf* destLen, Bytef* source, uLong sourceLen, int level ) ;
FUNCTION: int uncompress ( Bytef* dest, uLongf* destLen, Bytef* source, uLong sourceLen ) ;

9
basis/zlib/zlib-tests.factor Executable file
View File

@ -0,0 +1,9 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel tools.test zlib classes ;
IN: zlib.tests
: compress-me ( -- byte-array ) B{ 1 2 3 4 5 } ;
[ t ] [ compress-me [ compress uncompress ] keep = ] unit-test
[ t ] [ compress-me compress compressed instance? ] unit-test

48
basis/zlib/zlib.factor Executable file
View File

@ -0,0 +1,48 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.syntax byte-arrays combinators
kernel math math.functions sequences system accessors
libc ;
QUALIFIED: zlib.ffi
IN: zlib
TUPLE: compressed data length ;
: <compressed> ( data length -- compressed )
compressed new
swap >>length
swap >>data ;
ERROR: zlib-failed n string ;
: zlib-error-message ( n -- * )
dup zlib.ffi:Z_ERRNO = [
drop errno "native libc error"
] [
dup {
"no error" "libc_error"
"stream error" "data error"
"memory error" "buffer error" "zlib version error"
} ?nth
] if zlib-failed ;
: zlib-error ( n -- )
dup zlib.ffi:Z_OK = [ drop ] [ dup zlib-error-message zlib-failed ] if ;
: compressed-size ( byte-array -- n )
length 1001/1000 * ceiling 12 + ;
: compress ( byte-array -- compressed )
[
[ compressed-size <byte-array> dup length <ulong> ] keep [
dup length zlib.ffi:compress zlib-error
] 3keep drop *ulong head
] keep length <compressed> ;
: uncompress ( compressed -- byte-array )
[
length>> [ <byte-array> ] keep <ulong> 2dup
] [
data>> dup length
zlib.ffi:uncompress zlib-error
] bi *ulong head ;

79
core/io/files/files-tests.factor
View File

@ -1,8 +1,7 @@
USING: tools.test io.files io.files.private io.files.temp
io.directories io.encodings.8-bit arrays make system
io.encodings.binary io threads kernel continuations
io.encodings.ascii sequences strings accessors
io.encodings.utf8 math destructors namespaces ;
USING: arrays debugger.threads destructors io io.directories
io.encodings.8-bit io.encodings.ascii io.encodings.binary
io.files io.files.private io.files.temp io.files.unique kernel
make math sequences system threads tools.test ;
IN: io.files.tests
\ exists? must-infer
@ -75,3 +74,73 @@ USE: debugger.threads
[ t ] [ "quux-test.txt" temp-file exists? ] unit-test
[ ] [ "quux-test.txt" temp-file delete-file ] unit-test
! File seeking tests
[ B{ 3 2 3 4 5 } ]
[
"seek-test1" unique-file binary
[
[
B{ 1 2 3 4 5 } write 0 seek-absolute seek-output
B{ 3 } write
] with-file-writer
] [
file-contents
] 2bi
] unit-test
[ B{ 1 2 3 4 3 } ]
[
"seek-test2" unique-file binary
[
[
B{ 1 2 3 4 5 } write -1 seek-relative seek-output
B{ 3 } write
] with-file-writer
] [
file-contents
] 2bi
] unit-test
[ B{ 1 2 3 4 5 0 3 } ]
[
"seek-test3" unique-file binary
[
[
B{ 1 2 3 4 5 } write 1 seek-relative seek-output
B{ 3 } write
] with-file-writer
] [
file-contents
] 2bi
] unit-test
[ B{ 3 } ]
[
B{ 1 2 3 4 5 } "seek-test4" unique-file binary [
set-file-contents
] [
[
-3 seek-end seek-input 1 read
] with-file-reader
] 2bi
] unit-test
[ B{ 2 } ]
[
B{ 1 2 3 4 5 } "seek-test5" unique-file binary [
set-file-contents
] [
[
3 seek-absolute seek-input
-2 seek-relative seek-input
1 read
] with-file-reader
] 2bi
] unit-test
[
"seek-test6" unique-file binary [
-10 seek-absolute seek-input
] with-file-reader
] must-fail

53
core/io/io-docs.factor
View File

@ -68,6 +68,51 @@ HELP: stream-copy
{ $description "Copies the contents of one stream into another, closing both streams when done." }
$io-error ;
HELP: stream-seek
{ $values
{ "n" integer } { "seek-type" "a seek singleton" } { "stream" "a stream" }
}
{ $description "Moves the pointer associated with a stream's handle to an offset " { $snippet "n" } " bytes from the seek type so that further reading or writing happens at the new location. For output streams, the buffer is flushed before seeking. Seeking past the end of an output stream will pad the difference with zeros once the stream is written to again." $nl
"Three methods of seeking are supported:"
{ $list { $link seek-absolute } { $link seek-relative } { $link seek-end } }
}
{ $notes "Stream seeking is not supported on streams that do not have a known length, e.g. TCP/IP streams." } ;
HELP: seek-absolute
{ $values
{ "value" "a seek singleton" }
}
{ $description "Seeks to an offset from the beginning of the stream." } ;
HELP: seek-end
{ $values
{ "value" "a seek singleton" }
}
{ $description "Seeks to an offset from the end of the stream. If the offset puts the stream pointer past the end of the data on an output stream, writing to it will pad the difference with zeros." } ;
HELP: seek-relative
{ $values
{ "value" "a seek singleton" }
}
{ $description "Seeks to an offset from the current position of the stream pointer." } ;
HELP: seek-input
{ $values
{ "n" integer } { "seek-type" "a seek singleton" }
}
{ $description "Calls " { $link stream-seek } " on the stream stored in " { $link input-stream } "." } ;
HELP: seek-output
{ $values
{ "n" integer } { "seek-type" "a seek singleton" }
}
{ $description "Calls " { $link stream-seek } " on the stream stored in " { $link output-stream } "." } ;
HELP: input-stream
{ $var-description "Holds an input stream for various implicit stream operations. Rebound using " { $link with-input-stream } " and " { $link with-input-stream* } "." } ;
@ -196,6 +241,8 @@ $nl
{ $subsection stream-write }
"This word is only required for string output streams:"
{ $subsection stream-nl }
"This word is for streams that allow seeking:"
{ $subsection stream-seek }
"For a discussion of the distinction between binary and string streams, see " { $link "stream-elements" } "."
{ $see-also "io.timeouts" } ;
@ -249,6 +296,8 @@ $nl
{ $subsection read-partial }
"If the default input stream is a string stream (" { $link "stream-elements" } "), lines of text can be read:"
{ $subsection readln }
"Seeking on the default input stream:"
{ $subsection seek-input }
"A pair of combinators for rebinding the " { $link input-stream } " variable:"
{ $subsection with-input-stream }
{ $subsection with-input-stream* }
@ -256,7 +305,7 @@ $nl
{ $subsection output-stream }
"Unless rebound in a child namespace, this variable will be set to a console stream for showing output to the user."
$nl
"Words writing to the default input stream:"
"Words writing to the default output stream:"
{ $subsection flush }
{ $subsection write1 }
{ $subsection write }
@ -265,6 +314,8 @@ $nl
{ $subsection print }
{ $subsection nl }
{ $subsection bl }
"Seeking on the default output stream:"
{ $subsection seek-output }
"A pair of combinators for rebinding the " { $link output-stream } " variable:"
{ $subsection with-output-stream }
{ $subsection with-output-stream* }

4
core/io/io-tests.factor
View File

@ -1,6 +1,4 @@
USING: arrays io io.files kernel math parser strings system
tools.test words namespaces make io.encodings.8-bit
io.encodings.binary sequences ;
USING: io parser tools.test words ;
IN: io.tests
[ f ] [

8
core/io/io.factor
View File

@ -15,6 +15,10 @@ GENERIC: stream-write ( seq stream -- )
GENERIC: stream-flush ( stream -- )
GENERIC: stream-nl ( stream -- )
ERROR: bad-seek-type type ;
SINGLETONS: seek-absolute seek-relative seek-end ;
GENERIC: stream-seek ( n seek-type stream -- )
: stream-print ( str stream -- ) [ stream-write ] keep stream-nl ;
! Default streams
@ -27,6 +31,8 @@ SYMBOL: error-stream
: read ( n -- seq ) input-stream get stream-read ;
: read-until ( seps -- seq sep/f ) input-stream get stream-read-until ;
: read-partial ( n -- seq ) input-stream get stream-read-partial ;
: seek-input ( n seek-type -- ) input-stream get stream-seek ;
: seek-output ( n seek-type -- ) output-stream get stream-seek ;
: write1 ( elt -- ) output-stream get stream-write1 ;
: write ( seq -- ) output-stream get stream-write ;
@ -82,4 +88,4 @@ PRIVATE>
: stream-copy ( in out -- )
[ [ [ write ] each-block ] with-output-stream ]
curry with-input-stream ;
curry with-input-stream ;

5
core/strings/strings-docs.factor
View File

@ -53,8 +53,9 @@ HELP: 1string
HELP: >string
{ $values { "seq" "a sequence of characters" } { "str" string } }
{ $description "Outputs a freshly-allocated string with the same elements as a given sequence." }
{ $errors "Throws an error if the sequence contains elements other than real numbers." } ;
{ $description "Outputs a freshly-allocated string with the same elements as a given sequence, by interpreting the sequence elements as Unicode code points." }
{ $notes "This operation is only appropriate if the underlying sequence holds Unicode code points, which is rare unless it is a " { $link slice } " of another string. To convert a sequence of bytes to a string, use the words documented in " { $link "io.encodings.string" } "." }
{ $errors "Throws an error if the sequence contains elements other than integers." } ;
HELP: resize-string ( n str -- newstr )
{ $values { "n" "a non-negative integer" } { "str" string } { "newstr" string } }

2
core/words/words-docs.factor
View File

@ -107,7 +107,7 @@ $nl
{ { { $snippet "\"help\"" } ", " { $snippet "\"help-loc\"" } ", " { $snippet "\"help-parent\"" } } { "Where word help is stored - " { $link "writing-help" } } }
{ { $snippet "\"infer\"" } { $link "compiler-transforms" } }
{ { $snippet "\"infer\"" } { $link "macros" } }
{ { { $snippet "\"inferred-effect\"" } } { $link "inference" } }

5
extra/24-game/24-game.factor
View File

@ -15,7 +15,8 @@ SYMBOL: commands
{ nop rot -rot swap spin swapd } amb-execute ;
: makes-24? ( a b c d -- ? )
[
2 [ some-rots do-something ] times
some-rots do-something
some-rots do-something
maybe-swap do-something
24 =
]
@ -60,4 +61,4 @@ DEFER: check-status
: 24-able ( -- vector ) build-quad dup 24-able? [ drop build-quad ] unless ;
: set-commands ( -- ) { + - * / rot swap q } commands set ;
: play-game ( -- ) set-commands 24-able repeat ;
MAIN: play-game
MAIN: play-game

33
extra/graphics/bitmap/bitmap-tests.factor
View File

@ -1,15 +1,30 @@
USING: graphics.bitmap graphics.viewer ;
USING: graphics.bitmap graphics.viewer io.encodings.binary
io.files io.files.unique kernel tools.test ;
IN: graphics.bitmap.tests
: test-bitmap24 ( -- )
"resource:extra/graphics/bitmap/test-images/thiswayup24.bmp" bitmap. ;
: test-bitmap32-alpha ( -- path )
"resource:extra/graphics/bitmap/test-images/32alpha.bmp" ;
: test-bitmap8 ( -- )
"resource:extra/graphics/bitmap/test-images/rgb8bit.bmp" bitmap. ;
: test-bitmap24 ( -- path )
"resource:extra/graphics/bitmap/test-images/thiswayup24.bmp" ;
: test-bitmap4 ( -- )
"resource:extra/graphics/bitmap/test-images/rgb4bit.bmp" bitmap. ;
: test-bitmap16 ( -- path )
"resource:extra/graphics/bitmap/test-images/rgb16bit.bmp" ;
: test-bitmap1 ( -- )
"resource:extra/graphics/bitmap/test-images/1bit.bmp" bitmap. ;
: test-bitmap8 ( -- path )
"resource:extra/graphics/bitmap/test-images/rgb8bit.bmp" ;
: test-bitmap4 ( -- path )
"resource:extra/graphics/bitmap/test-images/rgb4bit.bmp" ;
: test-bitmap1 ( -- path )
"resource:extra/graphics/bitmap/test-images/1bit.bmp" ;
[ t ]
[
test-bitmap24
[ binary file-contents ] [ load-bitmap ] bi
"test-bitmap24" unique-file
[ save-bitmap ] [ binary file-contents ] bi =
] unit-test

39
extra/graphics/bitmap/bitmap.factor
View File

@ -1,11 +1,10 @@
! Copyright (C) 2007 Doug Coleman.
! Copyright (C) 2007, 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays byte-arrays combinators summary
io io.binary io.files kernel libc math
math.functions math.bitwise namespaces opengl opengl.gl
prettyprint sequences strings ui ui.gadgets.panes fry
io.encodings.binary accessors grouping macros alien.c-types ;
USING: accessors alien alien.c-types arrays byte-arrays columns
combinators fry grouping io io.binary io.encodings.binary
io.files kernel libc macros math math.bitwise math.functions
namespaces opengl opengl.gl prettyprint sequences strings
summary ui ui.gadgets.panes ;
IN: graphics.bitmap
! Currently can only handle 24/32bit bitmaps.
@ -14,6 +13,7 @@ IN: graphics.bitmap
TUPLE: bitmap magic size reserved offset header-length width
height planes bit-count compression size-image
x-pels y-pels color-used color-important rgb-quads color-index
alpha-channel-zero?
array ;
: array-copy ( bitmap array -- bitmap array' )
@ -39,20 +39,18 @@ MACRO: (nbits>bitmap) ( bits -- )
[ rgb-quads>> 4 <sliced-groups> [ 3 head-slice ] map ]
[ color-index>> >array ] bi [ swap nth ] with map concat ;
: 4bit>array ( bitmap -- array )
[ rgb-quads>> 4 <sliced-groups> [ 3 head-slice ] map ]
[ color-index>> >array ] bi [ swap nth ] with map concat ;
ERROR: bmp-not-supported n ;
: raw-bitmap>array ( bitmap -- array )
dup bit-count>>
{
{ 32 [ color-index>> ] }
{ 24 [ color-index>> ] }
{ 16 [ "16bit" throw ] }
{ 16 [ bmp-not-supported ] }
{ 8 [ 8bit>array ] }
{ 4 [ 4bit>array ] }
{ 2 [ "2bit" throw ] }
{ 1 [ "1bit" throw ] }
{ 4 [ bmp-not-supported ] }
{ 2 [ bmp-not-supported ] }
{ 1 [ bmp-not-supported ] }
} case >byte-array ;
ERROR: bitmap-magic ;
@ -97,12 +95,19 @@ M: bitmap-magic summary
dup rgb-quads-length read >>rgb-quads
dup color-index-length read >>color-index ;
: load-bitmap ( path -- bitmap )
: (load-bitmap) ( path -- bitmap )
binary [
bitmap new
parse-file-header parse-bitmap-header parse-bitmap
] with-file-reader
dup raw-bitmap>array >>array ;
] with-file-reader ;
: alpha-channel-zero? ( bitmap -- ? )
array>> 4 <sliced-groups> 3 <column> [ 0 = ] all? ;
: load-bitmap ( path -- bitmap )
(load-bitmap)
dup raw-bitmap>array >>array
dup alpha-channel-zero? >>alpha-channel-zero? ;
: write2 ( n -- ) 2 >le write ;
: write4 ( n -- ) 4 >le write ;

1
extra/graphics/tiff/authors.txt Executable file
View File

@ -0,0 +1 @@
Doug Coleman

BIN
extra/graphics/tiff/rgb.tiff Executable file
View File

Binary file not shown.

9
extra/graphics/tiff/tiff-tests.factor Executable file
View File

@ -0,0 +1,9 @@
! Copyright (C) 2009 Your name.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test graphics.tiff ;
IN: graphics.tiff.tests
: tiff-test-path ( -- path )
"resource:extra/graphics/tiff/rgb.tiff" ;

227
extra/graphics/tiff/tiff.factor Executable file
View File

@ -0,0 +1,227 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators io io.encodings.binary io.files
kernel pack endian tools.hexdump constructors sequences arrays
sorting.slots math.order math.parser prettyprint classes ;
IN: graphics.tiff
TUPLE: tiff
endianness
the-answer
ifd-offset
ifds ;
CONSTRUCTOR: tiff ( -- tiff )
V{ } clone >>ifds ;
TUPLE: ifd count ifd-entries next processed-tags strips ;
CONSTRUCTOR: ifd ( count ifd-entries next -- ifd ) ;
TUPLE: ifd-entry tag type count offset ;
CONSTRUCTOR: ifd-entry ( tag type count offset -- ifd-entry ) ;
TUPLE: photometric-interpretation color ;
CONSTRUCTOR: photometric-interpretation ( color -- object ) ;
SINGLETONS: white-is-zero black-is-zero rgb palette-color ;
ERROR: bad-photometric-interpretation n ;
: lookup-photometric-interpretation ( n -- singleton )
{
{ 0 [ white-is-zero ] }
{ 1 [ black-is-zero ] }
{ 2 [ rgb ] }
{ 3 [ palette-color ] }
[ bad-photometric-interpretation ]
} case <photometric-interpretation> ;
TUPLE: compression method ;
CONSTRUCTOR: compression ( method -- object ) ;
SINGLETONS: no-compression CCITT-2 pack-bits lzw ;
ERROR: bad-compression n ;
: lookup-compression ( n -- compression )
{
{ 1 [ no-compression ] }
{ 2 [ CCITT-2 ] }
{ 5 [ lzw ] }
{ 32773 [ pack-bits ] }
[ bad-compression ]
} case <compression> ;
TUPLE: image-length n ;
CONSTRUCTOR: image-length ( n -- object ) ;
TUPLE: image-width n ;
CONSTRUCTOR: image-width ( n -- object ) ;
TUPLE: x-resolution n ;
CONSTRUCTOR: x-resolution ( n -- object ) ;
TUPLE: y-resolution n ;
CONSTRUCTOR: y-resolution ( n -- object ) ;
TUPLE: rows-per-strip n ;
CONSTRUCTOR: rows-per-strip ( n -- object ) ;
TUPLE: strip-offsets n ;
CONSTRUCTOR: strip-offsets ( n -- object ) ;
TUPLE: strip-byte-counts n ;
CONSTRUCTOR: strip-byte-counts ( n -- object ) ;
TUPLE: bits-per-sample n ;
CONSTRUCTOR: bits-per-sample ( n -- object ) ;
TUPLE: samples-per-pixel n ;
CONSTRUCTOR: samples-per-pixel ( n -- object ) ;
SINGLETONS: no-resolution-unit
inch-resolution-unit
centimeter-resolution-unit ;
TUPLE: resolution-unit type ;
CONSTRUCTOR: resolution-unit ( type -- object ) ;
ERROR: bad-resolution-unit n ;
: lookup-resolution-unit ( n -- object )
{
{ 1 [ no-resolution-unit ] }
{ 2 [ inch-resolution-unit ] }
{ 3 [ centimeter-resolution-unit ] }
[ bad-resolution-unit ]
} case <resolution-unit> ;
TUPLE: predictor type ;
CONSTRUCTOR: predictor ( type -- object ) ;
SINGLETONS: no-predictor horizontal-differencing-predictor ;
ERROR: bad-predictor n ;
: lookup-predictor ( n -- object )
{
{ 1 [ no-predictor ] }
{ 2 [ horizontal-differencing-predictor ] }
[ bad-predictor ]
} case <predictor> ;
TUPLE: planar-configuration type ;
CONSTRUCTOR: planar-configuration ( type -- object ) ;
SINGLETONS: chunky planar ;
ERROR: bad-planar-configuration n ;
: lookup-planar-configuration ( n -- object )
{
{ 1 [ no-predictor ] }
{ 2 [ horizontal-differencing-predictor ] }
[ bad-predictor ]
} case <planar-configuration> ;
TUPLE: new-subfile-type n ;
CONSTRUCTOR: new-subfile-type ( n -- object ) ;
ERROR: bad-tiff-magic bytes ;
: tiff-endianness ( byte-array -- ? )
{
{ B{ CHAR: M CHAR: M } [ big-endian ] }
{ B{ CHAR: I CHAR: I } [ little-endian ] }
[ bad-tiff-magic ]
} case ;
: with-tiff-endianness ( tiff quot -- tiff )
[ dup endianness>> ] dip with-endianness ; inline
: read-header ( tiff -- tiff )
2 read tiff-endianness [ >>endianness ] keep
[
2 read endian> >>the-answer
4 read endian> >>ifd-offset
] with-endianness ;
: push-ifd ( tiff ifd -- tiff )
over ifds>> push ;
: read-ifd ( -- ifd )
2 read endian>
2 read endian>
4 read endian>
4 read endian> <ifd-entry> ;
: read-ifds ( tiff -- tiff )
[
dup ifd-offset>> seek-absolute seek-input
2 read endian>
dup [ read-ifd ] replicate
4 read endian>
[ <ifd> push-ifd ] [ 0 = [ read-ifds ] unless ] bi
] with-tiff-endianness ;
: read-strips ( ifd -- ifd )
dup processed-tags>>
[ [ strip-byte-counts instance? ] find nip n>> ]
[ [ strip-offsets instance? ] find nip n>> ] bi
[ seek-absolute seek-input read ] { } 2map-as >>strips ;
! ERROR: unhandled-ifd-entry data n ;
: unhandled-ifd-entry ;
: ifd-entry-value ( ifd-entry -- n )
dup count>> 1 = [
offset>>
] [
[ offset>> seek-absolute seek-input ] [ count>> read ] bi
] if ;
: process-ifd-entry ( ifd-entry -- object )
[ ifd-entry-value ] [ tag>> ] bi {
{ 254 [ <new-subfile-type> ] }
{ 256 [ <image-width> ] }
{ 257 [ <image-length> ] }
{ 258 [ <bits-per-sample> ] }
{ 259 [ lookup-compression ] }
{ 262 [ lookup-photometric-interpretation ] }
{ 273 [ <strip-offsets> ] }
{ 277 [ <samples-per-pixel> ] }
{ 278 [ <rows-per-strip> ] }
{ 279 [ <strip-byte-counts> ] }
{ 282 [ <x-resolution> ] }
{ 283 [ <y-resolution> ] }
{ 284 [ <planar-configuration> ] }
{ 296 [ lookup-resolution-unit ] }
{ 317 [ lookup-predictor ] }
[ unhandled-ifd-entry swap 2array ]
} case ;
: process-ifd ( ifd -- ifd )
dup ifd-entries>> [ process-ifd-entry ] map >>processed-tags ;
: (load-tiff) ( path -- tiff )
binary [
<tiff>
read-header
read-ifds
dup ifds>> [ process-ifd read-strips drop ] each
] with-file-reader ;
: load-tiff ( path -- tiff )
(load-tiff) ;
! TODO: duplicate ifds = error, seeking out of bounds = error

8
extra/infix/ast/ast.factor Normal file
View File

@ -0,0 +1,8 @@
IN: infix.ast
TUPLE: ast-number value ;
TUPLE: ast-local name ;
TUPLE: ast-array name index ;
TUPLE: ast-function name arguments ;
TUPLE: ast-op left right op ;
TUPLE: ast-negation term ;

38
extra/infix/infix-docs.factor Normal file
View File

@ -0,0 +1,38 @@
USING: help.syntax help.markup prettyprint locals ;
IN: infix
HELP: [infix
{ $syntax "[infix ... infix]" }
{ $description "Parses the infix code inside the brackets, converts it to stack code and executes it." }
{ $examples
{ $example
"USING: infix prettyprint ;"
"IN: scratchpad"
"[infix 8+2*3 infix] ."
"14"
} $nl
{ $link POSTPONE: [infix } " isn't that useful by itself, as it can only access literal numbers and no variables. It is designed to be used together with locals; for example with " { $link POSTPONE: :: } " :"
{ $example
"USING: infix locals math.functions prettyprint ;"
"IN: scratchpad"
":: quadratic-equation ( a b c -- z- z+ )"
" [infix (-b-sqrt(b*b-4*a*c)) / (2*a) infix]"
" [infix (-b+sqrt(b*b-4*a*c)) / (2*a) infix] ;"
"1 0 -1 quadratic-equation . ."
"1.0\n-1.0"
}
} ;
HELP: [infix|
{ $syntax "[infix| binding1 [ value1... ]\n binding2 [ value2... ]\n ... |\n infix-expression infix]" }
{ $description "Introduces a set of lexical bindings and evaluates the body as a snippet of infix code. The values are evaluated in parallel, and may not refer to other bindings within the same " { $link POSTPONE: [infix| } " form, as it is based on " { $link POSTPONE: [let } "." }
{ $examples
{ $example
"USING: infix prettyprint ;"
"IN: scratchpad"
"[infix| pi [ 3.14 ] r [ 12 ] | r*r*pi infix] ."
"452.16"
}
} ;
{ POSTPONE: [infix POSTPONE: [infix| } related-words

45
extra/infix/infix-tests.factor Normal file
View File

@ -0,0 +1,45 @@
USING: infix infix.private kernel locals math math.functions
tools.test ;
IN: infix.tests
[ 0 ] [ [infix 0 infix] ] unit-test
[ 0.5 ] [ [infix 3.0/6 infix] ] unit-test
[ 1+2/3 ] [ [infix 5/3 infix] ] unit-test
[ 3 ] [ [infix 2*7%3+1 infix] ] unit-test
[ 1 ] [ [infix 2-
1
-5*
0 infix] ] unit-test
[ 452.16 ] [ [infix| r [ 12 ] pi [ 3.14 ] |
r*r*pi infix] ] unit-test
[ 0 ] [ [infix| a [ 3 ] | 0 infix] ] unit-test
[ 4/5 ] [ [infix| x [ 3 ] f [ 12 ] | f/(f+x) infix] ] unit-test
[ 144 ] [ [infix| a [ 0 ] b [ 12 ] | b*b-a infix] ] unit-test
[ 0 ] [ [infix| a [ { 0 1 2 3 } ] | a[0] infix] ] unit-test
[ 0 ] [ [infix| a [ { 0 1 2 3 } ] | 3*a[0]*2*a[1] infix] ] unit-test
[ 6 ] [ [infix| a [ { 0 1 2 3 } ] | a[0]+a[10%3]+a[3-1]+a[18/6] infix] ] unit-test
[ -1 ] [ [infix| a [ { 0 1 2 3 } ] | -a[+1] infix] ] unit-test
[ 0.0 ] [ [infix sin(0) infix] ] unit-test
[ 10 ] [ [infix lcm(2,5) infix] ] unit-test
[ 1.0 ] [ [infix +cos(-0*+3) infix] ] unit-test
[ f ] [ 2 \ gcd check-word ] unit-test ! multiple return values
[ f ] [ 1 \ drop check-word ] unit-test ! no return value
[ f ] [ 1 \ lcm check-word ] unit-test ! takes 2 args
: no-stack-effect-declared + ;
[ 0 \ no-stack-effect-declared check-word ] must-fail
: qux ( -- x ) 2 ;
[ t ] [ 0 \ qux check-word ] unit-test
[ 8 ] [ [infix qux()*3+2 infix] ] unit-test
: foobar ( x -- y ) 1 + ;
[ t ] [ 1 \ foobar check-word ] unit-test
[ 4 ] [ [infix foobar(3*5%12) infix] ] unit-test
: stupid_function ( x x x x x -- y ) + + + + ;
[ t ] [ 5 \ stupid_function check-word ] unit-test
[ 10 ] [ [infix stupid_function (0, 1, 2, 3, 4) infix] ] unit-test
[ -1 ] [ [let | a [ 1 ] | [infix -a infix] ] ] unit-test

99
extra/infix/infix.factor Normal file
View File

@ -0,0 +1,99 @@
USING: accessors assocs combinators combinators.short-circuit
effects fry infix.parser infix.ast kernel locals.parser
locals.types math multiline namespaces parser quotations
sequences summary words ;
IN: infix
<PRIVATE
: prepare-operand ( term -- quot )
dup callable? [ 1quotation ] unless ;
ERROR: local-not-defined name ;
M: local-not-defined summary
drop "local is not defined" ;
: at? ( key assoc -- value/key ? )
dupd at* [ nip t ] [ drop f ] if ;
: >local-word ( string -- word )
locals get at? [ local-not-defined ] unless ;
: select-op ( string -- word )
{
{ "+" [ [ + ] ] }
{ "-" [ [ - ] ] }
{ "*" [ [ * ] ] }
{ "/" [ [ / ] ] }
[ drop [ mod ] ]
} case ;
GENERIC: infix-codegen ( ast -- quot/number )
M: ast-number infix-codegen value>> ;
M: ast-local infix-codegen
name>> >local-word ;
M: ast-array infix-codegen
[ index>> infix-codegen prepare-operand ]
[ name>> >local-word ] bi '[ @ _ nth ] ;
M: ast-op infix-codegen
[ left>> infix-codegen ] [ right>> infix-codegen ]
[ op>> select-op ] tri
2over [ number? ] both? [ call ] [
[ [ prepare-operand ] bi@ ] dip '[ @ @ @ ]
] if ;
M: ast-negation infix-codegen
term>> infix-codegen
{
{ [ dup number? ] [ neg ] }
{ [ dup callable? ] [ '[ @ neg ] ] }
[ '[ _ neg ] ] ! local word
} cond ;
ERROR: bad-stack-effect word ;
M: bad-stack-effect summary
drop "Words used in infix must declare a stack effect and return exactly one value" ;
: check-word ( argcount word -- ? )
dup stack-effect [ ] [ bad-stack-effect ] ?if
[ in>> length ] [ out>> length ] bi
[ = ] dip 1 = and ;
: find-and-check ( args argcount string -- quot )
dup search [ ] [ no-word ] ?if
[ nip ] [ check-word ] 2bi
[ 1quotation compose ] [ bad-stack-effect ] if ;
: arguments-codegen ( seq -- quot )
dup empty? [ drop [ ] ] [
[ infix-codegen prepare-operand ]
[ compose ] map-reduce
] if ;
M: ast-function infix-codegen
[ arguments>> [ arguments-codegen ] [ length ] bi ]
[ name>> ] bi find-and-check ;
: [infix-parse ( end -- result/quot )
parse-multiline-string build-infix-ast
infix-codegen prepare-operand ;
PRIVATE>
: [infix
"infix]" [infix-parse parsed \ call parsed ; parsing
<PRIVATE
: parse-infix-locals ( assoc end -- quot )
[
in-lambda? on
[ dup [ locals set ] [ push-locals ] bi ] dip
[infix-parse prepare-operand swap pop-locals
] with-scope ;
PRIVATE>
: [infix|
"|" parse-bindings "infix]" parse-infix-locals <let>
parsed-lambda ; parsing

175
extra/infix/parser/parser-tests.factor Normal file
View File

@ -0,0 +1,175 @@
USING: infix.ast infix.parser infix.tokenizer tools.test ;
IN: infix.parser.tests
\ parse-infix must-infer
\ build-infix-ast must-infer
[ T{ ast-number { value 1 } } ] [ "1" build-infix-ast ] unit-test
[ T{ ast-negation f T{ ast-number { value 1 } } } ]
[ "-1" build-infix-ast ] unit-test
[ T{ ast-op
{ left
T{ ast-op
{ left T{ ast-number { value 1 } } }
{ right T{ ast-number { value 2 } } }
{ op "+" }
}
}
{ right T{ ast-number { value 4 } } }
{ op "+" }
} ] [ "1+2+4" build-infix-ast ] unit-test
[ T{ ast-op
{ left T{ ast-number { value 1 } } }
{ right
T{ ast-op
{ left T{ ast-number { value 2 } } }
{ right T{ ast-number { value 3 } } }
{ op "*" }
}
}
{ op "+" }
} ] [ "1+2*3" build-infix-ast ] unit-test
[ T{ ast-op
{ left T{ ast-number { value 1 } } }
{ right T{ ast-number { value 2 } } }
{ op "+" }
} ] [ "(1+2)" build-infix-ast ] unit-test
[ T{ ast-local { name "foo" } } ] [ "foo" build-infix-ast ] unit-test
[ "-" build-infix-ast ] must-fail
[ T{ ast-function
{ name "foo" }
{ arguments
V{
T{ ast-op
{ left T{ ast-number { value 1 } } }
{ right T{ ast-number { value 2 } } }
{ op "+" }
}
T{ ast-op
{ left T{ ast-number { value 2 } } }
{ right T{ ast-number { value 3 } } }
{ op "%" }
}
}
}
} ] [ "foo (1+ 2,2%3) " build-infix-ast ] unit-test
[ T{ ast-op
{ left
T{ ast-op
{ left
T{ ast-function
{ name "bar" }
{ arguments V{ } }
}
}
{ right
T{ ast-array
{ name "baz" }
{ index
T{ ast-op
{ left
T{ ast-op
{ left
T{ ast-number
{ value 2 }
}
}
{ right
T{ ast-number
{ value 3 }
}
}
{ op "/" }
}
}
{ right
T{ ast-number { value 4 } }
}
{ op "+" }
}
}
}
}
{ op "+" }
}
}
{ right T{ ast-number { value 2 } } }
{ op "/" }
} ] [ "(bar() + baz[2/ 3+4 ] )/2" build-infix-ast ] unit-test
[ T{ ast-op
{ left T{ ast-number { value 1 } } }
{ right
T{ ast-op
{ left T{ ast-number { value 2 } } }
{ right T{ ast-number { value 3 } } }
{ op "/" }
}
}
{ op "+" }
} ] [ "1\n+\n2\r/\t3" build-infix-ast ] unit-test
[ T{ ast-negation
{ term
T{ ast-function
{ name "foo" }
{ arguments
V{
T{ ast-number { value 2 } }
T{ ast-negation
{ term T{ ast-number { value 3 } } }
}
}
}
}
}
} ] [ "-foo(+2,-3)" build-infix-ast ] unit-test
[ T{ ast-array
{ name "arr" }
{ index
T{ ast-op
{ left
T{ ast-negation
{ term
T{ ast-op
{ left
T{ ast-function
{ name "foo" }
{ arguments
V{
T{ ast-number
{ value 2 }
}
}
}
}
}
{ right
T{ ast-negation
{ term
T{ ast-number
{ value 1 }
}
}
}
}
{ op "+" }
}
}
}
}
{ right T{ ast-number { value 3 } } }
{ op "/" }
}
}
} ] [ "+arr[-(foo(2)+-1)/3]" build-infix-ast ] unit-test
[ "foo bar baz" build-infix-ast ] must-fail
[ "1+2/4+" build-infix-ast ] must-fail
[ "quaz(2/3,)" build-infix-ast ] must-fail

30
extra/infix/parser/parser.factor Normal file
View File

@ -0,0 +1,30 @@
USING: infix.ast infix.tokenizer kernel math peg.ebnf sequences
strings vectors ;
IN: infix.parser
EBNF: parse-infix
Number = . ?[ ast-number? ]?
Identifier = . ?[ string? ]?
Array = Identifier:i "[" Sum:s "]" => [[ i s ast-array boa ]]
Function = Identifier:i "(" FunArgs?:a ")" => [[ i a [ V{ } ] unless* ast-function boa ]]
FunArgs = FunArgs:a "," Sum:s => [[ s a push a ]]
| Sum:s => [[ s 1vector ]]
Terminal = ("-"|"+"):op Terminal:term => [[ term op "-" = [ ast-negation boa ] when ]]
| "(" Sum:s ")" => [[ s ]]
| Number | Array | Function
| Identifier => [[ ast-local boa ]]
Product = Product:p ("*"|"/"|"%"):op Terminal:term => [[ p term op ast-op boa ]]
| Terminal
Sum = Sum:s ("+"|"-"):op Product:p => [[ s p op ast-op boa ]]
| Product
End = !(.)
Expression = Sum End
;EBNF
: build-infix-ast ( string -- ast )
tokenize-infix parse-infix ;

20
extra/infix/tokenizer/tokenizer-tests.factor Normal file
View File

@ -0,0 +1,20 @@
USING: infix.ast infix.tokenizer tools.test ;
IN: infix.tokenizer.tests
\ tokenize-infix must-infer
[ V{ T{ ast-number f 1 } } ] [ "1" tokenize-infix ] unit-test
[ V{ T{ ast-number f 1.02 } CHAR: * T{ ast-number f 3 } } ] [ "1.02*3" tokenize-infix ] unit-test
[ V{ T{ ast-number f 3 } CHAR: / CHAR: ( T{ ast-number f 3 } CHAR: + T{ ast-number f 4 } CHAR: ) } ]
[ "3/(3+4)" tokenize-infix ] unit-test
[ V{ "foo" CHAR: ( "x" CHAR: , "y" CHAR: , "z" CHAR: ) } ] [ "foo(x,y,z)" tokenize-infix ] unit-test
[ V{ "arr" CHAR: [ "x" CHAR: + T{ ast-number f 3 } CHAR: ] } ]
[ "arr[x+3]" tokenize-infix ] unit-test
[ "1.0.4" tokenize-infix ] must-fail
[ V{ CHAR: + CHAR: ] T{ ast-number f 3.4 } CHAR: , "bar" } ]
[ "+]3.4,bar" tokenize-infix ] unit-test
[ V{ "baz_34c" } ] [ "baz_34c" tokenize-infix ] unit-test
[ V{ T{ ast-number f 34 } "c_baz" } ] [ "34c_baz" tokenize-infix ] unit-test
[ V{ CHAR: ( T{ ast-number f 1 } CHAR: + T{ ast-number f 2 } CHAR: ) } ]
[ "(1+2)" tokenize-infix ] unit-test
[ V{ T{ ast-number f 1 } CHAR: + T{ ast-number f 2 } CHAR: / T{ ast-number f 3 } } ]
[ "1\n+\r2\t/ 3" tokenize-infix ] unit-test

21
extra/infix/tokenizer/tokenizer.factor Normal file
View File

@ -0,0 +1,21 @@
USING: infix.ast kernel peg peg.ebnf math.parser sequences
strings ;
IN: infix.tokenizer
EBNF: tokenize-infix
Letter = [a-zA-Z]
Digit = [0-9]
Digits = Digit+
Number = Digits '.' Digits => [[ concat >string string>number ast-number boa ]]
| Digits => [[ >string string>number ast-number boa ]]
Space = " " | "\n" | "\r" | "\t"
Spaces = Space* => [[ ignore ]]
NameFirst = Letter | "_" => [[ CHAR: _ ]]
NameRest = NameFirst | Digit
Name = NameFirst NameRest* => [[ first2 swap prefix >string ]]
Special = [+*/%(),] | "-" => [[ CHAR: - ]]
| "[" => [[ CHAR: [ ]] | "]" => [[ CHAR: ] ]]
Tok = Spaces (Name | Number | Special )
End = !(.)
Toks = Tok* Spaces End
;EBNF

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

@ -65,7 +65,7 @@ SYMBOL: dh-file
"concatenative.org" 25 <inet> smtp-server set-global
"noreply@concatenative.org" lost-password-from set-global
"website@concatenative.org" insomniac-sender set-global
"slava@factorcode.org" insomniac-recipients set-global
{ "slava@factorcode.org" } insomniac-recipients set-global
init-factor-db ;
: init-testing ( -- )

6
unmaintained/openal/macosx/macosx.factor
View File

@ -9,6 +9,6 @@ LIBRARY: alut
FUNCTION: void alutLoadWAVFile ( ALbyte* fileName, ALenum* format, void** data, ALsizei* size, ALsizei* frequency ) ;
M: macosx load-wav-file ( path -- format data size frequency )
0 <int> f <void*> 0 <int> 0 <int>
[ alutLoadWAVFile ] 4keep
>r >r >r *int r> *void* r> *int r> *int ;
0 <int> f <void*> 0 <int> 0 <int>
[ alutLoadWAVFile ] 4keep
[ [ [ *int ] dip *void* ] dip *int ] dip *int ;

252
unmaintained/openal/openal.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel arrays alien system combinators alien.syntax namespaces
alien.c-types sequences vocabs.loader shuffle combinators.lib
alien.c-types sequences vocabs.loader shuffle
openal.backend specialized-arrays.uint ;
IN: openal
@ -36,75 +36,75 @@ TYPEDEF: int ALenum
TYPEDEF: float ALfloat
TYPEDEF: double ALdouble
: AL_INVALID ( -- number ) -1 ; inline
: AL_NONE ( -- number ) 0 ; inline
: AL_FALSE ( -- number ) 0 ; inline
: AL_TRUE ( -- number ) 1 ; inline
: AL_SOURCE_RELATIVE ( -- number ) HEX: 202 ; inline
: AL_CONE_INNER_ANGLE ( -- nmber ) HEX: 1001 ; inline
: AL_CONE_OUTER_ANGLE ( -- number ) HEX: 1002 ; inline
: AL_PITCH ( -- number ) HEX: 1003 ; inline
: AL_POSITION ( -- number ) HEX: 1004 ; inline
: AL_DIRECTION ( -- number ) HEX: 1005 ; inline
: AL_VELOCITY ( -- number ) HEX: 1006 ; inline
: AL_LOOPING ( -- number ) HEX: 1007 ; inline
: AL_BUFFER ( -- number ) HEX: 1009 ; inline
: AL_GAIN ( -- number ) HEX: 100A ; inline
: AL_MIN_GAIN ( -- number ) HEX: 100D ; inline
: AL_MAX_GAIN ( -- number ) HEX: 100E ; inline
: AL_ORIENTATION ( -- number ) HEX: 100F ; inline
: AL_CHANNEL_MASK ( -- number ) HEX: 3000 ; inline
: AL_SOURCE_STATE ( -- number ) HEX: 1010 ; inline
: AL_INITIAL ( -- number ) HEX: 1011 ; inline
: AL_PLAYING ( -- number ) HEX: 1012 ; inline
: AL_PAUSED ( -- number ) HEX: 1013 ; inline
: AL_STOPPED ( -- number ) HEX: 1014 ; inline
: AL_BUFFERS_QUEUED ( -- number ) HEX: 1015 ; inline
: AL_BUFFERS_PROCESSED ( -- number ) HEX: 1016 ; inline
: AL_SEC_OFFSET ( -- number ) HEX: 1024 ; inline
: AL_SAMPLE_OFFSET ( -- number ) HEX: 1025 ; inline
: AL_BYTE_OFFSET ( -- number ) HEX: 1026 ; inline
: AL_SOURCE_TYPE ( -- number ) HEX: 1027 ; inline
: AL_STATIC ( -- number ) HEX: 1028 ; inline
: AL_STREAMING ( -- number ) HEX: 1029 ; inline
: AL_UNDETERMINED ( -- number ) HEX: 1030 ; inline
: AL_FORMAT_MONO8 ( -- number ) HEX: 1100 ; inline
: AL_FORMAT_MONO16 ( -- number ) HEX: 1101 ; inline
: AL_FORMAT_STEREO8 ( -- number ) HEX: 1102 ; inline
: AL_FORMAT_STEREO16 ( -- number ) HEX: 1103 ; inline
: AL_REFERENCE_DISTANCE ( -- number ) HEX: 1020 ; inline
: AL_ROLLOFF_FACTOR ( -- number ) HEX: 1021 ; inline
: AL_CONE_OUTER_GAIN ( -- number ) HEX: 1022 ; inline
: AL_MAX_DISTANCE ( -- number ) HEX: 1023 ; inline
: AL_FREQUENCY ( -- number ) HEX: 2001 ; inline
: AL_BITS ( -- number ) HEX: 2002 ; inline
: AL_CHANNELS ( -- number ) HEX: 2003 ; inline
: AL_SIZE ( -- number ) HEX: 2004 ; inline
: AL_UNUSED ( -- number ) HEX: 2010 ; inline
: AL_PENDING ( -- number ) HEX: 2011 ; inline
: AL_PROCESSED ( -- number ) HEX: 2012 ; inline
: AL_NO_ERROR ( -- number ) AL_FALSE ; inline
: AL_INVALID_NAME ( -- number ) HEX: A001 ; inline
: AL_ILLEGAL_ENUM ( -- number ) HEX: A002 ; inline
: AL_INVALID_ENUM ( -- number ) HEX: A002 ; inline
: AL_INVALID_VALUE ( -- number ) HEX: A003 ; inline
: AL_ILLEGAL_COMMAND ( -- number ) HEX: A004 ; inline
: AL_INVALID_OPERATION ( -- number ) HEX: A004 ; inline
: AL_OUT_OF_MEMORY ( -- number ) HEX: A005 ; inline
: AL_VENDOR ( -- number ) HEX: B001 ; inline
: AL_VERSION ( -- number ) HEX: B002 ; inline
: AL_RENDERER ( -- number ) HEX: B003 ; inline
: AL_EXTENSIONS ( -- number ) HEX: B004 ; inline
: AL_DOPPLER_FACTOR ( -- number ) HEX: C000 ; inline
: AL_DOPPLER_VELOCITY ( -- number ) HEX: C001 ; inline
: AL_SPEED_OF_SOUND ( -- number ) HEX: C003 ; inline
: AL_DISTANCE_MODEL ( -- number ) HEX: D000 ; inline
: AL_INVERSE_DISTANCE ( -- number ) HEX: D001 ; inline
: AL_INVERSE_DISTANCE_CLAMPED ( -- number ) HEX: D002 ; inline
: AL_LINEAR_DISTANCE ( -- number ) HEX: D003 ; inline
: AL_LINEAR_DISTANCE_CLAMPED ( -- number ) HEX: D004 ; inline
: AL_EXPONENT_DISTANCE ( -- number ) HEX: D005 ; inline
: AL_EXPONENT_DISTANCE_CLAMPED ( -- number ) HEX: D006 ; inline
CONSTANT: AL_INVALID -1
CONSTANT: AL_NONE 0
CONSTANT: AL_FALSE 0
CONSTANT: AL_TRUE 1
CONSTANT: AL_SOURCE_RELATIVE HEX: 202
CONSTANT: AL_CONE_INNER_ANGLE HEX: 1001
CONSTANT: AL_CONE_OUTER_ANGLE HEX: 1002
CONSTANT: AL_PITCH HEX: 1003
CONSTANT: AL_POSITION HEX: 1004
CONSTANT: AL_DIRECTION HEX: 1005
CONSTANT: AL_VELOCITY HEX: 1006
CONSTANT: AL_LOOPING HEX: 1007
CONSTANT: AL_BUFFER HEX: 1009
CONSTANT: AL_GAIN HEX: 100A
CONSTANT: AL_MIN_GAIN HEX: 100D
CONSTANT: AL_MAX_GAIN HEX: 100E
CONSTANT: AL_ORIENTATION HEX: 100F
CONSTANT: AL_CHANNEL_MASK HEX: 3000
CONSTANT: AL_SOURCE_STATE HEX: 1010
CONSTANT: AL_INITIAL HEX: 1011
CONSTANT: AL_PLAYING HEX: 1012
CONSTANT: AL_PAUSED HEX: 1013
CONSTANT: AL_STOPPED HEX: 1014
CONSTANT: AL_BUFFERS_QUEUED HEX: 1015
CONSTANT: AL_BUFFERS_PROCESSED HEX: 1016
CONSTANT: AL_SEC_OFFSET HEX: 1024
CONSTANT: AL_SAMPLE_OFFSET HEX: 1025
CONSTANT: AL_BYTE_OFFSET HEX: 1026
CONSTANT: AL_SOURCE_TYPE HEX: 1027
CONSTANT: AL_STATIC HEX: 1028
CONSTANT: AL_STREAMING HEX: 1029
CONSTANT: AL_UNDETERMINED HEX: 1030
CONSTANT: AL_FORMAT_MONO8 HEX: 1100
CONSTANT: AL_FORMAT_MONO16 HEX: 1101
CONSTANT: AL_FORMAT_STEREO8 HEX: 1102
CONSTANT: AL_FORMAT_STEREO16 HEX: 1103
CONSTANT: AL_REFERENCE_DISTANCE HEX: 1020
CONSTANT: AL_ROLLOFF_FACTOR HEX: 1021
CONSTANT: AL_CONE_OUTER_GAIN HEX: 1022
CONSTANT: AL_MAX_DISTANCE HEX: 1023
CONSTANT: AL_FREQUENCY HEX: 2001
CONSTANT: AL_BITS HEX: 2002
CONSTANT: AL_CHANNELS HEX: 2003
CONSTANT: AL_SIZE HEX: 2004
CONSTANT: AL_UNUSED HEX: 2010
CONSTANT: AL_PENDING HEX: 2011
CONSTANT: AL_PROCESSED HEX: 2012
CONSTANT: AL_NO_ERROR AL_FALSE
CONSTANT: AL_INVALID_NAME HEX: A001
CONSTANT: AL_ILLEGAL_ENUM HEX: A002
CONSTANT: AL_INVALID_ENUM HEX: A002
CONSTANT: AL_INVALID_VALUE HEX: A003
CONSTANT: AL_ILLEGAL_COMMAND HEX: A004
CONSTANT: AL_INVALID_OPERATION HEX: A004
CONSTANT: AL_OUT_OF_MEMORY HEX: A005
CONSTANT: AL_VENDOR HEX: B001
CONSTANT: AL_VERSION HEX: B002
CONSTANT: AL_RENDERER HEX: B003
CONSTANT: AL_EXTENSIONS HEX: B004
CONSTANT: AL_DOPPLER_FACTOR HEX: C000
CONSTANT: AL_DOPPLER_VELOCITY HEX: C001
CONSTANT: AL_SPEED_OF_SOUND HEX: C003
CONSTANT: AL_DISTANCE_MODEL HEX: D000
CONSTANT: AL_INVERSE_DISTANCE HEX: D001
CONSTANT: AL_INVERSE_DISTANCE_CLAMPED HEX: D002
CONSTANT: AL_LINEAR_DISTANCE HEX: D003
CONSTANT: AL_LINEAR_DISTANCE_CLAMPED HEX: D004
CONSTANT: AL_EXPONENT_DISTANCE HEX: D005
CONSTANT: AL_EXPONENT_DISTANCE_CLAMPED HEX: D006
FUNCTION: void alEnable ( ALenum capability ) ;
FUNCTION: void alDisable ( ALenum capability ) ;
@ -182,34 +182,34 @@ FUNCTION: void alDistanceModel ( ALenum distanceModel ) ;
LIBRARY: alut
: ALUT_API_MAJOR_VERSION ( -- number ) 1 ; inline
: ALUT_API_MINOR_VERSION ( -- number ) 1 ; inline
: ALUT_ERROR_NO_ERROR ( -- number ) 0 ; inline
: ALUT_ERROR_OUT_OF_MEMORY ( -- number ) HEX: 200 ; inline
: ALUT_ERROR_INVALID_ENUM ( -- number ) HEX: 201 ; inline
: ALUT_ERROR_INVALID_VALUE ( -- number ) HEX: 202 ; inline
: ALUT_ERROR_INVALID_OPERATION ( -- number ) HEX: 203 ; inline
: ALUT_ERROR_NO_CURRENT_CONTEXT ( -- number ) HEX: 204 ; inline
: ALUT_ERROR_AL_ERROR_ON_ENTRY ( -- number ) HEX: 205 ; inline
: ALUT_ERROR_ALC_ERROR_ON_ENTRY ( -- number ) HEX: 206 ; inline
: ALUT_ERROR_OPEN_DEVICE ( -- number ) HEX: 207 ; inline
: ALUT_ERROR_CLOSE_DEVICE ( -- number ) HEX: 208 ; inline
: ALUT_ERROR_CREATE_CONTEXT ( -- number ) HEX: 209 ; inline
: ALUT_ERROR_MAKE_CONTEXT_CURRENT ( -- number ) HEX: 20A ; inline
: ALUT_ERROR_DESTRY_CONTEXT ( -- number ) HEX: 20B ; inline
: ALUT_ERROR_GEN_BUFFERS ( -- number ) HEX: 20C ; inline
: ALUT_ERROR_BUFFER_DATA ( -- number ) HEX: 20D ; inline
: ALUT_ERROR_IO_ERROR ( -- number ) HEX: 20E ; inline
: ALUT_ERROR_UNSUPPORTED_FILE_TYPE ( -- number ) HEX: 20F ; inline
: ALUT_ERROR_UNSUPPORTED_FILE_SUBTYPE ( -- number ) HEX: 210 ; inline
: ALUT_ERROR_CORRUPT_OR_TRUNCATED_DATA ( -- number ) HEX: 211 ; inline
: ALUT_WAVEFORM_SINE ( -- number ) HEX: 100 ; inline
: ALUT_WAVEFORM_SQUARE ( -- number ) HEX: 101 ; inline
: ALUT_WAVEFORM_SAWTOOTH ( -- number ) HEX: 102 ; inline
: ALUT_WAVEFORM_WHITENOISE ( -- number ) HEX: 103 ; inline
: ALUT_WAVEFORM_IMPULSE ( -- number ) HEX: 104 ; inline
: ALUT_LOADER_BUFFER ( -- number ) HEX: 300 ; inline
: ALUT_LOADER_MEMORY ( -- number ) HEX: 301 ; inline
CONSTANT: ALUT_API_MAJOR_VERSION 1
CONSTANT: ALUT_API_MINOR_VERSION 1
CONSTANT: ALUT_ERROR_NO_ERROR 0
CONSTANT: ALUT_ERROR_OUT_OF_MEMORY HEX: 200
CONSTANT: ALUT_ERROR_INVALID_ENUM HEX: 201
CONSTANT: ALUT_ERROR_INVALID_VALUE HEX: 202
CONSTANT: ALUT_ERROR_INVALID_OPERATION HEX: 203
CONSTANT: ALUT_ERROR_NO_CURRENT_CONTEXT HEX: 204
CONSTANT: ALUT_ERROR_AL_ERROR_ON_ENTRY HEX: 205
CONSTANT: ALUT_ERROR_ALC_ERROR_ON_ENTRY HEX: 206
CONSTANT: ALUT_ERROR_OPEN_DEVICE HEX: 207
CONSTANT: ALUT_ERROR_CLOSE_DEVICE HEX: 208
CONSTANT: ALUT_ERROR_CREATE_CONTEXT HEX: 209
CONSTANT: ALUT_ERROR_MAKE_CONTEXT_CURRENT HEX: 20A
CONSTANT: ALUT_ERROR_DESTRY_CONTEXT HEX: 20B
CONSTANT: ALUT_ERROR_GEN_BUFFERS HEX: 20C
CONSTANT: ALUT_ERROR_BUFFER_DATA HEX: 20D
CONSTANT: ALUT_ERROR_IO_ERROR HEX: 20E
CONSTANT: ALUT_ERROR_UNSUPPORTED_FILE_TYPE HEX: 20F
CONSTANT: ALUT_ERROR_UNSUPPORTED_FILE_SUBTYPE HEX: 210
CONSTANT: ALUT_ERROR_CORRUPT_OR_TRUNCATED_DATA HEX: 211
CONSTANT: ALUT_WAVEFORM_SINE HEX: 100
CONSTANT: ALUT_WAVEFORM_SQUARE HEX: 101
CONSTANT: ALUT_WAVEFORM_SAWTOOTH HEX: 102
CONSTANT: ALUT_WAVEFORM_WHITENOISE HEX: 103
CONSTANT: ALUT_WAVEFORM_IMPULSE HEX: 104
CONSTANT: ALUT_LOADER_BUFFER HEX: 300
CONSTANT: ALUT_LOADER_MEMORY HEX: 301
FUNCTION: ALboolean alutInit ( int* argcp, char** argv ) ;
FUNCTION: ALboolean alutInitWithoutContext ( int* argcp, char** argv ) ;
@ -234,37 +234,37 @@ FUNCTION: void alutUnloadWAV ( ALenum format, void* data, ALsizei size, ALsizei
SYMBOL: init
: init-openal ( -- )
init get-global expired? [
f f alutInit 0 = [ "Could not initialize OpenAL" throw ] when
1337 <alien> init set-global
] when ;
init get-global expired? [
f f alutInit 0 = [ "Could not initialize OpenAL" throw ] when
1337 <alien> init set-global
] when ;
: exit-openal ( -- )
init get-global expired? [
alutExit 0 = [ "Could not close OpenAL" throw ] when
f init set-global
] unless ;
init get-global expired? [
alutExit 0 = [ "Could not close OpenAL" throw ] when
f init set-global
] unless ;
: <uint-array> ( n -- byte-array ) "ALuint" <c-array> ;
: gen-sources ( size -- seq )
dup <uint-array> 2dup underlying>> alGenSources swap ;
dup <uint-array> 2dup underlying>> alGenSources swap ;
: gen-buffers ( size -- seq )
dup <uint-array> 2dup underlying>> alGenBuffers swap ;
dup <uint-array> 2dup underlying>> alGenBuffers swap ;
: gen-buffer ( -- buffer ) 1 gen-buffers first ;
: create-buffer-from-file ( filename -- buffer )
alutCreateBufferFromFile dup AL_NONE = [
"create-buffer-from-file failed" throw
] when ;
alutCreateBufferFromFile dup AL_NONE = [
"create-buffer-from-file failed" throw
] when ;
os macosx? "openal.macosx" "openal.other" ? require
: create-buffer-from-wav ( filename -- buffer )
gen-buffer dup rot load-wav-file
[ alBufferData ] 4keep alutUnloadWAV ;
gen-buffer dup rot load-wav-file
[ alBufferData ] 4keep alutUnloadWAV ;
: queue-buffers ( source buffers -- )
[ length ] [ >uint-array underlying>> ] bi alSourceQueueBuffers ;
@ -273,29 +273,27 @@ os macosx? "openal.macosx" "openal.other" ? require
1array queue-buffers ;
: set-source-param ( source param value -- )
alSourcei ;
alSourcei ;
: get-source-param ( source param -- value )
0 <uint> dup >r alGetSourcei r> *uint ;
0 <uint> dup [ alGetSourcei ] dip *uint ;
: set-buffer-param ( source param value -- )
alBufferi ;
alBufferi ;
: get-buffer-param ( source param -- value )
0 <uint> dup >r alGetBufferi r> *uint ;
0 <uint> dup [ alGetBufferi ] dip *uint ;
: source-play ( source -- )
alSourcePlay ;
: source-play ( source -- ) alSourcePlay ;
: source-stop ( source -- )
alSourceStop ;
: source-stop ( source -- ) alSourceStop ;
: check-error ( -- )
alGetError dup ALUT_ERROR_NO_ERROR = [
drop
] [
alGetString throw
] if ;
alGetError dup ALUT_ERROR_NO_ERROR = [
drop
] [
alGetString throw
] if ;
: source-playing? ( source -- bool )
AL_SOURCE_STATE get-source-param AL_PLAYING = ;
AL_SOURCE_STATE get-source-param AL_PLAYING = ;

4
vm/io.h
View File

@ -1,7 +1,7 @@
void init_c_io(void);
void io_error(void);
int err_no(void);
void clear_err_no(void);
DLLEXPORT int err_no(void);
DLLEXPORT void clear_err_no(void);
void primitive_fopen(void);
void primitive_fgetc(void);