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

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

db4
Slava Pestov 2008-03-19 21:26:13 -05:00
parent 27e87292f0 6f2369b16e
commit 4675811d68
112 changed files with 656 additions and 572 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
core/bootstrap/primitives.factor
View File

@ -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.

2
core/bootstrap/stage2.factor
View File

@ -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

1
core/bootstrap/syntax.factor
View File

@ -21,6 +21,7 @@ IN: bootstrap.syntax
"C:"
"CHAR:"
"DEFER:"
"ERROR:"
"F{"
"FV{"
"FORGET:"

12
core/classes/classes-tests.factor
View File

@ -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

2
core/classes/union/union.factor
View File

@ -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 ;

2
core/combinators/combinators.factor
View File

@ -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? [

4
core/command-line/command-line.factor
View File

@ -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 ;

2
core/compiler/tests/intrinsics.factor
View File

@ -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 <char> [ { byte-array } declare *char ] compile-call ] unit-test
[ 156 ] [ -100 <uchar> [ { byte-array } declare *uchar ] compile-call ] unit-test

2
core/generic/math/math.factor
View File

@ -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 ;

4
core/generic/standard/standard.factor
View File

@ -161,7 +161,7 @@ C: <hook-combination> 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 ;

26
core/io/encodings/encodings.factor
View File

@ -14,19 +14,26 @@ GENERIC: encode-char ( char stream encoding -- )
GENERIC: <decoder> ( stream decoding -- newstream )
GENERIC: <encoder> ( stream encoding -- newstream )
: replacement-char HEX: fffd ;
! Decoding
<PRIVATE
TUPLE: decoder stream code cr ;
TUPLE: decode-error ;
: decode-error ( -- * ) \ decode-error construct-empty throw ;
TUPLE: decoder stream code cr ;
GENERIC: <encoder> ( stream encoding -- newstream )
TUPLE: encoder stream code ;
TUPLE: encode-error ;
: encode-error ( -- * ) \ encode-error construct-empty throw ;
! Decoding
<PRIVATE
M: tuple-class <decoder> construct-empty <decoder> ;
M: tuple <decoder> 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 <encoder> construct-empty <encoder> ;
M: tuple <encoder> encoder construct-boa ;
@ -132,6 +133,7 @@ INSTANCE: encoder plain-writer
: redecode ( stream encoding -- newstream )
over decoder? [ >r decoder-stream r> ] when <decoder> ;
PRIVATE>
: <encoder-duplex> ( stream-in stream-out encoding -- duplex )

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

@ -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." } ;

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

@ -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 )

2
core/optimizer/specializers/specializers.factor
View File

@ -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 } = [

2
core/sequences/sequences.factor
View File

@ -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 -- )

5
core/syntax/syntax.factor
View File

@ -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

2
core/vocabs/loader/loader-docs.factor
View File

@ -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 } "." }

12
core/vocabs/loader/loader-tests.factor
View File

@ -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-link> vocab-files
"kernel" <vocab-link> 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 <vocab-link> run
"vocabs.loader.test.2" <vocab-link> 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 <vocab-link> where ] unit-test
[ "kernel" <vocab-link> 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 ;

66
core/vocabs/loader/loader.factor
View File

@ -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) ;
[
[

9
core/vocabs/vocabs-docs.factor
View File

@ -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 } "." } ;

21
core/vocabs/vocabs.factor
View File

@ -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 ;
: <vocab-link> ( name root -- vocab-link )
[ dup vocab-root ] unless* vocab-link construct-boa ;
: <vocab-link> ( 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 <vocab-link> ] if ;
UNION: vocab-spec vocab vocab-link ;
GENERIC: >vocab-link ( name -- vocab )
M: vocab-spec >vocab-link ;
M: string >vocab-link dup vocab [ ] [ <vocab-link> ] ?if ;
: forget-vocab ( vocab -- )
dup words forget-all
vocab-name dictionary get delete-at ;

8
extra/asn1/asn1.factor
View File

@ -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 ;
! =========================================================

2
extra/assocs/lib/lib.factor
View File

@ -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 )

2
extra/automata/automata.factor
View File

