diff --git a/basis/calendar/unix/unix.factor b/basis/calendar/unix/unix.factor index d5b66ffc1a..9848d0c164 100644 --- a/basis/calendar/unix/unix.factor +++ b/basis/calendar/unix/unix.factor @@ -4,13 +4,19 @@ USING: alien alien.c-types alien.syntax arrays calendar kernel math unix unix.time namespaces system ; IN: calendar.unix -: timeval>unix-time ( timeval -- timestamp ) +: timeval>seconds ( timeval -- seconds ) [ timeval-sec seconds ] [ timeval-usec microseconds ] bi - time+ since-1970 ; + time+ ; -: timespec>unix-time ( timeval -- timestamp ) +: timeval>unix-time ( timeval -- timestamp ) + timeval>seconds since-1970 ; + +: timespec>seconds ( timespec -- seconds ) [ timespec-sec seconds ] [ timespec-nsec nanoseconds ] bi - time+ since-1970 ; + time+ ; + +: timespec>unix-time ( timespec -- timestamp ) + timespec>seconds since-1970 ; : get-time ( -- alien ) f time localtime ; diff --git a/basis/cpu/x86/assembler/assembler-tests.factor b/basis/cpu/x86/assembler/assembler-tests.factor index 941bbe5b73..915847a453 100644 --- a/basis/cpu/x86/assembler/assembler-tests.factor +++ b/basis/cpu/x86/assembler/assembler-tests.factor @@ -4,9 +4,9 @@ IN: cpu.x86.assembler.tests [ { HEX: 49 HEX: 89 HEX: 04 HEX: 24 } ] [ [ R12 [] RAX MOV ] { } make ] unit-test [ { HEX: 49 HEX: 8b HEX: 06 } ] [ [ RAX R14 [] MOV ] { } make ] unit-test -! [ { HEX: 89 HEX: ca } ] [ [ EDX ECX MOV ] { } make ] unit-test -! [ { HEX: 4c HEX: 89 HEX: e2 } ] [ [ RDX R12 MOV ] { } make ] unit-test -! [ { HEX: 49 HEX: 89 HEX: d4 } ] [ [ R12 RDX MOV ] { } make ] unit-test +[ { HEX: 89 HEX: ca } ] [ [ EDX ECX MOV ] { } make ] unit-test +[ { HEX: 4c HEX: 89 HEX: e2 } ] [ [ RDX R12 MOV ] { } make ] unit-test +[ { HEX: 49 HEX: 89 HEX: d4 } ] [ [ R12 RDX MOV ] { } make ] unit-test [ { HEX: f2 HEX: 0f HEX: 2c HEX: c0 } ] [ [ EAX XMM0 CVTTSD2SI ] { } make ] unit-test [ { HEX: f2 HEX: 48 HEX: 0f HEX: 2c HEX: c0 } ] [ [ RAX XMM0 CVTTSD2SI ] { } make ] unit-test @@ -39,3 +39,21 @@ IN: cpu.x86.assembler.tests [ { HEX: 80 HEX: 08 HEX: 05 } ] [ [ EAX [] 5 OR ] { } make ] unit-test [ { HEX: c6 HEX: 00 HEX: 05 } ] [ [ EAX [] 5 MOV ] { } make ] unit-test + +[ { HEX: 49 HEX: 89 HEX: 04 HEX: 1a } ] [ [ R10 RBX [+] RAX MOV ] { } make ] unit-test +[ { HEX: 49 HEX: 89 HEX: 04 HEX: 1b } ] [ [ R11 RBX [+] RAX MOV ] { } make ] unit-test + +[ { HEX: 49 HEX: 89 HEX: 04 HEX: 1c } ] [ [ R12 RBX [+] RAX MOV ] { } make ] unit-test +[ { HEX: 48 HEX: 89 HEX: 04 HEX: 1c } ] [ [ RSP RBX [+] RAX MOV ] { } make ] unit-test + +[ { HEX: 49 HEX: 89 HEX: 44 HEX: 1d HEX: 00 } ] [ [ R13 RBX [+] RAX MOV ] { } make ] unit-test +[ { HEX: 48 HEX: 89 HEX: 44 HEX: 1d HEX: 00 } ] [ [ RBP RBX [+] RAX MOV ] { } make ] unit-test + +[ { HEX: 4a HEX: 89 HEX: 04 HEX: 23 } ] [ [ RBX R12 [+] RAX MOV ] { } make ] unit-test +[ { HEX: 4a HEX: 89 HEX: 04 HEX: 2b } ] [ [ RBX R13 [+] RAX MOV ] { } make ] unit-test + +[ { HEX: 4b HEX: 89 HEX: 44 HEX: 25 HEX: 00 } ] [ [ R13 R12 [+] RAX MOV ] { } make ] unit-test +[ { HEX: 4b HEX: 89 HEX: 04 HEX: 2c } ] [ [ R12 R13 [+] RAX MOV ] { } make ] unit-test + +[ { HEX: 49 HEX: 89 HEX: 04 HEX: 2c } ] [ [ R12 RBP [+] RAX MOV ] { } make ] unit-test +[ [ R12 RSP [+] RAX MOV ] { } make ] must-fail diff --git a/basis/cpu/x86/assembler/assembler.factor b/basis/cpu/x86/assembler/assembler.factor index f557bb4adc..8cb0d620af 100644 --- a/basis/cpu/x86/assembler/assembler.factor +++ b/basis/cpu/x86/assembler/assembler.factor @@ -64,18 +64,18 @@ M: indirect extended? base>> extended? ; : canonicalize-EBP ( indirect -- indirect ) #! { EBP } ==> { EBP 0 } - dup base>> { EBP RBP R13 } member? [ - dup displacement>> [ 0 >>displacement ] unless - ] when ; + dup [ base>> { EBP RBP R13 } member? ] [ displacement>> not ] bi and + [ 0 >>displacement ] when ; -: canonicalize-ESP ( indirect -- indirect ) - #! { ESP } ==> { ESP ESP } - dup base>> { ESP RSP R12 } member? [ ESP >>index ] when ; +ERROR: bad-index indirect ; + +: check-ESP ( indirect -- indirect ) + dup index>> { ESP RSP } memq? [ bad-index ] when ; : canonicalize ( indirect -- indirect ) #! Modify the indirect to work around certain addressing mode #! quirks. - canonicalize-EBP canonicalize-ESP ; + canonicalize-EBP check-ESP ; : ( base index scale displacement -- indirect ) indirect boa canonicalize ; @@ -91,7 +91,7 @@ M: indirect extended? base>> extended? ; GENERIC: sib-present? ( op -- ? ) M: indirect sib-present? - [ base>> { ESP RSP } member? ] [ index>> ] [ scale>> ] tri or or ; + [ base>> { ESP RSP R12 } member? ] [ index>> ] [ scale>> ] tri or or ; M: register sib-present? drop f ; @@ -254,7 +254,8 @@ M: object operand-64? drop f ; reg-code swap addressing ; : direction-bit ( dst src op -- dst' src' op' ) - pick register? [ BIN: 10 opcode-or swapd ] when ; + pick register? pick register? not and + [ BIN: 10 opcode-or swapd ] when ; : operand-size-bit ( dst src op -- dst' src' op' ) over register-8? [ BIN: 1 opcode-or ] unless ; diff --git a/basis/debugger/debugger-docs.factor b/basis/debugger/debugger-docs.factor index f8897712e7..fe00d011c3 100644 --- a/basis/debugger/debugger-docs.factor +++ b/basis/debugger/debugger-docs.factor @@ -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." } ; diff --git a/basis/environment/authors.txt b/basis/environment/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/environment/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/environment/environment-docs.factor b/basis/environment/environment-docs.factor new file mode 100644 index 0000000000..e539b446f3 --- /dev/null +++ b/basis/environment/environment-docs.factor @@ -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" diff --git a/basis/environment/environment-tests.factor b/basis/environment/environment-tests.factor new file mode 100644 index 0000000000..3717303175 --- /dev/null +++ b/basis/environment/environment-tests.factor @@ -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 "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 diff --git a/basis/environment/environment.factor b/basis/environment/environment.factor new file mode 100644 index 0000000000..492925c7c0 --- /dev/null +++ b/basis/environment/environment.factor @@ -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 diff --git a/basis/environment/summary.txt b/basis/environment/summary.txt new file mode 100644 index 0000000000..24d14cb458 --- /dev/null +++ b/basis/environment/summary.txt @@ -0,0 +1 @@ +Environment variables diff --git a/basis/environment/unix/authors.txt b/basis/environment/unix/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/environment/unix/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/environment/unix/macosx/authors.txt b/basis/environment/unix/macosx/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/environment/unix/macosx/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/environment/unix/macosx/macosx.factor b/basis/environment/unix/macosx/macosx.factor new file mode 100644 index 0000000000..51cee7ba08 --- /dev/null +++ b/basis/environment/unix/macosx/macosx.factor @@ -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 ; diff --git a/basis/environment/unix/macosx/tags.txt b/basis/environment/unix/macosx/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/environment/unix/macosx/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/environment/unix/tags.txt b/basis/environment/unix/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/environment/unix/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/environment/unix/unix.factor b/basis/environment/unix/unix.factor new file mode 100644 index 0000000000..c2dddc25ab --- /dev/null +++ b/basis/environment/unix/unix.factor @@ -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 diff --git a/basis/environment/winnt/authors.txt b/basis/environment/winnt/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/environment/winnt/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/environment/winnt/tags.txt b/basis/environment/winnt/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/environment/winnt/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/environment/winnt/winnt.factor b/basis/environment/winnt/winnt.factor new file mode 100644 index 0000000000..33cf6a698b --- /dev/null +++ b/basis/environment/winnt/winnt.factor @@ -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" + [ 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 [ + [ + utf16n decode-input + [ "\0" read-until drop dup empty? not ] + [ ] [ drop ] produce + ] with-input-stream* + ] [ FreeEnvironmentStrings win32-error=0/f ] bi ; diff --git a/basis/http/http-tests.factor b/basis/http/http-tests.factor index b3930878ff..96320b7d12 100644 --- a/basis/http/http-tests.factor +++ b/basis/http/http-tests.factor @@ -192,110 +192,104 @@ test-db [ init-furnace-tables ] with-db -: test-httpd ( -- ) - #! Return as soon as server is running. - - 1237 >>insecure - f >>secure - start-server* ; +: test-httpd ( responder -- ) + [ + main-responder set + + 0 >>insecure + f >>secure + dup start-server* + sockets>> first addr>> port>> + ] with-scope "port" set ; [ ] [ - [ + + add-quit-action - add-quit-action - - "resource:basis/http/test" >>default - "nested" add-responder - - [ URL" redirect-loop" ] >>display - "redirect-loop" add-responder - main-responder set + "resource:basis/http/test" >>default + "nested" add-responder + + [ URL" redirect-loop" ] >>display + "redirect-loop" add-responder - test-httpd - ] with-scope + test-httpd ] unit-test +: add-port ( url -- url' ) + >url clone "port" get >>port ; + [ t ] [ "resource:basis/http/test/foo.html" ascii file-contents - "http://localhost:1237/nested/foo.html" http-get nip = + "http://localhost/nested/foo.html" add-port http-get nip = ] unit-test -[ "http://localhost:1237/redirect-loop" http-get nip ] +[ "http://localhost/redirect-loop" add-port http-get nip ] [ too-many-redirects? ] must-fail-with [ "Goodbye" ] [ - "http://localhost:1237/quit" http-get nip + "http://localhost/quit" add-port http-get nip ] unit-test ! HTTP client redirect bug [ ] [ - [ - - add-quit-action - [ "quit" ] >>display - "redirect" add-responder - main-responder set + + add-quit-action + [ "quit" ] >>display + "redirect" add-responder - test-httpd - ] with-scope + test-httpd ] unit-test [ "Goodbye" ] [ - "http://localhost:1237/redirect" http-get nip + "http://localhost/redirect" add-port http-get nip ] unit-test [ ] [ - [ "http://localhost:1237/quit" http-get 2drop ] ignore-errors + [ "http://localhost/quit" add-port http-get 2drop ] ignore-errors ] unit-test ! Dispatcher bugs [ ] [ - [ + + + "Test" + + "" add-responder + add-quit-action - - "Test" - - "" add-responder - add-quit-action - - "" add-responder - "d" add-responder - test-db - main-responder set + "" add-responder + "d" add-responder + test-db - test-httpd - ] with-scope + test-httpd ] unit-test : 404? [ download-failed? ] [ response>> code>> 404 = ] bi and ; ! This should give a 404 not an infinite redirect loop -[ "http://localhost:1237/d/blah" http-get nip ] [ 404? ] must-fail-with +[ "http://localhost/d/blah" add-port http-get nip ] [ 404? ] must-fail-with ! This should give a 404 not an infinite redirect loop -[ "http://localhost:1237/blah/" http-get nip ] [ 404? ] must-fail-with +[ "http://localhost/blah/" add-port http-get nip ] [ 404? ] must-fail-with -[ "Goodbye" ] [ "http://localhost:1237/quit" http-get nip ] unit-test +[ "Goodbye" ] [ "http://localhost/quit" add-port http-get nip ] unit-test [ ] [ - [ - - [ [ "Hi" write ] "text/plain" ] >>display - "Test" - - "" add-responder - add-quit-action - test-db - main-responder set + + [ [ "Hi" write ] "text/plain" ] >>display + "Test" + + "" add-responder + add-quit-action + test-db - test-httpd - ] with-scope + test-httpd ] unit-test -[ "Hi" ] [ "http://localhost:1237/" http-get nip ] unit-test +[ "Hi" ] [ "http://localhost/" add-port http-get nip ] unit-test -[ "Goodbye" ] [ "http://localhost:1237/quit" http-get nip ] unit-test +[ "Goodbye" ] [ "http://localhost/quit" add-port http-get nip ] unit-test USING: html.components html.elements html.forms xml xml.utilities validators @@ -304,22 +298,19 @@ furnace furnace.conversations ; SYMBOL: a [ ] [ - [ - - - [ a get-global "a" set-value ] >>init - [ [ "a" render ] "text/html" ] >>display - [ { { "a" [ v-integer ] } } validate-params ] >>validate - [ "a" value a set-global URL" " ] >>submit - - - >>default - add-quit-action - test-db - main-responder set + + + [ a get-global "a" set-value ] >>init + [ [ "a" render ] "text/html" ] >>display + [ { { "a" [ v-integer ] } } validate-params ] >>validate + [ "a" value a set-global URL" " ] >>submit + + + >>default + add-quit-action + test-db - test-httpd - ] with-scope + test-httpd ] unit-test 3 a set-global @@ -327,27 +318,35 @@ SYMBOL: a : test-a string>xml "input" tag-named "value" swap at ; [ "3" ] [ - "http://localhost:1237/" http-get + "http://localhost/" add-port http-get swap dup cookies>> "cookies" set session-id-key get-cookie value>> "session-id" set test-a ] unit-test [ "4" ] [ - H{ { "a" "4" } { "__u" "http://localhost:1237/" } } "session-id" get session-id-key associate assoc-union - "http://localhost:1237/" "cookies" get >>cookies http-request nip test-a + [ + "4" "a" set + "http://localhost" add-port "__u" set + "session-id" get session-id-key set + ] H{ } make-assoc + "http://localhost/" add-port "cookies" get >>cookies http-request nip test-a ] unit-test [ 4 ] [ a get-global ] unit-test ! Test flash scope [ "xyz" ] [ - H{ { "a" "xyz" } { "__u" "http://localhost:1237/" } } "session-id" get session-id-key associate assoc-union - "http://localhost:1237/" "cookies" get >>cookies http-request nip test-a + [ + "xyz" "a" set + "http://localhost" add-port "__u" set + "session-id" get session-id-key set + ] H{ } make-assoc + "http://localhost/" add-port "cookies" get >>cookies http-request nip test-a ] unit-test [ 4 ] [ a get-global ] unit-test -[ "Goodbye" ] [ "http://localhost:1237/quit" http-get nip ] unit-test +[ "Goodbye" ] [ "http://localhost/quit" add-port http-get nip ] unit-test ! Test cloning [ f ] [ <404> dup clone "b" "a" set-header drop "a" header ] unit-test diff --git a/basis/http/server/static/static.factor b/basis/http/server/static/static.factor index 3e3307033a..208273364c 100644 --- a/basis/http/server/static/static.factor +++ b/basis/http/server/static/static.factor @@ -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 escape-string write ; : directory. ( path -- ) @@ -68,8 +68,7 @@ TUPLE: file-responder root hook special allow-listings ; [

