From fe55e939f95b198602ca12659fc13759c33a6fc5 Mon Sep 17 00:00:00 2001 From: Jason Merrill Date: Thu, 12 Feb 2009 23:13:16 -0500 Subject: [PATCH 01/45] Added math.dual and math.derivatives for computing with dual numbers. Also made a few more methods in math.functions generic in order to specialize them on dual numbers. --- basis/math/functions/functions.factor | 8 +- extra/math/derivatives/authors.txt | 1 + .../math/derivatives/derivatives-docs.factor | 11 +++ .../math/derivatives/derivatives-tests.factor | 4 + extra/math/derivatives/derivatives.factor | 34 +++++++ extra/math/derivatives/syntax/authors.txt | 1 + .../derivatives/syntax/syntax-docs.factor | 18 ++++ extra/math/derivatives/syntax/syntax.factor | 10 +++ extra/math/dual/authors.txt | 1 + extra/math/dual/dual-docs.factor | 90 +++++++++++++++++++ extra/math/dual/dual-tests.factor | 14 +++ extra/math/dual/dual.factor | 80 +++++++++++++++++ 12 files changed, 270 insertions(+), 2 deletions(-) create mode 100644 extra/math/derivatives/authors.txt create mode 100644 extra/math/derivatives/derivatives-docs.factor create mode 100644 extra/math/derivatives/derivatives-tests.factor create mode 100644 extra/math/derivatives/derivatives.factor create mode 100644 extra/math/derivatives/syntax/authors.txt create mode 100644 extra/math/derivatives/syntax/syntax-docs.factor create mode 100644 extra/math/derivatives/syntax/syntax.factor create mode 100644 extra/math/dual/authors.txt create mode 100644 extra/math/dual/dual-docs.factor create mode 100644 extra/math/dual/dual-tests.factor create mode 100644 extra/math/dual/dual.factor diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor index 85b4d711ac..3a1ce18daa 100644 --- a/basis/math/functions/functions.factor +++ b/basis/math/functions/functions.factor @@ -252,10 +252,14 @@ M: real tanh ftanh ; : -i* ( x -- y ) >rect swap neg rect> ; -: asin ( x -- y ) +GENERIC: asin ( x -- y ) foldable + +M: number asin dup [-1,1]? [ fasin ] [ i* asinh -i* ] if ; inline -: acos ( x -- y ) +GENERIC: acos ( x -- y ) foldable + +M: number acos dup [-1,1]? [ facos ] [ asin pi 2 / swap - ] if ; inline diff --git a/extra/math/derivatives/authors.txt b/extra/math/derivatives/authors.txt new file mode 100644 index 0000000000..b6089d8622 --- /dev/null +++ b/extra/math/derivatives/authors.txt @@ -0,0 +1 @@ +Jason W. Merrill \ No newline at end of file diff --git a/extra/math/derivatives/derivatives-docs.factor b/extra/math/derivatives/derivatives-docs.factor new file mode 100644 index 0000000000..4905f260bc --- /dev/null +++ b/extra/math/derivatives/derivatives-docs.factor @@ -0,0 +1,11 @@ +! Copyright (C) 2009 Jason W. Merrill. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax ; +IN: math.derivatives + +ARTICLE: "math.derivatives" "Derivatives" +"The " { $vocab-link "math.derivatives" } " vocabulary defines the derivative of many of the words in the " { $vocab-link "math" } " and " { $vocab-link "math.functions" } " vocabularies. The derivative for a word is given by a sequence of quotations stored in its " { $snippet "derivative" } " word property that give the partial derivative of the word with respect to each of its inputs." +{ $see-also "math.derivatives.syntax" } +; + +ABOUT: "math.derivatives" diff --git a/extra/math/derivatives/derivatives-tests.factor b/extra/math/derivatives/derivatives-tests.factor new file mode 100644 index 0000000000..f95eb43849 --- /dev/null +++ b/extra/math/derivatives/derivatives-tests.factor @@ -0,0 +1,4 @@ +! Copyright (C) 2009 Jason W. Merrill. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test automatic-differentiation.derivatives ; +IN: automatic-differentiation.derivatives.tests diff --git a/extra/math/derivatives/derivatives.factor b/extra/math/derivatives/derivatives.factor new file mode 100644 index 0000000000..8e69cec129 --- /dev/null +++ b/extra/math/derivatives/derivatives.factor @@ -0,0 +1,34 @@ +! Copyright (C) 2009 Jason W. Merrill. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math math.functions math.derivatives.syntax ; +IN: math.derivatives + +DERIVATIVE: + [ 2drop ] [ 2drop ] +DERIVATIVE: - [ 2drop ] [ 2drop neg ] +DERIVATIVE: * [ nip * ] [ drop * ] +DERIVATIVE: / [ nip / ] [ sq / neg * ] +! Conditional checks if the epsilon-part of the exponent is +! 0 to avoid getting float answers for integer powers. +DERIVATIVE: ^ [ [ 1 - ^ ] keep * * ] + [ [ dup zero? ] 2dip [ 3drop 0 ] [ [ ^ ] keep log * * ] if ] + +DERIVATIVE: sqrt [ sqrt 2 * / ] + +DERIVATIVE: exp [ exp * ] +DERIVATIVE: log [ / ] + +DERIVATIVE: sin [ cos * ] +DERIVATIVE: cos [ sin neg * ] +DERIVATIVE: tan [ sec sq * ] + +DERIVATIVE: sinh [ cosh * ] +DERIVATIVE: cosh [ sinh * ] +DERIVATIVE: tanh [ sech sq * ] + +DERIVATIVE: asin [ sq neg 1 + sqrt / ] +DERIVATIVE: acos [ sq neg 1 + sqrt neg / ] +DERIVATIVE: atan [ sq 1 + / ] + +DERIVATIVE: asinh [ sq 1 + sqrt / ] +DERIVATIVE: acosh [ [ 1 + sqrt ] [ 1 - sqrt ] bi * / ] +DERIVATIVE: atanh [ sq neg 1 + / ] \ No newline at end of file diff --git a/extra/math/derivatives/syntax/authors.txt b/extra/math/derivatives/syntax/authors.txt new file mode 100644 index 0000000000..b6089d8622 --- /dev/null +++ b/extra/math/derivatives/syntax/authors.txt @@ -0,0 +1 @@ +Jason W. Merrill \ No newline at end of file diff --git a/extra/math/derivatives/syntax/syntax-docs.factor b/extra/math/derivatives/syntax/syntax-docs.factor new file mode 100644 index 0000000000..2273e7b83c --- /dev/null +++ b/extra/math/derivatives/syntax/syntax-docs.factor @@ -0,0 +1,18 @@ +! Copyright (C) 2009 Jason W. Merrill. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax ; +IN: math.derivatives.syntax + +HELP: DERIVATIVE: +{ $description "Defines the derivative of a word by setting its " { $snippet "derivative" } " word property. Reads a word followed by " { $snippet "n" } " quotations, giving the " { $snippet "n" } " partial derivatives of the word with respect to each of its arguments successively. Each quotation should take " { $snippet "n + 1" } " inputs, where the first input is an increment and the last " { $snippet "n" } " inputs are the point at which to evaluate the derivative. The derivative should be a linear function of the increment, and should have the same number of outputs as the original word." } +{ $examples + { $unchecked-example "USING: math math.functions math.derivatives.syntax ;" + "DERIVATIVE: sin [ cos * ]" + "DERIVATIVE: * [ nip * ] [ drop * ]" "" } +} ; + +ARTICLE: "math.derivatives.syntax" "Derivative Syntax" +"The " { $vocab-link "math.derivatives.syntax" } " vocabulary provides the " { $link POSTPONE: DERIVATIVE: } " syntax for specifying the derivative of a word." +; + +ABOUT: "math.derivatives.syntax" diff --git a/extra/math/derivatives/syntax/syntax.factor b/extra/math/derivatives/syntax/syntax.factor new file mode 100644 index 0000000000..02b0608ed8 --- /dev/null +++ b/extra/math/derivatives/syntax/syntax.factor @@ -0,0 +1,10 @@ +! Copyright (C) 2009 Jason W. Merrill. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel parser words effects accessors sequences + math.ranges ; + +IN: math.derivatives.syntax + +: DERIVATIVE: scan-object dup stack-effect in>> length [1,b] + [ drop scan-object ] map + "derivative" set-word-prop ; parsing \ No newline at end of file diff --git a/extra/math/dual/authors.txt b/extra/math/dual/authors.txt new file mode 100644 index 0000000000..b6089d8622 --- /dev/null +++ b/extra/math/dual/authors.txt @@ -0,0 +1 @@ +Jason W. Merrill \ No newline at end of file diff --git a/extra/math/dual/dual-docs.factor b/extra/math/dual/dual-docs.factor new file mode 100644 index 0000000000..de3b0749a5 --- /dev/null +++ b/extra/math/dual/dual-docs.factor @@ -0,0 +1,90 @@ +! Copyright (C) 2009 Jason W. Merrill. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax kernel words math math.functions math.derivatives.syntax ; +IN: math.dual + +HELP: +{ $values + { "ordinary-part" real } { "epsilon-part" real } + { "dual" dual number } +} +{ $description "Creates a dual number from its ordinary and epsilon parts." } ; + +HELP: d* +{ $values + { "x" dual } { "y" dual } + { "x*y" dual } +} +{ $description "Multiply dual numbers." } ; + +HELP: d+ +{ $values + { "x" dual } { "y" dual } + { "x+y" dual } +} +{ $description "Add dual numbers." } ; + +HELP: d- +{ $values + { "x" dual } { "y" dual } + { "x-y" dual } +} +{ $description "Subtract dual numbers." } ; + +HELP: d/ +{ $values + { "x" dual } { "y" dual } + { "x/y" dual } +} +{ $description "Divide dual numbers." } +{ $errors "Throws an error if the ordinary part of " { $snippet "x" } " is zero." } ; + +HELP: d^ +{ $values + { "x" dual } { "y" dual } + { "x^y" dual } +} +{ $description "Raise a dual number to a (possibly dual) power" } ; + +HELP: define-dual-method +{ $values + { "word" word } +} +{ $description "Defines a method on the dual numbers for generic word." } +{ $notes "Uses the derivative word-prop, which holds a list of quotations giving the partial derivatives of the word with respect to each of its arguments. This can be set using " { $link POSTPONE: DERIVATIVE: } "." } ; + +{ define-dual-method dual-op POSTPONE: DERIVATIVE: } related-words + +HELP: dual +{ $class-description "The class of dual numbers with non-zero epsilon part." } ; + +HELP: dual-op +{ $values + { "word" word } +} +{ $description "Similar to " { $link execute } ", but promotes word to operate on duals." } +{ $notes "Uses the derivative word-prop, which holds a list of quotations giving the partial derivatives of the word with respect to each of its arguments. This can be set using " { $link POSTPONE: DERIVATIVE: } ". Once a derivative has been defined for a word, dual-op makes it easy to extend the definition to dual numbers." } +{ $examples + { $unchecked-example "USING: math math.dual math.derivatives.syntax math.functions ;" + "DERIVATIVE: sin [ cos * ]" + "M: dual sin \\sin dual-op ;" "" } + { $unchecked-example "USING: math math.dual math.derivatives.syntax ;" + "DERIVATIVE: * [ drop ] [ nip ]" + ": d* ( x y -- x*y ) \ * dual-op ;" "" } +} ; + +HELP: unpack-dual +{ $values + { "dual" dual } + { "ordinary-part" number } { "epsilon-part" number } +} +{ $description "Extracts the ordinary and epsilon part of a dual number." } ; + +ARTICLE: "math.dual" "Dual Numbers" +"The " { $vocab-link "math.dual" } " vocabulary implements dual numbers, along with arithmetic methods for working with them. Many of the functions in " { $vocab-link "math.functions" } " are extended to work with dual numbers." +$nl +"Dual numbers are ordered pairs " { $snippet ""} "--an ordinary part and an epsilon part--with component-wise addition and multiplication defined by "{ $snippet "* = " } ". They are analagous to complex numbers with " { $snippet "i^2 = 0" } "instead of " { $snippet "i^2 = -1" } ". For well-behaved functions " { $snippet "f" } ", " { $snippet "f() = f(o1) + e1*f'(o1)" } ", where " { $snippet "f'"} " is the derivative of " { $snippet "f" } "." +; + + +ABOUT: "math.dual" diff --git a/extra/math/dual/dual-tests.factor b/extra/math/dual/dual-tests.factor new file mode 100644 index 0000000000..2fe751dd63 --- /dev/null +++ b/extra/math/dual/dual-tests.factor @@ -0,0 +1,14 @@ +! Copyright (C) 2009 Jason W. Merrill. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test math.dual kernel accessors math math.functions + math.constants ; +IN: math.dual.tests + +[ 0.0 1.0 ] [ 0 1 sin unpack-dual ] unit-test +[ 1.0 0.0 ] [ 0 1 cos unpack-dual ] unit-test +[ 3 5 ] [ 1 5 2 d+ unpack-dual ] unit-test +[ 0 -1 ] [ 1 5 1 6 d- unpack-dual ] unit-test +[ 2 1 ] [ 2 3 1 -1 d* unpack-dual ] unit-test +[ 1/2 -1/4 ] [ 2 1 1 swap d/ unpack-dual ] unit-test +[ 2 ] [ 1 1 2 d^ epsilon-part>> ] unit-test +[ 2.0 .25 ] [ 4 1 sqrt unpack-dual ] unit-test \ No newline at end of file diff --git a/extra/math/dual/dual.factor b/extra/math/dual/dual.factor new file mode 100644 index 0000000000..214db9b678 --- /dev/null +++ b/extra/math/dual/dual.factor @@ -0,0 +1,80 @@ +! Copyright (C) 2009 Jason W. Merrill. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math math.functions math.derivatives accessors + macros words effects sequences generalizations fry + combinators.smart generic compiler.units ; + +IN: math.dual + +TUPLE: dual ordinary-part epsilon-part ; + +C: dual + +! Ordinary numbers implement the dual protocol by returning +! themselves as the ordinary part, and 0 as the epsilon part. +M: number ordinary-part>> ; + +M: number epsilon-part>> drop 0 ; + +: unpack-dual ( dual -- ordinary-part epsilon-part ) + [ ordinary-part>> ] [ epsilon-part>> ] bi ; + +> length ; + +MACRO: ordinary-op ( word -- o ) + [ input-length ] keep + '[ [ ordinary-part>> ] _ napply _ execute ] ; + +! Takes N dual numbers ... and weaves +! their ordinary and epsilon parts to produce +! e1 o1 o2 ... oN e2 o1 o2 ... oN ... eN o1 o2 ... oN +! This allows a set of partial derivatives each to be evaluated +! at the same point. +MACRO: duals>nweave ( n -- ) + dup dup dup + '[ + [ [ epsilon-part>> ] _ napply ] + _ nkeep + [ ordinary-part>> ] _ napply + _ nweave + ] ; + +MACRO: chain-rule ( word -- e ) + [ input-length '[ _ duals>nweave ] ] + [ "derivative" word-prop ] + [ input-length 1+ '[ _ nspread ] ] + tri + '[ [ @ _ @ ] sum-outputs ] ; + +PRIVATE> + +MACRO: dual-op ( word -- ) + [ '[ _ ordinary-op ] ] + [ input-length '[ _ nkeep ] ] + [ '[ _ chain-rule ] ] + tri + '[ _ @ @ ] ; + +: define-dual-method ( word -- ) + [ \ dual swap create-method ] keep '[ _ dual-op ] define ; + +! Specialize math functions to operate on dual numbers. +[ { sqrt exp log sin cos tan sinh cosh tanh acos asin atan } + [ define-dual-method ] each ] with-compilation-unit + +! Inverse methods { asinh, acosh, atanh } are not generic, so +! there is no way to specialize them for dual numbers. However, +! they are defined in terms of functions that can operate on +! dual numbers and arithmetic methods, so if it becomes +! possible to make arithmetic operators work directly on dual +! numbers, we will get these for free. + +! Arithmetic methods are not generic (yet?), so we have to +! define special versions of them to operate on dual numbers. +: d+ ( x y -- x+y ) \ + dual-op ; +: d- ( x y -- x-y ) \ - dual-op ; +: d* ( x y -- x*y ) \ * dual-op ; +: d/ ( x y -- x/y ) \ / dual-op ; +: d^ ( x y -- x^y ) \ ^ dual-op ; \ No newline at end of file From b3e20dfdf2bba6c85c6828e7f38876fc35a54d08 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 13 Feb 2009 15:10:46 -0600 Subject: [PATCH 02/45] better factor annotations docs --- extra/annotations/annotations-docs.factor | 30 ++++++++++++++--------- 1 file changed, 19 insertions(+), 11 deletions(-) diff --git a/extra/annotations/annotations-docs.factor b/extra/annotations/annotations-docs.factor index c340554119..1effdf4067 100644 --- a/extra/annotations/annotations-docs.factor +++ b/extra/annotations/annotations-docs.factor @@ -9,6 +9,22 @@ IN: annotations : comment-usage.-word ( base -- word ) "s." append "annotations" lookup ; PRIVATE> +: $annotation ( element -- ) + P first + [ "!" " your comment here" surround 1array $syntax ] + [ [ "Treats the rest of the line after the exclamation point as a code annotation that can be looked up with the " \ $link ] dip comment-usage.-word 2array " word." 3array $description ] + [ ": foo ( x y z -- w )\n !" " --w-ó()ò-w-- kilroy was here\n + * ;" surround 1array $unchecked-example ] + tri ; + +: $annotation-usage. ( element -- ) + first + [ "Displays a list of words, help articles, and vocabularies that contain " \ $link ] dip comment-word 2array " annotations." 3array $description ; + +: $annotation-usage ( element -- ) + first + { "usages" sequence } $values + [ "Returns a list of words, help articles, and vocabularies that contain " \ $link ] dip [ comment-word 2array " annotations. For a more user-friendly display, use the " \ $link ] [ comment-usage.-word 2array " word." 6 narray ] bi 1array $description ; + "Code annotations" { "The " { $vocab-link "annotations" } " vocabulary provides syntax for comment-like annotations that can be looked up with Factor's " { $link usage } " mechanism." @@ -26,17 +42,9 @@ annotation-tags natural-sort annotation-tags [ { - [ [ \ $syntax ] dip "!" " your comment here" surround 2array ] - [ [ \ $description "Treats the rest of the line after the exclamation point as a code annotation that can be looked up with the " \ $link ] dip comment-usage.-word 2array " word." 4array ] - [ [ \ $unchecked-example ] dip ": foo ( x y z -- w )\n !" " --w-ó()ò-w-- kilroy was here\n + * ;" surround 2array 3array ] - [ comment-word set-word-help ] - - [ [ \ $description "Displays a list of words, help articles, and vocabularies that contain " \ $link ] dip comment-word 2array " annotations." 4array 1array ] - [ comment-usage.-word set-word-help ] - - [ [ { $values { "usages" sequence } } \ $description "Returns a list of words, help articles, and vocabularies that contain " \ $link ] dip [ comment-word 2array " annotations. For a more user-friendly display, use the " \ $link ] [ comment-usage.-word 2array " word." 6 narray 2array ] bi ] - [ comment-usage-word set-word-help ] - + [ [ \ $annotation swap 2array 1array ] [ comment-word set-word-help ] bi ] + [ [ \ $annotation-usage swap 2array 1array ] [ comment-usage-word set-word-help ] bi ] + [ [ \ $annotation-usage. swap 2array 1array ] [ comment-usage.-word set-word-help ] bi ] [ [ comment-word ] [ comment-usage-word ] [ comment-usage.-word ] tri 3array related-words ] } cleave ] each From 8169c35b9ef5b2e25d7a439dcd2c80f712ed73b0 Mon Sep 17 00:00:00 2001 From: "Yun, Jonghyouk" Date: Tue, 17 Feb 2009 16:40:01 +0900 Subject: [PATCH 03/45] io.encodings.korean TODOs --- basis/io/encodings/korean/korean.factor | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/basis/io/encodings/korean/korean.factor b/basis/io/encodings/korean/korean.factor index cd98bb1eb0..8771c1d928 100644 --- a/basis/io/encodings/korean/korean.factor +++ b/basis/io/encodings/korean/korean.factor @@ -6,6 +6,11 @@ math.order math.parser memoize multiline sequences splitting values hashtables io.binary ; IN: io.encodings.korean +! TODO: write-docs +! TODO: euckr, cp949 seperate (euckr: backslash = Won, cp949: bs <> Won) +! TODO: no byte manip. only code-tables. +! TODO: migrate to common code-table parser (by Dan). + SINGLETON: cp949 cp949 "EUC-KR" register-encoding From da9ae85637008259c5da1e21b5c070c672fce651 Mon Sep 17 00:00:00 2001 From: "Yun, Jonghyouk" Date: Tue, 17 Feb 2009 21:46:57 +0900 Subject: [PATCH 04/45] io.encodings.korean some docs. --- basis/io/encodings/korean/korean-docs.factor | 14 ++++++++++++++ 1 file changed, 14 insertions(+) create mode 100644 basis/io/encodings/korean/korean-docs.factor diff --git a/basis/io/encodings/korean/korean-docs.factor b/basis/io/encodings/korean/korean-docs.factor new file mode 100644 index 0000000000..2500e794a7 --- /dev/null +++ b/basis/io/encodings/korean/korean-docs.factor @@ -0,0 +1,14 @@ +! Copyright (C) 2009 Yun, Jonghyouk. +! See http://factorcode.org/license.txt for BSD license. +USING: help.syntax help.markup ; +IN: io.encodings.korean + +ARTICLE: "io.encodings.korean" "Korean text encodings" +"The " { $vocab-link "io.encodings.korean" } " vocabulary implements encodings used for Korean text besides the standard UTF encodings for Unicode strings." +{ $subsection cp949 } ; + +ABOUT: "io.encodings.korean" + +HELP: cp949 +{ $class-description "This encoding class implements Microsoft's code page #949 encoding, also called Unified Hangul Code or ks_c_5601-1987, UHC. CP949 is extended version of EUC-KR and downward-compatibility to EUC-KR. " } +{ $see-also "encodings-introduction" } ; From 89a3e45a3abe17c8a3199391213d0db00502a570 Mon Sep 17 00:00:00 2001 From: "Yun, Jonghyouk" Date: Tue, 17 Feb 2009 21:47:45 +0900 Subject: [PATCH 05/45] io.encodings.korean TODOs comment --- basis/io/encodings/korean/korean.factor | 1 - 1 file changed, 1 deletion(-) diff --git a/basis/io/encodings/korean/korean.factor b/basis/io/encodings/korean/korean.factor index 8771c1d928..c1fed1d57c 100644 --- a/basis/io/encodings/korean/korean.factor +++ b/basis/io/encodings/korean/korean.factor @@ -6,7 +6,6 @@ math.order math.parser memoize multiline sequences splitting values hashtables io.binary ; IN: io.encodings.korean -! TODO: write-docs ! TODO: euckr, cp949 seperate (euckr: backslash = Won, cp949: bs <> Won) ! TODO: no byte manip. only code-tables. ! TODO: migrate to common code-table parser (by Dan). From 4440a210b101b3cbde5ca545f4c2d3d4a104973a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 17 Feb 2009 11:28:43 -0600 Subject: [PATCH 06/45] make io.servers.packet load again --- basis/io/servers/packet/{datagram.factor => packet.factor} | 3 +++ 1 file changed, 3 insertions(+) rename basis/io/servers/packet/{datagram.factor => packet.factor} (80%) diff --git a/basis/io/servers/packet/datagram.factor b/basis/io/servers/packet/packet.factor similarity index 80% rename from basis/io/servers/packet/datagram.factor rename to basis/io/servers/packet/packet.factor index c081dfb0fa..3f092ab9f1 100644 --- a/basis/io/servers/packet/datagram.factor +++ b/basis/io/servers/packet/packet.factor @@ -1,3 +1,5 @@ +USING: concurrency.combinators destructors fry +io.servers.datagram.private io.sockets kernel logging ; IN: io.servers.datagram : with-datagrams ( seq service quot -- ) + [ DEBUG ] dip '[ [ [ _ ] dip spawn-datagrams ] parallel-each ] with-logging ; inline From d92b02b0c29414e6b8ddf5242451024d8a8fedc8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 17 Feb 2009 11:30:06 -0600 Subject: [PATCH 07/45] use the new with-logging --- basis/io/servers/connection/connection.factor | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/basis/io/servers/connection/connection.factor b/basis/io/servers/connection/connection.factor index bc90915213..91fb3bfb37 100644 --- a/basis/io/servers/connection/connection.factor +++ b/basis/io/servers/connection/connection.factor @@ -12,6 +12,7 @@ IN: io.servers.connection TUPLE: threaded-server name +log-level secure insecure secure-config sockets @@ -29,6 +30,7 @@ ready ; : new-threaded-server ( class -- threaded-server ) new "server" >>name + DEBUG >>log-level ascii >>encoding 1 minutes >>timeout V{ } clone >>sockets @@ -115,7 +117,7 @@ M: threaded-server handle-client* handler>> call ; : (start-server) ( threaded-server -- ) init-server dup threaded-server [ - dup name>> [ + [ ] [ name>> ] [ log-level>> ] tri [ [ listen-on [ start-accept-loop ] parallel-each ] [ ready>> raise-flag ] bi From e55425a65e20565879fb728ebe22e3a18aa892e8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 17 Feb 2009 11:30:28 -0600 Subject: [PATCH 08/45] with-logging takes a log-level, more docs --- basis/logging/insomniac/insomniac.factor | 2 +- basis/logging/logging-docs.factor | 11 +++++---- basis/logging/logging.factor | 30 ++++++++++++++++++++---- basis/logging/parser/parser.factor | 4 ++-- 4 files changed, 35 insertions(+), 12 deletions(-) diff --git a/basis/logging/insomniac/insomniac.factor b/basis/logging/insomniac/insomniac.factor index 91baae631f..935326da2d 100644 --- a/basis/logging/insomniac/insomniac.factor +++ b/basis/logging/insomniac/insomniac.factor @@ -30,7 +30,7 @@ SYMBOL: insomniac-recipients \ (email-log-report) NOTICE add-error-logging : email-log-report ( service word-names -- ) - "logging.insomniac" [ (email-log-report) ] with-logging ; + "logging.insomniac" DEBUG [ (email-log-report) ] with-logging ; : schedule-insomniac ( service word-names -- ) [ [ email-log-report ] assoc-each rotate-logs ] 2curry diff --git a/basis/logging/logging-docs.factor b/basis/logging/logging-docs.factor index 275d900f3d..64956493c6 100644 --- a/basis/logging/logging-docs.factor +++ b/basis/logging/logging-docs.factor @@ -8,6 +8,9 @@ HELP: DEBUG HELP: NOTICE { $description "Log level for ordinary messages." } ; +HELP: WARNING +{ $description "Log level for warnings." } ; + HELP: ERROR { $description "Log level for error messages." } ; @@ -18,6 +21,7 @@ ARTICLE: "logging.levels" "Log levels" "Several log levels are supported, from lowest to highest:" { $subsection DEBUG } { $subsection NOTICE } +{ $subsection WARNING } { $subsection ERROR } { $subsection CRITICAL } ; @@ -36,7 +40,7 @@ ARTICLE: "logging.files" "Log files" 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 } "." } ; +{ $description "Sends a message to the current log if the level is more urgent than " { $link log-level } ". Does nothing if not executing in a dynamic scope established by " { $link with-logging } "." } ; HELP: add-logging { $values { "level" "a log level" } { "word" word } } @@ -90,8 +94,8 @@ 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" } "." } ; +{ $values { "service" "a log service name" } { "level" "a log level" } { "quot" quotation } } +{ $description "Calls the quotation a new dynamic scope where all logging calls more urgent than " { $link log-level } " are sent to the log file for " { $snippet "service" } "." } ; ARTICLE: "logging.rotation" "Log rotation" "Log files should be rotated periodically to prevent unbounded growth." @@ -120,4 +124,3 @@ ARTICLE: "logging" "Logging framework" { $subsection "logging.server" } ; ABOUT: "logging" - diff --git a/basis/logging/logging.factor b/basis/logging/logging.factor index 6769932c88..2389389074 100644 --- a/basis/logging/logging.factor +++ b/basis/logging/logging.factor @@ -4,12 +4,29 @@ USING: logging.server sequences namespaces concurrency.messaging words kernel arrays shuffle tools.annotations prettyprint.config prettyprint debugger io.streams.string splitting continuations effects generalizations parser strings -quotations fry accessors ; +quotations fry accessors math assocs math.order ; IN: logging SYMBOLS: DEBUG NOTICE WARNING ERROR CRITICAL ; -: log-levels { DEBUG NOTICE NOTICE WARNING ERROR CRITICAL } ; +SYMBOL: log-level + +: log-levels ( -- assoc ) + H{ + { DEBUG 0 } + { NOTICE 10 } + { WARNING 20 } + { ERROR 30 } + { CRITICAL 40 } + } ; + +ERROR: undefined-log-level ; + +: log-level<=> ( log-level log-level -- ? ) + [ log-levels at* [ undefined-log-level ] unless ] bi@ <=> ; + +: log? ( log-level -- ? ) + log-level get log-level<=> +lt+ = not ; : send-to-log-server ( array string -- ) prefix "log-server" get send ; @@ -22,7 +39,8 @@ SYMBOL: log-service : log-message ( msg word level -- ) check-log-message - log-service get dup [ + dup log? + log-service get dup and [ [ [ string-lines ] [ name>> ] [ name>> ] tri* ] dip 4array "log-message" send-to-log-server ] [ @@ -35,8 +53,10 @@ SYMBOL: log-service : close-logs ( -- ) { } "close-logs" send-to-log-server ; -: with-logging ( service quot -- ) - log-service swap with-variable ; inline +: with-logging ( service level quot -- ) + '[ + _ log-service [ _ log-level _ with-variable ] with-variable + ] call ; inline ! Aspect-oriented programming idioms diff --git a/basis/logging/parser/parser.factor b/basis/logging/parser/parser.factor index 07a84ec5c6..5406d8fcd0 100644 --- a/basis/logging/parser/parser.factor +++ b/basis/logging/parser/parser.factor @@ -3,7 +3,7 @@ USING: accessors peg peg.parsers memoize kernel sequences logging arrays words strings vectors io io.files io.encodings.utf8 namespaces make combinators logging.server -calendar calendar.format ; +calendar calendar.format assocs ; IN: logging.parser TUPLE: log-entry date level word-name message ; @@ -21,7 +21,7 @@ SYMBOL: multiline "[" "]" surrounded-by ; : 'log-level' ( -- parser ) - log-levels [ + log-levels keys [ [ name>> token ] keep [ nip ] curry action ] map choice ; From bf3ef49dd0492f2b2a93d1dcfd002cb753bb67d6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 17 Feb 2009 11:31:01 -0600 Subject: [PATCH 09/45] with-logging change --- extra/spider/spider.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/spider/spider.factor b/extra/spider/spider.factor index bd5b2668be..0f702d7d22 100644 --- a/extra/spider/spider.factor +++ b/extra/spider/spider.factor @@ -88,7 +88,7 @@ links processing-time timestamp ; PRIVATE> : run-spider ( spider -- spider ) - "spider" [ + "spider" DEBUG [ dup spider [ queue-initial-links [ todo>> ] [ max-depth>> ] bi From b3e3c74561d6b23c875e2d2cc2c06581a7b11839 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 17 Feb 2009 11:40:50 -0600 Subject: [PATCH 10/45] add ; to word definition in stack-checker docs --- basis/stack-checker/stack-checker-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/stack-checker/stack-checker-docs.factor b/basis/stack-checker/stack-checker-docs.factor index 5926f08d8c..db8abac441 100644 --- a/basis/stack-checker/stack-checker-docs.factor +++ b/basis/stack-checker/stack-checker-docs.factor @@ -56,7 +56,7 @@ ARTICLE: "inference-recursive" "Stack effects of recursive words" "When a recursive call is encountered, the declared stack effect is substituted in. When inference is complete, the inferred stack effect is compared with the declared stack effect." $nl "Attempting to infer the stack effect of a recursive word which outputs a variable number of objects on the stack will fail. For example, the following will throw an " { $link unbalanced-branches-error } ":" -{ $code ": foo ( seq -- ) dup empty? [ drop ] [ dup pop foo ] if" "[ foo ] infer." } +{ $code ": foo ( seq -- ) dup empty? [ drop ] [ dup pop foo ] if ;" "[ foo ] infer." } "If you declare an incorrect stack effect, inference will fail also. Badly defined recursive words cannot confuse the inferencer." ; ARTICLE: "inference-recursive-combinators" "Recursive combinator inference" From cbe99c4bedbda5520c1ae7aa7e6804277c5a914e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 17 Feb 2009 12:36:27 -0600 Subject: [PATCH 11/45] use +foo+ as symbol names --- basis/tools/files/files.factor | 49 ++++++++++++------------ basis/tools/files/unix/unix.factor | 19 +++++---- basis/tools/files/windows/windows.factor | 2 +- 3 files changed, 37 insertions(+), 33 deletions(-) diff --git a/basis/tools/files/files.factor b/basis/tools/files/files.factor index 7508c37cac..8d882099de 100755 --- a/basis/tools/files/files.factor +++ b/basis/tools/files/files.factor @@ -35,9 +35,10 @@ IN: tools.files PRIVATE> -SYMBOLS: file-name file-name/type permissions file-type nlinks file-size -file-date file-time file-datetime uid gid user group link-target unix-datetime -directory-or-size ; +SYMBOLS: +file-name+ +file-name/type+ +permissions+ +file-type+ ++nlinks+ +file-size+ +file-date+ +file-time+ +file-datetime+ ++uid+ +gid+ +user+ +group+ +link-target+ +unix-datetime+ ++directory-or-size+ ; TUPLE: listing-tool path specs sort ; @@ -48,10 +49,10 @@ C: file-listing : ( path -- listing-tool ) listing-tool new swap >>path - { file-name } >>specs ; + { +file-name+ } >>specs ; : list-slow? ( listing-tool -- ? ) - specs>> { file-name } sequence= not ; + specs>> { +file-name+ } sequence= not ; ERROR: unknown-file-spec symbol ; @@ -59,12 +60,12 @@ HOOK: file-spec>string os ( file-listing spec -- string ) M: object file-spec>string ( file-listing spec -- string ) { - { file-name [ directory-entry>> name>> ] } - { directory-or-size [ file-info>> dir-or-size ] } - { file-size [ file-info>> size>> number>string ] } - { file-date [ file-info>> modified>> listing-date ] } - { file-time [ file-info>> modified>> listing-time ] } - { file-datetime [ file-info>> modified>> timestamp>ymdhms ] } + { +file-name+ [ directory-entry>> name>> ] } + { +directory-or-size+ [ file-info>> dir-or-size ] } + { +file-size+ [ file-info>> size>> number>string ] } + { +file-date+ [ file-info>> modified>> listing-date ] } + { +file-time+ [ file-info>> modified>> listing-time ] } + { +file-datetime+ [ file-info>> modified>> timestamp>ymdhms ] } [ unknown-file-spec ] } case ; @@ -85,22 +86,22 @@ HOOK: (directory.) os ( path -- lines ) : directory. ( path -- ) (directory.) simple-table. ; -SYMBOLS: device-name mount-point type -available-space free-space used-space total-space -percent-used percent-free ; +SYMBOLS: +device-name+ +mount-point+ +type+ ++available-space+ +free-space+ +used-space+ +total-space+ ++percent-used+ +percent-free+ ; : percent ( real -- integer ) 100 * >integer ; inline : file-system-spec ( file-system-info obj -- str ) { - { device-name [ device-name>> "" or ] } - { mount-point [ mount-point>> "" or ] } - { type [ type>> "" or ] } - { available-space [ available-space>> 0 or ] } - { free-space [ free-space>> 0 or ] } - { used-space [ used-space>> 0 or ] } - { total-space [ total-space>> 0 or ] } - { percent-used [ + { +device-name+ [ device-name>> "" or ] } + { +mount-point+ [ mount-point>> "" or ] } + { +type+ [ type>> "" or ] } + { +available-space+ [ available-space>> 0 or ] } + { +free-space+ [ free-space>> 0 or ] } + { +used-space+ [ used-space>> 0 or ] } + { +total-space+ [ total-space>> 0 or ] } + { +percent-used+ [ [ used-space>> ] [ total-space>> ] bi [ 0 or ] bi@ dup 0 = [ 2drop 0 ] [ / percent ] if @@ -116,8 +117,8 @@ percent-used percent-free ; : file-systems. ( -- ) { - device-name available-space free-space used-space - total-space percent-used mount-point + +device-name+ +available-space+ +free-space+ +used-space+ + +total-space+ +percent-used+ +mount-point+ } print-file-systems ; { diff --git a/basis/tools/files/unix/unix.factor b/basis/tools/files/unix/unix.factor index e63ab09076..90e91529a1 100755 --- a/basis/tools/files/unix/unix.factor +++ b/basis/tools/files/unix/unix.factor @@ -47,21 +47,24 @@ IN: tools.files.unix M: unix (directory.) ( path -- lines ) - { permissions nlinks user group file-size file-date file-name } >>specs + { + +permissions+ +nlinks+ +user+ +group+ + +file-size+ +file-date+ +file-name+ + } >>specs { { directory-entry>> name>> <=> } } >>sort [ [ list-files ] with-group-cache ] with-user-cache ; M: unix file-spec>string ( file-listing spec -- string ) { - { file-name/type [ + { +file-name/type+ [ directory-entry>> [ name>> ] [ file-type>trailing ] bi append ] } - { permissions [ file-info>> permissions-string ] } - { nlinks [ file-info>> nlink>> number>string ] } - { user [ file-info>> uid>> user-name ] } - { group [ file-info>> gid>> group-name ] } - { uid [ file-info>> uid>> number>string ] } - { gid [ file-info>> gid>> number>string ] } + { +permissions+ [ file-info>> permissions-string ] } + { +nlinks+ [ file-info>> nlink>> number>string ] } + { +user+ [ file-info>> uid>> user-name ] } + { +group+ [ file-info>> gid>> group-name ] } + { +uid+ [ file-info>> uid>> number>string ] } + { +gid+ [ file-info>> gid>> number>string ] } [ call-next-method ] } case ; diff --git a/basis/tools/files/windows/windows.factor b/basis/tools/files/windows/windows.factor index f321c2fc7f..874b2ef5c1 100755 --- a/basis/tools/files/windows/windows.factor +++ b/basis/tools/files/windows/windows.factor @@ -9,7 +9,7 @@ IN: tools.files.windows M: windows (directory.) ( entries -- lines ) - { file-datetime directory-or-size file-name } >>specs + { +file-datetime+ +directory-or-size+ +file-name+ } >>specs { { directory-entry>> name>> <=> } } >>sort list-files ; From 894ba6182ec2cd9fa3e19df0db1bfd389f2c19d8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 17 Feb 2009 17:09:27 -0600 Subject: [PATCH 12/45] add timestamp>mdtm to calendar.format --- basis/calendar/format/format-tests.factor | 7 +++++++ basis/calendar/format/format.factor | 3 +++ 2 files changed, 10 insertions(+) diff --git a/basis/calendar/format/format-tests.factor b/basis/calendar/format/format-tests.factor index 81930cdf49..f8864351a4 100644 --- a/basis/calendar/format/format-tests.factor +++ b/basis/calendar/format/format-tests.factor @@ -51,6 +51,11 @@ IN: calendar.format.tests timestamp>string ] unit-test +[ "20080504070000" ] [ + "Sun May 04 07:00:00 2008 GMT" cookie-string>timestamp + timestamp>mdtm +] unit-test + [ T{ timestamp f 2008 @@ -74,3 +79,5 @@ IN: calendar.format.tests { gmt-offset T{ duration f 0 0 0 0 0 0 } } } ] [ "Thursday, 02-Oct-2008 23:59:59 GMT" cookie-string>timestamp ] unit-test + + diff --git a/basis/calendar/format/format.factor b/basis/calendar/format/format.factor index 15a4cb8266..916d3499fe 100644 --- a/basis/calendar/format/format.factor +++ b/basis/calendar/format/format.factor @@ -78,6 +78,9 @@ M: integer year. ( n -- ) M: timestamp year. ( timestamp -- ) year>> year. ; +: timestamp>mdtm ( timestamp -- str ) + [ { YYYY MM DD hh mm ss } formatted ] with-string-writer ; + : (timestamp>string) ( timestamp -- ) { DAY ", " D " " MONTH " " YYYY " " hh ":" mm ":" ss } formatted ; From fdad5d4d979cd004dd11ab0cb7b419589a4d4932 Mon Sep 17 00:00:00 2001 From: "Yun, Jonghyouk" Date: Wed, 18 Feb 2009 19:19:18 +0900 Subject: [PATCH 13/45] io.encodings.korean TODO removes --- basis/io/encodings/korean/korean.factor | 2 -- 1 file changed, 2 deletions(-) diff --git a/basis/io/encodings/korean/korean.factor b/basis/io/encodings/korean/korean.factor index c1fed1d57c..a021cfce33 100644 --- a/basis/io/encodings/korean/korean.factor +++ b/basis/io/encodings/korean/korean.factor @@ -6,8 +6,6 @@ math.order math.parser memoize multiline sequences splitting values hashtables io.binary ; IN: io.encodings.korean -! TODO: euckr, cp949 seperate (euckr: backslash = Won, cp949: bs <> Won) -! TODO: no byte manip. only code-tables. ! TODO: migrate to common code-table parser (by Dan). SINGLETON: cp949 From 2af9d5a6df34a3a6f1473aa959cc2e68902ead1f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 18 Feb 2009 13:33:55 -0600 Subject: [PATCH 14/45] add canonicalize-path, fix a bug in file-extension --- core/io/pathnames/pathnames-docs.factor | 14 +++++++++++++- core/io/pathnames/pathnames-tests.factor | 4 ++++ core/io/pathnames/pathnames.factor | 9 ++++++++- 3 files changed, 25 insertions(+), 2 deletions(-) diff --git a/core/io/pathnames/pathnames-docs.factor b/core/io/pathnames/pathnames-docs.factor index a4f261391a..f5ad6e533b 100644 --- a/core/io/pathnames/pathnames-docs.factor +++ b/core/io/pathnames/pathnames-docs.factor @@ -1,4 +1,5 @@ -USING: help.markup help.syntax io.backend io.files strings ; +USING: help.markup help.syntax io.backend io.files strings +sequences ; IN: io.pathnames HELP: path-separator? @@ -22,6 +23,10 @@ HELP: file-name { $example "USING: io.pathnames prettyprint ;" "\"/usr/libexec/awk/\" file-name ." "\"awk\"" } } ; +HELP: path-components +{ $values { "path" "a pathnames string" } { "seq" sequence } } +{ $description "Splits a pathname on the " { $link path-separator } " into its its component strings." } ; + HELP: append-path { $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } } { $description "Appends " { $snippet "str1" } " and " { $snippet "str2" } " to form a pathname." } ; @@ -57,6 +62,10 @@ HELP: normalize-path { $values { "str" "a pathname string" } { "newstr" "a new pathname string" } } { $description "Called by words such as " { $link } " and " { $link } " to prepare a pathname before passing it to underlying code." } ; +HELP: canonicalize-path +{ $values { "path" "a pathname string" } { "path'" "a new pathname string" } } +{ $description "Returns an canonical name for a path. The canonical name is an absolute path containing no symlinks." } ; + HELP: { $values { "string" "a pathname string" } { "pathname" pathname } } { $description "Creates a new " { $link pathname } "." } ; @@ -74,9 +83,12 @@ ARTICLE: "io.pathnames" "Pathname manipulation" { $subsection POSTPONE: P" } "Pathname manipulation:" { $subsection normalize-path } +{ $subsection canonicalize-path } { $subsection parent-directory } { $subsection file-name } { $subsection last-path-separator } +{ $subsection path-components } +{ $subsection prepend-path } { $subsection append-path } "Pathname presentations:" { $subsection pathname } diff --git a/core/io/pathnames/pathnames-tests.factor b/core/io/pathnames/pathnames-tests.factor index 41498fa15a..c3e419e60d 100644 --- a/core/io/pathnames/pathnames-tests.factor +++ b/core/io/pathnames/pathnames-tests.factor @@ -66,3 +66,7 @@ IN: io.pathnames.tests ] with-scope [ t ] [ cwd "misc" resource-path [ ] with-directory cwd = ] unit-test + +! Regression test for bug in file-extension +[ f ] [ "/funny.directory/file-with-no-extension" file-extension ] unit-test +[ "" ] [ "/funny.directory/file-with-no-extension." file-extension ] unit-test diff --git a/core/io/pathnames/pathnames.factor b/core/io/pathnames/pathnames.factor index 96ac872826..eba3e6a19f 100644 --- a/core/io/pathnames/pathnames.factor +++ b/core/io/pathnames/pathnames.factor @@ -119,7 +119,14 @@ PRIVATE> ] unless ; : file-extension ( filename -- extension ) - "." split1-last nip ; + file-name "." split1-last nip ; + +: path-components ( path -- seq ) + normalize-path path-separator split harvest ; + +HOOK: canonicalize-path os ( path -- path' ) + +M: object canonicalize-path normalize-path ; : resource-path ( path -- newpath ) "resource-path" get prepend-path ; From 6324fb6c13c3d74b6cf7e2d8b272163ba39f71af Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 18 Feb 2009 13:34:45 -0600 Subject: [PATCH 15/45] add unix canonicalize-path --- basis/io/files/info/unix/linux/linux.factor | 3 ++- basis/io/files/links/unix/unix.factor | 7 ++++++- 2 files changed, 8 insertions(+), 2 deletions(-) diff --git a/basis/io/files/info/unix/linux/linux.factor b/basis/io/files/info/unix/linux/linux.factor index 5dddca4f9d..72401004ae 100644 --- a/basis/io/files/info/unix/linux/linux.factor +++ b/basis/io/files/info/unix/linux/linux.factor @@ -72,13 +72,14 @@ M: linux file-systems ] map ; : (find-mount-point) ( path mtab-paths -- mtab-entry ) - [ follow-links ] dip 2dup at* [ + 2dup at* [ 2nip ] [ drop [ parent-directory ] dip (find-mount-point) ] if ; : find-mount-point ( path -- mtab-entry ) + canonicalize-path parse-mtab [ [ mount-point>> ] keep ] H{ } map>assoc (find-mount-point) ; ERROR: file-system-not-found ; diff --git a/basis/io/files/links/unix/unix.factor b/basis/io/files/links/unix/unix.factor index 2f38c39e02..7d2a6ee4f3 100644 --- a/basis/io/files/links/unix/unix.factor +++ b/basis/io/files/links/unix/unix.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io.backend io.files.links system unix ; +USING: io.backend io.files.links system unix io.pathnames kernel +io.files sequences ; IN: io.files.links.unix M: unix make-link ( path1 path2 -- ) @@ -8,3 +9,7 @@ M: unix make-link ( path1 path2 -- ) M: unix read-link ( path -- path' ) normalize-path read-symbolic-link ; + +M: unix canonicalize-path ( path -- path' ) + path-components "/" + [ append-path dup exists? [ follow-links ] when ] reduce ; From 1045b904be7c85521cea91992a6263f38cb07013 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 18 Feb 2009 13:35:55 -0600 Subject: [PATCH 16/45] fix logging check, unit tests --- basis/logging/logging-tests.factor | 2 +- basis/logging/logging.factor | 8 +++++--- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/basis/logging/logging-tests.factor b/basis/logging/logging-tests.factor index 796c8769fc..63eecc7319 100644 --- a/basis/logging/logging-tests.factor +++ b/basis/logging/logging-tests.factor @@ -13,7 +13,7 @@ USING: tools.test logging math ; \ error-logging-test ERROR add-error-logging -"logging-test" [ +"logging-test" DEBUG [ [ 4 ] [ 1 3 input-logging-test ] unit-test [ 4 ] [ 1 3 output-logging-test ] unit-test diff --git a/basis/logging/logging.factor b/basis/logging/logging.factor index 2389389074..496dae2c61 100644 --- a/basis/logging/logging.factor +++ b/basis/logging/logging.factor @@ -33,14 +33,16 @@ ERROR: undefined-log-level ; SYMBOL: log-service +ERROR: bad-log-message-parameters msg word level ; + : check-log-message ( msg word level -- msg word level ) 3dup [ string? ] [ word? ] [ word? ] tri* and and - [ "Bad parameters to log-message" throw ] unless ; inline + [ bad-log-message-parameters ] unless ; inline : log-message ( msg word level -- ) check-log-message - dup log? - log-service get dup and [ + log-service get + 2dup [ log? ] [ ] bi* and [ [ [ string-lines ] [ name>> ] [ name>> ] tri* ] dip 4array "log-message" send-to-log-server ] [ From 966627a1e2b1168d7d34dbd50cabc0961641abe9 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 18 Feb 2009 13:36:23 -0600 Subject: [PATCH 17/45] make ftp server work with firefox, simplify some code --- basis/ftp/ftp.factor | 9 +- basis/ftp/server/server.factor | 406 +++++++++++++++++---------------- 2 files changed, 212 insertions(+), 203 deletions(-) diff --git a/basis/ftp/ftp.factor b/basis/ftp/ftp.factor index adf7d5b41b..27eebc5946 100644 --- a/basis/ftp/ftp.factor +++ b/basis/ftp/ftp.factor @@ -4,8 +4,7 @@ USING: accessors arrays assocs combinators io io.files kernel math.parser sequences strings ; IN: ftp -SINGLETON: active -SINGLETON: passive +SYMBOLS: +active+ +passive+ ; TUPLE: ftp-response n strings parsed ; @@ -17,5 +16,7 @@ TUPLE: ftp-response n strings parsed ; over strings>> push ; : ftp-send ( string -- ) write "\r\n" write flush ; -: ftp-ipv4 1 ; inline -: ftp-ipv6 2 ; inline + +CONSTANT: ftp-ipv4 1 + +CONSTANT: ftp-ipv6 2 diff --git a/basis/ftp/server/server.factor b/basis/ftp/server/server.factor index 20a753785c..ffe16b2f4c 100644 --- a/basis/ftp/server/server.factor +++ b/basis/ftp/server/server.factor @@ -1,52 +1,46 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: combinators.short-circuit accessors combinators io -io.encodings.8-bit io.encodings io.encodings.binary -io.encodings.utf8 io.files io.files.info io.directories -io.sockets kernel math.parser namespaces make sequences -ftp io.launcher.unix.parser unicode.case splitting -assocs classes io.servers.connection destructors calendar -io.timeouts io.streams.duplex threads continuations math -concurrency.promises byte-arrays io.backend tools.hexdump -io.streams.string math.bitwise tools.files io.pathnames ; +USING: accessors assocs byte-arrays calendar classes +combinators combinators.short-circuit concurrency.promises +continuations destructors ftp io io.backend io.directories +io.encodings io.encodings.8-bit io.encodings.binary +tools.files io.encodings.utf8 io.files io.files.info +io.pathnames io.launcher.unix.parser io.servers.connection +io.sockets io.streams.duplex io.streams.string io.timeouts +kernel make math math.bitwise math.parser namespaces sequences +splitting threads unicode.case logging calendar.format +strings io.files.links io.files.types ; IN: ftp.server -TUPLE: ftp-client url mode state command-promise user password ; - -: ( url -- ftp-client ) - ftp-client new - swap >>url ; - +SYMBOL: server SYMBOL: client -: ftp-server-directory ( -- str ) - \ ftp-server-directory get-global "resource:temp" or - normalize-path ; +TUPLE: ftp-server < threaded-server { serving-directory string } ; + +TUPLE: ftp-client user password extra-connection ; TUPLE: ftp-command raw tokenized ; - -: ( -- obj ) - ftp-command new ; +: ( str -- obj ) + dup \ DEBUG log-message + ftp-command new + over >>raw + swap tokenize-command >>tokenized ; TUPLE: ftp-get path ; - : ( path -- obj ) ftp-get new swap >>path ; TUPLE: ftp-put path ; - : ( path -- obj ) ftp-put new swap >>path ; TUPLE: ftp-list ; - C: ftp-list -: read-command ( -- ftp-command ) - readln - [ >>raw ] [ tokenize-command >>tokenized ] bi ; +TUPLE: ftp-disconnect ; +C: ftp-disconnect : (send-response) ( n string separator -- ) [ number>string write ] 2dip write ftp-send ; @@ -56,28 +50,50 @@ C: ftp-list [ but-last-slice [ "-" (send-response) ] with each ] [ first " " (send-response) ] 2bi ; -: server-response ( n string -- ) +: server-response ( string n -- ) + 2dup number>string swap ":" glue \ server-response DEBUG log-message - swap add-response-line swap >>n + swap add-response-line send-response ; -: ftp-error ( string -- ) - 500 "Unrecognized command: " rot append server-response ; +: serving? ( path -- ? ) + normalize-path server get serving-directory>> head? ; + +: can-serve-directory? ( path -- ? ) + canonicalize-path + { [ exists? ] [ file-info directory? ] [ serving? ] } 1&& ; + +: can-serve-file? ( path -- ? ) + canonicalize-path + { + [ exists? ] + [ file-info type>> +regular-file+ = ] + [ serving? ] + } 1&& ; + +: can-serve? ( path -- ? ) + [ can-serve-file? ] [ can-serve-directory? ] bi or ; + +: ftp-error ( string -- ) 500 server-response ; +: ftp-syntax-error ( string -- ) 501 server-response ; +: ftp-unimplemented ( string -- ) 502 server-response ; +: ftp-file-not-available ( string -- ) 550 server-response ; +: ftp-illegal-file-name ( string -- ) 553 server-response ; : send-banner ( -- ) - 220 "Welcome to " host-name append server-response ; + "Welcome to " host-name append 220 server-response ; : anonymous-only ( -- ) - 530 "This FTP server is anonymous only." server-response ; + "This FTP server is anonymous only." 530 server-response ; : handle-QUIT ( obj -- ) - drop 221 "Goodbye." server-response ; + drop "Goodbye." 221 server-response ; : handle-USER ( ftp-command -- ) [ tokenized>> second client get (>>user) - 331 "Please specify the password." server-response + "Please specify the password." 331 server-response ] [ 2drop "bad USER" ftp-error ] recover ; @@ -85,7 +101,7 @@ C: ftp-list : handle-PASS ( ftp-command -- ) [ tokenized>> second client get (>>password) - 230 "Login successful" server-response + "Login successful" 230 server-response ] [ 2drop "PASS error" ftp-error ] recover ; @@ -102,7 +118,7 @@ ERROR: type-error type ; : handle-TYPE ( obj -- ) [ tokenized>> second parse-type - [ 200 ] dip "Switching to " " mode" surround server-response + "Switching to " " mode" surround 200 server-response ] [ 2drop "TYPE is binary only" ftp-error ] recover ; @@ -115,65 +131,57 @@ ERROR: type-error type ; : handle-PWD ( obj -- ) drop - 257 current-directory get "\"" dup surround server-response ; + current-directory get "\"" dup surround 257 server-response ; : handle-SYST ( obj -- ) drop - 215 "UNIX Type: L8" server-response ; - -: if-command-promise ( quot -- ) - [ client get command-promise>> ] dip - [ "Establish an active or passive connection first" ftp-error ] if* ; - -: handle-STOR ( obj -- ) - [ - tokenized>> second - [ [ ] dip fulfill ] if-command-promise - ] [ - 2drop - ] recover ; - -! EPRT |2|::1|62138| -! : handle-EPRT ( obj -- ) - ! tokenized>> second "|" split harvest ; + "UNIX Type: L8" 215 server-response ; : start-directory ( -- ) - 150 "Here comes the directory listing." server-response ; + "Here comes the directory listing." 150 server-response ; + +: transfer-outgoing-file ( path -- ) + [ "Opening BINARY mode data connection for " ] dip + [ file-name ] [ + file-info size>> number>string + "(" " bytes)." surround + ] bi " " glue append 150 server-response ; + +: transfer-incoming-file ( path -- ) + "Opening BINARY mode data connection for " prepend + 150 server-response ; + +: finish-file-transfer ( -- ) + "File send OK." 226 server-response ; + +GENERIC: handle-passive-command ( stream obj -- ) + +: passive-loop ( server -- ) + [ + [ + |dispose + 30 seconds over set-timeout + accept drop &dispose + client get extra-connection>> + 30 seconds ?promise-timeout + handle-passive-command + ] + [ client get f >>extra-connection drop ] + [ drop ] cleanup + ] with-destructors ; : finish-directory ( -- ) - 226 "Directory send OK." server-response ; + "Directory send OK." 226 server-response ; -GENERIC: service-command ( stream obj -- ) - -M: ftp-list service-command ( stream obj -- ) +M: ftp-list handle-passive-command ( stream obj -- ) drop start-directory [ utf8 encode-output [ current-directory get directory. ] with-string-writer string-lines harvest [ ftp-send ] each - ] with-output-stream - finish-directory ; + ] with-output-stream finish-directory ; -: transfer-outgoing-file ( path -- ) - [ - 150 - "Opening BINARY mode data connection for " - ] dip - [ - file-name - ] [ - file-info size>> number>string - "(" " bytes)." surround - ] bi " " glue append server-response ; - -: transfer-incoming-file ( path -- ) - [ 150 ] dip "Opening BINARY mode data connection for " prepend - server-response ; - -: finish-file-transfer ( -- ) - 226 "File send OK." server-response ; - -M: ftp-get service-command ( stream obj -- ) +M: ftp-get handle-passive-command ( stream obj -- ) [ path>> [ transfer-outgoing-file ] @@ -183,7 +191,7 @@ M: ftp-get service-command ( stream obj -- ) 3drop "File transfer failed" ftp-error ] recover ; -M: ftp-put service-command ( stream obj -- ) +M: ftp-put handle-passive-command ( stream obj -- ) [ path>> [ transfer-incoming-file ] @@ -193,165 +201,165 @@ M: ftp-put service-command ( stream obj -- ) 3drop "File transfer failed" ftp-error ] recover ; -: passive-loop ( server -- ) - [ - [ - |dispose - 30 seconds over set-timeout - accept drop &dispose - client get command-promise>> - 30 seconds ?promise-timeout - service-command - ] - [ client get f >>command-promise drop ] - [ drop ] cleanup - ] with-destructors ; +M: ftp-disconnect handle-passive-command ( stream obj -- ) + drop dispose ; + +: fulfill-client ( obj -- ) + client get extra-connection>> [ + fulfill + ] [ + drop + "Establish an active or passive connection first" ftp-error + ] if* ; + +: handle-STOR ( obj -- ) + tokenized>> second + dup can-serve-file? [ + fulfill-client + ] [ + drop + fulfill-client + ] if ; : handle-LIST ( obj -- ) - drop - [ [ ] dip fulfill ] if-command-promise ; - -: handle-SIZE ( obj -- ) - [ - [ 213 ] dip - tokenized>> second file-info size>> - number>string server-response + drop current-directory get + can-serve-directory? [ + fulfill-client ] [ - 2drop - 550 "Could not get file size" server-response - ] recover ; + fulfill-client + ] if ; + +: not-a-plain-file ( path -- ) + ": not a plain file." append ftp-error ; : handle-RETR ( obj -- ) - [ tokenized>> second swap fulfill ] - curry if-command-promise ; + tokenized>> second + dup can-serve-file? [ + fulfill-client + ] [ + not-a-plain-file + fulfill-client + ] if ; + +: handle-SIZE ( obj -- ) + tokenized>> second + dup can-serve-file? [ + file-info size>> number>string 213 server-response + ] [ + not-a-plain-file + ] if ; : expect-connection ( -- port ) + client get (>>extra-connection) random-local-server - client get >>command-promise drop [ [ passive-loop ] curry in-thread ] [ addr>> port>> ] bi ; : handle-PASV ( obj -- ) - drop client get passive >>mode drop - 221 + drop expect-connection port>bytes [ number>string ] bi@ "," glue "Entering Passive Mode (127,0,0,1," ")" surround - server-response ; + 221 server-response ; : handle-EPSV ( obj -- ) drop - client get command-promise>> [ - "You already have a passive stream" ftp-error - ] [ - 229 - expect-connection number>string - "Entering Extended Passive Mode (|||" "|)" surround - server-response - ] if ; + client get f >>extra-connection drop + expect-connection number>string + "Entering Extended Passive Mode (|||" "|)" surround + 229 server-response ; -! LPRT 6,16,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,2,242,186 -! : handle-LPRT ( obj -- ) tokenized>> "," split ; - -ERROR: not-a-directory ; -ERROR: no-permissions ; - -: handle-CWD ( obj -- ) - [ - tokenized>> second dup normalize-path - dup ftp-server-directory head? [ - no-permissions - ] unless - - file-info directory? [ - set-current-directory - 250 "Directory successully changed." server-response +: handle-MDTM ( obj -- ) + tokenized>> 1 swap ?nth [ + dup file-info dup directory? [ + drop not-a-plain-file ] [ - not-a-directory + nip + modified>> timestamp>mdtm + 213 server-response ] if ] [ - 2drop - 550 "Failed to change directory." server-response - ] recover ; + "" not-a-plain-file + ] if* ; -: unrecognized-command ( obj -- ) raw>> ftp-error ; +ERROR: not-a-directory ; +ERROR: no-directory-permissions ; -: handle-client-loop ( -- ) - readln - USE: prettyprint global [ dup . flush ] bind - [ >>raw ] - [ tokenize-command >>tokenized ] bi +: directory-change-success ( -- ) + "Directory successully changed." 250 server-response ; + +: directory-change-failed ( -- ) + "Failed to change directory." 553 server-response ; + +: handle-CWD ( obj -- ) + tokenized>> 1 swap ?nth [ + dup can-serve-directory? [ + set-current-directory + directory-change-success + ] [ + drop + directory-change-failed + ] if + ] [ + directory-change-success + ] if* ; + +: unrecognized-command ( obj -- ) + raw>> "Unrecognized command: " prepend ftp-error ; + +: client-loop-dispatch ( str/f -- ? ) dup tokenized>> first >upper { + { "QUIT" [ handle-QUIT f ] } { "USER" [ handle-USER t ] } { "PASS" [ handle-PASS t ] } - { "ACCT" [ drop "ACCT unimplemented" ftp-error t ] } - { "CWD" [ handle-CWD t ] } - ! { "XCWD" [ ] } - ! { "CDUP" [ ] } - ! { "SMNT" [ ] } - - ! { "REIN" [ drop client get reset-ftp-client t ] } - { "QUIT" [ handle-QUIT f ] } - - ! { "PORT" [ ] } ! TODO - { "PASV" [ handle-PASV t ] } - ! { "MODE" [ ] } - { "TYPE" [ handle-TYPE t ] } - ! { "STRU" [ ] } - - ! { "ALLO" [ ] } - ! { "REST" [ ] } - { "STOR" [ handle-STOR t ] } - ! { "STOU" [ ] } - { "RETR" [ handle-RETR t ] } - { "LIST" [ handle-LIST t ] } - { "SIZE" [ handle-SIZE t ] } - ! { "NLST" [ ] } - ! { "APPE" [ ] } - ! { "RNFR" [ ] } - ! { "RNTO" [ ] } - ! { "DELE" [ handle-DELE t ] } - ! { "RMD" [ handle-RMD t ] } - ! ! { "XRMD" [ handle-XRMD t ] } - ! { "MKD" [ handle-MKD t ] } - { "PWD" [ handle-PWD t ] } - ! { "ABOR" [ ] } - { "SYST" [ handle-SYST t ] } - ! { "STAT" [ ] } - ! { "HELP" [ ] } - - ! { "SITE" [ ] } - ! { "NOOP" [ ] } - - ! { "EPRT" [ handle-EPRT ] } - ! { "LPRT" [ handle-LPRT ] } + { "ACCT" [ drop "ACCT unimplemented" ftp-unimplemented t ] } + { "PWD" [ handle-PWD t ] } + { "TYPE" [ handle-TYPE t ] } + { "CWD" [ handle-CWD t ] } + { "PASV" [ handle-PASV t ] } { "EPSV" [ handle-EPSV t ] } - ! { "LPSV" [ drop handle-LPSV t ] } + { "LIST" [ handle-LIST t ] } + { "STOR" [ handle-STOR t ] } + { "RETR" [ handle-RETR t ] } + { "SIZE" [ handle-SIZE t ] } + { "MDTM" [ handle-MDTM t ] } [ drop unrecognized-command t ] - } case [ handle-client-loop ] when ; + } case ; -TUPLE: ftp-server < threaded-server ; +: read-command ( -- ftp-command/f ) + readln [ f ] [ ] if-empty ; + +: handle-client-loop ( -- ) + read-command [ + client-loop-dispatch + [ handle-client-loop ] when + ] when* ; + +: serve-directory ( server -- ) + serving-directory>> [ + send-banner + handle-client-loop + ] with-directory ; M: ftp-server handle-client* ( server -- ) - drop [ - ftp-server-directory [ - host-name client set - send-banner handle-client-loop - ] with-directory + "New client" \ handle-client* DEBUG log-message + ftp-client new client set + [ server set ] [ serve-directory ] bi ] with-destructors ; -: ( port -- server ) +: ( directory port -- server ) ftp-server new-threaded-server swap >>insecure + swap >>serving-directory "ftp.server" >>name 5 minutes >>timeout latin1 >>encoding ; -: ftpd ( port -- ) +: ftpd ( directory port -- ) start-server ; -: ftpd-main ( -- ) 2100 ftpd ; +: ftpd-main ( path -- ) 2100 ftpd ; MAIN: ftpd-main From 30e639ae39266a897fa28dcfcdf98cf746120889 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 18 Feb 2009 15:29:06 -0600 Subject: [PATCH 18/45] add a couple unit tests to ftp --- basis/ftp/client/client.factor | 2 +- basis/ftp/ftp.factor | 4 --- basis/ftp/server/server-tests.factor | 50 ++++++++++++++++++++++++++++ basis/ftp/server/server.factor | 4 +-- 4 files changed, 52 insertions(+), 8 deletions(-) create mode 100644 basis/ftp/server/server-tests.factor diff --git a/basis/ftp/client/client.factor b/basis/ftp/client/client.factor index ac21bb8f78..14877110d3 100644 --- a/basis/ftp/client/client.factor +++ b/basis/ftp/client/client.factor @@ -93,7 +93,7 @@ ERROR: ftp-error got expected ; : ensure-login ( url -- url ) dup username>> [ "anonymous" >>username - "ftp-client" >>password + "ftp-client@factorcode.org" >>password ] unless ; : >ftp-url ( url -- url' ) >url ensure-port ensure-login ; diff --git a/basis/ftp/ftp.factor b/basis/ftp/ftp.factor index 27eebc5946..eea98c0172 100644 --- a/basis/ftp/ftp.factor +++ b/basis/ftp/ftp.factor @@ -16,7 +16,3 @@ TUPLE: ftp-response n strings parsed ; over strings>> push ; : ftp-send ( string -- ) write "\r\n" write flush ; - -CONSTANT: ftp-ipv4 1 - -CONSTANT: ftp-ipv6 2 diff --git a/basis/ftp/server/server-tests.factor b/basis/ftp/server/server-tests.factor new file mode 100644 index 0000000000..d7d9d8384d --- /dev/null +++ b/basis/ftp/server/server-tests.factor @@ -0,0 +1,50 @@ +USING: calendar ftp.server io.encodings.ascii io.files +io.files.unique namespaces threads tools.test kernel +io.servers.connection ftp.client accessors urls +io.pathnames io.directories sequences fry ; +IN: ftp.server.tests + +: test-file-contents ( -- string ) + "Files are so boring anymore." ; + +: create-test-file ( -- path ) + test-file-contents + "ftp.server" "test" make-unique-file + [ ascii set-file-contents ] keep canonicalize-path ; + +: test-ftp-server ( quot -- ) + '[ + current-temporary-directory get 0 + + [ start-server* ] + [ + sockets>> first addr>> port>> + + swap >>port + "ftp" >>protocol + "localhost" >>host + create-test-file >>path + _ call + ] + [ stop-server ] tri + ] with-unique-directory drop ; inline + +[ t ] +[ + + [ + unique-directory [ + [ ftp-get ] [ path>> file-name ascii file-contents ] bi + ] with-directory + ] test-ftp-server test-file-contents = +] unit-test + +[ + + [ + "/" >>path + unique-directory [ + [ ftp-get ] [ path>> file-name ascii file-contents ] bi + ] with-directory + ] test-ftp-server test-file-contents = +] must-fail diff --git a/basis/ftp/server/server.factor b/basis/ftp/server/server.factor index ffe16b2f4c..5247b824fa 100644 --- a/basis/ftp/server/server.factor +++ b/basis/ftp/server/server.factor @@ -61,11 +61,9 @@ C: ftp-disconnect normalize-path server get serving-directory>> head? ; : can-serve-directory? ( path -- ? ) - canonicalize-path { [ exists? ] [ file-info directory? ] [ serving? ] } 1&& ; : can-serve-file? ( path -- ? ) - canonicalize-path { [ exists? ] [ file-info type>> +regular-file+ = ] @@ -351,7 +349,7 @@ M: ftp-server handle-client* ( server -- ) : ( directory port -- server ) ftp-server new-threaded-server swap >>insecure - swap >>serving-directory + swap canonicalize-path >>serving-directory "ftp.server" >>name 5 minutes >>timeout latin1 >>encoding ; From 1ed6c013a2adc8ce2fa2474ae0ec070e5047c017 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 18 Feb 2009 15:49:18 -0600 Subject: [PATCH 19/45] call canonicalize-path when determining if we can serve a path --- basis/ftp/server/server.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/ftp/server/server.factor b/basis/ftp/server/server.factor index 5247b824fa..2eeeac714a 100644 --- a/basis/ftp/server/server.factor +++ b/basis/ftp/server/server.factor @@ -58,7 +58,7 @@ C: ftp-disconnect send-response ; : serving? ( path -- ? ) - normalize-path server get serving-directory>> head? ; + canonicalize-path server get serving-directory>> head? ; : can-serve-directory? ( path -- ? ) { [ exists? ] [ file-info directory? ] [ serving? ] } 1&& ; From b8445b3432c331ad693b4c953763e609ceea6ab1 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 18 Feb 2009 15:51:03 -0600 Subject: [PATCH 20/45] remove dead code --- basis/ftp/server/server.factor | 6 ------ 1 file changed, 6 deletions(-) diff --git a/basis/ftp/server/server.factor b/basis/ftp/server/server.factor index 2eeeac714a..8438aae94e 100644 --- a/basis/ftp/server/server.factor +++ b/basis/ftp/server/server.factor @@ -70,14 +70,8 @@ C: ftp-disconnect [ serving? ] } 1&& ; -: can-serve? ( path -- ? ) - [ can-serve-file? ] [ can-serve-directory? ] bi or ; - : ftp-error ( string -- ) 500 server-response ; -: ftp-syntax-error ( string -- ) 501 server-response ; : ftp-unimplemented ( string -- ) 502 server-response ; -: ftp-file-not-available ( string -- ) 550 server-response ; -: ftp-illegal-file-name ( string -- ) 553 server-response ; : send-banner ( -- ) "Welcome to " host-name append 220 server-response ; From 91b4947e1eed69f07dbf34935725acced661a235 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 18 Feb 2009 16:01:53 -0600 Subject: [PATCH 21/45] with-logging should not take a DEBUG level --- basis/io/servers/connection/connection.factor | 2 +- basis/io/servers/packet/packet.factor | 1 - basis/logging/insomniac/insomniac.factor | 2 +- basis/logging/logging-docs.factor | 2 +- basis/logging/logging-tests.factor | 2 +- basis/logging/logging.factor | 6 ++---- extra/spider/spider.factor | 2 +- 7 files changed, 7 insertions(+), 10 deletions(-) diff --git a/basis/io/servers/connection/connection.factor b/basis/io/servers/connection/connection.factor index 91fb3bfb37..589a50d2eb 100644 --- a/basis/io/servers/connection/connection.factor +++ b/basis/io/servers/connection/connection.factor @@ -117,7 +117,7 @@ M: threaded-server handle-client* handler>> call ; : (start-server) ( threaded-server -- ) init-server dup threaded-server [ - [ ] [ name>> ] [ log-level>> ] tri [ + [ ] [ name>> ] bi [ [ listen-on [ start-accept-loop ] parallel-each ] [ ready>> raise-flag ] bi diff --git a/basis/io/servers/packet/packet.factor b/basis/io/servers/packet/packet.factor index 3f092ab9f1..4edffa96b7 100644 --- a/basis/io/servers/packet/packet.factor +++ b/basis/io/servers/packet/packet.factor @@ -20,5 +20,4 @@ LOG: received-datagram NOTICE PRIVATE> : with-datagrams ( seq service quot -- ) - [ DEBUG ] dip '[ [ [ _ ] dip spawn-datagrams ] parallel-each ] with-logging ; inline diff --git a/basis/logging/insomniac/insomniac.factor b/basis/logging/insomniac/insomniac.factor index 935326da2d..91baae631f 100644 --- a/basis/logging/insomniac/insomniac.factor +++ b/basis/logging/insomniac/insomniac.factor @@ -30,7 +30,7 @@ SYMBOL: insomniac-recipients \ (email-log-report) NOTICE add-error-logging : email-log-report ( service word-names -- ) - "logging.insomniac" DEBUG [ (email-log-report) ] with-logging ; + "logging.insomniac" [ (email-log-report) ] with-logging ; : schedule-insomniac ( service word-names -- ) [ [ email-log-report ] assoc-each rotate-logs ] 2curry diff --git a/basis/logging/logging-docs.factor b/basis/logging/logging-docs.factor index 64956493c6..a4b3f3f019 100644 --- a/basis/logging/logging-docs.factor +++ b/basis/logging/logging-docs.factor @@ -94,7 +94,7 @@ 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" } { "level" "a log level" } { "quot" quotation } } +{ $values { "service" "a log service name" } { "quot" quotation } } { $description "Calls the quotation a new dynamic scope where all logging calls more urgent than " { $link log-level } " are sent to the log file for " { $snippet "service" } "." } ; ARTICLE: "logging.rotation" "Log rotation" diff --git a/basis/logging/logging-tests.factor b/basis/logging/logging-tests.factor index 63eecc7319..796c8769fc 100644 --- a/basis/logging/logging-tests.factor +++ b/basis/logging/logging-tests.factor @@ -13,7 +13,7 @@ USING: tools.test logging math ; \ error-logging-test ERROR add-error-logging -"logging-test" DEBUG [ +"logging-test" [ [ 4 ] [ 1 3 input-logging-test ] unit-test [ 4 ] [ 1 3 output-logging-test ] unit-test diff --git a/basis/logging/logging.factor b/basis/logging/logging.factor index 496dae2c61..ff1baa4ebb 100644 --- a/basis/logging/logging.factor +++ b/basis/logging/logging.factor @@ -55,10 +55,8 @@ ERROR: bad-log-message-parameters msg word level ; : close-logs ( -- ) { } "close-logs" send-to-log-server ; -: with-logging ( service level quot -- ) - '[ - _ log-service [ _ log-level _ with-variable ] with-variable - ] call ; inline +: with-logging ( service quot -- ) + [ log-service ] dip with-variable ; inline ! Aspect-oriented programming idioms diff --git a/extra/spider/spider.factor b/extra/spider/spider.factor index 0f702d7d22..bd5b2668be 100644 --- a/extra/spider/spider.factor +++ b/extra/spider/spider.factor @@ -88,7 +88,7 @@ links processing-time timestamp ; PRIVATE> : run-spider ( spider -- spider ) - "spider" DEBUG [ + "spider" [ dup spider [ queue-initial-links [ todo>> ] [ max-depth>> ] bi From ddce0e0a107ffdb295b02363c553d562641b72b9 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 18 Feb 2009 16:57:20 -0600 Subject: [PATCH 22/45] change literals so that $ works with constants in same compilation unit --- extra/literals/literals-docs.factor | 8 ++++---- extra/literals/literals-tests.factor | 5 +++-- extra/literals/literals.factor | 4 ++-- 3 files changed, 9 insertions(+), 8 deletions(-) diff --git a/extra/literals/literals-docs.factor b/extra/literals/literals-docs.factor index ae25c75495..6525264f6a 100644 --- a/extra/literals/literals-docs.factor +++ b/extra/literals/literals-docs.factor @@ -1,19 +1,19 @@ ! Copyright (C) 2008 Joe Groff. ! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax multiline ; +USING: help.markup help.syntax kernel multiline ; IN: literals HELP: $ { $syntax "$ word" } { $description "Executes " { $snippet "word" } " at parse time and adds the result(s) to the parser accumulator." } -{ $notes "Since " { $snippet "word" } " is executed at parse time, " { $snippet "$" } " cannot be used with words defined in the same compilation unit." } +{ $notes { $snippet "word" } "'s definition is looked up and " { $link call } "ed at parse time, so words that reference words in the current compilation unit cannot be used with " { $snippet "$" } "." } { $examples { $example <" USING: kernel literals prettyprint ; IN: scratchpad -<< : five 5 ; >> +CONSTANT: five 5 { $ five } . "> "{ 5 }" } @@ -30,7 +30,7 @@ IN: scratchpad HELP: $[ { $syntax "$[ code ]" } { $description "Calls " { $snippet "code" } " at parse time and adds the result(s) to the parser accumulator." } -{ $notes "Since " { $snippet "code" } " is executed at parse time, it cannot reference any words defined in the same compilation unit." } +{ $notes "Since " { $snippet "code" } " is " { $link call } "ed at parse time, it cannot reference any words defined in the same compilation unit." } { $examples { $example <" diff --git a/extra/literals/literals-tests.factor b/extra/literals/literals-tests.factor index 34ea4d6415..0e933d5209 100644 --- a/extra/literals/literals-tests.factor +++ b/extra/literals/literals-tests.factor @@ -2,11 +2,12 @@ USING: kernel literals math tools.test ; IN: literals.tests << -: five 5 ; -: seven-eleven 7 11 ; : six-six-six 6 6 6 ; >> +: five 5 ; +: seven-eleven 7 11 ; + [ { 5 } ] [ { $ five } ] unit-test [ { 7 11 } ] [ { $ seven-eleven } ] unit-test [ { 6 6 6 } ] [ { $ six-six-six } ] unit-test diff --git a/extra/literals/literals.factor b/extra/literals/literals.factor index 6df51a35ef..d3cfcaae23 100644 --- a/extra/literals/literals.factor +++ b/extra/literals/literals.factor @@ -1,6 +1,6 @@ ! (c) Joe Groff, see license for details -USING: continuations kernel parser words quotations vectors ; +USING: accessors continuations kernel parser words quotations vectors ; IN: literals -: $ scan-word [ execute ] curry with-datastack >vector ; parsing +: $ scan-word [ def>> call ] curry with-datastack >vector ; parsing : $[ \ ] parse-until >quotation with-datastack >vector ; parsing From 67d2da40404752979a9c07d75f0ba6c8aa84318b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 18 Feb 2009 16:59:23 -0600 Subject: [PATCH 23/45] set a default log level --- basis/logging/logging.factor | 2 ++ 1 file changed, 2 insertions(+) diff --git a/basis/logging/logging.factor b/basis/logging/logging.factor index ff1baa4ebb..e295960baa 100644 --- a/basis/logging/logging.factor +++ b/basis/logging/logging.factor @@ -11,6 +11,8 @@ SYMBOLS: DEBUG NOTICE WARNING ERROR CRITICAL ; SYMBOL: log-level +log-level [ DEBUG ] initialize + : log-levels ( -- assoc ) H{ { DEBUG 0 } From adb6b216832979de9e7af2a6a544b6e5c3b830d2 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 18 Feb 2009 17:25:58 -0600 Subject: [PATCH 24/45] fix load error --- basis/io/servers/packet/packet.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/io/servers/packet/packet.factor b/basis/io/servers/packet/packet.factor index 4edffa96b7..2a346b4d13 100644 --- a/basis/io/servers/packet/packet.factor +++ b/basis/io/servers/packet/packet.factor @@ -1,6 +1,6 @@ USING: concurrency.combinators destructors fry -io.servers.datagram.private io.sockets kernel logging ; -IN: io.servers.datagram +io.sockets kernel logging ; +IN: io.servers.packet Date: Thu, 19 Feb 2009 01:33:47 +0100 Subject: [PATCH 25/45] FUEL: Don't load vocabs in USING: form by default. --- extra/fuel/fuel.factor | 2 ++ extra/fuel/help/help.factor | 6 ++++++ misc/fuel/README | 1 + misc/fuel/fuel-autodoc.el | 21 +++++++++++++++++++-- misc/fuel/fuel-eval.el | 2 +- misc/fuel/fuel-mode.el | 15 ++++++++++++++- 6 files changed, 43 insertions(+), 4 deletions(-) diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor index 2bf8f1b98d..403708e880 100644 --- a/extra/fuel/fuel.factor +++ b/extra/fuel/fuel.factor @@ -99,6 +99,8 @@ PRIVATE> : fuel-vocab-help ( name -- ) (fuel-vocab-help) fuel-eval-set-result ; +: fuel-word-synopsis ( word usings -- ) (fuel-word-synopsis) fuel-eval-set-result ; + : fuel-vocab-summary ( name -- ) (fuel-vocab-summary) fuel-eval-set-result ; diff --git a/extra/fuel/help/help.factor b/extra/fuel/help/help.factor index 55183734b3..bf637fd0b3 100644 --- a/extra/fuel/help/help.factor +++ b/extra/fuel/help/help.factor @@ -90,6 +90,12 @@ PRIVATE> : (fuel-word-help) ( name -- elem ) fuel-find-word [ [ auto-use? on (fuel-word-element) ] with-scope ] [ f ] if* ; +: (fuel-word-synopsis) ( word usings -- str/f ) + [ + [ vocab ] filter interactive-vocabs get append interactive-vocabs set + fuel-find-word [ synopsis ] when* + ] with-scope ; + : (fuel-word-see) ( word -- elem ) [ name>> \ article swap ] [ [ see ] with-string-writer \ $code swap 2array ] bi 3array ; inline diff --git a/misc/fuel/README b/misc/fuel/README index d712560b03..79b8f49f9a 100644 --- a/misc/fuel/README +++ b/misc/fuel/README @@ -111,6 +111,7 @@ beast. | C-cC-ev | edit vocabulary (fuel-edit-vocabulary) | | C-cC-ew | edit word (fuel-edit-word-at-point) | | C-cC-ed | edit word's doc (C-u M-x fuel-edit-word-doc-at-point) | + | C-cC-el | load vocabs in USING: form | |-----------------+------------------------------------------------------------| | C-cC-er | eval region | | C-M-r, C-cC-ee | eval region, extending it to definition boundaries | diff --git a/misc/fuel/fuel-autodoc.el b/misc/fuel/fuel-autodoc.el index 76919702bb..d02e4fcfb9 100644 --- a/misc/fuel/fuel-autodoc.el +++ b/misc/fuel/fuel-autodoc.el @@ -32,6 +32,22 @@ :type 'boolean) +(defcustom fuel-autodoc-eval-using-form-p nil + "When enabled, automatically load vocabularies in USING: form +to display autodoc messages. + +In order to show autodoc messages for words in a Factor buffer, +the used vocabularies must be loaded in the Factor image. Setting +this variable to `t' will do that automatically for you, +asynchronously. That means that you'll be able to move around +while the vocabs are being loaded, but no other FUEL +functionality will be available until loading finishes (and it +may take a while). Thus, this functionality is disabled by +default. You can force loading the vocabs in a Factor buffer +USING: form with \\[fuel-load-usings]." + :group 'fuel-autodoc + :type 'boolean) + ;;; Eldoc function: @@ -41,9 +57,10 @@ (let ((word (or word (fuel-syntax-symbol-at-point))) (fuel-log--inhibit-p t)) (when word - (let* ((cmd (if (fuel-syntax--in-using) + (let* ((usings (if fuel-autodoc-eval-using-form-p :usings t)) + (cmd (if (fuel-syntax--in-using) `(:fuel* (,word fuel-vocab-summary) :in t) - `(:fuel* (((:quote ,word) synopsis :get)) :in))) + `(:fuel* ((,word :usings fuel-word-synopsis)) t ,usings))) (ret (fuel-eval--send/wait cmd fuel-autodoc--timeout)) (res (fuel-eval--retort-result ret))) (when (and ret (not (fuel-eval--retort-error ret)) (stringp res)) diff --git a/misc/fuel/fuel-eval.el b/misc/fuel/fuel-eval.el index 9e8210a3e3..985722854f 100644 --- a/misc/fuel/fuel-eval.el +++ b/misc/fuel/fuel-eval.el @@ -77,7 +77,7 @@ (t (error "Invalid 'in' (%s)" in)))) (defsubst factor--fuel-usings (usings) - (cond ((null usings) :usings) + (cond ((or (null usings) (eq usings :usings)) :usings) ((eq usings t) nil) ((listp usings) `(:array ,@usings)) (t (error "Invalid 'usings' (%s)" usings)))) diff --git a/misc/fuel/fuel-mode.el b/misc/fuel/fuel-mode.el index 504308fccd..c4f08f3c62 100644 --- a/misc/fuel/fuel-mode.el +++ b/misc/fuel/fuel-mode.el @@ -132,6 +132,18 @@ With prefix argument, ask for the file name." (let ((file (car (fuel-mode--read-file arg)))) (when file (fuel-debug--uses-for-file file)))) +(defun fuel-load-usings () + "Loads all vocabularies in the current buffer's USING: from. +Useful to activate autodoc help messages in a vocabulary not yet +loaded. See documentation for `fuel-autodoc-eval-using-form-p' +for details." + (interactive) + (message "Loading all vocabularies in USING: form ...") + (let ((err (fuel-eval--retort-error + (fuel-eval--send/wait '(:fuel* (t) t :usings) 120000)))) + (message (if err "Warning: some vocabularies failed to load" + "All vocabularies loaded")))) + ;;; Minor mode definition: @@ -191,7 +203,8 @@ interacting with a factor listener is at your disposal. (fuel-mode--key ?e ?d 'fuel-edit-word-doc-at-point) (fuel-mode--key ?e ?e 'fuel-eval-extended-region) -(fuel-mode--key ?e ?l 'fuel-run-file) +(fuel-mode--key ?e ?k 'fuel-run-file) +(fuel-mode--key ?e ?l 'fuel-load-usings) (fuel-mode--key ?e ?r 'fuel-eval-region) (fuel-mode--key ?e ?u 'fuel-update-usings) (fuel-mode--key ?e ?v 'fuel-edit-vocabulary) From 8968093623a2bc7087527fcce6cc7c324148e3af Mon Sep 17 00:00:00 2001 From: Jason Merrill Date: Wed, 18 Feb 2009 21:28:48 -0500 Subject: [PATCH 26/45] Added dual versions of a few more words to math.dual. --- extra/math/derivatives/derivatives.factor | 23 +++++++++++-- extra/math/dual/dual-docs.factor | 42 +++++++++++++++++++++++ extra/math/dual/dual-tests.factor | 4 ++- extra/math/dual/dual.factor | 26 ++++++++++---- 4 files changed, 85 insertions(+), 10 deletions(-) diff --git a/extra/math/derivatives/derivatives.factor b/extra/math/derivatives/derivatives.factor index 8e69cec129..c6a9d1a357 100644 --- a/extra/math/derivatives/derivatives.factor +++ b/extra/math/derivatives/derivatives.factor @@ -1,8 +1,15 @@ ! Copyright (C) 2009 Jason W. Merrill. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math math.functions math.derivatives.syntax ; +USING: kernel math math.functions math.derivatives.syntax + math.order math.parser summary accessors make combinators ; IN: math.derivatives +ERROR: undefined-derivative point word ; +M: undefined-derivative summary + [ dup "Derivative of " % word>> name>> % + " is undefined at " % point>> # "." % ] + "" make ; + DERIVATIVE: + [ 2drop ] [ 2drop ] DERIVATIVE: - [ 2drop ] [ 2drop neg ] DERIVATIVE: * [ nip * ] [ drop * ] @@ -12,6 +19,15 @@ DERIVATIVE: / [ nip / ] [ sq / neg * ] DERIVATIVE: ^ [ [ 1 - ^ ] keep * * ] [ [ dup zero? ] 2dip [ 3drop 0 ] [ [ ^ ] keep log * * ] if ] +DERIVATIVE: abs + [ 0 <=> + { + { +lt+ [ neg ] } + { +eq+ [ 0 \ abs undefined-derivative ] } + { +gt+ [ ] } + } case + ] + DERIVATIVE: sqrt [ sqrt 2 * / ] DERIVATIVE: exp [ exp * ] @@ -31,4 +47,7 @@ DERIVATIVE: atan [ sq 1 + / ] DERIVATIVE: asinh [ sq 1 + sqrt / ] DERIVATIVE: acosh [ [ 1 + sqrt ] [ 1 - sqrt ] bi * / ] -DERIVATIVE: atanh [ sq neg 1 + / ] \ No newline at end of file +DERIVATIVE: atanh [ sq neg 1 + / ] + +DERIVATIVE: neg [ drop neg ] +DERIVATIVE: recip [ sq recip neg * ] diff --git a/extra/math/dual/dual-docs.factor b/extra/math/dual/dual-docs.factor index de3b0749a5..6c287a8f1e 100644 --- a/extra/math/dual/dual-docs.factor +++ b/extra/math/dual/dual-docs.factor @@ -46,6 +46,48 @@ HELP: d^ } { $description "Raise a dual number to a (possibly dual) power" } ; +HELP: dabs +{ $values + { "x" dual } + { "|x|" dual } +} +{ $description "Absolute value of a dual number." } ; + +HELP: dacosh +{ $values + { "x" dual } + { "y" dual } +} +{ $description "Inverse hyberbolic cosine of a dual number." } ; + +HELP: dasinh +{ $values + { "x" dual } + { "y" dual } +} +{ $description "Inverse hyberbolic sine of a dual number." } ; + +HELP: datanh +{ $values + { "x" dual } + { "y" dual } +} +{ $description "Inverse hyberbolic tangent of a dual number." } ; + +HELP: dneg +{ $values + { "x" dual } + { "-x" dual } +} +{ $description "Negative of a dual number." } ; + +HELP: drecip +{ $values + { "x" dual } + { "1/x" dual } +} +{ $description "Reciprocal of a dual number." } ; + HELP: define-dual-method { $values { "word" word } diff --git a/extra/math/dual/dual-tests.factor b/extra/math/dual/dual-tests.factor index 2fe751dd63..ea46c46124 100644 --- a/extra/math/dual/dual-tests.factor +++ b/extra/math/dual/dual-tests.factor @@ -11,4 +11,6 @@ IN: math.dual.tests [ 2 1 ] [ 2 3 1 -1 d* unpack-dual ] unit-test [ 1/2 -1/4 ] [ 2 1 1 swap d/ unpack-dual ] unit-test [ 2 ] [ 1 1 2 d^ epsilon-part>> ] unit-test -[ 2.0 .25 ] [ 4 1 sqrt unpack-dual ] unit-test \ No newline at end of file +[ 2.0 .25 ] [ 4 1 sqrt unpack-dual ] unit-test +[ 2 -1 ] [ -2 1 dabs unpack-dual ] unit-test +[ -2 -1 ] [ 2 1 dneg unpack-dual ] unit-test \ No newline at end of file diff --git a/extra/math/dual/dual.factor b/extra/math/dual/dual.factor index 214db9b678..36d684bc6d 100644 --- a/extra/math/dual/dual.factor +++ b/extra/math/dual/dual.factor @@ -51,9 +51,9 @@ MACRO: chain-rule ( word -- e ) PRIVATE> MACRO: dual-op ( word -- ) - [ '[ _ ordinary-op ] ] - [ input-length '[ _ nkeep ] ] - [ '[ _ chain-rule ] ] + [ '[ _ ordinary-op ] ] + [ input-length '[ _ nkeep ] ] + [ '[ _ chain-rule ] ] tri '[ _ @ @ ] ; @@ -64,17 +64,29 @@ MACRO: dual-op ( word -- ) [ { sqrt exp log sin cos tan sinh cosh tanh acos asin atan } [ define-dual-method ] each ] with-compilation-unit -! Inverse methods { asinh, acosh, atanh } are not generic, so +! Inverse methods { asinh, acosh, atanh } are not generic, so ! there is no way to specialize them for dual numbers. However, ! they are defined in terms of functions that can operate on ! dual numbers and arithmetic methods, so if it becomes ! possible to make arithmetic operators work directly on dual ! numbers, we will get these for free. -! Arithmetic methods are not generic (yet?), so we have to +! Arithmetic words are not generic (yet?), so we have to ! define special versions of them to operate on dual numbers. : d+ ( x y -- x+y ) \ + dual-op ; -: d- ( x y -- x-y ) \ - dual-op ; +: d- ( x y -- x-y ) \ - dual-op ; : d* ( x y -- x*y ) \ * dual-op ; : d/ ( x y -- x/y ) \ / dual-op ; -: d^ ( x y -- x^y ) \ ^ dual-op ; \ No newline at end of file +: d^ ( x y -- x^y ) \ ^ dual-op ; + +: dabs ( x -- |x| ) \ abs dual-op ; + +! The following words are also not generic, but are defined in +! terms of words that can operate on dual numbers and +! arithmetic. If it becomes possible to implement arithmetic on +! dual numbers directly, these functions can be deleted. +: dneg ( x -- -x ) \ neg dual-op ; +: drecip ( x -- 1/x ) \ recip dual-op ; +: dasinh ( x -- y ) \ asinh dual-op ; +: dacosh ( x -- y ) \ acosh dual-op ; +: datanh ( x -- y ) \ atanh dual-op ; \ No newline at end of file From 318533e1870d7b3d15b892bcbb7e0c92e0dd8246 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 18 Feb 2009 21:13:46 -0600 Subject: [PATCH 27/45] fix load error --- extra/annotations/annotations-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/annotations/annotations-docs.factor b/extra/annotations/annotations-docs.factor index 1effdf4067..bf8aef3a07 100644 --- a/extra/annotations/annotations-docs.factor +++ b/extra/annotations/annotations-docs.factor @@ -10,7 +10,7 @@ IN: annotations PRIVATE> : $annotation ( element -- ) - P first + first [ "!" " your comment here" surround 1array $syntax ] [ [ "Treats the rest of the line after the exclamation point as a code annotation that can be looked up with the " \ $link ] dip comment-usage.-word 2array " word." 3array $description ] [ ": foo ( x y z -- w )\n !" " --w-ó()ò-w-- kilroy was here\n + * ;" surround 1array $unchecked-example ] From 9c44c87b054140abd20a422d22151242e854184c Mon Sep 17 00:00:00 2001 From: Tim Wawrzynczak Date: Wed, 18 Feb 2009 21:32:31 -0600 Subject: [PATCH 28/45] Merged interfaces between v1 and v2 (id3-info); added textual genre names instead of numbers --- extra/id3/id3-docs.factor | 10 +- extra/id3/id3-tests.factor | 195 +++++-------------------------------- extra/id3/id3.factor | 185 +++++++++++++++++++++++++++++++---- 3 files changed, 196 insertions(+), 194 deletions(-) diff --git a/extra/id3/id3-docs.factor b/extra/id3/id3-docs.factor index da69c2ced3..a54bba1629 100644 --- a/extra/id3/id3-docs.factor +++ b/extra/id3/id3-docs.factor @@ -1,13 +1,19 @@ ! Copyright (C) 2008 Tim Wawrzynczak ! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax sequences kernel ; +USING: help.markup help.syntax sequences kernel accessors ; IN: id3 HELP: file-id3-tags { $values { "path" "a path string" } { "object/f" "a tuple storing ID3 metadata or f" } } -{ $description "Return a tuple containing the ID3 information parsed out of the MP3 file, or " { $link f } " if no metadata is present." } ; + { $description "Return a tuple containing the ID3 information parsed out of the MP3 file, or " { $link f } " if no metadata is present. Currently, the parser supports the following tags: " + $nl { $link title>> } + $nl { $link artist>> } + $nl { $link album>> } + $nl { $link year>> } + $nl { $link genre>> } + $nl { $link comment>> } } ; ARTICLE: "id3" "ID3 tags" "The " { $vocab-link "id3" } " vocabulary contains words for parsing " { $emphasis "ID3" } " tags, which are textual fields storing an MP3's title, artist, and other metadata." $nl diff --git a/extra/id3/id3-tests.factor b/extra/id3/id3-tests.factor index fdbaf69f03..bcdc312440 100644 --- a/extra/id3/id3-tests.factor +++ b/extra/id3/id3-tests.factor @@ -1,182 +1,35 @@ ! Copyright (C) 2009 Tim Wawrzynczak ! See http://factorcode.org/license.txt for BSD license. -USING: tools.test id3 ; +USING: tools.test id3 id3.private ; IN: id3.tests -[ T{ mp3v2-file - { header T{ header f t 0 502 } } - { frames - { - T{ frame - { frame-id "COMM" } - { flags B{ 0 0 } } - { size 19 } - { data "eng, AG# 08E1C12E" } - } - T{ frame - { frame-id "TIT2" } - { flags B{ 0 0 } } - { size 15 } - { data "Stormy Weather" } - } - T{ frame - { frame-id "TRCK" } - { flags B{ 0 0 } } - { size 3 } - { data "32" } - } - T{ frame - { frame-id "TCON" } - { flags B{ 0 0 } } - { size 5 } - { data "(96)" } - } - T{ frame - { frame-id "TALB" } - { flags B{ 0 0 } } - { size 28 } - { data "Night and Day Frank Sinatra" } - } - T{ frame - { frame-id "PRIV" } - { flags B{ 0 0 } } - { size 39 } - { data "WM/MediaClassPrimaryID�}`�#��K�H�*(D" } - } - T{ frame - { frame-id "PRIV" } - { flags B{ 0 0 } } - { size 41 } - { data "WM/MediaClassSecondaryID" } - } - T{ frame - { frame-id "TPE1" } - { flags B{ 0 0 } } - { size 14 } - { data "Frank Sinatra" } - } - } - } -} -] [ "resource:extra/id3/tests/blah3.mp3" file-id3-tags ] unit-test +[ + T{ id3-info + { title "BLAH" } + { artist "ARTIST" } + { album "ALBUM" } + { year "2009" } + { comment "COMMENT" } + { genre "Bluegrass" } + } +] [ "resource:extra/id3/tests/blah.mp3" file-id3-tags ] unit-test [ - T{ mp3v2-file - { header - T{ header { version t } { flags 0 } { size 1405 } } + T{ id3-info + { title "Anthem of the Trinity" } + { artist "Terry Riley" } + { album "Shri Camel" } + { genre "Classical" } } - { frames - { - T{ frame - { frame-id "TIT2" } - { flags B{ 0 0 } } - { size 22 } - { data "Anthem of the Trinity" } - } - T{ frame - { frame-id "TPE1" } - { flags B{ 0 0 } } - { size 12 } - { data "Terry Riley" } - } - T{ frame - { frame-id "TALB" } - { flags B{ 0 0 } } - { size 11 } - { data "Shri Camel" } - } - T{ frame - { frame-id "TCON" } - { flags B{ 0 0 } } - { size 10 } - { data "Classical" } - } - T{ frame - { frame-id "UFID" } - { flags B{ 0 0 } } - { size 23 } - { data "http://musicbrainz.org" } - } - T{ frame - { frame-id "TXXX" } - { flags B{ 0 0 } } - { size 23 } - { data "MusicBrainz Artist Id" } - } - T{ frame - { frame-id "TXXX" } - { flags B{ 0 0 } } - { size 22 } - { data "musicbrainz_artistid" } - } - T{ frame - { frame-id "TRCK" } - { flags B{ 0 0 } } - { size 2 } - { data "1" } - } - T{ frame - { frame-id "TXXX" } - { flags B{ 0 0 } } - { size 22 } - { data "MusicBrainz Album Id" } - } - T{ frame - { frame-id "TXXX" } - { flags B{ 0 0 } } - { size 21 } - { data "musicbrainz_albumid" } - } - T{ frame - { frame-id "TXXX" } - { flags B{ 0 0 } } - { size 29 } - { data "MusicBrainz Album Artist Id" } - } - T{ frame - { frame-id "TXXX" } - { flags B{ 0 0 } } - { size 27 } - { data "musicbrainz_albumartistid" } - } - T{ frame - { frame-id "TPOS" } - { flags B{ 0 0 } } - { size 2 } - { data "1" } - } - T{ frame - { frame-id "TSOP" } - { flags B{ 0 0 } } - { size 1 } - } - T{ frame - { frame-id "TMED" } - { flags B{ 0 0 } } - { size 4 } - { data "DIG" } - } - } - } -} ] [ "resource:extra/id3/tests/blah2.mp3" file-id3-tags ] unit-test [ - T{ mp3v1-file - { title - "BLAH" - } - { artist - "ARTIST" - } - { album - "ALBUM" - } - { year "2009" } - { comment - "COMMENT" - } - { genre 89 } - } -] [ "resource:extra/id3/tests/blah.mp3" file-id3-tags ] unit-test + T{ id3-info + { title "Stormy Weather" } + { artist "Frank Sinatra" } + { album "Night and Day Frank Sinatra" } + { comment "eng, AG# 08E1C12E" } + { genre "Big Band" } + } +] [ "resource:extra/id3/tests/blah3.mp3" file-id3-tags ] unit-test diff --git a/extra/id3/id3.factor b/extra/id3/id3.factor index 5b0d3f373e..f2bbd08996 100644 --- a/extra/id3/id3.factor +++ b/extra/id3/id3.factor @@ -1,28 +1,159 @@ ! Copyright (C) 2009 Tim Wawrzynczak ! See http://factorcode.org/license.txt for BSD license. -USING: sequences io io.encodings.binary io.files io.pathnames strings kernel math io.mmap io.mmap.uchar accessors syntax combinators math.ranges unicode.categories byte-arrays prettyprint io.encodings.string io.encodings.ascii ; +USING: sequences io io.encodings.binary io.files io.pathnames strings kernel math io.mmap io.mmap.uchar accessors syntax combinators math.ranges unicode.categories byte-arrays io.encodings.string io.encodings.utf8 assocs math.parser ; IN: id3 + ( -- object ) mp3v1-file new ; +: ( -- object ) id3-info new ; -: ( header frames -- object ) mp3v2-file boa ; +: ( header frames -- object ) id3v2-info boa ; :
( -- object ) header new ; : ( -- object ) frame new ; - ] dip { - [ read-frame-id ascii decode >>frame-id ] + [ read-frame-id utf8 decode >>frame-id ] [ read-frame-flags >byte-array >>flags ] [ read-frame-size >28bitword >>size ] - [ read-frame-data ascii decode >>data ] + [ read-frame-data utf8 decode >>data ] } cleave ; : read-frame ( mmap -- frame/f ) @@ -98,9 +229,21 @@ TUPLE: mp3v1-file title artist album year comment genre ; : drop-header ( mmap -- seq1 seq2 ) dup 10 tail-slice swap ; -: read-v2-tag-data ( seq -- mp3v2-file ) - drop-header read-v2-header swap read-frames ; +: parse-frames ( id3v2-info -- id3-info ) + [ ] dip frames>> + { + [ [ frame-id>> "TIT2" = ] find nip [ data>> >>title ] when* ] + [ [ frame-id>> "TALB" = ] find nip [ data>> >>album ] when* ] + [ [ frame-id>> "TPE1" = ] find nip [ data>> >>artist ] when* ] + [ [ frame-id>> "TCON" = ] find nip [ data>> [ [ digit? ] filter string>number ] keep swap [ genres at nip ] when* + >>genre ] when* ] + [ [ frame-id>> "COMM" = ] find nip [ data>> >>comment ] when* ] + [ [ frame-id>> "TYER" = ] find nip [ data>> >>year ] when* ] + } cleave ; +: read-v2-tag-data ( seq -- id3-info ) + drop-header read-v2-header swap read-frames parse-frames ; + ! v1 information : skip-to-v1-data ( seq -- seq ) @@ -125,14 +268,14 @@ TUPLE: mp3v1-file title artist album year comment genre ; [ 124 ] dip nth ; : (read-v1-tag-data) ( seq -- mp3-file ) - [ ] dip + [ ] dip { - [ read-title ascii decode filter-text-data >>title ] - [ read-artist ascii decode filter-text-data >>artist ] - [ read-album ascii decode filter-text-data >>album ] - [ read-year ascii decode filter-text-data >>year ] - [ read-comment ascii decode filter-text-data >>comment ] - [ read-genre >fixnum >>genre ] + [ read-title utf8 decode filter-text-data >>title ] + [ read-artist utf8 decode filter-text-data >>artist ] + [ read-album utf8 decode filter-text-data >>album ] + [ read-year utf8 decode filter-text-data >>year ] + [ read-comment utf8 decode filter-text-data >>comment ] + [ read-genre >fixnum genres at >>genre ] } cleave ; : read-v1-tag-data ( seq -- mp3-file ) @@ -140,13 +283,13 @@ TUPLE: mp3v1-file title artist album year comment genre ; PRIVATE> -! main stuff +! public interface : file-id3-tags ( path -- object/f ) [ { - { [ dup id3v2? ] [ read-v2-tag-data ] } ! ( ? -- mp3v2-file ) - { [ dup id3v1? ] [ read-v1-tag-data ] } ! ( ? -- mp3v1-file ) + { [ dup id3v2? ] [ read-v2-tag-data ] } ! ( ? -- id3v2 ) + { [ dup id3v1? ] [ read-v1-tag-data ] } ! ( ? -- id3-info ) [ drop f ] ! ( mmap -- f ) } cond ] with-mapped-uchar-file ; From 9e68c222f0f34e14b0ba569e65904b4df6aad8c7 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Thu, 19 Feb 2009 10:26:00 +0100 Subject: [PATCH 29/45] FUEL: small refactoring. --- extra/fuel/help/help.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/fuel/help/help.factor b/extra/fuel/help/help.factor index bf637fd0b3..9aaae4ea80 100644 --- a/extra/fuel/help/help.factor +++ b/extra/fuel/help/help.factor @@ -92,7 +92,7 @@ PRIVATE> : (fuel-word-synopsis) ( word usings -- str/f ) [ - [ vocab ] filter interactive-vocabs get append interactive-vocabs set + [ vocab ] filter interactive-vocabs [ append ] change fuel-find-word [ synopsis ] when* ] with-scope ; From e426026f734d1e62209872041c8a0a7b2be46d5d Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Thu, 19 Feb 2009 10:36:52 +0100 Subject: [PATCH 30/45] FUEL: Fix. --- extra/fuel/help/help.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/fuel/help/help.factor b/extra/fuel/help/help.factor index 9aaae4ea80..64d77566b5 100644 --- a/extra/fuel/help/help.factor +++ b/extra/fuel/help/help.factor @@ -93,7 +93,7 @@ PRIVATE> : (fuel-word-synopsis) ( word usings -- str/f ) [ [ vocab ] filter interactive-vocabs [ append ] change - fuel-find-word [ synopsis ] when* + fuel-find-word [ synopsis ] [ f ] if* ] with-scope ; : (fuel-word-see) ( word -- elem ) From bdb790010a029adfcf2b3a5a5360067e6ef1af0d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 19 Feb 2009 04:08:32 -0600 Subject: [PATCH 31/45] Add bytes-per-pixel word to images vocab --- basis/images/images.factor | 20 +++++++++++++++++++- 1 file changed, 19 insertions(+), 1 deletion(-) diff --git a/basis/images/images.factor b/basis/images/images.factor index c2dc33608e..5ac0da7a28 100644 --- a/basis/images/images.factor +++ b/basis/images/images.factor @@ -9,6 +9,24 @@ IN: images SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR R16G16B16 R32G32B32 R16G16B16A16 R32G32B32A32 ; +: bytes-per-pixel ( component-order -- n ) + { + { BGR [ 3 ] } + { RGB [ 3 ] } + { BGRA [ 4 ] } + { RGBA [ 4 ] } + { ABGR [ 4 ] } + { ARGB [ 4 ] } + { RGBX [ 4 ] } + { XRGB [ 4 ] } + { BGRX [ 4 ] } + { XBGR [ 4 ] } + { R16G16B16 [ 6 ] } + { R32G32B32 [ 12 ] } + { R16G16B16A16 [ 8 ] } + { R32G32B32A32 [ 16 ] } + } case ; + TUPLE: image dim component-order bitmap ; : ( -- image ) image new ; inline @@ -63,4 +81,4 @@ M: image normalize-scan-line-order ; : normalize-image ( image -- image ) [ >byte-array ] change-bitmap normalize-component-order - normalize-scan-line-order ; + normalize-scan-line-order ; \ No newline at end of file From d6cede8a8f1c8e88d33f360dabfd596381120525 Mon Sep 17 00:00:00 2001 From: Benjamin Pollack Date: Thu, 19 Feb 2009 11:48:40 -0500 Subject: [PATCH 32/45] documentation fix --- basis/help/handbook/handbook.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/help/handbook/handbook.factor b/basis/help/handbook/handbook.factor index 39b5a13e30..36496ac5c4 100644 --- a/basis/help/handbook/handbook.factor +++ b/basis/help/handbook/handbook.factor @@ -33,8 +33,8 @@ $nl { { $snippet { $emphasis "foo" } "*" } { "alternative form of " { $snippet "foo" } ", or a generic word called by " { $snippet "foo" } } { { $links at* pprint* } } } { { $snippet "(" { $emphasis "foo" } ")" } { "implementation detail word used by " { $snippet "foo" } } { { $link (clone) } } } { { $snippet "set-" { $emphasis "foo" } } { "sets " { $snippet "foo" } " to a new value" } { $links set-length } } - { { $snippet { $emphasis "foo" } ">>" } { "gets the " { $snippet "foo" } " slot of the tuple at the top of the stack; see " { $link "accessors" } } { { $link >>name } } } - { { $snippet ">>" { $emphasis "foo" } } { "sets the " { $snippet "foo" } " slot of the tuple at the top of the stack; see " { $link "accessors" } } { { $link name>> } } } + { { $snippet { $emphasis "foo" } ">>" } { "gets the " { $snippet "foo" } " slot of the tuple at the top of the stack; see " { $link "accessors" } } { { $link name>> } } } + { { $snippet ">>" { $emphasis "foo" } } { "sets the " { $snippet "foo" } " slot of the tuple at the top of the stack; see " { $link "accessors" } } { { $link >>name } } } { { $snippet "with-" { $emphasis "foo" } } { "performs some kind of initialization and cleanup related to " { $snippet "foo" } ", usually in a new dynamic scope" } { $links with-scope with-input-stream with-output-stream } } { { $snippet "$" { $emphasis "foo" } } { "help markup" } { $links $heading $emphasis } } } From 60134eeb981dcbc75dcb21895071eed0fe719110 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 19 Feb 2009 13:35:53 -0600 Subject: [PATCH 33/45] Documentation fixes --- basis/compiler/compiler-docs.factor | 12 ++++++++---- basis/help/cookbook/cookbook.factor | 19 ------------------- basis/math/functions/functions-docs.factor | 2 +- basis/stack-checker/errors/errors-docs.factor | 2 ++ core/classes/tuple/tuple-docs.factor | 2 +- core/compiler/errors/errors-docs.factor | 13 ++++++++++--- core/vocabs/loader/loader-docs.factor | 13 ++++++++++--- 7 files changed, 32 insertions(+), 31 deletions(-) diff --git a/basis/compiler/compiler-docs.factor b/basis/compiler/compiler-docs.factor index 512d26f4bf..1c6e7b796e 100644 --- a/basis/compiler/compiler-docs.factor +++ b/basis/compiler/compiler-docs.factor @@ -19,15 +19,19 @@ ARTICLE: "compiler-usage" "Calling the optimizing compiler" "Higher-level words can be found in " { $link "compilation-units" } "." ; ARTICLE: "compiler" "Optimizing compiler" -"Factor is a fully compiled language implementation with two distinct compilers:" +"Factor includes two compilers which work behind the scenes. Words are always compiled, and the compilers do not have to be invoked explicitly. For the most part, compilation is fully transparent. However, there are a few things worth knowing about the compilation process." +$nl +"The two compilers differ in the level of analysis they perform:" { $list { "The " { $emphasis "non-optimizing quotation compiler" } " compiles quotations to naive machine code very quickly. The non-optimizing quotation compiler is part of the VM." } { "The " { $emphasis "optimizing word compiler" } " compiles whole words at a time while performing extensive data and control flow analysis. This provides greater performance for generated code, but incurs a much longer compile time. The optimizing compiler is written in Factor." } } -"The optimizing compiler only compiles words which have a static stack effect. This means that methods defined on fundamental generic words such as " { $link nth } " should have a static stack effect; for otherwise, most of the system would be compiled with the non-optimizing compiler. See " { $link "inference" } " and " { $link "cookbook-pitfalls" } "." -{ $subsection "compiler-usage" } +"The optimizing compiler only compiles words which have a static stack effect. This means that methods defined on fundamental generic words such as " { $link nth } " should have a static stack effect. See " { $link "inference" } " and " { $link "cookbook-pitfalls" } "." +$nl +"The optimizing compiler also trades off compile time for performance of generated code, so loading certain vocabularies might take a while. Saving the image after loading vocabularies can save you a lot of time that you would spend waiting for the same code to load in every coding session; see " { $link "images" } " for information." { $subsection "compiler-errors" } -{ $subsection "hints" } ; +{ $subsection "hints" } +{ $subsection "compiler-usage" } ; ABOUT: "compiler" diff --git a/basis/help/cookbook/cookbook.factor b/basis/help/cookbook/cookbook.factor index ebc711d527..3fe09de263 100644 --- a/basis/help/cookbook/cookbook.factor +++ b/basis/help/cookbook/cookbook.factor @@ -220,24 +220,6 @@ ARTICLE: "cookbook-io" "Input and output cookbook" "io" } ; -ARTICLE: "cookbook-compiler" "Compiler cookbook" -"Factor includes two compilers which work behind the scenes. Words are always compiled, and the compilers do not have to be invoked explicitly. For the most part, compilation is a fully transparent process. However, there are a few things worth knowing about the compilation process." -$nl -"The optimizing compiler trades off compile time for performance of generated code, so loading certain vocabularies might take a while. Saving the image after loading vocabularies can save you a lot of time that you would spend waiting for the same code to load in every coding session; see " { $link "images" } " for information." -$nl -"After loading a vocabulary, you might see messages like:" -{ $code - ":errors - print 2 compiler errors." - ":warnings - print 50 compiler warnings." -} -"These warnings arise from the compiler's stack effect checker. Warnings are non-fatal conditions -- not all code has a static stack effect, so you try to minimize warnings but understand that in many cases they cannot be eliminated. Errors indicate programming mistakes, such as erroneous stack effect declarations." -{ $references - "To learn more about the compiler and static stack effect inference, read these articles:" - "compiler" - "compiler-errors" - "inference" -} ; - ARTICLE: "cookbook-application" "Application cookbook" "Vocabularies can define a main entry point:" { $code "IN: game-of-life" @@ -396,7 +378,6 @@ ARTICLE: "cookbook" "Factor cookbook" { $subsection "cookbook-io" } { $subsection "cookbook-application" } { $subsection "cookbook-scripts" } -{ $subsection "cookbook-compiler" } { $subsection "cookbook-philosophy" } { $subsection "cookbook-pitfalls" } { $subsection "cookbook-next" } ; diff --git a/basis/math/functions/functions-docs.factor b/basis/math/functions/functions-docs.factor index ea3da55082..b463a48e49 100644 --- a/basis/math/functions/functions-docs.factor +++ b/basis/math/functions/functions-docs.factor @@ -235,7 +235,7 @@ HELP: arg HELP: >polar { $values { "z" number } { "abs" "a non-negative real number" } { "arg" "a number in the interval " { $snippet "(-pi,pi]" } } } -{ $description "Creates a complex number from an absolute value and argument (polar form)." } ; +{ $description "Converts a complex number into an absolute value and argument (polar form)." } ; HELP: cis { $values { "arg" "a real number" } { "z" "a complex number on the unit circle" } } diff --git a/basis/stack-checker/errors/errors-docs.factor b/basis/stack-checker/errors/errors-docs.factor index c3b9797a36..5b314a3154 100644 --- a/basis/stack-checker/errors/errors-docs.factor +++ b/basis/stack-checker/errors/errors-docs.factor @@ -87,6 +87,8 @@ HELP: inconsistent-recursive-call-error } ; ARTICLE: "inference-errors" "Inference warnings and errors" +"These conditions are thrown by " { $link "inference" } ", as well as the " { $link "compiler" } "." +$nl "Main wrapper for all inference warnings and errors:" { $subsection inference-error } "Inference warnings:" diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor index 0469f3564a..32cab65904 100644 --- a/core/classes/tuple/tuple-docs.factor +++ b/core/classes/tuple/tuple-docs.factor @@ -22,7 +22,7 @@ ARTICLE: "slot-class-declaration" "Slot class declarations" ARTICLE: "slot-class-coercion" "Coercive slot declarations" "If the class of a slot is declared to be one of " { $link fixnum } " or " { $link float } ", then rather than testing values with the class predicate, writer words coerce values to the relevant type with " { $link >fixnum } " or " { $link >float } ". This may still result in error, but permits a wider range of values than a class predicate test. It also results in a possible loss of precision; for example, storing a large integer into a " { $link fixnum } " slot will silently overflow and discard high bits, and storing a ratio into a " { $link float } " slot may lose precision if the ratio is one which cannot be represented exactly with floating-point." $nl -"This feature is mostly intended as an optimization for low-level code designed to avoid integer overflow, or where floating point precision is sufficient. Most code needs to work transparently with large integers, and thus hsould avoid the coercion behavior by using " { $link integer } " and " { $link real } " in place of " { $link fixnum } " and " { $link float } "." ; +"This feature is mostly intended as an optimization for low-level code designed to avoid integer overflow, or where floating point precision is sufficient. Most code needs to work transparently with large integers, and thus should avoid the coercion behavior by using " { $link integer } " and " { $link real } " in place of " { $link fixnum } " and " { $link float } "." ; ARTICLE: "tuple-declarations" "Tuple slot declarations" "The slot specifier syntax of the " { $link POSTPONE: TUPLE: } " parsing word understands the following slot attributes:" diff --git a/core/compiler/errors/errors-docs.factor b/core/compiler/errors/errors-docs.factor index f5ecf5add1..8368afeb19 100644 --- a/core/compiler/errors/errors-docs.factor +++ b/core/compiler/errors/errors-docs.factor @@ -3,9 +3,16 @@ USING: help.markup help.syntax vocabs.loader words io quotations words.symbol ; ARTICLE: "compiler-errors" "Compiler warnings and errors" -"The compiler saves " { $link "inference-errors" } " in a global variable:" -{ $subsection compiler-errors } -"These notifications can be viewed later:" +"After loading a vocabulary, you might see messages like:" +{ $code + ":errors - print 2 compiler errors." + ":warnings - print 50 compiler warnings." +} +"These warnings arise from the compiler's stack effect checker. Warnings are non-fatal conditions -- not all code has a static stack effect, so you try to minimize warnings but understand that in many cases they cannot be eliminated. Errors indicate programming mistakes, such as erroneous stack effect declarations." +$nl +"The precise warning and error conditions are documented in " { $link "inference-errors" } "." +$nl +"Words to view warnings and errors:" { $subsection :errors } { $subsection :warnings } { $subsection :linkage } diff --git a/core/vocabs/loader/loader-docs.factor b/core/vocabs/loader/loader-docs.factor index ce3b5ea024..527da053fb 100644 --- a/core/vocabs/loader/loader-docs.factor +++ b/core/vocabs/loader/loader-docs.factor @@ -34,13 +34,20 @@ $nl { $subsection "vocabs.roots" } "Vocabulary names map directly to source files. A vocabulary named " { $snippet "foo.bar" } " must be defined in a " { $snippet "bar" } " directory nested inside a " { $snippet "foo" } " directory of a vocabulary root. Any level of vocabulary nesting is permitted." $nl -"The vocabulary directory - " { $snippet "bar" } " in our example - can contain the following files; the first is required while the rest are optional:" +"The vocabulary directory - " { $snippet "bar" } " in our example - contains a source file:" +{ $list + { { $snippet "foo/bar/bar.factor" } " - the source file, must define words in the " { $snippet "foo.bar" } " vocabulary with an " { $snippet "IN: foo.bar" } " form" } +} +"Two other Factor source files, storing documentation and tests, respectively, are optional:" { $list - { { $snippet "foo/bar/bar.factor" } " - the source file, defines words in the " { $snippet "foo.bar" } " vocabulary" } { { $snippet "foo/bar/bar-docs.factor" } " - documentation, see " { $link "writing-help" } } { { $snippet "foo/bar/bar-tests.factor" } " - unit tests, see " { $link "tools.test" } } +} +"Finally, three text files can contain meta-data:" +{ $list + { { $snippet "foo/bar/authors.txt" } " - a series of lines, with one author name per line. These are listed under " { $link "vocab-authors" } } { { $snippet "foo/bar/summary.txt" } " - a one-line description" } - { { $snippet "foo/bar/tags.txt" } " - a whitespace-separated list of tags which classify the vocabulary" } + { { $snippet "foo/bar/tags.txt" } " - a whitespace-separated list of tags which classify the vocabulary. Consult " { $link "vocab-tags" } " for a list of existing tags you can re-use" } } "While " { $link POSTPONE: USE: } " and " { $link POSTPONE: USING: } " load vocabularies which have not been loaded before adding them to the search path, it is also possible to load a vocabulary without adding it to the search path:" { $subsection require } From 90b6b38fd132a227c848c09fb6d77651f0274451 Mon Sep 17 00:00:00 2001 From: Jason Merrill Date: Thu, 19 Feb 2009 18:49:13 -0500 Subject: [PATCH 34/45] Changed math.dual to define words as dword instead of overloading generic words on dual numbers. --- basis/math/functions/functions.factor | 8 +--- .../math/derivatives/derivatives-tests.factor | 4 -- extra/math/dual/dual-docs.factor | 6 +-- extra/math/dual/dual-tests.factor | 6 +-- extra/math/dual/dual.factor | 43 +++++-------------- 5 files changed, 19 insertions(+), 48 deletions(-) delete mode 100644 extra/math/derivatives/derivatives-tests.factor diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor index 3a1ce18daa..85b4d711ac 100644 --- a/basis/math/functions/functions.factor +++ b/basis/math/functions/functions.factor @@ -252,14 +252,10 @@ M: real tanh ftanh ; : -i* ( x -- y ) >rect swap neg rect> ; -GENERIC: asin ( x -- y ) foldable - -M: number asin +: asin ( x -- y ) dup [-1,1]? [ fasin ] [ i* asinh -i* ] if ; inline -GENERIC: acos ( x -- y ) foldable - -M: number acos +: acos ( x -- y ) dup [-1,1]? [ facos ] [ asin pi 2 / swap - ] if ; inline diff --git a/extra/math/derivatives/derivatives-tests.factor b/extra/math/derivatives/derivatives-tests.factor deleted file mode 100644 index f95eb43849..0000000000 --- a/extra/math/derivatives/derivatives-tests.factor +++ /dev/null @@ -1,4 +0,0 @@ -! Copyright (C) 2009 Jason W. Merrill. -! See http://factorcode.org/license.txt for BSD license. -USING: tools.test automatic-differentiation.derivatives ; -IN: automatic-differentiation.derivatives.tests diff --git a/extra/math/dual/dual-docs.factor b/extra/math/dual/dual-docs.factor index 6c287a8f1e..1f24c8217c 100644 --- a/extra/math/dual/dual-docs.factor +++ b/extra/math/dual/dual-docs.factor @@ -88,14 +88,14 @@ HELP: drecip } { $description "Reciprocal of a dual number." } ; -HELP: define-dual-method +HELP: define-dual { $values { "word" word } } -{ $description "Defines a method on the dual numbers for generic word." } +{ $description "Defines a word " { $snippet "d[word]" } " in the " { $vocab-link "math.dual" } " vocabulary that operates on dual numbers." } { $notes "Uses the derivative word-prop, which holds a list of quotations giving the partial derivatives of the word with respect to each of its arguments. This can be set using " { $link POSTPONE: DERIVATIVE: } "." } ; -{ define-dual-method dual-op POSTPONE: DERIVATIVE: } related-words +{ define-dual dual-op POSTPONE: DERIVATIVE: } related-words HELP: dual { $class-description "The class of dual numbers with non-zero epsilon part." } ; diff --git a/extra/math/dual/dual-tests.factor b/extra/math/dual/dual-tests.factor index ea46c46124..dbafe74d6a 100644 --- a/extra/math/dual/dual-tests.factor +++ b/extra/math/dual/dual-tests.factor @@ -4,13 +4,13 @@ USING: tools.test math.dual kernel accessors math math.functions math.constants ; IN: math.dual.tests -[ 0.0 1.0 ] [ 0 1 sin unpack-dual ] unit-test -[ 1.0 0.0 ] [ 0 1 cos unpack-dual ] unit-test +[ 0.0 1.0 ] [ 0 1 dsin unpack-dual ] unit-test +[ 1.0 0.0 ] [ 0 1 dcos unpack-dual ] unit-test [ 3 5 ] [ 1 5 2 d+ unpack-dual ] unit-test [ 0 -1 ] [ 1 5 1 6 d- unpack-dual ] unit-test [ 2 1 ] [ 2 3 1 -1 d* unpack-dual ] unit-test [ 1/2 -1/4 ] [ 2 1 1 swap d/ unpack-dual ] unit-test [ 2 ] [ 1 1 2 d^ epsilon-part>> ] unit-test -[ 2.0 .25 ] [ 4 1 sqrt unpack-dual ] unit-test +[ 2.0 .25 ] [ 4 1 dsqrt unpack-dual ] unit-test [ 2 -1 ] [ -2 1 dabs unpack-dual ] unit-test [ -2 -1 ] [ 2 1 dneg unpack-dual ] unit-test \ No newline at end of file diff --git a/extra/math/dual/dual.factor b/extra/math/dual/dual.factor index 36d684bc6d..c85c23e51d 100644 --- a/extra/math/dual/dual.factor +++ b/extra/math/dual/dual.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Jason W. Merrill. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math math.functions math.derivatives accessors - macros words effects sequences generalizations fry + macros words effects vocabs sequences generalizations fry combinators.smart generic compiler.units ; IN: math.dual @@ -57,36 +57,15 @@ MACRO: dual-op ( word -- ) tri '[ _ @ @ ] ; -: define-dual-method ( word -- ) - [ \ dual swap create-method ] keep '[ _ dual-op ] define ; +: define-dual ( word -- ) + [ + [ stack-effect ] + [ name>> "d" prepend "math.dual" create ] + bi [ set-stack-effect ] keep + ] + keep + '[ _ dual-op ] define ; ! Specialize math functions to operate on dual numbers. -[ { sqrt exp log sin cos tan sinh cosh tanh acos asin atan } - [ define-dual-method ] each ] with-compilation-unit - -! Inverse methods { asinh, acosh, atanh } are not generic, so -! there is no way to specialize them for dual numbers. However, -! they are defined in terms of functions that can operate on -! dual numbers and arithmetic methods, so if it becomes -! possible to make arithmetic operators work directly on dual -! numbers, we will get these for free. - -! Arithmetic words are not generic (yet?), so we have to -! define special versions of them to operate on dual numbers. -: d+ ( x y -- x+y ) \ + dual-op ; -: d- ( x y -- x-y ) \ - dual-op ; -: d* ( x y -- x*y ) \ * dual-op ; -: d/ ( x y -- x/y ) \ / dual-op ; -: d^ ( x y -- x^y ) \ ^ dual-op ; - -: dabs ( x -- |x| ) \ abs dual-op ; - -! The following words are also not generic, but are defined in -! terms of words that can operate on dual numbers and -! arithmetic. If it becomes possible to implement arithmetic on -! dual numbers directly, these functions can be deleted. -: dneg ( x -- -x ) \ neg dual-op ; -: drecip ( x -- 1/x ) \ recip dual-op ; -: dasinh ( x -- y ) \ asinh dual-op ; -: dacosh ( x -- y ) \ acosh dual-op ; -: datanh ( x -- y ) \ atanh dual-op ; \ No newline at end of file +[ all-words [ "derivative" word-prop ] filter + [ define-dual ] each ] with-compilation-unit \ No newline at end of file From a61bac7ab5a158f07d81a71f482538ca5932328a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 19 Feb 2009 18:26:11 -0600 Subject: [PATCH 35/45] fix sqlite foreign triggers create/delete bug ignore-errors only if there is a sql spec defined for the class until database-specific errors are implemented --- basis/db/sqlite/lib/lib.factor | 6 +- basis/db/sqlite/sqlite-tests.factor | 8 +- basis/db/sqlite/sqlite.factor | 135 ++++++++++++++++++++-------- basis/db/tuples/tuples.factor | 37 +++++--- 4 files changed, 130 insertions(+), 56 deletions(-) diff --git a/basis/db/sqlite/lib/lib.factor b/basis/db/sqlite/lib/lib.factor index b1bc9aa1a2..60141bc830 100644 --- a/basis/db/sqlite/lib/lib.factor +++ b/basis/db/sqlite/lib/lib.factor @@ -5,8 +5,7 @@ namespaces sequences db.sqlite.ffi db combinators continuations db.types calendar.format serialize io.streams.byte-array byte-arrays io.encodings.binary io.backend db.errors present urls io.encodings.utf8 -io.encodings.string accessors shuffle io prettyprint -db.private ; +io.encodings.string accessors shuffle io db.private ; IN: db.sqlite.lib ERROR: sqlite-error < db-error n string ; @@ -125,8 +124,7 @@ ERROR: sqlite-sql-error < sql-error n string ; ] if* (sqlite-bind-type) ; : sqlite-finalize ( handle -- ) sqlite3_finalize sqlite-check-result ; -: sqlite-reset ( handle -- ) -"resetting: " write dup . sqlite3_reset sqlite-check-result ; +: sqlite-reset ( handle -- ) sqlite3_reset sqlite-check-result ; : sqlite-clear-bindings ( handle -- ) sqlite3_clear_bindings sqlite-check-result ; : sqlite-#columns ( query -- int ) sqlite3_column_count ; diff --git a/basis/db/sqlite/sqlite-tests.factor b/basis/db/sqlite/sqlite-tests.factor index 5ad4b0c889..677ec17a6e 100644 --- a/basis/db/sqlite/sqlite-tests.factor +++ b/basis/db/sqlite/sqlite-tests.factor @@ -1,6 +1,7 @@ USING: io io.files io.files.temp io.directories io.launcher kernel namespaces prettyprint tools.test db.sqlite db sequences -continuations db.types db.tuples unicode.case ; +continuations db.types db.tuples unicode.case accessors arrays +sorting ; IN: db.sqlite.tests : db-path ( -- path ) "test.db" temp-file ; @@ -74,8 +75,9 @@ IN: db.sqlite.tests ] with-db ] unit-test +[ \ swap ensure-table ] must-fail + ! You don't need a primary key -USING: accessors arrays sorting ; TUPLE: things one two ; things "THINGS" { @@ -163,5 +165,3 @@ watch "WATCH" { user>> f user boa select-tuple ] with-db ] unit-test - -[ \ swap ensure-table ] must-fail diff --git a/basis/db/sqlite/sqlite.factor b/basis/db/sqlite/sqlite.factor index d006145ea8..62a1b4714f 100755 --- a/basis/db/sqlite/sqlite.factor +++ b/basis/db/sqlite/sqlite.factor @@ -1,12 +1,12 @@ ! Copyright (C) 2005, 2008 Chris Double, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien arrays assocs classes compiler db hashtables -io.files kernel math math.parser namespaces prettyprint +io.files kernel math math.parser namespaces prettyprint fry sequences strings classes.tuple alien.c-types continuations db.sqlite.lib db.sqlite.ffi db.tuples words db.types combinators math.intervals io nmake accessors vectors math.ranges random math.bitwise db.queries destructors db.tuples.private interpolate -io.streams.string multiline make db.private ; +io.streams.string multiline make db.private sequences.deep ; IN: db.sqlite TUPLE: sqlite-db path ; @@ -126,30 +126,6 @@ M: sqlite-statement query-results ( query -- result-set ) dup handle>> sqlite-result-set new-result-set dup advance-row ; -M: sqlite-db-connection create-sql-statement ( class -- statement ) - [ - dupd - "create table " 0% 0% - "(" 0% [ ", " 0% ] [ - dup "sql-spec" set - dup column-name>> [ "table-id" set ] [ 0% ] bi - " " 0% - dup type>> lookup-create-type 0% - modifiers 0% - ] interleave - - find-primary-key [ - ", " 0% - "primary key(" 0% - [ "," 0% ] [ column-name>> 0% ] interleave - ")" 0% - ] unless-empty - ");" 0% - ] query-make ; - -M: sqlite-db-connection drop-sql-statement ( class -- statement ) - [ "drop table " 0% 0% ";" 0% drop ] query-make ; - M: sqlite-db-connection ( tuple -- statement ) [ "insert into " 0% 0% @@ -225,7 +201,7 @@ M: sqlite-db-connection persistent-table ( -- assoc ) : insert-trigger ( -- string ) [ <" - CREATE TRIGGER fki_${table-name}_${foreign-table-name}_id + CREATE TRIGGER fki_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id BEFORE INSERT ON ${table-name} FOR EACH ROW BEGIN SELECT RAISE(ROLLBACK, 'insert on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"') @@ -237,7 +213,7 @@ M: sqlite-db-connection persistent-table ( -- assoc ) : insert-trigger-not-null ( -- string ) [ <" - CREATE TRIGGER fki_${table-name}_${foreign-table-name}_id + CREATE TRIGGER fki_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id BEFORE INSERT ON ${table-name} FOR EACH ROW BEGIN SELECT RAISE(ROLLBACK, 'insert on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"') @@ -247,10 +223,17 @@ M: sqlite-db-connection persistent-table ( -- assoc ) "> interpolate ] with-string-writer ; +: drop-insert-trigger ( -- string ) + [ + <" + DROP TRIGGER fki_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id; + "> interpolate + ] with-string-writer ; + : update-trigger ( -- string ) [ <" - CREATE TRIGGER fku_${table-name}_${foreign-table-name}_id + CREATE TRIGGER fku_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id BEFORE UPDATE ON ${table-name} FOR EACH ROW BEGIN SELECT RAISE(ROLLBACK, 'update on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"') @@ -262,7 +245,7 @@ M: sqlite-db-connection persistent-table ( -- assoc ) : update-trigger-not-null ( -- string ) [ <" - CREATE TRIGGER fku_${table-name}_${foreign-table-name}_id + CREATE TRIGGER fku_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id BEFORE UPDATE ON ${table-name} FOR EACH ROW BEGIN SELECT RAISE(ROLLBACK, 'update on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"') @@ -272,10 +255,17 @@ M: sqlite-db-connection persistent-table ( -- assoc ) "> interpolate ] with-string-writer ; +: drop-update-trigger ( -- string ) + [ + <" + DROP TRIGGER fku_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id; + "> interpolate + ] with-string-writer ; + : delete-trigger-restrict ( -- string ) [ <" - CREATE TRIGGER fkd_${table-name}_${foreign-table-name}_id + CREATE TRIGGER fkd_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id BEFORE DELETE ON ${foreign-table-name} FOR EACH ROW BEGIN SELECT RAISE(ROLLBACK, 'delete on table "${foreign-table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"') @@ -284,10 +274,17 @@ M: sqlite-db-connection persistent-table ( -- assoc ) "> interpolate ] with-string-writer ; +: drop-delete-trigger-restrict ( -- string ) + [ + <" + DROP TRIGGER fkd_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id; + "> interpolate + ] with-string-writer ; + : delete-trigger-cascade ( -- string ) [ <" - CREATE TRIGGER fkd_${table-name}_${foreign-table-name}_id + CREATE TRIGGER fkd_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id BEFORE DELETE ON ${foreign-table-name} FOR EACH ROW BEGIN DELETE from ${table-name} WHERE ${table-id} = OLD.${foreign-table-id}; @@ -295,6 +292,13 @@ M: sqlite-db-connection persistent-table ( -- assoc ) "> interpolate ] with-string-writer ; +: drop-delete-trigger-cascade ( -- string ) + [ + <" + DROP TRIGGER fkd_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id; + "> interpolate + ] with-string-writer ; + : can-be-null? ( -- ? ) "sql-spec" get modifiers>> [ +not-null+ = ] any? not ; @@ -318,14 +322,69 @@ M: sqlite-db-connection persistent-table ( -- assoc ) delete-trigger-restrict sqlite-trigger, ] if ; +: drop-sqlite-triggers ( -- ) + drop-insert-trigger sqlite-trigger, + drop-update-trigger sqlite-trigger, + delete-cascade? [ + drop-delete-trigger-cascade sqlite-trigger, + ] [ + drop-delete-trigger-restrict sqlite-trigger, + ] if ; + +: db-triggers ( sql-specs word -- ) + '[ + [ modifiers>> [ +foreign-id+ = ] deep-any? ] filter + [ + [ class>> db-table-name "db-table" set ] + [ column-name>> "table-id" set ] + [ + modifiers>> [ [ +foreign-id+ = ] deep-any? ] filter + [ + [ second db-table-name "foreign-table-name" set ] + [ third "foreign-table-id" set ] bi + _ execute + ] each + ] tri + ] each + ] call ; + +: sqlite-create-table ( sql-specs class-name -- ) + [ + "create table " 0% 0% + "(" 0% [ ", " 0% ] [ + dup "sql-spec" set + dup column-name>> [ "table-id" set ] [ 0% ] bi + " " 0% + dup type>> lookup-create-type 0% + modifiers 0% + ] interleave + ] [ + drop + find-primary-key [ + ", " 0% + "primary key(" 0% + [ "," 0% ] [ column-name>> 0% ] interleave + ")" 0% + ] unless-empty + ");" 0% + ] 2bi ; + +M: sqlite-db-connection create-sql-statement ( class -- statement ) + [ + ! specs name + [ sqlite-create-table ] + [ drop \ create-sqlite-triggers db-triggers ] 2bi + ] query-make ; + +M: sqlite-db-connection drop-sql-statement ( class -- statements ) + [ + [ nip "drop table " 0% 0% ";" 0% ] + [ drop \ drop-sqlite-triggers db-triggers ] 2bi + ] query-make ; + M: sqlite-db-connection compound ( string seq -- new-string ) over { { "default" [ first number>string " " glue ] } - { "references" [ - [ >reference-string ] keep - first2 [ db-table-name "foreign-table-name" set ] - [ "foreign-table-id" set ] bi* - create-sqlite-triggers - ] } + { "references" [ >reference-string ] } [ 2drop ] } case ; diff --git a/basis/db/tuples/tuples.factor b/basis/db/tuples/tuples.factor index 219116aefd..9edd5bac69 100644 --- a/basis/db/tuples/tuples.factor +++ b/basis/db/tuples/tuples.factor @@ -3,7 +3,8 @@ USING: arrays assocs classes db kernel namespaces classes.tuple words sequences slots math accessors math.parser io prettyprint db.types continuations -destructors mirrors sets db.types db.private ; +destructors mirrors sets db.types db.private fry +combinators.short-circuit ; IN: db.tuples HOOK: create-sql-statement db-connection ( class -- object ) @@ -29,7 +30,7 @@ GENERIC: eval-generator ( singleton -- object ) : resulting-tuple ( exemplar-tuple row out-params -- tuple ) rot class new [ - [ [ slot-name>> ] dip set-slot-named ] curry 2each + '[ slot-name>> _ set-slot-named ] 2each ] keep ; : query-tuples ( exemplar-tuple statement -- seq ) @@ -98,33 +99,49 @@ M: query >query clone ; M: tuple >query swap >>tuple ; +ERROR: no-defined-persistent object ; + +: ensure-defined-persistent ( object -- object ) + dup { [ class? ] [ "db-table" word-prop ] } 1&& [ + no-defined-persistent + ] unless ; + : create-table ( class -- ) + ensure-defined-persistent create-sql-statement [ execute-statement ] with-disposals ; : drop-table ( class -- ) + ensure-defined-persistent drop-sql-statement [ execute-statement ] with-disposals ; : recreate-table ( class -- ) + ensure-defined-persistent [ - [ drop-sql-statement [ execute-statement ] with-disposals - ] curry ignore-errors + '[ + _ drop-sql-statement [ execute-statement ] with-disposals + ] ignore-errors ] [ create-table ] bi ; -: ensure-table ( class -- ) [ create-table ] curry ignore-errors ; +: ensure-table ( class -- ) + ensure-defined-persistent + '[ _ create-table ] ignore-errors ; : ensure-tables ( classes -- ) [ ensure-table ] each ; : insert-tuple ( tuple -- ) - dup class db-columns find-primary-key db-assigned-id-spec? + dup class ensure-defined-persistent + db-columns find-primary-key db-assigned-id-spec? [ insert-db-assigned-statement ] [ insert-user-assigned-statement ] if ; : update-tuple ( tuple -- ) - dup class + dup class ensure-defined-persistent db-connection get update-statements>> [ ] cache [ bind-tuple ] keep execute-statement ; : delete-tuples ( tuple -- ) - dup dup class [ + dup + dup class ensure-defined-persistent + [ [ bind-tuple ] keep execute-statement ] with-disposal ; @@ -132,8 +149,8 @@ M: tuple >query swap >>tuple ; >query [ tuple>> ] [ query>statement ] bi do-select ; : select-tuple ( query/tuple -- tuple/f ) - >query 1 >>limit [ tuple>> ] [ query>statement ] bi do-select - [ f ] [ first ] if-empty ; + >query 1 >>limit [ tuple>> ] [ query>statement ] bi + do-select [ f ] [ first ] if-empty ; : count-tuples ( query/tuple -- n ) >query [ tuple>> ] [ ] bi do-count From dd1587c74582b08267de6d8c2278809e31265088 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 19 Feb 2009 18:52:45 -0600 Subject: [PATCH 36/45] Fixing SQLite unit tests --- basis/db/sqlite/sqlite-tests.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/basis/db/sqlite/sqlite-tests.factor b/basis/db/sqlite/sqlite-tests.factor index 677ec17a6e..fd730f07ae 100644 --- a/basis/db/sqlite/sqlite-tests.factor +++ b/basis/db/sqlite/sqlite-tests.factor @@ -117,7 +117,7 @@ hi "HELLO" { 1 insert-tuple f select-tuple 1 1 insert-tuple - f select-tuple + f f select-tuple hi drop-table foo drop-table ] with-db @@ -160,6 +160,7 @@ watch "WATCH" { show new insert-tuple show new select-tuple "littledan" f user boa select-tuple + swap [ username>> ] [ id>> ] bi* watch boa insert-tuple watch new select-tuple user>> f user boa select-tuple From d59415d23b606ad7d89e1a6d634d6644658f5a70 Mon Sep 17 00:00:00 2001 From: Jason Merrill Date: Thu, 19 Feb 2009 22:21:31 -0500 Subject: [PATCH 37/45] Fixed help for math.dual. Help is now autogenerated where possible. --- extra/math/dual/dual-docs.factor | 79 -------------------------------- extra/math/dual/dual.factor | 30 ++++++++---- 2 files changed, 21 insertions(+), 88 deletions(-) diff --git a/extra/math/dual/dual-docs.factor b/extra/math/dual/dual-docs.factor index 1f24c8217c..67b3d6ae97 100644 --- a/extra/math/dual/dual-docs.factor +++ b/extra/math/dual/dual-docs.factor @@ -10,84 +10,6 @@ HELP: } { $description "Creates a dual number from its ordinary and epsilon parts." } ; -HELP: d* -{ $values - { "x" dual } { "y" dual } - { "x*y" dual } -} -{ $description "Multiply dual numbers." } ; - -HELP: d+ -{ $values - { "x" dual } { "y" dual } - { "x+y" dual } -} -{ $description "Add dual numbers." } ; - -HELP: d- -{ $values - { "x" dual } { "y" dual } - { "x-y" dual } -} -{ $description "Subtract dual numbers." } ; - -HELP: d/ -{ $values - { "x" dual } { "y" dual } - { "x/y" dual } -} -{ $description "Divide dual numbers." } -{ $errors "Throws an error if the ordinary part of " { $snippet "x" } " is zero." } ; - -HELP: d^ -{ $values - { "x" dual } { "y" dual } - { "x^y" dual } -} -{ $description "Raise a dual number to a (possibly dual) power" } ; - -HELP: dabs -{ $values - { "x" dual } - { "|x|" dual } -} -{ $description "Absolute value of a dual number." } ; - -HELP: dacosh -{ $values - { "x" dual } - { "y" dual } -} -{ $description "Inverse hyberbolic cosine of a dual number." } ; - -HELP: dasinh -{ $values - { "x" dual } - { "y" dual } -} -{ $description "Inverse hyberbolic sine of a dual number." } ; - -HELP: datanh -{ $values - { "x" dual } - { "y" dual } -} -{ $description "Inverse hyberbolic tangent of a dual number." } ; - -HELP: dneg -{ $values - { "x" dual } - { "-x" dual } -} -{ $description "Negative of a dual number." } ; - -HELP: drecip -{ $values - { "x" dual } - { "1/x" dual } -} -{ $description "Reciprocal of a dual number." } ; - HELP: define-dual { $values { "word" word } @@ -128,5 +50,4 @@ $nl "Dual numbers are ordered pairs " { $snippet ""} "--an ordinary part and an epsilon part--with component-wise addition and multiplication defined by "{ $snippet "* = " } ". They are analagous to complex numbers with " { $snippet "i^2 = 0" } "instead of " { $snippet "i^2 = -1" } ". For well-behaved functions " { $snippet "f" } ", " { $snippet "f() = f(o1) + e1*f'(o1)" } ", where " { $snippet "f'"} " is the derivative of " { $snippet "f" } "." ; - ABOUT: "math.dual" diff --git a/extra/math/dual/dual.factor b/extra/math/dual/dual.factor index c85c23e51d..3e0e5437b4 100644 --- a/extra/math/dual/dual.factor +++ b/extra/math/dual/dual.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2009 Jason W. Merrill. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math math.functions math.derivatives accessors - macros words effects vocabs sequences generalizations fry - combinators.smart generic compiler.units ; + macros generic compiler.units words effects vocabs + sequences arrays assocs generalizations fry make + combinators.smart help help.markup ; IN: math.dual @@ -48,6 +49,19 @@ MACRO: chain-rule ( word -- e ) tri '[ [ @ _ @ ] sum-outputs ] ; +: set-dual-help ( word dword -- ) + [ swap + [ stack-effect [ in>> ] [ out>> ] bi append + [ dual ] { } map>assoc { $values } prepend + ] + [ [ { $description } % "Version of " , + { $link } swap suffix , + " extended to work on dual numbers." , ] + { } make + ] + bi* 2array + ] keep set-word-help ; + PRIVATE> MACRO: dual-op ( word -- ) @@ -58,13 +72,11 @@ MACRO: dual-op ( word -- ) '[ _ @ @ ] ; : define-dual ( word -- ) - [ - [ stack-effect ] - [ name>> "d" prepend "math.dual" create ] - bi [ set-stack-effect ] keep - ] - keep - '[ _ dual-op ] define ; + dup name>> "d" prepend "math.dual" create + [ [ stack-effect ] dip set-stack-effect ] + [ set-dual-help ] + [ swap '[ _ dual-op ] define ] + 2tri ; ! Specialize math functions to operate on dual numbers. [ all-words [ "derivative" word-prop ] filter From 19acf89d82b0f7f33f58b02cbe505930432a036d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 20 Feb 2009 12:12:00 -0600 Subject: [PATCH 38/45] fix find-in-program-files --- basis/io/directories/search/search.factor | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/basis/io/directories/search/search.factor b/basis/io/directories/search/search.factor index 41031f8ac3..b56fb7b6a3 100755 --- a/basis/io/directories/search/search.factor +++ b/basis/io/directories/search/search.factor @@ -57,8 +57,14 @@ PRIVATE> pusher [ [ f ] compose iterate-directory drop ] dip ] [ drop f ] recover ; inline +ERROR: file-not-found ; + : find-in-directories ( directories bfs? quot: ( obj -- ? ) -- path'/f ) - '[ _ _ find-file ] attempt-all ; + [ + '[ _ _ find-file [ file-not-found ] unless* ] attempt-all + ] [ + drop f + ] recover ; : find-all-in-directories ( directories bfs? quot: ( obj -- ? ) -- paths/f ) '[ _ _ find-all-files ] map concat ; From 394ec538a1afdd8d695b4aeb3b44e87147285006 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 20 Feb 2009 12:15:26 -0600 Subject: [PATCH 39/45] make emacsw32 work on windows out of the box --- basis/editors/emacs/emacs.factor | 13 +++++++++---- basis/editors/emacs/windows/authors.txt | 1 + basis/editors/emacs/windows/windows.factor | 9 +++++++++ 3 files changed, 19 insertions(+), 4 deletions(-) create mode 100755 basis/editors/emacs/windows/authors.txt create mode 100755 basis/editors/emacs/windows/windows.factor diff --git a/basis/editors/emacs/emacs.factor b/basis/editors/emacs/emacs.factor index 79387f9820..fa78c1b429 100644 --- a/basis/editors/emacs/emacs.factor +++ b/basis/editors/emacs/emacs.factor @@ -1,12 +1,18 @@ USING: definitions io.launcher kernel parser words sequences math -math.parser namespaces editors make system ; +math.parser namespaces editors make system combinators.short-circuit ; IN: editors.emacs +SYMBOL: emacsclient-path + +HOOK: default-emacsclient os ( -- path ) + +M: object default-emacsclient ( -- path ) "emacsclient" ; + : emacsclient ( file line -- ) [ - \ emacsclient get "emacsclient" or , + { [ \ emacsclient-path get ] [ default-emacsclient ] } 0|| , os windows? [ "--no-wait" , ] unless - "+" swap number>string append , + number>string "+" prepend , , ] { } make try-process ; @@ -14,4 +20,3 @@ IN: editors.emacs where first2 emacsclient ; [ emacsclient ] edit-hook set-global - diff --git a/basis/editors/emacs/windows/authors.txt b/basis/editors/emacs/windows/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/basis/editors/emacs/windows/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/basis/editors/emacs/windows/windows.factor b/basis/editors/emacs/windows/windows.factor new file mode 100755 index 0000000000..d5c1e7811c --- /dev/null +++ b/basis/editors/emacs/windows/windows.factor @@ -0,0 +1,9 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: editors.emacs io.directories.search.windows kernel sequences +system ; +IN: editors.emacs.windows + +M: windows default-emacsclient + "Emacs" t [ "emacsclient.exe" tail? ] find-in-program-files + "emacsclient.exe" or ; From 114d9bb21c2d8079b9d3ffb1f2ff14f5f21cd148 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 20 Feb 2009 12:25:55 -0600 Subject: [PATCH 40/45] run with --no-wait on windows so emacsclient doesn't block, use run-detached so that errors on emacsclient exit are ignored. emacs on windows is fully usable now --- basis/editors/emacs/emacs.factor | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/basis/editors/emacs/emacs.factor b/basis/editors/emacs/emacs.factor index fa78c1b429..0aeb7bb467 100644 --- a/basis/editors/emacs/emacs.factor +++ b/basis/editors/emacs/emacs.factor @@ -1,5 +1,6 @@ USING: definitions io.launcher kernel parser words sequences math -math.parser namespaces editors make system combinators.short-circuit ; +math.parser namespaces editors make system combinators.short-circuit +fry threads ; IN: editors.emacs SYMBOL: emacsclient-path @@ -11,10 +12,10 @@ M: object default-emacsclient ( -- path ) "emacsclient" ; : emacsclient ( file line -- ) [ { [ \ emacsclient-path get ] [ default-emacsclient ] } 0|| , - os windows? [ "--no-wait" , ] unless + "--no-wait" , number>string "+" prepend , , - ] { } make try-process ; + ] { } make run-detached drop ; : emacs ( word -- ) where first2 emacsclient ; From 1b9208490bb1d29cf67fb49f043a20cf9cdb92ae Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 20 Feb 2009 12:32:07 -0600 Subject: [PATCH 41/45] keep the old emacs behavior on unix systems --- basis/editors/emacs/emacs.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/basis/editors/emacs/emacs.factor b/basis/editors/emacs/emacs.factor index 0aeb7bb467..fa717a70fa 100644 --- a/basis/editors/emacs/emacs.factor +++ b/basis/editors/emacs/emacs.factor @@ -15,7 +15,8 @@ M: object default-emacsclient ( -- path ) "emacsclient" ; "--no-wait" , number>string "+" prepend , , - ] { } make run-detached drop ; + ] { } make + os windows? [ run-detached drop ] [ try-process ] if ; : emacs ( word -- ) where first2 emacsclient ; From 624719c18fb1894f09c278b4417f5e88475eb64e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 20 Feb 2009 12:58:19 -0600 Subject: [PATCH 42/45] emacsclient.exe is a console app, so whenever it's run a console box pops up. run emacsclientw.exe instead if it exists --- basis/editors/emacs/windows/windows.factor | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/basis/editors/emacs/windows/windows.factor b/basis/editors/emacs/windows/windows.factor index d5c1e7811c..e18c39ed60 100755 --- a/basis/editors/emacs/windows/windows.factor +++ b/basis/editors/emacs/windows/windows.factor @@ -1,9 +1,12 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: editors.emacs io.directories.search.windows kernel sequences -system ; +system combinators.short-circuit ; IN: editors.emacs.windows M: windows default-emacsclient - "Emacs" t [ "emacsclient.exe" tail? ] find-in-program-files - "emacsclient.exe" or ; + { + [ "Emacs" t [ "emacsclientw.exe" tail? ] find-in-program-files ] + [ "Emacs" t [ "emacsclient.exe" tail? ] find-in-program-files ] + [ "emacsclient.exe" ] + } 0|| ; From 8b5a2f4a0e94d91557b7ac8fe0b91285178dcfda Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 20 Feb 2009 14:52:38 -0600 Subject: [PATCH 43/45] fix sqlite triggers -- NEW.table-id not NEW.foreign-table-id --- basis/db/sqlite/sqlite-tests.factor | 20 ++++++++------------ basis/db/sqlite/sqlite.factor | 27 ++++++++++++++------------- 2 files changed, 22 insertions(+), 25 deletions(-) diff --git a/basis/db/sqlite/sqlite-tests.factor b/basis/db/sqlite/sqlite-tests.factor index fd730f07ae..b6e756a3dd 100644 --- a/basis/db/sqlite/sqlite-tests.factor +++ b/basis/db/sqlite/sqlite-tests.factor @@ -123,12 +123,8 @@ hi "HELLO" { ] with-db ] unit-test -[ ] [ - test.db [ - hi create-table - hi drop-table - ] with-db -] unit-test + +! Test SQLite triggers TUPLE: show id ; TUPLE: user username data ; @@ -144,12 +140,12 @@ show "SHOW" { } define-persistent watch "WATCH" { - { "user" "USER" TEXT +not-null+ - { +foreign-id+ user "USERNAME" } +user-assigned-id+ } - { "show" "SHOW" BIG-INTEGER +not-null+ - { +foreign-id+ show "ID" } +user-assigned-id+ } + { "user" "USER" TEXT +not-null+ +user-assigned-id+ + { +foreign-id+ user "USERNAME" } } + { "show" "SHOW" BIG-INTEGER +not-null+ +user-assigned-id+ + { +foreign-id+ show "ID" } } } define-persistent - + [ T{ user { username "littledan" } { data "foo" } } ] [ test.db [ user create-table @@ -160,7 +156,7 @@ watch "WATCH" { show new insert-tuple show new select-tuple "littledan" f user boa select-tuple - swap [ username>> ] [ id>> ] bi* + [ id>> ] [ username>> ] bi* watch boa insert-tuple watch new select-tuple user>> f user boa select-tuple diff --git a/basis/db/sqlite/sqlite.factor b/basis/db/sqlite/sqlite.factor index 62a1b4714f..c94de27894 100755 --- a/basis/db/sqlite/sqlite.factor +++ b/basis/db/sqlite/sqlite.factor @@ -204,7 +204,7 @@ M: sqlite-db-connection persistent-table ( -- assoc ) CREATE TRIGGER fki_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id BEFORE INSERT ON ${table-name} FOR EACH ROW BEGIN - SELECT RAISE(ROLLBACK, 'insert on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"') + SELECT RAISE(ROLLBACK, 'insert on table "${table-name}" violates foreign key constraint "fki_${table-name}_$table-id}_${foreign-table-name}_${foreign-table-id}_id"') WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL; END; "> interpolate @@ -216,8 +216,8 @@ M: sqlite-db-connection persistent-table ( -- assoc ) CREATE TRIGGER fki_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id BEFORE INSERT ON ${table-name} FOR EACH ROW BEGIN - SELECT RAISE(ROLLBACK, 'insert on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"') - WHERE NEW.${foreign-table-id} IS NOT NULL + SELECT RAISE(ROLLBACK, 'insert on table "${table-name}" violates foreign key constraint "fki_${table-name}_$table-id}_${foreign-table-name}_${foreign-table-id}_id"') + WHERE NEW.${table-id} IS NOT NULL AND (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL; END; "> interpolate @@ -236,8 +236,8 @@ M: sqlite-db-connection persistent-table ( -- assoc ) CREATE TRIGGER fku_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id BEFORE UPDATE ON ${table-name} FOR EACH ROW BEGIN - SELECT RAISE(ROLLBACK, 'update on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"') - WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL; + SELECT RAISE(ROLLBACK, 'update on table "${table-name}" violates foreign key constraint "fku_${table-name}_$table-id}_${foreign-table-name}_${foreign-table-id}_id"') + WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL; END; "> interpolate ] with-string-writer ; @@ -248,8 +248,8 @@ M: sqlite-db-connection persistent-table ( -- assoc ) CREATE TRIGGER fku_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id BEFORE UPDATE ON ${table-name} FOR EACH ROW BEGIN - SELECT RAISE(ROLLBACK, 'update on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"') - WHERE NEW.${foreign-table-id} IS NOT NULL + SELECT RAISE(ROLLBACK, 'update on table "${table-name}" violates foreign key constraint "fku_${table-name}_$table-id}_${foreign-table-name}_${foreign-table-id}_id"') + WHERE NEW.${table-id} IS NOT NULL AND (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL; END; "> interpolate @@ -268,8 +268,8 @@ M: sqlite-db-connection persistent-table ( -- assoc ) CREATE TRIGGER fkd_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id BEFORE DELETE ON ${foreign-table-name} FOR EACH ROW BEGIN - SELECT RAISE(ROLLBACK, 'delete on table "${foreign-table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"') - WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = OLD.${foreign-table-id}) IS NOT NULL; + SELECT RAISE(ROLLBACK, 'delete on table "${foreign-table-name}" violates foreign key constraint "fkd_${table-name}_$table-id}_${foreign-table-name}_${foreign-table-id}_id"') + WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = OLD.${foreign-table-id}) IS NOT NULL; END; "> interpolate ] with-string-writer ; @@ -336,15 +336,17 @@ M: sqlite-db-connection persistent-table ( -- assoc ) [ modifiers>> [ +foreign-id+ = ] deep-any? ] filter [ [ class>> db-table-name "db-table" set ] - [ column-name>> "table-id" set ] [ + [ "sql-spec" set ] + [ column-name>> "table-id" set ] + [ ] tri modifiers>> [ [ +foreign-id+ = ] deep-any? ] filter [ [ second db-table-name "foreign-table-name" set ] [ third "foreign-table-id" set ] bi _ execute ] each - ] tri + ] bi ] each ] call ; @@ -378,8 +380,7 @@ M: sqlite-db-connection create-sql-statement ( class -- statement ) M: sqlite-db-connection drop-sql-statement ( class -- statements ) [ - [ nip "drop table " 0% 0% ";" 0% ] - [ drop \ drop-sqlite-triggers db-triggers ] 2bi + nip "drop table " 0% 0% ";" 0% ] query-make ; M: sqlite-db-connection compound ( string seq -- new-string ) From 6eaa5aee2457b0eaad5020445f13b12299f8a4fc Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 20 Feb 2009 17:29:11 -0600 Subject: [PATCH 44/45] fix compile error --- basis/db/sqlite/sqlite.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/db/sqlite/sqlite.factor b/basis/db/sqlite/sqlite.factor index c94de27894..19cfc5d0b7 100755 --- a/basis/db/sqlite/sqlite.factor +++ b/basis/db/sqlite/sqlite.factor @@ -348,7 +348,7 @@ M: sqlite-db-connection persistent-table ( -- assoc ) ] each ] bi ] each - ] call ; + ] call ; inline : sqlite-create-table ( sql-specs class-name -- ) [ From 70d931d0b2197da63474e3f817cc8cf27e0cf5b9 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Fri, 20 Feb 2009 20:14:54 -0600 Subject: [PATCH 45/45] Creating math.bits --- basis/math/bits/authors.txt | 1 + basis/math/bits/bits-docs.factor | 26 ++++++++++++++++++++++ basis/math/bits/bits-tests.factor | 16 +++++++++++++ basis/math/bits/bits.factor | 16 +++++++++++++ basis/math/bits/summary.txt | 1 + basis/math/bitwise/bitwise.factor | 4 ++-- basis/math/functions/functions-docs.factor | 8 ------- basis/math/functions/functions.factor | 18 ++++----------- extra/crypto/passwd-md5/passwd-md5.factor | 6 ++--- 9 files changed, 69 insertions(+), 27 deletions(-) create mode 100644 basis/math/bits/authors.txt create mode 100644 basis/math/bits/bits-docs.factor create mode 100644 basis/math/bits/bits-tests.factor create mode 100644 basis/math/bits/bits.factor create mode 100644 basis/math/bits/summary.txt diff --git a/basis/math/bits/authors.txt b/basis/math/bits/authors.txt new file mode 100644 index 0000000000..f990dd0ed2 --- /dev/null +++ b/basis/math/bits/authors.txt @@ -0,0 +1 @@ +Daniel Ehrenberg diff --git a/basis/math/bits/bits-docs.factor b/basis/math/bits/bits-docs.factor new file mode 100644 index 0000000000..6ae83f7af0 --- /dev/null +++ b/basis/math/bits/bits-docs.factor @@ -0,0 +1,26 @@ +! Copyright (C) 2009 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: help.syntax help.markup math ; +IN: math.bits + +ABOUT: "math.bits" + +ARTICLE: "math.bits" "Number bits virtual sequence" +{ $subsection bits } +{ $subsection } +{ $subsection make-bits } ; + +HELP: bits +{ $class-description "Virtual sequence class of bits of a number. The first bit is the least significant bit. This can be constructed with " { $link } " or " { $link make-bits } "." } ; + +HELP: +{ $values { "number" integer } { "length" integer } { "bits" bits } } +{ $description "Creates a virtual sequence of bits of a number in little endian order, with the given length." } ; + +HELP: make-bits +{ $values { "number" integer } { "bits" bits } } +{ $description "Creates a " { $link bits } " object out of the given number, using its log base 2 as the length. This implies that the last element, corresponding to the most significant bit, will be 1." } +{ $examples + { $example "USING: math.bits prettyprint arrays ;" "BIN: 1101 make-bits >array ." "{ t f t t }" } + { $example "USING: math.bits prettyprint arrays ;" "-3 make-bits >array ." "{ t f }" } +} ; diff --git a/basis/math/bits/bits-tests.factor b/basis/math/bits/bits-tests.factor new file mode 100644 index 0000000000..0503d27f33 --- /dev/null +++ b/basis/math/bits/bits-tests.factor @@ -0,0 +1,16 @@ +! Copyright (C) 2009 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test math.bits sequences arrays ; +IN: math.bits.tests + +[ t ] [ BIN: 111111 3 second ] unit-test +[ { t t t } ] [ BIN: 111111 3 >array ] unit-test +[ f ] [ BIN: 111101 3 second ] unit-test +[ { f f t } ] [ BIN: 111100 3 >array ] unit-test +[ 3 ] [ BIN: 111111 3 length ] unit-test +[ 6 ] [ BIN: 111111 make-bits length ] unit-test +[ 0 ] [ 0 make-bits length ] unit-test +[ 2 ] [ 3 make-bits length ] unit-test +[ 2 ] [ -3 make-bits length ] unit-test +[ 1 ] [ 1 make-bits length ] unit-test +[ 1 ] [ -1 make-bits length ] unit-test diff --git a/basis/math/bits/bits.factor b/basis/math/bits/bits.factor new file mode 100644 index 0000000000..8920955df3 --- /dev/null +++ b/basis/math/bits/bits.factor @@ -0,0 +1,16 @@ +! Copyright (C) 2009 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: sequences kernel math accessors sequences.private ; +IN: math.bits + +TUPLE: bits { number read-only } { length read-only } ; +C: bits + +: make-bits ( number -- bits ) + dup zero? [ drop T{ bits f 0 0 } ] [ dup abs log2 1+ ] if ; inline + +M: bits length length>> ; + +M: bits nth-unsafe number>> swap bit? ; + +INSTANCE: bits immutable-sequence diff --git a/basis/math/bits/summary.txt b/basis/math/bits/summary.txt new file mode 100644 index 0000000000..265a7b8277 --- /dev/null +++ b/basis/math/bits/summary.txt @@ -0,0 +1 @@ +Virtual sequence for bits of an integer diff --git a/basis/math/bitwise/bitwise.factor b/basis/math/bitwise/bitwise.factor index 339703c0a6..4f639c02a7 100755 --- a/basis/math/bitwise/bitwise.factor +++ b/basis/math/bitwise/bitwise.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007, 2008 Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel math math.functions sequences +USING: arrays kernel math sequences accessors math.bits sequences.private words namespaces macros hints combinators fry io.binary combinators.smart ; IN: math.bitwise @@ -65,7 +65,7 @@ DEFER: byte-bit-count \ byte-bit-count 256 [ - 0 swap [ [ 1+ ] when ] each-bit + 8 0 [ [ 1+ ] when ] reduce ] B{ } map-as '[ HEX: ff bitand _ nth-unsafe ] (( byte -- table )) define-declared diff --git a/basis/math/functions/functions-docs.factor b/basis/math/functions/functions-docs.factor index b463a48e49..33a5d96fc4 100644 --- a/basis/math/functions/functions-docs.factor +++ b/basis/math/functions/functions-docs.factor @@ -278,14 +278,6 @@ HELP: mod-inv { $example "USING: math prettyprint ;" "173 815 * 1119 mod ." "1" } } ; -HELP: each-bit -{ $values { "n" integer } { "quot" { $quotation "( ? -- )" } } } -{ $description "Applies the quotation to each bit of the integer, starting from the least significant bit, and stopping at the last bit from which point on all bits are either clear (if the integer is positive) or all bits are set (if the integer is negataive)." } -{ $examples - { $example "USING: math.functions make prettyprint ;" "[ BIN: 1101 [ , ] each-bit ] { } make ." "{ t f t t }" } - { $example "USING: math.functions make prettyprint ;" "[ -3 [ , ] each-bit ] { } make ." "{ t f }" } -} ; - HELP: ~ { $values { "x" real } { "y" real } { "epsilon" real } { "?" "a boolean" } } { $description "Tests if " { $snippet "x" } " and " { $snippet "y" } " are approximately equal to each other. There are three possible comparison tests, chosen based on the sign of " { $snippet "epsilon" } ":" diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor index 85b4d711ac..7e2ac0884c 100644 --- a/basis/math/functions/functions.factor +++ b/basis/math/functions/functions.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: math kernel math.constants math.private +USING: math kernel math.constants math.private math.bits math.libm combinators math.order sequences ; IN: math.functions @@ -26,16 +26,6 @@ GENERIC: sqrt ( x -- y ) foldable M: real sqrt >float dup 0.0 < [ neg fsqrt 0.0 swap rect> ] [ fsqrt ] if ; -: each-bit ( n quot: ( ? -- ) -- ) - over [ 0 = ] [ -1 = ] bi or [ - 2drop - ] [ - 2dup { [ odd? ] [ call ] [ 2/ ] [ each-bit ] } spread - ] if ; inline recursive - -: map-bits ( n quot: ( ? -- obj ) -- seq ) - accumulator [ each-bit ] dip ; inline - : factor-2s ( n -- r s ) #! factor an integer into 2^r * s dup 0 = [ 1 ] [ @@ -47,7 +37,7 @@ M: real sqrt GENERIC# ^n 1 ( z w -- z^w ) : (^n) ( z w -- z^w ) - 1 swap [ [ dupd * ] when [ sq ] dip ] each-bit nip ; inline + make-bits 1 [ [ dupd * ] when [ sq ] dip ] reduce nip ; inline M: integer ^n [ factor-2s ] dip [ (^n) ] keep rot * shift ; @@ -94,9 +84,9 @@ PRIVATE> dup zero? [ drop 0./0. ] [ 0 < 1./0. 0 ? ] if ; inline : (^mod) ( n x y -- z ) - 1 swap [ + make-bits 1 [ [ dupd * pick mod ] when [ sq over mod ] dip - ] each-bit 2nip ; inline + ] reduce 2nip ; inline : (gcd) ( b a x y -- a d ) over zero? [ diff --git a/extra/crypto/passwd-md5/passwd-md5.factor b/extra/crypto/passwd-md5/passwd-md5.factor index e292981876..286a313fda 100644 --- a/extra/crypto/passwd-md5/passwd-md5.factor +++ b/extra/crypto/passwd-md5/passwd-md5.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: kernel base64 checksums.md5 sequences checksums -locals prettyprint math math.bitwise grouping io combinators +locals prettyprint math math.bits grouping io combinators fry make combinators.short-circuit math.functions splitting ; IN: crypto.passwd-md5 @@ -22,8 +22,8 @@ PRIVATE> password length [ 16 / ceiling swap concat ] keep head-slice append - password [ length ] [ first ] bi - '[ [ CHAR: \0 _ ? , ] each-bit ] "" make append + password [ length make-bits ] [ first ] bi + '[ CHAR: \0 _ ? ] "" map-as append md5 checksum-bytes ] | 1000 [ "" swap