diff --git a/basis/alarms/alarms-docs.factor b/basis/alarms/alarms-docs.factor index f07a8b9a2d..49480c0fe0 100755 --- a/basis/alarms/alarms-docs.factor +++ b/basis/alarms/alarms-docs.factor @@ -9,13 +9,19 @@ HELP: add-alarm { $description "Creates and registers an alarm. If " { $snippet "frequency" } " is " { $link f } ", this will be a one-time alarm, otherwise it will fire with the given frequency. The quotation will be called from the alarm thread." } ; HELP: later -{ $values { "quot" quotation } { "dt" duration } { "alarm" alarm } } +{ $values { "quot" quotation } { "duration" duration } { "alarm" alarm } } { $description "Creates and registers an alarm which calls the quotation once at " { $snippet "time" } " from now." } ; HELP: cancel-alarm { $values { "alarm" alarm } } { $description "Cancels an alarm. Does nothing if the alarm is not active." } ; +HELP: every +{ $values + { "quot" quotation } { "duration" duration } + { "alarm" alarm } } +{ $description "Creates and registers an alarm which calls the quotation repeatedly, using " { $snippet "dt" } " as the frequency." } ; + ARTICLE: "alarms" "Alarms" "Alarms provide a lightweight way to schedule one-time and recurring tasks without spawning a new thread." { $subsection alarm } diff --git a/basis/alarms/alarms.factor b/basis/alarms/alarms.factor index cbbebde579..7fdeca9ae6 100755 --- a/basis/alarms/alarms.factor +++ b/basis/alarms/alarms.factor @@ -82,10 +82,10 @@ PRIVATE> : add-alarm ( quot time frequency -- alarm ) [ register-alarm ] keep ; -: later ( quot dt -- alarm ) +: later ( quot duration -- alarm ) hence f add-alarm ; -: every ( quot dt -- alarm ) +: every ( quot duration -- alarm ) [ hence ] keep add-alarm ; : cancel-alarm ( alarm -- ) diff --git a/basis/bit-arrays/bit-arrays.factor b/basis/bit-arrays/bit-arrays.factor index d6064ba852..11601f7b63 100755 --- a/basis/bit-arrays/bit-arrays.factor +++ b/basis/bit-arrays/bit-arrays.factor @@ -91,5 +91,5 @@ M: bit-array byte-length length 7 + -3 shift ; INSTANCE: bit-array sequence M: bit-array pprint-delims drop \ ?{ \ } ; - M: bit-array >pprint-sequence ; +M: bit-array pprint* pprint-object ; diff --git a/basis/bit-vectors/bit-vectors.factor b/basis/bit-vectors/bit-vectors.factor index 6a7d68beca..404b26829b 100755 --- a/basis/bit-vectors/bit-vectors.factor +++ b/basis/bit-vectors/bit-vectors.factor @@ -34,5 +34,5 @@ INSTANCE: bit-vector growable : ?V{ \ } [ >bit-vector ] parse-literal ; parsing M: bit-vector >pprint-sequence ; - M: bit-vector pprint-delims drop \ ?V{ \ } ; +M: bit-vector pprint* pprint-object ; diff --git a/basis/calendar/calendar-docs.factor b/basis/calendar/calendar-docs.factor index e3e5338820..62ff4ad517 100644 --- a/basis/calendar/calendar-docs.factor +++ b/basis/calendar/calendar-docs.factor @@ -21,8 +21,8 @@ HELP: { $description "Returns a timestamp object representing the start of the specified day in your current timezone." } { $examples { $example "USING: calendar prettyprint ;" - "12 25 2010 ." - "T{ timestamp f 12 25 2010 0 0 0 T{ duration f 0 0 0 -5 0 0 } }" + "2010 12 25 ." + "T{ timestamp\n { year 2010 }\n { month 12 }\n { day 25 }\n { gmt-offset T{ duration { hour -5 } } }\n}" } } ; diff --git a/basis/channels/channels.factor b/basis/channels/channels.factor index 9b5cbee04b..545d8a0e1d 100755 --- a/basis/channels/channels.factor +++ b/basis/channels/channels.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. ! ! Channels - based on ideas from newsqueak -USING: kernel sequences sequences.lib threads continuations -random math accessors ; +USING: kernel sequences threads continuations +random math accessors random ; IN: channels TUPLE: channel receivers senders ; diff --git a/basis/html/parser/analyzer/authors.txt b/basis/checksums/common/authors.txt old mode 100755 new mode 100644 similarity index 100% rename from basis/html/parser/analyzer/authors.txt rename to basis/checksums/common/authors.txt diff --git a/basis/checksums/common/common.factor b/basis/checksums/common/common.factor new file mode 100644 index 0000000000..ea1c6f5b39 --- /dev/null +++ b/basis/checksums/common/common.factor @@ -0,0 +1,21 @@ +! Copyright (C) 2006, 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math math.bitwise strings io.binary namespaces +grouping ; +IN: checksums.common + +SYMBOL: bytes-read + +: calculate-pad-length ( length -- pad-length ) + dup 56 < 55 119 ? swap - ; + +: pad-last-block ( str big-endian? length -- str ) + [ + rot % + HEX: 80 , + dup HEX: 3f bitand calculate-pad-length 0 % + 3 shift 8 rot [ >be ] [ >le ] if % + ] "" make 64 group ; + +: update-old-new ( old new -- ) + [ get >r get r> ] 2keep >r >r w+ dup r> set r> set ; inline diff --git a/basis/checksums/common/summary.txt b/basis/checksums/common/summary.txt new file mode 100644 index 0000000000..0956c052a4 --- /dev/null +++ b/basis/checksums/common/summary.txt @@ -0,0 +1 @@ +Some code shared by MD5, SHA1 and SHA2 implementations diff --git a/basis/checksums/md5/md5.factor b/basis/checksums/md5/md5.factor index f0e0c71c19..6158254f84 100755 --- a/basis/checksums/md5/md5.factor +++ b/basis/checksums/md5/md5.factor @@ -1,11 +1,14 @@ -! See http://www.faqs.org/rfcs/rfc1321.html - +! Copyright (C) 2006, 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. USING: kernel io io.binary io.files io.streams.byte-array math math.functions math.parser namespaces splitting grouping strings -sequences crypto.common byte-arrays locals sequences.private -io.encodings.binary symbols math.bitfields.lib checksums ; +sequences byte-arrays locals sequences.private +io.encodings.binary symbols math.bitwise checksums +checksums.common ; IN: checksums.md5 +! See http://www.faqs.org/rfcs/rfc1321.html + be> ; inline + : make-w ( str -- ) #! compute w, steps a-b of RFC 3174, section 6.1 16 [ nth-int-be w get push ] with each @@ -113,8 +118,16 @@ INSTANCE: sha1 checksum M: sha1 checksum-stream ( stream -- sha1 ) drop [ initialize-sha1 stream>sha1 get-sha1 ] with-input-stream ; +: seq>2seq ( seq -- seq1 seq2 ) + #! { abcdefgh } -> { aceg } { bdfh } + 2 group flip dup empty? [ drop { } { } ] [ first2 ] if ; + +: 2seq>seq ( seq1 seq2 -- seq ) + #! { aceg } { bdfh } -> { abcdefgh } + [ zip concat ] keep like ; + : sha1-interleave ( string -- seq ) - [ zero? ] left-trim + [ zero? ] trim-left dup length odd? [ rest ] when seq>2seq [ sha1 checksum-bytes ] bi@ 2seq>seq ; diff --git a/basis/checksums/sha2/sha2.factor b/basis/checksums/sha2/sha2.factor index 6cf7914e6c..ac93c05260 100755 --- a/basis/checksums/sha2/sha2.factor +++ b/basis/checksums/sha2/sha2.factor @@ -1,6 +1,8 @@ -USING: crypto.common kernel splitting grouping -math sequences namespaces io.binary symbols -math.bitfields.lib checksums ; +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel splitting grouping math sequences namespaces +io.binary symbols math.bitwise checksums checksums.common +sbufs strings ; IN: checksums.sha2 r dup 3 + r> first3 ; inline + : T1 ( W n -- T1 ) [ swap nth ] keep K get nth + @@ -112,6 +116,15 @@ SYMBOLS: vars M K H S0 S1 process-M word-size block-size ; : seq>byte-array ( n seq -- string ) [ swap [ >be % ] curry each ] B{ } make ; +: preprocess-plaintext ( string big-endian? -- padded-string ) + #! pad 0x80 then 00 til 8 bytes left, then 64bit length in bits + >r >sbuf r> over [ + HEX: 80 , + dup length HEX: 3f bitand + calculate-pad-length 0 % + length 3 shift 8 rot [ >be ] [ >le ] if % + ] "" make over push-all ; + : byte-array>sha2 ( byte-array -- string ) t preprocess-plaintext block-size get group [ process-chunk ] each diff --git a/basis/cocoa/windows/windows.factor b/basis/cocoa/windows/windows.factor index 74a181f9a2..dd2d1bfd41 100755 --- a/basis/cocoa/windows/windows.factor +++ b/basis/cocoa/windows/windows.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2007 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel math cocoa cocoa.messages cocoa.classes -sequences math.bitfields ; +sequences math.bitwise ; IN: cocoa.windows : NSBorderlessWindowMask 0 ; inline diff --git a/basis/compiler/generator/fixup/fixup.factor b/basis/compiler/generator/fixup/fixup.factor index ae30502524..5a3337fb32 100755 --- a/basis/compiler/generator/fixup/fixup.factor +++ b/basis/compiler/generator/fixup/fixup.factor @@ -3,7 +3,7 @@ USING: arrays byte-arrays generic assocs hashtables io.binary kernel kernel.private math namespaces sequences words quotations strings alien.accessors alien.strings layouts system -combinators math.bitfields words.private cpu.architecture +combinators math.bitwise words.private cpu.architecture math.order accessors growable ; IN: compiler.generator.fixup diff --git a/basis/compiler/generator/registers/registers.factor b/basis/compiler/generator/registers/registers.factor index e460f5558b..e909db3f83 100755 --- a/basis/compiler/generator/registers/registers.factor +++ b/basis/compiler/generator/registers/registers.factor @@ -647,7 +647,7 @@ UNION: immediate fixnum POSTPONE: f ; : phantom-shuffle ( shuffle -- ) [ in>> length phantom-datastack get phantom-input ] keep - shuffle* phantom-datastack get phantom-append ; + shuffle phantom-datastack get phantom-append ; : phantom->r ( n -- ) phantom-datastack get phantom-input diff --git a/basis/compiler/tree/normalization/normalization.factor b/basis/compiler/tree/normalization/normalization.factor index 12c7a60ec8..08481726dc 100644 --- a/basis/compiler/tree/normalization/normalization.factor +++ b/basis/compiler/tree/normalization/normalization.factor @@ -151,7 +151,7 @@ M: #branch normalize* : eliminate-phi-introductions ( introductions seq terminated -- seq' ) [ [ nip ] [ - dup [ +bottom+ eq? ] left-trim + dup [ +bottom+ eq? ] trim-left [ [ length ] bi@ - tail* ] keep append ] if ] 3map ; diff --git a/basis/cpu/ppc/assembler/backend/backend.factor b/basis/cpu/ppc/assembler/backend/backend.factor index 072f50520c..b881f5a974 100644 --- a/basis/cpu/ppc/assembler/backend/backend.factor +++ b/basis/cpu/ppc/assembler/backend/backend.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: compiler.generator.fixup kernel namespaces sequences -words math math.bitfields io.binary parser lexer ; +words math math.bitwise io.binary parser lexer ; IN: cpu.ppc.assembler.backend : insn ( operand opcode -- ) { 26 0 } bitfield , ; diff --git a/basis/db/db.factor b/basis/db/db.factor index c269341240..10da653c9f 100755 --- a/basis/db/db.factor +++ b/basis/db/db.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs classes continuations destructors kernel math -namespaces sequences sequences.lib classes.tuple words strings -tools.walker accessors combinators.lib combinators ; +namespaces sequences classes.tuple words strings +tools.walker accessors combinators ; IN: db TUPLE: db diff --git a/basis/db/postgresql/postgresql.factor b/basis/db/postgresql/postgresql.factor index 692241fab0..d833063b51 100755 --- a/basis/db/postgresql/postgresql.factor +++ b/basis/db/postgresql/postgresql.factor @@ -4,8 +4,8 @@ USING: arrays assocs alien alien.syntax continuations io kernel math math.parser namespaces prettyprint quotations sequences debugger db db.postgresql.lib db.postgresql.ffi db.tuples db.types tools.annotations math.ranges -combinators sequences.lib classes locals words tools.walker -namespaces.lib accessors random db.queries destructors ; +combinators classes locals words tools.walker +nmake accessors random db.queries destructors ; USE: tools.walker IN: db.postgresql diff --git a/basis/db/queries/queries.factor b/basis/db/queries/queries.factor index e5334703f6..a28f283d30 100644 --- a/basis/db/queries/queries.factor +++ b/basis/db/queries/queries.factor @@ -1,9 +1,8 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel math namespaces sequences random -strings math.parser math.intervals combinators -math.bitfields.lib namespaces.lib db db.tuples db.types -sequences.lib db.sql classes words shuffle arrays ; +USING: accessors kernel math namespaces sequences random strings +math.parser math.intervals combinators math.bitwise nmake db +db.tuples db.types db.sql classes words shuffle arrays ; IN: db.queries GENERIC: where ( specs obj -- ) @@ -142,8 +141,8 @@ M: db ( tuple class -- statement ) : make-query ( tuple query -- tuple' ) dupd { - [ group>> [ do-group ] [ drop ] if-seq ] - [ order>> [ do-order ] [ drop ] if-seq ] + [ group>> [ drop ] [ do-group ] if-empty ] + [ order>> [ drop ] [ do-order ] if-empty ] [ limit>> [ do-limit ] [ drop ] if* ] [ offset>> [ do-offset ] [ drop ] if* ] } 2cleave ; diff --git a/basis/db/sql/sql.factor b/basis/db/sql/sql.factor index 7dd4abf4be..06428485e1 100755 --- a/basis/db/sql/sql.factor +++ b/basis/db/sql/sql.factor @@ -1,6 +1,6 @@ USING: kernel parser quotations classes.tuple words math.order -namespaces.lib namespaces sequences arrays combinators -prettyprint strings math.parser sequences.lib math symbols ; +nmake namespaces sequences arrays combinators +prettyprint strings math.parser math symbols ; IN: db.sql SYMBOLS: insert update delete select distinct columns from as diff --git a/basis/db/sqlite/sqlite.factor b/basis/db/sqlite/sqlite.factor index 49d79b1b8c..dc8104ba00 100755 --- a/basis/db/sqlite/sqlite.factor +++ b/basis/db/sqlite/sqlite.factor @@ -1,13 +1,11 @@ ! Copyright (C) 2005, 2008 Chris Double, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien arrays assocs classes compiler db -hashtables io.files kernel math math.parser namespaces -prettyprint sequences strings classes.tuple alien.c-types -continuations db.sqlite.lib db.sqlite.ffi db.tuples -words combinators.lib db.types combinators math.intervals -io namespaces.lib accessors vectors math.ranges random -math.bitfields.lib db.queries destructors ; -USE: tools.walker +USING: alien arrays assocs classes compiler db hashtables +io.files kernel math math.parser namespaces prettyprint +sequences strings classes.tuple alien.c-types continuations +db.sqlite.lib db.sqlite.ffi db.tuples words db.types combinators +math.intervals io nmake accessors vectors math.ranges random +math.bitwise db.queries destructors ; IN: db.sqlite TUPLE: sqlite-db < db path ; diff --git a/basis/db/tuples/tuples-tests.factor b/basis/db/tuples/tuples-tests.factor index 5dd3ec8ae0..3b04454995 100755 --- a/basis/db/tuples/tuples-tests.factor +++ b/basis/db/tuples/tuples-tests.factor @@ -3,8 +3,8 @@ USING: io.files kernel tools.test db db.tuples classes db.types continuations namespaces math math.ranges prettyprint calendar sequences db.sqlite math.intervals -db.postgresql accessors random math.bitfields.lib -math.ranges strings sequences.lib urls fry ; +db.postgresql accessors random math.bitwise +math.ranges strings urls fry ; IN: db.tuples.tests TUPLE: person the-id the-name the-number the-real diff --git a/basis/db/tuples/tuples.factor b/basis/db/tuples/tuples.factor index 1b7ab24366..437224ea5a 100755 --- a/basis/db/tuples/tuples.factor +++ b/basis/db/tuples/tuples.factor @@ -3,7 +3,7 @@ USING: arrays assocs classes db kernel namespaces classes.tuple words sequences slots math accessors math.parser io prettyprint db.types continuations -destructors mirrors sequences.lib combinators.lib ; +destructors mirrors ; IN: db.tuples : define-persistent ( class table columns -- ) @@ -71,13 +71,14 @@ SINGLETON: retryable ] 2map >>bind-params ; M: retryable execute-statement* ( statement type -- ) - drop [ + drop [ retries>> ] [ [ + nip [ query-results dispose t ] [ ] [ regenerate-params bind-statement* f ] cleanup ] curry - ] [ retries>> ] bi retry drop ; + ] bi attempt-all drop ; : resulting-tuple ( class row out-params -- tuple ) rot class new [ @@ -159,7 +160,8 @@ M: retryable execute-statement* ( statement type -- ) dup dup class do-select ; : select-tuple ( tuple -- tuple/f ) - dup dup class \ query new 1 >>limit do-select ?first ; + dup dup class \ query new 1 >>limit do-select + [ f ] [ first ] if-empty ; : do-count ( exemplar-tuple statement -- tuples ) [ diff --git a/basis/db/types/types.factor b/basis/db/types/types.factor index 2efa41c401..d3b99fcff3 100755 --- a/basis/db/types/types.factor +++ b/basis/db/types/types.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs db kernel math math.parser -sequences continuations sequences.deep sequences.lib +sequences continuations sequences.deep words namespaces slots slots.private classes mirrors classes.tuple combinators calendar.format symbols classes.singleton accessors quotations random ; diff --git a/basis/float-arrays/float-arrays.factor b/basis/float-arrays/float-arrays.factor index 28eea4701e..411643ddc0 100755 --- a/basis/float-arrays/float-arrays.factor +++ b/basis/float-arrays/float-arrays.factor @@ -61,8 +61,8 @@ INSTANCE: float-array sequence : F{ \ } [ >float-array ] parse-literal ; parsing M: float-array pprint-delims drop \ F{ \ } ; - M: float-array >pprint-sequence ; +M: float-array pprint* pprint-object ; USING: hints math.vectors arrays ; diff --git a/basis/float-vectors/float-vectors.factor b/basis/float-vectors/float-vectors.factor index 68b692da5a..8e93582f04 100755 --- a/basis/float-vectors/float-vectors.factor +++ b/basis/float-vectors/float-vectors.factor @@ -34,5 +34,5 @@ INSTANCE: float-vector growable : FV{ \ } [ >float-vector ] parse-literal ; parsing M: float-vector >pprint-sequence ; - M: float-vector pprint-delims drop \ FV{ \ } ; +M: float-vector pprint* pprint-object ; diff --git a/basis/help/help-docs.factor b/basis/help/help-docs.factor index 47cc2987d7..643e121f5e 100755 --- a/basis/help/help-docs.factor +++ b/basis/help/help-docs.factor @@ -14,6 +14,7 @@ ARTICLE: "span-elements" "Span elements" { $subsection $link } { $subsection $vocab-link } { $subsection $snippet } +{ $subsection $slot } { $subsection $url } ; ARTICLE: "block-elements" "Block elements" @@ -212,6 +213,18 @@ HELP: $code { $markup-example { $code "2 2 + ." } } } ; +HELP: $nl +{ $values { "children" "unused parameter" } } +{ $description "Prints a paragraph break. The parameter is unused." } ; + +HELP: $snippet +{ $values { "children" "markup elements" } } +{ $description "Prints a key word or otherwise notable snippet of text, such as a type or a word input parameter. To document slot names, use " { $link $slot } "." } ; + +HELP: $slot +{ $values { "children" "markup elements" } } +{ $description "Prints a tuple slot name in the same way as a snippet. The help tool can check that there exists an accessor with this name." } ; + HELP: $vocabulary { $values { "element" "a markup element of the form " { $snippet "{ word }" } } } { $description "Prints a word's vocabulary. This markup element is automatically output by the help system, so help descriptions of parsing words should not call it." } ; diff --git a/basis/help/markup/markup.factor b/basis/help/markup/markup.factor index d65eb8fc88..d94b9c4b41 100755 --- a/basis/help/markup/markup.factor +++ b/basis/help/markup/markup.factor @@ -3,7 +3,7 @@ USING: accessors arrays definitions generic io kernel assocs hashtables namespaces parser prettyprint sequences strings io.styles vectors words math sorting splitting classes slots -vocabs help.stylesheet help.topics vocabs.loader ; +vocabs help.stylesheet help.topics vocabs.loader alias ; IN: help.markup ! Simple markup language. @@ -61,6 +61,9 @@ M: f print-element drop ; : $snippet ( children -- ) [ snippet-style get print-element* ] ($span) ; +! for help-lint +ALIAS: $slot $snippet + : $emphasis ( children -- ) [ emphasis-style get print-element* ] ($span) ; diff --git a/basis/html/forms/forms.factor b/basis/html/forms/forms.factor index 0da3fcb0b3..911e545f87 100644 --- a/basis/html/forms/forms.factor +++ b/basis/html/forms/forms.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors strings namespaces assocs hashtables -mirrors math fry sequences sequences.lib words continuations ; +mirrors math fry sequences words continuations ; IN: html.forms TUPLE: form errors values validation-failed ; diff --git a/basis/html/templates/chloe/chloe.factor b/basis/html/templates/chloe/chloe.factor index afbd82fed4..f40fc43b32 100644 --- a/basis/html/templates/chloe/chloe.factor +++ b/basis/html/templates/chloe/chloe.factor @@ -3,7 +3,7 @@ USING: accessors kernel sequences combinators kernel namespaces classes.tuple assocs splitting words arrays memoize io io.files io.encodings.utf8 io.streams.string -unicode.case tuple-syntax mirrors fry math urls present +unicode.case mirrors fry math urls present multiline xml xml.data xml.writer xml.utilities html.forms html.elements diff --git a/basis/html/templates/chloe/syntax/syntax.factor b/basis/html/templates/chloe/syntax/syntax.factor index 82309a49b2..65b5cd8790 100644 --- a/basis/html/templates/chloe/syntax/syntax.factor +++ b/basis/html/templates/chloe/syntax/syntax.factor @@ -4,7 +4,7 @@ IN: html.templates.chloe.syntax USING: accessors kernel sequences combinators kernel namespaces classes.tuple assocs splitting words arrays memoize parser lexer io io.files io.encodings.utf8 io.streams.string -unicode.case tuple-syntax mirrors fry math urls +unicode.case mirrors fry math urls multiline xml xml.data xml.writer xml.utilities html.elements html.components diff --git a/basis/http/client/client-tests.factor b/basis/http/client/client-tests.factor index 28a605174a..1219ae0b97 100755 --- a/basis/http/client/client-tests.factor +++ b/basis/http/client/client-tests.factor @@ -1,5 +1,5 @@ USING: http.client http.client.private http tools.test -tuple-syntax namespaces urls ; +namespaces urls ; [ "localhost" f ] [ "localhost" parse-host ] unit-test [ "localhost" 8888 ] [ "localhost:8888" parse-host ] unit-test @@ -9,12 +9,12 @@ tuple-syntax namespaces urls ; [ "www.arc.com" ] [ "http://www.arc.com////" download-name ] unit-test [ - TUPLE{ request - url: TUPLE{ url protocol: "http" host: "www.apple.com" port: 80 path: "/index.html" } - method: "GET" - version: "1.1" - cookies: V{ } - header: H{ { "connection" "close" } { "user-agent" "Factor http.client" } } + T{ request + { url T{ url { protocol "http" } { host "www.apple.com" } { port 80 } { path "/index.html" } } } + { method "GET" } + { version "1.1" } + { cookies V{ } } + { header H{ { "connection" "close" } { "user-agent" "Factor http.client" } } } } ] [ "http://www.apple.com/index.html" @@ -22,12 +22,12 @@ tuple-syntax namespaces urls ; ] unit-test [ - TUPLE{ request - url: TUPLE{ url protocol: "https" host: "www.amazon.com" port: 443 path: "/index.html" } - method: "GET" - version: "1.1" - cookies: V{ } - header: H{ { "connection" "close" } { "user-agent" "Factor http.client" } } + T{ request + { url T{ url { protocol "https" } { host "www.amazon.com" } { port 443 } { path "/index.html" } } } + { method "GET" } + { version "1.1" } + { cookies V{ } } + { header H{ { "connection" "close" } { "user-agent" "Factor http.client" } } } } ] [ "https://www.amazon.com/index.html" diff --git a/basis/http/client/client.factor b/basis/http/client/client.factor index ea1cfd9a4b..8dc1924a12 100755 --- a/basis/http/client/client.factor +++ b/basis/http/client/client.factor @@ -113,7 +113,7 @@ SYMBOL: redirects PRIVATE> : read-chunk-size ( -- n ) - read-crlf ";" split1 drop [ blank? ] right-trim + read-crlf ";" split1 drop [ blank? ] trim-right hex> [ "Bad chunk size" throw ] unless* ; : read-chunks ( -- ) diff --git a/basis/http/http-tests.factor b/basis/http/http-tests.factor index 40154e94ef..3294940d89 100755 --- a/basis/http/http-tests.factor +++ b/basis/http/http-tests.factor @@ -1,8 +1,8 @@ USING: http http.server http.client tools.test multiline -tuple-syntax io.streams.string io.encodings.utf8 -io.encodings.8-bit io.encodings.binary io.encodings.string -kernel arrays splitting sequences assocs io.sockets db db.sqlite -continuations urls hashtables accessors ; +io.streams.string io.encodings.utf8 io.encodings.8-bit +io.encodings.binary io.encodings.string kernel arrays splitting +sequences assocs io.sockets db db.sqlite continuations urls +hashtables accessors ; IN: http.tests [ "text/plain" latin1 ] [ "text/plain" parse-content-type ] unit-test @@ -24,13 +24,13 @@ blah ; [ - TUPLE{ request - url: TUPLE{ url path: "/bar" } - method: "POST" - version: "1.1" - header: H{ { "some-header" "1; 2" } { "content-length" "4" } { "content-type" "application/octet-stream" } } - post-data: TUPLE{ post-data content: "blah" raw: "blah" content-type: "application/octet-stream" } - cookies: V{ } + T{ request + { url T{ url { path "/bar" } } } + { method "POST" } + { version "1.1" } + { header H{ { "some-header" "1; 2" } { "content-length" "4" } { "content-type" "application/octet-stream" } } } + { post-data T{ post-data { content "blah" } { raw "blah" } { content-type "application/octet-stream" } } } + { cookies V{ } } } ] [ read-request-test-1 lf>crlf [ @@ -62,12 +62,12 @@ Host: www.sex.com ; [ - TUPLE{ request - url: TUPLE{ url host: "www.sex.com" path: "/bar" } - method: "HEAD" - version: "1.1" - header: H{ { "host" "www.sex.com" } } - cookies: V{ } + T{ request + { url T{ url { host "www.sex.com" } { path "/bar" } } } + { method "HEAD" } + { version "1.1" } + { header H{ { "host" "www.sex.com" } } } + { cookies V{ } } } ] [ read-request-test-2 lf>crlf [ @@ -103,14 +103,14 @@ blah ; [ - TUPLE{ response - version: "1.1" - code: 404 - message: "not found" - header: H{ { "content-type" "text/html; charset=UTF-8" } } - cookies: { } - content-type: "text/html" - content-charset: utf8 + T{ response + { version "1.1" } + { code 404 } + { message "not found" } + { header H{ { "content-type" "text/html; charset=UTF-8" } } } + { cookies { } } + { content-type "text/html" } + { content-charset utf8 } } ] [ read-response-test-1 lf>crlf diff --git a/basis/http/http.factor b/basis/http/http.factor index 2a5a19036f..e450631d94 100755 --- a/basis/http/http.factor +++ b/basis/http/http.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel combinators math namespaces -assocs assocs.lib sequences splitting sorting sets debugger +assocs sequences splitting sorting sets debugger strings vectors hashtables quotations arrays byte-arrays math.parser calendar calendar.format present @@ -27,9 +27,12 @@ IN: http : (read-header) ( -- alist ) [ read-crlf dup f like ] [ parse-header-line ] [ drop ] produce ; +: collect-headers ( assoc -- assoc' ) + H{ } clone [ '[ , push-at ] assoc-each ] keep ; + : process-header ( alist -- assoc ) f swap [ [ swap or dup ] dip swap ] assoc-map nip - [ ?push ] histogram [ "; " join ] assoc-map + collect-headers [ "; " join ] assoc-map >hashtable ; : read-header ( -- assoc ) diff --git a/basis/http/server/static/static.factor b/basis/http/server/static/static.factor index 98510e45fd..dfbe93d86d 100755 --- a/basis/http/server/static/static.factor +++ b/basis/http/server/static/static.factor @@ -45,9 +45,9 @@ TUPLE: file-responder root hook special allow-listings ; [ file-responder get hook>> call ] [ 2drop <304> ] if ; : serving-path ( filename -- filename ) - file-responder get root>> right-trim-separators + file-responder get root>> trim-right-separators "/" - rot "" or left-trim-separators 3append ; + rot "" or trim-left-separators 3append ; : serve-file ( filename -- response ) dup mime-type diff --git a/basis/io/monitors/monitors-tests.factor b/basis/io/monitors/monitors-tests.factor index 63381811d1..1cc97753b7 100755 --- a/basis/io/monitors/monitors-tests.factor +++ b/basis/io/monitors/monitors-tests.factor @@ -54,7 +54,7 @@ os { winnt linux macosx } member? [ "m" get next-change drop dup print flush dup parent-directory - [ right-trim-separators "xyz" tail? ] either? not + [ trim-right-separators "xyz" tail? ] either? not ] loop "c1" get count-down @@ -63,7 +63,7 @@ os { winnt linux macosx } member? [ "m" get next-change drop dup print flush dup parent-directory - [ right-trim-separators "yxy" tail? ] either? not + [ trim-right-separators "yxy" tail? ] either? not ] loop "c2" get count-down diff --git a/basis/io/sockets/sockets.factor b/basis/io/sockets/sockets.factor index 0e49ca86ec..79a1abd49c 100755 --- a/basis/io/sockets/sockets.factor +++ b/basis/io/sockets/sockets.factor @@ -77,17 +77,9 @@ M: inet4 make-sockaddr ( inet -- sockaddr ) "0.0.0.0" or rot inet-pton *uint over set-sockaddr-in-addr ; - - M: inet4 parse-sockaddr >r dup sockaddr-in-addr r> inet-ntop - swap sockaddr-in-port ntohs (port) ; + swap sockaddr-in-port ntohs ; TUPLE: inet6 host port ; @@ -140,7 +132,7 @@ M: inet6 make-sockaddr ( inet -- sockaddr ) M: inet6 parse-sockaddr >r dup sockaddr-in6-addr r> inet-ntop - swap sockaddr-in6-port ntohs (port) ; + swap sockaddr-in6-port ntohs ; : addrspec-of-family ( af -- addrspec ) { @@ -259,17 +251,6 @@ HOOK: (send) io-backend ( packet addrspec datagram -- ) [ addrinfo>addrspec ] map sift ; -: prepare-resolve-host ( addrspec -- host' serv' flags ) - #! If the port is a number, we resolve for 'http' then - #! change it later. This is a workaround for a FreeBSD - #! getaddrinfo() limitation -- on Windows, Linux and Mac, - #! we can convert a number to a string and pass that as the - #! service name, but on FreeBSD this gives us an unknown - #! service error. - [ host>> ] - [ port>> dup integer? [ port-override set "http" ] when ] bi - over 0 AI_PASSIVE ? ; - HOOK: addrinfo-error io-backend ( n -- ) GENERIC: resolve-host ( addrspec -- seq ) @@ -278,17 +259,24 @@ TUPLE: inet host port ; C: inet +: resolve-passive-host ( -- addrspecs ) + { T{ inet6 f "::" f } T{ inet4 f "0.0.0.0" f } } [ clone ] map ; + +: prepare-addrinfo ( -- addrinfo ) + "addrinfo" + PF_UNSPEC over set-addrinfo-family + IPPROTO_TCP over set-addrinfo-protocol ; + +: fill-in-ports ( addrspecs port -- addrspecs ) + [ >>port ] curry map ; + M: inet resolve-host - [ - prepare-resolve-host - "addrinfo" - [ set-addrinfo-flags ] keep - PF_UNSPEC over set-addrinfo-family - IPPROTO_TCP over set-addrinfo-protocol - f [ getaddrinfo addrinfo-error ] keep *void* - [ parse-addrinfo-list ] keep - freeaddrinfo - ] with-scope ; + [ port>> ] [ host>> ] bi [ + f prepare-addrinfo f + [ getaddrinfo addrinfo-error ] keep *void* + [ parse-addrinfo-list ] keep freeaddrinfo + ] [ resolve-passive-host ] if* + swap fill-in-ports ; M: f resolve-host drop { } ; diff --git a/basis/io/unix/files/files.factor b/basis/io/unix/files/files.factor index 63712cd45c..c6eda50855 100755 --- a/basis/io/unix/files/files.factor +++ b/basis/io/unix/files/files.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: io.backend io.ports io.unix.backend io.files io unix unix.stat unix.time kernel math continuations -math.bitfields byte-arrays alien combinators calendar +math.bitwise byte-arrays alien combinators calendar io.encodings.binary accessors sequences strings system io.files.private destructors ; diff --git a/basis/io/unix/files/unique/unique.factor b/basis/io/unix/files/unique/unique.factor index dca2f51958..95e321fd93 100644 --- a/basis/io/unix/files/unique/unique.factor +++ b/basis/io/unix/files/unique/unique.factor @@ -1,4 +1,4 @@ -USING: kernel io.ports io.unix.backend math.bitfields +USING: kernel io.ports io.unix.backend math.bitwise unix io.files.unique.backend system ; IN: io.unix.files.unique diff --git a/basis/io/unix/kqueue/kqueue.factor b/basis/io/unix/kqueue/kqueue.factor index 8888d0182f..b3e69a453c 100755 --- a/basis/io/unix/kqueue/kqueue.factor +++ b/basis/io/unix/kqueue/kqueue.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types kernel math math.bitfields namespaces +USING: alien.c-types kernel math math.bitwise namespaces locals accessors combinators threads vectors hashtables sequences assocs continuations sets unix unix.time unix.kqueue unix.process diff --git a/basis/io/unix/linux/monitors/monitors.factor b/basis/io/unix/linux/monitors/monitors.factor index 5a980266f1..ff23fba0c6 100644 --- a/basis/io/unix/linux/monitors/monitors.factor +++ b/basis/io/unix/linux/monitors/monitors.factor @@ -4,7 +4,7 @@ USING: kernel io.backend io.monitors io.monitors.recursive io.files io.buffers io.monitors io.ports io.timeouts io.unix.backend io.unix.select io.encodings.utf8 unix.linux.inotify assocs namespaces threads continuations init -math math.bitfields sets alien alien.strings alien.c-types +math math.bitwise sets alien alien.strings alien.c-types vocabs.loader accessors system hashtables destructors unix ; IN: io.unix.linux.monitors diff --git a/basis/io/unix/mmap/mmap.factor b/basis/io/unix/mmap/mmap.factor index c31e23849e..d5dcda9436 100755 --- a/basis/io/unix/mmap/mmap.factor +++ b/basis/io/unix/mmap/mmap.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien io io.files kernel math math.bitfields system unix +USING: alien io io.files kernel math math.bitwise system unix io.unix.backend io.ports io.mmap destructors locals accessors ; IN: io.unix.mmap diff --git a/basis/io/windows/files/files.factor b/basis/io/windows/files/files.factor index 1377f82ced..5698ab6cf2 100755 --- a/basis/io/windows/files/files.factor +++ b/basis/io/windows/files/files.factor @@ -4,8 +4,7 @@ USING: alien.c-types io.binary io.backend io.files io.buffers io.windows kernel math splitting windows windows.kernel32 windows.time calendar combinators math.functions sequences namespaces words symbols system -io.ports destructors accessors -math.bitfields math.bitfields.lib ; +io.ports destructors accessors math.bitwise ; IN: io.windows.files : open-file ( path access-mode create-mode flags -- handle ) diff --git a/basis/io/windows/mmap/mmap.factor b/basis/io/windows/mmap/mmap.factor index 660a4017be..e5b0d10f2f 100755 --- a/basis/io/windows/mmap/mmap.factor +++ b/basis/io/windows/mmap/mmap.factor @@ -1,6 +1,6 @@ USING: alien alien.c-types arrays destructors generic io.mmap io.ports io.windows io.windows.files io.windows.privileges -kernel libc math math.bitfields namespaces quotations sequences +kernel libc math math.bitwise namespaces quotations sequences windows windows.advapi32 windows.kernel32 io.backend system accessors locals ; IN: io.windows.mmap diff --git a/basis/io/windows/nt/files/files-tests.factor b/basis/io/windows/nt/files/files-tests.factor index 0fa4b4151c..830861eba0 100755 --- a/basis/io/windows/nt/files/files-tests.factor +++ b/basis/io/windows/nt/files/files-tests.factor @@ -21,8 +21,8 @@ IN: io.windows.nt.files.tests [ t ] [ "\\\\" root-directory? ] unit-test [ t ] [ "/" root-directory? ] unit-test [ t ] [ "//" root-directory? ] unit-test -[ t ] [ "c:\\" right-trim-separators root-directory? ] unit-test -[ t ] [ "Z:\\" right-trim-separators root-directory? ] unit-test +[ t ] [ "c:\\" trim-right-separators root-directory? ] unit-test +[ t ] [ "Z:\\" trim-right-separators root-directory? ] unit-test [ f ] [ "c:\\foo" root-directory? ] unit-test [ f ] [ "." root-directory? ] unit-test [ f ] [ ".." root-directory? ] unit-test diff --git a/basis/io/windows/nt/files/files.factor b/basis/io/windows/nt/files/files.factor index 6a890f6392..5fbacfa325 100755 --- a/basis/io/windows/nt/files/files.factor +++ b/basis/io/windows/nt/files/files.factor @@ -22,7 +22,7 @@ M: winnt root-directory? ( path -- ? ) { { [ dup empty? ] [ f ] } { [ dup [ path-separator? ] all? ] [ t ] } - { [ dup right-trim-separators { [ length 2 = ] [ second CHAR: : = ] } 1&& ] [ t ] } + { [ dup trim-right-separators { [ length 2 = ] [ second CHAR: : = ] } 1&& ] [ t ] } [ f ] } cond nip ; diff --git a/basis/io/windows/nt/monitors/monitors.factor b/basis/io/windows/nt/monitors/monitors.factor index fa4d19a46e..54cb3b1104 100755 --- a/basis/io/windows/nt/monitors/monitors.factor +++ b/basis/io/windows/nt/monitors/monitors.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types libc destructors locals kernel math assocs namespaces continuations sequences hashtables -sorting arrays combinators math.bitfields strings system +sorting arrays combinators math.bitwise strings system accessors threads splitting io.backend io.windows io.windows.nt.backend io.windows.nt.files io.monitors io.ports io.buffers io.files io.timeouts io diff --git a/basis/io/windows/nt/pipes/pipes.factor b/basis/io/windows/nt/pipes/pipes.factor index dc0d7cf1e5..aa52152b75 100755 --- a/basis/io/windows/nt/pipes/pipes.factor +++ b/basis/io/windows/nt/pipes/pipes.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types arrays destructors io io.windows libc -windows.types math.bitfields windows.kernel32 windows namespaces +windows.types math.bitwise windows.kernel32 windows namespaces kernel sequences windows.errors assocs math.parser system random combinators accessors io.pipes io.ports ; IN: io.windows.nt.pipes diff --git a/basis/io/windows/nt/privileges/privileges.factor b/basis/io/windows/nt/privileges/privileges.factor index 007d05f9af..8418d09a5e 100755 --- a/basis/io/windows/nt/privileges/privileges.factor +++ b/basis/io/windows/nt/privileges/privileges.factor @@ -1,6 +1,6 @@ USING: alien alien.c-types alien.syntax arrays continuations destructors generic io.mmap io.ports io.windows io.windows.files -kernel libc math math.bitfields namespaces quotations sequences windows +kernel libc math math.bitwise namespaces quotations sequences windows windows.advapi32 windows.kernel32 io.backend system accessors io.windows.privileges ; IN: io.windows.nt.privileges diff --git a/basis/io/windows/windows.factor b/basis/io/windows/windows.factor index a290821163..6f6c29fc55 100755 --- a/basis/io/windows/windows.factor +++ b/basis/io/windows/windows.factor @@ -5,7 +5,7 @@ io.buffers io.files io.ports io.sockets io.binary io.sockets io.timeouts windows.errors strings kernel math namespaces sequences windows windows.kernel32 windows.shell32 windows.types windows.winsock splitting -continuations math.bitfields system accessors ; +continuations math.bitwise system accessors ; IN: io.windows : set-inherit ( handle ? -- ) diff --git a/basis/lcs/lcs.factor b/basis/lcs/lcs.factor index 2fa0b6cc71..6f9ae3c883 100755 --- a/basis/lcs/lcs.factor +++ b/basis/lcs/lcs.factor @@ -1,6 +1,5 @@ USING: sequences kernel math locals math.order math.ranges -accessors combinators.lib arrays namespaces combinators -combinators.short-circuit ; +accessors arrays namespaces combinators combinators.short-circuit ; IN: lcs r dup word? [ swapd execute ] when r> shift bitor ; - -: bitfield ( values... bitspec -- n ) - 0 [ (bitfield) ] reduce ; - -: flags ( values -- n ) - 0 [ dup word? [ execute ] when bitor ] reduce ; - -GENERIC: (bitfield-quot) ( spec -- quot ) - -M: integer (bitfield-quot) ( spec -- quot ) - [ swapd shift bitor ] curry ; - -M: pair (bitfield-quot) ( spec -- quot ) - first2 over word? [ >r swapd execute r> ] [ ] ? - [ shift bitor ] append 2curry ; - -: bitfield-quot ( spec -- quot ) - [ (bitfield-quot) ] map [ 0 ] prefix concat ; - -\ bitfield [ bitfield-quot ] 1 define-transform - -\ flags [ - [ 0 , [ , \ bitor , ] each ] [ ] make -] 1 define-transform diff --git a/basis/math/bitfields/summary.txt b/basis/math/bitfields/summary.txt deleted file mode 100644 index d622f818fd..0000000000 --- a/basis/math/bitfields/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Domain-specific language for constructing integers diff --git a/basis/math/bitfields/authors.txt b/basis/math/bitwise/authors.txt similarity index 50% rename from basis/math/bitfields/authors.txt rename to basis/math/bitwise/authors.txt index 1901f27a24..f372b574ae 100644 --- a/basis/math/bitfields/authors.txt +++ b/basis/math/bitwise/authors.txt @@ -1 +1,2 @@ Slava Pestov +Doug Coleman diff --git a/basis/math/bitfields/bitfields-docs.factor b/basis/math/bitwise/bitwise-docs.factor similarity index 75% rename from basis/math/bitfields/bitfields-docs.factor rename to basis/math/bitwise/bitwise-docs.factor index f9d16d2b6c..247523369b 100644 --- a/basis/math/bitfields/bitfields-docs.factor +++ b/basis/math/bitwise/bitwise-docs.factor @@ -1,5 +1,5 @@ USING: help.markup help.syntax math ; -IN: math.bitfields +IN: math.bitwise ARTICLE: "math-bitfields" "Constructing bit fields" "Some applications, such as binary communication protocols and assemblers, need to construct integers from elaborate bit field specifications. Hand-coding this using " { $link shift } " and " { $link bitor } " results in repetitive code. A higher-level facility exists to factor out this repetition:" @@ -35,3 +35,16 @@ HELP: bitfield " } ;" } } ; + +HELP: bits +{ $values { "m" integer } { "n" integer } { "m'" integer } } +{ $description "Keep only n bits from the integer m." } +{ $example "USING: math.bitwise prettyprint ;" "HEX: 123abcdef 16 bits .h" "cdef" } ; + +HELP: bitroll +{ $values { "x" "an integer (input)" } { "s" "an integer (shift)" } { "w" "an integer (wrap)" } { "y" integer } } +{ $description "Roll n by s bits to the left, wrapping around after w bits." } +{ $examples + { $example "USING: math.bitwise prettyprint ;" "1 -1 32 bitroll .b" "10000000000000000000000000000000" } + { $example "USING: math.bitwise prettyprint ;" "HEX: ffff0000 8 32 bitroll .h" "ff0000ff" } +} ; diff --git a/basis/math/bitwise/bitwise-tests.factor b/basis/math/bitwise/bitwise-tests.factor new file mode 100755 index 0000000000..8b13cb23b3 --- /dev/null +++ b/basis/math/bitwise/bitwise-tests.factor @@ -0,0 +1,29 @@ +USING: accessors math math.bitwise tools.test kernel words ; +IN: math.bitwise.tests + +[ 0 ] [ 1 0 0 bitroll ] unit-test +[ 1 ] [ 1 0 1 bitroll ] unit-test +[ 1 ] [ 1 1 1 bitroll ] unit-test +[ 1 ] [ 1 0 2 bitroll ] unit-test +[ 1 ] [ 1 0 1 bitroll ] unit-test +[ 1 ] [ 1 20 2 bitroll ] unit-test +[ 1 ] [ 1 8 8 bitroll ] unit-test +[ 1 ] [ 1 -8 8 bitroll ] unit-test +[ 1 ] [ 1 -32 8 bitroll ] unit-test +[ 128 ] [ 1 -1 8 bitroll ] unit-test +[ 8 ] [ 1 3 32 bitroll ] unit-test + +[ 0 ] [ { } bitfield ] unit-test +[ 256 ] [ 1 { 8 } bitfield ] unit-test +[ 268 ] [ 3 1 { 8 2 } bitfield ] unit-test +[ 268 ] [ 1 { 8 { 3 2 } } bitfield ] unit-test +[ 512 ] [ 1 { { 1+ 8 } } bitfield ] unit-test + +: a 1 ; inline +: b 2 ; inline + +: foo ( -- flags ) { a b } flags ; + +[ 3 ] [ foo ] unit-test +[ 3 ] [ { a b } flags ] unit-test +\ foo must-infer diff --git a/basis/math/bitwise/bitwise.factor b/basis/math/bitwise/bitwise.factor new file mode 100644 index 0000000000..60c585c779 --- /dev/null +++ b/basis/math/bitwise/bitwise.factor @@ -0,0 +1,94 @@ +! Copyright (C) 2007, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays kernel math math.functions sequences +sequences.private words namespaces macros hints +combinators fry ; +IN: math.bitwise + +! utilities +: clear-bit ( x n -- y ) 2^ bitnot bitand ; inline +: set-bit ( x n -- y ) 2^ bitor ; inline +: bit-clear? ( x n -- ? ) 2^ bitand zero? ; inline +: unmask ( x n -- ? ) bitnot bitand ; inline +: unmask? ( x n -- ? ) unmask 0 > ; inline +: mask ( x n -- ? ) bitand ; inline +: mask? ( x n -- ? ) mask 0 > ; inline +: wrap ( m n -- m' ) 1- bitand ; inline +: bits ( m n -- m' ) 2^ wrap ; inline +: mask-bit ( m n -- m' ) 1- 2^ mask ; inline + +: shift-mod ( n s w -- n ) + >r shift r> 2^ wrap ; inline + +: bitroll ( x s w -- y ) + [ wrap ] keep + [ shift-mod ] + [ [ - ] keep shift-mod ] 3bi bitor ; inline + +: bitroll-32 ( n s -- n' ) 32 bitroll ; + +HINTS: bitroll-32 bignum fixnum ; + +: bitroll-64 ( n s -- n' ) 64 bitroll ; + +HINTS: bitroll-64 bignum fixnum ; + +! 32-bit arithmetic +: w+ ( int int -- int ) + 32 bits ; inline +: w- ( int int -- int ) - 32 bits ; inline +: w* ( int int -- int ) * 32 bits ; inline + +! flags +MACRO: flags ( values -- ) + [ 0 ] [ [ execute bitor ] curry compose ] reduce ; + +! bitfield +r swapd execute r> ] [ ] ? + [ shift bitor ] append 2curry ; + +PRIVATE> + +MACRO: bitfield ( bitspec -- ) + [ 0 ] [ (bitfield-quot) compose ] reduce ; + +! bit-count +> + +GENERIC: (bit-count) ( x -- n ) + +M: fixnum (bit-count) + { + [ byte-bit-count ] + [ -8 shift byte-bit-count ] + [ -16 shift byte-bit-count ] + [ -24 shift byte-bit-count ] + } cleave + + + ; + +M: bignum (bit-count) + dup 0 = [ drop 0 ] [ + [ byte-bit-count ] [ -8 shift (bit-count) ] bi + + ] if ; + +PRIVATE> + +: bit-count ( x -- n ) + dup 0 >= [ (bit-count) ] [ bitnot (bit-count) ] if ; inline diff --git a/basis/math/bitwise/summary.txt b/basis/math/bitwise/summary.txt new file mode 100644 index 0000000000..23f73db76c --- /dev/null +++ b/basis/math/bitwise/summary.txt @@ -0,0 +1 @@ +Bitwise arithmetic utilities diff --git a/basis/math/complex/complex.factor b/basis/math/complex/complex.factor index ff5c0feb78..acc8a9d6d6 100755 --- a/basis/math/complex/complex.factor +++ b/basis/math/complex/complex.factor @@ -49,5 +49,5 @@ IN: syntax : C{ \ } [ first2 rect> ] parse-literal ; parsing M: complex pprint-delims drop \ C{ \ } ; - M: complex >pprint-sequence >rect 2array ; +M: complex pprint* pprint-object ; diff --git a/basis/multiline/multiline-docs.factor b/basis/multiline/multiline-docs.factor index 0c0eb5e9dd..4782571d4a 100644 --- a/basis/multiline/multiline-docs.factor +++ b/basis/multiline/multiline-docs.factor @@ -9,14 +9,30 @@ HELP: <" { $syntax "<\" text \">" } { $description "This forms a multiline string literal ending in \">. Unlike the " { $link POSTPONE: STRING: } " form, you can end it in the middle of a line. This construct is non-nesting. In the example above, the string would be parsed as \"text\"." } ; -{ POSTPONE: <" POSTPONE: STRING: } related-words +HELP: /* +{ $syntax "/* comment */" } +{ $description "Provides C-like comments that can span multiple lines. One caveat is that " { $snippet "/*" } " and " { $snippet "*/" } " are still tokens and must not abut the comment text itself." } +{ $example "USING: multiline ;" + "/* I think that I shall never see" + " A poem lovely as a tree. */" + "" +} ; -HELP: parse-here -{ $values { "str" "a string" } } -{ $description "Parses a multiline string literal, as used by " { $link POSTPONE: STRING: } "." } ; +{ POSTPONE: <" POSTPONE: STRING: } related-words HELP: parse-multiline-string { $values { "end-text" "a string delineating the end" } { "str" "the parsed string" } } -{ $description "Parses a multiline string literal, as used by " { $link POSTPONE: <" } ". The end-text is the delimiter for the end." } ; +{ $description "Parses the input stream until the " { $snippet "end-text" } " is reached and returns the parsed text as a string." } +{ $notes "Used to implement " { $link POSTPONE: /* } " and " { $link POSTPONE: <" } "." } ; -{ parse-here parse-multiline-string } related-words +ARTICLE: "multiline" "Multiline" +"Multiline strings:" +{ $subsection POSTPONE: STRING: } +{ $subsection POSTPONE: <" } +"Multiline comments:" +{ $subsection POSTPONE: /* } +"Writing new multiline parsing words:" +{ $subsection parse-multiline-string } +; + +ABOUT: "multiline" diff --git a/basis/multiline/multiline.factor b/basis/multiline/multiline.factor index 67bcc55a06..561af504c6 100755 --- a/basis/multiline/multiline.factor +++ b/basis/multiline/multiline.factor @@ -4,6 +4,7 @@ USING: namespaces parser lexer kernel sequences words quotations math accessors ; IN: multiline +> ; @@ -13,6 +14,7 @@ IN: multiline [ drop lexer get next-line ] [ % "\n" % (parse-here) ] if ] [ ";" unexpected-eof ] if* ; +PRIVATE> : parse-here ( -- str ) [ (parse-here) ] "" make but-last @@ -22,6 +24,7 @@ IN: multiline CREATE-WORD parse-here 1quotation define-inline ; parsing +> [ 2dup start @@ -30,6 +33,7 @@ IN: multiline lexer get next-line swap (parse-multiline-string) ] if* ] [ nip unexpected-eof ] if* ; +PRIVATE> : parse-multiline-string ( end-text -- str ) [ diff --git a/basis/nmake/nmake-tests.factor b/basis/nmake/nmake-tests.factor new file mode 100644 index 0000000000..a6b1afb297 --- /dev/null +++ b/basis/nmake/nmake-tests.factor @@ -0,0 +1,8 @@ +IN: nmake.tests +USING: nmake kernel tools.test ; + +[ ] [ [ ] { } nmake ] unit-test + +[ { 1 } { 2 } ] [ [ 1 0, 2 1, ] { { } { } } nmake ] unit-test + +[ [ ] [ call ] curry { { } } nmake ] must-infer diff --git a/basis/nmake/nmake.factor b/basis/nmake/nmake.factor new file mode 100644 index 0000000000..80c3ce3411 --- /dev/null +++ b/basis/nmake/nmake.factor @@ -0,0 +1,44 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: namespaces sequences math.parser kernel macros +generalizations locals ; +IN: nmake + +SYMBOL: building-seq +: get-building-seq ( n -- seq ) + building-seq get nth ; + +: n, ( obj n -- ) get-building-seq push ; +: n% ( seq n -- ) get-building-seq push-all ; +: n# ( num n -- ) >r number>string r> n% ; + +: 0, ( obj -- ) 0 n, ; +: 0% ( seq -- ) 0 n% ; +: 0# ( num -- ) 0 n# ; +: 1, ( obj -- ) 1 n, ; +: 1% ( seq -- ) 1 n% ; +: 1# ( num -- ) 1 n# ; +: 2, ( obj -- ) 2 n, ; +: 2% ( seq -- ) 2 n% ; +: 2# ( num -- ) 2 n# ; +: 3, ( obj -- ) 3 n, ; +: 3% ( seq -- ) 3 n% ; +: 3# ( num -- ) 3 n# ; +: 4, ( obj -- ) 4 n, ; +: 4% ( seq -- ) 4 n% ; +: 4# ( num -- ) 4 n# ; + +MACRO: finish-nmake ( exemplars -- ) + length [ firstn ] curry ; + +:: nmake ( quot exemplars -- ) + [ + exemplars + [ 0 swap new-resizable ] map + building-seq set + + quot call + + building-seq get + exemplars [ [ like ] 2map ] [ finish-nmake ] bi + ] with-scope ; inline diff --git a/basis/openssl/libssl/libssl.factor b/basis/openssl/libssl/libssl.factor index e951ad8858..f1dc21f993 100755 --- a/basis/openssl/libssl/libssl.factor +++ b/basis/openssl/libssl/libssl.factor @@ -2,7 +2,7 @@ ! Portions copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.syntax combinators kernel system namespaces -assocs parser lexer sequences words quotations math.bitfields ; +assocs parser lexer sequences words quotations math.bitwise ; IN: openssl.libssl diff --git a/basis/peg/ebnf/ebnf.factor b/basis/peg/ebnf/ebnf.factor index 6e9d78e649..7083262c49 100644 --- a/basis/peg/ebnf/ebnf.factor +++ b/basis/peg/ebnf/ebnf.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel compiler.units words arrays strings math.parser sequences quotations vectors namespaces math assocs continuations peg - peg.parsers unicode.categories multiline combinators.lib + peg.parsers unicode.categories multiline splitting accessors effects sequences.deep peg.search combinators.short-circuit lexer io.streams.string stack-checker io prettyprint combinators parser ; diff --git a/basis/peg/peg.factor b/basis/peg/peg.factor index 0cf0382ee2..9ef1ac658e 100755 --- a/basis/peg/peg.factor +++ b/basis/peg/peg.factor @@ -513,18 +513,11 @@ TUPLE: action-parser p1 quot ; M: action-parser (compile) ( peg -- quot ) [ p1>> compile-parser 1quotation ] [ quot>> ] bi '[ @ , check-action ] ; -: left-trim-slice ( string -- string ) - #! Return a new string without any leading whitespace - #! from the original string. - dup empty? [ - dup first blank? [ rest-slice left-trim-slice ] when - ] unless ; - TUPLE: sp-parser p1 ; M: sp-parser (compile) ( peg -- quot ) p1>> compile-parser 1quotation '[ - input-slice left-trim-slice input-from pos set @ + input-slice [ blank? ] trim-left-slice input-from pos set @ ] ; TUPLE: delay-parser quot ; diff --git a/extra/peg/search/authors.txt b/basis/peg/search/authors.txt similarity index 100% rename from extra/peg/search/authors.txt rename to basis/peg/search/authors.txt diff --git a/extra/peg/search/search-docs.factor b/basis/peg/search/search-docs.factor similarity index 100% rename from extra/peg/search/search-docs.factor rename to basis/peg/search/search-docs.factor diff --git a/extra/peg/search/search-tests.factor b/basis/peg/search/search-tests.factor similarity index 100% rename from extra/peg/search/search-tests.factor rename to basis/peg/search/search-tests.factor diff --git a/extra/peg/search/search.factor b/basis/peg/search/search.factor similarity index 100% rename from extra/peg/search/search.factor rename to basis/peg/search/search.factor diff --git a/extra/peg/search/summary.txt b/basis/peg/search/summary.txt similarity index 100% rename from extra/peg/search/summary.txt rename to basis/peg/search/summary.txt diff --git a/extra/peg/search/tags.txt b/basis/peg/search/tags.txt similarity index 100% rename from extra/peg/search/tags.txt rename to basis/peg/search/tags.txt diff --git a/basis/persistent/hashtables/hashtables.factor b/basis/persistent/hashtables/hashtables.factor index ae60aba50e..2e2be264bb 100644 --- a/basis/persistent/hashtables/hashtables.factor +++ b/basis/persistent/hashtables/hashtables.factor @@ -51,5 +51,5 @@ M: persistent-hash clone ; : PH{ \ } [ >persistent-hash ] parse-literal ; parsing M: persistent-hash pprint-delims drop \ PH{ \ } ; - M: persistent-hash >pprint-sequence >alist ; +M: persistent-hash pprint* pprint-object ; diff --git a/basis/persistent/hashtables/nodes/bitmap/bitmap.factor b/basis/persistent/hashtables/nodes/bitmap/bitmap.factor index 7fb14a4541..f231043274 100644 --- a/basis/persistent/hashtables/nodes/bitmap/bitmap.factor +++ b/basis/persistent/hashtables/nodes/bitmap/bitmap.factor @@ -1,7 +1,7 @@ ! Based on Clojure's PersistentHashMap by Rich Hickey. -USING: math math.bit-count arrays kernel accessors locals sequences -sequences.private sequences.lib +USING: math math.bitwise arrays kernel accessors locals sequences +sequences.private persistent.sequences persistent.hashtables.config persistent.hashtables.nodes ; diff --git a/basis/persistent/hashtables/nodes/collision/collision.factor b/basis/persistent/hashtables/nodes/collision/collision.factor index b74a2ed45d..83003e5c47 100644 --- a/basis/persistent/hashtables/nodes/collision/collision.factor +++ b/basis/persistent/hashtables/nodes/collision/collision.factor @@ -1,6 +1,6 @@ ! Based on Clojure's PersistentHashMap by Rich Hickey. -USING: kernel accessors math arrays fry sequences sequences.lib +USING: kernel accessors math arrays fry sequences locals persistent.sequences persistent.hashtables.config persistent.hashtables.nodes diff --git a/basis/persistent/hashtables/nodes/full/full.factor b/basis/persistent/hashtables/nodes/full/full.factor index e0fcc1a0ab..5c60c91dca 100644 --- a/basis/persistent/hashtables/nodes/full/full.factor +++ b/basis/persistent/hashtables/nodes/full/full.factor @@ -1,7 +1,7 @@ ! Based on Clojure's PersistentHashMap by Rich Hickey. USING: math accessors kernel arrays sequences sequences.private -locals sequences.lib +locals persistent.sequences persistent.hashtables.config persistent.hashtables.nodes ; diff --git a/basis/persistent/hashtables/nodes/nodes.factor b/basis/persistent/hashtables/nodes/nodes.factor index 6201e68c6a..d681cd57fa 100644 --- a/basis/persistent/hashtables/nodes/nodes.factor +++ b/basis/persistent/hashtables/nodes/nodes.factor @@ -1,6 +1,6 @@ ! Based on Clojure's PersistentHashMap by Rich Hickey. -USING: math arrays kernel sequences sequences.lib +USING: math arrays kernel sequences accessors locals persistent.hashtables.config ; IN: persistent.hashtables.nodes diff --git a/basis/persistent/vectors/vectors.factor b/basis/persistent/vectors/vectors.factor index a636d31f48..92b3f82a54 100644 --- a/basis/persistent/vectors/vectors.factor +++ b/basis/persistent/vectors/vectors.factor @@ -182,7 +182,7 @@ M: persistent-vector equal? : PV{ \ } [ >persistent-vector ] parse-literal ; parsing M: persistent-vector pprint-delims drop \ PV{ \ } ; - M: persistent-vector >pprint-sequence ; +M: persistent-vector pprint* pprint-object ; INSTANCE: persistent-vector immutable-sequence diff --git a/basis/prettyprint/backend/backend-docs.factor b/basis/prettyprint/backend/backend-docs.factor index c6eff28d08..cc4f5cedb5 100755 --- a/basis/prettyprint/backend/backend-docs.factor +++ b/basis/prettyprint/backend/backend-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax io kernel prettyprint +USING: help.markup help.syntax io kernel prettyprint.config prettyprint.sections words strings ; IN: prettyprint.backend @@ -24,7 +24,7 @@ HELP: unparse-ch HELP: do-string-limit { $values { "str" string } { "trimmed" "a possibly trimmed string" } } -{ $description "If " { $link string-limit } " is on, trims the string such that it does not exceed the margin, appending \"...\" if trimming took place." } ; +{ $description "If " { $link string-limit? } " is on, trims the string such that it does not exceed the margin, appending \"...\" if trimming took place." } ; HELP: pprint-string { $values { "obj" object } { "str" string } { "prefix" string } { "suffix" string } } diff --git a/basis/prettyprint/backend/backend.factor b/basis/prettyprint/backend/backend.factor index 87f6d3122e..34ab1a2fcc 100755 --- a/basis/prettyprint/backend/backend.factor +++ b/basis/prettyprint/backend/backend.factor @@ -80,7 +80,7 @@ M: f pprint* drop \ f pprint-word ; dup ch>ascii-escape [ "\\" % ] [ ] ?if , ; : do-string-limit ( str -- trimmed ) - string-limit get [ + string-limit? get [ dup length margin get > [ margin get 3 - head "..." append ] when @@ -129,6 +129,30 @@ M: pathname pprint* ] if ] if ; inline +: tuple>assoc ( tuple -- assoc ) + [ class all-slots ] [ tuple-slots ] bi zip + [ [ initial>> ] dip = not ] assoc-filter + [ [ name>> ] dip ] assoc-map ; + +: pprint-slot-value ( name value -- ) + ] bi* + \ } pprint-word block> ; + +M: tuple pprint* + boa-tuples? get [ call-next-method ] [ + [ + assoc [ pprint-slot-value ] assoc-each + block> + \ } pprint-word + block> + ] check-recursion + ] if ; + : do-length-limit ( seq -- trimmed n/f ) length-limit get dup [ over length over [-] @@ -188,6 +212,8 @@ M: tuple pprint-narrow? drop t ; ] check-recursion ; M: object pprint* pprint-object ; +M: vector pprint* pprint-object ; +M: hashtable pprint* pprint-object ; M: curry pprint* dup quot>> callable? [ pprint-object ] [ diff --git a/basis/prettyprint/config/config-docs.factor b/basis/prettyprint/config/config-docs.factor index 1a2fd69949..dda565d5c9 100644 --- a/basis/prettyprint/config/config-docs.factor +++ b/basis/prettyprint/config/config-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax io kernel prettyprint +USING: help.markup help.syntax io kernel prettyprint.sections words ; IN: prettyprint.config @@ -19,5 +19,9 @@ HELP: length-limit HELP: line-limit { $var-description "The maximum number of lines output by the prettyprinter before output is truncated with \"...\". The default is " { $link f } ", denoting unlimited line count." } ; -HELP: string-limit +HELP: string-limit? { $var-description "Toggles whether printed strings are truncated to the margin." } ; + +HELP: boa-tuples? +{ $var-description "Toggles whether tuples print in BOA-form or assoc-form." } +{ $notes "See " { $link POSTPONE: T{ } " for a description of both literal tuple forms." } ; diff --git a/basis/prettyprint/config/config.factor b/basis/prettyprint/config/config.factor index 6a649bc5a6..d986791f94 100644 --- a/basis/prettyprint/config/config.factor +++ b/basis/prettyprint/config/config.factor @@ -1,9 +1,9 @@ -! Copyright (C) 2003, 2007 Slava Pestov. +! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -IN: prettyprint.config USING: arrays generic assocs io kernel math namespaces sequences strings io.styles vectors words continuations ; +IN: prettyprint.config ! Configuration SYMBOL: tab-size @@ -11,10 +11,8 @@ SYMBOL: margin SYMBOL: nesting-limit SYMBOL: length-limit SYMBOL: line-limit -SYMBOL: string-limit +SYMBOL: string-limit? +SYMBOL: boa-tuples? -global [ - 4 tab-size set - 64 margin set - string-limit off -] bind +4 tab-size set-global +64 margin set-global diff --git a/basis/prettyprint/prettyprint-docs.factor b/basis/prettyprint/prettyprint-docs.factor index f7f0f7ee44..44cf5f724f 100755 --- a/basis/prettyprint/prettyprint-docs.factor +++ b/basis/prettyprint/prettyprint-docs.factor @@ -26,7 +26,8 @@ ARTICLE: "prettyprint-variables" "Prettyprint control variables" { $subsection nesting-limit } { $subsection length-limit } { $subsection line-limit } -{ $subsection string-limit } +{ $subsection string-limit? } +{ $subsection boa-tuples? } "Note that the " { $link short. } " and " { $link pprint-short } " variables override some of these variables." { $warning "Treat the global variables as essentially being constants. Only ever rebind them in a nested scope." @@ -86,7 +87,7 @@ $nl { $subsection "prettyprint-section-protocol" } ; ARTICLE: "prettyprint-literal" "Literal prettyprinting protocol" -"Unless a more specialized method exists for the input class, the " { $link pprint* } " word outputs an object in a standard format, ultimately calling two generic words:" +"Most custom data types have a literal syntax which resembles a sequence. An easy way to define such a syntax is to add a method to the " { $link pprint* } " generic word which calls " { $link pprint-object } ", and then to provide methods on two other generic words:" { $subsection pprint-delims } { $subsection >pprint-sequence } "For example, consider the following data type, together with a parsing word for creating literals:" @@ -104,10 +105,11 @@ ARTICLE: "prettyprint-literal" "Literal prettyprinting protocol" { $code "RECT[ 100 * 200 ]" } "Without further effort, the literal does not print in the same way:" { $unchecked-example "RECT[ 100 * 200 ] ." "T{ rect f 100 200 }" } -"However, we can define two methods easily enough:" +"However, we can define three methods easily enough:" { $code "M: rect pprint-delims drop \\ RECT[ \\ ] ;" "M: rect >pprint-sequence dup rect-w \\ * rot rect-h 3array ;" + "M: rect pprint* pprint-object ;" } "Now, it will be printed in a custom way:" { $unchecked-example "RECT[ 100 * 200 ] ." "RECT[ 100 * 200 ]" } ; diff --git a/basis/prettyprint/prettyprint.factor b/basis/prettyprint/prettyprint.factor index 63a44d85d4..c52ab18027 100755 --- a/basis/prettyprint/prettyprint.factor +++ b/basis/prettyprint/prettyprint.factor @@ -71,7 +71,8 @@ IN: prettyprint { line-limit 1 } { length-limit 15 } { nesting-limit 2 } - { string-limit t } + { string-limit? t } + { boa-tuples? t } } clone [ pprint ] bind ; : unparse-short ( obj -- str ) diff --git a/basis/random/mersenne-twister/mersenne-twister.factor b/basis/random/mersenne-twister/mersenne-twister.factor index 01e79abff2..0a730190c2 100755 --- a/basis/random/mersenne-twister/mersenne-twister.factor +++ b/basis/random/mersenne-twister/mersenne-twister.factor @@ -3,7 +3,7 @@ ! mersenne twister based on ! http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/MT2002/CODES/mt19937ar.c USING: arrays kernel math namespaces sequences system init -accessors math.ranges random circular math.bitfields.lib +accessors math.ranges random circular math.bitwise combinators ; IN: random.mersenne-twister diff --git a/basis/random/random-tests.factor b/basis/random/random-tests.factor index d85df3e0be..eed4bf2e13 100644 --- a/basis/random/random-tests.factor +++ b/basis/random/random-tests.factor @@ -1,4 +1,4 @@ -USING: random sequences tools.test ; +USING: random sequences tools.test kernel ; IN: random.tests [ 4 ] [ 4 random-bytes length ] unit-test @@ -6,3 +6,6 @@ IN: random.tests [ 4 ] [ [ 4 random-bytes length ] with-secure-random ] unit-test [ 7 ] [ [ 7 random-bytes length ] with-secure-random ] unit-test + +[ 2 ] [ V{ 10 20 30 } [ delete-random drop ] keep length ] unit-test +[ V{ } [ delete-random drop ] keep length ] must-fail diff --git a/basis/random/random.factor b/basis/random/random.factor index 74b7a78723..d37e2fc2b7 100755 --- a/basis/random/random.factor +++ b/basis/random/random.factor @@ -43,6 +43,9 @@ M: f random-32* ( obj -- * ) no-random-number-generator ; ] keep nth ] if ; +: delete-random ( seq -- elt ) + [ length random ] keep [ nth ] 2keep delete-nth ; + : random-bits ( n -- r ) 2^ random ; : with-random ( tuple quot -- ) diff --git a/basis/smtp/smtp.factor b/basis/smtp/smtp.factor index 5df4b80614..fa98c7a947 100755 --- a/basis/smtp/smtp.factor +++ b/basis/smtp/smtp.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2007, 2008 Elie CHAFTARI, Dirk Vleugels, ! Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays namespaces io io.timeouts kernel logging io.sockets -sequences combinators sequences.lib splitting assocs strings +USING: arrays namespaces io io.timeouts kernel logging +io.sockets sequences combinators splitting assocs strings math.parser random system calendar io.encodings.ascii summary calendar.format accessors sets hashtables ; IN: smtp @@ -112,7 +112,7 @@ ERROR: smtp-transaction-failed < smtp-error ; } cond ; : multiline? ( response -- boolean ) - ?fourth CHAR: - = ; + 3 swap ?nth CHAR: - = ; : process-multiline ( multiline -- response ) >r readln r> 2dup " " append head? [ @@ -184,21 +184,3 @@ PRIVATE> : send-email ( email -- ) [ email>headers ] keep (send-email) ; - -! Dirk's old AUTH CRAM-MD5 code. I don't know anything about -! CRAM MD5, and the old code didn't work properly either, so here -! it is in case anyone wants to fix it later. -! -! check-response used to have this clause: -! { [ dup "334" head? ] [ " " split 1 swap nth base64> challenge set ] } -! -! and the rest of the code was as follows: -! : (cram-md5-auth) ( -- response ) -! swap challenge get -! string>md5-hmac hex-string -! " " prepend append -! >base64 ; -! -! : cram-md5-auth ( key login -- ) -! "AUTH CRAM-MD5\r\n" get-ok -! (cram-md5-auth) "\r\n" append get-ok ; diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 1c25df4112..80e888a3e9 100755 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -47,7 +47,7 @@ IN: stack-checker.known-words : infer-shuffle ( shuffle -- ) [ in>> length consume-d ] keep ! inputs shuffle - [ drop ] [ shuffle* dup copy-values dup output-d ] 2bi ! inputs outputs copies + [ drop ] [ shuffle dup copy-values dup output-d ] 2bi ! inputs outputs copies [ nip ] [ swap zip ] 2bi ! inputs copies mapping #shuffle, ; diff --git a/basis/state-parser/state-parser.factor b/basis/state-parser/state-parser.factor index ee5a5113bf..15c83bf73a 100644 --- a/basis/state-parser/state-parser.factor +++ b/basis/state-parser/state-parser.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: io io.streams.string kernel math namespaces sequences strings circular prettyprint debugger ascii sbufs fry summary -accessors sequences.lib ; +accessors ; IN: state-parser ! * Basic underlying words @@ -120,7 +120,7 @@ M: not-enough-characters summary ( obj -- str ) : take ( n -- string ) [ 1- ] [ ] bi [ - '[ drop get-char [ next , push f ] [ t ] if* ] attempt-each drop + '[ drop get-char [ next , push f ] [ t ] if* ] contains? drop ] keep get-char [ over push ] when* >string ; : pass-blank ( -- ) diff --git a/basis/syndication/syndication-tests.factor b/basis/syndication/syndication-tests.factor index 73541e7908..eb2095203c 100755 --- a/basis/syndication/syndication-tests.factor +++ b/basis/syndication/syndication-tests.factor @@ -25,7 +25,7 @@ IN: syndication.tests f } } -} ] [ "resource:extra/syndication/test/rss1.xml" load-news-file ] unit-test +} ] [ "resource:basis/syndication/test/rss1.xml" load-news-file ] unit-test [ T{ feed f @@ -42,4 +42,4 @@ IN: syndication.tests T{ timestamp f 2003 12 13 8 29 29 T{ duration f 0 0 0 -4 0 0 } } } } -} ] [ "resource:extra/syndication/test/atom.xml" load-news-file ] unit-test +} ] [ "resource:basis/syndication/test/atom.xml" load-news-file ] unit-test diff --git a/basis/tools/annotations/annotations-docs.factor b/basis/tools/annotations/annotations-docs.factor index affb95c761..f0a3235e62 100755 --- a/basis/tools/annotations/annotations-docs.factor +++ b/basis/tools/annotations/annotations-docs.factor @@ -1,4 +1,5 @@ -USING: help.markup help.syntax words parser ; +USING: help.markup help.syntax words parser quotations strings +system sequences ; IN: tools.annotations ARTICLE: "tools.annotations" "Word annotations" @@ -20,6 +21,8 @@ HELP: watch { $values { "word" word } } { $description "Annotates a word definition to print the data stack on entry and exit." } ; +{ watch watch-vars reset } related-words + HELP: breakpoint { $values { "word" word } } { $description "Annotates a word definition to enter the single stepper when executed." } ; @@ -27,3 +30,36 @@ HELP: breakpoint HELP: breakpoint-if { $values { "quot" "a quotation with stack effect" { $snippet "( -- ? )" } } { "word" word } } { $description "Annotates a word definition to enter the single stepper if the quotation yields true." } ; + +HELP: annotate-methods +{ $values + { "word" word } { "quot" quotation } } +{ $description "Annotates the word -- for generic words, all its methods -- with the quotation." } ; + +HELP: entering +{ $values + { "str" string } } +{ $description "Prints a message and the inputs to the word before the word has been called." } ; + +HELP: leaving +{ $values + { "str" string } } +{ $description "Prints a message and the outputs from a word after a word has been called." } ; + +HELP: reset +{ $values + { "word" word } } +{ $description "Resets any annotations on a word." } +{ $notes "This word will remove a " { $link watch } "." } ; + +HELP: watch-vars +{ $values + { "word" word } { "vars" "a sequence of symbols" } } +{ $description "Annotates a word definition to print the " { $snippet "vars" } " upon entering the word. This word is useful for debugging." } ; + +HELP: word-inputs +{ $values + { "word" word } + { "seq" sequence } } +{ $description "Makes a sequence of the inputs to a word by counting the number of inputs in the stack effect and saving that many items from the datastack." } ; + diff --git a/basis/tools/deploy/deploy-tests.factor b/basis/tools/deploy/deploy-tests.factor index 9171a480cf..3d007e566c 100755 --- a/basis/tools/deploy/deploy-tests.factor +++ b/basis/tools/deploy/deploy-tests.factor @@ -79,7 +79,7 @@ M: quit-responder call-responder* [ add-quot-responder - "resource:extra/http/test" >>default + "resource:basis/http/test" >>default main-responder set test-httpd diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index 833528018b..7e37436654 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -252,7 +252,8 @@ IN: tools.deploy.shaker strip-prettyprint? [ { prettyprint.config:margin - prettyprint.config:string-limit + prettyprint.config:string-limit? + prettyprint.config:boa-tuples? prettyprint.config:tab-size } % ] when diff --git a/basis/tools/scaffold/scaffold.factor b/basis/tools/scaffold/scaffold.factor index 69eac5dc15..8bc9f93bd2 100644 --- a/basis/tools/scaffold/scaffold.factor +++ b/basis/tools/scaffold/scaffold.factor @@ -3,8 +3,8 @@ USING: assocs io.files hashtables kernel namespaces sequences vocabs.loader io combinators io.encodings.utf8 calendar accessors math.parser io.streams.string ui.tools.operations quotations -strings arrays prettyprint words vocabs sorting sets cords -classes sequences.lib combinators.lib ; +strings arrays prettyprint words vocabs sorting sets +classes math alien ; IN: tools.scaffold SYMBOL: developer-name @@ -95,6 +95,7 @@ ERROR: no-vocab vocab ; { "obj3" object } { "obj4" object } { "quot" quotation } { "quot1" quotation } { "quot2" quotation } { "quot3" quotation } + { "quot'" quotation } { "string" string } { "string1" string } { "string2" string } { "string3" string } { "str" string } @@ -105,9 +106,20 @@ ERROR: no-vocab vocab ; { "ch" "a character" } { "word" word } { "array" array } + { "duration" duration } { "path" "a pathname string" } { "vocab" "a vocabulary specifier" } { "vocab-root" "a vocabulary root string" } + { "c-ptr" c-ptr } + { "seq" sequence } { "seq1" sequence } { "seq2" sequence } + { "seq3" sequence } { "seq4" sequence } + { "seq1'" sequence } { "seq2'" sequence } + { "newseq" sequence } + { "assoc" assoc } { "assoc1" assoc } { "assoc2" assoc } + { "assoc3" assoc } { "newassoc" assoc } + { "alist" "an array of key/value pairs" } + { "keys" sequence } { "values" sequence } + { "class" class } } at* ; : add-using ( object -- ) @@ -160,16 +172,18 @@ ERROR: no-vocab vocab ; : help-file-string ( str1 -- str2 ) [ - [ "IN: " write print nl ] - [ interesting-words. ] - [ "ARTICLE: " write unparse dup write bl print ";" print nl ] - [ "ABOUT: " write unparse print ] quad + { + [ "IN: " write print nl ] + [ interesting-words. ] + [ "ARTICLE: " write unparse dup write bl print ";" print nl ] + [ "ABOUT: " write unparse print ] + } cleave ] with-string-writer ; : write-using ( -- ) "USING:" write using get keys - { "help.markup" "help.syntax" } cord-append natural-sort + { "help.markup" "help.syntax" } append natural-sort [ bl write ] each " ;" print ; @@ -225,3 +239,20 @@ PRIVATE> [ drop scaffold-authors ] [ nip require ] } 2cleave ; + +SYMBOL: examples-flag + +: example ( -- ) + { + "{ $example \"\" \"USING: prettyprint ;\"" + " \"\"" + " \"\"" + "}" + } [ examples-flag get [ " " write ] when print ] each ; + +: examples ( n -- ) + t \ examples-flag [ + "{ $examples " print + [ example ] times + "}" print + ] with-variable ; diff --git a/basis/tools/vocabs/monitor/monitor.factor b/basis/tools/vocabs/monitor/monitor.factor index 12b2e41d36..ed2e486ecc 100755 --- a/basis/tools/vocabs/monitor/monitor.factor +++ b/basis/tools/vocabs/monitor/monitor.factor @@ -9,8 +9,8 @@ IN: tools.vocabs.monitor TR: convert-separators "/\\" ".." ; : vocab-dir>vocab-name ( path -- vocab ) - left-trim-separators - right-trim-separators + trim-left-separators + trim-right-separators convert-separators ; : path>vocab-name ( path -- vocab ) diff --git a/basis/ui/gadgets/canvas/canvas.factor b/basis/ui/gadgets/canvas/canvas.factor index 85149f4551..4ff7519a85 100755 --- a/basis/ui/gadgets/canvas/canvas.factor +++ b/basis/ui/gadgets/canvas/canvas.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: ui.backend ui.gadgets ui.gadgets.theme ui.gadgets.lib +USING: ui.backend ui.gadgets ui.gadgets.theme ui.gadgets.worlds ui.render opengl opengl.gl kernel namespaces classes.tuple colors accessors ; IN: ui.gadgets.canvas diff --git a/basis/ui/gadgets/lib/lib.factor b/basis/ui/gadgets/lib/lib.factor deleted file mode 100644 index 866369b0af..0000000000 --- a/basis/ui/gadgets/lib/lib.factor +++ /dev/null @@ -1,8 +0,0 @@ - -USING: accessors kernel ui.backend ui.gadgets.worlds ; - -IN: ui.gadgets.lib - -ERROR: no-world-found ; -: find-gl-context ( gadget -- ) - find-world dup [ handle>> select-gl-context ] [ no-world-found ] if ; diff --git a/basis/ui/gadgets/slate/authors.txt b/basis/ui/gadgets/slate/authors.txt deleted file mode 100755 index 6cfd5da273..0000000000 --- a/basis/ui/gadgets/slate/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Eduardo Cavazos diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor index bf4c275dc2..cedd03e39e 100755 --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/basis/ui/gadgets/worlds/worlds.factor @@ -22,6 +22,12 @@ window-loc ; : hide-status ( gadget -- ) f swap show-status ; +ERROR: no-world-found ; + +: find-gl-context ( gadget -- ) + find-world dup + [ handle>> select-gl-context ] [ no-world-found ] if ; + : (request-focus) ( child world ? -- ) pick parent>> pick eq? [ >r >r dup parent>> dup r> r> diff --git a/basis/ui/windows/windows.factor b/basis/ui/windows/windows.factor index 5f67ed4a4b..f6481225ae 100755 --- a/basis/ui/windows/windows.factor +++ b/basis/ui/windows/windows.factor @@ -8,7 +8,7 @@ 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 locals symbols accessors math.geometry.rect ; +math.bitwise locals symbols accessors math.geometry.rect ; IN: ui.windows SINGLETON: windows-ui-backend diff --git a/basis/unicode/collation/collation.factor b/basis/unicode/collation/collation.factor index b5c7665b8b..d71fffaaab 100755 --- a/basis/unicode/collation/collation.factor +++ b/basis/unicode/collation/collation.factor @@ -136,7 +136,7 @@ PRIVATE> : insensitive= ( str1 str2 levels-removed -- ? ) [ swap collation-key swap - [ [ 0 = not ] right-trim but-last ] times + [ [ 0 = not ] trim-right but-last ] times ] curry bi@ = ; PRIVATE> diff --git a/basis/unix/linux/inotify/inotify.factor b/basis/unix/linux/inotify/inotify.factor index f94dc74ab9..3385e454d2 100644 --- a/basis/unix/linux/inotify/inotify.factor +++ b/basis/unix/linux/inotify/inotify.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax math math.bitfields ; +USING: alien.syntax math math.bitwise ; IN: unix.linux.inotify C-STRUCT: inotify-event diff --git a/basis/urls/urls-tests.factor b/basis/urls/urls-tests.factor index 87c9b91950..7f835b2918 100644 --- a/basis/urls/urls-tests.factor +++ b/basis/urls/urls-tests.factor @@ -1,7 +1,6 @@ IN: urls.tests USING: urls urls.private tools.test -tuple-syntax arrays kernel assocs -present accessors ; +arrays kernel assocs present accessors ; [ "hello%20world" ] [ "hello world" url-encode ] unit-test [ "hello world" ] [ "hello%20world" url-decode ] unit-test @@ -30,78 +29,78 @@ present accessors ; : urls { { - TUPLE{ url - protocol: "http" - host: "www.apple.com" - port: 1234 - path: "/a/path" - query: H{ { "a" "b" } } - anchor: "foo" + T{ url + { protocol "http" } + { host "www.apple.com" } + { port 1234 } + { path "/a/path" } + { query H{ { "a" "b" } } } + { anchor "foo" } } "http://www.apple.com:1234/a/path?a=b#foo" } { - TUPLE{ url - protocol: "http" - host: "www.apple.com" - path: "/a/path" - query: H{ { "a" "b" } } - anchor: "foo" + T{ url + { protocol "http" } + { host "www.apple.com" } + { path "/a/path" } + { query H{ { "a" "b" } } } + { anchor "foo" } } "http://www.apple.com/a/path?a=b#foo" } { - TUPLE{ url - protocol: "http" - host: "www.apple.com" - port: 1234 - path: "/another/fine/path" - anchor: "foo" + T{ url + { protocol "http" } + { host "www.apple.com" } + { port 1234 } + { path "/another/fine/path" } + { anchor "foo" } } "http://www.apple.com:1234/another/fine/path#foo" } { - TUPLE{ url - path: "/a/relative/path" - anchor: "foo" + T{ url + { path "/a/relative/path" } + { anchor "foo" } } "/a/relative/path#foo" } { - TUPLE{ url - path: "/a/relative/path" + T{ url + { path "/a/relative/path" } } "/a/relative/path" } { - TUPLE{ url - path: "a/relative/path" + T{ url + { path "a/relative/path" } } "a/relative/path" } { - TUPLE{ url - path: "bar" - query: H{ { "a" "b" } } + T{ url + { path "bar" } + { query H{ { "a" "b" } } } } "bar?a=b" } { - TUPLE{ url - protocol: "ftp" - host: "ftp.kernel.org" - username: "slava" - path: "/" + T{ url + { protocol "ftp" } + { host "ftp.kernel.org" } + { username "slava" } + { path "/" } } "ftp://slava@ftp.kernel.org/" } { - TUPLE{ url - protocol: "ftp" - host: "ftp.kernel.org" - username: "slava" - password: "secret" - path: "/" + T{ url + { protocol "ftp" } + { host "ftp.kernel.org" } + { username "slava" } + { password "secret" } + { path "/" } } "ftp://slava:secret@ftp.kernel.org/" } @@ -128,94 +127,94 @@ urls [ [ "/xxx/bar" ] [ "/xxx/baz" "bar" url-append-path ] unit-test [ - TUPLE{ url - protocol: "http" - host: "www.apple.com" - port: 1234 - path: "/a/path" + T{ url + { protocol "http" } + { host "www.apple.com" } + { port 1234 } + { path "/a/path" } } ] [ - TUPLE{ url - protocol: "http" - host: "www.apple.com" - port: 1234 - path: "/foo" + T{ url + { protocol "http" } + { host "www.apple.com" } + { port 1234 } + { path "/foo" } } - TUPLE{ url - path: "/a/path" + T{ url + { path "/a/path" } } derive-url ] unit-test [ - TUPLE{ url - protocol: "http" - host: "www.apple.com" - port: 1234 - path: "/a/path/relative/path" - query: H{ { "a" "b" } } - anchor: "foo" + T{ url + { protocol "http" } + { host "www.apple.com" } + { port 1234 } + { path "/a/path/relative/path" } + { query H{ { "a" "b" } } } + { anchor "foo" } } ] [ - TUPLE{ url - protocol: "http" - host: "www.apple.com" - port: 1234 - path: "/a/path/" + T{ url + { protocol "http" } + { host "www.apple.com" } + { port 1234 } + { path "/a/path/" } } - TUPLE{ url - path: "relative/path" - query: H{ { "a" "b" } } - anchor: "foo" + T{ url + { path "relative/path" } + { query H{ { "a" "b" } } } + { anchor "foo" } } derive-url ] unit-test [ - TUPLE{ url - protocol: "http" - host: "www.apple.com" - port: 1234 - path: "/a/path/relative/path" - query: H{ { "a" "b" } } - anchor: "foo" + T{ url + { protocol "http" } + { host "www.apple.com" } + { port 1234 } + { path "/a/path/relative/path" } + { query H{ { "a" "b" } } } + { anchor "foo" } } ] [ - TUPLE{ url - protocol: "http" - host: "www.apple.com" - port: 1234 - path: "/a/path/" + T{ url + { protocol "http" } + { host "www.apple.com" } + { port 1234 } + { path "/a/path/" } } - TUPLE{ url - path: "relative/path" - query: H{ { "a" "b" } } - anchor: "foo" + T{ url + { path "relative/path" } + { query H{ { "a" "b" } } } + { anchor "foo" } } derive-url ] unit-test [ - TUPLE{ url - protocol: "http" - host: "www.apple.com" - path: "/xxx/baz" + T{ url + { protocol "http" } + { host "www.apple.com" } + { path "/xxx/baz" } } ] [ - TUPLE{ url - protocol: "http" - host: "www.apple.com" - path: "/xxx/bar" + T{ url + { protocol "http" } + { host "www.apple.com" } + { path "/xxx/bar" } } - TUPLE{ url - path: "baz" + T{ url + { path "baz" } } derive-url diff --git a/basis/validators/validators.factor b/basis/validators/validators.factor index 37c0216740..b786ef5529 100644 --- a/basis/validators/validators.factor +++ b/basis/validators/validators.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006, 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: kernel continuations sequences sequences.lib math +USING: kernel continuations sequences math namespaces sets math.parser math.ranges assocs regexp unicode.categories arrays hashtables words classes quotations xmode.catalog ; diff --git a/basis/windows/advapi32/advapi32.factor b/basis/windows/advapi32/advapi32.factor index b7381968a5..251b59a4d8 100755 --- a/basis/windows/advapi32/advapi32.factor +++ b/basis/windows/advapi32/advapi32.factor @@ -1,4 +1,4 @@ -USING: alias alien.syntax kernel math windows.types math.bitfields ; +USING: alias alien.syntax kernel math windows.types math.bitwise ; IN: windows.advapi32 LIBRARY: advapi32 diff --git a/basis/windows/opengl32/opengl32.factor b/basis/windows/opengl32/opengl32.factor index ca2206eac4..df09d9327a 100755 --- a/basis/windows/opengl32/opengl32.factor +++ b/basis/windows/opengl32/opengl32.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2006 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.syntax parser namespaces kernel -math math.bitfields windows.types windows.types init assocs +math math.bitwise windows.types windows.types init assocs sequences libc ; IN: windows.opengl32 diff --git a/basis/windows/user32/user32.factor b/basis/windows/user32/user32.factor index 481f00f36b..e5c9f96275 100755 --- a/basis/windows/user32/user32.factor +++ b/basis/windows/user32/user32.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2006 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.syntax parser namespaces kernel math -windows.types generalizations math.bitfields alias ; +windows.types generalizations math.bitwise alias ; IN: windows.user32 ! HKL for ActivateKeyboardLayout diff --git a/basis/windows/winsock/winsock.factor b/basis/windows/winsock/winsock.factor index 303aefeb5f..3c4230e21e 100755 --- a/basis/windows/winsock/winsock.factor +++ b/basis/windows/winsock/winsock.factor @@ -2,7 +2,7 @@ USING: alien alien.c-types alien.strings alien.syntax arrays byte-arrays kernel math sequences windows.types windows.kernel32 -windows.errors structs windows math.bitfields alias ; +windows.errors structs windows math.bitwise alias ; IN: windows.winsock USE: libc diff --git a/basis/x11/windows/windows.factor b/basis/x11/windows/windows.factor index f9158c2956..aed45655f6 100755 --- a/basis/x11/windows/windows.factor +++ b/basis/x11/windows/windows.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2006 Eduardo Cavazos and Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types hashtables kernel math math.vectors math.bitfields -namespaces sequences x11.xlib x11.constants x11.glx ; +USING: alien alien.c-types hashtables kernel math math.vectors +math.bitwise namespaces sequences x11.xlib x11.constants x11.glx ; IN: x11.windows : create-window-mask ( -- n ) diff --git a/basis/x11/xlib/xlib.factor b/basis/x11/xlib/xlib.factor index 6fc586106c..eecf427c9e 100755 --- a/basis/x11/xlib/xlib.factor +++ b/basis/x11/xlib/xlib.factor @@ -12,7 +12,7 @@ ! and note the section. USING: kernel arrays alien alien.c-types alien.strings -alien.syntax math math.bitfields words sequences namespaces +alien.syntax math math.bitwise words sequences namespaces continuations io.encodings.ascii ; IN: x11.xlib diff --git a/basis/xml/generator/generator.factor b/basis/xml/generator/generator.factor index d5cf4dac40..0de1692e00 100644 --- a/basis/xml/generator/generator.factor +++ b/basis/xml/generator/generator.factor @@ -1,7 +1,6 @@ ! Copyright (C) 2006, 2007 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: namespaces kernel xml.data xml.utilities assocs splitting -sequences parser lexer quotations sequences.lib xml.utilities ; +USING: namespaces kernel xml.data xml.utilities assocs sequences ; IN: xml.generator : comment, ( string -- ) , ; @@ -24,56 +23,3 @@ IN: xml.generator (tag,) build-xml ; inline : make-xml ( name quot -- xml ) f swap make-xml* ; inline - -! Word-based XML literal syntax -: parsed-name ( accum -- accum ) - scan ":" split1 [ f ] [ ] if* parsed ; - -: run-combinator ( accum quot1 quot2 -- accum ) - >r [ ] like parsed r> [ parsed ] each ; - -: parse-tag-contents ( accum contained? -- accum ) - [ \ contained*, parsed ] [ - scan-word \ [ = - [ POSTPONE: [ \ tag*, parsed ] - [ "Expected [ missing" throw ] if - ] if ; - -DEFER: >> - -: attributes-parsed ( accum quot -- accum ) - dup empty? [ drop f parsed ] [ - >r \ >r parsed r> parsed - [ H{ } make-assoc r> swap ] [ parsed ] each - ] if ; - -: << - parsed-name [ - \ >> parse-until >quotation - attributes-parsed \ contained? get - ] with-scope parse-tag-contents ; parsing - -: == - \ call parsed parsed-name \ set parsed ; parsing - -: // - \ contained? on ; parsing - -: parse-special ( accum end-token word -- accum ) - >r parse-tokens " " join parsed r> parsed ; - -: " \ comment, parse-special ; parsing - -: " \ directive, parse-special ; parsing - -: " \ instruction, parse-special ; parsing - -: >xml-document ( seq -- xml ) - dup first prolog? [ unclip-slice ] [ standard-prolog ] if swap - [ tag? ] split-around ; - -DEFER: XML> - -: [ >quotation ] parse-literal - { } parsed \ make parsed \ >xml-document parsed ; parsing diff --git a/basis/xmode/marker/marker.factor b/basis/xmode/marker/marker.factor index f11ac6b5b2..dfdd6c801a 100755 --- a/basis/xmode/marker/marker.factor +++ b/basis/xmode/marker/marker.factor @@ -1,7 +1,7 @@ IN: xmode.marker USING: kernel namespaces xmode.rules xmode.tokens xmode.marker.state xmode.marker.context xmode.utilities -xmode.catalog sequences math assocs combinators combinators.lib +xmode.catalog sequences math assocs combinators strings regexp splitting parser-combinators ascii unicode.case combinators.short-circuit accessors ; diff --git a/core/alien/alien-docs.factor b/core/alien/alien-docs.factor index 7eca2af858..814ca8613e 100755 --- a/core/alien/alien-docs.factor +++ b/core/alien/alien-docs.factor @@ -10,12 +10,30 @@ HELP: alien HELP: dll { $class-description "The class of native library handles. See " { $link "syntax-aliens" } " for syntax and " { $link "dll.private" } " for general information." } ; +HELP: dll-valid? ( dll -- ? ) +{ $values { "dll" dll } { "?" "a boolean" } } +{ $description "Returns true if the library exists and is loaded." } ; + HELP: expired? -{ $values { "c-ptr" "an alien, byte array, or " { $link f } } { "?" "a boolean" } } +{ $values { "c-ptr" c-ptr } { "?" "a boolean" } } { $description "Tests if the alien is a relic from an earlier session. A byte array is never considered to have expired, whereas passing " { $link f } " always yields true." } ; +HELP: +{ $values { "alien" c-ptr } } +{ $description "Constructs an invalid alien pointer that has expired." } ; + +HELP: +{ $values + { "path" "a pathname string" } { "abi" "the ABI used by the library, either " { $snippet "cdecl" } " or " { $snippet "stdcall" } } + { "library" library } } +{ $description "Opens a C library using the path and ABI parameters and outputs a library tuple." } +{ $notes "User code should use " { $link add-library } " so that the opened library is added to a global hashtable, " { $link libraries } "." } ; + +HELP: libraries +{ $description "A global hashtable that keeps a list of open libraries. Use the " { $link add-library } " word to construct a library and add it with a single call." } ; + HELP: ( displacement c-ptr -- alien ) -{ $values { "displacement" "an integer" } { "c-ptr" "an alien, byte array, or " { $link f } } { "alien" "a new alien" } } +{ $values { "displacement" "an integer" } { "c-ptr" c-ptr } { "alien" "a new alien" } } { $description "Creates a new alien address object, wrapping a raw memory address. The alien points to a location in memory which is offset by " { $snippet "displacement" } " from the address of " { $snippet "c-ptr" } "." } { $notes "Passing a value of " { $link f } " for " { $snippet "c-ptr" } " creates an alien with an absolute address; this is how " { $link } " is implemented." $nl @@ -24,7 +42,7 @@ $nl { alien-address } related-words HELP: alien-address ( c-ptr -- addr ) -{ $values { "c-ptr" "an alien or " { $link f } } { "addr" "a non-negative integer" } } +{ $values { "c-ptr" c-ptr } { "addr" "a non-negative integer" } } { $description "Outputs the address of an alien." } { $notes "Taking the address of a " { $link byte-array } " is explicitly prohibited since byte arrays can be moved by the garbage collector between the time the address is taken, and when it is accessed. If you need to pass pointers to C functions which will persist across alien calls, you must allocate unmanaged memory instead. See " { $link "malloc" } "." } ; @@ -124,7 +142,7 @@ HELP: alien-callback-error } ; HELP: alien-callback -{ $values { "return" "a C return type" } { "parameters" "a sequence of C parameter types" } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } { "quot" "a quotation" } { "alien" c-ptr } } +{ $values { "return" "a C return type" } { "parameters" "a sequence of C parameter types" } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } { "quot" "a quotation" } { "alien" alien } } { $description "Defines a callback from C to Factor which accepts the given set of parameters from the C caller, pushes them on the data stack, calls the quotation, and passes a return value back to the C caller. A return type of " { $snippet "\"void\"" } " indicates that no value is to be returned." $nl @@ -228,7 +246,8 @@ $nl "Usually one never has to deal with DLL handles directly; the C library interface creates them as required. However if direct access to these operating system facilities is required, the following primitives can be used:" { $subsection dlopen } { $subsection dlsym } -{ $subsection dlclose } ; +{ $subsection dlclose } +{ $subsection dll-valid? } ; ARTICLE: "embedding-api" "Factor embedding API" "The Factor embedding API is defined in " { $snippet "vm/master.h" } "." diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor index 67bd860732..f969b208eb 100755 --- a/core/assocs/assocs-docs.factor +++ b/core/assocs/assocs-docs.factor @@ -1,7 +1,7 @@ -! Copyright (C) 2007 Daniel Ehrenberg and Slava Pestov +! Copyright (C) 2007 Daniel Ehrenberg, Slava Pestov, and Doug Coleman ! See http://factorcode.org/license.txt for BSD license. USING: help.markup help.syntax kernel sequences -sequences.private namespaces math ; +sequences.private namespaces math quotations ; IN: assocs ARTICLE: "alists" "Association lists" @@ -81,6 +81,7 @@ ARTICLE: "assocs-sets" "Set-theoretic operations on assocs" { $subsection remove-all } { $subsection substitute } { $subsection substitute-here } +{ $subsection extract-keys } { $see-also key? assoc-contains? assoc-all? "sets" } ; ARTICLE: "assocs-mutation" "Storing keys and values in assocs" @@ -89,7 +90,18 @@ ARTICLE: "assocs-mutation" "Storing keys and values in assocs" { $subsection rename-at } { $subsection change-at } { $subsection at+ } -{ $see-also set-at delete-at clear-assoc } ; +{ $see-also set-at delete-at clear-assoc push-at } ; + +ARTICLE: "assocs-conversions" "Associative mapping conversions" +"Converting to other assocs:" +{ $subsection assoc-clone-like } +"Combining a sequence of assocs into a single assoc:" +{ $subsection assoc-combine } +"Creating an assoc from key/value sequences:" +{ $subsection zip } +"Creating key/value sequences from an assoc:" +{ $subsection unzip } +; ARTICLE: "assocs-combinators" "Associative mapping combinators" "The following combinators can be used on any associative mapping." @@ -104,10 +116,14 @@ $nl { $subsection assoc-filter } { $subsection assoc-contains? } { $subsection assoc-all? } -"Three additional combinators:" +"Additional combinators:" { $subsection cache } { $subsection map>assoc } -{ $subsection assoc>map } ; +{ $subsection assoc>map } +{ $subsection assoc-map-as } +{ $subsection search-alist } +"Utility word:" +{ $subsection assoc-pusher } ; ARTICLE: "assocs" "Associative mapping operations" "An " { $emphasis "associative mapping" } ", abbreviated " { $emphasis "assoc" } ", is a collection of key/value pairs which provides efficient lookup and storage indexed by key." @@ -121,7 +137,8 @@ $nl { $subsection "assocs-values" } { $subsection "assocs-mutation" } { $subsection "assocs-combinators" } -{ $subsection "assocs-sets" } ; +{ $subsection "assocs-sets" } +{ $subsection "assocs-conversions" } ; ABOUT: "assocs" @@ -204,6 +221,8 @@ HELP: assoc-map } } ; +{ assoc-map assoc-map-as } related-words + HELP: assoc-push-if { $values { "accum" "a resizable mutable sequence" } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "key" object } { "value" object } } { $description "If the quotation yields true when applied to the key/value pair, adds the key/value pair at the end of " { $snippet "accum" } "." } ; @@ -334,3 +353,96 @@ HELP: >alist { $values { "assoc" assoc } { "newassoc" "an array of key/value pairs" } } { $contract "Converts an associative structure into an association list." } { $notes "The " { $link assoc } " mixin has a default implementation for this generic word which constructs the association list by iterating over the assoc with " { $link assoc-find } "." } ; + +HELP: assoc-clone-like +{ $values + { "assoc" assoc } { "exemplar" assoc } + { "newassoc" assoc } } +{ $description "Outputs a newly-allocated assoc with the same elements as " { $snippet "assoc" } "." } +{ $examples { $example "USING: prettyprint assocs hashtables ;" "H{ { 1 2 } { 3 4 } } { } assoc-clone-like ." "{ { 1 2 } { 3 4 } }" } } ; + +HELP: assoc-combine +{ $values + { "seq" "a sequence of assocs" } + { "union" assoc } } +{ $description "Takes the union of all of the " { $snippet "assocs" } " in " { $snippet "seq" } "." } +{ $examples { $example "USING: prettyprint assocs ;" "{ H{ { 1 2 } } H{ { 3 4 } } } assoc-combine ." "H{ { 1 2 } { 3 4 } }" } } ; + +HELP: assoc-map-as +{ $values + { "assoc" assoc } { "quot" quotation } { "exemplar" assoc } + { "newassoc" assoc } } +{ $description "Applies the quotation to each entry in the input assoc and collects the results in a new assoc of the stame type as the exemplar." } +{ $examples { $example "USING: prettyprint assocs hashtables math ;" " H{ { 1 2 } { 3 4 } } [ sq ] { } assoc-map-as ." "{ { 1 4 } { 3 16 } }" } } ; + +HELP: assoc-pusher +{ $values + { "quot" "a predicate quotation" } + { "quot'" quotation } { "accum" assoc } } +{ $description "Creates a new " { $snippet "assoc" } " to accumulate the key/value pairs which return true for a predicate. Returns a new quotation which accepts a pair of object to be tested and stored in the accumulator if the test yields true. The accumulator is left on the stack for convenience." } +{ $example "! Find only the pairs that sum to 5:" "USING: prettyprint assocs math kernel ;" + "{ { 1 2 } { 2 3 } { 3 4 } } [ + 5 = ] assoc-pusher [ assoc-each ] dip ." + "V{ { 2 3 } }" +} +{ $notes "Used to implement the " { $link assoc-filter } " word." } ; + + +HELP: extract-keys +{ $values + { "seq" sequence } { "assoc" assoc } + { "subassoc" assoc } } +{ $description "Outputs an new " { $snippet "assoc" } " with key/value pairs whose keys match the elements in the input " { $snippet "seq" } "." } +{ $examples + { $example "USING: prettyprint assocs ;" + "{ 1 3 } { { 1 10 } { 2 20 } { 3 30 } } extract-keys ." + "{ { 1 10 } { 3 30 } }" + } +} ; + +HELP: push-at +{ $values + { "value" object } { "key" object } { "assoc" assoc } } +{ $description "Pushes the " { $snippet "value" } " onto a " { $snippet "vector" } " stored at the " { $snippet "key" } " in the " { $snippet "assoc" } ". If the " { $snippet "key" } " does not yet exist, creates a new " { $snippet "vector" } " at that " { $snippet "key" } " and pushes the " { $snippet "value" } "." } +{ $examples { $example "USING: prettyprint assocs kernel ;" +"H{ { \"cats\" V{ \"Mittens\" } } } \"Mew\" \"cats\" pick push-at ." +"H{ { \"cats\" V{ \"Mittens\" \"Mew\" } } }" +} } ; + +HELP: search-alist +{ $values + { "key" object } { "alist" "an array of key/value pairs" } + { "pair/f" "a key/value pair" } { "i/f" integer } } +{ $description "Performs an in-order traversal of a " { $snippet "alist" } " and stops when the key is matched or the end of the " { $snippet "alist" } " has been reached. If there is no match, both outputs are " { $link f } "." } +{ $examples { $example "USING: prettyprint assocs kernel ;" + "3 { { 1 2 } { 3 4 } } search-alist [ . ] bi@" + "{ 3 4 }\n1" + } { $example "USING: prettyprint assocs kernel ;" + "6 { { 1 2 } { 3 4 } } search-alist [ . ] bi@" + "f\nf" + } +} ; + +HELP: unzip +{ $values + { "assoc" assoc } + { "keys" sequence } { "values" sequence } } +{ $description "Outputs an array of keys and an array of values of the input " { $snippet "assoc" } "." } +{ $examples + { $example "USING: prettyprint assocs kernel ;" + "{ { 1 4 } { 2 5 } { 3 6 } } unzip [ . ] bi@" + "{ 1 2 3 }\n{ 4 5 6 }" + } +} ; + +HELP: zip +{ $values + { "keys" sequence } { "values" sequence } + { "alist" "an array of key/value pairs" } } +{ $description "Combines two sequences pairwise into a single sequence of key/value pairs." } +{ $examples + { $example "" "USING: prettyprint assocs ;" + "{ 1 2 3 } { 4 5 6 } zip ." + "{ { 1 4 } { 2 5 } { 3 6 } }" + } +} ; +{ unzip zip } related-words diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index 7415bd0eb2..9b8065e6c4 100755 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -164,7 +164,7 @@ M: assoc value-at* swap [ = nip ] curry assoc-find nip ; : unzip ( assoc -- keys values ) dup assoc-empty? [ drop { } { } ] [ >alist flip first2 ] if ; -: search-alist ( key alist -- pair i ) +: search-alist ( key alist -- pair/f i/f ) [ first = ] with find swap ; inline M: sequence at* diff --git a/core/byte-arrays/byte-arrays-docs.factor b/core/byte-arrays/byte-arrays-docs.factor index 8a51f4c663..25bff0fce5 100755 --- a/core/byte-arrays/byte-arrays-docs.factor +++ b/core/byte-arrays/byte-arrays-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax ; +USING: kernel help.markup help.syntax ; IN: byte-arrays ARTICLE: "byte-arrays" "Byte arrays" @@ -13,7 +13,13 @@ $nl { $subsection byte-array? } "There are several ways to construct byte arrays." { $subsection >byte-array } -{ $subsection } ; +{ $subsection } +{ $subsection 1byte-array } +{ $subsection 2byte-array } +{ $subsection 3byte-array } +{ $subsection 4byte-array } +"Resizing byte-arrays:" +{ $subsection resize-byte-array } ; ABOUT: "byte-arrays" @@ -29,3 +35,34 @@ HELP: >byte-array { $description "Outputs a freshly-allocated byte array whose elements have the same signed byte values as a given sequence." } { $errors "Throws an error if the sequence contains elements other than integers." } ; + +HELP: 1byte-array +{ $values + { "x" object } + { "byte-array" byte-array } } +{ $description "Creates a new byte-array with one element." } ; + +HELP: 2byte-array +{ $values + { "x" object } { "y" object } + { "byte-array" byte-array } } +{ $description "Creates a new byte-array with two elements." } ; + +HELP: 3byte-array +{ $values + { "x" object } { "y" object } { "z" object } + { "byte-array" byte-array } } +{ $description "Creates a new byte-array with three element." } ; + +HELP: 4byte-array +{ $values + { "w" object } { "x" object } { "y" object } { "z" object } + { "byte-array" byte-array } } +{ $description "Creates a new byte-array with four elements." } ; + +{ 1byte-array 2byte-array 3byte-array 4byte-array } related-words + +HELP: resize-byte-array ( n byte-array -- newbyte-array ) +{ $values { "n" "a non-negative integer" } { "byte-array" byte-array } + { "newbyte-array" byte-array } } +{ $description "Creates a new byte-array of n elements. The contents of the existing byte-array are copied into the new byte-array; if the new byte-array is shorter, only an initial segment is copied, and if the new byte-array is longer the remaining space is filled in with 0." } ; diff --git a/core/byte-arrays/byte-arrays.factor b/core/byte-arrays/byte-arrays.factor index 0bcea2651a..50ea4b32ba 100755 --- a/core/byte-arrays/byte-arrays.factor +++ b/core/byte-arrays/byte-arrays.factor @@ -20,10 +20,10 @@ M: byte-array resize INSTANCE: byte-array sequence -: 1byte-array ( x -- array ) 1 [ set-first ] keep ; inline +: 1byte-array ( x -- byte-array ) 1 [ set-first ] keep ; inline -: 2byte-array ( x y -- array ) B{ } 2sequence ; inline +: 2byte-array ( x y -- byte-array ) B{ } 2sequence ; inline -: 3byte-array ( x y z -- array ) B{ } 3sequence ; inline +: 3byte-array ( x y z -- byte-array ) B{ } 3sequence ; inline -: 4byte-array ( w x y z -- array ) B{ } 4sequence ; inline +: 4byte-array ( w x y z -- byte-array ) B{ } 4sequence ; inline diff --git a/core/classes/classes-docs.factor b/core/classes/classes-docs.factor index 94a913d81c..ff7aac36d3 100755 --- a/core/classes/classes-docs.factor +++ b/core/classes/classes-docs.factor @@ -28,8 +28,10 @@ $nl $nl "Classes themselves form a class:" { $subsection class? } -"You can ask an object for its class:" +"You can ask an object for its class or superclass:" { $subsection class } +{ $subsection superclass } +{ $subsection superclasses } "Testing if an object is an instance of a class:" { $subsection instance? } "Class predicates can be used to test instances directly:" @@ -79,7 +81,27 @@ $low-level-note ; HELP: superclass { $values { "class" class } { "super" class } } -{ $description "Outputs the superclass of a class. All instances of this class are also instances of the superclass." } ; +{ $description "Outputs the superclass of a class. All instances of this class are also instances of the superclass." } +{ $examples + { $example "USING: classes prettyprint ;" + "t superclass ." + "word" + } +} ; + +HELP: superclasses +{ $values + { "class" class } + { "supers" sequence } } +{ $description "Outputs a sequence of superclasses of a class along with the class itself." } +{ $examples + { $example "USING: classes prettyprint ;" + "t superclasses ." + "{ word t }" + } +} ; + +{ superclass superclasses } related-words HELP: members { $values { "class" class } { "seq" "a sequence of union members, or " { $link f } } } @@ -97,3 +119,9 @@ $low-level-note ; HELP: implementors { $values { "class/classes" "a class or a sequence of classes" } { "seq" "a sequence of generic words" } } { $description "Finds all generic words in the dictionary implementing methods for the given set of classes." } ; + +HELP: instance? +{ $values + { "object" object } { "class" class } + { "?" "a boolean" } } +{ $description "Tests whether the input object is a member of the class." } ; diff --git a/core/classes/tuple/parser/parser-tests.factor b/core/classes/tuple/parser/parser-tests.factor index 7b0cb998e4..17376a594f 100644 --- a/core/classes/tuple/parser/parser-tests.factor +++ b/core/classes/tuple/parser/parser-tests.factor @@ -91,4 +91,8 @@ must-fail-with ] with-compilation-unit ] unit-test +TUPLE: syntax-test bar baz ; +[ T{ syntax-test } ] [ T{ syntax-test } ] unit-test +[ T{ syntax-test f { 2 3 } { 4 { 5 } } } ] +[ T{ syntax-test { bar { 2 3 } } { baz { 4 { 5 } } } } ] unit-test diff --git a/core/classes/tuple/parser/parser.factor b/core/classes/tuple/parser/parser.factor index e85910d18d..0865de16c3 100644 --- a/core/classes/tuple/parser/parser.factor +++ b/core/classes/tuple/parser/parser.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel sets namespaces sequences parser -lexer combinators words classes.parser classes.tuple arrays ; +lexer combinators words classes.parser classes.tuple arrays +slots math assocs ; IN: classes.tuple.parser : slot-names ( slots -- seq ) @@ -59,9 +60,30 @@ ERROR: invalid-slot-name name ; dup check-duplicate-slots 3dup check-slot-shadowing ; -: literal>tuple ( seq -- tuple ) - { - { [ dup length 1 = ] [ first new ] } - { [ dup second not ] [ [ 2 tail ] [ first ] bi slots>tuple ] } - [ "Not implemented" throw ] - } cond ; +: parse-slot-value ( -- ) + scan scan-object 2array , scan "}" assert= ; + +: (parse-slot-values) ( -- ) + parse-slot-value + scan { + { "{" [ (parse-slot-values) ] } + { "}" [ ] } + } case ; + +: parse-slot-values ( -- ) + [ (parse-slot-values) ] { } make ; + +: boa>tuple ( class slots -- tuple ) + swap prefix >tuple ; + +: assoc>tuple ( class slots -- tuple ) + [ [ ] [ initial-values ] [ all-slots ] tri ] dip + swap [ [ slot-named offset>> 2 - ] curry dip ] curry assoc-map + [ dup ] dip update boa>tuple ; + +: parse-tuple-literal ( -- tuple ) + scan-word scan { + { "f" [ \ } parse-until boa>tuple ] } + { "{" [ parse-slot-values assoc>tuple ] } + { "}" [ new ] } + } case ; diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor index 01ade6ad05..e16be25ce4 100755 --- a/core/classes/tuple/tuple-docs.factor +++ b/core/classes/tuple/tuple-docs.factor @@ -421,7 +421,7 @@ HELP: new "IN: scratchpad" "TUPLE: employee number name department ;" "employee new ." - "T{ employee f f f f }" + "T{ employee }" } } ; diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 89e4e80460..b5c3658542 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -48,14 +48,14 @@ PREDICATE: immutable-tuple-class < tuple-class ( class -- ? ) ] 2each ] if-bootstrapping ; inline +PRIVATE> + : initial-values ( class -- slots ) all-slots [ initial>> ] map ; : pad-slots ( slots class -- slots' class ) [ initial-values over length tail append ] keep ; inline -PRIVATE> - : tuple>array ( tuple -- array ) prepare-tuple>array >r copy-tuple-slots r> diff --git a/core/combinators/combinators-docs.factor b/core/combinators/combinators-docs.factor index 67fde74a92..a494c09b05 100755 --- a/core/combinators/combinators-docs.factor +++ b/core/combinators/combinators-docs.factor @@ -16,6 +16,10 @@ $nl { $subsection while } "Generalization of " { $link bi } " and " { $link tri } ":" { $subsection cleave } +"Generalization of " { $link 2bi } " and " { $link 2tri } ":" +{ $subsection 2cleave } +"Generalization of " { $link 3bi } " and " { $link 3tri } ":" +{ $subsection 3cleave } "Generalization of " { $link bi* } " and " { $link tri* } ":" { $subsection spread } "Two combinators which abstract out nested chains of " { $link if } ":" @@ -50,6 +54,16 @@ HELP: cleave } } ; +HELP: 2cleave +{ $values { "x" object } { "y" object } + { "seq" "a sequence of quotations with stack effect " { $snippet "( x y -- ... )" } } } +{ $description "Applies each quotation to the two objects in turn." } ; + +HELP: 3cleave +{ $values { "x" object } { "y" object } { "z" object } + { "seq" "a sequence of quotations with stack effect " { $snippet "( x y z -- ... )" } } } +{ $description "Applies each quotation to the three objects in turn." } ; + { bi tri cleave } related-words HELP: spread diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index d0c83d0ca2..4a362a7f9d 100755 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -13,14 +13,14 @@ IN: combinators [ [ keep ] curry ] map concat [ drop ] append [ ] like ; ! 2cleave -: 2cleave ( x seq -- ) +: 2cleave ( x y seq -- ) [ 2keep ] each 2drop ; : 2cleave>quot ( seq -- quot ) [ [ 2keep ] curry ] map concat [ 2drop ] append [ ] like ; ! 3cleave -: 3cleave ( x seq -- ) +: 3cleave ( x y z seq -- ) [ 3keep ] each 3drop ; : 3cleave>quot ( seq -- quot ) diff --git a/core/effects/effects.factor b/core/effects/effects.factor index 2e0aa4c279..8a000b0615 100755 --- a/core/effects/effects.factor +++ b/core/effects/effects.factor @@ -65,8 +65,5 @@ M: effect clone : shuffled-values ( shuffle -- values ) out>> [ get ] map ; -: shuffle* ( stack shuffle -- newstack ) - [ [ load-shuffle ] keep shuffled-values ] with-scope ; - : shuffle ( stack shuffle -- newstack ) - [ split-shuffle ] keep shuffle* append ; + [ [ load-shuffle ] keep shuffled-values ] with-scope ; diff --git a/core/io/files/files.factor b/core/io/files/files.factor index cf87506bf9..93405fe7c0 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -47,11 +47,11 @@ HOOK: (file-appender) io-backend ( path -- stream ) : path-separator ( -- string ) os windows? "\\" "/" ? ; -: right-trim-separators ( str -- newstr ) - [ path-separator? ] right-trim ; +: trim-right-separators ( str -- newstr ) + [ path-separator? ] trim-right ; -: left-trim-separators ( str -- newstr ) - [ path-separator? ] left-trim ; +: trim-left-separators ( str -- newstr ) + [ path-separator? ] trim-left ; : last-path-separator ( path -- n ? ) [ length 1- ] keep [ path-separator? ] find-last-from ; @@ -65,7 +65,7 @@ ERROR: no-parent-directory path ; : parent-directory ( path -- parent ) dup root-directory? [ - right-trim-separators + trim-right-separators dup last-path-separator [ 1+ cut ] [ @@ -92,7 +92,7 @@ ERROR: no-parent-directory path ; : append-path-empty ( path1 path2 -- path' ) { { [ dup head.? ] [ - rest left-trim-separators append-path-empty + rest trim-left-separators append-path-empty ] } { [ dup head..? ] [ drop no-parent-directory ] } [ nip ] @@ -121,19 +121,19 @@ PRIVATE> { { [ over empty? ] [ append-path-empty ] } { [ dup empty? ] [ drop ] } - { [ over right-trim-separators "." = ] [ nip ] } + { [ over trim-right-separators "." = ] [ nip ] } { [ dup absolute-path? ] [ nip ] } - { [ dup head.? ] [ rest left-trim-separators append-path ] } + { [ dup head.? ] [ rest trim-left-separators append-path ] } { [ dup head..? ] [ - 2 tail left-trim-separators + 2 tail trim-left-separators >r parent-directory r> append-path ] } { [ over absolute-path? over first path-separator? and ] [ >r 2 head r> append ] } [ - >r right-trim-separators "/" r> - left-trim-separators 3append + >r trim-right-separators "/" r> + trim-left-separators 3append ] } cond ; @@ -142,7 +142,7 @@ PRIVATE> : file-name ( path -- string ) dup root-directory? [ - right-trim-separators + trim-right-separators dup last-path-separator [ 1+ tail ] [ drop "resource:" ?head [ file-name ] when ] if @@ -200,7 +200,7 @@ SYMBOL: current-directory : (normalize-path) ( path -- path' ) "resource:" ?head [ - left-trim-separators resource-path + trim-left-separators resource-path (normalize-path) ] [ current-directory get prepend-path @@ -219,7 +219,7 @@ M: object normalize-path ( path -- path' ) HOOK: make-directory io-backend ( path -- ) : make-directories ( path -- ) - normalize-path right-trim-separators { + normalize-path trim-right-separators { { [ dup "." = ] [ ] } { [ dup root-directory? ] [ ] } { [ dup empty? ] [ ] } diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 487d75cc6c..454c8be6e9 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -161,12 +161,13 @@ SYMBOL: interactive-vocabs "arrays" "assocs" "combinators" + "compiler" "compiler.errors" + "compiler.units" "continuations" "debugger" "definitions" "editors" - "generic" "help" "inspector" "io" @@ -174,6 +175,7 @@ SYMBOL: interactive-vocabs "kernel" "listener" "math" + "math.order" "memory" "namespaces" "prettyprint" diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index 1bcd01d9b9..4ada1ece9a 100755 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -178,6 +178,16 @@ ARTICLE: "sequences-search" "Searching sequences" { $subsection find-last } { $subsection find-last-from } ; +ARTICLE: "sequences-trimming" "Trimming sequences" +"Trimming words:" +{ $subsection trim } +{ $subsection trim-left } +{ $subsection trim-right } +"Potentially more efficient trim:" +{ $subsection trim-slice } +{ $subsection trim-left-slice } +{ $subsection trim-right-slice } ; + ARTICLE: "sequences-destructive" "Destructive operations" "These words modify their input, instead of creating a new sequence." $nl @@ -245,6 +255,7 @@ $nl { $subsection "sequences-sorting" } { $subsection "binary-search" } { $subsection "sets" } +{ $subsection "sequences-trimming" } "For inner loops:" { $subsection "sequences-unsafe" } ; @@ -315,6 +326,15 @@ HELP: empty? { $values { "seq" sequence } { "?" "a boolean" } } { $description "Tests if the sequence has zero length." } ; +HELP: if-empty +{ $values { "seq" sequence } { "quot1" quotation } { "quot2" quotation } } +{ $description "Makes an implicit check if the sequence is empty. An empty sequence is dropped and " { $snippet "quot1" } " is called. Otherwise, if the sequence has any elements, " { $snippet "quot2" } " is called on it." } +{ $example + "USING: kernel prettyprint sequences sequences.lib ;" + "{ 1 2 3 } [ \"empty sequence\" ] [ sum ] if-empty ." + "6" +} ; + HELP: delete-all { $values { "seq" "a resizable sequence" } } { $description "Resizes the sequence to zero length, removing all elements. Not all sequences are resizable." } @@ -722,7 +742,7 @@ HELP: reverse-here HELP: padding { $values { "seq" sequence } { "n" "a non-negative integer" } { "elt" object } { "quot" "a quotation with stack effect " { $snippet "( seq1 seq2 -- newseq )" } } { "newseq" "a new sequence" } } -{ $description "Outputs a new string sequence of " { $snippet "elt" } " repeated, that when appended to " { $snippet "seq" } ", yields a sequence of length " { $snippet "n" } ". If the length of { " { $snippet "seq" } " is greater than " { $snippet "n" } ", this word outputs an empty sequence." } ; +{ $description "Outputs a new string sequence of " { $snippet "elt" } " repeated, that when appended to " { $snippet "seq" } ", yields a sequence of length " { $snippet "n" } ". If the length of " { $snippet "seq" } " is greater than " { $snippet "n" } ", this word outputs an empty sequence." } ; HELP: pad-left { $values { "seq" sequence } { "n" "a non-negative integer" } { "elt" object } { "padded" "a new sequence" } } @@ -995,3 +1015,45 @@ HELP: count "50" } ; +HELP: pusher +{ $values + { "quot" "a predicate quotation" } + { "quot" quotation } { "accum" vector } } +{ $description "Creates a new vector to accumulate the values which return true for a predicate. Returns a new quotation which accepts an object to be tested and stored in the accumulator if the test yields true. The accumulator is left on the stack for convenience." } +{ $example "! Find all the even numbers:" "USING: prettyprint sequences math kernel ;" + "10 [ even? ] pusher [ each ] dip ." + "V{ 0 2 4 6 8 }" +} +{ $notes "Used to implement the " { $link filter } " word." } ; + +HELP: trim-left +{ $values + { "seq" sequence } { "quot" quotation } + { "newseq" sequence } } +{ $description "Removes elements starting from the left side of a sequence if they match a predicate. Once an element does not match, the test stops and the rest of the sequence is left on the stack as a new sequence." } +{ $example "" "USING: prettyprint math sequences ;" + "{ 0 0 1 2 3 0 0 } [ zero? ] trim-left ." + "{ 1 2 3 0 0 }" +} ; + +HELP: trim-right +{ $values + { "seq" sequence } { "quot" quotation } + { "newseq" sequence } } +{ $description "Removes elements starting from the right side of a sequence if they match a predicate. Once an element does not match, the test stops and the rest of the sequence is left on the stack as a new sequence." } +{ $example "" "USING: prettyprint math sequences ;" + "{ 0 0 1 2 3 0 0 } [ zero? ] trim-right ." + "{ 0 0 1 2 3 }" +} ; + +HELP: trim +{ $values + { "seq" sequence } { "quot" quotation } + { "newseq" sequence } } +{ $description "Removes elements starting from the left and right sides of a sequence if they match a predicate. Once an element does not match, the test stops and the rest of the sequence is left on the stack as a new sequence." } +{ $example "" "USING: prettyprint math sequences ;" + "{ 0 0 1 2 3 0 0 } [ zero? ] trim ." + "{ 1 2 3 }" +} ; + +{ trim-left trim-right trim } related-words diff --git a/core/sequences/sequences-tests.factor b/core/sequences/sequences-tests.factor index 4b7b8a3151..8018fe1cdc 100755 --- a/core/sequences/sequences-tests.factor +++ b/core/sequences/sequences-tests.factor @@ -3,6 +3,9 @@ sequences.private strings sbufs tools.test vectors generic vocabs.loader ; IN: sequences.tests +[ "empty" ] [ { } [ "empty" ] [ "not empty" ] if-empty ] unit-test +[ { 1 } "not empty" ] [ { 1 } [ "empty" ] [ "not empty" ] if-empty ] unit-test + [ V{ 1 2 3 4 } ] [ 1 5 dup >vector ] unit-test [ 3 ] [ 1 4 dup length ] unit-test [ 2 ] [ 1 3 { 1 2 3 4 } length ] unit-test @@ -234,13 +237,13 @@ unit-test [ -1./0. 0 delete-nth ] must-fail [ "" ] [ "" [ CHAR: \s = ] trim ] unit-test -[ "" ] [ "" [ CHAR: \s = ] left-trim ] unit-test -[ "" ] [ "" [ CHAR: \s = ] right-trim ] unit-test -[ "" ] [ " " [ CHAR: \s = ] left-trim ] unit-test -[ "" ] [ " " [ CHAR: \s = ] right-trim ] unit-test +[ "" ] [ "" [ CHAR: \s = ] trim-left ] unit-test +[ "" ] [ "" [ CHAR: \s = ] trim-right ] unit-test +[ "" ] [ " " [ CHAR: \s = ] trim-left ] unit-test +[ "" ] [ " " [ CHAR: \s = ] trim-right ] unit-test [ "asdf" ] [ " asdf " [ CHAR: \s = ] trim ] unit-test -[ "asdf " ] [ " asdf " [ CHAR: \s = ] left-trim ] unit-test -[ " asdf" ] [ " asdf " [ CHAR: \s = ] right-trim ] unit-test +[ "asdf " ] [ " asdf " [ CHAR: \s = ] trim-left ] unit-test +[ " asdf" ] [ " asdf " [ CHAR: \s = ] trim-right ] unit-test [ 328350 ] [ 100 [ sq ] sigma ] unit-test @@ -257,3 +260,9 @@ TUPLE: bogus-hashcode ; M: bogus-hashcode hashcode* 2drop 0 >bignum ; [ 0 ] [ { T{ bogus-hashcode } } hashcode ] unit-test + +[ { 2 4 6 } { 1 3 5 7 } ] [ { 1 2 3 4 5 6 7 } [ even? ] partition ] unit-test + +[ { 1 3 7 } ] [ 2 { 1 3 5 7 } remove-nth ] unit-test + +[ { 1 3 "X" 5 7 } ] [ "X" 2 { 1 3 5 7 } insert-nth ] unit-test diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 73c9289415..b7f36eb071 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -28,6 +28,14 @@ M: sequence lengthen 2dup length > [ set-length ] [ 2drop ] if ; M: sequence shorten 2dup length < [ set-length ] [ 2drop ] if ; : empty? ( seq -- ? ) length zero? ; inline + +: if-empty ( seq quot1 quot2 -- ) + [ dup empty? ] [ [ drop ] prepose ] [ ] tri* if ; inline + +: when-empty ( seq quot1 -- ) [ ] if-empty ; inline + +: unless-empty ( seq quot1 -- ) [ ] swap if-empty ; inline + : delete-all ( seq -- ) 0 swap set-length ; : first ( seq -- first ) 0 swap nth ; inline @@ -418,6 +426,15 @@ PRIVATE> : filter ( seq quot -- subseq ) over >r pusher >r each r> r> like ; inline +: push-either ( elt quot accum1 accum2 -- ) + >r >r keep swap r> r> ? push ; inline + +: 2pusher ( quot -- quot accum1 accum2 ) + V{ } clone V{ } clone [ [ push-either ] 3curry ] 2keep ; inline + +: partition ( seq quot -- trueseq falseseq ) + over >r 2pusher >r >r each r> r> r> tuck [ like ] 2bi@ ; inline + : monotonic? ( seq quot -- ? ) >r dup length 1- swap r> (monotonic) all? ; inline @@ -582,6 +599,9 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ; [ >r >r dup pick length + r> - over r> open-slice ] keep copy ; +: remove-nth ( n seq -- seq' ) + [ swap head-slice ] [ swap 1+ tail-slice ] 2bi append ; + : pop ( seq -- elt ) [ length 1- ] [ [ nth ] [ shorten ] 2bi ] bi ; @@ -659,6 +679,9 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ; : cut-slice ( seq n -- before after ) [ head-slice ] [ tail-slice ] 2bi ; +: insert-nth ( elt n seq -- seq' ) + swap cut-slice [ swap suffix ] dip append ; + : midpoint@ ( seq -- n ) length 2/ ; inline : halves ( seq -- first second ) @@ -725,16 +748,25 @@ PRIVATE> dup slice? [ { } like ] when 0 over length rot ; inline -: left-trim ( seq quot -- newseq ) +: trim-left-slice ( seq quot -- slice ) over >r [ not ] compose find drop r> swap - [ tail ] [ dup length tail ] if* ; inline + [ tail-slice ] [ dup length tail-slice ] if* ; inline + +: trim-left ( seq quot -- newseq ) + over [ trim-left-slice ] dip like ; inline -: right-trim ( seq quot -- newseq ) +: trim-right-slice ( seq quot -- slice ) over >r [ not ] compose find-last drop r> swap - [ 1+ head ] [ 0 head ] if* ; inline + [ 1+ head-slice ] [ 0 head-slice ] if* ; inline + +: trim-right ( seq quot -- newseq ) + over [ trim-right-slice ] dip like ; inline + +: trim-slice ( seq quot -- slice ) + [ trim-left-slice ] [ trim-right-slice ] bi ; inline : trim ( seq quot -- newseq ) - [ left-trim ] [ right-trim ] bi ; inline + over [ trim-slice ] dip like ; inline : sum ( seq -- n ) 0 [ + ] binary-reduce ; diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index 57dec876a5..cd76967e5a 100755 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -284,10 +284,31 @@ HELP: C{ HELP: T{ { $syntax "T{ class slots... }" } -{ $values { "class" "a tuple class word" } { "slots" "list of objects" } } -{ $description "Marks the beginning of a literal tuple. Literal tuples are terminated by " { $link POSTPONE: } } "." +{ $values { "class" "a tuple class word" } { "slots" "slot values" } } +{ $description "Marks the beginning of a literal tuple." $nl -"The class word must always be specified. If an insufficient number of values is given after the class word, the remaining slots of the tuple are set to " { $link f } ". If too many values are given, they are ignored." } ; +"Three literal syntax forms are recognized:" +{ $list + { "empty tuple form: if no slot values are specified, then the literal tuple will have all slots set to their initial values (see " { $link "slot-initial-values" } ")." } + { "BOA-form: if the first element of " { $snippet "slots" } " is " { $snippet "f" } ", then the remaining elements are slot values corresponding to slots in the order in which they are defined in the " { $link POSTPONE: TUPLE: } " form." } + { "assoc-form: otherwise, " { $snippet "slots" } " is interpreted as a sequence of " { $snippet "{ slot-name value }" } " pairs. The " { $snippet "slot-name" } " should not be quoted." } +} +"BOA form is more concise, whereas assoc form is more readable for larger tuples with many slots, or if only a few slots are to be specified." +$nl +"With BOA form, specifying an insufficient number of values is given after the class word, the remaining slots of the tuple are set to their initial values (see " { $link "slot-initial-values" } "). If too many values are given, an error will be raised." } +{ $examples +"An empty tuple; since vectors have their own literal syntax, the above is equivalent to " { $snippet "V{ }" } "" +{ $code "T{ vector }" } +"A BOA-form tuple:" +{ $code + "USE: colors" + "T{ rgba f 1.0 0.0 0.5 }" +} +"An assoc-form tuple equal to the above:" +{ $code + "USE: colors" + "T{ rgba { red 1.0 } { green 0.0 } { blue 0.5 } }" +} } ; HELP: W{ { $syntax "W{ object }" } diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 1617617b44..105bdc325f 100755 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -83,7 +83,7 @@ IN: bootstrap.syntax "B{" [ \ } [ >byte-array ] parse-literal ] define-syntax "BV{" [ \ } [ >byte-vector ] parse-literal ] define-syntax "H{" [ \ } [ >hashtable ] parse-literal ] define-syntax - "T{" [ \ } [ literal>tuple ] parse-literal ] define-syntax + "T{" [ parse-tuple-literal parsed ] define-syntax "W{" [ \ } [ first ] parse-literal ] define-syntax "POSTPONE:" [ scan-word parsed ] define-syntax diff --git a/extra/cfdg/cfdg.factor b/extra/cfdg/cfdg.factor index 434ecd59f5..121c835105 100644 --- a/extra/cfdg/cfdg.factor +++ b/extra/cfdg/cfdg.factor @@ -159,7 +159,7 @@ MACRO: rule ( seq -- quot ) [rule] ; VAR: background -: set-initial-background ( -- ) T{ hsva syntax:f 0 0 1 1 } clone >self ; +: set-initial-background ( -- ) T{ hsva f 0 0 1 1 } clone >self ; : set-background ( -- ) set-initial-background @@ -174,7 +174,7 @@ VAR: viewport ! { left width bottom height } VAR: start-shape -: set-initial-color ( -- ) T{ hsva syntax:f 0 0 0 1 } clone >self ; +: set-initial-color ( -- ) T{ hsva f 0 0 0 1 } clone >self ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -245,7 +245,7 @@ SYMBOL: the-slate C[ dlist get [ dlist get 1 glDeleteLists ] when ] >>ungraft H{ } clone - T{ key-down syntax:f syntax:f "ENTER" } C[ drop rebuild ] swap pick set-at + T{ key-down f f "ENTER" } C[ drop rebuild ] swap pick set-at T{ button-down } C[ drop rebuild ] swap pick set-at >>table ; diff --git a/extra/crypto/common/common.factor b/extra/crypto/common/common.factor index 651bd51774..61cc11f959 100644 --- a/extra/crypto/common/common.factor +++ b/extra/crypto/common/common.factor @@ -1,55 +1,17 @@ USING: arrays kernel io io.binary sbufs splitting grouping strings sequences namespaces math math.parser parser -hints math.bitfields.lib assocs ; +hints math.bitwise assocs ; IN: crypto.common -: w+ ( int int -- int ) + 32 bits ; inline - : (nth-int) ( string n -- int ) 2 shift dup 4 + rot ; inline : nth-int ( string n -- int ) (nth-int) le> ; inline -: nth-int-be ( string n -- int ) (nth-int) be> ; inline - : update ( num var -- ) [ w+ ] change ; inline - -: calculate-pad-length ( length -- pad-length ) - dup 56 < 55 119 ? swap - ; -: preprocess-plaintext ( string big-endian? -- padded-string ) - #! pad 0x80 then 00 til 8 bytes left, then 64bit length in bits - >r >sbuf r> over [ - HEX: 80 , - dup length HEX: 3f bitand - calculate-pad-length 0 % - length 3 shift 8 rot [ >be ] [ >le ] if % - ] "" make over push-all ; - -SYMBOL: bytes-read SYMBOL: big-endian? -: pad-last-block ( str big-endian? length -- str ) - [ - rot % - HEX: 80 , - dup HEX: 3f bitand calculate-pad-length 0 % - 3 shift 8 rot [ >be ] [ >le ] if % - ] "" make 64 group ; - -: update-old-new ( old new -- ) - [ get >r get r> ] 2keep >r >r w+ dup r> set r> set ; inline - -: slice3 ( n seq -- a b c ) >r dup 3 + r> first3 ; - -: seq>2seq ( seq -- seq1 seq2 ) - #! { abcdefgh } -> { aceg } { bdfh } - 2 group flip dup empty? [ drop { } { } ] [ first2 ] if ; - -: 2seq>seq ( seq1 seq2 -- seq ) - #! { aceg } { bdfh } -> { abcdefgh } - [ zip concat ] keep like ; - : mod-nth ( n seq -- elt ) #! 5 "abcd" -> b [ length mod ] [ nth ] bi ; diff --git a/basis/html/parser/analyzer/analyzer.factor b/extra/html/parser/analyzer/analyzer.factor similarity index 100% rename from basis/html/parser/analyzer/analyzer.factor rename to extra/html/parser/analyzer/analyzer.factor diff --git a/basis/html/parser/authors.txt b/extra/html/parser/analyzer/authors.txt similarity index 100% rename from basis/html/parser/authors.txt rename to extra/html/parser/analyzer/authors.txt diff --git a/basis/html/parser/printer/authors.txt b/extra/html/parser/authors.txt similarity index 100% rename from basis/html/parser/printer/authors.txt rename to extra/html/parser/authors.txt diff --git a/basis/html/parser/parser-tests.factor b/extra/html/parser/parser-tests.factor similarity index 100% rename from basis/html/parser/parser-tests.factor rename to extra/html/parser/parser-tests.factor diff --git a/basis/html/parser/parser.factor b/extra/html/parser/parser.factor similarity index 100% rename from basis/html/parser/parser.factor rename to extra/html/parser/parser.factor diff --git a/basis/html/parser/utils/authors.txt b/extra/html/parser/printer/authors.txt similarity index 100% rename from basis/html/parser/utils/authors.txt rename to extra/html/parser/printer/authors.txt diff --git a/basis/html/parser/printer/printer.factor b/extra/html/parser/printer/printer.factor similarity index 100% rename from basis/html/parser/printer/printer.factor rename to extra/html/parser/printer/printer.factor diff --git a/basis/units/authors.txt b/extra/html/parser/utils/authors.txt similarity index 100% rename from basis/units/authors.txt rename to extra/html/parser/utils/authors.txt diff --git a/basis/html/parser/utils/utils-tests.factor b/extra/html/parser/utils/utils-tests.factor similarity index 100% rename from basis/html/parser/utils/utils-tests.factor rename to extra/html/parser/utils/utils-tests.factor diff --git a/basis/html/parser/utils/utils.factor b/extra/html/parser/utils/utils.factor similarity index 100% rename from basis/html/parser/utils/utils.factor rename to extra/html/parser/utils/utils.factor diff --git a/extra/io/files/unique/unique.factor b/extra/io/files/unique/unique.factor index 3efef66ae3..db11471a7a 100644 --- a/extra/io/files/unique/unique.factor +++ b/extra/io/files/unique/unique.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math math.bitfields combinators.lib math.parser +USING: kernel math math.bitwise combinators.lib math.parser random sequences sequences.lib continuations namespaces io.files io arrays io.files.unique.backend system combinators vocabs.loader ; diff --git a/extra/io/serial/serial.factor b/extra/io/serial/serial.factor index c24f08906c..936bc182bc 100644 --- a/extra/io/serial/serial.factor +++ b/extra/io/serial/serial.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien.c-types assocs combinators destructors -kernel math math.bitfields math.parser sequences summary system +kernel math math.bitwise math.parser sequences summary system vocabs.loader ; IN: io.serial diff --git a/extra/io/serial/unix/bsd/bsd.factor b/extra/io/serial/unix/bsd/bsd.factor index 3c5ce62c63..b684190698 100644 --- a/extra/io/serial/unix/bsd/bsd.factor +++ b/extra/io/serial/unix/bsd/bsd.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax kernel math.bitfields sequences system io.serial ; +USING: alien.syntax kernel math.bitwise sequences system io.serial ; IN: io.serial.unix M: bsd lookup-baud ( m -- n ) diff --git a/extra/io/serial/unix/unix-tests.factor b/extra/io/serial/unix/unix-tests.factor index bbfd10b943..6dd056feb5 100644 --- a/extra/io/serial/unix/unix-tests.factor +++ b/extra/io/serial/unix/unix-tests.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel math.bitfields serial serial.unix ; +USING: accessors kernel math.bitwise serial serial.unix ; IN: io.serial.unix : serial-obj ( -- obj ) diff --git a/extra/io/serial/unix/unix.factor b/extra/io/serial/unix/unix.factor index ed60d941dd..1da6385f96 100644 --- a/extra/io/serial/unix/unix.factor +++ b/extra/io/serial/unix/unix.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien.c-types alien.syntax combinators io.ports -io.streams.duplex io.unix.backend system kernel math math.bitfields +io.streams.duplex io.unix.backend system kernel math math.bitwise vocabs.loader unix io.serial io.serial.unix.termios ; IN: io.serial.unix diff --git a/extra/math/bit-count/bit-count.factor b/extra/math/bit-count/bit-count.factor deleted file mode 100644 index f5b0cc53df..0000000000 --- a/extra/math/bit-count/bit-count.factor +++ /dev/null @@ -1,38 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel math math.functions quotations words sequences -sequences.private combinators fry ; -IN: math.bit-count - -> - -GENERIC: (bit-count) ( x -- n ) - -M: fixnum (bit-count) - { - [ byte-bit-count ] - [ -8 shift byte-bit-count ] - [ -16 shift byte-bit-count ] - [ -24 shift byte-bit-count ] - } cleave + + + ; - -M: bignum (bit-count) - dup 0 = [ drop 0 ] [ - [ byte-bit-count ] [ -8 shift (bit-count) ] bi + - ] if ; - -PRIVATE> - -: bit-count ( x -- n ) - dup 0 >= [ (bit-count) ] [ bitnot (bit-count) ] if ; inline diff --git a/extra/math/bitfields/lib/lib-docs.factor b/extra/math/bitfields/lib/lib-docs.factor deleted file mode 100644 index bfbe9eaded..0000000000 --- a/extra/math/bitfields/lib/lib-docs.factor +++ /dev/null @@ -1,16 +0,0 @@ -USING: help.markup help.syntax kernel math sequences ; -IN: math.bitfields.lib - -HELP: bits -{ $values { "m" integer } { "n" integer } { "m'" integer } } -{ $description "Keep only n bits from the integer m." } -{ $example "USING: math.bitfields.lib prettyprint ;" "HEX: 123abcdef 16 bits .h" "cdef" } ; - -HELP: bitroll -{ $values { "x" "an integer (input)" } { "s" "an integer (shift)" } { "w" "an integer (wrap)" } { "y" integer } } -{ $description "Roll n by s bits to the left, wrapping around after w bits." } -{ $examples - { $example "USING: math.bitfields.lib prettyprint ;" "1 -1 32 bitroll .b" "10000000000000000000000000000000" } - { $example "USING: math.bitfields.lib prettyprint ;" "HEX: ffff0000 8 32 bitroll .h" "ff0000ff" } -} ; - diff --git a/extra/math/bitfields/lib/lib-tests.factor b/extra/math/bitfields/lib/lib-tests.factor deleted file mode 100644 index c002240e69..0000000000 --- a/extra/math/bitfields/lib/lib-tests.factor +++ /dev/null @@ -1,14 +0,0 @@ -USING: math.bitfields.lib tools.test ; -IN: math.bitfields.lib.test - -[ 0 ] [ 1 0 0 bitroll ] unit-test -[ 1 ] [ 1 0 1 bitroll ] unit-test -[ 1 ] [ 1 1 1 bitroll ] unit-test -[ 1 ] [ 1 0 2 bitroll ] unit-test -[ 1 ] [ 1 0 1 bitroll ] unit-test -[ 1 ] [ 1 20 2 bitroll ] unit-test -[ 1 ] [ 1 8 8 bitroll ] unit-test -[ 1 ] [ 1 -8 8 bitroll ] unit-test -[ 1 ] [ 1 -32 8 bitroll ] unit-test -[ 128 ] [ 1 -1 8 bitroll ] unit-test -[ 8 ] [ 1 3 32 bitroll ] unit-test diff --git a/extra/math/bitfields/lib/lib.factor b/extra/math/bitfields/lib/lib.factor deleted file mode 100644 index 1e755d71d9..0000000000 --- a/extra/math/bitfields/lib/lib.factor +++ /dev/null @@ -1,30 +0,0 @@ -USING: hints kernel math ; -IN: math.bitfields.lib - -: clear-bit ( x n -- y ) 2^ bitnot bitand ; inline -: set-bit ( x n -- y ) 2^ bitor ; inline -: bit-clear? ( x n -- ? ) 2^ bitand zero? ; inline -: unmask ( x n -- ? ) bitnot bitand ; inline -: unmask? ( x n -- ? ) unmask 0 > ; inline -: mask ( x n -- ? ) bitand ; inline -: mask? ( x n -- ? ) mask 0 > ; inline -: wrap ( m n -- m' ) 1- bitand ; inline -: bits ( m n -- m' ) 2^ wrap ; inline -: mask-bit ( m n -- m' ) 1- 2^ mask ; inline - -: shift-mod ( n s w -- n ) - >r shift r> 2^ wrap ; inline - -: bitroll ( x s w -- y ) - [ wrap ] keep - [ shift-mod ] - [ [ - ] keep shift-mod ] 3bi bitor ; inline - -: bitroll-32 ( n s -- n' ) 32 bitroll ; - -HINTS: bitroll-32 bignum fixnum ; - -: bitroll-64 ( n s -- n' ) 64 bitroll ; - -HINTS: bitroll-64 bignum fixnum ; - diff --git a/extra/math/blas/syntax/syntax.factor b/extra/math/blas/syntax/syntax.factor index 1072c64b32..6b40910687 100644 --- a/extra/math/blas/syntax/syntax.factor +++ b/extra/math/blas/syntax/syntax.factor @@ -31,4 +31,6 @@ M: float-complex-blas-matrix pprint-delims drop \ cmatrix{ \ } ; M: double-complex-blas-matrix pprint-delims drop \ zmatrix{ \ } ; M: blas-vector-base >pprint-sequence ; +M: blas-vector-base pprint* pprint-object ; M: blas-matrix-base >pprint-sequence Mrows ; +M: blas-matrix-base pprint* pprint-object ; diff --git a/extra/math/polynomials/polynomials.factor b/extra/math/polynomials/polynomials.factor index e3adf2277d..1883f56929 100644 --- a/extra/math/polynomials/polynomials.factor +++ b/extra/math/polynomials/polynomials.factor @@ -22,7 +22,7 @@ PRIVATE> : p= ( p p -- ? ) pextend = ; : ptrim ( p -- p ) - dup length 1 = [ [ zero? ] right-trim ] unless ; + dup length 1 = [ [ zero? ] trim-right ] unless ; : 2ptrim ( p p -- p p ) [ ptrim ] bi@ ; : p+ ( p p -- p ) pextend v+ ; diff --git a/extra/money/money.factor b/extra/money/money.factor index ba7a0ae04f..bf9f4d3a67 100644 --- a/extra/money/money.factor +++ b/extra/money/money.factor @@ -6,14 +6,16 @@ IN: money : dollars/cents ( dollars -- dollars cents ) 100 * 100 /mod round ; -: money. ( object -- ) - dollars/cents - [ +: money>string ( object -- string ) + dollars/cents [ "$" % swap number>string 3 group "," join % "." % number>string 2 CHAR: 0 pad-left % - ] "" make print ; + ] "" make ; + +: money. ( object -- ) + money>string print ; ERROR: not-a-decimal x ; diff --git a/extra/namespaces/lib/lib-tests.factor b/extra/namespaces/lib/lib-tests.factor index 0bc2e6311a..d3f5a12faa 100755 --- a/extra/namespaces/lib/lib-tests.factor +++ b/extra/namespaces/lib/lib-tests.factor @@ -1,8 +1 @@ -IN: namespaces.lib.tests -USING: namespaces.lib kernel tools.test ; -[ ] [ [ ] { } nmake ] unit-test - -[ { 1 } { 2 } ] [ [ 1 0, 2 1, ] { { } { } } nmake ] unit-test - -[ [ ] [ call ] curry { { } } nmake ] must-infer diff --git a/extra/namespaces/lib/lib.factor b/extra/namespaces/lib/lib.factor index da9fde9d79..ae0887e45a 100755 --- a/extra/namespaces/lib/lib.factor +++ b/extra/namespaces/lib/lib.factor @@ -16,45 +16,6 @@ IN: namespaces.lib : set* ( val var -- ) namestack* set-assoc-stack ; -SYMBOL: building-seq -: get-building-seq ( n -- seq ) - building-seq get nth ; - -: n, ( obj n -- ) get-building-seq push ; -: n% ( seq n -- ) get-building-seq push-all ; -: n# ( num n -- ) >r number>string r> n% ; - -: 0, ( obj -- ) 0 n, ; -: 0% ( seq -- ) 0 n% ; -: 0# ( num -- ) 0 n# ; -: 1, ( obj -- ) 1 n, ; -: 1% ( seq -- ) 1 n% ; -: 1# ( num -- ) 1 n# ; -: 2, ( obj -- ) 2 n, ; -: 2% ( seq -- ) 2 n% ; -: 2# ( num -- ) 2 n# ; -: 3, ( obj -- ) 3 n, ; -: 3% ( seq -- ) 3 n% ; -: 3# ( num -- ) 3 n# ; -: 4, ( obj -- ) 4 n, ; -: 4% ( seq -- ) 4 n% ; -: 4# ( num -- ) 4 n# ; - -MACRO: finish-nmake ( exemplars -- ) - length [ firstn ] curry ; - -:: nmake ( quot exemplars -- ) - [ - exemplars - [ 0 swap new-resizable ] map - building-seq set - - quot call - - building-seq get - exemplars [ [ like ] 2map ] [ finish-nmake ] bi - ] with-scope ; inline - : make-object ( quot class -- object ) new [ swap bind ] keep ; inline diff --git a/basis/opengl/capabilities/authors.txt b/extra/opengl/capabilities/authors.txt similarity index 100% rename from basis/opengl/capabilities/authors.txt rename to extra/opengl/capabilities/authors.txt diff --git a/basis/opengl/capabilities/capabilities-docs.factor b/extra/opengl/capabilities/capabilities-docs.factor similarity index 100% rename from basis/opengl/capabilities/capabilities-docs.factor rename to extra/opengl/capabilities/capabilities-docs.factor diff --git a/basis/opengl/capabilities/capabilities.factor b/extra/opengl/capabilities/capabilities.factor similarity index 100% rename from basis/opengl/capabilities/capabilities.factor rename to extra/opengl/capabilities/capabilities.factor diff --git a/basis/opengl/capabilities/summary.txt b/extra/opengl/capabilities/summary.txt similarity index 100% rename from basis/opengl/capabilities/summary.txt rename to extra/opengl/capabilities/summary.txt diff --git a/basis/opengl/capabilities/tags.txt b/extra/opengl/capabilities/tags.txt similarity index 100% rename from basis/opengl/capabilities/tags.txt rename to extra/opengl/capabilities/tags.txt diff --git a/basis/opengl/demo-support/authors.txt b/extra/opengl/demo-support/authors.txt similarity index 100% rename from basis/opengl/demo-support/authors.txt rename to extra/opengl/demo-support/authors.txt diff --git a/basis/opengl/demo-support/demo-support.factor b/extra/opengl/demo-support/demo-support.factor similarity index 100% rename from basis/opengl/demo-support/demo-support.factor rename to extra/opengl/demo-support/demo-support.factor diff --git a/basis/opengl/demo-support/summary.txt b/extra/opengl/demo-support/summary.txt similarity index 100% rename from basis/opengl/demo-support/summary.txt rename to extra/opengl/demo-support/summary.txt diff --git a/basis/opengl/demo-support/tags.txt b/extra/opengl/demo-support/tags.txt similarity index 100% rename from basis/opengl/demo-support/tags.txt rename to extra/opengl/demo-support/tags.txt diff --git a/basis/opengl/framebuffers/authors.txt b/extra/opengl/framebuffers/authors.txt similarity index 100% rename from basis/opengl/framebuffers/authors.txt rename to extra/opengl/framebuffers/authors.txt diff --git a/basis/opengl/framebuffers/framebuffers-docs.factor b/extra/opengl/framebuffers/framebuffers-docs.factor similarity index 100% rename from basis/opengl/framebuffers/framebuffers-docs.factor rename to extra/opengl/framebuffers/framebuffers-docs.factor diff --git a/basis/opengl/framebuffers/framebuffers.factor b/extra/opengl/framebuffers/framebuffers.factor similarity index 100% rename from basis/opengl/framebuffers/framebuffers.factor rename to extra/opengl/framebuffers/framebuffers.factor diff --git a/basis/opengl/framebuffers/summary.txt b/extra/opengl/framebuffers/summary.txt similarity index 100% rename from basis/opengl/framebuffers/summary.txt rename to extra/opengl/framebuffers/summary.txt diff --git a/basis/opengl/framebuffers/tags.txt b/extra/opengl/framebuffers/tags.txt similarity index 100% rename from basis/opengl/framebuffers/tags.txt rename to extra/opengl/framebuffers/tags.txt diff --git a/basis/opengl/gadgets/gadgets-tests.factor b/extra/opengl/gadgets/gadgets-tests.factor similarity index 100% rename from basis/opengl/gadgets/gadgets-tests.factor rename to extra/opengl/gadgets/gadgets-tests.factor diff --git a/basis/opengl/gadgets/gadgets.factor b/extra/opengl/gadgets/gadgets.factor similarity index 100% rename from basis/opengl/gadgets/gadgets.factor rename to extra/opengl/gadgets/gadgets.factor diff --git a/basis/opengl/shaders/authors.txt b/extra/opengl/shaders/authors.txt similarity index 100% rename from basis/opengl/shaders/authors.txt rename to extra/opengl/shaders/authors.txt diff --git a/basis/opengl/shaders/shaders-docs.factor b/extra/opengl/shaders/shaders-docs.factor similarity index 100% rename from basis/opengl/shaders/shaders-docs.factor rename to extra/opengl/shaders/shaders-docs.factor diff --git a/basis/opengl/shaders/shaders.factor b/extra/opengl/shaders/shaders.factor similarity index 100% rename from basis/opengl/shaders/shaders.factor rename to extra/opengl/shaders/shaders.factor diff --git a/basis/opengl/shaders/summary.txt b/extra/opengl/shaders/summary.txt similarity index 100% rename from basis/opengl/shaders/summary.txt rename to extra/opengl/shaders/summary.txt diff --git a/basis/opengl/shaders/tags.txt b/extra/opengl/shaders/tags.txt similarity index 100% rename from basis/opengl/shaders/tags.txt rename to extra/opengl/shaders/tags.txt diff --git a/extra/pack/pack.factor b/extra/pack/pack.factor index ed2756bb80..b487b385b9 100755 --- a/extra/pack/pack.factor +++ b/extra/pack/pack.factor @@ -1,7 +1,7 @@ USING: alien alien.c-types arrays assocs byte-arrays io io.binary io.streams.string kernel math math.parser namespaces parser prettyprint quotations sequences strings vectors words -macros math.functions math.bitfields.lib ; +macros math.functions math.bitwise ; IN: pack SYMBOL: big-endian @@ -84,7 +84,7 @@ M: string b, ( n string -- ) heap-size b, ; "\0" read-until [ drop f ] unless ; : read-c-string* ( n -- str/f ) - read [ zero? ] right-trim dup empty? [ drop f ] when ; + read [ zero? ] trim-right dup empty? [ drop f ] when ; : (read-128-ber) ( n -- n ) read1 diff --git a/extra/parser-combinators/parser-combinators.factor b/extra/parser-combinators/parser-combinators.factor index da723bae9d..0ee91bc326 100755 --- a/extra/parser-combinators/parser-combinators.factor +++ b/extra/parser-combinators/parser-combinators.factor @@ -175,11 +175,11 @@ M: or-parser parse ( input parser1 -- list ) parsers>> 0 swap seq>list [ parse ] lazy-map-with lconcat ; -: left-trim-slice ( string -- string ) +: trim-left-slice ( string -- string ) #! Return a new string without any leading whitespace #! from the original string. dup empty? [ - dup first blank? [ rest-slice left-trim-slice ] when + dup first blank? [ rest-slice trim-left-slice ] when ] unless ; TUPLE: sp-parser p1 ; @@ -191,7 +191,7 @@ C: sp sp-parser ( p1 -- parser ) M: sp-parser parse ( input parser -- list ) #! Skip all leading whitespace from the input then call #! the parser on the remaining input. - >r left-trim-slice r> p1>> parse ; + >r trim-left-slice r> p1>> parse ; TUPLE: just-parser p1 ; diff --git a/extra/project-euler/059/059.factor b/extra/project-euler/059/059.factor index 7cc6df3525..aa2cdb75b0 100644 --- a/extra/project-euler/059/059.factor +++ b/extra/project-euler/059/059.factor @@ -53,7 +53,7 @@ IN: project-euler.059 : source-059 ( -- seq ) "resource:extra/project-euler/059/cipher1.txt" - ascii file-contents [ blank? ] right-trim "," split + ascii file-contents [ blank? ] trim-right "," split [ string>number ] map ; TUPLE: rollover seq n ; diff --git a/extra/sequences/lib/lib-tests.factor b/extra/sequences/lib/lib-tests.factor index 3744a7217a..76f3bb4f5b 100755 --- a/extra/sequences/lib/lib-tests.factor +++ b/extra/sequences/lib/lib-tests.factor @@ -43,9 +43,6 @@ IN: sequences.lib.tests [ { { 1 1 1 1 } { 2 2 } { 3 } { 4 } { 5 } { 6 6 6 } } ] [ { 1 1 1 1 2 2 3 4 5 6 6 6 } [ = ] monotonic-split [ >array ] map ] unit-test -[ 2 ] [ V{ 10 20 30 } [ delete-random drop ] keep length ] unit-test -[ V{ } [ delete-random drop ] keep length ] must-fail - [ { 1 9 25 } ] [ { 1 3 5 6 } [ sq ] [ even? ] map-until ] unit-test [ { 2 4 } ] [ { 2 4 1 3 } [ even? ] take-while ] unit-test @@ -69,6 +66,3 @@ IN: sequences.lib.tests [ "empty" ] [ { } [ "not empty" ] [ "empty" ] if-seq ] unit-test [ { 1 } "not empty" ] [ { 1 } [ "not empty" ] [ "empty" ] if-seq ] unit-test - -[ "empty" ] [ { } [ "empty" ] [ "not empty" ] if-empty ] unit-test -[ { 1 } "not empty" ] [ { 1 } [ "empty" ] [ "not empty" ] if-empty ] unit-test diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index 9e984857f6..2eb3c44b42 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -88,9 +88,6 @@ IN: sequences.lib : monotonic-split ( seq quot -- newseq ) over empty? [ 2drop { } ] [ (monotonic-split) ] if ; -: delete-random ( seq -- value ) - [ length random ] keep [ nth ] 2keep delete-nth ; - ERROR: element-not-found ; : split-around ( seq quot -- before elem after ) dupd find over [ element-not-found ] unless @@ -138,15 +135,6 @@ PRIVATE> : power-set ( seq -- subsets ) 2 over length exact-number-strings swap [ switches ] curry map ; -: push-either ( elt quot accum1 accum2 -- ) - >r >r keep swap r> r> ? push ; inline - -: 2pusher ( quot -- quot accum1 accum2 ) - V{ } clone V{ } clone [ [ push-either ] 3curry ] 2keep ; inline - -: partition ( seq quot -- trueseq falseseq ) - over >r 2pusher >r >r each r> r> r> drop ; inline - : cut-find ( seq pred -- before after ) dupd find drop dup [ cut ] when ; @@ -202,12 +190,6 @@ PRIVATE> : ?nth* ( n seq -- elt/f ? ) 2dup bounds-check? [ nth-unsafe t ] [ 2drop f f ] if ; flushable -: remove-nth ( n seq -- seq' ) - [ swap head-slice ] [ swap 1+ tail-slice ] 2bi append ; - -: insert-nth ( elt n seq -- seq' ) - swap cut-slice [ swap 1array ] dip 3append ; - : if-seq ( seq quot1 quot2 -- ) [ f like ] 2dip if* ; inline : if-empty ( seq quot1 quot2 -- ) swap if-seq ; inline diff --git a/extra/serial/serial.factor b/extra/serial/serial.factor index 39a63927da..df304e0f04 100644 --- a/extra/serial/serial.factor +++ b/extra/serial/serial.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien.c-types assocs combinators destructors -kernel math math.bitfields math.parser sequences summary system +kernel math math.bitwise math.parser sequences summary system vocabs.loader ; IN: serial diff --git a/extra/serial/unix/bsd/bsd.factor b/extra/serial/unix/bsd/bsd.factor index feed85348b..d31d947dcb 100644 --- a/extra/serial/unix/bsd/bsd.factor +++ b/extra/serial/unix/bsd/bsd.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax kernel math.bitfields sequences system serial ; +USING: alien.syntax kernel math.bitwise sequences system serial ; IN: serial.unix M: bsd lookup-baud ( m -- n ) diff --git a/extra/serial/unix/unix-tests.factor b/extra/serial/unix/unix-tests.factor index bab6c3f4f1..e9126a5961 100644 --- a/extra/serial/unix/unix-tests.factor +++ b/extra/serial/unix/unix-tests.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel math.bitfields serial serial.unix ; +USING: accessors kernel math.bitwise serial serial.unix ; IN: serial.unix : serial-obj ( -- obj ) diff --git a/extra/serial/unix/unix.factor b/extra/serial/unix/unix.factor index 7ed5bced37..90dbd185bd 100644 --- a/extra/serial/unix/unix.factor +++ b/extra/serial/unix/unix.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien.c-types alien.syntax combinators io.ports -io.streams.duplex io.unix.backend system kernel math math.bitfields +io.streams.duplex io.unix.backend system kernel math math.bitwise vocabs.loader unix serial serial.unix.termios ; IN: serial.unix diff --git a/extra/soundex/soundex.factor b/extra/soundex/soundex.factor index 23d5ee4d4c..d0da0b1347 100644 --- a/extra/soundex/soundex.factor +++ b/extra/soundex/soundex.factor @@ -15,7 +15,7 @@ TR: soundex-tr [ 2 [ = not ] assoc-filter values ] [ first ] bi prefix ; : first>upper ( seq -- seq' ) 1 head >upper ; -: trim-first ( seq -- seq' ) dup first [ = ] curry left-trim ; +: trim-first ( seq -- seq' ) dup first [ = ] curry trim-left ; : remove-zeroes ( seq -- seq' ) CHAR: 0 swap remove ; : remove-non-alpha ( seq -- seq' ) [ alpha? ] filter ; : pad-4 ( first seq -- seq' ) "000" 3append 4 head ; diff --git a/extra/spheres/tags.txt b/extra/spheres/tags.txt index 2e6040bd16..b9a82374be 100644 --- a/extra/spheres/tags.txt +++ b/extra/spheres/tags.txt @@ -1,2 +1,3 @@ opengl glsl +demos diff --git a/extra/tar/tar.factor b/extra/tar/tar.factor index 28913d7141..286ac0183a 100755 --- a/extra/tar/tar.factor +++ b/extra/tar/tar.factor @@ -135,7 +135,7 @@ M: unknown-typeflag summary ( obj -- str ) : typeflag-L ( header -- ) drop ; ! [ read-data-blocks ] keep - ! >string [ zero? ] right-trim filename set + ! >string [ zero? ] trim-right filename set ! filename get tar-prepend-path make-directories ; ! Multi volume continuation entry diff --git a/extra/tuple-syntax/authors.txt b/extra/tuple-syntax/authors.txt deleted file mode 100644 index f990dd0ed2..0000000000 --- a/extra/tuple-syntax/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Daniel Ehrenberg diff --git a/extra/tuple-syntax/summary.txt b/extra/tuple-syntax/summary.txt deleted file mode 100644 index f243374925..0000000000 --- a/extra/tuple-syntax/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Tuple literals with named slots diff --git a/extra/tuple-syntax/tags.txt b/extra/tuple-syntax/tags.txt deleted file mode 100644 index abf53a421b..0000000000 --- a/extra/tuple-syntax/tags.txt +++ /dev/null @@ -1 +0,0 @@ -reflection diff --git a/extra/tuple-syntax/tuple-syntax-docs.factor b/extra/tuple-syntax/tuple-syntax-docs.factor deleted file mode 100644 index d27cf27c9b..0000000000 --- a/extra/tuple-syntax/tuple-syntax-docs.factor +++ /dev/null @@ -1,8 +0,0 @@ -USING: help.markup help.syntax ; -IN: tuple-syntax - -HELP: TUPLE{ -{ $syntax "TUPLE{ class slot-name: value... }" } -{ $values { "class" "a tuple class word" } { "slot-name" "the name of a slot, without the tuple class name" } { "value" "the value for a slot" } } -{ $description "Marks the beginning of a literal tuple. Literal tuples are terminated by " { $link POSTPONE: } } ". The class word must be specified. Slots which aren't specified are set to f. If slot names are duplicated, the latest one is used." } -{ $see-also POSTPONE: T{ } ; diff --git a/extra/tuple-syntax/tuple-syntax-tests.factor b/extra/tuple-syntax/tuple-syntax-tests.factor deleted file mode 100755 index 452672ea2a..0000000000 --- a/extra/tuple-syntax/tuple-syntax-tests.factor +++ /dev/null @@ -1,8 +0,0 @@ -USING: tools.test tuple-syntax ; -IN: tuple-syntax.tests - -TUPLE: foo bar baz ; - -[ T{ foo } ] [ TUPLE{ foo } ] unit-test -[ T{ foo f { 2 3 } { 4 { 5 } } } ] -[ TUPLE{ foo bar: { 2 3 } baz: { 4 { 5 } } } ] unit-test diff --git a/extra/tuple-syntax/tuple-syntax.factor b/extra/tuple-syntax/tuple-syntax.factor deleted file mode 100755 index 0feb251691..0000000000 --- a/extra/tuple-syntax/tuple-syntax.factor +++ /dev/null @@ -1,18 +0,0 @@ -USING: classes.tuple accessors kernel sequences slots parser -lexer words classes slots.private mirrors ; -IN: tuple-syntax - -! TUPLE: foo bar baz ; -! TUPLE{ foo bar: 1 baz: 2 } - -: parse-slot-writer ( tuple -- slot# ) - scan dup "}" = [ 2drop f ] [ - but-last swap class all-slots slot-named offset>> - ] if ; - -: parse-slots ( accum tuple -- accum tuple ) - dup parse-slot-writer - [ scan-object pick rot set-slot parse-slots ] when* ; - -: TUPLE{ - scan-word new parse-slots parsed ; parsing diff --git a/basis/ui/gadgets/cartesian/cartesian.factor b/extra/ui/gadgets/cartesian/cartesian.factor similarity index 100% rename from basis/ui/gadgets/cartesian/cartesian.factor rename to extra/ui/gadgets/cartesian/cartesian.factor diff --git a/basis/ui/gadgets/frame-buffer/frame-buffer.factor b/extra/ui/gadgets/frame-buffer/frame-buffer.factor similarity index 100% rename from basis/ui/gadgets/frame-buffer/frame-buffer.factor rename to extra/ui/gadgets/frame-buffer/frame-buffer.factor diff --git a/basis/ui/gadgets/handler/authors.txt b/extra/ui/gadgets/handler/authors.txt similarity index 100% rename from basis/ui/gadgets/handler/authors.txt rename to extra/ui/gadgets/handler/authors.txt diff --git a/basis/ui/gadgets/handler/handler.factor b/extra/ui/gadgets/handler/handler.factor similarity index 100% rename from basis/ui/gadgets/handler/handler.factor rename to extra/ui/gadgets/handler/handler.factor diff --git a/basis/ui/gadgets/plot/plot.factor b/extra/ui/gadgets/plot/plot.factor similarity index 100% rename from basis/ui/gadgets/plot/plot.factor rename to extra/ui/gadgets/plot/plot.factor diff --git a/basis/ui/gadgets/lib/authors.txt b/extra/ui/gadgets/slate/authors.txt similarity index 100% rename from basis/ui/gadgets/lib/authors.txt rename to extra/ui/gadgets/slate/authors.txt diff --git a/basis/ui/gadgets/slate/slate.factor b/extra/ui/gadgets/slate/slate.factor similarity index 100% rename from basis/ui/gadgets/slate/slate.factor rename to extra/ui/gadgets/slate/slate.factor diff --git a/basis/ui/gadgets/tabs/authors.txt b/extra/ui/gadgets/tabs/authors.txt similarity index 100% rename from basis/ui/gadgets/tabs/authors.txt rename to extra/ui/gadgets/tabs/authors.txt diff --git a/basis/ui/gadgets/tabs/summary.txt b/extra/ui/gadgets/tabs/summary.txt similarity index 100% rename from basis/ui/gadgets/tabs/summary.txt rename to extra/ui/gadgets/tabs/summary.txt diff --git a/basis/ui/gadgets/tabs/tabs.factor b/extra/ui/gadgets/tabs/tabs.factor similarity index 100% rename from basis/ui/gadgets/tabs/tabs.factor rename to extra/ui/gadgets/tabs/tabs.factor diff --git a/basis/ui/gadgets/tiling/tiling.factor b/extra/ui/gadgets/tiling/tiling.factor similarity index 100% rename from basis/ui/gadgets/tiling/tiling.factor rename to extra/ui/gadgets/tiling/tiling.factor diff --git a/basis/units/constants/authors.txt b/extra/units/authors.txt similarity index 100% rename from basis/units/constants/authors.txt rename to extra/units/authors.txt diff --git a/basis/units/imperial/authors.txt b/extra/units/constants/authors.txt similarity index 100% rename from basis/units/imperial/authors.txt rename to extra/units/constants/authors.txt diff --git a/basis/units/constants/constants.factor b/extra/units/constants/constants.factor similarity index 100% rename from basis/units/constants/constants.factor rename to extra/units/constants/constants.factor diff --git a/basis/units/constants/constants.txt b/extra/units/constants/constants.txt similarity index 100% rename from basis/units/constants/constants.txt rename to extra/units/constants/constants.txt diff --git a/basis/units/si/authors.txt b/extra/units/imperial/authors.txt similarity index 100% rename from basis/units/si/authors.txt rename to extra/units/imperial/authors.txt diff --git a/basis/units/imperial/imperial-tests.factor b/extra/units/imperial/imperial-tests.factor similarity index 100% rename from basis/units/imperial/imperial-tests.factor rename to extra/units/imperial/imperial-tests.factor diff --git a/basis/units/imperial/imperial.factor b/extra/units/imperial/imperial.factor similarity index 100% rename from basis/units/imperial/imperial.factor rename to extra/units/imperial/imperial.factor diff --git a/extra/units/si/authors.txt b/extra/units/si/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/units/si/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/basis/units/si/si-tests.factor b/extra/units/si/si-tests.factor similarity index 100% rename from basis/units/si/si-tests.factor rename to extra/units/si/si-tests.factor diff --git a/basis/units/si/si.factor b/extra/units/si/si.factor similarity index 100% rename from basis/units/si/si.factor rename to extra/units/si/si.factor diff --git a/basis/units/units-tests.factor b/extra/units/units-tests.factor similarity index 100% rename from basis/units/units-tests.factor rename to extra/units/units-tests.factor diff --git a/basis/units/units.factor b/extra/units/units.factor similarity index 100% rename from basis/units/units.factor rename to extra/units/units.factor diff --git a/extra/websites/concatenative/page.xml b/extra/websites/concatenative/page.xml index 464a3d9c5d..129dcb1546 100644 --- a/extra/websites/concatenative/page.xml +++ b/extra/websites/concatenative/page.xml @@ -10,7 +10,7 @@ - + diff --git a/extra/x/widgets/wm/frame/frame.factor b/extra/x/widgets/wm/frame/frame.factor index b75671fa3c..d20c5bf672 100755 --- a/extra/x/widgets/wm/frame/frame.factor +++ b/extra/x/widgets/wm/frame/frame.factor @@ -4,7 +4,7 @@ USING: kernel io combinators namespaces quotations arrays sequences x11.xlib x11.constants mortar mortar.sugar slot-accessors geom.rect - math.bitfields + math.bitwise x x.gc x.widgets x.widgets.button x.widgets.wm.child diff --git a/extra/xml/syntax/syntax.factor b/extra/xml/syntax/syntax.factor new file mode 100644 index 0000000000..283efa8412 --- /dev/null +++ b/extra/xml/syntax/syntax.factor @@ -0,0 +1,58 @@ +! Copyright (C) 2008 Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. +USING: lexer parser splitting kernel quotations namespaces +sequences assocs sequences.lib xml.generator xml.utilities +xml.data ; +IN: xml.syntax + +: parsed-name ( accum -- accum ) + scan ":" split1 [ f ] [ ] if* parsed ; + +: run-combinator ( accum quot1 quot2 -- accum ) + >r [ ] like parsed r> [ parsed ] each ; + +: parse-tag-contents ( accum contained? -- accum ) + [ \ contained*, parsed ] [ + scan-word \ [ = + [ POSTPONE: [ \ tag*, parsed ] + [ "Expected [ missing" throw ] if + ] if ; + +DEFER: >> + +: attributes-parsed ( accum quot -- accum ) + dup empty? [ drop f parsed ] [ + >r \ >r parsed r> parsed + [ H{ } make-assoc r> swap ] [ parsed ] each + ] if ; + +: << + parsed-name [ + \ >> parse-until >quotation + attributes-parsed \ contained? get + ] with-scope parse-tag-contents ; parsing + +: == + \ call parsed parsed-name \ set parsed ; parsing + +: // + \ contained? on ; parsing + +: parse-special ( accum end-token word -- accum ) + >r parse-tokens " " join parsed r> parsed ; + +: " \ comment, parse-special ; parsing + +: " \ directive, parse-special ; parsing + +: " \ instruction, parse-special ; parsing + +: >xml-document ( seq -- xml ) + dup first prolog? [ unclip-slice ] [ standard-prolog ] if swap + [ tag? ] split-around ; + +DEFER: XML> + +: [ >quotation ] parse-literal + { } parsed \ make parsed \ >xml-document parsed ; parsing diff --git a/unmaintained/random-tester/random-tester.factor b/unmaintained/random-tester/random-tester.factor index 2b2559e02a..cbf9f52fa6 100755 --- a/unmaintained/random-tester/random-tester.factor +++ b/unmaintained/random-tester/random-tester.factor @@ -1,7 +1,8 @@ USING: compiler continuations io kernel math namespaces prettyprint quotations random sequences vectors compiler.units ; -USING: random-tester.databank random-tester.safe-words ; +USING: random-tester.databank random-tester.safe-words +random-tester.random ; IN: random-tester SYMBOL: errored @@ -13,6 +14,8 @@ ERROR: random-tester-error ; : setup-test ( #data #code -- data... quot ) #! Variable stack effect >r [ databank random ] times r> + ! 200 300 random-cond ; + ! random-if ; [ drop \ safe-words get random ] map >quotation ; : test-compiler ! ( data... quot -- ... ) diff --git a/unmaintained/random-tester/random/random.factor b/unmaintained/random-tester/random/random.factor index 11f2e60d1a..7bedcb8cec 100755 --- a/unmaintained/random-tester/random/random.factor +++ b/unmaintained/random-tester/random/random.factor @@ -1,6 +1,7 @@ USING: kernel math sequences namespaces hashtables words -arrays parser compiler syntax io prettyprint optimizer -random math.constants math.functions layouts random-tester.utils ; +arrays parser compiler syntax io prettyprint random +math.constants math.functions layouts random-tester.utils +random-tester.safe-words quotations fry combinators ; IN: random-tester ! Tweak me @@ -72,3 +73,14 @@ IN: random-tester : random-complex ( -- C ) random-number random-number rect> ; +: random-quot ( n -- quot ) + [ \ safe-words get random ] replicate >quotation ; + +: random-if ( n -- quot ) + [ random-quot ] [ random-quot ] bi + '[ , , if ] ; + +: random-cond ( m n -- quot ) + [ '[ , [ random-quot ] [ random-quot ] bi 2array ] replicate ] + [ random-quot ] bi suffix + '[ , cond ] ; diff --git a/unmaintained/random-tester/safe-words/safe-words.factor b/unmaintained/random-tester/safe-words/safe-words.factor index 7d8adcbc2a..77e5562f4d 100755 --- a/unmaintained/random-tester/safe-words/safe-words.factor +++ b/unmaintained/random-tester/safe-words/safe-words.factor @@ -6,8 +6,6 @@ IN: random-tester.safe-words : ?-words { - delegate - /f bits>float bits>double