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

core/bootstrap/image/image-tests.factor

@@ -1,6 +1,5 @@
 IN: temporary
-USING: bootstrap.image bootstrap.image.private
+USING: bootstrap.image bootstrap.image.private tools.test ;
-tools.test.inference ;
 
 \ ' must-infer
 \ write-image must-infer

core/bootstrap/image/image.factor

@@ -10,6 +10,23 @@ definitions debugger float-arrays quotations.private
 combinators.private combinators ;
 IN: bootstrap.image
 
+: my-arch ( -- arch )
+    cpu dup "ppc" = [ os "-" rot 3append ] when ;
+
+: boot-image-name ( arch -- string )
+    "boot." swap ".image" 3append ;
+
+: my-boot-image-name ( -- string )
+    my-arch boot-image-name ;
+
+: images ( -- seq )
+    {
+        "x86.32"
+        "x86.64"
+        "linux-ppc" "macosx-ppc"
+        ! "arm"
+    } ;
+
 <PRIVATE
 
 ! Constants
@@ -394,9 +411,6 @@ M: curry '
         [ >le write ] curry each
     ] if ;
 
-: image-name
-    "boot." architecture get ".image" 3append resource-path ;
-
 : write-image ( image filename -- )
     "Writing image to " write dup write "..." print flush
     <file-writer> [ (write-image) ] with-stream ;
@@ -415,16 +429,10 @@ PRIVATE>
         begin-image
         "resource:/core/bootstrap/stage1.factor" run-file
         end-image
-        image get image-name write-image
+        image get
+        architecture get boot-image-name resource-path
+        write-image
     ] with-variable ;
 
-: my-arch ( -- arch )
-    cpu dup "ppc" = [ os "-" rot 3append ] when ;
-
 : make-images ( -- )
-    {
+    images [ make-image ] each ;
-        "x86.32"
-        "x86.64"
-        "linux-ppc" "macosx-ppc"
-        ! "arm"
-    } [ make-image ] each ;

core/compiler/test/alien.factor

@@ -3,7 +3,7 @@ USING: alien alien.c-types alien.syntax compiler kernel
 namespaces namespaces tools.test sequences inference words
 arrays parser quotations continuations inference.backend effects
 namespaces.private io io.streams.string memory system threads
-tools.test.inference ;
+tools.test ;
 
 FUNCTION: void ffi_test_0 ;
 [ ] [ ffi_test_0 ] unit-test
@@ -80,7 +80,7 @@ FUNCTION: tiny ffi_test_17 int x ;
 : indirect-test-1
     "int" { } "cdecl" alien-indirect ;
 
-{ 1 1 } [ indirect-test-1 ] unit-test-effect
+{ 1 1 } [ indirect-test-1 ] must-infer-as
 
 [ 3 ] [ "ffi_test_1" f dlsym indirect-test-1 ] unit-test
 
@@ -89,7 +89,7 @@ FUNCTION: tiny ffi_test_17 int x ;
 : indirect-test-2
     "int" { "int" "int" } "cdecl" alien-indirect data-gc ;
 
-{ 3 1 } [ indirect-test-2 ] unit-test-effect
+{ 3 1 } [ indirect-test-2 ] must-infer-as
 
 [ 5 ]
 [ 2 3 "ffi_test_2" f dlsym indirect-test-2 ]

core/compiler/test/redefine.factor

@@ -1,6 +1,6 @@
 USING: compiler definitions generic assocs inference math
 namespaces parser tools.test words kernel sequences arrays io
-effects tools.test.inference compiler.units inference.state ;
+effects tools.test compiler.units inference.state ;
 IN: temporary
 
 DEFER: x-1
@@ -28,13 +28,13 @@ DEFER: c
 
 [ 1 2 1 2 ] [ "USE: temporary b" eval ] unit-test
 
-{ 0 4 } [ b ] unit-test-effect
+{ 0 4 } [ b ] must-infer-as
 
 [ ] [ "IN: temporary : a 1 2 3 ;" eval ] unit-test
 
 [ 1 2 3 1 2 3 ] [ "USE: temporary b" eval ] unit-test
 
-{ 0 6 } [ b ] unit-test-effect
+{ 0 6 } [ b ] must-infer-as
 
 \ b word-xt "b-xt" set
 
@@ -52,7 +52,7 @@ DEFER: c
 
 [ ] [ "IN: temporary : a 1 2 ;" eval ] unit-test
 
-{ 0 4 } [ c ] unit-test-effect
+{ 0 4 } [ c ] must-infer-as
 
 [ f ] [ "c-xt" get \ c word-xt = ] unit-test
 

core/inference/inference-docs.factor

@@ -73,6 +73,12 @@ $nl
 { $subsection infer-quot-value }
 "The " { $vocab-link "macros" } " vocabulary defines some nice syntax sugar which makes compiler transforms easier to work with." ;
 
+ARTICLE: "dataflow-graphs" "Inspecting the dataflow graph"
+"The dataflow graph used by " { $link "compiler" } " can be obtained:"
+{ $subsection dataflow }
+"The " { $vocab-link "optimizer.debugger" } " tool prints the dataflow graph in human readable form."
+$nl ;
+
 ARTICLE: "inference" "Stack effect inference"
 "The stack effect inference tool is used to check correctness of code before it is run. It is also used by the compiler to build a dataflow graph on which optimizations can be performed. Only words for which a stack effect can be inferred will compile."
 $nl
@@ -80,14 +86,15 @@ $nl
 { $subsection infer. }
 "Instead of printing the inferred information, it can be returned as objects on the stack:"
 { $subsection infer }
-"The dataflow graph used by " { $link "compiler" } " can be obtained:"
+"Static stack effect inference can be combined with unit tests; see " { $link "tools.test.write" } "."
-{ $subsection dataflow }
+$nl
 "The following articles describe the implementation of the stack effect inference algorithm:"
 { $subsection "inference-simple" }
 { $subsection "inference-combinators" }
 { $subsection "inference-branches" }
 { $subsection "inference-recursive" } 
 { $subsection "inference-limitations" } 
+{ $subsection "dataflow-graphs" }
 { $subsection "compiler-transforms" } ;
 
 ABOUT: "inference"

core/inference/inference-tests.factor

@@ -4,23 +4,22 @@ math.parser math.private namespaces namespaces.private parser
 sequences strings vectors words quotations effects tools.test
 continuations generic.standard sorting assocs definitions
 prettyprint io inspector tuples classes.union classes.predicate
-debugger threads.private io.streams.string combinators.private
+debugger threads.private io.streams.string combinators.private ;
-tools.test.inference ;
 IN: temporary
 
-{ 0 2 } [ 2 "Hello" ] unit-test-effect
+{ 0 2 } [ 2 "Hello" ] must-infer-as
-{ 1 2 } [ dup ] unit-test-effect
+{ 1 2 } [ dup ] must-infer-as
 
-{ 1 2 } [ [ dup ] call ] unit-test-effect
+{ 1 2 } [ [ dup ] call ] must-infer-as
 [ [ call ] infer ] must-fail
 
-{ 2 4 } [ 2dup ] unit-test-effect
+{ 2 4 } [ 2dup ] must-infer-as
 
-{ 1 0 } [ [ ] [ ] if ] unit-test-effect
+{ 1 0 } [ [ ] [ ] if ] must-infer-as
 [ [ if ] infer ] must-fail
 [ [ [ ] if ] infer ] must-fail
 [ [ [ 2 ] [ ] if ] infer ] must-fail
-{ 4 3 } [ [ rot ] [ -rot ] if ] unit-test-effect
+{ 4 3 } [ [ rot ] [ -rot ] if ] must-infer-as
 
 { 4 3 } [
     [
@@ -28,17 +27,17 @@ IN: temporary
     ] [
         -rot
     ] if
-] unit-test-effect
+] must-infer-as
 
-{ 1 1 } [ dup [ ] when ] unit-test-effect
+{ 1 1 } [ dup [ ] when ] must-infer-as
-{ 1 1 } [ dup [ dup fixnum* ] when ] unit-test-effect
+{ 1 1 } [ dup [ dup fixnum* ] when ] must-infer-as
-{ 2 1 } [ [ dup fixnum* ] when ] unit-test-effect
+{ 2 1 } [ [ dup fixnum* ] when ] must-infer-as
 
-{ 1 0 } [ [ drop ] when* ] unit-test-effect
+{ 1 0 } [ [ drop ] when* ] must-infer-as
-{ 1 1 } [ [ { { [ ] } } ] unless* ] unit-test-effect
+{ 1 1 } [ [ { { [ ] } } ] unless* ] must-infer-as
 
 { 0 1 }
-[ [ 2 2 fixnum+ ] dup [ ] when call ] unit-test-effect
+[ [ 2 2 fixnum+ ] dup [ ] when call ] must-infer-as
 
 [
     [ [ [ 2 2 fixnum+ ] ] [ [ 2 2 fixnum* ] ] if call ] infer
@@ -50,7 +49,7 @@ IN: temporary
 
 : termination-test-2 [ termination-test-1 ] [ 3 ] if ;
 
-{ 1 1 } [ termination-test-2 ] unit-test-effect
+{ 1 1 } [ termination-test-2 ] must-infer-as
 
 : infinite-loop infinite-loop ;
 
@@ -62,12 +61,12 @@ IN: temporary
 : simple-recursion-1 ( obj -- obj )
     dup [ simple-recursion-1 ] [ ] if ;
 
-{ 1 1 } [ simple-recursion-1 ] unit-test-effect
+{ 1 1 } [ simple-recursion-1 ] must-infer-as
 
 : simple-recursion-2 ( obj -- obj )
     dup [ ] [ simple-recursion-2 ] if ;
 
-{ 1 1 } [ simple-recursion-2 ] unit-test-effect
+{ 1 1 } [ simple-recursion-2 ] must-infer-as
 
 : bad-recursion-2 ( obj -- obj )
     dup [ dup first swap second bad-recursion-2 ] [ ] if ;
@@ -77,10 +76,10 @@ IN: temporary
 : funny-recursion ( obj -- obj )
     dup [ funny-recursion 1 ] [ 2 ] if drop ;
 
-{ 1 1 } [ funny-recursion ] unit-test-effect
+{ 1 1 } [ funny-recursion ] must-infer-as
 
 ! Simple combinators
-{ 1 2 } [ [ first ] keep second ] unit-test-effect
+{ 1 2 } [ [ first ] keep second ] must-infer-as
 
 ! Mutual recursion
 DEFER: foe
@@ -103,8 +102,8 @@ DEFER: foe
         2drop f
     ] if ;
 
-{ 2 1 } [ fie ] unit-test-effect
+{ 2 1 } [ fie ] must-infer-as
-{ 2 1 } [ foe ] unit-test-effect
+{ 2 1 } [ foe ] must-infer-as
 
 : nested-when ( -- )
     t [
@@ -113,7 +112,7 @@ DEFER: foe
         ] when
     ] when ;
 
-{ 0 0 } [ nested-when ] unit-test-effect
+{ 0 0 } [ nested-when ] must-infer-as
 
 : nested-when* ( obj -- )
     [
@@ -122,11 +121,11 @@ DEFER: foe
         ] when*
     ] when* ;
 
-{ 1 0 } [ nested-when* ] unit-test-effect
+{ 1 0 } [ nested-when* ] must-infer-as
 
 SYMBOL: sym-test
 
-{ 0 1 } [ sym-test ] unit-test-effect
+{ 0 1 } [ sym-test ] must-infer-as
 
 : terminator-branch
     dup [
@@ -135,7 +134,7 @@ SYMBOL: sym-test
         "foo" throw
     ] if ;
 
-{ 1 1 } [ terminator-branch ] unit-test-effect
+{ 1 1 } [ terminator-branch ] must-infer-as
 
 : recursive-terminator ( obj -- )
     dup [
@@ -144,7 +143,7 @@ SYMBOL: sym-test
         "Hi" throw
     ] if ;
 
-{ 1 0 } [ recursive-terminator ] unit-test-effect
+{ 1 0 } [ recursive-terminator ] must-infer-as
 
 GENERIC: potential-hang ( obj -- obj )
 M: fixnum potential-hang dup [ potential-hang ] when ;
@@ -157,24 +156,24 @@ M: funny-cons iterate funny-cons-cdr iterate ;
 M: f iterate drop ;
 M: real iterate drop ;
 
-{ 1 0 } [ iterate ] unit-test-effect
+{ 1 0 } [ iterate ] must-infer-as
 
 ! Regression
 : cat ( obj -- * ) dup [ throw ] [ throw ] if ;
 : dog ( a b c -- ) dup [ cat ] [ 3drop ] if ;
-{ 3 0 } [ dog ] unit-test-effect
+{ 3 0 } [ dog ] must-infer-as
 
 ! Regression
 DEFER: monkey
 : friend ( a b c -- ) dup [ friend ] [ monkey ] if ;
 : monkey ( a b c -- ) dup [ 3drop ] [ friend ] if ;
-{ 3 0 } [ friend ] unit-test-effect
+{ 3 0 } [ friend ] must-infer-as
 
 ! Regression -- same as above but we infer the second word first
 DEFER: blah2
 : blah ( a b c -- ) dup [ blah ] [ blah2 ] if ;
 : blah2 ( a b c -- ) dup [ blah ] [ 3drop ] if ;
-{ 3 0 } [ blah2 ] unit-test-effect
+{ 3 0 } [ blah2 ] must-infer-as
 
 ! Regression
 DEFER: blah4
@@ -182,7 +181,7 @@ DEFER: blah4
     dup [ blah3 ] [ dup [ blah4 ] [ blah3 ] if ] if ;
 : blah4 ( a b c -- )
     dup [ blah4 ] [ dup [ 3drop ] [ blah3 ] if ] if ;
-{ 3 0 } [ blah4 ] unit-test-effect
+{ 3 0 } [ blah4 ] must-infer-as
 
 ! Regression
 : bad-combinator ( obj quot -- )
@@ -199,7 +198,7 @@ DEFER: blah4
     dup string? [ 2array throw ] unless
     over string? [ 2array throw ] unless ;
 
