! (c)2009 Joe Groff bsd license
USING: accessors alien.c-types alien.parser alien.syntax
-tools.test vocabs.parser parser eval vocabs.parser debugger
-continuations ;
+tools.test vocabs.parser parser eval debugger kernel
+continuations words ;
IN: alien.parser.tests
TYPEDEF: char char2
] with-file-vocabs
+FUNCTION: void* alien-parser-effect-test ( int *arg1 float arg2 ) ;
+[ (( arg1 arg2 -- void* )) ] [
+ \ alien-parser-effect-test "declared-effect" word-prop
+] unit-test
+
! Reported by mnestic
TYPEDEF: int alien-parser-test-int ! reasonably unique name...
: function-quot ( return library function types -- quot )
'[ _ _ _ _ alien-invoke ] ;
-:: make-function ( return! library function! parameters -- word quot effect )
- return function normalize-c-arg function! return!
+:: make-function ( return library function parameters -- word quot effect )
+ return function normalize-c-arg :> ( return-c-type function )
function create-in dup reset-generic
- return library function
+ return-c-type library function
parameters return parse-arglist [ function-quot ] dip ;
: parse-arg-tokens ( -- tokens )
-USING: concurrency.mailboxes concurrency.count-downs concurrency.conditions\r
-vectors sequences threads tools.test math kernel strings namespaces\r
-continuations calendar destructors ;\r
-IN: concurrency.mailboxes.tests\r
-\r
-{ 1 1 } [ [ integer? ] mailbox-get? ] must-infer-as\r
-\r
-[ V{ 1 2 3 } ] [\r
- 0 <vector>\r
- <mailbox>\r
- [ mailbox-get swap push ] in-thread\r
- [ mailbox-get swap push ] in-thread\r
- [ mailbox-get swap push ] in-thread\r
- 1 over mailbox-put\r
- 2 over mailbox-put\r
- 3 swap mailbox-put\r
-] unit-test\r
-\r
-[ V{ 1 2 3 } ] [\r
- 0 <vector>\r
- <mailbox>\r
- [ [ integer? ] mailbox-get? swap push ] in-thread\r
- [ [ integer? ] mailbox-get? swap push ] in-thread\r
- [ [ integer? ] mailbox-get? swap push ] in-thread\r
- 1 over mailbox-put\r
- 2 over mailbox-put\r
- 3 swap mailbox-put\r
-] unit-test\r
-\r
-[ V{ 1 "junk" 3 "junk2" } [ 456 ] ] [\r
- 0 <vector>\r
- <mailbox>\r
- [ [ integer? ] mailbox-get? swap push ] in-thread\r
- [ [ integer? ] mailbox-get? swap push ] in-thread\r
- [ [ string? ] mailbox-get? swap push ] in-thread\r
- [ [ string? ] mailbox-get? swap push ] in-thread\r
- 1 over mailbox-put\r
- "junk" over mailbox-put\r
- [ 456 ] over mailbox-put\r
- 3 over mailbox-put\r
- "junk2" over mailbox-put\r
- mailbox-get\r
-] unit-test\r
-\r
-[ { "foo" "bar" } ] [\r
- <mailbox>\r
- "foo" over mailbox-put\r
- "bar" over mailbox-put\r
- mailbox-get-all\r
-] unit-test\r
-\r
-[\r
- <mailbox> 1 seconds mailbox-get-timeout\r
-] [ wait-timeout? ] must-fail-with\r
+USING: concurrency.mailboxes concurrency.count-downs concurrency.conditions
+vectors sequences threads tools.test math kernel strings namespaces
+continuations calendar destructors ;
+IN: concurrency.mailboxes.tests
+
+{ 1 1 } [ [ integer? ] mailbox-get? ] must-infer-as
+
+[ V{ 1 2 3 } ] [
+ 0 <vector>
+ <mailbox>
+ [ mailbox-get swap push ] in-thread
+ [ mailbox-get swap push ] in-thread
+ [ mailbox-get swap push ] in-thread
+ 1 over mailbox-put
+ 2 over mailbox-put
+ 3 swap mailbox-put
+] unit-test
+
+[ V{ 1 2 3 } ] [
+ 0 <vector>
+ <mailbox>
+ [ [ integer? ] mailbox-get? swap push ] in-thread
+ [ [ integer? ] mailbox-get? swap push ] in-thread
+ [ [ integer? ] mailbox-get? swap push ] in-thread
+ 1 over mailbox-put
+ 2 over mailbox-put
+ 3 swap mailbox-put
+] unit-test
+
+[ V{ 1 "junk" 3 "junk2" } [ 456 ] ] [
+ 0 <vector>
+ <mailbox>
+ [ [ integer? ] mailbox-get? swap push ] in-thread
+ [ [ integer? ] mailbox-get? swap push ] in-thread
+ [ [ string? ] mailbox-get? swap push ] in-thread
+ [ [ string? ] mailbox-get? swap push ] in-thread
+ 1 over mailbox-put
+ "junk" over mailbox-put
+ [ 456 ] over mailbox-put
+ 3 over mailbox-put
+ "junk2" over mailbox-put
+ mailbox-get
+] unit-test
+
+[ { "foo" "bar" } ] [
+ <mailbox>
+ "foo" over mailbox-put
+ "bar" over mailbox-put
+ mailbox-get-all
+] unit-test
+
+[
+ <mailbox> 1 seconds mailbox-get-timeout
+] [ wait-timeout? ] must-fail-with
-! Copyright (C) 2005, 2010 Chris Double, Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: dlists deques threads sequences continuations namespaces\r
-math quotations words kernel arrays assocs init system\r
-concurrency.conditions accessors debugger debugger.threads\r
-locals fry ;\r
-IN: concurrency.mailboxes\r
-\r
-TUPLE: mailbox threads data ;\r
-\r
-: <mailbox> ( -- mailbox )\r
- mailbox new\r
- <dlist> >>threads\r
- <dlist> >>data ;\r
-\r
-: mailbox-empty? ( mailbox -- bool )\r
- data>> deque-empty? ;\r
-\r
-: mailbox-put ( obj mailbox -- )\r
- [ data>> push-front ]\r
- [ threads>> notify-all ] bi yield ;\r
-\r
-: wait-for-mailbox ( mailbox timeout -- )\r
- [ threads>> ] dip "mailbox" wait ;\r
-\r
-:: block-unless-pred ( mailbox timeout pred: ( message -- ? ) -- )\r
- mailbox data>> pred dlist-any? [\r
- mailbox timeout wait-for-mailbox\r
- mailbox timeout pred block-unless-pred\r
- ] unless ; inline recursive\r
-\r
-: block-if-empty ( mailbox timeout -- mailbox )\r
- over mailbox-empty? [\r
- 2dup wait-for-mailbox block-if-empty\r
- ] [\r
- drop\r
- ] if ;\r
-\r
-: mailbox-peek ( mailbox -- obj )\r
- data>> peek-back ;\r
-\r
-: mailbox-get-timeout ( mailbox timeout -- obj )\r
- block-if-empty data>> pop-back ;\r
-\r
-: mailbox-get ( mailbox -- obj )\r
- f mailbox-get-timeout ;\r
-\r
-: mailbox-get-all-timeout ( mailbox timeout -- array )\r
- block-if-empty\r
- [ dup mailbox-empty? not ]\r
- [ dup data>> pop-back ]\r
- produce nip ;\r
-\r
-: mailbox-get-all ( mailbox -- array )\r
- f mailbox-get-all-timeout ;\r
-\r
-: while-mailbox-empty ( mailbox quot -- )\r
- [ '[ _ mailbox-empty? ] ] dip while ; inline\r
-\r
-: mailbox-get-timeout? ( mailbox timeout pred -- obj )\r
- [ block-unless-pred ]\r
- [ [ drop data>> ] dip delete-node-if ]\r
- 3bi ; inline\r
-\r
-: mailbox-get? ( mailbox pred -- obj )\r
- f swap mailbox-get-timeout? ; inline\r
-\r
-: wait-for-close-timeout ( mailbox timeout -- )\r
- over disposed>>\r
- [ 2drop ] [ 2dup wait-for-mailbox wait-for-close-timeout ] if ;\r
-\r
-: wait-for-close ( mailbox -- )\r
- f wait-for-close-timeout ;\r
-\r
-TUPLE: linked-error error thread ;\r
-\r
-M: linked-error error.\r
- [ thread>> error-in-thread. ] [ error>> error. ] bi ;\r
-\r
-C: <linked-error> linked-error\r
-\r
-: ?linked ( message -- message )\r
- dup linked-error? [ rethrow ] when ;\r
-\r
-TUPLE: linked-thread < thread supervisor ;\r
-\r
-M: linked-thread error-in-thread\r
- [ <linked-error> ] [ supervisor>> ] bi mailbox-put ;\r
-\r
-: <linked-thread> ( quot name mailbox -- thread' )\r
- [ linked-thread new-thread ] dip >>supervisor ;\r
-\r
-: spawn-linked-to ( quot name mailbox -- thread )\r
- <linked-thread> [ (spawn) ] keep ;\r
+! Copyright (C) 2005, 2010 Chris Double, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: dlists deques threads sequences continuations namespaces
+math quotations words kernel arrays assocs init system
+concurrency.conditions accessors debugger debugger.threads
+locals fry ;
+IN: concurrency.mailboxes
+
+TUPLE: mailbox threads data ;
+
+: <mailbox> ( -- mailbox )
+ mailbox new
+ <dlist> >>threads
+ <dlist> >>data ;
+
+: mailbox-empty? ( mailbox -- bool )
+ data>> deque-empty? ;
+
+: mailbox-put ( obj mailbox -- )
+ [ data>> push-front ]
+ [ threads>> notify-all ] bi yield ;
+
+: wait-for-mailbox ( mailbox timeout -- )
+ [ threads>> ] dip "mailbox" wait ;
+
+:: block-unless-pred ( mailbox timeout pred: ( message -- ? ) -- )
+ mailbox data>> pred dlist-any? [
+ mailbox timeout wait-for-mailbox
+ mailbox timeout pred block-unless-pred
+ ] unless ; inline recursive
+
+: block-if-empty ( mailbox timeout -- mailbox )
+ over mailbox-empty? [
+ 2dup wait-for-mailbox block-if-empty
+ ] [
+ drop
+ ] if ;
+
+: mailbox-peek ( mailbox -- obj )
+ data>> peek-back ;
+
+: mailbox-get-timeout ( mailbox timeout -- obj )
+ block-if-empty data>> pop-back ;
+
+: mailbox-get ( mailbox -- obj )
+ f mailbox-get-timeout ;
+
+: mailbox-get-all-timeout ( mailbox timeout -- array )
+ block-if-empty
+ [ dup mailbox-empty? not ]
+ [ dup data>> pop-back ]
+ produce nip ;
+
+: mailbox-get-all ( mailbox -- array )
+ f mailbox-get-all-timeout ;
+
+: while-mailbox-empty ( mailbox quot -- )
+ [ '[ _ mailbox-empty? ] ] dip while ; inline
+
+: mailbox-get-timeout? ( mailbox timeout pred -- obj )
+ [ block-unless-pred ]
+ [ [ drop data>> ] dip delete-node-if ]
+ 3bi ; inline
+
+: mailbox-get? ( mailbox pred -- obj )
+ f swap mailbox-get-timeout? ; inline
+
+: wait-for-close-timeout ( mailbox timeout -- )
+ over disposed>>
+ [ 2drop ] [ 2dup wait-for-mailbox wait-for-close-timeout ] if ;
+
+: wait-for-close ( mailbox -- )
+ f wait-for-close-timeout ;
+
+TUPLE: linked-error error thread ;
+
+M: linked-error error.
+ [ thread>> error-in-thread. ] [ error>> error. ] bi ;
+
+C: <linked-error> linked-error
+
+: ?linked ( message -- message )
+ dup linked-error? [ rethrow ] when ;
+
+TUPLE: linked-thread < thread supervisor ;
+
+M: linked-thread error-in-thread
+ [ <linked-error> ] [ supervisor>> ] bi mailbox-put ;
+
+: <linked-thread> ( quot name mailbox -- thread' )
+ [ linked-thread new-thread ] dip >>supervisor ;
+
+: spawn-linked-to ( quot name mailbox -- thread )
+ <linked-thread> [ (spawn) ] keep ;
-! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors concurrency.mailboxes kernel continuations ;\r
-IN: concurrency.promises\r
-\r
-TUPLE: promise mailbox ;\r
-\r
-: <promise> ( -- promise )\r
- <mailbox> promise boa ;\r
-\r
-: promise-fulfilled? ( promise -- ? )\r
- mailbox>> mailbox-empty? not ;\r
-\r
-ERROR: promise-already-fulfilled promise ;\r
-\r
-: fulfill ( value promise -- )\r
- dup promise-fulfilled? [ \r
- promise-already-fulfilled\r
- ] [\r
- mailbox>> mailbox-put\r
- ] if ;\r
-\r
-: ?promise-timeout ( promise timeout -- result )\r
- [ mailbox>> ] dip block-if-empty mailbox-peek ;\r
-\r
-: ?promise ( promise -- result )\r
- f ?promise-timeout ;\r
+! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors concurrency.mailboxes kernel continuations ;
+IN: concurrency.promises
+
+TUPLE: promise mailbox ;
+
+: <promise> ( -- promise )
+ <mailbox> promise boa ;
+
+: promise-fulfilled? ( promise -- ? )
+ mailbox>> mailbox-empty? not ;
+
+ERROR: promise-already-fulfilled promise ;
+
+: fulfill ( value promise -- )
+ dup promise-fulfilled? [
+ promise-already-fulfilled
+ ] [
+ mailbox>> mailbox-put
+ ] if ;
+
+: ?promise-timeout ( promise timeout -- result )
+ [ mailbox>> ] dip block-if-empty mailbox-peek ;
+
+: ?promise ( promise -- result )
+ f ?promise-timeout ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel strings words vocabs ;
+USING: help.markup help.syntax kernel strings words vocabs sequences ;
IN: tools.scaffold
HELP: developer-name
{ scaffold-help scaffold-undocumented } related-words
+HELP: scaffold-authors
+{ $values
+ { "vocab" "a vocabulary specifier" }
+}
+{ $description "Creates an authors.txt file using the value in " { $link developer-name } ". This word only works if no authors.txt file yet exists." } ;
+
+HELP: scaffold-summary
+{ $values
+ { "vocab" "a vocabulary specifier" } { "summary" string }
+}
+{ $description "Creates a summary.txt file with the given summary. This word only works if no summary.txt file yet exists." } ;
+
+HELP: scaffold-tags
+{ $values
+ { "vocab" "a vocabulary specifier" } { "tags" string }
+}
+{ $description "Creates a tags.txt file with the given tags. This word only works if no tags.txt file yet exists." } ;
+
+HELP: scaffold-tests
+{ $values
+ { "vocab" "a vocabulary specifier" }
+}
+{ $description "Takes an existing vocabulary and creates an empty tests file help for each word. This word only works if no tests file yet exists." } ;
+
HELP: scaffold-vocab
{ $values
{ "vocab-root" "a vocabulary root string" } { "string" string } }
: vocab-root/vocab/suffix>path ( vocab-root vocab suffix -- path )
[ vocab-root/vocab>path dup file-name append-path ] dip append ;
+: vocab/file>path ( vocab file -- path )
+ [ vocab>path ] dip append-path ;
+
: vocab/suffix>path ( vocab suffix -- path )
[ vocab>path dup file-name append-path ] dip append ;
2drop
] if ;
-: scaffold-authors ( vocab-root vocab -- )
- developer-name get [
- "authors.txt" vocab-root/vocab/file>path scaffolding? [
- developer-name get swap utf8 set-file-contents
+: scaffold-metadata ( vocab file contents -- )
+ [ ensure-vocab-exists ] 2dip
+ [
+ [ vocab/file>path ] dip swap scaffolding? [
+ utf8 set-file-contents
] [
- drop
+ 2drop
] if
] [
2drop
- ] if ;
+ ] if* ;
: lookup-type ( string -- object/string ? )
"new" ?head drop [ { [ CHAR: ' = ] [ digit? ] } 1|| ] trim-tail
: scaffold-undocumented ( string -- )
[ interesting-words. ] [ link-vocab ] bi ;
+: scaffold-authors ( vocab -- )
+ "authors.txt" developer-name get scaffold-metadata ;
+
+: scaffold-tags ( vocab tags -- )
+ [ "tags.txt" ] dip scaffold-metadata ;
+
+: scaffold-summary ( vocab summary -- )
+ [ "summary.txt" ] dip scaffold-metadata ;
+
: scaffold-vocab ( vocab-root string -- )
{
[ scaffold-directory ]
[ scaffold-main ]
- [ scaffold-authors ]
[ nip require ]
+ [ nip scaffold-authors ]
} 2cleave ;
: scaffold-core ( string -- ) "resource:core" swap scaffold-vocab ;
USING: help.markup help.syntax strings ;
IN: vocabs.files
+HELP: vocab-tests-file
+{ $values { "vocab" "a vocabulary specifier" } { "path" "pathname string to test file" } }
+{ $description "Outputs a pathname where the unit test file is located." } ;
+
+HELP: vocab-tests-dir
+{ $values { "vocab" "a vocabulary specifier" } { "paths" "a sequence of pathname strings" } }
+{ $description "Outputs a sequence of pathnames for the tests in the test directory." } ;
+
HELP: vocab-files
{ $values { "vocab" "a vocabulary specifier" } { "seq" "a sequence of pathname strings" } }
{ $description "Outputs a sequence of files comprising this vocabulary, or " { $link f } " if the vocabulary does not have a directory on disk." } ;
sequences vocabs.loader ;
IN: vocabs.files
-<PRIVATE
-
: vocab-tests-file ( vocab -- path )
dup "-tests.factor" vocab-dir+ vocab-append-path dup
[ dup exists? [ drop f ] unless ] [ drop f ] if ;
] [ drop f ] if
] [ drop f ] if ;
-PRIVATE>
-
: vocab-tests ( vocab -- tests )
[
[ vocab-tests-file [ , ] when* ]
[ vocab-source-path [ , ] when* ]
[ vocab-docs-path [ , ] when* ]
[ vocab-tests % ] tri
- ] { } make ;
\ No newline at end of file
+ ] { } make ;
USING: accessors assocs compiler.units continuations fuel.eval fuel.help
fuel.remote fuel.xref help.topics io.pathnames kernel namespaces parser
-sequences tools.scaffold vocabs.loader vocabs.parser words ;
+sequences tools.scaffold vocabs.loader vocabs.parser words vocabs.files
+vocabs.metadata ;
IN: fuel
[ fuel-scaffold-name dup require dup scaffold-help ] with-scope
vocab-docs-path absolute-path fuel-eval-set-result ;
+: fuel-scaffold-tests ( name devname -- )
+ [ fuel-scaffold-name dup require dup scaffold-tests ] with-scope
+ vocab-tests-file absolute-path fuel-eval-set-result ;
+
+: fuel-scaffold-authors ( name devname -- )
+ [ fuel-scaffold-name dup require dup scaffold-authors ] with-scope
+ [ vocab-authors-path ] keep swap vocab-append-path absolute-path fuel-eval-set-result ;
+
+: fuel-scaffold-tags ( name tags -- )
+ [ scaffold-tags ]
+ [ drop [ vocab-tags-path ] keep swap vocab-append-path absolute-path fuel-eval-set-result ] 2bi ;
+
+: fuel-scaffold-summary ( name summary -- )
+ [ scaffold-summary ]
+ [ drop [ vocab-summary-path ] keep swap vocab-append-path absolute-path fuel-eval-set-result ] 2bi ;
+
: fuel-scaffold-get-root ( name -- ) find-vocab-root fuel-eval-set-result ;
! Remote connection
-! Copyright (C) 2007 Chris Double.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel accessors arrays alien system combinators\r
-alien.syntax namespaces alien.c-types sequences vocabs.loader\r
-shuffle openal openal.alut.backend alien.libraries generalizations\r
-specialized-arrays alien.destructors ;\r
-FROM: alien.c-types => float short ;\r
-SPECIALIZED-ARRAY: uint\r
-IN: openal.alut\r
-\r
-<< "alut" {\r
- { [ os windows? ] [ "alut.dll" ] }\r
- { [ os macosx? ] [\r
- "/System/Library/Frameworks/OpenAL.framework/OpenAL"\r
- ] }\r
- { [ os unix? ] [ "libalut.so" ] }\r
- } cond "cdecl" add-library >>\r
-\r
-<< os macosx? [ "alut" deploy-library ] unless >>\r
-\r
-LIBRARY: alut\r
-\r
-CONSTANT: ALUT_API_MAJOR_VERSION 1\r
-CONSTANT: ALUT_API_MINOR_VERSION 1\r
-CONSTANT: ALUT_ERROR_NO_ERROR 0\r
-CONSTANT: ALUT_ERROR_OUT_OF_MEMORY HEX: 200\r
-CONSTANT: ALUT_ERROR_INVALID_ENUM HEX: 201\r
-CONSTANT: ALUT_ERROR_INVALID_VALUE HEX: 202\r
-CONSTANT: ALUT_ERROR_INVALID_OPERATION HEX: 203\r
-CONSTANT: ALUT_ERROR_NO_CURRENT_CONTEXT HEX: 204\r
-CONSTANT: ALUT_ERROR_AL_ERROR_ON_ENTRY HEX: 205\r
-CONSTANT: ALUT_ERROR_ALC_ERROR_ON_ENTRY HEX: 206\r
-CONSTANT: ALUT_ERROR_OPEN_DEVICE HEX: 207\r
-CONSTANT: ALUT_ERROR_CLOSE_DEVICE HEX: 208\r
-CONSTANT: ALUT_ERROR_CREATE_CONTEXT HEX: 209\r
-CONSTANT: ALUT_ERROR_MAKE_CONTEXT_CURRENT HEX: 20A\r
-CONSTANT: ALUT_ERROR_DESTRY_CONTEXT HEX: 20B\r
-CONSTANT: ALUT_ERROR_GEN_BUFFERS HEX: 20C\r
-CONSTANT: ALUT_ERROR_BUFFER_DATA HEX: 20D\r
-CONSTANT: ALUT_ERROR_IO_ERROR HEX: 20E\r
-CONSTANT: ALUT_ERROR_UNSUPPORTED_FILE_TYPE HEX: 20F\r
-CONSTANT: ALUT_ERROR_UNSUPPORTED_FILE_SUBTYPE HEX: 210\r
-CONSTANT: ALUT_ERROR_CORRUPT_OR_TRUNCATED_DATA HEX: 211\r
-CONSTANT: ALUT_WAVEFORM_SINE HEX: 100\r
-CONSTANT: ALUT_WAVEFORM_SQUARE HEX: 101\r
-CONSTANT: ALUT_WAVEFORM_SAWTOOTH HEX: 102\r
-CONSTANT: ALUT_WAVEFORM_WHITENOISE HEX: 103\r
-CONSTANT: ALUT_WAVEFORM_IMPULSE HEX: 104\r
-CONSTANT: ALUT_LOADER_BUFFER HEX: 300\r
-CONSTANT: ALUT_LOADER_MEMORY HEX: 301\r
-\r
-FUNCTION: ALboolean alutInit ( int* argcp, char** argv ) ;\r
-FUNCTION: ALboolean alutInitWithoutContext ( int* argcp, char** argv ) ;\r
-FUNCTION: ALboolean alutExit ( ) ;\r
-FUNCTION: ALenum alutGetError ( ) ;\r
-FUNCTION: char* alutGetErrorString ( ALenum error ) ;\r
-FUNCTION: ALuint alutCreateBufferFromFile ( char* fileName ) ;\r
-FUNCTION: ALuint alutCreateBufferFromFileImage ( void* data, ALsizei length ) ;\r
-FUNCTION: ALuint alutCreateBufferHelloWorld ( ) ;\r
-FUNCTION: ALuint alutCreateBufferWaveform ( ALenum waveshape, ALfloat frequency, ALfloat phase, ALfloat duration ) ;\r
-FUNCTION: void* alutLoadMemoryFromFile ( char* fileName, ALenum* format, ALsizei* size, ALfloat* frequency ) ;\r
-FUNCTION: void* alutLoadMemoryFromFileImage ( void* data, ALsizei length, ALenum* format, ALsizei* size, ALfloat* frequency ) ;\r
-FUNCTION: void* alutLoadMemoryHelloWorld ( ALenum* format, ALsizei* size, ALfloat* frequency ) ;\r
-FUNCTION: void* alutLoadMemoryWaveform ( ALenum waveshape, ALfloat frequency, ALfloat phase, ALfloat duration, ALenum* format, ALsizei* size, ALfloat* freq ) ;\r
-FUNCTION: char* alutGetMIMETypes ( ALenum loader ) ;\r
-FUNCTION: ALint alutGetMajorVersion ( ) ;\r
-FUNCTION: ALint alutGetMinorVersion ( ) ;\r
-FUNCTION: ALboolean alutSleep ( ALfloat duration ) ;\r
-\r
-FUNCTION: void alutUnloadWAV ( ALenum format, void* data, ALsizei size, ALsizei frequency ) ;\r
-\r
-SYMBOL: init\r
-\r
-: init-openal ( -- )\r
- init get-global expired? [\r
- f f alutInit 0 = [ "Could not initialize OpenAL" throw ] when\r
- 1337 <alien> init set-global\r
- ] when ;\r
-\r
-: exit-openal ( -- )\r
- init get-global expired? [\r
- alutExit 0 = [ "Could not close OpenAL" throw ] when\r
- f init set-global\r
- ] unless ;\r
-\r
-: create-buffer-from-file ( filename -- buffer )\r
- alutCreateBufferFromFile dup AL_NONE = [\r
- "create-buffer-from-file failed" throw\r
- ] when ;\r
-\r
-os macosx? "openal.alut.macosx" "openal.alut.other" ? require\r
-\r
-: create-buffer-from-wav ( filename -- buffer )\r
- gen-buffer dup rot load-wav-file\r
- [ alBufferData ] 4 nkeep alutUnloadWAV ;\r
-\r
-: check-error ( -- )\r
- alGetError dup ALUT_ERROR_NO_ERROR = [\r
- drop\r
- ] [\r
- alGetString throw\r
- ] if ;\r
-\r
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors arrays alien system combinators
+alien.syntax namespaces alien.c-types sequences vocabs.loader
+shuffle openal openal.alut.backend alien.libraries generalizations
+specialized-arrays alien.destructors ;
+FROM: alien.c-types => float short ;
+SPECIALIZED-ARRAY: uint
+IN: openal.alut
+
+<< "alut" {
+ { [ os windows? ] [ "alut.dll" ] }
+ { [ os macosx? ] [
+ "/System/Library/Frameworks/OpenAL.framework/OpenAL"
+ ] }
+ { [ os unix? ] [ "libalut.so" ] }
+ } cond "cdecl" add-library >>
+
+<< os macosx? [ "alut" deploy-library ] unless >>
+
+LIBRARY: alut
+
+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 ) ;
+FUNCTION: ALboolean alutExit ( ) ;
+FUNCTION: ALenum alutGetError ( ) ;
+FUNCTION: char* alutGetErrorString ( ALenum error ) ;
+FUNCTION: ALuint alutCreateBufferFromFile ( char* fileName ) ;
+FUNCTION: ALuint alutCreateBufferFromFileImage ( void* data, ALsizei length ) ;
+FUNCTION: ALuint alutCreateBufferHelloWorld ( ) ;
+FUNCTION: ALuint alutCreateBufferWaveform ( ALenum waveshape, ALfloat frequency, ALfloat phase, ALfloat duration ) ;
+FUNCTION: void* alutLoadMemoryFromFile ( char* fileName, ALenum* format, ALsizei* size, ALfloat* frequency ) ;
+FUNCTION: void* alutLoadMemoryFromFileImage ( void* data, ALsizei length, ALenum* format, ALsizei* size, ALfloat* frequency ) ;
+FUNCTION: void* alutLoadMemoryHelloWorld ( ALenum* format, ALsizei* size, ALfloat* frequency ) ;
+FUNCTION: void* alutLoadMemoryWaveform ( ALenum waveshape, ALfloat frequency, ALfloat phase, ALfloat duration, ALenum* format, ALsizei* size, ALfloat* freq ) ;
+FUNCTION: char* alutGetMIMETypes ( ALenum loader ) ;
+FUNCTION: ALint alutGetMajorVersion ( ) ;
+FUNCTION: ALint alutGetMinorVersion ( ) ;
+FUNCTION: ALboolean alutSleep ( ALfloat duration ) ;
+
+FUNCTION: void alutUnloadWAV ( ALenum format, void* data, ALsizei size, ALsizei frequency ) ;
+
+SYMBOL: init
+
+: init-openal ( -- )
+ init get-global expired? [
+ f f alutInit 0 = [ "Could not initialize OpenAL" throw ] when
+ 1337 <alien> init set-global
+ ] when ;
+
+: exit-openal ( -- )
+ init get-global expired? [
+ alutExit 0 = [ "Could not close OpenAL" throw ] when
+ f init set-global
+ ] unless ;
+
+: create-buffer-from-file ( filename -- buffer )
+ alutCreateBufferFromFile dup AL_NONE = [
+ "create-buffer-from-file failed" throw
+ ] when ;
+
+os macosx? "openal.alut.macosx" "openal.alut.other" ? require
+
+: create-buffer-from-wav ( filename -- buffer )
+ gen-buffer dup rot load-wav-file
+ [ alBufferData ] 4 nkeep alutUnloadWAV ;
+
+: check-error ( -- )
+ alGetError dup ALUT_ERROR_NO_ERROR = [
+ drop
+ ] [
+ alGetString throw
+ ] if ;
+
-! Copyright (C) 2007 Chris Double.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: calendar kernel openal openal.alut sequences threads ;\r
-IN: openal.example\r
-\r
-: play-hello ( -- )\r
- init-openal\r
- 1 gen-sources\r
- first dup AL_BUFFER alutCreateBufferHelloWorld set-source-param\r
- source-play\r
- 1000 milliseconds sleep ;\r
- \r
-: (play-file) ( source -- )\r
- 100 milliseconds sleep\r
- dup source-playing? [ (play-file) ] [ drop ] if ;\r
-\r
-: play-file ( filename -- )\r
- init-openal\r
- create-buffer-from-file \r
- 1 gen-sources\r
- first dup [ AL_BUFFER rot set-source-param ] dip\r
- dup source-play\r
- check-error\r
- (play-file) ;\r
-\r
-: play-wav ( filename -- )\r
- init-openal\r
- create-buffer-from-wav \r
- 1 gen-sources\r
- first dup [ AL_BUFFER rot set-source-param ] dip\r
- dup source-play\r
- check-error\r
- (play-file) ;\r
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: calendar kernel openal openal.alut sequences threads ;
+IN: openal.example
+
+: play-hello ( -- )
+ init-openal
+ 1 gen-sources
+ first dup AL_BUFFER alutCreateBufferHelloWorld set-source-param
+ source-play
+ 1000 milliseconds sleep ;
+
+: (play-file) ( source -- )
+ 100 milliseconds sleep
+ dup source-playing? [ (play-file) ] [ drop ] if ;
+
+: play-file ( filename -- )
+ init-openal
+ create-buffer-from-file
+ 1 gen-sources
+ first dup [ AL_BUFFER rot set-source-param ] dip
+ dup source-play
+ check-error
+ (play-file) ;
+
+: play-wav ( filename -- )
+ init-openal
+ create-buffer-from-wav
+ 1 gen-sources
+ first dup [ AL_BUFFER rot set-source-param ] dip
+ dup source-play
+ check-error
+ (play-file) ;
(defsubst factor-mode--in-tests (&optional file)
(factor-mode--code-file "tests"))
-(defun factor-mode-visit-other-file (&optional skip)
+(defun factor-mode-visit-other-file (&optional create)
"Cycle between code, tests and docs factor files.
-With prefix, non-existing files will be skipped."
+With prefix, non-existing files will be created."
(interactive "P")
- (let ((file (factor-mode--cycle-next (buffer-file-name) skip)))
+ (let ((file (factor-mode--cycle-next (buffer-file-name) (not create))))
(unless file (error "No other file found"))
(find-file file)
(unless (file-exists-p file)
(comint-send-string nil "\"Refreshing loaded vocabs...\" write nl flush")
(comint-send-string nil " refresh-all \"Done!\" write nl flush\n")))
-(defun fuel-test-vocab (vocab)
- "Run the unit tests for the specified vocabulary."
- (interactive (list (fuel-completion--read-vocab nil (fuel-syntax--current-vocab))))
- (comint-send-string (fuel-listener--process)
- (concat "\"" vocab "\" reload nl flush\n"
- "\"" vocab "\" test nl flush\n")))
+(defun fuel-test-vocab (&optional arg)
+ "Run the unit tests for the current vocabulary. With prefix argument, ask for
+the vocabulary name."
+ (interactive "P")
+ (let* ((vocab (or (and (not arg) (fuel-syntax--current-vocab))
+ (fuel-completion--read-vocab nil))))
+ (comint-send-string (fuel-listener--process)
+ (concat "\"" vocab "\" reload nl flush\n"
+ "\"" vocab "\" test nl flush\n"))))
\f
;;; Completion support
"fuel")))
(fuel-eval--send/wait cmd)))
+(defsubst fuel-scaffold--create-tests (vocab)
+ (let ((cmd `(:fuel* (,vocab ,fuel-scaffold-developer-name fuel-scaffold-tests)
+ "fuel")))
+ (fuel-eval--send/wait cmd)))
+
+(defsubst fuel-scaffold--create-authors (vocab)
+ (let ((cmd `(:fuel* (,vocab ,fuel-scaffold-developer-name fuel-scaffold-authors) "fuel")))
+ (fuel-eval--send/wait cmd)))
+
+(defsubst fuel-scaffold--create-tags (vocab tags)
+ (let ((cmd `(:fuel* (,vocab ,tags fuel-scaffold-tags) "fuel")))
+ (fuel-eval--send/wait cmd)))
+
+(defsubst fuel-scaffold--create-summary (vocab summary)
+ (let ((cmd `(:fuel* (,vocab ,summary fuel-scaffold-summary) "fuel")))
+ (fuel-eval--send/wait cmd)))
+
+(defsubst fuel-scaffold--creaet-
+
(defun fuel-scaffold--help (parent)
(when (and parent (fuel-scaffold--check-auto fuel-scaffold-help-autoinsert-p))
(let* ((ret (fuel-scaffold--create-docs (fuel-scaffold--vocab parent)))
(defun fuel-scaffold-vocab (&optional other-window name-hint root-hint)
"Creates a directory in the given root for a new vocabulary and
-adds source, tests and authors.txt files.
+adds source and authors.txt files. Prompts the user for optional summary,
+tags, help, and test file creation.
You can configure `fuel-scaffold-developer-name' (set by default to
`user-full-name') for the name to be inserted in the generated files."
(root (completing-read "Vocab root: "
(fuel-scaffold--vocab-roots)
nil t (or root-hint "resource:")))
+ (summary (read-string "Vocab summary (empty for none): "))
+ (tags (read-string "Vocab tags (empty for none): "))
+ (help (y-or-n-p "Scaffold help? "))
+ (tests (y-or-n-p "Scaffold tests? "))
(cmd `(:fuel* ((,root ,name ,fuel-scaffold-developer-name)
(fuel-scaffold-vocab)) "fuel"))
(ret (fuel-eval--send/wait cmd))
(file (fuel-eval--retort-result ret)))
(unless file
(error "Error creating vocab (%s)" (car (fuel-eval--retort-error ret))))
+ (when (not (equal "" summary))
+ (fuel-scaffold--create-summary name summary))
+ (when (not (equal "" tags))
+ (fuel-scaffold--create-tags name tags))
+ (when help
+ (fuel-scaffold--create-docs name))
+ (when tests
+ (fuel-scaffold--create-tests name))
(if other-window (find-file-other-window file) (find-file file))
(goto-char (point-max))
name))
(error "Error creating help file" (car (fuel-eval--retort-error ret))))
(find-file file)))
+(defun fuel-scaffold-tests (&optional arg)
+ "Creates, if it does not already exist, a tests file for the current vocabulary.
+
+With prefix argument, ask for the vocabulary name.
+You can configure `fuel-scaffold-developer-name' (set by default to
+`user-full-name') for the name to be inserted in the generated file."
+ (interactive "P")
+ (let* ((vocab (or (and (not arg) (fuel-syntax--current-vocab))
+ (fuel-completion--read-vocab nil)))
+ (ret (fuel-scaffold--create-tests vocab))
+ (file (fuel-eval--retort-result ret)))
+ (unless file
+ (error "Error creating tests file" (car (fuel-eval--retort-error ret))))
+ (find-file file)))
+
+(defun fuel-scaffold-authors (&optional arg)
+ "Creates, if it does not already exist, an authors file for the current vocabulary.
+
+With prefix argument, ask for the vocabulary name.
+You can configure `fuel-scaffold-developer-name' (set by default to
+`user-full-name') for the name to be inserted in the generated file."
+ (interactive "P")
+ (let* ((vocab (or (and (not arg) (fuel-syntax--current-vocab))
+ (fuel-completion--read-vocab nil)))
+ (ret (fuel-scaffold--create-authors vocab))
+ (file (fuel-eval--retort-result ret)))
+ (unless file
+ (error "Error creating authors file" (car (fuel-eval--retort-error ret))))
+ (find-file file)))
+
+(defun fuel-scaffold-tags (&optional arg)
+ "Creates, if it does not already exist, a tags file for the current vocabulary."
+ (interactive "P")
+ (let* ((vocab (or (and (not arg) (fuel-syntax--current-vocab))
+ (fuel-completion--read-vocab nil)))
+ (tags (read-string "Tags: "))
+ (ret (fuel-scaffold--create-tags vocab tags))
+ (file (fuel-eval--retort-result ret)))
+ (unless file
+ (error "Error creating tags file" (car (fuel-eval--retort-error ret))))
+ (find-file file)))
+
+(defun fuel-scaffold-summary (&optional arg)
+ "Creates, if it does not already exist, a summary file for the current vocabulary."
+ (interactive "P")
+ (let* ((vocab (or (and (not arg ) (fuel-syntax--current-vocab))
+ (fuel-completion--read-vocab nil)))
+ (summary (read-string "Summary: "))
+ (ret (fuel-scaffold--create-summary vocab summary))
+ (file (fuel-eval--retort-result ret)))
+ (unless file
+ (error "Error creating summary file" (car (fuel-eval--retort-error ret))))
+ (find-file file)))
+
\f
(provide 'fuel-scaffold)
;;; fuel-scaffold.el ends here
projects / factor.git / commitdiff