diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 0b686e3c7f..e407bfd143 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -30,6 +30,7 @@ crossref off "syntax" vocab vocab-words bootstrap-syntax set H{ } clone dictionary set H{ } clone changed-words set +H{ } clone root-cache set ! Trivial recompile hook. We don't want to touch the code heap ! during stage1 bootstrap, it would just waste time. diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index 63b5726ad7..2aeb3099ac 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -25,7 +25,7 @@ SYMBOL: bootstrap-time "exclude" "include" [ get-global " " split [ empty? not ] subset ] 2apply seq-diff - [ "bootstrap." swap append require ] each ; + [ "bootstrap." prepend require ] each ; : compile-remaining ( -- ) "Compiling remaining words..." print flush diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor index a4e87f28d8..e7e90d8dd0 100755 --- a/core/bootstrap/syntax.factor +++ b/core/bootstrap/syntax.factor @@ -21,6 +21,7 @@ IN: bootstrap.syntax "C:" "CHAR:" "DEFER:" + "ERROR:" "F{" "FV{" "FORGET:" diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index 7d43ee905a..f97f088845 100755 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -1,6 +1,6 @@ USING: alien arrays definitions generic assocs hashtables io kernel math namespaces parser prettyprint sequences strings -tools.test vectors words quotations classes io.streams.string +tools.test vectors words quotations classes classes.private classes.union classes.mixin classes.predicate vectors definitions source-files compiler.units ; IN: classes.tests @@ -63,10 +63,6 @@ UNION: c a b ; UNION: bah fixnum alien ; [ bah ] [ \ bah? "predicating" word-prop ] unit-test -! Test generic see and parsing -[ "USING: alien math ;\nIN: classes.tests\nUNION: bah fixnum alien ;\n" ] -[ [ \ bah see ] with-string-writer ] unit-test - ! Test redefinition of classes UNION: union-1 fixnum float ; @@ -180,6 +176,8 @@ UNION: forget-class-bug-2 forget-class-bug-1 dll ; [ f ] [ forget-class-bug-2 typemap get values [ memq? ] with contains? ] unit-test +USE: io.streams.string + 2 [ [ "mixin-forget-test" forget-source ] with-compilation-unit @@ -224,3 +222,7 @@ MIXIN: flat-mx-2 INSTANCE: flat-mx-2 flat-mx-1 TUPLE: flat-mx-2-1 ; INSTANCE: flat-mx-2-1 flat-mx-2 [ t ] [ T{ flat-mx-2-1 } flat-mx-1? ] unit-test + +! Test generic see and parsing +[ "USING: alien math ;\nIN: classes.tests\nUNION: bah fixnum alien ;\n" ] +[ [ \ bah see ] with-string-writer ] unit-test diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor index dcc05e8160..c1c82d158b 100755 --- a/core/classes/union/union.factor +++ b/core/classes/union/union.factor @@ -13,7 +13,7 @@ PREDICATE: class union-class drop [ drop f ] ] [ unclip first "predicate" word-prop swap - [ >r "predicate" word-prop [ dup ] swap append r> ] + [ >r "predicate" word-prop [ dup ] prepend r> ] assoc-map alist>quot ] if ; diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index ffd1576e6e..53d18b53ca 100755 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -80,7 +80,7 @@ M: hashtable hashcode* : hash-case-quot ( default assoc -- quot ) hash-case-table hash-dispatch-quot - [ dup hashcode >fixnum ] swap append ; + [ dup hashcode >fixnum ] prepend ; : contiguous-range? ( keys -- from to ? ) dup [ fixnum? ] all? [ diff --git a/core/command-line/command-line.factor b/core/command-line/command-line.factor index ed4fb9f606..72c1e063e0 100644 --- a/core/command-line/command-line.factor +++ b/core/command-line/command-line.factor @@ -7,12 +7,12 @@ splitting io.files ; : run-bootstrap-init ( -- ) "user-init" get [ - home ".factor-boot-rc" path+ ?run-file + home ".factor-boot-rc" append-path ?run-file ] when ; : run-user-init ( -- ) "user-init" get [ - home ".factor-rc" path+ ?run-file + home ".factor-rc" append-path ?run-file ] when ; : cli-var-param ( name value -- ) swap set-global ; diff --git a/core/compiler/tests/intrinsics.factor b/core/compiler/tests/intrinsics.factor index dd9a453cfc..b854b4ef0d 100755 --- a/core/compiler/tests/intrinsics.factor +++ b/core/compiler/tests/intrinsics.factor @@ -385,7 +385,7 @@ cell 8 = [ [ 252 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-unsigned-1 ] compile-call ] unit-test [ -4 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-signed-1 ] compile-call ] unit-test -: xword-def word-def [ { fixnum } declare ] swap append ; +: xword-def word-def [ { fixnum } declare ] prepend ; [ -100 ] [ -100 [ { byte-array } declare *char ] compile-call ] unit-test [ 156 ] [ -100 [ { byte-array } declare *uchar ] compile-call ] unit-test diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index 9fd5481a39..b01fb87f72 100755 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -53,7 +53,7 @@ TUPLE: no-math-method left right generic ; 2dup and [ 2dup math-upgrade >r math-class-max over order min-class applicable-method - r> swap append + r> prepend ] [ 2drop object-method ] if ; diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index c634e02e75..35161319ef 100755 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -161,7 +161,7 @@ C: hook-combination 0 (dispatch#) [ swap slip hook-combination-var [ get ] curry - swap append + prepend ] with-variable ; inline M: hook-combination make-default-method @@ -170,7 +170,7 @@ M: hook-combination make-default-method M: hook-combination perform-combination [ standard-methods - [ [ drop ] swap append ] assoc-map + [ [ drop ] prepend ] assoc-map single-combination ] with-hook ; diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor index 4cd43ef455..03ea2262a8 100755 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -14,19 +14,26 @@ GENERIC: encode-char ( char stream encoding -- ) GENERIC: ( stream decoding -- newstream ) -GENERIC: ( stream encoding -- newstream ) - : replacement-char HEX: fffd ; -! Decoding - - ( stream encoding -- newstream ) + +TUPLE: encoder stream code ; + +TUPLE: encode-error ; + +: encode-error ( -- * ) \ encode-error construct-empty throw ; + +! Decoding + + construct-empty ; M: tuple f decoder construct-boa ; @@ -101,12 +108,6 @@ M: decoder stream-readln ( stream -- str ) M: decoder dispose decoder-stream dispose ; ! Encoding - -TUPLE: encode-error ; - -: encode-error ( -- * ) \ encode-error construct-empty throw ; - -TUPLE: encoder stream code ; M: tuple-class construct-empty ; M: tuple encoder construct-boa ; @@ -132,6 +133,7 @@ INSTANCE: encoder plain-writer : redecode ( stream encoding -- newstream ) over decoder? [ >r decoder-stream r> ] when ; + PRIVATE> : ( stream-in stream-out encoding -- duplex ) diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index df9c78fe47..1ee9d19e4a 100755 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -19,7 +19,7 @@ ARTICLE: "pathnames" "Pathname manipulation" { $subsection parent-directory } { $subsection file-name } { $subsection last-path-separator } -{ $subsection path+ } +{ $subsection append-path } "Pathnames relative to Factor's install directory:" { $subsection resource-path } { $subsection ?resource-path } @@ -224,7 +224,7 @@ HELP: stat ( path -- directory? permissions length modified ) { stat exists? directory? } related-words -HELP: path+ +HELP: append-path { $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } } { $description "Concatenates two pathnames." } ; diff --git a/core/io/files/files.factor b/core/io/files/files.factor index a6320a7507..0d00197415 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -32,10 +32,13 @@ HOOK: rename-file io-backend ( from to -- ) : left-trim-separators ( str -- newstr ) [ path-separator? ] left-trim ; -: path+ ( str1 str2 -- str ) +: append-path ( str1 str2 -- str ) >r right-trim-separators "/" r> left-trim-separators 3append ; +: prepend-path ( str1 str2 -- str ) + swap append-path ; inline + : last-path-separator ( path -- n ? ) [ length 1- ] keep [ path-separator? ] find-last* ; @@ -119,7 +122,7 @@ HOOK: make-directory io-backend ( path -- ) : fixup-directory ( path seq -- newseq ) [ dup string? - [ tuck path+ directory? 2array ] [ nip ] if + [ tuck append-path directory? 2array ] [ nip ] if ] with map [ first special-directory? not ] subset ; @@ -127,7 +130,7 @@ HOOK: make-directory io-backend ( path -- ) normalize-directory dup (directory) fixup-directory ; : directory* ( path -- seq ) - dup directory [ first2 >r path+ r> 2array ] with map ; + dup directory [ first2 >r append-path r> 2array ] with map ; ! Touching files HOOK: touch-file io-backend ( path -- ) @@ -146,7 +149,7 @@ HOOK: delete-directory io-backend ( path -- ) : delete-tree ( path -- ) dup directory? (delete-tree) ; -: to-directory over file-name path+ ; +: to-directory over file-name append-path ; ! Moving and renaming files HOOK: move-file io-backend ( from to -- ) @@ -179,7 +182,7 @@ DEFER: copy-tree-into : copy-tree ( from to -- ) over directory? [ >r dup directory swap r> [ - >r swap first path+ r> copy-tree-into + >r swap first append-path r> copy-tree-into ] 2curry each ] [ copy-file @@ -194,7 +197,7 @@ DEFER: copy-tree-into ! Special paths : resource-path ( path -- newpath ) \ resource-path get [ image parent-directory ] unless* - swap path+ ; + prepend-path ; : ?resource-path ( path -- newpath ) "resource:" ?head [ resource-path ] when ; @@ -236,7 +239,7 @@ M: pathname <=> [ pathname-string ] compare ; [ dup make-directory ] when ; -: temp-file ( name -- path ) temp-directory swap path+ ; +: temp-file ( name -- path ) temp-directory prepend-path ; ! Home directory : home ( -- dir ) diff --git a/core/optimizer/specializers/specializers.factor b/core/optimizer/specializers/specializers.factor index 5153d84c7f..560a174289 100755 --- a/core/optimizer/specializers/specializers.factor +++ b/core/optimizer/specializers/specializers.factor @@ -35,7 +35,7 @@ IN: optimizer.specializers swap "method-class" word-prop add* ; : specialize-method ( quot method -- quot' ) - method-declaration [ declare ] curry swap append ; + method-declaration [ declare ] curry prepend ; : specialize-quot ( quot specializer -- quot' ) dup { number } = [ diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 9fc5264440..3c69bfa41c 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -299,6 +299,8 @@ M: immutable-sequence clone-like like ; : append ( seq1 seq2 -- newseq ) over (append) ; +: prepend ( seq1 seq2 -- newseq ) swap append ; inline + : 3append ( seq1 seq2 seq3 -- newseq ) pick (3append) ; : change-nth ( i seq quot -- ) diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index d9870b08da..8cc9211599 100755 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -163,6 +163,11 @@ IN: bootstrap.syntax [ construct-boa ] curry define-inline ] define-syntax + "ERROR:" [ + CREATE-CLASS dup ";" parse-tokens define-tuple-class + dup [ construct-boa throw ] curry define + ] define-syntax + "FORGET:" [ scan-word dup parsing? [ V{ } clone swap execute first ] when diff --git a/core/vocabs/loader/loader-docs.factor b/core/vocabs/loader/loader-docs.factor index c7652c34c7..c0542f7b96 100755 --- a/core/vocabs/loader/loader-docs.factor +++ b/core/vocabs/loader/loader-docs.factor @@ -43,8 +43,6 @@ HELP: find-vocab-root { $values { "vocab" "a vocabulary specifier" } { "path/f" "a pathname string" } } { $description "Searches for a vocabulary in the vocabulary roots." } ; -{ vocab-root find-vocab-root } related-words - HELP: no-vocab { $values { "name" "a vocabulary name" } } { $description "Throws a " { $link no-vocab } "." } diff --git a/core/vocabs/loader/loader-tests.factor b/core/vocabs/loader/loader-tests.factor index 015f54540d..85399ca9e7 100755 --- a/core/vocabs/loader/loader-tests.factor +++ b/core/vocabs/loader/loader-tests.factor @@ -13,15 +13,15 @@ debugger compiler.units tools.vocabs ; ] unit-test [ T{ vocab-link f "vocabs.loader.test" } ] -[ "vocabs.loader.test" f >vocab-link ] unit-test +[ "vocabs.loader.test" >vocab-link ] unit-test [ t ] -[ "kernel" f >vocab-link "kernel" vocab = ] unit-test +[ "kernel" >vocab-link "kernel" vocab = ] unit-test [ t ] [ "kernel" vocab-files "kernel" vocab vocab-files - "kernel" f vocab-files + "kernel" vocab-files 3array all-equal? ] unit-test @@ -36,7 +36,7 @@ IN: vocabs.loader.tests [ { 3 3 3 } ] [ "vocabs.loader.test.2" run "vocabs.loader.test.2" vocab run - "vocabs.loader.test.2" f run + "vocabs.loader.test.2" run 3array ] unit-test @@ -115,7 +115,7 @@ IN: vocabs.loader.tests [ 3 ] [ "count-me" get-global ] unit-test [ { "resource:core/kernel/kernel.factor" 1 } ] -[ "kernel" f where ] unit-test +[ "kernel" where ] unit-test [ { "resource:core/kernel/kernel.factor" 1 } ] [ "kernel" vocab where ] unit-test @@ -136,7 +136,7 @@ IN: vocabs.loader.tests [ { "2" "a" "b" "d" "e" "f" } [ - "vocabs.loader.test." swap append forget-vocab + "vocabs.loader.test." prepend forget-vocab ] each ] with-compilation-unit ; diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index 96193ef664..103b5290a4 100755 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -23,30 +23,30 @@ V{ [ >r dup peek r> append add ] when* "/" join ; -: vocab-path+ ( vocab path -- newpath ) - swap vocab-root dup [ swap path+ ] [ 2drop f ] if ; - -: vocab-source-path ( vocab -- path/f ) - dup ".factor" vocab-dir+ vocab-path+ ; - -: vocab-docs-path ( vocab -- path/f ) - dup "-docs.factor" vocab-dir+ vocab-path+ ; - : vocab-dir? ( root name -- ? ) over [ - ".factor" vocab-dir+ path+ resource-exists? + ".factor" vocab-dir+ append-path resource-exists? ] [ 2drop f ] if ; +SYMBOL: root-cache + +H{ } clone root-cache set-global + : find-vocab-root ( vocab -- path/f ) - vocab-roots get swap [ vocab-dir? ] curry find nip ; + vocab-name root-cache get [ + vocab-roots get swap [ vocab-dir? ] curry find nip + ] cache ; -M: string vocab-root - vocab dup [ vocab-root ] when ; +: vocab-append-path ( vocab path -- newpath ) + swap find-vocab-root dup [ prepend-path ] [ 2drop f ] if ; -M: vocab-link vocab-root - vocab-link-root ; +: vocab-source-path ( vocab -- path/f ) + dup ".factor" vocab-dir+ vocab-append-path ; + +: vocab-docs-path ( vocab -- path/f ) + dup "-docs.factor" vocab-dir+ vocab-append-path ; SYMBOL: load-help? @@ -56,7 +56,7 @@ SYMBOL: load-help? : load-source ( vocab -- ) [ source-wasn't-loaded ] keep - [ vocab-source-path bootstrap-file ] keep + [ vocab-source-path [ bootstrap-file ] when* ] keep source-was-loaded ; : docs-were-loaded t swap set-vocab-docs-loaded? ; @@ -70,18 +70,9 @@ SYMBOL: load-help? docs-were-loaded ] [ drop ] if ; -: create-vocab-with-root ( name root -- vocab ) - swap create-vocab [ set-vocab-root ] keep ; - -: update-root ( vocab -- ) - dup vocab-root - [ drop ] [ dup find-vocab-root swap set-vocab-root ] if ; - : reload ( name -- ) [ - dup vocab [ - dup update-root dup load-source load-docs - ] [ no-vocab ] ?if + dup vocab [ dup load-source load-docs ] [ no-vocab ] ?if ] with-compiler-errors ; : require ( vocab -- ) @@ -104,22 +95,17 @@ SYMBOL: blacklist GENERIC: (load-vocab) ( name -- ) M: vocab (load-vocab) - dup update-root - - dup vocab-root [ - [ - dup vocab-source-loaded? [ dup load-source ] unless - dup vocab-docs-loaded? [ dup load-docs ] unless - ] [ [ swap add-to-blacklist ] keep rethrow ] recover - ] when drop ; - -M: string (load-vocab) - ! ".private" ?tail drop - dup find-vocab-root >vocab-link (load-vocab) ; + [ + dup vocab-source-loaded? [ dup load-source ] unless + dup vocab-docs-loaded? [ dup load-docs ] unless + drop + ] [ [ swap add-to-blacklist ] keep rethrow ] recover ; M: vocab-link (load-vocab) - dup vocab-name swap vocab-root dup - [ create-vocab-with-root (load-vocab) ] [ 2drop ] if ; + vocab-name create-vocab (load-vocab) ; + +M: string (load-vocab) + create-vocab (load-vocab) ; [ [ diff --git a/core/vocabs/vocabs-docs.factor b/core/vocabs/vocabs-docs.factor index f16a33f0d5..0d55499620 100755 --- a/core/vocabs/vocabs-docs.factor +++ b/core/vocabs/vocabs-docs.factor @@ -16,7 +16,6 @@ $nl { $subsection vocab } "Accessors for various vocabulary attributes:" { $subsection vocab-name } -{ $subsection vocab-root } { $subsection vocab-main } { $subsection vocab-help } "Looking up existing vocabularies and creating new vocabularies:" @@ -50,10 +49,6 @@ HELP: vocab-name { $values { "vocab" "a vocabulary specifier" } { "name" string } } { $description "Outputs the name of a vocabulary." } ; -HELP: vocab-root -{ $values { "vocab" "a vocabulary specifier" } { "root" "a pathname string or " { $link f } } } -{ $description "Outputs the vocabulary root where the source code for a vocabulary is located, or " { $link f } " if the vocabulary is not defined in source files." } ; - HELP: vocab-words { $values { "vocab" "a vocabulary specifier" } { "words" "an assoc mapping strings to words" } } { $description "Outputs the words defined in a vocabulary." } ; @@ -101,11 +96,11 @@ HELP: child-vocabs } ; HELP: vocab-link -{ $class-description "Instances of this class identify vocabularies which are potentially not loaded. The " { $link vocab-name } " slot is the vocabulary name, and " { $link vocab-root } " is a pathname string identifying the vocabulary root where the sources to this vocabulary are located, or " { $link f } " if the root is not known." +{ $class-description "Instances of this class identify vocabularies which are potentially not loaded. The " { $link vocab-name } " slot is the vocabulary name." $nl "Vocabulary links are created by calling " { $link >vocab-link } "." } ; HELP: >vocab-link -{ $values { "name" string } { "root" "a pathname string or " { $link f } } { "vocab" "a vocabulary specifier" } } +{ $values { "name" string } { "vocab" "a vocabulary specifier" } } { $description "If the vocabulary is loaded, outputs the corresponding " { $link vocab } " instance, otherwise creates a new " { $link vocab-link } "." } ; diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor index 9d281c864b..807e08f73b 100755 --- a/core/vocabs/vocabs.factor +++ b/core/vocabs/vocabs.factor @@ -92,10 +92,10 @@ SYMBOL: load-vocab-hook ! ( name -- ) : child-vocabs ( vocab -- seq ) vocab-name vocabs [ child-vocab? ] with subset ; -TUPLE: vocab-link name root ; +TUPLE: vocab-link name ; -: ( name root -- vocab-link ) - [ dup vocab-root ] unless* vocab-link construct-boa ; +: ( name -- vocab-link ) + vocab-link construct-boa ; M: vocab-link equal? over vocab-link? @@ -106,17 +106,14 @@ M: vocab-link hashcode* M: vocab-link vocab-name vocab-link-name ; -GENERIC# >vocab-link 1 ( name root -- vocab ) - -M: vocab >vocab-link drop ; - -M: vocab-link >vocab-link drop ; - -M: string >vocab-link - over vocab dup [ 2nip ] [ drop ] if ; - UNION: vocab-spec vocab vocab-link ; +GENERIC: >vocab-link ( name -- vocab ) + +M: vocab-spec >vocab-link ; + +M: string >vocab-link dup vocab [ ] [ ] ?if ; + : forget-vocab ( vocab -- ) dup words forget-all vocab-name dictionary get delete-at ; diff --git a/extra/asn1/asn1.factor b/extra/asn1/asn1.factor index 99d1e0a19d..8954ffd8cc 100644 --- a/extra/asn1/asn1.factor +++ b/extra/asn1/asn1.factor @@ -135,18 +135,18 @@ SYMBOL: end GENERIC: >ber ( obj -- byte-array ) M: fixnum >ber ( n -- byte-array ) >128-ber dup length 2 swap 2array - "cc" pack-native swap append ; + "cc" pack-native prepend ; : >ber-enumerated ( n -- byte-array ) >128-ber >byte-array dup length 10 swap 2array - "CC" pack-native swap append ; + "CC" pack-native prepend ; : >ber-length-encoding ( n -- byte-array ) dup 127 <= [ 1array "C" pack-be ] [ 1array "I" pack-be 0 swap remove dup length - HEX: 80 + 1array "C" pack-be swap append + HEX: 80 + 1array "C" pack-be prepend ] if ; ! ========================================================= @@ -158,7 +158,7 @@ M: bignum >ber ( n -- byte-array ) dup 126 > [ "range error in bignum" throw ] [ - 2 swap 2array "CC" pack-native swap append + 2 swap 2array "CC" pack-native prepend ] if ; ! ========================================================= diff --git a/extra/assocs/lib/lib.factor b/extra/assocs/lib/lib.factor index 2500940373..b23ee1f830 100755 --- a/extra/assocs/lib/lib.factor +++ b/extra/assocs/lib/lib.factor @@ -41,7 +41,7 @@ IN: assocs.lib >r 2array flip r> assoc-like ; : generate-key ( assoc -- str ) - >r random-256 >hex r> + >r 256 random-bits >hex r> 2dup key? [ nip generate-key ] [ drop ] if ; : set-at-unique ( value assoc -- key ) diff --git a/extra/automata/automata.factor b/extra/automata/automata.factor index cd799d477e..b6d4152d0e 100644 --- a/extra/automata/automata.factor +++ b/extra/automata/automata.factor @@ -46,7 +46,7 @@ dup >rule-number rule-values rule-keys [ rule> set-at ] 2each ; : pattern>state ( {_a_b_c_} -- state ) rule> at ; -: cap-line ( line -- 0-line-0 ) { 0 } swap append { 0 } append ; +: cap-line ( line -- 0-line-0 ) { 0 } prepend { 0 } append ; : wrap-line ( a-line-z -- za-line-za ) dup peek 1array swap dup first 1array append append ; diff --git a/extra/bitfields/bitfields.factor b/extra/bitfields/bitfields.factor index 211ab28c92..175f66f4a6 100644 --- a/extra/bitfields/bitfields.factor +++ b/extra/bitfields/bitfields.factor @@ -88,7 +88,7 @@ M: check< summary drop "Number exceeds upper bound" ; >r keys r> define-slots ; : define-setters ( classname slots -- ) - >r "with-" swap append r> + >r "with-" prepend r> dup values [setters] >r keys r> define-slots ; diff --git a/extra/bootstrap/image/download/download.factor b/extra/bootstrap/image/download/download.factor index df559f49da..a186954ef0 100644 --- a/extra/bootstrap/image/download/download.factor +++ b/extra/bootstrap/image/download/download.factor @@ -18,7 +18,7 @@ bootstrap.image sequences io ; : download-image ( arch -- ) boot-image-name dup need-new-image? [ "Downloading " write dup write "..." print - url swap append download + url prepend download ] [ "Boot image up to date" print drop diff --git a/extra/bootstrap/random/random.factor b/extra/bootstrap/random/random.factor new file mode 100644 index 0000000000..7132860e1c --- /dev/null +++ b/extra/bootstrap/random/random.factor @@ -0,0 +1,8 @@ +USING: vocabs.loader sequences system ; + +"random.mersenne-twister" require + +{ + { [ windows? ] [ "random.windows" require ] } + { [ unix? ] [ "random.unix" require ] } +} cond diff --git a/extra/bootstrap/ui/tools/tools.factor b/extra/bootstrap/ui/tools/tools.factor index c4a555b3e2..a3d02a0016 100755 --- a/extra/bootstrap/ui/tools/tools.factor +++ b/extra/bootstrap/ui/tools/tools.factor @@ -1,7 +1,7 @@ USING: kernel vocabs vocabs.loader sequences system ; { "ui" "help" "tools" } -[ "bootstrap." swap append vocab ] all? [ +[ "bootstrap." prepend vocab ] all? [ "ui.tools" require "ui.cocoa" vocab [ diff --git a/extra/bootstrap/ui/ui.factor b/extra/bootstrap/ui/ui.factor index 86538e0000..f8db831dbc 100644 --- a/extra/bootstrap/ui/ui.factor +++ b/extra/bootstrap/ui/ui.factor @@ -8,7 +8,7 @@ vocabs vocabs.loader ; { [ windows? ] [ "windows" ] } { [ unix? ] [ "x11" ] } } cond - ] unless* "ui." swap append require + ] unless* "ui." prepend require "ui.freetype" require ] when diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index 7d95ce2409..ea404d6efa 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -58,8 +58,8 @@ IN: builder ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : copy-image ( -- ) - builds "factor" path+ my-boot-image-name path+ ".." copy-file-into - builds "factor" path+ my-boot-image-name path+ "." copy-file-into ; + builds "factor" append-path my-boot-image-name append-path ".." copy-file-into + builds "factor" append-path my-boot-image-name append-path "." copy-file-into ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/builder/release/release.factor b/extra/builder/release/release.factor index f0cf0ee113..0e26abe02f 100644 --- a/extra/builder/release/release.factor +++ b/extra/builder/release/release.factor @@ -8,7 +8,7 @@ IN: builder.release ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : releases ( -- path ) - builds "releases" path+ + builds "releases" append-path dup exists? not [ dup make-directory ] when ; diff --git a/extra/calendar/backend/backend.factor b/extra/calendar/backend/backend.factor index 15b5e7cb8d..01c36c65ae 100644 --- a/extra/calendar/backend/backend.factor +++ b/extra/calendar/backend/backend.factor @@ -2,4 +2,4 @@ USING: kernel ; IN: calendar.backend SYMBOL: calendar-backend -HOOK: gmt-offset calendar-backend +HOOK: gmt-offset calendar-backend ( -- hours minutes seconds ) diff --git a/extra/calendar/calendar-tests.factor b/extra/calendar/calendar-tests.factor index 1041c79691..e49d3ad894 100755 --- a/extra/calendar/calendar-tests.factor +++ b/extra/calendar/calendar-tests.factor @@ -2,14 +2,14 @@ USING: arrays calendar kernel math sequences tools.test continuations system ; IN: calendar.tests -[ f ] [ 2004 12 32 0 0 0 0 valid-timestamp? ] unit-test -[ f ] [ 2004 2 30 0 0 0 0 valid-timestamp? ] unit-test -[ f ] [ 2003 2 29 0 0 0 0 valid-timestamp? ] unit-test -[ f ] [ 2004 -2 9 0 0 0 0 valid-timestamp? ] unit-test -[ f ] [ 2004 12 0 0 0 0 0 valid-timestamp? ] unit-test -[ f ] [ 2004 12 1 24 0 0 0 valid-timestamp? ] unit-test -[ f ] [ 2004 12 1 23 60 0 0 valid-timestamp? ] unit-test -[ f ] [ 2004 12 1 23 59 60 0 valid-timestamp? ] unit-test +[ f ] [ 2004 12 32 0 0 0 instant valid-timestamp? ] unit-test +[ f ] [ 2004 2 30 0 0 0 instant valid-timestamp? ] unit-test +[ f ] [ 2003 2 29 0 0 0 instant valid-timestamp? ] unit-test +[ f ] [ 2004 -2 9 0 0 0 instant valid-timestamp? ] unit-test +[ f ] [ 2004 12 0 0 0 0 instant valid-timestamp? ] unit-test +[ f ] [ 2004 12 1 24 0 0 instant valid-timestamp? ] unit-test +[ f ] [ 2004 12 1 23 60 0 instant valid-timestamp? ] unit-test +[ f ] [ 2004 12 1 23 59 60 instant valid-timestamp? ] unit-test [ t ] [ now valid-timestamp? ] unit-test [ f ] [ 1900 leap-year? ] unit-test @@ -18,126 +18,126 @@ IN: calendar.tests [ f ] [ 2001 leap-year? ] unit-test [ f ] [ 2006 leap-year? ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 1 seconds time+ - 2006 10 10 0 0 1 0 = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 100 seconds time+ - 2006 10 10 0 1 40 0 = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 -100 seconds time+ - 2006 10 9 23 58 20 0 = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 86400 seconds time+ - 2006 10 11 0 0 0 0 = ] unit-test +[ t ] [ 2006 10 10 0 0 0 instant 1 seconds time+ + 2006 10 10 0 0 1 instant = ] unit-test +[ t ] [ 2006 10 10 0 0 0 instant 100 seconds time+ + 2006 10 10 0 1 40 instant = ] unit-test +[ t ] [ 2006 10 10 0 0 0 instant -100 seconds time+ + 2006 10 9 23 58 20 instant = ] unit-test +[ t ] [ 2006 10 10 0 0 0 instant 86400 seconds time+ + 2006 10 11 0 0 0 instant = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 10 minutes time+ - 2006 10 10 0 10 0 0 = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 10.5 minutes time+ - 2006 10 10 0 10 30 0 = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 3/4 minutes time+ - 2006 10 10 0 0 45 0 = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 -3/4 minutes time+ - 2006 10 9 23 59 15 0 = ] unit-test +[ t ] [ 2006 10 10 0 0 0 instant 10 minutes time+ + 2006 10 10 0 10 0 instant = ] unit-test +[ t ] [ 2006 10 10 0 0 0 instant 10.5 minutes time+ + 2006 10 10 0 10 30 instant = ] unit-test +[ t ] [ 2006 10 10 0 0 0 instant 3/4 minutes time+ + 2006 10 10 0 0 45 instant = ] unit-test +[ t ] [ 2006 10 10 0 0 0 instant -3/4 minutes time+ + 2006 10 9 23 59 15 instant = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 7200 minutes time+ - 2006 10 15 0 0 0 0 = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 -10 minutes time+ - 2006 10 9 23 50 0 0 = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 -100 minutes time+ - 2006 10 9 22 20 0 0 = ] unit-test +[ t ] [ 2006 10 10 0 0 0 instant 7200 minutes time+ + 2006 10 15 0 0 0 instant = ] unit-test +[ t ] [ 2006 10 10 0 0 0 instant -10 minutes time+ + 2006 10 9 23 50 0 instant = ] unit-test +[ t ] [ 2006 10 10 0 0 0 instant -100 minutes time+ + 2006 10 9 22 20 0 instant = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 1 hours time+ - 2006 1 1 1 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 24 hours time+ - 2006 1 2 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 -24 hours time+ - 2005 12 31 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 12 hours time+ - 2006 1 1 12 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 72 hours time+ - 2006 1 4 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant 1 hours time+ + 2006 1 1 1 0 0 instant = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant 24 hours time+ + 2006 1 2 0 0 0 instant = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant -24 hours time+ + 2005 12 31 0 0 0 instant = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant 12 hours time+ + 2006 1 1 12 0 0 instant = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant 72 hours time+ + 2006 1 4 0 0 0 instant = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 1 days time+ - 2006 1 2 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 -1 days time+ - 2005 12 31 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 365 days time+ - 2007 1 1 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 -365 days time+ - 2005 1 1 0 0 0 0 = ] unit-test -[ t ] [ 2004 1 1 0 0 0 0 365 days time+ - 2004 12 31 0 0 0 0 = ] unit-test -[ t ] [ 2004 1 1 0 0 0 0 366 days time+ - 2005 1 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant 1 days time+ + 2006 1 2 0 0 0 instant = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant -1 days time+ + 2005 12 31 0 0 0 instant = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant 365 days time+ + 2007 1 1 0 0 0 instant = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant -365 days time+ + 2005 1 1 0 0 0 instant = ] unit-test +[ t ] [ 2004 1 1 0 0 0 instant 365 days time+ + 2004 12 31 0 0 0 instant = ] unit-test +[ t ] [ 2004 1 1 0 0 0 instant 366 days time+ + 2005 1 1 0 0 0 instant = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 11 months time+ - 2006 12 1 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 12 months time+ - 2007 1 1 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 24 months time+ - 2008 1 1 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 13 months time+ - 2007 2 1 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 1 months time+ - 2006 2 1 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 0 months time+ - 2006 1 1 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 -1 months time+ - 2005 12 1 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 -2 months time+ - 2005 11 1 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 -13 months time+ - 2004 12 1 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 -24 months time+ - 2004 1 1 0 0 0 0 = ] unit-test -[ t ] [ 2004 2 29 0 0 0 0 12 months time+ - 2005 3 1 0 0 0 0 = ] unit-test -[ t ] [ 2004 2 29 0 0 0 0 -12 months time+ - 2003 3 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant 11 months time+ + 2006 12 1 0 0 0 instant = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant 12 months time+ + 2007 1 1 0 0 0 instant = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant 24 months time+ + 2008 1 1 0 0 0 instant = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant 13 months time+ + 2007 2 1 0 0 0 instant = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant 1 months time+ + 2006 2 1 0 0 0 instant = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant 0 months time+ + 2006 1 1 0 0 0 instant = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant -1 months time+ + 2005 12 1 0 0 0 instant = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant -2 months time+ + 2005 11 1 0 0 0 instant = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant -13 months time+ + 2004 12 1 0 0 0 instant = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant -24 months time+ + 2004 1 1 0 0 0 instant = ] unit-test +[ t ] [ 2004 2 29 0 0 0 instant 12 months time+ + 2005 3 1 0 0 0 instant = ] unit-test +[ t ] [ 2004 2 29 0 0 0 instant -12 months time+ + 2003 3 1 0 0 0 instant = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 0 years time+ - 2006 1 1 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 1 years time+ - 2007 1 1 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 -1 years time+ - 2005 1 1 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 -100 years time+ - 1906 1 1 0 0 0 0 = ] unit-test -! [ t ] [ 2004 2 29 0 0 0 0 -1 years time+ -! 2003 2 28 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant 0 years time+ + 2006 1 1 0 0 0 instant = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant 1 years time+ + 2007 1 1 0 0 0 instant = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant -1 years time+ + 2005 1 1 0 0 0 instant = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant -100 years time+ + 1906 1 1 0 0 0 instant = ] unit-test +! [ t ] [ 2004 2 29 0 0 0 instant -1 years time+ +! 2003 2 28 0 0 0 instant = ] unit-test -[ 5 ] [ 2006 7 14 0 0 0 0 day-of-week ] unit-test +[ 5 ] [ 2006 7 14 0 0 0 instant day-of-week ] unit-test -[ t ] [ 2006 7 14 [ julian-day-number julian-day-number>date 0 0 0 0 ] 3keep 0 0 0 0 = ] unit-test +[ t ] [ 2006 7 14 [ julian-day-number julian-day-number>date 0 0 0 instant ] 3keep 0 0 0 instant = ] unit-test -[ 1 ] [ 2006 1 1 0 0 0 0 day-of-year ] unit-test -[ 60 ] [ 2004 2 29 0 0 0 0 day-of-year ] unit-test -[ 61 ] [ 2004 3 1 0 0 0 0 day-of-year ] unit-test -[ 366 ] [ 2004 12 31 0 0 0 0 day-of-year ] unit-test -[ 365 ] [ 2003 12 31 0 0 0 0 day-of-year ] unit-test -[ 60 ] [ 2003 3 1 0 0 0 0 day-of-year ] unit-test +[ 1 ] [ 2006 1 1 0 0 0 instant day-of-year ] unit-test +[ 60 ] [ 2004 2 29 0 0 0 instant day-of-year ] unit-test +[ 61 ] [ 2004 3 1 0 0 0 instant day-of-year ] unit-test +[ 366 ] [ 2004 12 31 0 0 0 instant day-of-year ] unit-test +[ 365 ] [ 2003 12 31 0 0 0 instant day-of-year ] unit-test +[ 60 ] [ 2003 3 1 0 0 0 instant day-of-year ] unit-test -[ t ] [ 2004 12 31 0 0 0 0 dup = ] unit-test -[ t ] [ 2004 1 1 0 0 0 0 10 seconds 5 years time+ time+ - 2009 1 1 0 0 10 0 = ] unit-test -[ t ] [ 2004 1 1 0 0 0 0 -10 seconds -5 years time+ time+ - 1998 12 31 23 59 50 0 = ] unit-test +[ t ] [ 2004 12 31 0 0 0 instant dup = ] unit-test +[ t ] [ 2004 1 1 0 0 0 instant 10 seconds 5 years time+ time+ + 2009 1 1 0 0 10 instant = ] unit-test +[ t ] [ 2004 1 1 0 0 0 instant -10 seconds -5 years time+ time+ + 1998 12 31 23 59 50 instant = ] unit-test -[ t ] [ 2004 1 1 23 0 0 12 0 convert-timezone - 2004 1 1 11 0 0 0 = ] unit-test -[ t ] [ 2004 1 1 5 0 0 -11 0 convert-timezone - 2004 1 1 16 0 0 0 = ] unit-test -[ t ] [ 2004 1 1 23 0 0 9+1/2 0 convert-timezone - 2004 1 1 13 30 0 0 = ] unit-test +[ t ] [ 2004 1 1 23 0 0 12 hours >gmt + 2004 1 1 11 0 0 instant = ] unit-test +[ t ] [ 2004 1 1 5 0 0 -11 hours >gmt + 2004 1 1 16 0 0 instant = ] unit-test +[ t ] [ 2004 1 1 23 0 0 9+1/2 hours >gmt + 2004 1 1 13 30 0 instant = ] unit-test -[ 0 ] [ 2004 1 1 13 30 0 0 - 2004 1 1 12 30 0 -1 <=> ] unit-test +[ 0 ] [ 2004 1 1 13 30 0 instant + 2004 1 1 12 30 0 -1 hours <=> ] unit-test -[ 1 ] [ 2004 1 1 13 30 0 0 - 2004 1 1 12 30 0 0 <=> ] unit-test +[ 1 ] [ 2004 1 1 13 30 0 instant + 2004 1 1 12 30 0 instant <=> ] unit-test -[ -1 ] [ 2004 1 1 12 30 0 0 - 2004 1 1 13 30 0 0 <=> ] unit-test +[ -1 ] [ 2004 1 1 12 30 0 instant + 2004 1 1 13 30 0 instant <=> ] unit-test -[ 1 ] [ 2005 1 1 12 30 0 0 - 2004 1 1 13 30 0 0 <=> ] unit-test +[ 1 ] [ 2005 1 1 12 30 0 instant + 2004 1 1 13 30 0 instant <=> ] unit-test [ t ] [ now timestamp>millis millis - 1000 < ] unit-test [ t ] [ 0 millis>timestamp unix-1970 = ] unit-test diff --git a/extra/calendar/calendar.factor b/extra/calendar/calendar.factor index 2b80a8dce6..457b0bea11 100755 --- a/extra/calendar/calendar.factor +++ b/extra/calendar/calendar.factor @@ -3,20 +3,23 @@ USING: arrays kernel math math.functions namespaces sequences strings tuples system vocabs.loader calendar.backend threads -new-slots accessors combinators ; +new-slots accessors combinators locals ; IN: calendar TUPLE: timestamp year month day hour minute second gmt-offset ; C: timestamp -: ( year month day -- timestamp ) - 0 0 0 gmt-offset ; - TUPLE: duration year month day hour minute second ; C: duration +: gmt-offset-duration ( -- duration ) + 0 0 0 gmt-offset ; + +: ( year month day -- timestamp ) + 0 0 0 gmt-offset-duration ; + : month-names { "Not a month" "January" "February" "March" "April" "May" "June" @@ -226,16 +229,18 @@ M: duration <=> [ dt>years ] compare ; : dt>seconds ( dt -- x ) dt>years seconds-per-year * ; : dt>milliseconds ( dt -- x ) dt>seconds 1000 * ; -: convert-timezone ( timestamp n -- timestamp ) +GENERIC: time- ( time1 time2 -- time ) + +: convert-timezone ( timestamp duration -- timestamp ) over gmt-offset>> over = [ drop ] [ - [ over gmt-offset>> - hours time+ ] keep >>gmt-offset + [ over gmt-offset>> time- time+ ] keep >>gmt-offset ] if ; : >local-time ( timestamp -- timestamp ) - gmt-offset convert-timezone ; + gmt-offset-duration convert-timezone ; : >gmt ( timestamp -- timestamp ) - 0 convert-timezone ; + instant convert-timezone ; M: timestamp <=> ( ts1 ts2 -- n ) [ >gmt tuple-slots ] compare ; @@ -245,8 +250,6 @@ M: timestamp <=> ( ts1 ts2 -- n ) [ [ >date< julian-day-number ] 2apply - 86400 * ] 2keep [ >time< >r >r 3600 * r> 60 * r> + + ] 2apply - + ; -GENERIC: time- ( time1 time2 -- time ) - M: timestamp time- #! Exact calendar-time difference (time-) seconds ; @@ -263,14 +266,14 @@ M: timestamp time- M: duration time- before time+ ; -: 0 0 0 0 0 0 0 ; +: 0 0 0 0 0 0 instant ; : valid-timestamp? ( timestamp -- ? ) - clone 0 >>gmt-offset + clone instant >>gmt-offset dup time- time+ = ; : unix-1970 ( -- timestamp ) - 1970 1 1 0 0 0 0 ; foldable + 1970 1 1 0 0 0 instant ; foldable : millis>timestamp ( n -- timestamp ) >r unix-1970 r> milliseconds time+ ; diff --git a/extra/calendar/format/format-tests.factor b/extra/calendar/format/format-tests.factor index eb32ce5b43..88bd0733c0 100755 --- a/extra/calendar/format/format-tests.factor +++ b/extra/calendar/format/format-tests.factor @@ -1,5 +1,6 @@ +USING: calendar.format calendar kernel tools.test +io.streams.string ; IN: calendar.format.tests -USING: calendar.format tools.test io.streams.string ; [ 0 ] [ "Z" [ read-rfc3339-gmt-offset ] with-string-reader @@ -20,3 +21,6 @@ USING: calendar.format tools.test io.streams.string ; [ 1+1/2 ] [ "+01:30" [ read-rfc3339-gmt-offset ] with-string-reader ] unit-test + +[ ] [ now timestamp>rfc3339 drop ] unit-test +[ ] [ now timestamp>rfc822 drop ] unit-test diff --git a/extra/calendar/format/format.factor b/extra/calendar/format/format.factor index 89e09e0d0c..0ac0ebb2c3 100755 --- a/extra/calendar/format/format.factor +++ b/extra/calendar/format/format.factor @@ -1,6 +1,7 @@ -IN: calendar.format USING: math math.parser kernel sequences io calendar -accessors arrays io.streams.string combinators accessors ; +accessors arrays io.streams.string combinators accessors +combinators.cleave ; +IN: calendar.format GENERIC: day. ( obj -- ) @@ -54,17 +55,17 @@ M: timestamp year. ( timestamp -- ) : timestamp>string ( timestamp -- str ) [ (timestamp>string) ] with-string-writer ; -: (write-gmt-offset) ( ratio -- ) - 1 /mod swap write-00 60 * write-00 ; +: (write-gmt-offset) ( duration -- ) + [ hour>> write-00 ] [ minute>> write-00 ] bi ; : write-gmt-offset ( gmt-offset -- ) - { - { [ dup zero? ] [ drop "GMT" write ] } - { [ dup 0 < ] [ "-" write neg (write-gmt-offset) ] } - { [ dup 0 > ] [ "+" write (write-gmt-offset) ] } + dup instant <=> { + { [ dup 0 = ] [ 2drop "GMT" write ] } + { [ dup 0 < ] [ drop "-" write before (write-gmt-offset) ] } + { [ dup 0 > ] [ drop "+" write (write-gmt-offset) ] } } cond ; -: timestamp>rfc822-string ( timestamp -- str ) +: timestamp>rfc822 ( timestamp -- str ) #! RFC822 timestamp format #! Example: Tue, 15 Nov 1994 08:12:31 +0200 [ @@ -76,14 +77,19 @@ M: timestamp year. ( timestamp -- ) : timestamp>http-string ( timestamp -- str ) #! http timestamp format #! Example: Tue, 15 Nov 1994 08:12:31 GMT - >gmt timestamp>rfc822-string ; + >gmt timestamp>rfc822 ; -: write-rfc3339-gmt-offset ( n -- ) - dup zero? [ drop "Z" write ] [ - dup 0 < [ CHAR: - write1 neg ] [ CHAR: + write1 ] if - 60 * 60 /mod swap write-00 CHAR: : write1 write-00 - ] if ; +: (write-rfc3339-gmt-offset) ( duration -- ) + [ hour>> write-00 CHAR: : write1 ] + [ minute>> write-00 ] bi ; +: write-rfc3339-gmt-offset ( duration -- ) + dup instant <=> { + { [ dup 0 = ] [ 2drop "Z" write ] } + { [ dup 0 < ] [ drop CHAR: - write1 before (write-rfc3339-gmt-offset) ] } + { [ dup 0 > ] [ drop CHAR: + write1 (write-rfc3339-gmt-offset) ] } + } cond ; + : (timestamp>rfc3339) ( timestamp -- ) dup year>> number>string write CHAR: - write1 dup month>> write-00 CHAR: - write1 diff --git a/extra/calendar/unix/unix.factor b/extra/calendar/unix/unix.factor index 30e22c487b..2877fa07b5 100644 --- a/extra/calendar/unix/unix.factor +++ b/extra/calendar/unix/unix.factor @@ -1,6 +1,5 @@ - USING: alien alien.c-types arrays calendar.backend - kernel structs math unix.time namespaces ; +kernel structs math unix.time namespaces ; IN: calendar.unix @@ -8,11 +7,11 @@ TUPLE: unix-calendar ; T{ unix-calendar } calendar-backend set-global -: get-time +: get-time ( -- alien ) f time localtime ; -: timezone-name +: timezone-name ( -- string ) get-time tm-zone ; -M: unix-calendar gmt-offset - get-time tm-gmtoff 3600 / ; +M: unix-calendar gmt-offset ( -- hours minutes seconds ) + get-time tm-gmtoff 3600 /mod 60 /mod ; diff --git a/extra/calendar/windows/windows.factor b/extra/calendar/windows/windows.factor index 9e34fdac00..acbae2fcd3 100755 --- a/extra/calendar/windows/windows.factor +++ b/extra/calendar/windows/windows.factor @@ -8,8 +8,14 @@ T{ windows-calendar } calendar-backend set-global : TIME_ZONE_ID_INVALID HEX: ffffffff ; inline -M: windows-calendar gmt-offset ( -- float ) +M: windows-calendar gmt-offset ( -- hours minutes seconds ) "TIME_ZONE_INFORMATION" - dup GetTimeZoneInformation - TIME_ZONE_ID_INVALID = [ win32-error ] when - TIME_ZONE_INFORMATION-Bias 60 / neg ; + dup GetTimeZoneInformation { + { [ dup TIME_ZONE_ID_INVALID = ] [ win32-error ] } + { [ dup { TIME_ZONE_ID_UNKNOWN TIME_ZONE_ID_STANDARD } member? ] + [ TIME_ZONE_INFORMATION-Bias 60 / neg ] } + { [ dup TIME_ZONE_ID_DAYLIGHT = ] [ + [ TIME_ZONE_INFORMATION-Bias 60 / neg ] + [ TIME_ZONE_INFORMATION-DaylightBias ] bi + ] } + } cond ; diff --git a/extra/channels/remote/remote.factor b/extra/channels/remote/remote.factor index 2d8d003b8d..c9cfc83d27 100755 --- a/extra/channels/remote/remote.factor +++ b/extra/channels/remote/remote.factor @@ -14,7 +14,7 @@ IN: channels.remote PRIVATE> : publish ( channel -- id ) - random-256 dup >r remote-channels set-at r> ; + 256 random-bits dup >r remote-channels set-at r> ; : get-channel ( id -- channel ) remote-channels at ; diff --git a/extra/cocoa/messages/messages.factor b/extra/cocoa/messages/messages.factor index e2072f441c..480e19b005 100755 --- a/extra/cocoa/messages/messages.factor +++ b/extra/cocoa/messages/messages.factor @@ -59,7 +59,7 @@ objc-methods global [ H{ } assoc-like ] change-at : lookup-method ( selector -- method ) dup objc-methods get at - [ ] [ "No such method: " swap append throw ] ?if ; + [ ] [ "No such method: " prepend throw ] ?if ; : make-dip ( quot n -- quot' ) dup @@ -90,7 +90,7 @@ MACRO: (send) ( selector super? -- quot ) ! Runtime introspection : (objc-class) ( string word -- class ) dupd execute - [ ] [ "No such class: " swap append throw ] ?if ; inline + [ ] [ "No such class: " prepend throw ] ?if ; inline : objc-class ( string -- class ) \ objc_getClass (objc-class) ; diff --git a/extra/combinators/cleave/cleave.factor b/extra/combinators/cleave/cleave.factor index 049c8bf2a9..1bc7480198 100644 --- a/extra/combinators/cleave/cleave.factor +++ b/extra/combinators/cleave/cleave.factor @@ -54,6 +54,8 @@ MACRO: 2cleave ( seq -- ) : bi* ( x y p q -- p(x) q(y) ) >r swap slip r> call ; inline +: 2bi* ( w x y z p q -- p(x) q(y) ) >r -rot 2slip r> call ; inline + : tri* ( x y z p q r -- p(x) q(y) r(z) ) >r rot >r bi* r> r> call ; inline @@ -68,7 +70,7 @@ MACRO: spread ( seq -- ) dup [ drop [ >r ] ] map concat swap - [ [ r> ] swap append ] map concat + [ [ r> ] prepend ] map concat append ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/combinators/lib/lib.factor b/extra/combinators/lib/lib.factor index e177e33c15..459938c885 100755 --- a/extra/combinators/lib/lib.factor +++ b/extra/combinators/lib/lib.factor @@ -8,13 +8,6 @@ continuations ; IN: combinators.lib -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: generate ( generator predicate -- obj ) - #! Call 'generator' until the result satisfies 'predicate'. - [ slip over slip ] 2keep - roll [ 2drop ] [ rot drop generate ] if ; inline - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Generalized versions of core combinators ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -82,11 +75,11 @@ MACRO: && ( quots -- ? ) [ [ not ] append [ f ] ] t short-circuit ; MACRO: <-&& ( quots -- ) - [ [ dup ] swap append [ not ] append [ f ] ] t short-circuit + [ [ dup ] prepend [ not ] append [ f ] ] t short-circuit [ nip ] append ; MACRO: <--&& ( quots -- ) - [ [ 2dup ] swap append [ not ] append [ f ] ] t short-circuit + [ [ 2dup ] prepend [ not ] append [ f ] ] t short-circuit [ 2nip ] append ; MACRO: || ( quots -- ? ) [ [ t ] ] f short-circuit ; @@ -137,12 +130,12 @@ MACRO: map-call-with ( quots -- ) [ (make-call-with) ] keep length [ narray ] curry compose ; : (make-call-with2) ( quots -- quot ) - [ [ 2dup >r >r ] swap append [ r> r> ] append ] map concat + [ [ 2dup >r >r ] prepend [ r> r> ] append ] map concat [ 2drop ] append ; MACRO: map-call-with2 ( quots -- ) [ - [ [ 2dup >r >r ] swap append [ r> r> ] append ] map concat + [ [ 2dup >r >r ] prepend [ r> r> ] append ] map concat [ 2drop ] append ] keep length [ narray ] curry append ; @@ -175,3 +168,10 @@ MACRO: multikeep ( word out-indexes -- ... ) : retry ( quot n -- ) [ drop ] rot compose attempt-all ; inline + +: do-while ( pred body tail -- ) + >r tuck 2slip r> while ; + +: generate ( generator predicate -- obj ) + [ dup ] swap [ dup [ nip ] unless not ] 3compose + swap [ ] do-while ; diff --git a/extra/concurrency/messaging/messaging.factor b/extra/concurrency/messaging/messaging.factor index cfa2aea30d..e566a83fdf 100755 --- a/extra/concurrency/messaging/messaging.factor +++ b/extra/concurrency/messaging/messaging.factor @@ -40,7 +40,7 @@ M: thread send ( message thread -- ) TUPLE: synchronous data sender tag ; : ( data -- sync ) - self random-256 synchronous construct-boa ; + self 256 random-bits synchronous construct-boa ; TUPLE: reply data tag ; diff --git a/extra/core-foundation/core-foundation.factor b/extra/core-foundation/core-foundation.factor index 297e4aec87..73b8fce229 100644 --- a/extra/core-foundation/core-foundation.factor +++ b/extra/core-foundation/core-foundation.factor @@ -83,7 +83,7 @@ FUNCTION: void CFRelease ( void* cf ) ; dup [ CFBundleLoadExecutable drop ] [ - "Cannot load bundled named " swap append throw + "Cannot load bundled named " prepend throw ] ?if ; FUNCTION: CFRunLoopRef CFRunLoopGetMain ( ) ; diff --git a/extra/cpu/8080/emulator/emulator.factor b/extra/cpu/8080/emulator/emulator.factor index 24eceee744..d4574119b2 100755 --- a/extra/cpu/8080/emulator/emulator.factor +++ b/extra/cpu/8080/emulator/emulator.factor @@ -446,7 +446,7 @@ M: cpu reset ( cpu -- ) SYMBOL: rom-root : rom-dir ( -- string ) - rom-root get [ home "roms" path+ dup exists? [ drop f ] unless ] unless* ; + rom-root get [ home "roms" append-path dup exists? [ drop f ] unless ] unless* ; : load-rom* ( seq cpu -- ) #! 'seq' is an array of arrays. Each array contains @@ -455,7 +455,7 @@ SYMBOL: rom-root #! file path shoul dbe relative to the '/roms' resource path. rom-dir [ cpu-ram [ - swap first2 rom-dir swap path+ binary [ + swap first2 rom-dir prepend-path binary [ swap (load-rom) ] with-file-reader ] curry each @@ -1027,14 +1027,14 @@ SYMBOL: $4 8-bit-registers sp <&> "," token <& 8-bit-registers <&> - just [ first2 swap first2 swap >r swap append r> curry ] <@ ; + just [ first2 swap first2 swap >r prepend r> curry ] <@ ; : ADC-R,(RR)-instruction ( -- parser ) "ADC-R,(RR)" "ADC" complex-instruction 8-bit-registers sp <&> "," token <& 16-bit-registers indirect <&> - just [ first2 swap first2 swap >r swap append r> curry ] <@ ; + just [ first2 swap first2 swap >r prepend r> curry ] <@ ; : SBC-R,N-instruction ( -- parser ) "SBC-R,N" "SBC" complex-instruction @@ -1047,14 +1047,14 @@ SYMBOL: $4 8-bit-registers sp <&> "," token <& 8-bit-registers <&> - just [ first2 swap first2 swap >r swap append r> curry ] <@ ; + just [ first2 swap first2 swap >r prepend r> curry ] <@ ; : SBC-R,(RR)-instruction ( -- parser ) "SBC-R,(RR)" "SBC" complex-instruction 8-bit-registers sp <&> "," token <& 16-bit-registers indirect <&> - just [ first2 swap first2 swap >r swap append r> curry ] <@ ; + just [ first2 swap first2 swap >r prepend r> curry ] <@ ; : SUB-R-instruction ( -- parser ) "SUB-R" "SUB" complex-instruction @@ -1082,21 +1082,21 @@ SYMBOL: $4 8-bit-registers sp <&> "," token <& 8-bit-registers <&> - just [ first2 swap first2 swap >r swap append r> curry ] <@ ; + just [ first2 swap first2 swap >r prepend r> curry ] <@ ; : ADD-RR,RR-instruction ( -- parser ) "ADD-RR,RR" "ADD" complex-instruction 16-bit-registers sp <&> "," token <& 16-bit-registers <&> - just [ first2 swap first2 swap >r swap append r> curry ] <@ ; + just [ first2 swap first2 swap >r prepend r> curry ] <@ ; : ADD-R,(RR)-instruction ( -- parser ) "ADD-R,(RR)" "ADD" complex-instruction 8-bit-registers sp <&> "," token <& 16-bit-registers indirect <&> - just [ first2 swap first2 swap >r swap append r> curry ] <@ ; + just [ first2 swap first2 swap >r prepend r> curry ] <@ ; : LD-RR,NN-instruction #! LD BC,nn @@ -1124,28 +1124,28 @@ SYMBOL: $4 16-bit-registers indirect sp <&> "," token <& 8-bit-registers <&> - just [ first2 swap first2 swap >r swap append r> curry ] <@ ; + just [ first2 swap first2 swap >r prepend r> curry ] <@ ; : LD-R,R-instruction "LD-R,R" "LD" complex-instruction 8-bit-registers sp <&> "," token <& 8-bit-registers <&> - just [ first2 swap first2 swap >r swap append r> curry ] <@ ; + just [ first2 swap first2 swap >r prepend r> curry ] <@ ; : LD-RR,RR-instruction "LD-RR,RR" "LD" complex-instruction 16-bit-registers sp <&> "," token <& 16-bit-registers <&> - just [ first2 swap first2 swap >r swap append r> curry ] <@ ; + just [ first2 swap first2 swap >r prepend r> curry ] <@ ; : LD-R,(RR)-instruction "LD-R,(RR)" "LD" complex-instruction 8-bit-registers sp <&> "," token <& 16-bit-registers indirect <&> - just [ first2 swap first2 swap >r swap append r> curry ] <@ ; + just [ first2 swap first2 swap >r prepend r> curry ] <@ ; : LD-(NN),RR-instruction "LD-(NN),RR" "LD" complex-instruction @@ -1194,14 +1194,14 @@ SYMBOL: $4 16-bit-registers indirect sp <&> "," token <& 16-bit-registers <&> - just [ first2 swap first2 swap >r swap append r> curry ] <@ ; + just [ first2 swap first2 swap >r prepend r> curry ] <@ ; : EX-RR,RR-instruction "EX-RR,RR" "EX" complex-instruction 16-bit-registers sp <&> "," token <& 16-bit-registers <&> - just [ first2 swap first2 swap >r swap append r> curry ] <@ ; + just [ first2 swap first2 swap >r prepend r> curry ] <@ ; : 8080-generator-parser NOP-instruction diff --git a/extra/crypto/blum-blum-shub.factor b/extra/crypto/blum-blum-shub.factor deleted file mode 100644 index a1c196d08e..0000000000 --- a/extra/crypto/blum-blum-shub.factor +++ /dev/null @@ -1,36 +0,0 @@ -USING: kernel math sequences namespaces crypto math-contrib ; -IN: crypto-internals - -! TODO: take (log log M) bits instead of 1 bit -! Blum Blum Shub, M = pq -TUPLE: bbs x n ; - -: generate-bbs-primes ( numbits -- p q ) - #! two primes congruent to 3 (mod 4) - dup [ random-miller-rabin-prime==3(mod4) ] 2apply ; - -IN: crypto -: make-bbs ( numbits -- blum-blum-shub ) - #! returns a Blum-Blum-Shub tuple - generate-bbs-primes * [ find-relative-prime ] keep ; - -IN: crypto-internals -SYMBOL: blum-blum-shub 256 make-bbs blum-blum-shub set-global - -: next-bbs-bit ( bbs -- bit ) - #! x = x^2 mod n, return low bit of calculated x - [ [ bbs-x ] keep 2 swap bbs-n ^mod ] keep - [ set-bbs-x ] keep bbs-x 1 bitand ; - -SYMBOL: temp-bbs -: (bbs-bits) ( numbits bbs -- n ) - temp-bbs set [ [ temp-bbs get next-bbs-bit ] swap make-bits ] with-scope ; - -IN: crypto -: random-bbs-bits* ( numbits bbs -- n ) (bbs-bits) ; -: random-bits ( numbits -- n ) blum-blum-shub get (bbs-bits) ; -: random-bytes ( numbits -- n ) 8 * random-bits ; -: random ( n -- n ) - ! #! Cryptographically secure random number using Blum-Blum-Shub 256 - [ log2 1+ random-bits ] keep dupd >= [ -1 shift ] when ; - diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index bca904279b..d7d954c0dc 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -71,7 +71,7 @@ M: sqlite-statement bind-tuple ( tuple statement -- ) [ statement-in-params [ - [ sql-spec-column-name ":" swap append ] + [ sql-spec-column-name ":" prepend ] [ sql-spec-slot-name rot get-slot-named ] [ sql-spec-type ] tri 3array ] with map @@ -173,7 +173,7 @@ M: sqlite-db ( specs table -- sql ) ! : select-sequence ( seq name -- ) ; M: sqlite-db bind% ( spec -- ) - dup 1, sql-spec-column-name ":" swap append 0% ; + dup 1, sql-spec-column-name ":" prepend 0% ; M: sqlite-db ( tuple class -- statement ) [ diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor index a0414f334d..94a8d6f392 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -127,7 +127,7 @@ TUPLE: no-sql-modifier ; : modifiers ( spec -- str ) sql-spec-modifiers [ lookup-modifier ] map " " join - dup empty? [ " " swap append ] unless ; + dup empty? [ " " prepend ] unless ; HOOK: bind% db ( spec -- ) diff --git a/extra/documents/documents.factor b/extra/documents/documents.factor index 993e69ec14..60ae592d4c 100755 --- a/extra/documents/documents.factor +++ b/extra/documents/documents.factor @@ -74,7 +74,7 @@ TUPLE: document locs ; 0 swap [ append ] change-nth ; : append-last ( str seq -- ) - [ length 1- ] keep [ swap append ] change-nth ; + [ length 1- ] keep [ prepend ] change-nth ; : loc-col/str ( loc document -- str col ) >r first2 swap r> nth swap ; diff --git a/extra/editors/editpadpro/editpadpro.factor b/extra/editors/editpadpro/editpadpro.factor index eb31b2aa47..9da57e16bf 100755 --- a/extra/editors/editpadpro/editpadpro.factor +++ b/extra/editors/editpadpro/editpadpro.factor @@ -5,7 +5,7 @@ IN: editors.editpadpro : editpadpro-path \ editpadpro-path get-global [ - program-files "JGsoft" path+ + program-files "JGsoft" append-path t [ >lower "editpadpro.exe" tail? ] find-file ] unless* ; diff --git a/extra/editors/editplus/editplus.factor b/extra/editors/editplus/editplus.factor index ee24c99463..363d202f6c 100755 --- a/extra/editors/editplus/editplus.factor +++ b/extra/editors/editplus/editplus.factor @@ -4,7 +4,7 @@ IN: editors.editplus : editplus-path ( -- path ) \ editplus-path get-global [ - program-files "\\EditPlus 2\\editplus.exe" path+ + program-files "\\EditPlus 2\\editplus.exe" append-path ] unless* ; : editplus ( file line -- ) diff --git a/extra/editors/emeditor/emeditor.factor b/extra/editors/emeditor/emeditor.factor index bed333694c..8aecb49ae5 100755 --- a/extra/editors/emeditor/emeditor.factor +++ b/extra/editors/emeditor/emeditor.factor @@ -4,7 +4,7 @@ IN: editors.emeditor : emeditor-path ( -- path ) \ emeditor-path get-global [ - program-files "\\EmEditor\\EmEditor.exe" path+ + program-files "\\EmEditor\\EmEditor.exe" append-path ] unless* ; : emeditor ( file line -- ) diff --git a/extra/editors/gvim/windows/windows.factor b/extra/editors/gvim/windows/windows.factor index 030c968e81..489000498e 100755 --- a/extra/editors/gvim/windows/windows.factor +++ b/extra/editors/gvim/windows/windows.factor @@ -4,6 +4,6 @@ IN: editors.gvim.windows M: windows-io gvim-path \ gvim-path get-global [ - program-files "vim" path+ + program-files "vim" append-path t [ "gvim.exe" tail? ] find-file ] unless* ; diff --git a/extra/editors/jedit/jedit.factor b/extra/editors/jedit/jedit.factor index 3ce2c40192..7b6066df7c 100644 --- a/extra/editors/jedit/jedit.factor +++ b/extra/editors/jedit/jedit.factor @@ -8,7 +8,7 @@ io.encodings.utf8 ; IN: editors.jedit : jedit-server-info ( -- port auth ) - home "/.jedit/server" path+ ascii [ + home "/.jedit/server" append-path ascii [ readln drop readln string>number readln string>number @@ -32,7 +32,7 @@ IN: editors.jedit ] with-stream ; : jedit-location ( file line -- ) - number>string "+line:" swap append 2array + number>string "+line:" prepend 2array make-jedit-request send-jedit-request ; : jedit-file ( file -- ) diff --git a/extra/editors/notepadpp/notepadpp.factor b/extra/editors/notepadpp/notepadpp.factor index 72ac6c72d7..959e633cc3 100755 --- a/extra/editors/notepadpp/notepadpp.factor +++ b/extra/editors/notepadpp/notepadpp.factor @@ -4,7 +4,7 @@ IN: editors.notepadpp : notepadpp-path \ notepadpp-path get-global [ - program-files "notepad++\\notepad++.exe" path+ + program-files "notepad++\\notepad++.exe" append-path ] unless* ; : notepadpp ( file line -- ) diff --git a/extra/editors/scite/scite.factor b/extra/editors/scite/scite.factor index ac9a032abc..a0bacaabba 100755 --- a/extra/editors/scite/scite.factor +++ b/extra/editors/scite/scite.factor @@ -14,7 +14,7 @@ IN: editors.scite : scite-path ( -- path ) \ scite-path get-global [ - program-files "wscite\\SciTE.exe" path+ + program-files "wscite\\SciTE.exe" append-path ] unless* ; : scite-command ( file line -- cmd ) diff --git a/extra/editors/ted-notepad/ted-notepad.factor b/extra/editors/ted-notepad/ted-notepad.factor index 5d58e182a3..9b341dd2a8 100755 --- a/extra/editors/ted-notepad/ted-notepad.factor +++ b/extra/editors/ted-notepad/ted-notepad.factor @@ -4,7 +4,7 @@ IN: editors.ted-notepad : ted-notepad-path \ ted-notepad-path get-global [ - program-files "\\TED Notepad\\TedNPad.exe" path+ + program-files "\\TED Notepad\\TedNPad.exe" append-path ] unless* ; : ted-notepad ( file line -- ) diff --git a/extra/editors/ultraedit/ultraedit.factor b/extra/editors/ultraedit/ultraedit.factor index f9d27174b3..1fef9f3350 100755 --- a/extra/editors/ultraedit/ultraedit.factor +++ b/extra/editors/ultraedit/ultraedit.factor @@ -5,7 +5,7 @@ IN: editors.ultraedit : ultraedit-path ( -- path ) \ ultraedit-path get-global [ program-files - "\\IDM Computer Solutions\\UltraEdit-32\\uedit32.exe" path+ + "\\IDM Computer Solutions\\UltraEdit-32\\uedit32.exe" append-path ] unless* ; : ultraedit ( file line -- ) diff --git a/extra/editors/wordpad/wordpad.factor b/extra/editors/wordpad/wordpad.factor index 5ad08b613b..d1f979e0f3 100755 --- a/extra/editors/wordpad/wordpad.factor +++ b/extra/editors/wordpad/wordpad.factor @@ -5,7 +5,7 @@ IN: editors.wordpad : wordpad-path ( -- path ) \ wordpad-path get [ - program-files "\\Windows NT\\Accessories\\wordpad.exe" path+ + program-files "\\Windows NT\\Accessories\\wordpad.exe" append-path ] unless* ; : wordpad ( file line -- ) diff --git a/extra/faq/faq.factor b/extra/faq/faq.factor index 7ad3900163..d7624466f7 100644 --- a/extra/faq/faq.factor +++ b/extra/faq/faq.factor @@ -79,7 +79,7 @@ C: faq "br" contained, nl, ; : toc-link, ( question-list number -- ) - number>string "#" swap append "href" swap 2array 1array + number>string "#" prepend "href" swap 2array 1array "a" swap [ question-list-title , ] tag*, br, ; : toc, ( faq -- ) diff --git a/extra/help/help.factor b/extra/help/help.factor index 34e90b2ccf..4cb8cfe854 100755 --- a/extra/help/help.factor +++ b/extra/help/help.factor @@ -98,7 +98,7 @@ M: word set-article-parent swap "help-parent" set-word-prop ; : about ( vocab -- ) dup require dup vocab [ ] [ - "No such vocabulary: " swap append throw + "No such vocabulary: " prepend throw ] ?if dup vocab-help [ help diff --git a/extra/help/markup/markup.factor b/extra/help/markup/markup.factor index 7cfe384bde..47a40d6948 100755 --- a/extra/help/markup/markup.factor +++ b/extra/help/markup/markup.factor @@ -159,7 +159,7 @@ M: f print-element drop ; [ first ($long-link) ] ($subsection) ; : ($vocab-link) ( text vocab -- ) - dup vocab-root >vocab-link write-link ; + >vocab-link write-link ; : $vocab-subsection ( element -- ) [ diff --git a/extra/html/elements/elements.factor b/extra/html/elements/elements.factor index 286037d4dc..754afb1ea7 100644 --- a/extra/html/elements/elements.factor +++ b/extra/html/elements/elements.factor @@ -38,7 +38,7 @@ IN: html.elements ! "Click me" write ! ! (url -- ) -! "click" write +! "click" write ! ! (url -- ) ! "click" write @@ -72,7 +72,7 @@ SYMBOL: html dup swap [ write-html ] curry empty-effect html-word ; -: - [ +path+ get "xxx" get "X" concat append ] >>submit - { { +path+ [ ] } { "xxx" [ v-number ] } } >>post-params + [ +append-path get "xxx" get "X" concat append ] >>submit + { { +append-path [ ] } { "xxx" [ v-number ] } } >>post-params "action-2" set STRING: action-request-test-2 diff --git a/extra/http/server/actions/actions.factor b/extra/http/server/actions/actions.factor index 52567ed352..287f6dd907 100755 --- a/extra/http/server/actions/actions.factor +++ b/extra/http/server/actions/actions.factor @@ -5,7 +5,7 @@ http.server http.server.validators http hashtables namespaces combinators.cleave fry continuations locals ; IN: http.server.actions -SYMBOL: +path+ +SYMBOL: +append-path SYMBOL: params @@ -40,7 +40,7 @@ TUPLE: action init display submit get-params post-params ; M: action call-responder ( path action -- response ) '[ , , - [ +path+ associate request-params union params set ] + [ +append-path associate request-params union params set ] [ action set ] bi* request get method>> { { "GET" [ handle-get ] } diff --git a/extra/http/server/auth/providers/providers.factor b/extra/http/server/auth/providers/providers.factor index d51679016e..cdad4815a6 100755 --- a/extra/http/server/auth/providers/providers.factor +++ b/extra/http/server/auth/providers/providers.factor @@ -27,7 +27,7 @@ GENERIC: new-user ( user provider -- user/f ) user email>> length 0 > [ user email>> email = [ user - random-256 >hex >>ticket + 256 random-bits >hex >>ticket dup provider update-user ] [ f ] if ] [ f ] if diff --git a/extra/http/server/components/components.factor b/extra/http/server/components/components.factor index 02c992651a..8581335f3d 100755 --- a/extra/http/server/components/components.factor +++ b/extra/http/server/components/components.factor @@ -13,7 +13,7 @@ TUPLE: component id required default ; : component ( name -- component ) dup components get at - [ ] [ "No such component: " swap append throw ] ?if ; + [ ] [ "No such component: " prepend throw ] ?if ; GENERIC: validate* ( value component -- result ) GENERIC: render-view* ( value component -- ) diff --git a/extra/http/server/static/static.factor b/extra/http/server/static/static.factor index b408b1b6b0..b001242776 100755 --- a/extra/http/server/static/static.factor +++ b/extra/http/server/static/static.factor @@ -39,7 +39,7 @@ TUPLE: file-responder root hook special ; [ 2drop <304> ] [ file-responder get hook>> call ] if ; : serving-path ( filename -- filename ) - "" or file-responder get root>> swap path+ ; + "" or file-responder get root>> prepend-path ; : serve-file ( filename -- response ) dup mime-type @@ -68,7 +68,7 @@ TUPLE: file-responder root hook special ; swap '[ , directory. ] >>body ; : find-index ( filename -- path ) - { "index.html" "index.fhtml" } [ path+ ] with map + { "index.html" "index.fhtml" } [ append-path ] with map [ exists? ] find nip ; : serve-directory ( filename -- response ) diff --git a/extra/http/server/templating/fhtml/fhtml-tests.factor b/extra/http/server/templating/fhtml/fhtml-tests.factor index 9774e4c1f2..2e253d9132 100755 --- a/extra/http/server/templating/fhtml/fhtml-tests.factor +++ b/extra/http/server/templating/fhtml/fhtml-tests.factor @@ -5,7 +5,7 @@ IN: http.server.templating.fhtml.tests : test-template ( path -- ? ) "resource:extra/http/server/templating/fhtml/test/" - swap append + prepend [ ".fhtml" append [ run-template ] with-string-writer ] keep diff --git a/extra/http/server/validators/validators.factor b/extra/http/server/validators/validators.factor index 539a58d19f..f2d1f568e6 100755 --- a/extra/http/server/validators/validators.factor +++ b/extra/http/server/validators/validators.factor @@ -59,7 +59,7 @@ C: validation-error : v-regexp ( str what regexp -- str ) >r over r> matches? - [ drop ] [ "invalid " swap append throw ] if ; + [ drop ] [ "invalid " prepend throw ] if ; : v-email ( str -- str ) #! From http://www.regular-expressions.info/email.html diff --git a/extra/io/encodings/utf16/utf16.factor b/extra/io/encodings/utf16/utf16.factor index 290761ec91..05dc7235f6 100755 --- a/extra/io/encodings/utf16/utf16.factor +++ b/extra/io/encodings/utf16/utf16.factor @@ -18,13 +18,13 @@ TUPLE: utf16 ; over [ 8 shift bitor ] [ 2drop replacement-char ] if ; : double-be ( stream byte -- stream char ) - over stream-read1 swap append-nums ; + over stream-read1 prepend-nums ; : quad-be ( stream byte -- stream char ) double-be over stream-read1 [ dup -2 shift BIN: 110111 number= [ >r 2 shift r> BIN: 11 bitand bitor - over stream-read1 swap append-nums HEX: 10000 + + over stream-read1 prepend-nums HEX: 10000 + ] [ 2drop dup stream-read1 drop replacement-char ] if ] when* ; diff --git a/extra/io/files/unique/unique.factor b/extra/io/files/unique/unique.factor index 1e77cd6814..9a271e402c 100644 --- a/extra/io/files/unique/unique.factor +++ b/extra/io/files/unique/unique.factor @@ -24,7 +24,7 @@ PRIVATE> : make-unique-file ( prefix suffix -- path stream ) temporary-path -rot [ - unique-length random-name swap 3append path+ + unique-length random-name swap 3append append-path dup (make-unique-file) ] 3curry unique-retries retry ; @@ -36,7 +36,7 @@ PRIVATE> : make-unique-directory ( -- path ) [ - temporary-path unique-length random-name path+ + temporary-path unique-length random-name append-path dup make-directory ] unique-retries retry ; diff --git a/extra/io/paths/paths.factor b/extra/io/paths/paths.factor index 4acfb9acad..163194195d 100755 --- a/extra/io/paths/paths.factor +++ b/extra/io/paths/paths.factor @@ -5,7 +5,7 @@ IN: io.paths TUPLE: directory-iterator path bfs queue ; : qualified-directory ( path -- seq ) - dup directory [ first2 >r path+ r> 2array ] with map ; + dup directory [ first2 >r append-path r> 2array ] with map ; : push-directory ( path iter -- ) >r qualified-directory r> [ diff --git a/extra/io/timeouts/timeouts.factor b/extra/io/timeouts/timeouts.factor index ef660a6f0d..f1031e98e2 100755 --- a/extra/io/timeouts/timeouts.factor +++ b/extra/io/timeouts/timeouts.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov, Doug Coleman ! See http://factorcode.org/license.txt for BSD license. -USING: kernel calendar alarms io.streams.duplex ; +USING: kernel calendar alarms io.streams.duplex io.encodings ; IN: io.timeouts ! Won't need this with new slot accessors @@ -12,6 +12,10 @@ M: duplex-stream set-timeout duplex-stream-in set-timeout duplex-stream-out set-timeout ; +M: decoder set-timeout decoder-stream set-timeout ; + +M: encoder set-timeout encoder-stream set-timeout ; + GENERIC: timed-out ( obj -- ) M: object timed-out drop ; diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor index dda94da892..7cf056674f 100755 --- a/extra/io/windows/nt/files/files.factor +++ b/extra/io/windows/nt/files/files.factor @@ -32,9 +32,9 @@ M: windows-nt-io root-directory? ( path -- ? ) } && [ 2 head ] [ "Not an absolute path" throw ] if ; : prepend-prefix ( string -- string' ) - unicode-prefix swap append ; + unicode-prefix prepend ; -: windows-path+ ( cwd path -- newpath ) +: windows-append-path ( cwd path -- newpath ) { ! empty { [ dup empty? ] [ drop ] } @@ -43,7 +43,7 @@ M: windows-nt-io root-directory? ( path -- ? ) ! \\\\?\\c:\\foo { [ dup unicode-prefix head? ] [ nip ] } ! ..\\foo - { [ dup "..\\" head? ] [ >r parent-directory r> 3 tail windows-path+ ] } + { [ dup "..\\" head? ] [ >r parent-directory r> 3 tail windows-append-path ] } ! .\\foo { [ dup ".\\" head? ] [ 1 tail append prepend-prefix ] } ! \\foo @@ -62,7 +62,7 @@ M: windows-nt-io normalize-pathname ( string -- string ) dup string? [ "Pathname must be a string" throw ] unless dup empty? [ "Empty pathname" throw ] when { { CHAR: / CHAR: \\ } } substitute - cwd swap windows-path+ + cwd swap windows-append-path [ "/\\." member? ] right-trim dup peek CHAR: : = [ "\\" append ] when ; diff --git a/extra/io/windows/nt/nt-tests.factor b/extra/io/windows/nt/nt-tests.factor index c4ac99fe4a..6353bfe86e 100755 --- a/extra/io/windows/nt/nt-tests.factor +++ b/extra/io/windows/nt/nt-tests.factor @@ -22,15 +22,15 @@ IN: io.windows.nt.tests [ "\\\\?\\C:\\builds\\factor\\log.txt" ] [ "C:\\builds\\factor\\12345\\" - "..\\log.txt" windows-path+ + "..\\log.txt" windows-append-path ] unit-test [ "\\\\?\\C:\\builds\\" ] [ "C:\\builds\\factor\\12345\\" - "..\\.." windows-path+ + "..\\.." windows-append-path ] unit-test [ "\\\\?\\C:\\builds\\" ] [ "C:\\builds\\factor\\12345\\" - "..\\.." windows-path+ + "..\\.." windows-append-path ] unit-test diff --git a/extra/koszul/koszul.factor b/extra/koszul/koszul.factor index 69de838eec..71cbb1d951 100755 --- a/extra/koszul/koszul.factor +++ b/extra/koszul/koszul.factor @@ -33,7 +33,7 @@ SYMBOL: terms { { [ dup 1 = ] [ drop " + " ] } { [ dup -1 = ] [ drop " - " ] } - { [ t ] [ number>string " + " swap append ] } + { [ t ] [ number>string " + " prepend ] } } cond ; : (alt.) ( basis n -- str ) @@ -155,7 +155,7 @@ DEFER: (d) : (tensor) ( seq1 seq2 -- seq ) [ - [ swap append natural-sort ] curry map + [ prepend natural-sort ] curry map ] with map concat ; : tensor ( graded-basis1 graded-basis2 -- bigraded-basis ) @@ -202,7 +202,7 @@ DEFER: (d) : bigraded-betti ( u-generators z-generators -- seq ) [ basis graded ] 2apply tensor bigraded-ker/im-d [ [ [ first ] map ] map ] keep - [ [ second ] map 2 head* { 0 0 } swap append ] map + [ [ second ] map 2 head* { 0 0 } prepend ] map 1 tail dup first length 0 add [ v- ] 2map ; diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor index d7788c80bc..cc1785ff62 100755 --- a/extra/locals/locals.factor +++ b/extra/locals/locals.factor @@ -180,7 +180,7 @@ M: block lambda-rewrite* #! Turn free variables into bound variables, curry them #! onto the body dup free-vars [ ] map dup % [ - over block-vars swap append + over block-vars prepend swap block-body [ [ lambda-rewrite* ] each ] [ ] make swap point-free , ] keep length \ curry % ; diff --git a/extra/logging/server/server.factor b/extra/logging/server/server.factor index 372216c45e..bed6a2fec3 100755 --- a/extra/logging/server/server.factor +++ b/extra/logging/server/server.factor @@ -11,10 +11,10 @@ IN: logging.server \ log-root get "logs" resource-path or ; : log-path ( service -- path ) - log-root swap path+ ; + log-root prepend-path ; : log# ( path n -- path' ) - number>string ".log" append path+ ; + number>string ".log" append append-path ; SYMBOL: log-files diff --git a/extra/math/haar/haar.factor b/extra/math/haar/haar.factor index 13eaa479a5..91d9fd8ece 100644 --- a/extra/math/haar/haar.factor +++ b/extra/math/haar/haar.factor @@ -12,4 +12,4 @@ IN: math.haar 2 group dup averages [ differences ] keep ; : haar ( seq -- seq ) - dup length 1 <= [ haar-step haar swap append ] unless ; + dup length 1 <= [ haar-step haar prepend ] unless ; diff --git a/extra/math/miller-rabin/miller-rabin.factor b/extra/math/miller-rabin/miller-rabin.factor index 3985906b32..ea7f02829d 100755 --- a/extra/math/miller-rabin/miller-rabin.factor +++ b/extra/math/miller-rabin/miller-rabin.factor @@ -19,8 +19,6 @@ SYMBOL: trials : next-odd ( m -- n ) dup even? [ 1+ ] [ 2 + ] if ; -: random-bits ( m -- n ) 2^ random ; foldable - TUPLE: positive-even-expected n ; : (factor-2s) ( r s -- r s ) diff --git a/extra/new-slots/new-slots.factor b/extra/new-slots/new-slots.factor index 3273036b8b..9773da7b41 100755 --- a/extra/new-slots/new-slots.factor +++ b/extra/new-slots/new-slots.factor @@ -27,7 +27,7 @@ IN: new-slots : setter-effect T{ effect f { "object" "value" } { "value" } } ; inline : setter-word ( name -- word ) - ">>" swap append setter-effect create-accessor ; + ">>" prepend setter-effect create-accessor ; : define-setter ( name -- ) dup setter-word dup deferred? [ @@ -37,7 +37,7 @@ IN: new-slots : changer-effect T{ effect f { "object" "quot" } { "object" } } ; inline : changer-word ( name -- word ) - "change-" swap append changer-effect create-accessor ; + "change-" prepend changer-effect create-accessor ; : define-changer ( name -- ) dup changer-word dup deferred? [ diff --git a/extra/optimizer/debugger/debugger.factor b/extra/optimizer/debugger/debugger.factor index 3cbddf8296..1f5453798d 100755 --- a/extra/optimizer/debugger/debugger.factor +++ b/extra/optimizer/debugger/debugger.factor @@ -65,7 +65,7 @@ MATCH-VARS: ?a ?b ?c ; M: #shuffle node>quot dup node-in-d over node-out-d pretty-shuffle [ , ] [ >r drop t r> ] if* - dup effect-str "#shuffle: " swap append comment, ; + dup effect-str "#shuffle: " prepend comment, ; : pushed-literals node-out-d [ value-literal literalize ] map ; diff --git a/extra/project-euler/002/002.factor b/extra/project-euler/002/002.factor index 0b8f773887..b660ed0958 100644 --- a/extra/project-euler/002/002.factor +++ b/extra/project-euler/002/002.factor @@ -41,7 +41,7 @@ PRIVATE> : fib-upto* ( n -- seq ) 0 1 [ pick over >= ] [ tuck + dup ] [ ] unfold 3nip - 1 head-slice* { 0 1 } swap append ; + 1 head-slice* { 0 1 } prepend ; : euler002a ( -- answer ) 1000000 fib-upto* [ even? ] subset sum ; diff --git a/extra/project-euler/035/035.factor b/extra/project-euler/035/035.factor index d8d38d1647..9873abf05c 100755 --- a/extra/project-euler/035/035.factor +++ b/extra/project-euler/035/035.factor @@ -34,7 +34,7 @@ IN: project-euler.035 ] if ; : rotate ( seq n -- seq ) - cut* swap append ; + cut* prepend ; : (circular?) ( seq n -- ? ) dup 0 > [ diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index 25ddd9a60b..04339ad5b7 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -30,7 +30,7 @@ IN: project-euler number>string 3 CHAR: 0 pad-left ; : solution-path ( n -- str/f ) - number>euler "project-euler." swap append + number>euler "project-euler." prepend vocab where dup [ first ?resource-path ] when ; PRIVATE> @@ -40,7 +40,7 @@ PRIVATE> : run-project-euler ( -- ) problem-prompt dup problem-solved? [ - dup number>euler "project-euler." swap append run + dup number>euler "project-euler." prepend run "Answer: " swap dup number? [ number>string ] when append print "Source: " swap solution-path append print ] [ diff --git a/extra/random/blum-blum-shub/blum-blum-shub.factor b/extra/random/blum-blum-shub/blum-blum-shub.factor new file mode 100644 index 0000000000..e1ba48281a --- /dev/null +++ b/extra/random/blum-blum-shub/blum-blum-shub.factor @@ -0,0 +1,36 @@ +USING: kernel math sequences namespaces +math.miller-rabin combinators.cleave combinators.lib +math.functions new-slots accessors random ; +IN: random.blum-blum-shub + +! TODO: take (log log M) bits instead of 1 bit +! Blum Blum Shub, M = pq +TUPLE: blum-blum-shub x n ; + +C: blum-blum-shub + +: generate-bbs-primes ( numbits -- p q ) + #! two primes congruent to 3 (mod 4) + [ [ random-prime ] curry [ 4 mod 3 = ] generate ] dup bi ; + +IN: crypto +: ( numbits -- blum-blum-shub ) + #! returns a Blum-Blum-Shub tuple + generate-bbs-primes * + [ find-relative-prime ] keep + blum-blum-shub construct-boa ; + +! 256 make-bbs blum-blum-shub set-global + +: next-bbs-bit ( bbs -- bit ) + #! x = x^2 mod n, return low bit of calculated x + [ [ x>> 2 ] [ n>> ] bi ^mod ] + [ [ >>x ] keep x>> 1 bitand ] bi ; + +IN: crypto +! : random ( n -- n ) + ! ! #! Cryptographically secure random number using Blum-Blum-Shub 256 + ! [ log2 1+ random-bits ] keep dupd >= [ -1 shift ] when ; + +M: blum-blum-shub random-32 ( bbs -- r ) + ; diff --git a/extra/random/dummy/dummy.factor b/extra/random/dummy/dummy.factor new file mode 100644 index 0000000000..af6e2365bb --- /dev/null +++ b/extra/random/dummy/dummy.factor @@ -0,0 +1,11 @@ +USING: kernel random math new-slots accessors ; +IN: random.dummy + +TUPLE: random-dummy i ; +C: random-dummy + +M: random-dummy seed-random ( seed obj -- ) + (>>i) ; + +M: random-dummy random-32 ( obj -- r ) + [ dup 1+ ] change-i drop ; diff --git a/extra/random/authors.txt b/extra/random/mersenne-twister/authors.txt similarity index 100% rename from extra/random/authors.txt rename to extra/random/mersenne-twister/authors.txt diff --git a/extra/random/random-docs.factor b/extra/random/mersenne-twister/mersenne-twister-docs.factor.bak similarity index 78% rename from extra/random/random-docs.factor rename to extra/random/mersenne-twister/mersenne-twister-docs.factor.bak index 1d8334ab31..981b206b29 100644 --- a/extra/random/random-docs.factor +++ b/extra/random/mersenne-twister/mersenne-twister-docs.factor.bak @@ -1,17 +1,17 @@ USING: help.markup help.syntax math ; -IN: random +IN: random.mersenne-twister ARTICLE: "random-numbers" "Generating random integers" "The " { $vocab-link "random" } " vocabulary implements the ``Mersenne Twister'' pseudo-random number generator algorithm." -{ $subsection init-random } +! { $subsection init-random } { $subsection (random) } { $subsection random } ; ABOUT: "random-numbers" -HELP: init-random -{ $values { "seed" integer } } -{ $description "Initializes the random number generator with the given seed. This word is called on startup to initialize the random number generator with the current time." } ; +! HELP: init-random +! { $values { "seed" integer } } +! { $description "Initializes the random number generator with the given seed. This word is called on startup to initialize the random number generator with the current time." } ; HELP: (random) { $values { "rand" "an integer between 0 and 2^32-1" } } diff --git a/extra/random/mersenne-twister/mersenne-twister-tests.factor b/extra/random/mersenne-twister/mersenne-twister-tests.factor new file mode 100644 index 0000000000..afd9d085b6 --- /dev/null +++ b/extra/random/mersenne-twister/mersenne-twister-tests.factor @@ -0,0 +1,30 @@ +USING: kernel math random namespaces random.mersenne-twister +sequences tools.test ; +IN: random.mersenne-twister.tests +USE: tools.walker + +: check-random ( max -- ? ) + dup >r random 0 r> between? ; + +[ t ] [ 100 [ drop 674 check-random ] all? ] unit-test + +: make-100-randoms + [ 100 [ 100 random , ] times ] { } make ; + +: test-rng ( seed quot -- ) + >r r> with-random ; + +[ f ] [ 1234 [ make-100-randoms make-100-randoms = ] test-rng ] unit-test + +[ 1333075495 ] [ + 0 [ 1000 [ drop \ random get random-32 drop ] each \ random get random-32 ] test-rng +] unit-test + +[ 1575309035 ] [ + 0 [ 10000 [ drop \ random get random-32 drop ] each \ random get random-32 ] test-rng +] unit-test + + +[ 3 ] [ 101 [ 3 random-bytes length ] test-rng ] unit-test +[ 33 ] [ 101 [ 33 random-bytes length ] test-rng ] unit-test +[ t ] [ 101 [ 100 random-bits log2 90 > ] test-rng ] unit-test diff --git a/extra/random/mersenne-twister/mersenne-twister.factor b/extra/random/mersenne-twister/mersenne-twister.factor new file mode 100755 index 0000000000..79101c083e --- /dev/null +++ b/extra/random/mersenne-twister/mersenne-twister.factor @@ -0,0 +1,80 @@ +! Copyright (C) 2005, 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +! 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 new-slots accessors +math.ranges combinators.cleave circular random ; +IN: random.mersenne-twister + += [ - ] [ drop ] if ; inline +: mt-wrap ( x -- y ) mt-n wrap ; inline + +: set-generated ( mt y from-elt to -- ) + >r >r [ 2/ ] [ odd? mt-a 0 ? ] bi + r> bitxor bitxor r> new-set-nth drop ; inline + +: calculate-y ( mt y1 y2 -- y ) + >r over r> + [ new-nth mt-hi ] [ new-nth mt-lo ] 2bi* bitor ; inline + +: (mt-generate) ( mt-seq n -- y to from-elt ) + [ dup 1+ mt-wrap calculate-y ] + [ mt-m + mt-wrap new-nth ] + [ nip ] 2tri ; + +: mt-generate ( mt -- ) + [ seq>> mt-n [ dupd (mt-generate) set-generated ] with each ] + [ 0 >>i drop ] bi ; + +: init-mt-first ( seed -- seq ) + >r mt-n 0 r> + HEX: ffffffff bitand 0 new-set-nth ; + +: init-mt-formula ( seq i -- f(seq[i]) ) + tuck new-nth dup -30 shift bitxor 1812433253 * + + 1+ HEX: ffffffff bitand ; + +: init-mt-rest ( seq -- ) + mt-n 1- [0,b) [ + dupd [ init-mt-formula ] keep 1+ new-set-nth drop + ] with each ; + +: init-mt-seq ( seed -- seq ) + init-mt-first dup init-mt-rest ; + +: mt-temper ( y -- yt ) + dup -11 shift bitxor + dup 7 shift HEX: 9d2c5680 bitand bitxor + dup 15 shift HEX: efc60000 bitand bitxor + dup -18 shift bitxor ; inline + +PRIVATE> + +: ( seed -- obj ) + init-mt-seq 0 mersenne-twister construct-boa + dup mt-generate ; + +M: mersenne-twister seed-random ( mt seed -- ) + init-mt-seq >>seq drop ; + +M: mersenne-twister random-32 ( mt -- r ) + dup [ seq>> ] [ i>> ] bi + dup mt-n < [ drop 0 pick mt-generate ] unless + new-nth mt-temper + swap [ 1+ ] change-i drop ; + +[ millis \ random set-global ] "random" add-init-hook diff --git a/extra/random/summary.txt b/extra/random/mersenne-twister/summary.txt similarity index 100% rename from extra/random/summary.txt rename to extra/random/mersenne-twister/summary.txt diff --git a/extra/random/random-tests.factor b/extra/random/random-tests.factor deleted file mode 100644 index d431e57d01..0000000000 --- a/extra/random/random-tests.factor +++ /dev/null @@ -1,15 +0,0 @@ -USING: kernel math random namespaces sequences tools.test ; -IN: random.tests - -: check-random ( max -- ? ) - dup >r random 0 r> between? ; - -[ t ] [ 100 [ drop 674 check-random ] all? ] unit-test - -: make-100-randoms - [ 100 [ 100 random , ] times ] { } make ; - -[ f ] [ make-100-randoms make-100-randoms = ] unit-test - -[ 1333075495 ] [ 0 init-random 1000 [ drop (random) drop ] each (random) ] unit-test -[ 1575309035 ] [ 0 init-random 10000 [ drop (random) drop ] each (random) ] unit-test diff --git a/extra/random/random.factor b/extra/random/random.factor old mode 100755 new mode 100644 index db2aacd2b0..bbf54e21eb --- a/extra/random/random.factor +++ b/extra/random/random.factor @@ -1,107 +1,39 @@ -! Copyright (C) 2005, 2007 Doug Coleman. +! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. - -! 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 alien.c-types ; +USING: alien.c-types kernel math namespaces sequences +io.backend ; IN: random - mersenne-twister +: (random-bytes) ( tuple n -- byte-array ) + [ drop random-32 ] with map >c-uint-array ; -: mt-n 624 ; inline -: mt-m 397 ; inline -: mt-a HEX: 9908b0df ; inline -: mt-hi HEX: 80000000 ; inline -: mt-lo HEX: 7fffffff ; inline +DEFER: random -SYMBOL: mt +: random-bytes ( n -- r ) + [ + 4 /mod zero? [ 1+ ] unless + \ random get swap (random-bytes) + ] keep head ; -: mt-seq ( -- seq ) - mt get mersenne-twister-seq ; inline - -: mt-nth ( n -- nth ) - mt-seq nth ; inline - -: mt-i ( -- i ) - mt get mersenne-twister-i ; inline - -: mti-inc ( -- ) - mt get [ mersenne-twister-i 1+ ] keep set-mersenne-twister-i ; inline - -: set-mt-ith ( y i-get i-set -- ) - >r mt-nth >r - [ 2/ ] keep odd? mt-a 0 ? r> bitxor bitxor r> - mt-seq set-nth ; inline - -: mt-y ( y1 y2 -- y ) - mt-nth mt-lo bitand - >r mt-nth mt-hi bitand r> bitor ; inline - -: mod* ( x n -- y ) - #! no floating point - 2dup >= [ - ] [ drop ] if ; inline - -: (mt-generate) ( n -- y n n+(mt-m) ) - dup [ 1+ 624 mod* mt-y ] keep [ mt-m + 624 mod* ] keep ; - -: mt-generate ( -- ) - mt-n [ (mt-generate) set-mt-ith ] each - 0 mt get set-mersenne-twister-i ; - -: init-mt-first ( seed -- seq ) - >r mt-n 0 r> - HEX: ffffffff bitand 0 pick set-nth ; - -: init-mt-formula ( seq i -- f(seq[i]) ) - dup rot nth dup -30 shift bitxor - 1812433253 * + HEX: ffffffff bitand 1+ ; inline - -: init-mt-rest ( seq -- ) - mt-n 1 head* [ - [ init-mt-formula ] 2keep 1+ swap set-nth - ] with each ; - -: mt-temper ( y -- yt ) - dup -11 shift bitxor - dup 7 shift HEX: 9d2c5680 bitand bitxor - dup 15 shift HEX: efc60000 bitand bitxor - dup -18 shift bitxor ; inline - -PRIVATE> - -: init-random ( seed -- ) - global [ - dup init-mt-first - [ init-mt-rest ] keep - 0 mt set - mt-generate - ] bind ; - -: (random) ( -- rand ) - global [ - mt-i dup mt-n < [ drop mt-generate 0 ] unless - mt-nth mti-inc - mt-temper - ] bind ; - -: big-random ( n -- r ) - [ drop (random) ] map >c-uint-array byte-array>bignum ; - -: random-256 ( -- r ) 8 big-random ; inline +: random-bits ( n -- r ) 2^ random ; : random ( seq -- elt ) dup empty? [ drop f ] [ [ - length dup log2 31 + 32 /i big-random swap mod + length dup log2 7 + 8 /i + random-bytes byte-array>bignum swap mod ] keep nth ] if ; -[ millis init-random ] "random" add-init-hook +: with-random ( tuple quot -- ) + \ random swap with-variable ; inline diff --git a/extra/random/unix/unix.factor b/extra/random/unix/unix.factor new file mode 100644 index 0000000000..f41a3ae0e8 --- /dev/null +++ b/extra/random/unix/unix.factor @@ -0,0 +1,22 @@ +USING: alien.c-types io io.files io.nonblocking kernel +namespaces random io.encodings.binary singleton ; +IN: random.unix + +SINGLETON: unix-random + +: file-read-unbuffered ( n path -- bytes ) + over default-buffer-size [ + binary [ read ] with-stream + ] with-variable ; + +M: unix-random os-crypto-random-bytes ( n -- byte-array ) + "/dev/random" file-read-unbuffered ; + +M: unix-random os-random-bytes ( n -- byte-array ) + "/dev/urandom" file-read-unbuffered ; + +M: unix-random os-crypto-random-32 ( -- r ) + 4 os-crypto-random-bytes *uint ; + +M: unix-random os-random-32 ( -- r ) + 4 os-random-bytes *uint ; diff --git a/extra/random/windows/windows.factor b/extra/random/windows/windows.factor new file mode 100644 index 0000000000..8b3c1012c8 --- /dev/null +++ b/extra/random/windows/windows.factor @@ -0,0 +1,3 @@ +IN: random.windows + +! M: windows-io diff --git a/extra/smtp/smtp.factor b/extra/smtp/smtp.factor index a941b14a47..f7cdf9e64d 100755 --- a/extra/smtp/smtp.factor +++ b/extra/smtp/smtp.factor @@ -31,7 +31,7 @@ LOG: log-smtp-connection NOTICE ( addrspec -- ) : validate-address ( string -- string' ) #! Make sure we send funky stuff to the server by accident. dup "\r\n>" seq-intersect empty? - [ "Bad e-mail address: " swap append throw ] unless ; + [ "Bad e-mail address: " prepend throw ] unless ; : mail-from ( fromaddr -- ) "MAIL FROM:<" write validate-address write ">" write crlf ; @@ -89,7 +89,7 @@ LOG: smtp-response DEBUG : validate-header ( string -- string' ) dup "\r\n" seq-intersect empty? - [ "Invalid header string: " swap append throw ] unless ; + [ "Invalid header string: " prepend throw ] unless ; : write-header ( key value -- ) swap @@ -143,7 +143,7 @@ M: email clone dup to>> ", " join "To" set-header [ [ extract-email ] map ] change-to dup subject>> "Subject" set-header - now timestamp>rfc822-string "Date" set-header + now timestamp>rfc822 "Date" set-header message-id "Message-Id" set-header ; : ( -- email ) @@ -164,7 +164,7 @@ M: email clone ! : (cram-md5-auth) ( -- response ) ! swap challenge get ! string>md5-hmac hex-string -! " " swap append append +! " " prepend append ! >base64 ; ! ! : cram-md5-auth ( key login -- ) diff --git a/extra/strings/lib/lib.factor b/extra/strings/lib/lib.factor index 7f13cd58a9..c6299e6b08 100644 --- a/extra/strings/lib/lib.factor +++ b/extra/strings/lib/lib.factor @@ -7,7 +7,7 @@ IN: strings.lib : >Upper ( str -- str ) dup empty? [ - unclip ch>upper 1string swap append + unclip ch>upper 1string prepend ] unless ; : >Upper-dashes ( str -- str ) diff --git a/extra/tar/tar.factor b/extra/tar/tar.factor index 06e9644370..d1c4b148a5 100755 --- a/extra/tar/tar.factor +++ b/extra/tar/tar.factor @@ -89,12 +89,12 @@ TUPLE: unimplemented-typeflag header ; tar-header-typeflag 1string \ unimplemented-typeflag construct-boa ; -: tar-path+ ( path -- newpath ) - base-dir get swap path+ ; +: tar-append-path ( path -- newpath ) + base-dir get prepend-path ; ! Normal file : typeflag-0 - tar-header-name tar-path+ binary + tar-header-name tar-append-path binary [ read-data-blocks ] keep dispose ; ! Hard link @@ -115,7 +115,7 @@ TUPLE: unimplemented-typeflag header ; ! Directory : typeflag-5 ( header -- ) - tar-header-name tar-path+ make-directories ; + tar-header-name tar-append-path make-directories ; ! FIFO : typeflag-6 ( header -- ) @@ -166,7 +166,7 @@ TUPLE: unimplemented-typeflag header ; [ read-data-blocks ] keep >string [ zero? ] right-trim filename set global [ "long filename: " write filename get . flush ] bind - filename get tar-path+ make-directories ; + filename get tar-append-path make-directories ; ! Multi volume continuation entry : typeflag-M ( header -- ) @@ -226,7 +226,7 @@ TUPLE: unimplemented-typeflag header ; ! drop ! ] [ ! dup tar-header-name - ! dup parent-dir base-dir swap path+ + ! dup parent-dir base-dir prepend-path ! global [ dup [ . flush ] when* ] bind ! make-directories ! out-stream set diff --git a/extra/tools/deploy/backend/backend.factor b/extra/tools/deploy/backend/backend.factor index 60dc11257f..2476077ba9 100755 --- a/extra/tools/deploy/backend/backend.factor +++ b/extra/tools/deploy/backend/backend.factor @@ -79,9 +79,9 @@ IN: tools.deploy.backend "-run=tools.deploy.shaker" , - "-deploy-vocab=" swap append , + "-deploy-vocab=" prepend , - "-output-image=" swap append , + "-output-image=" prepend , strip-word-names? [ "-no-stack-traces" , ] when ] { } make diff --git a/extra/tools/deploy/config/config.factor b/extra/tools/deploy/config/config.factor index 78f1d487de..c527cb945c 100755 --- a/extra/tools/deploy/config/config.factor +++ b/extra/tools/deploy/config/config.factor @@ -66,7 +66,7 @@ SYMBOL: deploy-image } union ; : deploy-config-path ( vocab -- string ) - vocab-dir "deploy.factor" path+ ; + vocab-dir "deploy.factor" append-path ; : deploy-config ( vocab -- assoc ) dup default-config swap diff --git a/extra/tools/deploy/deploy-tests.factor b/extra/tools/deploy/deploy-tests.factor index 6d3385d0a4..3b88d14fb3 100755 --- a/extra/tools/deploy/deploy-tests.factor +++ b/extra/tools/deploy/deploy-tests.factor @@ -1,6 +1,7 @@ IN: tools.deploy.tests USING: tools.test system io.files kernel tools.deploy.config -tools.deploy.backend math sequences io.launcher arrays ; +tools.deploy.backend math sequences io.launcher arrays +namespaces ; : shake-and-bake ( vocab -- ) "." resource-path [ @@ -26,6 +27,10 @@ tools.deploy.backend math sequences io.launcher arrays ; [ ] [ "hello-ui" shake-and-bake ] unit-test +[ "staging.math-compiler-ui-strip.image" ] [ + "hello-ui" deploy-config [ staging-image-name ] bind +] unit-test + [ t ] [ 2000000 small-enough? ] unit-test diff --git a/extra/tools/deploy/macosx/macosx.factor b/extra/tools/deploy/macosx/macosx.factor index 6db19cf868..9fe35647fe 100755 --- a/extra/tools/deploy/macosx/macosx.factor +++ b/extra/tools/deploy/macosx/macosx.factor @@ -10,15 +10,15 @@ IN: tools.deploy.macosx vm parent-directory parent-directory ; : copy-bundle-dir ( bundle-name dir -- ) - bundle-dir over path+ -rot - "Contents" swap path+ path+ copy-tree ; + bundle-dir over append-path -rot + "Contents" prepend-path append-path copy-tree ; : copy-vm ( executable bundle-name -- vm ) - "Contents/MacOS/" path+ swap path+ vm over copy-file ; + "Contents/MacOS/" append-path prepend-path vm over copy-file ; : copy-fonts ( name -- ) "fonts/" resource-path - swap "Contents/Resources/" path+ copy-tree-into ; + swap "Contents/Resources/" append-path copy-tree-into ; : app-plist ( executable bundle-name -- string ) [ @@ -30,12 +30,12 @@ IN: tools.deploy.macosx file-name "CFBundleName" set dup "CFBundleExecutable" set - "org.factor." swap append "CFBundleIdentifier" set + "org.factor." prepend "CFBundleIdentifier" set ] H{ } make-assoc plist>string ; : create-app-plist ( vocab bundle-name -- ) [ app-plist ] keep - "Contents/Info.plist" path+ + "Contents/Info.plist" append-path utf8 set-file-contents ; : create-app-dir ( vocab bundle-name -- vm ) diff --git a/extra/tools/deploy/windows/windows.factor b/extra/tools/deploy/windows/windows.factor index 6a2ce448af..1c9a8195c5 100755 --- a/extra/tools/deploy/windows/windows.factor +++ b/extra/tools/deploy/windows/windows.factor @@ -6,7 +6,7 @@ prettyprint windows.shell32 windows.user32 ; IN: tools.deploy.windows : copy-vm ( executable bundle-name -- vm ) - swap path+ ".exe" append + prepend-path ".exe" append vm over copy-file ; : copy-fonts ( bundle-name -- ) @@ -23,7 +23,7 @@ IN: tools.deploy.windows copy-vm ; : image-name ( vocab bundle-name -- str ) - swap path+ ".image" append ; + prepend-path ".image" append ; TUPLE: windows-deploy-implementation ; diff --git a/extra/tools/vocabs/browser/browser.factor b/extra/tools/vocabs/browser/browser.factor index 2c66305d47..69ad9272a7 100755 --- a/extra/tools/vocabs/browser/browser.factor +++ b/extra/tools/vocabs/browser/browser.factor @@ -31,7 +31,7 @@ IN: tools.vocabs.browser ] with-row ; : root-heading. ( root -- ) - [ "Children from " swap append ] [ "Children" ] if* + [ "Children from " prepend ] [ "Children" ] if* $heading ; : vocabs. ( assoc -- ) @@ -127,7 +127,7 @@ C: vocab-author : $describe-vocab ( element -- ) first dup describe-children - dup vocab-root over vocab-dir? [ + dup find-vocab-root [ dup describe-summary dup describe-tags dup describe-authors @@ -195,7 +195,7 @@ M: vocab-tag summary article-title ; M: vocab-author >link ; M: vocab-author article-title - vocab-author-name "Vocabularies by " swap append ; + vocab-author-name "Vocabularies by " prepend ; M: vocab-author article-name vocab-author-name ; diff --git a/extra/tools/vocabs/vocabs.factor b/extra/tools/vocabs/vocabs.factor index 82c411cbfb..d7e1070666 100755 --- a/extra/tools/vocabs/vocabs.factor +++ b/extra/tools/vocabs/vocabs.factor @@ -6,29 +6,27 @@ memoize inspector sorting splitting combinators source-files io debugger continuations compiler.errors init io.crc32 ; IN: tools.vocabs -: vocab-tests-file, ( vocab -- ) - dup "-tests.factor" vocab-dir+ vocab-path+ - dup resource-exists? [ , ] [ drop ] if ; +: vocab-tests-file ( vocab -- path ) + dup "-tests.factor" vocab-dir+ vocab-append-path dup + [ dup resource-exists? [ drop f ] unless ] [ drop f ] if ; -: vocab-tests-dir, ( vocab -- ) - dup vocab-dir "tests" path+ vocab-path+ - dup resource-exists? [ - dup ?resource-path directory keys - [ ".factor" tail? ] subset - [ path+ , ] with each - ] [ drop ] if ; +: vocab-tests-dir ( vocab -- paths ) + dup vocab-dir "tests" append-path vocab-append-path dup [ + dup resource-exists? [ + dup ?resource-path directory keys + [ ".factor" tail? ] subset + [ append-path ] with map + ] [ drop f ] if + ] [ drop f ] if ; : vocab-tests ( vocab -- tests ) - dup vocab-root dup [ - [ - >vocab-link dup - vocab-tests-file, - vocab-tests-dir, - ] { } make - ] [ 2drop f ] if ; + [ + dup vocab-tests-file [ , ] when* + vocab-tests-dir [ % ] when* + ] { } make ; : vocab-files ( vocab -- seq ) - dup find-vocab-root >vocab-link [ + [ dup vocab-source-path [ , ] when* dup vocab-docs-path [ , ] when* vocab-tests % @@ -53,12 +51,8 @@ IN: tools.vocabs : modified-docs ( vocabs -- seq ) [ vocab-docs-path ] modified ; -: update-roots ( vocabs -- ) - [ dup find-vocab-root swap vocab set-vocab-root ] each ; - : to-refresh ( prefix -- modified-sources modified-docs ) child-vocabs - dup update-roots dup modified-sources swap modified-docs ; : vocab-heading. ( vocab -- ) @@ -109,10 +103,10 @@ MEMO: (vocab-file-contents) ( path -- lines ) [ utf8 file-lines ] [ drop f ] if ; : vocab-file-contents ( vocab name -- seq ) - vocab-path+ dup [ (vocab-file-contents) ] when ; + vocab-append-path dup [ (vocab-file-contents) ] when ; : set-vocab-file-contents ( seq vocab name -- ) - dupd vocab-path+ [ + dupd vocab-append-path [ ?resource-path utf8 set-file-lines ] [ "The " swap vocab-name @@ -121,7 +115,7 @@ MEMO: (vocab-file-contents) ( path -- lines ) ] ?if ; : vocab-summary-path ( vocab -- string ) - vocab-dir "summary.txt" path+ ; + vocab-dir "summary.txt" append-path ; : vocab-summary ( vocab -- summary ) dup dup vocab-summary-path vocab-file-contents @@ -147,7 +141,7 @@ M: vocab-link summary vocab-summary ; set-vocab-file-contents ; : vocab-tags-path ( vocab -- string ) - vocab-dir "tags.txt" path+ ; + vocab-dir "tags.txt" append-path ; : vocab-tags ( vocab -- tags ) dup vocab-tags-path vocab-file-contents ; @@ -159,7 +153,7 @@ M: vocab-link summary vocab-summary ; [ vocab-tags append prune ] keep set-vocab-tags ; : vocab-authors-path ( vocab -- string ) - vocab-dir "authors.txt" path+ ; + vocab-dir "authors.txt" append-path ; : vocab-authors ( vocab -- authors ) dup vocab-authors-path vocab-file-contents ; @@ -171,7 +165,7 @@ M: vocab-link summary vocab-summary ; directory [ second ] subset keys natural-sort ; : (all-child-vocabs) ( root name -- vocabs ) - [ vocab-dir path+ ?resource-path subdirs ] keep + [ vocab-dir append-path ?resource-path subdirs ] keep dup empty? [ drop ] [ @@ -180,7 +174,7 @@ M: vocab-link summary vocab-summary ; : vocabs-in-dir ( root name -- ) dupd (all-child-vocabs) [ - 2dup vocab-dir? [ 2dup swap >vocab-link , ] when + 2dup vocab-dir? [ dup >vocab-link , ] when vocabs-in-dir ] with each ; @@ -233,7 +227,7 @@ MEMO: all-vocabs-seq ( -- seq ) : unrooted-child-vocabs ( prefix -- seq ) dup empty? [ CHAR: . add ] unless vocabs - [ vocab-root not ] subset + [ find-vocab-root not ] subset [ vocab-name swap ?head CHAR: . rot member? not and ] with subset @@ -241,10 +235,9 @@ MEMO: all-vocabs-seq ( -- seq ) : all-child-vocabs ( prefix -- assoc ) vocab-roots get [ - over dupd dupd (all-child-vocabs) - swap [ >vocab-link ] curry map + dup pick (all-child-vocabs) [ >vocab-link ] map ] { } map>assoc - f rot unrooted-child-vocabs 2array add ; + swap unrooted-child-vocabs f swap 2array add ; : all-child-vocabs-seq ( prefix -- assoc ) vocab-roots get swap [ @@ -262,6 +255,7 @@ MEMO: all-authors ( -- seq ) all-vocabs-seq [ vocab-authors ] map>set ; : reset-cache ( -- ) + root-cache get-global clear-assoc \ (vocab-file-contents) reset-memoized \ all-vocabs-seq reset-memoized \ all-authors reset-memoized diff --git a/extra/tuple-arrays/tuple-arrays.factor b/extra/tuple-arrays/tuple-arrays.factor index 7a1df7ac1d..061deec6ec 100644 --- a/extra/tuple-arrays/tuple-arrays.factor +++ b/extra/tuple-arrays/tuple-arrays.factor @@ -15,7 +15,7 @@ TUPLE: tuple-array example ; [ set-tuple-array-example ] keep ; : reconstruct ( seq example -- tuple ) - swap append >tuple ; + prepend >tuple ; M: tuple-array nth [ delegate nth ] keep diff --git a/extra/ui/gadgets/lists/lists.factor b/extra/ui/gadgets/lists/lists.factor index 5fbe9ba0eb..3bac7969c5 100755 --- a/extra/ui/gadgets/lists/lists.factor +++ b/extra/ui/gadgets/lists/lists.factor @@ -27,7 +27,7 @@ TUPLE: list index presenter color hook ; swap set-list-index ; : list-presentation-hook ( list -- quot ) - list-hook [ [ [ list? ] is? ] find-parent ] swap append ; + list-hook [ [ [ list? ] is? ] find-parent ] prepend ; : ( hook elt presenter -- gadget ) keep diff --git a/extra/wrap/wrap.factor b/extra/wrap/wrap.factor index 41dea1bd13..a2ca25ce6e 100644 --- a/extra/wrap/wrap.factor +++ b/extra/wrap/wrap.factor @@ -29,4 +29,4 @@ SYMBOL: width broken-lines "\n" join ; : indented-break ( string width indent -- newstring ) - [ length - broken-lines ] keep [ swap append ] curry map "\n" join ; + [ length - broken-lines ] keep [ prepend ] curry map "\n" join ; diff --git a/extra/xmode/catalog/catalog.factor b/extra/xmode/catalog/catalog.factor index 6bff786fff..c7eaafe887 100755 --- a/extra/xmode/catalog/catalog.factor +++ b/extra/xmode/catalog/catalog.factor @@ -37,13 +37,13 @@ TAGS> MEMO: (load-mode) ( name -- rule-sets ) modes at mode-file - "extra/xmode/modes/" swap append + "extra/xmode/modes/" prepend resource-path utf8 parse-mode ; SYMBOL: rule-sets : no-such-rule-set ( name -- * ) - "No such rule set: " swap append throw ; + "No such rule set: " prepend throw ; : get-rule-set ( name -- rule-sets rules ) dup "::" split1 [ swap (load-mode) ] [ rule-sets get ] if*