diff --git a/core/alien/c-types/c-types-docs.factor b/core/alien/c-types/c-types-docs.factor index f4aa297a3a..1fd8cafdcf 100755 --- a/core/alien/c-types/c-types-docs.factor +++ b/core/alien/c-types/c-types-docs.factor @@ -88,29 +88,11 @@ HELP: memory>byte-array ( base len -- string ) { $values { "base" c-ptr } { "len" "a non-negative integer" } { "byte-array" byte-array } } { $description "Reads " { $snippet "len" } " bytes starting from " { $snippet "base" } " and stores them in a new byte array." } ; -HELP: memory>char-string ( base len -- string ) -{ $values { "base" c-ptr } { "len" "a non-negative integer" } { "string" string } } -{ $description "Reads " { $snippet "len" } " bytes starting from " { $snippet "base" } " and stores them in a new string." } ; - -HELP: memory>u16-string ( base len -- string ) -{ $values { "base" c-ptr } { "len" "a non-negative integer" } { "string" string } } -{ $description "Reads " { $snippet "len" } " UCS2 characters starting from " { $snippet "base" } " and stores them in a new string." } ; - HELP: byte-array>memory ( string base -- ) { $values { "byte-array" byte-array } { "base" c-ptr } } { $description "Writes a byte array to memory starting from the " { $snippet "base" } " address." } { $warning "This word is unsafe. Improper use can corrupt memory." } ; -HELP: string>char-memory ( string base -- ) -{ $values { "string" string } { "base" c-ptr } } -{ $description "Writes a string to memory starting from the " { $snippet "base" } " address." } -{ $warning "This word is unsafe. Improper use can corrupt memory." } ; - -HELP: string>u16-memory ( string base -- ) -{ $values { "string" string } { "base" c-ptr } } -{ $description "Writes a string to memory starting from the " { $snippet "base" } " address." } -{ $warning "This word is unsafe. Improper use can corrupt memory." } ; - HELP: malloc-array { $values { "n" "a non-negative integer" } { "type" "a C type" } { "alien" alien } } { $description "Allocates an unmanaged memory block large enough to hold " { $snippet "n" } " values of a C type." } @@ -293,11 +275,7 @@ ARTICLE: "c-strings" "C strings" $nl "Finally, a set of words can be used to read and write " { $snippet "char*" } " and " { $snippet "ushort*" } " strings at arbitrary addresses:" { $subsection alien>char-string } -{ $subsection alien>u16-string } -{ $subsection memory>char-string } -{ $subsection memory>u16-string } -{ $subsection string>char-memory } -{ $subsection string>u16-memory } ; +{ $subsection alien>u16-string } ; ARTICLE: "c-data" "Passing data between Factor and C" "Two defining characteristics of Factor are dynamic typing and automatic memory management, which are somewhat incompatible with the machine-level data model exposed by C. Factor's C library interface defines its own set of C data types, distinct from Factor language types, together with automatic conversion between Factor values and C types. For example, C integer types must be declared and are fixed-width, whereas Factor supports arbitrary-precision integers. Also Factor's garbage collector can move objects in memory, which means that special support has to be provided for passing blocks of memory to C code." diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor index a67c7f4fb9..91089a8278 100755 --- a/core/alien/c-types/c-types.factor +++ b/core/alien/c-types/c-types.factor @@ -155,20 +155,9 @@ M: float-array byte-length length "double" heap-size * ; : memory>byte-array ( alien len -- byte-array ) dup [ -rot memcpy ] keep ; -: memory>char-string ( alien len -- string ) - memory>byte-array >string ; - -DEFER: c-ushort-array> - -: memory>u16-string ( alien len -- string ) - [ memory>byte-array ] keep 2/ c-ushort-array> >string ; - : byte-array>memory ( byte-array base -- ) swap dup length memcpy ; -: string>char-memory ( string base -- ) - >r B{ } like r> byte-array>memory ; - DEFER: >c-ushort-array : string>u16-memory ( string base -- ) @@ -274,7 +263,7 @@ M: long-long-type box-return ( type -- ) ] when ; : malloc-file-contents ( path -- alien ) - binary file-contents >byte-array malloc-byte-array ; + binary file-contents malloc-byte-array ; [ [ alien-cell ] diff --git a/core/io/binary/binary-tests.factor b/core/io/binary/binary-tests.factor index f6d103b0d1..a6fea14fc7 100755 --- a/core/io/binary/binary-tests.factor +++ b/core/io/binary/binary-tests.factor @@ -1,8 +1,10 @@ -USING: io.binary tools.test ; +USING: io.binary tools.test classes math ; IN: io.binary.tests -[ "\0\0\u000004\u0000d2" ] [ 1234 4 >be ] unit-test -[ "\u0000d2\u000004\0\0" ] [ 1234 4 >le ] unit-test +[ B{ 0 0 4 HEX: d2 } ] [ 1234 4 >be ] unit-test +[ B{ HEX: d2 4 0 0 } ] [ 1234 4 >le ] unit-test [ 1234 ] [ 1234 4 >be be> ] unit-test [ 1234 ] [ 1234 4 >le le> ] unit-test + +[ fixnum ] [ B{ 0 0 0 0 0 0 0 0 0 0 } be> class ] unit-test diff --git a/core/io/binary/binary.factor b/core/io/binary/binary.factor index 9f6231b643..f2ede93fd5 100755 --- a/core/io/binary/binary.factor +++ b/core/io/binary/binary.factor @@ -3,7 +3,7 @@ USING: kernel math sequences ; IN: io.binary -: le> ( seq -- x ) B{ } like byte-array>bignum ; +: le> ( seq -- x ) B{ } like byte-array>bignum >integer ; : be> ( seq -- x ) le> ; : mask-byte ( x -- y ) HEX: ff bitand ; inline diff --git a/core/io/encodings/utf8/utf8-tests.factor b/core/io/encodings/utf8/utf8-tests.factor old mode 100644 new mode 100755 index 8f1c998f3d..af169854c9 --- a/core/io/encodings/utf8/utf8-tests.factor +++ b/core/io/encodings/utf8/utf8-tests.factor @@ -1,4 +1,5 @@ -USING: io.encodings.utf8 tools.test io.encodings.string strings arrays ; +USING: io.encodings.utf8 tools.test io.encodings.string strings arrays unicode ; +IN: io.encodings.utf8.tests : decode-utf8-w/stream ( array -- newarray ) utf8 decode >array ; diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index e7f7f4f777..e2eeef6528 100755 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -6,9 +6,8 @@ USING: tools.test io.files io threads kernel continuations io.encodings.ascii ; [ "awk" ] [ "/usr/libexec/awk///" file-name ] unit-test [ ] [ - "test-foo.txt" temp-file ascii [ - "Hello world." print - ] with-file-writer + { "Hello world." } + "test-foo.txt" temp-file ascii set-file-lines ] unit-test [ ] [ @@ -69,8 +68,8 @@ USING: tools.test io.files io threads kernel continuations io.encodings.ascii ; [ ] [ "delete-tree-test/a/b/c" temp-file make-directories ] unit-test [ ] [ - "delete-tree-test/a/b/c/d" temp-file - ascii [ "Hi" print ] with-file-writer + { "Hi" } + "delete-tree-test/a/b/c/d" temp-file ascii set-file-lines ] unit-test [ ] [ @@ -82,8 +81,9 @@ USING: tools.test io.files io threads kernel continuations io.encodings.ascii ; ] unit-test [ ] [ + "Foobar" "copy-tree-test/a/b/c/d" temp-file - ascii [ "Foobar" write ] with-file-writer + ascii set-file-contents ] unit-test [ ] [ diff --git a/core/io/files/files.factor b/core/io/files/files.factor index f740d1dc21..cbb6e77ff9 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -213,18 +213,24 @@ C: pathname M: pathname <=> [ pathname-string ] compare ; -: file-lines ( path encoding -- seq ) lines ; - -: file-contents ( path encoding -- str ) - dupd swap file-length - [ stream-copy ] keep >string ; +: file-lines ( path encoding -- seq ) + lines ; : with-file-reader ( path encoding quot -- ) >r r> with-stream ; inline +: file-contents ( path encoding -- str ) + dupd [ file-length read ] with-file-reader ; + : with-file-writer ( path encoding quot -- ) >r r> with-stream ; inline +: set-file-lines ( seq path encoding -- ) + [ [ print ] each ] with-file-writer ; + +: set-file-contents ( str path encoding -- ) + [ write ] with-file-writer ; + : with-file-appender ( path encoding quot -- ) >r r> with-stream ; inline diff --git a/core/io/streams/c/c-tests.factor b/core/io/streams/c/c-tests.factor index 321cad4d19..4a3d94a172 100755 --- a/core/io/streams/c/c-tests.factor +++ b/core/io/streams/c/c-tests.factor @@ -3,9 +3,7 @@ io.encodings.ascii strings ; IN: io.streams.c.tests [ "hello world" ] [ - "test.txt" temp-file ascii [ - "hello world" write - ] with-file-writer + "hello world" "test.txt" temp-file ascii set-file-contents "test.txt" temp-file "rb" fopen contents >string diff --git a/core/layouts/layouts.factor b/core/layouts/layouts.factor index cba3532d9f..db23bf03d0 100755 --- a/core/layouts/layouts.factor +++ b/core/layouts/layouts.factor @@ -33,6 +33,10 @@ SYMBOL: type-numbers : most-negative-fixnum ( -- n ) first-bignum neg ; +M: bignum >integer + dup most-negative-fixnum most-positive-fixnum between? + [ >fixnum ] when ; + M: real >integer dup most-negative-fixnum most-positive-fixnum between? [ >fixnum ] [ >bignum ] if ; diff --git a/core/listener/listener-tests.factor b/core/listener/listener-tests.factor index d694c62c67..2c05c049a7 100755 --- a/core/listener/listener-tests.factor +++ b/core/listener/listener-tests.factor @@ -8,9 +8,11 @@ IN: listener.tests : parse-interactive ( string -- quot ) stream-read-quot ; -[ [ ] ] [ - "USE: listener.tests hello" parse-interactive -] unit-test +[ + [ [ ] ] [ + "USE: listener.tests hello" parse-interactive + ] unit-test +] with-file-vocabs [ "debugger" use+ @@ -35,8 +37,10 @@ IN: listener.tests ] unit-test [ - "USE: vocabs.loader.test.c" parse-interactive -] must-fail + [ + "USE: vocabs.loader.test.c" parse-interactive + ] must-fail +] with-file-vocabs [ ] [ [ @@ -44,7 +48,9 @@ IN: listener.tests ] with-compilation-unit ] unit-test -[ ] [ - "IN: listener.tests : hello\n\"world\" ;" parse-interactive +[ + [ ] [ + "IN: listener.tests : hello\n\"world\" ;" parse-interactive drop -] unit-test + ] unit-test +] with-file-vocabs diff --git a/core/math/integers/integers.factor b/core/math/integers/integers.factor index 011af6342e..70a6d2e087 100755 --- a/core/math/integers/integers.factor +++ b/core/math/integers/integers.factor @@ -6,10 +6,10 @@ IN: math.integers.private M: integer numerator ; M: integer denominator drop 1 ; -M: integer >integer ; M: fixnum >fixnum ; M: fixnum >bignum fixnum>bignum ; +M: fixnum >integer ; M: fixnum number= eq? ; diff --git a/core/math/intervals/intervals-tests.factor b/core/math/intervals/intervals-tests.factor index 8e2f47f72b..5a3fe777b6 100755 --- a/core/math/intervals/intervals-tests.factor +++ b/core/math/intervals/intervals-tests.factor @@ -1,5 +1,5 @@ USING: math.intervals kernel sequences words math arrays -prettyprint tools.test random vocabs ; +prettyprint tools.test random vocabs combinators ; IN: math.intervals.tests [ T{ interval f { 1 t } { 2 t } } ] [ 1 2 [a,b] ] unit-test @@ -94,33 +94,88 @@ IN: math.intervals.tests ] unit-test ] when -[ t ] [ 0 5 [a,b] 5 interval<= ] unit-test +[ t ] [ 1 [a,a] interval-singleton? ] unit-test -[ incomparable ] [ 0 5 [a,b] 5 interval< ] unit-test +[ f ] [ 1 1 [a,b) interval-singleton? ] unit-test -[ t ] [ 0 5 [a,b) 5 interval< ] unit-test +[ f ] [ 1 3 [a,b) interval-singleton? ] unit-test -[ f ] [ 0 5 [a,b] -1 interval< ] unit-test +[ f ] [ 1 1 (a,b) interval-singleton? ] unit-test -[ incomparable ] [ 0 5 [a,b] 1 interval< ] unit-test +[ 2 ] [ 1 3 [a,b) interval-length ] unit-test -[ t ] [ -1 1 (a,b) -1 interval> ] unit-test +[ 0 ] [ f interval-length ] unit-test -[ t ] [ -1 1 (a,b) -1 interval>= ] unit-test +[ t ] [ 0 5 [a,b] 5 [a,a] interval<= ] unit-test -[ f ] [ -1 1 (a,b) -1 interval< ] unit-test +[ incomparable ] [ 0 5 [a,b] 5 [a,a] interval< ] unit-test -[ f ] [ -1 1 (a,b) -1 interval<= ] unit-test +[ t ] [ 0 5 [a,b) 5 [a,a] interval< ] unit-test -[ t ] [ -1 1 (a,b] 1 interval<= ] unit-test +[ f ] [ 0 5 [a,b] -1 [a,a] interval< ] unit-test + +[ incomparable ] [ 0 5 [a,b] 1 [a,a] interval< ] unit-test + +[ t ] [ -1 1 (a,b) -1 [a,a] interval> ] unit-test + +[ t ] [ -1 1 (a,b) -1 [a,a] interval>= ] unit-test + +[ f ] [ -1 1 (a,b) -1 [a,a] interval< ] unit-test + +[ f ] [ -1 1 (a,b) -1 [a,a] interval<= ] unit-test + +[ t ] [ -1 1 (a,b] 1 [a,a] interval<= ] unit-test + +[ t ] [ -1 1 (a,b] 1 2 [a,b] interval<= ] unit-test + +[ incomparable ] [ -1 1 (a,b] 1 2 [a,b] interval>= ] unit-test + +[ incomparable ] [ -1 1 (a,b] 1 2 [a,b] interval> ] unit-test + +[ t ] [ -1 1 (a,b] 1 2 (a,b] interval<= ] unit-test + +[ f ] [ 0 10 [a,b] 0 [a,a] interval< ] unit-test + +[ f ] [ 0 10 [a,b] 10 [a,a] interval> ] unit-test + +[ incomparable ] [ 0 [a,a] 0 10 [a,b] interval< ] unit-test + +[ incomparable ] [ 10 [a,a] 0 10 [a,b] interval> ] unit-test + +[ t ] [ 0 [a,a] 0 10 [a,b] interval<= ] unit-test + +[ incomparable ] [ 0 [a,a] 0 10 [a,b] interval>= ] unit-test + +[ t ] [ 0 10 [a,b] 0 [a,a] interval>= ] unit-test + +[ t ] [ + 418 + 418 423 [a,b) + 79 893 (a,b] + interval-max + interval-contains? +] unit-test + +[ f ] [ 1 100 [a,b] -1 1 [a,b] interval/i ] unit-test ! Interval random tester : random-element ( interval -- n ) - dup interval-to first swap interval-from first tuck - - random + ; + dup interval-to first over interval-from first tuck - random + + 2dup swap interval-contains? [ + nip + ] [ + drop random-element + ] if ; : random-interval ( -- interval ) - 1000 random dup 1 1000 random + + [a,b] ; + 1000 random dup 2 1000 random + + + 1 random zero? [ [ neg ] 2apply swap ] when + 4 random { + { 0 [ [a,b] ] } + { 1 [ [a,b) ] } + { 2 [ (a,b) ] } + { 3 [ (a,b] ] } + } case ; : random-op { @@ -138,12 +193,32 @@ IN: math.intervals.tests random ; : interval-test - random-interval random-interval random-op + random-interval random-interval random-op ! 3dup . . . 0 pick interval-contains? over first { / /i } member? and [ 3drop t ] [ - [ >r [ random-element ] 2apply r> first execute ] 3keep + [ >r [ random-element ] 2apply ! 2dup . . + r> first execute ] 3keep second execute interval-contains? ] if ; -[ t ] [ 1000 [ drop interval-test ] all? ] unit-test +[ t ] [ 40000 [ drop interval-test ] all? ] unit-test + +: random-comparison + { + { < interval< } + { <= interval<= } + { > interval> } + { >= interval>= } + } random ; + +: comparison-test + random-interval random-interval random-comparison + [ >r [ random-element ] 2apply r> first execute ] 3keep + second execute dup incomparable eq? [ + 2drop t + ] [ + = + ] if ; + +[ t ] [ 40000 [ drop comparison-test ] all? ] unit-test diff --git a/core/math/intervals/intervals.factor b/core/math/intervals/intervals.factor old mode 100644 new mode 100755 index b7eb5be8c9..d1c458065f --- a/core/math/intervals/intervals.factor +++ b/core/math/intervals/intervals.factor @@ -88,20 +88,6 @@ C: interval [ interval>points [ first integer? ] both? ] both? r> [ 2drop f ] if ; inline -: interval-shift ( i1 i2 -- i3 ) - [ [ shift ] interval-op ] interval-integer-op ; - -: interval-shift-safe ( i1 i2 -- i3 ) - dup interval-to first 100 > [ - 2drop f - ] [ - interval-shift - ] if ; - -: interval-max ( i1 i2 -- i3 ) [ max ] interval-op ; - -: interval-min ( i1 i2 -- i3 ) [ min ] interval-op ; - : interval-1+ ( i1 -- i2 ) 1 [a,a] interval+ ; : interval-1- ( i1 -- i2 ) -1 [a,a] interval+ ; @@ -143,8 +129,41 @@ C: interval : interval-contains? ( x int -- ? ) >r [a,a] r> interval-subset? ; +: interval-singleton? ( int -- ? ) + interval>points + 2dup [ second ] 2apply and + [ [ first ] 2apply = ] + [ 2drop f ] if ; + +: interval-length ( int -- n ) + dup + [ interval>points [ first ] 2apply swap - ] + [ drop 0 ] if ; + : interval-closure ( i1 -- i2 ) - interval>points [ first ] 2apply [a,b] ; + dup [ interval>points [ first ] 2apply [a,b] ] when ; + +: interval-shift ( i1 i2 -- i3 ) + #! Inaccurate; could be tighter + [ [ shift ] interval-op ] interval-integer-op interval-closure ; + +: interval-shift-safe ( i1 i2 -- i3 ) + dup interval-to first 100 > [ + 2drop f + ] [ + interval-shift + ] if ; + +: interval-max ( i1 i2 -- i3 ) + #! Inaccurate; could be tighter + [ max ] interval-op interval-closure ; + +: interval-min ( i1 i2 -- i3 ) + #! Inaccurate; could be tighter + [ min ] interval-op interval-closure ; + +: interval-interior ( i1 -- i2 ) + interval>points [ first ] 2apply (a,b) ; : interval-division-op ( i1 i2 quot -- i3 ) >r 0 over interval-closure interval-contains? @@ -156,7 +175,7 @@ C: interval : interval/i ( i1 i2 -- i3 ) [ [ [ /i ] interval-op ] interval-integer-op - ] interval-division-op ; + ] interval-division-op interval-closure ; : interval-recip ( i1 -- i2 ) 1 [a,a] swap interval/ ; @@ -164,24 +183,46 @@ C: interval SYMBOL: incomparable -: interval-compare ( int n quot -- ? ) - >r dupd r> call interval-intersect dup [ - = t incomparable ? - ] [ - 2drop f - ] if ; inline +: left-endpoint-< ( i1 i2 -- ? ) + [ swap interval-subset? ] 2keep + [ nip interval-singleton? ] 2keep + [ interval-from ] 2apply = + and and ; -: interval< ( int n -- ? ) - [ [-inf,a) ] interval-compare ; inline +: right-endpoint-< ( i1 i2 -- ? ) + [ interval-subset? ] 2keep + [ drop interval-singleton? ] 2keep + [ interval-to ] 2apply = + and and ; -: interval<= ( int n -- ? ) - [ [-inf,a] ] interval-compare ; inline +: (interval<) over interval-from over interval-from endpoint< ; -: interval> ( int n -- ? ) - [ (a,inf] ] interval-compare ; inline +: interval< ( i1 i2 -- ? ) + { + { [ 2dup interval-intersect not ] [ (interval<) ] } + { [ 2dup left-endpoint-< ] [ f ] } + { [ 2dup right-endpoint-< ] [ f ] } + { [ t ] [ incomparable ] } + } cond 2nip ; -: interval>= ( int n -- ? ) - [ [a,inf] ] interval-compare ; inline +: left-endpoint-<= ( i1 i2 -- ? ) + >r interval-from r> interval-to = ; + +: right-endpoint-<= ( i1 i2 -- ? ) + >r interval-to r> interval-from = ; + +: interval<= ( i1 i2 -- ? ) + { + { [ 2dup interval-intersect not ] [ (interval<) ] } + { [ 2dup right-endpoint-<= ] [ t ] } + { [ t ] [ incomparable ] } + } cond 2nip ; + +: interval> ( i1 i2 -- ? ) + swap interval< ; + +: interval>= ( i1 i2 -- ? ) + swap interval<= ; : assume< ( i1 i2 -- i3 ) interval-to first [-inf,a) interval-intersect ; diff --git a/core/optimizer/math/math.factor b/core/optimizer/math/math.factor index b7c82e402a..7afc177d10 100755 --- a/core/optimizer/math/math.factor +++ b/core/optimizer/math/math.factor @@ -371,13 +371,15 @@ most-negative-fixnum most-positive-fixnum [a,b] ] assoc-each ! Remove redundant comparisons -: known-comparison? ( #call -- ? ) +: intervals-first2 ( #call -- first second ) dup dup node-in-d first node-interval - swap dup node-in-d second node-literal real? and ; + swap dup node-in-d second node-interval ; + +: known-comparison? ( #call -- ? ) + intervals-first2 and ; : perform-comparison ( #call word -- result ) - >r dup dup node-in-d first node-interval - swap dup node-in-d second node-literal r> execute ; inline + >r intervals-first2 r> execute ; inline : foldable-comparison? ( #call word -- ? ) >r dup known-comparison? [ diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 8e1927c043..cc84084258 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -240,11 +240,14 @@ PREDICATE: unexpected unexpected-eof : CREATE ( -- word ) scan create-in ; -: CREATE-CLASS ( -- word ) - scan in get create +: create-class ( word vocab -- word ) + create dup save-class-location dup predicate-word dup set-word save-location ; +: CREATE-CLASS ( -- word ) + scan in get create-class ; + : word-restarts ( possibilities -- restarts ) natural-sort [ [ "Use the word " swap summary append ] keep diff --git a/extra/benchmark/mandel/mandel.factor b/extra/benchmark/mandel/mandel.factor index 05eda2ad81..0f8c81da75 100755 --- a/extra/benchmark/mandel/mandel.factor +++ b/extra/benchmark/mandel/mandel.factor @@ -1,6 +1,7 @@ IN: benchmark.mandel USING: arrays io kernel math namespaces sequences strings sbufs -math.functions math.parser io.files colors.hsv io.encodings.binary ; +math.functions math.parser io.files colors.hsv +io.encodings.ascii ; : max-color 360 ; inline : zoom-fact 0.8 ; inline @@ -65,7 +66,6 @@ SYMBOL: cols ] with-scope ; : mandel-main ( -- ) - "mandel.ppm" temp-file - binary [ mandel write ] with-file-writer ; + mandel "mandel.ppm" temp-file ascii set-file-contents ; MAIN: mandel-main diff --git a/extra/benchmark/raytracer/raytracer.factor b/extra/benchmark/raytracer/raytracer.factor index 232842a51e..4bb8c30383 100644 --- a/extra/benchmark/raytracer/raytracer.factor +++ b/extra/benchmark/raytracer/raytracer.factor @@ -3,7 +3,7 @@ USING: float-arrays compiler generic io io.files kernel math math.functions math.vectors math.parser namespaces sequences -sequences.private words io.encodings.binary ; +sequences.private words io.encodings.ascii ; IN: benchmark.raytracer ! parameters @@ -170,7 +170,6 @@ DEFER: create ( level c r -- scene ) ] "" make ; : raytracer-main - "raytracer.pnm" temp-file - binary [ run write ] with-file-writer ; + run "raytracer.pnm" temp-file ascii set-file-contents ; MAIN: raytracer-main diff --git a/extra/bitfields/bitfields-tests.factor b/extra/bitfields/bitfields-tests.factor old mode 100644 new mode 100755 index 8a3bb1f043..bbd4aa3db0 --- a/extra/bitfields/bitfields-tests.factor +++ b/extra/bitfields/bitfields-tests.factor @@ -1,4 +1,5 @@ USING: tools.test bitfields kernel ; +IN: bitfields.tests SAFE-BITFIELD: foo bar:5 baz:10 111 bing:2 ; diff --git a/extra/builder/test/test.factor b/extra/builder/test/test.factor index d03be0781a..e92efaf8fc 100644 --- a/extra/builder/test/test.factor +++ b/extra/builder/test/test.factor @@ -7,6 +7,7 @@ USING: kernel namespaces sequences assocs builder continuations tools.browser tools.test io.encodings.utf8 + combinators.cleave bootstrap.stage2 benchmark builder.util ; IN: builder.test @@ -14,8 +15,18 @@ IN: builder.test : do-load ( -- ) try-everything keys "../load-everything-vocabs" utf8 [ . ] with-file-writer ; +! : do-tests ( -- ) +! run-all-tests keys "../test-all-vocabs" utf8 [ . ] with-file-writer ; + : do-tests ( -- ) - run-all-tests keys "../test-all-vocabs" utf8 [ . ] with-file-writer ; + run-all-tests + "../test-all-vocabs" utf8 + [ + [ keys . ] + [ test-failures. ] + bi + ] + with-file-writer ; : do-benchmarks ( -- ) run-benchmarks "../benchmarks" utf8 [ . ] with-file-writer ; diff --git a/extra/calendar/calendar-tests.factor b/extra/calendar/calendar-tests.factor index f700d244f5..1041c79691 100755 --- a/extra/calendar/calendar-tests.factor +++ b/extra/calendar/calendar-tests.factor @@ -1,5 +1,6 @@ USING: arrays calendar kernel math sequences tools.test continuations system ; +IN: calendar.tests [ f ] [ 2004 12 32 0 0 0 0 valid-timestamp? ] unit-test [ f ] [ 2004 2 30 0 0 0 0 valid-timestamp? ] unit-test diff --git a/extra/cocoa/plists/plists.factor b/extra/cocoa/plists/plists.factor index 646a759c59..5965c74af8 100644 --- a/extra/cocoa/plists/plists.factor +++ b/extra/cocoa/plists/plists.factor @@ -19,5 +19,5 @@ M: hashtable >plist >plist 1array "plist" build-tag* dup { { "version" "1.0" } } update ; -: print-plist ( obj -- ) - build-plist build-xml print-xml ; +: plist>string ( obj -- string ) + build-plist build-xml xml>string ; diff --git a/extra/crypto/hmac/hmac-tests.factor b/extra/crypto/hmac/hmac-tests.factor index 35c99258db..fa0cbef4c7 100755 --- a/extra/crypto/hmac/hmac-tests.factor +++ b/extra/crypto/hmac/hmac-tests.factor @@ -1,11 +1,12 @@ -USING: kernel io strings sequences namespaces math parser crypto.hmac tools.test ; +USING: kernel io strings byte-arrays sequences namespaces math +parser crypto.hmac tools.test ; IN: crypto.hmac.tests -[ "\u000092\u000094rz68\u0000bb\u00001c\u000013\u0000f4\u00008e\u0000f8\u000015\u00008b\u0000fc\u00009d" ] [ 16 11 "Hi There" string>md5-hmac >string ] unit-test -[ "u\u00000cx>j\u0000b0\u0000b5\u000003\u0000ea\u0000a8n1\n]\u0000b78" ] [ "Jefe" "what do ya want for nothing?" string>md5-hmac >string ] unit-test -[ "V\u0000be4R\u00001d\u000014L\u000088\u0000db\u0000b8\u0000c73\u0000f0\u0000e8\u0000b3\u0000f6" ] [ 16 HEX: aa 50 HEX: dd string>md5-hmac >string ] unit-test +[ "\u000092\u000094rz68\u0000bb\u00001c\u000013\u0000f4\u00008e\u0000f8\u000015\u00008b\u0000fc\u00009d" ] [ 16 11 "Hi There" byte-array>md5-hmac >string ] unit-test +[ "u\u00000cx>j\u0000b0\u0000b5\u000003\u0000ea\u0000a8n1\n]\u0000b78" ] [ "Jefe" "what do ya want for nothing?" byte-array>md5-hmac >string ] unit-test +[ "V\u0000be4R\u00001d\u000014L\u000088\u0000db\u0000b8\u0000c73\u0000f0\u0000e8\u0000b3\u0000f6" ] [ 16 HEX: aa 50 HEX: dd >byte-array byte-array>md5-hmac >string ] unit-test -[ "g[\u00000b:\eM\u0000dfN\u000012Hr\u0000dal/c+\u0000fe\u0000d9W\u0000e9" ] [ 16 11 "Hi There" string>sha1-hmac >string ] unit-test -[ "\u0000ef\u0000fc\u0000dfj\u0000e5\u0000eb/\u0000a2\u0000d2t\u000016\u0000d5\u0000f1\u000084\u0000df\u00009c%\u00009a|y" ] [ "Jefe" "what do ya want for nothing?" string>sha1-hmac >string ] unit-test -[ "\u0000d70YM\u000016~5\u0000d5\u000095o\u0000d8\0=\r\u0000b3\u0000d3\u0000f4m\u0000c7\u0000bb" ] [ 16 HEX: aa 50 HEX: dd string>sha1-hmac >string ] unit-test +[ "g[\u00000b:\eM\u0000dfN\u000012Hr\u0000dal/c+\u0000fe\u0000d9W\u0000e9" ] [ 16 11 "Hi There" >byte-array byte-array>sha1-hmac >string ] unit-test +[ "\u0000ef\u0000fc\u0000dfj\u0000e5\u0000eb/\u0000a2\u0000d2t\u000016\u0000d5\u0000f1\u000084\u0000df\u00009c%\u00009a|y" ] [ "Jefe" "what do ya want for nothing?" >byte-array byte-array>sha1-hmac >string ] unit-test +[ "\u0000d70YM\u000016~5\u0000d5\u000095o\u0000d8\0=\r\u0000b3\u0000d3\u0000f4m\u0000c7\u0000bb" ] [ 16 HEX: aa 50 HEX: dd >byte-array byte-array>sha1-hmac >string ] unit-test diff --git a/extra/crypto/hmac/hmac.factor b/extra/crypto/hmac/hmac.factor old mode 100644 new mode 100755 index 56d39e71dc..3dad01fe3a --- a/extra/crypto/hmac/hmac.factor +++ b/extra/crypto/hmac/hmac.factor @@ -1,5 +1,5 @@ USING: arrays combinators crypto.common crypto.md5 crypto.sha1 -crypto.md5.private io io.binary io.files io.streams.string +crypto.md5.private io io.binary io.files io.streams.byte-array kernel math math.vectors memoize sequences io.encodings.binary ; IN: crypto.hmac @@ -34,8 +34,8 @@ MEMO: opad ( -- seq ) 64 HEX: 5c ; : file>sha1-hmac ( K path -- hmac ) binary stream>sha1-hmac ; -: string>sha1-hmac ( K string -- hmac ) - stream>sha1-hmac ; +: byte-array>sha1-hmac ( K string -- hmac ) + binary stream>sha1-hmac ; : stream>md5-hmac ( K stream -- hmac ) @@ -44,6 +44,5 @@ MEMO: opad ( -- seq ) 64 HEX: 5c ; : file>md5-hmac ( K path -- hmac ) binary stream>md5-hmac ; -: string>md5-hmac ( K string -- hmac ) - stream>md5-hmac ; - +: byte-array>md5-hmac ( K string -- hmac ) + binary stream>md5-hmac ; diff --git a/extra/crypto/md5/md5-docs.factor b/extra/crypto/md5/md5-docs.factor old mode 100644 new mode 100755 index fd8bf3f74d..667e0449ae --- a/extra/crypto/md5/md5-docs.factor +++ b/extra/crypto/md5/md5-docs.factor @@ -1,15 +1,15 @@ USING: help.markup help.syntax kernel math sequences quotations -crypto.common ; +crypto.common byte-arrays ; IN: crypto.md5 HELP: stream>md5 { $values { "stream" "a stream" } { "byte-array" "md5 hash" } } { $description "Take the MD5 hash until end of stream." } -{ $notes "Used to implement " { $link string>md5 } " and " { $link file>md5 } ". Call " { $link hex-string } " to convert to the canonical string representation." } ; +{ $notes "Used to implement " { $link byte-array>md5 } " and " { $link file>md5 } ". Call " { $link hex-string } " to convert to the canonical string representation." } ; -HELP: string>md5 -{ $values { "string" "a string" } { "byte-array" "byte-array md5 hash" } } -{ $description "Outputs the MD5 hash of a string." } +HELP: byte-array>md5 +{ $values { "byte-array" byte-array } { "checksum" "an md5 hash" } } +{ $description "Outputs the MD5 hash of a byte array." } { $notes "Call " { $link hex-string } " to convert to the canonical string representation." } ; HELP: file>md5 diff --git a/extra/crypto/md5/md5-tests.factor b/extra/crypto/md5/md5-tests.factor old mode 100644 new mode 100755 index 9a361eb594..73bd240455 --- a/extra/crypto/md5/md5-tests.factor +++ b/extra/crypto/md5/md5-tests.factor @@ -1,10 +1,10 @@ -USING: kernel math namespaces crypto.md5 tools.test ; +USING: kernel math namespaces crypto.md5 tools.test byte-arrays ; -[ "d41d8cd98f00b204e9800998ecf8427e" ] [ "" string>md5str ] unit-test -[ "0cc175b9c0f1b6a831c399e269772661" ] [ "a" string>md5str ] unit-test -[ "900150983cd24fb0d6963f7d28e17f72" ] [ "abc" string>md5str ] unit-test -[ "f96b697d7cb7938d525a2f31aaf161d0" ] [ "message digest" string>md5str ] unit-test -[ "c3fcd3d76192e4007dfb496cca67e13b" ] [ "abcdefghijklmnopqrstuvwxyz" string>md5str ] unit-test -[ "d174ab98d277d9f5a5611c2c9f419d9f" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" string>md5str ] unit-test -[ "57edf4a22be3c955ac49da2e2107b67a" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" string>md5str ] unit-test +[ "d41d8cd98f00b204e9800998ecf8427e" ] [ "" >byte-array byte-array>md5str ] unit-test +[ "0cc175b9c0f1b6a831c399e269772661" ] [ "a" >byte-array byte-array>md5str ] unit-test +[ "900150983cd24fb0d6963f7d28e17f72" ] [ "abc" >byte-array byte-array>md5str ] unit-test +[ "f96b697d7cb7938d525a2f31aaf161d0" ] [ "message digest" >byte-array byte-array>md5str ] unit-test +[ "c3fcd3d76192e4007dfb496cca67e13b" ] [ "abcdefghijklmnopqrstuvwxyz" >byte-array byte-array>md5str ] unit-test +[ "d174ab98d277d9f5a5611c2c9f419d9f" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" >byte-array byte-array>md5str ] unit-test +[ "57edf4a22be3c955ac49da2e2107b67a" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" >byte-array byte-array>md5str ] unit-test diff --git a/extra/crypto/md5/md5.factor b/extra/crypto/md5/md5.factor old mode 100644 new mode 100755 index debef26de4..7ecbd767b9 --- a/extra/crypto/md5/md5.factor +++ b/extra/crypto/md5/md5.factor @@ -1,21 +1,14 @@ ! See http://www.faqs.org/rfcs/rfc1321.html -USING: kernel io io.binary io.files io.streams.string math +USING: kernel io io.binary io.files io.streams.byte-array math math.functions math.parser namespaces splitting strings sequences crypto.common byte-arrays locals sequences.private -io.encodings.binary ; +io.encodings.binary symbols ; IN: crypto.md5 bignum ; foldable @@ -185,7 +178,14 @@ PRIVATE> : stream>md5 ( stream -- byte-array ) [ initialize-md5 (stream>md5) get-md5 ] with-stream ; -: string>md5 ( string -- byte-array ) stream>md5 ; -: string>md5str ( string -- md5-string ) string>md5 hex-string ; -: file>md5 ( path -- byte-array ) binary stream>md5 ; -: file>md5str ( path -- md5-string ) file>md5 hex-string ; +: byte-array>md5 ( byte-array -- checksum ) + binary stream>md5 ; + +: byte-array>md5str ( byte-array -- md5-string ) + byte-array>md5 hex-string ; + +: file>md5 ( path -- byte-array ) + binary stream>md5 ; + +: file>md5str ( path -- md5-string ) + file>md5 hex-string ; diff --git a/extra/crypto/sha1/sha1-tests.factor b/extra/crypto/sha1/sha1-tests.factor index 795ee4971d..14307355c2 100755 --- a/extra/crypto/sha1/sha1-tests.factor +++ b/extra/crypto/sha1/sha1-tests.factor @@ -1,14 +1,14 @@ USING: arrays kernel math namespaces sequences tools.test crypto.sha1 ; -[ "a9993e364706816aba3e25717850c26c9cd0d89d" ] [ "abc" string>sha1str ] unit-test -[ "84983e441c3bd26ebaae4aa1f95129e5e54670f1" ] [ "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" string>sha1str ] unit-test +[ "a9993e364706816aba3e25717850c26c9cd0d89d" ] [ "abc" byte-array>sha1str ] unit-test +[ "84983e441c3bd26ebaae4aa1f95129e5e54670f1" ] [ "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" byte-array>sha1str ] unit-test ! [ "34aa973cd4c4daa4f61eeb2bdbad27316534016f" ] [ 1000000 CHAR: a fill string>sha1str ] unit-test ! takes a long time... [ "dea356a2cddd90c7a7ecedc5ebb563934f460452" ] [ "0123456701234567012345670123456701234567012345670123456701234567" -10 swap concat string>sha1str ] unit-test +10 swap concat byte-array>sha1str ] unit-test [ ";\u00009b\u0000fd\u0000cdK\u0000a3^s\u0000d0*\u0000e3\\\u0000b5\u000013<\u0000e8wA\u0000b2\u000083\u0000d20\u0000f1\u0000e6\u0000cc\u0000d8\u00001e\u00009c\u000004\u0000d7PT]\u0000ce,\u000001\u000012\u000080\u000096\u000099" ] [ "\u000066\u000053\u0000f1\u00000c\u00001a\u0000fa\u0000b5\u00004c\u000061\u0000c8\u000025\u000075\u0000a8\u00004a\u0000fe\u000030\u0000d8\u0000aa\u00001a\u00003a\u000096\u000096\u0000b3\u000018\u000099\u000092\u0000bf\u0000e1\u0000cb\u00007f\u0000a6\u0000a7" - string>sha1-interleave + byte-array>sha1-interleave ] unit-test diff --git a/extra/crypto/sha1/sha1.factor b/extra/crypto/sha1/sha1.factor old mode 100644 new mode 100755 index eaad6df622..af3671e7d9 --- a/extra/crypto/sha1/sha1.factor +++ b/extra/crypto/sha1/sha1.factor @@ -1,23 +1,12 @@ -USING: arrays combinators crypto.common kernel io io.encodings.binary -io.files io.streams.string math.vectors strings sequences -namespaces math parser sequences vectors io.binary -hashtables ; +USING: arrays combinators crypto.common kernel io +io.encodings.binary io.files io.streams.byte-array math.vectors +strings sequences namespaces math parser sequences vectors +io.binary hashtables symbols ; IN: crypto.sha1 ! Implemented according to RFC 3174. -SYMBOL: h0 -SYMBOL: h1 -SYMBOL: h2 -SYMBOL: h3 -SYMBOL: h4 -SYMBOL: A -SYMBOL: B -SYMBOL: C -SYMBOL: D -SYMBOL: E -SYMBOL: w -SYMBOL: K +SYMBOLS: h0 h1 h2 h3 h4 A B C D E w K ; : get-wth ( n -- wth ) w get nth ; inline : shift-wth ( n -- x ) get-wth 1 bitroll-32 ; inline @@ -118,15 +107,22 @@ SYMBOL: K [ [ h0 h1 h2 h3 h4 ] [ get 4 >be % ] each ] "" make ; : stream>sha1 ( stream -- sha1 ) - [ [ initialize-sha1 (stream>sha1) get-sha1 ] with-stream ] with-scope ; + [ initialize-sha1 (stream>sha1) get-sha1 ] with-stream ; -: string>sha1 ( string -- sha1 ) stream>sha1 ; -: string>sha1str ( string -- str ) string>sha1 hex-string ; -: string>sha1-bignum ( string -- n ) string>sha1 be> ; -: file>sha1 ( file -- sha1 ) binary stream>sha1 ; +: byte-array>sha1 ( string -- sha1 ) + binary stream>sha1 ; -: string>sha1-interleave ( string -- seq ) +: byte-array>sha1str ( string -- str ) + byte-array>sha1 hex-string ; + +: byte-array>sha1-bignum ( string -- n ) + byte-array>sha1 be> ; + +: file>sha1 ( file -- sha1 ) + binary stream>sha1 ; + +: byte-array>sha1-interleave ( string -- seq ) [ zero? ] left-trim dup length odd? [ 1 tail ] when - seq>2seq [ string>sha1 ] 2apply + seq>2seq [ byte-array>sha1 ] 2apply swap 2seq>seq ; diff --git a/extra/crypto/sha2/sha2-tests.factor b/extra/crypto/sha2/sha2-tests.factor old mode 100644 new mode 100755 index 25da4e1446..8fe655f205 --- a/extra/crypto/sha2/sha2-tests.factor +++ b/extra/crypto/sha2/sha2-tests.factor @@ -1,7 +1,7 @@ USING: arrays kernel math namespaces sequences tools.test crypto.sha2 ; -[ "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" ] [ "" string>sha-256-string ] unit-test -[ "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad" ] [ "abc" string>sha-256-string ] unit-test -[ "f7846f55cf23e14eebeab5b4e1550cad5b509e3348fbc4efa3a1413d393cb650" ] [ "message digest" string>sha-256-string ] unit-test -[ "71c480df93d6ae2f1efad1447c66c9525e316218cf51fc8d9ed832f2daf18b73" ] [ "abcdefghijklmnopqrstuvwxyz" string>sha-256-string ] unit-test -[ "db4bfcbd4da0cd85a60c3c37d3fbd8805c77f15fc6b1fdfe614ee0a7c8fdb4c0" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" string>sha-256-string ] unit-test -[ "f371bc4a311f2b009eef952dd83ca80e2b60026c8e935592d0f9c308453c813e" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" string>sha-256-string ] unit-test +[ "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" ] [ "" byte-array>sha-256-string ] unit-test +[ "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad" ] [ "abc" byte-array>sha-256-string ] unit-test +[ "f7846f55cf23e14eebeab5b4e1550cad5b509e3348fbc4efa3a1413d393cb650" ] [ "message digest" byte-array>sha-256-string ] unit-test +[ "71c480df93d6ae2f1efad1447c66c9525e316218cf51fc8d9ed832f2daf18b73" ] [ "abcdefghijklmnopqrstuvwxyz" byte-array>sha-256-string ] unit-test +[ "db4bfcbd4da0cd85a60c3c37d3fbd8805c77f15fc6b1fdfe614ee0a7c8fdb4c0" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" byte-array>sha-256-string ] unit-test +[ "f371bc4a311f2b009eef952dd83ca80e2b60026c8e935592d0f9c308453c813e" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" byte-array>sha-256-string ] unit-test diff --git a/extra/crypto/sha2/sha2.factor b/extra/crypto/sha2/sha2.factor old mode 100644 new mode 100755 index 8e7710f40f..daba6d29ff --- a/extra/crypto/sha2/sha2.factor +++ b/extra/crypto/sha2/sha2.factor @@ -1,19 +1,10 @@ USING: crypto.common kernel splitting math sequences namespaces -io.binary ; +io.binary symbols ; IN: crypto.sha2 word +SYMBOLS: vars M K H S0 S1 process-M word-size block-size >word ; : a 0 ; : b 1 ; @@ -117,26 +108,25 @@ SYMBOL: >word T1 T2 update-vars ] with each vars get H get [ w+ ] 2map H set ; -: seq>string ( n seq -- string ) - [ swap [ >be % ] curry each ] "" make ; +: seq>byte-array ( n seq -- string ) + [ swap [ >be % ] curry each ] B{ } make ; -: string>sha2 ( string -- string ) +: byte-array>sha2 ( byte-array -- string ) t preprocess-plaintext block-size get group [ process-chunk ] each - 4 H get seq>string ; + 4 H get seq>byte-array ; PRIVATE> -: string>sha-256 ( string -- string ) +: byte-array>sha-256 ( string -- string ) [ K-256 K set initial-H-256 H set 4 word-size set 64 block-size set \ >32-bit >word set - string>sha2 + byte-array>sha2 ] with-scope ; -: string>sha-256-string ( string -- hexstring ) - string>sha-256 hex-string ; - +: byte-array>sha-256-string ( string -- hexstring ) + byte-array>sha-256 hex-string ; diff --git a/extra/db/mysql/mysql.factor b/extra/db/mysql/mysql.factor old mode 100644 new mode 100755 index 91562e89ff..dc7225514e --- a/extra/db/mysql/mysql.factor +++ b/extra/db/mysql/mysql.factor @@ -9,37 +9,37 @@ TUPLE: mysql-statement ; TUPLE: mysql-result-set ; M: mysql-db db-open ( mysql-db -- ) - ; + drop ; M: mysql-db dispose ( mysql-db -- ) mysql-db-handle mysql_close ; -M: mysql-db ( str -- statement ) - ; +M: mysql-db ( str in out -- statement ) + 3drop f ; -M: mysql-db ( str -- statement ) - ; +M: mysql-db ( str in out -- statement ) + 3drop f ; M: mysql-statement prepare-statement ( statement -- ) - ; + drop ; M: mysql-statement bind-statement* ( statement -- ) - ; + drop ; M: mysql-statement query-results ( query -- result-set ) - ; + drop f ; M: mysql-result-set #rows ( result-set -- n ) - ; + drop 0 ; M: mysql-result-set #columns ( result-set -- n ) - ; + drop 0 ; M: mysql-result-set row-column ( result-set n -- obj ) - ; + 2drop f ; -M: mysql-result-set advance-row ( result-set -- ? ) - ; +M: mysql-result-set advance-row ( result-set -- ) + drop ; M: mysql-db begin-transaction ( -- ) ; diff --git a/extra/db/sql/sql-tests.factor b/extra/db/sql/sql-tests.factor new file mode 100644 index 0000000000..2133b0e36c --- /dev/null +++ b/extra/db/sql/sql-tests.factor @@ -0,0 +1,42 @@ +USING: kernel db.sql ; +IN: db.sql.tests + +TUPLE: person name age ; +: insert-1 + { insert + { table "person" } + { columns "name" "age" } + { values "erg" 26 } + } ; + +: update-1 + { update "person" + { set { "name" "erg" } + { "age" 6 } } + { where { "age" 6 } } + } ; + +: select-1 + { select + { columns + "branchno" + { count "staffno" as "mycount" } + { sum "salary" as "mysum" } } + { from "staff" "lol" } + { where + { "salary" > all + { select + { columns "salary" } + { from "staff" } + { where { "branchno" "b003" } } + } + } + { "branchno" > 3 } } + { group-by "branchno" "lol2" } + { having { count "staffno" > 1 } } + { order-by "branchno" } + { offset 40 } + { limit 20 } + } ; + + diff --git a/extra/db/sql/sql.factor b/extra/db/sql/sql.factor new file mode 100755 index 0000000000..1de4bdfb5a --- /dev/null +++ b/extra/db/sql/sql.factor @@ -0,0 +1,69 @@ +USING: kernel parser quotations tuples words +namespaces.lib namespaces sequences arrays combinators +prettyprint strings math.parser sequences.lib math symbols ; +USE: tools.walker +IN: db.sql + +SYMBOLS: insert update delete select distinct columns from as +where group-by having order-by limit offset is-null desc all +any count avg table values ; + +: input-spec, 1, ; +: output-spec, 2, ; +: input, 3, ; +: output, 4, ; + +DEFER: sql% + +: (sql-interleave) ( seq sep -- ) + [ sql% ] curry [ sql% ] interleave ; + +: sql-interleave ( seq str sep -- ) + swap sql% (sql-interleave) ; + +: sql-function, ( seq function -- ) + sql% "(" sql% unclip sql% ")" sql% [ sql% ] each ; + +: sql-array% ( array -- ) + unclip + { + { columns [ "," (sql-interleave) ] } + { from [ "from" "," sql-interleave ] } + { where [ "where" "and" sql-interleave ] } + { group-by [ "group by" "," sql-interleave ] } + { having [ "having" "," sql-interleave ] } + { order-by [ "order by" "," sql-interleave ] } + { offset [ "offset" sql% sql% ] } + { limit [ "limit" sql% sql% ] } + { select [ "(select" sql% sql% ")" sql% ] } + { table [ sql% ] } + { set [ "set" "," sql-interleave ] } + { values [ "values(" sql% "," (sql-interleave) ")" sql% ] } + { count [ "count" sql-function, ] } + { sum [ "sum" sql-function, ] } + { avg [ "avg" sql-function, ] } + { min [ "min" sql-function, ] } + { max [ "max" sql-function, ] } + [ sql% [ sql% ] each ] + } case ; + +TUPLE: no-sql-match ; +: sql% ( obj -- ) + { + { [ dup string? ] [ " " 0% 0% ] } + { [ dup array? ] [ sql-array% ] } + { [ dup number? ] [ number>string sql% ] } + { [ dup symbol? ] [ unparse sql% ] } + { [ dup word? ] [ unparse sql% ] } + { [ t ] [ T{ no-sql-match } throw ] } + } cond ; + +: parse-sql ( obj -- sql in-spec out-spec in out ) + [ + unclip { + { insert [ "insert into" sql% ] } + { update [ "update" sql% ] } + { delete [ "delete" sql% ] } + { select [ "select" sql% ] } + } case [ sql% ] each + ] { "" { } { } { } { } } nmake ; diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor index f11f1e2ba6..9bf9ede895 100755 --- a/extra/db/sqlite/lib/lib.factor +++ b/extra/db/sqlite/lib/lib.factor @@ -3,8 +3,7 @@ USING: alien.c-types arrays assocs kernel math math.parser namespaces sequences db.sqlite.ffi db combinators continuations db.types calendar.format serialize -io.streams.string byte-arrays ; -USE: tools.walker +io.streams.byte-array byte-arrays io.encodings.binary ; IN: db.sqlite.lib : sqlite-error ( n -- * ) @@ -94,7 +93,7 @@ IN: db.sqlite.lib { TIMESTAMP [ sqlite-bind-text-by-name ] } { BLOB [ sqlite-bind-blob-by-name ] } { FACTOR-BLOB [ - [ serialize ] with-string-writer >byte-array + binary [ serialize ] with-byte-writer sqlite-bind-blob-by-name ] } { +native-id+ [ sqlite-bind-int-by-name ] } @@ -137,7 +136,8 @@ IN: db.sqlite.lib { DATETIME [ sqlite3_column_text dup [ ymdhms>timestamp ] when ] } { BLOB [ sqlite-column-blob ] } { FACTOR-BLOB [ - sqlite-column-blob [ deserialize ] with-string-reader + sqlite-column-blob + binary [ deserialize ] with-byte-reader ] } ! { NULL [ 2drop f ] } [ no-sql-type ] diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index d0bf721aa7..b72d788605 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -4,7 +4,7 @@ USING: alien arrays assocs classes compiler db hashtables io.files kernel math math.parser namespaces prettyprint sequences strings tuples alien.c-types continuations db.sqlite.lib db.sqlite.ffi db.tuples -words combinators.lib db.types combinators tools.walker +words combinators.lib db.types combinators combinators.cleave io namespaces.lib ; IN: db.sqlite @@ -22,14 +22,17 @@ M: sqlite-db db-close ( handle -- ) M: sqlite-db dispose ( db -- ) dispose-db ; +: with-sqlite ( path quot -- ) + sqlite-db swap with-db ; inline + TUPLE: sqlite-statement ; TUPLE: sqlite-result-set has-more? ; -M: sqlite-db ( str -- obj ) +M: sqlite-db ( str in out -- obj ) ; -M: sqlite-db ( str -- obj ) +M: sqlite-db ( str in out -- obj ) { set-statement-sql set-statement-in-params diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor index 023c72cd2d..7014aaa943 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -3,8 +3,7 @@ USING: arrays assocs db kernel math math.parser sequences continuations sequences.deep sequences.lib words namespaces tools.walker slots slots.private classes -mirrors tuples combinators calendar.format serialize -io.streams.string ; +mirrors tuples combinators calendar.format symbols ; IN: db.types HOOK: modifier-table db ( -- hash ) @@ -14,11 +13,10 @@ HOOK: create-type-table db ( -- hash ) HOOK: compound-type db ( str n -- hash ) TUPLE: sql-spec class slot-name column-name type modifiers primary-key ; -! ID is the Primary key -! +native-id+ can be a columns type or a modifier -SYMBOL: +native-id+ -! +assigned-id+ can only be a modifier -SYMBOL: +assigned-id+ + +SYMBOLS: +native-id+ +assigned-id+ +autoincrement+ ++serial+ +unique+ +default+ +null+ +not-null+ ++foreign-id+ +has-many+ ; : (primary-key?) ( obj -- ? ) { +native-id+ +assigned-id+ } member? ; @@ -45,35 +43,10 @@ SYMBOL: +assigned-id+ : assigned-id? ( spec -- ? ) sql-spec-primary-key +assigned-id+ = ; -SYMBOL: +foreign-id+ - -! Same concept, SQLite has autoincrement, PostgreSQL has serial -SYMBOL: +autoincrement+ -SYMBOL: +serial+ -SYMBOL: +unique+ - -SYMBOL: +default+ -SYMBOL: +null+ -SYMBOL: +not-null+ - -SYMBOL: +has-many+ - : relation? ( spec -- ? ) [ +has-many+ = ] deep-find ; -SYMBOL: INTEGER -SYMBOL: BIG-INTEGER -SYMBOL: DOUBLE -SYMBOL: REAL -SYMBOL: BOOLEAN -SYMBOL: TEXT -SYMBOL: VARCHAR -SYMBOL: DATE -SYMBOL: TIME -SYMBOL: DATETIME -SYMBOL: TIMESTAMP -SYMBOL: BLOB -SYMBOL: FACTOR-BLOB -SYMBOL: NULL +SYMBOLS: INTEGER BIG-INTEGER DOUBLE REAL BOOLEAN TEXT VARCHAR +DATE TIME DATETIME TIMESTAMP BLOB FACTOR-BLOB NULL ; : spec>tuple ( class spec -- tuple ) [ ?first3 ] keep 3 ?tail* diff --git a/unmaintained/gap-buffer/authors.txt b/extra/digraphs/authors.txt similarity index 100% rename from unmaintained/gap-buffer/authors.txt rename to extra/digraphs/authors.txt diff --git a/extra/digraphs/digraphs-tests.factor b/extra/digraphs/digraphs-tests.factor new file mode 100644 index 0000000000..b113c18ca7 --- /dev/null +++ b/extra/digraphs/digraphs-tests.factor @@ -0,0 +1,9 @@ +USING: digraphs kernel sequences tools.test ; +IN: digraphs.tests + +: test-digraph ( -- digraph ) + + { { "one" 1 } { "two" 2 } { "three" 3 } { "four" 4 } { "five" 5 } } [ first2 pick add-vertex ] each + { { "one" "three" } { "one" "four" } { "two" "three" } { "two" "one" } { "three" "four" } } [ first2 pick add-edge ] each ; + +[ 5 ] [ test-digraph topological-sort length ] unit-test diff --git a/extra/digraphs/digraphs.factor b/extra/digraphs/digraphs.factor new file mode 100644 index 0000000000..5c6fa9b2a1 --- /dev/null +++ b/extra/digraphs/digraphs.factor @@ -0,0 +1,50 @@ +! Copyright (C) 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs kernel new-slots sequences vectors ; +IN: digraphs + +TUPLE: digraph ; +TUPLE: vertex value edges ; + +: ( -- digraph ) + digraph construct-empty H{ } clone over set-delegate ; + +: ( value -- vertex ) + V{ } clone vertex construct-boa ; + +: add-vertex ( key value digraph -- ) + >r swap r> set-at ; + +: children ( key digraph -- seq ) + at edges>> ; + +: @edges ( from to digraph -- to edges ) swapd at edges>> ; +: add-edge ( from to digraph -- ) @edges push ; +: delete-edge ( from to digraph -- ) @edges delete ; + +: delete-to-edges ( to digraph -- ) + [ nip dupd edges>> delete ] assoc-each drop ; + +: delete-vertex ( key digraph -- ) + 2dup delete-at delete-to-edges ; + +: unvisited? ( unvisited key -- ? ) swap key? ; +: visited ( unvisited key -- ) swap delete-at ; + +DEFER: (topological-sort) +: visit-children ( seq unvisited key -- seq unvisited ) + over children [ (topological-sort) ] each ; + +: (topological-sort) ( seq unvisited key -- seq unvisited ) + 2dup unvisited? [ + [ visit-children ] keep 2dup visited pick push + ] [ + drop + ] if ; + +: topological-sort ( digraph -- seq ) + dup clone V{ } clone spin + [ drop (topological-sort) ] assoc-each drop reverse ; + +: topological-sorted-values ( digraph -- seq ) + dup topological-sort swap [ at value>> ] curry map ; diff --git a/extra/digraphs/summary.txt b/extra/digraphs/summary.txt new file mode 100644 index 0000000000..78e5a53313 --- /dev/null +++ b/extra/digraphs/summary.txt @@ -0,0 +1 @@ +Simple directed graph implementation for topological sorting diff --git a/unmaintained/gap-buffer/cursortree/authors.txt b/extra/gap-buffer/authors.txt similarity index 100% rename from unmaintained/gap-buffer/cursortree/authors.txt rename to extra/gap-buffer/authors.txt diff --git a/extra/gap-buffer/cursortree/authors.txt b/extra/gap-buffer/cursortree/authors.txt new file mode 100644 index 0000000000..e9c193bac7 --- /dev/null +++ b/extra/gap-buffer/cursortree/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/unmaintained/gap-buffer/cursortree/cursortree-tests.factor b/extra/gap-buffer/cursortree/cursortree-tests.factor similarity index 100% rename from unmaintained/gap-buffer/cursortree/cursortree-tests.factor rename to extra/gap-buffer/cursortree/cursortree-tests.factor diff --git a/unmaintained/gap-buffer/cursortree/cursortree.factor b/extra/gap-buffer/cursortree/cursortree.factor similarity index 90% rename from unmaintained/gap-buffer/cursortree/cursortree.factor rename to extra/gap-buffer/cursortree/cursortree.factor index de567702a8..e056cc8dee 100644 --- a/unmaintained/gap-buffer/cursortree/cursortree.factor +++ b/extra/gap-buffer/cursortree/cursortree.factor @@ -1,12 +1,12 @@ ! Copyright (C) 2007 Alex Chapman All Rights Reserved. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel gap-buffer generic trees trees.avl-tree math sequences quotations ; +USING: assocs kernel gap-buffer generic trees trees.avl math sequences quotations ; IN: gap-buffer.cursortree TUPLE: cursortree cursors ; : ( seq -- cursortree ) - cursortree construct-empty tuck set-delegate + cursortree construct-empty tuck set-delegate over set-cursortree-cursors ; GENERIC: cursortree-gb ( cursortree -- gb ) @@ -20,10 +20,11 @@ TUPLE: right-cursor ; : cursor-index ( cursor -- i ) cursor-i ; inline -: add-cursor ( cursortree cursor -- ) dup cursor-index rot tree-insert ; +: add-cursor ( cursortree cursor -- ) dup cursor-index rot avl-insert ; : remove-cursor ( cursortree cursor -- ) - dup [ eq? ] curry swap cursor-index rot cursortree-cursors tree-delete-if ; + cursor-index swap delete-at ; + ! dup [ eq? ] curry swap cursor-index rot cursortree-cursors tree-delete-if ; : set-cursor-index ( index cursor -- ) dup cursor-tree over remove-cursor tuck set-cursor-i diff --git a/unmaintained/gap-buffer/cursortree/summary.txt b/extra/gap-buffer/cursortree/summary.txt similarity index 100% rename from unmaintained/gap-buffer/cursortree/summary.txt rename to extra/gap-buffer/cursortree/summary.txt diff --git a/unmaintained/gap-buffer/gap-buffer-tests.factor b/extra/gap-buffer/gap-buffer-tests.factor similarity index 100% rename from unmaintained/gap-buffer/gap-buffer-tests.factor rename to extra/gap-buffer/gap-buffer-tests.factor diff --git a/unmaintained/gap-buffer/gap-buffer.factor b/extra/gap-buffer/gap-buffer.factor similarity index 98% rename from unmaintained/gap-buffer/gap-buffer.factor rename to extra/gap-buffer/gap-buffer.factor index 75d5be4f7a..99051ea678 100644 --- a/unmaintained/gap-buffer/gap-buffer.factor +++ b/extra/gap-buffer/gap-buffer.factor @@ -4,7 +4,7 @@ ! gap buffer -- largely influenced by Strandh and Villeneuve's Flexichain ! for a good introduction see: ! http://p-cos.net/lisp-ecoop/submissions/StrandhVilleneuveMoore.pdf -USING: kernel arrays sequences sequences.private circular math generic ; +USING: kernel arrays sequences sequences.private circular math math.functions generic ; IN: gap-buffer ! gap-start -- the first element of the gap diff --git a/unmaintained/gap-buffer/summary.txt b/extra/gap-buffer/summary.txt similarity index 100% rename from unmaintained/gap-buffer/summary.txt rename to extra/gap-buffer/summary.txt diff --git a/unmaintained/gap-buffer/tags.txt b/extra/gap-buffer/tags.txt similarity index 100% rename from unmaintained/gap-buffer/tags.txt rename to extra/gap-buffer/tags.txt diff --git a/extra/hash2/hash2-tests.factor b/extra/hash2/hash2-tests.factor old mode 100644 new mode 100755 index b7a4f42ac5..f3c17bb04b --- a/extra/hash2/hash2-tests.factor +++ b/extra/hash2/hash2-tests.factor @@ -1,4 +1,5 @@ USING: tools.test hash2 kernel ; +IN: hash2.tests : sample-hash 5 diff --git a/extra/hello-ui/deploy.factor b/extra/hello-ui/deploy.factor index a1ad007c62..43d8ca21ef 100755 --- a/extra/hello-ui/deploy.factor +++ b/extra/hello-ui/deploy.factor @@ -1,13 +1,14 @@ USING: tools.deploy.config ; H{ - { deploy-math? t } - { deploy-reflection 2 } { deploy-io 1 } - { deploy-word-props? f } - { deploy-word-defs? f } - { "stop-after-last-window?" t } - { deploy-ui? t } { deploy-compiler? t } + { deploy-word-defs? f } + { deploy-word-props? f } + { deploy-math? t } { deploy-name "Hello world" } { deploy-c-types? f } + { deploy-ui? t } + { deploy-threads? t } + { deploy-reflection 1 } + { "stop-after-last-window?" t } } diff --git a/extra/hooks/hooks-tests.factor b/extra/hooks/hooks-tests.factor new file mode 100644 index 0000000000..683109f795 --- /dev/null +++ b/extra/hooks/hooks-tests.factor @@ -0,0 +1,14 @@ +USING: hooks kernel tools.test ; +IN: hooks.tests + +SYMBOL: test-hook +test-hook reset-hook +: add-test-hook test-hook add-hook ; +[ ] [ test-hook call-hook ] unit-test +[ "op called" ] [ "op" [ "op called" ] add-test-hook test-hook call-hook ] unit-test +[ "first called" "second called" ] [ + test-hook reset-hook + "second op" [ "second called" ] add-test-hook + "first op" [ "first called" ] add-test-hook + test-hook call-hook +] unit-test diff --git a/extra/hooks/hooks.factor b/extra/hooks/hooks.factor new file mode 100644 index 0000000000..65e310f268 --- /dev/null +++ b/extra/hooks/hooks.factor @@ -0,0 +1,28 @@ +! Copyright (C) 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: assocs digraphs kernel namespaces sequences ; +IN: hooks + +: hooks ( -- hooks ) + \ hooks global [ drop H{ } clone ] cache ; + +: hook-graph ( hook -- graph ) + hooks [ drop ] cache ; + +: reset-hook ( hook -- ) + swap hooks set-at ; + +: add-hook ( key quot hook -- ) + #! hook should be a symbol. Note that symbols with the same name but + #! different vocab are not equal + hook-graph add-vertex ; + +: before ( key1 key2 hook -- ) + hook-graph add-edge ; + +: after ( key1 key2 hook -- ) + swapd before ; + +: call-hook ( hook -- ) + hook-graph topological-sorted-values [ call ] each ; + diff --git a/extra/html/elements/elements.factor b/extra/html/elements/elements.factor index 4f9a052032..286037d4dc 100644 --- a/extra/html/elements/elements.factor +++ b/extra/html/elements/elements.factor @@ -161,5 +161,6 @@ SYMBOL: html "id" "onclick" "style" "valign" "accesskey" "src" "language" "colspan" "onchange" "rel" "width" "selected" "onsubmit" "xmlns" "lang" "xml:lang" + "media" ] [ define-attribute-word ] each ] with-compilation-unit diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor index f011ff537e..0d733ba97d 100755 --- a/extra/http/client/client.factor +++ b/extra/http/client/client.factor @@ -82,8 +82,8 @@ PRIVATE> : download-to ( url file -- ) #! Downloads the contents of a URL to a file. - swap http-get-stream check-response - [ swap binary stream-copy ] with-disposal ; + swap http-get-stream swap check-response + [ swap latin1 stream-copy ] with-disposal ; : download ( url -- ) dup download-name download-to ; diff --git a/extra/http/server/authentication/basic/basic.factor b/extra/http/server/authentication/basic/basic.factor deleted file mode 100755 index b6dbed4b62..0000000000 --- a/extra/http/server/authentication/basic/basic.factor +++ /dev/null @@ -1,50 +0,0 @@ -! Copyright (c) 2007 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -IN: http.server.authentication.basic -USING: accessors new-slots quotations assocs kernel splitting -base64 crypto.sha2 html.elements io combinators http.server -http sequences ; - -! 'users' is a quotation or an assoc. The quotation -! has stack effect ( sha-256-string username -- ? ). -! It should perform the user authentication. 'sha-256-string' -! is the plain text password provided by the user passed through -! 'string>sha-256-string'. If 'users' is an assoc then -! it is a mapping of usernames to sha-256 hashed passwords. -TUPLE: realm responder name users ; - -C: realm - -: user-authorized? ( password username realm -- ? ) - users>> { - { [ dup callable? ] [ call ] } - { [ dup assoc? ] [ at = ] } - } cond ; - -: authorization-ok? ( realm header -- bool ) - #! Given the realm and the 'Authorization' header, - #! authenticate the user. - dup [ - " " split1 swap "Basic" = [ - base64> ":" split1 string>sha-256-string - spin user-authorized? - ] [ - 2drop f - ] if - ] [ - 2drop f - ] if ; - -: <401> ( realm -- response ) - 401 "Unauthorized" - "Basic realm=\"" rot name>> "\"" 3append - "WWW-Authenticate" set-header - [ - - "Username or Password is invalid" write - - ] >>body ; - -M: realm call-responder ( request path realm -- response ) - pick "authorization" header dupd authorization-ok? - [ responder>> call-responder ] [ 2nip <401> ] if ; diff --git a/extra/http/server/templating/fhtml/fhtml-tests.factor b/extra/http/server/templating/fhtml/fhtml-tests.factor index 40654734fa..e655bf9001 100755 --- a/extra/http/server/templating/fhtml/fhtml-tests.factor +++ b/extra/http/server/templating/fhtml/fhtml-tests.factor @@ -1,5 +1,6 @@ USING: io io.files io.streams.string io.encodings.utf8 -http.server.templating.fhtml kernel tools.test sequences ; +http.server.templating.fhtml kernel tools.test sequences +parser ; IN: http.server.templating.fhtml.tests : test-template ( path -- ? ) @@ -14,4 +15,6 @@ IN: http.server.templating.fhtml.tests [ t ] [ "bug" test-template ] unit-test [ t ] [ "stack" test-template ] unit-test -[ ] [ "<%\n%>" parse-template drop ] unit-test +[ + [ ] [ "<%\n%>" parse-template drop ] unit-test +] with-file-vocabs diff --git a/extra/io/buffers/buffers-docs.factor b/extra/io/buffers/buffers-docs.factor old mode 100644 new mode 100755 index cf069f17aa..dbd05eaf2f --- a/extra/io/buffers/buffers-docs.factor +++ b/extra/io/buffers/buffers-docs.factor @@ -1,8 +1,8 @@ -USING: help.markup help.syntax strings alien ; +USING: help.markup help.syntax byte-arrays alien ; IN: io.buffers ARTICLE: "buffers" "Locked I/O buffers" -"I/O buffers are first-in-first-out queues of characters. Their key feature is that they are backed by manually allocated storage that does not get moved by the garbage collector. They are used to implement native I/O backends." +"I/O buffers are first-in-first-out queues of bytes. Their key feature is that they are backed by manually allocated storage that does not get moved by the garbage collector. They are used to implement native I/O backends." $nl "Buffer words are found in the " { $vocab-link "buffers" } " vocabulary." { $subsection buffer } @@ -23,7 +23,7 @@ $nl { $subsection buffer-until } "Writing to the buffer:" { $subsection extend-buffer } -{ $subsection ch>buffer } +{ $subsection byte>buffer } { $subsection >buffer } { $subsection n>buffer } ; @@ -48,7 +48,7 @@ HELP: buffer-free { $warning "You " { $emphasis "must" } " free a buffer using this word, before letting the GC collect the buffer tuple instance." } ; HELP: (buffer>>) -{ $values { "buffer" buffer } { "string" "a string" } } +{ $values { "buffer" buffer } { "byte-array" byte-array } } { $description "Collects the entire contents of the buffer into a string." } ; HELP: buffer-reset @@ -68,15 +68,15 @@ HELP: buffer-end { $description "Outputs the memory address of the current fill-pointer." } ; HELP: (buffer>) -{ $values { "n" "a non-negative integer" } { "buffer" buffer } { "string" string } } +{ $values { "n" "a non-negative integer" } { "buffer" buffer } { "byte-array" byte-array } } { $description "Outputs a string of the first " { $snippet "n" } " characters at the buffer's current position. If there are less than " { $snippet "n" } " characters available, the output is truncated." } ; HELP: buffer> -{ $values { "n" "a non-negative integer" } { "buffer" buffer } { "string" "a string" } } +{ $values { "n" "a non-negative integer" } { "buffer" buffer } { "byte-array" byte-array } } { $description "Collects a string of " { $snippet "n" } " characters starting from the buffer's current position, and advances the position accordingly. If there are less than " { $snippet "n" } " characters available, the output is truncated." } ; HELP: buffer>> -{ $values { "buffer" buffer } { "string" "a string" } } +{ $values { "buffer" buffer } { "byte-array" byte-array } } { $description "Collects the contents of the buffer into a string, and resets the position and fill pointer to 0." } ; HELP: buffer-length @@ -102,11 +102,11 @@ HELP: check-overflow { $errors "Throws an error if the buffer contains unread data, and the new data does not fit." } ; HELP: >buffer -{ $values { "string" "a string" } { "buffer" buffer } } +{ $values { "byte-array" byte-array } { "buffer" buffer } } { $description "Copies a string to the buffer's fill pointer, and advances it accordingly." } ; -HELP: ch>buffer -{ $values { "ch" "a character" } { "buffer" buffer } } +HELP: byte>buffer +{ $values { "byte" "a byte" } { "buffer" buffer } } { $description "Appends a single byte to a buffer." } ; HELP: n>buffer @@ -123,5 +123,5 @@ HELP: buffer-pop { $description "Outputs the byte at the buffer position and advances the position." } ; HELP: buffer-until -{ $values { "separators" string } { "buffer" buffer } { "string" string } { "separator" "a character or " { $link f } } } -{ $description "Searches the buffer for a character appearing in " { $snippet "separators" } ", starting from " { $link buffer-pos } ". If a separator is found, all data up to but not including the separator is output, together with the separator itself; otherwise the remainder of the buffer's contents are output together with " { $link f } "." } ; +{ $values { "separators" "a sequence of bytes" } { "buffer" buffer } { "byte-array" byte-array } { "separator" "a byte or " { $link f } } } +{ $description "Searches the buffer for a byte appearing in " { $snippet "separators" } ", starting from " { $link buffer-pos } ". If a separator is found, all data up to but not including the separator is output, together with the separator itself; otherwise the remainder of the buffer's contents are output together with " { $link f } "." } ; diff --git a/extra/io/buffers/buffers-tests.factor b/extra/io/buffers/buffers-tests.factor index 2260bf5882..1f3e262fed 100755 --- a/extra/io/buffers/buffers-tests.factor +++ b/extra/io/buffers/buffers-tests.factor @@ -1,15 +1,15 @@ IN: io.buffers.tests USING: alien alien.c-types io.buffers kernel kernel.private libc -sequences tools.test namespaces ; +sequences tools.test namespaces byte-arrays strings ; : buffer-set ( string buffer -- ) - 2dup buffer-ptr string>char-memory + over >byte-array over buffer-ptr byte-array>memory >r length r> buffer-reset ; : string>buffer ( string -- buffer ) dup length tuck buffer-set ; -[ "" 65536 ] [ +[ B{ } 65536 ] [ 65536 dup (buffer>>) over buffer-capacity @@ -18,15 +18,15 @@ sequences tools.test namespaces ; [ "hello world" "" ] [ "hello world" string>buffer - dup (buffer>>) + dup (buffer>>) >string 0 pick buffer-reset - over (buffer>>) + over (buffer>>) >string rot buffer-free ] unit-test [ "hello" ] [ "hello world" string>buffer - 5 over buffer> swap buffer-free + 5 over buffer> >string swap buffer-free ] unit-test [ 11 ] [ @@ -36,8 +36,8 @@ sequences tools.test namespaces ; [ "hello world" ] [ "hello" 1024 [ buffer-set ] keep - " world" over >buffer - dup (buffer>>) swap buffer-free + " world" >byte-array over >buffer + dup (buffer>>) >string swap buffer-free ] unit-test [ CHAR: e ] [ @@ -47,33 +47,33 @@ sequences tools.test namespaces ; [ "hello" CHAR: \r ] [ "hello\rworld" string>buffer - "\r" over buffer-until + "\r" over buffer-until >r >string r> rot buffer-free ] unit-test [ "hello" CHAR: \r ] [ "hello\rworld" string>buffer - "\n\r" over buffer-until + "\n\r" over buffer-until >r >string r> rot buffer-free ] unit-test [ "hello\rworld" f ] [ "hello\rworld" string>buffer - "X" over buffer-until + "X" over buffer-until >r >string r> rot buffer-free ] unit-test [ "hello" CHAR: \r "world" CHAR: \n ] [ "hello\rworld\n" string>buffer - [ "\r\n" swap buffer-until ] keep - [ "\r\n" swap buffer-until ] keep + [ "\r\n" swap buffer-until >r >string r> ] keep + [ "\r\n" swap buffer-until >r >string r> ] keep buffer-free ] unit-test "hello world" string>buffer "b" set -[ "hello world" ] [ 1000 "b" get buffer> ] unit-test +[ "hello world" ] [ 1000 "b" get buffer> >string ] unit-test "b" get buffer-free 100 "b" set -[ 1000 "b" get n>buffer ] must-fail +[ 1000 "b" get n>buffer >string ] must-fail "b" get buffer-free diff --git a/extra/io/buffers/buffers.factor b/extra/io/buffers/buffers.factor index ef12543d52..a2ecfe3f3e 100755 --- a/extra/io/buffers/buffers.factor +++ b/extra/io/buffers/buffers.factor @@ -3,7 +3,7 @@ ! See http://factorcode.org/license.txt for BSD license. IN: io.buffers USING: alien alien.accessors alien.c-types alien.syntax kernel -kernel.private libc math sequences strings hints ; +kernel.private libc math sequences byte-arrays strings hints ; TUPLE: buffer size ptr fill pos ; @@ -37,18 +37,18 @@ TUPLE: buffer size ptr fill pos ; : buffer-pop ( buffer -- ch ) dup buffer-peek 1 rot buffer-consume ; -: (buffer>) ( n buffer -- string ) +: (buffer>) ( n buffer -- byte-array ) [ dup buffer-fill swap buffer-pos - min ] keep - buffer@ swap memory>char-string ; + buffer@ swap memory>byte-array ; -: buffer> ( n buffer -- string ) +: buffer> ( n buffer -- byte-array ) [ (buffer>) ] 2keep buffer-consume ; -: (buffer>>) ( buffer -- string ) +: (buffer>>) ( buffer -- byte-array ) dup buffer-pos over buffer-ptr - over buffer-fill rot buffer-pos - memory>char-string ; + over buffer-fill rot buffer-pos - memory>byte-array ; -: buffer>> ( buffer -- string ) +: buffer>> ( buffer -- byte-array ) dup (buffer>>) 0 rot buffer-reset ; : search-buffer-until ( start end alien separators -- n ) @@ -56,7 +56,7 @@ TUPLE: buffer size ptr fill pos ; HINTS: search-buffer-until { fixnum fixnum simple-alien string } ; -: finish-buffer-until ( buffer n -- string separator ) +: finish-buffer-until ( buffer n -- byte-array separator ) [ over buffer-pos - over buffer> @@ -65,7 +65,7 @@ HINTS: search-buffer-until { fixnum fixnum simple-alien string } ; buffer>> f ] if* ; -: buffer-until ( separators buffer -- string separator ) +: buffer-until ( separators buffer -- byte-array separator ) tuck { buffer-pos buffer-fill buffer-ptr } get-slots roll search-buffer-until finish-buffer-until ; @@ -85,12 +85,12 @@ HINTS: search-buffer-until { fixnum fixnum simple-alien string } ; : check-overflow ( n buffer -- ) 2dup buffer-capacity > [ extend-buffer ] [ 2drop ] if ; -: >buffer ( string buffer -- ) +: >buffer ( byte-array buffer -- ) over length over check-overflow - [ buffer-end string>char-memory ] 2keep + [ buffer-end byte-array>memory ] 2keep [ buffer-fill swap length + ] keep set-buffer-fill ; -: ch>buffer ( ch buffer -- ) +: byte>buffer ( ch buffer -- ) 1 over check-overflow [ buffer-end 0 set-alien-unsigned-1 ] keep [ buffer-fill 1+ ] keep set-buffer-fill ; diff --git a/extra/io/encodings/latin1/latin1.factor b/extra/io/encodings/latin1/latin1.factor index ec01da5983..71e98a1747 100755 --- a/extra/io/encodings/latin1/latin1.factor +++ b/extra/io/encodings/latin1/latin1.factor @@ -7,3 +7,6 @@ TUPLE: latin1 ; M: latin1 stream-write-encoded drop 256 encode-check< ; + +M: latin1 decode-step + drop swap push ; diff --git a/extra/io/files/tmp/tmp-tests.factor b/extra/io/files/tmp/tmp-tests.factor new file mode 100644 index 0000000000..ba2ff7046c --- /dev/null +++ b/extra/io/files/tmp/tmp-tests.factor @@ -0,0 +1,5 @@ +USING: io.files io.files.tmp kernel strings tools.test ; +IN: temporary + +[ t ] [ tmpdir string? ] unit-test +[ t f ] [ ".tmp" [ dup exists? swap ] with-tmpfile exists? ] unit-test diff --git a/extra/io/files/tmp/tmp.factor b/extra/io/files/tmp/tmp.factor new file mode 100644 index 0000000000..a859cfdc91 --- /dev/null +++ b/extra/io/files/tmp/tmp.factor @@ -0,0 +1,22 @@ +USING: continuations io io.files kernel sequences strings.lib ; +IN: io.files.tmp + +: tmpdir ( -- dirname ) + #! ensure that a tmp dir exists and return its name + #! I'm using a sub-directory of factor for crossplatconformity (windows doesn't have /tmp) + "tmp" resource-path dup directory? [ dup make-directory ] unless ; + +: touch ( filename -- ) + dispose ; + +: tmpfile ( extension -- filename ) + 16 random-alphanumeric-string over append + tmpdir swap path+ dup exists? [ + drop tmpfile + ] [ + nip dup touch + ] if ; + +: with-tmpfile ( extension quot -- ) + #! quot should have stack effect ( filename -- ) + swap tmpfile tuck swap curry swap [ delete-file ] curry [ ] cleanup ; diff --git a/extra/io/mmap/mmap-tests.factor b/extra/io/mmap/mmap-tests.factor index 81c3faec1e..f1c65178d9 100644 --- a/extra/io/mmap/mmap-tests.factor +++ b/extra/io/mmap/mmap-tests.factor @@ -3,7 +3,7 @@ sequences io.encodings.ascii ; IN: io.mmap.tests [ "mmap-test-file.txt" resource-path delete-file ] ignore-errors -[ ] [ "mmap-test-file.txt" resource-path ascii [ "12345" write ] with-file-writer ] unit-test +[ ] [ "12345" "mmap-test-file.txt" resource-path ascii set-file-contents ] unit-test [ ] [ "mmap-test-file.txt" resource-path dup file-length [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test [ 5 ] [ "mmap-test-file.txt" resource-path dup file-length [ length ] with-mapped-file ] unit-test [ "22345" ] [ "mmap-test-file.txt" resource-path ascii file-contents ] unit-test diff --git a/extra/io/nonblocking/nonblocking-docs.factor b/extra/io/nonblocking/nonblocking-docs.factor index d8d2cf5479..e1cb6425ff 100755 --- a/extra/io/nonblocking/nonblocking-docs.factor +++ b/extra/io/nonblocking/nonblocking-docs.factor @@ -1,5 +1,5 @@ USING: io io.buffers io.backend help.markup help.syntax kernel -strings sbufs words continuations ; +byte-arrays sbufs words continuations byte-vectors ; IN: io.nonblocking ARTICLE: "io.nonblocking" "Non-blocking I/O implementation" @@ -93,12 +93,12 @@ HELP: unless-eof { $description "If the port has reached end of file, outputs " { $link f } ", otherwise applies the quotation to the port." } ; HELP: read-until-step -{ $values { "separators" string } { "port" input-port } { "string/f" "a string or " { $link f } } { "separator/f" "a character or " { $link f } } } +{ $values { "separators" "a sequence of bytes" } { "port" input-port } { "byte-array/f" "a byte array or " { $link f } } { "separator/f" "a byte or " { $link f } } } { $description "If the port has reached end of file, outputs " { $link f } { $link f } ", otherwise scans the buffer for a separator and outputs a string up to but not including the separator." } ; HELP: read-until-loop -{ $values { "seps" string } { "port" input-port } { "sbuf" sbuf } { "separator/f" "a character or " { $link f } } } -{ $description "Accumulates data in the string buffer, calling " { $link (wait-to-read) } " as many times as necessary, until either an occurrence of a separator is read, or end of file is reached." } ; +{ $values { "seps" "a sequence of bytes" } { "port" input-port } { "accum" byte-vector } { "separator/f" "a byte or " { $link f } } } +{ $description "Accumulates data in the byte vector, calling " { $link (wait-to-read) } " as many times as necessary, until either an occurrence of a separator is read, or end of file is reached." } ; HELP: can-write? { $values { "len" "a positive integer" } { "writer" output-port } { "?" "a boolean" } } diff --git a/extra/io/nonblocking/nonblocking.factor b/extra/io/nonblocking/nonblocking.factor index 6eee3739d9..1cd8658355 100755 --- a/extra/io/nonblocking/nonblocking.factor +++ b/extra/io/nonblocking/nonblocking.factor @@ -75,7 +75,7 @@ M: input-port stream-read1 [ wait-to-read ] 2keep [ dupd buffer> ] unless-eof nip ; -: read-loop ( count port sbuf -- ) +: read-loop ( count port accum -- ) pick over length - dup 0 > [ pick read-step dup [ over push-all read-loop @@ -143,7 +143,7 @@ M: input-port stream-read-partial ( max stream -- byte-array/f ) tuck can-write? [ drop ] [ stream-flush ] if ; M: output-port stream-write1 - 1 over wait-to-write ch>buffer ; + 1 over wait-to-write byte>buffer ; M: output-port stream-write over length over buffer-size > [ diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index 1d472c19a3..73090ea724 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -68,7 +68,7 @@ M: unix-io delete-directory ( path -- ) ] with-disposal ; M: unix-io copy-file ( from to -- ) - >r dup file-permissions over r> (copy-file) chmod io-error ; + [ (copy-file) ] 2keep swap file-permissions chmod io-error ; : stat>type ( stat -- type ) stat-st_mode { diff --git a/extra/io/windows/files/files.factor b/extra/io/windows/files/files.factor index d107f80723..3d51e65116 100644 --- a/extra/io/windows/files/files.factor +++ b/extra/io/windows/files/files.factor @@ -3,23 +3,13 @@ USING: alien.c-types io.files io.windows kernel math windows windows.kernel32 combinators.cleave windows.time calendar combinators math.functions -sequences combinators.lib namespaces words ; +sequences combinators.lib namespaces words symbols ; IN: io.windows.files -SYMBOL: +read-only+ -SYMBOL: +hidden+ -SYMBOL: +system+ -SYMBOL: +directory+ -SYMBOL: +archive+ -SYMBOL: +device+ -SYMBOL: +normal+ -SYMBOL: +temporary+ -SYMBOL: +sparse-file+ -SYMBOL: +reparse-point+ -SYMBOL: +compressed+ -SYMBOL: +offline+ -SYMBOL: +not-content-indexed+ -SYMBOL: +encrypted+ +SYMBOLS: +read-only+ +hidden+ +system+ ++directory+ +archive+ +device+ +normal+ +temporary+ ++sparse-file+ +reparse-point+ +compressed+ +offline+ ++not-content-indexed+ +encrypted+ ; : expand-constants ( word/obj -- obj'/obj ) dup word? [ execute ] when ; diff --git a/extra/io/windows/nt/monitors/monitors.factor b/extra/io/windows/nt/monitors/monitors.factor index d14dff8c22..83e062c3a9 100755 --- a/extra/io/windows/nt/monitors/monitors.factor +++ b/extra/io/windows/nt/monitors/monitors.factor @@ -5,7 +5,7 @@ io.windows.nt.backend kernel math windows windows.kernel32 windows.types libc assocs alien namespaces continuations io.monitors io.monitors.private io.nonblocking io.buffers io.files io.timeouts io sequences hashtables sorting arrays -combinators math.bitfields ; +combinators math.bitfields strings ; IN: io.windows.nt.monitors : open-directory ( path -- handle ) @@ -66,6 +66,9 @@ M: windows-nt-io ( path recursive? -- monitor ) { [ t ] [ +modify-file+ ] } } cond nip ; +: memory>u16-string ( alien len -- string ) + [ memory>byte-array ] keep 2/ c-ushort-array> >string ; + : parse-file-notify ( buffer -- changed path ) { FILE_NOTIFY_INFORMATION-FileName diff --git a/extra/jamshred/authors.txt b/extra/jamshred/authors.txt old mode 100755 new mode 100644 diff --git a/extra/jamshred/game/game.factor b/extra/jamshred/game/game.factor index fe517d68fd..f82ee91d22 100644 --- a/extra/jamshred/game/game.factor +++ b/extra/jamshred/game/game.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2007 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. USING: kernel opengl arrays sequences jamshred.tunnel jamshred.player math.vectors ; IN: jamshred.game diff --git a/extra/jamshred/gl/gl.factor b/extra/jamshred/gl/gl.factor index da38e43392..85c5a8dbaf 100644 --- a/extra/jamshred/gl/gl.factor +++ b/extra/jamshred/gl/gl.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2007 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types colors jamshred.game jamshred.oint jamshred.player jamshred.tunnel kernel math math.vectors opengl opengl.gl opengl.glu sequences ; diff --git a/extra/jamshred/jamshred.factor b/extra/jamshred/jamshred.factor index 36dd0619f0..8beecc955c 100644 --- a/extra/jamshred/jamshred.factor +++ b/extra/jamshred/jamshred.factor @@ -1,9 +1,11 @@ -USING: arrays jamshred.game jamshred.gl kernel math math.constants -namespaces sequences timers ui ui.gadgets ui.gestures ui.render +! Copyright (C) 2007, 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: alarms arrays calendar jamshred.game jamshred.gl kernel math +math.constants namespaces sequences ui ui.gadgets ui.gestures ui.render math.vectors ; IN: jamshred -TUPLE: jamshred-gadget jamshred last-hand-loc ; +TUPLE: jamshred-gadget jamshred last-hand-loc alarm ; : ( jamshred -- gadget ) jamshred-gadget construct-gadget tuck set-jamshred-gadget-jamshred ; @@ -17,13 +19,17 @@ M: jamshred-gadget pref-dim* M: jamshred-gadget draw-gadget* ( gadget -- ) dup jamshred-gadget-jamshred swap rect-dim first2 draw-jamshred ; -M: jamshred-gadget tick ( gadget -- ) +: tick ( gadget -- ) dup jamshred-gadget-jamshred jamshred-update relayout-1 ; M: jamshred-gadget graft* ( gadget -- ) - 10 1 add-timer ; + [ + [ tick ] curry 10 milliseconds from-now 10 milliseconds add-alarm + ] keep set-jamshred-gadget-alarm ; -M: jamshred-gadget ungraft* ( gadget -- ) remove-timer ; +M: jamshred-gadget ungraft* ( gadget -- ) + [ jamshred-gadget-alarm cancel-alarm f ] keep + set-jamshred-gadget-alarm ; : jamshred-restart ( jamshred-gadget -- ) swap set-jamshred-gadget-jamshred ; diff --git a/extra/jamshred/oint/oint.factor b/extra/jamshred/oint/oint.factor index 254be2057a..bcf4597307 100644 --- a/extra/jamshred/oint/oint.factor +++ b/extra/jamshred/oint/oint.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2007 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. USING: arrays float-arrays kernel math math.constants math.functions math.matrices math.vectors math.quaternions random sequences ; IN: jamshred.oint diff --git a/extra/jamshred/player/player.factor b/extra/jamshred/player/player.factor index 4daecf29a2..6cc433903e 100644 --- a/extra/jamshred/player/player.factor +++ b/extra/jamshred/player/player.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2007 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. USING: colors jamshred.oint jamshred.tunnel kernel math math.constants sequences ; IN: jamshred.player diff --git a/extra/jamshred/summary.txt b/extra/jamshred/summary.txt new file mode 100644 index 0000000000..e26fc1cf8b --- /dev/null +++ b/extra/jamshred/summary.txt @@ -0,0 +1 @@ +A simple 3d tunnel racing game diff --git a/extra/jamshred/tags.txt b/extra/jamshred/tags.txt new file mode 100644 index 0000000000..8ae5957a4b --- /dev/null +++ b/extra/jamshred/tags.txt @@ -0,0 +1,2 @@ +applications +games diff --git a/extra/jamshred/tunnel/tunnel-tests.factor b/extra/jamshred/tunnel/tunnel-tests.factor index 3cc230126c..8031678896 100644 --- a/extra/jamshred/tunnel/tunnel-tests.factor +++ b/extra/jamshred/tunnel/tunnel-tests.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2007 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. USING: jamshred.oint jamshred.tunnel kernel sequences tools.test ; IN: jamshred.tunnel.tests diff --git a/extra/jamshred/tunnel/tunnel.factor b/extra/jamshred/tunnel/tunnel.factor index 4d60a65a4a..61fef7959c 100755 --- a/extra/jamshred/tunnel/tunnel.factor +++ b/extra/jamshred/tunnel/tunnel.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2007 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. USING: arrays float-arrays kernel jamshred.oint math math.functions math.ranges math.vectors math.constants random sequences vectors ; IN: jamshred.tunnel diff --git a/extra/koszul/koszul-tests.factor b/extra/koszul/koszul-tests.factor old mode 100644 new mode 100755 index 13dc341350..01fba49995 --- a/extra/koszul/koszul-tests.factor +++ b/extra/koszul/koszul-tests.factor @@ -1,4 +1,5 @@ -USING: koszul tools.test kernel sequences assocs namespaces ; +USING: koszul tools.test kernel sequences assocs namespaces +symbols ; IN: koszul.tests [ diff --git a/extra/koszul/koszul.factor b/extra/koszul/koszul.factor index 9545e1cc9d..69de838eec 100755 --- a/extra/koszul/koszul.factor +++ b/extra/koszul/koszul.factor @@ -3,14 +3,10 @@ USING: arrays assocs hashtables assocs io kernel math math.vectors math.matrices math.matrices.elimination namespaces parser prettyprint sequences words combinators math.parser -splitting sorting shuffle ; +splitting sorting shuffle symbols ; IN: koszul ! Utilities -: SYMBOLS: - ";" parse-tokens [ create-in define-symbol ] each ; - parsing - : -1^ odd? -1 1 ? ; : >alt ( obj -- vec ) diff --git a/extra/ldap/ldap-tests.factor b/extra/ldap/ldap-tests.factor old mode 100644 new mode 100755 index 42e51c782a..14029706e5 --- a/extra/ldap/ldap-tests.factor +++ b/extra/ldap/ldap-tests.factor @@ -1,57 +1,58 @@ -USING: alien alien.c-types io kernel ldap ldap.libldap namespaces prettyprint -tools.test ; +USING: alien alien.c-types io kernel ldap ldap.libldap +namespaces prettyprint tools.test ; +IN: ldap.tests "void*" "ldap://localhost:389" initialize get-ldp LDAP_OPT_PROTOCOL_VERSION LDAP_VERSION3 set-option -[ 3 ] [ +[ 3 ] [ get-ldp LDAP_OPT_PROTOCOL_VERSION "int*" [ get-option ] keep *int ] unit-test [ -get-ldp "cn=jimbob,dc=example,dc=com" "secret" [ + get-ldp "cn=jimbob,dc=example,dc=com" "secret" [ - ! get-ldp "dc=example,dc=com" LDAP_SCOPE_ONELEVEL "(objectclass=*)" f 0 - ! "void*" [ search-s ] keep *int . + ! get-ldp "dc=example,dc=com" LDAP_SCOPE_ONELEVEL "(objectclass=*)" f 0 + ! "void*" [ search-s ] keep *int . - [ 2 ] [ - get-ldp "dc=example,dc=com" LDAP_SCOPE_SUBTREE "(objectclass=*)" f 0 - search - ] unit-test + [ 2 ] [ + get-ldp "dc=example,dc=com" LDAP_SCOPE_SUBTREE "(objectclass=*)" f 0 + search + ] unit-test - ! get-ldp LDAP_RES_ANY 0 f "void*" result . + ! get-ldp LDAP_RES_ANY 0 f "void*" result . - get-ldp LDAP_RES_ANY LDAP_MSG_ALL f "void*" result + get-ldp LDAP_RES_ANY LDAP_MSG_ALL f "void*" result - ! get-message *int . + ! get-message *int . - "Message ID: " write + "Message ID: " write - get-message msgid . + get-message msgid . - get-ldp get-message get-dn . + get-ldp get-message get-dn . - "Entries count: " write + "Entries count: " write - get-ldp get-message count-entries . + get-ldp get-message count-entries . - SYMBOL: entry - SYMBOL: attr + SYMBOL: entry + SYMBOL: attr - "Attribute: " write + "Attribute: " write - get-ldp get-message first-entry entry set get-ldp entry get - "void*" first-attribute dup . attr set + get-ldp get-message first-entry entry set get-ldp entry get + "void*" first-attribute dup . attr set - "Value: " write + "Value: " write - get-ldp entry get attr get get-values *char* . + get-ldp entry get attr get get-values *char* . - get-ldp get-message first-message msgtype result-type + get-ldp get-message first-message msgtype result-type - get-ldp get-message next-message msgtype result-type + get-ldp get-message next-message msgtype result-type -] with-bind + ] with-bind ] drop diff --git a/extra/morse/morse-docs.factor b/extra/morse/morse-docs.factor new file mode 100644 index 0000000000..c11ba23db7 --- /dev/null +++ b/extra/morse/morse-docs.factor @@ -0,0 +1,25 @@ +! Copyright (C) 2007 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax ; +IN: morse + +HELP: ch>morse +{ $values + { "ch" "A character that has a morse code translation" } { "str" "A string consisting of zero or more dots and dashes" } } +{ $description "If the given character has a morse code translation, then return that translation, otherwise return an empty string." } ; + +HELP: morse>ch +{ $values + { "str" "A string of dots and dashes that represents a single character in morse code" } { "ch" "The translated character" } } +{ $description "If the given string represents a morse code character, then return that character, otherwise return f" } ; + +HELP: >morse +{ $values + { "str" "A string of ASCII characters which can be translated into morse code" } { "str" "A string in morse code" } } +{ $description "Translates ASCII text into morse code, represented by a series of dots, dashes, and slashes." } +{ $see-also morse> ch>morse } ; + +HELP: morse> +{ $values { "str" "A string of morse code, in which the character '.' represents dots, '-' dashes, ' ' spaces between letters, and ' / ' spaces between words." } { "str" "The ASCII translation of the given string" } } +{ $description "Translates morse code into ASCII text" } +{ $see-also >morse morse>ch } ; diff --git a/extra/morse/morse-tests.factor b/extra/morse/morse-tests.factor new file mode 100644 index 0000000000..97efe1afb4 --- /dev/null +++ b/extra/morse/morse-tests.factor @@ -0,0 +1,11 @@ +! Copyright (C) 2007 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: arrays morse strings tools.test ; + +[ "" ] [ CHAR: \\ ch>morse ] unit-test +[ "..." ] [ CHAR: s ch>morse ] unit-test +[ CHAR: s ] [ "..." morse>ch ] unit-test +[ f ] [ "..--..--.." morse>ch ] unit-test +[ "-- --- .-. ... . / -.-. --- -.. ." ] [ "morse code" >morse ] unit-test +[ "morse code" ] [ "-- --- .-. ... . / -.-. --- -.. ." morse> ] unit-test +[ "hello, world!" ] [ "Hello, World!" >morse morse> ] unit-test diff --git a/extra/morse/morse.factor b/extra/morse/morse.factor new file mode 100644 index 0000000000..f493951ed5 --- /dev/null +++ b/extra/morse/morse.factor @@ -0,0 +1,125 @@ +! Copyright (C) 2007 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: assocs hashtables kernel lazy-lists namespaces openal +parser-combinators promises sequences strings unicode.case ; +IN: morse + +morse-assoc ( -- assoc ) + morse-codes >hashtable ; + +: morse>ch-assoc ( -- assoc ) + morse-codes [ reverse ] map >hashtable ; + +PRIVATE> + +: ch>morse ( ch -- str ) + ch>lower ch>morse-assoc at* swap "" ? ; + +: morse>ch ( str -- ch ) + morse>ch-assoc at* swap f ? ; + +: >morse ( str -- str ) + [ + [ CHAR: \s , ] [ ch>morse % ] interleave + ] "" make ; + + <+> ; + +LAZY: 'morse-word' ( -- parser ) + 'morse-char' 'char-gap' list-of ; + +LAZY: 'morse-words' ( -- parser ) + 'morse-word' 'word-gap' list-of ; + +PRIVATE> + +: morse> ( str -- str ) + 'morse-words' parse car parse-result-parsed [ + [ + >string morse>ch + ] map >string + ] map [ [ CHAR: \s , ] [ % ] interleave ] "" make ; + diff --git a/extra/msxml-to-csv/msxml-to-csv.factor b/extra/msxml-to-csv/msxml-to-csv.factor index 3004324511..839fcaaf54 100644 --- a/extra/msxml-to-csv/msxml-to-csv.factor +++ b/extra/msxml-to-csv/msxml-to-csv.factor @@ -1,8 +1,7 @@ -USING: io io.files sequences xml xml.utilities io.encodings.utf8 ; +USING: io io.files sequences xml xml.utilities +io.encodings.ascii kernel ; IN: msxml-to-csv -: print-csv ( table -- ) [ "," join print ] each ; - : (msxml>csv) ( xml -- table ) "Worksheet" tag-named "Table" tag-named @@ -12,7 +11,6 @@ IN: msxml-to-csv ] map ] map ; -: msxml>csv ( infile outfile -- ) - utf8 [ - file>xml (msxml>csv) print-csv - ] with-file-writer ; +: msxml>csv ( outfile infile -- ) + file>xml (msxml>csv) [ "," join ] map + swap ascii set-file-lines ; diff --git a/extra/multiline/multiline-tests.factor b/extra/multiline/multiline-tests.factor old mode 100644 new mode 100755 index a9b9ee2322..c323e9b96a --- a/extra/multiline/multiline-tests.factor +++ b/extra/multiline/multiline-tests.factor @@ -1,4 +1,5 @@ USING: multiline tools.test ; +IN: multiline.tests STRING: test-it foo diff --git a/extra/namespaces/lib/lib.factor b/extra/namespaces/lib/lib.factor index 8e7af02597..76ba0ac63e 100644 --- a/extra/namespaces/lib/lib.factor +++ b/extra/namespaces/lib/lib.factor @@ -35,6 +35,12 @@ SYMBOL: building-seq : 2, 2 n, ; : 2% 2 n% ; : 2# 2 n# ; +: 3, 3 n, ; +: 3% 3 n% ; +: 3# 3 n# ; +: 4, 4 n, ; +: 4% 4 n% ; +: 4# 4 n# ; : nmake ( quot exemplars -- seqs ) dup length dup zero? [ 1+ ] when diff --git a/extra/oracle/oracle-tests.factor b/extra/oracle/oracle-tests.factor old mode 100644 new mode 100755 index 5756578d92..7006bde23a --- a/extra/oracle/oracle-tests.factor +++ b/extra/oracle/oracle-tests.factor @@ -1,57 +1,59 @@ USING: oracle oracle.liboci prettyprint tools.test ; -"testuser" "testpassword" "//localhost/test1" log-on . +[ + "testuser" "testpassword" "//localhost/test1" log-on . -allocate-statement-handle + allocate-statement-handle -"CREATE TABLE TESTTABLE ( COL1 VARCHAR(40), COL2 NUMBER)" prepare-statement + "CREATE TABLE TESTTABLE ( COL1 VARCHAR(40), COL2 NUMBER)" prepare-statement -[ t ] [ execute-statement ] unit-test + [ t ] [ execute-statement ] unit-test -"INSERT INTO TESTTABLE (COL1, COL2) VALUES('hello', 50)" prepare-statement + "INSERT INTO TESTTABLE (COL1, COL2) VALUES('hello', 50)" prepare-statement -[ t ] [ execute-statement ] unit-test + [ t ] [ execute-statement ] unit-test -"INSERT INTO TESTTABLE (COL1, COL2) VALUES('hi', 60)" prepare-statement + "INSERT INTO TESTTABLE (COL1, COL2) VALUES('hi', 60)" prepare-statement -[ t ] [ execute-statement ] unit-test + [ t ] [ execute-statement ] unit-test -"INSERT INTO TESTTABLE (COL1, COL2) VALUES('bye', 70)" prepare-statement + "INSERT INTO TESTTABLE (COL1, COL2) VALUES('bye', 70)" prepare-statement -[ t ] [ execute-statement ] unit-test + [ t ] [ execute-statement ] unit-test -"COMMIT" prepare-statement + "COMMIT" prepare-statement -[ t ] [ execute-statement ] unit-test + [ t ] [ execute-statement ] unit-test -"SELECT * FROM TESTTABLE" prepare-statement + "SELECT * FROM TESTTABLE" prepare-statement -1 SQLT_STR define-by-position run-query + 1 SQLT_STR define-by-position run-query -[ V{ "hello" "hi" "bye" "50" "60" "70" } ] [ -2 SQLT_STR define-by-position run-query gather-results -] unit-test + [ V{ "hello" "hi" "bye" "50" "60" "70" } ] [ + 2 SQLT_STR define-by-position run-query gather-results + ] unit-test -clear-result + clear-result -"UPDATE TESTTABLE SET COL2 = 10 WHERE COL1='hi'" prepare-statement + "UPDATE TESTTABLE SET COL2 = 10 WHERE COL1='hi'" prepare-statement -[ t ] [ execute-statement ] unit-test + [ t ] [ execute-statement ] unit-test -"COMMIT" prepare-statement + "COMMIT" prepare-statement -[ t ] [ execute-statement ] unit-test + [ t ] [ execute-statement ] unit-test -"SELECT * FROM TESTTABLE WHERE COL1 = 'hi'" prepare-statement + "SELECT * FROM TESTTABLE WHERE COL1 = 'hi'" prepare-statement -[ V{ "10" } ] [ -2 SQLT_STR define-by-position run-query gather-results -] unit-test + [ V{ "10" } ] [ + 2 SQLT_STR define-by-position run-query gather-results + ] unit-test -clear-result + clear-result -"DROP TABLE TESTTABLE" prepare-statement + "DROP TABLE TESTTABLE" prepare-statement -execute-statement + execute-statement -free-statement-handle log-off clean-up terminate + free-statement-handle log-off clean-up terminate +] drop diff --git a/extra/pdf/pdf-tests.factor b/extra/pdf/pdf-tests.factor old mode 100644 new mode 100755 index 097f671d9a..290773a89d --- a/extra/pdf/pdf-tests.factor +++ b/extra/pdf/pdf-tests.factor @@ -1,4 +1,5 @@ USING: io.files kernel math namespaces pdf pdf.libhpdf prettyprint sequences ; +IN: pdf.tests SYMBOL: font diff --git a/extra/project-euler/022/022.factor b/extra/project-euler/022/022.factor index 5bd1797272..c0a48ec055 100644 --- a/extra/project-euler/022/022.factor +++ b/extra/project-euler/022/022.factor @@ -1,6 +1,7 @@ ! Copyright (c) 2007 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: ascii io.files kernel math project-euler.common sequences sorting splitting ; +USING: ascii io.encodings.ascii io.files kernel math project-euler.common + sequences sequences.lib sorting splitting ; IN: project-euler.022 ! http://projecteuler.net/index.php?section=problems&id=22 @@ -28,10 +29,10 @@ IN: project-euler.022 : source-022 ( -- seq ) "extra/project-euler/022/names.txt" resource-path - file-contents [ quotable? ] subset "," split ; + ascii file-contents [ quotable? ] subset "," split ; : name-scores ( seq -- seq ) - dup length [ 1+ swap alpha-value * ] 2map ; + [ 1+ swap alpha-value * ] map-index ; PRIVATE> diff --git a/extra/project-euler/047/047.factor b/extra/project-euler/047/047.factor new file mode 100644 index 0000000000..98e819a7db --- /dev/null +++ b/extra/project-euler/047/047.factor @@ -0,0 +1,96 @@ +! Copyright (c) 2008 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays combinators.lib kernel math math.primes math.primes.factors + math.ranges namespaces sequences ; +IN: project-euler.047 + +! http://projecteuler.net/index.php?section=problems&id=47 + +! DESCRIPTION +! ----------- + +! The first two consecutive numbers to have two distinct prime factors are: + +! 14 = 2 * 7 +! 15 = 3 * 5 + +! The first three consecutive numbers to have three distinct prime factors are: + +! 644 = 2² * 7 * 23 +! 645 = 3 * 5 * 43 +! 646 = 2 * 17 * 19. + +! Find the first four consecutive integers to have four distinct primes +! factors. What is the first of these numbers? + + +! SOLUTION +! -------- + +! Brute force, not sure why it's incredibly slow compared to other languages + + + +: euler047 ( -- answer ) + 4 646 consecutive ; + +! [ euler047 ] time +! 542708 ms run / 60548 ms GC time + + +! ALTERNATE SOLUTIONS +! ------------------- + +! Use a sieve to generate prime factor counts up to an arbitrary limit, then +! look for a repetition of the specified number of factors. + + >array sieve set ; + +: is-prime? ( index -- ? ) + sieve get nth zero? ; + +: multiples ( n -- seq ) + sieve get length 1- over ; + +: increment-counts ( n -- ) + multiples [ sieve get [ 1+ ] change-nth ] each ; + +: prime-tau-upto ( limit -- seq ) + dup initialize-sieve 2 swap [a,b) [ + dup is-prime? [ increment-counts ] [ drop ] if + ] each sieve get ; + +: consecutive-under ( m limit -- n/f ) + prime-tau-upto [ dup ] dip start ; + +PRIVATE> + +: euler047a ( -- answer ) + 4 200000 consecutive-under ; + +! [ euler047a ] 100 ave-time +! 503 ms run / 5 ms GC ave time - 100 trials + +! TODO: I don't like that you have to specify the upper bound, maybe try making +! this lazy so it could also short-circuit when it finds the answer? + +MAIN: euler047a diff --git a/extra/project-euler/059/059.factor b/extra/project-euler/059/059.factor new file mode 100644 index 0000000000..1c20d1ab34 --- /dev/null +++ b/extra/project-euler/059/059.factor @@ -0,0 +1,92 @@ +! Copyright (c) 2008 Aaron Schaefer, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays ascii assocs hashtables io.encodings.ascii io.files kernel math + math.parser namespaces sequences sequences.lib sequences.private sorting + splitting strings ; +IN: project-euler.059 + +! http://projecteuler.net/index.php?section=problems&id=59 + +! DESCRIPTION +! ----------- + +! Each character on a computer is assigned a unique code and the preferred +! standard is ASCII (American Standard Code for Information Interchange). For +! example, uppercase A = 65, asterisk (*) = 42, and lowercase k = 107. + +! A modern encryption method is to take a text file, convert the bytes to +! ASCII, then XOR each byte with a given value, taken from a secret key. The +! advantage with the XOR function is that using the same encryption key on the +! cipher text, restores the plain text; for example, 65 XOR 42 = 107, then 107 +! XOR 42 = 65. + +! For unbreakable encryption, the key is the same length as the plain text +! message, and the key is made up of random bytes. The user would keep the +! encrypted message and the encryption key in different locations, and without +! both "halves", it is impossible to decrypt the message. + +! Unfortunately, this method is impractical for most users, so the modified +! method is to use a password as a key. If the password is shorter than the +! message, which is likely, the key is repeated cyclically throughout the +! message. The balance for this method is using a sufficiently long password +! key for security, but short enough to be memorable. + +! Your task has been made easy, as the encryption key consists of three lower +! case characters. Using cipher1.txt (right click and 'Save Link/Target +! As...'), a file containing the encrypted ASCII codes, and the knowledge that +! the plain text must contain common English words, decrypt the message and +! find the sum of the ASCII values in the original text. + + +! SOLUTION +! -------- + +! Assume that the space character will be the most common, so XOR the input +! text with a space character then group the text into three "columns" since +! that's how long our key is. Then do frequency analysis on each column to +! find out what the most likely candidate is for the key. + +! NOTE: This technique would probably not work well in all cases, but luckily +! it did for this particular problem. + +number ] map ; + +TUPLE: rollover seq n ; + +C: rollover + +M: rollover length rollover-n ; + +M: rollover nth-unsafe rollover-seq [ length mod ] keep nth-unsafe ; + +INSTANCE: rollover immutable-sequence + +: decrypt ( seq key -- seq ) + over length swap [ bitxor ] 2map ; + +: frequency-analysis ( seq -- seq ) + dup prune [ + [ 2dup [ = ] curry count 2array , ] each + ] { } make nip ; inline + +: most-frequent ( seq -- elt ) + frequency-analysis sort-values keys peek ; + +: crack-key ( seq key-length -- key ) + [ " " decrypt ] dip group 1 head-slice* + flip [ most-frequent ] map ; + +PRIVATE> + +: euler059 ( -- answer ) + source-059 dup 3 crack-key decrypt sum ; + +! [ euler059 ] 100 ave-time +! 13 ms run / 0 ms GC ave time - 100 trials + +MAIN: euler059 diff --git a/extra/project-euler/059/cipher1.txt b/extra/project-euler/059/cipher1.txt new file mode 100644 index 0000000000..08cee2dba4 --- /dev/null +++ b/extra/project-euler/059/cipher1.txt @@ -0,0 +1 @@ +79,59,12,2,79,35,8,28,20,2,3,68,8,9,68,45,0,12,9,67,68,4,7,5,23,27,1,21,79,85,78,79,85,71,38,10,71,27,12,2,79,6,2,8,13,9,1,13,9,8,68,19,7,1,71,56,11,21,11,68,6,3,22,2,14,0,30,79,1,31,6,23,19,10,0,73,79,44,2,79,19,6,28,68,16,6,16,15,79,35,8,11,72,71,14,10,3,79,12,2,79,19,6,28,68,32,0,0,73,79,86,71,39,1,71,24,5,20,79,13,9,79,16,15,10,68,5,10,3,14,1,10,14,1,3,71,24,13,19,7,68,32,0,0,73,79,87,71,39,1,71,12,22,2,14,16,2,11,68,2,25,1,21,22,16,15,6,10,0,79,16,15,10,22,2,79,13,20,65,68,41,0,16,15,6,10,0,79,1,31,6,23,19,28,68,19,7,5,19,79,12,2,79,0,14,11,10,64,27,68,10,14,15,2,65,68,83,79,40,14,9,1,71,6,16,20,10,8,1,79,19,6,28,68,14,1,68,15,6,9,75,79,5,9,11,68,19,7,13,20,79,8,14,9,1,71,8,13,17,10,23,71,3,13,0,7,16,71,27,11,71,10,18,2,29,29,8,1,1,73,79,81,71,59,12,2,79,8,14,8,12,19,79,23,15,6,10,2,28,68,19,7,22,8,26,3,15,79,16,15,10,68,3,14,22,12,1,1,20,28,72,71,14,10,3,79,16,15,10,68,3,14,22,12,1,1,20,28,68,4,14,10,71,1,1,17,10,22,71,10,28,19,6,10,0,26,13,20,7,68,14,27,74,71,89,68,32,0,0,71,28,1,9,27,68,45,0,12,9,79,16,15,10,68,37,14,20,19,6,23,19,79,83,71,27,11,71,27,1,11,3,68,2,25,1,21,22,11,9,10,68,6,13,11,18,27,68,19,7,1,71,3,13,0,7,16,71,28,11,71,27,12,6,27,68,2,25,1,21,22,11,9,10,68,10,6,3,15,27,68,5,10,8,14,10,18,2,79,6,2,12,5,18,28,1,71,0,2,71,7,13,20,79,16,2,28,16,14,2,11,9,22,74,71,87,68,45,0,12,9,79,12,14,2,23,2,3,2,71,24,5,20,79,10,8,27,68,19,7,1,71,3,13,0,7,16,92,79,12,2,79,19,6,28,68,8,1,8,30,79,5,71,24,13,19,1,1,20,28,68,19,0,68,19,7,1,71,3,13,0,7,16,73,79,93,71,59,12,2,79,11,9,10,68,16,7,11,71,6,23,71,27,12,2,79,16,21,26,1,71,3,13,0,7,16,75,79,19,15,0,68,0,6,18,2,28,68,11,6,3,15,27,68,19,0,68,2,25,1,21,22,11,9,10,72,71,24,5,20,79,3,8,6,10,0,79,16,8,79,7,8,2,1,71,6,10,19,0,68,19,7,1,71,24,11,21,3,0,73,79,85,87,79,38,18,27,68,6,3,16,15,0,17,0,7,68,19,7,1,71,24,11,21,3,0,71,24,5,20,79,9,6,11,1,71,27,12,21,0,17,0,7,68,15,6,9,75,79,16,15,10,68,16,0,22,11,11,68,3,6,0,9,72,16,71,29,1,4,0,3,9,6,30,2,79,12,14,2,68,16,7,1,9,79,12,2,79,7,6,2,1,73,79,85,86,79,33,17,10,10,71,6,10,71,7,13,20,79,11,16,1,68,11,14,10,3,79,5,9,11,68,6,2,11,9,8,68,15,6,23,71,0,19,9,79,20,2,0,20,11,10,72,71,7,1,71,24,5,20,79,10,8,27,68,6,12,7,2,31,16,2,11,74,71,94,86,71,45,17,19,79,16,8,79,5,11,3,68,16,7,11,71,13,1,11,6,1,17,10,0,71,7,13,10,79,5,9,11,68,6,12,7,2,31,16,2,11,68,15,6,9,75,79,12,2,79,3,6,25,1,71,27,12,2,79,22,14,8,12,19,79,16,8,79,6,2,12,11,10,10,68,4,7,13,11,11,22,2,1,68,8,9,68,32,0,0,73,79,85,84,79,48,15,10,29,71,14,22,2,79,22,2,13,11,21,1,69,71,59,12,14,28,68,14,28,68,9,0,16,71,14,68,23,7,29,20,6,7,6,3,68,5,6,22,19,7,68,21,10,23,18,3,16,14,1,3,71,9,22,8,2,68,15,26,9,6,1,68,23,14,23,20,6,11,9,79,11,21,79,20,11,14,10,75,79,16,15,6,23,71,29,1,5,6,22,19,7,68,4,0,9,2,28,68,1,29,11,10,79,35,8,11,74,86,91,68,52,0,68,19,7,1,71,56,11,21,11,68,5,10,7,6,2,1,71,7,17,10,14,10,71,14,10,3,79,8,14,25,1,3,79,12,2,29,1,71,0,10,71,10,5,21,27,12,71,14,9,8,1,3,71,26,23,73,79,44,2,79,19,6,28,68,1,26,8,11,79,11,1,79,17,9,9,5,14,3,13,9,8,68,11,0,18,2,79,5,9,11,68,1,14,13,19,7,2,18,3,10,2,28,23,73,79,37,9,11,68,16,10,68,15,14,18,2,79,23,2,10,10,71,7,13,20,79,3,11,0,22,30,67,68,19,7,1,71,8,8,8,29,29,71,0,2,71,27,12,2,79,11,9,3,29,71,60,11,9,79,11,1,79,16,15,10,68,33,14,16,15,10,22,73 diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index a322f69e90..25ddd9a60b 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -13,10 +13,11 @@ USING: definitions io io.files kernel math math.parser project-euler.ave-time project-euler.033 project-euler.034 project-euler.035 project-euler.036 project-euler.037 project-euler.038 project-euler.039 project-euler.040 project-euler.041 project-euler.042 project-euler.043 project-euler.044 - project-euler.045 project-euler.046 project-euler.048 project-euler.052 - project-euler.053 project-euler.056 project-euler.067 project-euler.075 - project-euler.079 project-euler.092 project-euler.097 project-euler.134 - project-euler.169 project-euler.173 project-euler.175 ; + project-euler.045 project-euler.046 project-euler.047 project-euler.048 + project-euler.052 project-euler.053 project-euler.056 project-euler.059 + project-euler.067 project-euler.075 project-euler.079 project-euler.092 + project-euler.097 project-euler.134 project-euler.169 project-euler.173 + project-euler.175 ; IN: project-euler r \ context r> with-variable ; diff --git a/extra/semantic-db/hierarchy/hierarchy.factor b/extra/semantic-db/hierarchy/hierarchy.factor new file mode 100644 index 0000000000..fa10fff01c --- /dev/null +++ b/extra/semantic-db/hierarchy/hierarchy.factor @@ -0,0 +1,44 @@ +! Copyright (C) 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: accessors db.tuples kernel new-slots semantic-db semantic-db.relations sequences sequences.deep ; +IN: semantic-db.hierarchy + +TUPLE: tree id children ; +C: tree + +: has-parent-relation ( -- relation-id ) + "has parent" relation-id ; + +: parent-child* ( parent child -- arc-id ) + has-parent-relation spin create-arc* ; + +: parent-child ( parent child -- ) + parent-child* drop ; + +: un-parent-child ( parent child -- ) + has-parent-relation spin select-tuples [ id>> delete-arc ] each ; + +: child-arcs ( node-id -- child-arcs ) + has-parent-relation f rot select-tuples ; + +: children ( node-id -- children ) + child-arcs [ subject>> ] map ; + +: parent-arcs ( node-id -- parent-arcs ) + has-parent-relation swap f select-tuples ; + +: parents ( node-id -- parents ) + parent-arcs [ object>> ] map ; + +: get-node-hierarchy ( node-id -- tree ) + dup children [ get-node-hierarchy ] map ; + +: (get-root-nodes) ( node-id -- root-nodes/node-id ) + dup parents dup empty? [ + drop + ] [ + nip [ (get-root-nodes) ] map + ] if ; + +: get-root-nodes ( node-id -- root-nodes ) + (get-root-nodes) flatten ; diff --git a/extra/semantic-db/relations/relations.factor b/extra/semantic-db/relations/relations.factor new file mode 100644 index 0000000000..17c335c4ae --- /dev/null +++ b/extra/semantic-db/relations/relations.factor @@ -0,0 +1,26 @@ +! Copyright (C) 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: db.types kernel namespaces semantic-db semantic-db.context +sequences.lib ; +IN: semantic-db.relations + +! relations: +! - have a context in context 'semantic-db' + +: create-relation* ( context-id relation-name -- relation-id ) + create-node* tuck has-context-relation spin create-arc ; + +: create-relation ( context-id relation-name -- ) + create-relation* drop ; + +: get-relation ( context-id relation-name -- relation-id/f ) + [ + ":name" TEXT param , + ":context" INTEGER param , + has-context-relation ":has_context" INTEGER param , + ] { } make + "select n.id from node n, arc a where n.content = :name and n.id = a.subject and a.relation = :has_context and a.object = :context" + single-int-results ?first ; + +: relation-id ( relation-name -- relation-id ) + context swap [ get-relation ] [ create-relation* ] ensure2 ; diff --git a/extra/semantic-db/semantic-db-tests.factor b/extra/semantic-db/semantic-db-tests.factor new file mode 100644 index 0000000000..01476a145a --- /dev/null +++ b/extra/semantic-db/semantic-db-tests.factor @@ -0,0 +1,58 @@ +USING: accessors arrays db db.sqlite db.tuples kernel math namespaces +semantic-db semantic-db.context semantic-db.hierarchy semantic-db.relations +sequences tools.test tools.walker ; +IN: semantic-db.tests + +[ + create-node-table create-arc-table + [ 1 ] [ "first node" create-node* ] unit-test + [ 2 ] [ "second node" create-node* ] unit-test + [ 3 ] [ "third node" create-node* ] unit-test + [ 4 ] [ f create-node* ] unit-test + [ 5 ] [ 1 2 3 create-arc* ] unit-test +] with-tmp-sqlite + +[ + init-semantic-db + "test content" create-context* [ + [ 4 ] [ context ] unit-test + [ 5 ] [ context "is test content" create-relation* ] unit-test + [ 5 ] [ context "is test content" get-relation ] unit-test + [ 5 ] [ "is test content" relation-id ] unit-test + [ 7 ] [ "has parent" relation-id ] unit-test + [ 7 ] [ "has parent" relation-id ] unit-test + [ "has parent" ] [ "has parent" relation-id node-content ] unit-test + [ "test content" ] [ context node-content ] unit-test + ] with-context + ! type-type 1array [ "type" ensure-type ] unit-test + ! [ { 1 2 3 } ] [ type-type select-nodes-of-type ] unit-test + ! [ 1 ] [ type-type select-node-of-type ] unit-test + ! [ t ] [ "content" ensure-type integer? ] unit-test + ! [ t ] [ "content" ensure-type "content" ensure-type = ] unit-test + ! [ t ] [ "content" ensure-type "first content" create-node-of-type integer? ] unit-test + ! [ t ] [ "content" ensure-type select-node-of-type integer? ] unit-test + ! [ t ] [ "content" ensure-type "first content" select-node-of-type-with-content integer? ] unit-test + ! [ t ] [ "content" ensure-type "first content" ensure-node-of-type integer? ] unit-test + ! [ t ] [ "content" ensure-type "second content" ensure-node-of-type integer? ] unit-test + ! [ 2 ] [ "content" ensure-type select-nodes-of-type length ] unit-test +] with-tmp-sqlite + +! test hierarchy +[ + init-semantic-db + "family tree" create-context* [ + "adam" create-node* "adam" set + "eve" create-node* "eve" set + "bob" create-node* "bob" set + "fran" create-node* "fran" set + "charlie" create-node* "charlie" set + "gertrude" create-node* "gertrude" set + [ t ] [ "adam" get "bob" get parent-child* integer? ] unit-test + { { "eve" "bob" } { "eve" "fran" } { "bob" "gertrude" } { "bob" "fran" } { "fran" "charlie" } } [ first2 [ get ] 2apply parent-child ] each + [ { "bob" "fran" } ] [ "eve" get children [ node-content ] map ] unit-test + [ { "adam" "eve" } ] [ "bob" get parents [ node-content ] map ] unit-test + [ "fran" { "charlie" } ] [ "fran" get get-node-hierarchy dup tree-id node-content swap tree-children [ tree-id node-content ] map ] unit-test + [ { "adam" "eve" } ] [ "charlie" get break get-root-nodes [ node-content ] map ] unit-test + [ { } ] [ "fran" get "charlie" get tuck un-parent-child parents [ node-content ] map ] unit-test + ] with-context +] with-tmp-sqlite diff --git a/extra/semantic-db/semantic-db.factor b/extra/semantic-db/semantic-db.factor new file mode 100644 index 0000000000..a48048f152 --- /dev/null +++ b/extra/semantic-db/semantic-db.factor @@ -0,0 +1,88 @@ +! Copyright (C) 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays continuations db db.tuples db.types db.sqlite kernel math math.parser new-slots sequences ; +IN: semantic-db + +TUPLE: node id content ; +: ( content -- node ) + node construct-empty swap >>content ; + +: ( id -- node ) + node construct-empty swap >>id ; + +node "node" +{ + { "id" "id" +native-id+ +autoincrement+ } + { "content" "content" TEXT } +} define-persistent + +: create-node-table ( -- ) + node create-table ; + +: delete-node ( node-id -- ) + delete-tuple ; + +: create-node* ( str -- node-id ) + dup insert-tuple id>> ; + +: create-node ( str -- ) + create-node* drop ; + +: node-content ( id -- str ) + f swap >>id select-tuple content>> ; + +TUPLE: arc id relation subject object ; + +: ( relation subject object -- arc ) + arc construct-empty swap >>object swap >>subject swap >>relation ; + +: ( id -- arc ) + arc construct-empty swap >>id ; + +: insert-arc ( arc -- ) + f dup insert-tuple id>> >>id insert-tuple ; + +: delete-arc ( arc-id -- ) + dup delete-node delete-tuple ; + +: create-arc* ( relation subject object -- arc-id ) + dup insert-arc id>> ; + +: create-arc ( relation subject object -- ) + create-arc* drop ; + +arc "arc" +{ + { "id" "id" INTEGER +assigned-id+ } ! foreign key to node table? + { "relation" "relation" INTEGER +not-null+ } + { "subject" "subject" INTEGER +not-null+ } + { "object" "object" INTEGER +not-null+ } +} define-persistent + +: create-arc-table ( -- ) + arc create-table ; + +: create-bootstrap-nodes ( -- ) + "semantic-db" create-node + "has context" create-node ; + +: semantic-db-context 1 ; +: has-context-relation 2 ; + +: create-bootstrap-arcs ( -- ) + has-context-relation has-context-relation semantic-db-context create-arc ; + +: init-semantic-db ( -- ) + create-node-table create-arc-table create-bootstrap-nodes create-bootstrap-arcs ; + +: param ( value key type -- param ) + swapd 3array ; + +: single-int-results ( bindings sql -- array ) + f f [ do-bound-query ] with-disposal + [ first string>number ] map ; + +: ensure2 ( x y quot1 quot2 -- z ) + #! quot1 ( x y -- z/f ) finds an existing z + #! quot2 ( x y -- z ) creates a new z if quot1 returns f + >r >r 2dup r> call [ 2nip ] r> if* ; diff --git a/extra/semantic-db/type/type.factor b/extra/semantic-db/type/type.factor new file mode 100644 index 0000000000..7eec2fe179 --- /dev/null +++ b/extra/semantic-db/type/type.factor @@ -0,0 +1,48 @@ +! Copyright (C) 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: arrays db db.types kernel semantic-db sequences sequences.lib ; +IN: semantic-db.type + +! types: +! - have type 'type' in context 'semantic-db' +! - have a context in context 'semantic-db' + +: assign-type ( type nid -- arc-id ) + has-type-relation spin arc-id ; + +: create-node-of-type ( type content -- node-id ) + node-id [ assign-type drop ] keep ; + +: select-nodes-of-type ( type -- node-ids ) + ":type" INTEGER param + has-type-relation ":has_type" INTEGER param 2array + "select a.subject from arc a where a.relation = :has_type and a.object = :type" + single-int-results ; + +: select-node-of-type ( type -- node-id ) + select-nodes-of-type ?first ; + +: select-nodes-of-type-with-content ( type content -- node-ids ) + ! find nodes with the given content that are the subjects of arcs with: + ! relation = has-type-relation + ! object = type + ":name" TEXT param + swap ":type" INTEGER param + has-type-relation ":has_type" INTEGER param 3array + "select n.id from node n, arc a where n.content = :name and n.id = a.subject and a.object = :type and a.relation = :has_type" + single-int-results ; + +: select-node-of-type-with-content ( type content -- node-id/f ) + select-nodes-of-type-with-content ?first ; + +: ensure-node-of-type ( type content -- node-id ) + [ select-node-of-type-with-content ] [ create-node-of-type ] ensure2 ; + ! 2dup select-node-of-type-with-content [ 2nip ] [ create-node-of-type ] if* ; + + +: ensure-type ( type -- node-id ) + dup "type" = [ + drop type-type + ] [ + type-type swap ensure-node-of-type + ] if ; diff --git a/extra/sequences/deep/deep-tests.factor b/extra/sequences/deep/deep-tests.factor old mode 100644 new mode 100755 index 9c02d52089..541570f3f9 --- a/extra/sequences/deep/deep-tests.factor +++ b/extra/sequences/deep/deep-tests.factor @@ -1,5 +1,6 @@ USING: sequences.deep kernel tools.test strings math arrays namespaces sequences ; +IN: sequences.deep.tests [ [ "hello" 3 4 swap ] ] [ [ { "hello" V{ 3 4 } } swap ] flatten ] unit-test diff --git a/extra/serialize/serialize-docs.factor b/extra/serialize/serialize-docs.factor old mode 100644 new mode 100755 index e12751d6ab..6b2dd304f5 --- a/extra/serialize/serialize-docs.factor +++ b/extra/serialize/serialize-docs.factor @@ -3,47 +3,20 @@ USING: help.syntax help.markup ; IN: serialize -HELP: (serialize) -{ $values { "obj" "object to serialize" } -} -{ $description "Serializes the object to the current output stream. Object references within the structure being serialized are maintained. It must be called from within the scope of a " { $link with-serialized } " call." } -{ $examples - { $example "USING: serialize io.streams.string ;" "[\n [ { 1 2 } dup (serialize) (serialize) ] with-serialized\n] with-string-writer\n\n[\n [ (deserialize) (deserialize) ] with-serialized\n] with-string-reader eq? ." "t" } -} -{ $see-also deserialize (deserialize) serialize with-serialized } ; - -HELP: (deserialize) -{ $values { "obj" "deserialized object" } -} -{ $description "Deserializes an object by reading from the current input stream. Object references within the structure that was originally serialized are maintained. It must be called from within the scope of a " { $link with-serialized } " call." } -{ $examples - { $example "USING: serialize io.streams.string ;" "[\n [ { 1 2 } dup (serialize) (serialize) ] with-serialized\n] with-string-writer\n\n[\n [ (deserialize) (deserialize) ] with-serialized\n] with-string-reader eq? ." "t" } -} -{ $see-also (serialize) deserialize serialize with-serialized } ; - -HELP: with-serialized -{ $values { "quot" "a quotation" } -} -{ $description "Creates a scope for serialization and deserialization operations. The quotation is called within this scope. The scope is used for maintaining the structure and object references of serialized objects." } -{ $examples - { $example "USING: serialize io.streams.string ;" "[\n [ { 1 2 } dup (serialize) (serialize) ] with-serialized\n] with-string-writer\n\n[\n [ (deserialize) (deserialize) ] with-serialized\n] with-string-reader eq? ." "t" } -} -{ $see-also (serialize) (deserialize) serialize deserialize } ; - HELP: serialize { $values { "obj" "object to serialize" } } { $description "Serializes the object to the current output stream. Object references within the structure being serialized are maintained." } { $examples - { $example "USING: serialize io.streams.string ;" "[ { 1 2 } serialize ] with-string-writer\n\n[ deserialize ] with-string-reader ." "{ 1 2 }" } + { $example "USING: serialize io.streams.string ;" "binary [ { 1 2 } serialize ] with-byte-writer\n\nbinary [ deserialize ] with-byte-reader ." "{ 1 2 }" } } -{ $see-also deserialize (deserialize) (serialize) with-serialized } ; +{ $see-also deserialize } ; HELP: deserialize { $values { "obj" "deserialized object" } } { $description "Deserializes an object by reading from the current input stream. Object references within the structure that was originally serialized are maintained." } { $examples - { $example "USING: serialize io.streams.string ;" "[ { 1 2 } serialize ] with-string-writer\n\n[ deserialize ] with-string-reader ." "{ 1 2 }" } + { $example "USING: serialize io.streams.string ;" "binary [ { 1 2 } serialize ] with-byte-writer\n\nbinary [ deserialize ] with-byte-reader ." "{ 1 2 }" } } -{ $see-also (serialize) deserialize (deserialize) with-serialized } ; +{ $see-also serialize } ; diff --git a/extra/serialize/serialize-tests.factor b/extra/serialize/serialize-tests.factor index 766103e4b0..1831495924 100755 --- a/extra/serialize/serialize-tests.factor +++ b/extra/serialize/serialize-tests.factor @@ -1,11 +1,29 @@ ! Copyright (C) 2006 Chris Double. ! See http://factorcode.org/license.txt for BSD license. ! -USING: tools.test kernel serialize io io.streams.string math +USING: tools.test kernel serialize io io.streams.byte-array math alien arrays byte-arrays sequences math prettyprint parser -classes math.constants ; +classes math.constants io.encodings.binary random +combinators.lib ; IN: serialize.tests +: test-serialize-cell + 2^ random dup + binary [ serialize-cell ] with-byte-writer + binary [ deserialize-cell ] with-byte-reader = ; + +[ t ] [ + 100 [ + drop + { + [ 40 [ test-serialize-cell ] all? ] + [ 4 [ 40 * test-serialize-cell ] all? ] + [ 4 [ 400 * test-serialize-cell ] all? ] + [ 4 [ 4000 * test-serialize-cell ] all? ] + } && + ] all? +] unit-test + TUPLE: serialize-test a b ; C: serialize-test @@ -25,6 +43,7 @@ C: serialize-test { 1 2 "three" } V{ 1 2 "three" } SBUF" hello world" + "hello \u123456 unicode" \ dup [ \ dup dup ] T{ serialize-test f "a" 2 } @@ -38,8 +57,9 @@ C: serialize-test : check-serialize-1 ( obj -- ? ) dup class . - dup [ serialize ] with-string-writer - [ deserialize ] with-string-reader = ; + dup + binary [ serialize ] with-byte-writer + binary [ deserialize ] with-byte-reader = ; : check-serialize-2 ( obj -- ? ) dup number? over wrapper? or [ @@ -47,8 +67,8 @@ C: serialize-test ] [ dup class . dup 2array - [ serialize ] with-string-writer - [ deserialize ] with-string-reader + binary [ serialize ] with-byte-writer + binary [ deserialize ] with-byte-reader first2 eq? ] if ; @@ -57,13 +77,5 @@ C: serialize-test [ t ] [ objects [ check-serialize-2 ] all? ] unit-test [ t ] [ pi check-serialize-1 ] unit-test - -[ t ] [ - { 1 2 3 } [ - [ - dup (serialize) (serialize) - ] with-serialized - ] with-string-writer [ - deserialize-sequence all-eq? - ] with-string-reader -] unit-test +[ serialize ] must-infer +[ deserialize ] must-infer diff --git a/extra/serialize/serialize.factor b/extra/serialize/serialize.factor index 03e1645870..36455bd060 100755 --- a/extra/serialize/serialize.factor +++ b/extra/serialize/serialize.factor @@ -10,151 +10,176 @@ IN: serialize USING: namespaces sequences kernel math io math.functions io.binary strings classes words sbufs tuples arrays vectors byte-arrays bit-arrays quotations hashtables -assocs help.syntax help.markup float-arrays splitting ; +assocs help.syntax help.markup float-arrays splitting +io.encodings.string io.encodings.utf8 combinators ; -! Variable holding a sequence of objects already serialized +! Variable holding a assoc of objects already serialized SYMBOL: serialized -: add-object ( obj -- id ) +TUPLE: id obj ; + +C: id + +M: id hashcode* id-obj hashcode* ; + +M: id equal? over id? [ [ id-obj ] 2apply eq? ] [ 2drop f ] if ; + +: add-object ( obj -- ) #! Add an object to the sequence of already serialized - #! objects. Return the id of that object. - serialized get [ push ] keep length 1 - ; + #! objects. + serialized get [ assoc-size swap ] keep set-at ; : object-id ( obj -- id ) #! Return the id of an already serialized object - serialized get [ eq? ] with find [ drop f ] unless ; - -USE: prettyprint + serialized get at ; ! Serialize object GENERIC: (serialize) ( obj -- ) -: serialize-cell 8 >be write ; +! Numbers are serialized as follows: +! 0 => B{ 0 } +! 1<=x<=126 => B{ x | 0x80 } +! x>127 => B{ length(x) x[0] x[1] ... } +! x>2^1024 => B{ 0xff length(x) x[0] x[1] ... } +! The last case is needed because a very large number would +! otherwise be confused with a small number. +: serialize-cell ( n -- ) + dup zero? [ drop 0 write1 ] [ + dup HEX: 7e <= [ + HEX: 80 bitor write1 + ] [ + dup log2 8 /i 1+ + dup HEX: 7f >= [ + HEX: ff write1 + dup serialize-cell + ] [ + dup write1 + ] if + >be write + ] if + ] if ; -: deserialize-cell 8 read be> ; +: deserialize-cell ( -- n ) + read1 { + { [ dup HEX: ff = ] [ drop deserialize-cell read be> ] } + { [ dup HEX: 80 >= ] [ HEX: 80 bitxor ] } + { [ t ] [ read be> ] } + } cond ; : serialize-shared ( obj quot -- ) >r dup object-id - [ "o" write serialize-cell drop ] r> if* ; inline + [ CHAR: o write1 serialize-cell drop ] r> if* ; inline M: f (serialize) ( obj -- ) - drop "n" write ; - -: bytes-needed ( number -- int ) - log2 8 + 8 /i ; inline + drop CHAR: n write1 ; M: integer (serialize) ( obj -- ) - dup 0 = [ - drop "z" write + dup zero? [ + drop CHAR: z write1 ] [ - dup 0 < [ neg "m" ] [ "p" ] if write - dup bytes-needed dup serialize-cell - >be write + dup 0 < [ neg CHAR: m ] [ CHAR: p ] if write1 + serialize-cell ] if ; M: float (serialize) ( obj -- ) - "F" write + CHAR: F write1 double>bits serialize-cell ; M: complex (serialize) ( obj -- ) - "c" write + CHAR: c write1 dup real-part (serialize) imaginary-part (serialize) ; M: ratio (serialize) ( obj -- ) - "r" write + CHAR: r write1 dup numerator (serialize) denominator (serialize) ; -M: string (serialize) ( obj -- ) - [ - "s" write - dup add-object serialize-cell - dup length serialize-cell - write - ] serialize-shared ; +: serialize-string ( obj code -- ) + write1 + dup utf8 encode dup length serialize-cell write + add-object ; -M: sbuf (serialize) ( obj -- ) - [ - "S" write - dup add-object serialize-cell - dup length serialize-cell - >string write - ] serialize-shared ; +M: string (serialize) ( obj -- ) + [ CHAR: s serialize-string ] serialize-shared ; + +: serialize-elements + [ (serialize) ] each CHAR: . write1 ; M: tuple (serialize) ( obj -- ) [ - "T" write - dup add-object serialize-cell - tuple>array - dup length serialize-cell - [ (serialize) ] each + CHAR: T write1 + dup tuple>array serialize-elements + add-object ] serialize-shared ; : serialize-seq ( seq code -- ) [ - write - dup add-object serialize-cell - dup length serialize-cell - [ (serialize) ] each + write1 + dup serialize-elements + add-object ] curry serialize-shared ; M: array (serialize) ( obj -- ) - "a" serialize-seq ; - -M: vector (serialize) ( obj -- ) - "v" serialize-seq ; + CHAR: a serialize-seq ; M: byte-array (serialize) ( obj -- ) - "A" serialize-seq ; + [ + CHAR: A write1 + dup dup length serialize-cell write + add-object + ] serialize-shared ; M: bit-array (serialize) ( obj -- ) - "b" serialize-seq ; + [ + CHAR: b write1 + dup length serialize-cell + dup [ 1 0 ? ] B{ } map-as write + add-object + ] serialize-shared ; M: quotation (serialize) ( obj -- ) - "q" serialize-seq ; - -M: curry (serialize) ( obj -- ) - [ - "C" write - dup add-object serialize-cell - dup curry-obj (serialize) curry-quot (serialize) - ] serialize-shared ; + CHAR: q serialize-seq ; M: float-array (serialize) ( obj -- ) [ - "f" write - dup add-object serialize-cell + CHAR: f write1 dup length serialize-cell - [ double>bits 8 >be write ] each + dup [ double>bits 8 >be write ] each + add-object ] serialize-shared ; M: hashtable (serialize) ( obj -- ) [ - "h" write - dup add-object serialize-cell - >alist (serialize) + CHAR: h write1 + dup >alist (serialize) + add-object ] serialize-shared ; M: word (serialize) ( obj -- ) - "w" write - dup word-name (serialize) - word-vocabulary (serialize) ; + [ + CHAR: w write1 + dup word-name (serialize) + dup word-vocabulary (serialize) + add-object + ] serialize-shared ; M: wrapper (serialize) ( obj -- ) - "W" write + CHAR: W write1 wrapped (serialize) ; DEFER: (deserialize) ( -- obj ) -: intern-object ( id obj -- obj ) - dup rot serialized get set-nth ; +SYMBOL: deserialized + +: intern-object ( obj -- ) + deserialized get push ; : deserialize-false ( -- f ) f ; : deserialize-positive-integer ( -- number ) - deserialize-cell read be> ; + deserialize-cell ; : deserialize-negative-integer ( -- number ) deserialize-positive-integer neg ; @@ -171,85 +196,83 @@ DEFER: (deserialize) ( -- obj ) : deserialize-complex ( -- complex ) (deserialize) (deserialize) rect> ; -: deserialize-string ( -- string ) - deserialize-cell deserialize-cell read intern-object ; +: (deserialize-string) ( -- string ) + deserialize-cell read utf8 decode ; -: deserialize-sbuf ( -- sbuf ) - deserialize-cell deserialize-cell read >sbuf intern-object ; +: deserialize-string ( -- string ) + (deserialize-string) dup intern-object ; : deserialize-word ( -- word ) (deserialize) dup (deserialize) lookup - [ ] [ "Unknown word" throw ] ?if ; + [ dup intern-object ] [ "Unknown word" throw ] ?if ; : deserialize-wrapper ( -- wrapper ) (deserialize) ; +SYMBOL: +stop+ + +: (deserialize-seq) ( -- seq ) + [ (deserialize) dup +stop+ get eq? not ] [ ] [ drop ] unfold ; + : deserialize-seq ( seq -- array ) - deserialize-cell deserialize-cell - [ drop (deserialize) ] roll map-as - intern-object ; + >r (deserialize-seq) r> like dup intern-object ; : deserialize-array ( -- array ) { } deserialize-seq ; -: deserialize-vector ( -- array ) - V{ } deserialize-seq ; - : deserialize-quotation ( -- array ) [ ] deserialize-seq ; +: (deserialize-byte-array) ( -- byte-array ) + deserialize-cell read B{ } like ; + : deserialize-byte-array ( -- byte-array ) - B{ } deserialize-seq ; + (deserialize-byte-array) dup intern-object ; : deserialize-bit-array ( -- bit-array ) - ?{ } deserialize-seq ; + (deserialize-byte-array) [ 0 > ] ?{ } map-as + dup intern-object ; : deserialize-float-array ( -- float-array ) - deserialize-cell deserialize-cell + deserialize-cell 8 * read 8 [ be> bits>double ] F{ } map-as - intern-object ; + dup intern-object ; : deserialize-hashtable ( -- hashtable ) - deserialize-cell (deserialize) >hashtable intern-object ; + (deserialize) >hashtable dup intern-object ; : deserialize-tuple ( -- array ) - deserialize-cell - deserialize-cell [ drop (deserialize) ] map >tuple - intern-object ; - -: deserialize-curry ( -- curry ) - deserialize-cell - (deserialize) (deserialize) curry - intern-object ; + (deserialize-seq) >tuple dup intern-object ; : deserialize-unknown ( -- object ) - deserialize-cell serialized get nth ; + deserialize-cell deserialized get nth ; + +: deserialize-stop ( -- object ) + +stop+ get ; : deserialize* ( -- object ? ) read1 [ - H{ - { CHAR: A deserialize-byte-array } - { CHAR: C deserialize-curry } - { CHAR: F deserialize-float } - { CHAR: S deserialize-sbuf } - { CHAR: T deserialize-tuple } - { CHAR: W deserialize-wrapper } - { CHAR: a deserialize-array } - { CHAR: b deserialize-bit-array } - { CHAR: c deserialize-complex } - { CHAR: f deserialize-float-array } - { CHAR: h deserialize-hashtable } - { CHAR: m deserialize-negative-integer } - { CHAR: n deserialize-false } - { CHAR: o deserialize-unknown } - { CHAR: p deserialize-positive-integer } - { CHAR: q deserialize-quotation } - { CHAR: r deserialize-ratio } - { CHAR: s deserialize-string } - { CHAR: v deserialize-vector } - { CHAR: w deserialize-word } - { CHAR: z deserialize-zero } - } at dup [ "Unknown typecode" throw ] unless execute t + { + { CHAR: A [ deserialize-byte-array ] } + { CHAR: F [ deserialize-float ] } + { CHAR: T [ deserialize-tuple ] } + { CHAR: W [ deserialize-wrapper ] } + { CHAR: a [ deserialize-array ] } + { CHAR: b [ deserialize-bit-array ] } + { CHAR: c [ deserialize-complex ] } + { CHAR: f [ deserialize-float-array ] } + { CHAR: h [ deserialize-hashtable ] } + { CHAR: m [ deserialize-negative-integer ] } + { CHAR: n [ deserialize-false ] } + { CHAR: o [ deserialize-unknown ] } + { CHAR: p [ deserialize-positive-integer ] } + { CHAR: q [ deserialize-quotation ] } + { CHAR: r [ deserialize-ratio ] } + { CHAR: s [ deserialize-string ] } + { CHAR: w [ deserialize-word ] } + { CHAR: z [ deserialize-zero ] } + { CHAR: . [ deserialize-stop ] } + } case t ] [ f f ] if* ; @@ -257,14 +280,15 @@ DEFER: (deserialize) ( -- obj ) : (deserialize) ( -- obj ) deserialize* [ "End of stream" throw ] unless ; -: with-serialized ( quot -- ) - V{ } clone serialized rot with-variable ; inline - -: deserialize-sequence ( -- seq ) - [ [ deserialize* ] [ ] [ drop ] unfold ] with-serialized ; - : deserialize ( -- obj ) - [ (deserialize) ] with-serialized ; + [ + V{ } clone deserialized set + gensym +stop+ set + (deserialize) + ] with-scope ; : serialize ( obj -- ) - [ (serialize) ] with-serialized ; \ No newline at end of file + [ + H{ } clone serialized set + (serialize) + ] with-scope ; \ No newline at end of file diff --git a/extra/singleton/singleton-docs.factor b/extra/singleton/singleton-docs.factor index b87c557366..358d1a5bf6 100644 --- a/extra/singleton/singleton-docs.factor +++ b/extra/singleton/singleton-docs.factor @@ -1,14 +1,26 @@ -USING: help.markup help.syntax ; +USING: help.markup help.syntax kernel words ; IN: singleton HELP: SINGLETON: { $syntax "SINGLETON: class" } { $values - { "class" "a new tuple class to define" } + { "class" "a new singleton to define" } } { $description - "Defines a new tuple class with membership predicate name? and a default empty constructor that is the class name itself." + "Defines a new predicate class whose superclass is " { $link word } ". Only one instance of a singleton may exist because classes are " { $link eq? } " to themselves. Methods may be defined on a singleton." } { $examples - { $example "SINGLETON: foo\nfoo ." "T{ foo f }" } + { $example "SINGLETON: foo\nGENERIC: bar ( obj -- )\nM: foo bar drop \"a foo!\" print ;\nfoo bar" "a foo!" } } { $see-also - POSTPONE: TUPLE: + POSTPONE: PREDICATE: +} ; + +HELP: SINGLETONS: +{ $syntax "SINGLETONS: classes... ;" +} { $values + { "classes" "new singletons to define" } +} { $description + "Defines a new singleton for each class in the list." +} { $examples + { $example "SINGLETONS: foo bar baz ;" "" } +} { $see-also + POSTPONE: SINGLETON: } ; diff --git a/extra/singleton/singleton-tests.factor b/extra/singleton/singleton-tests.factor new file mode 100644 index 0000000000..1698181ed3 --- /dev/null +++ b/extra/singleton/singleton-tests.factor @@ -0,0 +1,9 @@ +USING: kernel singleton tools.test ; +IN: singleton.tests + +[ ] [ SINGLETON: bzzt ] unit-test +[ t ] [ bzzt bzzt? ] unit-test +[ t ] [ bzzt bzzt eq? ] unit-test +GENERIC: zammo ( obj -- ) +[ ] [ M: bzzt zammo drop "yes!" ; ] unit-test +[ "yes!" ] [ bzzt zammo ] unit-test diff --git a/extra/singleton/singleton.factor b/extra/singleton/singleton.factor index b745e8f902..1451283f23 100644 --- a/extra/singleton/singleton.factor +++ b/extra/singleton/singleton.factor @@ -1,10 +1,15 @@ -! Copyright (C) 2007 Doug Coleman. +! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel parser quotations prettyprint tuples words ; +USING: classes.predicate kernel namespaces parser quotations +sequences words ; IN: singleton +: define-singleton ( token -- ) + \ word swap in get create-class + dup [ eq? ] curry define-predicate-class ; + : SINGLETON: - CREATE-CLASS - dup { } define-tuple-class - dup unparse create-in reset-generic - dup construct-empty 1quotation define ; parsing + scan define-singleton ; parsing + +: SINGLETONS: + ";" parse-tokens [ define-singleton ] each ; parsing diff --git a/extra/size-of/size-of.factor b/extra/size-of/size-of.factor index df43a9adb2..5b6f26acea 100644 --- a/extra/size-of/size-of.factor +++ b/extra/size-of/size-of.factor @@ -1,7 +1,9 @@ USING: kernel namespaces sequences - io io.files io.launcher bake builder.util - accessors vars ; + io io.files io.launcher io.encodings.ascii + bake builder.util + accessors vars + math.parser ; IN: size-of @@ -16,7 +18,7 @@ VAR: headers { "#include " include-headers - { "main() { printf( \"%i\\n\" , sizeof( " , " ) ) ; }" } + { "main() { printf( \"%i\" , sizeof( " , " ) ) ; }" } } bake to-strings ; @@ -26,21 +28,12 @@ VAR: headers : exe ( -- path ) "size-of" temp-file ; -: answer ( -- path ) "size-of-answer" temp-file ; - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : size-of ( type -- n ) - c-file - [ size-of-c-program [ print ] each ] - with-file-writer + size-of-c-program c-file ascii set-file-lines { "gcc" c-file "-o" exe } to-strings [ "Error compiling generated C program" print ] run-or-bail - - - { exe } to-strings >>arguments - answer >>stdout - >desc run-process drop - answer eval-file ; \ No newline at end of file + exe ascii contents string>number ; \ No newline at end of file diff --git a/extra/strings/lib/lib-tests.factor b/extra/strings/lib/lib-tests.factor new file mode 100644 index 0000000000..2779e190c9 --- /dev/null +++ b/extra/strings/lib/lib-tests.factor @@ -0,0 +1,8 @@ +USING: kernel sequences strings.lib tools.test ; +IN: temporary + +[ "abcdefghijklmnopqrstuvwxyz" ] [ lower-alpha-chars "" like ] unit-test +[ "ABCDEFGHIJKLMNOPQRSTUVWXYZ" ] [ upper-alpha-chars "" like ] unit-test +[ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" ] [ alpha-chars "" like ] unit-test +[ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" ] [ alphanumeric-chars "" like ] unit-test +[ t ] [ 100 [ drop random-alphanumeric-char ] map alphanumeric-chars [ member? ] curry all? ] unit-test diff --git a/extra/strings/lib/lib.factor b/extra/strings/lib/lib.factor new file mode 100644 index 0000000000..7f13cd58a9 --- /dev/null +++ b/extra/strings/lib/lib.factor @@ -0,0 +1,39 @@ +USING: math arrays sequences kernel random splitting strings unicode.case ; +IN: strings.lib + +: char>digit ( c -- i ) 48 - ; + +: string>digits ( s -- seq ) [ char>digit ] { } map-as ; + +: >Upper ( str -- str ) + dup empty? [ + unclip ch>upper 1string swap append + ] unless ; + +: >Upper-dashes ( str -- str ) + "-" split [ >Upper ] map "-" join ; + +: lower-alpha-chars ( -- seq ) + 26 [ CHAR: a + ] map ; + +: upper-alpha-chars ( -- seq ) + 26 [ CHAR: A + ] map ; + +: numeric-chars ( -- seq ) + 10 [ CHAR: 0 + ] map ; + +: alpha-chars ( -- seq ) + lower-alpha-chars upper-alpha-chars append ; + +: alphanumeric-chars ( -- seq ) + alpha-chars numeric-chars append ; + +: random-alpha-char ( -- ch ) + alpha-chars random ; + +: random-alphanumeric-char ( -- ch ) + alphanumeric-chars random ; + +: random-alphanumeric-string ( length -- str ) + [ drop random-alphanumeric-char ] map "" like ; + diff --git a/extra/symbols/authors.txt b/extra/symbols/authors.txt new file mode 100644 index 0000000000..f372b574ae --- /dev/null +++ b/extra/symbols/authors.txt @@ -0,0 +1,2 @@ +Slava Pestov +Doug Coleman diff --git a/extra/symbols/symbols-docs.factor b/extra/symbols/symbols-docs.factor new file mode 100644 index 0000000000..c6886ce31a --- /dev/null +++ b/extra/symbols/symbols-docs.factor @@ -0,0 +1,9 @@ +USING: help.markup help.syntax ; +IN: symbols + +HELP: SYMBOLS: +{ $syntax "SYMBOLS: words... ;" } +{ $values { "words" "a sequence of new words to define" } } +{ $description "Creates a new word for every token until the ';'." } +{ $examples { $example "SYMBOLS: foo bar baz ;\nfoo . bar . baz ." "foo\nbar\nbaz" } } +{ $see-also POSTPONE: SYMBOL: } ; diff --git a/extra/symbols/symbols-tests.factor b/extra/symbols/symbols-tests.factor new file mode 100644 index 0000000000..84a61509c8 --- /dev/null +++ b/extra/symbols/symbols-tests.factor @@ -0,0 +1,7 @@ +USING: kernel symbols tools.test ; +IN: symbols.tests + +[ ] [ SYMBOLS: a b c ; ] unit-test +[ a ] [ a ] unit-test +[ b ] [ b ] unit-test +[ c ] [ c ] unit-test diff --git a/extra/symbols/symbols.factor b/extra/symbols/symbols.factor new file mode 100644 index 0000000000..8e074f4163 --- /dev/null +++ b/extra/symbols/symbols.factor @@ -0,0 +1,8 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: parser sequences words ; +IN: symbols + +: SYMBOLS: + ";" parse-tokens [ create-in define-symbol ] each ; + parsing diff --git a/extra/tetris/tetris.factor b/extra/tetris/tetris.factor index 78f3f8f0f7..02f8f240d2 100644 --- a/extra/tetris/tetris.factor +++ b/extra/tetris/tetris.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2006, 2007 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: kernel ui.gadgets ui.gadgets.labels ui.gadgets.worlds -ui.gadgets.status-bar ui.gestures ui.render ui tetris.game -tetris.gl sequences arrays math math.parser namespaces timers ; +USING: alarms arrays calendar kernel ui.gadgets ui.gadgets.labels +ui.gadgets.worlds ui.gadgets.status-bar ui.gestures ui.render ui +tetris.game tetris.gl sequences system math math.parser namespaces ; IN: tetris -TUPLE: tetris-gadget tetris ; +TUPLE: tetris-gadget tetris alarm ; : ( tetris -- gadget ) tetris-gadget construct-gadget @@ -41,14 +41,15 @@ tetris-gadget H{ { T{ key-down f f "n" } [ new-tetris ] } } set-gestures -M: tetris-gadget tick ( object -- ) +: tick ( gadget -- ) dup tetris-gadget-tetris maybe-update relayout-1 ; M: tetris-gadget graft* ( gadget -- ) - 100 1 add-timer ; + dup [ tick ] curry 100 milliseconds from-now 100 milliseconds add-alarm + swap set-tetris-gadget-alarm ; M: tetris-gadget ungraft* ( gadget -- ) - remove-timer ; + [ tetris-gadget-alarm cancel-alarm f ] keep set-tetris-gadget-alarm ; : tetris-window ( -- ) [ diff --git a/extra/tools/browser/browser.factor b/extra/tools/browser/browser.factor index 24836c1201..c189a6f9de 100755 --- a/extra/tools/browser/browser.factor +++ b/extra/tools/browser/browser.factor @@ -17,8 +17,7 @@ MEMO: (vocab-file-contents) ( path -- lines ) : set-vocab-file-contents ( seq vocab name -- ) dupd vocab-path+ [ - ?resource-path - utf8 [ [ print ] each ] with-file-writer + ?resource-path utf8 set-file-lines ] [ "The " swap vocab-name " vocabulary was not loaded from the file system" diff --git a/extra/tools/deploy/backend/backend.factor b/extra/tools/deploy/backend/backend.factor index 6e8a231b81..301ffa3378 100755 --- a/extra/tools/deploy/backend/backend.factor +++ b/extra/tools/deploy/backend/backend.factor @@ -23,7 +23,7 @@ IN: tools.deploy.backend +closed+ >>stdin utf8 dup copy-lines - process-stream-process wait-for-process zero? [ + process>> wait-for-process zero? [ "Deployment failed" throw ] unless ; @@ -61,7 +61,7 @@ IN: tools.deploy.backend ] { } make ; : run-factor ( vm flags -- ) - dup . swap add* run-with-output ; inline + swap add* dup . run-with-output ; inline : make-staging-image ( vm config -- ) staging-command-line run-factor ; diff --git a/extra/tools/deploy/macosx/macosx.factor b/extra/tools/deploy/macosx/macosx.factor index 6cab5c98b9..6db19cf868 100755 --- a/extra/tools/deploy/macosx/macosx.factor +++ b/extra/tools/deploy/macosx/macosx.factor @@ -9,17 +9,18 @@ IN: tools.deploy.macosx : bundle-dir ( -- dir ) vm parent-directory parent-directory ; -: copy-bundle-dir ( name dir -- ) - bundle-dir swap path+ swap "Contents" path+ copy-tree ; +: copy-bundle-dir ( bundle-name dir -- ) + bundle-dir over path+ -rot + "Contents" swap path+ path+ copy-tree ; : copy-vm ( executable bundle-name -- vm ) "Contents/MacOS/" path+ swap path+ vm over copy-file ; : copy-fonts ( name -- ) "fonts/" resource-path - swap "Contents/Resources/" path+ copy-tree ; + swap "Contents/Resources/" path+ copy-tree-into ; -: print-app-plist ( executable bundle-name -- ) +: app-plist ( executable bundle-name -- string ) [ namespace { { "CFBundleInfoDictionaryVersion" "6.0" } @@ -30,11 +31,12 @@ IN: tools.deploy.macosx dup "CFBundleExecutable" set "org.factor." swap append "CFBundleIdentifier" set - ] H{ } make-assoc print-plist ; + ] H{ } make-assoc plist>string ; : create-app-plist ( vocab bundle-name -- ) - dup "Contents/Info.plist" path+ - utf8 [ print-app-plist ] with-file-writer ; + [ app-plist ] keep + "Contents/Info.plist" path+ + utf8 set-file-contents ; : create-app-dir ( vocab bundle-name -- vm ) dup "Frameworks" copy-bundle-dir @@ -62,7 +64,7 @@ M: macosx-deploy-implementation deploy* ( vocab -- ) ".app deploy tool" assert.app "." resource-path cd dup deploy-config [ - bundle-name delete-tree + bundle-name dup exists? [ delete-tree ] [ drop ] if [ bundle-name create-app-dir ] keep [ bundle-name deploy.app-image ] keep namespace make-deploy-image diff --git a/extra/tuple-arrays/tuple-arrays-tests.factor b/extra/tuple-arrays/tuple-arrays-tests.factor old mode 100644 new mode 100755 index dfe9002bb9..dd9510405f --- a/extra/tuple-arrays/tuple-arrays-tests.factor +++ b/extra/tuple-arrays/tuple-arrays-tests.factor @@ -1,4 +1,5 @@ USING: tuple-arrays sequences tools.test namespaces kernel math ; +IN: tuple-arrays.tests SYMBOL: mat TUPLE: foo bar ; diff --git a/extra/ui/gestures/gestures.factor b/extra/ui/gestures/gestures.factor index 0edf82dbd1..e494afd46d 100755 --- a/extra/ui/gestures/gestures.factor +++ b/extra/ui/gestures/gestures.factor @@ -3,7 +3,7 @@ USING: arrays assocs kernel math models namespaces sequences words strings system hashtables math.parser math.vectors tuples classes ui.gadgets combinators.lib boxes -calendar alarms ; +calendar alarms symbols ; IN: ui.gestures : set-gestures ( class hash -- ) "gestures" set-word-prop ; @@ -49,10 +49,7 @@ TUPLE: select-all-action ; C: select-all-action tuple>array 1 head* >tuple ; ! Modifiers -SYMBOL: C+ -SYMBOL: A+ -SYMBOL: M+ -SYMBOL: S+ +SYMBOLS: C+ A+ M+ S+ ; TUPLE: key-down mods sym ; diff --git a/extra/ui/windows/windows.factor b/extra/ui/windows/windows.factor index 6cba5cfdf8..a1b513380c 100755 --- a/extra/ui/windows/windows.factor +++ b/extra/ui/windows/windows.factor @@ -6,7 +6,8 @@ math math.vectors namespaces prettyprint sequences strings vectors words windows.kernel32 windows.gdi32 windows.user32 windows.opengl32 windows.messages windows.types windows.nt windows threads libc combinators continuations command-line -shuffle opengl ui.render unicode.case ascii math.bitfields ; +shuffle opengl ui.render unicode.case ascii math.bitfields +locals symbols ; IN: ui.windows TUPLE: windows-ui-backend ; @@ -67,9 +68,7 @@ M: pasteboard set-clipboard-contents drop copy ; TUPLE: win hWnd hDC hRC world title ; C: win -SYMBOL: msg-obj -SYMBOL: class-name-ptr -SYMBOL: mouse-captured +SYMBOLS: msg-obj class-name-ptr mouse-captured ; : style ( -- n ) WS_OVERLAPPEDWINDOW ; inline : ex-style ( -- n ) WS_EX_APPWINDOW WS_EX_WINDOWEDGE bitor ; inline @@ -188,30 +187,21 @@ SYMBOL: mouse-captured ] if ] if ; -SYMBOL: lParam -SYMBOL: wParam -SYMBOL: uMsg -SYMBOL: hWnd - -: handle-wm-keydown ( hWnd uMsg wParam lParam -- ) - lParam set wParam set uMsg set hWnd set - wParam get exclude-key-wm-keydown? [ - wParam get keystroke>gesture - hWnd get window-focus send-gesture drop +:: handle-wm-keydown ( hWnd uMsg wParam lParam -- ) + wParam exclude-key-wm-keydown? [ + wParam keystroke>gesture + hWnd window-focus send-gesture drop ] unless ; -: handle-wm-char ( hWnd uMsg wParam lParam -- ) - lParam set wParam set uMsg set hWnd set - wParam get exclude-key-wm-char? ctrl? alt? xor or [ - wParam get 1string - hWnd get window-focus user-input +:: handle-wm-char ( hWnd uMsg wParam lParam -- ) + wParam exclude-key-wm-char? ctrl? alt? xor or [ + wParam 1string + hWnd window-focus user-input ] unless ; -: handle-wm-keyup ( hWnd uMsg wParam lParam -- ) - lParam set wParam set uMsg set hWnd set - wParam get keystroke>gesture - hWnd get window-focus send-gesture - drop ; +:: handle-wm-keyup ( hWnd uMsg wParam lParam -- ) + wParam keystroke>gesture + hWnd window-focus send-gesture drop ; : handle-wm-syscommand ( hWnd uMsg wParam lParam -- n ) dup alpha? [ 4drop 0 ] [ DefWindowProc ] if ; diff --git a/extra/xml/tests/errors.factor b/extra/xml/tests/errors.factor old mode 100644 new mode 100755 index c0a60d8a3f..b421ae011a --- a/extra/xml/tests/errors.factor +++ b/extra/xml/tests/errors.factor @@ -1,4 +1,5 @@ USING: continuations xml xml.errors tools.test kernel arrays xml.data state-parser quotations ; +IN: xml.tests : xml-error-test ( expected-error xml-string -- ) [ string>xml ] curry swap [ = ] curry must-fail-with ; diff --git a/extra/xmode/marker/state/state.factor b/extra/xmode/marker/state/state.factor index e3e380798f..2cf12f301d 100755 --- a/extra/xmode/marker/state/state.factor +++ b/extra/xmode/marker/state/state.factor @@ -1,20 +1,12 @@ -USING: xmode.marker.context xmode.rules +USING: xmode.marker.context xmode.rules symbols xmode.tokens namespaces kernel sequences assocs math ; IN: xmode.marker.state ! Based on org.gjt.sp.jedit.syntax.TokenMarker -SYMBOL: line -SYMBOL: last-offset -SYMBOL: position -SYMBOL: context - -SYMBOL: whitespace-end -SYMBOL: seen-whitespace-end? - -SYMBOL: escaped? -SYMBOL: process-escape? -SYMBOL: delegate-end-escaped? +SYMBOLS: line last-offset position context + whitespace-end seen-whitespace-end? + escaped? process-escape? delegate-end-escaped? ; : current-rule ( -- rule ) context get line-context-in-rule ; diff --git a/extra/xmode/tokens/tokens.factor b/extra/xmode/tokens/tokens.factor old mode 100644 new mode 100755 index e1fa2dd04f..7b913cbac0 --- a/extra/xmode/tokens/tokens.factor +++ b/extra/xmode/tokens/tokens.factor @@ -5,12 +5,12 @@ IN: xmode.tokens ! Based on org.gjt.sp.jedit.syntax.Token SYMBOL: tokens -[ - { "COMMENT1" "COMMENT2" "COMMENT3" "COMMENT4" "DIGIT" "FUNCTION" "INVALID" "KEYWORD1" "KEYWORD2" "KEYWORD3" "KEYWORD4" "LABEL" "LITERAL1" "LITERAL2" "LITERAL3" "LITERAL4" "MARKUP" "OPERATOR" "END" "NULL" } [ - create-in dup define-symbol - dup word-name swap - ] H{ } map>assoc tokens set-global -] with-compilation-unit +<< +{ "COMMENT1" "COMMENT2" "COMMENT3" "COMMENT4" "DIGIT" "FUNCTION" "INVALID" "KEYWORD1" "KEYWORD2" "KEYWORD3" "KEYWORD4" "LABEL" "LITERAL1" "LITERAL2" "LITERAL3" "LITERAL4" "MARKUP" "OPERATOR" "END" "NULL" } [ + create-in dup define-symbol + dup word-name swap +] H{ } map>assoc tokens set-global +>> : string>token ( string -- id ) tokens get at ; diff --git a/misc/factor.sh b/misc/factor.sh index 3a6d2d64f9..0ad44430c8 100755 --- a/misc/factor.sh +++ b/misc/factor.sh @@ -68,11 +68,11 @@ check_gcc_version() { } set_downloader() { - test_program_installed wget + test_program_installed wget curl if [[ $? -ne 0 ]] ; then - DOWNLOAD=wget + DOWNLOADER=wget else - DOWNLOAD="curl -O" + DOWNLOADER="curl -O" fi } @@ -95,7 +95,6 @@ check_installed_programs() { ensure_program_installed md5sum md5 ensure_program_installed cut case $OS in - macosx) ensure_program_installed port;; netbsd) ensure_program_installed gmake;; esac check_gcc_version @@ -203,6 +202,7 @@ echo_build_info() { echo MAKE_IMAGE_TARGET=$MAKE_IMAGE_TARGET echo GIT_PROTOCOL=$GIT_PROTOCOL echo GIT_URL=$GIT_URL + echo DOWNLOADER=$DOWNLOADER } set_build_info() { @@ -235,6 +235,7 @@ find_build_info() { find_word_size set_factor_binary set_build_info + set_downloader echo_build_info } @@ -304,12 +305,12 @@ get_boot_image() { } get_url() { - if [[ $DOWNLOAD -eq "" ]] ; then + if [[ $DOWNLOADER -eq "" ]] ; then set_downloader; fi - echo $DOWNLOAD $1 ; - $DOWNLOAD $1 - check_ret $DOWNLOAD + echo $DOWNLOADER $1 ; + $DOWNLOADER $1 + check_ret $DOWNLOADER } maybe_download_dlls() { @@ -372,14 +373,23 @@ make_boot_image() { } -install_libraries_apt() { +install_build_system_apt() { + ensure_program_installed yes yes | sudo apt-get install sudo libc6-dev libfreetype6-dev libx11-dev xorg-dev glutg3-dev wget git-core git-doc rlwrap gcc make check_ret sudo } -install_libraries_port() { - ensure_program_installed port - yes | sudo port install git-core +install_build_system_port() { + test_program_installed git + if [[ $? -ne 1 ]] ; then + ensure_program_installed yes + echo "git not found." + echo "This script requires either git-core or port." + echo "If it fails, install git-core or port and try again." + ensure_program_installed port + echo "Installing git-core with port...this will take awhile." + yes | sudo port install git-core + fi } usage() { @@ -390,8 +400,8 @@ usage() { case "$1" in install) install ;; - install-x11) install_libraries_apt; install ;; - install-macosx) install_libraries_port; install ;; + install-x11) install_build_system_apt; install ;; + install-macosx) install_build_system_port; install ;; self-update) update; make_boot_image; bootstrap;; quick-update) update; refresh_image ;; update) update; update_bootstrap ;;