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

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

db4
Joe Groff 2010-01-24 12:48:17 -08:00
parent a7bb13348d c50682c6f0
commit 230630c78a
104 changed files with 878 additions and 772 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
GNUmakefile
View File

@ -213,6 +213,8 @@ endif
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

115
basis/alien/c-types/c-types.factor
View File

@ -348,52 +348,6 @@ SYMBOLS:
"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
@ -514,16 +468,75 @@ SYMBOLS:
[ >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

2
basis/cocoa/cocoa-tests.factor
View File

@ -1,5 +1,5 @@
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

4
basis/compiler/cfg/ssa/construction/tdmsc/tdmsc.factor
View File

@ -86,7 +86,7 @@ SYMBOLS: visited merge-sets levels again? ;
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 } ;
@ -107,4 +107,4 @@ PRIVATE>
] 2each ; inline
: merge-set ( bbs -- bbs' )
(merge-set) filter-by ;
(merge-set) filter-by ;

2
basis/compiler/cfg/stacks/uninitialized/uninitialized.factor
View File

@ -55,7 +55,7 @@ M: insn visit-insn drop ;
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>

15
basis/compiler/compiler-docs.factor
View File

@ -16,11 +16,7 @@ ARTICLE: "compiler-usage" "Calling the optimizing compiler"
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."
@ -60,10 +56,6 @@ $nl
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." }
@ -72,8 +64,3 @@ HELP: compile-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." } ;

13
basis/compiler/compiler.factor
View File

@ -1,4 +1,4 @@
! 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
@ -181,14 +181,6 @@ t compile-dependencies? set-global
: 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 )
@ -220,6 +212,3 @@ M: optimizing-compiler process-forgotten-words
: disable-optimizer ( -- )
f compiler-impl set-global ;
: recompile-all ( -- )
all-words compile ;

1
basis/compiler/test/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

19
basis/compiler/test/test.factor Normal file
View File

@ -0,0 +1,19 @@
! 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 ;

2
basis/compiler/tests/codegen.factor
View File

@ -1,4 +1,4 @@
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

2
basis/compiler/tests/curry.factor
View File

@ -1,5 +1,5 @@
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

5
basis/compiler/tests/float.factor
View File

@ -1,5 +1,6 @@
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

2
basis/compiler/tests/intrinsics.factor
View File

@ -4,7 +4,7 @@ strings tools.test words continuations sequences.private
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

2
basis/compiler/tests/optimizer.factor
View File

@ -4,7 +4,7 @@ sbufs strings tools.test vectors words sequences.private
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 )

2
basis/compiler/tests/simple.factor
View File

@ -1,4 +1,4 @@
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 ;

2
basis/compiler/tests/tuples.factor
View File

@ -1,4 +1,4 @@
USING: kernel tools.test compiler.units compiler ;
USING: kernel tools.test compiler.units compiler.test ;
IN: compiler.tests.tuples
TUPLE: color red green blue ;

2
basis/concurrency/combinators/combinators.factor
View File

@ -22,7 +22,7 @@ PRIVATE>
] (parallel-each) ; inline
: parallel-filter ( seq quot -- newseq )
over [ pusher [ parallel-each ] dip ] dip like ; inline
over [ selector [ parallel-each ] dip ] dip like ; inline
<PRIVATE

4
basis/cpu/x86/x86.factor
View File

@ -56,8 +56,8 @@ M: x86 stack-frame-size ( stack-frame -- i )
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 )

2
basis/db/db.factor
View File

@ -113,7 +113,7 @@ M: object execute-statement* ( statement type -- )
] 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

2
basis/dlists/dlists.factor
View File

@ -153,7 +153,7 @@ M: dlist clear-deque ( dlist -- )
'[ obj>> @ ] dlist-each-node ; inline
: dlist>seq ( dlist -- seq )
[ ] accumulator [ dlist-each ] dip ;
[ ] collector [ dlist-each ] dip ;
: 1dlist ( obj -- dlist ) <dlist> [ push-front ] keep ;

2
basis/documents/documents.factor
View File

@ -61,7 +61,7 @@ TUPLE: document < model locs undos redos inside-undo? ;
] 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* ;

2
basis/environment/unix/unix.factor
View File

@ -3,7 +3,7 @@
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* )

2
basis/game/input/dinput/dinput.factor
View File

@ -314,7 +314,7 @@ CONSTANT: pov-values
} 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