-{ 2 2 } [ bad-input# ] unit-test-effect
+{ 2 2 } [ bad-input# ] must-infer-as
 
 ! Regression
 
@@ -218,7 +217,7 @@ DEFER: do-crap*
 ! Regression
 : too-deep ( a b -- c )
     dup [ drop ] [ 2dup too-deep too-deep * ] if ; inline
-{ 2 1 } [ too-deep ] unit-test-effect
+{ 2 1 } [ too-deep ] must-infer-as
 
 ! Error reporting is wrong
 MATH: xyz
@@ -258,17 +257,17 @@ DEFER: C
         [ dup B C ]
     } dispatch ;
 
-{ 1 0 } [ A ] unit-test-effect
+{ 1 0 } [ A ] must-infer-as
-{ 1 0 } [ B ] unit-test-effect
+{ 1 0 } [ B ] must-infer-as
-{ 1 0 } [ C ] unit-test-effect
+{ 1 0 } [ C ] must-infer-as
 
 ! I found this bug by thinking hard about the previous one
 DEFER: Y
 : X ( a b -- c d ) dup [ swap Y ] [ ] if ;
 : Y ( a b -- c d ) X ;
 
-{ 2 2 } [ X ] unit-test-effect
+{ 2 2 } [ X ] must-infer-as
-{ 2 2 } [ Y ] unit-test-effect
+{ 2 2 } [ Y ] must-infer-as
 
 ! This one comes from UI code
 DEFER: #1
@@ -332,9 +331,9 @@ DEFER: bar
 [ [ get-slots ] infer ] [ inference-error? ] must-fail-with
 
 ! Test some curry stuff
-{ 1 1 } [ 3 [ ] curry 4 [ ] curry if ] unit-test-effect
+{ 1 1 } [ 3 [ ] curry 4 [ ] curry if ] must-infer-as
 
-{ 2 1 } [ [ ] curry 4 [ ] curry if ] unit-test-effect
+{ 2 1 } [ [ ] curry 4 [ ] curry if ] must-infer-as
 
 [ [ 3 [ ] curry 1 2 [ ] 2curry if ] infer ] must-fail
 
@@ -381,7 +380,7 @@ DEFER: bar
 \ assoc-like must-infer
 \ assoc-clone-like must-infer
 \ >alist must-infer
-{ 1 3 } [ [ 2drop f ] assoc-find ] unit-test-effect
+{ 1 3 } [ [ 2drop f ] assoc-find ] must-infer-as
 
 ! Test some random library words
 \ 1quotation must-infer
@@ -404,10 +403,10 @@ DEFER: bar
 \ define-predicate-class must-infer
 
 ! Test words with continuations
-{ 0 0 } [ [ drop ] callcc0 ] unit-test-effect
+{ 0 0 } [ [ drop ] callcc0 ] must-infer-as
-{ 0 1 } [ [ 4 swap continue-with ] callcc1 ] unit-test-effect
+{ 0 1 } [ [ 4 swap continue-with ] callcc1 ] must-infer-as
-{ 2 1 } [ [ + ] [ ] [ ] cleanup ] unit-test-effect
+{ 2 1 } [ [ + ] [ ] [ ] cleanup ] must-infer-as
-{ 2 1 } [ [ + ] [ 3drop 0 ] recover ] unit-test-effect
+{ 2 1 } [ [ + ] [ 3drop 0 ] recover ] must-infer-as
 
 \ dispose must-infer
 
@@ -450,13 +449,13 @@ DEFER: bar
 [ [ barxxx ] infer ] must-fail
 
 ! A typo
-{ 1 0 } [ { [ ] } dispatch ] unit-test-effect
+{ 1 0 } [ { [ ] } dispatch ] must-infer-as
 
 DEFER: inline-recursive-2
 : inline-recursive-1 ( -- ) inline-recursive-2 ;
 : inline-recursive-2 ( -- ) inline-recursive-1 ;
 
-{ 0 0 } [ inline-recursive-1 ] unit-test-effect
+{ 0 0 } [ inline-recursive-1 ] must-infer-as
 
 ! Hooks
 SYMBOL: my-var
@@ -465,22 +464,22 @@ HOOK: my-hook my-var ( -- x )
 M: integer my-hook "an integer" ;
 M: string my-hook "a string" ;
 
-{ 0 1 } [ my-hook ] unit-test-effect
+{ 0 1 } [ my-hook ] must-infer-as
 
 DEFER: deferred-word
 
 : calls-deferred-word [ deferred-word ] [ 3 ] if ;
 
-{ 1 1 } [ calls-deferred-word ] unit-test-effect
+{ 1 1 } [ calls-deferred-word ] must-infer-as
 
 USE: inference.dataflow
 
-{ 1 0 } [ [ iterate-next ] iterate-nodes ] unit-test-effect
+{ 1 0 } [ [ iterate-next ] iterate-nodes ] must-infer-as
 
 { 1 0 }
 [
     [ [ iterate-next ] iterate-nodes ] with-node-iterator
-] unit-test-effect
+] must-infer-as
 
 : nilpotent ( quot -- )
     t [ [ call ] keep nilpotent ] [ drop ] if ; inline
@@ -490,11 +489,11 @@ USE: inference.dataflow
 
 { 0 1 }
 [ [ ] [ call ] keep [ [ call ] keep ] nilpotent ]
-unit-test-effect
+must-infer-as
 
-{ 0 0 } [ [ ] semisimple ] unit-test-effect
+{ 0 0 } [ [ ] semisimple ] must-infer-as
 
-{ 1 0 } [ [ drop ] each-node ] unit-test-effect
+{ 1 0 } [ [ drop ] each-node ] must-infer-as
 
 DEFER: an-inline-word
 
@@ -510,9 +509,9 @@ DEFER: an-inline-word
 : an-inline-word ( obj quot -- )
     >r normal-word r> call ; inline
 
-{ 1 1 } [ [ 3 * ] an-inline-word ] unit-test-effect
+{ 1 1 } [ [ 3 * ] an-inline-word ] must-infer-as
 
-{ 0 1 } [ [ 2 ] [ 2 ] [ + ] compose compose call ] unit-test-effect
+{ 0 1 } [ [ 2 ] [ 2 ] [ + ] compose compose call ] must-infer-as
 
 TUPLE: custom-error ;
 
@@ -536,4 +535,4 @@ TUPLE: custom-error ;
 
 ! This was a false trigger of the undecidable quotation
 ! recursion bug
-{ 2 1 } [ find-last-sep ] unit-test-effect
+{ 2 1 } [ find-last-sep ] must-infer-as

core/inference/transforms/transforms-tests.factor

@@ -1,6 +1,6 @@
 IN: temporary
 USING: sequences inference.transforms tools.test math kernel
-quotations tools.test.inference inference ;
+quotations inference ;
 
 : compose-n-quot <repetition> >quotation ;
 : compose-n compose-n-quot call ;

core/io/files/files.factor

@@ -173,3 +173,12 @@ PRIVATE>
 
 : file-contents ( path -- str )
     dup <file-reader> swap file-length <sbuf> [ stream-copy ] keep >string ;
+
+: with-file-in ( path quot -- )
+    >r <file-reader> r> with-stream ; inline
+
+: with-file-out ( path quot -- )
+    >r <file-writer> r> with-stream ; inline
+
+: with-file-appender ( path quot -- )
+    >r <file-appender> r> with-stream ; inline

core/math/parser/parser-docs.factor

@@ -25,14 +25,10 @@ $nl
 ABOUT: "number-strings"
 
 HELP: digits>integer
-{ $values { "radix" "an integer between 2 and 36" } { "seq" "a sequence of integers" } { "n" integer } }
+{ $values { "seq" "a sequence of integers" } { "radix" "an integer between 2 and 36" } { "n" integer } }
 { $description "Converts a sequence of digits (with most significant digit first) into an integer." }
 { $notes "This is one of the factors of " { $link string>number } "." } ;
 
-HELP: valid-digits?
-{ $values { "radix" "an integer between 2 and 36" } { "seq" "a sequence of integers" } { "?" "a boolean" } }
-{ $description "Tests if this sequence of integers represents a valid integer in the given radix." } ;
-
 HELP: >digit
 { $values { "n" "an integer between 0 and 35" } { "ch" "a character" } }
 { $description "Outputs a character representation of a digit." }
@@ -43,11 +39,6 @@ HELP: digit>
 { $description "Converts a character representation of a digit to an integer." }
 { $notes "This is one of the factors of " { $link string>number } "." } ;
 
-HELP: string>integer
-{ $values { "str" string } { "radix" "an integer between 2 and 36" } { "n/f" "an integer or " { $link f } } }
-{ $description "Creates an integer from a string representation." }
-{ $notes "The " { $link base> } " word is more general." } ;
-
 HELP: base>
 { $values { "str" string } { "radix" "an integer between 2 and 36" } { "n/f" "a real number or " { $link f } } }
 { $description "Creates a real number from a string representation with the given radix. The radix is ignored for floating point literals; they are always taken to be in base 10."

core/math/parser/parser-tests.factor

@@ -95,16 +95,6 @@ unit-test
 
 [ f ] [ "\0." string>number ] unit-test
 
-! [ t ] [
-!     { "1.0/0.0" "-1.0/0.0" "0.0/0.0" }
-!     [ dup string>number number>string = ] all?
-! ] unit-test
-! 
-! [ t ] [
-!     { 1.0/0.0 -1.0/0.0 0.0/0.0 }
-!     [ dup number>string string>number = ] all?
-! ] unit-test
-
 [ 1 1 >base ] must-fail
 [ 1 0 >base ] must-fail
 [ 1 -1 >base ] must-fail

core/math/parser/parser.factor

@@ -4,12 +4,6 @@ USING: kernel math.private namespaces sequences strings arrays
 combinators splitting math assocs ;
 IN: math.parser
 
-DEFER: base>
-
-: string>ratio ( str radix -- a/b )
-    >r "/" split1 r> tuck base> >r base> r>
-    2dup and [ / ] [ 2drop f ] if ;
-
 : digit> ( ch -- n )
     H{
         { CHAR: 0 0 }
@@ -36,30 +30,54 @@ DEFER: base>
         { CHAR: f 15 }
     } at ;
 
-: digits>integer ( radix seq -- n )
-    0 rot [ swapd * + ] curry reduce ;
-
-: valid-digits? ( radix seq -- ? )
-    {
-        { [ dup empty? ] [ 2drop f ] }
-        { [ f over memq? ] [ 2drop f ] }
-        { [ t ] [ swap [ < ] curry all? ] }
-    } cond ;
-
 : string>digits ( str -- digits )
     [ digit> ] { } map-as ;
 
-: string>integer ( str radix -- n/f )
+: digits>integer ( seq radix -- n )
-    swap "-" ?head >r
+    0 swap [ swapd * + ] curry reduce ;
-    string>digits 2dup valid-digits?
+
-    [ digits>integer r> [ neg ] when ] [ r> 3drop f ] if ;
+DEFER: base>
+
+<PRIVATE
+
+SYMBOL: radix
+
+: with-radix ( radix quot -- )
+    radix swap with-variable ; inline
+
+: (base>) ( str -- n ) radix get base> ;
+
+: whole-part ( str -- m n )
+    "+" split1 >r (base>) r>
+    dup [ (base>) ] [ drop 0 swap ] if ;
+
+: string>ratio ( str -- a/b )
+    "/" split1 (base>) >r whole-part r>
+    3dup and and [ / + ] [ 3drop f ] if ;
+
+: valid-digits? ( seq -- ? )
+    {
+        { [ dup empty? ] [ drop f ] }
+        { [ f over memq? ] [ drop f ] }
+        { [ t ] [ radix get [ < ] curry all? ] }
+    } cond ;
+
+: string>integer ( str -- n/f )
+    string>digits dup valid-digits?
+    [ radix get digits>integer ] [ drop f ] if ;
+
+PRIVATE>
 
 : base> ( str radix -- n/f )
+    [
+        "-" ?head >r
         {
-        { [ CHAR: / pick member? ] [ string>ratio ] }
+            { [ CHAR: / over member? ] [ string>ratio ] }
-        { [ CHAR: . pick member? ] [ drop string>float ] }
+            { [ CHAR: . over member? ] [ string>float ] }
             { [ t ] [ string>integer ] }
-    } cond ;
+        } cond
+        r> [ dup [ neg ] when ] when
+    ] with-radix ;
 
 : string>number ( str -- n/f ) 10 base> ;
 : bin> ( str -- n/f ) 2 base> ;
@@ -74,8 +92,16 @@ DEFER: base>
     dup >r /mod >digit , dup 0 >
     [ r> integer, ] [ r> 2drop ] if ;
 
+PRIVATE>
+
 GENERIC# >base 1 ( n radix -- str )
 
