diff --git a/README.txt b/README.txt index 98616539d2..d60bf03130 100755 --- a/README.txt +++ b/README.txt @@ -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..image + factor.com -i=boot..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 diff --git a/basis/endian/authors.txt b/basis/endian/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/basis/endian/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/basis/endian/endian-tests.factor b/basis/endian/endian-tests.factor new file mode 100755 index 0000000000..b066ce6995 --- /dev/null +++ b/basis/endian/endian-tests.factor @@ -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 diff --git a/basis/endian/endian.factor b/basis/endian/endian.factor new file mode 100755 index 0000000000..a832d6c0a2 --- /dev/null +++ b/basis/endian/endian.factor @@ -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 *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 diff --git a/basis/furnace/utilities/utilities-docs.factor b/basis/furnace/utilities/utilities-docs.factor index d2291786df..3a0d8804ef 100644 --- a/basis/furnace/utilities/utilities-docs.factor +++ b/basis/furnace/utilities/utilities-docs.factor @@ -27,7 +27,7 @@ HELP: hidden-form-field { $example "USING: furnace.utilities io ;" "\"bar\" \"foo\" hidden-form-field nl" - "" + "" } } ; diff --git a/basis/generalizations/generalizations-docs.factor b/basis/generalizations/generalizations-docs.factor index 912f69587e..ac8e14c05a 100644 --- a/basis/generalizations/generalizations-docs.factor +++ b/basis/generalizations/generalizations-docs.factor @@ -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" diff --git a/basis/generalizations/generalizations-tests.factor b/basis/generalizations/generalizations-tests.factor index 35e02f08b4..7ede271d01 100644 --- a/basis/generalizations/generalizations-tests.factor +++ b/basis/generalizations/generalizations-tests.factor @@ -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 \ No newline at end of file diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor index 4692fd20db..9b2b2456c2 100644 --- a/basis/generalizations/generalizations.factor +++ b/basis/generalizations/generalizations.factor @@ -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 spread>quot ; MACRO: mnswap ( m n -- ) - 1+ '[ _ -nrot ] spread>quot ; + 1+ '[ _ -nrot ] swap '[ _ _ napply ] ; + +MACRO: nweave ( n -- ) + [ dup [ '[ _ _ mnswap ] ] with map ] keep + '[ _ _ ncleave ] ; : nappend-as ( n exemplar -- seq ) [ narray concat ] dip like ; inline diff --git a/basis/html/templates/chloe/chloe-docs.factor b/basis/html/templates/chloe/chloe-docs.factor index b2259e629e..18e6db66f6 100644 --- a/basis/html/templates/chloe/chloe-docs.factor +++ b/basis/html/templates/chloe/chloe-docs.factor @@ -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 /> XML] ;" } "Finally, we can define a Chloe component:" { $code "COMPONENT: image" } diff --git a/basis/io/backend/unix/unix.factor b/basis/io/backend/unix/unix.factor index 4bc8868a3c..f5e6426859 100644 --- a/basis/io/backend/unix/unix.factor +++ b/basis/io/backend/unix/unix.factor @@ -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 ; diff --git a/basis/io/backend/windows/nt/nt.factor b/basis/io/backend/windows/nt/nt.factor index c6b24a0a11..6f283ac1bb 100755 --- a/basis/io/backend/windows/nt/nt.factor +++ b/basis/io/backend/windows/nt/nt.factor @@ -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 [ 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 { diff --git a/basis/io/ports/ports.factor b/basis/io/ports/ports.factor index 1fe717d5ee..1a58d4200b 100644 --- a/basis/io/ports/ports.factor +++ b/basis/io/ports/ports.factor @@ -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 ; diff --git a/basis/io/sockets/secure/unix/unix.factor b/basis/io/sockets/secure/unix/unix.factor index 8419246eb6..f1f39a0559 100644 --- a/basis/io/sockets/secure/unix/unix.factor +++ b/basis/io/sockets/secure/unix/unix.factor @@ -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 ; diff --git a/basis/io/sockets/unix/unix.factor b/basis/io/sockets/unix/unix.factor index f209df5862..e701874afd 100644 --- a/basis/io/sockets/unix/unix.factor +++ b/basis/io/sockets/unix/unix.factor @@ -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 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 ] [ diff --git a/basis/libc/libc.factor b/basis/libc/libc.factor index 1e751833a2..c154544f81 100644 --- a/basis/libc/libc.factor +++ b/basis/libc/libc.factor @@ -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 ; + >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? ] [ diff --git a/basis/pack/pack.factor b/basis/pack/pack.factor index 3cf7dbab4c..9078817206 100755 --- a/basis/pack/pack.factor +++ b/basis/pack/pack.factor @@ -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 *char zero? ; - - - -: >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 : 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 ; diff --git a/basis/unix/unix.factor b/basis/unix/unix.factor index 42444261e2..a6a0147504 100644 --- a/basis/unix/unix.factor +++ b/basis/unix/unix.factor @@ -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 ; 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 diff --git a/basis/windows/kernel32/kernel32.factor b/basis/windows/kernel32/kernel32.factor index d3e823f844..3494e83e83 100755 --- a/basis/windows/kernel32/kernel32.factor +++ b/basis/windows/kernel32/kernel32.factor @@ -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 diff --git a/basis/zlib/authors.txt b/basis/zlib/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/basis/zlib/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/basis/zlib/ffi/authors.txt b/basis/zlib/ffi/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/basis/zlib/ffi/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/basis/zlib/ffi/ffi.factor b/basis/zlib/ffi/ffi.factor new file mode 100755 index 0000000000..bda2809f56 --- /dev/null +++ b/basis/zlib/ffi/ffi.factor @@ -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 ) ; diff --git a/basis/zlib/zlib-tests.factor b/basis/zlib/zlib-tests.factor new file mode 100755 index 0000000000..0ac77277dc --- /dev/null +++ b/basis/zlib/zlib-tests.factor @@ -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 diff --git a/basis/zlib/zlib.factor b/basis/zlib/zlib.factor new file mode 100755 index 0000000000..b40d9c2a98 --- /dev/null +++ b/basis/zlib/zlib.factor @@ -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 ; + +: ( 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 dup length ] keep [ + dup length zlib.ffi:compress zlib-error + ] 3keep drop *ulong head + ] keep length ; + +: uncompress ( compressed -- byte-array ) + [ + length>> [ ] keep 2dup + ] [ + data>> dup length + zlib.ffi:uncompress zlib-error + ] bi *ulong head ; diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index f9702fd133..152d1bb85d 100644 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -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 diff --git a/core/io/io-docs.factor b/core/io/io-docs.factor index d7534ddb50..5d8aa6a88f 100644 --- a/core/io/io-docs.factor +++ b/core/io/io-docs.factor @@ -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* } diff --git a/core/io/io-tests.factor b/core/io/io-tests.factor index 009ba3a9e7..cf6b935215 100644 --- a/core/io/io-tests.factor +++ b/core/io/io-tests.factor @@ -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 ] [ diff --git a/core/io/io.factor b/core/io/io.factor index 55cc336ef8..11a2a6d1a8 100644 --- a/core/io/io.factor +++ b/core/io/io.factor @@ -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 ; \ No newline at end of file + curry with-input-stream ; diff --git a/core/strings/strings-docs.factor b/core/strings/strings-docs.factor index d40cd982d8..9a1671b126 100644 --- a/core/strings/strings-docs.factor +++ b/core/strings/strings-docs.factor @@ -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 } } diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor index 764df9924c..4dfa2d49bc 100644 --- a/core/words/words-docs.factor +++ b/core/words/words-docs.factor @@ -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" } } diff --git a/extra/24-game/24-game.factor b/extra/24-game/24-game.factor index 126215ab13..f842d5f4cb 100644 --- a/extra/24-game/24-game.factor +++ b/extra/24-game/24-game.factor @@ -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 \ No newline at end of file +MAIN: play-game diff --git a/extra/graphics/bitmap/bitmap-tests.factor b/extra/graphics/bitmap/bitmap-tests.factor index 15e960084a..f8a125e855 100644 --- a/extra/graphics/bitmap/bitmap-tests.factor +++ b/extra/graphics/bitmap/bitmap-tests.factor @@ -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 diff --git a/extra/graphics/bitmap/bitmap.factor b/extra/graphics/bitmap/bitmap.factor index bd34a9ee41..f8008dc7c1 100755 --- a/extra/graphics/bitmap/bitmap.factor +++ b/extra/graphics/bitmap/bitmap.factor @@ -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 [ 3 head-slice ] map ] [ color-index>> >array ] bi [ swap nth ] with map concat ; -: 4bit>array ( bitmap -- array ) - [ rgb-quads>> 4 [ 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 3 [ 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 ; diff --git a/extra/graphics/tiff/authors.txt b/extra/graphics/tiff/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/graphics/tiff/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/graphics/tiff/rgb.tiff b/extra/graphics/tiff/rgb.tiff new file mode 100755 index 0000000000..71cbaa9d6e Binary files /dev/null and b/extra/graphics/tiff/rgb.tiff differ diff --git a/extra/graphics/tiff/tiff-tests.factor b/extra/graphics/tiff/tiff-tests.factor new file mode 100755 index 0000000000..daee9a5d9e --- /dev/null +++ b/extra/graphics/tiff/tiff-tests.factor @@ -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" ; + + diff --git a/extra/graphics/tiff/tiff.factor b/extra/graphics/tiff/tiff.factor new file mode 100755 index 0000000000..f0b3f9337e --- /dev/null +++ b/extra/graphics/tiff/tiff.factor @@ -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 ; + + +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 ; + +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 ; + + +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 ; + + +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 ; + + +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> ; + +: read-ifds ( tiff -- tiff ) + [ + dup ifd-offset>> seek-absolute seek-input + 2 read endian> + dup [ read-ifd ] replicate + 4 read endian> + [ 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 [ ] } + { 256 [ ] } + { 257 [ ] } + { 258 [ ] } + { 259 [ lookup-compression ] } + { 262 [ lookup-photometric-interpretation ] } + { 273 [ ] } + { 277 [ ] } + { 278 [ ] } + { 279 [ ] } + { 282 [ ] } + { 283 [ ] } + { 284 [ ] } + { 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 [ + + 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 diff --git a/extra/infix/ast/ast.factor b/extra/infix/ast/ast.factor new file mode 100644 index 0000000000..0bc22feeb7 --- /dev/null +++ b/extra/infix/ast/ast.factor @@ -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 ; diff --git a/extra/infix/infix-docs.factor b/extra/infix/infix-docs.factor new file mode 100644 index 0000000000..7a4febb514 --- /dev/null +++ b/extra/infix/infix-docs.factor @@ -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 diff --git a/extra/infix/infix-tests.factor b/extra/infix/infix-tests.factor new file mode 100644 index 0000000000..5ee6468131 --- /dev/null +++ b/extra/infix/infix-tests.factor @@ -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 diff --git a/extra/infix/infix.factor b/extra/infix/infix.factor new file mode 100644 index 0000000000..31cd1cbe1f --- /dev/null +++ b/extra/infix/infix.factor @@ -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 + +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 + + + +: [infix| + "|" parse-bindings "infix]" parse-infix-locals + parsed-lambda ; parsing diff --git a/extra/infix/parser/parser-tests.factor b/extra/infix/parser/parser-tests.factor new file mode 100644 index 0000000000..0a0288c41b --- /dev/null +++ b/extra/infix/parser/parser-tests.factor @@ -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 diff --git a/extra/infix/parser/parser.factor b/extra/infix/parser/parser.factor new file mode 100644 index 0000000000..beaf3c335d --- /dev/null +++ b/extra/infix/parser/parser.factor @@ -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 ; diff --git a/extra/infix/tokenizer/tokenizer-tests.factor b/extra/infix/tokenizer/tokenizer-tests.factor new file mode 100644 index 0000000000..7e1fb005ef --- /dev/null +++ b/extra/infix/tokenizer/tokenizer-tests.factor @@ -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 diff --git a/extra/infix/tokenizer/tokenizer.factor b/extra/infix/tokenizer/tokenizer.factor new file mode 100644 index 0000000000..8c1a1b4a18 --- /dev/null +++ b/extra/infix/tokenizer/tokenizer.factor @@ -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 diff --git a/extra/websites/concatenative/concatenative.factor b/extra/websites/concatenative/concatenative.factor index c1d62c6cda..35a1129338 100644 --- a/extra/websites/concatenative/concatenative.factor +++ b/extra/websites/concatenative/concatenative.factor @@ -65,7 +65,7 @@ SYMBOL: dh-file "concatenative.org" 25 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 ( -- ) diff --git a/unmaintained/openal/macosx/macosx.factor b/unmaintained/openal/macosx/macosx.factor index d2a0422d8d..abc0d65fb9 100644 --- a/unmaintained/openal/macosx/macosx.factor +++ b/unmaintained/openal/macosx/macosx.factor @@ -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 f 0 0 - [ alutLoadWAVFile ] 4keep - >r >r >r *int r> *void* r> *int r> *int ; + 0 f 0 0 + [ alutLoadWAVFile ] 4keep + [ [ [ *int ] dip *void* ] dip *int ] dip *int ; diff --git a/unmaintained/openal/openal.factor b/unmaintained/openal/openal.factor index 40593d1e8d..8533308f26 100644 --- a/unmaintained/openal/openal.factor +++ b/unmaintained/openal/openal.factor @@ -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 init set-global - ] when ; + init get-global expired? [ + f f alutInit 0 = [ "Could not initialize OpenAL" throw ] when + 1337 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 ; : ( n -- byte-array ) "ALuint" ; : gen-sources ( size -- seq ) - dup 2dup underlying>> alGenSources swap ; + dup 2dup underlying>> alGenSources swap ; : gen-buffers ( size -- seq ) - dup 2dup underlying>> alGenBuffers swap ; + dup 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 dup >r alGetSourcei r> *uint ; + 0 dup [ alGetSourcei ] dip *uint ; : set-buffer-param ( source param value -- ) - alBufferi ; + alBufferi ; : get-buffer-param ( source param -- value ) - 0 dup >r alGetBufferi r> *uint ; + 0 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 = ; diff --git a/vm/io.h b/vm/io.h index 08c9dd7807..dc7d69edee 100755 --- a/vm/io.h +++ b/vm/io.h @@ -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);