2
basis/images/jpeg/jpeg.factor
View File

@ -351,7 +351,7 @@ SINGLETONS: YUV420 YUV444 Y MAGIC! ;
[ 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

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

@ -2,7 +2,7 @@
! 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
@ -17,8 +17,8 @@ TUPLE: fd < disposable fd ;
: 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 )
@ -50,7 +50,7 @@ M: fd cancel-operation ( 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 {
@ -59,7 +59,7 @@ M: unix seek-handle ( n seek-type handle -- )
{ 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+

6
basis/io/directories/search/search.factor
View File

@ -64,17 +64,17 @@ PRIVATE>
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 ;

4
basis/io/directories/unix/linux/linux.factor
View File

@ -1,11 +1,11 @@
! 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 ;

8
basis/io/directories/unix/unix.factor
View File

@ -4,7 +4,7 @@ USING: accessors alien.c-types alien.strings combinators
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 )
@ -17,15 +17,15 @@ M: unix touch-file ( path -- )
] 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 ;

2
basis/io/files/info/info.factor
View File

@ -26,7 +26,7 @@ available-space free-space used-space total-space ;
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

25
basis/io/files/info/unix/unix.factor
View File

@ -1,13 +1,13 @@
! 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
@ -109,7 +109,7 @@ M: unix stat>type ( stat -- type )
: 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 -- ? )
@ -174,7 +174,7 @@ CONSTANT: ALL-EXECUTE OCT: 0000111
: 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>> ;
@ -202,7 +202,7 @@ PRIVATE>
: 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 ;
@ -211,7 +211,8 @@ PRIVATE>
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 -- )
@ -285,3 +286,5 @@ PRIVATE>
{ +regular-file+ [ file-type>executable ] }
[ drop file-type>executable ]
} case ;
"io.files.info.unix." os name>> append require

8
basis/io/files/links/unix/unix.factor
View File

@ -1,14 +1,14 @@
! 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 ;

2
basis/io/files/unique/unix/unix.factor
View File

@ -1,7 +1,7 @@
! 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 )

7
basis/io/files/unix/unix.factor
View File

@ -2,11 +2,12 @@
! 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 ;
@ -33,7 +34,7 @@ M: unix (file-writer) ( path -- stream )
: 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 )

23
basis/io/launcher/launcher.factor Normal file → Executable file
View File

@ -1,4 +1,4 @@
! 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
@ -127,16 +127,17 @@ M: process-was-killed error.
"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
@ -264,7 +265,7 @@ M: output-process-error error.
+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 -- )

2
basis/io/launcher/unix/unix.factor
View File

@ -5,7 +5,7 @@ continuations environment io io.backend io.backend.unix
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 )

14
basis/io/launcher/windows/nt/nt-tests.factor Normal file → Executable file
View File

@ -23,6 +23,20 @@ IN: io.launcher.windows.nt.tests
[ 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 ;

2
basis/io/mmap/unix/unix.factor
View File

@ -1,7 +1,7 @@
! 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 )

2
basis/io/pipes/unix/unix.factor
View File

@ -1,7 +1,7 @@
! 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

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

@ -6,7 +6,8 @@ alien.strings libc continuations destructors openssl
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

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

@ -11,7 +11,7 @@ IN: io.sockets
<< {
{ [ os windows? ] [ "windows.winsock" ] }
{ [ os unix? ] [ "unix" ] }
{ [ os unix? ] [ "unix.ffi" ] }
} cond use-vocab >>
! Addressing

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

@ -5,7 +5,7 @@ threads sequences byte-arrays io.binary io.backend.unix
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 ;
@ -59,10 +59,15 @@ M: object (get-remote-address) ( handle local -- sockaddr )
[ (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
] }
@ -70,7 +75,12 @@ M: object establish-connection ( client-out remote -- )
} 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
@ -83,12 +93,12 @@ M: object ((client)) ( addrspec -- 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 )

2
basis/lists/lists.factor
View File

@ -88,7 +88,7 @@ PRIVATE>
<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 ;

1
basis/math/blas/config/config.factor
View File