+<PRIVATE
+
+: (>base) ( n -- str ) radix get >base ;
+
+PRIVATE>
+
 M: integer >base
     [
         over 0 < [
@@ -87,10 +113,15 @@ M: integer >base
 
 M: ratio >base
     [
-        over numerator over >base %
+        [
-        CHAR: / ,
+            dup 0 < [ "-" % neg ] when
-        swap denominator swap >base %
+            1 /mod
-    ] "" make ;
+            >r dup zero? [ drop ] [ (>base) % "+" % ] if r>
+            dup numerator (>base) %
+            "/" %
+            denominator (>base) %
+        ] "" make
+    ] with-radix ;
 
 : fix-float ( str -- newstr )
     {

core/syntax/syntax-docs.factor

@@ -47,11 +47,13 @@ ARTICLE: "syntax-integers" "Integer syntax"
 "More information on integers can be found in " { $link "integers" } "." ;
 
 ARTICLE: "syntax-ratios" "Ratio syntax"
-"The printed representation of a ratio is a pair of integers separated by a slash (/). No intermediate whitespace is permitted. Either integer may be signed, however the ratio will be normalized into a form where the denominator is positive and the greatest common divisor of the two terms is 1."
+"The printed representation of a ratio is a pair of integers separated by a slash (/), prefixed by an optional whole number part followed by a plus (+). No intermediate whitespace is permitted. Here are some examples:"
 { $code
     "75/33"
     "1/10"
     "-5/-6"
+    "1+1/3"
+    "-10+1/7"
 }
 "More information on ratios can be found in " { $link "rationals" } ;
 

core/vocabs/loader/loader-docs.factor

@@ -124,11 +124,6 @@ HELP: refresh
 { $values { "prefix" string } }
 { $description "Reloads source files and documentation belonging to loaded vocabularies whose names are prefixed by " { $snippet "prefix" } " which have been modified on disk." } ;
 
-HELP: require-all-error
-{ $values { "vocabs" "a sequence of vocabularies" } }
-{ $description "Throws a " { $link require-all-error } "." }
-{ $error-description "Thrown by " { $link require-all } " if one or more vocabulary failed to load." } ;
-
 HELP: refresh-all
 { $description "Reloads source files and documentation for all loaded vocabularies which have been modified on disk." } ;
 

core/vocabs/loader/loader.factor

@@ -148,38 +148,37 @@ SYMBOL: load-help?
     dup update-roots
     dup modified-sources swap modified-docs ;
 
-: load-error. ( vocab error -- )
+: vocab-heading. ( vocab -- )
-    "==== " write >r
+    nl
-    dup vocab-name swap f >vocab-link write-object ":" print nl
+    "==== " write
-    r> print-error ;
+    dup vocab-name swap f >vocab-link write-object ":" print
+    nl ;
 
-TUPLE: require-all-error vocabs ;
+: load-error. ( triple -- )
+    dup first vocab-heading.
+    dup second print-error
+    drop ;
+    ! third "Traceback" swap write-object ;
 
-: require-all-error ( vocabs -- )
+: load-failures. ( failures -- )
-    [ vocab-name ] map
+    [ load-error. nl ] each ;
-    \ require-all-error construct-boa throw ;
 
-M: require-all-error summary
+: require-all ( vocabs -- failures )
-    drop "The require-all operation failed" ;
-
-: require-all ( vocabs -- )
-    dup length 1 = [ first require ] [
     [
         [
-                [ [ require ] [ 2array , ] recover ] each
+            [
+                [ require ]
+                [ error-continuation get 3array , ]
+                recover
+            ] each
         ] { } make
-            dup empty? [ drop ] [
+    ] with-compiler-errors ;
-                dup [ nl load-error. ] assoc-each
-                keys require-all-error
-            ] if
-        ] with-compiler-errors
-    ] if ;
 
 : do-refresh ( modified-sources modified-docs -- )
     2dup
     [ f swap set-vocab-docs-loaded? ] each
     [ f swap set-vocab-source-loaded? ] each
-    append prune require-all ;
+    append prune require-all load-failures. ;
 
 : refresh ( prefix -- ) to-refresh do-refresh ;
 

extra/asn1/tags.txt

@@ -0,0 +1 @@
+enterprise

extra/benchmark/bootstrap2/bootstrap2.factor

@@ -1,4 +1,4 @@
-USING: io.files io.launcher system tools.deploy.backend
+USING: io.files io.launcher system bootstrap.image
 namespaces sequences kernel ;
 IN: benchmark.bootstrap2
 
@@ -6,7 +6,7 @@ IN: benchmark.bootstrap2
     "." resource-path cd
     [
         vm ,
-        "-i=" boot-image-name append ,
+        "-i=" my-boot-image-name append ,
         "-output-image=foo.image" ,
         "-no-user-init" ,
     ] { } make run-process drop ;

extra/bootstrap/image/download/download.factor

@@ -0,0 +1,25 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: bootstrap.image.download
+USING: http.client crypto.md5 splitting assocs kernel io.files
+bootstrap.image sequences io ;
+
+: url "http://factorcode.org/images/latest/" ;
+
+: download-checksums ( -- alist )
+    url "checksums.txt" append http-get
+    string-lines [ " " split1 ] { } map>assoc ;
+
+: need-new-image? ( image -- ? )
+    dup exists?
+    [ dup file>md5str swap download-checksums at = not ]
+    [ drop t ] if ;
+
+: download-image ( arch -- )
+    boot-image-name dup need-new-image? [
+        "Downloading " write dup write "..." print
+        url swap append download
+    ] [
+        "Boot image up to date" print
+        drop
+    ] if ;

extra/bootstrap/image/download/summary.txt

@@ -0,0 +1 @@
+Smart image downloader utility which first checks MD5 checksum

extra/bootstrap/image/upload/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

extra/bootstrap/image/upload/summary.txt

@@ -0,0 +1 @@
+Image upload utility

extra/bootstrap/image/upload/upload.factor

@@ -0,0 +1,25 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: bootstrap.image.upload
+USING: http.client crypto.md5 splitting assocs kernel io.files
+bootstrap.image sequences io namespaces io.launcher math ;
+
+: destination "slava@factorcode.org:www/images/latest/" ;
+
+: boot-image-names images [ boot-image-name ] map ;
+
+: compute-checksums ( -- )
+    "checksums.txt" [
+        boot-image-names [ dup write bl file>md5str print ] each
+    ] with-file-out ;
+
+: upload-images ( -- )
+    [
+        "scp" , boot-image-names % "checksums.txt" , destination ,
+    ] { } make run-process
+    wait-for-process zero? [ "Upload failed" throw ] unless ;
+
+: new-images ( -- )
+    make-images compute-checksums upload-images ;
+
+MAIN: new-images

extra/builder/builder.factor

@@ -8,6 +8,15 @@ IN: builder
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
+: runtime ( quot -- time ) benchmark nip ;
+
+: log-runtime ( quot file -- )
+  >r runtime r> <file-writer> [ . ] with-stream ;
+
+: log-object ( object file -- ) <file-writer> [ . ] with-stream ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
 : datestamp ( -- string )
   now `{ ,[ dup timestamp-year   ]
          ,[ dup timestamp-month  ]
@@ -40,7 +49,7 @@ SYMBOL: builder-recipients
 : factor-binary ( -- name )
   os
   { { "macosx" [ "./Factor.app/Contents/MacOS/factor" ] }
-    { "windows" [ "./factor-nt.exe" ] }
+    { "winnt" [ "./factor-nt.exe" ] }
     [ drop "./factor" ] }
   case ;
 
@@ -56,7 +65,14 @@ VAR: stamp
 
   "/builds/factor" cd
   
-  { "git" "pull" "--no-summary" "git://factorcode.org/git/factor.git" }
+  {
+    "git"
+    "pull"
+    "--no-summary"
+    "git://factorcode.org/git/factor.git"
+    ! "http://dharmatech.onigirihouse.com/factor.git"
+    "master"
+  }
   run-process process-status
   0 =
   [ ]
@@ -69,14 +85,12 @@ VAR: stamp
   "/builds/" stamp> append make-directory
   "/builds/" stamp> append cd
 
-  { "git" "clone" "/builds/factor" } run-process drop
+  { "git" "clone" "../factor" } run-process drop
 
   "factor" cd
 
-  { "git" "show" } <process-stream>
+  { "git" "show" } <process-stream> [ readln ] with-stream " " split second
-  [ readln ] with-stream
+  "../git-id" log-object
-  " " split second
-  "../git-id" <file-writer> [ print ] with-stream
 
   { "make" "clean" } run-process drop
 
@@ -106,9 +120,7 @@ VAR: stamp
      { +stdout+   "../boot-log" }
      { +stderr+   +stdout+ }
    }
-  >hashtable
+  >hashtable [ run-process ] "../boot-time" log-runtime process-status
-  [ run-process process-status ]
-  benchmark nip "../boot-time" <file-writer> [ . ] with-stream
   0 =
   [ ]
   [
@@ -116,20 +128,17 @@ VAR: stamp
     "builder: bootstrap" throw
   ] if
 
-  `{
+  `{ ,[ factor-binary ] "-run=builder.test" } run-process drop
-     { +arguments+
+  
-       { ,[ factor-binary ] "-e=USE: tools.browser load-everything" } }
+  "../load-everything-log" exists?
-     { +stdout+    "../load-everything-log" }
+  [ "builder: load-everything" "../load-everything-log" email-file ]
-     { +stderr+    +stdout+ }
+  when
-   }
+
-  >hashtable [ run-process process-status ] benchmark nip
+  "../failing-tests" exists?
-  "../load-everything-time" <file-writer> [ . ] with-stream
+  [ "builder: failing tests" "../failing-tests" email-file ]
-  0 =
+  when
-  [ ]
+
-  [
+  ;
-    "builder: load-everything" "../load-everything-log" email-file
-    "builder: load-everything" throw
-  ] if ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 

extra/builder/test/test.factor

@@ -0,0 +1,36 @@
+
+USING: kernel sequences assocs builder continuations vocabs vocabs.loader
+       io
+       io.files
+       tools.browser
+       tools.test ;
+
+IN: builder.test
+
+: do-load ( -- )
+  [
+    [ load-everything ]
+    [ require-all-error-vocabs "../load-everything-log" log-object ]
+    recover
+  ]
+  "../load-everything-time" log-runtime ;
+
+: do-tests ( -- )
+  "" child-vocabs
+  [ vocab-source-loaded? ] subset
+  [ vocab-tests-path ] map
+  [ dup [ ?resource-path exists? ] when ] subset
+  [ dup run-test ] { } map>assoc
+  [ second empty? not ] subset
+  dup empty?
+  [ drop ]
+  [
+    "../failing-tests" <file-writer>
+      [ [ nl failures. ] assoc-each ]
+    with-stream
+  ]
+  if ;
+
+: do-all ( -- ) do-load do-tests ;
+
+MAIN: do-all

extra/calendar/calendar.factor

@@ -349,13 +349,29 @@ M: timestamp year. ( timestamp -- )
 : timestamp>string ( timestamp -- str )
     [ (timestamp>string) ] string-out ;
 
+: (write-gmt-offset) ( ratio -- )
+    1 /mod swap write-00 60 * write-00 ;
+
+: write-gmt-offset ( gmt-offset -- )
+    {
+        { [ dup zero? ] [ drop "GMT" write ] }
+        { [ dup 0 < ] [ "-" write neg (write-gmt-offset) ] }
+        { [ dup 0 > ] [ "+" write (write-gmt-offset) ] }
+    } cond ;
+
+: timestamp>rfc822-string ( timestamp -- str )
+    #! RFC822 timestamp format
+    #! Example: Tue, 15 Nov 1994 08:12:31 +0200
+    [
+        dup (timestamp>string)
+        " " write
+        timestamp-gmt-offset write-gmt-offset
+    ] string-out ;
+
 : timestamp>http-string ( timestamp -- str )
     #! http timestamp format
     #! Example: Tue, 15 Nov 1994 08:12:31 GMT
-    >gmt [
+    >gmt timestamp>rfc822-string ;
-        (timestamp>string)
-        " GMT" write
-    ] string-out ;
 
 : (timestamp>rfc3339) ( timestamp -- )
     dup timestamp-year number>string write CHAR: - write1

extra/calendar/windows/windows.factor

@@ -6,8 +6,10 @@ TUPLE: windows-calendar ;
 
 T{ windows-calendar } calendar-backend set-global
 
+: TIME_ZONE_ID_INVALID HEX: ffffffff ; inline
+
 M: windows-calendar gmt-offset ( -- float )
     "TIME_ZONE_INFORMATION" <c-object>
-    [ GetTimeZoneInformation win32-error=0/f ] keep
+    dup GetTimeZoneInformation
-    [ TIME_ZONE_INFORMATION-Bias ] keep
+    TIME_ZONE_ID_INVALID = [ win32-error ] when
-    TIME_ZONE_INFORMATION-DaylightBias + 60 /f neg ;
+    TIME_ZONE_INFORMATION-Bias 60 / neg ;

extra/combinators/lib/lib-tests.factor

@@ -1,5 +1,5 @@
 USING: combinators.lib kernel math math.ranges random sequences
-tools.test tools.test.inference continuations arrays vectors ;
+tools.test continuations arrays vectors ;
 IN: temporary
 
 [ 5 ] [ [ 10 random ] [ 5 = ] generate ] unit-test

extra/concurrency/distributed/distributed.factor

@@ -14,7 +14,7 @@ C: <node> node
 
 : node-server ( port -- )
     internet-server
-    "concurrency"
+    "concurrency.distributed"
     [ handle-node-client ] with-server ;
 
 : send-to-node ( msg pid  host port -- )

extra/crypto/sha1/sha1.factor

@@ -48,14 +48,13 @@ SYMBOL: K
 ! f(t;B,C,D) = (B AND C) OR (B AND D) OR (C AND D)  (40 <= t <= 59)
 ! f(t;B,C,D) = B XOR C XOR D                        (60 <= t <= 79)
 : sha1-f ( B C D t -- f_tbcd )
-    #! Maybe use dispatch
     20 /i
     {   
-        { [ dup 0 = ] [ drop >r over bitnot r> bitand >r bitand r> bitor ] }
+        { 0 [ >r over bitnot r> bitand >r bitand r> bitor ] }
-        { [ dup 1 = ] [ drop bitxor bitxor ] }
+        { 1 [ bitxor bitxor ] }
-        { [ dup 2 = ] [ drop 2dup bitand >r pick bitand >r bitand r> r> bitor bitor ] }
+        { 2 [ 2dup bitand >r pick bitand >r bitand r> r> bitor bitor ] }
-        { [ dup 3 = ] [ drop bitxor bitxor ] }
+        { 3 [ bitxor bitxor ] }
-    } cond ;
+    } case ;
 
 : make-w ( str -- )
     #! compute w, steps a-b of RFC 3174, section 6.1

extra/db/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

extra/db/summary.txt

@@ -0,0 +1 @@
+Relational database abstraction layer

extra/db/tags.txt

@@ -0,0 +1 @@
+enterprise

extra/furnace/tags.txt

@@ -0,0 +1 @@
+enterprise

extra/http/client/client.factor

@@ -47,32 +47,31 @@ DEFER: http-get-stream
         dispose "location" swap peek-at nip http-get-stream
     ] when ;
 
+: default-timeout 60 1000 * over set-timeout ;
+
 : http-get-stream ( url -- code headers stream )
     #! Opens a stream for reading from an HTTP URL.
     parse-url over parse-host <inet> <client> [
         [ [ get-request read-response ] with-stream* ] keep
+        default-timeout
     ] [ ] [ dispose ] cleanup do-redirect ;
 
-: http-get ( url -- code headers string )
+: success? ( code -- ? ) 200 = ;
-    #! Opens a stream for reading from an HTTP URL.
+
-    [
+: check-response ( code headers stream -- stream )
-        http-get-stream [ stdio get contents ] with-stream
+    nip swap success?
-    ] with-scope ;
+    [ dispose "HTTP download failed" throw ] unless ;
+
+: http-get ( url -- string )
+    http-get-stream check-response contents ;
 
 : download-name ( url -- name )
     file-name "?" split1 drop "/" ?tail drop ;
 
-: default-timeout 60 1000 * over set-timeout ;
-
-: success? ( code -- ? ) 200 = ;
-
 : download-to ( url file -- )
     #! Downloads the contents of a URL to a file.
-    >r http-get-stream nip default-timeout swap success? [
+    >r http-get-stream check-response
-        r> <file-writer> stream-copy
+    r> <file-writer> stream-copy ;
-    ] [
-        r> drop dispose "HTTP download failed" throw
-    ] if ;
 
 : download ( url -- )
     dup download-name download-to ;

extra/http/server/responders/responders.factor

@@ -1,8 +1,8 @@
-! Copyright (C) 2004, 2007 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays assocs hashtables html html.elements splitting
 http io kernel math math.parser namespaces parser sequences
-strings io.server vectors assocs.lib ;
+strings io.server vectors assocs.lib logging ;
 
 IN: http.server.responders
 
@@ -22,7 +22,7 @@ SYMBOL: responders
     <html> <body> <h1> write </h1> </body> </html> ;
 
 : error-head ( error -- )
-    dup log-error response
+    response
     H{ { "Content-Type" V{ "text/html" } } } print-header nl ;
 
 : httpd-error ( error -- )
@@ -30,6 +30,8 @@ SYMBOL: responders
     dup error-head
     "head" "method" get = [ drop ] [ error-body ] if ;
 
+\ httpd-error ERROR add-error-logging
+
 : bad-request ( -- )
     [
         ! Make httpd-error print a body
@@ -84,7 +86,10 @@ SYMBOL: max-post-request
 : read-post-request ( header -- str hash )
     content-length [ read dup query>hash ] [ f f ] if* ;
 
-: log-headers ( hash -- )
+LOG: log-headers DEBUG
+
+: interesting-headers ( assoc -- string )
+    [
         [
             drop {
                 "user-agent"
@@ -93,8 +98,9 @@ SYMBOL: max-post-request
                 "host"
             } member?
         ] assoc-subset [
-        ": " swap 3append log-message
+            ": " swap 3append % "\n" %
-    ] multi-assoc-each ;
+        ] multi-assoc-each
+    ] "" make ;
 
 : prepare-url ( url -- url )
     #! This is executed in the with-request namespace.
@@ -105,7 +111,7 @@ SYMBOL: max-post-request
 : prepare-header ( -- )
     read-header
     dup "header" set
-    dup log-headers
+    dup interesting-headers log-headers
     read-post-request "response" set "raw-response" set ;
 
 ! Responders are called in a new namespace with these
@@ -177,9 +183,6 @@ SYMBOL: max-post-request
     "/" "responder-url" set
     "default" responder call-responder ;
 
-: log-responder ( path -- )
-    "Calling responder " swap append log-message ;
-
 : trim-/ ( url -- url )
     #! Trim a leading /, if there is one.
     "/" ?head drop ;
@@ -199,13 +202,15 @@ SYMBOL: max-post-request
     #! /foo/bar... - default responder used
     #! /responder/foo/bar - responder foo, argument bar
     vhost [
-        dup log-responder trim-/ "responder/" ?head [
+        trim-/ "responder/" ?head [
             serve-explicit-responder
         ] [
             serve-default-responder
         ] if
     ] bind ;
 
+\ serve-responder DEBUG add-input-logging
+
 : no-such-responder ( -- )
     "404 No such responder" httpd-error ;
 

extra/http/server/server.factor

@@ -1,8 +1,8 @@
-! Copyright (C) 2003, 2007 Slava Pestov.
+! Copyright (C) 2003, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs kernel namespaces io strings splitting
 threads http http.server.responders sequences prettyprint
-io.server ;
+io.server logging ;
 
 IN: http.server
 
@@ -36,7 +36,6 @@ IN: http.server
     [ (handle-request) serve-responder ] with-scope ;
 
 : parse-request ( request -- )
-    dup log-message
     " " split1 dup [
         " HTTP" split1 drop url>path secure-path dup [
             swap handle-request
@@ -47,8 +46,9 @@ IN: http.server
         2drop bad-request
     ] if ;
 
+\ parse-request NOTICE add-input-logging
+
 : httpd ( port -- )
-    "Starting HTTP server on port " write dup . flush
     internet-server "http.server" [
         60000 stdio get set-timeout
         readln [ parse-request ] when*

extra/io/launcher/launcher-tests.factor

@@ -1,4 +1,4 @@
 IN: temporary
-USING: tools.test tools.test.inference io.launcher ;
+USING: tools.test io.launcher ;
 
 \ <process-stream> must-infer

extra/io/server/server-docs.factor

@@ -1,29 +1,6 @@
 USING: help help.syntax help.markup io ;
 IN: io.server
 
-HELP: log-stream
-{ $var-description "Holds an output stream for logging messages." }
-{ $see-also log-error log-client with-logging } ;
-
-HELP: log-message
-{ $values { "str" "a string" } }
-{ $description "Logs a message to the log stream. If " { $link log-stream } " is not set, logs to the " { $link stdio } " stream." }
-{ $see-also log-error log-client } ;
-
-HELP: log-error
-{ $values { "str" "a string" } }
-{ $description "Logs an error message." }
-{ $see-also log-message log-client } ;
-
-HELP: log-client
-{ $values { "client" "a client socket stream" } }
-{ $description "Logs an incoming client connection." }
-{ $see-also log-message log-error } ;
-
-HELP: with-logging
-{ $values { "service" "a string or " { $link f } } { "quot" "a quotation" } }
-{ $description "Calls the quotation in a new dynamic scope where the " { $link log-stream } " is set to a file stream appending to a log file (if " { $snippet "service" } " is not " { $link f } ") or the " { $link stdio } " stream at the time " { $link with-logging } " is called (if " { $snippet "service" } " is " { $link f } ")." } ;
-
 HELP: with-client
 { $values { "quot" "a quotation" } { "client" "a client socket stream" } }
 { $description "Logs a client connection and spawns a new thread that calls the quotation, with the " { $link stdio } " stream set to the client stream. If the quotation throws an error, the client connection is closed, and the error is printed to the " { $link stdio } " stream at the time the thread was spawned." } ;

extra/io/server/server-tests.factor

@@ -1,4 +1,4 @@
 IN: temporary
-USING: tools.test.inference io.server ;
+USING: tools.test io.server ;
 
-{ 1 0 } [ [ ] spawn-server ] unit-test-effect
+{ 1 0 } [ [ ] spawn-server ] must-infer-as

extra/io/server/server.factor

@@ -1,69 +1,35 @@
 ! Copyright (C) 2003, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: io io.sockets io.files continuations kernel math
+USING: io io.sockets io.files logging continuations kernel
-math.parser namespaces parser sequences strings
+math math.parser namespaces parser sequences strings
 prettyprint debugger quotations calendar qualified ;
 QUALIFIED: concurrency
 
 IN: io.server
 
-SYMBOL: log-stream
+LOG: accepted-connection NOTICE
 
-: with-log-stream ( quot -- )
+: with-client ( client quot -- )
-    log-stream get swap with-stream* ; inline
-
-: log-message ( str -- )
     [
-        "[" write now timestamp>string write "] " write
+        over client-stream-addr accepted-connection
-        print flush
+        with-stream*
-    ] with-log-stream ;
+    ] curry with-disposal ; inline
 
-: log-error ( str -- ) "Error: " swap append log-message ;
+\ with-client NOTICE add-error-logging
-
-: log-client ( client -- )
-    "Accepted connection from "
-    swap client-stream-addr unparse append log-message ;
-
-: log-file ( service -- path )
-    ".log" append resource-path ;
-
-: with-log-file ( file quot -- )
-    >r <file-appender> r>
-    [ log-stream swap with-variable ] curry
-    with-disposal ; inline
-
-: with-log-stdio ( quot -- )
-    stdio get log-stream rot with-variable ; inline
-
-: with-logging ( service quot -- )
-    over [
-        >r log-file
-        "Writing log messages to " write dup print flush r>
-        with-log-file
-    ] [
-        nip with-log-stdio
-    ] if ; inline
-
-: with-client ( quot client -- )
-    dup log-client
-    [ swap with-stream ] 2curry concurrency:spawn drop ; inline
 
 : accept-loop ( server quot -- )
-    [ swap accept with-client ] 2keep accept-loop ; inline
+    [
+        >r accept r> [ with-client ] 2curry
+        concurrency:spawn drop
+    ] 2keep accept-loop ; inline
 
 : server-loop ( server quot -- )
     [ accept-loop ] curry with-disposal ; inline
 
 : spawn-server ( addrspec quot -- )
-    "Waiting for connections on " pick unparse append
+    >r <server> r> server-loop ; inline
-    log-message
+
-    [
+\ spawn-server NOTICE add-error-logging
-        >r <server> r> server-loop
-    ] [
-        "Cannot spawn server: " print
-        print-error
-        2drop
-    ] recover ; inline
 
 : local-server ( port -- seq )
     "localhost" swap t resolve-host ;
@@ -76,19 +42,21 @@ SYMBOL: log-stream
         [ spawn-server ] curry concurrency:parallel-each
     ] curry with-logging ; inline
 
-: log-datagram ( addrspec -- )
+: received-datagram ( addrspec -- ) drop ;
-    "Received datagram from " swap unparse append log-message ;
+
+\ received-datagram NOTICE add-input-logging
 
 : datagram-loop ( quot datagram -- )
     [
-        [ receive dup log-datagram >r swap call r> ] keep
+        [ receive dup received-datagram >r swap call r> ] keep
         pick [ send ] [ 3drop ] keep
     ] 2keep datagram-loop ; inline
 
 : spawn-datagrams ( quot addrspec -- )
-    "Waiting for datagrams on " over unparse append log-message
     <datagram> [ datagram-loop ] with-disposal ; inline
 
+\ spawn-datagrams NOTICE add-input-logging
+
 : with-datagrams ( seq service quot -- )
     [
         [ swap spawn-datagrams ] curry concurrency:parallel-each

extra/json/reader/reader.factor

@@ -104,7 +104,7 @@ LAZY: 'digit1-9' ( -- parser )
 LAZY: 'digit0-9' ( -- parser )
   [ digit? ] satisfy [ digit> ] <@ ;
 
-: decimal>integer ( seq -- num ) 10 swap digits>integer ;
+: decimal>integer ( seq -- num ) 10 digits>integer ;
 
 LAZY: 'int' ( -- parser )
   'zero' 

extra/logging/analysis/analysis-docs.factor

@@ -0,0 +1,31 @@
+USING: help.markup help.syntax assocs logging math ;
+IN: logging.analysis
+
+HELP: analyze-entries
+{ $values { "entries" "a sequence of log entries" } { "word-names" "a sequence of strings" } { "errors" "a sequence of log entries" } { "word-histogram" assoc } { "message-histogram" assoc } }
+{ $description "Analyzes log entries:"
+    { $list
+        { "Errors (entries with level " { $link ERROR } " or " { $link CRITICAL } ") are collected into the " { $snippet "errors" } " sequence." }
+        { "All logging words are tallied into " { $snippet "word-histogram" } " - for example, this can tell you about HTTP server hit counts." }
+        { "All words listed in " { $snippet "word-names" } " have their messages tallied into " { $snippet "message-histogram" } " - for example, this can tell you about popular URLs on an HTTP server." }
+    }
+} ;
+
+HELP: analysis.
+{ $values { "errors" "a sequence of log entries" } { "word-histogram" assoc } { "message-histogram" assoc } }
+{ $description "Prints a logging report output by " { $link analyze-entries } ". Formatted output words are used, so the report looks nice in the UI or if sent to an HTML stream." } ;
+
+HELP: analyze-log
+{ $values { "service" "a log service name" } { "n" integer } { "word-names" "a sequence of strings" } }
+{ $description "Analyzes a log file and prints a formatted report. The " { $snippet "word-names" } " parameter is documented in " { $link analyze-entries } "." } ;
+
+ARTICLE: "logging.analysis" "Log analysis"
+"The " { $vocab-link "logging.analysis" } " vocabulary builds on the " { $vocab-link "logging.parser" } " vocabulary. It parses log files and produces formatted summary reports. It is used by the " { $vocab-link "logger.insomniac" } " vocabulary to e-mail daily reports."
+$nl
+"Print log file summary:"
+{ $subsection analyze-log }
+"Factors:"
+{ $subsection analyze-entries }
+{ $subsection analysis. } ;
+
+ABOUT: "logging.analysis"

extra/logging/analysis/analysis.factor

@@ -0,0 +1,70 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences namespaces words assocs logging sorting
+prettyprint io io.styles strings logging.parser ;
+IN: logging.analysis
+
+SYMBOL: word-names
+SYMBOL: errors
+SYMBOL: word-histogram
+SYMBOL: message-histogram
+
+: analyze-entry ( entry -- )
+    dup second ERROR eq? [ dup errors get push ] when
+    dup second CRITICAL eq? [ dup errors get push ] when
+    1 over third word-histogram get at+
+    dup third word-names get member? [
+        1 over 1 tail message-histogram get at+
+    ] when
+    drop ;
+
+: analyze-entries ( entries word-names -- errors word-histogram message-histogram )
+    [
+        word-names set
+        V{ } clone errors set
+        H{ } clone word-histogram set
+        H{ } clone message-histogram set
+
+        [
+            analyze-entry
+        ] each
+
+        errors get
+        word-histogram get
+        message-histogram get
+    ] with-scope ;
+
+: histogram. ( assoc quot -- )
+    standard-table-style [
+        >r >alist sort-values <reversed> r> [
+            [ >r swap r> with-cell pprint-cell ] with-row
+        ] curry assoc-each
+    ] tabular-output ;
+
+: log-entry.
+    [
+        dup first [ write ] with-cell
+        dup second [ pprint ] with-cell
+        dup third [ write ] with-cell
+        fourth "\n" join [ write ] with-cell
+    ] with-row ;
+
+: errors. ( errors -- )
+    standard-table-style
+    [ [ log-entry. ] each ] tabular-output ;
+
+: analysis. ( errors word-histogram message-histogram -- )
+    "==== INTERESTING MESSAGES:" print nl
+    "Total: " write dup values sum . nl
+    [
+        dup second write ": " write third "\n" join write
+    ] histogram.
+    nl
+    "==== WORDS:" print nl
+    [ write ] histogram.
+    nl
+    "==== ERRORS:" print nl
+    errors. ;
+
+: analyze-log ( lines word-names -- )
+    >r parse-log r> analyze-entries analysis. ;

extra/logging/analysis/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

extra/logging/analysis/summary.txt

@@ -0,0 +1 @@
+Analyze logs and produce summaries

extra/logging/analysis/tags.txt

@@ -0,0 +1 @@
+enterprise

extra/logging/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

extra/logging/insomniac/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

extra/logging/insomniac/insomniac-docs.factor

@@ -0,0 +1,44 @@
+USING: help.markup help.syntax assocs strings logging
+logging.analysis smtp ;
+IN: logging.insomniac
+
+HELP: insomniac-smtp-host
+{ $var-description "An SMTP server to use for e-mailing log reports. If not set, the value of " { $link smtp-host } " is used." } ;
+
+HELP: insomniac-smtp-port
+{ $var-description "An SMTP server port to use for e-mailing log reports. If not set, the value of " { $link smtp-port } " is used." } ;
+
+HELP: insomniac-sender
+{ $var-description "The originating e-mail address for mailing log reports. Must be set before " { $vocab-link "logging.insomniac" } " is used." } ;
+
+HELP: insomniac-recipients
+{ $var-description "A sequence of e-mail addresses to mail log reports to. Must be set before " { $vocab-link "logging.insomniac" } " is used." } ;
+
+HELP: ?analyze-log
+{ $values { "service" "a log service name" } { "word-names" "a sequence of strings" } { "string" string } }
+{ $description "Analyzes the most recent log and outputs the string analysis, or outputs " { $link f } " if it doesn't exist." }
+{ $see-also analyze-log } ;
+
+HELP: email-log-report
+{ $values { "service" "a log service name" } { "word-names" "a sequence of strings" } }
+{ $description "E-mails a log report for the given log service. The " { $link insomniac-smtp-host } ", " { $link insomniac-sender } " and " { $link insomniac-recipients } " parameters must be set up first. The " { $snippet "word-names" } " parameter is documented in " { $link analyze-entries } "." } ;
+
+HELP: schedule-insomniac
+{ $values { "alist" "a sequence of pairs of shape " { $snippet "{ service word-names }" } } }
+{ $description "Starts a thread which e-mails log reports and rotates logs daily." } ;
+
+ARTICLE: "logging.insomniac" "Automating log analysis and rotation"
+"The " { $vocab-link "logging.insomniac" } " vocabulary builds on the " { $vocab-link "logging.analysis" } " vocabulary. It provides support for e-mailing log reports and rotating logs on a daily basis. E-mails are sent using the " { $vocab-link "smtp" } " vocabulary."
+$nl
+"Required configuration parameters:"
+{ $subsection insomniac-sender }
+{ $subsection insomniac-recipients }
+"Optional configuration parameters:"
+{ $subsection insomniac-smtp-host }
+{ $subsection insomniac-smtp-port }
+"E-mailing a one-off report:"
+{ $subsection email-log-report }
+"E-mailing reports and rotating logs on a daily basis:"
+{ $subsection schedule-insomniac } ;
+
+ABOUT: "logging.insomniac"

extra/logging/insomniac/insomniac.factor

@@ -0,0 +1,48 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: logging.analysis logging.server logging smtp io.sockets
+kernel io.files io.streams.string namespaces raptor.cron assocs ;
+IN: logging.insomniac
+
+SYMBOL: insomniac-smtp-host
+SYMBOL: insomniac-smtp-port
+SYMBOL: insomniac-sender
+SYMBOL: insomniac-recipients
+
+: ?analyze-log ( service word-names -- string/f )
+    >r log-path 1 log# dup exists? [
+        file-lines r> [ analyze-log ] string-out
+    ] [
+        r> 2drop f
+    ] if ;
+
+: with-insomniac-smtp ( quot -- )
+    [
+        insomniac-smtp-host get [ smtp-host set ] when*
+        insomniac-smtp-port get [ smtp-port set ] when*
+        call
+    ] with-scope ; inline
+
+: email-subject ( service -- string )
+    [ "[INSOMNIAC] " % % " on " % host-name % ] "" make ;
+
+: (email-log-report) ( service word-names -- )
+    [
+        over >r
+        ?analyze-log dup [
+            r> email-subject
+            insomniac-recipients get
+            insomniac-sender get
+            send-simple-message
+        ] [ r> 2drop ] if
+    ] with-insomniac-smtp ;
+
+\ (email-log-report) NOTICE add-error-logging
+
+: email-log-report ( service word-names -- )
+    "logging.insomniac" [ (email-log-report) ] with-logging ;
+
+: schedule-insomniac ( alist -- )
+    { 25 } { 6 } f f f <when> -rot [
+        [ email-log-report ] assoc-each rotate-logs
+    ] 2curry schedule ;

extra/logging/insomniac/summary.txt

@@ -0,0 +1 @@
+Task which rotates logs and e-mails summaries

extra/logging/insomniac/tags.txt

@@ -0,0 +1 @@
+enterprise

extra/logging/logging-docs.factor

@@ -0,0 +1,130 @@
+IN: logging
+USING: help.markup help.syntax assocs math calendar
+logging.server strings words quotations ;
+
+HELP: DEBUG
+{ $description "Log level for debug messages." } ;
+
+HELP: NOTICE
+{ $description "Log level for ordinary messages." } ;
+
+HELP: ERROR
+{ $description "Log level for error messages." } ;
+
+HELP: CRITICAL
+{ $description "Log level for critical errors which require immediate attention." } ;
+
+ARTICLE: "logging.levels" "Log levels"
+"Several log levels are supported, from lowest to highest:"
+{ $subsection DEBUG }
+{ $subsection NOTICE }
+{ $subsection ERROR }
+{ $subsection CRITICAL } ;
+
+ARTICLE: "logging.files" "Log files"
+"Each application that wishes to use logging must choose a log service name; the following combinator should wrap the top level of the application:"
+{ $subsection with-logging }
+"Log messages are written to " { $snippet "log-root/service/1.log" } ", where"
+{ $list
+    { { $snippet "log-root" } " is the Factor source directory by default, but can be overriden with the " { $link log-root } " variable" }
+    { { $snippet "service" } " is the service name" }
+}
+"You can get the log path for a service:"
+{ $subsection log-path }
+{ $subsection log# }
+"New log entries are always sent to " { $snippet "1.log" } " but " { $link "logging.rotation" } " moves " { $snippet "1.log" } " to " { $snippet "2.log" } ", " { $snippet "2.log" } " to " { $snippet "3.log" } ", and so on." ;
+
+HELP: log-message
+{ $values { "msg" string } { "word" word } { "level" "a log level" } }
+{ $description "Sends a message to the current log. Does nothing if not executing in a dynamic scope established by " { $link with-logging } "." } ;
+
+HELP: add-logging
+{ $values { "word" word } }
+{ $description "Causes the word to log a message every time it is called." } ;
+
+HELP: add-input-logging
+{ $values { "word" word } }
+{ $description "Causes the word to log its input values every time it is called. The word must have a stack effect declaration." } ;
+
+HELP: add-output-logging
+{ $values { "word" word } }
+{ $description "Causes the word to log its output values every time it is called. The word must have a stack effect declaration." } ;
+
+HELP: add-error-logging
+{ $values { "word" word } }
+{ $description "Causes the word to log its input values and any errors it throws."
+$nl
+"If the word is not executed in a dynamic scope established by " { $link with-logging } ", its behavior is unchanged, and any errors it throws are passed to the caller."
+$nl
+"If called from a logging context, its input values are logged, and if it throws an error, the error is logged and the word returns normally. Any inputs are popped from the stack and " { $link f } " is pushed in place of each output." } ;
+
+HELP: log-error
+{ $values { "error" "an error" } { "word" word } }
+{ $description "Logs an error." } ;
+
+HELP: log-critical
+{ $values { "critical" "an critical" } { "word" word } }
+{ $description "Logs a critical error." } ;
+
+HELP: LOG:
+{ $syntax "LOG: name level" }
+{ $values { "name" "a new word name" } { "level" "a log level" } }
+{ $description "Creates a word with stack effect " { $snippet "( object -- )" } " which logs its input and does nothing else." } ;
+
+ARTICLE: "logging.messages" "Logging messages"
+"Logging messages explicitly:"
+{ $subsection log-message }
+{ $subsection log-error }
+{ $subsection log-critical }
+"A utility for defining words which just log and do nothing else:"
+{ $subsection POSTPONE: LOG: }
+"Annotating words to log; this uses the " { $link "tools.annotations" } " feature:"
+{ $subsection add-input-logging }
+{ $subsection add-output-logging }
+{ $subsection add-error-logging } ;
+
+HELP: rotate-logs
+{ $description "Rotates all logs. The highest numbered log file in each log directory is deleted, and each file is renamed so that its number increments by one. Subsequent logging calls will create a new #1 log file. This keeps log files from getting too large and makes them easier to search." } ;
+
+HELP: close-logs
+{ $description "Closes all open log streams. Subsequent logging will re-open the streams. This should be used before moving or deleting log files." } ;
+
+HELP: with-logging
+{ $values { "service" "a log service name" } { "quot" quotation } }
+{ $description "Calls the quotation a new dynamic scope where all logging calls are sent to the log file for " { $snippet "service" } "." } ;
+
+ARTICLE: "logging.rotation" "Log rotation"
+"Log files should be rotated periodically to prevent unbounded growth."
+{ $subsection rotate-logs }
+{ $subsection close-logs }
+"The " { $vocab-link "logging.insomniac" } " vocabulary automates log rotation." ;
+
+ARTICLE: "logging.server" "Log implementation"
+"The " { $vocab-link "logging.server" } " vocabulary implements a concurrent log server using " { $vocab-link "concurrency" } ". User code never interacts with the server directly, instead ot uses the words in the " { $link "logging" } " vocabulary. The server is used to synchronize access to log files and ensure that log rotation can proceed in an orderly fashion."
+$nl
+"The " { $link log-message } " word sends a message to the server which results in the server executing an internal word:"
+{ $subsection (log-message) }
+"The " { $link rotate-logs } " word sends a message to the server which results in the server executing an internal word:"
+{ $subsection (rotate-logs) }
+"The " { $link close-logs } " word sends a message to the server which results in the server executing an internal word:"
+{ $subsection (close-logs) } ;
+
+ARTICLE: "logging" "Logging framework"
+"The " { $vocab-link "logging" } " vocabulary implements a comprehensive logging framework suitable for server-side production applications."
+{ $subsection "logging.files" }
+{ $subsection "logging.levels" }
+{ $subsection "logging.messages" }
+{ $subsection "logging.rotation" }
+{ $subsection "logging.parser" }
+{ $subsection "logging.analysis" }
+{ $subsection "logging.insomniac" }
+{ $subsection "logging.server" } ;
+
+ABOUT: "logging"
+
+! A workaround for circular dependency prohibition
+USING: threads vocabs.loader ;
+[
+    yield
+    "logging.insomniac" require
+] in-thread

extra/logging/logging.factor

@@ -0,0 +1,130 @@
+! Copyright (C) 2003, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: logging.server sequences namespaces concurrency
+words kernel arrays shuffle tools.annotations
+prettyprint.config prettyprint debugger io.streams.string
+splitting continuations effects arrays.lib parser strings
+combinators.lib ;
+IN: logging
+
+SYMBOL: DEBUG
+SYMBOL: NOTICE
+SYMBOL: WARNING
+SYMBOL: ERROR
+SYMBOL: CRITICAL
+
+: log-levels
+    { DEBUG NOTICE NOTICE WARNING ERROR CRITICAL } ;
+
+: send-to-log-server ( array string -- )
+    add* "log-server" get send ;
+
+SYMBOL: log-service
+
+: check-log-message
+    pick string?
+    pick word?
+    pick word? and and
+    [ "Bad parameters to log-message" throw ] unless ;
+
+: log-message ( msg word level -- )
+    check-log-message
+    log-service get dup [
+        >r >r >r string-lines r> word-name r> word-name r>
+        4array "log-message" send-to-log-server
+    ] [
+        4drop
+    ] if ;
+
+: rotate-logs ( -- )
+    { } "rotate-logs" send-to-log-server ;
+
+: close-logs ( -- )
+    { } "close-logs" send-to-log-server ;
+
+: with-logging ( service quot -- )
+    log-service swap with-variable ; inline
+
+! Aspect-oriented programming idioms
+
+<PRIVATE
+
+: one-string?
+    {
+        [ dup array? ]
+        [ dup length 1 = ]
+        [ dup first string? ]
+    } && nip ;
+
+: stack>message ( obj -- inputs>message )
+    dup one-string? [ first ] [
+        H{
+            { string-limit f }
+            { line-limit 1 }
+            { nesting-limit 3 }
+            { margin 0 }
+        } clone [ unparse ] bind
+    ] if ;
+
+PRIVATE>
+
+: (define-logging) ( word level quot -- )
+    >r >r dup r> r> 2curry annotate ;
+
+: call-logging-quot ( quot word level -- quot' )
+    "called" -rot [ log-message ] 3curry swap compose ;
+
+: add-logging ( word level -- )
+    [ call-logging-quot ] (define-logging) ;
+
+: log-stack ( n word level -- )
+    log-service get [
+        >r >r [ ndup ] keep narray stack>message
+        r> r> log-message
+    ] [
+        3drop
+    ] if ; inline
+
+: input# stack-effect effect-in length ;
+
+: input-logging-quot ( quot word level -- quot' )
+    over input# -rot [ log-stack ] 3curry swap compose ;
+
+: add-input-logging ( word level -- )
+    [ input-logging-quot ] (define-logging) ;
+
+: output# stack-effect effect-out length ;
+
+: output-logging-quot ( quot word level -- quot' )
+    over output# -rot [ log-stack ] 3curry compose ;
+
+: add-output-logging ( word level -- )
+    [ output-logging-quot ] (define-logging) ;
+
+: (log-error) ( object word level -- )
+    log-service get [
+        >r >r [ print-error ] string-out r> r> log-message
+    ] [
+        2drop rethrow
+    ] if ;
+
+: log-error ( error word -- ) ERROR (log-error) ;
+
+: log-critical ( error word -- ) CRITICAL (log-error) ;
+
+: error-logging-quot ( quot word -- quot' )
+    dup stack-effect effect-in length
+    [ >r log-error r> ndrop ] 2curry
+    [ recover ] 2curry ;
+
+: add-error-logging ( word level -- )
+    [ over >r input-logging-quot r> error-logging-quot ]
+    (define-logging) ;
+
+: LOG:
+    #! Syntax: name level
+    CREATE
+    dup reset-generic
+    dup scan-word
+    [ >r >r 1array stack>message r> r> log-message ] 2curry
+    define ; parsing

extra/logging/parser/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

extra/logging/parser/parser-docs.factor

@@ -0,0 +1,21 @@
+IN: logging.parser
+USING: help.markup help.syntax assocs logging math calendar ;
+
+HELP: parse-log
+{ $values { "lines" "a sequence of strings" } { "entries" "a sequence of log entries" } }
+{ $description "Parses a sequence of log entries. Malformed entries are printed out and ignore. The result is a sequence of arrays of the shape " { $snippet "{ timestamp level word-name message }" } ", where"
+    { $list
+        { { $snippet "timestamp" } " is a " { $link timestamp } }
+        { { $snippet "level" } " is a log level; see " { $link "logger.levels" } }
+        { { $snippet "word-name" } " is a string" }
+        { { $snippet "message" } " is a string" }
+    }
+} ;
+
+ARTICLE: "logging.parser" "Log file parser"
+"The " { $vocab-link "logging.parser" } " vocabulary parses log files output by the " { $vocab-link "logging" } " vocabulary. It is used by " { $link "logging.analysis" } " and " { $link "logging.insomniac" } " to analyze logs."
+$nl
+"There is only one primary entry point:"
+{ $subsection parse-log } ;
+
+ABOUT: "logging.parser"

extra/logging/parser/parser.factor

@@ -0,0 +1,66 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: parser-combinators memoize kernel sequences
+logging arrays words strings vectors io io.files
+namespaces combinators combinators.lib logging.server ;
+IN: logging.parser
+
+: string-of satisfy <!*> [ >string ] <@ ;
+
+: 'date'
+    [ CHAR: ] eq? not ] string-of
+    "[" "]" surrounded-by ;
+
+: 'log-level'
+    log-levels [
+        [ word-name token ] keep [ nip ] curry <@
+    ] map <or-parser> ;
+
+: 'word-name'
+    [ " :" member? not ] string-of ;
+
+SYMBOL: malformed
+
+: 'malformed-line'
+    [ drop t ] string-of [ malformed swap 2array ] <@ ;
+
+: 'log-message'
+    [ drop t ] string-of [ 1vector ] <@ ;
+
+MEMO: 'log-line' ( -- parser )
+    'date' " " token <&
+    'log-level' " " token <& <&>
+    'word-name' ": " token <& <:&>
+    'log-message' <:&>
+    'malformed-line' <|> ;
+
+: parse-log-line ( string -- entry )
+    'log-line' parse-1 ;
+
+: malformed? ( line -- ? )
+    first malformed eq? ;
+
+: multiline? ( line -- ? )
+    first first CHAR: - = ;
+
+: malformed-line
+    "Warning: malformed log line:" print
+    second print ;
+
+: add-multiline ( line -- )
+    building get empty? [
+        "Warning: log begins with multiline entry" print drop
+    ] [
+        fourth first building get peek fourth push
+    ] if ;
+
+: parse-log ( lines -- entries )
+    [
+        [
+            parse-log-line {
+                { [ dup malformed? ] [ malformed-line ] }
+                { [ dup multiline? ] [ add-multiline ] }
+                { [ t ] [ , ] }
+            } cond
+        ] each
+    ] { } make ;

extra/logging/parser/summary.txt

@@ -0,0 +1 @@
+Log parser

extra/logging/parser/tags.txt

@@ -0,0 +1 @@
+enterprise

extra/logging/server/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

extra/logging/server/server-docs.factor

@@ -0,0 +1,4 @@
+IN: logging.server
+USING: help.syntax ;
+
+ABOUT: "logging.server"

extra/logging/server/server.factor

@@ -0,0 +1,101 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces kernel io calendar sequences io.files
+io.sockets continuations prettyprint assocs math.parser
+words debugger math combinators concurrency arrays init
+math.ranges strings ;
+IN: logging.server
+
+: log-root ( -- string )
+    \ log-root get "logs" resource-path or ;
+
+: log-path ( service -- path )
+    log-root swap path+ ;
+
+: log# ( path n -- path' )
+    number>string ".log" append path+ ;
+
+SYMBOL: log-files
+
+: open-log-stream ( service -- stream )
+    log-path
+    dup make-directories
+    1 log# <file-appender> ;
+
+: log-stream ( service -- stream )
+    log-files get [ open-log-stream ] cache ;
+
+: (write-message) ( msg word-name level multi? -- )
+    [
+        "[" write 20 CHAR: - <string> write "] " write
+    ] [
+        "[" write now (timestamp>rfc3339) "] " write
+    ] if
+    write bl write ": " write print ;
+
+: write-message ( msg word-name level -- )
+    rot [ empty? not ] subset {
+        { [ dup empty? ] [ 3drop ] }
+        { [ dup length 1 = ] [ first -rot f (write-message) ] }
+        { [ t ] [
+            [ first -rot f (write-message) ] 3keep
+            1 tail -rot [ t (write-message) ] 2curry each
+        ] }
+    } cond ;
+
+: (log-message) ( msg -- )
+    #! msg: { msg word-name level service }
+    first4 log-stream [ write-message flush ] with-stream* ;
+
+: try-dispose ( stream -- )
+    [ dispose ] curry [ error. ] recover ;
+
+: close-log ( service -- )
+    log-files get delete-at*
+    [ try-dispose ] [ drop ] if ;
+
+: (close-logs) ( -- )
+    log-files get
+    dup values [ try-dispose ] each
+    clear-assoc ;
+
+: keep-logs 10 ;
+
+: ?delete-file ( path -- )
+    dup exists? [ delete-file ] [ drop ] if ;
+
+: delete-oldest keep-logs log# ?delete-file ;
+
+: ?rename-file ( old new -- )
+    over exists? [ rename-file ] [ 2drop ] if ;
+
+: advance-log ( path n -- )
+    [ 1- log# ] 2keep log# ?rename-file ;
+
+: rotate-log ( service -- )
+    dup close-log
+    log-path
+    dup delete-oldest
+    keep-logs 1 [a,b] [ advance-log ] with each ;
+
+: (rotate-logs) ( -- )
+    (close-logs)
+    log-root directory [ drop rotate-log ] assoc-each ;
+
+: log-server-loop
+    [
+        receive unclip {
+            { "log-message" [ (log-message) ] }
+            { "rotate-logs" [ drop (rotate-logs) ] }
+            { "close-logs" [ drop (close-logs) ] }
+        } case
+    ] [ error. (close-logs) ] recover
+    log-server-loop ;
+
+: log-server ( -- )
+    [ log-server-loop ] spawn "log-server" set-global ;
+
+[
+    H{ } clone log-files set-global
+    log-server
+] "logging" add-init-hook

extra/logging/server/summary.txt

@@ -0,0 +1 @@
+Distributed concurrency log server

extra/logging/server/tags.txt

@@ -0,0 +1 @@
+enterprise

extra/logging/summary.txt

@@ -0,0 +1 @@
+Logging framework with support for log rotation and machine-readable logs

extra/logging/tags.txt

@@ -0,0 +1 @@
+enterprise

extra/math/ratios/ratios-docs.factor

@@ -7,6 +7,7 @@ ARTICLE: "rationals" "Rational numbers"
 "When we add, subtract or multiply any two integers, the result is always an integer. However, dividing a numerator by a denominator that is not an integral divisor of the denominator yields a ratio:"
 { $example "1210 11 / ." "110" }
 { $example "100 330 / ." "10/33" }
+{ $example "14 10 / ." "1+2/5" }
 "Ratios are printed and can be input literally in the form above. Ratios are always reduced to lowest terms by factoring out the greatest common divisor of the numerator and denominator. A ratio with a denominator of 1 becomes an integer. Division with a denominator of 0 throws an error."
 $nl
 "Ratios behave just like any other number -- all numerical operations work as you would expect."

extra/math/ratios/ratios-tests.factor

@@ -105,3 +105,8 @@ unit-test
 [ "33/100" ]
 [ "66/200" string>number number>string ]
 unit-test
+
+[ 3 ] [ "1+1/2" string>number 2 * ] unit-test
+[ -3 ] [ "-1+1/2" string>number 2 * ] unit-test
+[ "2+1/7" ] [ 1 7 / 2 + number>string ] unit-test
+[ "1/8" ] [ 1 8 / number>string ] unit-test

extra/math/ratios/ratios.factor

@@ -48,3 +48,4 @@ M: ratio * 2>fraction * >r * r> / ;
 M: ratio / scale / ;
 M: ratio /i scale /i ;
 M: ratio mod 2dup >r >r /i r> r> rot * - ;
+M: ratio /mod [ /i ] 2keep mod ;

extra/math/text/english/english.factor

@@ -33,7 +33,7 @@ SYMBOL: and-needed?
 
 : 3digit-groups ( n -- seq )
     number>string <reversed> 3 <groups>
-    [ reverse 10 string>integer ] map ;
+    [ reverse string>number ] map ;
 
 : hundreds-place ( n -- str )
     100 /mod swap dup zero? [

extra/parser-combinators/simple/simple.factor

@@ -8,7 +8,7 @@ IN: parser-combinators.simple
   [ digit? ] satisfy [ digit> ] <@ ;
 
 : 'integer' ( -- parser )
-  'digit' <!+> [ 10 swap digits>integer ] <@ ;
+  'digit' <!+> [ 10 digits>integer ] <@ ;
 
 : 'string' ( -- parser )
   [ CHAR: " = ] satisfy 

extra/peg/peg.factor

@@ -343,7 +343,7 @@ MEMO: 'digit' ( -- parser )
   [ digit? ] satisfy [ digit> ] action ;
 
 MEMO: 'integer' ( -- parser )
-  'digit' repeat1 [ 10 swap digits>integer ] action ;
+  'digit' repeat1 [ 10 digits>integer ] action ;
 
 MEMO: 'string' ( -- parser )
   [

extra/project-euler/012/012.factor

@@ -33,9 +33,6 @@ IN: project-euler.012
 ! SOLUTION
 ! --------
 
-: nth-triangle ( n -- n )
-    dup 1+ * 2 / ;
-
 : euler012 ( -- answer )
     8 [ dup nth-triangle tau* 500 < ] [ 1+ ] [ ] while nth-triangle ;
 

extra/project-euler/022/022.factor

@@ -1,7 +1,6 @@
 ! Copyright (c) 2007 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: io.files kernel math math.parser namespaces sequences sorting splitting
+USING: ascii io.files kernel math project-euler.common sequences sorting splitting ;
-    strings system vocabs ascii ;
 IN: project-euler.022
 
 ! http://projecteuler.net/index.php?section=problems&id=22
@@ -31,9 +30,6 @@ IN: project-euler.022
     "extra/project-euler/022/names.txt" resource-path
     file-contents [ quotable? ] subset "," split ;
 
-: alpha-value ( str -- n )
-    [ string>digits sum ] keep length 9 * - ;
-
 : name-scores ( seq -- seq )
     dup length [ 1+ swap alpha-value * ] 2map ;
 
@@ -43,9 +39,6 @@ PRIVATE>
     source-022 natural-sort name-scores sum ;
 
 ! [ euler022 ] 100 ave-time
-! 59 ms run / 1 ms GC ave time - 100 trials
+! 123 ms run / 4 ms GC ave time - 100 trials
-
-! source-022 [ natural-sort name-scores sum ] curry 100 ave-time
-! 45 ms run / 1 ms GC ave time - 100 trials
 
 MAIN: euler022

extra/project-euler/024/024.factor

@@ -23,7 +23,7 @@ IN: project-euler.024
 ! --------
 
 : euler024 ( -- answer )
-    999999 10 permutation 10 swap digits>integer ;
+    999999 10 permutation 10 digits>integer ;
 
 ! [ euler024 ] 100 ave-time
 ! 0 ms run / 0 ms GC ave time - 100 trials

extra/project-euler/032/032.factor

@@ -1,7 +1,7 @@
 ! Copyright (c) 2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: combinators.lib hashtables kernel math math.combinatorics math.parser
+USING: combinators.lib hashtables kernel math math.combinatorics math.functions
-    math.ranges project-euler.common sequences ;
+    math.parser math.ranges project-euler.common sequences ;
 IN: project-euler.032
 
 ! http://projecteuler.net/index.php?section=problems&id=32
@@ -27,21 +27,21 @@ IN: project-euler.032
 <PRIVATE
 
 : source-032 ( -- seq )
-    9 factorial [ 9 permutation [ 1+ ] map 10 swap digits>integer ] map ;
+    9 factorial [ 9 permutation [ 1+ ] map 10 digits>integer ] map ;
 
 : 1and4 ( n -- ? )
     number>string 1 cut-slice 4 cut-slice
-    [ 10 string>integer ] 3apply [ * ] dip = ;
+    [ string>number ] 3apply [ * ] dip = ;
 
 : 2and3 ( n -- ? )
     number>string 2 cut-slice 3 cut-slice
-    [ 10 string>integer ] 3apply [ * ] dip = ;
+    [ string>number ] 3apply [ * ] dip = ;
 
 : valid? ( n -- ? )
     dup 1and4 swap 2and3 or ;
 
 : products ( seq -- m )
-    [ number>string 4 tail* 10 string>integer ] map ;
+    [ 10 4 ^ mod ] map ;
 
 PRIVATE>
 
@@ -49,7 +49,7 @@ PRIVATE>
     source-032 [ valid? ] subset products prune sum ;
 
 ! [ euler032 ] 10 ave-time
-! 27609 ms run / 2484 ms GC ave time - 10 trials
+! 23922 ms run / 1505 ms GC ave time - 10 trials
 
 
 ! ALTERNATE SOLUTIONS
@@ -65,7 +65,7 @@ PRIVATE>
 
 ! multiplicand/multiplier/product
 : mmp ( pair -- n )
-    first2 2dup * [ number>string ] 3apply 3append 10 string>integer ;
+    first2 2dup * [ number>string ] 3apply 3append string>number ;
 
 PRIVATE>
 

extra/project-euler/035/035.factor

@@ -38,7 +38,7 @@ IN: project-euler.035
 
 : (circular?) ( seq n -- ? )
     dup 0 > [
-        2dup rotate 10 swap digits>integer
+        2dup rotate 10 digits>integer
         prime? [ 1- (circular?) ] [ 2drop f ] if
     ] [
         2drop t

extra/project-euler/037/037.factor

@@ -32,7 +32,7 @@ IN: project-euler.037
     ] if ;
 
 : reverse-digits ( n -- m )
-    number>string reverse 10 string>integer ;
+    number>string reverse string>number ;
 
 : l-trunc? ( n -- ? )
     reverse-digits 10 /i reverse-digits dup 0 > [

extra/project-euler/038/038.factor

@@ -36,7 +36,7 @@ IN: project-euler.038
 
 : (concat-product) ( accum n multiplier -- m )
     pick length 8 > [
-        2drop 10 swap digits>integer
+        2drop 10 digits>integer
     ] [
         [ * number>digits over push-all ] 2keep 1+ (concat-product)
     ] if ;

extra/project-euler/040/040.factor

@@ -37,7 +37,7 @@ IN: project-euler.040
     SBUF" " clone 1 -rot (concat-upto) ;
 
 : nth-integer ( n str -- m )
-    [ 1- ] dip nth 1string 10 string>integer ;
+    [ 1- ] dip nth 1string string>number ;
 
 PRIVATE>
 

extra/project-euler/041/041.factor

@@ -0,0 +1,40 @@
+! Copyright (c) 2008 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math.combinatorics math.parser math.primes sequences ;
+IN: project-euler.041
+
+! http://projecteuler.net/index.php?section=problems&id=41
+
+! DESCRIPTION
+! -----------
+
+! We shall say that an n-digit number is pandigital if it makes use of all the
+! digits 1 to n exactly once. For example, 2143 is a 4-digit pandigital and is
+! also prime.
+
+! What is the largest n-digit pandigital prime that exists?
+
+
+! SOLUTION
+! --------
+
+! Check 7-digit pandigitals because if the sum of the digits in any number add
+! up to a multiple of three, then it is a multiple of three and can't be prime.
+! I assumed there would be a 7-digit answer, but technically a higher 4-digit
+! pandigital than the one given in the description was also possible.
+
+!     1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 = 45
+!     1 + 2 + 3 + 4 + 5 + 6 + 7 + 8     = 36
+!     1 + 2 + 3 + 4 + 5 + 6 + 7         = 28  *** not divisible by 3 ***
+!     1 + 2 + 3 + 4 + 5 + 6             = 21
+!     1 + 2 + 3 + 4 + 5                 = 15
+!     1 + 2 + 3 + 4                     = 10  *** not divisible by 3 ***
+
+: euler041 ( -- answer )
+    { 7 6 5 4 3 2 1 } all-permutations
+    [ 10 digits>integer ] map [ prime? ] find nip ;
+
+! [ euler041 ] 100 ave-time
+! 107 ms run / 7 ms GC ave time - 100 trials
+
+MAIN: euler041

extra/project-euler/042/042.factor

@@ -0,0 +1,74 @@
+! Copyright (c) 2008 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: ascii combinators.lib io.files kernel math math.functions namespaces
+    project-euler.common sequences splitting ;
+IN: project-euler.042
+
+! http://projecteuler.net/index.php?section=problems&id=42
+
+! DESCRIPTION
+! -----------
+
+! The nth term of the sequence of triangle numbers is given by,
+! tn = n * (n + 1) / 2; so the first ten triangle numbers are:
+
+!     1, 3, 6, 10, 15, 21, 28, 36, 45, 55, ...
+
+! By converting each letter in a word to a number corresponding to its
+! alphabetical position and adding these values we form a word value. For
+! example, the word value for SKY is 19 + 11 + 25 = 55 = t10. If the word value
+! is a triangle number then we shall call the word a triangle word.
+
+! Using words.txt (right click and 'Save Link/Target As...'), a 16K text file
+! containing nearly two-thousand common English words, how many are triangle
+! words?
+
+
+! SOLUTION
+! --------
+
+<PRIVATE
+
+: source-042 ( -- seq )
+    "extra/project-euler/042/words.txt" resource-path
+    file-contents [ quotable? ] subset "," split ;
+
+: (triangle-upto) ( limit n -- )
+    2dup nth-triangle > [
+        dup nth-triangle , 1+ (triangle-upto)
+    ] [
+        2drop
+    ] if ;
+
+: triangle-upto ( n -- seq )
+    [ 1 (triangle-upto) ] { } make ;
+
+PRIVATE>
+
+: euler042 ( -- answer )
+    source-042 [ alpha-value ] map dup supremum
+    triangle-upto [ member? ] curry count ;
+
+! [ euler042 ] 100 ave-time
+! 27 ms run / 1 ms GC ave time - 100 trials
+
+
+! ALTERNATE SOLUTIONS
+! -------------------
+
+! Use the inverse function of n * (n + 1) / 2 and test if the result is an integer
+
+<PRIVATE
+
+: triangle? ( n -- ? )
+    8 * 1+ sqrt 1- 2 / 1 mod zero? ;
+
+PRIVATE>
+
+: euler042a ( -- answer )
+    source-042 [ alpha-value ] map [ triangle? ] count ;
+
+! [ euler042a ] 100 ave-time
+! 25 ms run / 1 ms GC ave time - 100 trials
+
+MAIN: euler042a

extra/project-euler/043/043.factor

@@ -0,0 +1,97 @@
+! Copyright (c) 2008 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators.lib hashtables kernel math math.combinatorics math.parser
+    math.ranges project-euler.common sequences sorting ;
+IN: project-euler.043
+
+! http://projecteuler.net/index.php?section=problems&id=43
+
+! DESCRIPTION
+! -----------
+
+! The number, 1406357289, is a 0 to 9 pandigital number because it is made up
+! of each of the digits 0 to 9 in some order, but it also has a rather
+! interesting sub-string divisibility property.
+
+! Let d1 be the 1st digit, d2 be the 2nd digit, and so on. In this way, we note
+! the following:
+
+!     * d2d3d4  = 406 is divisible by 2
+!     * d3d4d5  = 063 is divisible by 3
+!     * d4d5d6  = 635 is divisible by 5
+!     * d5d6d7  = 357 is divisible by 7
+!     * d6d7d8  = 572 is divisible by 11
+!     * d7d8d9  = 728 is divisible by 13
+!     * d8d9d10 = 289 is divisible by 17
+
+! Find the sum of all 0 to 9 pandigital numbers with this property.
+
+
+! SOLUTION
+! --------
+
+! Brute force generating all the pandigitals then checking 3-digit divisiblity
+! properties...this is very slow!
+
+<PRIVATE
+
+: subseq-divisible? ( n index seq -- ? )
+    [ 1- dup 3 + ] dip subseq 10 digits>integer swap mod zero? ;
+
+: interesting? ( seq -- ? )
+    {
+        [ 17 8 pick subseq-divisible? ]
+        [ 13 7 pick subseq-divisible? ]
+        [ 11 6 pick subseq-divisible? ]
+        [ 7 5 pick subseq-divisible? ]
+        [ 5 4 pick subseq-divisible? ]
+        [ 3 3 pick subseq-divisible? ]
+        [ 2 2 pick subseq-divisible? ]
+    } && nip ;
+
+PRIVATE>
+
+: euler043 ( -- answer )
+    1234567890 number>digits all-permutations
+    [ interesting? ] subset [ 10 digits>integer ] map sum ;
+
+! [ euler043 ] time
+! 125196 ms run / 19548 ms GC time
+
+
+! ALTERNATE SOLUTIONS
+! -------------------
+
+! Build the number from right to left, generating the next 3-digits according
+! to the divisiblity rules and combining them with the previous digits if they
+! overlap and still have all unique digits. When done with that, add whatever
+! missing digit is needed to make the number pandigital.
+
+<PRIVATE
+
+: candidates ( n -- seq )
+    1000 over <range> [ number>digits 3 0 pad-left ] map [ all-unique? ] subset ;
+
+: overlap? ( seq -- ? )
+    dup first 2 tail* swap second 2 head = ;
+
+: clean ( seq -- seq )
+    [ unclip 1 head add* concat ] map [ all-unique? ] subset ;
+
+: add-missing-digit ( seq -- seq )
+    dup natural-sort 10 seq-diff first add* ;
+
+: interesting-pandigitals ( -- seq )
+    17 candidates { 13 11 7 5 3 2 } [
+        candidates swap cartesian-product [ overlap? ] subset clean
+    ] each [ add-missing-digit ] map ;
+
+PRIVATE>
+
+: euler043a ( -- answer )
+    interesting-pandigitals [ 10 digits>integer ] sigma ;
+
+! [ euler043a ] 100 ave-time
+! 19 ms run / 1 ms GC ave time - 100 trials
+
+MAIN: euler043a

extra/project-euler/044/044.factor

@@ -0,0 +1,50 @@
+! Copyright (c) 2008 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math math.functions math.ranges project-euler.common sequences ;
+IN: project-euler.044
+
+! http://projecteuler.net/index.php?section=problems&id=44
+
+! DESCRIPTION
+! -----------
+
+! Pentagonal numbers are generated by the formula, Pn=n(3n−1)/2. The first ten
+! pentagonal numbers are:
+
+!     1, 5, 12, 22, 35, 51, 70, 92, 117, 145, ...
+
+! It can be seen that P4 + P7 = 22 + 70 = 92 = P8. However, their difference,
+! 70 − 22 = 48, is not pentagonal.
+
+! Find the pair of pentagonal numbers, Pj and Pk, for which their sum and
+! difference is pentagonal and D = |Pk − Pj| is minimised; what is the value of D?
+
+
+! SOLUTION
+! --------
+
+! Brute force using a cartesian product and an arbitrarily chosen limit.
+
+<PRIVATE
+
+: nth-pentagonal ( n -- seq )
+    dup 3 * 1- * 2 / ;
+
+: pentagonal? ( n -- ? )
+    dup 0 > [ 24 * 1+ sqrt 1+ 6 / 1 mod zero? ] [ drop f ] if ;
+
+: sum-and-diff? ( m n -- ? )
+    2dup + -rot - [ pentagonal? ] 2apply and ;
+
+PRIVATE>
+
+: euler044 ( -- answer )
+    2500 [1,b] [ nth-pentagonal ] map dup cartesian-product
+    [ first2 sum-and-diff? ] subset [ first2 - abs ] map infimum ;
+
+! [ euler044 ] 10 ave-time
+! 8924 ms run / 2872 ms GC ave time - 10 trials
+
+! TODO: this solution is ugly and not very efficient...find a better algorithm
+
+MAIN: euler044

extra/project-euler/048/048.factor

@@ -0,0 +1,25 @@
+! Copyright (c) 2008 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators.lib kernel math math.functions ;
+IN: project-euler.048
+
+! http://projecteuler.net/index.php?section=problems&id=48
+
+! DESCRIPTION
+! -----------
+
+! The series, 1^1 + 2^2 + 3^3 + ... + 10^10 = 10405071317.
+
+! Find the last ten digits of the series, 1^1 + 2^2 + 3^3 + ... + 1000^1000.
+
+
+! SOLUTION
+! --------
+
+: euler048 ( -- answer )
+    1000 [ 1+ dup ^ ] sigma 10 10 ^ mod ;
+
+! [ euler048 ] 100 ave-time
+! 276 ms run / 1 ms GC ave time - 100 trials
+
+MAIN: euler048

extra/project-euler/052/052.factor

@@ -0,0 +1,50 @@
+! Copyright (c) 2008 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators.lib kernel math project-euler.common sequences sorting ;
+IN: project-euler.052
+
+! http://projecteuler.net/index.php?section=problems&id=52
+
+! DESCRIPTION
+! -----------
+
+! It can be seen that the number, 125874, and its double, 251748, contain
+! exactly the same digits, but in a different order.
+
+! Find the smallest positive integer, x, such that 2x, 3x, 4x, 5x, and 6x,
+! contain the same digits.
+
+
+! SOLUTION
+! --------
+
+! Analysis shows the number must be odd, divisible by 3, and larger than 123456
+
+<PRIVATE
+
+: map-nx ( n x -- seq )
+    [ 1+ * ] with map ; inline
+
+: all-same-digits? ( seq -- ? )
+    [ number>digits natural-sort ] map all-equal? ;
+
+: candidate? ( n -- ? )
+    { [ dup odd? ] [ dup 3 mod zero? ] } && nip ;
+
+: next-all-same ( x n -- n )
+    dup candidate? [
+        2dup swap map-nx all-same-digits?
+        [ nip ] [ 1+ next-all-same ] if
+    ] [
+        1+ next-all-same
+    ] if ;
+
+PRIVATE>
+
+: euler052 ( -- answer )
+    6 123456 next-all-same ;
+
+! [ euler052 ] 100 ave-time
+! 403 ms run / 7 ms GC ave time - 100 trials
+
+MAIN: euler052

extra/project-euler/067/067.factor

@@ -58,7 +58,4 @@ PRIVATE>
 ! [ euler067a ] 100 ave-time
 ! 14 ms run / 0 ms GC ave time - 100 trials
 
-! source-067 [ max-path ] curry 100 ave-time
-! 3 ms run / 0 ms GC ave time - 100 trials
-
 MAIN: euler067a

extra/project-euler/079/079.factor

@@ -0,0 +1,65 @@
+! Copyright (c) 2008 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs hashtables io.files kernel math math.parser namespaces sequences ;
+IN: project-euler.079
+
+! http://projecteuler.net/index.php?section=problems&id=79
+
+! DESCRIPTION
+! -----------
+
+! A common security method used for online banking is to ask the user for three
+! random characters from a passcode. For example, if the passcode was 531278,
+! they may asked for the 2nd, 3rd, and 5th characters; the expected reply would
+! be: 317.
+
+! The text file, keylog.txt, contains fifty successful login attempts.
+
+! Given that the three characters are always asked for in order, analyse the
+! file so as to determine the shortest possible secret passcode of unknown
+! length.
+
+
+! SOLUTION
+! --------
+
+<PRIVATE
+
+: source-079 ( -- seq )
+    "extra/project-euler/079/keylog.txt" resource-path file-lines ;
+
+: >edges ( seq -- seq )
+    [
+        [ string>digits [ 2 head , ] keep 2 tail* , ] each
+    ] { } make ;
+
+: find-source ( seq -- elt )
+    dup values swap keys [ prune ] 2apply seq-diff
+    dup empty? [ "Topological sort failed" throw ] [ first ] if ;
+
+: remove-source ( seq elt -- seq )
+    [ swap member? not ] curry subset ;
+
+: (topological-sort) ( seq -- )
+    dup length 1 > [
+        dup find-source dup , remove-source (topological-sort)
+    ] [
+        dup empty? [ drop ] [ first [ , ] each ] if
+    ] if ;
+
+PRIVATE>
+
+: topological-sort ( seq -- seq )
+    [ [ (topological-sort) ] { } make ] keep
+    concat prune dupd seq-diff append ;
+
+: euler079 ( -- answer )
+    source-079 >edges topological-sort 10 digits>integer ;
+
+! [ euler079 ] 100 ave-time
+! 2 ms run / 0 ms GC ave time - 100 trials
+
+! TODO: prune and seq-diff are relatively slow; topological sort could be
+! cleaned up and generalized much better, but it works for this problem
+
+MAIN: euler079

extra/project-euler/079/keylog.txt

@@ -0,0 +1,50 @@
+319
+680
+180
+690
+129
+620
+762
+689
+762
+318
+368
+710
+720
+710
+629
+168
+160
+689
+716
+731
+736
+729
+316
+729
+729
+710
+769
+290
+719
+680
+318
+389
+162
+289
+162
+718
+729
+319
+790
+680
+890
+362
+319
+760
+316
+729
+380
+319
+728
+716

extra/project-euler/097/097.factor

@@ -0,0 +1,31 @@
+! Copyright (c) 2008 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: math math.functions ;
+IN: project-euler.097
+
+! http://projecteuler.net/index.php?section=problems&id=97
+
+! DESCRIPTION
+! -----------
+
+! The first known prime found to exceed one million digits was discovered in
+! 1999, and is a Mersenne prime of the form 2^6972593 − 1; it contains exactly
+! 2,098,960 digits. Subsequently other Mersenne primes, of the form 2p − 1,
+! have been found which contain more digits.
+
+! However, in 2004 there was found a massive non-Mersenne prime which contains
+! 2,357,207 digits: 28433 * 2^7830457 + 1.
+
+! Find the last ten digits of this prime number.
+
+
+! SOLUTION
+! --------
+
+: euler097 ( -- answer )
+     2 7830457 10 10 ^ ^mod 28433 * 10 10 ^ mod 1+ ;
+
+! [ euler097 ] 100 ave-time
+! 0 ms run / 0 ms GC ave time - 100 trials
+
+MAIN: euler097

extra/project-euler/common/common.factor

@@ -1,6 +1,6 @@
 USING: arrays combinators.lib kernel math math.functions math.miller-rabin
     math.matrices math.parser math.primes.factors math.ranges namespaces
-    sequences sorting ;
+    sequences sorting unicode.case ;
 IN: project-euler.common
 
 ! A collection of words used by more than one Project Euler solution
@@ -8,10 +8,12 @@ IN: project-euler.common
 
 ! Problems using each public word
 ! -------------------------------
+! alpha-value - #22, #42
 ! cartesian-product - #4, #27, #29, #32, #33
 ! collect-consecutive - #8, #11
 ! log10 - #25, #134
 ! max-path - #18, #67
+! nth-triangle - #12, #42
 ! number>digits - #16, #20, #30, #34
 ! pandigital? - #32, #38
 ! propagate-all - #18, #67
@@ -52,6 +54,9 @@ IN: project-euler.common
 
 PRIVATE>
 
+: alpha-value ( str -- n )
+    >lower [ CHAR: a - 1+ ] sigma ;
+
 : cartesian-product ( seq1 seq2 -- seq1xseq2 )
     swap [ swap [ 2array ] map-with ] map-with concat ;
 
@@ -73,6 +78,9 @@ PRIVATE>
 : number>digits ( n -- seq )
     number>string string>digits ;
 
+: nth-triangle ( n -- n )
+    dup 1+ * 2 / ;
+
 : pandigital? ( n -- ? )
     number>string natural-sort "123456789" = ;
 

extra/project-euler/project-euler.factor

@@ -12,7 +12,9 @@ USING: definitions io io.files kernel math math.parser project-euler.ave-time
     project-euler.029 project-euler.030 project-euler.031 project-euler.032
     project-euler.033 project-euler.034 project-euler.035 project-euler.036
     project-euler.037 project-euler.038 project-euler.039 project-euler.040
-    project-euler.067 project-euler.075 project-euler.134 project-euler.169
+    project-euler.041 project-euler.042 project-euler.043 project-euler.044
+    project-euler.048 project-euler.052 project-euler.067 project-euler.075
+    project-euler.079 project-euler.097 project-euler.134 project-euler.169
     project-euler.173 project-euler.175 ;
 IN: project-euler
 

extra/random-tester/safe-words/safe-words.factor

@@ -16,7 +16,7 @@ IN: random-tester.safe-words
         array? integer? complex? value-ref? ref? key-ref?
         interval? number?
         wrapper? tuple?
-        [-1,1]? between? bignum? both? either? eq? equal? even? fixnum? float? fp-nan? hashtable? interval-contains? interval-subset? interval? key-ref? key? number? odd? pair? power-of-2? ratio? rational? real? subassoc? valid-digits? zero? assoc? curry? vector? callstack? ! clear 3.14 [ <vector> assoc? ] compile-1
+        [-1,1]? between? bignum? both? either? eq? equal? even? fixnum? float? fp-nan? hashtable? interval-contains? interval-subset? interval? key-ref? key? number? odd? pair? power-of-2? ratio? rational? real? subassoc? zero? assoc? curry? vector? callstack? ! clear 3.14 [ <vector> assoc? ] compile-1
         2^ not
         ! arrays
         resize-array <array>

extra/raptor/cron/cron.factor

@@ -1,6 +1,6 @@
 
 USING: kernel namespaces threads sequences calendar
-       combinators.cleave combinators.lib ;
+       combinators.cleave combinators.lib debugger ;
 
 IN: raptor.cron
 
@@ -43,9 +43,9 @@ C: <when> when
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 : recurring-job ( when quot -- )
-  [ swap when=now? [ call ] [ drop ] if 60000 sleep ] [ recurring-job ] 2bi ;
+  [ swap when=now? [ try ] [ drop ] if 60000 sleep ] [ recurring-job ] 2bi ;
 
-: schedule ( when quot -- ) [ recurring-job ] curry curry in-thread ;
+: schedule ( when quot -- ) [ recurring-job ] 2curry in-thread ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 

extra/rss/rss.factor

@@ -78,7 +78,7 @@ C: <entry> entry
 
 : download-feed ( url -- feed )
     #! Retrieve an news syndication file, return as a feed tuple.
-    http-get-stream rot 200 = [
+    http-get-stream rot success? [
         nip read-feed
     ] [
         2drop "Error retrieving newsfeed file" throw

extra/smtp/authors.txt

@@ -1 +1,3 @@
 Elie Chaftari
+Dirk Vleugels
+Slava Pestov

extra/smtp/server/server.factor

@@ -1,8 +1,10 @@
 ! Copyright (C) 2007 Elie CHAFTARI
 ! See http://factorcode.org/license.txt for BSD license.
 
-! Usage: 8889 start-server
+! Mock SMTP server for testing purposes.
-! $ telnet 127.0.0.1 8889
+
+! Usage: 4321 smtp-server
+! $ telnet 127.0.0.1 4321
 ! Trying 127.0.0.1...
 ! Connected to localhost.
 ! Escape character is '^]'.
@@ -26,7 +28,7 @@
 ! Connection closed by foreign host.
 
 USING: combinators kernel prettyprint io io.server sequences
-namespaces ;
+namespaces io.sockets continuations ;
 
 SYMBOL: data-mode
 
@@ -59,10 +61,12 @@ SYMBOL: data-mode
           ] }
     } cond nip [ process ] when ;
 
-: start-server ( port -- )
+: smtp-server ( port -- )
     "Starting SMTP server on port " write dup . flush
-    internet-server "smtp-server" [
+    "127.0.0.1" swap <inet4> <server> [
+        accept [
             60000 stdio get set-timeout
             "220 hello\r\n" write flush
             process
-    ] with-server ;
+        ] with-stream
+    ] with-disposal ;

extra/smtp/smtp-tests.factor

@@ -1,41 +1,111 @@
-! Tested with Apache JAMES version 2.3.1 on localhost
+USING: smtp tools.test io.streams.string threads
-! cram-md5 authentication tested against Exim 4
+smtp.server kernel sequences namespaces ;
-! Replace "localhost" with your smtp server
+IN: temporary
-! e.g. "your.smtp.server" initialize
 
-USING: smtp tools.test ;
+{ 0 0 } [ [ ] with-smtp-connection ] must-infer-as
 
-"localhost" initialize ! replace localhost with your smtp server
+[ "hello\nworld" validate-address ] must-fail
 
-! 8889 set-port ! default port = 25, change for testing purposes
+[ "slava@factorcode.org" ]
+[ "slava@factorcode.org" validate-address ] unit-test
 
-! 30000 set-read-timeout ! default = 60000
+[ { "hello" "." "world" } validate-message ] must-fail
-! f set-esmtp ! when esmtp (extended smtp) is not supported
 
-start
+[ "hello\r\nworld\r\n.\r\n" ] [
+    { "hello" "world" } [ send-body ] string-out
+] unit-test
 
-! "md5 password here" "login" cram-md5-auth
+[
+    [
+        "500 syntax error" check-response
+    ] with-log-stdio
+] must-fail
 
-"root@localhost" mailfrom ! your@mail.address
+[ ] [
+    [
+        "220 success" check-response
+    ] with-log-stdio
+] unit-test
 
-"root@localhost" rcptto ! someone@example.com
+[ "220 success" ] [
+    "220 success" [ receive-response ] string-in
+] unit-test
 
-! { "From: Your Name <your@mail.address>" 
+[ "220 the end" ] [
-!   "To: Destination Address <someone@example.com>"
+    [
-!   "Subject: test message"
+        "220-a multiline response\r\n250-another line\r\n220 the end"
-!   "Date: Thu, 17 May 2007 18:46:45 +0200"
+        [ receive-response ] string-in
-!   "Message-Id: <unique.message.id.string@example.com>"
+    ] with-log-stdio
-!   " "
+] unit-test
-!   "This is a test message."
-! } send-message
 
-{ "From: Your Name <root@localhost>" 
+[ ] [
-  "To: Destination Address <root@localhost>"
+    [
-  "Subject: test message"
+        "220-a multiline response\r\n250-another line\r\n220 the end"
-  "Date: Thu, 17 May 2007 18:46:45 +0200"
+        [ get-ok ] string-in
-  "Message-Id: <unique.message.id.string@example.com>"
+    ] with-log-stdio
+] unit-test
+
+[
+    "Subject:\r\nsecurity hole" validate-header
+] must-fail
+
+[
+    V{
+        { "To" "Slava <slava@factorcode.org>, Ed <dharmatech@factorcode.org>" }
+        { "From" "Doug <erg@factorcode.org>" }
+        { "Subject" "Factor rules" }
+    }
+    { "slava@factorcode.org" "dharmatech@factorcode.org" }
+    "erg@factorcode.org"
+] [
+    "Factor rules"
+    {
+        "Slava <slava@factorcode.org>"
+        "Ed <dharmatech@factorcode.org>"
+    }
+    "Doug <erg@factorcode.org>"
+    simple-headers >r >r 2 head* r> r>
+] unit-test
+
+[
+    {
+        "To: Slava <slava@factorcode.org>, Ed <dharmatech@factorcode.org>"
+        "From: Doug <erg@factorcode.org>"
+        "Subject: Factor rules"
+        f
+        f
         " "
-  "This is a test message."
+        "Hi guys"
-} send-message
+        "Bye guys"
+    }
+    { "slava@factorcode.org" "dharmatech@factorcode.org" }
+    "erg@factorcode.org"
+] [
+    "Hi guys\nBye guys"
+    "Factor rules"
+    {
+        "Slava <slava@factorcode.org>"
+        "Ed <dharmatech@factorcode.org>"
+    }
+    "Doug <erg@factorcode.org>"
+    prepare-simple-message
+    >r >r f 3 pick set-nth f 4 pick set-nth r> r>
+] unit-test
 
-quit
+[ ] [ [ 4321 smtp-server ] in-thread ] unit-test
+
+[ ] [
+    [
+        4321 smtp-port set
+
+        "Hi guys\nBye guys"
+        "Factor rules"
+        {
+            "Slava <slava@factorcode.org>"
+            "Ed <dharmatech@factorcode.org>"
+        }
+        "Doug <erg@factorcode.org>"
+
+        send-simple-message
+    ] with-scope
+] unit-test

extra/smtp/smtp.factor

@@ -1,138 +1,170 @@
-! Copyright (C) 2007 Elie CHAFTARI
+! Copyright (C) 2007, 2008 Elie CHAFTARI, Dirk Vleugels, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-!
+USING: namespaces io kernel logging io.sockets sequences
-! cram-md5 auth code contributed by Dirk Vleugels <dvl@2scale.net>
+combinators sequences.lib splitting assocs strings math.parser
-
+random system calendar ;
-USING: alien alien.c-types combinators crypto.common crypto.hmac base64
-kernel io io.sockets namespaces sequences splitting ;
 
 IN: smtp
 
-! =========================================================
+SYMBOL: smtp-domain
-! smtp.factor implementation
+SYMBOL: smtp-host       "localhost" smtp-host set-global
-! =========================================================
+SYMBOL: smtp-port       25 smtp-port set-global
+SYMBOL: read-timeout    60000 read-timeout set-global
+SYMBOL: esmtp           t esmtp set-global
 
-! Connection default values
+: log-smtp-connection ( host port -- ) 2drop ;
-: default-port  25                      ; inline
-: read-timeout  60000                   ; inline
-: esmtp         t                       ; inline ! t = ehlo
-: domain        "localhost.localdomain" ; inline
 
-SYMBOL: sess
+\ log-smtp-connection NOTICE add-input-logging
-SYMBOL: conn
-SYMBOL: challenge
 
-TUPLE: session address port timeout domain esmtp ;
+: with-smtp-connection ( quot -- )
+    smtp-host get smtp-port get
+    2dup log-smtp-connection
+    <inet> <client> [
+        smtp-domain [ host-name or ] change
+        read-timeout get stdio get set-timeout
+        call
+    ] with-stream ; inline
 
-: <session> ( address -- session )
+: crlf "\r\n" write ;
-    default-port read-timeout domain esmtp
-    session construct-boa ;
 
-! =========================================================
+: helo ( -- )
-! Initialization routines
+    esmtp get "EHLO " "HELO " ? write host-name write crlf ;
-! =========================================================
 
-: initialize ( address -- )
+: validate-address ( string -- string' )
-    <session> sess set ;
+    #! Make sure we send funky stuff to the server by accident.
+    dup [ "\r\n>" member? ] contains?
+    [ "Bad e-mail address: " swap append throw ] when ;
 
-: set-port ( port -- )
+: mail-from ( fromaddr -- )
-    sess get set-session-port ;
+    "MAIL FROM:<" write validate-address write ">" write crlf ;
 
-: set-read-timeout ( timeout -- )
+: rcpt-to ( to -- )
-    sess get set-session-timeout ;
+    "RCPT TO:<" write validate-address write ">" write crlf ;
 
-: set-esmtp ( esmtp -- )
+: data ( -- )
-    sess get set-session-esmtp ;
+    "DATA" write crlf ;
 
-: set-domain ( -- )
+: validate-message ( msg -- msg' )
-    host-name sess get set-session-domain ;
+    "." over member? [ "Message cannot contain . on a line by itself" throw ] when ;
 
-: do-start ( -- )
+: send-body ( body -- )
-    sess get [ session-address ] keep session-port <inet> <client>
+    validate-message
-    dup conn set [ sess get session-timeout swap set-timeout ]
+    [ write crlf ] each
-    keep stream-readln print ;
+    "." write crlf ;
 
-! =========================================================
+: quit ( -- )
-! Command routines
+    "QUIT" write crlf ;
-! =========================================================
+
+LOG: smtp-response DEBUG
 
 : check-response ( response -- )
     {
-        { [ dup "220" head? ] [ print ] }
+        { [ dup "220" head? ] [ smtp-response ] }
-        { [ dup "235" swap subseq? ] [ print ] }
+        { [ dup "235" swap subseq? ] [ smtp-response ] }
-        { [ dup "250" head? ] [ print ] }
+        { [ dup "250" head? ] [ smtp-response ] }
-        { [ dup "221" head? ] [ print ] }
+        { [ dup "221" head? ] [ smtp-response ] }
-        { [ dup "bye" head? ] [ print ] }
+        { [ dup "bye" head? ] [ smtp-response ] }
         { [ dup "4" head? ] [ "server busy" throw ] }
-        { [ dup "334" head? ] [ " " split 1 swap nth base64> challenge set ] }
+        { [ dup "354" head? ] [ smtp-response ] }
-        { [ dup "354" head? ] [ print ] }
+        { [ dup "50" head? ] [ smtp-response "syntax error" throw ] }
-        { [ dup "50" head? ] [ print "syntax error" throw ] }
+        { [ dup "53" head? ] [ smtp-response "invalid authentication data" throw ] }
-        { [ dup "53" head? ] [ print "invalid authentication data" throw ] }
+        { [ dup "55" head? ] [ smtp-response "fatal error" throw ] }
-        { [ dup "55" head? ] [ print "fatal error" throw ] }
+        { [ t ] [ "unknown error" throw ] }
-        { [ t ] [ "unknow error" throw ] }
     } cond ;
 
-SYMBOL: multiline
-
 : multiline? ( response -- boolean )
-    CHAR: - swap index 3 = ;
+    ?fourth CHAR: - = ;
 
-: process-multiline ( -- response )
+: process-multiline ( multiline -- response )
-    conn get stream-readln dup
+    >r readln r> 2dup " " append head? [
-    multiline get " " append head? [ 
+        drop dup smtp-response
-        print
     ] [
-        check-response process-multiline
+        swap check-response process-multiline
     ] if ;
 
-: recv-response ( -- response )
+: receive-response ( -- response )
-    conn get stream-readln
+    readln
-    dup multiline? [
+    dup multiline? [ 3 head process-multiline ] when ;
-        dup 3 head multiline set process-multiline
-    ] [ ] if ;
 
-: get-ok ( command -- )
+: get-ok ( -- ) flush receive-response check-response ;
-    >r conn get r> over stream-write stream-flush
-    recv-response check-response ;
 
-: helo ( -- )
+: send-raw-message ( body to from -- )
-    "HELO " sess get session-domain append "\r\n" append get-ok ;
+    [
+        helo get-ok
+        mail-from get-ok
+        [ rcpt-to get-ok ] each
+        data get-ok
+        send-body get-ok
+        quit get-ok
+    ] with-smtp-connection ;
 
-: ehlo ( -- )
+: validate-header ( string -- string' )
-    "EHLO " sess get session-domain append "\r\n" append get-ok ;
+    dup [ "\r\n" member? ] contains?
+    [ "Invalid header string: " swap append throw ] when ;
 
-: mailfrom ( fromaddr -- )
+: prepare-header ( key value -- )
-    "MAIL FROM:<" swap append ">\r\n" append get-ok ;
+    swap
+    validate-header %
+    ": " %
+    validate-header % ;
 
-: rcptto ( to -- )
+: prepare-headers ( assoc -- )
-    "RCPT TO:<" swap append ">\r\n" append get-ok ;
+    [ [ prepare-header ] "" make , ] assoc-each ;
 
-: (cram-md5-auth) ( -- response )
+: extract-email ( recepient -- email )
-    swap challenge get 
+    #! This could be much smarter.
-    string>md5-hmac hex-string 
+    " " last-split1 [ ] [ ] ?if "<" ?head drop ">" ?tail drop ;
-    " " swap append append 
-    >base64 ;
 
-: cram-md5-auth ( key login  -- )
+: message-id ( -- string )
-    "AUTH CRAM-MD5\r\n" get-ok 
+    [
-    (cram-md5-auth) "\r\n" append get-ok ;
+        "<" %
+        2 big-random #
+        "-" %
+        millis #
+        "@" %
+        smtp-domain get %
+        ">" %
+    ] "" make ;
 
-: data ( -- )
+: simple-headers ( subject to from -- headers to from )
-    "DATA\r\n" get-ok ;
+    [
+        >r dup ", " join "To" set [ extract-email ] map r>
+        dup "From" set extract-email
+        rot "Subject" set
+        now timestamp>rfc822-string "Date" set
+        message-id "Message-Id" set
+    ] { } make-assoc -rot ;
 
-: start ( -- )
+: prepare-message ( body headers -- body' )
-    set-domain ! replaces localhost.localdomain with hostname
+    [
-    do-start
+        prepare-headers
-    sess get session-esmtp [
+        " " ,
-        ehlo
+        dup string? [ string-lines ] when %
-    ] [
+    ] { } make ;
-        helo
-    ] if ;
 
-: send-message ( msg -- )
+: prepare-simple-message ( body subject to from -- body' to from )
-    data
+    simple-headers >r >r prepare-message r> r> ;
-    "\r\n" join conn get swap "\r\n" append over stream-write
-    stream-flush ".\r\n" get-ok ;
 
-: quit ( -- )
+: send-message ( body headers to from -- )
-    "QUIT\r\n" get-ok ;
+    >r >r prepare-message r> r> send-raw-message ;
+
+: send-simple-message ( body subject to from -- )
+    prepare-simple-message send-raw-message ;
+
+! Dirk's old AUTH CRAM-MD5 code. I don't know anything about
+! CRAM MD5, and the old code didn't work properly either, so here
+! it is in case anyone wants to fix it later.
+!
+! check-response used to have this clause:
+! { [ dup "334" head? ] [ " " split 1 swap nth base64> challenge set ] }
+!
+! and the rest of the code was as follows:
+! : (cram-md5-auth) ( -- response )
+!     swap challenge get 
+!     string>md5-hmac hex-string 
+!     " " swap append append 
+!     >base64 ;
+! 
+! : cram-md5-auth ( key login  -- )
+!     "AUTH CRAM-MD5\r\n" get-ok 
+!     (cram-md5-auth) "\r\n" append get-ok ;