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

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

db4
erg 2008-10-19 19:40:53 -05:00
parent 608b8fb294 4f948ef5ce
commit ff2d7a00cc
95 changed files with 1239 additions and 1192 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/db/queries/queries.factor
View File

@ -166,9 +166,11 @@ M: db <select-by-slots-statement> ( tuple class -- statement )
swap 3append ;
: do-group ( tuple groups -- )
dup string? [ 1array ] when
[ ", " join " group by " splice ] curry change-sql drop ;
: do-order ( tuple order -- )
dup string? [ 1array ] when
[ ", " join " order by " splice ] curry change-sql drop ;
: do-offset ( tuple n -- )

29
basis/db/sqlite/lib/lib.factor
View File

@ -5,7 +5,7 @@ namespaces sequences db.sqlite.ffi db combinators
continuations db.types calendar.format serialize
io.streams.byte-array byte-arrays io.encodings.binary
io.backend db.errors present urls io.encodings.utf8
io.encodings.string accessors ;
io.encodings.string accessors shuffle ;
IN: db.sqlite.lib
ERROR: sqlite-error < db-error n string ;
@ -79,6 +79,9 @@ ERROR: sqlite-sql-error < sql-error n string ;
: sqlite-bind-uint64-by-name ( handle name int64 -- )
parameter-index sqlite-bind-uint64 ;
: sqlite-bind-boolean-by-name ( handle name obj -- )
>boolean 1 0 ? parameter-index sqlite-bind-int ;
: sqlite-bind-double-by-name ( handle name double -- )
parameter-index sqlite-bind-double ;
@ -88,14 +91,14 @@ ERROR: sqlite-sql-error < sql-error n string ;
: sqlite-bind-null-by-name ( handle name obj -- )
parameter-index drop sqlite-bind-null ;
: sqlite-bind-type ( handle key value type -- )
over [ drop NULL ] unless
: (sqlite-bind-type) ( handle key value type -- )
dup array? [ first ] when
{
{ INTEGER [ sqlite-bind-int-by-name ] }
{ BIG-INTEGER [ sqlite-bind-int64-by-name ] }
{ SIGNED-BIG-INTEGER [ sqlite-bind-int64-by-name ] }
{ UNSIGNED-BIG-INTEGER [ sqlite-bind-uint64-by-name ] }
{ BOOLEAN [ sqlite-bind-boolean-by-name ] }
{ TEXT [ sqlite-bind-text-by-name ] }
{ VARCHAR [ sqlite-bind-text-by-name ] }
{ DOUBLE [ sqlite-bind-double-by-name ] }
@ -104,10 +107,7 @@ ERROR: sqlite-sql-error < sql-error n string ;
{ DATETIME [ timestamp>ymdhms sqlite-bind-text-by-name ] }
{ TIMESTAMP [ timestamp>ymdhms sqlite-bind-text-by-name ] }
{ BLOB [ sqlite-bind-blob-by-name ] }
{ FACTOR-BLOB [
object>bytes
sqlite-bind-blob-by-name
] }
{ FACTOR-BLOB [ object>bytes sqlite-bind-blob-by-name ] }
{ URL [ present sqlite-bind-text-by-name ] }
{ +db-assigned-id+ [ sqlite-bind-int-by-name ] }
{ +random-id+ [ sqlite-bind-int64-by-name ] }
@ -115,6 +115,14 @@ ERROR: sqlite-sql-error < sql-error n string ;
[ no-sql-type ]
} case ;
: sqlite-bind-type ( handle key value type -- )
#! null and empty values need to be set by sqlite-bind-null-by-name
over [
NULL = [ 2drop NULL NULL ] when
] [
drop NULL
] if* (sqlite-bind-type) ;
: sqlite-finalize ( handle -- ) sqlite3_finalize sqlite-check-result ;
: sqlite-reset ( handle -- ) sqlite3_reset sqlite-check-result ;
: sqlite-clear-bindings ( handle -- )
@ -141,6 +149,7 @@ ERROR: sqlite-sql-error < sql-error n string ;
{ BIG-INTEGER [ sqlite3_column_int64 ] }
{ SIGNED-BIG-INTEGER [ sqlite3_column_int64 ] }
{ UNSIGNED-BIG-INTEGER [ sqlite3-column-uint64 ] }
{ BOOLEAN [ sqlite3_column_int 1 = ] }
{ DOUBLE [ sqlite3_column_double ] }
{ TEXT [ sqlite3_column_text ] }
{ VARCHAR [ sqlite3_column_text ] }
@ -150,11 +159,7 @@ ERROR: sqlite-sql-error < sql-error n string ;
{ DATETIME [ sqlite3_column_text dup [ ymdhms>timestamp ] when ] }
{ BLOB [ sqlite-column-blob ] }
{ URL [ sqlite3_column_text dup [ >url ] when ] }
{ FACTOR-BLOB [
sqlite-column-blob
dup [ bytes>object ] when
] }
! { NULL [ 2drop f ] }
{ FACTOR-BLOB [ sqlite-column-blob dup [ bytes>object ] when ] }
[ no-sql-type ]
} case ;

1
basis/db/sqlite/sqlite.factor
View File

@ -185,6 +185,7 @@ M: sqlite-db persistent-table ( -- assoc )
{ +set-null+ { f f "set null" } }
{ +set-default+ { f f "set default" } }
{ BOOLEAN { "boolean" "boolean" f } }
{ INTEGER { "integer" "integer" f } }
{ BIG-INTEGER { "bigint" "bigint" f } }
{ SIGNED-BIG-INTEGER { "bigint" "bigint" f } }

6
basis/debugger/debugger-docs.factor
View File

@ -1,7 +1,6 @@
USING: alien arrays generic generic.math help.markup help.syntax
kernel math memory strings sbufs vectors io io.files classes
help generic.standard continuations system io.files.private
listener ;
help generic.standard continuations io.files.private listener ;
IN: debugger
ARTICLE: "debugger" "The debugger"
@ -144,5 +143,4 @@ HELP: memory-error.
{ $notes "This can be a result of incorrect usage of C library interface words, a bug in the compiler, or a bug in the VM." } ;
HELP: primitive-error.
{ $error-description "Thrown by the Factor VM if an unsupported primitive word is called." }
{ $notes "This word is only ever thrown on Windows CE, where the " { $link cwd } ", " { $link cd } ", and " { $link os-env } " primitives are unsupported." } ;
{ $error-description "Thrown by the Factor VM if an unsupported primitive word is called." } ;

3
basis/editors/editors.factor
View File

@ -27,7 +27,8 @@ SYMBOL: edit-hook
: edit-location ( file line -- )
>r (normalize-path) r>
edit-hook get [ call ] [ no-edit-hook edit-location ] if* ;
edit-hook get-global
[ call ] [ no-edit-hook edit-location ] if* ;
: edit ( defspec -- )
where [ first2 edit-location ] when* ;

1
basis/environment/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

68
basis/environment/environment-docs.factor Normal file
View File

@ -0,0 +1,68 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs help.markup help.syntax io.streams.string sequences strings ;
IN: environment
HELP: (os-envs)
{ $values
{ "seq" sequence } }
{ $description "" } ;
HELP: (set-os-envs)
{ $values
{ "seq" sequence } }
{ $description "" } ;
HELP: os-env ( key -- value )
{ $values { "key" string } { "value" string } }
{ $description "Looks up the value of a shell environment variable." }
{ $examples
"This is an operating system-specific feature. On Unix, you can do:"
{ $unchecked-example "\"USER\" os-env print" "jane" }
} ;
HELP: os-envs
{ $values { "assoc" "an association mapping strings to strings" } }
{ $description "Outputs the current set of environment variables." }
{ $notes
"Names and values of environment variables are operating system-specific."
} ;
HELP: set-os-envs
{ $values { "assoc" "an association mapping strings to strings" } }
{ $description "Replaces the current set of environment variables." }
{ $notes
"Names and values of environment variables are operating system-specific. Windows NT allows values up to 32766 characters in length."
} ;
HELP: set-os-env ( value key -- )
{ $values { "value" string } { "key" string } }
{ $description "Set an environment variable." }
{ $notes
"Names and values of environment variables are operating system-specific."
} ;
HELP: unset-os-env ( key -- )
{ $values { "key" string } }
{ $description "Unset an environment variable." }
{ $notes
"Names and values of environment variables are operating system-specific."
} ;
{ os-env os-envs set-os-env unset-os-env set-os-envs } related-words
ARTICLE: "environment" "Environment variables"
"The " { $vocab-link "environment" } " vocabulary interfaces to the platform-dependent mechanism for setting environment variables." $nl
"Windows CE has no concept of environment variables, so these words are undefined on that platform." $nl
"Reading environment variables:"
{ $subsection os-env }
{ $subsection os-envs }
"Writing environment variables:"
{ $subsection set-os-env }
{ $subsection unset-os-env }
{ $subsection set-os-envs } ;
ABOUT: "environment"

29
basis/environment/environment-tests.factor Normal file
View File

@ -0,0 +1,29 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces prettyprint system tools.test
environment strings sequences ;
IN: environment.tests
os wince? [
[ ] [ os-envs . ] unit-test
os unix? [
[ ] [ os-envs "envs" set ] unit-test
[ ] [ { { "A" "B" } } set-os-envs ] unit-test
[ "B" ] [ "A" os-env ] unit-test
[ ] [ "envs" get set-os-envs ] unit-test
[ t ] [ os-envs "envs" get = ] unit-test
] when
[ ] [ "factor-test-key-1" unset-os-env ] unit-test
[ ] [ "ps3" "factor-test-key-1" set-os-env ] unit-test
[ "ps3" ] [ "factor-test-key-1" os-env ] unit-test
[ ] [ "factor-test-key-1" unset-os-env ] unit-test
[ f ] [ "factor-test-key-1" os-env ] unit-test
[ ] [
32766 CHAR: a <string> "factor-test-key-long" set-os-env
] unit-test
[ 32766 ] [ "factor-test-key-long" os-env length ] unit-test
[ ] [ "factor-test-key-long" unset-os-env ] unit-test
] unless

27
basis/environment/environment.factor Normal file
View File

@ -0,0 +1,27 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs combinators kernel sequences splitting system
vocabs.loader ;
IN: environment
HOOK: os-env os ( key -- value )
HOOK: set-os-env os ( value key -- )
HOOK: unset-os-env os ( key -- )
HOOK: (os-envs) os ( -- seq )
HOOK: (set-os-envs) os ( seq -- )
: os-envs ( -- assoc )
(os-envs) [ "=" split1 ] H{ } map>assoc ;
: set-os-envs ( assoc -- )
[ "=" swap 3append ] { } assoc>map (set-os-envs) ;
{
{ [ os unix? ] [ "environment.unix" require ] }
{ [ os winnt? ] [ "environment.winnt" require ] }
{ [ os wince? ] [ ] }
} cond

1
basis/environment/summary.txt Normal file
View File

@ -0,0 +1 @@
Environment variables

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

@ -0,0 +1 @@
Doug Coleman

1
basis/environment/unix/macosx/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

8
basis/environment/unix/macosx/macosx.factor Normal file
View File

@ -0,0 +1,8 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax system environment.unix ;
IN: environment.unix.macosx
FUNCTION: void* _NSGetEnviron ( ) ;
M: macosx environ _NSGetEnviron ;

1
basis/environment/unix/macosx/tags.txt Normal file
View File

@ -0,0 +1 @@
unportable

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

@ -0,0 +1 @@
unportable

29
basis/environment/unix/unix.factor Normal file
View File

@ -0,0 +1,29 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings alien.syntax kernel
layouts sequences system unix environment io.encodings.utf8
unix.utilities vocabs.loader combinators alien.accessors ;
IN: environment.unix
HOOK: environ os ( -- void* )
M: unix environ ( -- void* ) "environ" f dlsym ;
M: unix os-env ( key -- value ) getenv ;
M: unix set-os-env ( value key -- ) swap 1 setenv io-error ;
M: unix unset-os-env ( key -- ) unsetenv io-error ;
M: unix (os-envs) ( -- seq )
environ *void* utf8 alien>strings ;
: set-void* ( value alien -- ) 0 set-alien-cell ;
M: unix (set-os-envs) ( seq -- )
utf8 strings>alien malloc-byte-array environ set-void* ;
os {
{ macosx [ "environment.unix.macosx" require ] }
[ drop ]
} case

1
basis/environment/winnt/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

1
basis/environment/winnt/tags.txt Normal file
View File

@ -0,0 +1 @@
unportable

33
basis/environment/winnt/winnt.factor Normal file
View File

@ -0,0 +1,33 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.strings fry io.encodings.utf16 kernel
splitting windows windows.kernel32 system environment
alien.c-types sequences windows.errors io.streams.memory
io.encodings io ;
IN: environment.winnt
M: winnt os-env ( key -- value )
MAX_UNICODE_PATH "TCHAR" <c-array>
[ dup length GetEnvironmentVariable ] keep over 0 = [
2drop f
] [
nip utf16n alien>string
] if ;
M: winnt set-os-env ( value key -- )
swap SetEnvironmentVariable win32-error=0/f ;
M: winnt unset-os-env ( key -- )
f SetEnvironmentVariable 0 = [
GetLastError ERROR_ENVVAR_NOT_FOUND =
[ win32-error ] unless
] when ;
M: winnt (os-envs) ( -- seq )
GetEnvironmentStrings [
<memory-stream> [
utf16n decode-input
[ "\0" read-until drop dup empty? not ]
[ ] [ drop ] produce
] with-input-stream*
] [ FreeEnvironmentStrings win32-error=0/f ] bi ;

6
basis/http/server/static/static.factor
View File

@ -59,8 +59,8 @@ TUPLE: file-responder root hook special allow-listings ;
\ serve-file NOTICE add-input-logging
: file. ( name dirp -- )
[ "/" append ] when
: file. ( name -- )
dup link-info directory? [ "/" append ] when
dup <a =href a> escape-string write </a> ;
: directory. ( path -- )
@ -68,7 +68,7 @@ TUPLE: file-responder root hook special allow-listings ;
[ <h1> file-name escape-string write </h1> ]
[
<ul>
directory sort-keys
directory-files
[ <li> file. </li> ] assoc-each
</ul>
] bi

9
basis/io/launcher/launcher.factor
View File

@ -2,7 +2,7 @@
! 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 concurrency.flags destructors
math accessors concurrency.flags destructors environment
io io.backend io.timeouts io.pipes io.pipes.private io.encodings
io.streams.duplex io.ports debugger prettyprint summary ;
IN: io.launcher
@ -58,8 +58,6 @@ SYMBOL: +realtime-priority+
! Non-blocking process exit notification facility
SYMBOL: processes
[ H{ } clone processes set-global ] "io.launcher" add-init-hook
HOOK: wait-for-processes io-backend ( -- ? )
SYMBOL: wait-flag
@ -73,7 +71,10 @@ SYMBOL: wait-flag
<flag> wait-flag set-global
[ wait-loop t ] "Process wait" spawn-server drop ;
[ start-wait-thread ] "io.launcher" add-init-hook
[
H{ } clone processes set-global
start-wait-thread
] "io.launcher" add-init-hook
: process-started ( process handle -- )
>>handle

7
basis/io/monitors/recursive/recursive.factor
View File