@ -15,7 +15,6 @@ blas-fortran-abi [
{
{ [ 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 ] }

4
basis/math/floats/env/env-tests.factor vendored
View File

@ -1,7 +1,7 @@
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 ( -- )

2
basis/math/vectors/conversion/conversion-tests.factor
View File

@ -1,5 +1,5 @@
! (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 ;

2
basis/math/vectors/simd/simd-tests.factor
View File

@ -1,4 +1,4 @@
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

2
basis/regexp/regexp.factor
View File

@ -84,7 +84,7 @@ PRIVATE>
[ 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 ;

2
basis/sequences/deep/deep.factor
View File

@ -21,7 +21,7 @@ M: object branch? drop f ;
[ '[ _ 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 ? )

8
basis/sequences/generalizations/generalizations.factor
View File

@ -58,19 +58,19 @@ MACRO: (ncollect) ( n -- )
: 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

3
basis/specialized-arrays/specialized-arrays-tests.factor
View File

@ -4,7 +4,8 @@ specialized-arrays.private sequences alien.c-types accessors
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

4
basis/stack-checker/known-words/known-words.factor
View File

@ -516,9 +516,9 @@ M: bad-executable summary
\ 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

2
basis/tools/profiler/profiler-tests.factor
View File

@ -1,6 +1,6 @@
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 ] [

2
basis/tools/time/time-tests.factor
View File

@ -1,4 +1,4 @@
IN: tools.time.tests
USING: tools.time tools.test compiler ;
USING: tools.time tools.test compiler.test ;
[ ] [ [ [ ] time ] compile-call ] unit-test

30
basis/unix/bsd/netbsd/structs/structs.factor
View File

@ -1,30 +0,0 @@
! 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 } } ;

5
basis/unix/debugger/debugger.factor
View File

@ -1,7 +1,6 @@
! 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.

1
basis/unix/ffi/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

0
basis/unix/bsd/authors.txt → basis/unix/ffi/bsd/authors.txt
View File

10
basis/unix/bsd/bsd.factor → basis/unix/ffi/bsd/bsd.factor
View File

@ -2,7 +2,7 @@
! 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
IN: unix.ffi
CONSTANT: MAXPATHLEN 1024
@ -85,8 +85,8 @@ 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 ] }
{ 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

2
basis/unix/bsd/freebsd/freebsd.factor → basis/unix/ffi/bsd/freebsd/freebsd.factor
View File

@ -1,5 +1,5 @@
USING: alien.c-types alien.syntax classes.struct unix.types ;
IN: unix
IN: unix.ffi
CONSTANT: FD_SETSIZE 1024

0
basis/unix/bsd/freebsd/tags.txt → basis/unix/ffi/bsd/freebsd/tags.txt
View File

7
basis/unix/bsd/macosx/macosx.factor → basis/unix/ffi/bsd/macosx/macosx.factor
View File

@ -1,6 +1,7 @@
USING: alien.c-types alien.syntax unix.time unix.types
unix.types.macosx classes.struct ;
IN: unix
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

0
basis/unix/bsd/macosx/tags.txt → basis/unix/ffi/bsd/macosx/tags.txt
View File

32
basis/unix/bsd/netbsd/netbsd.factor → basis/unix/ffi/bsd/netbsd/netbsd.factor
View File

@ -1,6 +1,6 @@
USING: alien.syntax alien.c-types math vocabs.loader
classes.struct unix.types ;
IN: unix
classes.struct unix.types unix.time ;
IN: unix.ffi
CONSTANT: FD_SETSIZE 256
@ -127,6 +127,8 @@ CONSTANT: _UTX_LINESIZE 32
CONSTANT: _UTX_IDSIZE 4
CONSTANT: _UTX_HOSTSIZE 256
<<
CONSTANT: _SS_MAXSIZE 128
: _SS_ALIGNSIZE ( -- n )
@ -138,4 +140,28 @@ CONSTANT: _SS_MAXSIZE 128
: _SS_PAD2SIZE ( -- n )
_SS_MAXSIZE 2 - _SS_PAD1SIZE - _SS_ALIGNSIZE - ; inline
"unix.bsd.netbsd.structs" require
>>
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 } } ;

0
basis/unix/bsd/netbsd/structs/tags.txt → basis/unix/ffi/bsd/netbsd/tags.txt
View File

2
basis/unix/bsd/openbsd/openbsd.factor → basis/unix/ffi/bsd/openbsd/openbsd.factor
View File

@ -1,5 +1,5 @@
USING: alien.c-types alien.syntax classes.struct unix.types ;
IN: unix
IN: unix.ffi
CONSTANT: FD_SETSIZE 1024

0
basis/unix/bsd/netbsd/tags.txt → basis/unix/ffi/bsd/openbsd/tags.txt
View File