@ -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 ;

2
extra/bitfields/bitfields.factor
View File

@ -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 ;

2
extra/bootstrap/image/download/download.factor
View File

@ -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

8
extra/bootstrap/random/random.factor Normal file
View File

@ -0,0 +1,8 @@
USING: vocabs.loader sequences system ;
"random.mersenne-twister" require
{
{ [ windows? ] [ "random.windows" require ] }
{ [ unix? ] [ "random.unix" require ] }
} cond

2
extra/bootstrap/ui/tools/tools.factor
View File

@ -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 [

2
extra/bootstrap/ui/ui.factor
View File

@ -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

4
extra/builder/builder.factor
View File

@ -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 ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

2
extra/builder/release/release.factor
View File

@ -8,7 +8,7 @@ IN: builder.release
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: releases ( -- path )
builds "releases" path+
builds "releases" append-path
dup exists? not
[ dup make-directory ]
when ;

2
extra/calendar/backend/backend.factor
View File

@ -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 )

226
extra/calendar/calendar-tests.factor
View File

@ -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 <timestamp> valid-timestamp? ] unit-test
[ f ] [ 2004 2 30 0 0 0 0 <timestamp> valid-timestamp? ] unit-test
[ f ] [ 2003 2 29 0 0 0 0 <timestamp> valid-timestamp? ] unit-test
[ f ] [ 2004 -2 9 0 0 0 0 <timestamp> valid-timestamp? ] unit-test
[ f ] [ 2004 12 0 0 0 0 0 <timestamp> valid-timestamp? ] unit-test
[ f ] [ 2004 12 1 24 0 0 0 <timestamp> valid-timestamp? ] unit-test
[ f ] [ 2004 12 1 23 60 0 0 <timestamp> valid-timestamp? ] unit-test
[ f ] [ 2004 12 1 23 59 60 0 <timestamp> valid-timestamp? ] unit-test
[ f ] [ 2004 12 32 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
[ f ] [ 2004 2 30 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
[ f ] [ 2003 2 29 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
[ f ] [ 2004 -2 9 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
[ f ] [ 2004 12 0 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
[ f ] [ 2004 12 1 24 0 0 instant <timestamp> valid-timestamp? ] unit-test
[ f ] [ 2004 12 1 23 60 0 instant <timestamp> valid-timestamp? ] unit-test
[ f ] [ 2004 12 1 23 59 60 instant <timestamp> 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 <timestamp> 1 seconds time+
2006 10 10 0 0 1 0 <timestamp> = ] unit-test
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 100 seconds time+
2006 10 10 0 1 40 0 <timestamp> = ] unit-test
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> -100 seconds time+
2006 10 9 23 58 20 0 <timestamp> = ] unit-test
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 86400 seconds time+
2006 10 11 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 10 10 0 0 0 instant <timestamp> 1 seconds time+
2006 10 10 0 0 1 instant <timestamp> = ] unit-test
[ t ] [ 2006 10 10 0 0 0 instant <timestamp> 100 seconds time+
2006 10 10 0 1 40 instant <timestamp> = ] unit-test
[ t ] [ 2006 10 10 0 0 0 instant <timestamp> -100 seconds time+
2006 10 9 23 58 20 instant <timestamp> = ] unit-test
[ t ] [ 2006 10 10 0 0 0 instant <timestamp> 86400 seconds time+
2006 10 11 0 0 0 instant <timestamp> = ] unit-test
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 10 minutes time+
2006 10 10 0 10 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 10.5 minutes time+
2006 10 10 0 10 30 0 <timestamp> = ] unit-test
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 3/4 minutes time+
2006 10 10 0 0 45 0 <timestamp> = ] unit-test
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> -3/4 minutes time+
2006 10 9 23 59 15 0 <timestamp> = ] unit-test
[ t ] [ 2006 10 10 0 0 0 instant <timestamp> 10 minutes time+
2006 10 10 0 10 0 instant <timestamp> = ] unit-test
[ t ] [ 2006 10 10 0 0 0 instant <timestamp> 10.5 minutes time+
2006 10 10 0 10 30 instant <timestamp> = ] unit-test
[ t ] [ 2006 10 10 0 0 0 instant <timestamp> 3/4 minutes time+
2006 10 10 0 0 45 instant <timestamp> = ] unit-test
[ t ] [ 2006 10 10 0 0 0 instant <timestamp> -3/4 minutes time+
2006 10 9 23 59 15 instant <timestamp> = ] unit-test
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 7200 minutes time+
2006 10 15 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> -10 minutes time+
2006 10 9 23 50 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> -100 minutes time+
2006 10 9 22 20 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 10 10 0 0 0 instant <timestamp> 7200 minutes time+
2006 10 15 0 0 0 instant <timestamp> = ] unit-test
[ t ] [ 2006 10 10 0 0 0 instant <timestamp> -10 minutes time+
2006 10 9 23 50 0 instant <timestamp> = ] unit-test
[ t ] [ 2006 10 10 0 0 0 instant <timestamp> -100 minutes time+
2006 10 9 22 20 0 instant <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 1 hours time+
2006 1 1 1 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 24 hours time+
2006 1 2 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -24 hours time+
2005 12 31 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 12 hours time+
2006 1 1 12 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 72 hours time+
2006 1 4 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 1 hours time+
2006 1 1 1 0 0 instant <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 24 hours time+
2006 1 2 0 0 0 instant <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> -24 hours time+
2005 12 31 0 0 0 instant <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 12 hours time+
2006 1 1 12 0 0 instant <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 72 hours time+
2006 1 4 0 0 0 instant <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 1 days time+
2006 1 2 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -1 days time+
2005 12 31 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 365 days time+
2007 1 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -365 days time+
2005 1 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2004 1 1 0 0 0 0 <timestamp> 365 days time+
2004 12 31 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2004 1 1 0 0 0 0 <timestamp> 366 days time+
2005 1 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 1 days time+
2006 1 2 0 0 0 instant <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> -1 days time+
2005 12 31 0 0 0 instant <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 365 days time+
2007 1 1 0 0 0 instant <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> -365 days time+
2005 1 1 0 0 0 instant <timestamp> = ] unit-test
[ t ] [ 2004 1 1 0 0 0 instant <timestamp> 365 days time+
2004 12 31 0 0 0 instant <timestamp> = ] unit-test
[ t ] [ 2004 1 1 0 0 0 instant <timestamp> 366 days time+
2005 1 1 0 0 0 instant <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 11 months time+
2006 12 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 12 months time+
2007 1 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 24 months time+
2008 1 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 13 months time+
2007 2 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 1 months time+
2006 2 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 0 months time+
2006 1 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -1 months time+
2005 12 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -2 months time+
2005 11 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -13 months time+
2004 12 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -24 months time+
2004 1 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2004 2 29 0 0 0 0 <timestamp> 12 months time+
2005 3 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2004 2 29 0 0 0 0 <timestamp> -12 months time+
2003 3 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 11 months time+
2006 12 1 0 0 0 instant <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 12 months time+
2007 1 1 0 0 0 instant <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 24 months time+
2008 1 1 0 0 0 instant <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 13 months time+
2007 2 1 0 0 0 instant <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 1 months time+
2006 2 1 0 0 0 instant <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 0 months time+
2006 1 1 0 0 0 instant <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> -1 months time+
2005 12 1 0 0 0 instant <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> -2 months time+
2005 11 1 0 0 0 instant <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> -13 months time+
2004 12 1 0 0 0 instant <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> -24 months time+
2004 1 1 0 0 0 instant <timestamp> = ] unit-test
[ t ] [ 2004 2 29 0 0 0 instant <timestamp> 12 months time+
2005 3 1 0 0 0 instant <timestamp> = ] unit-test
[ t ] [ 2004 2 29 0 0 0 instant <timestamp> -12 months time+
2003 3 1 0 0 0 instant <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 0 years time+
2006 1 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 1 years time+
2007 1 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -1 years time+
2005 1 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -100 years time+
1906 1 1 0 0 0 0 <timestamp> = ] unit-test
! [ t ] [ 2004 2 29 0 0 0 0 <timestamp> -1 years time+
! 2003 2 28 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 0 years time+
2006 1 1 0 0 0 instant <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 1 years time+
2007 1 1 0 0 0 instant <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> -1 years time+
2005 1 1 0 0 0 instant <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> -100 years time+
1906 1 1 0 0 0 instant <timestamp> = ] unit-test
! [ t ] [ 2004 2 29 0 0 0 instant <timestamp> -1 years time+
! 2003 2 28 0 0 0 instant <timestamp> = ] unit-test
[ 5 ] [ 2006 7 14 0 0 0 0 <timestamp> day-of-week ] unit-test
[ 5 ] [ 2006 7 14 0 0 0 instant <timestamp> day-of-week ] unit-test
[ t ] [ 2006 7 14 [ julian-day-number julian-day-number>date 0 0 0 0 <timestamp> ] 3keep 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 7 14 [ julian-day-number julian-day-number>date 0 0 0 instant <timestamp> ] 3keep 0 0 0 instant <timestamp> = ] unit-test
[ 1 ] [ 2006 1 1 0 0 0 0 <timestamp> day-of-year ] unit-test
[ 60 ] [ 2004 2 29 0 0 0 0 <timestamp> day-of-year ] unit-test
[ 61 ] [ 2004 3 1 0 0 0 0 <timestamp> day-of-year ] unit-test
[ 366 ] [ 2004 12 31 0 0 0 0 <timestamp> day-of-year ] unit-test
[ 365 ] [ 2003 12 31 0 0 0 0 <timestamp> day-of-year ] unit-test
[ 60 ] [ 2003 3 1 0 0 0 0 <timestamp> day-of-year ] unit-test
[ 1 ] [ 2006 1 1 0 0 0 instant <timestamp> day-of-year ] unit-test
[ 60 ] [ 2004 2 29 0 0 0 instant <timestamp> day-of-year ] unit-test
[ 61 ] [ 2004 3 1 0 0 0 instant <timestamp> day-of-year ] unit-test
[ 366 ] [ 2004 12 31 0 0 0 instant <timestamp> day-of-year ] unit-test
[ 365 ] [ 2003 12 31 0 0 0 instant <timestamp> day-of-year ] unit-test
[ 60 ] [ 2003 3 1 0 0 0 instant <timestamp> day-of-year ] unit-test
[ t ] [ 2004 12 31 0 0 0 0 <timestamp> dup = ] unit-test
[ t ] [ 2004 1 1 0 0 0 0 <timestamp> 10 seconds 5 years time+ time+
2009 1 1 0 0 10 0 <timestamp> = ] unit-test
[ t ] [ 2004 1 1 0 0 0 0 <timestamp> -10 seconds -5 years time+ time+
1998 12 31 23 59 50 0 <timestamp> = ] unit-test
[ t ] [ 2004 12 31 0 0 0 instant <timestamp> dup = ] unit-test
[ t ] [ 2004 1 1 0 0 0 instant <timestamp> 10 seconds 5 years time+ time+
2009 1 1 0 0 10 instant <timestamp> = ] unit-test
[ t ] [ 2004 1 1 0 0 0 instant <timestamp> -10 seconds -5 years time+ time+
1998 12 31 23 59 50 instant <timestamp> = ] unit-test
[ t ] [ 2004 1 1 23 0 0 12 <timestamp> 0 convert-timezone
2004 1 1 11 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2004 1 1 5 0 0 -11 <timestamp> 0 convert-timezone
2004 1 1 16 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2004 1 1 23 0 0 9+1/2 <timestamp> 0 convert-timezone
2004 1 1 13 30 0 0 <timestamp> = ] unit-test
[ t ] [ 2004 1 1 23 0 0 12 hours <timestamp> >gmt
2004 1 1 11 0 0 instant <timestamp> = ] unit-test
[ t ] [ 2004 1 1 5 0 0 -11 hours <timestamp> >gmt
2004 1 1 16 0 0 instant <timestamp> = ] unit-test
[ t ] [ 2004 1 1 23 0 0 9+1/2 hours <timestamp> >gmt
2004 1 1 13 30 0 instant <timestamp> = ] unit-test
[ 0 ] [ 2004 1 1 13 30 0 0 <timestamp>
2004 1 1 12 30 0 -1 <timestamp> <=> ] unit-test
[ 0 ] [ 2004 1 1 13 30 0 instant <timestamp>
2004 1 1 12 30 0 -1 hours <timestamp> <=> ] unit-test
[ 1 ] [ 2004 1 1 13 30 0 0 <timestamp>
2004 1 1 12 30 0 0 <timestamp> <=> ] unit-test
[ 1 ] [ 2004 1 1 13 30 0 instant <timestamp>
2004 1 1 12 30 0 instant <timestamp> <=> ] unit-test
[ -1 ] [ 2004 1 1 12 30 0 0 <timestamp>
2004 1 1 13 30 0 0 <timestamp> <=> ] unit-test
[ -1 ] [ 2004 1 1 12 30 0 instant <timestamp>
2004 1 1 13 30 0 instant <timestamp> <=> ] unit-test
[ 1 ] [ 2005 1 1 12 30 0 0 <timestamp>
2004 1 1 13 30 0 0 <timestamp> <=> ] unit-test
[ 1 ] [ 2005 1 1 12 30 0 instant <timestamp>
2004 1 1 13 30 0 instant <timestamp> <=> ] unit-test
[ t ] [ now timestamp>millis millis - 1000 < ] unit-test
[ t ] [ 0 millis>timestamp unix-1970 = ] unit-test