file-name escape-string write

] [
    - directory sort-keys - [
  • file.
    • ] assoc-each + directory-files [
  • file.
    • ] each
] bi ] simple-page ; diff --git a/basis/io/launcher/launcher.factor b/basis/io/launcher/launcher.factor index 7f1a3f4507..3e1ef6ce05 100644 --- a/basis/io/launcher/launcher.factor +++ b/basis/io/launcher/launcher.factor @@ -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 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 diff --git a/basis/io/monitors/recursive/recursive.factor b/basis/io/monitors/recursive/recursive.factor index 383e166214..45979363c9 100644 --- a/basis/io/monitors/recursive/recursive.factor +++ b/basis/io/monitors/recursive/recursive.factor @@ -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 ] [ [ diff --git a/basis/io/servers/connection/connection-tests.factor b/basis/io/servers/connection/connection-tests.factor index a3223ed2aa..ae79290f0a 100644 --- a/basis/io/servers/connection/connection-tests.factor +++ b/basis/io/servers/connection/connection-tests.factor @@ -27,25 +27,12 @@ concurrency.promises io.encodings.ascii io threads calendar ; init-server semaphore>> count>> ] unit-test -[ ] [ "p" set ] unit-test - [ ] [ 5 >>max-connections - 1237 >>insecure + 0 >>insecure [ "Hello world." write stop-this-server ] >>handler - "server" set + dup start-server* sockets>> first addr>> port>> "port" set ] unit-test -[ ] [ - [ - "server" get start-server - t "p" get fulfill - ] in-thread -] unit-test - -[ ] [ "server" get wait-for-server ] unit-test - -[ "Hello world." ] [ "localhost" 1237 ascii drop contents ] unit-test - -[ t ] [ "p" get 2 seconds ?promise-timeout ] unit-test +[ "Hello world." ] [ "localhost" "port" get ascii drop contents ] unit-test diff --git a/basis/io/unix/files/bsd/bsd.factor b/basis/io/unix/files/bsd/bsd.factor index 18e713af2f..3c94baa39a 100644 --- a/basis/io/unix/files/bsd/bsd.factor +++ b/basis/io/unix/files/bsd/bsd.factor @@ -13,5 +13,8 @@ M: bsd stat>file-info ( stat -- file-info ) { [ stat-st_flags >>flags ] [ stat-st_gen >>gen ] - [ stat-st_birthtimespec timespec>unix-time >>birth-time ] + [ + stat-st_birthtimespec timespec>unix-time + >>birth-time + ] } cleave ; diff --git a/basis/io/unix/files/files-docs.factor b/basis/io/unix/files/files-docs.factor index 5b5e257c5e..3798380e0f 100644 --- a/basis/io/unix/files/files-docs.factor +++ b/basis/io/unix/files/files-docs.factor @@ -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:" diff --git a/basis/io/unix/files/files-tests.factor b/basis/io/unix/files/files-tests.factor index 5a24c1314a..78a80ad969 100644 --- a/basis/io/unix/files/files-tests.factor +++ b/basis/io/unix/files/files-tests.factor @@ -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 diff --git a/basis/io/unix/files/files.factor b/basis/io/unix/files/files.factor index 40ef9ad859..9ebfdaaa5a 100644 --- a/basis/io/unix/files/files.factor +++ b/basis/io/unix/files/files.factor @@ -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 unix.statfs ; 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" + f + [ 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 ; + : 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 ; diff --git a/basis/io/unix/launcher/launcher.factor b/basis/io/unix/launcher/launcher.factor index fb8dc85cf8..421e12a92f 100644 --- a/basis/io/unix/launcher/launcher.factor +++ b/basis/io/unix/launcher/launcher.factor @@ -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 diff --git a/basis/io/windows/files/files.factor b/basis/io/windows/files/files.factor index dbe16f0a6e..e4fe0fbc63 100644 --- a/basis/io/windows/files/files.factor +++ b/basis/io/windows/files/files.factor @@ -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" tuck + FindFirstFile + [ INVALID_HANDLE_VALUE = [ win32-error ] when ] keep ; + +: find-next-file ( path -- WIN32_FIND_DATA/f ) + "WIN32_FIND_DATA" 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+ @@ -218,6 +246,21 @@ M: winnt file-info ( path -- info ) M: winnt link-info ( path -- info ) file-info ; +TUPLE: winnt-file-system-info < file-system-info +total-bytes total-free-bytes ; + +M: winnt file-system-info ( path -- file-system-info ) + normalize-path + dup file-info directory? [ parent-directory ] unless + "ULARGE_INTEGER" + "ULARGE_INTEGER" + "ULARGE_INTEGER" + [ GetDiskFreeSpaceEx win32-error=0/f ] 3keep + \ winnt-file-system-info new + swap *ulonglong >>total-free-bytes + swap *ulonglong >>total-bytes + swap *ulonglong >>free-space ; + : file-times ( path -- timestamp timestamp timestamp ) [ normalize-path open-existing &dispose handle>> diff --git a/basis/io/windows/files/unique/unique.factor b/basis/io/windows/files/unique/unique.factor index dcb713df7f..b1bf2bdc1c 100644 --- a/basis/io/windows/files/unique/unique.factor +++ b/basis/io/windows/files/unique/unique.factor @@ -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 -- ) diff --git a/basis/io/windows/nt/files/files.factor b/basis/io/windows/nt/files/files.factor index 157662ade8..9b77a9f128 100644 --- a/basis/io/windows/nt/files/files.factor +++ b/basis/io/windows/nt/files/files.factor @@ -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 ; diff --git a/basis/io/windows/nt/launcher/launcher-tests.factor b/basis/io/windows/nt/launcher/launcher-tests.factor index d5e77caa19..949b0a7961 100644 --- a/basis/io/windows/nt/launcher/launcher-tests.factor +++ b/basis/io/windows/nt/launcher/launcher-tests.factor @@ -1,7 +1,7 @@ -IN: io.windows.launcher.nt.tests -USING: io.launcher tools.test calendar accessors +USING: io.launcher tools.test calendar accessors environment namespaces kernel system arrays io io.files io.encodings.ascii sequences parser assocs hashtables math continuations eval ; +IN: io.windows.launcher.nt.tests [ ] [ diff --git a/basis/io/windows/nt/launcher/test/env.factor b/basis/io/windows/nt/launcher/test/env.factor index a0015f7ea2..503ca7d018 100644 --- a/basis/io/windows/nt/launcher/test/env.factor +++ b/basis/io/windows/nt/launcher/test/env.factor @@ -1,3 +1,4 @@ -USE: system -USE: prettyprint -os-envs . +USE: system +USE: prettyprint +USE: environment +os-envs . diff --git a/basis/logging/server/server.factor b/basis/logging/server/server.factor index d13ae616be..47656e8655 100644 --- a/basis/logging/server/server.factor +++ b/basis/logging/server/server.factor @@ -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 { diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 80e888a3e9..1332415c49 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -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 diff --git a/basis/tools/deploy/deploy-tests.factor b/basis/tools/deploy/deploy-tests.factor index db4255cdb1..71e83ea29c 100644 --- a/basis/tools/deploy/deploy-tests.factor +++ b/basis/tools/deploy/deploy-tests.factor @@ -1,7 +1,8 @@ IN: tools.deploy.tests USING: tools.test system io.files kernel tools.deploy.config tools.deploy.backend math sequences io.launcher arrays -namespaces continuations layouts accessors ; +namespaces continuations layouts accessors io.encodings.ascii +urls math.parser ; : shake-and-bake ( vocab -- ) [ "test.image" temp-file delete-file ] ignore-errors @@ -38,7 +39,7 @@ namespaces continuations layouts accessors ; ! [ ] [ "tetris" shake-and-bake ] unit-test ! ! [ t ] [ 1500000 small-enough? ] unit-test -! + [ ] [ "bunny" shake-and-bake ] unit-test [ t ] [ 2500000 small-enough? ] unit-test @@ -71,22 +72,24 @@ M: quit-responder call-responder* : add-quot-responder ( responder -- responder ) quit-responder "quit" add-responder ; -: test-httpd ( -- ) - #! Return as soon as server is running. - - 1237 >>insecure - f >>secure - start-server* ; +: test-httpd ( responder -- ) + [ + main-responder set + + 0 >>insecure + f >>secure + dup start-server* + sockets>> first addr>> port>> + dup number>string "resource:temp/port-number" ascii set-file-contents + ] with-scope + "port" set ; [ ] [ - [ - - add-quot-responder - "resource:basis/http/test" >>default - main-responder set + + add-quot-responder + "resource:basis/http/test" >>default - test-httpd - ] with-scope + test-httpd ] unit-test [ ] [ @@ -94,7 +97,10 @@ M: quit-responder call-responder* run-temp-image ] unit-test -[ ] [ "http://localhost:1237/quit" http-get 2drop ] unit-test +: add-port ( url -- url' ) + >url clone "port" get >>port ; + +[ ] [ "http://localhost/quit" add-port http-get 2drop ] unit-test [ ] [ "tools.deploy.test.6" shake-and-bake diff --git a/basis/tools/deploy/test/5/5.factor b/basis/tools/deploy/test/5/5.factor index debc020d49..9118fa3ca7 100644 --- a/basis/tools/deploy/test/5/5.factor +++ b/basis/tools/deploy/test/5/5.factor @@ -1,7 +1,10 @@ IN: tools.deploy.test.5 -USING: http.client kernel ; +USING: accessors urls io.encodings.ascii io.files math.parser +http.client kernel ; : deploy-test-5 ( -- ) - "http://localhost:1237/foo.html" http-get 2drop ; + URL" http://localhost/foo.html" clone + "resource:port-number" ascii file-contents string>number >>port + http-get 2drop ; MAIN: deploy-test-5 diff --git a/basis/tools/scaffold/scaffold.factor b/basis/tools/scaffold/scaffold.factor index 17eafa91c6..6659940b2b 100644 --- a/basis/tools/scaffold/scaffold.factor +++ b/basis/tools/scaffold/scaffold.factor @@ -16,13 +16,18 @@ ERROR: vocab-name-contains-dot path ; ERROR: no-vocab vocab ; . ; +: (scaffold-path) ( path string -- path ) + dupd [ file-name ] dip append append-path ; + : scaffold-path ( path string -- path ? ) - dupd [ file-name ] dip append append-path + (scaffold-path) dup exists? [ dup not-scaffolding f ] [ dup scaffolding t ] if ; : scaffold-copyright ( -- ) @@ -205,14 +213,15 @@ ERROR: no-vocab vocab ; : check-vocab ( vocab -- vocab ) dup find-vocab-root [ no-vocab ] unless ; + PRIVATE> : link-vocab ( vocab -- ) check-vocab "Edit documentation: " write - [ find-vocab-root ] keep - [ append-path ] keep "-docs.factor" append append-path - . ; + [ find-vocab-root ] + [ vocab>scaffold-path ] bi + "-docs.factor" (scaffold-path) . ; : help. ( word -- ) [ (help.) ] [ nl vocabulary>> link-vocab ] bi ; diff --git a/basis/tools/test/test.factor b/basis/tools/test/test.factor index d3304bbdb1..5c2bd8f4e3 100644 --- a/basis/tools/test/test.factor +++ b/basis/tools/test/test.factor @@ -12,6 +12,7 @@ SYMBOL: failures error-continuation get 3array ; : failure ( error what -- ) + "--> test failed!" print failures get push ; SYMBOL: this-test diff --git a/basis/tools/vocabs/vocabs.factor b/basis/tools/vocabs/vocabs.factor index 732a6635b7..b929c62e04 100644 --- a/basis/tools/vocabs/vocabs.factor +++ b/basis/tools/vocabs/vocabs.factor @@ -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,15 @@ M: vocab-link summary vocab-summary ; dup vocab-authors-path set-vocab-file-contents ; : subdirs ( dir -- dirs ) - directory [ second ] filter keys natural-sort ; + [ + [ link-info directory? ] filter + ] with-directory-files 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 ; diff --git a/basis/ui/tools/listener/listener-tests.factor b/basis/ui/tools/listener/listener-tests.factor index e86b52c664..616226a9c5 100644 --- a/basis/ui/tools/listener/listener-tests.factor +++ b/basis/ui/tools/listener/listener-tests.factor @@ -2,7 +2,7 @@ USING: continuations documents ui.tools.interactor ui.tools.listener hashtables kernel namespaces parser sequences tools.test ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.panes vocabs words tools.test.ui slots.private -threads arrays generic threads accessors listener ; +threads arrays generic threads accessors listener math ; IN: ui.tools.listener.tests [ f ] [ "word" source-editor command-map commands>> empty? ] unit-test @@ -51,3 +51,5 @@ IN: ui.tools.listener.tests [ ] [ "listener" get com-end ] unit-test ] with-grafted-gadget + +[ ] [ \ + interactor-use use-if-necessary ] unit-test diff --git a/basis/ui/tools/listener/listener.factor b/basis/ui/tools/listener/listener.factor index 6fc6fa4f10..4c8b88d62c 100644 --- a/basis/ui/tools/listener/listener.factor +++ b/basis/ui/tools/listener/listener.factor @@ -101,8 +101,8 @@ M: engine-word word-completion-string "engine-generic" word-prop word-completion-string ; : use-if-necessary ( word seq -- ) - over vocabulary>> [ - 2dup assoc-stack pick = [ 2drop ] [ + over vocabulary>> over and [ + 2dup [ assoc-stack ] keep = [ 2drop ] [ >r vocabulary>> vocab-words r> push ] if ] [ 2drop ] if ; @@ -114,9 +114,10 @@ M: engine-word word-completion-string 2bi ; : quot-action ( interactor -- lines ) - dup control-value - dup "\n" join pick add-interactor-history - swap select-all ; + [ control-value ] keep + [ [ "\n" join ] dip add-interactor-history ] + [ select-all ] + 2bi ; TUPLE: stack-display < track ; diff --git a/basis/ui/tools/tools.factor b/basis/ui/tools/tools.factor index f4205061cd..aed4b9d675 100644 --- a/basis/ui/tools/tools.factor +++ b/basis/ui/tools/tools.factor @@ -40,11 +40,11 @@ IN: ui.tools : resize-workspace ( workspace -- ) dup sizes>> over control-value zero? [ - 1/5 1 pick set-nth - 4/5 2 rot set-nth + 1/5 over set-second + 4/5 swap set-third ] [ - 2/3 1 pick set-nth - 1/3 2 rot set-nth + 2/3 over set-second + 1/3 swap set-third ] if relayout ; M: workspace model-changed diff --git a/basis/ui/x11/x11.factor b/basis/ui/x11/x11.factor index 3122bc536b..e3c8421080 100644 --- a/basis/ui/x11/x11.factor +++ b/basis/ui/x11/x11.factor @@ -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 diff --git a/basis/unix/bsd/bsd.factor b/basis/unix/bsd/bsd.factor index 7bbf2b4fdf..bd66c5253e 100644 --- a/basis/unix/bsd/bsd.factor +++ b/basis/unix/bsd/bsd.factor @@ -3,8 +3,6 @@ USING: alien.syntax combinators system vocabs.loader ; IN: unix -! FreeBSD - : MAXPATHLEN 1024 ; inline : O_RDONLY HEX: 0000 ; inline @@ -85,6 +83,16 @@ C-STRUCT: passwd : SEEK_CUR 1 ; inline : SEEK_END 2 ; inline +: 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 + os { { macosx [ "unix.bsd.macosx" require ] } { freebsd [ "unix.bsd.freebsd" require ] } diff --git a/basis/unix/bsd/freebsd/freebsd.factor b/basis/unix/bsd/freebsd/freebsd.factor index 34f0f0429c..81885ff141 100644 --- a/basis/unix/bsd/freebsd/freebsd.factor +++ b/basis/unix/bsd/freebsd/freebsd.factor @@ -13,6 +13,13 @@ 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" } ; + : EPERM 1 ; inline : ENOENT 2 ; inline : ESRCH 3 ; inline diff --git a/basis/unix/bsd/macosx/macosx.factor b/basis/unix/bsd/macosx/macosx.factor index c41ae6df7d..fb9eb9a621 100644 --- a/basis/unix/bsd/macosx/macosx.factor +++ b/basis/unix/bsd/macosx/macosx.factor @@ -13,6 +13,32 @@ 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" } ; + : EPERM 1 ; inline : ENOENT 2 ; inline : ESRCH 3 ; inline @@ -117,18 +143,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" } ; diff --git a/basis/unix/bsd/netbsd/netbsd.factor b/basis/unix/bsd/netbsd/netbsd.factor index ca42b7840c..149f35afce 100644 --- a/basis/unix/bsd/netbsd/netbsd.factor +++ b/basis/unix/bsd/netbsd/netbsd.factor @@ -13,6 +13,13 @@ C-STRUCT: addrinfo { "void*" "addr" } { "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" } ; + : EPERM 1 ; inline : ENOENT 2 ; inline : ESRCH 3 ; inline diff --git a/basis/unix/bsd/openbsd/openbsd.factor b/basis/unix/bsd/openbsd/openbsd.factor index 31025a47e9..a4189775e7 100644 --- a/basis/unix/bsd/openbsd/openbsd.factor +++ b/basis/unix/bsd/openbsd/openbsd.factor @@ -13,6 +13,13 @@ 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" } ; + : EPERM 1 ; inline : ENOENT 2 ; inline : ESRCH 3 ; inline diff --git a/basis/unix/groups/groups.factor b/basis/unix/groups/groups.factor index c3af9cc83d..b8edf7fa36 100644 --- a/basis/unix/groups/groups.factor +++ b/basis/unix/groups/groups.factor @@ -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 ) string - [ alien-address "char**" heap-size + ] dip - ] [ ] produce nip ; + group-gr_mem utf8 alien>strings ; : (group-struct) ( id -- group-struct id group-struct byte-array length void* ) "group" tuck 4096 diff --git a/basis/unix/linux/fs/fs.factor b/basis/unix/linux/fs/fs.factor index 475d0290a6..6cb9f68934 100644 --- a/basis/unix/linux/fs/fs.factor +++ b/basis/unix/linux/fs/fs.factor @@ -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 ) ; \ No newline at end of file +FUNCTION: int umount ( char* file ) ; diff --git a/basis/unix/linux/linux.factor b/basis/unix/linux/linux.factor index 457d96c7d8..7a77dc9316 100644 --- a/basis/unix/linux/linux.factor +++ b/basis/unix/linux/linux.factor @@ -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 diff --git a/basis/unix/process/process.factor b/basis/unix/process/process.factor index 7d3d757705..030f0977e2 100644 --- a/basis/unix/process/process.factor +++ b/basis/unix/process/process.factor @@ -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 [ 0 waitpid drop ] keep *int WEXITSTATUS ; \ No newline at end of file + 0 [ 0 waitpid drop ] keep *int WEXITSTATUS ; diff --git a/basis/unix/stat/linux/32/32.factor b/basis/unix/stat/linux/32/32.factor index 3f6c6ba0e0..ded06595de 100644 --- a/basis/unix/stat/linux/32/32.factor +++ b/basis/unix/stat/linux/32/32.factor @@ -1,6 +1,4 @@ - USING: kernel alien.syntax math ; - IN: unix.stat ! Ubuntu 8.04 32-bit @@ -24,8 +22,6 @@ C-STRUCT: stat { "ulong" "unused4" } { "ulong" "unused5" } ; -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - FUNCTION: int __xstat ( int ver, char* pathname, stat* buf ) ; FUNCTION: int __lxstat ( int ver, char* pathname, stat* buf ) ; diff --git a/basis/unix/stat/linux/64/64.factor b/basis/unix/stat/linux/64/64.factor index 088ab8d339..f406b2ccee 100644 --- a/basis/unix/stat/linux/64/64.factor +++ b/basis/unix/stat/linux/64/64.factor @@ -1,6 +1,5 @@ - -USING: kernel alien.syntax math ; - +USING: kernel alien.syntax math sequences unix +alien.c-types arrays accessors combinators ; IN: unix.stat ! Ubuntu 7.10 64-bit diff --git a/basis/unix/stat/linux/linux.factor b/basis/unix/stat/linux/linux.factor index 2f4b6174d9..f1c931617e 100644 --- a/basis/unix/stat/linux/linux.factor +++ b/basis/unix/stat/linux/linux.factor @@ -1,11 +1,8 @@ - -USING: layouts combinators vocabs.loader ; - +USING: alien.syntax layouts combinators vocabs.loader ; IN: unix.stat cell-bits - { +{ { 32 [ "unix.stat.linux.32" require ] } { 64 [ "unix.stat.linux.64" require ] } - } -case +} case diff --git a/basis/unix/stat/macosx/macosx.factor b/basis/unix/stat/macosx/macosx.factor index b2574b474d..2656ec71e1 100644 --- a/basis/unix/stat/macosx/macosx.factor +++ b/basis/unix/stat/macosx/macosx.factor @@ -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 diff --git a/basis/unix/stat/netbsd/netbsd.factor b/basis/unix/stat/netbsd/netbsd.factor index 8057e5939b..6fccd570e3 100644 --- a/basis/unix/stat/netbsd/netbsd.factor +++ b/basis/unix/stat/netbsd/netbsd.factor @@ -1,4 +1,4 @@ -USING: layouts combinators vocabs.loader ; +USING: layouts combinators vocabs.loader alien.syntax ; IN: unix.stat cell-bits { diff --git a/basis/unix/stat/stat.factor b/basis/unix/stat/stat.factor index 46fe7d98f9..17d6604fc0 100644 --- a/basis/unix/stat/stat.factor +++ b/basis/unix/stat/stat.factor @@ -18,6 +18,12 @@ FUNCTION: int chmod ( char* path, mode_t mode ) ; FUNCTION: int fchmod ( int fd, mode_t mode ) ; FUNCTION: int mkdir ( char* path, mode_t mode ) ; +C-STRUCT: fsid + { { "int" 2 } "__val" } ; + + TYPEDEF: fsid __fsid_t + TYPEDEF: fsid fsid_t + << os { { linux [ "unix.stat.linux" require ] } { macosx [ "unix.stat.macosx" require ] } @@ -27,11 +33,7 @@ FUNCTION: int mkdir ( char* path, mode_t mode ) ; } case >> : file-status ( pathname -- stat ) - "stat" [ - [ stat ] unix-system-call drop - ] keep ; + "stat" [ [ stat ] unix-system-call drop ] keep ; : link-status ( pathname -- stat ) - "stat" [ - [ lstat ] unix-system-call drop - ] keep ; + "stat" [ [ lstat ] unix-system-call drop ] keep ; diff --git a/basis/unix/statfs/authors.txt b/basis/unix/statfs/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/unix/statfs/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/unix/statfs/freebsd/authors.txt b/basis/unix/statfs/freebsd/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/unix/statfs/freebsd/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/unix/statfs/freebsd/freebsd.factor b/basis/unix/statfs/freebsd/freebsd.factor new file mode 100644 index 0000000000..6c5a45c4d2 --- /dev/null +++ b/basis/unix/statfs/freebsd/freebsd.factor @@ -0,0 +1,52 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.syntax kernel unix io.files math accessors +combinators system io.backend alien.c-types ; +IN: unix.statfs.freebsd + +: ST_RDONLY 1 ; inline +: ST_NOSUID 2 ; inline + +C-STRUCT: statvfs + { "fsblkcnt_t" "f_bavail" } + { "fsblkcnt_t" "f_bfree" } + { "fsblkcnt_t" "f_blocks" } + { "fsfilcnt_t" "f_favail" } + { "fsfilcnt_t" "f_ffree" } + { "fsfilcnt_t" "f_files" } + { "ulong" "f_bsize" } + { "ulong" "f_flag" } + { "ulong" "f_frsize" } + { "ulong" "f_fsid" } + { "ulong" "f_namemax" } ; + +FUNCTION: int statvfs ( char* path, statvfs* buf ) ; + +TUPLE: freebsd-file-system-info < file-system-info +bavail bfree blocks favail ffree ffiles +bsize flag frsize fsid namemax ; + +M: freebsd >file-system-info ( struct -- statfs ) + [ \ freebsd-file-system-info new ] dip + { + [ + [ statvfs-f_bsize ] + [ statvfs-f_bavail ] bi * >>free-space + ] + [ statvfs-f_bavail >>bavail ] + [ statvfs-f_bfree >>bfree ] + [ statvfs-f_blocks >>blocks ] + [ statvfs-f_favail >>favail ] + [ statvfs-f_ffree >>ffree ] + [ statvfs-f_files >>files ] + [ statvfs-f_bsize >>bsize ] + [ statvfs-f_flag >>flag ] + [ statvfs-f_frsize >>frsize ] + [ statvfs-f_fsid >>fsid ] + [ statvfs-f_namemax >>namemax ] + } cleave ; + +M: freebsd file-system-info ( path -- byte-array ) + normalize-path + "statvfs" tuck statvfs io-error + >file-system-info ; diff --git a/basis/unix/statfs/freebsd/tags.txt b/basis/unix/statfs/freebsd/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/statfs/freebsd/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/statfs/linux/32/32.factor b/basis/unix/statfs/linux/32/32.factor new file mode 100644 index 0000000000..c6ec0bc658 --- /dev/null +++ b/basis/unix/statfs/linux/32/32.factor @@ -0,0 +1,46 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.c-types combinators kernel io.files unix.stat +math accessors system unix io.backend layouts vocabs.loader +alien.syntax ; +IN: unix.statfs.linux + +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" } ; + +FUNCTION: int statfs ( char* path, statfs* buf ) ; + +TUPLE: linux32-file-system-info < file-system-info +type bsize blocks bfree bavail files ffree fsid +namelen frsize spare ; + +M: linux >file-system-info ( struct -- statfs ) + [ \ linux32-file-system-info new ] dip + { + [ + [ statfs-f_bsize ] + [ statfs-f_bavail ] bi * >>free-space + ] + [ statfs-f_type >>type ] + [ statfs-f_bsize >>bsize ] + [ statfs-f_blocks >>blocks ] + [ statfs-f_bfree >>bfree ] + [ statfs-f_bavail >>bavail ] + [ statfs-f_files >>files ] + [ statfs-f_ffree >>ffree ] + [ statfs-f_fsid >>fsid ] + [ statfs-f_namelen >>namelen ] + } cleave ; + +M: linux file-system-info ( path -- byte-array ) + normalize-path + "statfs" tuck statfs io-error + >file-system-info ; diff --git a/basis/unix/statfs/linux/32/authors.txt b/basis/unix/statfs/linux/32/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/unix/statfs/linux/32/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/unix/statfs/linux/32/tags.txt b/basis/unix/statfs/linux/32/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/statfs/linux/32/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/statfs/linux/64/64.factor b/basis/unix/statfs/linux/64/64.factor new file mode 100644 index 0000000000..a84bec0486 --- /dev/null +++ b/basis/unix/statfs/linux/64/64.factor @@ -0,0 +1,50 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.c-types combinators kernel io.files unix.stat +math accessors system unix io.backend layouts vocabs.loader +alien.syntax ; +IN: unix.statfs.linux + +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" } ; + +FUNCTION: int statfs64 ( char* path, statfs64* buf ) ; + +TUPLE: linux64-file-system-info < file-system-info +type bsize blocks bfree bavail files ffree fsid +namelen frsize spare ; + +M: linux >file-system-info ( struct -- statfs ) + [ \ linux64-file-system-info new ] dip + { + [ + [ statfs64-f_bsize ] + [ statfs64-f_bavail ] bi * >>free-space + ] + [ 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 ; + +M: linux file-system-info ( path -- byte-array ) + normalize-path + "statfs64" tuck statfs64 io-error + >file-system-info ; diff --git a/basis/unix/statfs/linux/64/authors.txt b/basis/unix/statfs/linux/64/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/unix/statfs/linux/64/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/unix/statfs/linux/64/tags.txt b/basis/unix/statfs/linux/64/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/statfs/linux/64/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/statfs/linux/authors.txt b/basis/unix/statfs/linux/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/unix/statfs/linux/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/unix/statfs/linux/linux.factor b/basis/unix/statfs/linux/linux.factor new file mode 100644 index 0000000000..b4413fba15 --- /dev/null +++ b/basis/unix/statfs/linux/linux.factor @@ -0,0 +1,10 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.c-types combinators kernel io.files unix.stat +math accessors system unix io.backend layouts vocabs.loader ; +IN: unix.statfs.linux + +cell-bits { + { 32 [ "unix.statfs.linux.32" require ] } + { 64 [ "unix.statfs.linux.64" require ] } +} case diff --git a/basis/unix/statfs/linux/tags.txt b/basis/unix/statfs/linux/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/statfs/linux/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/statfs/macosx/authors.txt b/basis/unix/statfs/macosx/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/unix/statfs/macosx/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/unix/statfs/macosx/macosx.factor b/basis/unix/statfs/macosx/macosx.factor new file mode 100644 index 0000000000..4bd9f55132 --- /dev/null +++ b/basis/unix/statfs/macosx/macosx.factor @@ -0,0 +1,165 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.c-types io.encodings.utf8 io.encodings.string +kernel sequences unix.stat accessors unix combinators math +grouping system unix.statfs io.files io.backend alien.strings +math.bitwise alien.syntax ; +IN: unix.statfs.macosx + +: 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 + +: 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 ) ; + + +TUPLE: macosx-file-system-info < file-system-info +block-size io-size blocks blocks-free blocks-available files +files-free file-system-id owner type flags filesystem-subtype +file-system-type-name mount-from ; + +M: macosx mounted* ( -- array ) + f dup 0 getmntinfo64 dup io-error + [ *void* ] dip + "statfs64" heap-size [ * memory>byte-array ] keep group ; + +M: macosx >file-system-info ( byte-array -- file-system-info ) + [ \ macosx-file-system-info new ] dip + { + [ + [ statfs64-f_bavail ] [ statfs64-f_bsize ] bi * + >>free-space + ] + [ statfs64-f_mntonname utf8 alien>string >>mount-on ] + [ statfs64-f_bsize >>block-size ] + + [ statfs64-f_iosize >>io-size ] + [ statfs64-f_blocks >>blocks ] + [ statfs64-f_bfree >>blocks-free ] + [ statfs64-f_bavail >>blocks-available ] + [ statfs64-f_files >>files ] + [ statfs64-f_ffree >>files-free ] + [ statfs64-f_fsid >>file-system-id ] + [ statfs64-f_owner >>owner ] + [ statfs64-f_type >>type ] + [ statfs64-f_flags >>flags ] + [ statfs64-f_fssubtype >>filesystem-subtype ] + [ + statfs64-f_fstypename utf8 alien>string + >>file-system-type-name + ] + [ + statfs64-f_mntfromname + utf8 alien>string >>mount-from + ] + } cleave ; + +M: macosx file-system-info ( path -- file-system-info ) + normalize-path + "statfs64" tuck statfs64 io-error + >file-system-info ; diff --git a/basis/unix/statfs/macosx/tags.txt b/basis/unix/statfs/macosx/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/statfs/macosx/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/statfs/netbsd/authors.txt b/basis/unix/statfs/netbsd/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/unix/statfs/netbsd/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/unix/statfs/netbsd/netbsd.factor b/basis/unix/statfs/netbsd/netbsd.factor new file mode 100644 index 0000000000..dd1ccd4c9a --- /dev/null +++ b/basis/unix/statfs/netbsd/netbsd.factor @@ -0,0 +1,78 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.syntax kernel io.files unix.stat math unix +combinators system io.backend accessors alien.c-types +io.encodings.utf8 alien.strings unix.types ; +IN: unix.statfs.netbsd + +: _VFS_NAMELEN 32 ; inline +: _VFS_MNAMELEN 1024 ; inline + +C-STRUCT: statvfs + { "ulong" "f_flag" } + { "ulong" "f_bsize" } + { "ulong" "f_frsize" } + { "ulong" "f_iosize" } + { "fsblkcnt_t" "f_blocks" } + { "fsblkcnt_t" "f_bfree" } + { "fsblkcnt_t" "f_bavail" } + { "fsblkcnt_t" "f_bresvd" } + { "fsfilcnt_t" "f_files" } + { "fsfilcnt_t" "f_ffree" } + { "fsfilcnt_t" "f_favail" } + { "fsfilcnt_t" "f_fresvd" } + { "uint64_t" "f_syncreads" } + { "uint64_t" "f_syncwrites" } + { "uint64_t" "f_asyncreads" } + { "uint64_t" "f_asyncwrites" } + { "fsid_t" "f_fsidx" } + { "ulong" "f_fsid" } + { "ulong" "f_namemax" } + { "uid_t" "f_owner" } + { { "uint32_t" 4 } "f_spare" } + { { "char" _VFS_NAMELEN } "f_fstypename" } + { { "char" _VFS_NAMELEN } "f_mntonname" } + { { "char" _VFS_NAMELEN } "f_mntfromname" } ; + +FUNCTION: int statvfs ( char* path, statvfs *buf ) ; + +TUPLE: netbsd-file-system-info < file-system-info +flag bsize frsize io-size +blocks blocks-free blocks-available blocks-reserved +files ffree sync-reads sync-writes async-reads async-writes +fsidx fsid namemax owner spare fstype mnotonname mntfromname +file-system-type-name mount-from ; + +M: netbsd >file-system-info ( byte-array -- netbsd-file-system-info ) + [ \ netbsd-file-system-info new ] dip + { + [ + [ statvfs-f_bsize ] + [ statvfs-f_bavail ] bi * >>free-space + ] + [ statvfs-f_flag >>flag ] + [ statvfs-f_bsize >>bsize ] + [ statvfs-f_frsize >>frsize ] + [ statvfs-f_iosize >>io-size ] + [ statvfs-f_blocks >>blocks ] + [ statvfs-f_bfree >>blocks-free ] + [ statvfs-f_favail >>blocks-available ] + [ statvfs-f_fresvd >>blocks-reserved ] + [ statvfs-f_files >>files ] + [ statvfs-f_ffree >>ffree ] + [ statvfs-f_syncreads >>sync-reads ] + [ statvfs-f_syncwrites >>sync-writes ] + [ statvfs-f_asyncreads >>async-reads ] + [ statvfs-f_asyncwrites >>async-writes ] + [ statvfs-f_fsidx >>fsidx ] + [ statvfs-f_namemax >>namemax ] + [ statvfs-f_owner >>owner ] + [ statvfs-f_spare >>spare ] + [ statvfs-f_fstypename utf8 alien>string >>file-system-type-name ] + [ statvfs-f_mntonname utf8 alien>string >>mount-on ] + [ statvfs-f_mntfromname utf8 alien>string >>mount-from ] + } cleave ; + +M: netbsd file-system-info + normalize-path "statvfs" tuck statvfs io-error + >file-system-info ; diff --git a/basis/unix/statfs/netbsd/tags.txt b/basis/unix/statfs/netbsd/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/statfs/netbsd/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/statfs/openbsd/32/32.factor b/basis/unix/statfs/openbsd/32/32.factor new file mode 100644 index 0000000000..aa1e8425dc --- /dev/null +++ b/basis/unix/statfs/openbsd/32/32.factor @@ -0,0 +1,26 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.syntax kernel unix ; +IN: unix.statfs.openbsd.32 + +: MFSNAMELEN 16 ; inline +: MNAMELEN 90 ; inline + +C-STRUCT: statfs + { "u_int32_t" "f_flags" } + { "int32_t" "f_bsize" } + { "u_int32_t" "f_iosize" } + { "u_int32_t" "f_blocks" } + { "u_int32_t" "f_bfree" } + { "int32_t" "f_bavail" } + { "u_int32_t" "f_files" } + { "u_int32_t" "f_ffree" } + { "fsid_t" "f_fsid" } + { "uid_t" "f_owner" } + { "u_int32_t" "f_syncwrites" } + { "u_int32_t" "f_asyncwrites" } + { "u_int32_t" "f_ctime" } + { { "u_int32_t" 3 } "f_spare" } + { { "char" MFSNAMELEN } "f_fstypename" } + { { "char" MNAMELEN } "f_mntonname" } + { { "char" MNAMELEN } "f_mntfromname" } ; diff --git a/basis/unix/statfs/openbsd/32/authors.txt b/basis/unix/statfs/openbsd/32/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/unix/statfs/openbsd/32/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/unix/statfs/openbsd/32/tags.txt b/basis/unix/statfs/openbsd/32/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/statfs/openbsd/32/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/statfs/openbsd/64/64.factor b/basis/unix/statfs/openbsd/64/64.factor new file mode 100644 index 0000000000..fd40fba033 --- /dev/null +++ b/basis/unix/statfs/openbsd/64/64.factor @@ -0,0 +1,32 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.syntax unix ; +IN: unix.statfs.openbsd.64 + +: MFSNAMELEN 16 ; inline +: MNAMELEN 90 ; inline + +C-STRUCT: statfss + { "u_int32_t" "f_flags" } + { "u_int32_t" "f_bsize" } + { "u_int32_t" "f_iosize" } + { "u_int64_t" "f_blocks" } + { "u_int64_t" "f_bfree" } + { "int64_t" "f_bavail" } + { "u_int64_t" "f_files" } + { "u_int64_t" "f_ffree" } + { "int64_t" "f_favail" } + { "u_int64_t" "f_syncwrites" } + { "u_int64_t" "f_syncreads" } + { "u_int64_t" "f_asyncwrites" } + { "u_int64_t" "f_asyncreads" } + { "fsid_t" "f_fsid" } + { "u_int32_t" "f_namemax" } + { "uid_t" "f_owner" } + { "u_int32_t" "f_ctime" } + { { "u_int32_t" 3 } " f_spare" } + { { "char" MFSNAMELEN } "f_fstypename" } + { { "char" MNAMELEN } "f_mntonname" } + { { "char" MNAMELEN } "f_mntfromname" } + { { "char" 512 } "mount_info" } ; + ! { "mount_info" "mount_info" } ; diff --git a/basis/unix/statfs/openbsd/64/authors.txt b/basis/unix/statfs/openbsd/64/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/unix/statfs/openbsd/64/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/unix/statfs/openbsd/64/tags.txt b/basis/unix/statfs/openbsd/64/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/statfs/openbsd/64/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/statfs/openbsd/authors.txt b/basis/unix/statfs/openbsd/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/unix/statfs/openbsd/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/unix/statfs/openbsd/openbsd.factor b/basis/unix/statfs/openbsd/openbsd.factor new file mode 100644 index 0000000000..a64b60a078 --- /dev/null +++ b/basis/unix/statfs/openbsd/openbsd.factor @@ -0,0 +1,52 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.syntax accessors combinators kernel io.files +unix.types math system io.backend alien.c-types unix ; +IN: unix.statfs.openbsd + +C-STRUCT: statvfs + { "ulong" "f_bsize" } + { "ulong" "f_frsize" } + { "fsblkcnt_t" "f_blocks" } + { "fsblkcnt_t" "f_bfree" } + { "fsblkcnt_t" "f_bavail" } + { "fsfilcnt_t" "f_files" } + { "fsfilcnt_t" "f_ffree" } + { "fsfilcnt_t" "f_favail" } + { "ulong" "f_fsid" } + { "ulong" "f_flag" } + { "ulong" "f_namemax" } ; + +: ST_RDONLY 1 ; inline +: ST_NOSUID 2 ; inline + +FUNCTION: int statvfs ( char* path, statvfs* buf ) ; + +TUPLE: openbsd-file-system-info < file-system-info +bsize frsize blocks bfree bavail files ffree favail +fsid flag namemax ; + +M: openbsd >file-system-info ( struct -- statfs ) + [ \ openbsd-file-system-info new ] dip + { + [ + [ statvfs-f_bsize ] + [ statvfs-f_bavail ] bi * >>free-space + ] + [ statvfs-f_bsize >>bsize ] + [ statvfs-f_frsize >>frsize ] + [ statvfs-f_blocks >>blocks ] + [ statvfs-f_bfree >>bfree ] + [ statvfs-f_bavail >>bavail ] + [ statvfs-f_files >>files ] + [ statvfs-f_ffree >>ffree ] + [ statvfs-f_favail >>favail ] + [ statvfs-f_fsid >>fsid ] + [ statvfs-f_flag >>flag ] + [ statvfs-f_namemax >>namemax ] + } cleave ; + +M: openbsd file-system-info ( path -- byte-array ) + normalize-path + "statvfs" tuck statvfs io-error + >file-system-info ; diff --git a/basis/unix/statfs/openbsd/tags.txt b/basis/unix/statfs/openbsd/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/statfs/openbsd/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/statfs/statfs-tests.factor b/basis/unix/statfs/statfs-tests.factor new file mode 100644 index 0000000000..39bc77fc87 --- /dev/null +++ b/basis/unix/statfs/statfs-tests.factor @@ -0,0 +1,4 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test unix.statfs ; +IN: unix.statfs.tests diff --git a/basis/unix/statfs/statfs.factor b/basis/unix/statfs/statfs.factor new file mode 100644 index 0000000000..f00ffe77cd --- /dev/null +++ b/basis/unix/statfs/statfs.factor @@ -0,0 +1,33 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: sequences system vocabs.loader combinators accessors +kernel math.order sorting ; +IN: unix.statfs + +TUPLE: mounted block-size io-size blocks blocks-free +blocks-available files files-free file-system-id owner type +flags filesystem-subtype file-system-type-name mount-on +mount-from ; + +HOOK: mounted* os ( -- array ) +HOOK: mounted-struct>mounted os ( byte-array -- mounted ) + +TUPLE: file-system-info root-directory total-free-size total-size ; + +HOOK: >file-system-info os ( struct -- statfs ) + +: mounted ( -- array ) + mounted* [ mounted-struct>mounted ] map ; + +: mounted-drive ( path -- mounted/f ) + mounted + [ [ mount-on>> ] bi@ <=> ] sort + [ mount-on>> head? ] with find nip ; + +os { + { linux [ "unix.statfs.linux" require ] } + { macosx [ "unix.statfs.macosx" require ] } + { freebsd [ "unix.statfs.freebsd" require ] } + { netbsd [ "unix.statfs.netbsd" require ] } + { openbsd [ "unix.statfs.openbsd" require ] } +} case diff --git a/basis/unix/statfs/tags.txt b/basis/unix/statfs/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/statfs/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/types/linux/linux.factor b/basis/unix/types/linux/linux.factor index 8822366a3a..bf5d4b7f1d 100644 --- a/basis/unix/types/linux/linux.factor +++ b/basis/unix/types/linux/linux.factor @@ -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,21 @@ 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 \ No newline at end of file +TYPEDEF: __slongword_type time_t + +TYPEDEF: ssize_t __SWORD_TYPE +TYPEDEF: ulonglong __fsblkcnt64_t +TYPEDEF: ulonglong __fsfilcnt64_t diff --git a/basis/unix/types/netbsd/netbsd.factor b/basis/unix/types/netbsd/netbsd.factor index 5b54928d95..b5b0ffe661 100644 --- a/basis/unix/types/netbsd/netbsd.factor +++ b/basis/unix/types/netbsd/netbsd.factor @@ -3,24 +3,12 @@ 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 TYPEDEF: __uint32_t nlink_t TYPEDEF: __uint32_t uid_t +TYPEDEF: __uint32_t __uid_t TYPEDEF: __uint32_t gid_t TYPEDEF: __int64_t off_t TYPEDEF: __int64_t blkcnt_t diff --git a/basis/unix/types/openbsd/openbsd.factor b/basis/unix/types/openbsd/openbsd.factor index a07e6f1c6a..8938afa936 100644 --- a/basis/unix/types/openbsd/openbsd.factor +++ b/basis/unix/types/openbsd/openbsd.factor @@ -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 diff --git a/basis/unix/types/types.factor b/basis/unix/types/types.factor index 69d07a07f1..51db6f5da0 100644 --- a/basis/unix/types/types.factor +++ b/basis/unix/types/types.factor @@ -6,6 +6,11 @@ TYPEDEF: void* caddr_t TYPEDEF: uint in_addr_t TYPEDEF: uint socklen_t +TYPEDEF: __uint64_t fsblkcnt_t +TYPEDEF: fsblkcnt_t __fsblkcnt_t +TYPEDEF: __uint64_t fsfilcnt_t +TYPEDEF: fsfilcnt_t __fsfilcnt_t + TYPEDEF: char int8_t TYPEDEF: short int16_t TYPEDEF: int int32_t @@ -16,6 +21,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 diff --git a/basis/unix/unix.factor b/basis/unix/unix.factor index 960115d1a6..2fcb83dc2c 100644 --- a/basis/unix/unix.factor +++ b/basis/unix/unix.factor @@ -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,9 @@ FUNCTION: int pipe ( int* filedes ) ; FUNCTION: void* popen ( char* command, char* type ) ; FUNCTION: ssize_t read ( int fd, void* buf, size_t nbytes ) ; +FUNCTION: dirent* readdir ( DIR* dirp ) ; +FUNCTION: int readdir_r ( void* dirp, dirent* entry, dirent** result ) ; + FUNCTION: ssize_t readlink ( char* path, char* buf, size_t bufsize ) ; : PATH_MAX 1024 ; inline @@ -171,6 +179,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 ) ; diff --git a/basis/unix/utilities/authors.txt b/basis/unix/utilities/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/unix/utilities/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/unix/utilities/utilities.factor b/basis/unix/utilities/utilities.factor new file mode 100644 index 0000000000..1f3a6bf78a --- /dev/null +++ b/basis/unix/utilities/utilities.factor @@ -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 ; + +: 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 ; diff --git a/basis/windows/errors/errors.factor b/basis/windows/errors/errors.factor index 2e4e709d43..bd938fdbad 100644 --- a/basis/windows/errors/errors.factor +++ b/basis/windows/errors/errors.factor @@ -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 - diff --git a/basis/windows/kernel32/kernel32.factor b/basis/windows/kernel32/kernel32.factor index 108e02cb46..dfac6a5236 100644 --- a/basis/windows/kernel32/kernel32.factor +++ b/basis/windows/kernel32/kernel32.factor @@ -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 @@ -927,17 +928,19 @@ FUNCTION: HANDLE GetCurrentThread ( ) ; ! FUNCTION: GetDevicePowerState ! FUNCTION: GetDiskFreeSpaceA ! FUNCTION: GetDiskFreeSpaceExA -! FUNCTION: GetDiskFreeSpaceExW +FUNCTION: BOOL GetDiskFreeSpaceExW ( LPCTSTR lpDirectoryName, PULARGE_INTEGER pFreeBytesAvailable, PULARGE_INTEGER lpTotalNumberOfBytes, PULARGE_INTEGER lpTotalNumberOfFreeBytes ) ; +ALIAS: GetDiskFreeSpaceEx GetDiskFreeSpaceExW ! FUNCTION: GetDiskFreeSpaceW ! FUNCTION: GetDllDirectoryA ! 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 +1421,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 diff --git a/basis/windows/types/types.factor b/basis/windows/types/types.factor index 3fef691741..0ac8409016 100644 --- a/basis/windows/types/types.factor +++ b/basis/windows/types/types.factor @@ -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 @@ -62,14 +62,16 @@ TYPEDEF: ulonglong ULONGLONG TYPEDEF: longlong LONG64 TYPEDEF: ulonglong DWORD64 TYPEDEF: longlong LARGE_INTEGER +TYPEDEF: ulonglong ULARGE_INTEGER TYPEDEF: LARGE_INTEGER* PLARGE_INTEGER +TYPEDEF: ULARGE_INTEGER* PULARGE_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 diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 1a6fa3c18a..62d4ec9273 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -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" } diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 577ad133e1..ecff54d9bc 100644 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -102,8 +102,8 @@ ERROR: bad-superclass class ; dup dup tuple-layout echelon>> [ tuple-instance? ] 2curry define-predicate ; -: superclass-size ( class -- n ) - superclasses but-last [ "slots" word-prop length ] sigma ; +: class-size ( class -- n ) + superclasses [ "slots" word-prop length ] sigma ; : (instance-check-quot) ( class -- quot ) [ @@ -138,16 +138,16 @@ ERROR: bad-superclass class ; : define-tuple-prototype ( class -- ) dup tuple-prototype "prototype" set-word-prop ; -: finalize-tuple-slots ( class slots -- slots ) - swap superclass-size 2 + finalize-slots ; +: prepare-slots ( slots superclass -- slots' ) + [ make-slots ] [ class-size 2 + ] bi* finalize-slots ; : define-tuple-slots ( class -- ) - dup dup "slots" word-prop finalize-tuple-slots + dup "slots" word-prop over superclass prepare-slots define-accessors ; : make-tuple-layout ( class -- layout ) [ ] - [ [ superclass-size ] [ "slots" word-prop length ] bi + ] + [ [ superclass class-size ] [ "slots" word-prop length ] bi + ] [ superclasses dup length 1- ] tri ; @@ -208,7 +208,6 @@ M: tuple-class update-class } cleave ; : define-new-tuple-class ( class superclass slots -- ) - make-slots [ drop f f tuple-class define-class ] [ nip "slots" set-word-prop ] [ 2drop update-classes ] @@ -241,16 +240,19 @@ M: tuple-class update-class : check-superclass ( superclass -- ) dup valid-superclass? [ bad-superclass ] unless drop ; +GENERIC# (define-tuple-class) 2 ( class superclass slots -- ) + PRIVATE> -GENERIC# define-tuple-class 2 ( class superclass slots -- ) - -M: word define-tuple-class +: define-tuple-class ( class superclass slots -- ) over check-superclass + over prepare-slots + (define-tuple-class) ; + +M: word (define-tuple-class) define-new-tuple-class ; -M: tuple-class define-tuple-class - over check-superclass +M: tuple-class (define-tuple-class) 3dup tuple-class-unchanged? [ 3drop ] [ redefine-tuple-class ] if ; diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index 8e32c100e0..9a85688202 100644 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -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 } @@ -80,6 +81,7 @@ ARTICLE: "fs-meta" "File metadata" { $subsection link-info } { $subsection exists? } { $subsection directory? } + "File types:" { $subsection "file-types" } ; @@ -304,23 +306,28 @@ 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: file-system-info +{ $values +{ "path" "a pathname string" } +{ "file-system-info" file-system-info } } +{ $description "Returns a platform-specific object describing the file-system that contains the path. The cross-platform slot is " { $slot "free-space" } "." } ; HELP: resource-path { $values { "path" "a pathname string" } { "newpath" "a pathname string" } } @@ -329,10 +336,6 @@ HELP: resource-path HELP: pathname { $class-description "Class of path name objects. Path name objects can be created by calling " { $link } "." } ; -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 } " and " { $link } " to prepare a pathname before passing it to underlying code." } ; diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index 0723096519..3104fcdb55 100644 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -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 diff --git a/core/io/files/files.factor b/core/io/files/files.factor index bc84aa5d21..1f6a48b50e 100644 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -153,7 +153,8 @@ PRIVATE> "." last-split1 nip ; ! File info -TUPLE: file-info type size permissions created modified accessed ; +TUPLE: file-info type size permissions created modified +accessed ; HOOK: file-info io-backend ( path -- info ) @@ -181,6 +182,12 @@ SYMBOL: +unknown+ : directory? ( file-info -- ? ) type>> +directory+ = ; +! File-system + +TUPLE: file-system-info mount-on free-space ; + +HOOK: file-system-info os ( path -- file-system-info ) + 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 +269,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 +311,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 +340,6 @@ C: 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 ; diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 786919bb68..61e10a9c00 100644 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -621,6 +621,14 @@ HELP: 2dip { $code "[ foo bar ] 2dip" } } ; +HELP: 3dip +{ $values { "obj1" object } { "obj2" object } { "obj3" object } { "quot" quotation } } +{ $description "Calls " { $snippet "quot" } " with " { $snippet "obj1" } ", " { $snippet "obj2" } " and " { $snippet "obj3" } " hidden on the retain stack." } +{ $notes "The following are equivalent:" + { $code ">r >r >r foo bar r> r> r>" } + { $code "[ foo bar ] 3dip" } +} ; + HELP: while { $values { "pred" "a quotation with stack effect " { $snippet "( -- ? )" } } { "body" "a quotation" } { "tail" "a quotation" } } { $description "Repeatedly calls " { $snippet "pred" } ". If it yields " { $link f } ", iteration stops, otherwise " { $snippet "body" } " is called. After iteration stops, " { $snippet "tail" } " is called." } @@ -815,6 +823,7 @@ ARTICLE: "slip-keep-combinators" "The dip, slip and keep combinators" "The dip combinators invoke the quotation at the top of the stack, hiding the values underneath:" { $subsection dip } { $subsection 2dip } +{ $subsection 3dip } "The slip combinators invoke a quotation further down on the stack. They are most useful for implementing other combinators:" { $subsection slip } { $subsection 2slip } diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index 55ed67e0fa..1402b4edf2 100644 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -59,6 +59,8 @@ DEFER: if : 2dip ( obj1 obj2 quot -- obj1 obj2 ) -rot 2slip ; inline +: 3dip ( obj1 obj2 obj3 quot -- obj1 obj2 obj3 ) -roll 3slip ; inline + ! Keepers : keep ( x quot -- x ) over slip ; inline diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index 0a4974607d..a75b97c040 100644 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -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 } related-words +{ reverse reverse-here } related-words HELP: ( 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" diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 63cc14d1d7..0fe47f0099 100644 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -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 ; 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> [ diff --git a/core/system/system-docs.factor b/core/system/system-docs.factor index 49886492ec..acd42b094f 100644 --- a/core/system/system-docs.factor +++ b/core/system/system-docs.factor @@ -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." } ; diff --git a/core/system/system-tests.factor b/core/system/system-tests.factor deleted file mode 100644 index c731a14725..0000000000 --- a/core/system/system-tests.factor +++ /dev/null @@ -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 "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 diff --git a/core/system/system.factor b/core/system/system.factor index 6c9d838fa4..66662a23e1 100644 --- a/core/system/system.factor +++ b/core/system/system.factor @@ -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) ; diff --git a/extra/benchmark/sockets/sockets.factor b/extra/benchmark/sockets/sockets.factor index 68e3a625a7..20c905156b 100755 --- a/extra/benchmark/sockets/sockets.factor +++ b/extra/benchmark/sockets/sockets.factor @@ -1,20 +1,25 @@ -USING: io.sockets io kernel math threads io.encodings.ascii -io.streams.duplex debugger tools.time prettyprint -concurrency.count-downs namespaces arrays continuations -destructors ; +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel math threads io io.sockets +io.encodings.ascii io.streams.duplex debugger tools.time +prettyprint concurrency.count-downs concurrency.promises +namespaces arrays continuations destructors ; IN: benchmark.sockets SYMBOL: counter +SYMBOL: port-promise +SYMBOL: server : number-of-requests 1000 ; -: server-addr ( -- addr ) "127.0.0.1" 7777 ; +: server-addr ( -- addr ) + "127.0.0.1" port-promise get ?promise ; : server-loop ( server -- ) dup accept drop [ [ read1 CHAR: x = [ - "server" get dispose + server get dispose ] [ number-of-requests [ read1 write1 flush ] times @@ -25,9 +30,11 @@ SYMBOL: counter : simple-server ( -- ) [ - server-addr ascii dup "server" set [ - server-loop - ] with-disposal + "127.0.0.1" 0 ascii + [ server set ] + [ addr>> port>> port-promise get fulfill ] + [ [ server-loop ] with-disposal ] + tri ] ignore-errors ; : simple-client ( -- ) @@ -47,6 +54,7 @@ SYMBOL: counter : clients ( n -- ) dup pprint " clients: " write [ + port-promise set dup 2 * counter set [ simple-server ] "Simple server" spawn drop yield yield diff --git a/extra/crypto/aes/aes-tests.factor b/extra/crypto/aes/aes-tests.factor new file mode 100644 index 0000000000..c76ee8cb14 --- /dev/null +++ b/extra/crypto/aes/aes-tests.factor @@ -0,0 +1,344 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel sequences grouping tools.test crypto.aes ; +IN: crypto.aes.tests + +[ { + HEX: 00 HEX: 01 HEX: 02 HEX: 04 HEX: 08 HEX: 10 + HEX: 20 HEX: 40 HEX: 80 HEX: 1b HEX: 36 +} ] [ rcon ] unit-test + +[ { + HEX: 63 HEX: 7c HEX: 77 HEX: 7b HEX: f2 HEX: 6b HEX: 6f HEX: c5 + HEX: 30 HEX: 01 HEX: 67 HEX: 2b HEX: fe HEX: d7 HEX: ab HEX: 76 + HEX: ca HEX: 82 HEX: c9 HEX: 7d HEX: fa HEX: 59 HEX: 47 HEX: f0 + HEX: ad HEX: d4 HEX: a2 HEX: af HEX: 9c HEX: a4 HEX: 72 HEX: c0 + HEX: b7 HEX: fd HEX: 93 HEX: 26 HEX: 36 HEX: 3f HEX: f7 HEX: cc + HEX: 34 HEX: a5 HEX: e5 HEX: f1 HEX: 71 HEX: d8 HEX: 31 HEX: 15 + HEX: 04 HEX: c7 HEX: 23 HEX: c3 HEX: 18 HEX: 96 HEX: 05 HEX: 9a + HEX: 07 HEX: 12 HEX: 80 HEX: e2 HEX: eb HEX: 27 HEX: b2 HEX: 75 + HEX: 09 HEX: 83 HEX: 2c HEX: 1a HEX: 1b HEX: 6e HEX: 5a HEX: a0 + HEX: 52 HEX: 3b HEX: d6 HEX: b3 HEX: 29 HEX: e3 HEX: 2f HEX: 84 + HEX: 53 HEX: d1 HEX: 00 HEX: ed HEX: 20 HEX: fc HEX: b1 HEX: 5b + HEX: 6a HEX: cb HEX: be HEX: 39 HEX: 4a HEX: 4c HEX: 58 HEX: cf + HEX: d0 HEX: ef HEX: aa HEX: fb HEX: 43 HEX: 4d HEX: 33 HEX: 85 + HEX: 45 HEX: f9 HEX: 02 HEX: 7f HEX: 50 HEX: 3c HEX: 9f HEX: a8 + HEX: 51 HEX: a3 HEX: 40 HEX: 8f HEX: 92 HEX: 9d HEX: 38 HEX: f5 + HEX: bc HEX: b6 HEX: da HEX: 21 HEX: 10 HEX: ff HEX: f3 HEX: d2 + HEX: cd HEX: 0c HEX: 13 HEX: ec HEX: 5f HEX: 97 HEX: 44 HEX: 17 + HEX: c4 HEX: a7 HEX: 7e HEX: 3d HEX: 64 HEX: 5d HEX: 19 HEX: 73 + HEX: 60 HEX: 81 HEX: 4f HEX: dc HEX: 22 HEX: 2a HEX: 90 HEX: 88 + HEX: 46 HEX: ee HEX: b8 HEX: 14 HEX: de HEX: 5e HEX: 0b HEX: db + HEX: e0 HEX: 32 HEX: 3a HEX: 0a HEX: 49 HEX: 06 HEX: 24 HEX: 5c + HEX: c2 HEX: d3 HEX: ac HEX: 62 HEX: 91 HEX: 95 HEX: e4 HEX: 79 + HEX: e7 HEX: c8 HEX: 37 HEX: 6d HEX: 8d HEX: d5 HEX: 4e HEX: a9 + HEX: 6c HEX: 56 HEX: f4 HEX: ea HEX: 65 HEX: 7a HEX: ae HEX: 08 + HEX: ba HEX: 78 HEX: 25 HEX: 2e HEX: 1c HEX: a6 HEX: b4 HEX: c6 + HEX: e8 HEX: dd HEX: 74 HEX: 1f HEX: 4b HEX: bd HEX: 8b HEX: 8a + HEX: 70 HEX: 3e HEX: b5 HEX: 66 HEX: 48 HEX: 03 HEX: f6 HEX: 0e + HEX: 61 HEX: 35 HEX: 57 HEX: b9 HEX: 86 HEX: c1 HEX: 1d HEX: 9e + HEX: e1 HEX: f8 HEX: 98 HEX: 11 HEX: 69 HEX: d9 HEX: 8e HEX: 94 + HEX: 9b HEX: 1e HEX: 87 HEX: e9 HEX: ce HEX: 55 HEX: 28 HEX: df + HEX: 8c HEX: a1 HEX: 89 HEX: 0d HEX: bf HEX: e6 HEX: 42 HEX: 68 + HEX: 41 HEX: 99 HEX: 2d HEX: 0f HEX: b0 HEX: 54 HEX: bb HEX: 16 +} ] [ sbox ] unit-test + +[ +{ + HEX: 52 HEX: 09 HEX: 6a HEX: d5 HEX: 30 HEX: 36 HEX: a5 HEX: 38 + HEX: bf HEX: 40 HEX: a3 HEX: 9e HEX: 81 HEX: f3 HEX: d7 HEX: fb + HEX: 7c HEX: e3 HEX: 39 HEX: 82 HEX: 9b HEX: 2f HEX: ff HEX: 87 + HEX: 34 HEX: 8e HEX: 43 HEX: 44 HEX: c4 HEX: de HEX: e9 HEX: cb + HEX: 54 HEX: 7b HEX: 94 HEX: 32 HEX: a6 HEX: c2 HEX: 23 HEX: 3d + HEX: ee HEX: 4c HEX: 95 HEX: 0b HEX: 42 HEX: fa HEX: c3 HEX: 4e + HEX: 08 HEX: 2e HEX: a1 HEX: 66 HEX: 28 HEX: d9 HEX: 24 HEX: b2 + HEX: 76 HEX: 5b HEX: a2 HEX: 49 HEX: 6d HEX: 8b HEX: d1 HEX: 25 + HEX: 72 HEX: f8 HEX: f6 HEX: 64 HEX: 86 HEX: 68 HEX: 98 HEX: 16 + HEX: d4 HEX: a4 HEX: 5c HEX: cc HEX: 5d HEX: 65 HEX: b6 HEX: 92 + HEX: 6c HEX: 70 HEX: 48 HEX: 50 HEX: fd HEX: ed HEX: b9 HEX: da + HEX: 5e HEX: 15 HEX: 46 HEX: 57 HEX: a7 HEX: 8d HEX: 9d HEX: 84 + HEX: 90 HEX: d8 HEX: ab HEX: 00 HEX: 8c HEX: bc HEX: d3 HEX: 0a + HEX: f7 HEX: e4 HEX: 58 HEX: 05 HEX: b8 HEX: b3 HEX: 45 HEX: 06 + HEX: d0 HEX: 2c HEX: 1e HEX: 8f HEX: ca HEX: 3f HEX: 0f HEX: 02 + HEX: c1 HEX: af HEX: bd HEX: 03 HEX: 01 HEX: 13 HEX: 8a HEX: 6b + HEX: 3a HEX: 91 HEX: 11 HEX: 41 HEX: 4f HEX: 67 HEX: dc HEX: ea + HEX: 97 HEX: f2 HEX: cf HEX: ce HEX: f0 HEX: b4 HEX: e6 HEX: 73 + HEX: 96 HEX: ac HEX: 74 HEX: 22 HEX: e7 HEX: ad HEX: 35 HEX: 85 + HEX: e2 HEX: f9 HEX: 37 HEX: e8 HEX: 1c HEX: 75 HEX: df HEX: 6e + HEX: 47 HEX: f1 HEX: 1a HEX: 71 HEX: 1d HEX: 29 HEX: c5 HEX: 89 + HEX: 6f HEX: b7 HEX: 62 HEX: 0e HEX: aa HEX: 18 HEX: be HEX: 1b + HEX: fc HEX: 56 HEX: 3e HEX: 4b HEX: c6 HEX: d2 HEX: 79 HEX: 20 + HEX: 9a HEX: db HEX: c0 HEX: fe HEX: 78 HEX: cd HEX: 5a HEX: f4 + HEX: 1f HEX: dd HEX: a8 HEX: 33 HEX: 88 HEX: 07 HEX: c7 HEX: 31 + HEX: b1 HEX: 12 HEX: 10 HEX: 59 HEX: 27 HEX: 80 HEX: ec HEX: 5f + HEX: 60 HEX: 51 HEX: 7f HEX: a9 HEX: 19 HEX: b5 HEX: 4a HEX: 0d + HEX: 2d HEX: e5 HEX: 7a HEX: 9f HEX: 93 HEX: c9 HEX: 9c HEX: ef + HEX: a0 HEX: e0 HEX: 3b HEX: 4d HEX: ae HEX: 2a HEX: f5 HEX: b0 + HEX: c8 HEX: eb HEX: bb HEX: 3c HEX: 83 HEX: 53 HEX: 99 HEX: 61 + HEX: 17 HEX: 2b HEX: 04 HEX: 7e HEX: ba HEX: 77 HEX: d6 HEX: 26 + HEX: e1 HEX: 69 HEX: 14 HEX: 63 HEX: 55 HEX: 21 HEX: 0c HEX: 7d +} +] [ inv-sbox ] unit-test + +[ { + HEX: 50a7f451 HEX: 5365417e HEX: c3a4171a HEX: 965e273a HEX: cb6bab3b HEX: f1459d1f HEX: ab58faac HEX: 9303e34b + HEX: 55fa3020 HEX: f66d76ad HEX: 9176cc88 HEX: 254c02f5 HEX: fcd7e54f HEX: d7cb2ac5 HEX: 80443526 HEX: 8fa362b5 + HEX: 495ab1de HEX: 671bba25 HEX: 980eea45 HEX: e1c0fe5d HEX: 02752fc3 HEX: 12f04c81 HEX: a397468d HEX: c6f9d36b + HEX: e75f8f03 HEX: 959c9215 HEX: eb7a6dbf HEX: da595295 HEX: 2d83bed4 HEX: d3217458 HEX: 2969e049 HEX: 44c8c98e + HEX: 6a89c275 HEX: 78798ef4 HEX: 6b3e5899 HEX: dd71b927 HEX: b64fe1be HEX: 17ad88f0 HEX: 66ac20c9 HEX: b43ace7d + HEX: 184adf63 HEX: 82311ae5 HEX: 60335197 HEX: 457f5362 HEX: e07764b1 HEX: 84ae6bbb HEX: 1ca081fe HEX: 942b08f9 + HEX: 58684870 HEX: 19fd458f HEX: 876cde94 HEX: b7f87b52 HEX: 23d373ab HEX: e2024b72 HEX: 578f1fe3 HEX: 2aab5566 + HEX: 0728ebb2 HEX: 03c2b52f HEX: 9a7bc586 HEX: a50837d3 HEX: f2872830 HEX: b2a5bf23 HEX: ba6a0302 HEX: 5c8216ed + HEX: 2b1ccf8a HEX: 92b479a7 HEX: f0f207f3 HEX: a1e2694e HEX: cdf4da65 HEX: d5be0506 HEX: 1f6234d1 HEX: 8afea6c4 + HEX: 9d532e34 HEX: a055f3a2 HEX: 32e18a05 HEX: 75ebf6a4 HEX: 39ec830b HEX: aaef6040 HEX: 069f715e HEX: 51106ebd + HEX: f98a213e HEX: 3d06dd96 HEX: ae053edd HEX: 46bde64d HEX: b58d5491 HEX: 055dc471 HEX: 6fd40604 HEX: ff155060 + HEX: 24fb9819 HEX: 97e9bdd6 HEX: cc434089 HEX: 779ed967 HEX: bd42e8b0 HEX: 888b8907 HEX: 385b19e7 HEX: dbeec879 + HEX: 470a7ca1 HEX: e90f427c HEX: c91e84f8 HEX: 00000000 HEX: 83868009 HEX: 48ed2b32 HEX: ac70111e HEX: 4e725a6c + HEX: fbff0efd HEX: 5638850f HEX: 1ed5ae3d HEX: 27392d36 HEX: 64d90f0a HEX: 21a65c68 HEX: d1545b9b HEX: 3a2e3624 + HEX: b1670a0c HEX: 0fe75793 HEX: d296eeb4 HEX: 9e919b1b HEX: 4fc5c080 HEX: a220dc61 HEX: 694b775a HEX: 161a121c + HEX: 0aba93e2 HEX: e52aa0c0 HEX: 43e0223c HEX: 1d171b12 HEX: 0b0d090e HEX: adc78bf2 HEX: b9a8b62d HEX: c8a91e14 + HEX: 8519f157 HEX: 4c0775af HEX: bbdd99ee HEX: fd607fa3 HEX: 9f2601f7 HEX: bcf5725c HEX: c53b6644 HEX: 347efb5b + HEX: 7629438b HEX: dcc623cb HEX: 68fcedb6 HEX: 63f1e4b8 HEX: cadc31d7 HEX: 10856342 HEX: 40229713 HEX: 2011c684 + HEX: 7d244a85 HEX: f83dbbd2 HEX: 1132f9ae HEX: 6da129c7 HEX: 4b2f9e1d HEX: f330b2dc HEX: ec52860d HEX: d0e3c177 + HEX: 6c16b32b HEX: 99b970a9 HEX: fa489411 HEX: 2264e947 HEX: c48cfca8 HEX: 1a3ff0a0 HEX: d82c7d56 HEX: ef903322 + HEX: c74e4987 HEX: c1d138d9 HEX: fea2ca8c HEX: 360bd498 HEX: cf81f5a6 HEX: 28de7aa5 HEX: 268eb7da HEX: a4bfad3f + HEX: e49d3a2c HEX: 0d927850 HEX: 9bcc5f6a HEX: 62467e54 HEX: c2138df6 HEX: e8b8d890 HEX: 5ef7392e HEX: f5afc382 + HEX: be805d9f HEX: 7c93d069 HEX: a92dd56f HEX: b31225cf HEX: 3b99acc8 HEX: a77d1810 HEX: 6e639ce8 HEX: 7bbb3bdb + HEX: 097826cd HEX: f418596e HEX: 01b79aec HEX: a89a4f83 HEX: 656e95e6 HEX: 7ee6ffaa HEX: 08cfbc21 HEX: e6e815ef + HEX: d99be7ba HEX: ce366f4a HEX: d4099fea HEX: d67cb029 HEX: afb2a431 HEX: 31233f2a HEX: 3094a5c6 HEX: c066a235 + HEX: 37bc4e74 HEX: a6ca82fc HEX: b0d090e0 HEX: 15d8a733 HEX: 4a9804f1 HEX: f7daec41 HEX: 0e50cd7f HEX: 2ff69117 + HEX: 8dd64d76 HEX: 4db0ef43 HEX: 544daacc HEX: df0496e4 HEX: e3b5d19e HEX: 1b886a4c HEX: b81f2cc1 HEX: 7f516546 + HEX: 04ea5e9d HEX: 5d358c01 HEX: 737487fa HEX: 2e410bfb HEX: 5a1d67b3 HEX: 52d2db92 HEX: 335610e9 HEX: 1347d66d + HEX: 8c61d79a HEX: 7a0ca137 HEX: 8e14f859 HEX: 893c13eb HEX: ee27a9ce HEX: 35c961b7 HEX: ede51ce1 HEX: 3cb1477a + HEX: 59dfd29c HEX: 3f73f255 HEX: 79ce1418 HEX: bf37c773 HEX: eacdf753 HEX: 5baafd5f HEX: 146f3ddf HEX: 86db4478 + HEX: 81f3afca HEX: 3ec468b9 HEX: 2c342438 HEX: 5f40a3c2 HEX: 72c31d16 HEX: 0c25e2bc HEX: 8b493c28 HEX: 41950dff + HEX: 7101a839 HEX: deb30c08 HEX: 9ce4b4d8 HEX: 90c15664 HEX: 6184cb7b HEX: 70b632d5 HEX: 745c6c48 HEX: 4257b8d0 + HEX: a7f45150 HEX: 65417e53 HEX: a4171ac3 HEX: 5e273a96 HEX: 6bab3bcb HEX: 459d1ff1 HEX: 58faacab HEX: 03e34b93 + HEX: fa302055 HEX: 6d76adf6 HEX: 76cc8891 HEX: 4c02f525 HEX: d7e54ffc HEX: cb2ac5d7 HEX: 44352680 HEX: a362b58f + HEX: 5ab1de49 HEX: 1bba2567 HEX: 0eea4598 HEX: c0fe5de1 HEX: 752fc302 HEX: f04c8112 HEX: 97468da3 HEX: f9d36bc6 + HEX: 5f8f03e7 HEX: 9c921595 HEX: 7a6dbfeb HEX: 595295da HEX: 83bed42d HEX: 217458d3 HEX: 69e04929 HEX: c8c98e44 + HEX: 89c2756a HEX: 798ef478 HEX: 3e58996b HEX: 71b927dd HEX: 4fe1beb6 HEX: ad88f017 HEX: ac20c966 HEX: 3ace7db4 + HEX: 4adf6318 HEX: 311ae582 HEX: 33519760 HEX: 7f536245 HEX: 7764b1e0 HEX: ae6bbb84 HEX: a081fe1c HEX: 2b08f994 + HEX: 68487058 HEX: fd458f19 HEX: 6cde9487 HEX: f87b52b7 HEX: d373ab23 HEX: 024b72e2 HEX: 8f1fe357 HEX: ab55662a + HEX: 28ebb207 HEX: c2b52f03 HEX: 7bc5869a HEX: 0837d3a5 HEX: 872830f2 HEX: a5bf23b2 HEX: 6a0302ba HEX: 8216ed5c + HEX: 1ccf8a2b HEX: b479a792 HEX: f207f3f0 HEX: e2694ea1 HEX: f4da65cd HEX: be0506d5 HEX: 6234d11f HEX: fea6c48a + HEX: 532e349d HEX: 55f3a2a0 HEX: e18a0532 HEX: ebf6a475 HEX: ec830b39 HEX: ef6040aa HEX: 9f715e06 HEX: 106ebd51 + HEX: 8a213ef9 HEX: 06dd963d HEX: 053eddae HEX: bde64d46 HEX: 8d5491b5 HEX: 5dc47105 HEX: d406046f HEX: 155060ff + HEX: fb981924 HEX: e9bdd697 HEX: 434089cc HEX: 9ed96777 HEX: 42e8b0bd HEX: 8b890788 HEX: 5b19e738 HEX: eec879db + HEX: 0a7ca147 HEX: 0f427ce9 HEX: 1e84f8c9 HEX: 00000000 HEX: 86800983 HEX: ed2b3248 HEX: 70111eac HEX: 725a6c4e + HEX: ff0efdfb HEX: 38850f56 HEX: d5ae3d1e HEX: 392d3627 HEX: d90f0a64 HEX: a65c6821 HEX: 545b9bd1 HEX: 2e36243a + HEX: 670a0cb1 HEX: e757930f HEX: 96eeb4d2 HEX: 919b1b9e HEX: c5c0804f HEX: 20dc61a2 HEX: 4b775a69 HEX: 1a121c16 + HEX: ba93e20a HEX: 2aa0c0e5 HEX: e0223c43 HEX: 171b121d HEX: 0d090e0b HEX: c78bf2ad HEX: a8b62db9 HEX: a91e14c8 + HEX: 19f15785 HEX: 0775af4c HEX: dd99eebb HEX: 607fa3fd HEX: 2601f79f HEX: f5725cbc HEX: 3b6644c5 HEX: 7efb5b34 + HEX: 29438b76 HEX: c623cbdc HEX: fcedb668 HEX: f1e4b863 HEX: dc31d7ca HEX: 85634210 HEX: 22971340 HEX: 11c68420 + HEX: 244a857d HEX: 3dbbd2f8 HEX: 32f9ae11 HEX: a129c76d HEX: 2f9e1d4b HEX: 30b2dcf3 HEX: 52860dec HEX: e3c177d0 + HEX: 16b32b6c HEX: b970a999 HEX: 489411fa HEX: 64e94722 HEX: 8cfca8c4 HEX: 3ff0a01a HEX: 2c7d56d8 HEX: 903322ef + HEX: 4e4987c7 HEX: d138d9c1 HEX: a2ca8cfe HEX: 0bd49836 HEX: 81f5a6cf HEX: de7aa528 HEX: 8eb7da26 HEX: bfad3fa4 + HEX: 9d3a2ce4 HEX: 9278500d HEX: cc5f6a9b HEX: 467e5462 HEX: 138df6c2 HEX: b8d890e8 HEX: f7392e5e HEX: afc382f5 + HEX: 805d9fbe HEX: 93d0697c HEX: 2dd56fa9 HEX: 1225cfb3 HEX: 99acc83b HEX: 7d1810a7 HEX: 639ce86e HEX: bb3bdb7b + HEX: 7826cd09 HEX: 18596ef4 HEX: b79aec01 HEX: 9a4f83a8 HEX: 6e95e665 HEX: e6ffaa7e HEX: cfbc2108 HEX: e815efe6 + HEX: 9be7bad9 HEX: 366f4ace HEX: 099fead4 HEX: 7cb029d6 HEX: b2a431af HEX: 233f2a31 HEX: 94a5c630 HEX: 66a235c0 + HEX: bc4e7437 HEX: ca82fca6 HEX: d090e0b0 HEX: d8a73315 HEX: 9804f14a HEX: daec41f7 HEX: 50cd7f0e HEX: f691172f + HEX: d64d768d HEX: b0ef434d HEX: 4daacc54 HEX: 0496e4df HEX: b5d19ee3 HEX: 886a4c1b HEX: 1f2cc1b8 HEX: 5165467f + HEX: ea5e9d04 HEX: 358c015d HEX: 7487fa73 HEX: 410bfb2e HEX: 1d67b35a HEX: d2db9252 HEX: 5610e933 HEX: 47d66d13 + HEX: 61d79a8c HEX: 0ca1377a HEX: 14f8598e HEX: 3c13eb89 HEX: 27a9ceee HEX: c961b735 HEX: e51ce1ed HEX: b1477a3c + HEX: dfd29c59 HEX: 73f2553f HEX: ce141879 HEX: 37c773bf HEX: cdf753ea HEX: aafd5f5b HEX: 6f3ddf14 HEX: db447886 + HEX: f3afca81 HEX: c468b93e HEX: 3424382c HEX: 40a3c25f HEX: c31d1672 HEX: 25e2bc0c HEX: 493c288b HEX: 950dff41 + HEX: 01a83971 HEX: b30c08de HEX: e4b4d89c HEX: c1566490 HEX: 84cb7b61 HEX: b632d570 HEX: 5c6c4874 HEX: 57b8d042 + HEX: f45150a7 HEX: 417e5365 HEX: 171ac3a4 HEX: 273a965e HEX: ab3bcb6b HEX: 9d1ff145 HEX: faacab58 HEX: e34b9303 + HEX: 302055fa HEX: 76adf66d HEX: cc889176 HEX: 02f5254c HEX: e54ffcd7 HEX: 2ac5d7cb HEX: 35268044 HEX: 62b58fa3 + HEX: b1de495a HEX: ba25671b HEX: ea45980e HEX: fe5de1c0 HEX: 2fc30275 HEX: 4c8112f0 HEX: 468da397 HEX: d36bc6f9 + HEX: 8f03e75f HEX: 9215959c HEX: 6dbfeb7a HEX: 5295da59 HEX: bed42d83 HEX: 7458d321 HEX: e0492969 HEX: c98e44c8 + HEX: c2756a89 HEX: 8ef47879 HEX: 58996b3e HEX: b927dd71 HEX: e1beb64f HEX: 88f017ad HEX: 20c966ac HEX: ce7db43a + HEX: df63184a HEX: 1ae58231 HEX: 51976033 HEX: 5362457f HEX: 64b1e077 HEX: 6bbb84ae HEX: 81fe1ca0 HEX: 08f9942b + HEX: 48705868 HEX: 458f19fd HEX: de94876c HEX: 7b52b7f8 HEX: 73ab23d3 HEX: 4b72e202 HEX: 1fe3578f HEX: 55662aab + HEX: ebb20728 HEX: b52f03c2 HEX: c5869a7b HEX: 37d3a508 HEX: 2830f287 HEX: bf23b2a5 HEX: 0302ba6a HEX: 16ed5c82 + HEX: cf8a2b1c HEX: 79a792b4 HEX: 07f3f0f2 HEX: 694ea1e2 HEX: da65cdf4 HEX: 0506d5be HEX: 34d11f62 HEX: a6c48afe + HEX: 2e349d53 HEX: f3a2a055 HEX: 8a0532e1 HEX: f6a475eb HEX: 830b39ec HEX: 6040aaef HEX: 715e069f HEX: 6ebd5110 + HEX: 213ef98a HEX: dd963d06 HEX: 3eddae05 HEX: e64d46bd HEX: 5491b58d HEX: c471055d HEX: 06046fd4 HEX: 5060ff15 + HEX: 981924fb HEX: bdd697e9 HEX: 4089cc43 HEX: d967779e HEX: e8b0bd42 HEX: 8907888b HEX: 19e7385b HEX: c879dbee + HEX: 7ca1470a HEX: 427ce90f HEX: 84f8c91e HEX: 00000000 HEX: 80098386 HEX: 2b3248ed HEX: 111eac70 HEX: 5a6c4e72 + HEX: 0efdfbff HEX: 850f5638 HEX: ae3d1ed5 HEX: 2d362739 HEX: 0f0a64d9 HEX: 5c6821a6 HEX: 5b9bd154 HEX: 36243a2e + HEX: 0a0cb167 HEX: 57930fe7 HEX: eeb4d296 HEX: 9b1b9e91 HEX: c0804fc5 HEX: dc61a220 HEX: 775a694b HEX: 121c161a + HEX: 93e20aba HEX: a0c0e52a HEX: 223c43e0 HEX: 1b121d17 HEX: 090e0b0d HEX: 8bf2adc7 HEX: b62db9a8 HEX: 1e14c8a9 + HEX: f1578519 HEX: 75af4c07 HEX: 99eebbdd HEX: 7fa3fd60 HEX: 01f79f26 HEX: 725cbcf5 HEX: 6644c53b HEX: fb5b347e + HEX: 438b7629 HEX: 23cbdcc6 HEX: edb668fc HEX: e4b863f1 HEX: 31d7cadc HEX: 63421085 HEX: 97134022 HEX: c6842011 + HEX: 4a857d24 HEX: bbd2f83d HEX: f9ae1132 HEX: 29c76da1 HEX: 9e1d4b2f HEX: b2dcf330 HEX: 860dec52 HEX: c177d0e3 + HEX: b32b6c16 HEX: 70a999b9 HEX: 9411fa48 HEX: e9472264 HEX: fca8c48c HEX: f0a01a3f HEX: 7d56d82c HEX: 3322ef90 + HEX: 4987c74e HEX: 38d9c1d1 HEX: ca8cfea2 HEX: d498360b HEX: f5a6cf81 HEX: 7aa528de HEX: b7da268e HEX: ad3fa4bf + HEX: 3a2ce49d HEX: 78500d92 HEX: 5f6a9bcc HEX: 7e546246 HEX: 8df6c213 HEX: d890e8b8 HEX: 392e5ef7 HEX: c382f5af + HEX: 5d9fbe80 HEX: d0697c93 HEX: d56fa92d HEX: 25cfb312 HEX: acc83b99 HEX: 1810a77d HEX: 9ce86e63 HEX: 3bdb7bbb + HEX: 26cd0978 HEX: 596ef418 HEX: 9aec01b7 HEX: 4f83a89a HEX: 95e6656e HEX: ffaa7ee6 HEX: bc2108cf HEX: 15efe6e8 + HEX: e7bad99b HEX: 6f4ace36 HEX: 9fead409 HEX: b029d67c HEX: a431afb2 HEX: 3f2a3123 HEX: a5c63094 HEX: a235c066 + HEX: 4e7437bc HEX: 82fca6ca HEX: 90e0b0d0 HEX: a73315d8 HEX: 04f14a98 HEX: ec41f7da HEX: cd7f0e50 HEX: 91172ff6 + HEX: 4d768dd6 HEX: ef434db0 HEX: aacc544d HEX: 96e4df04 HEX: d19ee3b5 HEX: 6a4c1b88 HEX: 2cc1b81f HEX: 65467f51 + HEX: 5e9d04ea HEX: 8c015d35 HEX: 87fa7374 HEX: 0bfb2e41 HEX: 67b35a1d HEX: db9252d2 HEX: 10e93356 HEX: d66d1347 + HEX: d79a8c61 HEX: a1377a0c HEX: f8598e14 HEX: 13eb893c HEX: a9ceee27 HEX: 61b735c9 HEX: 1ce1ede5 HEX: 477a3cb1 + HEX: d29c59df HEX: f2553f73 HEX: 141879ce HEX: c773bf37 HEX: f753eacd HEX: fd5f5baa HEX: 3ddf146f HEX: 447886db + HEX: afca81f3 HEX: 68b93ec4 HEX: 24382c34 HEX: a3c25f40 HEX: 1d1672c3 HEX: e2bc0c25 HEX: 3c288b49 HEX: 0dff4195 + HEX: a8397101 HEX: 0c08deb3 HEX: b4d89ce4 HEX: 566490c1 HEX: cb7b6184 HEX: 32d570b6 HEX: 6c48745c HEX: b8d04257 + HEX: 5150a7f4 HEX: 7e536541 HEX: 1ac3a417 HEX: 3a965e27 HEX: 3bcb6bab HEX: 1ff1459d HEX: acab58fa HEX: 4b9303e3 + HEX: 2055fa30 HEX: adf66d76 HEX: 889176cc HEX: f5254c02 HEX: 4ffcd7e5 HEX: c5d7cb2a HEX: 26804435 HEX: b58fa362 + HEX: de495ab1 HEX: 25671bba HEX: 45980eea HEX: 5de1c0fe HEX: c302752f HEX: 8112f04c HEX: 8da39746 HEX: 6bc6f9d3 + HEX: 03e75f8f HEX: 15959c92 HEX: bfeb7a6d HEX: 95da5952 HEX: d42d83be HEX: 58d32174 HEX: 492969e0 HEX: 8e44c8c9 + HEX: 756a89c2 HEX: f478798e HEX: 996b3e58 HEX: 27dd71b9 HEX: beb64fe1 HEX: f017ad88 HEX: c966ac20 HEX: 7db43ace + HEX: 63184adf HEX: e582311a HEX: 97603351 HEX: 62457f53 HEX: b1e07764 HEX: bb84ae6b HEX: fe1ca081 HEX: f9942b08 + HEX: 70586848 HEX: 8f19fd45 HEX: 94876cde HEX: 52b7f87b HEX: ab23d373 HEX: 72e2024b HEX: e3578f1f HEX: 662aab55 + HEX: b20728eb HEX: 2f03c2b5 HEX: 869a7bc5 HEX: d3a50837 HEX: 30f28728 HEX: 23b2a5bf HEX: 02ba6a03 HEX: ed5c8216 + HEX: 8a2b1ccf HEX: a792b479 HEX: f3f0f207 HEX: 4ea1e269 HEX: 65cdf4da HEX: 06d5be05 HEX: d11f6234 HEX: c48afea6 + HEX: 349d532e HEX: a2a055f3 HEX: 0532e18a HEX: a475ebf6 HEX: 0b39ec83 HEX: 40aaef60 HEX: 5e069f71 HEX: bd51106e + HEX: 3ef98a21 HEX: 963d06dd HEX: ddae053e HEX: 4d46bde6 HEX: 91b58d54 HEX: 71055dc4 HEX: 046fd406 HEX: 60ff1550 + HEX: 1924fb98 HEX: d697e9bd HEX: 89cc4340 HEX: 67779ed9 HEX: b0bd42e8 HEX: 07888b89 HEX: e7385b19 HEX: 79dbeec8 + HEX: a1470a7c HEX: 7ce90f42 HEX: f8c91e84 HEX: 00000000 HEX: 09838680 HEX: 3248ed2b HEX: 1eac7011 HEX: 6c4e725a + HEX: fdfbff0e HEX: 0f563885 HEX: 3d1ed5ae HEX: 3627392d HEX: 0a64d90f HEX: 6821a65c HEX: 9bd1545b HEX: 243a2e36 + HEX: 0cb1670a HEX: 930fe757 HEX: b4d296ee HEX: 1b9e919b HEX: 804fc5c0 HEX: 61a220dc HEX: 5a694b77 HEX: 1c161a12 + HEX: e20aba93 HEX: c0e52aa0 HEX: 3c43e022 HEX: 121d171b HEX: 0e0b0d09 HEX: f2adc78b HEX: 2db9a8b6 HEX: 14c8a91e + HEX: 578519f1 HEX: af4c0775 HEX: eebbdd99 HEX: a3fd607f HEX: f79f2601 HEX: 5cbcf572 HEX: 44c53b66 HEX: 5b347efb + HEX: 8b762943 HEX: cbdcc623 HEX: b668fced HEX: b863f1e4 HEX: d7cadc31 HEX: 42108563 HEX: 13402297 HEX: 842011c6 + HEX: 857d244a HEX: d2f83dbb HEX: ae1132f9 HEX: c76da129 HEX: 1d4b2f9e HEX: dcf330b2 HEX: 0dec5286 HEX: 77d0e3c1 + HEX: 2b6c16b3 HEX: a999b970 HEX: 11fa4894 HEX: 472264e9 HEX: a8c48cfc HEX: a01a3ff0 HEX: 56d82c7d HEX: 22ef9033 + HEX: 87c74e49 HEX: d9c1d138 HEX: 8cfea2ca HEX: 98360bd4 HEX: a6cf81f5 HEX: a528de7a HEX: da268eb7 HEX: 3fa4bfad + HEX: 2ce49d3a HEX: 500d9278 HEX: 6a9bcc5f HEX: 5462467e HEX: f6c2138d HEX: 90e8b8d8 HEX: 2e5ef739 HEX: 82f5afc3 + HEX: 9fbe805d HEX: 697c93d0 HEX: 6fa92dd5 HEX: cfb31225 HEX: c83b99ac HEX: 10a77d18 HEX: e86e639c HEX: db7bbb3b + HEX: cd097826 HEX: 6ef41859 HEX: ec01b79a HEX: 83a89a4f HEX: e6656e95 HEX: aa7ee6ff HEX: 2108cfbc HEX: efe6e815 + HEX: bad99be7 HEX: 4ace366f HEX: ead4099f HEX: 29d67cb0 HEX: 31afb2a4 HEX: 2a31233f HEX: c63094a5 HEX: 35c066a2 + HEX: 7437bc4e HEX: fca6ca82 HEX: e0b0d090 HEX: 3315d8a7 HEX: f14a9804 HEX: 41f7daec HEX: 7f0e50cd HEX: 172ff691 + HEX: 768dd64d HEX: 434db0ef HEX: cc544daa HEX: e4df0496 HEX: 9ee3b5d1 HEX: 4c1b886a HEX: c1b81f2c HEX: 467f5165 + HEX: 9d04ea5e HEX: 015d358c HEX: fa737487 HEX: fb2e410b HEX: b35a1d67 HEX: 9252d2db HEX: e9335610 HEX: 6d1347d6 + HEX: 9a8c61d7 HEX: 377a0ca1 HEX: 598e14f8 HEX: eb893c13 HEX: ceee27a9 HEX: b735c961 HEX: e1ede51c HEX: 7a3cb147 + HEX: 9c59dfd2 HEX: 553f73f2 HEX: 1879ce14 HEX: 73bf37c7 HEX: 53eacdf7 HEX: 5f5baafd HEX: df146f3d HEX: 7886db44 + HEX: ca81f3af HEX: b93ec468 HEX: 382c3424 HEX: c25f40a3 HEX: 1672c31d HEX: bc0c25e2 HEX: 288b493c HEX: ff41950d + HEX: 397101a8 HEX: 08deb30c HEX: d89ce4b4 HEX: 6490c156 HEX: 7b6184cb HEX: d570b632 HEX: 48745c6c HEX: d04257b8 +} ] [ d-table ] unit-test + +[ { +HEX: a56363c6 HEX: 847c7cf8 HEX: 997777ee HEX: 8d7b7bf6 HEX: 0df2f2ff HEX: bd6b6bd6 HEX: b16f6fde HEX: 54c5c591 +HEX: 50303060 HEX: 03010102 HEX: a96767ce HEX: 7d2b2b56 HEX: 19fefee7 HEX: 62d7d7b5 HEX: e6abab4d HEX: 9a7676ec +HEX: 45caca8f HEX: 9d82821f HEX: 40c9c989 HEX: 877d7dfa HEX: 15fafaef HEX: eb5959b2 HEX: c947478e HEX: 0bf0f0fb +HEX: ecadad41 HEX: 67d4d4b3 HEX: fda2a25f HEX: eaafaf45 HEX: bf9c9c23 HEX: f7a4a453 HEX: 967272e4 HEX: 5bc0c09b +HEX: c2b7b775 HEX: 1cfdfde1 HEX: ae93933d HEX: 6a26264c HEX: 5a36366c HEX: 413f3f7e HEX: 02f7f7f5 HEX: 4fcccc83 +HEX: 5c343468 HEX: f4a5a551 HEX: 34e5e5d1 HEX: 08f1f1f9 HEX: 937171e2 HEX: 73d8d8ab HEX: 53313162 HEX: 3f15152a +HEX: 0c040408 HEX: 52c7c795 HEX: 65232346 HEX: 5ec3c39d HEX: 28181830 HEX: a1969637 HEX: 0f05050a HEX: b59a9a2f +HEX: 0907070e HEX: 36121224 HEX: 9b80801b HEX: 3de2e2df HEX: 26ebebcd HEX: 6927274e HEX: cdb2b27f HEX: 9f7575ea +HEX: 1b090912 HEX: 9e83831d HEX: 742c2c58 HEX: 2e1a1a34 HEX: 2d1b1b36 HEX: b26e6edc HEX: ee5a5ab4 HEX: fba0a05b +HEX: f65252a4 HEX: 4d3b3b76 HEX: 61d6d6b7 HEX: ceb3b37d HEX: 7b292952 HEX: 3ee3e3dd HEX: 712f2f5e HEX: 97848413 +HEX: f55353a6 HEX: 68d1d1b9 HEX: 00000000 HEX: 2cededc1 HEX: 60202040 HEX: 1ffcfce3 HEX: c8b1b179 HEX: ed5b5bb6 +HEX: be6a6ad4 HEX: 46cbcb8d HEX: d9bebe67 HEX: 4b393972 HEX: de4a4a94 HEX: d44c4c98 HEX: e85858b0 HEX: 4acfcf85 +HEX: 6bd0d0bb HEX: 2aefefc5 HEX: e5aaaa4f HEX: 16fbfbed HEX: c5434386 HEX: d74d4d9a HEX: 55333366 HEX: 94858511 +HEX: cf45458a HEX: 10f9f9e9 HEX: 06020204 HEX: 817f7ffe HEX: f05050a0 HEX: 443c3c78 HEX: ba9f9f25 HEX: e3a8a84b +HEX: f35151a2 HEX: fea3a35d HEX: c0404080 HEX: 8a8f8f05 HEX: ad92923f HEX: bc9d9d21 HEX: 48383870 HEX: 04f5f5f1 +HEX: dfbcbc63 HEX: c1b6b677 HEX: 75dadaaf HEX: 63212142 HEX: 30101020 HEX: 1affffe5 HEX: 0ef3f3fd HEX: 6dd2d2bf +HEX: 4ccdcd81 HEX: 140c0c18 HEX: 35131326 HEX: 2fececc3 HEX: e15f5fbe HEX: a2979735 HEX: cc444488 HEX: 3917172e +HEX: 57c4c493 HEX: f2a7a755 HEX: 827e7efc HEX: 473d3d7a HEX: ac6464c8 HEX: e75d5dba HEX: 2b191932 HEX: 957373e6 +HEX: a06060c0 HEX: 98818119 HEX: d14f4f9e HEX: 7fdcdca3 HEX: 66222244 HEX: 7e2a2a54 HEX: ab90903b HEX: 8388880b +HEX: ca46468c HEX: 29eeeec7 HEX: d3b8b86b HEX: 3c141428 HEX: 79dedea7 HEX: e25e5ebc HEX: 1d0b0b16 HEX: 76dbdbad +HEX: 3be0e0db HEX: 56323264 HEX: 4e3a3a74 HEX: 1e0a0a14 HEX: db494992 HEX: 0a06060c HEX: 6c242448 HEX: e45c5cb8 +HEX: 5dc2c29f HEX: 6ed3d3bd HEX: efacac43 HEX: a66262c4 HEX: a8919139 HEX: a4959531 HEX: 37e4e4d3 HEX: 8b7979f2 +HEX: 32e7e7d5 HEX: 43c8c88b HEX: 5937376e HEX: b76d6dda HEX: 8c8d8d01 HEX: 64d5d5b1 HEX: d24e4e9c HEX: e0a9a949 +HEX: b46c6cd8 HEX: fa5656ac HEX: 07f4f4f3 HEX: 25eaeacf HEX: af6565ca HEX: 8e7a7af4 HEX: e9aeae47 HEX: 18080810 +HEX: d5baba6f HEX: 887878f0 HEX: 6f25254a HEX: 722e2e5c HEX: 241c1c38 HEX: f1a6a657 HEX: c7b4b473 HEX: 51c6c697 +HEX: 23e8e8cb HEX: 7cdddda1 HEX: 9c7474e8 HEX: 211f1f3e HEX: dd4b4b96 HEX: dcbdbd61 HEX: 868b8b0d HEX: 858a8a0f +HEX: 907070e0 HEX: 423e3e7c HEX: c4b5b571 HEX: aa6666cc HEX: d8484890 HEX: 05030306 HEX: 01f6f6f7 HEX: 120e0e1c +HEX: a36161c2 HEX: 5f35356a HEX: f95757ae HEX: d0b9b969 HEX: 91868617 HEX: 58c1c199 HEX: 271d1d3a HEX: b99e9e27 +HEX: 38e1e1d9 HEX: 13f8f8eb HEX: b398982b HEX: 33111122 HEX: bb6969d2 HEX: 70d9d9a9 HEX: 898e8e07 HEX: a7949433 +HEX: b69b9b2d HEX: 221e1e3c HEX: 92878715 HEX: 20e9e9c9 HEX: 49cece87 HEX: ff5555aa HEX: 78282850 HEX: 7adfdfa5 +HEX: 8f8c8c03 HEX: f8a1a159 HEX: 80898909 HEX: 170d0d1a HEX: dabfbf65 HEX: 31e6e6d7 HEX: c6424284 HEX: b86868d0 +HEX: c3414182 HEX: b0999929 HEX: 772d2d5a HEX: 110f0f1e HEX: cbb0b07b HEX: fc5454a8 HEX: d6bbbb6d HEX: 3a16162c +HEX: 6363c6a5 HEX: 7c7cf884 HEX: 7777ee99 HEX: 7b7bf68d HEX: f2f2ff0d HEX: 6b6bd6bd HEX: 6f6fdeb1 HEX: c5c59154 +HEX: 30306050 HEX: 01010203 HEX: 6767cea9 HEX: 2b2b567d HEX: fefee719 HEX: d7d7b562 HEX: abab4de6 HEX: 7676ec9a +HEX: caca8f45 HEX: 82821f9d HEX: c9c98940 HEX: 7d7dfa87 HEX: fafaef15 HEX: 5959b2eb HEX: 47478ec9 HEX: f0f0fb0b +HEX: adad41ec HEX: d4d4b367 HEX: a2a25ffd HEX: afaf45ea HEX: 9c9c23bf HEX: a4a453f7 HEX: 7272e496 HEX: c0c09b5b +HEX: b7b775c2 HEX: fdfde11c HEX: 93933dae HEX: 26264c6a HEX: 36366c5a HEX: 3f3f7e41 HEX: f7f7f502 HEX: cccc834f +HEX: 3434685c HEX: a5a551f4 HEX: e5e5d134 HEX: f1f1f908 HEX: 7171e293 HEX: d8d8ab73 HEX: 31316253 HEX: 15152a3f +HEX: 0404080c HEX: c7c79552 HEX: 23234665 HEX: c3c39d5e HEX: 18183028 HEX: 969637a1 HEX: 05050a0f HEX: 9a9a2fb5 +HEX: 07070e09 HEX: 12122436 HEX: 80801b9b HEX: e2e2df3d HEX: ebebcd26 HEX: 27274e69 HEX: b2b27fcd HEX: 7575ea9f +HEX: 0909121b HEX: 83831d9e HEX: 2c2c5874 HEX: 1a1a342e HEX: 1b1b362d HEX: 6e6edcb2 HEX: 5a5ab4ee HEX: a0a05bfb +HEX: 5252a4f6 HEX: 3b3b764d HEX: d6d6b761 HEX: b3b37dce HEX: 2929527b HEX: e3e3dd3e HEX: 2f2f5e71 HEX: 84841397 +HEX: 5353a6f5 HEX: d1d1b968 HEX: 00000000 HEX: ededc12c HEX: 20204060 HEX: fcfce31f HEX: b1b179c8 HEX: 5b5bb6ed +HEX: 6a6ad4be HEX: cbcb8d46 HEX: bebe67d9 HEX: 3939724b HEX: 4a4a94de HEX: 4c4c98d4 HEX: 5858b0e8 HEX: cfcf854a +HEX: d0d0bb6b HEX: efefc52a HEX: aaaa4fe5 HEX: fbfbed16 HEX: 434386c5 HEX: 4d4d9ad7 HEX: 33336655 HEX: 85851194 +HEX: 45458acf HEX: f9f9e910 HEX: 02020406 HEX: 7f7ffe81 HEX: 5050a0f0 HEX: 3c3c7844 HEX: 9f9f25ba HEX: a8a84be3 +HEX: 5151a2f3 HEX: a3a35dfe HEX: 404080c0 HEX: 8f8f058a HEX: 92923fad HEX: 9d9d21bc HEX: 38387048 HEX: f5f5f104 +HEX: bcbc63df HEX: b6b677c1 HEX: dadaaf75 HEX: 21214263 HEX: 10102030 HEX: ffffe51a HEX: f3f3fd0e HEX: d2d2bf6d +HEX: cdcd814c HEX: 0c0c1814 HEX: 13132635 HEX: ececc32f HEX: 5f5fbee1 HEX: 979735a2 HEX: 444488cc HEX: 17172e39 +HEX: c4c49357 HEX: a7a755f2 HEX: 7e7efc82 HEX: 3d3d7a47 HEX: 6464c8ac HEX: 5d5dbae7 HEX: 1919322b HEX: 7373e695 +HEX: 6060c0a0 HEX: 81811998 HEX: 4f4f9ed1 HEX: dcdca37f HEX: 22224466 HEX: 2a2a547e HEX: 90903bab HEX: 88880b83 +HEX: 46468cca HEX: eeeec729 HEX: b8b86bd3 HEX: 1414283c HEX: dedea779 HEX: 5e5ebce2 HEX: 0b0b161d HEX: dbdbad76 +HEX: e0e0db3b HEX: 32326456 HEX: 3a3a744e HEX: 0a0a141e HEX: 494992db HEX: 06060c0a HEX: 2424486c HEX: 5c5cb8e4 +HEX: c2c29f5d HEX: d3d3bd6e HEX: acac43ef HEX: 6262c4a6 HEX: 919139a8 HEX: 959531a4 HEX: e4e4d337 HEX: 7979f28b +HEX: e7e7d532 HEX: c8c88b43 HEX: 37376e59 HEX: 6d6ddab7 HEX: 8d8d018c HEX: d5d5b164 HEX: 4e4e9cd2 HEX: a9a949e0 +HEX: 6c6cd8b4 HEX: 5656acfa HEX: f4f4f307 HEX: eaeacf25 HEX: 6565caaf HEX: 7a7af48e HEX: aeae47e9 HEX: 08081018 +HEX: baba6fd5 HEX: 7878f088 HEX: 25254a6f HEX: 2e2e5c72 HEX: 1c1c3824 HEX: a6a657f1 HEX: b4b473c7 HEX: c6c69751 +HEX: e8e8cb23 HEX: dddda17c HEX: 7474e89c HEX: 1f1f3e21 HEX: 4b4b96dd HEX: bdbd61dc HEX: 8b8b0d86 HEX: 8a8a0f85 +HEX: 7070e090 HEX: 3e3e7c42 HEX: b5b571c4 HEX: 6666ccaa HEX: 484890d8 HEX: 03030605 HEX: f6f6f701 HEX: 0e0e1c12 +HEX: 6161c2a3 HEX: 35356a5f HEX: 5757aef9 HEX: b9b969d0 HEX: 86861791 HEX: c1c19958 HEX: 1d1d3a27 HEX: 9e9e27b9 +HEX: e1e1d938 HEX: f8f8eb13 HEX: 98982bb3 HEX: 11112233 HEX: 6969d2bb HEX: d9d9a970 HEX: 8e8e0789 HEX: 949433a7 +HEX: 9b9b2db6 HEX: 1e1e3c22 HEX: 87871592 HEX: e9e9c920 HEX: cece8749 HEX: 5555aaff HEX: 28285078 HEX: dfdfa57a +HEX: 8c8c038f HEX: a1a159f8 HEX: 89890980 HEX: 0d0d1a17 HEX: bfbf65da HEX: e6e6d731 HEX: 424284c6 HEX: 6868d0b8 +HEX: 414182c3 HEX: 999929b0 HEX: 2d2d5a77 HEX: 0f0f1e11 HEX: b0b07bcb HEX: 5454a8fc HEX: bbbb6dd6 HEX: 16162c3a +HEX: 63c6a563 HEX: 7cf8847c HEX: 77ee9977 HEX: 7bf68d7b HEX: f2ff0df2 HEX: 6bd6bd6b HEX: 6fdeb16f HEX: c59154c5 +HEX: 30605030 HEX: 01020301 HEX: 67cea967 HEX: 2b567d2b HEX: fee719fe HEX: d7b562d7 HEX: ab4de6ab HEX: 76ec9a76 +HEX: ca8f45ca HEX: 821f9d82 HEX: c98940c9 HEX: 7dfa877d HEX: faef15fa HEX: 59b2eb59 HEX: 478ec947 HEX: f0fb0bf0 +HEX: ad41ecad HEX: d4b367d4 HEX: a25ffda2 HEX: af45eaaf HEX: 9c23bf9c HEX: a453f7a4 HEX: 72e49672 HEX: c09b5bc0 +HEX: b775c2b7 HEX: fde11cfd HEX: 933dae93 HEX: 264c6a26 HEX: 366c5a36 HEX: 3f7e413f HEX: f7f502f7 HEX: cc834fcc +HEX: 34685c34 HEX: a551f4a5 HEX: e5d134e5 HEX: f1f908f1 HEX: 71e29371 HEX: d8ab73d8 HEX: 31625331 HEX: 152a3f15 +HEX: 04080c04 HEX: c79552c7 HEX: 23466523 HEX: c39d5ec3 HEX: 18302818 HEX: 9637a196 HEX: 050a0f05 HEX: 9a2fb59a +HEX: 070e0907 HEX: 12243612 HEX: 801b9b80 HEX: e2df3de2 HEX: ebcd26eb HEX: 274e6927 HEX: b27fcdb2 HEX: 75ea9f75 +HEX: 09121b09 HEX: 831d9e83 HEX: 2c58742c HEX: 1a342e1a HEX: 1b362d1b HEX: 6edcb26e HEX: 5ab4ee5a HEX: a05bfba0 +HEX: 52a4f652 HEX: 3b764d3b HEX: d6b761d6 HEX: b37dceb3 HEX: 29527b29 HEX: e3dd3ee3 HEX: 2f5e712f HEX: 84139784 +HEX: 53a6f553 HEX: d1b968d1 HEX: 00000000 HEX: edc12ced HEX: 20406020 HEX: fce31ffc HEX: b179c8b1 HEX: 5bb6ed5b +HEX: 6ad4be6a HEX: cb8d46cb HEX: be67d9be HEX: 39724b39 HEX: 4a94de4a HEX: 4c98d44c HEX: 58b0e858 HEX: cf854acf +HEX: d0bb6bd0 HEX: efc52aef HEX: aa4fe5aa HEX: fbed16fb HEX: 4386c543 HEX: 4d9ad74d HEX: 33665533 HEX: 85119485 +HEX: 458acf45 HEX: f9e910f9 HEX: 02040602 HEX: 7ffe817f HEX: 50a0f050 HEX: 3c78443c HEX: 9f25ba9f HEX: a84be3a8 +HEX: 51a2f351 HEX: a35dfea3 HEX: 4080c040 HEX: 8f058a8f HEX: 923fad92 HEX: 9d21bc9d HEX: 38704838 HEX: f5f104f5 +HEX: bc63dfbc HEX: b677c1b6 HEX: daaf75da HEX: 21426321 HEX: 10203010 HEX: ffe51aff HEX: f3fd0ef3 HEX: d2bf6dd2 +HEX: cd814ccd HEX: 0c18140c HEX: 13263513 HEX: ecc32fec HEX: 5fbee15f HEX: 9735a297 HEX: 4488cc44 HEX: 172e3917 +HEX: c49357c4 HEX: a755f2a7 HEX: 7efc827e HEX: 3d7a473d HEX: 64c8ac64 HEX: 5dbae75d HEX: 19322b19 HEX: 73e69573 +HEX: 60c0a060 HEX: 81199881 HEX: 4f9ed14f HEX: dca37fdc HEX: 22446622 HEX: 2a547e2a HEX: 903bab90 HEX: 880b8388 +HEX: 468cca46 HEX: eec729ee HEX: b86bd3b8 HEX: 14283c14 HEX: dea779de HEX: 5ebce25e HEX: 0b161d0b HEX: dbad76db +HEX: e0db3be0 HEX: 32645632 HEX: 3a744e3a HEX: 0a141e0a HEX: 4992db49 HEX: 060c0a06 HEX: 24486c24 HEX: 5cb8e45c +HEX: c29f5dc2 HEX: d3bd6ed3 HEX: ac43efac HEX: 62c4a662 HEX: 9139a891 HEX: 9531a495 HEX: e4d337e4 HEX: 79f28b79 +HEX: e7d532e7 HEX: c88b43c8 HEX: 376e5937 HEX: 6ddab76d HEX: 8d018c8d HEX: d5b164d5 HEX: 4e9cd24e HEX: a949e0a9 +HEX: 6cd8b46c HEX: 56acfa56 HEX: f4f307f4 HEX: eacf25ea HEX: 65caaf65 HEX: 7af48e7a HEX: ae47e9ae HEX: 08101808 +HEX: ba6fd5ba HEX: 78f08878 HEX: 254a6f25 HEX: 2e5c722e HEX: 1c38241c HEX: a657f1a6 HEX: b473c7b4 HEX: c69751c6 +HEX: e8cb23e8 HEX: dda17cdd HEX: 74e89c74 HEX: 1f3e211f HEX: 4b96dd4b HEX: bd61dcbd HEX: 8b0d868b HEX: 8a0f858a +HEX: 70e09070 HEX: 3e7c423e HEX: b571c4b5 HEX: 66ccaa66 HEX: 4890d848 HEX: 03060503 HEX: f6f701f6 HEX: 0e1c120e +HEX: 61c2a361 HEX: 356a5f35 HEX: 57aef957 HEX: b969d0b9 HEX: 86179186 HEX: c19958c1 HEX: 1d3a271d HEX: 9e27b99e +HEX: e1d938e1 HEX: f8eb13f8 HEX: 982bb398 HEX: 11223311 HEX: 69d2bb69 HEX: d9a970d9 HEX: 8e07898e HEX: 9433a794 +HEX: 9b2db69b HEX: 1e3c221e HEX: 87159287 HEX: e9c920e9 HEX: ce8749ce HEX: 55aaff55 HEX: 28507828 HEX: dfa57adf +HEX: 8c038f8c HEX: a159f8a1 HEX: 89098089 HEX: 0d1a170d HEX: bf65dabf HEX: e6d731e6 HEX: 4284c642 HEX: 68d0b868 +HEX: 4182c341 HEX: 9929b099 HEX: 2d5a772d HEX: 0f1e110f HEX: b07bcbb0 HEX: 54a8fc54 HEX: bb6dd6bb HEX: 162c3a16 +HEX: c6a56363 HEX: f8847c7c HEX: ee997777 HEX: f68d7b7b HEX: ff0df2f2 HEX: d6bd6b6b HEX: deb16f6f HEX: 9154c5c5 +HEX: 60503030 HEX: 02030101 HEX: cea96767 HEX: 567d2b2b HEX: e719fefe HEX: b562d7d7 HEX: 4de6abab HEX: ec9a7676 +HEX: 8f45caca HEX: 1f9d8282 HEX: 8940c9c9 HEX: fa877d7d HEX: ef15fafa HEX: b2eb5959 HEX: 8ec94747 HEX: fb0bf0f0 +HEX: 41ecadad HEX: b367d4d4 HEX: 5ffda2a2 HEX: 45eaafaf HEX: 23bf9c9c HEX: 53f7a4a4 HEX: e4967272 HEX: 9b5bc0c0 +HEX: 75c2b7b7 HEX: e11cfdfd HEX: 3dae9393 HEX: 4c6a2626 HEX: 6c5a3636 HEX: 7e413f3f HEX: f502f7f7 HEX: 834fcccc +HEX: 685c3434 HEX: 51f4a5a5 HEX: d134e5e5 HEX: f908f1f1 HEX: e2937171 HEX: ab73d8d8 HEX: 62533131 HEX: 2a3f1515 +HEX: 080c0404 HEX: 9552c7c7 HEX: 46652323 HEX: 9d5ec3c3 HEX: 30281818 HEX: 37a19696 HEX: 0a0f0505 HEX: 2fb59a9a +HEX: 0e090707 HEX: 24361212 HEX: 1b9b8080 HEX: df3de2e2 HEX: cd26ebeb HEX: 4e692727 HEX: 7fcdb2b2 HEX: ea9f7575 +HEX: 121b0909 HEX: 1d9e8383 HEX: 58742c2c HEX: 342e1a1a HEX: 362d1b1b HEX: dcb26e6e HEX: b4ee5a5a HEX: 5bfba0a0 +HEX: a4f65252 HEX: 764d3b3b HEX: b761d6d6 HEX: 7dceb3b3 HEX: 527b2929 HEX: dd3ee3e3 HEX: 5e712f2f HEX: 13978484 +HEX: a6f55353 HEX: b968d1d1 HEX: 00000000 HEX: c12ceded HEX: 40602020 HEX: e31ffcfc HEX: 79c8b1b1 HEX: b6ed5b5b +HEX: d4be6a6a HEX: 8d46cbcb HEX: 67d9bebe HEX: 724b3939 HEX: 94de4a4a HEX: 98d44c4c HEX: b0e85858 HEX: 854acfcf +HEX: bb6bd0d0 HEX: c52aefef HEX: 4fe5aaaa HEX: ed16fbfb HEX: 86c54343 HEX: 9ad74d4d HEX: 66553333 HEX: 11948585 +HEX: 8acf4545 HEX: e910f9f9 HEX: 04060202 HEX: fe817f7f HEX: a0f05050 HEX: 78443c3c HEX: 25ba9f9f HEX: 4be3a8a8 +HEX: a2f35151 HEX: 5dfea3a3 HEX: 80c04040 HEX: 058a8f8f HEX: 3fad9292 HEX: 21bc9d9d HEX: 70483838 HEX: f104f5f5 +HEX: 63dfbcbc HEX: 77c1b6b6 HEX: af75dada HEX: 42632121 HEX: 20301010 HEX: e51affff HEX: fd0ef3f3 HEX: bf6dd2d2 +HEX: 814ccdcd HEX: 18140c0c HEX: 26351313 HEX: c32fecec HEX: bee15f5f HEX: 35a29797 HEX: 88cc4444 HEX: 2e391717 +HEX: 9357c4c4 HEX: 55f2a7a7 HEX: fc827e7e HEX: 7a473d3d HEX: c8ac6464 HEX: bae75d5d HEX: 322b1919 HEX: e6957373 +HEX: c0a06060 HEX: 19988181 HEX: 9ed14f4f HEX: a37fdcdc HEX: 44662222 HEX: 547e2a2a HEX: 3bab9090 HEX: 0b838888 +HEX: 8cca4646 HEX: c729eeee HEX: 6bd3b8b8 HEX: 283c1414 HEX: a779dede HEX: bce25e5e HEX: 161d0b0b HEX: ad76dbdb +HEX: db3be0e0 HEX: 64563232 HEX: 744e3a3a HEX: 141e0a0a HEX: 92db4949 HEX: 0c0a0606 HEX: 486c2424 HEX: b8e45c5c +HEX: 9f5dc2c2 HEX: bd6ed3d3 HEX: 43efacac HEX: c4a66262 HEX: 39a89191 HEX: 31a49595 HEX: d337e4e4 HEX: f28b7979 +HEX: d532e7e7 HEX: 8b43c8c8 HEX: 6e593737 HEX: dab76d6d HEX: 018c8d8d HEX: b164d5d5 HEX: 9cd24e4e HEX: 49e0a9a9 +HEX: d8b46c6c HEX: acfa5656 HEX: f307f4f4 HEX: cf25eaea HEX: caaf6565 HEX: f48e7a7a HEX: 47e9aeae HEX: 10180808 +HEX: 6fd5baba HEX: f0887878 HEX: 4a6f2525 HEX: 5c722e2e HEX: 38241c1c HEX: 57f1a6a6 HEX: 73c7b4b4 HEX: 9751c6c6 +HEX: cb23e8e8 HEX: a17cdddd HEX: e89c7474 HEX: 3e211f1f HEX: 96dd4b4b HEX: 61dcbdbd HEX: 0d868b8b HEX: 0f858a8a +HEX: e0907070 HEX: 7c423e3e HEX: 71c4b5b5 HEX: ccaa6666 HEX: 90d84848 HEX: 06050303 HEX: f701f6f6 HEX: 1c120e0e +HEX: c2a36161 HEX: 6a5f3535 HEX: aef95757 HEX: 69d0b9b9 HEX: 17918686 HEX: 9958c1c1 HEX: 3a271d1d HEX: 27b99e9e +HEX: d938e1e1 HEX: eb13f8f8 HEX: 2bb39898 HEX: 22331111 HEX: d2bb6969 HEX: a970d9d9 HEX: 07898e8e HEX: 33a79494 +HEX: 2db69b9b HEX: 3c221e1e HEX: 15928787 HEX: c920e9e9 HEX: 8749cece HEX: aaff5555 HEX: 50782828 HEX: a57adfdf +HEX: 038f8c8c HEX: 59f8a1a1 HEX: 09808989 HEX: 1a170d0d HEX: 65dabfbf HEX: d731e6e6 HEX: 84c64242 HEX: d0b86868 +HEX: 82c34141 HEX: 29b09999 HEX: 5a772d2d HEX: 1e110f0f HEX: 7bcbb0b0 HEX: a8fc5454 HEX: 6dd6bbbb HEX: 2c3a1616 +} ] [ t-table ] unit-test + diff --git a/extra/crypto/aes/aes.factor b/extra/crypto/aes/aes.factor new file mode 100644 index 0000000000..cacfc5971a --- /dev/null +++ b/extra/crypto/aes/aes.factor @@ -0,0 +1,117 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays kernel math memoize sequences math.bitwise +locals ; +IN: crypto.aes + +: AES_BLOCK_SIZE 16 ; inline + +: sbox ( -- array ) +{ + HEX: 63 HEX: 7c HEX: 77 HEX: 7b HEX: f2 HEX: 6b HEX: 6f HEX: c5 + HEX: 30 HEX: 01 HEX: 67 HEX: 2b HEX: fe HEX: d7 HEX: ab HEX: 76 + HEX: ca HEX: 82 HEX: c9 HEX: 7d HEX: fa HEX: 59 HEX: 47 HEX: f0 + HEX: ad HEX: d4 HEX: a2 HEX: af HEX: 9c HEX: a4 HEX: 72 HEX: c0 + HEX: b7 HEX: fd HEX: 93 HEX: 26 HEX: 36 HEX: 3f HEX: f7 HEX: cc + HEX: 34 HEX: a5 HEX: e5 HEX: f1 HEX: 71 HEX: d8 HEX: 31 HEX: 15 + HEX: 04 HEX: c7 HEX: 23 HEX: c3 HEX: 18 HEX: 96 HEX: 05 HEX: 9a + HEX: 07 HEX: 12 HEX: 80 HEX: e2 HEX: eb HEX: 27 HEX: b2 HEX: 75 + HEX: 09 HEX: 83 HEX: 2c HEX: 1a HEX: 1b HEX: 6e HEX: 5a HEX: a0 + HEX: 52 HEX: 3b HEX: d6 HEX: b3 HEX: 29 HEX: e3 HEX: 2f HEX: 84 + HEX: 53 HEX: d1 HEX: 00 HEX: ed HEX: 20 HEX: fc HEX: b1 HEX: 5b + HEX: 6a HEX: cb HEX: be HEX: 39 HEX: 4a HEX: 4c HEX: 58 HEX: cf + HEX: d0 HEX: ef HEX: aa HEX: fb HEX: 43 HEX: 4d HEX: 33 HEX: 85 + HEX: 45 HEX: f9 HEX: 02 HEX: 7f HEX: 50 HEX: 3c HEX: 9f HEX: a8 + HEX: 51 HEX: a3 HEX: 40 HEX: 8f HEX: 92 HEX: 9d HEX: 38 HEX: f5 + HEX: bc HEX: b6 HEX: da HEX: 21 HEX: 10 HEX: ff HEX: f3 HEX: d2 + HEX: cd HEX: 0c HEX: 13 HEX: ec HEX: 5f HEX: 97 HEX: 44 HEX: 17 + HEX: c4 HEX: a7 HEX: 7e HEX: 3d HEX: 64 HEX: 5d HEX: 19 HEX: 73 + HEX: 60 HEX: 81 HEX: 4f HEX: dc HEX: 22 HEX: 2a HEX: 90 HEX: 88 + HEX: 46 HEX: ee HEX: b8 HEX: 14 HEX: de HEX: 5e HEX: 0b HEX: db + HEX: e0 HEX: 32 HEX: 3a HEX: 0a HEX: 49 HEX: 06 HEX: 24 HEX: 5c + HEX: c2 HEX: d3 HEX: ac HEX: 62 HEX: 91 HEX: 95 HEX: e4 HEX: 79 + HEX: e7 HEX: c8 HEX: 37 HEX: 6d HEX: 8d HEX: d5 HEX: 4e HEX: a9 + HEX: 6c HEX: 56 HEX: f4 HEX: ea HEX: 65 HEX: 7a HEX: ae HEX: 08 + HEX: ba HEX: 78 HEX: 25 HEX: 2e HEX: 1c HEX: a6 HEX: b4 HEX: c6 + HEX: e8 HEX: dd HEX: 74 HEX: 1f HEX: 4b HEX: bd HEX: 8b HEX: 8a + HEX: 70 HEX: 3e HEX: b5 HEX: 66 HEX: 48 HEX: 03 HEX: f6 HEX: 0e + HEX: 61 HEX: 35 HEX: 57 HEX: b9 HEX: 86 HEX: c1 HEX: 1d HEX: 9e + HEX: e1 HEX: f8 HEX: 98 HEX: 11 HEX: 69 HEX: d9 HEX: 8e HEX: 94 + HEX: 9b HEX: 1e HEX: 87 HEX: e9 HEX: ce HEX: 55 HEX: 28 HEX: df + HEX: 8c HEX: a1 HEX: 89 HEX: 0d HEX: bf HEX: e6 HEX: 42 HEX: 68 + HEX: 41 HEX: 99 HEX: 2d HEX: 0f HEX: b0 HEX: 54 HEX: bb HEX: 16 +} ; + +: inv-sbox ( -- array ) + 256 0 + dup 256 [ dup sbox nth rot set-nth ] with each ; + +: rcon ( -- array ) + { + HEX: 00 HEX: 01 HEX: 02 HEX: 04 HEX: 08 HEX: 10 + HEX: 20 HEX: 40 HEX: 80 HEX: 1b HEX: 36 + } ; + +: xtime ( x -- x' ) + [ 1 shift ] + [ HEX: 80 bitand 0 = 0 HEX: 1b ? ] bi bitxor 8 bits ; + +: ui32 ( a0 a1 a2 a3 -- a ) + [ 8 shift ] [ 16 shift ] [ 24 shift ] tri* + bitor bitor bitor 32 bits ; + +:: set-t ( T i -- ) + [let* | + a1 [ i sbox nth ] + a2 [ a1 xtime ] + a3 [ a1 a2 bitxor ] | + a2 a1 a1 a3 ui32 i T set-nth + a3 a2 a1 a1 ui32 i HEX: 100 + T set-nth + a1 a3 a2 a1 ui32 i HEX: 200 + T set-nth + a1 a1 a3 a2 ui32 i HEX: 300 + T set-nth + ] ; + + +MEMO:: t-table ( -- array ) + 1024 0 + dup 256 [ set-t ] with each ; + +:: set-d ( D i -- ) + [let* | + a1 [ i inv-sbox nth ] + a2 [ a1 xtime ] + a4 [ a2 xtime ] + a8 [ a4 xtime ] + a9 [ a8 a1 bitxor ] + ab [ a9 a2 bitxor ] + ad [ a9 a4 bitxor ] + ae [ a8 a4 a2 bitxor bitxor ] + | + ae a9 ad ab ui32 i D set-nth + ab ae a9 ad ui32 i HEX: 100 + D set-nth + ad ab ae a9 ui32 i HEX: 200 + D set-nth + a9 ad ab ae ui32 i HEX: 300 + D set-nth + ] ; + +MEMO:: d-table ( -- array ) + 1024 0 + dup 256 [ set-d ] with each ; + + +USE: multiline +/* +! : HT ( i x s -- + + +TUPLE: caes #rounds2 rkey ; +! rounds / 2, rkey is a byte-array 60 long +! key size is 16, 24, 32 bytes + +TUPLE: caescbc prev4 caes ; + + + +: aes-set-key-encode ( p key -- ) + + ; +*/ diff --git a/extra/crypto/aes/authors.txt b/extra/crypto/aes/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/crypto/aes/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/crypto/passwd-md5/authors.txt b/extra/crypto/passwd-md5/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/crypto/passwd-md5/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/crypto/passwd-md5/passwd-md5-docs.factor b/extra/crypto/passwd-md5/passwd-md5-docs.factor new file mode 100644 index 0000000000..eb8f3e74a9 --- /dev/null +++ b/extra/crypto/passwd-md5/passwd-md5-docs.factor @@ -0,0 +1,34 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax io.streams.string strings ; +IN: crypto.passwd-md5 + +HELP: authenticate-password +{ $values + { "shadow" string } { "password" string } + { "?" "a boolean" } } +{ $description "Encodes the provided password and compares it to the encoded password entry from a shadowed password file." } ; + +HELP: parse-shadow-password +{ $values + { "string" string } + { "magic" string } { "salt" string } { "password" string } } +{ $description "Splits a shadowed password entry into a magic string, a salt, and an encoded password string." } ; + +HELP: passwd-md5 +{ $values + { "magic" string } { "salt" string } { "password" string } + { "bytes" "an md5-shadowed password entry" } } +{ $description "Encodes the password with the given magic string and salt to an MD5-shadow password entry." } ; + +ARTICLE: "crypto.passwd-md5" "MD5 shadow passwords" +"The " { $vocab-link "crypto.passwd-md5" } " vocabulary can encode passwords for use in an MD5 shadow password file." $nl + +"Encoding a password:" +{ $subsection passwd-md5 } +"Parsing a shadowed password entry:" +{ $subsection parse-shadow-password } +"Authenticating against a shadowed password:" +{ $subsection authenticate-password } ; + +ABOUT: "crypto.passwd-md5" diff --git a/extra/crypto/passwd-md5/passwd-md5-tests.factor b/extra/crypto/passwd-md5/passwd-md5-tests.factor new file mode 100644 index 0000000000..a858d8dab5 --- /dev/null +++ b/extra/crypto/passwd-md5/passwd-md5-tests.factor @@ -0,0 +1,16 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test crypto.passwd-md5 ; +IN: crypto.passwd-md5.tests + + +[ "$1$npUpD5oQ$1.X7uXR2QG0FzPifVeZ2o1" ] +[ "$1$" "npUpD5oQ" "factor" passwd-md5 ] unit-test + +[ "$1$Kilak4kR$wlEr5Dv5DcdqPjKjQtt430" ] +[ + "$1$" + "Kilak4kR" + "longpassword12345678901234567890" + passwd-md5 +] unit-test diff --git a/extra/crypto/passwd-md5/passwd-md5.factor b/extra/crypto/passwd-md5/passwd-md5.factor new file mode 100644 index 0000000000..32a913ef23 --- /dev/null +++ b/extra/crypto/passwd-md5/passwd-md5.factor @@ -0,0 +1,47 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel base64 checksums.md5 symbols sequences checksums +locals prettyprint math math.bitwise grouping io combinators +fry make combinators.short-circuit math.functions splitting ; +IN: crypto.passwd-md5 + + + +:: passwd-md5 ( magic salt password -- bytes ) + [let* | final! [ password magic salt 3append + salt password tuck 3append md5 checksum-bytes + password length + [ 16 / ceiling swap concat ] keep + head-slice append + password [ length ] [ first ] bi + '[ [ CHAR: \0 _ ? , ] each-bit ] "" make append + md5 checksum-bytes ] | + 1000 [ + "" swap + { + [ 0 bit? password final ? append ] + [ 3 mod 0 > [ salt append ] when ] + [ 7 mod 0 > [ password append ] when ] + [ 0 bit? final password ? append ] + } cleave md5 checksum-bytes final! + ] each + + magic salt "$" 3append + { 12 0 6 13 1 7 14 2 8 15 3 9 5 4 10 } final nths 3 group + [ first3 [ 16 shift ] [ 8 shift ] bi* + + 4 to64 ] map concat + 11 final nth 2 to64 3append ] ; + +: parse-shadow-password ( string -- magic salt password ) + "$" split harvest first3 [ "$" tuck 3append ] 2dip ; + +: authenticate-password ( shadow password -- ? ) + '[ parse-shadow-password drop _ passwd-md5 ] keep = ; diff --git a/extra/ftp/ftp.factor b/extra/ftp/ftp.factor index b2b5ebc9aa..1fd97df6d5 100644 --- a/extra/ftp/ftp.factor +++ b/extra/ftp/ftp.factor @@ -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 ; diff --git a/extra/hardware-info/windows/ce/tags.txt b/extra/hardware-info/windows/ce/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/extra/hardware-info/windows/ce/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/extra/hardware-info/windows/nt/tags.txt b/extra/hardware-info/windows/nt/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/extra/hardware-info/windows/nt/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/extra/hexdump/hexdump-docs.factor b/extra/hexdump/hexdump-docs.factor index a83f64e8db..4278e92f0e 100644 --- a/extra/hexdump/hexdump-docs.factor +++ b/extra/hexdump/hexdump-docs.factor @@ -1,14 +1,14 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax kernel ; +USING: help.markup help.syntax kernel sequences strings ; IN: hexdump HELP: hexdump. -{ $values { "sequence" "a sequence" } } +{ $values { "seq" sequence } } { $description "Converts a sequence to its hexadecimal and ASCII representation sixteen characters at a time and writes it to standard out." } ; HELP: hexdump -{ $values { "sequence" "a sequence" } { "string" "a string" } } +{ $values { "seq" sequence } { "str" string } } { $description "Converts a sequence to its hexadecimal and ASCII representation sixteen characters at a time. Lines are separated by a newline character." } { $see-also hexdump. } ; diff --git a/extra/hexdump/hexdump.factor b/extra/hexdump/hexdump.factor index 618ed00802..5262755821 100644 --- a/extra/hexdump/hexdump.factor +++ b/extra/hexdump/hexdump.factor @@ -7,29 +7,30 @@ IN: hexdump hex write "h" write nl ; +: write-header ( len -- ) + "Length: " write + [ unparse write ", " write ] + [ >hex write "h" write nl ] bi ; -: offset. ( lineno -- ) +: write-offset ( lineno -- ) 16 * >hex 8 CHAR: 0 pad-left write "h: " write ; -: h-pad. ( digit -- ) +: write-hex-digit ( digit -- ) >hex 2 CHAR: 0 pad-left write ; -: line. ( str n -- ) - offset. - dup [ h-pad. " " write ] each +: write-hex-line ( str n -- ) + write-offset + dup [ write-hex-digit bl ] each 16 over length - 3 * CHAR: \s write [ dup printable? [ drop CHAR: . ] unless write1 ] each nl ; PRIVATE> -: hexdump ( sequence -- string ) +: hexdump ( seq -- str ) [ - dup length header. - 16 [ line. ] each-index + [ length write-header ] + [ 16 [ write-hex-line ] each-index ] bi ] with-string-writer ; -: hexdump. ( sequence -- ) - hexdump write ; +: hexdump. ( seq -- ) hexdump write ; diff --git a/extra/html/parser/analyzer/analyzer.factor b/extra/html/parser/analyzer/analyzer.factor index 095e3c3246..8d7a92b0d9 100755 --- a/extra/html/parser/analyzer/analyzer.factor +++ b/extra/html/parser/analyzer/analyzer.factor @@ -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 ; diff --git a/extra/io/paths/paths.factor b/extra/io/paths/paths.factor index 58b3518edd..8237e59a1b 100755 --- a/extra/io/paths/paths.factor +++ b/extra/io/paths/paths.factor @@ -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 ; diff --git a/extra/math/floating-point/authors.txt b/extra/math/floating-point/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/math/floating-point/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/math/floating-point/floating-point-tests.factor b/extra/math/floating-point/floating-point-tests.factor new file mode 100644 index 0000000000..2a60d30d02 --- /dev/null +++ b/extra/math/floating-point/floating-point-tests.factor @@ -0,0 +1,4 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test math.floating-point ; +IN: math.floating-point.tests diff --git a/extra/math/floating-point/floating-point.factor b/extra/math/floating-point/floating-point.factor new file mode 100644 index 0000000000..87767181cd --- /dev/null +++ b/extra/math/floating-point/floating-point.factor @@ -0,0 +1,32 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math sequences ; +IN: math.floating-point + +: float-sign ( float -- ? ) + float>bits -31 shift { 1 -1 } nth ; + +: double-sign ( float -- ? ) + double>bits -63 shift { 1 -1 } nth ; + +: float-exponent-bits ( float -- n ) + float>bits -23 shift 8 2^ 1- bitand ; + +: double-exponent-bits ( double -- n ) + double>bits -52 shift 11 2^ 1- bitand ; + +: float-mantissa-bits ( float -- n ) + float>bits 23 2^ 1- bitand ; + +: double-mantissa-bits ( double -- n ) + double>bits 52 2^ 1- bitand ; + +: float-e ( -- float ) 127 ; inline +: double-e ( -- float ) 1023 ; inline + +! : calculate-float ( S M E -- float ) + ! float-e - 2^ * * ; ! bits>float ; + +! : calculate-double ( S M E -- frac ) + ! double-e - 2^ swap 52 2^ /f 1+ * * ; + diff --git a/extra/roman/roman-docs.factor b/extra/roman/roman-docs.factor index a62e92ce08..87551635f1 100644 --- a/extra/roman/roman-docs.factor +++ b/extra/roman/roman-docs.factor @@ -43,3 +43,6 @@ HELP: roman/mod { $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } { "str4" "a string" } } { $description "Computes the quotient and remainder of two Roman numerals." } { $see-also roman* roman/i /mod } ; + +HELP: ROMAN: +{ $description "A parsing word that reads the next token and converts it to an integer." } ; diff --git a/extra/roman/roman-tests.factor b/extra/roman/roman-tests.factor index a15dcef354..82084e0b1f 100644 --- a/extra/roman/roman-tests.factor +++ b/extra/roman/roman-tests.factor @@ -36,3 +36,5 @@ USING: arrays kernel math roman roman.private sequences tools.test ; [ "i" ] [ "iii" "ii" roman/i ] unit-test [ "i" "ii" ] [ "v" "iii" roman/mod ] unit-test [ "iii" "iii" roman- ] must-fail + +[ 30 ] [ ROMAN: xxx ] unit-test diff --git a/extra/roman/roman.factor b/extra/roman/roman.factor index dcadb865f9..5ffdf67753 100644 --- a/extra/roman/roman.factor +++ b/extra/roman/roman.factor @@ -2,10 +2,11 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs kernel math math.order math.vectors namespaces make quotations sequences sequences.lib -sequences.private strings unicode.case ; +sequences.private strings unicode.case lexer parser ; IN: roman : >roman ( n -- str ) @@ -49,11 +51,13 @@ PRIVATE> ] map sum ; ( str1 str2 -- m n ) [ roman> ] bi@ ; : binary-roman-op ( str1 str2 quot -- str3 ) >r 2roman> r> call >roman ; inline + PRIVATE> : roman+ ( str1 str2 -- str3 ) @@ -70,3 +74,5 @@ PRIVATE> : roman/mod ( str1 str2 -- str3 str4 ) [ /mod ] binary-roman-op >r >roman r> ; + +: ROMAN: scan roman> parsed ; parsing diff --git a/extra/shell/shell.factor b/extra/shell/shell.factor index 0ed594602a..ae9b94ba0e 100644 --- a/extra/shell/shell.factor +++ b/extra/shell/shell.factor @@ -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 \ No newline at end of file +MAIN: ix diff --git a/extra/tetris/deploy.factor b/extra/tetris/deploy.factor index 57a5eda494..a21e592cc8 100755 --- a/extra/tetris/deploy.factor +++ b/extra/tetris/deploy.factor @@ -1,12 +1,15 @@ USING: tools.deploy.config ; -V{ +H{ { deploy-ui? t } - { deploy-io 1 } - { deploy-reflection 1 } { deploy-compiler? t } - { deploy-math? t } + { deploy-threads? t } { deploy-word-props? f } - { deploy-c-types? f } + { deploy-reflection 1 } { "stop-after-last-window?" t } + { deploy-random? t } + { deploy-io 2 } + { deploy-math? t } + { deploy-word-defs? f } + { deploy-c-types? f } { deploy-name "Tetris" } } diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor index 16c51a876b..b833cc8cc2 100644 --- a/extra/webapps/wiki/wiki.factor +++ b/extra/webapps/wiki/wiki.factor @@ -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 - 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 + swap >>content + swap >>title + "slava" >>author + now >>date + add-revision + ] [ 2drop ] if + ] each + ] with-directory-files ; diff --git a/unfinished/benchmark/richards/richards.factor b/unfinished/benchmark/richards/richards.factor new file mode 100644 index 0000000000..894948e44f --- /dev/null +++ b/unfinished/benchmark/richards/richards.factor @@ -0,0 +1,272 @@ +! Based on http://research.sun.com/people/mario/java_benchmarking/ +! Ported by Factor by Slava Pestov +! +! Based on original version written in BCPL by Dr Martin Richards +! in 1981 at Cambridge University Computer Laboratory, England +! Java version: Copyright (C) 1995 Sun Microsystems, Inc. +! by Jonathan Gibbons. +! Outer loop added 8/7/96 by Alex Jacoby +USING: values kernel accessors math math.bitwise sequences +arrays combinators fry locals ; +IN: benchmark.richards + +! Packets +TUPLE: packet link id kind a1 a2 ; + +: BUFSIZE 4 ; inline + +: ( link id kind -- packet ) + packet new + swap >>kind + swap >>id + swap >>link + 0 >>a1 + BUFSIZE 0 >>a2 ; + +: last-packet ( packet -- last ) + dup link>> [ last-packet ] [ ] ?if ; + +: append-to ( packet list -- packet ) + [ f >>link ] dip + [ tuck last-packet >>link drop ] when* ; + +! Tasks +: I_IDLE 1 ; inline +: I_WORK 2 ; inline +: I_HANDLERA 3 ; inline +: I_HANDLERB 4 ; inline +: I_DEVA 5 ; inline +: I_DEVB 6 ; inline + +! Packet types +: K_DEV 1000 ; inline +: K_WORK 1001 ; inline + +: PKTBIT 1 ; inline +: WAITBIT 2 ; inline +: HOLDBIT 4 ; inline + +: S_RUN 0 ; inline +: S_RUNPKT { PKTBIT } flags ; inline +: S_WAIT { WAITBIT } flags ; inline +: S_WAITPKT { WAITBIT PKTBIT } flags ; inline +: S_HOLD { HOLDBIT } flags ; inline +: S_HOLDPKT { HOLDBIT PKTBIT } flags ; inline +: S_HOLDWAIT { HOLDBIT WAITBIT } flags ; inline +: S_HOLDWAITPKT { HOLDBIT WAITBIT PKTBIT } flags ; inline + +: task-tab-size 10 ; inline + +VALUE: task-tab +VALUE: task-list +VALUE: tracing +VALUE: hold-count +VALUE: qpkt-count + +TUPLE: task link id pri wkq state ; + +: new-task ( id pri wkq state class -- task ) + new + swap >>state + swap >>wkq + swap >>pri + swap >>id + task-list >>link + dup to: task-list + dup dup id>> task-tab set-nth ; inline + +GENERIC: fn ( packet task -- task ) + +: state-on ( task flag -- task ) + '[ _ bitor ] change-state ; inline + +: state-off ( task flag -- task ) + '[ _ bitnot bitand ] change-state ; inline + +: wait-task ( task -- task ) + WAITBIT state-on ; + +: hold ( task -- task ) + hold-count 1+ to: hold-count + HOLDBIT state-on + link>> ; + +: highest-priority ( t1 t2 -- t1/t2 ) + [ [ pri>> ] bi@ > ] most ; + +: find-tcb ( i -- task ) + task-tab nth [ "Bad task" throw ] unless* ; + +: release ( task i -- task ) + find-tcb HOLDBIT state-off highest-priority ; + +:: qpkt ( task pkt -- task ) + [let | t [ pkt id>> find-tcb ] | + t [ + qpkt-count 1+ to: qpkt-count + f pkt (>>link) + task id>> pkt (>>id) + t wkq>> [ + pkt t wkq>> append-to t (>>wkq) + task + ] [ + pkt t (>>wkq) + t PKTBIT state-on drop + t task highest-priority + ] if + ] [ task ] if + ] ; + +: schedule-waitpkt ( task -- task pkt ) + dup wkq>> + 2dup link>> >>wkq drop + 2dup S_RUNPKT S_RUN ? >>state drop ; inline + +: schedule-run ( task pkt -- task ) + swap fn ; inline + +: schedule-wait ( task -- task ) + link>> ; inline + +: (schedule) ( task -- ) + [ + dup state>> { + { S_WAITPKT [ schedule-waitpkt schedule-run (schedule) ] } + { S_RUN [ f schedule-run (schedule) ] } + { S_RUNPKT [ f schedule-run (schedule) ] } + { S_WAIT [ schedule-wait (schedule) ] } + { S_HOLD [ schedule-wait (schedule) ] } + { S_HOLDPKT [ schedule-wait (schedule) ] } + { S_HOLDWAIT [ schedule-wait (schedule) ] } + { S_HOLDWAITPKT [ schedule-wait (schedule) ] } + [ 2drop ] + } case + ] when* ; + +: schedule ( -- ) + task-list (schedule) ; + +! Device task +TUPLE: device-task < task v1 ; + +: ( id pri wkq -- task ) + dup S_WAITPKT S_WAIT ? device-task new-task ; + +M:: device-task fn ( pkt task -- task ) + pkt [ + task dup v1>> + [ wait-task ] + [ [ f ] change-v1 swap qpkt ] if + ] [ pkt task (>>v1) task hold ] if ; + +TUPLE: handler-task < task workpkts devpkts ; + +: ( id pri wkq -- task ) + dup S_WAITPKT S_WAIT ? handler-task new-task ; + +M:: handler-task fn ( pkt task -- task ) + pkt [ + task over kind>> K_WORK = + [ [ append-to ] change-workpkts ] + [ [ append-to ] change-devpkts ] + if drop + ] when* + + task workpkts>> [ + [let* | devpkt [ task devpkts>> ] + workpkt [ task workpkts>> ] + count [ workpkt a1>> ] | + count BUFSIZE > [ + workpkt link>> task (>>workpkts) + task workpkt qpkt + ] [ + devpkt [ + devpkt link>> task (>>devpkts) + count workpkt a2>> nth devpkt (>>a1) + count 1+ workpkt (>>a1) + task devpkt qpkt + ] [ + task wait-task + ] if + ] if + ] + ] [ task wait-task ] if ; + +! Idle task +TUPLE: idle-task < task { v1 fixnum } { v2 fixnum } ; + +: ( i a1 a2 -- task ) + [ 0 f S_RUN idle-task new-task ] 2dip + [ >>v1 ] [ >>v2 ] bi* ; + +M: idle-task fn ( pkt task -- task ) + nip + [ 1- ] change-v2 + dup v2>> 0 = [ hold ] [ + dup v1>> 1 bitand 0 = [ + [ -1 shift ] change-v1 + I_DEVA release + ] [ + [ -1 shift HEX: d008 bitor ] change-v1 + I_DEVB release + ] if + ] if ; + +! Work task +TUPLE: work-task < task { handler fixnum } { n fixnum } ; + +: ( id pri w -- work-task ) + dup S_WAITPKT S_WAIT ? work-task new-task + I_HANDLERA >>handler + 0 >>n ; + +M:: work-task fn ( pkt task -- task ) + pkt [ + task [ I_HANDLERA = I_HANDLERB I_HANDLERA ? ] change-handler drop + task handler>> pkt (>>id) + 0 pkt (>>a1) + BUFSIZE [| i | + task [ 1+ ] change-n drop + task n>> 26 > [ 1 task (>>n) ] when + task n>> 1 - CHAR: A + i pkt a2>> set-nth + ] each + task pkt qpkt + ] [ task wait-task ] if ; + +! Main +: init ( -- ) + task-tab-size f to: task-tab + f to: tracing + 0 to: hold-count + 0 to: qpkt-count ; + +: start ( -- ) + I_IDLE 1 10000 drop + + I_WORK 1000 + f 0 K_WORK 0 K_WORK + drop + + I_HANDLERA 2000 + f I_DEVA K_DEV + I_DEVA K_DEV + I_DEVA K_DEV + drop + + I_HANDLERB 3000 + f I_DEVB K_DEV + I_DEVB K_DEV + I_DEVB K_DEV + drop + + I_DEVA 4000 f drop + I_DEVB 4000 f drop ; + +: check ( -- ) + qpkt-count 23246 assert= + hold-count 9297 assert= ; + +: run ( -- ) + init + start + schedule check ; diff --git a/vm/os-freebsd.h b/vm/os-freebsd.h index 5cedbc82b7..617a6686c2 100644 --- a/vm/os-freebsd.h +++ b/vm/os-freebsd.h @@ -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 diff --git a/vm/os-linux.h b/vm/os-linux.h index 1a1e088359..8e78595687 100644 --- a/vm/os-linux.h +++ b/vm/os-linux.h @@ -1,12 +1,5 @@ #include -#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); diff --git a/vm/os-macosx.h b/vm/os-macosx.h index 701bb8da01..216212e973 100644 --- a/vm/os-macosx.h +++ b/vm/os-macosx.h @@ -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; diff --git a/vm/os-netbsd.h b/vm/os-netbsd.h index b42c6b9d7e..54b5d0bcff 100644 --- a/vm/os-netbsd.h +++ b/vm/os-netbsd.h @@ -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; diff --git a/vm/os-openbsd.h b/vm/os-openbsd.h deleted file mode 100644 index 21e34c98f8..0000000000 --- a/vm/os-openbsd.h +++ /dev/null @@ -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 diff --git a/vm/os-solaris.h b/vm/os-solaris.h deleted file mode 100644 index 909cc3f4e9..0000000000 --- a/vm/os-solaris.h +++ /dev/null @@ -1,4 +0,0 @@ -#define UNKNOWN_TYPE_P(file) 1 -#define DIRECTORY_P(file) 0 - -extern char **environ; diff --git a/vm/os-unix.c b/vm/os-unix.c index d4aebad537..4ca62e6623 100755 --- a/vm/os-unix.c +++ b/vm/os-unix.c @@ -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(); diff --git a/vm/os-windows-nt.c b/vm/os-windows-nt.c index 4f5778d0c4..54afd1c147 100755 --- a/vm/os-windows-nt.c +++ b/vm/os-windows-nt.c @@ -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; diff --git a/vm/os-windows.c b/vm/os-windows.c index 4c21c9b5c9..c19aa5c4b5 100755 --- a/vm/os-windows.c +++ b/vm/os-windows.c @@ -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(); -} diff --git a/vm/platform.h b/vm/platform.h index 2f97cb9d1d..21336e88bb 100644 --- a/vm/platform.h +++ b/vm/platform.h @@ -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 diff --git a/vm/primitives.c b/vm/primitives.c index b5d9403342..94151f6c40 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -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,