0
basis/unix/bsd/summary.txt → basis/unix/ffi/bsd/summary.txt
View File

0
basis/unix/bsd/openbsd/tags.txt → basis/unix/ffi/bsd/tags.txt
View File

158
basis/unix/ffi/ffi.factor Normal file
View File

@ -0,0 +1,158 @@
! 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

1
basis/unix/ffi/linux/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

236
basis/unix/ffi/linux/linux.factor Normal file
View File

@ -0,0 +1,236 @@
! 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

0
basis/unix/bsd/tags.txt → basis/unix/ffi/linux/tags.txt
View File

0
basis/unix/solaris/authors.txt → basis/unix/ffi/solaris/authors.txt
View File

4
basis/unix/solaris/solaris.factor → basis/unix/ffi/solaris/solaris.factor
View File

@ -1,7 +1,7 @@
! 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
IN: unix.ffi
! Solaris.
@ -52,7 +52,7 @@ STRUCT: sockaddr-in6
{ addr uchar[16] }
{ scopeid uint } ;
: max-un-path 108 ;
CONSTANT: max-un-path 108
STRUCT: sockaddr-un
{ family ushort }

0
basis/unix/solaris/tags.txt → basis/unix/ffi/solaris/tags.txt
View File

1
basis/unix/ffi/tags.txt Normal file
View File

@ -0,0 +1 @@
unportable

28
basis/unix/groups/groups.factor
View File

@ -4,10 +4,10 @@ USING: alien alien.c-types alien.strings io.encodings.utf8
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
@ -23,17 +23,21 @@ GENERIC: group-struct ( obj -- group/f )
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
@ -64,8 +68,8 @@ PRIVATE>
: (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>
@ -79,7 +83,7 @@ M: integer user-groups ( id -- seq )
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 ;
@ -87,11 +91,11 @@ M: integer user-groups ( id -- seq )
: 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
@ -111,10 +115,10 @@ GENERIC: set-effective-group ( obj -- )
<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>

239
basis/unix/linux/linux.factor
View File

@ -1,241 +1,6 @@
! 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

2
basis/unix/stat/macosx/macosx.factor
View File

@ -1,5 +1,5 @@
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

2
basis/unix/statfs/macosx/macosx.factor
View File

@ -3,7 +3,7 @@
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

200
basis/unix/unix.factor
View File

@ -1,44 +1,14 @@
! 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 ;
@ -47,125 +17,45 @@ ERROR: unix-error errno message ;
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 -- )
@ -174,50 +64,18 @@ FUNCTION: int utime ( char* path, utimbuf* buf ) ;
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
>>

20
basis/unix/users/users.factor
View File

@ -4,9 +4,9 @@ USING: alien alien.c-types alien.strings io.encodings.utf8
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 ;
@ -31,13 +31,13 @@ M: unix passwd>new-passwd ( passwd -- seq )
} 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
@ -52,10 +52,10 @@ GENERIC: user-passwd ( obj -- passwd/f )
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
@ -65,13 +65,13 @@ M: string user-passwd ( string -- passwd/f )
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
@ -93,10 +93,10 @@ GENERIC: set-effective-user ( string/id -- )
<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>

1
basis/unix/utilities/tags.txt Normal file
View File

@ -0,0 +1 @@
unportable

2
basis/windows/directx/d2d1/d2d1.factor
View File

@ -1,5 +1,5 @@
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

2
basis/windows/directx/d2dbasetypes/d2dbasetypes.factor
View File

@ -1,5 +1,5 @@
USING: alien.syntax classes.struct windows.types ;
IN: windows.directx.d3dbasetypes
IN: windows.directx.d2dbasetypes
STRUCT: D3DCOLORVALUE
{ r FLOAT }

3
basis/windows/directx/d3d11shader/d3d11shader.factor
View File

@ -1,6 +1,7 @@
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

2
basis/windows/directx/d3dx10mesh/d3dx10mesh.factor
View File

@ -1,6 +1,6 @@
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

2
core/assocs/assocs.factor
View File