29
extra/calendar/calendar.factor
View File

@ -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> timestamp
: <date> ( year month day -- timestamp )
0 0 0 gmt-offset <timestamp> ;
TUPLE: duration year month day hour minute second ;
C: <duration> duration
: gmt-offset-duration ( -- duration )
0 0 0 gmt-offset <duration> ;
: <date> ( year month day -- timestamp )
0 0 0 gmt-offset-duration <timestamp> ;
: 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+ ;
: <zero> 0 0 0 0 0 0 0 <timestamp> ;
: <zero> 0 0 0 0 0 0 instant <timestamp> ;
: valid-timestamp? ( timestamp -- ? )
clone 0 >>gmt-offset
clone instant >>gmt-offset
dup <zero> time- <zero> time+ = ;
: unix-1970 ( -- timestamp )
1970 1 1 0 0 0 0 <timestamp> ; foldable
1970 1 1 0 0 0 instant <timestamp> ; foldable
: millis>timestamp ( n -- timestamp )
>r unix-1970 r> milliseconds time+ ;

6
extra/calendar/format/format-tests.factor
View File

@ -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

36
extra/calendar/format/format.factor
View File

@ -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

11
extra/calendar/unix/unix.factor
View File

@ -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 <uint> 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 ;

14
extra/calendar/windows/windows.factor
View File

