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

db4
Daniel Ehrenberg 2009-02-08 21:18:10 -06:00
commit 25dc79d0e8
49 changed files with 1311 additions and 249 deletions

View File

@ -116,16 +116,22 @@ Now if $DISPLAY is set, running ./factor will start the UI.
* Running Factor on Windows XP/Vista * 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 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: To run the listener in the command prompt:
factor.exe -run=listener factor.com -run=listener
* The Factor FAQ * The Factor FAQ

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

@ -0,0 +1 @@
Doug Coleman

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

View File

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

View File

@ -30,6 +30,10 @@ HELP: narray
{ nsequence narray } related-words { nsequence narray } related-words
HELP: nsum
{ $values { "n" integer } }
{ $description "Adds the top " { $snippet "n" } " stack values." } ;
HELP: firstn HELP: firstn
{ $values { "n" integer } } { $values { "n" integer } }
{ $description "A generalization of " { $link first } ", " { $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 HELP: mnswap
{ $values { "m" integer } { "n" integer } } { $values { "m" integer } { "n" integer } }
{ $description "Swaps the top " { $snippet "m" } " stack elements with the " { $snippet "n" } " elements directly underneath." } { $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 HELP: n*quot
{ $values { $values
{ "n" integer } { "seq" sequence } { "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." } ; { $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" ARTICLE: "sequence-generalizations" "Generalized sequence operations"
"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:"
{ $subsection narray } { $subsection narray }
{ $subsection nsequence } { $subsection nsequence }
{ $subsection firstn } { $subsection firstn }
{ $subsection nappend } { $subsection nappend }
{ $subsection nappend-as } { $subsection nappend-as } ;
"Generated stack shuffle operations:"
ARTICLE: "shuffle-generalizations" "Generalized shuffle words"
{ $subsection ndup } { $subsection ndup }
{ $subsection npick } { $subsection npick }
{ $subsection nrot } { $subsection nrot }
@ -319,14 +335,28 @@ $nl
{ $subsection ndrop } { $subsection ndrop }
{ $subsection ntuck } { $subsection ntuck }
{ $subsection mnswap } { $subsection mnswap }
"Generalized combinators:" { $subsection nweave } ;
ARTICLE: "combinator-generalizations" "Generalized combinators"
{ $subsection ndip } { $subsection ndip }
{ $subsection nslip } { $subsection nslip }
{ $subsection nkeep } { $subsection nkeep }
{ $subsection napply } { $subsection napply }
{ $subsection ncleave } { $subsection ncleave }
"Generalized quotation construction:" { $subsection nspread } ;
ARTICLE: "other-generalizations" "Additional generalizations"
{ $subsection ncurry } { $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" ABOUT: "generalizations"

View File

@ -53,3 +53,12 @@ IN: generalizations.tests
[ 4 nappend ] must-infer [ 4 nappend ] must-infer
[ 4 { } nappend-as ] 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

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

View File

@ -261,7 +261,7 @@ $nl
ARTICLE: "html.templates.chloe.extend.components.example" "An example of a custom Chloe component" 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:" "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" } { $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] ;" } { $code "M: image render* 2drop [XML <img src=<-> /> XML] ;" }
"Finally, we can define a Chloe component:" "Finally, we can define a Chloe component:"
{ $code "COMPONENT: image" } { $code "COMPONENT: image" }

View File

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

View File

@ -82,6 +82,24 @@ M: winnt init-io ( -- )
H{ } clone pending-overlapped set-global H{ } clone pending-overlapped set-global
windows.winsock:init-winsock ; 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? ) : file-error? ( n -- eof? )
zero? [ zero? [
GetLastError { GetLastError {

View File

@ -120,6 +120,18 @@ M: output-port stream-write
HOOK: (wait-to-write) io-backend ( port -- ) 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 -- ) GENERIC: shutdown ( handle -- )
M: object shutdown drop ; M: object shutdown drop ;

View File

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

View File

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

View File

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

View File

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

View File

@ -5,33 +5,9 @@ io.binary io.streams.string kernel math math.parser namespaces
make parser prettyprint quotations sequences strings vectors make parser prettyprint quotations sequences strings vectors
words macros math.functions math.bitwise fry generalizations words macros math.functions math.bitwise fry generalizations
combinators.smart io.streams.byte-array io.encodings.binary combinators.smart io.streams.byte-array io.encodings.binary
math.vectors combinators multiline ; math.vectors combinators multiline endian ;
IN: pack 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 ) GENERIC: >n-byte-array ( obj n -- byte-array )
M: integer >n-byte-array ( m n -- byte-array ) >endian ; M: integer >n-byte-array ( m n -- byte-array ) >endian ;
@ -124,13 +100,13 @@ PRIVATE>
[ ch>packed-length ] sigma ; [ ch>packed-length ] sigma ;
: pack-native ( seq str -- seq ) : pack-native ( seq str -- seq )
[ set-big-endian pack ] with-scope ; inline '[ _ _ pack ] with-native-endian ; inline
: pack-be ( seq str -- seq ) : pack-be ( seq str -- seq )
[ big-endian on pack ] with-scope ; inline '[ _ _ pack ] with-big-endian ; inline
: pack-le ( seq str -- seq ) : pack-le ( seq str -- seq )
[ big-endian off pack ] with-scope ; inline '[ _ _ pack ] with-little-endian ; inline
<PRIVATE <PRIVATE
@ -146,13 +122,13 @@ MACRO: unpack ( str -- quot )
PRIVATE> PRIVATE>
: unpack-native ( seq str -- seq ) : unpack-native ( seq str -- seq )
[ set-big-endian unpack ] with-scope ; inline '[ _ _ unpack ] with-native-endian ; inline
: unpack-be ( seq str -- seq ) : unpack-be ( seq str -- seq )
[ big-endian on unpack ] with-scope ; inline '[ _ _ unpack ] with-big-endian ; inline
: unpack-le ( seq str -- seq ) : unpack-le ( seq str -- seq )
[ big-endian off unpack ] with-scope ; inline '[ _ _ unpack ] with-little-endian ; inline
ERROR: packed-read-fail str bytes ; ERROR: packed-read-fail str bytes ;

View File

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

View File

@ -1235,7 +1235,7 @@ ALIAS: GetFileAttributesEx GetFileAttributesExW
FUNCTION: BOOL GetFileInformationByHandle ( HANDLE hFile, LPBY_HANDLE_FILE_INFORMATION lpFileInformation ) ; FUNCTION: BOOL GetFileInformationByHandle ( HANDLE hFile, LPBY_HANDLE_FILE_INFORMATION lpFileInformation ) ;
FUNCTION: DWORD GetFileSize ( HANDLE hFile, LPDWORD lpFileSizeHigh ) ; 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: BOOL GetFileTime ( HANDLE hFile, LPFILETIME lpCreationTime, LPFILETIME lpLastAccessTime, LPFILETIME lpLastWriteTime ) ;
FUNCTION: DWORD GetFileType ( HANDLE hFile ) ; FUNCTION: DWORD GetFileType ( HANDLE hFile ) ;
! FUNCTION: GetFirmwareEnvironmentVariableA ! 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 ;

View File

@ -1,8 +1,7 @@
USING: tools.test io.files io.files.private io.files.temp USING: arrays debugger.threads destructors io io.directories
io.directories io.encodings.8-bit arrays make system io.encodings.8-bit io.encodings.ascii io.encodings.binary
io.encodings.binary io threads kernel continuations io.files io.files.private io.files.temp io.files.unique kernel
io.encodings.ascii sequences strings accessors make math sequences system threads tools.test ;
io.encodings.utf8 math destructors namespaces ;
IN: io.files.tests IN: io.files.tests
\ exists? must-infer \ exists? must-infer
@ -75,3 +74,73 @@ USE: debugger.threads
[ t ] [ "quux-test.txt" temp-file exists? ] unit-test [ t ] [ "quux-test.txt" temp-file exists? ] unit-test
[ ] [ "quux-test.txt" temp-file delete-file ] 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

View File

@ -68,6 +68,51 @@ HELP: stream-copy
{ $description "Copies the contents of one stream into another, closing both streams when done." } { $description "Copies the contents of one stream into another, closing both streams when done." }
$io-error ; $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 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* } "." } ; { $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 } { $subsection stream-write }
"This word is only required for string output streams:" "This word is only required for string output streams:"
{ $subsection stream-nl } { $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" } "." "For a discussion of the distinction between binary and string streams, see " { $link "stream-elements" } "."
{ $see-also "io.timeouts" } ; { $see-also "io.timeouts" } ;
@ -249,6 +296,8 @@ $nl
{ $subsection read-partial } { $subsection read-partial }
"If the default input stream is a string stream (" { $link "stream-elements" } "), lines of text can be read:" "If the default input stream is a string stream (" { $link "stream-elements" } "), lines of text can be read:"
{ $subsection readln } { $subsection readln }
"Seeking on the default input stream:"
{ $subsection seek-input }
"A pair of combinators for rebinding the " { $link input-stream } " variable:" "A pair of combinators for rebinding the " { $link input-stream } " variable:"
{ $subsection with-input-stream } { $subsection with-input-stream }
{ $subsection with-input-stream* } { $subsection with-input-stream* }
@ -256,7 +305,7 @@ $nl
{ $subsection output-stream } { $subsection output-stream }
"Unless rebound in a child namespace, this variable will be set to a console stream for showing output to the user." "Unless rebound in a child namespace, this variable will be set to a console stream for showing output to the user."
$nl $nl
"Words writing to the default input stream:" "Words writing to the default output stream:"
{ $subsection flush } { $subsection flush }
{ $subsection write1 } { $subsection write1 }
{ $subsection write } { $subsection write }
@ -265,6 +314,8 @@ $nl
{ $subsection print } { $subsection print }
{ $subsection nl } { $subsection nl }
{ $subsection bl } { $subsection bl }
"Seeking on the default output stream:"
{ $subsection seek-output }
"A pair of combinators for rebinding the " { $link output-stream } " variable:" "A pair of combinators for rebinding the " { $link output-stream } " variable:"
{ $subsection with-output-stream } { $subsection with-output-stream }
{ $subsection with-output-stream* } { $subsection with-output-stream* }

View File

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

View File

@ -15,6 +15,10 @@ GENERIC: stream-write ( seq stream -- )
GENERIC: stream-flush ( stream -- ) GENERIC: stream-flush ( stream -- )
GENERIC: stream-nl ( 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 ; : stream-print ( str stream -- ) [ stream-write ] keep stream-nl ;
! Default streams ! Default streams
@ -27,6 +31,8 @@ SYMBOL: error-stream
: read ( n -- seq ) input-stream get stream-read ; : read ( n -- seq ) input-stream get stream-read ;
: read-until ( seps -- seq sep/f ) input-stream get stream-read-until ; : read-until ( seps -- seq sep/f ) input-stream get stream-read-until ;
: read-partial ( n -- seq ) input-stream get stream-read-partial ; : 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 ; : write1 ( elt -- ) output-stream get stream-write1 ;
: write ( seq -- ) output-stream get stream-write ; : write ( seq -- ) output-stream get stream-write ;
@ -82,4 +88,4 @@ PRIVATE>
: stream-copy ( in out -- ) : stream-copy ( in out -- )
[ [ [ write ] each-block ] with-output-stream ] [ [ [ write ] each-block ] with-output-stream ]
curry with-input-stream ; curry with-input-stream ;

View File

@ -53,8 +53,9 @@ HELP: 1string
HELP: >string HELP: >string
{ $values { "seq" "a sequence of characters" } { "str" string } } { $values { "seq" "a sequence of characters" } { "str" string } }
{ $description "Outputs a freshly-allocated string with the same elements as a given sequence." } { $description "Outputs a freshly-allocated string with the same elements as a given sequence, by interpreting the sequence elements as Unicode code points." }
{ $errors "Throws an error if the sequence contains elements other than real numbers." } ; { $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 ) HELP: resize-string ( n str -- newstr )
{ $values { "n" "a non-negative integer" } { "str" string } { "newstr" string } } { $values { "n" "a non-negative integer" } { "str" string } { "newstr" string } }

View File

@ -107,7 +107,7 @@ $nl
{ { { $snippet "\"help\"" } ", " { $snippet "\"help-loc\"" } ", " { $snippet "\"help-parent\"" } } { "Where word help is stored - " { $link "writing-help" } } } { { { $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" } } { { { $snippet "\"inferred-effect\"" } } { $link "inference" } }

View File

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

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 IN: graphics.bitmap.tests
: test-bitmap24 ( -- ) : test-bitmap32-alpha ( -- path )
"resource:extra/graphics/bitmap/test-images/thiswayup24.bmp" bitmap. ; "resource:extra/graphics/bitmap/test-images/32alpha.bmp" ;
: test-bitmap8 ( -- ) : test-bitmap24 ( -- path )
"resource:extra/graphics/bitmap/test-images/rgb8bit.bmp" bitmap. ; "resource:extra/graphics/bitmap/test-images/thiswayup24.bmp" ;
: test-bitmap4 ( -- ) : test-bitmap16 ( -- path )
"resource:extra/graphics/bitmap/test-images/rgb4bit.bmp" bitmap. ; "resource:extra/graphics/bitmap/test-images/rgb16bit.bmp" ;
: test-bitmap1 ( -- ) : test-bitmap8 ( -- path )
"resource:extra/graphics/bitmap/test-images/1bit.bmp" bitmap. ; "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

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

View File

@ -0,0 +1 @@
Doug Coleman

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

Binary file not shown.

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

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 ;

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

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

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

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 ;

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

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

View File

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

View File

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

View File

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

View File

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