clean:
rm -f vm/*.o
rm -f factor.dll
+ rm -f factor.lib
+ rm -f factor.dll.lib
rm -f libfactor.*
rm -f libfactor-ffi-test.*
rm -f Factor.app/Contents/Frameworks/libfactor.dylib
+!IF DEFINED(DEBUG)\r
+LINK_FLAGS = /nologo /DEBUG shell32.lib\r
+CL_FLAGS = /nologo /Zi /O2 /W3 /DFACTOR_DEBUG\r
+!ELSE\r
LINK_FLAGS = /nologo shell32.lib\r
CL_FLAGS = /nologo /O2 /W3\r
+!ENDIF\r
\r
EXE_OBJS = factor.dll.lib vm\main-windows-nt.obj vm\factor.res\r
\r
.cpp.obj:\r
cl /EHsc $(CL_FLAGS) /Fo$@ /c $<\r
\r
+.c.obj:\r
+ cl $(CL_FLAGS) /Fo$@ /c $<\r
+\r
.rs.res:\r
rc $<\r
\r
all: factor.com factor.exe\r
\r
+libfactor-ffi-test.dll: vm/ffi_test.obj\r
+ link $(LINK_FLAGS) /out:libfactor-ffi-test.dll /dll vm/ffi_test.obj\r
+\r
factor.dll.lib: $(DLL_OBJS)\r
link $(LINK_FLAGS) /implib:factor.dll.lib /out:factor.dll /dll $(DLL_OBJS)\r
\r
"alien_offset" >>unboxer
\ void* define-primitive-type
- <long-long-type>
- integer >>class
- integer >>boxed-class
- [ alien-signed-8 ] >>getter
- [ set-alien-signed-8 ] >>setter
- 8 >>size
- 8-byte-alignment
- "from_signed_8" >>boxer
- "to_signed_8" >>unboxer
- \ longlong define-primitive-type
-
- <long-long-type>
- integer >>class
- integer >>boxed-class
- [ alien-unsigned-8 ] >>getter
- [ set-alien-unsigned-8 ] >>setter
- 8 >>size
- 8-byte-alignment
- "from_unsigned_8" >>boxer
- "to_unsigned_8" >>unboxer
- \ ulonglong define-primitive-type
-
- <c-type>
- integer >>class
- integer >>boxed-class
- [ alien-signed-cell ] >>getter
- [ set-alien-signed-cell ] >>setter
- bootstrap-cell >>size
- bootstrap-cell >>align
- bootstrap-cell >>align-first
- "from_signed_cell" >>boxer
- "to_fixnum" >>unboxer
- \ long define-primitive-type
-
- <c-type>
- integer >>class
- integer >>boxed-class
- [ alien-unsigned-cell ] >>getter
- [ set-alien-unsigned-cell ] >>setter
- bootstrap-cell >>size
- bootstrap-cell >>align
- bootstrap-cell >>align-first
- "from_unsigned_cell" >>boxer
- "to_cell" >>unboxer
- \ ulong define-primitive-type
-
<c-type>
integer >>class
integer >>boxed-class
[ >float ] >>unboxer-quot
\ double define-primitive-type
- cpu x86.64? os windows? and [
+ cell 8 = [
+ <c-type>
+ integer >>class
+ integer >>boxed-class
+ [ alien-signed-cell ] >>getter
+ [ set-alien-signed-cell ] >>setter
+ bootstrap-cell >>size
+ bootstrap-cell >>align
+ bootstrap-cell >>align-first
+ "from_signed_cell" >>boxer
+ "to_fixnum" >>unboxer
+ \ longlong define-primitive-type
+
+ <c-type>
+ integer >>class
+ integer >>boxed-class
+ [ alien-unsigned-cell ] >>getter
+ [ set-alien-unsigned-cell ] >>setter
+ bootstrap-cell >>size
+ bootstrap-cell >>align
+ bootstrap-cell >>align-first
+ "from_unsigned_cell" >>boxer
+ "to_cell" >>unboxer
+ \ ulonglong define-primitive-type
+
+ os windows? [
+ \ int c-type \ long define-primitive-type
+ \ uint c-type \ ulong define-primitive-type
+ ] [
+ \ longlong c-type \ long define-primitive-type
+ \ ulonglong c-type \ ulong define-primitive-type
+ ] if
+
\ longlong c-type \ ptrdiff_t typedef
\ longlong c-type \ intptr_t typedef
+
\ ulonglong c-type \ uintptr_t typedef
\ ulonglong c-type \ size_t typedef
] [
- \ long c-type \ ptrdiff_t typedef
- \ long c-type \ intptr_t typedef
- \ ulong c-type \ uintptr_t typedef
- \ ulong c-type \ size_t typedef
+ <long-long-type>
+ integer >>class
+ integer >>boxed-class
+ [ alien-signed-8 ] >>getter
+ [ set-alien-signed-8 ] >>setter
+ 8 >>size
+ 8-byte-alignment
+ "from_signed_8" >>boxer
+ "to_signed_8" >>unboxer
+ \ longlong define-primitive-type
+
+ <long-long-type>
+ integer >>class
+ integer >>boxed-class
+ [ alien-unsigned-8 ] >>getter
+ [ set-alien-unsigned-8 ] >>setter
+ 8 >>size
+ 8-byte-alignment
+ "from_unsigned_8" >>boxer
+ "to_unsigned_8" >>unboxer
+ \ ulonglong define-primitive-type
+
+ \ int c-type \ long define-primitive-type
+ \ uint c-type \ ulong define-primitive-type
+
+ \ int c-type \ ptrdiff_t typedef
+ \ int c-type \ intptr_t typedef
+
+ \ uint c-type \ uintptr_t typedef
+ \ uint c-type \ size_t typedef
] if
] with-compilation-unit
(command-line) parse-command-line
load-vocab-roots
run-user-init
- "e" get [ eval( -- ) ] when*
- ignore-cli-args? not script get and
- [ run-script ] [ "run" get run ] if*
+
+ "e" get script get or [
+ "e" get [ eval( -- ) ] when*
+ script get [ run-script ] when*
+ ] [
+ "run" get run
+ ] if
+
output-stream get [ stream-flush ] when*
0 exit
] [ print-error 1 exit ] recover
USING: cocoa cocoa.messages cocoa.subclassing cocoa.types
-compiler kernel namespaces cocoa.classes cocoa.runtime
+compiler.test kernel namespaces cocoa.classes cocoa.runtime
tools.test memory compiler.units math core-graphics.types ;
FROM: alien.c-types => int void ;
IN: cocoa.tests
HELP: default-cli-args
{ $description "Sets global variables corresponding to default command line arguments." } ;
-HELP: ignore-cli-args?
-{ $values { "?" "a boolean" } }
-{ $description "On Mac OS X, source files to run are supplied by the Cocoa API, so to avoid running them twice the startup code has to call this word." } ;
-
ARTICLE: "runtime-cli-args" "Command line switches for the VM"
"A handful of command line switches are processed by the VM and not the library. They control low-level features."
{ $table
main-vocab "run" set
] bind ;
-: ignore-cli-args? ( -- ? )
- os macosx? "run" get "ui" = and ;
-
[ default-cli-args ] "command-line" add-startup-hook
cfg get reverse-post-order ; inline
: filter-by ( flags seq -- seq' )
- [ drop ] pusher [ 2each ] dip ;
+ [ drop ] selector [ 2each ] dip ;
HINTS: filter-by { bit-array object } ;
] 2each ; inline
: merge-set ( bbs -- bbs' )
- (merge-set) filter-by ;
\ No newline at end of file
+ (merge-set) filter-by ;
2dup [ length ] bi@ max '[ _ 1 pad-tail ] bi@ [ bitand ] 2map ;
: (uninitialized-locs) ( seq quot -- seq' )
- [ [ drop 0 = ] pusher [ each-index ] dip ] dip map ; inline
+ [ [ drop 0 = ] selector [ each-index ] dip ] dip map ; inline
PRIVATE>
disable-optimizer
enable-optimizer
}
-"Removing a word's optimized definition:"
-{ $subsections decompile }
-"Compiling a single quotation:"
-{ $subsections compile-call }
-"Higher-level words can be found in " { $link "compilation-units" } "." ;
+"More words can be found in " { $link "compilation-units" } "." ;
ARTICLE: "compiler-impl" "Compiler implementation"
"The " { $vocab-link "compiler" } "vocabulary, in addition to providing the user-visible words of the compiler, implements the main compilation loop."
ABOUT: "compiler"
-HELP: decompile
-{ $values { "word" word } }
-{ $description "Removes a word's optimized definition. The word will be compiled with the non-optimizing compiler until recompiled with the optimizing compiler again." } ;
-
HELP: compile-word
{ $values { "word" word } }
{ $description "Compile a single word." }
HELP: optimizing-compiler
{ $description "Singleton class implementing " { $link recompile } " to call the optimizing compiler." }
{ $notes "This is an internal word, and user code should call " { $link compile } " instead." } ;
-
-HELP: compile-call
-{ $values { "quot" quotation } }
-{ $description "Compiles and runs a quotation." }
-{ $notes "This word is used by compiler unit tests to test compilation of small pieces of code." } ;
-! Copyright (C) 2004, 2009 Slava Pestov.
+! Copyright (C) 2004, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces arrays sequences io words fry
continuations vocabs assocs dlists definitions math graphs generic
: compile-loop ( deque -- )
[ compile-word yield-hook get call( -- ) ] slurp-deque ;
-: decompile ( word -- )
- dup def>> 2array 1array modify-code-heap ;
-
-: compile-call ( quot -- )
- [ dup infer define-temp ] with-compilation-unit execute ;
-
-\ compile-call t "no-compile" set-word-prop
-
SINGLETON: optimizing-compiler
M: optimizing-compiler recompile ( words -- alist )
: disable-optimizer ( -- )
f compiler-impl set-global ;
-
-: recompile-all ( -- )
- all-words compile ;
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays compiler.units kernel stack-checker
+sequences vocabs words tools.test tools.test.private ;
+IN: compiler.test
+
+: decompile ( word -- )
+ dup def>> 2array 1array modify-code-heap ;
+
+: recompile-all ( -- )
+ all-words compile ;
+
+: compile-call ( quot -- )
+ [ dup infer define-temp ] with-compilation-unit execute ;
+
+<< \ compile-call t "no-compile" set-word-prop >>
+
+: compiler-test ( name -- )
+ "resource:basis/compiler/tests/" ".factor" surround run-test-file ;
-USING: generalizations accessors arrays compiler kernel
+USING: generalizations accessors arrays compiler.test kernel
kernel.private math hashtables.private math.private namespaces
sequences tools.test namespaces.private slots.private
sequences.private byte-arrays alien alien.accessors layouts
USING: tools.test quotations math kernel sequences
-assocs namespaces make compiler.units compiler ;
+assocs namespaces make compiler.units compiler.test ;
IN: compiler.tests.curry
[ 3 ] [ 5 [ [ 2 - ] curry call ] compile-call ] unit-test
-USING: compiler.units compiler kernel kernel.private memory math
-math.private tools.test math.floats.private math.order fry ;
+USING: compiler.units compiler.test kernel kernel.private memory
+math math.private tools.test math.floats.private math.order fry
+;
IN: compiler.tests.float
[ 5.0 ] [ [ 5.0 ] compile-call gc gc gc ] unit-test
hashtables.private byte-arrays system random layouts vectors
sbufs strings.private slots.private alien math.order
alien.accessors alien.c-types alien.data alien.syntax alien.strings
-namespaces libc io.encodings.ascii classes compiler ;
+namespaces libc io.encodings.ascii classes compiler.test ;
FROM: math => float ;
IN: compiler.tests.intrinsics
quotations classes classes.algebra classes.tuple.private
continuations growable namespaces hints alien.accessors
compiler.tree.builder compiler.tree.optimizer sequences.deep
-compiler definitions generic.single shuffle math.order ;
+compiler.test definitions generic.single shuffle math.order ;
IN: compiler.tests.optimizer
GENERIC: xyz ( obj -- obj )
-USING: compiler compiler.units tools.test kernel kernel.private
+USING: compiler.test compiler.units tools.test kernel kernel.private
sequences.private math.private math combinators strings alien
arrays memory vocabs parser eval quotations compiler.errors
definitions ;
-USING: kernel tools.test compiler.units compiler ;
+USING: kernel tools.test compiler.units compiler.test ;
IN: compiler.tests.tuples
TUPLE: color red green blue ;
}
{ $description "Reset the LZW uncompressor state (either at initialization time or immediately after receiving a Clear Code). " } ;
-ARTICLE: "compression.lzw.differences" "LZW Differences between TIFF and GIF"
+ARTICLE: "compression.lzw.differences" "LZW differences between TIFF and GIF"
{ $vocab-link "compression.lzw" }
$nl
"There are some subtle differences between the LZW algorithm used by TIFF and GIF images."
"TIFF and GIF both add the concept of a 'Clear Code' and a 'End of Information Code' to the LZW algorithm. In both cases, the 'Clear Code' is equal to 2**(code-size - 1) and the 'End of Information Code' is equal to the Clear Code + 1. These 2 codes are reserved in the string table. So in both cases, the LZW string table is initialized to have a length equal to the End of Information Code + 1."
;
-ARTICLE: "compression.lzw" "LZW Compression"
+ARTICLE: "compression.lzw" "LZW compression"
{ $vocab-link "compression.lzw" }
$nl
"Implements both the TIFF and GIF variations of the LZW algorithm."
] (parallel-each) ; inline\r
\r
: parallel-filter ( seq quot -- newseq )\r
- over [ pusher [ parallel-each ] dip ] dip like ; inline\r
+ over [ selector [ parallel-each ] dip ] dip like ; inline\r
\r
<PRIVATE\r
\r
! Copyright (C) 2005, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel math namespaces make sequences
-system layouts alien alien.c-types alien.accessors slots
-splitting assocs combinators locals compiler.constants
+system layouts alien alien.c-types alien.accessors alien.libraries
+slots splitting assocs combinators locals compiler.constants
compiler.codegen compiler.codegen.fixup
compiler.cfg.instructions compiler.cfg.builder
compiler.cfg.intrinsics compiler.cfg.stack-frame
! this is the end of alien-callback
n [ n rep reg-class-of return-reg rep %save-param-reg ] when ;
-M: x86.64 %unbox-long-long ( n func -- )
- [ int-rep ] dip %unbox ;
-
: %unbox-struct-field ( c-type i -- )
! Alien must be in param-reg-0.
R11 swap cells [+] swap rep>> reg-class-of {
] [
rep load-return-value
] if
- rep int-rep? [ param-reg-1 ] [ param-reg-0 ] if %mov-vm-ptr
+ rep int-rep?
+ cpu x86.64? os windows? and or
+ param-reg-1 param-reg-0 ? %mov-vm-ptr
func f %alien-invoke ;
-M: x86.64 %box-long-long ( n func -- )
- [ int-rep ] dip %box ;
-
: box-struct-field@ ( i -- operand ) 1 + cells param@ ;
: %box-struct-field ( c-type i -- )
M:: x86.64 %unary-float-function ( dst src func -- )
0 src float-function-param
- func f %alien-invoke
+ func "libm" load-library %alien-invoke
dst float-function-return ;
M:: x86.64 %binary-float-function ( dst src1 src2 func -- )
! src2 is always a spill slot
0 src1 float-function-param
1 src2 float-function-param
- func f %alien-invoke
+ func "libm" load-library %alien-invoke
dst float-function-return ;
M:: x86.64 %call-gc ( gc-root-count temp -- )
M: x86.64 dummy-fp-params? t ;
-M: x86.64 temp-reg RAX ;
+M: x86.64 temp-reg R11 ;
3 cells +
align-stack ;
-! Must be a volatile register not used for parameter passing, for safe
-! use in calls in and out of C
+! Must be a volatile register not used for parameter passing or
+! integer return
HOOK: temp-reg cpu ( -- reg )
HOOK: pic-tail-reg cpu ( -- reg )
] if ; inline recursive
: query-map ( statement quot -- seq )
- accumulator [ query-each ] dip { } like ; inline
+ collector [ query-each ] dip { } like ; inline
: with-db ( db quot -- )
[ db-open db-connection ] dip
'[ obj>> @ ] dlist-each-node ; inline
: dlist>seq ( dlist -- seq )
- [ ] accumulator [ dlist-each ] dip ;
+ [ ] collector [ dlist-each ] dip ;
: 1dlist ( obj -- dlist ) <dlist> [ push-front ] keep ;
] if ; inline
: map-lines ( from to quot -- results )
- accumulator [ each-line ] dip ; inline
+ collector [ each-line ] dip ; inline
: start/end-on-line ( from to line# document -- n1 n2 )
[ start-on-line ] [ end-on-line ] bi-curry bi-curry bi* ;
USING: alien alien.c-types alien.data alien.strings
alien.syntax kernel layouts sequences system unix
environment io.encodings.utf8 unix.utilities vocabs.loader
-combinators alien.accessors ;
+combinators alien.accessors unix.ffi ;
IN: environment.unix
HOOK: environ os ( -- void* )
IN: eval
-USING: help.markup help.syntax strings io effects ;
+USING: help.markup help.syntax strings io effects parser
+listener vocabs.parser debugger combinators ;
+
+HELP: (eval)
+{ $values { "str" string } { "effect" effect } }
+{ $description "Parses Factor source code from a string, and calls the resulting quotation, which must have the given stack effect." }
+{ $notes "This word must be wrapped within " { $link with-file-vocabs } " or " { $link with-interactive-vocabs } ", since it assumes that the " { $link manifest } " variable is set in the current dynamic scope." }
+{ $errors "Throws an error if the input is malformed, or if the evaluation itself throws an error." } ;
HELP: eval
{ $values { "str" string } { "effect" effect } }
{ $description "Parses Factor source code from a string, and calls the resulting quotation, which must have the given stack effect." }
+{ $notes "The code string is parsed and called in a new dynamic scope with an initial vocabulary search path consisting of just the " { $snippet "syntax" } " vocabulary. The evaluated code can use " { $link "word-search-syntax" } " to alter the search path." }
{ $errors "Throws an error if the input is malformed, or if the evaluation itself throws an error." } ;
HELP: eval(
{ $syntax "eval( inputs -- outputs )" }
{ $description "Parses Factor source code from the string at the top of the stack, and calls the resulting quotation, which must have the given stack effect." }
+{ $notes
+ "This parsing word is just a slightly nicer syntax for " { $link eval } ". The following are equivalent:"
+ { $code
+ "eval( inputs -- outputs )"
+ "(( inputs -- outputs )) eval"
+ }
+}
{ $errors "Throws an error if the input is malformed, or if the evaluation itself throws an error." } ;
HELP: eval>string
{ $values { "str" string } { "output" string } }
-{ $description "Evaluates the Factor code in " { $snippet "str" } " with " { $link output-stream } " rebound to a string output stream, then outputs the resulting string. The code in the string must not take or leave any values on the stack." } ;
+{ $description "Evaluates the Factor code in " { $snippet "str" } " with " { $link output-stream } " rebound to a string output stream, then outputs the resulting string. The code in the string must not take or leave any values on the stack." }
+{ $errors "If the code throws an error, the error is caught, and the result of calling " { $link print-error } " on the error is returned." } ;
+
+ARTICLE: "eval-vocabs" "Evaluating strings with a different vocabulary search path"
+"Strings passed to " { $link eval } " are always evaluated with an initial vocabulary search path consisting of just the " { $snippet "syntax" } " vocabulary. This is the same search path that source files start out with. This behavior can be customized by taking advantage of the fact that " { $link eval } " is composed from two simpler words:"
+{ $subsections
+ (eval)
+ with-file-vocabs
+}
+"Code in the listener tool starts out with a different initial search path, with more vocabularies are available by default. Strings of code can be evaluated in this search path by using " { $link (eval) } " with a different combinator:"
+{ $subsections
+ with-interactive-vocabs
+}
+"When using " { $link (eval) } ", the quotation passed to " { $link with-file-vocabs } " and " { $link with-interactive-vocabs } " can also make specific vocabularies available to the evaluated string. This is done by having the quotation change the run-time vocabulary search path prior to calling " { $link (eval) } ". For run-time analogues of the parse-time " { $link "word-search-syntax" } " see " { $link "word-search-parsing" } "."
+$nl
+"The vocabulary set used by " { $link with-interactive-vocabs } " can be altered by rebinding a dynamic variable:"
+{ $subsections interactive-vocabs }
+{ $heading "Example" }
+"In this example, a string is evaluated with a fictional " { $snippet "cad.objects" } " vocabulary in the search path by default, together with the listener's " { $link interactive-vocabs } "; the quotation is expected to produce a sequence on the stack:"
+{ $code
+ """USING: eval listener vocabs.parser ;
+[
+ "cad-objects" use-vocab
+ (( -- seq )) (eval)
+] with-interactive-vocabs"""
+}
+"Note that the search path in the outer code (set by the " { $link POSTPONE: USING: } " form) has no relation to the search path used when parsing the string parameter (this is determined by " { $link with-interactive-vocabs } " and " { $link use-vocab } ")." ;
-ARTICLE: "eval" "Evaluating strings at runtime"
-"The " { $vocab-link "eval" } " vocabulary implements support for evaluating strings at runtime."
+ARTICLE: "eval" "Evaluating strings at run time"
+"The " { $vocab-link "eval" } " vocabulary implements support for evaluating strings of code dynamically."
+$nl
+"The main entry point is a parsing word, which wraps a library word:"
{ $subsections
POSTPONE: eval(
- eval>string
-} ;
+ eval
+}
+"This pairing is analogous to that of " { $link POSTPONE: call( } " with " { $link call-effect } "."
+$nl
+"Advanced features:"
+{ $subsections "eval-vocabs" eval>string }
+;
ABOUT: "eval"
-USING: accessors alien alien.c-types alien.strings arrays
-assocs byte-arrays combinators combinators.short-circuit
-continuations game.input game.input.dinput.keys-array
-io.encodings.utf16 io.encodings.utf16n kernel locals math
-math.bitwise math.rectangles namespaces parser sequences
-shuffle specialized-arrays ui.backend.windows vectors
-windows.com windows.directx.dinput
-windows.directx.dinput.constants .errors windows.kernel32
-windows.messages .ole32 windows.user32 classes.struct
-alien.data ;
+USING: accessors alien alien.c-types alien.strings arrays assocs
+byte-arrays combinators combinators.short-circuit continuations
+game.input game.input.dinput.keys-array io.encodings.utf16
+io.encodings.utf16n kernel locals math math.bitwise
+math.rectangles namespaces parser sequences shuffle
+specialized-arrays ui.backend.windows vectors windows.com
+windows.directx.dinput windows.directx.dinput.constants
+windows.kernel32 windows.messages windows.ole32 windows.errors
+windows.user32 classes.struct alien.data ;
SPECIALIZED-ARRAY: DIDEVICEOBJECTDATA
IN: game.input.dinput
} case ;
: fill-mouse-state ( buffer count -- state )
- [ +mouse-state+ get ] 2dip swap [ nth (fill-mouse-state) ] curry each ;
+ iota [ +mouse-state+ get ] 2dip swap [ nth (fill-mouse-state) ] curry each ;
: get-device-state ( device DIJOYSTATE2 -- )
[ dup IDirectInputDevice8W::Poll ole32-error ] dip
[ f ] [ [ 1.0 1 1 ] all-equal? ] unit-test
[ t ] [ { 1 2 3 4 } [ < ] monotonic? ] unit-test
[ f ] [ { 1 2 3 4 } [ > ] monotonic? ] unit-test
+
+[ { 6 7 8 3 4 5 0 1 2 } ] [ 9 iota >array dup 3 <groups> reverse! drop ] unit-test
: article-links ( topic elements -- seq )
[ article-content ] dip
- collect-elements [ >link ] map ;
+ collect-elements ;
: article-children ( topic -- seq )
- { $subsection $subsections } article-links ;
+ { $subsection $subsections } article-links [ >link ] map ;
: help-path ( topic -- seq )
[ article-parent ] follow rest ;
'[ _ vocab-help [ article drop ] when* ] check-something ;
: check-vocab ( vocab -- )
- "Checking " write dup write "..." print
+ "Checking " write dup write "..." print flush
[ check-about ]
[ words [ check-word ] each ]
[ vocab-articles get at [ check-article ] each ]
[ bitstream>> ]
[ [ [ <huffman-decoder> ] with map ] change-huff-tables drop ] bi
jpeg> components>> [ fetch-tables ] each
- [ decode-macroblock 2array ] accumulator
+ [ decode-macroblock 2array ] collector
[ all-macroblocks ] dip
jpeg> setup-bitmap draw-macroblocks
jpeg> bitmap>> 3 <groups> [ color-transform ] map! drop
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.syntax generic assocs kernel
kernel.private math io.ports sequences strings sbufs threads
-unix vectors io.buffers io.backend io.encodings math.parser
+unix unix.ffi vectors io.buffers io.backend io.encodings math.parser
continuations system libc namespaces make io.timeouts
io.encodings.utf8 destructors destructors.private accessors
summary combinators locals unix.time unix.types fry
: init-fd ( fd -- fd )
[
|dispose
- dup fd>> F_SETFL O_NONBLOCK fcntl io-error
- dup fd>> F_SETFD FD_CLOEXEC fcntl io-error
+ dup fd>> F_SETFL O_NONBLOCK [ fcntl ] unix-system-call drop
+ dup fd>> F_SETFD FD_CLOEXEC [ fcntl ] unix-system-call drop
] with-destructors ;
: <fd> ( n -- fd )
] if ;
M: unix tell-handle ( handle -- n )
- fd>> 0 SEEK_CUR lseek [ io-error ] [ ] bi ;
+ fd>> 0 SEEK_CUR [ lseek ] unix-system-call [ io-error ] [ ] bi ;
M: unix seek-handle ( n seek-type handle -- )
swap {
{ io:seek-end [ SEEK_END ] }
[ io:bad-seek-type ]
} case
- [ fd>> swap ] dip lseek io-error ;
+ [ fd>> swap ] dip [ lseek ] unix-system-call drop ;
SYMBOL: +retry+ ! just try the operation again without blocking
SYMBOL: +input+
setup-traversal iterate-directory-entries drop ; inline
: recursive-directory-files ( path bfs? -- paths )
- [ ] accumulator [ each-file ] dip ; inline
+ [ ] collector [ each-file ] dip ; inline
: recursive-directory-entries ( path bfs? -- directory-entries )
- [ ] accumulator [ each-directory-entry ] dip ; inline
+ [ ] collector [ each-directory-entry ] dip ; inline
: find-file ( path bfs? quot -- path/f )
[ <directory-iterator> ] dip
[ keep and ] curry iterate-directory ; inline
: find-all-files ( path quot -- paths/f )
- [ f <directory-iterator> ] dip pusher
+ [ f <directory-iterator> ] dip selector
[ [ f ] compose iterate-directory drop ] dip ; inline
ERROR: file-not-found path bfs? quot ;
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types io.directories.unix kernel system unix
-classes.struct ;
+classes.struct unix.ffi ;
IN: io.directories.unix.linux
M: unix find-next-file ( DIR* -- dirent )
dirent <struct>
f <void*>
- [ readdir64_r 0 = [ (io-error) ] unless ] 2keep
+ [ [ readdir64_r ] unix-system-call 0 = [ (io-error) ] unless ] 2keep
*void* [ drop f ] unless ;
continuations destructors fry io io.backend io.backend.unix
io.directories io.encodings.binary io.encodings.utf8 io.files
io.pathnames io.files.types kernel math.bitwise sequences system
-unix unix.stat vocabs.loader classes.struct ;
+unix unix.stat vocabs.loader classes.struct unix.ffi ;
IN: io.directories.unix
: touch-mode ( -- n )
] if ;
M: unix move-file ( from to -- )
- [ normalize-path ] bi@ rename io-error ;
+ [ normalize-path ] bi@ [ rename ] unix-system-call drop ;
M: unix delete-file ( path -- ) normalize-path unlink-file ;
M: unix make-directory ( path -- )
- normalize-path OCT: 777 mkdir io-error ;
+ normalize-path OCT: 777 [ mkdir ] unix-system-call drop ;
M: unix delete-directory ( path -- )
- normalize-path rmdir io-error ;
+ normalize-path [ rmdir ] unix-system-call drop ;
M: unix copy-file ( from to -- )
[ normalize-path ] bi@ call-next-method ;
HOOK: file-system-info os ( path -- file-system-info )
{
- { [ os unix? ] [ "io.files.info.unix." os name>> append ] }
+ { [ os unix? ] [ "io.files.info" ] }
{ [ os windows? ] [ "io.files.info.windows" ] }
} cond require
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel system math math.bitwise strings arrays
-sequences combinators combinators.short-circuit alien.c-types
-vocabs.loader calendar calendar.unix io.files.info
-io.files.types io.backend io.directories unix unix.stat
-unix.time unix.users unix.groups classes.struct
-specialized-arrays literals ;
-SPECIALIZED-ARRAY: timeval
+USING: accessors alien.c-types arrays calendar calendar.unix
+classes.struct combinators combinators.short-circuit io.backend
+io.directories io.files.info io.files.types kernel literals
+math math.bitwise sequences specialized-arrays strings system
+unix unix.ffi unix.groups unix.stat unix.time unix.users
+vocabs.loader ;
IN: io.files.info.unix
+SPECIALIZED-ARRAY: timeval
TUPLE: unix-file-system-info < file-system-info
block-size preferred-block-size
: chmod-set-bit ( path mask ? -- )
[ dup stat-mode ] 2dip
- [ bitor ] [ unmask ] if chmod io-error ;
+ [ bitor ] [ unmask ] if [ chmod ] unix-system-call drop ;
GENERIC# file-mode? 1 ( obj mask -- ? )
: set-other-execute ( path ? -- ) OTHER-EXECUTE swap chmod-set-bit ;
: set-file-permissions ( path n -- )
- [ normalize-path ] dip chmod io-error ;
+ [ normalize-path ] dip [ chmod ] unix-system-call drop ;
: file-permissions ( path -- n )
normalize-path file-info permissions>> ;
: set-file-times ( path timestamps -- )
#! set access, write
[ normalize-path ] dip
- timestamps>byte-array utimes io-error ;
+ timestamps>byte-array [ utimes ] unix-system-call drop ;
: set-file-access-time ( path timestamp -- )
f 2array set-file-times ;
f swap 2array set-file-times ;
: set-file-ids ( path uid gid -- )
- [ normalize-path ] 2dip [ -1 or ] bi@ chown io-error ;
+ [ normalize-path ] 2dip [ -1 or ] bi@
+ [ chown ] unix-system-call drop ;
GENERIC: set-file-user ( path string/id -- )
{ +regular-file+ [ file-type>executable ] }
[ drop file-type>executable ]
} case ;
+
+"io.files.info.unix." os name>> append require
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: io.backend io.files.links system unix io.pathnames kernel
-io.files sequences ;
+USING: io.backend io.files io.files.links io.pathnames kernel
+sequences system unix unix.ffi ;
IN: io.files.links.unix
M: unix make-link ( path1 path2 -- )
- normalize-path symlink io-error ;
+ normalize-path [ symlink ] unix-system-call drop ;
M: unix make-hard-link ( path1 path2 -- )
- normalize-path link io-error ;
+ normalize-path [ link ] unix-system-call drop ;
M: unix read-link ( path -- path' )
normalize-path read-symbolic-link ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel io.ports io.backend.unix math.bitwise
-unix system io.files.unique ;
+unix system io.files.unique unix.ffi ;
IN: io.files.unique.unix
: open-unique-flags ( -- flags )
! See http://factorcode.org/license.txt for BSD license.
USING: unix byte-arrays kernel io.backend.unix math.bitwise
io.ports io.files io.files.private io.pathnames environment
-destructors system ;
+destructors system unix.ffi ;
IN: io.files.unix
M: unix cwd ( -- path )
- MAXPATHLEN [ <byte-array> ] keep getcwd
+ MAXPATHLEN [ <byte-array> ] keep
+ [ getcwd ] unix-system-call
[ (io-error) ] unless* ;
M: unix cd ( path -- ) [ chdir ] unix-system-call drop ;
: open-append ( path -- fd )
[
append-flags file-mode open-file |dispose
- dup 0 SEEK_END lseek io-error
+ dup 0 SEEK_END [ lseek ] unix-system-call drop
] with-destructors ;
M: unix (file-appender) ( path -- stream )
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: system kernel namespaces strings hashtables sequences assocs
combinators vocabs.loader init threads continuations math accessors
"Launch descriptor:" print nl
process>> . ;
-: wait-for-process ( process -- status )
+: (wait-for-process) ( process -- status )
+ dup handle>>
[
- dup handle>>
- [
- dup [ processes get at push ] curry
- "process" suspend drop
- ] when
- dup killed>>
- [ process-was-killed ] [ status>> ] if
- ] with-timeout ;
+ dup [ processes get at push ] curry
+ "process" suspend drop
+ ] when
+ dup killed>>
+ [ process-was-killed ] [ status>> ] if ;
+
+: wait-for-process ( process -- status )
+ [ (wait-for-process) ] with-timeout ;
: run-detached ( desc -- process )
>process
+stdout+ >>stderr
[ +closed+ or ] change-stdin
utf8 <process-reader*>
- [ stream-contents ] [ dup wait-for-process ] bi*
+ [ [ stream-contents ] [ dup (wait-for-process) ] bi* ] with-timeout
0 = [ 2drop ] [ output-process-error ] if ;
: notify-exit ( process status -- )
io.files io.files.private io.files.unix io.launcher
io.launcher.unix.parser io.pathnames io.ports kernel math
namespaces sequences strings system threads unix
-unix.process ;
+unix.process unix.ffi ;
IN: io.launcher.unix
: get-arguments ( process -- seq )
[ f ] [ "notepad" get process-running? ] unit-test
+[
+ <process>
+ "notepad" >>command
+ 1/2 seconds >>timeout
+ try-process
+] must-fail
+
+[
+ <process>
+ "notepad" >>command
+ 1/2 seconds >>timeout
+ try-output-process
+] must-fail
+
: console-vm ( -- path )
vm ".exe" ?tail [ ".com" append ] when ;
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors destructors io.backend.unix io.mmap
-io.mmap.private kernel locals math.bitwise system unix ;
+io.mmap.private kernel locals math.bitwise system unix unix.ffi ;
IN: io.mmap.unix
:: mmap-open ( path length prot flags open-mode -- alien fd )
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types system kernel unix math sequences
-io.backend.unix io.ports specialized-arrays accessors ;
+io.backend.unix io.ports specialized-arrays accessors unix.ffi ;
QUALIFIED: io.pipes
SPECIALIZED-ARRAY: int
IN: io.pipes.unix
openssl.libcrypto openssl.libssl io io.files io.ports
io.backend.unix io.sockets.unix io.encodings.ascii io.buffers
io.sockets io.sockets.private io.sockets.secure
-io.sockets.secure.openssl io.timeouts system summary fry ;
+io.sockets.secure.openssl io.timeouts system summary fry
+unix.ffi ;
FROM: io.ports => shutdown ;
IN: io.sockets.secure.unix
[ "1:2:0:0:0:0:3:4" ]
[ B{ 0 1 0 2 0 0 0 0 0 0 0 0 0 3 0 4 } T{ inet6 } inet-ntop ] unit-test
+[ B{ 0 0 0 0 0 0 0 0 0 127 0 0 0 0 0 1 } ]
+[ "::127.0.0.1" T{ inet6 } inet-pton ] unit-test
+
+[ B{ 0 2 0 0 0 0 0 9 0 127 0 0 0 0 0 1 } ]
+[ "2::9:127.0.0.1" T{ inet6 } inet-pton ] unit-test
+
[ "2001:6f8:37a:5:0:0:0:1" ]
[ "2001:6f8:37a:5::1" T{ inet6 } [ inet-pton ] [ inet-ntop ] bi ] unit-test
<< {
{ [ os windows? ] [ "windows.winsock" ] }
- { [ os unix? ] [ "unix" ] }
+ { [ os unix? ] [ "unix.ffi" ] }
} cond use-vocab >>
! Addressing
M: inet4 inet-ntop ( data addrspec -- str )
drop 4 memory>byte-array [ number>string ] { } map-as "." join ;
+ERROR: malformed-inet4 sequence ;
+ERROR: bad-inet4-component string ;
+
+: parse-inet4 ( string -- seq )
+ "." split dup length 4 = [
+ malformed-inet4
+ ] unless
+ [
+ string>number
+ [ "Dotted component not a number" throw ] unless*
+ ] B{ } map-as ;
+
ERROR: invalid-inet4 string reason ;
M: invalid-inet4 summary drop "Invalid IPv4 address" ;
M: inet4 inet-pton ( str addrspec -- data )
drop
- [
- "." split dup length 4 = [
- "Must have four components" throw
- ] unless
- [
- string>number
- [ "Dotted component not a number" throw ] unless*
- ] B{ } map-as
- ] [ invalid-inet4 ] recover ;
+ [ parse-inet4 ] [ invalid-inet4 ] recover ;
M: inet4 address-size drop 4 ;
<PRIVATE
+ERROR: bad-ipv6-component obj ;
+
+ERROR: bad-ipv4-embedded-prefix obj ;
+
+: parse-ipv6-component ( seq -- seq' )
+ [ dup hex> [ nip ] [ bad-ipv6-component ] if* ] { } map-as ;
+
: parse-inet6 ( string -- seq )
[ f ] [
- ":" split [
- hex> [ "Component not a number" throw ] unless*
- ] { } map-as
+ ":" split CHAR: . over last member? [
+ unclip-last
+ [ parse-ipv6-component ] [ parse-inet4 ] bi* append
+ ] [
+ parse-ipv6-component
+ ] if
] if-empty ;
: pad-inet6 ( string1 string2 -- seq )
io.streams.duplex io.backend io.pathnames io.sockets.private
io.files.private io.encodings.utf8 math.parser continuations
libc combinators system accessors destructors unix locals init
-classes.struct alien.data ;
+classes.struct alien.data unix.ffi ;
EXCLUDE: namespaces => bind ;
EXCLUDE: io => read write ;
[ (io-error) ]
} cond ;
-M: object establish-connection ( client-out remote -- )
- [ drop ] [ [ handle>> handle-fd ] [ make-sockaddr/size ] bi* connect ] 2bi
+M:: object establish-connection ( client-out remote -- )
+ client-out remote
+ [ drop ]
+ [
+ [ handle>> handle-fd ] [ make-sockaddr/size ] bi* connect
+ ] 2bi
{
{ [ 0 = ] [ drop ] }
+ { [ errno EINTR = ] [ drop client-out remote establish-connection ] }
{ [ errno EINPROGRESS = ] [
[ +output+ wait-for-port ] [ wait-to-connect ] bi
] }
} cond ;
: ?bind-client ( socket -- )
- bind-local-address get [ [ fd>> ] dip make-sockaddr/size bind io-error ] [ drop ] if* ; inline
+ bind-local-address get [
+ [ fd>> ] dip make-sockaddr/size
+ [ bind ] unix-system-call drop
+ ] [
+ drop
+ ] if* ; inline
M: object ((client)) ( addrspec -- fd )
protocol-family SOCK_STREAM socket-fd
: server-socket-fd ( addrspec type -- fd )
[ dup protocol-family ] dip socket-fd
[ init-server-socket ] keep
- [ handle-fd swap make-sockaddr/size bind io-error ] keep ;
+ [ handle-fd swap make-sockaddr/size [ bind ] unix-system-call drop ] keep ;
M: object (server) ( addrspec -- handle )
[
SOCK_STREAM server-socket-fd
- dup handle-fd 128 listen io-error
+ dup handle-fd 128 [ listen ] unix-system-call drop
] with-destructors ;
: do-accept ( server addrspec -- fd sockaddr )
-USING: help.markup help.syntax kernel io system prettyprint continuations ;
+USING: help.markup help.syntax kernel io system prettyprint continuations quotations ;
IN: listener
ARTICLE: "listener-watch" "Watching variables in the listener"
{ $values { "vocabs" "a sequence of vocabulary specifiers" } }
{ $description "Replaces the current manifest's vocabulary search path with the given set of vocabularies." } ;
+HELP: with-interactive-vocabs
+{ $values { "quot" quotation } }
+{ $description "Calls the quotation in a scope with an initial vocabulary search path consisting of all vocabularies from " { $link interactive-vocabs } ", and with the current vocabulary for new definitions set to " { $vocab-link "scratchpad" } "." }
+{ $notes "This is the same initial search path as used by the " { $link "listener" } " tool." } ;
+
HELP: show-var
{ $values { "var" "a variable name" } }
{ $description "Adds a variable to the watch list; its value will be printed by the listener after every expression." } ;
<reversed> nil [ swons ] reduce ;
: lmap>array ( list quot -- array )
- accumulator [ leach ] dip { } like ; inline
+ collector [ leach ] dip { } like ; inline
: list>array ( list -- array )
[ ] lmap>array ;
HELP: [|
{ $syntax "[| bindings... | body... ]" }
-{ $description "A literal quotation with named variable bindings. When the quotation is " { $link call } "ed, it will take values off the datastack values and place them into the bindings from left to right. The body may then refer to these bindings. The quotation may also bind to named variables in an enclosing scope to create a closure." }
+{ $description "A literal quotation with named variable bindings. When the quotation is " { $link call } "ed, it will take values off the datastack and place them into the bindings from left to right. The body may then refer to these bindings. The quotation may also bind to named variables in an enclosing scope to create a closure." }
{ $examples "See " { $link "locals-examples" } "." } ;
HELP: [let
{ $code ":> c :> b :> a" }
{ $code ":> ( a b c )" }
$nl
-"If any " { $snippet "var" } " name is followed by an exclamation point (" { $snippet "!" } "), that new variable is mutable. See " { $link "locals-mutable" } " for more information on mutable lexical variables." }
+"If any " { $snippet "var" } " name is followed by an exclamation point (" { $snippet "!" } "), that new variable is mutable. See " { $link "locals-mutable" } " for more information." }
{ $notes
"This syntax can only be used inside a lexical scope established by a " { $link POSTPONE: :: } " definition, " { $link POSTPONE: [let } " form, or " { $link POSTPONE: [| } " quotation. Normal quotations have their own lexical scope only if they are inside an outer scope. Definition forms such as " { $link POSTPONE: : } " do not establish a lexical scope by themselves unless documented otherwise, nor is there a lexical scope available at the top level of source files or in the listener. " { $link POSTPONE: [let } " can be used to create a lexical scope where one is not otherwise available." }
{ $examples "See " { $link "locals-examples" } "." } ;
{ $syntax ":: word ( vars... -- outputs... ) body... ;" }
{ $description "Defines a word with named inputs. The word binds its input values to lexical variables from left to right, then executes the body with those bindings in scope."
$nl
-"If any " { $snippet "var" } " name is followed by an exclamation point (" { $snippet "!" } "), the corresponding new variable is made mutable. See " { $link "locals-mutable" } " for more information on mutable lexical variables." }
+"If any " { $snippet "var" } " name is followed by an exclamation point (" { $snippet "!" } "), the corresponding new variable is made mutable. See " { $link "locals-mutable" } " for more information." }
{ $notes "The names of the " { $snippet "outputs" } " do not affect the word's behavior. However, the compiler verifies that the stack effect accurately represents the number of outputs as with " { $link POSTPONE: : } " definitions." }
{ $examples "See " { $link "locals-examples" } "." } ;
{ $syntax "MACRO:: word ( vars... -- outputs... ) body... ;" }
{ $description "Defines a macro with named inputs. The macro binds its input variables to lexical variables from left to right, then executes the body with those bindings in scope."
$nl
-"If any " { $snippet "var" } " name is followed by an exclamation point (" { $snippet "!" } "), the corresponding new variable is made mutable. See " { $link "locals-mutable" } " for more information on mutable lexical variables." }
+"If any " { $snippet "var" } " name is followed by an exclamation point (" { $snippet "!" } "), the corresponding new variable is made mutable. See " { $link "locals-mutable" } " for more information." }
{ $notes "The expansion of a macro cannot reference lexical variables bound in the outer scope. There are also limitations on passing arguments involving lexical variables into macros. See " { $link "locals-limitations" } " for details." }
{ $examples "See " { $link "locals-examples" } "." } ;
{ $syntax "MEMO:: word ( vars... -- outputs... ) body... ;" }
{ $description "Defines a memoized word with named inputs. The word binds its input values to lexical variables from left to right, then executes the body with those bindings in scope."
$nl
-"If any " { $snippet "var" } " name is followed by an exclamation point (" { $snippet "!" } "), the corresponding new variable is made mutable. See " { $link "locals-mutable" } " for more information on mutable lexical variables." }
+"If any " { $snippet "var" } " name is followed by an exclamation point (" { $snippet "!" } "), the corresponding new variable is made mutable. See " { $link "locals-mutable" } " for more information." }
{ $examples "See " { $link "locals-examples" } "." } ;
{ POSTPONE: MEMO: POSTPONE: MEMO:: } related-words
{ $syntax "M:: class generic ( vars... -- outputs... ) body... ;" }
{ $description "Defines a new method on " { $snippet "generic" } " for " { $snippet "class" } " with named inputs. The method binds its input values to lexical variables from left to right, then executes the body with those bindings in scope."
$nl
-"If any " { $snippet "var" } " name is followed by an exclamation point (" { $snippet "!" } "), the corresponding new variable is made mutable. See " { $link "locals-mutable" } " for more information on mutable lexical variables." }
+"If any " { $snippet "var" } " name is followed by an exclamation point (" { $snippet "!" } "), the corresponding new variable is made mutable. See " { $link "locals-mutable" } " for more information." }
{ $notes "The names of the " { $snippet "outputs" } " do not affect the word's behavior. However, the compiler verifies that the stack effect accurately represents the number of outputs as with " { $link POSTPONE: M: } " definitions." }
{ $examples "See " { $link "locals-examples" } "." } ;
ARTICLE: "locals-mutable" "Mutable lexical variables"
"When a lexical variable is bound using " { $link POSTPONE: :> } ", " { $link POSTPONE: :: } ", or " { $link POSTPONE: [| } ", the variable may be made mutable by suffixing its name with an exclamation point (" { $snippet "!" } "). A mutable variable's value is read by giving its name without the exclamation point as usual. To write to the variable, use its name with the " { $snippet "!" } " suffix."
$nl
-"Mutable bindings are implemented in a manner similar to the ML language; each mutable binding is actually an immutable binding of a mutable cell. Reading the binding automatically unboxes the value from the cell, and writing to the binding stores into it."
+"Mutable bindings are implemented in a manner similar to that taken by the ML language. Each mutable binding is actually an immutable binding of a mutable cell. Reading the binding automatically unboxes the value from the cell, and writing to the binding stores into it."
$nl
"Writing to mutable variables from outer lexical scopes is fully supported and has full closure semantics. See " { $link "locals-examples" } " for examples of mutable lexical variables in action." ;
{
{ [ os macosx? ] [ intel-unix-abi ] }
{ [ os windows? cpu x86.32? and ] [ f2c-abi ] }
- { [ os netbsd? cpu x86.64? and ] [ g95-abi ] }
{ [ os windows? cpu x86.64? and ] [ gfortran-abi ] }
{ [ os freebsd? ] [ gfortran-abi ] }
{ [ os linux? ] [ gfortran-abi ] }
USING: kernel math math.floats.env math.floats.env.private
math.functions math.libm sequences tools.test locals
-compiler.units kernel.private fry compiler math.private words
-system ;
+compiler.units kernel.private fry compiler.test math.private
+words system ;
IN: math.floats.env.tests
: set-default-fp-env ( -- )
! (c)Joe Groff bsd license
-USING: accessors arrays compiler continuations generalizations
+USING: accessors arrays compiler.test continuations generalizations
kernel kernel.private locals math.vectors.conversion math.vectors.simd
sequences stack-checker tools.test ;
FROM: alien.c-types => char uchar short ushort int uint longlong ulonglong float double ;
-USING: accessors arrays classes compiler compiler.tree.debugger
+USING: accessors arrays classes compiler.test compiler.tree.debugger
effects fry io kernel kernel.private math math.functions
math.private math.vectors math.vectors.simd
math.vectors.simd.private prettyprint random sequences system
{ "effect" "an effect" }
{ "style" "a style assoc" }
}
-{ $description "The styling hook for stack effects" } ;
+{ $description "The stylesheet for stack effects" } ;
HELP: string-style
{ $values
{ "str" "a string" }
{ "style" "a style assoc" }
}
-{ $description "The styling hook for string literals" } ;
+{ $description "The stylesheet for string literals" } ;
HELP: vocab-style
{ $values
{ "vocab" "a vocabulary specifier" }
{ "style" "a style assoc" }
}
-{ $description "The styling hook for vocab names" } ;
+{ $description "The stylesheet for vocab names" } ;
HELP: word-style
{ $values
{ "word" "a word" }
{ "style" "a style assoc" }
}
-{ $description "The styling hook for word names" } ;
+{ $description "The stylesheet for word names" } ;
-ARTICLE: "prettyprint.stylesheet" "Prettyprinter Formatted Output"
-{ $vocab-link "prettyprint.stylesheet" }
-$nl
-"Control the way that the prettyprinter formats output based on object type. These hooks form a basic \"syntax\" highlighting system."
+ARTICLE: "prettyprint.stylesheet" "Prettyprinter stylesheet"
+"The " { $vocab-link "prettyprint.stylesheet" } " vocabulary defines variables which control the way that the prettyprinter formats output based on object type."
{ $subsections
word-style
string-style
[ prepare-match-iterator ] dip (each-match) ; inline
: map-matches ( string regexp quot: ( start end string -- obj ) -- seq )
- accumulator [ each-match ] dip >array ; inline
+ collector [ each-match ] dip >array ; inline
: all-matching-slices ( string regexp -- seq )
[ slice boa ] map-matches ;
[ '[ _ deep-map ] map ] [ drop ] if ; inline recursive
: deep-filter ( obj quot: ( elt -- ? ) -- seq )
- over [ pusher [ deep-each ] dip ] dip
+ over [ selector [ deep-each ] dip ] dip
dup branch? [ like ] [ drop ] if ; inline recursive
: (deep-find) ( obj quot: ( elt -- ? ) -- elt ? )
: mnmap ( m*seq quot m n -- result*n )
2dup '[ [ _ npick ] dip swap _ dupn ] 2dip mnmap-as ; inline
-: naccumulator-for ( quot ...exemplar n -- quot' vec... )
+: ncollector-for ( quot ...exemplar n -- quot' vec... )
5 dupn '[
[ [ length ] keep new-resizable ] _ napply
[ [ [ push ] _ apply-curry _ spread* ] _ ncurry compose ] _ nkeep
] call ; inline
-: naccumulator ( quot n -- quot' vec... )
- [ V{ } swap dupn ] keep naccumulator-for ; inline
+: ncollector ( quot n -- quot' vec... )
+ [ V{ } swap dupn ] keep ncollector-for ; inline
: nproduce-as ( pred quot ...exemplar n -- seq... )
7 dupn '[
_ ndup
- [ _ naccumulator-for [ while ] _ ndip ]
+ [ _ ncollector-for [ while ] _ ndip ]
_ ncurry _ ndip
[ like ] _ apply-curry _ spread*
] call ; inline
kernel arrays combinators compiler compiler.units classes.struct
combinators.smart compiler.tree.debugger math libc destructors
sequences.private multiline eval words vocabs namespaces
-assocs prettyprint alien.data math.vectors definitions ;
+assocs prettyprint alien.data math.vectors definitions
+compiler.test ;
FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: int
V A <A> vectors.functor:define-vector
-M: V contract 2drop ;
+M: V contract 2drop ; inline
-M: V byte-length underlying>> byte-length ;
+M: V byte-length underlying>> byte-length ; inline
M: V pprint-delims drop \ V{ \ } ;
\ compact-gc { } { } define-primitive
-\ (save-image) { byte-array } { } define-primitive
+\ (save-image) { byte-array byte-array } { } define-primitive
-\ (save-image-and-exit) { byte-array } { } define-primitive
+\ (save-image-and-exit) { byte-array byte-array } { } define-primitive
\ data-room { } { byte-array } define-primitive
\ data-room make-flushable
-! Copyright (C) 2005, 2009 Slava Pestov.
+! Copyright (C) 2005, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: words assocs definitions io io.pathnames io.styles kernel
-prettyprint sorting see sets sequences arrays hashtables help.crossref
-help.topics help.markup quotations accessors source-files namespaces
-graphs vocabs generic generic.single threads compiler.units init ;
+prettyprint sorting see sets sequences arrays hashtables help
+help.crossref help.topics help.markup quotations accessors
+source-files namespaces graphs vocabs generic generic.single
+threads compiler.units init combinators.smart ;
IN: tools.crossref
SYMBOL: crossref
M: word uses def>> uses ;
-M: link uses { $subsection $subsections $link $see-also } article-links ;
+M: link uses
+ [ { $subsection $subsections $link $see-also } article-links [ >link ] map ]
+ [ { $vocab-link } article-links [ >vocab-link ] map ]
+ bi append ;
M: pathname uses string>> source-file top-level-form>> [ uses ] [ { } ] if* ;
+! To make UI browser happy
+M: vocab uses drop f ;
+
GENERIC: crossref-def ( defspec -- )
M: object crossref-def
M: word crossref-def
[ call-next-method ] [ subwords [ crossref-def ] each ] bi ;
-: build-crossref ( -- crossref )
- "Computing usage index... " write flush yield
- H{ } clone crossref [
+: defs-to-crossref ( -- seq )
+ [
all-words
+ all-articles [ >link ] map
source-files get keys [ <pathname> ] map
- [ [ crossref-def ] each ] bi@
- crossref get
- ] with-variable
+ ] append-outputs ;
+
+: build-crossref ( -- crossref )
+ "Computing usage index... " write flush yield
+ H{ } clone [
+ crossref set-global
+ defs-to-crossref [ crossref-def ] each
+ ] keep
"done" print flush ;
: get-crossref ( -- crossref )
- crossref global [ drop build-crossref ] cache ;
+ crossref get-global [ build-crossref ] unless* ;
GENERIC: irrelevant? ( defspec -- ? )
[
strip-debugger? [
"debugger" require
+ "tools.errors" require
"inspector" require
deploy-ui? get [
"ui.debugger" require
USING: accessors tools.profiler tools.test kernel memory math
threads alien alien.c-types tools.profiler.private sequences
-compiler compiler.units words ;
+compiler.test compiler.units words ;
IN: tools.profiler.tests
[ t ] [
IN: tools.time.tests
-USING: tools.time tools.test compiler ;
+USING: tools.time tools.test compiler.test ;
[ ] [ [ [ ] time ] compile-call ] unit-test
-! Copyright (C) 2005, 2009 Slava Pestov.
+! Copyright (C) 2005, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays hashtables kernel math namespaces
make sequences quotations math.vectors combinators sorting
<PRIVATE
-: ((fast-children-on)) ( gadget dim axis -- <=> )
- [ swap loc>> v- ] dip v. 0 <=> ;
-
-:: (fast-children-on) ( dim axis children -- i )
- children [ dim axis ((fast-children-on)) ] search drop ;
+:: (fast-children-on) ( point axis children quot -- i )
+ children [
+ [ point ] dip
+ quot call( value -- loc ) v-
+ axis v. 0 <=>
+ ] search drop ; inline
PRIVATE>
-: fast-children-on ( rect axis children -- from to )
- [ [ loc>> ] 2dip (fast-children-on) 0 or ]
- [ [ rect-bounds v+ ] 2dip (fast-children-on) ?1+ ]
- 3bi ;
+:: fast-children-on ( rect axis children quot -- slice )
+ rect loc>> axis children quot (fast-children-on) 0 or
+ rect rect-bounds v+ axis children quot (fast-children-on) ?1+
+ children <slice> ; inline
M: gadget contains-rect? ( bounds gadget -- ? )
dup visible?>> [ call-next-method ] [ 2drop f ] if ;
USING: ui.gadgets ui.gadgets.grids tools.test kernel arrays
namespaces math.rectangles accessors ui.gadgets.grids.private
-ui.gadgets.debug sequences ;
+ui.gadgets.debug sequences classes ;
IN: ui.gadgets.grids.tests
[ { 0 0 } ] [ { } <grid> pref-dim ] unit-test
: 100x100 ( -- gadget ) <gadget> { 100 100 } >>dim ;
+: 200x200 ( -- gadget ) <gadget> { 200 200 } >>dim ;
+
[ { 100 100 } ] [
100x100
1array 1array <grid> pref-dim
"g" get
dup layout
children>> [ loc>> ] map
-] unit-test
\ No newline at end of file
+] unit-test
+
+! children-on logic was insufficient
+[ ] [
+ 100x100 dup "a" set 200x200 2array
+ 100x100 dup "b" set 200x200 2array 2array <grid> f >>fill? "g" set
+] unit-test
+
+[ ] [ "g" get prefer ] unit-test
+[ ] [ "g" get layout ] unit-test
+
+[ { 0 50 } ] [ "a" get loc>> ] unit-test
+[ { 0 250 } ] [ "b" get loc>> ] unit-test
+
+[ gadget { 200 200 } ]
+[ { 120 20 } "g" get pick-up [ class ] [ dim>> ] bi ] unit-test
+
+[ gadget { 200 200 } ]
+[ { 120 220 } "g" get pick-up [ class ] [ dim>> ] bi ] unit-test
\ No newline at end of file
-! Copyright (C) 2006, 2009 Slava Pestov.
+! Copyright (C) 2006, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel math math.order math.matrices namespaces make sequences words io
-math.vectors ui.gadgets ui.baseline-alignment columns accessors strings.tables
+USING: arrays kernel math math.order math.matrices namespaces
+make sequences words io math.vectors ui.gadgets
+ui.baseline-alignment columns accessors strings.tables
math.rectangles fry ;
IN: ui.gadgets.grids
M: grid children-on ( rect gadget -- seq )
dup children>> empty? [ 2drop f ] [
- [ { 0 1 } ] dip grid>>
- [ 0 <column> fast-children-on ] [ <slice> concat ] bi
+ [ { 0 1 } ] dip
+ [ grid>> ] [ dim>> ] bi
+ '[ _ [ loc>> vmin ] reduce ] fast-children-on
+ concat
] if ;
M: grid gadget-text*
-! Copyright (C) 2005, 2009 Slava Pestov.
+! Copyright (C) 2005, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: sequences ui.gadgets ui.baseline-alignment
ui.baseline-alignment.private kernel math math.functions math.vectors
dup children>> pref-dims pack-layout ;
M: pack children-on ( rect gadget -- seq )
- [ orientation>> ] [ children>> ] bi
- [ fast-children-on ] keep <slice> ;
+ [ orientation>> ] [ children>> ] bi [ loc>> ] fast-children-on ;
-! Copyright (C) 2005, 2009 Slava Pestov.
+! Copyright (C) 2005, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays hashtables io kernel namespaces sequences
strings quotations math opengl combinators memoize math.vectors
GENERIC: sloppy-pick-up* ( loc gadget -- n )
M: pack sloppy-pick-up* ( loc gadget -- n )
- [ orientation>> ] [ children>> ] bi (fast-children-on) ;
+ [ orientation>> ] [ children>> ] bi
+ [ loc>> ] (fast-children-on) ;
M: gadget sloppy-pick-up*
children>> [ contains-point? ] with find-last drop ;
lt? [ lithuanian>upper ] when
[ title>> ] [ ch>title ] map-case ; inline
-: title-word ( string -- title )
- unclip 1string [ >lower ] [ (>title) ] bi* prepend ; inline
-
PRIVATE>
+: capitalize ( string -- title )
+ unclip 1string [ >lower ] [ (>title) ] bi* prepend ; inline
+
: >title ( string -- title )
- final-sigma >words [ title-word ] map concat ;
+ final-sigma >words [ capitalize ] map concat ;
HINTS: >title string ;
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2005, 2006 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types alien.syntax classes.struct combinators
-system unix.types vocabs.loader ;
-IN: unix
-
-CONSTANT: MAXPATHLEN 1024
-
-CONSTANT: O_RDONLY HEX: 0000
-CONSTANT: O_WRONLY HEX: 0001
-CONSTANT: O_RDWR HEX: 0002
-CONSTANT: O_NONBLOCK HEX: 0004
-CONSTANT: O_APPEND HEX: 0008
-CONSTANT: O_CREAT HEX: 0200
-CONSTANT: O_TRUNC HEX: 0400
-CONSTANT: O_EXCL HEX: 0800
-CONSTANT: O_NOCTTY HEX: 20000
-ALIAS: O_NDELAY O_NONBLOCK
-
-CONSTANT: SOL_SOCKET HEX: ffff
-CONSTANT: SO_REUSEADDR HEX: 4
-CONSTANT: SO_OOBINLINE HEX: 100
-CONSTANT: SO_SNDTIMEO HEX: 1005
-CONSTANT: SO_RCVTIMEO HEX: 1006
-
-CONSTANT: F_SETFD 2
-CONSTANT: F_SETFL 4
-CONSTANT: FD_CLOEXEC 1
-
-STRUCT: sockaddr-in
- { len uchar }
- { family uchar }
- { port ushort }
- { addr in_addr_t }
- { unused longlong } ;
-
-STRUCT: sockaddr-in6
- { len uchar }
- { family uchar }
- { port ushort }
- { flowinfo uint }
- { addr uchar[16] }
- { scopeid uint } ;
-
-STRUCT: sockaddr-un
- { len uchar }
- { family uchar }
- { path char[104] } ;
-
-STRUCT: passwd
- { pw_name char* }
- { pw_passwd char* }
- { pw_uid uid_t }
- { pw_gid gid_t }
- { pw_change time_t }
- { pw_class char* }
- { pw_gecos char* }
- { pw_dir char* }
- { pw_shell char* }
- { pw_expire time_t }
- { pw_fields int } ;
-
-CONSTANT: max-un-path 104
-
-CONSTANT: SOCK_STREAM 1
-CONSTANT: SOCK_DGRAM 2
-
-CONSTANT: AF_UNSPEC 0
-CONSTANT: AF_UNIX 1
-CONSTANT: AF_INET 2
-CONSTANT: AF_INET6 30
-
-ALIAS: PF_UNSPEC AF_UNSPEC
-ALIAS: PF_UNIX AF_UNIX
-ALIAS: PF_INET AF_INET
-ALIAS: PF_INET6 AF_INET6
-
-CONSTANT: IPPROTO_TCP 6
-CONSTANT: IPPROTO_UDP 17
-
-CONSTANT: AI_PASSIVE 1
-
-CONSTANT: SEEK_SET 0
-CONSTANT: SEEK_CUR 1
-CONSTANT: SEEK_END 2
-
-os {
- { macosx [ "unix.bsd.macosx" require ] }
- { freebsd [ "unix.bsd.freebsd" require ] }
- { openbsd [ "unix.bsd.openbsd" require ] }
- { netbsd [ "unix.bsd.netbsd" require ] }
-} case
+++ /dev/null
-USING: alien.c-types alien.syntax classes.struct unix.types ;
-IN: unix
-
-CONSTANT: FD_SETSIZE 1024
-
-STRUCT: addrinfo
- { flags int }
- { family int }
- { socktype int }
- { protocol int }
- { addrlen socklen_t }
- { canonname char* }
- { addr void* }
- { next addrinfo* } ;
-
-STRUCT: dirent
- { d_fileno u_int32_t }
- { d_reclen u_int16_t }
- { d_type u_int8_t }
- { d_namlen u_int8_t }
- { d_name char[256] } ;
-
-CONSTANT: EPERM 1
-CONSTANT: ENOENT 2
-CONSTANT: ESRCH 3
-CONSTANT: EINTR 4
-CONSTANT: EIO 5
-CONSTANT: ENXIO 6
-CONSTANT: E2BIG 7
-CONSTANT: ENOEXEC 8
-CONSTANT: EBADF 9
-CONSTANT: ECHILD 10
-CONSTANT: EDEADLK 11
-CONSTANT: ENOMEM 12
-CONSTANT: EACCES 13
-CONSTANT: EFAULT 14
-CONSTANT: ENOTBLK 15
-CONSTANT: EBUSY 16
-CONSTANT: EEXIST 17
-CONSTANT: EXDEV 18
-CONSTANT: ENODEV 19
-CONSTANT: ENOTDIR 20
-CONSTANT: EISDIR 21
-CONSTANT: EINVAL 22
-CONSTANT: ENFILE 23
-CONSTANT: EMFILE 24
-CONSTANT: ENOTTY 25
-CONSTANT: ETXTBSY 26
-CONSTANT: EFBIG 27
-CONSTANT: ENOSPC 28
-CONSTANT: ESPIPE 29
-CONSTANT: EROFS 30
-CONSTANT: EMLINK 31
-CONSTANT: EPIPE 32
-CONSTANT: EDOM 33
-CONSTANT: ERANGE 34
-CONSTANT: EAGAIN 35
-ALIAS: EWOULDBLOCK EAGAIN
-CONSTANT: EINPROGRESS 36
-CONSTANT: EALREADY 37
-CONSTANT: ENOTSOCK 38
-CONSTANT: EDESTADDRREQ 39
-CONSTANT: EMSGSIZE 40
-CONSTANT: EPROTOTYPE 41
-CONSTANT: ENOPROTOOPT 42
-CONSTANT: EPROTONOSUPPORT 43
-CONSTANT: ESOCKTNOSUPPORT 44
-CONSTANT: EOPNOTSUPP 45
-ALIAS: ENOTSUP EOPNOTSUPP
-CONSTANT: EPFNOSUPPORT 46
-CONSTANT: EAFNOSUPPORT 47
-CONSTANT: EADDRINUSE 48
-CONSTANT: EADDRNOTAVAIL 49
-CONSTANT: ENETDOWN 50
-CONSTANT: ENETUNREACH 51
-CONSTANT: ENETRESET 52
-CONSTANT: ECONNABORTED 53
-CONSTANT: ECONNRESET 54
-CONSTANT: ENOBUFS 55
-CONSTANT: EISCONN 56
-CONSTANT: ENOTCONN 57
-CONSTANT: ESHUTDOWN 58
-CONSTANT: ETOOMANYREFS 59
-CONSTANT: ETIMEDOUT 60
-CONSTANT: ECONNREFUSED 61
-CONSTANT: ELOOP 62
-CONSTANT: ENAMETOOLONG 63
-CONSTANT: EHOSTDOWN 64
-CONSTANT: EHOSTUNREACH 65
-CONSTANT: ENOTEMPTY 66
-CONSTANT: EPROCLIM 67
-CONSTANT: EUSERS 68
-CONSTANT: EDQUOT 69
-CONSTANT: ESTALE 70
-CONSTANT: EREMOTE 71
-CONSTANT: EBADRPC 72
-CONSTANT: ERPCMISMATCH 73
-CONSTANT: EPROGUNAVAIL 74
-CONSTANT: EPROGMISMATCH 75
-CONSTANT: EPROCUNAVAIL 76
-CONSTANT: ENOLCK 77
-CONSTANT: ENOSYS 78
-CONSTANT: EFTYPE 79
-CONSTANT: EAUTH 80
-CONSTANT: ENEEDAUTH 81
-CONSTANT: EIDRM 82
-CONSTANT: ENOMSG 83
-CONSTANT: EOVERFLOW 84
-CONSTANT: ECANCELED 85
-CONSTANT: EILSEQ 86
-CONSTANT: ENOATTR 87
-CONSTANT: EDOOFUS 88
-CONSTANT: EBADMSG 89
-CONSTANT: EMULTIHOP 90
-CONSTANT: ENOLINK 91
-CONSTANT: EPROTO 92
+++ /dev/null
-unportable
+++ /dev/null
-USING: alien.c-types alien.syntax unix.time unix.types
-unix.types.macosx classes.struct ;
-IN: unix
-
-CONSTANT: FD_SETSIZE 1024
-
-STRUCT: addrinfo
- { flags int }
- { family int }
- { socktype int }
- { protocol int }
- { addrlen socklen_t }
- { canonname char* }
- { addr void* }
- { next addrinfo* } ;
-
-CONSTANT: _UTX_USERSIZE 256
-CONSTANT: _UTX_LINESIZE 32
-CONSTANT: _UTX_IDSIZE 4
-CONSTANT: _UTX_HOSTSIZE 256
-
-STRUCT: utmpx
- { ut_user { char _UTX_USERSIZE } }
- { ut_id { char _UTX_IDSIZE } }
- { ut_line { char _UTX_LINESIZE } }
- { ut_pid pid_t }
- { ut_type short }
- { ut_tv timeval }
- { ut_host { char _UTX_HOSTSIZE } }
- { ut_pad { uint 16 } } ;
-
-CONSTANT: __DARWIN_MAXPATHLEN 1024
-CONSTANT: __DARWIN_MAXNAMELEN 255
-CONSTANT: __DARWIN_MAXNAMELEN+1 255
-
-STRUCT: dirent
- { d_ino ino_t }
- { d_reclen __uint16_t }
- { d_type __uint8_t }
- { d_namlen __uint8_t }
- { d_name { char __DARWIN_MAXNAMELEN+1 } } ;
-
-CONSTANT: EPERM 1
-CONSTANT: ENOENT 2
-CONSTANT: ESRCH 3
-CONSTANT: EINTR 4
-CONSTANT: EIO 5
-CONSTANT: ENXIO 6
-CONSTANT: E2BIG 7
-CONSTANT: ENOEXEC 8
-CONSTANT: EBADF 9
-CONSTANT: ECHILD 10
-CONSTANT: EDEADLK 11
-CONSTANT: ENOMEM 12
-CONSTANT: EACCES 13
-CONSTANT: EFAULT 14
-CONSTANT: ENOTBLK 15
-CONSTANT: EBUSY 16
-CONSTANT: EEXIST 17
-CONSTANT: EXDEV 18
-CONSTANT: ENODEV 19
-CONSTANT: ENOTDIR 20
-CONSTANT: EISDIR 21
-CONSTANT: EINVAL 22
-CONSTANT: ENFILE 23
-CONSTANT: EMFILE 24
-CONSTANT: ENOTTY 25
-CONSTANT: ETXTBSY 26
-CONSTANT: EFBIG 27
-CONSTANT: ENOSPC 28
-CONSTANT: ESPIPE 29
-CONSTANT: EROFS 30
-CONSTANT: EMLINK 31
-CONSTANT: EPIPE 32
-CONSTANT: EDOM 33
-CONSTANT: ERANGE 34
-CONSTANT: EAGAIN 35
-ALIAS: EWOULDBLOCK EAGAIN
-CONSTANT: EINPROGRESS 36
-CONSTANT: EALREADY 37
-CONSTANT: ENOTSOCK 38
-CONSTANT: EDESTADDRREQ 39
-CONSTANT: EMSGSIZE 40
-CONSTANT: EPROTOTYPE 41
-CONSTANT: ENOPROTOOPT 42
-CONSTANT: EPROTONOSUPPORT 43
-CONSTANT: ESOCKTNOSUPPORT 44
-CONSTANT: ENOTSUP 45
-CONSTANT: EPFNOSUPPORT 46
-CONSTANT: EAFNOSUPPORT 47
-CONSTANT: EADDRINUSE 48
-CONSTANT: EADDRNOTAVAIL 49
-CONSTANT: ENETDOWN 50
-CONSTANT: ENETUNREACH 51
-CONSTANT: ENETRESET 52
-CONSTANT: ECONNABORTED 53
-CONSTANT: ECONNRESET 54
-CONSTANT: ENOBUFS 55
-CONSTANT: EISCONN 56
-CONSTANT: ENOTCONN 57
-CONSTANT: ESHUTDOWN 58
-CONSTANT: ETOOMANYREFS 59
-CONSTANT: ETIMEDOUT 60
-CONSTANT: ECONNREFUSED 61
-CONSTANT: ELOOP 62
-CONSTANT: ENAMETOOLONG 63
-CONSTANT: EHOSTDOWN 64
-CONSTANT: EHOSTUNREACH 65
-CONSTANT: ENOTEMPTY 66
-CONSTANT: EPROCLIM 67
-CONSTANT: EUSERS 68
-CONSTANT: EDQUOT 69
-CONSTANT: ESTALE 70
-CONSTANT: EREMOTE 71
-CONSTANT: EBADRPC 72
-CONSTANT: ERPCMISMATCH 73
-CONSTANT: EPROGUNAVAIL 74
-CONSTANT: EPROGMISMATCH 75
-CONSTANT: EPROCUNAVAIL 76
-CONSTANT: ENOLCK 77
-CONSTANT: ENOSYS 78
-CONSTANT: EFTYPE 79
-CONSTANT: EAUTH 80
-CONSTANT: ENEEDAUTH 81
-CONSTANT: EPWROFF 82
-CONSTANT: EDEVERR 83
-CONSTANT: EOVERFLOW 84
-CONSTANT: EBADEXEC 85
-CONSTANT: EBADARCH 86
-CONSTANT: ESHLIBVERS 87
-CONSTANT: EBADMACHO 88
-CONSTANT: ECANCELED 89
-CONSTANT: EIDRM 90
-CONSTANT: ENOMSG 91
-CONSTANT: EILSEQ 92
-CONSTANT: ENOATTR 93
-CONSTANT: EBADMSG 94
-CONSTANT: EMULTIHOP 95
-CONSTANT: ENODATA 96
-CONSTANT: ENOLINK 97
-CONSTANT: ENOSR 98
-CONSTANT: ENOSTR 99
-CONSTANT: EPROTO 100
-CONSTANT: ETIME 101
-CONSTANT: EOPNOTSUPP 102
-CONSTANT: ENOPOLICY 103
+++ /dev/null
-unportable
+++ /dev/null
-USING: alien.syntax alien.c-types math vocabs.loader
-classes.struct unix.types ;
-IN: unix
-
-CONSTANT: FD_SETSIZE 256
-
-STRUCT: addrinfo
- { flags int }
- { family int }
- { socktype int }
- { protocol int }
- { addrlen socklen_t }
- { canonname char* }
- { addr void* }
- { next addrinfo* } ;
-
-STRUCT: dirent
- { d_fileno __uint32_t }
- { d_reclen __uint16_t }
- { d_type __uint8_t }
- { d_namlen __uint8_t }
- { d_name char[256] } ;
-
-CONSTANT: EPERM 1
-CONSTANT: ENOENT 2
-CONSTANT: ESRCH 3
-CONSTANT: EINTR 4
-CONSTANT: EIO 5
-CONSTANT: ENXIO 6
-CONSTANT: E2BIG 7
-CONSTANT: ENOEXEC 8
-CONSTANT: EBADF 9
-CONSTANT: ECHILD 10
-CONSTANT: EDEADLK 11
-CONSTANT: ENOMEM 12
-CONSTANT: EACCES 13
-CONSTANT: EFAULT 14
-CONSTANT: ENOTBLK 15
-CONSTANT: EBUSY 16
-CONSTANT: EEXIST 17
-CONSTANT: EXDEV 18
-CONSTANT: ENODEV 19
-CONSTANT: ENOTDIR 20
-CONSTANT: EISDIR 21
-CONSTANT: EINVAL 22
-CONSTANT: ENFILE 23
-CONSTANT: EMFILE 24
-CONSTANT: ENOTTY 25
-CONSTANT: ETXTBSY 26
-CONSTANT: EFBIG 27
-CONSTANT: ENOSPC 28
-CONSTANT: ESPIPE 29
-CONSTANT: EROFS 30
-CONSTANT: EMLINK 31
-CONSTANT: EPIPE 32
-CONSTANT: EDOM 33
-CONSTANT: ERANGE 34
-CONSTANT: EAGAIN 35
-ALIAS: EWOULDBLOCK EAGAIN
-CONSTANT: EINPROGRESS 36
-CONSTANT: EALREADY 37
-CONSTANT: ENOTSOCK 38
-CONSTANT: EDESTADDRREQ 39
-CONSTANT: EMSGSIZE 40
-CONSTANT: EPROTOTYPE 41
-CONSTANT: ENOPROTOOPT 42
-CONSTANT: EPROTONOSUPPORT 43
-CONSTANT: ESOCKTNOSUPPORT 44
-CONSTANT: EOPNOTSUPP 45
-CONSTANT: EPFNOSUPPORT 46
-CONSTANT: EAFNOSUPPORT 47
-CONSTANT: EADDRINUSE 48
-CONSTANT: EADDRNOTAVAIL 49
-CONSTANT: ENETDOWN 50
-CONSTANT: ENETUNREACH 51
-CONSTANT: ENETRESET 52
-CONSTANT: ECONNABORTED 53
-CONSTANT: ECONNRESET 54
-CONSTANT: ENOBUFS 55
-CONSTANT: EISCONN 56
-CONSTANT: ENOTCONN 57
-CONSTANT: ESHUTDOWN 58
-CONSTANT: ETOOMANYREFS 59
-CONSTANT: ETIMEDOUT 60
-CONSTANT: ECONNREFUSED 61
-CONSTANT: ELOOP 62
-CONSTANT: ENAMETOOLONG 63
-CONSTANT: EHOSTDOWN 64
-CONSTANT: EHOSTUNREACH 65
-CONSTANT: ENOTEMPTY 66
-CONSTANT: EPROCLIM 67
-CONSTANT: EUSERS 68
-CONSTANT: EDQUOT 69
-CONSTANT: ESTALE 70
-CONSTANT: EREMOTE 71
-CONSTANT: EBADRPC 72
-CONSTANT: ERPCMISMATCH 73
-CONSTANT: EPROGUNAVAIL 74
-CONSTANT: EPROGMISMATCH 75
-CONSTANT: EPROCUNAVAIL 76
-CONSTANT: ENOLCK 77
-CONSTANT: ENOSYS 78
-CONSTANT: EFTYPE 79
-CONSTANT: EAUTH 80
-CONSTANT: ENEEDAUTH 81
-CONSTANT: EIDRM 82
-CONSTANT: ENOMSG 83
-CONSTANT: EOVERFLOW 84
-CONSTANT: EILSEQ 85
-CONSTANT: ENOTSUP 86
-CONSTANT: ECANCELED 87
-CONSTANT: EBADMSG 88
-CONSTANT: ENODATA 89
-CONSTANT: ENOSR 90
-CONSTANT: ENOSTR 91
-CONSTANT: ETIME 92
-CONSTANT: ENOATTR 93
-CONSTANT: EMULTIHOP 94
-CONSTANT: ENOLINK 95
-CONSTANT: EPROTO 96
-CONSTANT: ELAST 96
-
-TYPEDEF: __uint8_t sa_family_t
-
-CONSTANT: _UTX_USERSIZE 32
-CONSTANT: _UTX_LINESIZE 32
-CONSTANT: _UTX_IDSIZE 4
-CONSTANT: _UTX_HOSTSIZE 256
-
-CONSTANT: _SS_MAXSIZE 128
-
-: _SS_ALIGNSIZE ( -- n )
- __int64_t heap-size ; inline
-
-: _SS_PAD1SIZE ( -- n )
- _SS_ALIGNSIZE 2 - ; inline
-
-: _SS_PAD2SIZE ( -- n )
- _SS_MAXSIZE 2 - _SS_PAD1SIZE - _SS_ALIGNSIZE - ; inline
-
-"unix.bsd.netbsd.structs" require
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types alien.syntax unix.time unix.types
-unix.types.netbsd classes.struct ;
-IN: unix
-
-STRUCT: sockaddr_storage
- { ss_len __uint8_t }
- { ss_family sa_family_t }
- { __ss_pad1 { char _SS_PAD1SIZE } }
- { __ss_align __int64_t }
- { __ss_pad2 { char _SS_PAD2SIZE } } ;
-
-STRUCT: exit_struct
- { e_termination uint16_t }
- { e_exit uint16_t } ;
-
-STRUCT: utmpx
- { ut_user { char _UTX_USERSIZE } }
- { ut_id { char _UTX_IDSIZE } }
- { ut_line { char _UTX_LINESIZE } }
- { ut_host { char _UTX_HOSTSIZE } }
- { ut_session uint16_t }
- { ut_type uint16_t }
- { ut_pid pid_t }
- { ut_exit exit_struct }
- { ut_ss sockaddr_storage }
- { ut_tv timeval }
- { ut_pad { uint32_t 10 } } ;
-
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-USING: alien.c-types alien.syntax classes.struct unix.types ;
-IN: unix
-
-CONSTANT: FD_SETSIZE 1024
-
-STRUCT: addrinfo
- { flags int }
- { family int }
- { socktype int }
- { protocol int }
- { addrlen socklen_t }
- { addr void* }
- { canonname char* }
- { next addrinfo* } ;
-
-STRUCT: dirent
- { d_fileno __uint32_t }
- { d_reclen __uint16_t }
- { d_type __uint8_t }
- { d_namlen __uint8_t }
- { d_name char[256] } ;
-
-CONSTANT: EPERM 1
-CONSTANT: ENOENT 2
-CONSTANT: ESRCH 3
-CONSTANT: EINTR 4
-CONSTANT: EIO 5
-CONSTANT: ENXIO 6
-CONSTANT: E2BIG 7
-CONSTANT: ENOEXEC 8
-CONSTANT: EBADF 9
-CONSTANT: ECHILD 10
-CONSTANT: EDEADLK 11
-CONSTANT: ENOMEM 12
-CONSTANT: EACCES 13
-CONSTANT: EFAULT 14
-CONSTANT: ENOTBLK 15
-CONSTANT: EBUSY 16
-CONSTANT: EEXIST 17
-CONSTANT: EXDEV 18
-CONSTANT: ENODEV 19
-CONSTANT: ENOTDIR 20
-CONSTANT: EISDIR 21
-CONSTANT: EINVAL 22
-CONSTANT: ENFILE 23
-CONSTANT: EMFILE 24
-CONSTANT: ENOTTY 25
-CONSTANT: ETXTBSY 26
-CONSTANT: EFBIG 27
-CONSTANT: ENOSPC 28
-CONSTANT: ESPIPE 29
-CONSTANT: EROFS 30
-CONSTANT: EMLINK 31
-CONSTANT: EPIPE 32
-CONSTANT: EDOM 33
-CONSTANT: ERANGE 34
-CONSTANT: EAGAIN 35
-ALIAS: EWOULDBLOCK EAGAIN
-CONSTANT: EINPROGRESS 36
-CONSTANT: EALREADY 37
-CONSTANT: ENOTSOCK 38
-CONSTANT: EDESTADDRREQ 39
-CONSTANT: EMSGSIZE 40
-CONSTANT: EPROTOTYPE 41
-CONSTANT: ENOPROTOOPT 42
-CONSTANT: EPROTONOSUPPORT 43
-CONSTANT: ESOCKTNOSUPPORT 44
-CONSTANT: EOPNOTSUPP 45
-CONSTANT: EPFNOSUPPORT 46
-CONSTANT: EAFNOSUPPORT 47
-CONSTANT: EADDRINUSE 48
-CONSTANT: EADDRNOTAVAIL 49
-CONSTANT: ENETDOWN 50
-CONSTANT: ENETUNREACH 51
-CONSTANT: ENETRESET 52
-CONSTANT: ECONNABORTED 53
-CONSTANT: ECONNRESET 54
-CONSTANT: ENOBUFS 55
-CONSTANT: EISCONN 56
-CONSTANT: ENOTCONN 57
-CONSTANT: ESHUTDOWN 58
-CONSTANT: ETOOMANYREFS 59
-CONSTANT: ETIMEDOUT 60
-CONSTANT: ECONNREFUSED 61
-CONSTANT: ELOOP 62
-CONSTANT: ENAMETOOLONG 63
-CONSTANT: EHOSTDOWN 64
-CONSTANT: EHOSTUNREACH 65
-CONSTANT: ENOTEMPTY 66
-CONSTANT: EPROCLIM 67
-CONSTANT: EUSERS 68
-CONSTANT: EDQUOT 69
-CONSTANT: ESTALE 70
-CONSTANT: EREMOTE 71
-CONSTANT: EBADRPC 72
-CONSTANT: ERPCMISMATCH 73
-CONSTANT: EPROGUNAVAIL 74
-CONSTANT: EPROGMISMATCH 75
-CONSTANT: EPROCUNAVAIL 76
-CONSTANT: ENOLCK 77
-CONSTANT: ENOSYS 78
-CONSTANT: EFTYPE 79
-CONSTANT: EAUTH 80
-CONSTANT: ENEEDAUTH 81
-CONSTANT: EIPSEC 82
-CONSTANT: ENOATTR 83
-CONSTANT: EILSEQ 84
-CONSTANT: ENOMEDIUM 85
-CONSTANT: EMEDIUMTYPE 86
-CONSTANT: EOVERFLOW 87
-CONSTANT: ECANCELED 88
+++ /dev/null
-unportable
+++ /dev/null
-*BSD/Mac OS X support
+++ /dev/null
-unportable
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: debugger prettyprint accessors unix kernel ;
-FROM: io => write print nl ;
+USING: accessors debugger io kernel prettyprint unix ;
IN: unix.debugger
M: unix-error error.
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2005, 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types alien.syntax classes.struct combinators
+system unix.types vocabs.loader ;
+IN: unix.ffi
+
+CONSTANT: MAXPATHLEN 1024
+
+CONSTANT: O_RDONLY HEX: 0000
+CONSTANT: O_WRONLY HEX: 0001
+CONSTANT: O_RDWR HEX: 0002
+CONSTANT: O_NONBLOCK HEX: 0004
+CONSTANT: O_APPEND HEX: 0008
+CONSTANT: O_CREAT HEX: 0200
+CONSTANT: O_TRUNC HEX: 0400
+CONSTANT: O_EXCL HEX: 0800
+CONSTANT: O_NOCTTY HEX: 20000
+ALIAS: O_NDELAY O_NONBLOCK
+
+CONSTANT: SOL_SOCKET HEX: ffff
+CONSTANT: SO_REUSEADDR HEX: 4
+CONSTANT: SO_OOBINLINE HEX: 100
+CONSTANT: SO_SNDTIMEO HEX: 1005
+CONSTANT: SO_RCVTIMEO HEX: 1006
+
+CONSTANT: F_SETFD 2
+CONSTANT: F_SETFL 4
+CONSTANT: FD_CLOEXEC 1
+
+STRUCT: sockaddr-in
+ { len uchar }
+ { family uchar }
+ { port ushort }
+ { addr in_addr_t }
+ { unused longlong } ;
+
+STRUCT: sockaddr-in6
+ { len uchar }
+ { family uchar }
+ { port ushort }
+ { flowinfo uint }
+ { addr uchar[16] }
+ { scopeid uint } ;
+
+STRUCT: sockaddr-un
+ { len uchar }
+ { family uchar }
+ { path char[104] } ;
+
+STRUCT: passwd
+ { pw_name char* }
+ { pw_passwd char* }
+ { pw_uid uid_t }
+ { pw_gid gid_t }
+ { pw_change time_t }
+ { pw_class char* }
+ { pw_gecos char* }
+ { pw_dir char* }
+ { pw_shell char* }
+ { pw_expire time_t }
+ { pw_fields int } ;
+
+CONSTANT: max-un-path 104
+
+CONSTANT: SOCK_STREAM 1
+CONSTANT: SOCK_DGRAM 2
+
+CONSTANT: AF_UNSPEC 0
+CONSTANT: AF_UNIX 1
+CONSTANT: AF_INET 2
+CONSTANT: AF_INET6 30
+
+ALIAS: PF_UNSPEC AF_UNSPEC
+ALIAS: PF_UNIX AF_UNIX
+ALIAS: PF_INET AF_INET
+ALIAS: PF_INET6 AF_INET6
+
+CONSTANT: IPPROTO_TCP 6
+CONSTANT: IPPROTO_UDP 17
+
+CONSTANT: AI_PASSIVE 1
+
+CONSTANT: SEEK_SET 0
+CONSTANT: SEEK_CUR 1
+CONSTANT: SEEK_END 2
+
+os {
+ { macosx [ "unix.ffi.bsd.macosx" require ] }
+ { freebsd [ "unix.ffi.bsd.freebsd" require ] }
+ { openbsd [ "unix.ffi.bsd.openbsd" require ] }
+ { netbsd [ "unix.ffi.bsd.netbsd" require ] }
+} case
--- /dev/null
+USING: alien.c-types alien.syntax classes.struct unix.types ;
+IN: unix.ffi
+
+CONSTANT: FD_SETSIZE 1024
+
+STRUCT: addrinfo
+ { flags int }
+ { family int }
+ { socktype int }
+ { protocol int }
+ { addrlen socklen_t }
+ { canonname char* }
+ { addr void* }
+ { next addrinfo* } ;
+
+STRUCT: dirent
+ { d_fileno u_int32_t }
+ { d_reclen u_int16_t }
+ { d_type u_int8_t }
+ { d_namlen u_int8_t }
+ { d_name char[256] } ;
+
+CONSTANT: EPERM 1
+CONSTANT: ENOENT 2
+CONSTANT: ESRCH 3
+CONSTANT: EINTR 4
+CONSTANT: EIO 5
+CONSTANT: ENXIO 6
+CONSTANT: E2BIG 7
+CONSTANT: ENOEXEC 8
+CONSTANT: EBADF 9
+CONSTANT: ECHILD 10
+CONSTANT: EDEADLK 11
+CONSTANT: ENOMEM 12
+CONSTANT: EACCES 13
+CONSTANT: EFAULT 14
+CONSTANT: ENOTBLK 15
+CONSTANT: EBUSY 16
+CONSTANT: EEXIST 17
+CONSTANT: EXDEV 18
+CONSTANT: ENODEV 19
+CONSTANT: ENOTDIR 20
+CONSTANT: EISDIR 21
+CONSTANT: EINVAL 22
+CONSTANT: ENFILE 23
+CONSTANT: EMFILE 24
+CONSTANT: ENOTTY 25
+CONSTANT: ETXTBSY 26
+CONSTANT: EFBIG 27
+CONSTANT: ENOSPC 28
+CONSTANT: ESPIPE 29
+CONSTANT: EROFS 30
+CONSTANT: EMLINK 31
+CONSTANT: EPIPE 32
+CONSTANT: EDOM 33
+CONSTANT: ERANGE 34
+CONSTANT: EAGAIN 35
+ALIAS: EWOULDBLOCK EAGAIN
+CONSTANT: EINPROGRESS 36
+CONSTANT: EALREADY 37
+CONSTANT: ENOTSOCK 38
+CONSTANT: EDESTADDRREQ 39
+CONSTANT: EMSGSIZE 40
+CONSTANT: EPROTOTYPE 41
+CONSTANT: ENOPROTOOPT 42
+CONSTANT: EPROTONOSUPPORT 43
+CONSTANT: ESOCKTNOSUPPORT 44
+CONSTANT: EOPNOTSUPP 45
+ALIAS: ENOTSUP EOPNOTSUPP
+CONSTANT: EPFNOSUPPORT 46
+CONSTANT: EAFNOSUPPORT 47
+CONSTANT: EADDRINUSE 48
+CONSTANT: EADDRNOTAVAIL 49
+CONSTANT: ENETDOWN 50
+CONSTANT: ENETUNREACH 51
+CONSTANT: ENETRESET 52
+CONSTANT: ECONNABORTED 53
+CONSTANT: ECONNRESET 54
+CONSTANT: ENOBUFS 55
+CONSTANT: EISCONN 56
+CONSTANT: ENOTCONN 57
+CONSTANT: ESHUTDOWN 58
+CONSTANT: ETOOMANYREFS 59
+CONSTANT: ETIMEDOUT 60
+CONSTANT: ECONNREFUSED 61
+CONSTANT: ELOOP 62
+CONSTANT: ENAMETOOLONG 63
+CONSTANT: EHOSTDOWN 64
+CONSTANT: EHOSTUNREACH 65
+CONSTANT: ENOTEMPTY 66
+CONSTANT: EPROCLIM 67
+CONSTANT: EUSERS 68
+CONSTANT: EDQUOT 69
+CONSTANT: ESTALE 70
+CONSTANT: EREMOTE 71
+CONSTANT: EBADRPC 72
+CONSTANT: ERPCMISMATCH 73
+CONSTANT: EPROGUNAVAIL 74
+CONSTANT: EPROGMISMATCH 75
+CONSTANT: EPROCUNAVAIL 76
+CONSTANT: ENOLCK 77
+CONSTANT: ENOSYS 78
+CONSTANT: EFTYPE 79
+CONSTANT: EAUTH 80
+CONSTANT: ENEEDAUTH 81
+CONSTANT: EIDRM 82
+CONSTANT: ENOMSG 83
+CONSTANT: EOVERFLOW 84
+CONSTANT: ECANCELED 85
+CONSTANT: EILSEQ 86
+CONSTANT: ENOATTR 87
+CONSTANT: EDOOFUS 88
+CONSTANT: EBADMSG 89
+CONSTANT: EMULTIHOP 90
+CONSTANT: ENOLINK 91
+CONSTANT: EPROTO 92
--- /dev/null
+unportable
--- /dev/null
+USING: alien alien.c-types alien.libraries alien.syntax
+classes.struct combinators kernel system unix unix.time
+unix.types vocabs vocabs.loader ;
+IN: unix.ffi
+
+CONSTANT: FD_SETSIZE 1024
+
+STRUCT: addrinfo
+ { flags int }
+ { family int }
+ { socktype int }
+ { protocol int }
+ { addrlen socklen_t }
+ { canonname char* }
+ { addr void* }
+ { next addrinfo* } ;
+
+CONSTANT: _UTX_USERSIZE 256
+CONSTANT: _UTX_LINESIZE 32
+CONSTANT: _UTX_IDSIZE 4
+CONSTANT: _UTX_HOSTSIZE 256
+
+STRUCT: utmpx
+ { ut_user { char _UTX_USERSIZE } }
+ { ut_id { char _UTX_IDSIZE } }
+ { ut_line { char _UTX_LINESIZE } }
+ { ut_pid pid_t }
+ { ut_type short }
+ { ut_tv timeval }
+ { ut_host { char _UTX_HOSTSIZE } }
+ { ut_pad { uint 16 } } ;
+
+CONSTANT: __DARWIN_MAXPATHLEN 1024
+CONSTANT: __DARWIN_MAXNAMELEN 255
+CONSTANT: __DARWIN_MAXNAMELEN+1 255
+
+STRUCT: dirent
+ { d_ino ino_t }
+ { d_reclen __uint16_t }
+ { d_type __uint8_t }
+ { d_namlen __uint8_t }
+ { d_name { char __DARWIN_MAXNAMELEN+1 } } ;
+
+CONSTANT: EPERM 1
+CONSTANT: ENOENT 2
+CONSTANT: ESRCH 3
+CONSTANT: EINTR 4
+CONSTANT: EIO 5
+CONSTANT: ENXIO 6
+CONSTANT: E2BIG 7
+CONSTANT: ENOEXEC 8
+CONSTANT: EBADF 9
+CONSTANT: ECHILD 10
+CONSTANT: EDEADLK 11
+CONSTANT: ENOMEM 12
+CONSTANT: EACCES 13
+CONSTANT: EFAULT 14
+CONSTANT: ENOTBLK 15
+CONSTANT: EBUSY 16
+CONSTANT: EEXIST 17
+CONSTANT: EXDEV 18
+CONSTANT: ENODEV 19
+CONSTANT: ENOTDIR 20
+CONSTANT: EISDIR 21
+CONSTANT: EINVAL 22
+CONSTANT: ENFILE 23
+CONSTANT: EMFILE 24
+CONSTANT: ENOTTY 25
+CONSTANT: ETXTBSY 26
+CONSTANT: EFBIG 27
+CONSTANT: ENOSPC 28
+CONSTANT: ESPIPE 29
+CONSTANT: EROFS 30
+CONSTANT: EMLINK 31
+CONSTANT: EPIPE 32
+CONSTANT: EDOM 33
+CONSTANT: ERANGE 34
+CONSTANT: EAGAIN 35
+ALIAS: EWOULDBLOCK EAGAIN
+CONSTANT: EINPROGRESS 36
+CONSTANT: EALREADY 37
+CONSTANT: ENOTSOCK 38
+CONSTANT: EDESTADDRREQ 39
+CONSTANT: EMSGSIZE 40
+CONSTANT: EPROTOTYPE 41
+CONSTANT: ENOPROTOOPT 42
+CONSTANT: EPROTONOSUPPORT 43
+CONSTANT: ESOCKTNOSUPPORT 44
+CONSTANT: ENOTSUP 45
+CONSTANT: EPFNOSUPPORT 46
+CONSTANT: EAFNOSUPPORT 47
+CONSTANT: EADDRINUSE 48
+CONSTANT: EADDRNOTAVAIL 49
+CONSTANT: ENETDOWN 50
+CONSTANT: ENETUNREACH 51
+CONSTANT: ENETRESET 52
+CONSTANT: ECONNABORTED 53
+CONSTANT: ECONNRESET 54
+CONSTANT: ENOBUFS 55
+CONSTANT: EISCONN 56
+CONSTANT: ENOTCONN 57
+CONSTANT: ESHUTDOWN 58
+CONSTANT: ETOOMANYREFS 59
+CONSTANT: ETIMEDOUT 60
+CONSTANT: ECONNREFUSED 61
+CONSTANT: ELOOP 62
+CONSTANT: ENAMETOOLONG 63
+CONSTANT: EHOSTDOWN 64
+CONSTANT: EHOSTUNREACH 65
+CONSTANT: ENOTEMPTY 66
+CONSTANT: EPROCLIM 67
+CONSTANT: EUSERS 68
+CONSTANT: EDQUOT 69
+CONSTANT: ESTALE 70
+CONSTANT: EREMOTE 71
+CONSTANT: EBADRPC 72
+CONSTANT: ERPCMISMATCH 73
+CONSTANT: EPROGUNAVAIL 74
+CONSTANT: EPROGMISMATCH 75
+CONSTANT: EPROCUNAVAIL 76
+CONSTANT: ENOLCK 77
+CONSTANT: ENOSYS 78
+CONSTANT: EFTYPE 79
+CONSTANT: EAUTH 80
+CONSTANT: ENEEDAUTH 81
+CONSTANT: EPWROFF 82
+CONSTANT: EDEVERR 83
+CONSTANT: EOVERFLOW 84
+CONSTANT: EBADEXEC 85
+CONSTANT: EBADARCH 86
+CONSTANT: ESHLIBVERS 87
+CONSTANT: EBADMACHO 88
+CONSTANT: ECANCELED 89
+CONSTANT: EIDRM 90
+CONSTANT: ENOMSG 91
+CONSTANT: EILSEQ 92
+CONSTANT: ENOATTR 93
+CONSTANT: EBADMSG 94
+CONSTANT: EMULTIHOP 95
+CONSTANT: ENODATA 96
+CONSTANT: ENOLINK 97
+CONSTANT: ENOSR 98
+CONSTANT: ENOSTR 99
+CONSTANT: EPROTO 100
+CONSTANT: ETIME 101
+CONSTANT: EOPNOTSUPP 102
+CONSTANT: ENOPOLICY 103
--- /dev/null
+unportable
--- /dev/null
+USING: alien.syntax alien.c-types math vocabs.loader
+classes.struct unix.types unix.time ;
+IN: unix.ffi
+
+CONSTANT: FD_SETSIZE 256
+
+STRUCT: addrinfo
+ { flags int }
+ { family int }
+ { socktype int }
+ { protocol int }
+ { addrlen socklen_t }
+ { canonname char* }
+ { addr void* }
+ { next addrinfo* } ;
+
+STRUCT: dirent
+ { d_fileno __uint32_t }
+ { d_reclen __uint16_t }
+ { d_type __uint8_t }
+ { d_namlen __uint8_t }
+ { d_name char[256] } ;
+
+CONSTANT: EPERM 1
+CONSTANT: ENOENT 2
+CONSTANT: ESRCH 3
+CONSTANT: EINTR 4
+CONSTANT: EIO 5
+CONSTANT: ENXIO 6
+CONSTANT: E2BIG 7
+CONSTANT: ENOEXEC 8
+CONSTANT: EBADF 9
+CONSTANT: ECHILD 10
+CONSTANT: EDEADLK 11
+CONSTANT: ENOMEM 12
+CONSTANT: EACCES 13
+CONSTANT: EFAULT 14
+CONSTANT: ENOTBLK 15
+CONSTANT: EBUSY 16
+CONSTANT: EEXIST 17
+CONSTANT: EXDEV 18
+CONSTANT: ENODEV 19
+CONSTANT: ENOTDIR 20
+CONSTANT: EISDIR 21
+CONSTANT: EINVAL 22
+CONSTANT: ENFILE 23
+CONSTANT: EMFILE 24
+CONSTANT: ENOTTY 25
+CONSTANT: ETXTBSY 26
+CONSTANT: EFBIG 27
+CONSTANT: ENOSPC 28
+CONSTANT: ESPIPE 29
+CONSTANT: EROFS 30
+CONSTANT: EMLINK 31
+CONSTANT: EPIPE 32
+CONSTANT: EDOM 33
+CONSTANT: ERANGE 34
+CONSTANT: EAGAIN 35
+ALIAS: EWOULDBLOCK EAGAIN
+CONSTANT: EINPROGRESS 36
+CONSTANT: EALREADY 37
+CONSTANT: ENOTSOCK 38
+CONSTANT: EDESTADDRREQ 39
+CONSTANT: EMSGSIZE 40
+CONSTANT: EPROTOTYPE 41
+CONSTANT: ENOPROTOOPT 42
+CONSTANT: EPROTONOSUPPORT 43
+CONSTANT: ESOCKTNOSUPPORT 44
+CONSTANT: EOPNOTSUPP 45
+CONSTANT: EPFNOSUPPORT 46
+CONSTANT: EAFNOSUPPORT 47
+CONSTANT: EADDRINUSE 48
+CONSTANT: EADDRNOTAVAIL 49
+CONSTANT: ENETDOWN 50
+CONSTANT: ENETUNREACH 51
+CONSTANT: ENETRESET 52
+CONSTANT: ECONNABORTED 53
+CONSTANT: ECONNRESET 54
+CONSTANT: ENOBUFS 55
+CONSTANT: EISCONN 56
+CONSTANT: ENOTCONN 57
+CONSTANT: ESHUTDOWN 58
+CONSTANT: ETOOMANYREFS 59
+CONSTANT: ETIMEDOUT 60
+CONSTANT: ECONNREFUSED 61
+CONSTANT: ELOOP 62
+CONSTANT: ENAMETOOLONG 63
+CONSTANT: EHOSTDOWN 64
+CONSTANT: EHOSTUNREACH 65
+CONSTANT: ENOTEMPTY 66
+CONSTANT: EPROCLIM 67
+CONSTANT: EUSERS 68
+CONSTANT: EDQUOT 69
+CONSTANT: ESTALE 70
+CONSTANT: EREMOTE 71
+CONSTANT: EBADRPC 72
+CONSTANT: ERPCMISMATCH 73
+CONSTANT: EPROGUNAVAIL 74
+CONSTANT: EPROGMISMATCH 75
+CONSTANT: EPROCUNAVAIL 76
+CONSTANT: ENOLCK 77
+CONSTANT: ENOSYS 78
+CONSTANT: EFTYPE 79
+CONSTANT: EAUTH 80
+CONSTANT: ENEEDAUTH 81
+CONSTANT: EIDRM 82
+CONSTANT: ENOMSG 83
+CONSTANT: EOVERFLOW 84
+CONSTANT: EILSEQ 85
+CONSTANT: ENOTSUP 86
+CONSTANT: ECANCELED 87
+CONSTANT: EBADMSG 88
+CONSTANT: ENODATA 89
+CONSTANT: ENOSR 90
+CONSTANT: ENOSTR 91
+CONSTANT: ETIME 92
+CONSTANT: ENOATTR 93
+CONSTANT: EMULTIHOP 94
+CONSTANT: ENOLINK 95
+CONSTANT: EPROTO 96
+CONSTANT: ELAST 96
+
+TYPEDEF: __uint8_t sa_family_t
+
+CONSTANT: _UTX_USERSIZE 32
+CONSTANT: _UTX_LINESIZE 32
+CONSTANT: _UTX_IDSIZE 4
+CONSTANT: _UTX_HOSTSIZE 256
+
+<<
+
+CONSTANT: _SS_MAXSIZE 128
+
+: _SS_ALIGNSIZE ( -- n )
+ __int64_t heap-size ; inline
+
+: _SS_PAD1SIZE ( -- n )
+ _SS_ALIGNSIZE 2 - ; inline
+
+: _SS_PAD2SIZE ( -- n )
+ _SS_MAXSIZE 2 - _SS_PAD1SIZE - _SS_ALIGNSIZE - ; inline
+
+>>
+
+STRUCT: sockaddr_storage
+ { ss_len __uint8_t }
+ { ss_family sa_family_t }
+ { __ss_pad1 { char _SS_PAD1SIZE } }
+ { __ss_align __int64_t }
+ { __ss_pad2 { char _SS_PAD2SIZE } } ;
+
+STRUCT: exit_struct
+ { e_termination uint16_t }
+ { e_exit uint16_t } ;
+
+STRUCT: utmpx
+ { ut_user { char _UTX_USERSIZE } }
+ { ut_id { char _UTX_IDSIZE } }
+ { ut_line { char _UTX_LINESIZE } }
+ { ut_host { char _UTX_HOSTSIZE } }
+ { ut_session uint16_t }
+ { ut_type uint16_t }
+ { ut_pid pid_t }
+ { ut_exit exit_struct }
+ { ut_ss sockaddr_storage }
+ { ut_tv timeval }
+ { ut_pad { uint32_t 10 } } ;
--- /dev/null
+unportable
--- /dev/null
+USING: alien.c-types alien.syntax classes.struct unix.types ;
+IN: unix.ffi
+
+CONSTANT: FD_SETSIZE 1024
+
+STRUCT: addrinfo
+ { flags int }
+ { family int }
+ { socktype int }
+ { protocol int }
+ { addrlen socklen_t }
+ { addr void* }
+ { canonname char* }
+ { next addrinfo* } ;
+
+STRUCT: dirent
+ { d_fileno __uint32_t }
+ { d_reclen __uint16_t }
+ { d_type __uint8_t }
+ { d_namlen __uint8_t }
+ { d_name char[256] } ;
+
+CONSTANT: EPERM 1
+CONSTANT: ENOENT 2
+CONSTANT: ESRCH 3
+CONSTANT: EINTR 4
+CONSTANT: EIO 5
+CONSTANT: ENXIO 6
+CONSTANT: E2BIG 7
+CONSTANT: ENOEXEC 8
+CONSTANT: EBADF 9
+CONSTANT: ECHILD 10
+CONSTANT: EDEADLK 11
+CONSTANT: ENOMEM 12
+CONSTANT: EACCES 13
+CONSTANT: EFAULT 14
+CONSTANT: ENOTBLK 15
+CONSTANT: EBUSY 16
+CONSTANT: EEXIST 17
+CONSTANT: EXDEV 18
+CONSTANT: ENODEV 19
+CONSTANT: ENOTDIR 20
+CONSTANT: EISDIR 21
+CONSTANT: EINVAL 22
+CONSTANT: ENFILE 23
+CONSTANT: EMFILE 24
+CONSTANT: ENOTTY 25
+CONSTANT: ETXTBSY 26
+CONSTANT: EFBIG 27
+CONSTANT: ENOSPC 28
+CONSTANT: ESPIPE 29
+CONSTANT: EROFS 30
+CONSTANT: EMLINK 31
+CONSTANT: EPIPE 32
+CONSTANT: EDOM 33
+CONSTANT: ERANGE 34
+CONSTANT: EAGAIN 35
+ALIAS: EWOULDBLOCK EAGAIN
+CONSTANT: EINPROGRESS 36
+CONSTANT: EALREADY 37
+CONSTANT: ENOTSOCK 38
+CONSTANT: EDESTADDRREQ 39
+CONSTANT: EMSGSIZE 40
+CONSTANT: EPROTOTYPE 41
+CONSTANT: ENOPROTOOPT 42
+CONSTANT: EPROTONOSUPPORT 43
+CONSTANT: ESOCKTNOSUPPORT 44
+CONSTANT: EOPNOTSUPP 45
+CONSTANT: EPFNOSUPPORT 46
+CONSTANT: EAFNOSUPPORT 47
+CONSTANT: EADDRINUSE 48
+CONSTANT: EADDRNOTAVAIL 49
+CONSTANT: ENETDOWN 50
+CONSTANT: ENETUNREACH 51
+CONSTANT: ENETRESET 52
+CONSTANT: ECONNABORTED 53
+CONSTANT: ECONNRESET 54
+CONSTANT: ENOBUFS 55
+CONSTANT: EISCONN 56
+CONSTANT: ENOTCONN 57
+CONSTANT: ESHUTDOWN 58
+CONSTANT: ETOOMANYREFS 59
+CONSTANT: ETIMEDOUT 60
+CONSTANT: ECONNREFUSED 61
+CONSTANT: ELOOP 62
+CONSTANT: ENAMETOOLONG 63
+CONSTANT: EHOSTDOWN 64
+CONSTANT: EHOSTUNREACH 65
+CONSTANT: ENOTEMPTY 66
+CONSTANT: EPROCLIM 67
+CONSTANT: EUSERS 68
+CONSTANT: EDQUOT 69
+CONSTANT: ESTALE 70
+CONSTANT: EREMOTE 71
+CONSTANT: EBADRPC 72
+CONSTANT: ERPCMISMATCH 73
+CONSTANT: EPROGUNAVAIL 74
+CONSTANT: EPROGMISMATCH 75
+CONSTANT: EPROCUNAVAIL 76
+CONSTANT: ENOLCK 77
+CONSTANT: ENOSYS 78
+CONSTANT: EFTYPE 79
+CONSTANT: EAUTH 80
+CONSTANT: ENEEDAUTH 81
+CONSTANT: EIPSEC 82
+CONSTANT: ENOATTR 83
+CONSTANT: EILSEQ 84
+CONSTANT: ENOMEDIUM 85
+CONSTANT: EMEDIUMTYPE 86
+CONSTANT: EOVERFLOW 87
+CONSTANT: ECANCELED 88
--- /dev/null
+unportable
--- /dev/null
+*BSD/Mac OS X support
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types alien.libraries alien.syntax
+classes.struct combinators kernel system unix.time unix.types
+vocabs vocabs.loader ;
+IN: unix.ffi
+
+<<
+
+{
+ { [ os linux? ] [ "unix.ffi.linux" require ] }
+ { [ os bsd? ] [ "unix.ffi.bsd" require ] }
+ { [ os solaris? ] [ "unix.ffi.solaris" require ] }
+} cond
+
+>>
+
+CONSTANT: PROT_NONE 0
+CONSTANT: PROT_READ 1
+CONSTANT: PROT_WRITE 2
+CONSTANT: PROT_EXEC 4
+
+CONSTANT: MAP_FILE 0
+CONSTANT: MAP_SHARED 1
+CONSTANT: MAP_PRIVATE 2
+
+CONSTANT: SEEK_SET 0
+CONSTANT: SEEK_CUR 1
+CONSTANT: SEEK_END 2
+
+: MAP_FAILED ( -- alien ) -1 <alien> ; inline
+
+CONSTANT: NGROUPS_MAX 16
+
+CONSTANT: DT_UNKNOWN 0
+CONSTANT: DT_FIFO 1
+CONSTANT: DT_CHR 2
+CONSTANT: DT_DIR 4
+CONSTANT: DT_BLK 6
+CONSTANT: DT_REG 8
+CONSTANT: DT_LNK 10
+CONSTANT: DT_SOCK 12
+CONSTANT: DT_WHT 14
+
+LIBRARY: libc
+
+FUNCTION: char* strerror ( int errno ) ;
+
+STRUCT: group
+ { gr_name char* }
+ { gr_passwd char* }
+ { gr_gid int }
+ { gr_mem char** } ;
+
+FUNCTION: int accept ( int s, void* sockaddr, socklen_t* socklen ) ;
+FUNCTION: int bind ( int s, void* name, socklen_t namelen ) ;
+FUNCTION: int chdir ( char* path ) ;
+FUNCTION: int chmod ( char* path, mode_t mode ) ;
+FUNCTION: int fchmod ( int fd, mode_t mode ) ;
+FUNCTION: int chown ( char* path, uid_t owner, gid_t group ) ;
+FUNCTION: int chroot ( char* path ) ;
+FUNCTION: int close ( int fd ) ;
+FUNCTION: int closedir ( DIR* dirp ) ;
+FUNCTION: int connect ( int s, void* name, socklen_t namelen ) ;
+FUNCTION: int dup2 ( int oldd, int newd ) ;
+FUNCTION: void endpwent ( ) ;
+FUNCTION: int fchdir ( int fd ) ;
+FUNCTION: int fchown ( int fd, uid_t owner, gid_t group ) ;
+FUNCTION: int fcntl ( int fd, int cmd, int arg ) ;
+FUNCTION: int flock ( int fd, int operation ) ;
+FUNCTION: void freeaddrinfo ( addrinfo* ai ) ;
+FUNCTION: int futimes ( int id, timeval[2] times ) ;
+FUNCTION: char* gai_strerror ( int ecode ) ;
+FUNCTION: int getaddrinfo ( char* hostname, char* servname, addrinfo* hints, addrinfo** res ) ;
+FUNCTION: char* getcwd ( char* buf, size_t size ) ;
+FUNCTION: pid_t getpid ;
+FUNCTION: int getdtablesize ;
+FUNCTION: gid_t getegid ;
+FUNCTION: uid_t geteuid ;
+FUNCTION: gid_t getgid ;
+FUNCTION: char* getenv ( char* name ) ;
+
+FUNCTION: int getgrgid_r ( gid_t gid, group* grp, char* buffer, size_t bufsize, group** result ) ;
+FUNCTION: int getgrnam_r ( char* name, group* grp, char* buffer, size_t bufsize, group** result ) ;
+FUNCTION: passwd* getpwent ( ) ;
+FUNCTION: passwd* getpwuid ( uid_t uid ) ;
+FUNCTION: passwd* getpwnam ( char* login ) ;
+FUNCTION: int getpwnam_r ( char* login, passwd* pwd, char* buffer, size_t bufsize, passwd** result ) ;
+FUNCTION: int getgroups ( int gidsetlen, gid_t* gidset ) ;
+FUNCTION: int getgrouplist ( char* name, int basegid, int* groups, int* ngroups ) ;
+FUNCTION: int getrlimit ( int resource, rlimit* rlp ) ;
+FUNCTION: int setrlimit ( int resource, rlimit* rlp ) ;
+FUNCTION: int getpriority ( int which, id_t who ) ;
+FUNCTION: int setpriority ( int which, id_t who, int prio ) ;
+FUNCTION: int getrusage ( int who, rusage* r_usage ) ;
+FUNCTION: group* getgrent ;
+FUNCTION: int gethostname ( char* name, int len ) ;
+FUNCTION: int getsockname ( int socket, sockaddr* address, socklen_t* address_len ) ;
+FUNCTION: int getpeername ( int socket, sockaddr* address, socklen_t* address_len ) ;
+FUNCTION: uid_t getuid ;
+FUNCTION: uint htonl ( uint n ) ;
+FUNCTION: ushort htons ( ushort n ) ;
+! FUNCTION: int issetugid ;
+FUNCTION: int ioctl ( int fd, ulong request, char* argp ) ;
+FUNCTION: int lchown ( char* path, uid_t owner, gid_t group ) ;
+FUNCTION: int listen ( int s, int backlog ) ;
+FUNCTION: off_t lseek ( int fildes, off_t offset, int whence ) ;
+FUNCTION: int mkdir ( char* path, mode_t mode ) ;
+FUNCTION: void* mmap ( void* addr, size_t len, int prot, int flags, int fd, off_t offset ) ;
+FUNCTION: int munmap ( void* addr, size_t len ) ;
+FUNCTION: uint ntohl ( uint n ) ;
+FUNCTION: ushort ntohs ( ushort n ) ;
+FUNCTION: int shutdown ( int fd, int how ) ;
+FUNCTION: int open ( char* path, int flags, int prot ) ;
+FUNCTION: DIR* opendir ( char* path ) ;
+
+STRUCT: utimbuf
+ { actime time_t }
+ { modtime time_t } ;
+
+FUNCTION: int utime ( char* path, utimbuf* buf ) ;
+
+FUNCTION: int pclose ( void* file ) ;
+FUNCTION: int pipe ( int* filedes ) ;
+FUNCTION: void* popen ( char* command, char* type ) ;
+FUNCTION: ssize_t read ( int fd, void* buf, size_t nbytes ) ;
+
+FUNCTION: dirent* readdir ( DIR* dirp ) ;
+FUNCTION: int readdir_r ( void* dirp, dirent* entry, dirent** result ) ;
+FUNCTION: ssize_t readlink ( char* path, char* buf, size_t bufsize ) ;
+
+CONSTANT: PATH_MAX 1024
+
+FUNCTION: ssize_t recv ( int s, void* buf, size_t nbytes, int flags ) ;
+FUNCTION: ssize_t recvfrom ( int s, void* buf, size_t nbytes, int flags, sockaddr-in* from, socklen_t* fromlen ) ;
+FUNCTION: int rename ( char* from, char* to ) ;
+FUNCTION: int rmdir ( char* path ) ;
+FUNCTION: int select ( int nfds, void* readfds, void* writefds, void* exceptfds, timeval* timeout ) ;
+FUNCTION: ssize_t sendto ( int s, void* buf, size_t len, int flags, sockaddr-in* to, socklen_t tolen ) ;
+FUNCTION: int setenv ( char* name, char* value, int overwrite ) ;
+FUNCTION: int unsetenv ( char* name ) ;
+FUNCTION: int setegid ( gid_t egid ) ;
+FUNCTION: int seteuid ( uid_t euid ) ;
+FUNCTION: int setgid ( gid_t gid ) ;
+FUNCTION: int setgroups ( int ngroups, gid_t* gidset ) ;
+FUNCTION: int setregid ( gid_t rgid, gid_t egid ) ;
+FUNCTION: int setreuid ( uid_t ruid, uid_t euid ) ;
+FUNCTION: int setsockopt ( int s, int level, int optname, void* optval, socklen_t optlen ) ;
+FUNCTION: int setuid ( uid_t uid ) ;
+FUNCTION: int socket ( int domain, int type, int protocol ) ;
+FUNCTION: int symlink ( char* path1, char* path2 ) ;
+FUNCTION: int link ( char* path1, char* path2 ) ;
+FUNCTION: int system ( char* command ) ;
+FUNCTION: int unlink ( char* path ) ;
+FUNCTION: int utimes ( char* path, timeval[2] times ) ;
+FUNCTION: ssize_t write ( int fd, void* buf, size_t nbytes ) ;
+
+"librt" "librt.so" "cdecl" add-library
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types alien.syntax classes.struct unix.types ;
+IN: unix.ffi
+
+CONSTANT: MAXPATHLEN 1024
+
+CONSTANT: O_RDONLY HEX: 0000
+CONSTANT: O_WRONLY HEX: 0001
+CONSTANT: O_RDWR HEX: 0002
+CONSTANT: O_CREAT HEX: 0040
+CONSTANT: O_EXCL HEX: 0080
+CONSTANT: O_NOCTTY HEX: 0100
+CONSTANT: O_TRUNC HEX: 0200
+CONSTANT: O_APPEND HEX: 0400
+CONSTANT: O_NONBLOCK HEX: 0800
+
+ALIAS: O_NDELAY O_NONBLOCK
+
+CONSTANT: SOL_SOCKET 1
+
+CONSTANT: FD_SETSIZE 1024
+
+CONSTANT: SO_REUSEADDR 2
+CONSTANT: SO_OOBINLINE 10
+CONSTANT: SO_SNDTIMEO HEX: 15
+CONSTANT: SO_RCVTIMEO HEX: 14
+
+CONSTANT: F_SETFD 2
+CONSTANT: FD_CLOEXEC 1
+
+CONSTANT: F_SETFL 4
+
+STRUCT: addrinfo
+ { flags int }
+ { family int }
+ { socktype int }
+ { protocol int }
+ { addrlen socklen_t }
+ { addr void* }
+ { canonname char* }
+ { next addrinfo* } ;
+
+STRUCT: sockaddr-in
+ { family ushort }
+ { port ushort }
+ { addr in_addr_t }
+ { unused longlong } ;
+
+STRUCT: sockaddr-in6
+ { family ushort }
+ { port ushort }
+ { flowinfo uint }
+ { addr uchar[16] }
+ { scopeid uint } ;
+
+CONSTANT: max-un-path 108
+
+STRUCT: sockaddr-un
+ { family ushort }
+ { path { char max-un-path } } ;
+
+CONSTANT: SOCK_STREAM 1
+CONSTANT: SOCK_DGRAM 2
+
+CONSTANT: AF_UNSPEC 0
+CONSTANT: AF_UNIX 1
+CONSTANT: AF_INET 2
+CONSTANT: AF_INET6 10
+
+ALIAS: PF_UNSPEC AF_UNSPEC
+ALIAS: PF_UNIX AF_UNIX
+ALIAS: PF_INET AF_INET
+ALIAS: PF_INET6 AF_INET6
+
+CONSTANT: IPPROTO_TCP 6
+CONSTANT: IPPROTO_UDP 17
+
+CONSTANT: AI_PASSIVE 1
+
+CONSTANT: SEEK_SET 0
+CONSTANT: SEEK_CUR 1
+CONSTANT: SEEK_END 2
+
+STRUCT: passwd
+ { pw_name char* }
+ { pw_passwd char* }
+ { pw_uid uid_t }
+ { pw_gid gid_t }
+ { pw_gecos char* }
+ { pw_dir char* }
+ { pw_shell char* } ;
+
+! dirent64
+STRUCT: dirent
+ { d_ino ulonglong }
+ { d_off longlong }
+ { d_reclen ushort }
+ { d_type uchar }
+ { d_name char[256] } ;
+
+FUNCTION: int open64 ( char* path, int flags, int prot ) ;
+FUNCTION: dirent* readdir64 ( DIR* dirp ) ;
+FUNCTION: int readdir64_r ( void* dirp, dirent* entry, dirent** result ) ;
+
+CONSTANT: EPERM 1
+CONSTANT: ENOENT 2
+CONSTANT: ESRCH 3
+CONSTANT: EINTR 4
+CONSTANT: EIO 5
+CONSTANT: ENXIO 6
+CONSTANT: E2BIG 7
+CONSTANT: ENOEXEC 8
+CONSTANT: EBADF 9
+CONSTANT: ECHILD 10
+CONSTANT: EAGAIN 11
+CONSTANT: ENOMEM 12
+CONSTANT: EACCES 13
+CONSTANT: EFAULT 14
+CONSTANT: ENOTBLK 15
+CONSTANT: EBUSY 16
+CONSTANT: EEXIST 17
+CONSTANT: EXDEV 18
+CONSTANT: ENODEV 19
+CONSTANT: ENOTDIR 20
+CONSTANT: EISDIR 21
+CONSTANT: EINVAL 22
+CONSTANT: ENFILE 23
+CONSTANT: EMFILE 24
+CONSTANT: ENOTTY 25
+CONSTANT: ETXTBSY 26
+CONSTANT: EFBIG 27
+CONSTANT: ENOSPC 28
+CONSTANT: ESPIPE 29
+CONSTANT: EROFS 30
+CONSTANT: EMLINK 31
+CONSTANT: EPIPE 32
+CONSTANT: EDOM 33
+CONSTANT: ERANGE 34
+CONSTANT: EDEADLK 35
+CONSTANT: ENAMETOOLONG 36
+CONSTANT: ENOLCK 37
+CONSTANT: ENOSYS 38
+CONSTANT: ENOTEMPTY 39
+CONSTANT: ELOOP 40
+ALIAS: EWOULDBLOCK EAGAIN
+CONSTANT: ENOMSG 42
+CONSTANT: EIDRM 43
+CONSTANT: ECHRNG 44
+CONSTANT: EL2NSYNC 45
+CONSTANT: EL3HLT 46
+CONSTANT: EL3RST 47
+CONSTANT: ELNRNG 48
+CONSTANT: EUNATCH 49
+CONSTANT: ENOCSI 50
+CONSTANT: EL2HLT 51
+CONSTANT: EBADE 52
+CONSTANT: EBADR 53
+CONSTANT: EXFULL 54
+CONSTANT: ENOANO 55
+CONSTANT: EBADRQC 56
+CONSTANT: EBADSLT 57
+ALIAS: EDEADLOCK EDEADLK
+CONSTANT: EBFONT 59
+CONSTANT: ENOSTR 60
+CONSTANT: ENODATA 61
+CONSTANT: ETIME 62
+CONSTANT: ENOSR 63
+CONSTANT: ENONET 64
+CONSTANT: ENOPKG 65
+CONSTANT: EREMOTE 66
+CONSTANT: ENOLINK 67
+CONSTANT: EADV 68
+CONSTANT: ESRMNT 69
+CONSTANT: ECOMM 70
+CONSTANT: EPROTO 71
+CONSTANT: EMULTIHOP 72
+CONSTANT: EDOTDOT 73
+CONSTANT: EBADMSG 74
+CONSTANT: EOVERFLOW 75
+CONSTANT: ENOTUNIQ 76
+CONSTANT: EBADFD 77
+CONSTANT: EREMCHG 78
+CONSTANT: ELIBACC 79
+CONSTANT: ELIBBAD 80
+CONSTANT: ELIBSCN 81
+CONSTANT: ELIBMAX 82
+CONSTANT: ELIBEXEC 83
+CONSTANT: EILSEQ 84
+CONSTANT: ERESTART 85
+CONSTANT: ESTRPIPE 86
+CONSTANT: EUSERS 87
+CONSTANT: ENOTSOCK 88
+CONSTANT: EDESTADDRREQ 89
+CONSTANT: EMSGSIZE 90
+CONSTANT: EPROTOTYPE 91
+CONSTANT: ENOPROTOOPT 92
+CONSTANT: EPROTONOSUPPORT 93
+CONSTANT: ESOCKTNOSUPPORT 94
+CONSTANT: EOPNOTSUPP 95
+CONSTANT: EPFNOSUPPORT 96
+CONSTANT: EAFNOSUPPORT 97
+CONSTANT: EADDRINUSE 98
+CONSTANT: EADDRNOTAVAIL 99
+CONSTANT: ENETDOWN 100
+CONSTANT: ENETUNREACH 101
+CONSTANT: ENETRESET 102
+CONSTANT: ECONNABORTED 103
+CONSTANT: ECONNRESET 104
+CONSTANT: ENOBUFS 105
+CONSTANT: EISCONN 106
+CONSTANT: ENOTCONN 107
+CONSTANT: ESHUTDOWN 108
+CONSTANT: ETOOMANYREFS 109
+CONSTANT: ETIMEDOUT 110
+CONSTANT: ECONNREFUSED 111
+CONSTANT: EHOSTDOWN 112
+CONSTANT: EHOSTUNREACH 113
+CONSTANT: EALREADY 114
+CONSTANT: EINPROGRESS 115
+CONSTANT: ESTALE 116
+CONSTANT: EUCLEAN 117
+CONSTANT: ENOTNAM 118
+CONSTANT: ENAVAIL 119
+CONSTANT: EISNAM 120
+CONSTANT: EREMOTEIO 121
+CONSTANT: EDQUOT 122
+CONSTANT: ENOMEDIUM 123
+CONSTANT: EMEDIUMTYPE 124
+CONSTANT: ECANCELED 125
+CONSTANT: ENOKEY 126
+CONSTANT: EKEYEXPIRED 127
+CONSTANT: EKEYREVOKED 128
+CONSTANT: EKEYREJECTED 129
+CONSTANT: EOWNERDEAD 130
+CONSTANT: ENOTRECOVERABLE 131
--- /dev/null
+unportable
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2006 Patrick Mauritz.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types alien.syntax system kernel layouts ;
+IN: unix.ffi
+
+! Solaris.
+
+CONSTANT: O_RDONLY HEX: 0000
+CONSTANT: O_WRONLY HEX: 0001
+CONSTANT: O_RDWR HEX: 0002
+CONSTANT: O_APPEND HEX: 0008
+CONSTANT: O_CREAT HEX: 0100
+CONSTANT: O_TRUNC HEX: 0200
+
+CONSTANT: SEEK_END 2
+
+CONSTANT: SOL_SOCKET HEX: ffff
+
+: FD_SETSIZE ( -- n ) cell 4 = 1024 65536 ? ;
+
+CONSTANT: SO_REUSEADDR 4
+CONSTANT: SO_OOBINLINE HEX: 0100
+CONSTANT: SO_SNDTIMEO HEX: 1005
+CONSTANT: SO_RCVTIMEO HEX: 1006
+
+CONSTANT: F_SETFL 4 ! set file status flags
+CONSTANT: O_NONBLOCK HEX: 80 ! no delay
+
+STRUCT: addrinfo
+ { flags int }
+ { family int }
+ { socktype int }
+ { protocol int }
+! #ifdef __sparcv9
+! int _ai_pad;
+! #endif
+ { addrlen int }
+ { canonname char* }
+ { addr void* }
+ { next void* } ;
+
+STRUCT: sockaddr-in
+ { family ushort }
+ { port ushort }
+ { addr in_addr_t }
+ { unused longlong } ;
+
+STRUCT: sockaddr-in6
+ { family ushort }
+ { port ushort }
+ { flowinfo uint }
+ { addr uchar[16] }
+ { scopeid uint } ;
+
+CONSTANT: max-un-path 108
+
+STRUCT: sockaddr-un
+ { family ushort }
+ { path { "char" max-un-path } } ;
+
+CONSTANT: EINTR 4
+CONSTANT: EAGAIN 11
+CONSTANT: EINPROGRESS 150
+
+CONSTANT: SOCK_STREAM 2
+CONSTANT: SOCK_DGRAM 1
+
+CONSTANT: AF_UNSPEC 0
+CONSTANT: AF_UNIX 1
+CONSTANT: AF_INET 2
+CONSTANT: AF_INET6 26
+
+ALIAS: PF_UNSPEC AF_UNSPEC
+ALIAS: PF_UNIX AF_UNIX
+ALIAS: PF_INET AF_INET
+ALIAS: PF_INET6 AF_INET6
+
+CONSTANT: IPPROTO_TCP 6
+CONSTANT: IPPROTO_UDP 17
+
+CONSTANT: AI_PASSIVE 8
--- /dev/null
+unportable
--- /dev/null
+unportable
io.backend.unix kernel math sequences splitting strings
combinators.short-circuit byte-arrays combinators
accessors math.parser fry assocs namespaces continuations
-unix.users unix.utilities classes.struct ;
+unix.users unix.utilities classes.struct unix ;
IN: unix.groups
-QUALIFIED: unix
+QUALIFIED: unix.ffi
QUALIFIED: grouping
gr_mem>> utf8 alien>strings ;
: (group-struct) ( id -- group-struct id group-struct byte-array length void* )
- [ \ unix:group <struct> ] dip over 4096
+ [ \ unix.ffi:group <struct> ] dip over 4096
[ <byte-array> ] keep f <void*> ;
: check-group-struct ( group-struct ptr -- group-struct/f )
*void* [ drop f ] unless ;
M: integer group-struct ( id -- group/f )
- (group-struct) [ unix:getgrgid_r unix:io-error ] keep check-group-struct ;
+ (group-struct)
+ [ [ unix.ffi:getgrgid_r ] unix-system-call drop ] keep
+ check-group-struct ;
M: string group-struct ( string -- group/f )
- (group-struct) [ unix:getgrnam_r unix:io-error ] keep check-group-struct ;
+ (group-struct)
+ [ [ unix.ffi:getgrnam_r ] unix-system-call drop ] keep
+ check-group-struct ;
: group-struct>group ( group-struct -- group )
[ \ group new ] dip
: (user-groups) ( string -- seq )
#! first group is -1337, legacy unix code
- -1337 unix:NGROUPS_MAX [ 4 * <byte-array> ] keep
- <int> [ unix:getgrouplist unix:io-error ] 2keep
+ -1337 unix.ffi:NGROUPS_MAX [ 4 * <byte-array> ] keep
+ <int> [ [ unix.ffi:getgrouplist ] unix-system-call drop ] 2keep
[ 4 tail-slice ] [ *int 1 - ] bi* >groups ;
PRIVATE>
user-name (user-groups) ;
: all-groups ( -- seq )
- [ unix:getgrent dup ] [ \ unix:group memory>struct group-struct>group ] produce nip ;
+ [ unix.ffi:getgrent dup ] [ \ unix.ffi:group memory>struct group-struct>group ] produce nip ;
: <group-cache> ( -- assoc )
all-groups [ [ id>> ] keep ] H{ } map>assoc ;
: with-group-cache ( quot -- )
[ <group-cache> group-cache ] dip with-variable ; inline
-: real-group-id ( -- id ) unix:getgid ; inline
+: real-group-id ( -- id ) unix.ffi:getgid ; inline
: real-group-name ( -- string ) real-group-id group-name ; inline
-: effective-group-id ( -- string ) unix:getegid ; inline
+: effective-group-id ( -- string ) unix.ffi:getegid ; inline
: effective-group-name ( -- string )
effective-group-id group-name ; inline
<PRIVATE
: (set-real-group) ( id -- )
- unix:setgid unix:io-error ; inline
+ [ unix.ffi:setgid ] unix-system-call drop ; inline
: (set-effective-group) ( id -- )
- unix:setegid unix:io-error ; inline
+ [ unix.ffi:setegid ] unix-system-call drop ; inline
PRIVATE>
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types alien.syntax alien system classes.struct
-unix.types ;
-IN: unix
-
-! Linux.
-
-CONSTANT: MAXPATHLEN 1024
-
-CONSTANT: O_RDONLY HEX: 0000
-CONSTANT: O_WRONLY HEX: 0001
-CONSTANT: O_RDWR HEX: 0002
-CONSTANT: O_CREAT HEX: 0040
-CONSTANT: O_EXCL HEX: 0080
-CONSTANT: O_NOCTTY HEX: 0100
-CONSTANT: O_TRUNC HEX: 0200
-CONSTANT: O_APPEND HEX: 0400
-CONSTANT: O_NONBLOCK HEX: 0800
-
-ALIAS: O_NDELAY O_NONBLOCK
-
-CONSTANT: SOL_SOCKET 1
-
-CONSTANT: FD_SETSIZE 1024
-
-CONSTANT: SO_REUSEADDR 2
-CONSTANT: SO_OOBINLINE 10
-CONSTANT: SO_SNDTIMEO HEX: 15
-CONSTANT: SO_RCVTIMEO HEX: 14
-
-CONSTANT: F_SETFD 2
-CONSTANT: FD_CLOEXEC 1
-
-CONSTANT: F_SETFL 4
-
-STRUCT: addrinfo
- { flags int }
- { family int }
- { socktype int }
- { protocol int }
- { addrlen socklen_t }
- { addr void* }
- { canonname char* }
- { next addrinfo* } ;
-
-STRUCT: sockaddr-in
- { family ushort }
- { port ushort }
- { addr in_addr_t }
- { unused longlong } ;
-
-STRUCT: sockaddr-in6
- { family ushort }
- { port ushort }
- { flowinfo uint }
- { addr uchar[16] }
- { scopeid uint } ;
-
-CONSTANT: max-un-path 108
-
-STRUCT: sockaddr-un
- { family ushort }
- { path { char max-un-path } } ;
-
-CONSTANT: SOCK_STREAM 1
-CONSTANT: SOCK_DGRAM 2
-
-CONSTANT: AF_UNSPEC 0
-CONSTANT: AF_UNIX 1
-CONSTANT: AF_INET 2
-CONSTANT: AF_INET6 10
-
-ALIAS: PF_UNSPEC AF_UNSPEC
-ALIAS: PF_UNIX AF_UNIX
-ALIAS: PF_INET AF_INET
-ALIAS: PF_INET6 AF_INET6
-
-CONSTANT: IPPROTO_TCP 6
-CONSTANT: IPPROTO_UDP 17
-
-CONSTANT: AI_PASSIVE 1
-
-CONSTANT: SEEK_SET 0
-CONSTANT: SEEK_CUR 1
-CONSTANT: SEEK_END 2
-
-STRUCT: passwd
- { pw_name char* }
- { pw_passwd char* }
- { pw_uid uid_t }
- { pw_gid gid_t }
- { pw_gecos char* }
- { pw_dir char* }
- { pw_shell char* } ;
-
-! dirent64
-STRUCT: dirent
- { d_ino ulonglong }
- { d_off longlong }
- { d_reclen ushort }
- { d_type uchar }
- { d_name char[256] } ;
-
-FUNCTION: int open64 ( char* path, int flags, int prot ) ;
-FUNCTION: dirent* readdir64 ( DIR* dirp ) ;
-FUNCTION: int readdir64_r ( void* dirp, dirent* entry, dirent** result ) ;
+USING: system unix unix.ffi unix.ffi.linux ;
+IN: unix.linux
M: linux open-file [ open64 ] unix-system-call ;
-
-CONSTANT: EPERM 1
-CONSTANT: ENOENT 2
-CONSTANT: ESRCH 3
-CONSTANT: EINTR 4
-CONSTANT: EIO 5
-CONSTANT: ENXIO 6
-CONSTANT: E2BIG 7
-CONSTANT: ENOEXEC 8
-CONSTANT: EBADF 9
-CONSTANT: ECHILD 10
-CONSTANT: EAGAIN 11
-CONSTANT: ENOMEM 12
-CONSTANT: EACCES 13
-CONSTANT: EFAULT 14
-CONSTANT: ENOTBLK 15
-CONSTANT: EBUSY 16
-CONSTANT: EEXIST 17
-CONSTANT: EXDEV 18
-CONSTANT: ENODEV 19
-CONSTANT: ENOTDIR 20
-CONSTANT: EISDIR 21
-CONSTANT: EINVAL 22
-CONSTANT: ENFILE 23
-CONSTANT: EMFILE 24
-CONSTANT: ENOTTY 25
-CONSTANT: ETXTBSY 26
-CONSTANT: EFBIG 27
-CONSTANT: ENOSPC 28
-CONSTANT: ESPIPE 29
-CONSTANT: EROFS 30
-CONSTANT: EMLINK 31
-CONSTANT: EPIPE 32
-CONSTANT: EDOM 33
-CONSTANT: ERANGE 34
-CONSTANT: EDEADLK 35
-CONSTANT: ENAMETOOLONG 36
-CONSTANT: ENOLCK 37
-CONSTANT: ENOSYS 38
-CONSTANT: ENOTEMPTY 39
-CONSTANT: ELOOP 40
-ALIAS: EWOULDBLOCK EAGAIN
-CONSTANT: ENOMSG 42
-CONSTANT: EIDRM 43
-CONSTANT: ECHRNG 44
-CONSTANT: EL2NSYNC 45
-CONSTANT: EL3HLT 46
-CONSTANT: EL3RST 47
-CONSTANT: ELNRNG 48
-CONSTANT: EUNATCH 49
-CONSTANT: ENOCSI 50
-CONSTANT: EL2HLT 51
-CONSTANT: EBADE 52
-CONSTANT: EBADR 53
-CONSTANT: EXFULL 54
-CONSTANT: ENOANO 55
-CONSTANT: EBADRQC 56
-CONSTANT: EBADSLT 57
-ALIAS: EDEADLOCK EDEADLK
-CONSTANT: EBFONT 59
-CONSTANT: ENOSTR 60
-CONSTANT: ENODATA 61
-CONSTANT: ETIME 62
-CONSTANT: ENOSR 63
-CONSTANT: ENONET 64
-CONSTANT: ENOPKG 65
-CONSTANT: EREMOTE 66
-CONSTANT: ENOLINK 67
-CONSTANT: EADV 68
-CONSTANT: ESRMNT 69
-CONSTANT: ECOMM 70
-CONSTANT: EPROTO 71
-CONSTANT: EMULTIHOP 72
-CONSTANT: EDOTDOT 73
-CONSTANT: EBADMSG 74
-CONSTANT: EOVERFLOW 75
-CONSTANT: ENOTUNIQ 76
-CONSTANT: EBADFD 77
-CONSTANT: EREMCHG 78
-CONSTANT: ELIBACC 79
-CONSTANT: ELIBBAD 80
-CONSTANT: ELIBSCN 81
-CONSTANT: ELIBMAX 82
-CONSTANT: ELIBEXEC 83
-CONSTANT: EILSEQ 84
-CONSTANT: ERESTART 85
-CONSTANT: ESTRPIPE 86
-CONSTANT: EUSERS 87
-CONSTANT: ENOTSOCK 88
-CONSTANT: EDESTADDRREQ 89
-CONSTANT: EMSGSIZE 90
-CONSTANT: EPROTOTYPE 91
-CONSTANT: ENOPROTOOPT 92
-CONSTANT: EPROTONOSUPPORT 93
-CONSTANT: ESOCKTNOSUPPORT 94
-CONSTANT: EOPNOTSUPP 95
-CONSTANT: EPFNOSUPPORT 96
-CONSTANT: EAFNOSUPPORT 97
-CONSTANT: EADDRINUSE 98
-CONSTANT: EADDRNOTAVAIL 99
-CONSTANT: ENETDOWN 100
-CONSTANT: ENETUNREACH 101
-CONSTANT: ENETRESET 102
-CONSTANT: ECONNABORTED 103
-CONSTANT: ECONNRESET 104
-CONSTANT: ENOBUFS 105
-CONSTANT: EISCONN 106
-CONSTANT: ENOTCONN 107
-CONSTANT: ESHUTDOWN 108
-CONSTANT: ETOOMANYREFS 109
-CONSTANT: ETIMEDOUT 110
-CONSTANT: ECONNREFUSED 111
-CONSTANT: EHOSTDOWN 112
-CONSTANT: EHOSTUNREACH 113
-CONSTANT: EALREADY 114
-CONSTANT: EINPROGRESS 115
-CONSTANT: ESTALE 116
-CONSTANT: EUCLEAN 117
-CONSTANT: ENOTNAM 118
-CONSTANT: ENAVAIL 119
-CONSTANT: EISNAM 120
-CONSTANT: EREMOTEIO 121
-CONSTANT: EDQUOT 122
-CONSTANT: ENOMEDIUM 123
-CONSTANT: EMEDIUMTYPE 124
-CONSTANT: ECANCELED 125
-CONSTANT: ENOKEY 126
-CONSTANT: EKEYEXPIRED 127
-CONSTANT: EKEYREVOKED 128
-CONSTANT: EKEYREJECTED 129
-CONSTANT: EOWNERDEAD 130
-CONSTANT: ENOTRECOVERABLE 131
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2006 Patrick Mauritz.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types alien.syntax system kernel layouts ;
-IN: unix
-
-! Solaris.
-
-CONSTANT: O_RDONLY HEX: 0000
-CONSTANT: O_WRONLY HEX: 0001
-CONSTANT: O_RDWR HEX: 0002
-CONSTANT: O_APPEND HEX: 0008
-CONSTANT: O_CREAT HEX: 0100
-CONSTANT: O_TRUNC HEX: 0200
-
-CONSTANT: SEEK_END 2
-
-CONSTANT: SOL_SOCKET HEX: ffff
-
-: FD_SETSIZE ( -- n ) cell 4 = 1024 65536 ? ;
-
-CONSTANT: SO_REUSEADDR 4
-CONSTANT: SO_OOBINLINE HEX: 0100
-CONSTANT: SO_SNDTIMEO HEX: 1005
-CONSTANT: SO_RCVTIMEO HEX: 1006
-
-CONSTANT: F_SETFL 4 ! set file status flags
-CONSTANT: O_NONBLOCK HEX: 80 ! no delay
-
-STRUCT: addrinfo
- { flags int }
- { family int }
- { socktype int }
- { protocol int }
-! #ifdef __sparcv9
-! int _ai_pad;
-! #endif
- { addrlen int }
- { canonname char* }
- { addr void* }
- { next void* } ;
-
-STRUCT: sockaddr-in
- { family ushort }
- { port ushort }
- { addr in_addr_t }
- { unused longlong } ;
-
-STRUCT: sockaddr-in6
- { family ushort }
- { port ushort }
- { flowinfo uint }
- { addr uchar[16] }
- { scopeid uint } ;
-
-: max-un-path 108 ;
-
-STRUCT: sockaddr-un
- { family ushort }
- { path { "char" max-un-path } } ;
-
-CONSTANT: EINTR 4
-CONSTANT: EAGAIN 11
-CONSTANT: EINPROGRESS 150
-
-CONSTANT: SOCK_STREAM 2
-CONSTANT: SOCK_DGRAM 1
-
-CONSTANT: AF_UNSPEC 0
-CONSTANT: AF_UNIX 1
-CONSTANT: AF_INET 2
-CONSTANT: AF_INET6 26
-
-ALIAS: PF_UNSPEC AF_UNSPEC
-ALIAS: PF_UNIX AF_UNIX
-ALIAS: PF_INET AF_INET
-ALIAS: PF_INET6 AF_INET6
-
-CONSTANT: IPPROTO_TCP 6
-CONSTANT: IPPROTO_UDP 17
-
-CONSTANT: AI_PASSIVE 8
+++ /dev/null
-unportable
USING: alien.c-types arrays accessors combinators classes.struct
-alien.syntax unix.time unix.types ;
+alien.syntax unix.time unix.types unix.ffi ;
IN: unix.stat
! Mac OS X
USING: alien.c-types io.encodings.utf8 io.encodings.string
kernel sequences unix.stat accessors unix combinators math
grouping system alien.strings math.bitwise alien.syntax
-unix.types classes.struct ;
+unix.types classes.struct unix.ffi ;
IN: unix.statfs.macosx
CONSTANT: MNT_RDONLY HEX: 00000001
! Copyright (C) 2005, 2010 Slava Pestov.
! Copyright (C) 2008 Eduardo Cavazos.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.syntax kernel libc sequences
-continuations byte-arrays strings math namespaces system
-combinators combinators.smart vocabs.loader accessors
-stack-checker macros locals generalizations unix.types io vocabs
-classes.struct unix.time alien.libraries ;
+USING: accessors alien alien.c-types alien.libraries
+alien.syntax byte-arrays classes.struct combinators
+combinators.short-circuit combinators.smart continuations
+generalizations io kernel libc locals macros math namespaces
+sequences stack-checker strings system unix.time unix.types
+vocabs vocabs.loader unix.ffi ;
IN: unix
-CONSTANT: PROT_NONE 0
-CONSTANT: PROT_READ 1
-CONSTANT: PROT_WRITE 2
-CONSTANT: PROT_EXEC 4
-
-CONSTANT: MAP_FILE 0
-CONSTANT: MAP_SHARED 1
-CONSTANT: MAP_PRIVATE 2
-
-CONSTANT: SEEK_SET 0
-CONSTANT: SEEK_CUR 1
-CONSTANT: SEEK_END 2
-
-: MAP_FAILED ( -- alien ) -1 <alien> ; inline
-
-CONSTANT: NGROUPS_MAX 16
-
-CONSTANT: DT_UNKNOWN 0
-CONSTANT: DT_FIFO 1
-CONSTANT: DT_CHR 2
-CONSTANT: DT_DIR 4
-CONSTANT: DT_BLK 6
-CONSTANT: DT_REG 8
-CONSTANT: DT_LNK 10
-CONSTANT: DT_SOCK 12
-CONSTANT: DT_WHT 14
-
-LIBRARY: libc
-
-FUNCTION: char* strerror ( int errno ) ;
-
ERROR: unix-error errno message ;
: (io-error) ( -- * ) errno dup strerror unix-error ;
ERROR: unix-system-call-error args errno message word ;
+: unix-call-failed? ( ret -- ? )
+ {
+ [ { [ integer? ] [ 0 < ] } 1&& ]
+ [ not ]
+ } 1|| ;
+
MACRO:: unix-system-call ( quot -- )
quot inputs :> n
quot first :> word
+ 0 :> ret!
+ f :> failed!
[
- n ndup quot call dup 0 < [
- drop
+ [
+ n ndup quot call ret!
+ ret {
+ [ unix-call-failed? dup failed! ]
+ [ drop errno EINTR = ]
+ } 1&&
+ ] loop
+ failed [
n narray
errno dup strerror
word unix-system-call-error
] [
- n nnip
+ n ndrop
+ ret
] if
] ;
HOOK: open-file os ( path flags mode -- fd )
-<<
-
-{
- { [ os linux? ] [ "unix.linux" require ] }
- { [ os bsd? ] [ "unix.bsd" require ] }
- { [ os solaris? ] [ "unix.solaris" require ] }
-} cond
-
-"debugger" vocab [
- "unix.debugger" require
-] when
-
->>
-
-STRUCT: group
- { gr_name char* }
- { gr_passwd char* }
- { gr_gid int }
- { gr_mem char** } ;
-
-FUNCTION: int accept ( int s, void* sockaddr, socklen_t* socklen ) ;
-FUNCTION: int bind ( int s, void* name, socklen_t namelen ) ;
-FUNCTION: int chdir ( char* path ) ;
-FUNCTION: int chmod ( char* path, mode_t mode ) ;
-FUNCTION: int fchmod ( int fd, mode_t mode ) ;
-FUNCTION: int chown ( char* path, uid_t owner, gid_t group ) ;
-FUNCTION: int chroot ( char* path ) ;
-
-FUNCTION: int close ( int fd ) ;
-FUNCTION: int closedir ( DIR* dirp ) ;
-
: close-file ( fd -- ) [ close ] unix-system-call drop ;
-FUNCTION: int connect ( int s, void* name, socklen_t namelen ) ;
-FUNCTION: int dup2 ( int oldd, int newd ) ;
-! FUNCTION: int dup ( int oldd ) ;
: _exit ( status -- * )
#! We throw to give this a terminating stack effect.
int f "_exit" { int } alien-invoke "Exit failed" throw ;
-FUNCTION: void endpwent ( ) ;
-FUNCTION: int fchdir ( int fd ) ;
-FUNCTION: int fchown ( int fd, uid_t owner, gid_t group ) ;
-FUNCTION: int fcntl ( int fd, int cmd, int arg ) ;
-FUNCTION: int flock ( int fd, int operation ) ;
-FUNCTION: void freeaddrinfo ( addrinfo* ai ) ;
-FUNCTION: int futimes ( int id, timeval[2] times ) ;
-FUNCTION: char* gai_strerror ( int ecode ) ;
-FUNCTION: int getaddrinfo ( char* hostname, char* servname, addrinfo* hints, addrinfo** res ) ;
-FUNCTION: char* getcwd ( char* buf, size_t size ) ;
-FUNCTION: pid_t getpid ;
-FUNCTION: int getdtablesize ;
-FUNCTION: gid_t getegid ;
-FUNCTION: uid_t geteuid ;
-FUNCTION: gid_t getgid ;
-FUNCTION: char* getenv ( char* name ) ;
-
-FUNCTION: int getgrgid_r ( gid_t gid, group* grp, char* buffer, size_t bufsize, group** result ) ;
-FUNCTION: int getgrnam_r ( char* name, group* grp, char* buffer, size_t bufsize, group** result ) ;
-FUNCTION: passwd* getpwent ( ) ;
-FUNCTION: passwd* getpwuid ( uid_t uid ) ;
-FUNCTION: passwd* getpwnam ( char* login ) ;
-FUNCTION: int getpwnam_r ( char* login, passwd* pwd, char* buffer, size_t bufsize, passwd** result ) ;
-FUNCTION: int getgroups ( int gidsetlen, gid_t* gidset ) ;
-FUNCTION: int getgrouplist ( char* name, int basegid, int* groups, int* ngroups ) ;
-FUNCTION: int getrlimit ( int resource, rlimit* rlp ) ;
-FUNCTION: int setrlimit ( int resource, rlimit* rlp ) ;
-
-FUNCTION: int getpriority ( int which, id_t who ) ;
-FUNCTION: int setpriority ( int which, id_t who, int prio ) ;
-
-FUNCTION: int getrusage ( int who, rusage* r_usage ) ;
-
-FUNCTION: group* getgrent ;
-FUNCTION: int gethostname ( char* name, int len ) ;
-FUNCTION: int getsockname ( int socket, sockaddr* address, socklen_t* address_len ) ;
-FUNCTION: int getpeername ( int socket, sockaddr* address, socklen_t* address_len ) ;
-FUNCTION: uid_t getuid ;
-FUNCTION: uint htonl ( uint n ) ;
-FUNCTION: ushort htons ( ushort n ) ;
-! FUNCTION: int issetugid ;
-FUNCTION: int ioctl ( int fd, ulong request, char* argp ) ;
-FUNCTION: int lchown ( char* path, uid_t owner, gid_t group ) ;
-FUNCTION: int listen ( int s, int backlog ) ;
-FUNCTION: off_t lseek ( int fildes, off_t offset, int whence ) ;
-FUNCTION: int mkdir ( char* path, mode_t mode ) ;
-FUNCTION: void* mmap ( void* addr, size_t len, int prot, int flags, int fd, off_t offset ) ;
-FUNCTION: int munmap ( void* addr, size_t len ) ;
-FUNCTION: uint ntohl ( uint n ) ;
-FUNCTION: ushort ntohs ( ushort n ) ;
-FUNCTION: int shutdown ( int fd, int how ) ;
-
-FUNCTION: int open ( char* path, int flags, int prot ) ;
M: unix open-file [ open ] unix-system-call ;
-FUNCTION: DIR* opendir ( char* path ) ;
-
-STRUCT: utimbuf
- { actime time_t }
- { modtime time_t } ;
-
-FUNCTION: int utime ( char* path, utimbuf* buf ) ;
-
: touch ( filename -- ) f [ utime ] unix-system-call drop ;
: change-file-times ( filename access modification -- )
swap >>actime
[ utime ] unix-system-call drop ;
-FUNCTION: int pclose ( void* file ) ;
-FUNCTION: int pipe ( int* filedes ) ;
-FUNCTION: void* popen ( char* command, char* type ) ;
-FUNCTION: ssize_t read ( int fd, void* buf, size_t nbytes ) ;
-
-FUNCTION: dirent* readdir ( DIR* dirp ) ;
-FUNCTION: int readdir_r ( void* dirp, dirent* entry, dirent** result ) ;
-FUNCTION: ssize_t readlink ( char* path, char* buf, size_t bufsize ) ;
-
-CONSTANT: PATH_MAX 1024
-
: read-symbolic-link ( path -- path )
PATH_MAX <byte-array> dup [
PATH_MAX
[ readlink ] unix-system-call
] dip swap head-slice >string ;
-FUNCTION: ssize_t recv ( int s, void* buf, size_t nbytes, int flags ) ;
-FUNCTION: ssize_t recvfrom ( int s, void* buf, size_t nbytes, int flags, sockaddr-in* from, socklen_t* fromlen ) ;
-FUNCTION: int rename ( char* from, char* to ) ;
-FUNCTION: int rmdir ( char* path ) ;
-FUNCTION: int select ( int nfds, void* readfds, void* writefds, void* exceptfds, timeval* timeout ) ;
-FUNCTION: ssize_t sendto ( int s, void* buf, size_t len, int flags, sockaddr-in* to, socklen_t tolen ) ;
-FUNCTION: int setenv ( char* name, char* value, int overwrite ) ;
-FUNCTION: int unsetenv ( char* name ) ;
-FUNCTION: int setegid ( gid_t egid ) ;
-FUNCTION: int seteuid ( uid_t euid ) ;
-FUNCTION: int setgid ( gid_t gid ) ;
-FUNCTION: int setgroups ( int ngroups, gid_t* gidset ) ;
-FUNCTION: int setregid ( gid_t rgid, gid_t egid ) ;
-FUNCTION: int setreuid ( uid_t ruid, uid_t euid ) ;
-FUNCTION: int setsockopt ( int s, int level, int optname, void* optval, socklen_t optlen ) ;
-FUNCTION: int setuid ( uid_t uid ) ;
-FUNCTION: int socket ( int domain, int type, int protocol ) ;
-FUNCTION: int symlink ( char* path1, char* path2 ) ;
-FUNCTION: int link ( char* path1, char* path2 ) ;
-FUNCTION: int system ( char* command ) ;
-
-FUNCTION: int unlink ( char* path ) ;
-
: unlink-file ( path -- ) [ unlink ] unix-system-call drop ;
-FUNCTION: int utimes ( char* path, timeval[2] times ) ;
+<<
-FUNCTION: ssize_t write ( int fd, void* buf, size_t nbytes ) ;
+"debugger" vocab [
+ "unix.debugger" require
+] when
-"librt" "librt.so" "cdecl" add-library
+>>
io.backend.unix kernel math sequences splitting strings
combinators.short-circuit grouping byte-arrays combinators
accessors math.parser fry assocs namespaces continuations
-vocabs.loader system classes.struct ;
+vocabs.loader system classes.struct unix ;
IN: unix.users
-QUALIFIED: unix
+QUALIFIED: unix.ffi
TUPLE: passwd user-name password uid gid gecos dir shell ;
} cleave ;
: with-pwent ( quot -- )
- [ unix:endpwent ] [ ] cleanup ; inline
+ [ unix.ffi:endpwent ] [ ] cleanup ; inline
PRIVATE>
: all-users ( -- seq )
[
- [ unix:getpwent dup ] [ unix:passwd memory>struct passwd>new-passwd ] produce nip
+ [ unix.ffi:getpwent dup ] [ unix.ffi:passwd memory>struct passwd>new-passwd ] produce nip
] with-pwent ;
SYMBOL: user-cache
M: integer user-passwd ( id -- passwd/f )
user-cache get
- [ at ] [ unix:getpwuid [ unix:passwd memory>struct passwd>new-passwd ] [ f ] if* ] if* ;
+ [ at ] [ unix.ffi:getpwuid [ unix.ffi:passwd memory>struct passwd>new-passwd ] [ f ] if* ] if* ;
M: string user-passwd ( string -- passwd/f )
- unix:getpwnam dup [ unix:passwd memory>struct passwd>new-passwd ] when ;
+ unix.ffi:getpwnam dup [ unix.ffi:passwd memory>struct passwd>new-passwd ] when ;
: user-name ( id -- string )
dup user-passwd
user-passwd uid>> ;
: real-user-id ( -- id )
- unix:getuid ; inline
+ unix.ffi:getuid ; inline
: real-user-name ( -- string )
real-user-id user-name ; inline
: effective-user-id ( -- id )
- unix:geteuid ; inline
+ unix.ffi:geteuid ; inline
: effective-user-name ( -- string )
effective-user-id user-name ; inline
<PRIVATE
: (set-real-user) ( id -- )
- unix:setuid unix:io-error ; inline
+ [ unix.ffi:setuid ] unix-system-call drop ; inline
: (set-effective-user) ( id -- )
- unix:seteuid unix:io-error ; inline
+ [ unix.ffi:seteuid ] unix-system-call drop ; inline
PRIVATE>
--- /dev/null
+unportable
{ refresh refresh-all } related-words
ARTICLE: "vocabs.refresh" "Runtime code reloading"
-"Reloading source files changed on disk:"
+"The " { $vocab-link "vocabs.refresh" } " vocabulary implements automatic reloading of changed source files."
+$nl
+"With the help of the " { $vocab-link "io.monitors" } " vocabulary, loaded source files across all vocabulary roots are monitored for changes on disk."
+$nl
+"If a change to a source file is detected, the next invocation of " { $link refresh-all } " will compare the file's checksum against its previous value, reloading the file if necessary. This takes advantage of the fact that the " { $vocab-link "source-files" } " vocabulary records CRC32 checksums of source files that have been parsed by " { $link "parser" } "."
+$nl
+"Words for reloading source files:"
{ $subsections
refresh
refresh-all
USING: alien.c-types alien.syntax classes.struct windows.com
-windows.com.syntax windows.directx.d3dbasetypes windows.directx.dcommon
+windows.com.syntax windows.directx.d2dbasetypes windows.directx.dcommon
windows.directx.dxgi windows.directx.dxgiformat windows.ole32 windows.types ;
IN: windows.directx.d2d1
USING: alien.syntax classes.struct windows.types ;
-IN: windows.directx.d3dbasetypes
+IN: windows.directx.d2dbasetypes
STRUCT: D3DCOLORVALUE
{ r FLOAT }
USING: alien.syntax alien.c-types classes.struct windows.types
windows.directx.d3d10shader windows.directx.d3d10
-windows.directx.d3d11 windows.com windows.com.syntax ;
+windows.directx.d3d11 windows.com windows.com.syntax
+windows.directx.d3dcommon ;
IN: windows.directx.d3d11shader
LIBRARY: d3d11
USING: alien.c-types alien.syntax classes.struct windows.com
windows.com.syntax windows.directx.d3d10
-windows.directx.d3d10misc windows.types ;
+windows.directx.d3d10misc windows.types windows.directx.d3dx10math ;
IN: windows.directx.d3dx10mesh
LIBRARY: d3dx10
(assoc-each) each ; inline
: assoc>map ( assoc quot exemplar -- seq )
- [ accumulator [ assoc-each ] dip ] dip like ; inline
+ [ collector [ assoc-each ] dip ] dip like ; inline
: assoc-map-as ( assoc quot exemplar -- newassoc )
[ [ 2array ] compose V{ } assoc>map ] dip assoc-like ; inline
{ "gc" "memory" "primitive_full_gc" (( -- )) }
{ "minor-gc" "memory" "primitive_minor_gc" (( -- )) }
{ "size" "memory" "primitive_size" (( obj -- n )) }
- { "(save-image)" "memory.private" "primitive_save_image" (( path -- )) }
- { "(save-image-and-exit)" "memory.private" "primitive_save_image_and_exit" (( path -- )) }
+ { "(save-image)" "memory.private" "primitive_save_image" (( path1 path2 -- )) }
+ { "(save-image-and-exit)" "memory.private" "primitive_save_image_and_exit" (( path1 path2 -- )) }
{ "jit-compile" "quotations" "primitive_jit_compile" (( quot -- )) }
{ "quot-compiled?" "quotations" "primitive_quot_compiled_p" (( quot -- ? )) }
{ "quotation-code" "quotations" "primitive_quotation_code" (( quot -- start end )) }
input-stream get swap each-stream-line ; inline
: stream-lines ( stream -- seq )
- [ [ ] accumulator [ each-stream-line ] dip { } like ] with-disposal ;
+ [ [ ] collector [ each-stream-line ] dip { } like ] with-disposal ;
: lines ( -- seq )
input-stream get stream-lines ; inline
{ $code "'[ 2 _ + ]" } ;
ARTICLE: "namespaces-make" "Making sequences with variables"
-"The " { $vocab-link "make" } " vocabulary implements a facility for constructing sequences by holding an accumulator sequence in a variable. Storing the accumulator sequence in a variable rather than the stack may allow code to be written with less stack manipulation."
+"The " { $vocab-link "make" } " vocabulary implements a facility for constructing sequences by holding an collector sequence in a variable. Storing the collector sequence in a variable rather than the stack may allow code to be written with less stack manipulation."
$nl
"Sequence construction is wrapped in a combinator:"
{ $subsections make }
%
#
}
-"The accumulator sequence can be accessed directly from inside a " { $link make } ":"
+"The collector sequence can be accessed directly from inside a " { $link make } ":"
{ $subsections building }
{ $example
"USING: make math.parser ;"
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel continuations sequences system
-io.backend alien.strings memory.private ;
+USING: alien.strings io.backend io.pathnames kernel
+memory.private sequences system ;
IN: memory
: instances ( quot -- seq )
[ all-instances ] dip filter ; inline
+: saving-path ( path -- saving-path path )
+ [ ".saving" append ] keep
+ [ native-string>alien ] bi@ ;
+
: save-image ( path -- )
- normalize-path native-string>alien (save-image) ;
+ normalize-path saving-path (save-image) ;
: save-image-and-exit ( path -- )
- normalize-path native-string>alien (save-image-and-exit) ;
+ normalize-path saving-path (save-image-and-exit) ;
: save ( -- ) image save-image ;
"word-search-parsing"
} ;
-ARTICLE: "parser-files" "Parsing source files"
-"The parser can run source files:"
-{ $subsections
- run-file
- parse-file
-}
-"The parser cross-references source files and definitions. This allows it to keep track of removed definitions, and prevent forward references and accidental redefinitions."
-$nl
-"While the above words are useful for one-off experiments, real programs should be written to use the vocabulary system instead; see " { $link "vocabs.loader" } "."
-{ $see-also "source-files" } ;
-
ARTICLE: "top-level-forms" "Top level forms"
"Any code outside of a definition is known as a " { $emphasis "top-level form" } "; top-level forms are run after the entire source file has been parsed, regardless of their position in the file."
$nl
"Also, top-level forms run in a new dynamic scope, so using " { $link set } " to store values is almost always wrong, since the values will be lost after the top-level form completes. To save values computed by a top-level form, either use " { $link set-global } " or define a new word with the value." ;
ARTICLE: "parser" "The parser"
-"This parser is a general facility for reading textual representations of objects and definitions. The parser is implemented in the " { $vocab-link "parser" } " and " { $vocab-link "syntax" } " vocabularies."
+"The Factor parser reading textual representations of objects and definitions, with all syntax determined by " { $link "parsing-words" } ". The parser is implemented in the " { $vocab-link "parser" } " vocabulary, with standard syntax in the " { $vocab-link "syntax" } " vocabulary. See " { $link "syntax" } " for a description of standard syntax."
+$nl
+"The parser cross-references " { $link "source-files" } " and " { $link "definitions" } ". This functionality is used for improved error checking, as well as tools such as " { $link "tools.crossref" } " and " { $link "editor" } "."
+$nl
+"The parser can be invoked reflectively, to run strings and source files."
+{ $subsections
+ "eval"
+ run-file
+ parse-file
+}
+"If Factor is run from the command line with a script file supplied as an argument, the script is run using " { $link run-file } ". See " { $link "cli" } "."
$nl
-"This section concerns itself with usage and extension of the parser. Standard syntax is described in " { $link "syntax" } "."
-{ $subsections "parser-files" }
-"The parser can be extended."
-{ $subsections "parser-lexer" }
-"The parser can be invoked reflectively;"
-{ $subsections parse-stream }
+"While " { $link run-file } " can be used interactively in the listener to load user code into the session, this should only be done for quick one-off scripts, and real programs should instead rely on the automatic " { $link "vocabs.loader" } "."
{ $see-also "parsing-words" "definitions" "definition-checking" } ;
ABOUT: "parser"
HELP: with-file-vocabs
{ $values { "quot" quotation } }
-{ $description "Calls the quotation in a scope with the initial the vocabulary search path for parsing a file. This consists of just the " { $snippet "syntax" } " vocabulary." } ;
+{ $description "Calls the quotation in a scope with an initial vocabulary search path consisting of just the " { $snippet "syntax" } " vocabulary." } ;
HELP: parse-fresh
{ $values { "lines" "a sequence of strings" } { "quot" quotation } }
"50"
} ;
-HELP: pusher
+HELP: selector
{ $values
{ "quot" "a predicate quotation" }
{ "quot" quotation } { "accum" vector } }
-{ $description "Creates a new vector to accumulate the values which return true for a predicate. Returns a new quotation which accepts an object to be tested and stored in the accumulator if the test yields true. The accumulator is left on the stack for convenience." }
+{ $description "Creates a new vector to accumulate the values which return true for a predicate. Returns a new quotation which accepts an object to be tested and stored in the collector if the test yields true. The collector is left on the stack for convenience." }
{ $example "! Find all the even numbers:" "USING: prettyprint sequences math kernel ;"
- "10 iota [ even? ] pusher [ each ] dip ."
+ "10 iota [ even? ] selector [ each ] dip ."
"V{ 0 2 4 6 8 }"
}
-{ $notes "Used to implement the " { $link filter } " word. Compare this word with " { $link accumulator } ", which is an unfiltering version." } ;
+{ $notes "Used to implement the " { $link filter } " word. Compare this word with " { $link collector } ", which is an unfiltering version." } ;
HELP: trim-head
{ $values
"1290"
} } ;
-HELP: 2pusher
+HELP: 2selector
{ $values
{ "quot" quotation }
{ "quot" quotation } { "accum1" vector } { "accum2" vector } }
"T{ slice { from 1 } { to 2 } { seq { 1 2 } } }\nT{ slice { from 1 } { to 2 } { seq { 3 4 } } }\n1\n3"
} } ;
-HELP: accumulator
+HELP: collector
{ $values
{ "quot" quotation }
{ "quot'" quotation } { "vec" vector } }
{ $description "Creates a new quotation that pushes its result to a vector and outputs that vector on the stack." }
{ $examples { $example "USING: sequences prettyprint kernel math ;"
- "{ 1 2 } [ 30 + ] accumulator [ each ] dip ."
+ "{ 1 2 } [ 30 + ] collector [ each ] dip ."
"V{ 31 32 }"
} } ;
ARTICLE: "sequences-combinator-implementation" "Implementing sequence combinators"
"Creating a new sequence unconditionally:"
{ $subsections
- accumulator
- accumulator-for
+ collector
+ collector-for
}
"Creating a new sequence conditionally:"
{ $subsections
- pusher
- pusher-for
- 2pusher
+ selector
+ selector-for
+ 2selector
} ;
ARTICLE: "sequences" "Sequence operations"
[ 2drop f f ]
if ; inline
+: (accumulate) ( seq identity quot -- seq identity quot )
+ [ swap ] dip [ curry keep ] curry ; inline
+
PRIVATE>
: each ( seq quot -- )
: map! ( seq quot -- seq )
over [ map-into ] keep ; inline
-: (accumulate) ( seq identity quot -- seq identity quot )
- [ swap ] dip [ curry keep ] curry ; inline
-
: accumulate-as ( seq identity quot exemplar -- final newseq )
[ (accumulate) ] dip map-as ; inline
: push-if ( elt quot accum -- )
[ keep ] dip rot [ push ] [ 2drop ] if ; inline
-: pusher-for ( quot exemplar -- quot accum )
+: selector-for ( quot exemplar -- quot accum )
[ length ] keep new-resizable [ [ push-if ] 2curry ] keep ; inline
-: pusher ( quot -- quot accum )
- V{ } pusher-for ; inline
+: selector ( quot -- quot accum )
+ V{ } selector-for ; inline
: filter-as ( seq quot exemplar -- subseq )
- dup [ pusher-for [ each ] dip ] curry dip like ; inline
+ dup [ selector-for [ each ] dip ] curry dip like ; inline
: filter ( seq quot -- subseq )
over filter-as ; inline
: push-either ( elt quot accum1 accum2 -- )
[ keep swap ] 2dip ? push ; inline
-: 2pusher ( quot -- quot accum1 accum2 )
+: 2selector ( quot -- quot accum1 accum2 )
V{ } clone V{ } clone [ [ push-either ] 3curry ] 2keep ; inline
: partition ( seq quot -- trueseq falseseq )
- over [ 2pusher [ each ] 2dip ] dip [ like ] curry bi@ ; inline
+ over [ 2selector [ each ] 2dip ] dip [ like ] curry bi@ ; inline
-: accumulator-for ( quot exemplar -- quot' vec )
+: collector-for ( quot exemplar -- quot' vec )
[ length ] keep new-resizable [ [ push ] curry compose ] keep ; inline
-: accumulator ( quot -- quot' vec )
- V{ } accumulator-for ; inline
+: collector ( quot -- quot' vec )
+ V{ } collector-for ; inline
: produce-as ( pred quot exemplar -- seq )
- dup [ accumulator-for [ while ] dip ] curry dip like ; inline
+ dup [ collector-for [ while ] dip ] curry dip like ; inline
: produce ( pred quot -- seq )
{ } produce-as ; inline
: assert-sequence= ( a b -- )
2dup sequence= [ 2drop ] [ assert-sequence ] if ;
+<PRIVATE
+
: sequence-hashcode-step ( oldhash newpart -- newhash )
>fixnum swap [
[ -2 fixnum-shift-fast ] [ 5 fixnum-shift-fast ] bi
fixnum+fast fixnum+fast
] keep fixnum-bitxor ; inline
+PRIVATE>
+
: sequence-hashcode ( n seq -- x )
[ 0 ] 2dip [ hashcode* sequence-hashcode-step ] with each ; inline
{ $subsections "add-vocab-roots" } ;
ARTICLE: "vocabs.loader" "Vocabulary loader"
-"The vocabulary loader is defined in the " { $vocab-link "vocabs.loader" } " vocabulary."
+"The vocabulary loader combines the vocabulary system with " { $link "parser" } " in order to implement automatic loading of vocabulary source files. The vocabulary loader is implemented in the " { $vocab-link "vocabs.loader" } " vocabulary."
$nl
-"Vocabularies are searched for in vocabulary roots."
+"When an attempt is made to use a vocabulary that has not been loaded into the image, the vocabulary loader is asked to locate the vocabulary's source files, and load them."
+$nl
+"The vocabulary loader searches for vocabularies in a set of directories known as vocabulary roots."
{ $subsections "vocabs.roots" }
-"Vocabulary names map directly to source files. A vocabulary named " { $snippet "foo.bar" } " must be defined in a " { $snippet "bar" } " directory nested inside a " { $snippet "foo" } " directory of a vocabulary root. Any level of vocabulary nesting is permitted."
+"Vocabulary names map directly to source files inside these roots. A vocabulary named " { $snippet "foo.bar" } " is defined in " { $snippet "foo/bar/bar.factor" } "; that is, a source file named " { $snippet "bar.factor" } " within a " { $snippet "bar" } " directory nested inside a " { $snippet "foo" } " directory of a vocabulary root. Any level of nesting, separated by dots, is permitted."
$nl
"The vocabulary directory - " { $snippet "bar" } " in our example - contains a source file:"
{ $list
- { { $snippet "foo/bar/bar.factor" } " - the source file, must define words in the " { $snippet "foo.bar" } " vocabulary with an " { $snippet "IN: foo.bar" } " form" }
+ { { $snippet "foo/bar/bar.factor" } " - the source file must define words in the " { $snippet "foo.bar" } " vocabulary with an " { $snippet "IN: foo.bar" } " form" }
}
-"Two other Factor source files, storing documentation and tests, respectively, are optional:"
+"Two other Factor source files, storing documentation and tests, respectively, may optionally be placed alongside the source file:"
{ $list
{ { $snippet "foo/bar/bar-docs.factor" } " - documentation, see " { $link "writing-help" } }
{ { $snippet "foo/bar/bar-tests.factor" } " - unit tests, see " { $link "tools.test" } }
}
-"Finally, three text files can contain meta-data:"
+"Finally, optional three text files may contain meta-data:"
{ $list
{ { $snippet "foo/bar/authors.txt" } " - a series of lines, with one author name per line. These are listed under " { $link "vocab-authors" } }
{ { $snippet "foo/bar/summary.txt" } " - a one-line description" }
{ { $snippet "foo/bar/tags.txt" } " - a whitespace-separated list of tags which classify the vocabulary. Consult " { $link "vocab-tags" } " for a list of existing tags you can re-use" }
}
-"While " { $link POSTPONE: USE: } " and " { $link POSTPONE: USING: } " load vocabularies which have not been loaded before adding them to the search path, it is also possible to load a vocabulary without adding it to the search path:"
+"The " { $link POSTPONE: USE: } " and " { $link POSTPONE: USING: } " words load vocabularies which have not been loaded yet, as needed."
+$nl
+"Vocabularies can also be loaded at run time, without altering the vocabulary search path. This is done by calling a word which loads a vocabulary if it is not in the image, doing nothing if it is:"
{ $subsections require }
-"Forcing a reload of a vocabulary, even if it has already been loaded:"
+"The above word will only ever load a vocabulary once in a given session. There is another word which unconditionally loads vocabulary from disk, regardless of whether or not is has already been loaded:"
{ $subsections reload }
+"For interactive development in the listener, calling " { $link reload } " directly is usually not necessary, since a better facility exists for " { $link "vocabs.refresh" } "."
+$nl
"Application vocabularies can define a main entry point, giving the user a convenient way to run the application:"
{ $subsections
POSTPONE: MAIN:
run
runnable-vocab
}
-{ $see-also "vocabularies" "parser-files" "source-files" } ;
+{ $see-also "vocabularies" "parser" "source-files" } ;
ABOUT: "vocabs.loader"
}
{ $see-also "words" } ;
-ARTICLE: "word-search-parsing" "Word lookup in parsing words"
+ARTICLE: "word-search-parsing" "Reflection support for vocabulary search path"
"The parsing words described in " { $link "word-search-syntax" } " are implemented using the below words, which you can also call from your own parsing words."
$nl
"The current state used for word search is stored in a " { $emphasis "manifest" } ":"
--- /dev/null
+! (c)2010 Joe Groff bsd license
+USING: alien byte-arrays help.markup help.syntax kernel math
+memory ;
+IN: audio
+
+HELP: <audio>
+{ $values
+ { "channels" integer } { "sample-bits" integer } { "sample-rate" integer } { "size" integer } { "data" c-ptr }
+ { "audio" integer }
+}
+{ $description "Constructs an " { $link audio } " object with the given parameters." } ;
+
+HELP: audio
+{ $class-description "Objects of this class contain uncompressed PCM audio data. The " { $snippet "data" } " slot contains an " { $link alien } " pointer or " { $link byte-array } " with the binary PCM data, and the " { $link size } " slot indicates the length in bytes of the data. The " { $snippet "channels" } ", " { $snippet "sample-bits" } " and " { $snippet "sample-rate" } " slots indicate the number of channels (1 for mono, 2 for stereo), bits per sample, and sample rate of the data." } ;
+
+HELP: format-unsupported-by-openal
+{ $values
+ { "audio" audio }
+}
+{ $description "Errors of this class are thrown when " { $link openal-format } " is called on an " { $link audio } " object for which there is no OpenAL-supported format." } ;
+
+HELP: openal-format
+{ $values
+ { "audio" audio }
+ { "format" "an ALenum value" }
+}
+{ $description "Returns the OpenAL format value that corresponds to the format of the " { $snippet "audio" } " object. If the object's format doesn't match an OpenAL-supported format, a " { $link format-unsupported-by-openal } " error is thrown." } ;
+
+ARTICLE: "audio" "Audio framework"
+"The " { $vocab-link "audio" } " vocabulary and its child vocabularies provide a framework for reading audio data from disk and playing back audio using prerendered, streaming, or generated audio sources. By itself, the " { $snippet "audio" } " vocabulary provides a container class for prerendered PCM audio data:"
+{ $subsections
+ audio
+ <audio>
+ openal-format
+}
+"The following child vocabularies provide additional audio features:"
+{ $list
+{ { $vocab-link "audio.engine" } " provides a high-level OpenAL-based engine for playing audio clips." }
+{ { $vocab-link "audio.loader" } " reads PCM data from files on disk into " { $link audio } " objects. " { $vocab-link "audio.wav" } " and " { $vocab-link "audio.aiff" } " support specific audio file formats." }
+{ { $vocab-link "audio.vorbis" } " implements an " { $snippet "audio.engine" } " compatible generator object for decoding Ogg Vorbis audio data from a stream." }
+} ;
+
+ABOUT: "audio"
+! (c)2010 Joe Groff bsd license
USING: accessors alien arrays combinators kernel math openal ;
IN: audio
--- /dev/null
+! (c)2010 Joe Groff bsd license
+USING: alien audio byte-arrays destructors help.markup
+help.syntax kernel math strings ;
+IN: audio.engine
+
+HELP: <audio-engine>
+{ $values
+ { "device-name" { $maybe string } } { "voice-count" integer }
+ { "engine" audio-engine }
+}
+{ $description "Constructs an " { $link audio-engine } " instance capable of playing " { $snippet "voice-count" } " simultaneous clips. The OpenAL device named " { $snippet "device-name" } " will be used, or the default device if " { $snippet "device-name" } " is " { $link f } ". An error will be thrown if the engine cannot be initialized. The engine is returned in the stopped state; to start audio processing, use " { $link start-audio } " or " { $link start-audio* } "." } ;
+
+HELP: <audio-orientation>
+{ $values
+ { "forward" "a sequence of 3 floats" } { "up" "a sequence of 3 floats" }
+ { "audio-orientation" audio-orientation }
+}
+{ $description "Constructs an " { $link audio-orientation } " tuple." } ;
+
+HELP: <standard-audio-engine>
+{ $values
+
+ { "engine" audio-engine }
+}
+{ $description "Constructs an " { $link audio-engine } " instance by calling " { $link <audio-engine> } " with the default values of " { $link f } " for the " { $snippet "device-name" } " and 16 for the " { $snippet "voice-count" } ". The engine is returned in the stopped state; to start audio processing, use " { $link start-audio } " or " { $link start-audio* } "." } ;
+
+HELP: <static-audio-clip>
+{ $values
+ { "audio-engine" audio-engine } { "source" "an object implementing the " { $link "audio.engine-sources" } } { "audio" audio } { "loop?" boolean }
+ { "audio-clip/f" { $maybe audio-clip } }
+}
+{ $description "Constructs a " { $link static-audio-clip } " tied to " { $snippet "source" } " and playing audio generated by " { $snippet "generator" } ". The clip won't be played until " { $link play-clip } " or " { $link play-clips } " is called on it. If " { $snippet "loop?" } " is true, the clip will repeat indefinitely when played until stopped with " { $link stop-clip } ". Otherwise, the clip will automatically be " { $link dispose } "d by the " { $link audio-engine } " after it finishes playing. If the engine has no available voices, no clip will be constructed, and " { $link f } " will be returned." } ;
+
+HELP: <streaming-audio-clip>
+{ $values
+ { "audio-engine" audio-engine } { "source" "an object implementing the " { $link "audio.engine-sources" } } { "generator" "an object implementing the " { $link "audio.engine-generators" } } { "buffer-count" integer }
+ { "audio-clip/f" { $maybe audio-clip } }
+}
+{ $description "Constructs a " { $link streaming-audio-clip } " tied to " { $snippet "source" } " and playing audio generated by " { $snippet "generator" } ". " { $snippet "buffer-count" } " buffers will be allocated for the clip. The clip won't be played until " { $link play-clip } " or " { $link play-clips } " is called on it. The clip will automatically be " { $link dispose } "d by the " { $link audio-engine } " when the generator stops supplying data and all the buffered data has played. The clip will in turn dispose its generator when it is disposed. If the engine has no available voices, no clip will be constructed, the generator will be disposed, and " { $link f } " will be returned." } ;
+
+HELP: audio-clip
+{ $class-description "Opaque type of clips being played by an " { $link audio-engine } ". There are two subclasses provided:"
+{ $list
+ { { $link static-audio-clip } ", constructed by " { $link <static-audio-clip> } " or " { $link play-static-audio-clip } }
+ { { $link streaming-audio-clip } ", constructed by " { $link <streaming-audio-clip> } " or " { $link play-streaming-audio-clip } }
+}
+"Clip objects are transient. They get " { $link dispose } "d and invalidated by the controlling " { $link audio-engine } " when their playback finishes or is stopped. The " { $link play-clip } ", " { $link pause-clip } ", and " { $link stop-clip } " words control playback of individual clips. " { $link play-clips } ", " { $link pause-clips } ", and " { $link stop-clips } " synchronize the playing, pausing, or stopping of multiple clips." } ;
+
+HELP: audio-context-not-available
+{ $values
+ { "device-name" { $maybe string } }
+}
+{ $description "Errors of this type are thrown by " { $link <audio-engine> } " when an OpenAL context cannot be created for the device named " { $snippet "device-name" } "." } ;
+
+HELP: audio-device-not-found
+{ $values
+ { "device-name" { $maybe string } }
+}
+{ $description "Errors of this type are thrown by " { $link <audio-engine> } " when it is unable to open the OpenAL device named " { $snippet "device-name" } "." } ;
+
+HELP: audio-distance
+{ $values
+ { "source" "an object implementing the " { $link "audio.engine-sources" } }
+ { "distance" float }
+}
+{ $description "Returns the reference distance (that is, the distance from the listener below which the clip plays at full volume) for a playing audio clip. Larger reference distances make the clip play louder at further distances from the listener." } ;
+
+HELP: audio-engine
+{ $class-description "Objects of this class encapsulate the state for an active audio engine. Audio processing on an engine can be started and stopped with " { $link start-audio } ", " { $link start-audio* } ", and " { $link stop-audio } ". While running, " { $link update-audio } " must be called on an engine regularly to update source and listener attributes and refill buffers for streaming clips."
+$nl
+"An engine object should be treated as opaque, except for the " { $snippet "listener" } " slot. This slot may be filled with any object implementing the " { $link "audio.engine-listener" } " protocol, which will then be used to control the position, velocity, volume, and other attributes of the lisetener. By default, this slot contains an " { $link audio-listener } " tuple with all the slots set to their initial values." } ;
+
+HELP: audio-gain
+{ $values
+ { "source/listener" "an object implementing the " { $link "audio.engine-sources" } " or " { $link "audio.engine-listener" } }
+ { "gain" "a " { $link float } " between 0.0 and 1.0" }
+}
+{ $description "Returns the base gain for an individual audio clip, or for the listener. A clip source's gain will be attenuated by its distance from the listener. The listener's gain will be multiplied on top of each source's gain." } ;
+
+HELP: audio-listener
+{ $class-description "A tuple class that trivially implements the " { $link "audio.engine-listener" } " with accessors on its tuple slots."
+{ $list
+ { { $snippet "position" } " provides the " { $link audio-position } "." }
+ { { $snippet "gain" } " provides the " { $link audio-gain } "." }
+ { { $snippet "velocity" } " provides the " { $link audio-velocity } "." }
+ { { $snippet "orientation" } " provides the " { $link audio-orientation } "." }
+} } ;
+
+HELP: audio-orientation
+{ $values
+ { "listener" "an object implementing the " { $link "audio.engine-listener" } }
+ { "orientation" audio-orientation }
+}
+{ $description "Returns the orientation of the listener. The orientation must be returned in an " { $snippet "audio-orientation" } " tuple with the following slots:"
+{ $list
+ { { $snippet "forward" } " is a 3-component vector indicating the direction the listener is facing." }
+ { { $snippet "up" } " is a 3-component vector indicating the \"up\" direction for the listener. This vector does not need to be normal to the " { $snippet "forward" } " vector." }
+} "The vectors do not need to be normalized." } ;
+
+HELP: audio-position
+{ $values
+ { "source/listener" "an object implementing the " { $link "audio.engine-sources" } " or " { $link "audio.engine-listener" } }
+ { "position" "a 3-component float vector" }
+}
+{ $description "Returns the position of an audio clip or of the listener. These positions determine the distance between clips and the listener, which in turn control the attenuation of the clips." } ;
+
+HELP: audio-relative?
+{ $values
+ { "source" "an object implementing the " { $link "audio.engine-sources" } }
+ { "relative?" boolean }
+}
+{ $description "If true, the " { $link audio-position } " and " { $link audio-velocity } " of the clip will be taken as being relative to the listener instead of in world space." } ;
+
+HELP: audio-rolloff
+{ $values
+ { "source" "an object implementing the " { $link "audio.engine-sources" } }
+ { "rolloff" float }
+}
+{ $description "Returns the rolloff factor for an audio clip. Rolloff factors greater than one will result in greater distance-based attenuation, and factors less than one will result in lesser attenuation." } ;
+
+HELP: audio-source
+{ $class-description "A tuple class that trivially implements the " { $link "audio.engine-sources" } " with accessors on its tuple slots."
+{ $list
+ { { $snippet "position" } " provides the " { $link audio-position } "." }
+ { { $snippet "gain" } " provides the " { $link audio-gain } "." }
+ { { $snippet "velocity" } " provides the " { $link audio-velocity } "." }
+ { { $snippet "relative?" } " provides the " { $link audio-relative? } " value." }
+ { { $snippet "distance" } " provides the " { $link audio-distance } "." }
+ { { $snippet "rolloff" } " provides the " { $link audio-rolloff } "." }
+} } ;
+
+HELP: audio-velocity
+{ $values
+ { "source/listener" "an object implementing the " { $link "audio.engine-sources" } " or " { $link "audio.engine-listener" } }
+ { "velocity" "a 3-component float vector" }
+}
+{ $description "Returns the velocity of an audio clip or of the listener. The relative velocity of each source to the listener is used to calculate a Doppler effect on its associated clips." } ;
+
+HELP: generate-audio
+{ $values
+ { "generator" "an object implementing the " { $link "audio.engine-generators" } }
+ { "c-ptr" { $maybe c-ptr } } { "size" { $maybe integer } }
+}
+{ $description "Tells " { $snippet "generator" } " to generate another block of PCM data. " { $snippet "c-ptr" } " can be a " { $link byte-array } " or " { $link alien } " pointer. " { $snippet "size" } " indicates the size in bytes of the returned buffer. The generator is allowed to reuse the buffer; the engine will copy the data to its own internal buffer before its next call to " { $snippet "generate-audio" } ". The method can provide " { $link f } " for both outputs or a " { $snippet "size" } " of 0 to indicate that its stream is exhausted." } ;
+
+HELP: generator-audio-format
+{ $values
+ { "generator" "an object implementing the " { $link "audio.engine-generators" } }
+ { "channels" integer } { "sample-bits" integer } { "sample-rate" integer }
+}
+{ $description "Returns the number of channels (1 for mono, 2 for stereo), number of bits per sample, and sample rate in hertz of the PCM data generated by " { $snippet "generator" } "." } ;
+
+HELP: pause-clip
+{ $values
+ { "audio-clip" audio-clip }
+}
+{ $description "Pauses the " { $link audio-clip } "." }
+{ $notes "Use " { $link pause-clips } " to synchronize the pausing of multiple clips." } ;
+
+HELP: pause-clips
+{ $values
+ { "audio-clips" "a sequence of " { $link audio-clip } "s" }
+}
+{ $description "Pauses all of the " { $link audio-clip } "s at the exact same time." } ;
+
+HELP: play-clip
+{ $values
+ { "audio-clip" audio-clip }
+}
+{ $description "Starts or resumes playing the " { $link audio-clip } "." }
+{ $notes "Use " { $link play-clips } " to synchronize the playing of multiple clips." } ;
+
+HELP: play-clips
+{ $values
+ { "audio-clips" "a sequence of " { $link audio-clip } "s" }
+}
+{ $description "Plays all of the " { $link audio-clip } "s at the exact same time." } ;
+
+HELP: play-static-audio-clip
+{ $values
+ { "audio-engine" audio-engine } { "source" "an object implementing the " { $link "audio.engine-sources" } } { "audio" audio } { "loop?" boolean }
+ { "audio-clip/f" { $maybe audio-clip } }
+}
+{ $description "Constructs and immediately starts playing a " { $link static-audio-clip } " tied to " { $snippet "source" } " and playing audio generated by " { $snippet "generator" } ". If " { $snippet "loop?" } " is true, the clip will repeat indefinitely until stopped with " { $link stop-clip } ". Otherwise, the clip will automatically be " { $link dispose } "d by the " { $link audio-engine } " when it finishes playing. If the engine has no available voices, no clip will be constructed, and " { $link f } " will be returned." }
+{ $notes "Use " { $link play-clips } " with " { $link <static-audio-clip> } " and " { $link <streaming-audio-clip> } " to synchronize the playing of multiple clips." } ;
+
+HELP: play-streaming-audio-clip
+{ $values
+ { "audio-engine" audio-engine } { "source" "an object implementing the " { $link "audio.engine-sources" } } { "generator" "an object implementing the " { $link "audio.engine-generators" } } { "buffer-count" integer }
+ { "audio-clip/f" { $maybe audio-clip } }
+}
+{ $description "Constructs and immediately starts playing a " { $link streaming-audio-clip } " tied to " { $snippet "source" } " and playing audio generated by " { $snippet "generator" } ". " { $snippet "buffer-count" } " buffers will be allocated for the clip. The clip will automatically be " { $link dispose } "d by the " { $link audio-engine } " when the generator stops supplying data and all the buffered data has played. The clip will in turn dispose its generator when it is disposed. If the engine has no available voices, no clip will be constructed, the generator will be disposed, and " { $link f } " will be returned." }
+{ $notes "Use " { $link play-clips } " with " { $link <static-audio-clip> } " and " { $link <streaming-audio-clip> } " to synchronize the playing of multiple clips." } ;
+
+HELP: start-audio
+{ $values
+ { "audio-engine" audio-engine }
+}
+{ $description "Starts processing of the " { $link audio-engine } ", and starts a thread that will call " { $link update-audio } " 50 times per second. If you will be integrating your own timer mechanism, " { $link start-audio* } " will start processing without providing the update thread." } ;
+
+HELP: start-audio*
+{ $values
+ { "audio-engine" audio-engine }
+}
+{ $description "Starts processing of the " { $link audio-engine } ". Unlike " { $link start-audio } ", this does not start a thread to call " { $link update-audio } " for you. This is useful if you will be integrating your own timer mechanism (such as a " { $vocab-link "game.loop" } ") to keep the audio engine updated." } ;
+
+HELP: static-audio-clip
+{ $class-description "An " { $link audio-clip } " that plays back static, prerendered, fixed-size PCM data from an " { $link audio } " object. Use " { $link <static-audio-clip> } " or " { $link play-static-audio-clip } " to construct static audio clips." } ;
+
+HELP: stop-audio
+{ $values
+ { "audio-engine" audio-engine }
+}
+{ $description "Stops processing of the " { $link audio-engine } " and invalidates any currently playing " { $link audio-clip } "s. The engine can be restarted using " { $link start-audio } " or " { $link start-audio* } "; however, any clips that were playing will remain invalidated." } ;
+
+HELP: stop-clip
+{ $values
+ { "audio-clip" audio-clip }
+}
+{ $description "Stops and disposes an audio clip." }
+{ $notes "Use " { $link pause-clip } " if playback will need to be continued. Use " { $link stop-clips } " to synchronize the stopping of multiple clips." } ;
+
+HELP: stop-clips
+{ $values
+ { "audio-clips" "a sequence of " { $link audio-clip } "s" }
+}
+{ $description "Stops all of the " { $link audio-clip } "s at the exact same time. All of the clips will be " { $link dispose } "d and rendered invalid." }
+{ $notes "Use " { $link pause-clips } " if playback will need to be continued." } ;
+
+HELP: streaming-audio-clip
+{ $class-description "An " { $link audio-clip } " that plays back PCM data streamed by a generator object implementing the " { $link "audio.engine-generators" } ". Use " { $link <streaming-audio-clip> } " or " { $link play-streaming-audio-clip } " to construct streaming audio clips." } ;
+
+HELP: update-audio
+{ $values
+ { "audio-engine" audio-engine }
+}
+{ $description "Updates the " { $link audio-engine } " state, refilling processed audio buffers for playing " { $link streaming-audio-clip } "s as well as updating the listener and source attributes of every audio clip. " { $link start-audio } " will start up a timer that will call " { $snippet "update-audio" } " regularly for you. If you start the audio engine using " { $link start-audio* } ", you will need to arrange for " { $snippet "update-audio" } " to be regularly invoked yourself." } ;
+
+ARTICLE: "audio.engine-generators" "Audio generator protocol"
+{ $link streaming-audio-clip } "s require a " { $snippet "generator" } " object to supply PCM data to the audio engine as it is needed. To function as a generator, an object must provide methods for the following generic words:"
+{ $subsections
+ generate-audio
+ generator-audio-format
+}
+"A generator object must also be " { $link disposable } "." ;
+
+ARTICLE: "audio.engine-listener" "Audio listener protocol"
+"The " { $link audio-engine } " has a " { $snippet "listener" } " slot. The engine uses the object in this slot to determine the position, velocity, volume, and other attributes of the frame of reference for audio playback. These attributes are dynamic; every time " { $link update-audio } " runs, the listener attributes are queried and updated. The listener object must provide methods for the following generic words:"
+{ $subsections
+ audio-position
+ audio-gain
+ audio-velocity
+ audio-orientation
+}
+"Some of these methods are shared with the " { $link "audio.engine-sources" } "."
+$nl
+"For simple applications, a tuple class is provided with a trivial implementation of these methods:"
+{ $subsections
+ audio-listener
+} ;
+
+ARTICLE: "audio.engine-sources" "Audio source protocol"
+"Every audio clip has an associated " { $snippet "source" } " object. The " { $link audio-engine } " uses this object to determine the position, velocity, volume, and other attributes of the clip. These attributes are dynamic; every time " { $link update-audio } " runs, these attributes are queried and updated for every currently playing clip. The source object must provide methods for the following generic words:"
+{ $subsections
+ audio-position
+ audio-gain
+ audio-velocity
+ audio-relative?
+ audio-distance
+ audio-rolloff
+}
+"Some of these methods are shared with the " { $link "audio.engine-listener" } "."
+$nl
+"For simple applications, a tuple class is provided with a trivial implementation of these methods:"
+{ $subsections
+ audio-source
+} ;
+
+ARTICLE: "audio.engine" "Audio playback engine"
+"The " { $vocab-link "audio.engine" } " manages playback of prerendered and streaming audio clips. It uses OpenAL as the underlying interface to audio hardware. As clips play, their 3D location, volume, and other attributes can be updated on the fly."
+$nl
+"An " { $link audio-engine } " object manages the connection to the OpenAL implementation and any playing clips:"
+{ $subsections
+ audio-engine
+ <audio-engine>
+ <standard-audio-engine>
+}
+"The audio engine can be started and stopped. While it is running, it must be regularly updated to keep audio buffers full and clip attributes up to date."
+{ $subsections
+ start-audio
+ start-audio*
+ stop-audio
+ update-audio
+}
+"Audio clips are represented by " { $link audio-clip } " objects while they are playing. Words are provided to control the playback of clips:"
+{ $subsections
+ audio-clip
+ play-clip
+ pause-clip
+ stop-clip
+ play-clips
+ pause-clips
+ stop-clips
+}
+"Two types of audio clip objects can be played by the engine. A " { $link static-audio-clip } " plays back a static, prerendered, fixed-size block of PCM data from an " { $link audio } " object."
+{ $subsections
+ static-audio-clip
+ <static-audio-clip>
+ play-static-audio-clip
+}
+"A " { $link streaming-audio-clip } " generates PCM data on the fly from a generator object."
+{ $subsections
+ "audio.engine-generators"
+ streaming-audio-clip
+ <streaming-audio-clip>
+ play-streaming-audio-clip
+}
+"Every audio clip has an associated " { $snippet "source" } " object that determines the clip's 3D position, velocity, volume, and other attributes. The engine itself has a " { $snippet "listener" } " that describes the position, orientation, velocity, and volume that make up the frame of reference for audio playback."
+{ $subsections
+ "audio.engine-sources"
+ "audio.engine-listener"
+} ;
+
+ABOUT: "audio.engine"
M: audio-source audio-gain gain>> ; inline
M: audio-source audio-velocity velocity>> ; inline
M: audio-source audio-relative? relative?>> ; inline
+M: audio-source audio-distance distance>> ; inline
+M: audio-source audio-rolloff rolloff>> ; inline
M: audio-listener audio-position position>> ; inline
M: audio-listener audio-gain gain>> ; inline
M: audio-listener audio-velocity velocity>> ; inline
M: audio-listener audio-orientation orientation>> ; inline
+GENERIC: generate-audio ( generator -- c-ptr size )
+GENERIC: generator-audio-format ( generator -- channels sample-bits sample-rate )
+
TUPLE: audio-engine < disposable
{ voice-count integer }
- { buffer-size integer }
- { buffer-count integer }
{ al-device c-ptr }
{ al-context c-ptr }
al-sources
TUPLE: audio-clip < disposable
{ audio-engine audio-engine }
- { audio audio }
source
- { loop? boolean }
- { al-source integer }
+ { al-source integer } ;
+
+TUPLE: static-audio-clip < audio-clip
+ { al-buffer integer } ;
+
+TUPLE: streaming-audio-clip < audio-clip
+ generator
+ { channels integer }
+ { sample-bits integer }
+ { sample-rate integer }
{ al-buffers uint-array }
- { next-data-offset integer } ;
+ { done? boolean } ;
ERROR: audio-device-not-found device-name ;
ERROR: audio-context-not-available device-name ;
-:: <audio-engine> ( device-name voice-count buffer-size buffer-count -- engine )
+:: <audio-engine> ( device-name voice-count -- engine )
[
device-name alcOpenDevice :> al-device
al-device [ device-name audio-device-not-found ] unless
voice-count >>voice-count
al-device >>al-device
al-context >>al-context
- buffer-size >>buffer-size
- buffer-count >>buffer-count
] with-destructors ;
: <standard-audio-engine> ( -- engine )
- f 16
8192 2 <audio-engine> ;
+ f 16 <audio-engine> ;
<PRIVATE
: allocate-sources ( audio-engine -- sources )
voice-count>> dup (uint-array) [ alGenSources ] keep ; inline
-:: flush-source ( source -- )
- source alSourceStop
+:: flush-source ( al-source -- )
+ al-source alSourceStop
0 c:<uint> :> dummy-buffer
- source AL_BUFFERS_PROCESSED get-source-param [
- source 1 dummy-buffer alSourceUnqueueBuffers
- ] times ;
+ al-source AL_BUFFERS_PROCESSED get-source-param [
+ al-source 1 dummy-buffer alSourceUnqueueBuffers
+ ] times
+ al-source AL_BUFFER 0 alSourcei ;
: free-sources ( sources -- )
[ length ] keep alDeleteSources ; inline
audio-engine next-source >>next-source drop
al-source ;
-:: (queue-clip-buffer) ( audio-clip al-buffer audio data size -- )
- al-buffer audio openal-format data size audio sample-rate>> alBufferData
- audio-clip al-source>> 1 al-buffer c:<uint> alSourceQueueBuffers
-
- audio-clip [ size + ] change-next-data-offset drop ; inline
-
:: queue-clip-buffer ( audio-clip al-buffer -- )
- audio-clip audio-engine>> :> audio-engine
- audio-engine buffer-size>> :> buffer-size
- audio-clip audio>> :> audio
- audio-clip next-data-offset>> :> next-data-offset
- audio size>> next-data-offset - :> remaining-audio
-
- {
- { [ remaining-audio 0 <= ] [
- audio-clip loop?>> [
- audio-clip 0 >>next-data-offset
- al-buffer queue-clip-buffer
- ] when
- ] }
- { [ remaining-audio buffer-size < ] [
- audio-clip loop?>> [
- audio data>>
- [ next-data-offset swap <displaced-alien> remaining-audio <direct-uchar-array> ]
- [ buffer-size remaining-audio - <direct-uchar-array> ] bi append :> data
- audio-clip al-buffer audio data buffer-size (queue-clip-buffer)
-
- audio-clip [ audio size>> mod ] change-next-data-offset drop
- ] [
- next-data-offset audio data>> <displaced-alien> :> data
- audio-clip al-buffer audio data remaining-audio (queue-clip-buffer)
- ] if
- ] }
- [
- next-data-offset audio data>> <displaced-alien> :> data
- audio-clip al-buffer audio data buffer-size (queue-clip-buffer)
- ]
- } cond ;
+ audio-clip done?>> [
+ audio-clip al-source>> :> al-source
+ audio-clip generator>> :> generator
+ generator generate-audio :> ( data size )
+
+ size { [ not ] [ zero? ] } 1|| [
+ audio-clip t >>done? drop
+ ] [
+ al-buffer audio-clip openal-format data size audio-clip sample-rate>> alBufferData
+ al-source 1 al-buffer c:<uint> alSourceQueueBuffers
+ ] if
+ ] unless ;
: update-listener ( audio-engine -- )
listener>> {
[ AL_ROLLOFF_FACTOR swap audio-rolloff alSourcef ]
} 2cleave ;
-:: update-audio-clip ( audio-clip -- )
- audio-clip update-source
+GENERIC: (update-audio-clip) ( audio-clip -- )
+
+M: static-audio-clip (update-audio-clip)
+ drop ;
+
+M:: streaming-audio-clip (update-audio-clip) ( audio-clip -- )
audio-clip al-source>> :> al-source
- 0 c:<uint> :> buffer*
-
- al-source AL_SOURCE_STATE get-source-param AL_STOPPED =
- [ audio-clip dispose ] [
- al-source AL_BUFFERS_PROCESSED get-source-param [
- al-source 1 buffer* alSourceUnqueueBuffers
- audio-clip buffer* c:*uint queue-clip-buffer
- ] times
- ] if ;
+ 0 c:<uint> :> buffer
+ al-source AL_BUFFERS_PROCESSED get-source-param [
+ al-source 1 buffer alSourceUnqueueBuffers
+ audio-clip buffer c:*uint queue-clip-buffer
+ ] times ;
+
+: update-audio-clip ( audio-clip -- )
+ [ update-source ] [
+ dup al-source>> AL_SOURCE_STATE get-source-param AL_STOPPED =
+ [ dispose ] [ (update-audio-clip) ] if
+ ] bi ;
: clip-al-sources ( clips -- length sources )
[ length ] [ [ al-source>> ] uint-array{ } map-as ] bi ;
[ [ alcCloseDevice* ] when* f ] change-al-device
drop ;
-:: (audio-clip) ( audio-engine audio source loop? -- audio-clip/f )
+:: <static-audio-clip> ( audio-engine source audio loop? -- audio-clip/f )
+ audio-engine get-available-source :> al-source
+
+ al-source [
+ 1 0 c:<uint> [ alGenBuffers ] keep c:*uint :> al-buffer
+ al-buffer audio { [ openal-format ] [ data>> ] [ size>> ] [ sample-rate>> ] } cleave
+ alBufferData
+
+ al-source AL_BUFFER al-buffer alSourcei
+ al-source AL_LOOPING loop? c:>c-bool alSourcei
+
+ static-audio-clip new-disposable
+ audio-engine >>audio-engine
+ source >>source
+ al-source >>al-source
+ al-buffer >>al-buffer
+ :> clip
+ clip audio-engine clips>> push
+ clip
+ ] [ f ] if ;
+
+:: <streaming-audio-clip> ( audio-engine source generator buffer-count -- audio-clip/f )
audio-engine get-available-source :> al-source
al-source [
- audio-engine buffer-count>> :> buffer-count
buffer-count dup (uint-array) [ alGenBuffers ] keep :> al-buffers
+ generator generator-audio-format :> ( channels sample-bits sample-rate )
- audio-clip new-disposable
+ streaming-audio-clip new-disposable
audio-engine >>audio-engine
- audio >>audio
source >>source
- loop? >>loop?
al-source >>al-source
+ generator >>generator
+ channels >>channels
+ sample-bits >>sample-bits
+ sample-rate >>sample-rate
al-buffers >>al-buffers
- 0 >>next-data-offset :> clip
+ :> clip
al-buffers [ clip swap queue-clip-buffer ] each
clip audio-engine clips>> push
-
clip
- ] [ f ] if ;
+ ] [ generator dispose f ] if ;
M: audio-clip dispose*
- {
- [ al-source>> flush-source ]
- [ al-buffers>> [ length ] keep alDeleteBuffers ]
- [ dup audio-engine>> clips>> remove! drop ]
- } cleave ;
+ [ dup audio-engine>> clips>> remove! drop ]
+ [ al-source>> flush-source ] bi ;
+
+M: static-audio-clip dispose*
+ [ call-next-method ]
+ [ [ 1 ] dip al-buffer>> c:<uint> alDeleteBuffers ] bi ;
+
+M: streaming-audio-clip dispose*
+ [ call-next-method ]
+ [ generator>> dispose ]
+ [ al-buffers>> [ length ] keep alDeleteBuffers ] tri ;
: play-clip ( audio-clip -- )
[ update-source ]
[ [ update-source ] each ]
[ clip-al-sources alSourcePlayv ] bi ;
-: <audio-clip> ( audio-engine audio source loop? -- audio-clip/f )
- (audio-clip) dup play-clip ;
+: play-static-audio-clip ( audio-engine source audio loop? -- audio-clip/f )
+ <static-audio-clip> dup [ play-clip ] when* ;
+
+: play-streaming-audio-clip ( audio-engine source generator buffer-count -- audio-clip/f )
+ <streaming-audio-clip> dup [ play-clip ] when* ;
: pause-clip ( audio-clip -- )
al-source>> alSourcePause ;
-: pause-clips ( audio-clip -- )
+: pause-clips ( audio-clips -- )
clip-al-sources alSourcePausev ;
: stop-clip ( audio-clip -- )
dispose ;
-: stop-clips ( audio-clip -- )
+: stop-clips ( audio-clips -- )
[ clip-al-sources alSourceStopv ]
[ [ dispose ] each ] bi ;
--- /dev/null
+Audio playback engine
! (c)2009 Joe Groff bsd license
USING: accessors alarms audio audio.engine audio.loader calendar
-destructors io kernel locals math math.functions ;
+destructors io kernel locals math math.functions math.ranges specialized-arrays
+sequences random math.vectors ;
+FROM: alien.c-types => short ;
+SPECIALIZED-ARRAY: short
IN: audio.engine.test
+TUPLE: noise-generator ;
+
+M: noise-generator generator-audio-format
+ drop 1 16 8000 ;
+M: noise-generator generate-audio
+ drop
+ 4096 [ -4096 4096 [a,b] random ] short-array{ } replicate-as
+ 8192 ;
+M: noise-generator dispose
+ drop ;
+
:: audio-engine-test ( -- )
"vocab:audio/engine/test/loop.aiff" read-audio :> loop-sound
"vocab:audio/engine/test/once.wav" read-audio :> once-sound
0 :> i!
- <standard-audio-engine> :> engine
+ f 4 <audio-engine> :> engine
engine start-audio*
- engine loop-sound T{ audio-source f { 1.0 0.0 0.0 } 1.0 { 0.0 0.0 0.0 } f } t <audio-clip>
- :> loop-clip
+
+ engine T{ audio-source f { 1.0 0.0 0.0 } 1.0 { 0.0 0.0 0.0 } f } loop-sound t
+ play-static-audio-clip :> loop-clip
+ engine T{ audio-source f { -1.0 0.0 0.0 } 1.0 { 0.0 0.0 0.0 } f } noise-generator new 2
+ play-streaming-audio-clip :> noise-clip
[
i 1 + i!
- i 0.05 * sin :> s
- loop-clip source>> { s 0.0 0.0 } >>position drop
+ i 0.05 * [ sin ] [ cos ] bi :> ( s c )
+ loop-clip source>> { c 0.0 s } >>position drop
+ noise-clip source>> { c 0.0 s } -2.0 v*n >>position drop
i 50 mod zero? [
- engine once-sound T{ audio-source f { 0.0 0.0 0.0 } 1.0 { 0.0 0.0 0.0 } f } f
- <audio-clip> drop
+ engine T{ audio-source f { 0.0 0.0 0.0 } 1.0 { 0.0 0.0 0.0 } f } once-sound f
+ play-static-audio-clip drop
] when
engine update-audio
alarm cancel-alarm
engine dispose ;
-
MAIN: audio-engine-test
--- /dev/null
+! (c)2010 Joe Groff bsd license
+USING: audio help.markup help.syntax kernel quotations strings ;
+IN: audio.loader
+
+HELP: read-audio
+{ $values
+ { "path" "a pathname string" }
+ { "audio" audio }
+}
+{ $description "Reads the audio data from the file on disk named " { $snippet "path" } ", saving the data in an " { $link audio } " object. If the file's extension is not recognized, an " { $link unknown-audio-extension } " error is thrown." } ;
+
+HELP: register-audio-extension
+{ $values
+ { "extension" string } { "quot" quotation }
+}
+{ $description "Registers a quotation for " { $link read-audio } " to use when reading audio files with filenames ending in " { $snippet ".extension" } ". The quotation should have the effect " { $snippet "( path -- audio )" } ", where " { $snippet "path" } " is the file's pathname and " { $snippet "audio" } " is the resulting " { $link audio } " object." } ;
+
+HELP: unknown-audio-extension
+{ $values
+ { "extension" string }
+}
+{ $description "Errors of this class are thrown by " { $link read-audio } " when it cannot recognize the extension of the file it is given to open." } ;
+
+ARTICLE: "audio.loader" "Audio file loader"
+"The " { $vocab-link "audio.loader" } " vocabulary provides words for reading uncompressed PCM data from files on disk."
+{ $subsections
+ read-audio
+}
+"Other vocabularies can extend " { $link read-audio } " by adding support for other audio file formats."
+{ $subsections
+ register-audio-extension
+ unknown-audio-extension
+}
+"By default, " { $snippet "audio.loader" } " supports WAV (with the file extension " { $snippet ".wav" } ") and AIFF (with extension " { $snippet ".aif" } " or " { $snippet ".aiff" } ")." ;
+
+ABOUT: "audio.loader"
--- /dev/null
+Read PCM audio data from uncompressed audio files
--- /dev/null
+Framework for reading and playing back audio
--- /dev/null
+Chris Double
+Joe Groff
--- /dev/null
+Ogg Vorbis audio streaming for audio.engine
--- /dev/null
+! (c)2010 Joe Groff bsd license
+USING: audio.engine destructors help.markup help.syntax
+io.files kernel math strings ;
+IN: audio.vorbis
+
+HELP: <vorbis-stream>
+{ $values
+ { "stream" "a binary input stream" } { "buffer-size" integer }
+ { "vorbis-stream" vorbis-stream }
+}
+{ $description "Constructs " { $link vorbis-stream } " over the contents of " { $snippet "stream" } ". When used as an audio generator, the Vorbis stream will supply data to the audio engine in " { $snippet "buffer-size" } " byte blocks. If the Vorbis stream is created successfully, it will take ownership of " { $snippet "stream" } ", disposing it when " { $link dispose } " is called on the " { $snippet "vorbis-stream" } "." } ;
+
+HELP: no-vorbis-in-ogg
+{ $description { $link <vorbis-stream> } " throws this error when the Ogg stream it reads contains no Vorbis channel." } ;
+
+HELP: ogg-error
+{ $values
+ { "code" integer }
+}
+{ $description { $link <vorbis-stream> } " throws this error when the Ogg library raises an error while trying to parse the stream." } ;
+
+HELP: read-vorbis-stream
+{ $values
+ { "filename" string } { "buffer-size" integer }
+ { "vorbis-stream" vorbis-stream }
+}
+{ $description "Opens a binary " { $link <file-reader> } " for the file named " { $snippet "filename" } ", and construct a " { $link vorbis-stream } " over the file contents using " { $link <vorbis-stream> } "." } ;
+
+{ read-vorbis-stream <vorbis-stream> } related-words
+
+HELP: vorbis-error
+{ $values
+ { "code" integer }
+}
+{ $description { $link <vorbis-stream> } " throws this error when the Vorbis library raises an error while trying to parse the stream." } ;
+
+HELP: vorbis-stream
+{ $class-description "Objects of this class maintain the stream and decoder state for the Ogg Vorbis decoder. " { $snippet "vorbis-stream" } " implements the " { $link "audio.engine-generators" } ", so it can be used as the generator for a " { $link streaming-audio-clip } ". Use " { $link <vorbis-stream> } " or " { $link read-vorbis-stream } " to construct a Vorbis stream." } ;
+
+ARTICLE: "audio.vorbis" "Ogg Vorbis audio streaming"
+"The " { $vocab-link "audio.vorbis" } " vocabulary provides Ogg Vorbis decoding and streaming for " { $vocab-link "audio.engine" } "."
+{ $subsections
+ vorbis-stream
+ read-vorbis-stream
+ <vorbis-stream>
+} ;
+
+ABOUT: "audio.vorbis"
--- /dev/null
+! (c)2007, 2010 Chris Double, Joe Groff bsd license
+USING: accessors alien.c-types audio.engine byte-arrays classes.struct
+combinators destructors fry io io.files io.encodings.binary
+kernel libc locals make math math.order math.parser ogg ogg.vorbis
+sequences specialized-arrays specialized-vectors ;
+FROM: alien.c-types => float short void* ;
+SPECIALIZED-ARRAYS: float void* ;
+SPECIALIZED-VECTOR: short
+IN: audio.vorbis
+
+TUPLE: vorbis-stream < disposable
+ stream
+ { buffer byte-array }
+ { packet ogg-packet }
+ { sync-state ogg-sync-state }
+ { page ogg-page }
+ { stream-state ogg-stream-state }
+ { info vorbis-info }
+ { dsp-state vorbis-dsp-state }
+ { block vorbis-block }
+ { comment vorbis-comment }
+ { temp-state ogg-stream-state }
+ { #vorbis-headers integer initial: 0 } ;
+
+CONSTANT: stream-buffer-size 4096
+
+ERROR: ogg-error code ;
+ERROR: vorbis-error code ;
+ERROR: no-vorbis-in-ogg ;
+
+<PRIVATE
+: init-vorbis ( vorbis-stream -- )
+ [ sync-state>> ogg_sync_init drop ]
+ [ info>> vorbis_info_init ]
+ [ comment>> vorbis_comment_init ] tri ;
+
+: sync-buffer ( vorbis-stream -- buffer size )
+ sync-state>> stream-buffer-size ogg_sync_buffer
+ stream-buffer-size ; inline
+
+: read-bytes-into ( dest size stream -- len )
+ #! Read the given number of bytes from a stream
+ #! and store them in the destination byte array.
+ stream-read >byte-array dup length [ memcpy ] keep ;
+
+: stream-into-buffer ( buffer size vorbis-stream -- len )
+ stream>> read-bytes-into ; inline
+
+: ?ogg-error ( n -- )
+ dup 0 < [ ogg-error ] [ drop ] if ; inline
+
+: confirm-buffer ( len vorbis-stream -- ? )
+ '[ _ sync-state>> swap ogg_sync_wrote ?ogg-error ] keep zero? not ; inline
+
+: buffer-data-from-stream ( vorbis-stream -- ? )
+ [ sync-buffer ] [ stream-into-buffer ] [ confirm-buffer ] tri ; inline
+
+: queue-page ( vorbis-stream -- )
+ [ stream-state>> ] [ page>> ] bi ogg_stream_pagein drop ; inline
+
+: retrieve-page ( vorbis-stream -- ? )
+ [ sync-state>> ] [ page>> ] bi ogg_sync_pageout 0 > ; inline
+
+: (sync-pages) ( vorbis-stream ? -- ? )
+ over retrieve-page
+ [ drop [ queue-page ] [ t (sync-pages) ] bi ] [
+ over buffer-data-from-stream
+ [ (sync-pages) ] [ nip ] if
+ ] if ;
+: sync-pages ( vorbis-stream -- ? )
+ f (sync-pages) ; inline
+
+: standard-initial-header? ( vorbis-stream -- bool )
+ page>> ogg_page_bos zero? not ; inline
+
+: ogg-stream-init ( vorbis-stream -- state )
+ [ temp-state>> dup ]
+ [ page>> ogg_page_serialno ogg_stream_init ?ogg-error ] bi ; inline
+
+: ogg-stream-pagein ( state vorbis-stream -- )
+ page>> ogg_stream_pagein drop ; inline
+
+: ogg-stream-packetout ( state vorbis-stream -- )
+ packet>> ogg_stream_packetout drop ; inline
+
+: decode-packet ( vorbis-stream -- state )
+ [ ogg-stream-init ] keep
+ [ ogg-stream-pagein ] [ ogg-stream-packetout ] [ drop ] 2tri ; inline
+
+: vorbis-header? ( vorbis-stream -- ? )
+ [ info>> ] [ comment>> ] [ packet>> ] tri vorbis_synthesis_headerin 0 >= ; inline
+
+: is-initial-vorbis-packet? ( vorbis-stream -- ? )
+ dup #vorbis-headers>> zero? [ vorbis-header? ] [ drop f ] if ; inline
+
+: save-initial-vorbis-header ( state vorbis-stream -- )
+ [ stream-state>> swap dup byte-length memcpy ]
+ [ 1 >>#vorbis-headers drop ] bi ; inline
+
+: drop-initial-other-header ( state vorbis-stream -- )
+ swap ogg_stream_clear 2drop ; inline
+
+: process-initial-header ( vorbis-stream -- ? )
+ dup standard-initial-header? [
+ [ decode-packet ] keep
+ dup is-initial-vorbis-packet?
+ [ save-initial-vorbis-header ]
+ [ drop-initial-other-header ] if
+ t
+ ] [ drop f ] if ;
+
+: parse-initial-headers ( vorbis-stream -- )
+ dup retrieve-page
+ [ dup process-initial-header [ parse-initial-headers ] [ queue-page ] if ]
+ [ dup buffer-data-from-stream [ parse-initial-headers ] [ drop ] if ] if ;
+
+: have-required-vorbis-headers? ( vorbis-stream -- ? )
+ #vorbis-headers>> 1 2 between? not ; inline
+
+: ?vorbis-error ( code -- )
+ [ vorbis-error ] unless-zero ; inline
+
+: get-remaining-vorbis-header-packet ( player -- ? )
+ [ stream-state>> ] [ packet>> ] bi ogg_stream_packetout {
+ { [ dup 0 < ] [ vorbis-error ] }
+ { [ dup zero? ] [ drop f ] }
+ [ drop t ]
+ } cond ;
+
+: decode-remaining-vorbis-header-packet ( vorbis-stream -- )
+ [ info>> ] [ comment>> ] [ packet>> ] tri vorbis_synthesis_headerin ?vorbis-error ;
+
+: parse-remaining-vorbis-headers ( vorbis-stream -- )
+ dup have-required-vorbis-headers? not [
+ dup get-remaining-vorbis-header-packet [
+ [ decode-remaining-vorbis-header-packet ]
+ [ [ 1 + ] change-#vorbis-headers drop ]
+ [ parse-remaining-vorbis-headers ] tri
+ ] [ drop ] if
+ ] [ drop ] if ;
+
+: parse-remaining-headers ( vorbis-stream -- )
+ dup have-required-vorbis-headers? not [
+ [ parse-remaining-vorbis-headers ]
+ [ dup retrieve-page [ queue-page ] [ buffer-data-from-stream drop ] if ]
+ [ parse-remaining-headers ] tri
+ ] [ drop ] if ;
+
+: init-vorbis-codec ( vorbis-stream -- )
+ [ [ dsp-state>> ] [ info>> ] bi vorbis_synthesis_init drop ]
+ [ [ dsp-state>> ] [ block>> ] bi vorbis_block_init drop ] bi ;
+
+: initialize-decoder ( vorbis-stream -- )
+ dup #vorbis-headers>> zero?
+ [ no-vorbis-in-ogg ]
+ [ init-vorbis-codec ] if ;
+
+: get-pending-decoded-audio ( vorbis-stream -- pcm len )
+ dsp-state>> f <void*> [ vorbis_synthesis_pcmout ] keep *void* swap ;
+
+: float>short-sample ( float -- short )
+ -32767.5 * 0.5 - >integer -32768 32767 clamp ; inline
+
+:: write-pcm-to-buffer ( vorbis-stream offset pcm len -- offset' )
+ vorbis-stream buffer>> :> buffer
+ buffer length -1 shift :> buffer-length
+ offset -1 shift :> sample-offset
+ buffer buffer-length <direct-short-array> sample-offset short-vector boa :> short-buffer
+ vorbis-stream info>> channels>> :> #channels
+ buffer-length sample-offset - #channels /i :> max-len
+ len max-len min :> len'
+ pcm #channels <direct-void*-array> :> channel*s
+
+ len' iota [| sample |
+ #channels iota [| channel |
+ channel channel*s nth len <direct-float-array>
+ sample swap nth
+ float>short-sample short-buffer push
+ ] each
+ ] each
+ vorbis-stream dsp-state>> len' vorbis_synthesis_read drop
+ short-buffer length 1 shift ; inline
+
+: queue-audio ( vorbis-stream -- ? )
+ dup [ stream-state>> ] [ packet>> ] bi ogg_stream_packetout 0 > [
+ dup [ block>> ] [ packet>> ] bi vorbis_synthesis 0 = [
+ [ dsp-state>> ] [ block>> ] bi vorbis_synthesis_blockin drop
+ ] [ drop ] if t
+ ] [ drop f ] if ;
+
+: (decode-audio) ( vorbis-stream offset -- offset' )
+ over get-pending-decoded-audio dup 0 > [ write-pcm-to-buffer ] [
+ 2drop over queue-audio [ (decode-audio) ] [ nip ] if
+ ] if ;
+
+: decode-audio ( vorbis-stream offset -- offset' )
+ 2dup (decode-audio) {
+ {
+ [ 3dup [ buffer>> length ] [ drop ] [ ] tri* = ]
+ [ 2nip ]
+ }
+ {
+ [ 2dup = ]
+ [
+ drop
+ over sync-pages [ decode-audio ] [ nip ] if
+ ]
+ }
+ [ nip decode-audio ]
+ } cond ;
+PRIVATE>
+
+:: <vorbis-stream> ( stream buffer-size -- vorbis-stream )
+ [
+ vorbis-stream new-disposable
+ stream >>stream
+ buffer-size <byte-array> >>buffer
+ ogg-packet malloc-struct |free >>packet
+ ogg-sync-state malloc-struct |free >>sync-state
+ ogg-page malloc-struct |free >>page
+ ogg-stream-state malloc-struct |free >>stream-state
+ vorbis-info malloc-struct |free >>info
+ vorbis-dsp-state malloc-struct |free >>dsp-state
+ vorbis-block malloc-struct |free >>block
+ vorbis-comment malloc-struct |free >>comment
+ ogg-stream-state malloc-struct |free >>temp-state
+ dup {
+ [ init-vorbis ]
+ [ parse-initial-headers ]
+ [ parse-remaining-headers ]
+ [ initialize-decoder ]
+ } cleave
+ ] with-destructors ;
+
+: read-vorbis-stream ( filename buffer-size -- vorbis-stream )
+ [ [ binary <file-reader> |dispose ] dip <vorbis-stream> ] with-destructors ; inline
+
+M: vorbis-stream dispose*
+ {
+ [ temp-state>> [ free ] when* ]
+ [ comment>> [ [ vorbis_comment_clear ] [ free ] bi ] when* ]
+ [ block>> [ free ] when* ]
+ [ dsp-state>> [ free ] when* ]
+ [ info>> [ [ vorbis_info_clear ] [ free ] bi ] when* ]
+ [ stream-state>> [ free ] when* ]
+ [ page>> [ free ] when* ]
+ [ sync-state>> [ free ] when* ]
+ [ packet>> [ free ] when* ]
+ [ stream>> [ dispose ] when* ]
+ } cleave ;
+
+M: vorbis-stream generator-audio-format
+ [ info>> channels>> ] [ drop 16 ] [ info>> rate>> ] tri ;
+M: vorbis-stream generate-audio
+ [ buffer>> ] [ 0 decode-audio ] bi ;
{ make-tuple 2make-tuple 3make-tuple nmake-tuple } related-words
ARTICLE: "combinators.tuple" "Tuple-constructing combinators"
-"The " { $vocab-link "combinators.tuple" } " vocabulary provides dataflow combinators that construct " { $link tuple } " objects."
+"The " { $vocab-link "combinators.tuple" } " vocabulary provides combinators that construct " { $link tuple } " objects. These provide additional functionality above and beyond built-in " { $link "tuple-constructors" } "."
{ $subsections
make-tuple
2make-tuple
{ { $snippet "use-audio-engine?" } " specifies whether the game world should manage an " { $link audio-engine } " instance. False by default." }
{ { $snippet "audio-engine-device" } " specifies the string name of the OpenAL device the audio engine, if any, should try to open. The default value of " { $link POSTPONE: f } " attempts to open the default OpenAL device." }
{ { $snippet "audio-engine-voice-count" } " determines the number of independent voices the audio engine will make available. This determines how many individual audio clips can play simultaneously. This cannot exceed the OpenAL implementation's limit on supported voices." }
-{ { $snippet "audio-engine-buffer-size" } " determines the size in bytes of the audio buffers the audio engine will stream to the sound card." }
-{ { $snippet "audio-engine-buffer-count" } " determines the number of buffers the audio engine will allocate per audio clip played." }
} ;
HELP: game-world
-{ $class-description "A subclass of " { $link world } " that automatically sets up and manages connections to the " { $vocab-link "game.loop" } ", " { $vocab-link "game.input" } ", and " { $vocab-link "audio.engine" } " libraries. It does this by providing methods on " { $link begin-world } ", " { $link end-world } ", and " { $link draw* } ". Subclasses can provide their own world setup and teardown code by adding methods to the " { $link begin-game-world } " and " { $link end-game-world } " generic words."
+{ $class-description "A subclass of " { $link world } " that automatically sets up and manages connections to the " { $vocab-link "game.loop" } ", " { $vocab-link "game.input" } ", and " { $vocab-link "audio.engine" } " libraries. It does this by providing methods on " { $link begin-world } ", " { $link end-world } ", and " { $link draw* } ". Subclasses can provide their own world setup, teardown, and update code by adding methods to the " { $link begin-game-world } " and " { $link end-game-world } " generic words. The standard " { $snippet "world" } " generics " { $link draw-world* } " and " { $link resize-world } " can also be given methods to draw the window contents and handle resize events. The " { $snippet "draw-world*" } " method will be invoked in a tight loop by the game loop."
$nl
"The game-world tuple has the following publicly accessible slots:"
{ $list
begin-game-world
end-game-world
tick-game-world
-} ;
+}
+"The standard " { $snippet "world" } " generics " { $link draw-world* } " and " { $link resize-world } " can also be given methods to draw the window contents and handle resize events. The " { $snippet "draw-world*" } " method will be invoked in a tight loop by the game loop to update the screen." ;
ABOUT: "game.worlds"
{ use-audio-engine? boolean }
{ audio-engine-device initial: f }
{ audio-engine-voice-count initial: 16 }
- { audio-engine-buffer-size initial: 8192 }
- { audio-engine-buffer-count initial: 2 }
{ tick-slice float initial: 0.0 } ;
GENERIC: begin-game-world ( world -- )
{
[ audio-engine-device>> ]
[ audio-engine-voice-count>> ]
- [ audio-engine-buffer-size>> ]
- [ audio-engine-buffer-count>> ]
} cleave <audio-engine>
[ start-audio* ] keep ; inline
{ use-game-input? boolean initial: f }
{ use-audio-engine? boolean initial: f }
{ audio-engine-device initial: f }
- { audio-engine-voice-count initial: 16 }
- { audio-engine-buffer-size initial: 8192 }
- { audio-engine-buffer-count initial: 2 } ;
+ { audio-engine-voice-count initial: 16 } ;
M: game-world apply-world-attributes
{
[ use-audio-engine?>> >>use-audio-engine? ]
[ audio-engine-device>> >>audio-engine-device ]
[ audio-engine-voice-count>> >>audio-engine-voice-count ]
- [ audio-engine-buffer-size>> >>audio-engine-buffer-size ]
- [ audio-engine-buffer-count>> >>audio-engine-buffer-count ]
[ call-next-method ]
} cleave ;
audio-engine world >>listener update-audio
- audio-engine "vocab:gpu/demos/raytrace/mirror-ball.aiff" read-audio
- spheres first t (audio-clip)
- audio-engine "vocab:gpu/demos/raytrace/red-ball.aiff" read-audio
- spheres second t (audio-clip)
- audio-engine "vocab:gpu/demos/raytrace/green-ball.aiff" read-audio
- spheres third t (audio-clip)
- audio-engine "vocab:gpu/demos/raytrace/yellow-ball.aiff" read-audio
- spheres fourth t (audio-clip)
+ audio-engine spheres first
+ "vocab:gpu/demos/raytrace/mirror-ball.aiff" read-audio t <static-audio-clip>
+ audio-engine spheres second
+ "vocab:gpu/demos/raytrace/red-ball.aiff" read-audio t <static-audio-clip>
+ audio-engine spheres third
+ "vocab:gpu/demos/raytrace/green-ball.aiff" read-audio t <static-audio-clip>
+ audio-engine spheres fourth
+ "vocab:gpu/demos/raytrace/yellow-ball.aiff" read-audio t <static-audio-clip>
4array play-clips ;
{ grab-input? t }
{ use-game-input? t }
{ use-audio-engine? t }
- { audio-engine-buffer-count 4 }
{ pref-dim { 1024 768 } }
{ tick-interval-micros $[ 60 fps ] }
} ;
: set-gpu-api ( -- )
"2.0" require-gl-version
+ "3.0" { { "GL_ARB_vertex_array_object" "GL_APPLE_vertex_array_object" } }
+ require-gl-version-or-extensions
"3.0" has-gl-version? opengl-3 opengl-2 ? gpu-api set-global ;
HOOK: init-gpu-api gpu-api ( -- )
IN: mason.child.tests
USING: mason.child mason.config tools.test namespaces io kernel sequences ;
-[ { "make" "winnt-x86-32" } ] [
+[ { "nmake" "/f" "nmakefile" } ] [
[
"winnt" target-os set
"x86.32" target-cpu set
-! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov.
+! Copyright (C) 2008, 2010 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays calendar combinators.short-circuit fry
continuations debugger io.directories io.files io.launcher
io.pathnames io.encodings.ascii kernel make mason.common mason.config
mason.platform mason.report mason.notify namespaces sequences
-quotations macros ;
+quotations macros system combinators ;
IN: mason.child
: make-cmd ( -- args )
- gnu-make platform 2array ;
+ {
+ { [ target-os get "winnt" = ] [ { "nmake" "/f" "nmakefile" } ] }
+ [ gnu-make platform 2array ]
+ } cond ;
: make-vm ( -- )
"factor" [
continuations strings io.sockets ;
IN: mason.common
+ERROR: no-host-name ;
+
: short-host-name ( -- string )
- host-name "." split1 drop ;
+ host-name "." split1 drop [ no-host-name ] unless* ;
SYMBOL: current-git-id
read-longlong >>cursor
read-int32 >>start#
read-int32 [ >>returned# ] keep
- [ H{ } stream>assoc ] accumulator [ times ] dip >>objects ;
+ [ H{ } stream>assoc ] collector [ times ] dip >>objects ;
: read-header ( message -- message )
read-int32 >>length
set iskeyword=!,@,33-35,%,$,38-64,A-Z,91-96,a-z,123-126,128-255
endif
-syn cluster factorCluster contains=factorComment,factorKeyword,factorRepeat,factorConditional,factorBoolean,factorCompileDirective,factorString,factorSbuf,@factorNumber,@factorNumErr,factorDelimiter,factorChar,factorCharErr,factorBackslash,@factorWordOps,factorAlien,factorTuple
+syn cluster factorCluster contains=factorComment,factorFryDirective,factorKeyword,factorRepeat,factorConditional,factorBoolean,factorCompileDirective,factorString,factorTriString,factorSbuf,@factorNumber,@factorNumErr,factorDelimiter,factorChar,factorBackslash,factorLiteral,factorLiteralBlock,@factorWordOps,factorAlien,factorTuple,factorStruct
syn match factorTodo /\(TODO\|FIXME\|XXX\):\=/ contained
-syn match factorComment /\<#! .*/ contains=factorTodo
-syn match factorComment /\<! .*/ contains=factorTodo
+syn match factorComment /\<#!\>.*/ contains=factorTodo
+syn match factorComment /\<!\>.*/ contains=factorTodo
syn cluster factorDefnContents contains=@factorCluster,factorStackEffect,factorLiteralStackEffect,factorArray0,factorQuotation0
syn region None matchgroup=factorPrivate start=/\<<PRIVATE\>/ end=/\<PRIVATE>\>/ contains=@factorDefnContents,factorPrivateDefn,factorPrivateMethod,factorPGeneric,factorPGenericN
-syn keyword factorBoolean boolean f general-t t
+syn keyword factorBoolean f t
+syn match factorFryDirective /\<\(@\|_\)\>/ contained
syn keyword factorCompileDirective inline foldable recursive
<%
syn cluster factorReal contains=factorInt,factorFloat,factorRatio,factorBinary,factorHex,factorOctal
syn cluster factorNumber contains=@factorReal,factorComplex
syn cluster factorNumErr contains=factorBinErr,factorHexErr,factorOctErr
-syn match factorInt /\<-\=\d\+\>/
-syn match factorFloat /\<-\=\d*\.\d\+\>/
-syn match factorRatio /\<-\=\d*\.*\d\+\/-\=\d*\.*\d\+\>/
+syn match factorInt /\<-\=[0-9]\([0-9,]*[0-9]\)\?\>/
+syn match factorFloat /\<-\=[0-9]\([0-9,]*[0-9]\)\?\.[0-9,]*[0-9]\+\>/
+syn match factorRatio /\<-\=[0-9]\([0-9,]*[0-9]\)\?\(+[0-9]\([0-9,]*[0-9]\+\)\?\)\?\/-\=[0-9]\([0-9,]*[0-9]\+\)\?\.\?\>/
syn region factorComplex start=/\<C{\>/ end=/\<}\>/ contains=@factorReal
-syn match factorBinErr /\<BIN:\s\+[01]*[^\s01]\S*\>/
-syn match factorBinary /\<BIN:\s\+[01]\+\>/
-syn match factorHexErr /\<HEX:\s\+\x*[^\x\s]\S*\>/
-syn match factorHex /\<HEX:\s\+\x\+\>/
-syn match factorOctErr /\<OCT:\s\+\o*[^\o\s]\S*\>/
-syn match factorOctal /\<OCT:\s\+\o\+\>/
+syn match factorBinErr /\<BIN:\s\+-\=[01,]*[^01 ]\S*\>/
+syn match factorBinary /\<BIN:\s\+-\=[01,]\+\>/
+syn match factorHexErr /\<HEX:\s\+-\=\(,\S*\|\S*,\|[-0-9a-fA-Fp,]*[^-0-9a-fA-Fp, ]\S*\)\>/
+syn match factorHex /\<HEX:\s\+-\=[0-9a-fA-F]\([0-9a-fA-F,]*[0-9a-fA-F]\)\?\(\.[0-9a-fA-F]\([0-9a-fA-F,]*[0-9a-fA-F]\)\?\)\?\(p-\=[0-9]\([0-9,]*[0-9]\)\?\)\?\>/
+syn match factorOctErr /\<OCT:\s\+-\=\(,\S*\|\S*,\|[0-7,]*[^0-7, ]\S*\)\>/
+syn match factorOctal /\<OCT:\s\+-\=[0-7,]\+\>/
+syn match factorNan /\<NAN:\s\+[0-9a-fA-F]\([0-9a-fA-F,]*[0-9a-fA-F]\)\?\>/
syn match factorIn /\<IN:\s\+\S\+\>/
syn match factorUse /\<USE:\s\+\S\+\>/
syn match factorUnuse /\<UNUSE:\s\+\S\+\>/
-syn match factorCharErr /\<CHAR:\s\+\S\+/
-syn match factorChar /\<CHAR:\s\+\\\=\S\>/
+syn match factorChar /\<CHAR:\s\+\S\+\>/
syn match factorBackslash /\<\\\>\s\+\S\+\>/
+syn match factorLiteral /\<\$\>\s\+\S\+\>/
+syn region factorLiteralBlock start=/\<\$\[\>/ end=/\<\]\>/
syn region factorUsing start=/\<USING:\>/ end=/;/
+syn match factorQualified /\<QUALIFIED:\s\+\S\+\>/
+syn match factorQualifiedWith /\<QUALIFIED-WITH:\s\+\S\+\s\+\S\+\>/
+syn region factorFrom start=/\<FROM:\>/ end=/;/
syn region factorSingletons start=/\<SINGLETONS:\>/ end=/;/
syn match factorSymbol /\<SYMBOL:\s\+\S\+\>/
syn region factorSymbols start=/\<SYMBOLS:\>/ end=/;/
syn region factorConstructor2 start=/\<CONSTRUCTOR:\?/ end=/;/
syn region factorTuple start=/\<TUPLE:\>/ end=/\<;\>/
+syn region factorStruct start=/\<\(UNION-STRUCT:\|STRUCT:\)\>/ end=/\<;\>/
syn match factorConstant /\<CONSTANT:\s\+\S\+\>/
+syn match factorAlias /\<ALIAS:\s\+\S\+\>/
syn match factorSingleton /\<SINGLETON:\s\+\S\+\>/
syn match factorPostpone /\<POSTPONE:\s\+\S\+\>/
syn match factorDefer /\<DEFER:\s\+\S\+\>/
syn match factorHook /\<HOOK:\s\+\S\+\s\+\S\+\>/
syn match factorMain /\<MAIN:\s\+\S\+\>/
syn match factorConstructor /\<C:\s\+\S\+\s\+\S\+\>/
-syn match factorAlien /\<ALIEN:\s\+\d\+\>/
-
-syn cluster factorWordOps contains=factorSymbol,factorPostpone,factorDefer,factorForget,factorMixin,factorInstance,factorHook,factorMain,factorConstructor
+syn match factorAlien /\<ALIEN:\s\+[0-9a-fA-F]\([0-9a-fA-F,]*[0-9a-fA-F]\)\?\>/
+syn cluster factorWordOps contains=factorConstant,factorAlias,factorSingleton,factorSingletons,factorSymbol,factorSymbols,factorPostpone,factorDefer,factorForget,factorMixin,factorInstance,factorHook,factorMain,factorConstructor
"TODO:
"misc:
" PRIMITIVE:
"C interface:
-" FIELD:
-" BEGIN-STRUCT:
" C-ENUM:
" FUNCTION:
-" END-STRUCT
-" DLL"
" TYPEDEF:
" LIBRARY:
-" C-UNION:
-"QUALIFIED:
-"QUALIFIED-WITH:
-"FROM:
-"ALIAS:
-"! POSTPONE: "
"#\ "
-syn region factorString start=/"/ skip=/\\"/ end=/"/ oneline
-syn region factorSbuf start=/SBUF" / skip=/\\"/ end=/"/ oneline
+syn region factorString start=/\<"/ skip=/\\"/ end=/"/
+syn region factorTriString start=/\<"""/ skip=/\\"/ end=/"""/
+syn region factorSbuf start=/\<SBUF"\>/ skip=/\\"/ end=/"/
syn region factorMultiString matchgroup=factorMultiStringDelims start=/\<STRING:\s\+\S\+\>/ end=/^;$/ contains=factorMultiStringContents
syn match factorMultiStringContents /.*/ contained
syn region factorQuotation matchgroup=factorDelimiter start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ matchgroup=factorDelimiter end=/\<\]\>/ contains=ALL
else
syn region factorQuotation0 matchgroup=hlLevel0 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation1,factorArray1
- syn region factorQuotation1 contained matchgroup=hlLevel1 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation2,factorArray2
- syn region factorQuotation2 contained matchgroup=hlLevel2 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation3,factorArray3
- syn region factorQuotation3 contained matchgroup=hlLevel3 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation4,factorArray4
- syn region factorQuotation4 contained matchgroup=hlLevel4 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation5,factorArray5
- syn region factorQuotation5 contained matchgroup=hlLevel5 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation6,factorArray6
- syn region factorQuotation6 contained matchgroup=hlLevel6 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation7,factorArray7
- syn region factorQuotation7 contained matchgroup=hlLevel7 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation8,factorArray8
- syn region factorQuotation8 contained matchgroup=hlLevel8 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation9,factorArray9
- syn region factorQuotation9 contained matchgroup=hlLevel9 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation0,factorArray0
+ syn region factorQuotation1 contained matchgroup=hlLevel1 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation2,factorArray2
+ syn region factorQuotation2 contained matchgroup=hlLevel2 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation3,factorArray3
+ syn region factorQuotation3 contained matchgroup=hlLevel3 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation4,factorArray4
+ syn region factorQuotation4 contained matchgroup=hlLevel4 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation5,factorArray5
+ syn region factorQuotation5 contained matchgroup=hlLevel5 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation6,factorArray6
+ syn region factorQuotation6 contained matchgroup=hlLevel6 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation7,factorArray7
+ syn region factorQuotation7 contained matchgroup=hlLevel7 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation8,factorArray8
+ syn region factorQuotation8 contained matchgroup=hlLevel8 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation9,factorArray9
+ syn region factorQuotation9 contained matchgroup=hlLevel9 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation0,factorArray0
endif
if exists("g:factor_norainbow")
- syn region factorArray matchgroup=factorDelimiter start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ matchgroup=factorDelimiter end=/\<}\>/ contains=ALL
+ syn region factorArray matchgroup=factorDelimiter start=/\<\(\$\|[-a-zA-Z0-9]\+\)\?{\>/ matchgroup=factorDelimiter end=/\<}\>/ contains=ALL
else
- syn region factorArray0 matchgroup=hlLevel0 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray1,factorQuotation1
- syn region factorArray1 contained matchgroup=hlLevel1 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray2,factorQuotation2
- syn region factorArray2 contained matchgroup=hlLevel2 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray3,factorQuotation3
- syn region factorArray3 contained matchgroup=hlLevel3 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray4,factorQuotation4
- syn region factorArray4 contained matchgroup=hlLevel4 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray5,factorQuotation5
- syn region factorArray5 contained matchgroup=hlLevel5 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray6,factorQuotation6
- syn region factorArray6 contained matchgroup=hlLevel6 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray7,factorQuotation7
- syn region factorArray7 contained matchgroup=hlLevel7 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray8,factorQuotation8
- syn region factorArray8 contained matchgroup=hlLevel8 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray9,factorQuotation9
- syn region factorArray9 contained matchgroup=hlLevel9 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray0,factorQuotation0
+ syn region factorArray0 matchgroup=hlLevel0 start=/\<\(\$\|[-a-zA-Z0-9]\+\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray1,factorQuotation1
+ syn region factorArray1 contained matchgroup=hlLevel1 start=/\<\(\$\|[-a-zA-Z0-9]\+\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray2,factorQuotation2
+ syn region factorArray2 contained matchgroup=hlLevel2 start=/\<\(\$\|[-a-zA-Z0-9]\+\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray3,factorQuotation3
+ syn region factorArray3 contained matchgroup=hlLevel3 start=/\<\(\$\|[-a-zA-Z0-9]\+\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray4,factorQuotation4
+ syn region factorArray4 contained matchgroup=hlLevel4 start=/\<\(\$\|[-a-zA-Z0-9]\+\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray5,factorQuotation5
+ syn region factorArray5 contained matchgroup=hlLevel5 start=/\<\(\$\|[-a-zA-Z0-9]\+\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray6,factorQuotation6
+ syn region factorArray6 contained matchgroup=hlLevel6 start=/\<\(\$\|[-a-zA-Z0-9]\+\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray7,factorQuotation7
+ syn region factorArray7 contained matchgroup=hlLevel7 start=/\<\(\$\|[-a-zA-Z0-9]\+\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray8,factorQuotation8
+ syn region factorArray8 contained matchgroup=hlLevel8 start=/\<\(\$\|[-a-zA-Z0-9]\+\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray9,factorQuotation9
+ syn region factorArray9 contained matchgroup=hlLevel9 start=/\<\(\$\|[-a-zA-Z0-9]\+\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray0,factorQuotation0
endif
syn match factorBracketErr /\<\]\>/
HiLink factorConditional Conditional
HiLink factorKeyword Keyword
HiLink factorOperator Operator
+ HiLink factorFryDirective Operator
HiLink factorBoolean Boolean
HiLink factorDefnDelims Typedef
HiLink factorMethodDelims Typedef
HiLink factorPGenericDelims Special
HiLink factorPGenericNDelims Special
HiLink factorString String
+ HiLink factorTriString String
HiLink factorSbuf String
HiLink factorMultiStringContents String
HiLink factorMultiStringDelims Typedef
HiLink factorBinErr Error
HiLink factorHex Number
HiLink factorHexErr Error
+ HiLink factorNan Number
HiLink factorOctal Number
HiLink factorOctErr Error
HiLink factorFloat Float
HiLink factorInt Number
HiLink factorUsing Include
+ HiLink factorQualified Include
+ HiLink factorQualifiedWith Include
+ HiLink factorFrom Include
HiLink factorUse Include
HiLink factorUnuse Include
HiLink factorIn Define
HiLink factorChar Character
- HiLink factorCharErr Error
HiLink factorDelimiter Delimiter
HiLink factorBackslash Special
+ HiLink factorLiteral Special
+ HiLink factorLiteralBlock Special
HiLink factorCompileDirective Typedef
HiLink factorSymbol Define
HiLink factorConstant Define
HiLink factorForget Define
HiLink factorAlien Define
HiLink factorTuple Typedef
+ HiLink factorStruct Typedef
if &bg == "dark"
hi hlLevel0 ctermfg=red guifg=red1
set iskeyword=!,@,33-35,%,$,38-64,A-Z,91-96,a-z,123-126,128-255
endif
-syn cluster factorCluster contains=factorComment,factorFryDirective,factorKeyword,factorRepeat,factorConditional,factorBoolean,factorCompileDirective,factorString,factorTriString,factorSbuf,@factorNumber,@factorNumErr,factorDelimiter,factorChar,factorCharErr,factorBackslash,factorLiteral,factorLiteralBlock,@factorWordOps,factorAlien,factorTuple,factorStruct
+syn cluster factorCluster contains=factorComment,factorFryDirective,factorKeyword,factorRepeat,factorConditional,factorBoolean,factorCompileDirective,factorString,factorTriString,factorSbuf,@factorNumber,@factorNumErr,factorDelimiter,factorChar,factorBackslash,factorLiteral,factorLiteralBlock,@factorWordOps,factorAlien,factorTuple,factorStruct
syn match factorTodo /\(TODO\|FIXME\|XXX\):\=/ contained
syn match factorComment /\<#!\>.*/ contains=factorTodo
syn match factorFryDirective /\<\(@\|_\)\>/ contained
syn keyword factorCompileDirective inline foldable recursive
-syn keyword factorKeyword boolean
-syn keyword factorKeyword or tuck 2bi 2tri while wrapper nip 4dip wrapper? bi* callstack>array both? hashcode die dupd callstack callstack? 3dup tri@ pick curry build ?execute 3bi prepose >boolean ?if clone eq? tri* ? = swapd call-clear 2over 2keep 3keep clear 2dup when not tuple? dup 2bi* 2tri* call tri-curry object bi@ do unless* if* loop bi-curry* drop when* assert= retainstack assert? -rot execute 2bi@ 2tri@ boa with either? 3drop bi curry? datastack until 3dip over 3curry roll tri-curry* swap tri-curry@ 2nip and throw set-retainstack bi-curry (clone) hashcode* compose spin 2dip if 3tri unless compose? tuple keep 2curry equal? set-datastack assert tri 2drop most <wrapper> boolean? identity-tuple? null new set-callstack dip bi-curry@ rot -roll xor identity-tuple boolean
+syn keyword factorKeyword or 2bi 2tri while wrapper nip 4dip wrapper? bi* callstack>array both? hashcode die dupd callstack callstack? 3dup tri@ pick curry build ?execute 3bi prepose >boolean ?if clone eq? tri* ? = swapd 2over 2keep 3keep clear 2dup when not tuple? dup 2bi* 2tri* call tri-curry object bi@ do unless* if* loop bi-curry* drop when* assert= retainstack assert? -rot execute 2bi@ 2tri@ boa with either? 3drop bi curry? datastack until 3dip over 3curry tri-curry* tri-curry@ swap and 2nip throw bi-curry (clone) hashcode* compose 2dip if 3tri unless compose? tuple keep 2curry equal? assert tri 2drop most <wrapper> boolean? identity-hashcode identity-tuple? null new dip bi-curry@ rot xor identity-tuple boolean
syn keyword factorKeyword ?at assoc? assoc-clone-like assoc= delete-at* assoc-partition extract-keys new-assoc value? assoc-size map>assoc push-at assoc-like key? assoc-intersect assoc-refine update assoc-union assoc-combine at* assoc-empty? at+ set-at assoc-all? assoc-subset? assoc-hashcode change-at assoc-each assoc-diff zip values value-at rename-at inc-at enum? at cache assoc>map <enum> assoc assoc-map enum value-at* assoc-map-as >alist assoc-filter-as clear-assoc assoc-stack maybe-set-at substitute assoc-filter 2cache delete-at assoc-find keys assoc-any? unzip
syn keyword factorKeyword case execute-effect no-cond no-case? 3cleave>quot 2cleave cond>quot wrong-values? no-cond? cleave>quot no-case case>quot 3cleave wrong-values to-fixed-point alist>quot case-find cond cleave call-effect 2cleave>quot recursive-hashcode linear-case-quot spread spread>quot
-syn keyword factorKeyword byte-array>bignum sgn >bignum next-float number= each-integer next-power-of-2 ?1+ fp-special? imaginary-part mod recip float>bits rational >float number? 2^ bignum? integer fixnum? neg fixnum sq bignum fp-snan? fp-infinity? denominator (all-integers?) times find-last-integer (each-integer) bit? * + fp-bitwise= - fp-qnan? / power-of-2? >= bitand find-integer complex <fp-nan> < log2 > integer? real number bits>double double>bits bitor 2/ zero? rem fp-nan-payload all-integers? (find-integer) real-part prev-float align bits>float float? shift float fp-nan? abs bitxor ratio? even? <= /mod odd? >integer ratio rational? bitnot real? >fixnum complex? /i numerator /f
-syn keyword factorKeyword append assert-sequence= find-last-from trim-head-slice clone-like 3sequence assert-sequence? map-as filter! last-index-from reversed index-from cut* pad-tail (indices) concat-as remove-eq but-last snip trim-tail nths nth 2pusher sequence slice? <slice> partition remove-nth tail-slice empty? tail* if-empty find-from virtual-sequence? member? set-length remove-eq! drop-prefix unclip iota unclip-last-slice bounds-error? sequence-hashcode-step map start midpoint@ rest-slice prepend fourth sift remove! map-sum new-sequence follow like remove-nth! first4 1sequence reverse slice unless-empty padding virtual@ repetition? set-last index 4sequence max-length set-second immutable-sequence first2 first3 replicate-as reduce-index unclip-slice supremum insert-nth trim-tail-slice tail 3append short count suffix concat flip filter sum immutable? 2sequence map-integers delete-all start* indices snip-slice check-slice sequence? head map-find reduce append-as reverse! sequence= halves collapse-slice interleave 2map binary-reduce virtual-seq slice-error? product bounds-check? bounds-check harvest immutable find produce remove pad-head last replicate set-fourth shorten reversed? map-find-last 3map-as 2unclip-slice shorter? 3map find-last head-slice pop* 2map-as tail-slice* but-last-slice 2map-reduce iota? accumulate each pusher cut-slice new-resizable each-index head-slice* 2reverse-each sequence-hashcode member-eq? pop set-nth ?nth <flat-slice> second map! join when-empty accumulator immutable-sequence? <reversed> all? 3append-as virtual-sequence subseq? push-either new-like length last-index push-if 2all? lengthen assert-sequence copy map-reduce move third first 3each tail? set-first prefix bounds-error any? <repetition> trim-slice exchange surround 2reduce cut change-nth min-length set-third produce-as push-all head? delete-slice rest sum-lengths 2each head* infimum glue slice-error subseq replace-slice push repetition map-index trim-head unclip-last mismatch trim
+syn keyword factorKeyword number= if-zero next-power-of-2 each-integer ?1+ fp-special? imaginary-part unless-zero float>bits number? fp-infinity? bignum? fp-snan? denominator fp-bitwise= * + power-of-2? - u>= / >= bitand log2-expects-positive < log2 > integer? number bits>double 2/ zero? (find-integer) bits>float float? shift ratio? even? ratio fp-sign bitnot >fixnum complex? /i /f byte-array>bignum when-zero sgn >bignum next-float u< u> mod recip rational find-last-integer >float (all-integers?) 2^ times integer fixnum? neg fixnum sq bignum (each-integer) bit? fp-qnan? find-integer complex <fp-nan> real double>bits bitor rem fp-nan-payload all-integers? real-part log2-expects-positive? prev-float align unordered? float fp-nan? abs bitxor u<= odd? <= /mod rational? >integer real? numerator
+syn keyword factorKeyword member-eq? append assert-sequence= find-last-from trim-head-slice clone-like 3sequence assert-sequence? map-as last-index-from reversed index-from cut* pad-tail remove-eq! concat-as but-last snip trim-tail nths nth 2selector sequence slice? <slice> partition remove-nth tail-slice empty? tail* if-empty find-from virtual-sequence? member? set-length drop-prefix unclip unclip-last-slice iota map-sum bounds-error? sequence-hashcode-step selector-for accumulate-as map start midpoint@ (accumulate) rest-slice prepend fourth sift accumulate! new-sequence follow map! like first4 1sequence reverse slice unless-empty padding virtual@ repetition? set-last index 4sequence max-length set-second immutable-sequence first2 first3 replicate-as reduce-index unclip-slice supremum suffix! insert-nth trim-tail-slice tail 3append short count suffix concat flip filter sum immutable? reverse! 2sequence map-integers delete-all start* indices snip-slice check-slice sequence? head map-find filter! append-as reduce sequence= halves collapse-slice interleave 2map filter-as binary-reduce slice-error? product bounds-check? bounds-check harvest immutable virtual-exemplar find produce remove pad-head last replicate set-fourth remove-eq shorten reversed? map-find-last 3map-as 2unclip-slice shorter? 3map find-last head-slice pop* 2map-as tail-slice* but-last-slice 2map-reduce iota? collector-for accumulate each selector append! new-resizable cut-slice each-index head-slice* 2reverse-each sequence-hashcode pop set-nth ?nth <flat-slice> second join when-empty collector immutable-sequence? <reversed> all? 3append-as virtual-sequence subseq? remove-nth! push-either new-like length last-index push-if 2all? lengthen assert-sequence copy map-reduce move third first 3each tail? set-first prefix bounds-error any? <repetition> trim-slice exchange surround 2reduce cut change-nth min-length set-third produce-as push-all head? delete-slice rest sum-lengths 2each head* infimum remove! glue slice-error subseq trim replace-slice push repetition map-index trim-head unclip-last mismatch
syn keyword factorKeyword global +@ change set-namestack change-global init-namespaces on off set-global namespace set with-scope bind with-variable inc dec counter initialize namestack get get-global make-assoc
syn keyword factorKeyword <array> 2array 3array pair >array 1array 4array pair? array resize-array array?
-syn keyword factorKeyword +character+ bad-seek-type? readln stream-seek read print with-output-stream contents write1 stream-write1 stream-copy stream-element-type with-input-stream stream-print stream-read stream-contents bl seek-output bad-seek-type nl stream-nl write flush stream-lines +byte+ stream-flush read1 seek-absolute? stream-read1 lines stream-readln stream-read-until each-line seek-end with-output-stream* seek-absolute with-streams seek-input seek-relative? input-stream stream-write read-partial seek-end? seek-relative error-stream read-until with-input-stream* with-streams* each-block output-stream stream-read-partial
+syn keyword factorKeyword +character+ bad-seek-type? readln each-morsel stream-seek read print with-output-stream contents write1 stream-write1 stream-copy stream-element-type with-input-stream stream-print stream-read stream-contents stream-tell tell-output bl seek-output bad-seek-type nl stream-nl write flush stream-lines +byte+ stream-flush read1 seek-absolute? stream-read1 lines stream-readln stream-read-until each-line seek-end with-output-stream* seek-absolute with-streams seek-input seek-relative? input-stream stream-write read-partial seek-end? seek-relative error-stream read-until with-input-stream* with-streams* tell-input each-block output-stream stream-read-partial each-stream-block each-stream-line
syn keyword factorKeyword resize-string >string <string> 1string string string?
syn keyword factorKeyword vector? <vector> ?push vector >vector 1vector
syn keyword factorKeyword with-return restarts return-continuation with-datastack recover rethrow-restarts <restart> ifcc set-catchstack >continuation< cleanup ignore-errors restart? compute-restarts attempt-all-error error-thread continue <continuation> attempt-all-error? condition? <condition> throw-restarts error catchstack continue-with thread-error-hook continuation rethrow callcc1 error-continuation callcc0 attempt-all condition continuation? restart return
syn match factorUse /\<USE:\s\+\S\+\>/
syn match factorUnuse /\<UNUSE:\s\+\S\+\>/
-syn match factorCharErr /\<CHAR:\s\+\S\+/
-syn match factorChar /\<CHAR:\s\+\\\=\S\>/
+syn match factorChar /\<CHAR:\s\+\S\+\>/
syn match factorBackslash /\<\\\>\s\+\S\+\>/
syn match factorLiteral /\<\$\>\s\+\S\+\>/
syn region factorString start=/\<"/ skip=/\\"/ end=/"/
syn region factorTriString start=/\<"""/ skip=/\\"/ end=/"""/
-syn region factorSbuf start=/\<SBUF"\>/ skip=/\\"/ end=/"/
+syn region factorSbuf start=/\<[-a-zA-Z0-9]\+"\>/ skip=/\\"/ end=/"/
syn region factorMultiString matchgroup=factorMultiStringDelims start=/\<STRING:\s\+\S\+\>/ end=/^;$/ contains=factorMultiStringContents
syn match factorMultiStringContents /.*/ contained
HiLink factorUnuse Include
HiLink factorIn Define
HiLink factorChar Character
- HiLink factorCharErr Error
HiLink factorDelimiter Delimiter
HiLink factorBackslash Special
HiLink factorLiteral Special
-#error "lol"
DLL_PATH=http://factorcode.org/dlls/64
CC=$(WIN64_PATH)-gcc.exe
WINDRES=$(WIN64_PATH)-windres.exe
#endif
#elif defined(FACTOR_AMD64)
#if defined(_MSC_VER)
- _BitScanReverse64(&n,x);
+ n = 0;
+ _BitScanReverse64((DWORD *)&n,x);
#else
asm ("bsr %1, %0;":"=r"(n):"r"(x));
#endif
}
}
-void factor_vm::check_code_address(cell address)
-{
-#ifdef FACTOR_DEBUG
- assert(address >= code->seg->start && address < code->seg->end);
-#endif
-}
-
/* References to undefined symbols are patched up to call this function on
image load */
void factor_vm::undefined_symbol()
inline static void set_call_target(cell return_address, void *target)
{
check_call_site(return_address);
- *(int *)(return_address - 4) = ((cell)target - return_address);
+ *(int *)(return_address - 4) = (u32)((cell)target - return_address);
}
inline static bool tail_call_site_p(cell return_address)
else if(strcmp(cmd,"x") == 0)
exit(1);
else if(strcmp(cmd,"im") == 0)
- save_image(STRING_LITERAL("fep.image"));
+ save_image(STRING_LITERAL("fep.image.saving"),STRING_LITERAL("fep.image"));
else if(strcmp(cmd,"data") == 0)
dump_objects(TYPE_COUNT);
else if(strcmp(cmd,"refs") == 0)
general_error(ERROR_MEMORY,allot_cell(addr),false_object,native_stack);
}
-void factor_vm::signal_error(int signal, stack_frame *native_stack)
+void factor_vm::signal_error(cell signal, stack_frame *native_stack)
{
general_error(ERROR_SIGNAL,allot_cell(signal),false_object,native_stack);
}
-#include <stdbool.h>
+#ifdef _MSC_VER
+ #define WINDOWS
+#else
+ #include <stdbool.h>
+#endif
#if defined(i386) || defined(__i386) || defined(__i386__) || defined(WIN32)
#define F_STDCALL __attribute__((stdcall))
for(; iter < end; iter++)
{
code_root *root = *iter;
- code_block *block = (code_block *)(root->value & -data_alignment);
+ code_block *block = (code_block *)(root->value & (~data_alignment - 1));
if(root->valid && !state->marked_p(block))
root->valid = false;
}
p->aging_size,
p->tenured_size);
- fixnum bytes_read = fread((void*)data->tenured->start,1,h->data_size,file);
+ fixnum bytes_read = safe_fread((void*)data->tenured->start,1,h->data_size,file);
if((cell)bytes_read != h->data_size)
{
if(h->code_size != 0)
{
- size_t bytes_read = fread(code->allocator->first_block(),1,h->code_size,file);
+ size_t bytes_read = safe_fread(code->allocator->first_block(),1,h->code_size,file);
if(bytes_read != h->code_size)
{
std::cout << "truncated image: " << bytes_read << " bytes read, ";
}
image_header h;
- if(fread(&h,sizeof(image_header),1,file) != 1)
+ if(safe_fread(&h,sizeof(image_header),1,file) != 1)
fatal_error("Cannot read image header",0);
if(h.magic != image_magic)
load_data_heap(file,&h,p);
load_code_heap(file,&h,p);
- fclose(file);
+ safe_fclose(file);
init_objects(&h);
}
/* Save the current image to disk */
-bool factor_vm::save_image(const vm_char *filename)
+bool factor_vm::save_image(const vm_char *saving_filename, const vm_char *filename)
{
FILE* file;
image_header h;
- file = OPEN_WRITE(filename);
+ file = OPEN_WRITE(saving_filename);
if(file == NULL)
{
- std::cout << "Cannot open image file: " << filename << std::endl;
+ std::cout << "Cannot open image file: " << saving_filename << std::endl;
std::cout << strerror(errno) << std::endl;
return false;
}
bool ok = true;
- if(fwrite(&h,sizeof(image_header),1,file) != 1) ok = false;
- if(fwrite((void*)data->tenured->start,h.data_size,1,file) != 1) ok = false;
- if(fwrite(code->allocator->first_block(),h.code_size,1,file) != 1) ok = false;
- if(fclose(file)) ok = false;
+ if(safe_fwrite(&h,sizeof(image_header),1,file) != 1) ok = false;
+ if(safe_fwrite((void*)data->tenured->start,h.data_size,1,file) != 1) ok = false;
+ if(safe_fwrite(code->allocator->first_block(),h.code_size,1,file) != 1) ok = false;
+ if(safe_fclose(file)) ok = false;
if(!ok)
std::cout << "save-image failed: " << strerror(errno) << std::endl;
+ else
+ MOVE_FILE(saving_filename,filename);
return ok;
}
/* do a full GC to push everything into tenured space */
primitive_compact_gc();
- data_root<byte_array> path(ctx->pop(),this);
- path.untag_check(this);
- save_image((vm_char *)(path.untagged() + 1));
+ data_root<byte_array> path2(ctx->pop(),this);
+ path2.untag_check(this);
+ data_root<byte_array> path1(ctx->pop(),this);
+ path1.untag_check(this);
+ save_image((vm_char *)(path1.untagged() + 1 ),(vm_char *)(path2.untagged() + 1));
}
void factor_vm::primitive_save_image_and_exit()
/* We unbox this before doing anything else. This is the only point
where we might throw an error, so we have to throw an error here since
later steps destroy the current image. */
- data_root<byte_array> path(ctx->pop(),this);
- path.untag_check(this);
+ data_root<byte_array> path2(ctx->pop(),this);
+ path2.untag_check(this);
+ data_root<byte_array> path1(ctx->pop(),this);
+ path1.untag_check(this);
/* strip out special_objects data which is set on startup anyway */
for(cell i = 0; i < special_object_count; i++)
false /* discard objects only reachable from stacks */);
/* Save the image */
- if(save_image((vm_char *)(path.untagged() + 1)))
+ if(save_image((vm_char *)(path1.untagged() + 1), (vm_char *)(path2.untagged() + 1)))
exit(0);
else
exit(1);
void instruction_operand::store_value_masked(fixnum value, cell mask, cell shift)
{
u32 *ptr = (u32 *)(pointer - sizeof(u32));
- *ptr = ((*ptr & ~mask) | ((value >> shift) & mask));
+ *ptr = (u32)((*ptr & ~mask) | ((value >> shift) & mask));
}
void instruction_operand::store_value(fixnum absolute_value)
*(cell *)(pointer - sizeof(cell)) = absolute_value;
break;
case RC_ABSOLUTE:
- *(u32 *)(pointer - sizeof(u32)) = absolute_value;
+ *(u32 *)(pointer - sizeof(u32)) = (u32)absolute_value;
break;
case RC_RELATIVE:
- *(s32 *)(pointer - sizeof(s32)) = relative_value;
+ *(s32 *)(pointer - sizeof(s32)) = (s32)relative_value;
break;
case RC_ABSOLUTE_PPC_2_2:
store_value_2_2(absolute_value);
relocation_class rel_class,
cell offset)
{
- value = (rel_type << 28) | (rel_class << 24) | offset;
+ value = (u32)((rel_type << 28) | (rel_class << 24) | offset);
}
relocation_type rel_type()
general_error(ERROR_IO,tag_fixnum(errno),false_object,NULL);
}
+size_t safe_fread(void *ptr, size_t size, size_t nitems, FILE *stream)
+{
+ size_t items_read = 0;
+
+ do {
+ items_read += fread((void*)((int*)ptr+items_read*size),size,nitems-items_read,stream);
+ } while(items_read != nitems && errno == EINTR);
+
+ return items_read;
+}
+
+size_t safe_fwrite(void *ptr, size_t size, size_t nitems, FILE *stream)
+{
+ size_t items_written = 0;
+
+ do {
+ items_written += fwrite((void*)((int*)ptr+items_written*size),size,nitems-items_written,stream);
+ } while(items_written != nitems && errno == EINTR);
+
+ return items_written;
+}
+
+int safe_fclose(FILE *stream)
+{
+ int ret = 0;
+
+ do {
+ ret = fclose(stream);
+ } while(ret != 0 && errno == EINTR);
+
+ return ret;
+}
+
void factor_vm::primitive_fopen()
{
data_root<byte_array> mode(ctx->pop(),this);
mode.untag_check(this);
path.untag_check(this);
- for(;;)
- {
- FILE *file = fopen((char *)(path.untagged() + 1),
+ FILE *file;
+ do {
+ file = fopen((char *)(path.untagged() + 1),
(char *)(mode.untagged() + 1));
if(file == NULL)
io_error();
- else
- {
- ctx->push(allot_alien(file));
- break;
- }
- }
+ } while(errno == EINTR);
+
+ ctx->push(allot_alien(file));
}
FILE *factor_vm::pop_file_handle()
{
FILE *file = pop_file_handle();
- for(;;)
- {
+ do {
int c = fgetc(file);
if(c == EOF)
{
ctx->push(tag_fixnum(c));
break;
}
- }
+ } while(errno == EINTR);
}
void factor_vm::primitive_fread()
for(;;)
{
- int c = fread(buf.untagged() + 1,1,size,file);
- if(c <= 0)
+ int c = safe_fread(buf.untagged() + 1,1,size,file);
+ if(c == 0)
{
if(feof(file))
{
}
else
{
- if(c != size)
+ if(feof(file))
{
byte_array *new_buf = allot_byte_array(c);
memcpy(new_buf + 1, buf.untagged() + 1,c);
buf = new_buf;
}
+
ctx->push(buf.value());
break;
}
FILE *file = pop_file_handle();
fixnum ch = to_fixnum(ctx->pop());
- for(;;)
- {
+ do {
if(fputc(ch,file) == EOF)
- {
io_error();
-
- /* Still here? EINTR */
- }
else
break;
- }
+ } while(errno == EINTR);
}
void factor_vm::primitive_fwrite()
if(length == 0)
return;
- for(;;)
- {
- size_t written = fwrite(string,1,length,file);
- if(written == length)
- break;
- else
- {
- if(feof(file))
- break;
- else
- io_error();
-
- /* Still here? EINTR */
- length -= written;
- string += written;
- }
- }
+ size_t written = safe_fwrite(string,1,length,file);
+ if(written != length)
+ io_error();
}
void factor_vm::primitive_ftell()
FILE *file = pop_file_handle();
off_t offset;
- if((offset = FTELL(file)) == -1)
- io_error();
+ do {
+ if((offset = FTELL(file)) == -1)
+ io_error();
+ else
+ break;
+ } while(errno == EINTR);
ctx->push(from_signed_8(offset));
}
break;
}
- if(FSEEK(file,offset,whence) == -1)
- {
- io_error();
-
- /* Still here? EINTR */
- critical_error("Don't know what to do; EINTR from fseek()?",0);
- }
+ do {
+ if(FSEEK(file,offset,whence) == -1)
+ io_error();
+ else
+ break;
+ } while(errno == EINTR);
}
void factor_vm::primitive_fflush()
{
FILE *file = pop_file_handle();
- for(;;)
- {
+ do {
if(fflush(file) == EOF)
io_error();
else
break;
- }
+ } while(errno == EINTR);
}
void factor_vm::primitive_fclose()
{
FILE *file = pop_file_handle();
- for(;;)
- {
- if(fclose(file) == EOF)
- io_error();
- else
- break;
- }
+ if(safe_fclose(file) == EOF)
+ io_error();
}
/* This function is used by FFI I/O. Accessing the errno global directly is
namespace factor
{
+size_t safe_fread(void *ptr, size_t size, size_t nitems, FILE *stream);
+size_t safe_fwrite(void *ptr, size_t size, size_t nitems, FILE *stream);
+int safe_fclose(FILE *stream);
+
/* Platform specific primitives */
VM_C_API int err_no();
/* Detect target CPU type */
#if defined(__arm__)
#define FACTOR_ARM
-#elif defined(__amd64__) || defined(__x86_64__)
+#elif defined(__amd64__) || defined(__x86_64__) || defined(_M_AMD64)
#define FACTOR_AMD64
#define FACTOR_64
-#elif defined(i386) || defined(__i386) || defined(__i386__) || defined(WIN32) || defined(_MSC_VER)
+#elif defined(i386) || defined(__i386) || defined(__i386__) || defined(_M_IX86)
#define FACTOR_X86
#elif defined(__POWERPC__) || defined(__ppc__) || defined(_ARCH_PPC)
#define FACTOR_PPC
#define WINDOWS
#endif
-#ifndef _MSC_VER
- #include <stdbool.h>
-#endif
-
/* Forward-declare this since it comes up in function prototypes */
namespace factor
{
void factor_vm::primitive_bignum_bitp()
{
- fixnum bit = to_fixnum(ctx->pop());
+ int bit = (int)to_fixnum(ctx->pop());
bignum *x = untag<bignum>(ctx->pop());
ctx->push(tag_boolean(bignum_logbitp(bit,x)));
}
void factor_vm::primitive_byte_array_to_bignum()
{
- cell n_digits = array_capacity(untag_check<byte_array>(ctx->peek()));
+ unsigned int n_digits = (unsigned int)array_capacity(untag_check<byte_array>(ctx->peek()));
bignum * result = digit_stream_to_bignum(n_digits,factor::bignum_producer,0x100,0);
ctx->replace(tag<bignum>(result));
}
void factor_vm::primitive_bits_float()
{
- ctx->push(allot_float(bits_float(to_cell(ctx->pop()))));
+ ctx->push(allot_float(bits_float((u32)to_cell(ctx->pop()))));
}
void factor_vm::primitive_double_bits()
#define OPEN_READ(path) fopen(path,"rb")
#define OPEN_WRITE(path) fopen(path,"wb")
+#define MOVE_FILE(path1,path2) \
+do {\
+ int ret = 0;\
+ do {\
+ ret = rename((path1),(path2));\
+ } while(ret < 0 && errno == EINTR);\
+ if(ret < 0)\
+ general_error(ERROR_IO,tag_fixnum(errno),false_object,NULL);\
+}while(0)
#define print_native_string(string) print_string(string)
#define ESP Rsp
#define EIP Rip
-#define X87SW(ctx) (ctx)->FloatSave.StatusWord
#define MXCSR(ctx) (ctx)->MxCsr
}
case STATUS_FLOAT_UNDERFLOW:
case STATUS_FLOAT_MULTIPLE_FAULTS:
case STATUS_FLOAT_MULTIPLE_TRAPS:
+#ifdef FACTOR_AMD64
+ signal_fpu_status = fpu_status(MXCSR(c));
+#else
signal_fpu_status = fpu_status(X87SW(c) | MXCSR(c));
X87SW(c) = 0;
+#endif
MXCSR(c) &= 0xffffffc0;
c->EIP = (cell)factor::fp_signal_handler_impl;
break;
#define CELL_HEX_FORMAT "%lx"
#endif
-#define OPEN_READ(path) _wfopen(path,L"rb")
-#define OPEN_WRITE(path) _wfopen(path,L"wb")
+#define OPEN_READ(path) _wfopen((path),L"rb")
+#define OPEN_WRITE(path) _wfopen((path),L"wb")
+#define MOVE_FILE(path1,path2)\
+do {\
+ if(MoveFileEx((path1),(path2),MOVEFILE_REPLACE_EXISTING) == false)\
+ std::cout << "MoveFile() failed: error " << GetLastError() << std::endl;\
+} while(0)
/* Difference between Jan 1 00:00:00 1601 and Jan 1 00:00:00 1970 */
#define EPOCH_OFFSET 0x019db1ded53e8000LL
void factor_vm::primitive_exit()
{
- exit(to_fixnum(ctx->pop()));
+ exit((int)to_fixnum(ctx->pop()));
}
void factor_vm::primitive_system_micros()
data_root<string> str(str_,this);
if(fill <= 0x7f)
- memset(&str->data()[start],fill,capacity - start);
+ memset(&str->data()[start],(int)fill,capacity - start);
else
{
cell i;
void not_implemented_error();
bool in_page(cell fault, cell area, cell area_size, int offset);
void memory_protection_error(cell addr, stack_frame *native_stack);
- void signal_error(int signal, stack_frame *native_stack);
+ void signal_error(cell signal, stack_frame *native_stack);
void divide_by_zero_error();
void fp_trap_error(unsigned int fpu_status, stack_frame *signal_callstack_top);
void primitive_call_clear();
cell compute_entry_point_pic_tail_address(cell w_);
cell code_block_owner(code_block *compiled);
void update_word_references(code_block *compiled);
- void check_code_address(cell address);
void undefined_symbol();
cell compute_dlsym_address(array *literals, cell index);
cell compute_vm_address(cell arg);
inline void check_code_pointer(cell ptr)
{
#ifdef FACTOR_DEBUG
- assert(in_code_heap_p(ptr));
+ //assert(in_code_heap_p(ptr));
#endif
}
void init_objects(image_header *h);
void load_data_heap(FILE *file, image_header *h, vm_parameters *p);
void load_code_heap(FILE *file, image_header *h, vm_parameters *p);
- bool save_image(const vm_char *filename);
+ bool save_image(const vm_char *saving_filename, const vm_char *filename);
void primitive_save_image();
void primitive_save_image_and_exit();
void fixup_data(cell data_offset, cell code_offset);
projects / factor.git / commitdiff