@ -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" <c-object>
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 ;

2
extra/channels/remote/remote.factor
View File

@ -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 ;

4
extra/cocoa/messages/messages.factor
View File

@ -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) ;

4
extra/combinators/cleave/cleave.factor
View File

@ -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 ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

22
extra/combinators/lib/lib.factor
View File

@ -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 ;

2
extra/concurrency/messaging/messaging.factor
View File

@ -40,7 +40,7 @@ M: thread send ( message thread -- )
TUPLE: synchronous data sender tag ;
: <synchronous> ( data -- sync )
self random-256 synchronous construct-boa ;
self 256 random-bits synchronous construct-boa ;
TUPLE: reply data tag ;

2
extra/core-foundation/core-foundation.factor
View File

@ -83,7 +83,7 @@ FUNCTION: void CFRelease ( void* cf ) ;
dup <CFBundle> [
CFBundleLoadExecutable drop
] [
"Cannot load bundled named " swap append throw
"Cannot load bundled named " prepend throw
] ?if ;
FUNCTION: CFRunLoopRef CFRunLoopGetMain ( ) ;

30
extra/cpu/8080/emulator/emulator.factor
View File

@ -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

36
extra/crypto/blum-blum-shub.factor
View File

@ -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 <bbs> ;
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 ;

4
extra/db/sqlite/sqlite.factor
View File