@ -19,11 +19,14 @@ DEFER: add-child-monitor
: add-child-monitors ( path -- )
#! We yield since this directory scan might take a while.
directory* [ first add-child-monitor ] each yield ;
dup [
[ append-path ] with map
[ add-child-monitor ] each yield
] with-directory-files ;
: add-child-monitor ( path -- )
notify? [ dup { +add-file+ } monitor tget queue-change ] when
qualify-path dup link-info type>> +directory+ eq? [
qualify-path dup link-info directory? [
[ add-child-monitors ]
[
[

48
basis/io/unix/files/files-docs.factor
View File

@ -36,39 +36,39 @@ HELP: file-user-id
HELP: group-execute?
{ $values
{ "path" "a pathname string" }
{ "obj" "a pathname string or an integer" }
{ "?" "a boolean" } }
{ $description "Tests whether the " { $snippet "group execute" } " bit is set on a file." } ;
{ $description "Tests whether the " { $snippet "group execute" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
HELP: group-read?
{ $values
{ "path" "a pathname string" }
{ "obj" "a pathname string, file-info object, or an integer" }
{ "?" "a boolean" } }
{ $description "Tests whether the " { $snippet "group read" } " bit is set on a file." } ;
{ $description "Tests whether the " { $snippet "group read" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
HELP: group-write?
{ $values
{ "path" "a pathname string" }
{ "obj" "a pathname string, file-info object, or an integer" }
{ "?" "a boolean" } }
{ $description "Tests whether the " { $snippet "group write" } " bit is set on a file." } ;
{ $description "Tests whether the " { $snippet "group write" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
HELP: other-execute?
{ $values
{ "path" "a pathname string" }
{ "obj" "a pathname string, file-info object, or an integer" }
{ "?" "a boolean" } }
{ $description "Tests whether the " { $snippet "other execute" } " bit is set on a file." } ;
{ $description "Tests whether the " { $snippet "other execute" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
HELP: other-read?
{ $values
{ "path" "a pathname string" }
{ "obj" "a pathname string, file-info object, or an integer" }
{ "?" "a boolean" } }
{ $description "Tests whether the " { $snippet "other read" } " bit is set on a file." } ;
{ $description "Tests whether the " { $snippet "other read" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
HELP: other-write?
{ $values
{ "path" "a pathname string" }
{ "obj" "a pathname string, file-info object, or an integer" }
{ "?" "a boolean" } }
{ $description "Tests whether the " { $snippet "other write" } " bit is set on a file." } ;
{ $description "Tests whether the " { $snippet "other write" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
HELP: set-file-access-time
{ $values
@ -124,9 +124,9 @@ HELP: set-gid
HELP: gid?
{ $values
{ "path" "a pathname string" }
{ "obj" "a pathname string, file-info object, or an integer" }
{ "?" "a boolean" } }
{ $description "Tests whether the " { $snippet "gid" } " bit is set on a file." } ;
{ $description "Tests whether the " { $snippet "gid" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
HELP: set-group-execute
{ $values
@ -165,9 +165,9 @@ HELP: set-sticky
HELP: sticky?
{ $values
{ "path" "a pathname string" }
{ "obj" "a pathname string, file-info object, or an integer" }
{ "?" "a boolean" } }
{ $description "Tests whether the " { $snippet "sticky" } " bit of a file is set." } ;
{ $description "Tests whether the " { $snippet "sticky" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
HELP: set-uid
{ $values
@ -176,9 +176,9 @@ HELP: set-uid
HELP: uid?
{ $values
{ "path" "a pathname string" }
{ "obj" "a pathname string, file-info object, or an integer" }
{ "?" "a boolean" } }
{ $description "Tests whether the " { $snippet "uid" } " bit of a file is set." } ;
{ $description "Tests whether the " { $snippet "uid" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
HELP: set-user-execute
{ $values
@ -197,21 +197,21 @@ HELP: set-user-write
HELP: user-execute?
{ $values
{ "path" "a pathname string" }
{ "obj" "a pathname string, file-info object, or an integer" }
{ "?" "a boolean" } }
{ $description "Tests whether the " { $snippet "user execute" } " bit is set on a file." } ;
{ $description "Tests whether the " { $snippet "user execute" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
HELP: user-read?
{ $values
{ "path" "a pathname string" }
{ "obj" "a pathname string, file-info object, or an integer" }
{ "?" "a boolean" } }
{ $description "Tests whether the " { $snippet "user read" } " bit is set on a file." } ;
{ $description "Tests whether the " { $snippet "user read" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
HELP: user-write?
{ $values
{ "path" "a pathname string" }
{ "obj" "a pathname string, file-info object, or an integer" }
{ "?" "a boolean" } }
{ $description "Tests whether the " { $snippet "user write" } " bit is set on a file." } ;
{ $description "Tests whether the " { $snippet "user write" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
ARTICLE: "unix-file-permissions" "Unix file permissions"
"Reading all file permissions:"

62
basis/io/unix/files/files-tests.factor
View File

@ -55,32 +55,32 @@ prepare-test-file
[ t ] [ test-file other-write? ] unit-test
[ t ] [ test-file other-execute? ] unit-test
[ t ]
[ test-file f set-other-execute perms OCT: 776 = ] unit-test
[ t ] [ test-file f set-other-execute perms OCT: 776 = ] unit-test
[ f ] [ test-file file-info other-execute? ] unit-test
[ t ]
[ test-file f set-other-write perms OCT: 774 = ] unit-test
[ t ] [ test-file f set-other-write perms OCT: 774 = ] unit-test
[ f ] [ test-file file-info other-write? ] unit-test
[ t ]
[ test-file f set-other-read perms OCT: 770 = ] unit-test
[ t ] [ test-file f set-other-read perms OCT: 770 = ] unit-test
[ f ] [ test-file file-info other-read? ] unit-test
[ t ]
[ test-file f set-group-execute perms OCT: 760 = ] unit-test
[ t ] [ test-file f set-group-execute perms OCT: 760 = ] unit-test
[ f ] [ test-file file-info group-execute? ] unit-test
[ t ]
[ test-file f set-group-write perms OCT: 740 = ] unit-test
[ t ] [ test-file f set-group-write perms OCT: 740 = ] unit-test
[ f ] [ test-file file-info group-write? ] unit-test
[ t ]
[ test-file f set-group-read perms OCT: 700 = ] unit-test
[ t ] [ test-file f set-group-read perms OCT: 700 = ] unit-test
[ f ] [ test-file file-info group-read? ] unit-test
[ t ]
[ test-file f set-user-execute perms OCT: 600 = ] unit-test
[ t ] [ test-file f set-user-execute perms OCT: 600 = ] unit-test
[ f ] [ test-file file-info other-execute? ] unit-test
[ t ]
[ test-file f set-user-write perms OCT: 400 = ] unit-test
[ t ] [ test-file f set-user-write perms OCT: 400 = ] unit-test
[ f ] [ test-file file-info other-write? ] unit-test
[ t ]
[ test-file f set-user-read perms OCT: 000 = ] unit-test
[ t ] [ test-file f set-user-read perms OCT: 000 = ] unit-test
[ f ] [ test-file file-info other-read? ] unit-test
[ t ]
[ test-file { USER-ALL GROUP-ALL OTHER-EXECUTE } flags set-file-permissions perms OCT: 771 = ] unit-test
@ -135,3 +135,29 @@ prepare-test-file
[ ]
[ test-file f f set-file-ids ] unit-test
[ t ] [ OCT: 4000 uid? ] unit-test
[ t ] [ OCT: 2000 gid? ] unit-test
[ t ] [ OCT: 1000 sticky? ] unit-test
[ t ] [ OCT: 400 user-read? ] unit-test
[ t ] [ OCT: 200 user-write? ] unit-test
[ t ] [ OCT: 100 user-execute? ] unit-test
[ t ] [ OCT: 040 group-read? ] unit-test
[ t ] [ OCT: 020 group-write? ] unit-test
[ t ] [ OCT: 010 group-execute? ] unit-test
[ t ] [ OCT: 004 other-read? ] unit-test
[ t ] [ OCT: 002 other-write? ] unit-test
[ t ] [ OCT: 001 other-execute? ] unit-test
[ f ] [ 0 uid? ] unit-test
[ f ] [ 0 gid? ] unit-test
[ f ] [ 0 sticky? ] unit-test
[ f ] [ 0 user-read? ] unit-test
[ f ] [ 0 user-write? ] unit-test
[ f ] [ 0 user-execute? ] unit-test
[ f ] [ 0 group-read? ] unit-test
[ f ] [ 0 group-write? ] unit-test
[ f ] [ 0 group-execute? ] unit-test
[ f ] [ 0 other-read? ] unit-test
[ f ] [ 0 other-write? ] unit-test
[ f ] [ 0 other-execute? ] unit-test

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

@ -5,7 +5,8 @@ unix unix.stat unix.time kernel math continuations
math.bitwise byte-arrays alien combinators calendar
io.encodings.binary accessors sequences strings system
io.files.private destructors vocabs.loader calendar.unix
unix.stat alien.c-types arrays unix.users unix.groups ;
unix.stat alien.c-types arrays unix.users unix.groups
environment fry io.encodings.utf8 alien.strings ;
IN: io.unix.files
M: unix cwd ( -- path )
@ -137,6 +138,27 @@ os {
{ linux [ ] }
} case
: with-unix-directory ( path quot -- )
[ opendir dup [ (io-error) ] unless ] dip
dupd curry swap '[ _ closedir io-error ] [ ] cleanup ; inline
: find-next-file ( DIR* -- byte-array )
"dirent" <c-object>
f <void*>
[ readdir_r 0 = [ (io-error) ] unless ] 2keep
*void* [ drop f ] unless ;
M: unix >directory-entry ( byte-array -- directory-entry )
[ dirent-d_name utf8 alien>string ]
[ dirent-d_type ] bi directory-entry boa ;
M: unix (directory-entries) ( path -- seq )
[
'[ _ find-next-file dup ]
[ >directory-entry ]
[ drop ] produce
] with-unix-directory ;
<PRIVATE
: stat-mode ( path -- mode )
@ -166,18 +188,57 @@ PRIVATE>
: OTHER-WRITE OCT: 0000002 ; inline
: OTHER-EXECUTE OCT: 0000001 ; inline
: uid? ( path -- ? ) UID file-mode? ;
: gid? ( path -- ? ) GID file-mode? ;
: sticky? ( path -- ? ) STICKY file-mode? ;
: user-read? ( path -- ? ) USER-READ file-mode? ;
: user-write? ( path -- ? ) USER-WRITE file-mode? ;
: user-execute? ( path -- ? ) USER-EXECUTE file-mode? ;
: group-read? ( path -- ? ) GROUP-READ file-mode? ;
: group-write? ( path -- ? ) GROUP-WRITE file-mode? ;
: group-execute? ( path -- ? ) GROUP-EXECUTE file-mode? ;
: other-read? ( path -- ? ) OTHER-READ file-mode? ;
: other-write? ( path -- ? ) OTHER-WRITE file-mode? ;
: other-execute? ( path -- ? ) OTHER-EXECUTE file-mode? ;
GENERIC: uid? ( obj -- ? )
GENERIC: gid? ( obj -- ? )
GENERIC: sticky? ( obj -- ? )
GENERIC: user-read? ( obj -- ? )
GENERIC: user-write? ( obj -- ? )
GENERIC: user-execute? ( obj -- ? )
GENERIC: group-read? ( obj -- ? )
GENERIC: group-write? ( obj -- ? )
GENERIC: group-execute? ( obj -- ? )
GENERIC: other-read? ( obj -- ? )
GENERIC: other-write? ( obj -- ? )
GENERIC: other-execute? ( obj -- ? )
M: integer uid? ( integer -- ? ) UID mask? ;
M: integer gid? ( integer -- ? ) GID mask? ;
M: integer sticky? ( integer -- ? ) STICKY mask? ;
M: integer user-read? ( integer -- ? ) USER-READ mask? ;
M: integer user-write? ( integer -- ? ) USER-WRITE mask? ;
M: integer user-execute? ( integer -- ? ) USER-EXECUTE mask? ;
M: integer group-read? ( integer -- ? ) GROUP-READ mask? ;
M: integer group-write? ( integer -- ? ) GROUP-WRITE mask? ;
M: integer group-execute? ( integer -- ? ) GROUP-EXECUTE mask? ;
M: integer other-read? ( integer -- ? ) OTHER-READ mask? ;
M: integer other-write? ( integer -- ? ) OTHER-WRITE mask? ;
M: integer other-execute? ( integer -- ? ) OTHER-EXECUTE mask? ;
M: file-info uid? ( file-info -- ? ) permissions>> uid? ;
M: file-info gid? ( file-info -- ? ) permissions>> gid? ;
M: file-info sticky? ( file-info -- ? ) permissions>> sticky? ;
M: file-info user-read? ( file-info -- ? ) permissions>> user-read? ;
M: file-info user-write? ( file-info -- ? ) permissions>> user-write? ;
M: file-info user-execute? ( file-info -- ? ) permissions>> user-execute? ;
M: file-info group-read? ( file-info -- ? ) permissions>> group-read? ;
M: file-info group-write? ( file-info -- ? ) permissions>> group-write? ;
M: file-info group-execute? ( file-info -- ? ) permissions>> group-execute? ;
M: file-info other-read? ( file-info -- ? ) permissions>> other-read? ;
M: file-info other-write? ( file-info -- ? ) permissions>> other-write? ;
M: file-info other-execute? ( file-info -- ? ) permissions>> other-execute? ;
M: string uid? ( path -- ? ) UID file-mode? ;
M: string gid? ( path -- ? ) GID file-mode? ;
M: string sticky? ( path -- ? ) STICKY file-mode? ;
M: string user-read? ( path -- ? ) USER-READ file-mode? ;
M: string user-write? ( path -- ? ) USER-WRITE file-mode? ;
M: string user-execute? ( path -- ? ) USER-EXECUTE file-mode? ;
M: string group-read? ( path -- ? ) GROUP-READ file-mode? ;
M: string group-write? ( path -- ? ) GROUP-WRITE file-mode? ;
M: string group-execute? ( path -- ? ) GROUP-EXECUTE file-mode? ;
M: string other-read? ( path -- ? ) OTHER-READ file-mode? ;
M: string other-write? ( path -- ? ) OTHER-WRITE file-mode? ;
M: string other-execute? ( path -- ? ) OTHER-EXECUTE file-mode? ;
: set-uid ( path ? -- ) UID swap chmod-set-bit ;
: set-gid ( path ? -- ) GID swap chmod-set-bit ;
@ -255,3 +316,5 @@ M: string set-file-group ( path string -- )
: file-group-name ( path -- string )
file-group-id group-name ;
M: unix home "HOME" os-env ;

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

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces math system sequences debugger
continuations arrays assocs combinators alien.c-types strings
threads accessors
threads accessors environment
io io.backend io.launcher io.ports io.files
io.files.private io.unix.files io.unix.backend
io.unix.launcher.parser

36
basis/io/windows/files/files.factor
View File

@ -1,10 +1,11 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types io.binary io.backend io.files io.buffers
io.windows kernel math splitting
io.windows kernel math splitting fry alien.strings
windows windows.kernel32 windows.time calendar combinators
math.functions sequences namespaces make words symbols system
io.ports destructors accessors math.bitwise ;
io.ports destructors accessors math.bitwise continuations
windows.errors arrays ;
IN: io.windows.files
: open-file ( path access-mode create-mode flags -- handle )
@ -113,8 +114,35 @@ M: windows delete-directory ( path -- )
normalize-path
RemoveDirectory win32-error=0/f ;
M: windows normalize-directory ( string -- string )
normalize-path "\\" ?tail drop "\\*" append ;
M: windows >directory-entry ( byte-array -- directory-entry )
[ WIN32_FIND_DATA-cFileName utf16n alien>string ]
[ WIN32_FIND_DATA-dwFileAttributes ]
bi directory-entry boa ;
: find-first-file ( path -- WIN32_FIND_DATA handle )
"WIN32_FIND_DATA" <c-object> tuck
FindFirstFile
[ INVALID_HANDLE_VALUE = [ win32-error ] when ] keep ;
: find-next-file ( path -- WIN32_FIND_DATA/f )
"WIN32_FIND_DATA" <c-object> tuck
FindNextFile 0 = [
GetLastError ERROR_NO_MORE_FILES = [
win32-error
] unless drop f
] when ;
M: windows (directory-entries) ( path -- seq )
"\\" ?tail drop "\\*" append
find-first-file [ >directory-entry ] dip
[
'[
[ _ find-next-file dup ]
[ >directory-entry ]
[ drop ] produce
over name>> "." = [ nip ] [ swap prefix ] if
]
] [ '[ _ FindClose win32-error=0/f ] ] bi [ ] cleanup ;
SYMBOLS: +read-only+ +hidden+ +system+
+archive+ +device+ +normal+ +temporary+

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

@ -1,6 +1,6 @@
USING: kernel system io.files.unique.backend
windows.kernel32 io.windows io.windows.files io.ports windows
destructors ;
destructors environment ;
IN: io.windows.files.unique
M: windows (make-unique-file) ( path -- )

4
basis/io/windows/nt/files/files.factor
View File

@ -1,7 +1,7 @@
USING: continuations destructors io.buffers io.files io.backend
io.timeouts io.ports io.windows io.windows.files
io.windows.nt.backend windows windows.kernel32
kernel libc math threads system
kernel libc math threads system environment
alien.c-types alien.arrays alien.strings sequences combinators
combinators.short-circuit ascii splitting alien strings
assocs namespaces make io.files.private accessors tr ;
@ -59,3 +59,5 @@ M: winnt FileArgs-overlapped ( port -- overlapped )
M: winnt open-append
[ dup file-info size>> ] [ drop 0 ] recover
>r (open-append) r> >>ptr ;
M: winnt home "USERPROFILE" os-env ;

70
basis/locals/locals-tests.factor
View File

@ -1,7 +1,7 @@
USING: locals math sequences tools.test hashtables words kernel
namespaces arrays strings prettyprint io.streams.string parser
accessors generic eval combinators combinators.short-circuit
combinators.short-circuit.smart math.order ;
combinators.short-circuit.smart math.order math.functions ;
IN: locals.tests
:: foo ( a b -- a a ) a a ;
@ -305,17 +305,29 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
[ f ] [ 8 &&-test ] unit-test
[ t ] [ 12 &&-test ] unit-test
:: wlet-&&-test ( a -- ? )
[wlet | is-integer? [ a integer? ]
is-even? [ a even? ]
>10? [ a 10 > ] |
{ [ is-integer? ] [ is-even? ] [ >10? ] } &&
:: let-and-cond-test-1 ( -- a )
[let | a [ 10 ] |
[let | a [ 20 ] |
{
{ [ t ] [ [let | c [ 30 ] | a ] ] }
} cond
]
] ;
! [ f ] [ 1.5 wlet-&&-test ] unit-test
! [ f ] [ 3 wlet-&&-test ] unit-test
! [ f ] [ 8 wlet-&&-test ] unit-test
! [ t ] [ 12 wlet-&&-test ] unit-test
\ let-and-cond-test-1 must-infer
[ 20 ] [ let-and-cond-test-1 ] unit-test
:: let-and-cond-test-2 ( -- pair )
[let | A [ 10 ] |
[let | B [ 20 ] |
{ { [ t ] [ { A B } ] } } cond
]
] ;
\ let-and-cond-test-2 must-infer
[ { 10 20 } ] [ let-and-cond-test-2 ] unit-test
[ { 10 } ] [ 10 [| a | { a } ] call ] unit-test
[ { 10 20 } ] [ 10 20 [| a b | { a b } ] call ] unit-test
@ -333,6 +345,16 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
{ 3 1 } [| from to seq | T{ slice f from to seq } ] must-infer-as
:: literal-identity-test ( -- a b )
{ } V{ } ;
[ t f ] [
literal-identity-test
literal-identity-test
swapd [ eq? ] [ eq? ] 2bi*
] unit-test
:: compare-case ( obj1 obj2 lt-quot eq-quot gt-quot -- )
obj1 obj2 <=> {
{ +lt+ [ lt-quot call ] }
@ -340,4 +362,30 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
{ +gt+ [ gt-quot call ] }
} case ; inline
[ [ ] [ ] [ ] compare-case ] must-infer
[ [ ] [ ] [ ] compare-case ] must-infer
:: big-case-test ( a -- b )
a {
{ 0 [ a 1 + ] }
{ 1 [ a 1 - ] }
{ 2 [ a 1 swap / ] }
{ 3 [ a dup * ] }
{ 4 [ a sqrt ] }
{ 5 [ a a ^ ] }
} case ;
\ big-case-test must-infer
[ 9 ] [ 3 big-case-test ] unit-test
! :: wlet-&&-test ( a -- ? )
! [wlet | is-integer? [ a integer? ]
! is-even? [ a even? ]
! >10? [ a 10 > ] |
! { [ is-integer? ] [ is-even? ] [ >10? ] } &&
! ] ;
! [ f ] [ 1.5 wlet-&&-test ] unit-test
! [ f ] [ 3 wlet-&&-test ] unit-test
! [ f ] [ 8 wlet-&&-test ] unit-test
! [ t ] [ 12 wlet-&&-test ] unit-test

35
basis/locals/locals.factor
View File

@ -35,11 +35,15 @@ C: <wlet> wlet
M: lambda expand-macros clone [ expand-macros ] change-body ;
M: lambda expand-macros* expand-macros literal ;
M: binding-form expand-macros
clone
[ [ expand-macros ] assoc-map ] change-bindings
[ expand-macros ] change-body ;
M: binding-form expand-macros* expand-macros literal ;
PREDICATE: local < word "local?" word-prop ;
: <local> ( name -- word )
@ -142,12 +146,12 @@ GENERIC: free-vars* ( form -- )
[ free-vars* ] { } make prune ;
: add-if-free ( object -- )
{
{ [ dup local-writer? ] [ "local-reader" word-prop , ] }
{ [ dup lexical? ] [ , ] }
{ [ dup quote? ] [ local>> , ] }
{ [ t ] [ free-vars* ] }
} cond ;
{
{ [ dup local-writer? ] [ "local-reader" word-prop , ] }
{ [ dup lexical? ] [ , ] }
{ [ dup quote? ] [ local>> , ] }
{ [ t ] [ free-vars* ] }
} cond ;
M: object free-vars* drop ;
@ -195,6 +199,20 @@ M: block lambda-rewrite*
swap point-free ,
] keep length \ curry <repetition> % ;
GENERIC: rewrite-literal? ( obj -- ? )
M: special rewrite-literal? drop t ;
M: array rewrite-literal? [ rewrite-literal? ] contains? ;
M: hashtable rewrite-literal? drop t ;
M: vector rewrite-literal? drop t ;
M: tuple rewrite-literal? drop t ;
M: object rewrite-literal? drop f ;
GENERIC: rewrite-element ( obj -- )
: rewrite-elements ( seq -- )
@ -203,7 +221,8 @@ GENERIC: rewrite-element ( obj -- )
: rewrite-sequence ( seq -- )
[ rewrite-elements ] [ length , ] [ , ] tri \ nsequence , ;
M: array rewrite-element rewrite-sequence ;
M: array rewrite-element
dup rewrite-literal? [ rewrite-sequence ] [ , ] if ;
M: vector rewrite-element rewrite-sequence ;
@ -441,7 +460,7 @@ M: lambda-memoized definition
"lambda" word-prop body>> ;
M: lambda-memoized reset-word
[ f "lambda" set-word-prop ] [ call-next-method ] bi ;
[ call-next-method ] [ f "lambda" set-word-prop ] bi ;
: method-stack-effect ( method -- effect )
dup "lambda" word-prop vars>>

2
basis/logging/server/server.factor
View File

@ -83,7 +83,7 @@ SYMBOL: log-files
: (rotate-logs) ( -- )
(close-logs)
log-root directory [ drop rotate-log ] assoc-each ;
log-root directory-files [ rotate-log ] each ;
: log-server-loop ( -- )
receive unclip {

29
basis/macros/expander/expander.factor
View File

@ -1,14 +1,12 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences namespaces make quotations accessors
words continuations vectors effects math
stack-checker.transforms ;
USING: kernel sequences sequences.private namespaces make
quotations accessors words continuations vectors effects math
generalizations stack-checker.transforms fry ;
IN: macros.expander
GENERIC: expand-macros ( quot -- quot' )
<PRIVATE
SYMBOL: stack
: begin ( -- ) V{ } clone stack set ;
@ -28,6 +26,17 @@ GENERIC: expand-macros* ( obj -- )
M: wrapper expand-macros* wrapped>> literal ;
: expand-dispatch? ( word -- ? )
\ dispatch eq? stack get length 1 >= and ;
: expand-dispatch ( -- )
stack get pop end
[ [ expand-macros ] [ ] map-as '[ _ dip ] % ]
[
length [ <reversed> ] keep
[ '[ _ ndrop _ nnip call ] [ ] like ] 2map , \ dispatch ,
] bi ;
: expand-macro ( quot -- )
stack [ swap with-datastack >vector ] change
stack get pop >quotation end (expand-macros) ;
@ -38,8 +47,14 @@ M: wrapper expand-macros* wrapped>> literal ;
stack get length <=
] [ 2drop f f ] if ;
: word, ( word -- ) end , ;
M: word expand-macros*
dup expand-macro? [ nip expand-macro ] [ drop end , ] if ;
dup expand-dispatch? [ drop expand-dispatch ] [
dup expand-macro? [ nip expand-macro ] [
drop word,
] if
] if ;
M: object expand-macros* literal ;
@ -48,5 +63,3 @@ M: callable expand-macros*
M: callable expand-macros ( quot -- quot' )
[ begin (expand-macros) end ] [ ] make ;
PRIVATE>

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

@ -396,8 +396,6 @@ do-primitive alien-invoke alien-indirect alien-callback
\ (exists?) { string } { object } define-primitive
\ (directory) { string } { array } define-primitive
\ gc { } { } define-primitive
\ gc-stats { } { array } define-primitive
@ -412,8 +410,6 @@ do-primitive alien-invoke alien-indirect alien-callback
\ code-room { } { integer integer integer integer } define-primitive
\ code-room make-flushable
\ os-env { string } { object } define-primitive
\ millis { } { integer } define-primitive
\ millis make-flushable
@ -590,14 +586,6 @@ do-primitive alien-invoke alien-indirect alien-callback
\ set-innermost-frame-quot { quotation callstack } { } define-primitive
\ (os-envs) { } { array } define-primitive
\ set-os-env { string string } { } define-primitive
\ unset-os-env { string } { } define-primitive
\ (set-os-envs) { array } { } define-primitive
\ dll-valid? { object } { object } define-primitive
\ modify-code-heap { array object } { } define-primitive

12
basis/tools/vocabs/vocabs.factor
View File

@ -14,8 +14,7 @@ IN: tools.vocabs
: vocab-tests-dir ( vocab -- paths )
dup vocab-dir "tests" append-path vocab-append-path dup [
dup exists? [
dup directory keys
[ ".factor" tail? ] filter
dup directory-files [ ".factor" tail? ] filter
[ append-path ] with map
] [ drop f ] if
] [ drop f ] if ;
@ -208,11 +207,16 @@ M: vocab-link summary vocab-summary ;
dup vocab-authors-path set-vocab-file-contents ;
: subdirs ( dir -- dirs )
directory [ second ] filter keys natural-sort ;
dup [
[ link-info directory? ] filter
] with-directory-files
[ append-path ] with map natural-sort ;
: (all-child-vocabs) ( root name -- vocabs )
[ vocab-dir append-path subdirs ] keep
[
vocab-dir append-path dup exists?
[ subdirs ] [ drop { } ] if
] keep [
swap [ "." swap 3append ] with map
] unless-empty ;

6
basis/ui/x11/x11.factor
View File

@ -6,8 +6,8 @@ assocs kernel math namespaces opengl sequences strings x11.xlib
x11.events x11.xim x11.glx x11.clipboard x11.constants
x11.windows io.encodings.string io.encodings.ascii
io.encodings.utf8 combinators debugger command-line qualified
math.vectors classes.tuple opengl.gl threads math.geometry.rect ;
QUALIFIED: system
math.vectors classes.tuple opengl.gl threads math.geometry.rect
environment ;
IN: ui.x11
SINGLETON: x11-ui-backend
@ -262,5 +262,5 @@ M: x11-ui-backend beep ( -- )
x11-ui-backend ui-backend set-global
[ "DISPLAY" system:os-env "ui" "listener" ? ]
[ "DISPLAY" os-env "ui" "listener" ? ]
main-vocab-hook set-global

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

@ -3,8 +3,6 @@
USING: alien.syntax combinators system vocabs.loader ;
IN: unix
! FreeBSD
: MAXPATHLEN 1024 ; inline
: O_RDONLY HEX: 0000 ; inline

17
basis/unix/bsd/freebsd/freebsd.factor
View File

@ -13,6 +13,23 @@ C-STRUCT: addrinfo
{ "void*" "addr" }
{ "addrinfo*" "next" } ;
C-STRUCT: dirent
{ "u_int32_t" "d_fileno" }
{ "u_int16_t" "d_reclen" }
{ "u_int8_t" "d_type" }
{ "u_int8_t" "d_namlen" }
{ { "char" 256 } "d_name" } ;
: DT_UNKNOWN 0 ; inline
: DT_FIFO 1 ; inline
: DT_CHR 2 ; inline
: DT_DIR 4 ; inline
: DT_BLK 6 ; inline
: DT_REG 8 ; inline
: DT_LNK 10 ; inline
: DT_SOCK 12 ; inline
: DT_WHT 14 ; inline
: EPERM 1 ; inline
: ENOENT 2 ; inline
: ESRCH 3 ; inline

52
basis/unix/bsd/macosx/macosx.factor
View File

@ -13,6 +13,43 @@ C-STRUCT: addrinfo
{ "void*" "addr" }
{ "addrinfo*" "next" } ;
: _UTX_USERSIZE 256 ; inline
: _UTX_LINESIZE 32 ; inline
: _UTX_IDSIZE 4 ; inline
: _UTX_HOSTSIZE 256 ; inline
C-STRUCT: utmpx
{ { "char" _UTX_USERSIZE } "ut_user" }
{ { "char" _UTX_IDSIZE } "ut_id" }
{ { "char" _UTX_LINESIZE } "ut_line" }
{ "pid_t" "ut_pid" }
{ "short" "ut_type" }
{ "timeval" "ut_tv" }
{ { "char" _UTX_HOSTSIZE } "ut_host" }
{ { "uint" 16 } "ut_pad" } ;
: __DARWIN_MAXPATHLEN 1024 ; inline
: __DARWIN_MAXNAMELEN 255 ; inline
: __DARWIN_MAXNAMELEN+1 255 ; inline
C-STRUCT: dirent
{ "ino_t" "d_ino" }
{ "__uint16_t" "d_reclen" }
{ "__uint8_t" "d_type" }
{ "__uint8_t" "d_namlen" }
{ { "char" __DARWIN_MAXNAMELEN+1 } "d_name" } ;
: DT_UNKNOWN 0 ; inline
: DT_FIFO 1 ; inline
: DT_CHR 2 ; inline
: DT_DIR 4 ; inline
: DT_BLK 6 ; inline
: DT_REG 8 ; inline
: DT_LNK 10 ; inline
: DT_SOCK 12 ; inline
: DT_WHT 14 ; inline
: EPERM 1 ; inline
: ENOENT 2 ; inline
: ESRCH 3 ; inline
@ -117,18 +154,3 @@ C-STRUCT: addrinfo
: ETIME 101 ; inline
: EOPNOTSUPP 102 ; inline
: ENOPOLICY 103 ; inline
: _UTX_USERSIZE 256 ; inline
: _UTX_LINESIZE 32 ; inline
: _UTX_IDSIZE 4 ; inline
: _UTX_HOSTSIZE 256 ; inline
C-STRUCT: utmpx
{ { "char" _UTX_USERSIZE } "ut_user" }
{ { "char" _UTX_IDSIZE } "ut_id" }
{ { "char" _UTX_LINESIZE } "ut_line" }
{ "pid_t" "ut_pid" }
{ "short" "ut_type" }
{ "timeval" "ut_tv" }
{ { "char" _UTX_HOSTSIZE } "ut_host" }
{ { "uint" 16 } "ut_pad" } ;

17
basis/unix/bsd/netbsd/netbsd.factor
View File

@ -13,6 +13,23 @@ C-STRUCT: addrinfo
{ "void*" "addr" }
{ "addrinfo*" "next" } ;
C-STRUCT: dirent
{ "ino_t" "d_fileno" }
{ "__uint16_t" "d_reclen" }
{ "__uint16_t" "d_namlen" }
{ "__uint8_t" "d_type" }
{ { "char" 512 } "d_name" } ;
: DT_UNKNOWN 0 ; inline
: DT_FIFO 1 ; inline
: DT_CHR 2 ; inline
: DT_DIR 4 ; inline
: DT_BLK 6 ; inline
: DT_REG 8 ; inline
: DT_LNK 10 ; inline
: DT_SOCK 12 ; inline
: DT_WHT 14 ; inline
: EPERM 1 ; inline
: ENOENT 2 ; inline
: ESRCH 3 ; inline

18
basis/unix/bsd/openbsd/openbsd.factor
View File

@ -13,6 +13,24 @@ C-STRUCT: addrinfo
{ "char*" "canonname" }
{ "addrinfo*" "next" } ;
C-STRUCT: dirent
{ "__uint32_t" "d_fileno" }
{ "__uint16_t" "d_reclen" }
{ "__uint8_t" "d_type" }
{ "__uint8_t" "d_namlen" }
{ { "char" 256 } "d_name" } ;
: DT_UNKNOWN 0 ; inline
: DT_FIFO 1 ; inline
: DT_CHR 2 ; inline
: DT_DIR 4 ; inline
: DT_BLK 6 ; inline
: DT_REG 8 ; inline
: DT_LNK 10 ; inline
: DT_SOCK 12 ; inline
: EPERM 1 ; inline
: ENOENT 2 ; inline
: ESRCH 3 ; inline

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

@ -4,7 +4,7 @@ USING: alien alien.c-types alien.strings io.encodings.utf8
io.unix.backend kernel math sequences splitting unix strings
combinators.short-circuit byte-arrays combinators qualified
accessors math.parser fry assocs namespaces continuations
unix.users ;
unix.users unix.utilities ;
IN: unix.groups
QUALIFIED: grouping
@ -18,12 +18,7 @@ GENERIC: group-struct ( obj -- group )
<PRIVATE
: group-members ( group-struct -- seq )
group-gr_mem
[ dup { [ ] [ *void* ] } 1&& ]
[
dup *void* utf8 alien>string
[ alien-address "char**" heap-size + <alien> ] dip
] [ ] produce nip ;
group-gr_mem utf8 alien>strings ;
: (group-struct) ( id -- group-struct id group-struct byte-array length void* )
"group" <c-object> tuck 4096

4
basis/unix/linux/fs/fs.factor
View File

@ -1,6 +1,4 @@
USING: alien.syntax ;
IN: unix.linux.fs
: MS_RDONLY 1 ; ! Mount read-only.
@ -22,4 +20,4 @@ FUNCTION: int mount
! FUNCTION: int umount2 ( char* file, int flags ) ;
FUNCTION: int umount ( char* file ) ;
FUNCTION: int umount ( char* file ) ;

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

@ -92,6 +92,13 @@ C-STRUCT: passwd
{ "char*" "pw_dir" }
{ "char*" "pw_shell" } ;
C-STRUCT: dirent
{ "__ino_t" "d_ino" }
{ "__off_t" "d_off" }
{ "ushort" "d_reclen" }
{ "uchar" "d_type" }
{ { "char" 256 } "d_name" } ;
: EPERM 1 ; inline
: ENOENT 2 ; inline
: ESRCH 3 ; inline

17
basis/unix/process/process.factor
View File

@ -1,6 +1,6 @@
USING: kernel alien.c-types alien.strings sequences math alien.syntax unix
vectors kernel namespaces continuations threads assocs vectors
io.unix.backend io.encodings.utf8 ;
vectors kernel namespaces continuations threads assocs vectors
io.unix.backend io.encodings.utf8 unix.utilities ;
IN: unix.process
! Low-level Unix process launching utilities. These are used
@ -15,17 +15,16 @@ FUNCTION: int execv ( char* path, char** argv ) ;
FUNCTION: int execvp ( char* path, char** argv ) ;
FUNCTION: int execve ( char* path, char** argv, char** envp ) ;
: >argv ( seq -- alien )
[ utf8 malloc-string ] map f suffix >c-void*-array ;
: exec ( pathname argv -- int )
[ utf8 malloc-string ] [ >argv ] bi* execv ;
[ utf8 malloc-string ] [ utf8 strings>alien ] bi* execv ;
: exec-with-path ( filename argv -- int )
[ utf8 malloc-string ] [ >argv ] bi* execvp ;
[ utf8 malloc-string ] [ utf8 strings>alien ] bi* execvp ;
: exec-with-env ( filename argv envp -- int )
[ utf8 malloc-string ] [ >argv ] [ >argv ] tri* execve ;
[ utf8 malloc-string ]
[ utf8 strings>alien ]
[ utf8 strings>alien ] tri* execve ;
: exec-args ( seq -- int )
[ first ] [ ] bi exec ;
@ -99,4 +98,4 @@ FUNCTION: pid_t wait ( int* status ) ;
FUNCTION: pid_t waitpid ( pid_t wpid, int* status, int options ) ;
: wait-for-pid ( pid -- status )
0 <int> [ 0 waitpid drop ] keep *int WEXITSTATUS ;
0 <int> [ 0 waitpid drop ] keep *int WEXITSTATUS ;

12
basis/unix/stat/linux/32/32.factor
View File

@ -31,3 +31,15 @@ FUNCTION: int __lxstat ( int ver, char* pathname, stat* buf ) ;
: stat ( pathname buf -- int ) 3 -rot __xstat ;
: lstat ( pathname buf -- int ) 3 -rot __lxstat ;
C-STRUCT: statfs
{ "long" "f_type" }
{ "long" "f_bsize" }
{ "long" "f_blocks" }
{ "long" "f_bfree" }
{ "long" "f_bavail" }
{ "long" "f_files" }
{ "long" "f_ffree" }
{ "fsid_t" "f_fsid" }
{ "long" "f_namelen" } ;

91
basis/unix/stat/linux/64/64.factor
View File

@ -1,5 +1,5 @@
USING: kernel alien.syntax math ;
USING: kernel alien.syntax math sequences unix
alien.c-types arrays accessors combinators ;
IN: unix.stat
@ -29,3 +29,90 @@ FUNCTION: int __lxstat ( int ver, char* pathname, stat* buf ) ;
: stat ( pathname buf -- int ) 1 -rot __xstat ;
: lstat ( pathname buf -- int ) 1 -rot __lxstat ;
C-STRUCT: fstab
{ "char*" "fs_spec" }
{ "char*" "fs_file" }
{ "char*" "fs_vfstype" }
{ "char*" "fs_mntops" }
{ "char*" "fs_type" }
{ "int" "fs_freq" }
{ "int" "fs_passno" } ;
FUNCTION: fstab* getfsent ( ) ;
FUNCTION: fstab* getfsspec ( char* name ) ;
FUNCTION: fstab* getfsfile ( char* name ) ;
FUNCTION: int setfsent ( ) ;
FUNCTION: void endfsent ( ) ;
TUPLE: fstab spec file vfstype mntops type freq passno ;
: fstab-struct>fstab ( struct -- fstab )
[ fstab new ] dip
{
[ fstab-fs_spec >>spec ]
[ fstab-fs_file >>file ]
[ fstab-fs_vfstype >>vfstype ]
[ fstab-fs_mntops >>mntops ]
[ fstab-fs_type >>type ]
[ fstab-fs_freq >>freq ]
[ fstab-fs_passno >>passno ]
} cleave ;
C-STRUCT: fsid
{ { "int" 2 } "__val" } ;
TYPEDEF: fsid __fsid_t
TYPEDEF: ssize_t __SWORD_TYPE
TYPEDEF: ulonglong __fsblkcnt64_t
TYPEDEF: ulonglong __fsfilcnt64_t
C-STRUCT: statfs64
{ "__SWORD_TYPE" "f_type" }
{ "__SWORD_TYPE" "f_bsize" }
{ "__fsblkcnt64_t" "f_blocks" }
{ "__fsblkcnt64_t" "f_bfree" }
{ "__fsblkcnt64_t" "f_bavail" }
{ "__fsfilcnt64_t" "f_files" }
{ "__fsfilcnt64_t" "f_ffree" }
{ "__fsid_t" "f_fsid" }
{ "__SWORD_TYPE" "f_namelen" }
{ "__SWORD_TYPE" "f_frsize" }
{ { "__SWORD_TYPE" 5 } "f_spare" } ;
TUPLE: statfs type bsize blocks bfree bavail files ffree fsid
namelen frsize spare ;
: statfs-struct>statfs ( struct -- statfs )
[ \ statfs new ] dip
{
[ statfs64-f_type >>type ]
[ statfs64-f_bsize >>bsize ]
[ statfs64-f_blocks >>blocks ]
[ statfs64-f_bfree >>bfree ]
[ statfs64-f_bavail >>bavail ]
[ statfs64-f_files >>files ]
[ statfs64-f_ffree >>ffree ]
[ statfs64-f_fsid >>fsid ]
[ statfs64-f_namelen >>namelen ]
[ statfs64-f_frsize >>frsize ]
[ statfs64-f_spare >>spare ]
} cleave ;
FUNCTION: int statfs64 ( char* path, statfs64* buf ) ;
: statfs ( path -- byte-array )
"statfs64" <c-object> [ statfs64 io-error ] keep ;
: all-fstabs ( -- seq )
setfsent io-error
[ getfsent dup ] [ fstab-struct>fstab ] [ drop ] produce endfsent ;
C-STRUCT: mntent
{ "char*" "mnt_fsname" }
{ "char*" "mnt_dir" }
{ "char*" "mnt_type" }
{ "char*" "mnt_opts" }
{ "int" "mnt_freq" }
{ "int" "mnt_passno" } ;

7
basis/unix/stat/linux/linux.factor
View File

@ -1,11 +1,8 @@
USING: layouts combinators vocabs.loader ;
IN: unix.stat
cell-bits
{
{
{ 32 [ "unix.stat.linux.32" require ] }
{ 64 [ "unix.stat.linux.64" require ] }
}
case
} case

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

@ -1,4 +1,5 @@
USING: kernel alien.syntax math ;
USING: kernel alien.syntax math unix math.bitwise
alien.c-types alien sequences grouping accessors combinators ;
IN: unix.stat
! Mac OS X ppc
@ -30,3 +31,120 @@ FUNCTION: int lstat64 ( char* pathname, stat* buf ) ;
: stat ( path buf -- n ) stat64 ;
: lstat ( path buf -- n ) lstat64 ;
: MNT_RDONLY HEX: 00000001 ; inline
: MNT_SYNCHRONOUS HEX: 00000002 ; inline
: MNT_NOEXEC HEX: 00000004 ; inline
: MNT_NOSUID HEX: 00000008 ; inline
: MNT_NODEV HEX: 00000010 ; inline
: MNT_UNION HEX: 00000020 ; inline
: MNT_ASYNC HEX: 00000040 ; inline
: MNT_EXPORTED HEX: 00000100 ; inline
: MNT_QUARANTINE HEX: 00000400 ; inline
: MNT_LOCAL HEX: 00001000 ; inline
: MNT_QUOTA HEX: 00002000 ; inline
: MNT_ROOTFS HEX: 00004000 ; inline
: MNT_DOVOLFS HEX: 00008000 ; inline
: MNT_DONTBROWSE HEX: 00100000 ; inline
: MNT_IGNORE_OWNERSHIP HEX: 00200000 ; inline
: MNT_AUTOMOUNTED HEX: 00400000 ; inline
: MNT_JOURNALED HEX: 00800000 ; inline
: MNT_NOUSERXATTR HEX: 01000000 ; inline
: MNT_DEFWRITE HEX: 02000000 ; inline
: MNT_MULTILABEL HEX: 04000000 ; inline
: MNT_NOATIME HEX: 10000000 ; inline
: MNT_UNKNOWNPERMISSIONS MNT_IGNORE_OWNERSHIP ; inline
: MNT_VISFLAGMASK ( -- n )
{
MNT_RDONLY MNT_SYNCHRONOUS MNT_NOEXEC
MNT_NOSUID MNT_NODEV MNT_UNION
MNT_ASYNC MNT_EXPORTED MNT_QUARANTINE
MNT_LOCAL MNT_QUOTA
MNT_ROOTFS MNT_DOVOLFS MNT_DONTBROWSE
MNT_IGNORE_OWNERSHIP MNT_AUTOMOUNTED MNT_JOURNALED
MNT_NOUSERXATTR MNT_DEFWRITE MNT_MULTILABEL MNT_NOATIME
} flags ; inline
: MNT_UPDATE HEX: 00010000 ; inline
: MNT_RELOAD HEX: 00040000 ; inline
: MNT_FORCE HEX: 00080000 ; inline
: MNT_CMDFLAGS { MNT_UPDATE MNT_RELOAD MNT_FORCE } flags ; inline
: VFS_GENERIC 0 ; inline
: VFS_NUMMNTOPS 1 ; inline
: VFS_MAXTYPENUM 1 ; inline
: VFS_CONF 2 ; inline
: VFS_SET_PACKAGE_EXTS 3 ; inline
: MNT_WAIT 1 ; inline
: MNT_NOWAIT 2 ; inline
: VFS_CTL_VERS1 HEX: 01 ; inline
: VFS_CTL_STATFS HEX: 00010001 ; inline
: VFS_CTL_UMOUNT HEX: 00010002 ; inline
: VFS_CTL_QUERY HEX: 00010003 ; inline
: VFS_CTL_NEWADDR HEX: 00010004 ; inline
: VFS_CTL_TIMEO HEX: 00010005 ; inline
: VFS_CTL_NOLOCKS HEX: 00010006 ; inline
C-STRUCT: vfsquery
{ "uint32_t" "vq_flags" }
{ { "uint32_t" 31 } "vq_spare" } ;
: VQ_NOTRESP HEX: 0001 ; inline
: VQ_NEEDAUTH HEX: 0002 ; inline
: VQ_LOWDISK HEX: 0004 ; inline
: VQ_MOUNT HEX: 0008 ; inline
: VQ_UNMOUNT HEX: 0010 ; inline
: VQ_DEAD HEX: 0020 ; inline
: VQ_ASSIST HEX: 0040 ; inline
: VQ_NOTRESPLOCK HEX: 0080 ; inline
: VQ_UPDATE HEX: 0100 ; inline
: VQ_FLAG0200 HEX: 0200 ; inline
: VQ_FLAG0400 HEX: 0400 ; inline
: VQ_FLAG0800 HEX: 0800 ; inline
: VQ_FLAG1000 HEX: 1000 ; inline
: VQ_FLAG2000 HEX: 2000 ; inline
: VQ_FLAG4000 HEX: 4000 ; inline
: VQ_FLAG8000 HEX: 8000 ; inline
: NFSV4_MAX_FH_SIZE 128 ; inline
: NFSV3_MAX_FH_SIZE 64 ; inline
: NFSV2_MAX_FH_SIZE 32 ; inline
: NFS_MAX_FH_SIZE NFSV4_MAX_FH_SIZE ; inline
! C-STRUCT: fhandle
! { "int" "fh_len" }
! { { "uchar" NFS_MAX_FH_SIZE } "fh_data" } ;
! TYPEDEF: fhandle fhandle_t
: MFSNAMELEN 15 ; inline
: MNAMELEN 90 ; inline
: MFSTYPENAMELEN 16 ; inline
C-STRUCT: fsid_t
{ { "int32_t" 2 } "val" } ;
C-STRUCT: statfs64
{ "uint32_t" "f_bsize" }
{ "int32_t" "f_iosize" }
{ "uint64_t" "f_blocks" }
{ "uint64_t" "f_bfree" }
{ "uint64_t" "f_bavail" }
{ "uint64_t" "f_files" }
{ "uint64_t" "f_ffree" }
{ "fsid_t" "f_fsid" }
{ "uid_t" "f_owner" }
{ "uint32_t" "f_type" }
{ "uint32_t" "f_flags" }
{ "uint32_t" "f_fssubtype" }
{ { "char" MFSTYPENAMELEN } "f_fstypename" }
{ { "char" MAXPATHLEN } "f_mntonname" }
{ { "char" MAXPATHLEN } "f_mntfromname" }
{ { "uint32_t" 8 } "f_reserved" } ;
FUNCTION: int statfs64 ( char* path, statfs64* buf ) ;
FUNCTION: int getmntinfo64 ( statfs64** mntbufp, int flags ) ;

8
basis/unix/stat/stat.factor
View File

@ -27,11 +27,7 @@ FUNCTION: int mkdir ( char* path, mode_t mode ) ;
} case >>
: file-status ( pathname -- stat )
"stat" <c-object> [
[ stat ] unix-system-call drop
] keep ;
"stat" <c-object> [ [ stat ] unix-system-call drop ] keep ;
: link-status ( pathname -- stat )
"stat" <c-object> [
[ lstat ] unix-system-call drop
] keep ;
"stat" <c-object> [ [ lstat ] unix-system-call drop ] keep ;

10
basis/unix/types/linux/linux.factor
View File

@ -1,10 +1,6 @@
USING: alien.syntax ;
IN: unix.types
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TYPEDEF: ulonglong __uquad_type
TYPEDEF: ulong __ulongword_type
TYPEDEF: long __sword_type
@ -13,17 +9,17 @@ TYPEDEF: long __slongword_type
TYPEDEF: uint __u32_type
TYPEDEF: int __s32_type
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TYPEDEF: __uquad_type dev_t
TYPEDEF: __ulongword_type ino_t
TYPEDEF: ino_t __ino_t
TYPEDEF: __u32_type mode_t
TYPEDEF: __uword_type nlink_t
TYPEDEF: __u32_type uid_t
TYPEDEF: __u32_type gid_t
TYPEDEF: __slongword_type off_t
TYPEDEF: off_t __off_t
TYPEDEF: __slongword_type blksize_t
TYPEDEF: __slongword_type blkcnt_t
TYPEDEF: __sword_type ssize_t
TYPEDEF: __s32_type pid_t
TYPEDEF: __slongword_type time_t
TYPEDEF: __slongword_type time_t

13
basis/unix/types/netbsd/netbsd.factor
View File

@ -3,19 +3,6 @@ IN: unix.types
! NetBSD 4.0
TYPEDEF: short __int16_t
TYPEDEF: ushort __uint16_t
TYPEDEF: int __int32_t
TYPEDEF: uint __uint32_t
TYPEDEF: longlong __int64_t
TYPEDEF: longlong __uint64_t
TYPEDEF: int int32_t
TYPEDEF: uint uint32_t
TYPEDEF: uint u_int32_t
TYPEDEF: longlong int64_t
TYPEDEF: ulonglong u_int64_t
TYPEDEF: __uint32_t __dev_t
TYPEDEF: __uint32_t dev_t
TYPEDEF: __uint32_t mode_t

13
basis/unix/types/openbsd/openbsd.factor
View File

@ -3,19 +3,6 @@ IN: unix.types
! OpenBSD 4.2
TYPEDEF: short __int16_t
TYPEDEF: ushort __uint16_t
TYPEDEF: int __int32_t
TYPEDEF: uint __uint32_t
TYPEDEF: longlong __int64_t
TYPEDEF: longlong __uint64_t
TYPEDEF: int int32_t
TYPEDEF: uint u_int32_t
TYPEDEF: uint uint32_t
TYPEDEF: longlong int64_t
TYPEDEF: ulonglong u_int64_t
TYPEDEF: __uint32_t __dev_t
TYPEDEF: __uint32_t dev_t
TYPEDEF: __uint32_t ino_t

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

@ -16,6 +16,11 @@ TYPEDEF: ushort uint16_t
TYPEDEF: uint uint32_t
TYPEDEF: ulonglong uint64_t
TYPEDEF: uchar u_int8_t
TYPEDEF: ushort u_int16_t
TYPEDEF: uint u_int32_t
TYPEDEF: ulonglong u_int64_t
TYPEDEF: char __int8_t
TYPEDEF: short __int16_t
TYPEDEF: int __int32_t

9
basis/unix/unix.factor
View File

@ -81,6 +81,7 @@ 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 ;
@ -105,6 +106,8 @@ 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 ( ) ;
@ -134,6 +137,8 @@ FUNCTION: int shutdown ( int fd, int how ) ;
FUNCTION: int open ( char* path, int flags, int prot ) ;
FUNCTION: DIR* opendir ( char* path ) ;
: open-file ( path flags mode -- fd ) [ open ] unix-system-call ;
C-STRUCT: utimbuf
@ -155,6 +160,8 @@ FUNCTION: int pipe ( int* filedes ) ;
FUNCTION: void* popen ( char* command, char* type ) ;
FUNCTION: ssize_t read ( int fd, void* buf, size_t nbytes ) ;
FUNCTION: int readdir_r ( void* dirp, dirent* entry, dirent** result ) ;
FUNCTION: ssize_t readlink ( char* path, char* buf, size_t bufsize ) ;
: PATH_MAX 1024 ; inline
@ -171,6 +178,8 @@ 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 ) ;

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

@ -0,0 +1 @@
Doug Coleman

19
basis/unix/utilities/utilities.factor Normal file
View File

@ -0,0 +1,19 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings
combinators.short-circuit fry kernel layouts sequences ;
IN: unix.utilities
: more? ( alien -- ? )
{ [ ] [ *void* ] } 1&& ;
: advance ( void* -- void* )
cell swap <displaced-alien> ;
: alien>strings ( alien encoding -- strings )
[ [ dup more? ] ] dip
'[ [ advance ] [ *void* _ alien>string ] bi ]
[ ] produce nip ;
: strings>alien ( strings encoding -- alien )
'[ _ malloc-string ] map f suffix >c-void*-array ;

3
basis/windows/errors/errors.factor
View File

@ -2,8 +2,9 @@ USING: kernel ;
IN: windows.errors
: ERROR_SUCCESS 0 ; inline
: ERROR_NO_MORE_FILES 18 ; inline
: ERROR_HANDLE_EOF 38 ; inline
: ERROR_BROKEN_PIPE 109 ; inline
: ERROR_ENVVAR_NOT_FOUND 203 ; inline
: ERROR_IO_INCOMPLETE 996 ; inline
: ERROR_IO_PENDING 997 ; inline

13
basis/windows/kernel32/kernel32.factor
View File

@ -838,7 +838,8 @@ ALIAS: FindNextFile FindNextFileW
! FUNCTION: FormatMessageW
! FUNCTION: FreeConsole
! FUNCTION: FreeEnvironmentStringsA
! FUNCTION: FreeEnvironmentStringsW
FUNCTION: BOOL FreeEnvironmentStringsW ( LPTCH lpszEnvironmentBlock ) ;
ALIAS: FreeEnvironmentStrings FreeEnvironmentStringsW
! FUNCTION: FreeLibrary
! FUNCTION: FreeLibraryAndExitThread
! FUNCTION: FreeResource
@ -933,11 +934,12 @@ FUNCTION: HANDLE GetCurrentThread ( ) ;
! FUNCTION: GetDllDirectoryW
! FUNCTION: GetDriveTypeA
! FUNCTION: GetDriveTypeW
! FUNCTION: GetEnvironmentStrings
FUNCTION: void* GetEnvironmentStringsW ( ) ;
! FUNCTION: GetEnvironmentStringsA
! FUNCTION: GetEnvironmentStringsW
ALIAS: GetEnvironmentStrings GetEnvironmentStringsW
! FUNCTION: GetEnvironmentVariableA
! FUNCTION: GetEnvironmentVariableW
FUNCTION: DWORD GetEnvironmentVariableW ( LPCTSTR lpName, LPTSTR lpBuffer, DWORD nSize ) ;
ALIAS: GetEnvironmentVariable GetEnvironmentVariableW
FUNCTION: BOOL GetExitCodeProcess ( HANDLE hProcess, LPDWORD lpExitCode ) ;
! FUNCTION: GetExitCodeThread
! FUNCTION: GetExpandedNameA
@ -1418,7 +1420,8 @@ ALIAS: SetCurrentDirectory SetCurrentDirectoryW
! FUNCTION: SetDllDirectoryW
FUNCTION: BOOL SetEndOfFile ( HANDLE hFile ) ;
! FUNCTION: SetEnvironmentVariableA
! FUNCTION: SetEnvironmentVariableW
FUNCTION: BOOL SetEnvironmentVariableW ( LPCTSTR key, LPCTSTR value ) ;
ALIAS: SetEnvironmentVariable SetEnvironmentVariableW
! FUNCTION: SetErrorMode
! FUNCTION: SetEvent
! FUNCTION: SetFileApisToANSI

10
basis/windows/types/types.factor
View File

@ -7,7 +7,7 @@ TYPEDEF: char CHAR
TYPEDEF: uchar UCHAR
TYPEDEF: uchar BYTE
TYPEDEF: ushort wchar_t
TYPEDEF: ushort wchar_t
TYPEDEF: wchar_t WCHAR
TYPEDEF: short SHORT
@ -64,12 +64,12 @@ TYPEDEF: ulonglong DWORD64
TYPEDEF: longlong LARGE_INTEGER
TYPEDEF: LARGE_INTEGER* PLARGE_INTEGER
TYPEDEF: WCHAR TCHAR
TYPEDEF: TCHAR TBYTE
TYPEDEF: wchar_t* LPCSTR
TYPEDEF: wchar_t* LPWSTR
TYPEDEF: WCHAR TCHAR
TYPEDEF: LPWSTR LPTCH
TYPEDEF: LPWSTR PTCH
TYPEDEF: TCHAR TBYTE
TYPEDEF: WORD ATOM
TYPEDEF: BYTE BOOLEAN

6
core/bootstrap/primitives.factor
View File

@ -434,7 +434,6 @@ tuple
{ "getenv" "kernel.private" }
{ "setenv" "kernel.private" }
{ "(exists?)" "io.files.private" }
{ "(directory)" "io.files.private" }
{ "gc" "memory" }
{ "gc-stats" "memory" }
{ "save-image" "memory" }
@ -448,7 +447,6 @@ tuple
{ "exit" "system" }
{ "data-room" "memory" }
{ "code-room" "memory" }
{ "os-env" "system" }
{ "millis" "system" }
{ "modify-code-heap" "compiler.units" }
{ "dlopen" "alien" }
@ -518,10 +516,6 @@ tuple
{ "innermost-frame-scan" "kernel.private" }
{ "set-innermost-frame-quot" "kernel.private" }
{ "call-clear" "kernel" }
{ "(os-envs)" "system.private" }
{ "set-os-env" "system" }
{ "unset-os-env" "system" }
{ "(set-os-envs)" "system.private" }
{ "resize-byte-array" "byte-arrays" }
{ "dll-valid?" "alien" }
{ "unimplemented" "kernel.private" }

21
core/combinators/combinators.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays sequences sequences.private math.private
kernel kernel.private math assocs quotations vectors
hashtables sorting words sets math.order ;
hashtables sorting words sets math.order make ;
IN: combinators
! cleave
@ -116,17 +116,16 @@ ERROR: no-case ;
] [ drop f ] if
] [ drop f ] if ;
: dispatch-case ( value from to default array -- )
>r >r 3dup between? r> r> rot [
>r 2drop - >fixnum r> dispatch
] [
drop 2nip call
] if ; inline
: dispatch-case-quot ( default assoc -- quot )
[ nip keys [ infimum ] [ supremum ] bi ] 2keep
sort-keys values [ >quotation ] map
[ dispatch-case ] 2curry 2curry ;
[
\ dup ,
dup keys [ infimum , ] [ supremum , ] bi \ between? ,
[
dup keys infimum , [ - >fixnum ] %
sort-keys values [ >quotation ] map ,
\ dispatch ,
] [ ] make , , \ if ,
] [ ] make ;
: case>quot ( default assoc -- quot )
dup keys {

30
core/io/files/files-docs.factor
View File

@ -55,8 +55,9 @@ ARTICLE: "directories" "Directories"
"Home directory:"
{ $subsection home }
"Directory listing:"
{ $subsection directory }
{ $subsection directory* }
{ $subsection directory-entries }
{ $subsection directory-files }
{ $subsection with-directory-files }
"Creating directories:"
{ $subsection make-directory }
{ $subsection make-directories }
@ -304,23 +305,22 @@ HELP: directory?
{ $values { "file-info" file-info } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "file-info" } " is a directory." } ;
HELP: (directory)
HELP: (directory-entries)
{ $values { "path" "a pathname string" } { "seq" "a sequence of " { $snippet "{ name dir? }" } " pairs" } }
{ $description "Outputs the contents of a directory named by " { $snippet "path" } "." }
{ $notes "This is a low-level word, and user code should call " { $link directory } " instead." } ;
{ $notes "This is a low-level word, and user code should call one of the related words instead." } ;
HELP: directory
{ $values { "path" "a pathname string" } { "seq" "a sequence of " { $snippet "{ name dir? }" } " pairs" } }
HELP: directory-entries
{ $values { "path" "a pathname string" } { "seq" "a sequence of " { $link directory-entry } " objects" } }
{ $description "Outputs the contents of a directory named by " { $snippet "path" } "." } ;
HELP: directory*
{ $values { "path" "a pathname string" } { "seq" "a sequence of " { $snippet "{ path dir? }" } " pairs" } }
{ $description "Outputs the contents of a directory named by " { $snippet "path" } "." }
{ $notes "Unlike " { $link directory } ", this word prepends the directory's path to all file names in the list." } ;
HELP: directory-files
{ $values { "path" "a pathname string" } { "seq" "a sequence of filenames" } }
{ $description "Outputs the contents of a directory named by " { $snippet "path" } "." } ;
! HELP: file-modified
! { $values { "path" "a pathname string" } { "n" "a non-negative integer or " { $link f } } }
! { $description "Outputs a file's last modification time, since midnight January 1, 1970. If the file does not exist, outputs " { $link f } "." } ;
HELP: with-directory-files
{ $values { "path" "a pathname string" } { "quot" quotation } }
{ $description "Calls the quotation with the directory file names on the stack and with the directory set as the " { $link current-directory } ". Restores the current directory after the quotation is called." } ;
HELP: resource-path
{ $values { "path" "a pathname string" } { "newpath" "a pathname string" } }
@ -329,10 +329,6 @@ HELP: resource-path
HELP: pathname
{ $class-description "Class of path name objects. Path name objects can be created by calling " { $link <pathname> } "." } ;
HELP: normalize-directory
{ $values { "str" "a pathname string" } { "newstr" "a new pathname string" } }
{ $description "Called by the " { $link directory } " word to prepare a pathname before passing it to the " { $link (directory) } " primitive." } ;
HELP: normalize-path
{ $values { "str" "a pathname string" } { "newstr" "a new pathname string" } }
{ $description "Called by words such as " { $link <file-reader> } " and " { $link <file-writer> } " to prepare a pathname before passing it to underlying code." } ;

14
core/io/files/files-tests.factor
View File

@ -151,18 +151,24 @@ USE: debugger.threads
"delete-tree-test" temp-file delete-tree
] unit-test
[ { { "kernel" t } } ] [
[ { "kernel" } ] [
"core" resource-path [
"." directory [ first "kernel" = ] filter
"." directory-files [ "kernel" = ] filter
] with-directory
] unit-test
[ { { "kernel" t } } ] [
[ { "kernel" } ] [
"resource:core" [
"." directory [ first "kernel" = ] filter
"." directory-files [ "kernel" = ] filter
] with-directory
] unit-test
[ { "kernel" } ] [
"resource:core" [
[ "kernel" = ] filter
] with-directory-files
] unit-test
[ ] [
"copy-tree-test/a/b/c" temp-file make-directories
] unit-test

49
core/io/files/files.factor
View File

@ -235,19 +235,22 @@ HOOK: make-directory io-backend ( path -- )
]
} cond drop ;
! Directory listings
: fixup-directory ( path seq -- newseq )
[
dup string?
[ tuck append-path file-info directory? 2array ] [ nip ] if
] with map
[ first { "." ".." } member? not ] filter ;
TUPLE: directory-entry name type ;
: directory ( path -- seq )
normalize-directory dup (directory) fixup-directory ;
HOOK: >directory-entry os ( byte-array -- directory-entry )
: directory* ( path -- seq )
dup directory [ first2 >r append-path r> 2array ] with map ;
HOOK: (directory-entries) os ( path -- seq )
: directory-entries ( path -- seq )
normalize-path
(directory-entries)
[ name>> { "." ".." } member? not ] filter ;
: directory-files ( path -- seq )
directory-entries [ name>> ] map ;
: with-directory-files ( path quot -- )
[ "" directory-files ] prepose with-directory ; inline
! Touching files
HOOK: touch-file io-backend ( path -- )
@ -259,12 +262,10 @@ HOOK: delete-directory io-backend ( path -- )
: delete-tree ( path -- )
dup link-info type>> +directory+ = [
dup directory over [
[ first delete-tree ] each
] with-directory delete-directory
] [
delete-file
] if ;
[ [ [ delete-tree ] each ] with-directory-files ]
[ delete-directory ]
bi
] [ delete-file ] if ;
: to-directory ( from to -- from to' )
over file-name append-path ;
@ -303,9 +304,9 @@ DEFER: copy-tree-into
{
{ +symbolic-link+ [ copy-link ] }
{ +directory+ [
>r dup directory r> rot [
[ >r first r> copy-tree-into ] curry each
] with-directory
swap [
[ swap copy-tree-into ] with each
] with-directory-files
] }
[ drop copy-file ]
} case ;
@ -332,10 +333,6 @@ C: <pathname> pathname
M: pathname <=> [ string>> ] compare ;
! Home directory
HOOK: home os ( -- dir )
HOOK: home io-backend ( -- dir )
M: winnt home "USERPROFILE" os-env ;
M: wince home "" resource-path ;
M: unix home "HOME" os-env ;
M: object home "" resource-path ;

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

@ -397,6 +397,11 @@ HELP: filter
{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "subseq" "a new sequence" } }
{ $description "Applies the quotation to each element in turn, and outputs a new sequence containing the elements of the original sequence for which the quotation output a true value." } ;
HELP: filter-here
{ $values { "seq" "a resizable mutable sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } }
{ $description "Applies the quotation to each element in turn, and removes elements for which the quotation outputs a false value." }
{ $side-effects "seq" } ;
HELP: monotonic?
{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt elt -- ? )" } } { "?" "a boolean" } }
{ $description "Applies the relation to successive pairs of elements in the sequence, testing for a truth value. The relation should be a transitive relation, such as a total order or an equality relation." }
@ -436,20 +441,24 @@ HELP: last-index-from
{ $description "Outputs the index of the last element in the sequence equal to " { $snippet "obj" } ", traversing the sequence backwards starting from the " { $snippet "i" } "th element and finishing at the first. If no element is found, outputs " { $link f } "." } ;
HELP: member?
{ $values { "obj" object } { "seq" sequence } { "?" "a boolean" } }
{ $description "Tests if the sequence contains an element equal to the object." } ;
{ $values { "elt" object } { "seq" sequence } { "?" "a boolean" } }
{ $description "Tests if the sequence contains an element equal to the object." }
{ $notes "This word uses equality comparison (" { $link = } ")." } ;
HELP: memq?
{ $values { "obj" object } { "seq" sequence } { "?" "a boolean" } }
{ $values { "elt" object } { "seq" sequence } { "?" "a boolean" } }
{ $description "Tests if the sequence contains the object." }
{ $examples
"This word uses identity comparison, so the following will most likely print " { $link f } ":"
{ $example "USING: prettyprint sequences ;" "\"hello\" { \"hello\" } memq? ." "f" }
} ;
{ $notes "This word uses identity comparison (" { $link eq? } ")." } ;
HELP: remove
{ $values { "obj" object } { "seq" sequence } { "newseq" "a new sequence" } }
{ $description "Outputs a new sequence containing all elements of the input sequence except those equal to the given element." } ;
{ $values { "elt" object } { "seq" sequence } { "newseq" "a new sequence" } }
{ $description "Outputs a new sequence containing all elements of the input sequence except for given element." }
{ $notes "This word uses equality comparison (" { $link = } ")." } ;
HELP: remq
{ $values { "elt" object } { "seq" sequence } { "newseq" "a new sequence" } }
{ $description "Outputs a new sequence containing all elements of the input sequence except those equal to the given element." }
{ $notes "This word uses identity comparison (" { $link eq? } ")." } ;
HELP: remove-nth
{ $values
@ -469,6 +478,13 @@ HELP: move
HELP: delete
{ $values { "elt" object } { "seq" "a resizable mutable sequence" } }
{ $description "Removes all elements equal to " { $snippet "elt" } " from " { $snippet "seq" } "." }
{ $notes "This word uses equality comparison (" { $link = } ")." }
{ $side-effects "seq" } ;
HELP: delq
{ $values { "elt" object } { "seq" "a resizable mutable sequence" } }
{ $description "Outputs a new sequence containing all elements of the input sequence except the given element." }
{ $notes "This word uses identity comparison (" { $link eq? } ")." }
{ $side-effects "seq" } ;
HELP: delete-nth
@ -592,7 +608,7 @@ HELP: reverse
{ $values { "seq" sequence } { "newseq" "a new sequence" } }
{ $description "Outputs a new sequence having the same elements as " { $snippet "seq" } " but in reverse order." } ;
{ reverse <reversed> } related-words
{ reverse <reversed> reverse-here } related-words
HELP: <reversed> ( seq -- reversed )
{ $values { "seq" sequence } { "reversed" "a new sequence" } }
@ -784,7 +800,7 @@ HELP: tail?
{ $values { "seq" sequence } { "end" sequence } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "seq" } " ends with " { $snippet "end" } ". If " { $snippet "end" } " is longer than " { $snippet "seq" } ", this word outputs " { $link f } "." } ;
{ delete-nth remove delete } related-words
{ remove remove-nth remq delq delete delete-nth } related-words
HELP: cut-slice
{ $values { "seq" sequence } { "n" "a non-negative integer" } { "before-slice" sequence } { "after-slice" "a slice" } }
@ -982,7 +998,7 @@ HELP: harvest
}
} ;
{ filter sift harvest } related-words
{ filter filter-here sift harvest } related-words
HELP: set-first
{ $values
@ -1315,6 +1331,7 @@ ARTICLE: "sequences-add-remove" "Adding and removing sequence elements"
{ $subsection suffix }
"Removing elements:"
{ $subsection remove }
{ $subsection remq }
{ $subsection remove-nth } ;
ARTICLE: "sequences-reshape" "Reshaping sequences"
@ -1446,29 +1463,49 @@ ARTICLE: "sequences-trimming" "Trimming sequences"
{ $subsection trim-left-slice }
{ $subsection trim-right-slice } ;
ARTICLE: "sequences-destructive-discussion" "When to use destructive operations"
"Constructive (non-destructive) operations should be preferred where possible because code without side-effects is usually more re-usable and easier to reason about. There are two main reasons to use destructive operations:"
{ $list
"For the side-effect. Some code is simpler to express with destructive operations; constructive operations return new objects, and sometimes ``threading'' the objects through the program manually complicates stack shuffling."
{ "As an optimization. Some code can be written to use constructive operations, however would suffer from worse performance. An example is a loop which adds an element to a sequence on each iteration; one could use either " { $link suffix } " or " { $link push } ", however the former copies the entire sequence first, which would cause the loop to run in quadratic time." }
}
"The second reason is much weaker than the first one. In particular, many combinators (see " { $link map } ", " { $link produce } " and " { $link "namespaces-make" } ") as well as more advanced data structures (such as " { $vocab-link "persistent.vectors" } ") alleviate the need for explicit use of side effects." ;
ARTICLE: "sequences-destructive" "Destructive operations"
"These words modify their input, instead of creating a new sequence."
$nl
"In-place variant of " { $link reverse } ":"
{ $subsection reverse-here }
"In-place variant of " { $link append } ":"
{ $subsection push-all }
"In-place variant of " { $link remove } ":"
{ $subsection delete }
"In-place variant of " { $link map } ":"
{ $subsection change-each }
{ $subsection "sequences-destructive-discussion" }
"Changing elements:"
{ $subsection change-each }
{ $subsection change-nth }
{ $subsection cache-nth }
"Deleting elements:"
{ $subsection delete }
{ $subsection delq }
{ $subsection delete-nth }
{ $subsection delete-slice }
{ $subsection delete-all }
{ $subsection filter-here }
"Other destructive words:"
{ $subsection reverse-here }
{ $subsection push-all }
{ $subsection move }
{ $subsection exchange }
{ $subsection copy }
{ $subsection replace-slice }
"Many operations have constructive and destructive variants:"
{ $table
{ "Constructive" "Destructive" }
{ { $link suffix } { $link push } }
{ { $link but-last } { $link pop* } }
{ { $link unclip-last } { $link pop } }
{ { $link remove } { $link delete } }
{ { $link remq } { $link delq } }
{ { $link remove-nth } { $link delete-nth } }
{ { $link reverse } { $link reverse-here } }
{ { $link append } { $link push-all } }
{ { $link map } { $link change-each } }
{ { $link filter } { $link filter-here } }
}
{ $see-also set-nth push pop "sequences-stacks" } ;
ARTICLE: "sequences-stacks" "Treating sequences as stacks"

29
core/sequences/sequences.factor
View File

@ -498,15 +498,18 @@ PRIVATE>
: contains? ( seq quot -- ? )
find drop >boolean ; inline
: member? ( obj seq -- ? )
: member? ( elt seq -- ? )
[ = ] with contains? ;
: memq? ( obj seq -- ? )
: memq? ( elt seq -- ? )
[ eq? ] with contains? ;
: remove ( obj seq -- newseq )
: remove ( elt seq -- newseq )
[ = not ] with filter ;
: remq ( elt seq -- newseq )
[ eq? not ] with filter ;
: sift ( seq -- newseq )
[ ] filter ;
@ -552,16 +555,24 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
<PRIVATE
: (delete) ( elt store scan seq -- elt store scan seq )
: (filter-here) ( quot: ( elt -- ? ) store scan seq -- )
2dup length < [
3dup move
[ nth pick = ] 2keep rot
[ >r >r 1+ r> r> ] unless >r 1+ r> (delete)
] when ;
[ move ] 3keep
[ nth-unsafe pick call [ 1+ ] when ] 2keep
[ 1+ ] dip
(filter-here)
] [ nip set-length drop ] if ; inline recursive
PRIVATE>
: delete ( elt seq -- ) 0 0 rot (delete) nip set-length drop ;
: filter-here ( seq quot -- )
0 0 roll (filter-here) ; inline
: delete ( elt seq -- )
[ = not ] with filter-here ;
: delq ( elt seq -- )
[ eq? not ] with filter-here ;
: prefix ( seq elt -- newseq )
over >r over length 1+ r> [

53
core/system/system-docs.factor
View File

@ -7,7 +7,6 @@ ABOUT: "system"
ARTICLE: "system" "System interface"
{ $subsection "cpu" }
{ $subsection "os" }
{ $subsection "environment-variables" }
"Getting the path to the Factor VM and image:"
{ $subsection vm }
{ $subsection image }
@ -16,15 +15,6 @@ ARTICLE: "system" "System interface"
"Exiting the Factor VM:"
{ $subsection exit } ;
ARTICLE: "environment-variables" "Environment variables"
"Reading environment variables:"
{ $subsection os-env }
{ $subsection os-envs }
"Writing environment variables:"
{ $subsection set-os-env }
{ $subsection unset-os-env }
{ $subsection set-os-envs } ;
ARTICLE: "cpu" "Processor detection"
"Processor detection:"
{ $subsection cpu }
@ -79,49 +69,6 @@ HELP: millis ( -- n )
{ $description "Outputs the number of milliseconds ellapsed since midnight January 1, 1970." }
{ $notes "This is a low-level word. The " { $vocab-link "calendar" } " vocabulary provides features for date/time arithmetic and formatting." } ;
HELP: os-env ( key -- value )
{ $values { "key" string } { "value" string } }
{ $description "Looks up the value of a shell environment variable." }
{ $examples
"This is an operating system-specific feature. On Unix, you can do:"
{ $unchecked-example "\"USER\" os-env print" "jane" }
}
{ $errors "Windows CE has no concept of environment variables, so this word throws an error there." } ;
HELP: os-envs
{ $values { "assoc" "an association mapping strings to strings" } }
{ $description "Outputs the current set of environment variables." }
{ $notes
"Names and values of environment variables are operating system-specific."
}
{ $errors "Windows CE has no concept of environment variables, so this word throws an error there." } ;
HELP: set-os-envs
{ $values { "assoc" "an association mapping strings to strings" } }
{ $description "Replaces the current set of environment variables." }
{ $notes
"Names and values of environment variables are operating system-specific. Windows NT allows values up to 32766 characters in length."
}
{ $errors "Windows CE has no concept of environment variables, so this word throws an error there." } ;
HELP: set-os-env ( value key -- )
{ $values { "value" string } { "key" string } }
{ $description "Set an environment variable." }
{ $notes
"Names and values of environment variables are operating system-specific."
}
{ $errors "Windows CE has no concept of environment variables, so this word throws an error there." } ;
HELP: unset-os-env ( key -- )
{ $values { "key" string } }
{ $description "Unset an environment variable." }
{ $notes
"Names and values of environment variables are operating system-specific."
}
{ $errors "Windows CE has no concept of environment variables, so this word throws an error there." } ;
{ os-env os-envs set-os-env unset-os-env set-os-envs } related-words
HELP: image
{ $values { "path" "a pathname string" } }
{ $description "Outputs the pathname of the currently running Factor image." } ;

27
core/system/system-tests.factor
View File

@ -1,27 +0,0 @@
USING: math tools.test system prettyprint namespaces kernel
strings sequences ;
IN: system.tests
os wince? [
[ ] [ os-envs . ] unit-test
] unless
os unix? [
[ ] [ os-envs "envs" set ] unit-test
[ ] [ { { "A" "B" } } set-os-envs ] unit-test
[ "B" ] [ "A" os-env ] unit-test
[ ] [ "envs" get set-os-envs ] unit-test
[ t ] [ os-envs "envs" get = ] unit-test
] when
[ ] [ "factor-test-key-1" unset-os-env ] unit-test
[ ] [ "ps3" "factor-test-key-1" set-os-env ] unit-test
[ "ps3" ] [ "factor-test-key-1" os-env ] unit-test
[ ] [ "factor-test-key-1" unset-os-env ] unit-test
[ f ] [ "factor-test-key-1" os-env ] unit-test
[ ] [
32766 CHAR: a <string> "factor-test-key-long" set-os-env
] unit-test
[ 32766 ] [ "factor-test-key-long" os-env length ] unit-test
[ ] [ "factor-test-key-long" unset-os-env ] unit-test

6
core/system/system.factor
View File

@ -65,9 +65,3 @@ PRIVATE>
] "system" add-init-hook
: embedded? ( -- ? ) 15 getenv ;
: os-envs ( -- assoc )
(os-envs) [ "=" split1 ] H{ } map>assoc ;
: set-os-envs ( assoc -- )
[ "=" swap 3append ] { } assoc>map (set-os-envs) ;

145
extra/dns/cache/cache.factor vendored
View File

@ -1,145 +0,0 @@
USING: kernel system
combinators
vectors sequences assocs
math math.functions
prettyprint unicode.case
accessors
combinators.cleave
newfx
dns ;
IN: dns.cache
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: cache ( -- table ) H{ } ;
! key: 'name type class' (as string)
! val: entry
TUPLE: entry time data ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: query->key ( query -- key )
{ [ name>> >lower ] [ type>> unparse ] [ class>> unparse ] } <arr> " " join ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: table-get ( query -- result ) query->key cache of ;
: table-check ( query -- ? ) query->key cache key? ;
: table-add ( query value -- ) [ query->key ] [ ] bi* cache at-mutate ;
: table-rem ( query -- ) query->key cache delete-key-of drop ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: now ( -- seconds ) millis 1000.0 / round >integer ;
: ttl->time ( ttl -- seconds ) now + ;
: time->ttl ( time -- ttl ) now - ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: NX
: cache-nx ( query ttl -- ) ttl->time NX entry boa table-add ;
: nx? ( obj -- ? ) dup entry? [ data>> NX = ] [ drop f ] if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: query->rr ( query -- rr ) [ name>> ] [ type>> ] [ class>> ] tri f f rr boa ;
: query+entry->rrs ( query entry -- rrs )
swap ! entry query
query->rr ! entry rr
over ! entry rr entry
time>> time->ttl >>ttl ! entry rr
swap ! rr entry
data>> [ >r dup clone r> >>rdata ] map
nip ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: expired? ( entry -- ? ) time>> time->ttl 0 <= ;
: cache-get* ( query -- rrs/NX/f )
dup table-get ! query result
{
{ [ dup f = ] [ 2drop f ] } ! not in the cache
{ [ dup expired? ] [ drop table-rem f ] } ! here but expired
{ [ dup nx? ] [ 2drop NX ] } ! negative result cached
{ [ t ] [ query+entry->rrs ] } ! good to go
}
cond ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: cache-get ( query -- rrs/f )
dup cache-get* dup NX = [ drop name>> name-error ] [ nip ] if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: rr->entry ( rr -- entry )
[ ttl>> ttl->time ] [ rdata>> {1} >vector ] bi entry boa ;
: maybe-pushed-on ( obj seq -- )
2dup member-of?
[ 2drop ]
[ pushed-on ]
if ;
: add-rr-to-entry ( rr entry -- )
over ttl>> ttl->time >>time
[ rdata>> ] [ data>> ] bi* maybe-pushed-on ;
: cache-add ( query rr -- )
over table-get ! query rr entry
{
{ [ dup f = ] [ drop rr->entry table-add ] }
{ [ dup nx? ] [ drop over table-rem rr->entry table-add ] }
{ [ dup expired? ] [ drop rr->entry table-add ] }
{ [ t ] [ rot drop add-rr-to-entry ] }
}
cond ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: rr->query ( rr -- query ) [ name>> ] [ type>> ] [ class>> ] tri query boa ;
: cache-add-rr ( rr -- ) [ rr->query ] [ ] bi cache-add ;
: cache-add-rrs ( rrs -- ) [ cache-add-rr ] each ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! cache-name-error
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: message-soa ( message -- rr/soa )
authority-section>> [ type>> SOA = ] filter 1st ;
: cache-name-error ( message -- message )
dup
[ message-query ] [ message-soa ttl>> ] bi
cache-nx ;
: cache-message-records ( message -- message )
dup
{
[ answer-section>> cache-add-rrs ]
[ authority-section>> cache-add-rrs ]
[ additional-section>> cache-add-rrs ]
}
cleave ;
: cache-message ( message -- message )
dup rcode>> NAME-ERROR = [ cache-name-error ] when
cache-message-records ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

2
extra/dns/cache/rr/rr.factor vendored
View File

@ -39,7 +39,7 @@ TUPLE: <entry> time data ;
[let | NAME [ OBJ name>> ]
TYPE [ OBJ type>> ]
CLASS [ OBJ class>> ]
TTL [ now ENT time>> - ] |
TTL [ ENT time>> now - ] |
ENT data>>
[| RDATA | T{ rr f NAME TYPE CLASS TTL RDATA } ]
map

180
extra/dns/forwarding/forwarding.factor
View File

@ -1,105 +1,121 @@
USING: combinators.short-circuit kernel
combinators
vectors
sequences
USING: kernel sequences combinators accessors locals random
combinators.short-circuit
io.sockets
accessors
combinators.lib
newfx
dns dns.cache dns.misc ;
dns dns.util dns.cache.rr dns.cache.nx ;
IN: dns.forwarding
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! DNS server - caching, forwarding
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: (socket) ( -- vec ) V{ f } ;
:: query->rrs ( QUERY -- rrs/f )
[let | RRS [ QUERY cache-get ] |
RRS
[ RRS ]
[
[let | NAME [ QUERY name>> ]
TYPE [ QUERY type>> ]
CLASS [ QUERY class>> ] |
[let | RRS/CNAME [ T{ query f NAME CNAME CLASS } cache-get ] |
: socket ( -- socket ) (socket) 1st ;
RRS/CNAME f =
[ f ]
[
[let | RR/CNAME [ RRS/CNAME first ] |
[let | REAL-NAME [ RR/CNAME rdata>> ] |
[let | RRS [
T{ query f REAL-NAME TYPE CLASS } query->rrs
] |
: init-socket-on-port ( port -- )
f swap <inet4> <datagram> 0 (socket) as-mutate ;
RRS
[ RRS/CNAME RRS append ]
[ f ]
if
] ] ]
]
if
] ]
]
if
] ;
: init-socket ( -- ) 53 init-socket-on-port ;
:: answer-from-cache ( MSG -- msg/f )
[let | QUERY [ MSG message-query ] |
[let | NX [ QUERY name>> non-existent-name? ]
RRS [ QUERY query->rrs ] |
{
{ [ NX ] [ MSG NAME-ERROR >>rcode ] }
{ [ RRS ] [ MSG RRS >>answer-section ] }
{ [ t ] [ f ] }
}
cond
]
] ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: (upstream-server) ( -- vec ) V{ f } ;
: message-soa ( message -- rr/soa )
authority-section>> [ type>> SOA = ] filter first ;
: upstream-server ( -- ip ) (upstream-server) 1st ;
! :: cache-message ( MSG -- msg )
! MSG rcode>> NAME-ERROR =
! [
! [let | NAME [ MSG message-query name>> ]
! TTL [ MSG message-soa ttl>> ] |
! NAME TTL cache-non-existent-name
! ]
! ]
! when
! MSG answer-section>> [ cache-add ] each
! MSG authority-section>> [ cache-add ] each
! MSG additional-section>> [ cache-add ] each
! MSG ;
: set-upstream-server ( ip -- ) 0 (upstream-server) as-mutate ;
:: cache-message ( MSG -- msg )
MSG rcode>> NAME-ERROR =
[
[let | RR/SOA [ MSG
authority-section>>
[ type>> SOA = ] filter
dup empty? [ drop f ] [ first ] if ] |
RR/SOA
[
[let | NAME [ MSG message-query name>> ]
TTL [ MSG message-soa ttl>> ] |
NAME TTL cache-non-existent-name
]
]
when
]
]
when
MSG answer-section>> [ cache-add ] each
MSG authority-section>> [ cache-add ] each
MSG additional-section>> [ cache-add ] each
MSG ;
: init-upstream-server ( -- )
upstream-server not
[ resolv-conf-server set-upstream-server ]
when ;
: answer-from-server ( msg servers -- msg ) random ask-server cache-message ;
:: find-answer ( MSG SERVERS -- msg )
{ [ MSG answer-from-cache ] [ MSG SERVERS answer-from-server ] } 0|| ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: rrs? ( obj -- ? ) { [ NX = not ] [ f = not ] } 1&& ;
:: start-server ( ADDR-SPEC SERVERS -- )
[let | SOCKET [ ADDR-SPEC <datagram> ] |
: query->answer/cache ( query -- rrs/NX/f )
dup cache-get* dup { [ rrs? ] [ NX = ] } 1||
[ nip ]
[
drop
dup clone CNAME >>type cache-get* dup { [ NX = ] [ f = ] } 1||
[ nip ]
[ ! query rrs
tuck ! rrs query rrs
1st ! rrs query rr/cname
rdata>> ! rrs query name
>r clone r> >>name ! rrs query
query->answer/cache ! rrs rrs/NX/f
dup rrs? [ append ] [ nip ] if
]
if
SOCKET receive-packet
[ parse-message SERVERS find-answer message->ba ]
change-data
respond
]
if ;
forever
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: answer-from-cache ( message -- message/f )
dup message-query ! message query
dup query->answer/cache ! message query rrs/NX/f
{
{ [ dup f = ] [ 3drop f ] }
{ [ dup NX = ] [ 2drop NAME-ERROR >>rcode ] }
{ [ t ] [ nip >>answer-section ] }
}
cond ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: answer-from-server ( message -- message )
upstream-server ask-server
cache-message ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: find-answer ( message -- message )
dup answer-from-cache dup
[ nip ]
[ drop answer-from-server ]
if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: loop ( -- )
socket receive ! byte-array addr-spec
swap ! addr-spec byte-array
parse-message ! addr-spec message
find-answer ! addr-spec message
message->ba ! addr-spec byte-array
swap ! byte-array addr-spec
socket send
loop ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: start ( -- ) init-socket init-upstream-server loop ;
MAIN: start
] ;

185
extra/dns/recursive/recursive.factor
View File

@ -1,185 +0,0 @@
USING: kernel continuations
combinators
sequences
math
random
unicode.case
accessors symbols
combinators.lib combinators.cleave
newfx
dns dns.cache ;
IN: dns.recursive
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: root-dns-servers ( -- servers )
{
"192.5.5.241"
"192.112.36.4"
"128.63.2.53"
"192.36.148.17"
"192.58.128.30"
"193.0.14.129"
"199.7.83.42"
"202.12.27.33"
"198.41.0.4"
} ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: {name-type-class} ( obj -- seq )
[ name>> >lower ] [ type>> ] [ class>> ] tri {3} ;
: rr=query? ( rr query -- ? ) [ {name-type-class} ] bi@ = ;
: rr-filter ( rrs query -- rrs ) [ rr=query? ] curry filter ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: answer-hits ( message -- rrs )
[ answer-section>> ] [ message-query ] bi rr-filter ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: name-hits ( message -- rrs )
[ answer-section>> ] [ message-query clone A >>type ] bi rr-filter ;
: cname-hits ( message -- rrs )
[ answer-section>> ] [ message-query clone CNAME >>type ] bi rr-filter ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: authority-hits ( message -- rrs )
authority-section>> [ type>> NS = ] filter ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOLS: ANSWERED NO-NAME-SERVERS UNCLASSIFIED ;
: classify-message ( message -- symbol )
{
{ [ dup rcode>> NAME-ERROR = ] [ drop NAME-ERROR ] }
{ [ dup rcode>> SERVER-FAILURE = ] [ drop SERVER-FAILURE ] }
{ [ dup answer-hits empty? not ] [ drop ANSWERED ] }
{ [ dup cname-hits empty? not ] [ drop CNAME ] }
{ [ dup authority-hits empty? ] [ drop NO-NAME-SERVERS ] }
{ [ t ] [ drop UNCLASSIFIED ] }
}
cond ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
DEFER: name->ip
! : name->ip/f ( name -- ip/f ) [ name->ip ] [ drop f ] recover ;
! : extract-ns-ips ( message -- ips )
! authority-hits [ rdata>> name->ip/f ] map [ ] filter ;
: extract-ns-ips ( message -- ips )
authority-hits [ rdata>> name->ip ] map [ ] filter ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: (recursive-query) ( query servers -- message )
dup random ! query servers server
pick query->message 0 >>rd ! query servers server message
over ask-server ! query servers server message
cache-message ! query servers server message
dup classify-message ! query servers server message sym
{
{ NAME-ERROR [ -roll 3drop ] }
{ ANSWERED [ -roll 3drop ] }
{ CNAME [ -roll 3drop ] }
{ NO-NAME-SERVERS [ -roll 3drop ] }
{
SERVER-FAILURE
[
-roll ! message query servers server
remove ! message query servers
dup empty?
[ 2drop ]
[ rot drop (recursive-query) ]
if
]
}
[ ! query servers server message sym
drop nip nip ! query message
extract-ns-ips ! query ips
(recursive-query)
]
}
case ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: cdr-name ( name -- name ) dup CHAR: . index 1+ tail ;
: cache-get-ns ( name -- seq/f ) NS IN query boa cache-get ;
: name->servers ( name -- servers )
{
{ [ dup "" = ] [ drop root-dns-servers ] }
{ [ dup cache-get-ns ] [ cache-get-ns [ rdata>> name->ip ] map ] }
{ [ t ] [ cdr-name name->servers ] }
}
cond ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: recursive-query ( query -- message )
dup name>> name->servers (recursive-query) ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: canonical/cache ( name -- name )
dup CNAME IN query boa cache-get dup [ nip 1st rdata>> ] [ drop ] if ;
: name->ip/cache ( name -- ip/f )
canonical/cache
A IN query boa cache-get dup [ random rdata>> ] [ ] if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: name-hits? ( message -- message ? ) dup name-hits empty? not ;
: cname-hits? ( message -- message ? ) dup cname-hits empty? not ;
! : name->ip/server ( name -- ip-or-f )
! A IN query boa root-dns-servers recursive-query ! message
! {
! { [ name-hits? ] [ name-hits random rdata>> ] }
! { [ cname-hits? ] [ cname-hits random rdata>> name->ip ] }
! { [ t ] [ drop f ] }
! }
! cond ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: name->ip/server ( name -- ip-or-f )
A IN query boa recursive-query ! message
{
{ [ name-hits? ] [ name-hits random rdata>> ] }
{ [ cname-hits? ] [ cname-hits random rdata>> name->ip ] }
{ [ t ] [ drop f ] }
}
cond ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! : name->ip ( name -- ip )
! { [ name->ip/cache ] [ name->ip/server ] [ name-error ] } 1|| ;
: name->ip ( name -- ip )
dup name->ip/cache dup
[ nip ]
[
drop dup name->ip/server dup
[ nip ]
[ drop name-error ]
if
]
if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

49
extra/dns/resolver/resolver.factor
View File

@ -1,49 +0,0 @@
USING: kernel vectors sequences combinators random
accessors newfx dns dns.cache ;
IN: dns.resolver
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: canonical/cache ( name -- name )
dup CNAME IN query boa cache-get dup vector? ! name result ?
[ nip 1st rdata>> ]
[ drop ]
if ;
: name->ip/cache ( name -- ip )
canonical/cache
dup A IN query boa cache-get ! name result
{
{ [ dup NX = ] [ 2drop f ] }
{ [ dup f = ] [ 2drop f ] }
{ [ t ] [ nip random rdata>> ] }
}
cond ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: canonical/server ( name -- name )
dup CNAME IN query boa query->message ask cache-message answer-section>>
[ type>> CNAME = ] filter dup empty? not
[ nip 1st rdata>> ]
[ drop ]
if ;
: name->ip/server ( name -- ip )
canonical/server
dup A IN query boa query->message ask cache-message answer-section>>
[ type>> A = ] filter dup empty? not
[ nip random rdata>> ]
[ 2drop f ]
if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: name->ip ( name -- ip )
fully-qualified
dup name->ip/cache dup
[ nip ]
[ drop name->ip/server ]
if ;

3
extra/dns/util/util.factor
View File

@ -28,3 +28,6 @@ TUPLE: packet data addr socket ;
: respond ( packet -- ) [ data>> ] [ addr>> ] [ socket>> ] tri send ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: forever ( quot -- ) [ call ] [ forever ] bi ; inline recursive

2
extra/ftp/ftp.factor
View File

@ -59,5 +59,5 @@ TUPLE: ftp-response n strings parsed ;
3array " " join ;
: directory-list ( -- seq )
"" directory keys
"" directory-files
[ [ link-info ] keep file-info>string ] map ;

1
extra/hardware-info/windows/ce/tags.txt Normal file
View File

@ -0,0 +1 @@
unportable

1
extra/hardware-info/windows/nt/tags.txt Normal file
View File

@ -0,0 +1 @@
unportable

93
extra/html/parser/analyzer/analyzer.factor
View File

@ -3,7 +3,7 @@
USING: assocs html.parser kernel math sequences strings ascii
arrays generalizations shuffle unicode.case namespaces make
splitting http accessors io combinators http.client urls
urls.encoding fry ;
urls.encoding fry prettyprint ;
IN: html.parser.analyzer
TUPLE: link attributes clickable ;
@ -19,35 +19,34 @@ TUPLE: link attributes clickable ;
'[ _ [ second @ ] find-from rot drop swap 1+ ]
[ f 0 ] 2dip times drop first2 ; inline
: find-first-name ( str vector -- i/f tag/f )
[ >lower ] dip [ name>> = ] with find ; inline
: find-first-name ( vector string -- i/f tag/f )
>lower '[ name>> _ = ] find ; inline
: find-matching-close ( str vector -- i/f tag/f )
[ >lower ] dip
[ [ name>> = ] [ closing?>> ] bi and ] with find ; inline
: find-matching-close ( vector string -- i/f tag/f )
>lower
'[ [ name>> _ = ] [ closing?>> ] bi and ] find ; inline
: find-between* ( i/f tag/f vector -- vector )
pick integer? [
rot tail-slice
>r name>> r>
[ find-matching-close drop dup [ 1+ ] when ] keep
swap [ head ] [ first ] if*
: find-between* ( vector i/f tag/f -- vector )
over integer? [
[ tail-slice ] [ name>> ] bi*
dupd find-matching-close drop dup [ 1+ ] when
[ head ] [ first ] if*
] [
3drop V{ } clone
] if ; inline
: find-between ( i/f tag/f vector -- vector )
: find-between ( vector i/f tag/f -- vector )
find-between* dup length 3 >= [
[ rest-slice but-last-slice ] keep like
] when ; inline
: find-between-first ( string vector -- vector' )
[ find-first-name ] keep find-between ; inline
: find-between-first ( vector string -- vector' )
dupd find-first-name find-between ; inline
: find-between-all ( vector quot -- seq )
[ [ [ closing?>> not ] bi and ] curry find-all ] curry
[ [ >r first2 r> find-between* ] curry map ] bi ; inline
dupd
'[ _ [ closing?>> not ] bi and ] find-all
[ first2 find-between* ] with map ;
: remove-blank-text ( vector -- vector' )
[
@ -61,27 +60,40 @@ TUPLE: link attributes clickable ;
[ [ [ blank? ] trim ] change-text ] when
] map ;
: find-by-id ( id vector -- vector )
[ attributes>> "id" swap at = ] with filter ;
: find-by-id ( vector id -- vector' )
'[ attributes>> "id" at _ = ] find ;
: find-by-class ( vector id -- vector' )
'[ attributes>> "class" at _ = ] find ;
: find-by-class ( id vector -- vector )
[ attributes>> "class" swap at = ] with filter ;
: find-by-name ( vector string -- vector )
>lower '[ name>> _ = ] find ;
: find-by-name ( str vector -- vector )
[ >lower ] dip [ name>> = ] with filter ;
: find-by-id-between ( vector string -- vector' )
dupd
'[ attributes>> "id" swap at _ = ] find find-between* ;
: find-by-class-between ( vector string -- vector' )
dupd
'[ attributes>> "class" swap at _ = ] find find-between* ;
: find-by-class-id-between ( vector class id -- vector' )
'[
[ attributes>> "class" swap at _ = ]
[ attributes>> "id" swap at _ = ] bi and
] dupd find find-between* ;
: find-by-attribute-key ( key vector -- vector )
[ >lower ] dip
[ attributes>> at ] with filter
sift ;
: find-by-attribute-key ( vector key -- vector' )
>lower
[ attributes>> at _ = ] filter sift ;
: find-by-attribute-key-value ( value key vector -- vector )
[ >lower ] dip
: find-by-attribute-key-value ( vector value key -- vector' )
>lower
[ attributes>> at over = ] with filter nip
sift ;
: find-first-attribute-key-value ( value key vector -- i/f tag/f )
[ >lower ] dip
: find-first-attribute-key-value ( vector value key -- i/f tag/f )
>lower
[ attributes>> at over = ] with find rot drop ;
: tag-link ( tag -- link/f )
@ -121,9 +133,9 @@ TUPLE: link attributes clickable ;
swap [ >r first2 r> find-between* ] curry map
[ [ name>> { "form" "input" } member? ] filter ] map ;
: find-html-objects ( string vector -- vector' )
[ find-opening-tags-by-name ] keep
[ [ first2 ] dip find-between* ] curry map ;
: find-html-objects ( vector string -- vector' )
dupd find-opening-tags-by-name
[ first2 find-between* ] curry map ;
: form-action ( vector -- string )
[ name>> "form" = ] find nip
@ -150,3 +162,12 @@ TUPLE: link attributes clickable ;
: query>assoc* ( str -- hash )
"?" split1 nip query>assoc ;
: html-class? ( tag string -- ? )
swap attributes>> "class" swap at = ;
: html-id? ( tag string -- ? )
swap attributes>> "id" swap at = ;
: opening-tag? ( tag -- ? )
closing?>> not ;

4
extra/io/paths/paths.factor
View File

@ -7,7 +7,7 @@ IN: io.paths
TUPLE: directory-iterator path bfs queue ;
: qualified-directory ( path -- seq )
dup directory [ first2 [ append-path ] dip 2array ] with map ;
dup directory-files [ append-path ] with map ;
: push-directory ( path iter -- )
[ qualified-directory ] dip [
@ -21,7 +21,7 @@ TUPLE: directory-iterator path bfs queue ;
: next-file ( iter -- file/f )
dup queue>> deque-empty? [ drop f ] [
dup queue>> pop-back first2
dup queue>> pop-back dup link-info directory?
[ over push-directory next-file ] [ nip ] if
] if ;

18
extra/sequences/lib/lib.factor
View File

@ -4,7 +4,8 @@
USING: combinators.lib kernel sequences math namespaces make
assocs random sequences.private shuffle math.functions arrays
math.parser math.private sorting strings ascii macros assocs.lib
quotations hashtables math.order locals generalizations ;
quotations hashtables math.order locals generalizations
math.ranges random ;
IN: sequences.lib
: each-withn ( seq quot n -- ) nwith each ; inline
@ -131,11 +132,6 @@ PRIVATE>
: power-set ( seq -- subsets )
2 over length exact-number-strings swap [ switches ] curry map ;
USE: continuations
: ?subseq ( from to seq -- subseq )
>r >r 0 max r> r>
[ length tuck min >r min r> ] keep subseq ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
<PRIVATE
@ -149,18 +145,10 @@ PRIVATE>
: attempt-each ( seq quot -- result )
(each) iterate-prep (attempt-each-integer) ; inline
: ?nth* ( n seq -- elt/f ? )
2dup bounds-check? [ nth-unsafe t ] [ 2drop f f ] if ; flushable
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
USE: math.ranges
USE: random
: randomize ( seq -- seq' )
dup length 1 (a,b] [ dup random pick exchange ] each ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: enumerate ( seq -- seq' )
<enum> >alist ;
: enumerate ( seq -- seq' ) <enum> >alist ;

6
extra/shell/shell.factor
View File

@ -3,7 +3,7 @@ USING: kernel parser words continuations namespaces debugger
sequences combinators splitting prettyprint
system io io.files io.launcher io.encodings.utf8 io.pipes sequences.deep
accessors multi-methods newfx shell.parser
combinators.short-circuit eval ;
combinators.short-circuit eval environment ;
IN: shell
@ -39,7 +39,7 @@ METHOD: expand { variable-expr } expr>> os-env ;
METHOD: expand { glob-expr }
expr>>
dup "*" =
[ drop current-directory get directory [ first ] map ]
[ drop current-directory get directory-files ]
[ ]
if ;
@ -139,4 +139,4 @@ DEFER: shell
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
MAIN: ix
MAIN: ix

25
extra/webapps/wiki/wiki.factor
View File

@ -374,15 +374,16 @@ M: revision feed-entry-url id>> revision-url ;
{ wiki "wiki-common" } >>template ;
: init-wiki ( -- )
"resource:extra/webapps/wiki/initial-content" directory* keys
[
dup file-name ".txt" ?tail [
swap ascii file-contents
f <revision>
swap >>content
swap >>title
"slava" >>author
now >>date
add-revision
] [ 2drop ] if
] each ;
"resource:extra/webapps/wiki/initial-content" [
[
dup ".txt" ?tail [
swap ascii file-contents
f <revision>
swap >>content
swap >>title
"slava" >>author
now >>date
add-revision
] [ 2drop ] if
] each
] with-directory-files ;

7
vm/os-freebsd.h
View File

@ -7,10 +7,3 @@ extern int getosreldate(void);
#ifndef KERN_PROC_PATHNAME
#define KERN_PROC_PATHNAME 12
#endif
#define UNKNOWN_TYPE_P(file) ((file)->d_type == DT_UNKNOWN)
#define DIRECTORY_P(file) ((file)->d_type == DT_DIR)
#ifndef environ
extern char **environ;
#endif

7
vm/os-linux.h
View File

@ -1,12 +1,5 @@
#include <sys/syscall.h>
#define UNKNOWN_TYPE_P(file) ((file)->d_type == DT_UNKNOWN)
#define DIRECTORY_P(file) ((file)->d_type == DT_DIR)
#ifndef environ
extern char **environ;
#endif
int inotify_init(void);
int inotify_add_watch(int fd, const char *name, u32 mask);
int inotify_rm_watch(int fd, u32 wd);

7
vm/os-macosx.h
View File

@ -1,8 +1,6 @@
#define DLLEXPORT __attribute__((visibility("default")))
#define FACTOR_OS_STRING "macosx"
#define NULL_DLL "libfactor.dylib"
#define UNKNOWN_TYPE_P(file) ((file)->d_type == DT_UNKNOWN)
#define DIRECTORY_P(file) ((file)->d_type == DT_DIR)
void init_signals(void);
void early_init(void);
@ -12,11 +10,6 @@ const char *default_image_path(void);
DLLEXPORT void c_to_factor_toplevel(CELL quot);
#ifndef environ
extern char ***_NSGetEnviron(void);
#define environ (*_NSGetEnviron())
#endif
INLINE void *ucontext_stack_pointer(void *uap)
{
ucontext_t *ucontext = (ucontext_t *)uap;

2
vm/os-netbsd.h
View File

@ -4,5 +4,3 @@
#define UNKNOWN_TYPE_P(file) ((file)->d_type == DT_UNKNOWN)
#define DIRECTORY_P(file) ((file)->d_type == DT_DIR)
extern char **environ;

6
vm/os-openbsd.h
View File

@ -1,6 +0,0 @@
#define UNKNOWN_TYPE_P(file) ((file)->d_type == DT_UNKNOWN)
#define DIRECTORY_P(file) ((file)->d_type == DT_DIR)
#ifndef environ
extern char **environ;
#endif

4
vm/os-solaris.h
View File

@ -1,4 +0,0 @@
#define UNKNOWN_TYPE_P(file) 1
#define DIRECTORY_P(file) 0
extern char **environ;

104
vm/os-unix.c
View File

@ -61,110 +61,6 @@ DEFINE_PRIMITIVE(existsp)
box_boolean(stat(unbox_char_string(),&sb) >= 0);
}
/* Allocates memory */
CELL parse_dir_entry(struct dirent *file)
{
CELL name = tag_object(from_char_string(file->d_name));
if(UNKNOWN_TYPE_P(file))
return name;
else
{
CELL dirp = tag_boolean(DIRECTORY_P(file));
return allot_array_2(name,dirp);
}
}
DEFINE_PRIMITIVE(read_dir)
{
DIR* dir = opendir(unbox_char_string());
GROWABLE_ARRAY(result);
REGISTER_ROOT(result);
if(dir != NULL)
{
struct dirent* file;
while((file = readdir(dir)) != NULL)
{
CELL pair = parse_dir_entry(file);
GROWABLE_ARRAY_ADD(result,pair);
}
closedir(dir);
}
UNREGISTER_ROOT(result);
GROWABLE_ARRAY_TRIM(result);
dpush(result);
}
DEFINE_PRIMITIVE(os_env)
{
char *name = unbox_char_string();
char *value = getenv(name);
if(value == NULL)
dpush(F);
else
box_char_string(value);
}
DEFINE_PRIMITIVE(os_envs)
{
GROWABLE_ARRAY(result);
REGISTER_ROOT(result);
char **env = environ;
while(*env)
{
CELL string = tag_object(from_char_string(*env));
GROWABLE_ARRAY_ADD(result,string);
env++;
}
UNREGISTER_ROOT(result);
GROWABLE_ARRAY_TRIM(result);
dpush(result);
}
DEFINE_PRIMITIVE(set_os_env)
{
char *key = unbox_char_string();
REGISTER_C_STRING(key);
char *value = unbox_char_string();
UNREGISTER_C_STRING(key);
setenv(key, value, 1);
}
DEFINE_PRIMITIVE(unset_os_env)
{
char *key = unbox_char_string();
unsetenv(key);
}
DEFINE_PRIMITIVE(set_os_envs)
{
F_ARRAY *array = untag_array(dpop());
CELL size = array_capacity(array);
/* Memory leak */
char **env = calloc(size + 1,sizeof(CELL));
CELL i;
for(i = 0; i < size; i++)
{
F_STRING *string = untag_string(array_nth(array,i));
CELL length = to_fixnum(string->length);
char *chars = malloc(length + 1);
char_string_to_memory(string,chars);
chars[length] = '\0';
env[i] = chars;
}
environ = env;
}
F_SEGMENT *alloc_segment(CELL size)
{
int pagesize = getpagesize();

29
vm/os-windows-nt.c
View File

@ -8,35 +8,6 @@ s64 current_millis(void)
- EPOCH_OFFSET) / 10000;
}
DEFINE_PRIMITIVE(os_envs)
{
GROWABLE_ARRAY(result);
REGISTER_ROOT(result);
TCHAR *env = GetEnvironmentStrings();
TCHAR *finger = env;
for(;;)
{
TCHAR *scan = finger;
while(*scan != '\0')
scan++;
if(scan == finger)
break;
CELL string = tag_object(from_u16_string(finger));
GROWABLE_ARRAY_ADD(result,string);
finger = scan + 1;
}
FreeEnvironmentStrings(env);
UNREGISTER_ROOT(result);
GROWABLE_ARRAY_TRIM(result);
dpush(result);
}
long exception_handler(PEXCEPTION_POINTERS pe)
{
PEXCEPTION_RECORD e = (PEXCEPTION_RECORD)pe->ExceptionRecord;

78
vm/os-windows.c
View File

@ -87,21 +87,6 @@ const F_CHAR *vm_executable_path(void)
return safe_strdup(full_path);
}
void find_file_stat(F_CHAR *path)
{
// FindFirstFile is the only call that can stat c:\pagefile.sys
WIN32_FIND_DATA st;
HANDLE h;
if(INVALID_HANDLE_VALUE == (h = FindFirstFile(path, &st)))
dpush(F);
else
{
FindClose(h);
dpush(T);
}
}
DEFINE_PRIMITIVE(existsp)
{
BY_HANDLE_FILE_INFORMATION bhfi;
@ -136,34 +121,6 @@ DEFINE_PRIMITIVE(existsp)
CloseHandle(h);
}
DEFINE_PRIMITIVE(read_dir)
{
HANDLE dir;
WIN32_FIND_DATA find_data;
F_CHAR *path = unbox_u16_string();
GROWABLE_ARRAY(result);
REGISTER_ROOT(result);
if(INVALID_HANDLE_VALUE != (dir = FindFirstFile(path, &find_data)))
{
do
{
CELL name = tag_object(from_u16_string(find_data.cFileName));
CELL dirp = tag_boolean(find_data.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY);
CELL pair = allot_array_2(name,dirp);
GROWABLE_ARRAY_ADD(result,pair);
}
while (FindNextFile(dir, &find_data));
FindClose(dir);
}
UNREGISTER_ROOT(result);
GROWABLE_ARRAY_TRIM(result);
dpush(result);
}
F_SEGMENT *alloc_segment(CELL size)
{
char *mem;
@ -214,38 +171,3 @@ void sleep_millis(DWORD msec)
{
Sleep(msec);
}
DEFINE_PRIMITIVE(os_env)
{
F_CHAR *key = unbox_u16_string();
F_CHAR *value = safe_malloc(MAX_UNICODE_PATH * 2);
int ret;
ret = GetEnvironmentVariable(key, value, MAX_UNICODE_PATH * 2);
if(ret == 0)
dpush(F);
else
dpush(tag_object(from_u16_string(value)));
free(value);
}
DEFINE_PRIMITIVE(set_os_env)
{
F_CHAR *key = unbox_u16_string();
REGISTER_C_STRING(key);
F_CHAR *value = unbox_u16_string();
UNREGISTER_C_STRING(key);
if(!SetEnvironmentVariable(key, value))
general_error(ERROR_IO, tag_object(get_error_message()), F, NULL);
}
DEFINE_PRIMITIVE(unset_os_env)
{
if(!SetEnvironmentVariable(unbox_u16_string(), NULL)
&& GetLastError() != ERROR_ENVVAR_NOT_FOUND)
general_error(ERROR_IO, tag_object(get_error_message()), F, NULL);
}
DEFINE_PRIMITIVE(set_os_envs)
{
not_implemented_error();
}

2
vm/platform.h
View File

@ -55,7 +55,6 @@
#endif
#elif defined(__OpenBSD__)
#define FACTOR_OS_STRING "openbsd"
#include "os-openbsd.h"
#if defined(FACTOR_X86)
#include "os-openbsd-x86.32.h"
@ -102,7 +101,6 @@
#error "Unsupported Solaris flavor"
#endif
#include "os-solaris.h"
#else
#error "Unsupported OS"
#endif

6
vm/primitives.c
View File

@ -57,7 +57,6 @@ void *primitives[] = {
primitive_getenv,
primitive_setenv,
primitive_existsp,
primitive_read_dir,
primitive_gc,
primitive_gc_stats,
primitive_save_image,
@ -71,7 +70,6 @@ void *primitives[] = {
primitive_exit,
primitive_data_room,
primitive_code_room,
primitive_os_env,
primitive_millis,
primitive_modify_code_heap,
primitive_dlopen,
@ -141,10 +139,6 @@ void *primitives[] = {
primitive_innermost_stack_frame_scan,
primitive_set_innermost_stack_frame_quot,
primitive_call_clear,
primitive_os_envs,
primitive_set_os_env,
primitive_unset_os_env,
primitive_set_os_envs,
primitive_resize_byte_array,
primitive_dll_validp,
primitive_unimplemented,