@ -58,7 +58,7 @@ PRIVATE>
(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

4
core/bootstrap/primitives.factor
View File

@ -511,8 +511,8 @@ tuple
{ "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 )) }

2
core/io/io.factor
View File

@ -113,7 +113,7 @@ PRIVATE>
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

4
core/make/make-docs.factor
View File

@ -37,7 +37,7 @@ $nl
{ $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 }
@ -47,7 +47,7 @@ $nl
%
#
}
"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 ;"

12
core/memory/memory.factor
View File

@ -1,16 +1,20 @@
! 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 ;

24
core/sequences/sequences-docs.factor
View File

@ -993,16 +993,16 @@ HELP: count
"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
@ -1199,7 +1199,7 @@ HELP: 2map-reduce
"1290"
} } ;
HELP: 2pusher
HELP: 2selector
{ $values
{ "quot" quotation }
{ "quot" quotation } { "accum1" vector } { "accum2" vector } }
@ -1224,13 +1224,13 @@ HELP: 2unclip-slice
"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 }"
} } ;
@ -1680,14 +1680,14 @@ ARTICLE: "sequences-f" "The f object as a sequence"
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"

30
core/sequences/sequences.factor
View File

@ -403,6 +403,9 @@ PRIVATE>
[ 2drop f f ]
if ; inline
: (accumulate) ( seq identity quot -- seq identity quot )
[ swap ] dip [ curry keep ] curry ; inline
PRIVATE>
: each ( seq quot -- )
@ -429,9 +432,6 @@ PRIVATE>
: 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
@ -486,14 +486,14 @@ PRIVATE>
: 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
@ -501,20 +501,20 @@ PRIVATE>
: 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
@ -603,12 +603,16 @@ ERROR: assert-sequence got expected ;
: 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

4
extra/mason/common/common.factor
View File

@ -8,8 +8,10 @@ calendar.format arrays mason.config locals debugger fry
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

2
extra/mongodb/operations/operations.factor
View File

@ -70,7 +70,7 @@ M: mdb-reply-op (read-message) ( msg-stub opcode -- message )
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

2
misc/vim/syntax/factor.vim
View File

@ -52,7 +52,7 @@ syn keyword factorKeyword or 2bi 2tri while wrapper nip 4dip wrapper? bi* callst
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 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 2pusher 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 pusher-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? accumulator-for accumulate each pusher append! new-resizable cut-slice each-index head-slice* 2reverse-each sequence-hashcode pop set-nth ?nth <flat-slice> second join when-empty accumulator 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 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 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

2
vm/debug.cpp
View File

@ -442,7 +442,7 @@ void factor_vm::factorbug()
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)

40
vm/image.cpp
View File

@ -22,7 +22,7 @@ void factor_vm::load_data_heap(FILE *file, image_header *h, vm_parameters *p)
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)
{
@ -43,7 +43,7 @@ void factor_vm::load_code_heap(FILE *file, image_header *h, vm_parameters *p)
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, ";
@ -241,7 +241,7 @@ void factor_vm::load_image(vm_parameters *p)
}
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)
@ -253,7 +253,7 @@ void factor_vm::load_image(vm_parameters *p)
load_data_heap(file,&h,p);
load_code_heap(file,&h,p);
fclose(file);
safe_fclose(file);
init_objects(&h);
@ -268,15 +268,15 @@ void factor_vm::load_image(vm_parameters *p)
}
/* 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;
}
@ -298,13 +298,15 @@ bool factor_vm::save_image(const vm_char *filename)
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;
}
@ -314,9 +316,11 @@ void factor_vm::primitive_save_image()
/* 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()
@ -324,8 +328,10 @@ 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++)
@ -336,7 +342,7 @@ void factor_vm::primitive_save_image_and_exit()
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);

124
vm/io.cpp
View File

@ -31,6 +31,39 @@ void factor_vm::io_error()
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);
@ -38,18 +71,15 @@ void factor_vm::primitive_fopen()
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()
@ -61,8 +91,7 @@ void factor_vm::primitive_fgetc()
{
FILE *file = pop_file_handle();
for(;;)
{
do {
int c = fgetc(file);
if(c == EOF)
{
@ -79,7 +108,7 @@ void factor_vm::primitive_fgetc()
ctx->push(tag_fixnum(c));
break;
}
}
} while(errno == EINTR);
}
void factor_vm::primitive_fread()
@ -97,8 +126,8 @@ 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))
{
@ -110,12 +139,13 @@ void factor_vm::primitive_fread()
}
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;
}
@ -127,17 +157,12 @@ void factor_vm::primitive_fputc()
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()
@ -150,23 +175,9 @@ 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()
@ -174,8 +185,12 @@ 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));
}
@ -196,37 +211,30 @@ void factor_vm::primitive_fseek()
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

Some files were not shown because too many files have changed in this diff Show More