@ -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 <delete-tuple-statement> ( 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 <select-by-slots-statement> ( tuple class -- statement )
[

2
extra/db/types/types.factor
View File

@ -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 -- )

2
extra/documents/documents.factor
View File

@ -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 ;

2
extra/editors/editpadpro/editpadpro.factor
View File

@ -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* ;

2
extra/editors/editplus/editplus.factor
View File

@ -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 -- )

2
extra/editors/emeditor/emeditor.factor
View File

@ -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 -- )

2
extra/editors/gvim/windows/windows.factor
View File

@ -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* ;

4
extra/editors/jedit/jedit.factor
View File

@ -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 -- )

2
extra/editors/notepadpp/notepadpp.factor
View File

@ -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 -- )

2
extra/editors/scite/scite.factor
View File

@ -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 )

2
extra/editors/ted-notepad/ted-notepad.factor
View File

@ -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 -- )

2
extra/editors/ultraedit/ultraedit.factor
View File

@ -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 -- )

2
extra/editors/wordpad/wordpad.factor
View File

@ -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 -- )

2
extra/faq/faq.factor
View File

@ -79,7 +79,7 @@ C: <faq> 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 -- )

2
extra/help/help.factor
View File

@ -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

2
extra/help/markup/markup.factor
View File

@ -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 -- )
[

6
extra/html/elements/elements.factor
View File

@ -38,7 +38,7 @@ IN: html.elements
! <a =href a> "Click me" write </a>
!
! (url -- )
! <a "http://" swap append =href a> "click" write </a>
! <a "http://" prepend =href a> "click" write </a>
!
! (url -- )
! <a [ "http://" % % ] "" make =href a> "click" write </a>
@ -72,7 +72,7 @@ SYMBOL: html
dup <foo> swap [ <foo> write-html ] curry
empty-effect html-word ;
: <foo "<" swap append ;
: <foo "<" prepend ;
: def-for-html-word-<foo ( name -- )
#! Return the name and code for the <foo patterned
@ -134,7 +134,7 @@ SYMBOL: html
: attribute-effect T{ effect f { "string" } 0 } ;
: define-attribute-word ( name -- )
dup "=" swap append swap
dup "=" prepend swap
[ write-attr ] curry attribute-effect html-word ;
[

2
extra/http/client/client.factor
View File

@ -12,7 +12,7 @@ DEFER: http-request
: parse-url ( url -- resource host port )
"http://" ?head [ "Only http:// supported" throw ] unless
"/" split1 [ "/" swap append ] [ "/" ] if*
"/" split1 [ "/" prepend ] [ "/" ] if*
swap parse-host ;
: store-path ( request path -- request )

4
extra/http/server/actions/actions-tests.factor
View File

@ -27,8 +27,8 @@ blah
] unit-test
<action>
[ +path+ get "xxx" get "X" <repetition> concat append ] >>submit
{ { +path+ [ ] } { "xxx" [ v-number ] } } >>post-params
[ +append-path get "xxx" get "X" <repetition> concat append ] >>submit
{ { +append-path [ ] } { "xxx" [ v-number ] } } >>post-params
"action-2" set
STRING: action-request-test-2

4
extra/http/server/actions/actions.factor
View File

@ -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 ] }

2
extra/http/server/auth/providers/providers.factor
View File

@ -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

2
extra/http/server/components/components.factor
View File

@ -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 -- )

4
extra/http/server/static/static.factor
View File

@ -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 )

2
extra/http/server/templating/fhtml/fhtml-tests.factor
View File

@ -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

2
extra/http/server/validators/validators.factor
View File

@ -59,7 +59,7 @@ C: <validation-error> 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

4
extra/io/encodings/utf16/utf16.factor
View File

@ -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* ;

4
extra/io/files/unique/unique.factor
View File

@ -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 ;

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

@ -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> [

6
extra/io/timeouts/timeouts.factor
View File

@ -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 ;

8
extra/io/windows/nt/files/files.factor
View File

@ -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 ;

6
extra/io/windows/nt/nt-tests.factor
View File

@ -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

6
extra/koszul/koszul.factor
View File

@ -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 <array> add
[ v- ] 2map ;

2
extra/locals/locals.factor
View File

@ -180,7 +180,7 @@ M: block lambda-rewrite*
#! Turn free variables into bound variables, curry them
#! onto the body
dup free-vars [ <quote> ] map dup % [
over block-vars swap append
over block-vars prepend
swap block-body [ [ lambda-rewrite* ] each ] [ ] make
swap point-free ,
] keep length \ curry <repetition> % ;

4
extra/logging/server/server.factor
View File

@ -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

2
extra/math/haar/haar.factor
View File

@ -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 ;

2
extra/math/miller-rabin/miller-rabin.factor
View File

@ -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 )

4
extra/new-slots/new-slots.factor
View File

@ -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? [

2
extra/optimizer/debugger/debugger.factor
View File

@ -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 ;

2
extra/project-euler/002/002.factor
View File

@ -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 ;

2
extra/project-euler/035/035.factor
View File

@ -34,7 +34,7 @@ IN: project-euler.035
] if ;
: rotate ( seq n -- seq )
cut* swap append ;
cut* prepend ;
: (circular?) ( seq n -- ? )
dup 0 > [

4
extra/project-euler/project-euler.factor
View File

@ -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
] [

36
extra/random/blum-blum-shub/blum-blum-shub.factor Normal file
View File

@ -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> 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
: <blum-blum-shub> ( 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 )
;

11
extra/random/dummy/dummy.factor Normal file
View File

@ -0,0 +1,11 @@
USING: kernel random math new-slots accessors ;
IN: random.dummy
TUPLE: random-dummy i ;
C: <random-dummy> random-dummy
M: random-dummy seed-random ( seed obj -- )
(>>i) ;
M: random-dummy random-32 ( obj -- r )
[ dup 1+ ] change-i drop ;

0
extra/random/authors.txt → extra/random/mersenne-twister/authors.txt
View File

10
extra/random/random-docs.factor → extra/random/mersenne-twister/mersenne-twister-docs.factor.bak
View File

@ -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" } }

30
extra/random/mersenne-twister/mersenne-twister-tests.factor Normal file
View File

@ -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 <mersenne-twister> 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

80
extra/random/mersenne-twister/mersenne-twister.factor Executable file
View File

@ -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
<PRIVATE
: new-nth ( seq i -- elt ) swap nth ; inline
: new-set-nth ( seq obj n -- seq ) pick set-nth ; inline
TUPLE: mersenne-twister seq i ;
: mt-n 624 ; inline
: mt-m 397 ; inline
: mt-a HEX: 9908b0df ; inline
: mt-hi HEX: 80000000 bitand ; inline
: mt-lo HEX: 7fffffff bitand ; inline
: wrap ( x n -- y ) 2dup >= [ - ] [ 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 <array> 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>
: <mersenne-twister> ( 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 <mersenne-twister> \ random set-global ] "random" add-init-hook

0
extra/random/summary.txt → extra/random/mersenne-twister/summary.txt
View File

15
extra/random/random-tests.factor
View File

@ -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

112
extra/random/random.factor Executable file → Normal file
View File

@ -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
<PRIVATE
HOOK: os-crypto-random-bytes io-backend ( n -- byte-array )
HOOK: os-random-bytes io-backend ( n -- byte-array )
HOOK: os-crypto-random-32 io-backend ( -- r )
HOOK: os-random-32 io-backend ( -- r )
TUPLE: mersenne-twister seed seq i ;
GENERIC: seed-random ( tuple seed -- )
GENERIC: random-32 ( tuple -- r )
C: <mersenne-twister> 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 <array> 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 <mersenne-twister> 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

22
extra/random/unix/unix.factor Normal file
View File

@ -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 <file-reader> [ 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 ;

3
extra/random/windows/windows.factor Normal file
View File

@ -0,0 +1,3 @@
IN: random.windows
! M: windows-io

8
extra/smtp/smtp.factor
View File

@ -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> ( -- 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 -- )

2
extra/strings/lib/lib.factor
View File

@ -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 )

Some files were not shown because too many files have changed in this diff Show More