From af9d70c65ad67e46e18cb7d5edb37f23c260e667 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 28 Jan 2009 14:33:33 -0600 Subject: [PATCH 01/21] XML chunks are a separate datatype; XML tags are no longer assocs --- basis/syndication/syndication.factor | 6 +++--- basis/xml/data/data.factor | 20 +++++++++++++------ basis/xml/elements/elements.factor | 7 ++++--- .../xml/interpolate/interpolate-tests.factor | 4 ++-- basis/xml/interpolate/interpolate.factor | 3 ++- basis/xml/tests/test.factor | 15 ++++++++------ basis/xml/tests/xmltest.factor | 12 ++++++----- basis/xml/writer/writer-tests.factor | 1 - basis/xml/xml.factor | 3 ++- basis/xmode/loader/loader.factor | 4 ++-- basis/xmode/marker/marker.factor | 2 +- 11 files changed, 46 insertions(+), 31 deletions(-) diff --git a/basis/syndication/syndication.factor b/basis/syndication/syndication.factor index fadb4f4fb3..58b2279cb1 100644 --- a/basis/syndication/syndication.factor +++ b/basis/syndication/syndication.factor @@ -70,8 +70,8 @@ TUPLE: entry title url description date ; tri ; : atom-entry-link ( tag -- url/f ) - "link" tags-named [ "rel" swap at "alternate" = ] find nip - dup [ "href" swap at >url ] when ; + "link" tags-named [ "rel" attr "alternate" = ] find nip + dup [ "href" attr >url ] when ; : atom1.0-entry ( tag -- entry ) entry new @@ -95,7 +95,7 @@ TUPLE: entry title url description date ; feed new swap [ "title" tag-named children>string >>title ] - [ "link" tag-named "href" swap at >url >>url ] + [ "link" tag-named "href" attr >url >>url ] [ "entry" tags-named [ atom1.0-entry ] map set-entries ] tri ; diff --git a/basis/xml/data/data.factor b/basis/xml/data/data.factor index 5dc13adf16..74ad348bab 100644 --- a/basis/xml/data/data.factor +++ b/basis/xml/data/data.factor @@ -150,9 +150,11 @@ TUPLE: tag [ assure-name ] [ T{ attrs } assoc-like ] [ ] tri* tag boa ; -! For convenience, tags follow the assoc protocol too (for attrs) -CONSULT: assoc-protocol tag attrs>> ; -INSTANCE: tag assoc +: attr ( tag name -- string ) + swap attrs>> at ; + +: set-attr ( tag value name -- ) + rot attrs>> set-at ; ! They also follow the sequence protocol (for children) CONSULT: sequence-protocol tag children>> ; @@ -217,8 +219,14 @@ M: xml like PREDICATE: contained-tag < tag children>> not ; PREDICATE: open-tag < tag children>> ; -UNION: xml-data - tag comment string directive instruction ; - TUPLE: unescaped string ; C: unescaped + +UNION: xml-data + tag comment string directive instruction unescaped ; + +TUPLE: xml-chunk seq ; +C: xml-chunk + +CONSULT: sequence-protocol xml-chunk seq>> ; +INSTANCE: xml-chunk sequence diff --git a/basis/xml/elements/elements.factor b/basis/xml/elements/elements.factor index 57e91cc24e..116acb076b 100644 --- a/basis/xml/elements/elements.factor +++ b/basis/xml/elements/elements.factor @@ -65,11 +65,12 @@ IN: xml.elements dup { "1.0" "1.1" } member? [ bad-version ] unless ; : prolog-version ( alist -- version ) - T{ name f "" "version" f } swap at + T{ name { space "" } { main "version" } } swap at [ good-version ] [ versionless-prolog ] if* ; : prolog-encoding ( alist -- encoding ) - T{ name f "" "encoding" f } swap at "UTF-8" or ; + T{ name { space "" } { main "encoding" } } swap at + "UTF-8" or ; : yes/no>bool ( string -- t/f ) { @@ -79,7 +80,7 @@ IN: xml.elements } case ; : prolog-standalone ( alist -- version ) - T{ name f "" "standalone" f } swap at + T{ name { space "" } { main "standalone" } } swap at [ yes/no>bool ] [ f ] if* ; : prolog-attrs ( alist -- prolog ) diff --git a/basis/xml/interpolate/interpolate-tests.factor b/basis/xml/interpolate/interpolate-tests.factor index 817cb453fa..4a7c64dd16 100644 --- a/basis/xml/interpolate/interpolate-tests.factor +++ b/basis/xml/interpolate/interpolate-tests.factor @@ -2,14 +2,14 @@ ! See http://factorcode.org/license.txt for BSD license. USING: tools.test xml.interpolate multiline kernel assocs sequences accessors xml.writer xml.interpolate.private -locals splitting urls ; +locals splitting urls xml.data ; IN: xml.interpolate.tests [ "a" "c" { "a" "c" f } ] [ "<-a->/><->" string>doc [ second var>> ] - [ fourth "val" swap at var>> ] + [ fourth "val" attr var>> ] [ extract-variables ] tri ] unit-test diff --git a/basis/xml/interpolate/interpolate.factor b/basis/xml/interpolate/interpolate.factor index 0b3bb15456..b9535fba39 100644 --- a/basis/xml/interpolate/interpolate.factor +++ b/basis/xml/interpolate/interpolate.factor @@ -33,8 +33,9 @@ M: string push-item , ; M: xml-data push-item , ; M: object push-item present , ; M: sequence push-item - [ dup array? [ % ] [ , ] if ] each ; + dup xml-data? [ , ] [ [ push-item ] each ] if ; M: number push-item present , ; +M: xml-chunk push-item % ; GENERIC: interpolate-item ( table item -- ) M: object interpolate-item nip , ; diff --git a/basis/xml/tests/test.factor b/basis/xml/tests/test.factor index e3a7fdbc7a..97793f2ab2 100644 --- a/basis/xml/tests/test.factor +++ b/basis/xml/tests/test.factor @@ -19,7 +19,7 @@ SYMBOL: xml-file [ "a" ] [ xml-file get space>> ] unit-test [ "http://www.hello.com" ] [ xml-file get url>> ] unit-test [ "that" ] [ - xml-file get T{ name f "" "this" "http://d.de" } swap at + xml-file get T{ name f "" "this" "http://d.de" } attr ] unit-test [ t ] [ xml-file get children>> second contained-tag? ] unit-test [ "" string>xml ] [ xml-error? ] must-fail-with @@ -30,7 +30,7 @@ SYMBOL: xml-file xml-file get after>> [ instruction? ] find nip text>> ] unit-test [ V{ "fa&g" } ] [ xml-file get "x" get-id children>> ] unit-test -[ "that" ] [ xml-file get "this" swap at ] unit-test +[ "that" ] [ xml-file get "this" attr ] unit-test [ "abcd" ] [ "
abcd
" string>xml [ [ dup string? [ % ] [ drop ] if ] deep-each ] "" make @@ -43,9 +43,11 @@ SYMBOL: xml-file "foo" string>xml "c" get-id children>string ] unit-test -[ "foo" ] [ "" string>xml "y" over - at swap "z" [ tuck ] dip swap set-at - T{ name f "blah" "z" f } swap at ] unit-test +[ "foo" ] [ + "" string>xml + dup dup "y" attr "z" set-attr + T{ name { space "blah" } { main "z" } } attr +] unit-test [ "foo" ] [ "" string>xml children>string ] unit-test [ "" string>xml ] must-fail [ ] [ "" string>xml drop ] unit-test @@ -58,5 +60,6 @@ SYMBOL: xml-file [ T{ doctype-decl f "foo" T{ system-id f "blah.dtd" } } ] [ "" string>xml-chunk first ] unit-test [ T{ doctype-decl f "foo" T{ system-id f "blah.dtd" } } ] [ "" string>xml-chunk first ] unit-test [ 958 ] [ [ "ξ" string>xml-chunk ] with-html-entities first first ] unit-test -[ "x" "<" ] [ "" string>xml [ name>> main>> ] [ "value" swap at ] bi ] unit-test +[ "x" "<" ] [ "" string>xml [ name>> main>> ] [ "value" attr ] bi ] unit-test [ "foo" ] [ "]>&bar;" string>xml children>string ] unit-test +[ T{ xml-chunk f V{ "hello" } } ] [ "hello" string>xml-chunk ] unit-test diff --git a/basis/xml/tests/xmltest.factor b/basis/xml/tests/xmltest.factor index 8caa5e8a75..a6a28e15a3 100644 --- a/basis/xml/tests/xmltest.factor +++ b/basis/xml/tests/xmltest.factor @@ -1,16 +1,16 @@ USING: accessors assocs combinators continuations fry generalizations io.pathnames kernel macros sequences stack-checker tools.test xml -xml.utilities xml.writer arrays ; +xml.utilities xml.writer arrays xml.data ; IN: xml.tests.suite TUPLE: xml-test id uri sections description type ; : >xml-test ( tag -- test ) xml-test new swap { - [ "TYPE" swap at >>type ] - [ "ID" swap at >>id ] - [ "URI" swap at >>uri ] - [ "SECTIONS" swap at >>sections ] + [ "TYPE" attr >>type ] + [ "ID" attr >>id ] + [ "URI" attr >>uri ] + [ "SECTIONS" attr >>sections ] [ children>> xml-chunk>string >>description ] } cleave ; @@ -51,3 +51,5 @@ MACRO: drop-input ( quot -- newquot ) : failing-valids ( -- tests ) partition-xml-tests nip [ second first ] map [ type>> "valid" = ] filter ; + +[ ] [ partition-xml-tests 2drop ] unit-test diff --git a/basis/xml/writer/writer-tests.factor b/basis/xml/writer/writer-tests.factor index e9959c1ef4..dcf7f1023d 100644 --- a/basis/xml/writer/writer-tests.factor +++ b/basis/xml/writer/writer-tests.factor @@ -52,7 +52,6 @@ IN: xml.writer.tests &foo;"} pprint-reprints-as [ t ] [ "" dup string>xml-chunk xml-chunk>string = ] unit-test -[ V{ "hello" } ] [ "hello" string>xml-chunk ] unit-test [ "" ] [ "" string>xml xml>string ] unit-test [ "bar baz" ] diff --git a/basis/xml/xml.factor b/basis/xml/xml.factor index b043d5771e..5369b04d9c 100644 --- a/basis/xml/xml.factor +++ b/basis/xml/xml.factor @@ -162,7 +162,8 @@ PRIVATE> : read-xml-chunk ( stream -- seq ) 1 depth - [ (read-xml-chunk) nip ] with-variable ; + [ (read-xml-chunk) nip ] with-variable + ; : string>xml ( string -- xml ) t string-input? diff --git a/basis/xmode/loader/loader.factor b/basis/xmode/loader/loader.factor index 8639c93e71..64c4234bd3 100644 --- a/basis/xmode/loader/loader.factor +++ b/basis/xmode/loader/loader.factor @@ -13,10 +13,10 @@ TAG: PROPS parse-props-tag >>props drop ; TAG: IMPORT - "DELEGATE" swap at swap import-rule-set ; + "DELEGATE" attr swap import-rule-set ; TAG: TERMINATE - "AT_CHAR" swap at string>number >>terminate-char drop ; + "AT_CHAR" attr string>number >>terminate-char drop ; RULE: SEQ seq-rule shared-tag-attrs delegate-attr literal-start ; diff --git a/basis/xmode/marker/marker.factor b/basis/xmode/marker/marker.factor index 798807f198..5d10d2ed02 100644 --- a/basis/xmode/marker/marker.factor +++ b/basis/xmode/marker/marker.factor @@ -297,7 +297,7 @@ M: mark-previous-rule handle-rule-start : tokenize-line ( line-context line rules -- line-context' seq ) [ - "MAIN" swap at -rot + "MAIN" attr -rot init-token-marker mark-token-loop mark-remaining From f438bd5157f32c4dea0d6c5220ae9492fc3a1fb4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 28 Jan 2009 15:04:36 -0600 Subject: [PATCH 02/21] Better handling of wrappers in locals --- basis/locals/locals-tests.factor | 4 +++- basis/locals/rewrite/sugar/sugar.factor | 11 ++++++----- 2 files changed, 9 insertions(+), 6 deletions(-) diff --git a/basis/locals/locals-tests.factor b/basis/locals/locals-tests.factor index 982674694a..e3aa504fbc 100644 --- a/basis/locals/locals-tests.factor +++ b/basis/locals/locals-tests.factor @@ -494,4 +494,6 @@ M:: integer lambda-method-forget-test ( a -- b ) ; ! Discovered by littledan [ "bar" ] [ [let | a [ [let | foo [ "bar" ] | foo ] ] | a ] ] unit-test -[ 10 ] [ [let | a [ 10 ] | [let | b [ a ] | b ] ] ] unit-test \ No newline at end of file +[ 10 ] [ [let | a [ 10 ] | [let | b [ a ] | b ] ] ] unit-test + +[ { \ + } ] [ [let | x [ \ + ] | { \ x } ] ] unit-test \ No newline at end of file diff --git a/basis/locals/rewrite/sugar/sugar.factor b/basis/locals/rewrite/sugar/sugar.factor index 835fa6e421..6e7e156ced 100644 --- a/basis/locals/rewrite/sugar/sugar.factor +++ b/basis/locals/rewrite/sugar/sugar.factor @@ -37,7 +37,7 @@ M: array rewrite-literal? [ rewrite-literal? ] contains? ; M: quotation rewrite-literal? [ rewrite-literal? ] contains? ; -M: wrapper rewrite-literal? drop t ; +M: wrapper rewrite-literal? wrapped>> rewrite-literal? ; M: hashtable rewrite-literal? drop t ; @@ -53,7 +53,7 @@ GENERIC: rewrite-element ( obj -- ) [ rewrite-element ] each ; : rewrite-sequence ( seq -- ) - [ rewrite-elements ] [ length , ] [ 0 head , ] tri \ nsequence , ; + [ rewrite-elements ] [ length ] [ 0 head ] tri '[ _ _ nsequence ] % ; M: array rewrite-element dup rewrite-literal? [ rewrite-sequence ] [ , ] if ; @@ -63,7 +63,7 @@ M: vector rewrite-element rewrite-sequence ; M: hashtable rewrite-element >alist rewrite-sequence \ >hashtable , ; M: tuple rewrite-element - [ tuple-slots rewrite-elements ] [ class literalize , ] bi \ boa , ; + [ tuple-slots rewrite-elements ] [ class ] bi '[ _ boa ] % ; M: quotation rewrite-element rewrite-sugar* ; @@ -84,7 +84,7 @@ M: local-word rewrite-element M: word rewrite-element literalize , ; M: wrapper rewrite-element - dup rewrite-literal? [ wrapped>> rewrite-element ] [ , ] if ; + dup rewrite-literal? [ wrapped>> rewrite-element \ literalize , ] [ , ] if ; M: object rewrite-element , ; @@ -98,7 +98,8 @@ M: def rewrite-sugar* , ; M: hashtable rewrite-sugar* rewrite-element ; -M: wrapper rewrite-sugar* rewrite-element ; +M: wrapper rewrite-sugar* + dup rewrite-literal? [ wrapped>> rewrite-element ] [ , ] if ; M: word rewrite-sugar* dup { load-locals get-local drop-locals } memq? From 16181f818b5ad90dade709e8c48f2bcf2b5641bb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 28 Jan 2009 15:07:16 -0600 Subject: [PATCH 03/21] Clean up functors so that the generated code looks sane with 'see' --- basis/functors/functors-tests.factor | 2 +- basis/functors/functors.factor | 33 ++++++++++-- basis/io/mmap/functor/functor.factor | 4 +- basis/math/blas/cblas/tags.txt | 1 - basis/math/blas/matrices/matrices.factor | 26 +++++----- basis/math/blas/matrices/tags.txt | 1 - basis/math/blas/syntax/syntax.factor | 2 +- basis/math/blas/syntax/tags.txt | 1 - basis/math/blas/vectors/tags.txt | 1 - basis/math/blas/vectors/vectors.factor | 52 +++++++++---------- .../specialized-arrays/functor/functor.factor | 6 +-- .../functor/functor.factor | 10 ++-- 12 files changed, 80 insertions(+), 59 deletions(-) diff --git a/basis/functors/functors-tests.factor b/basis/functors/functors-tests.factor index 39923afee7..577debd398 100644 --- a/basis/functors/functors-tests.factor +++ b/basis/functors/functors-tests.factor @@ -34,7 +34,7 @@ WW DEFINES ${W}${W} WHERE -: WW W twice ; inline +: WW ( a -- b ) \ W twice ; inline ;FUNCTOR diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor index 28bedc8360..b13ee8ff7c 100644 --- a/basis/functors/functors.factor +++ b/basis/functors/functors.factor @@ -1,17 +1,42 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel quotations classes.tuple make combinators generic words interpolate namespaces sequences io.streams.string fry classes.mixin effects lexer parser classes.tuple.parser effects.parser locals.types locals.parser -locals.rewrite.closures vocabs.parser ; +locals.rewrite.closures vocabs.parser arrays accessors ; IN: functors +! This is a hack + : scan-param ( -- obj ) scan-object dup special? [ literalize ] unless ; : define* ( word def effect -- ) pick set-word define-declared ; +TUPLE: fake-quotation seq ; + +GENERIC: >fake-quotations ( quot -- fake ) + +M: callable >fake-quotations + >array >fake-quotations fake-quotation boa ; + +M: array >fake-quotations [ >fake-quotations ] { } map-as ; + +M: object >fake-quotations ; + +GENERIC: fake-quotations> ( fake -- quot ) + +M: fake-quotation fake-quotations> + seq>> [ fake-quotations> ] map >quotation ; + +M: array fake-quotations> [ fake-quotations> ] map ; + +M: object fake-quotations> ; + +: parse-definition* ( -- ) + parse-definition >fake-quotations parsed \ fake-quotations> parsed ; + : DEFINE* ( accum -- accum ) effect get parsed \ define* parsed ; : `TUPLE: @@ -32,7 +57,7 @@ IN: functors scan-param parsed scan-param parsed \ create-method parsed - parse-definition parsed + parse-definition* DEFINE* ; parsing : `C: @@ -45,7 +70,7 @@ IN: functors : `: effect off scan-param parsed - parse-definition parsed + parse-definition* DEFINE* ; parsing : `INSTANCE: diff --git a/basis/io/mmap/functor/functor.factor b/basis/io/mmap/functor/functor.factor index 4587a75fd9..954d8b43c7 100644 --- a/basis/io/mmap/functor/functor.factor +++ b/basis/io/mmap/functor/functor.factor @@ -20,9 +20,9 @@ with-mapped-A-file DEFINES with-mapped-${T}-file WHERE : ( mapped-file -- direct-array ) - T mapped-file>direct execute ; inline + T mapped-file>direct ; inline : with-mapped-A-file ( path length quot -- ) - '[ execute @ ] with-mapped-file ; inline + '[ @ ] with-mapped-file ; inline ;FUNCTOR diff --git a/basis/math/blas/cblas/tags.txt b/basis/math/blas/cblas/tags.txt index 5118958180..241ec1ecda 100644 --- a/basis/math/blas/cblas/tags.txt +++ b/basis/math/blas/cblas/tags.txt @@ -1,3 +1,2 @@ math bindings -unportable diff --git a/basis/math/blas/matrices/matrices.factor b/basis/math/blas/matrices/matrices.factor index 75ab07709a..f6b98e3ae2 100755 --- a/basis/math/blas/matrices/matrices.factor +++ b/basis/math/blas/matrices/matrices.factor @@ -268,28 +268,28 @@ TUPLE: MATRIX < blas-matrix-base ; M: MATRIX element-type drop TYPE ; M: MATRIX (blas-matrix-like) - drop execute ; + drop ; M: VECTOR (blas-matrix-like) - drop execute ; + drop ; M: MATRIX (blas-vector-like) - drop execute ; + drop ; : >MATRIX ( arrays -- matrix ) - [ >ARRAY execute underlying>> ] (>matrix) - execute ; + [ >ARRAY underlying>> ] (>matrix) + ; M: VECTOR n*M.V+n*V! - [ TYPE>ARG execute ] (prepare-gemv) - [ XGEMV execute ] dip ; + [ TYPE>ARG ] (prepare-gemv) + [ XGEMV ] dip ; M: MATRIX n*M.M+n*M! - [ TYPE>ARG execute ] (prepare-gemm) - [ XGEMM execute ] dip ; + [ TYPE>ARG ] (prepare-gemm) + [ XGEMM ] dip ; M: MATRIX n*V(*)V+M! - [ TYPE>ARG execute ] (prepare-ger) - [ XGERU execute ] dip ; + [ TYPE>ARG ] (prepare-ger) + [ XGERU ] dip ; M: MATRIX n*V(*)Vconj+M! - [ TYPE>ARG execute ] (prepare-ger) - [ XGERC execute ] dip ; + [ TYPE>ARG ] (prepare-ger) + [ XGERC ] dip ; ;FUNCTOR diff --git a/basis/math/blas/matrices/tags.txt b/basis/math/blas/matrices/tags.txt index 5118958180..241ec1ecda 100644 --- a/basis/math/blas/matrices/tags.txt +++ b/basis/math/blas/matrices/tags.txt @@ -1,3 +1,2 @@ math bindings -unportable diff --git a/basis/math/blas/syntax/syntax.factor b/basis/math/blas/syntax/syntax.factor index 95f9f7bd08..2d171a801b 100644 --- a/basis/math/blas/syntax/syntax.factor +++ b/basis/math/blas/syntax/syntax.factor @@ -1,5 +1,5 @@ USING: kernel math.blas.vectors math.blas.matrices parser -arrays prettyprint.backend sequences ; +arrays prettyprint.backend prettyprint.custom sequences ; IN: math.blas.syntax : svector{ diff --git a/basis/math/blas/syntax/tags.txt b/basis/math/blas/syntax/tags.txt index 6a932d96d2..ede10ab61b 100644 --- a/basis/math/blas/syntax/tags.txt +++ b/basis/math/blas/syntax/tags.txt @@ -1,2 +1 @@ math -unportable diff --git a/basis/math/blas/vectors/tags.txt b/basis/math/blas/vectors/tags.txt index 6a932d96d2..ede10ab61b 100644 --- a/basis/math/blas/vectors/tags.txt +++ b/basis/math/blas/vectors/tags.txt @@ -1,2 +1 @@ math -unportable diff --git a/basis/math/blas/vectors/vectors.factor b/basis/math/blas/vectors/vectors.factor index db027b0ffd..c86fa30115 100755 --- a/basis/math/blas/vectors/vectors.factor +++ b/basis/math/blas/vectors/vectors.factor @@ -144,26 +144,26 @@ TUPLE: VECTOR < blas-vector-base ; : ( underlying length inc -- vector ) VECTOR boa ; inline : >VECTOR ( seq -- v ) - [ >ARRAY execute underlying>> ] [ length ] bi 1 execute ; + [ >ARRAY underlying>> ] [ length ] bi 1 ; M: VECTOR clone TYPE heap-size (prepare-copy) - [ XCOPY execute ] 3dip execute ; + [ XCOPY ] 3dip ; M: VECTOR element-type drop TYPE ; M: VECTOR Vswap - (prepare-swap) [ XSWAP execute ] 2dip ; + (prepare-swap) [ XSWAP ] 2dip ; M: VECTOR Viamax - (prepare-nrm2) IXAMAX execute ; + (prepare-nrm2) IXAMAX ; M: VECTOR (blas-vector-like) - drop execute ; + drop ; M: VECTOR (blas-direct-array) [ underlying>> ] [ [ length>> ] [ inc>> ] bi * ] bi - execute ; + ; ;FUNCTOR @@ -180,17 +180,17 @@ XSCAL IS cblas_${T}scal WHERE M: VECTOR V. - (prepare-dot) XDOT execute ; + (prepare-dot) XDOT ; M: VECTOR V.conj - (prepare-dot) XDOT execute ; + (prepare-dot) XDOT ; M: VECTOR Vnorm - (prepare-nrm2) XNRM2 execute ; + (prepare-nrm2) XNRM2 ; M: VECTOR Vasum - (prepare-nrm2) XASUM execute ; + (prepare-nrm2) XASUM ; M: VECTOR n*V+V! - (prepare-axpy) [ XAXPY execute ] dip ; + (prepare-axpy) [ XAXPY ] dip ; M: VECTOR n*V! - (prepare-scal) [ XSCAL execute ] dip ; + (prepare-scal) [ XSCAL ] dip ; ;FUNCTOR @@ -207,13 +207,13 @@ COMPLEX>ARG DEFINES ${TYPE}-complex>arg WHERE : ( alien len -- sequence ) - 1 shift execute ; + 1 shift ; : >COMPLEX-ARRAY ( sequence -- sequence ) - >ARRAY execute ; + >ARRAY ; : COMPLEX>ARG ( complex -- alien ) - >rect 2array >ARRAY execute underlying>> ; + >rect 2array >ARRAY underlying>> ; : ARG>COMPLEX ( alien -- complex ) - 2 execute first2 rect> ; + 2 first2 rect> ; ;FUNCTOR @@ -234,22 +234,22 @@ WHERE M: VECTOR V. (prepare-dot) TYPE - [ XDOTU_SUB execute ] keep - ARG>TYPE execute ; + [ XDOTU_SUB ] keep + ARG>TYPE ; M: VECTOR V.conj (prepare-dot) TYPE - [ XDOTC_SUB execute ] keep - ARG>TYPE execute ; + [ XDOTC_SUB ] keep + ARG>TYPE ; M: VECTOR Vnorm - (prepare-nrm2) XXNRM2 execute ; + (prepare-nrm2) XXNRM2 ; M: VECTOR Vasum - (prepare-nrm2) XXASUM execute ; + (prepare-nrm2) XXASUM ; M: VECTOR n*V+V! - [ TYPE>ARG execute ] 2dip - (prepare-axpy) [ XAXPY execute ] dip ; + [ TYPE>ARG ] 2dip + (prepare-axpy) [ XAXPY ] dip ; M: VECTOR n*V! - [ TYPE>ARG execute ] dip - (prepare-scal) [ XSCAL execute ] dip ; + [ TYPE>ARG ] dip + (prepare-scal) [ XSCAL ] dip ; ;FUNCTOR diff --git a/basis/specialized-arrays/functor/functor.factor b/basis/specialized-arrays/functor/functor.factor index 579da5b84a..718a1a7aa1 100644 --- a/basis/specialized-arrays/functor/functor.factor +++ b/basis/specialized-arrays/functor/functor.factor @@ -49,9 +49,9 @@ M: A set-nth-unsafe underlying>> SET-NTH call ; : >A ( seq -- specialized-array ) A new clone-like ; inline -M: A like drop dup A instance? [ >A execute ] unless ; +M: A like drop dup A instance? [ >A ] unless ; -M: A new-sequence drop (A) execute ; +M: A new-sequence drop (A) ; M: A equal? over A instance? [ sequence= ] [ 2drop f ] if ; @@ -70,7 +70,7 @@ M: A >pprint-sequence ; M: A pprint* pprint-object ; -: A{ \ } [ >A execute ] parse-literal ; parsing +: A{ \ } [ >A ] parse-literal ; parsing INSTANCE: A sequence diff --git a/basis/specialized-vectors/functor/functor.factor b/basis/specialized-vectors/functor/functor.factor index 6069a4cb4a..e6f1986874 100644 --- a/basis/specialized-vectors/functor/functor.factor +++ b/basis/specialized-vectors/functor/functor.factor @@ -18,16 +18,16 @@ WHERE TUPLE: V { underlying A } { length array-capacity } ; -: ( capacity -- vector ) execute 0 V boa ; inline +: ( capacity -- vector ) 0 V boa ; inline M: V like drop dup V instance? [ - dup A instance? [ dup length V boa ] [ >V execute ] if + dup A instance? [ dup length V boa ] [ >V ] if ] unless ; -M: V new-sequence drop [ execute ] [ >fixnum ] bi V boa ; +M: V new-sequence drop [ ] [ >fixnum ] bi V boa ; -M: A new-resizable drop execute ; +M: A new-resizable drop ; M: V equal? over V instance? [ sequence= ] [ 2drop f ] if ; @@ -39,7 +39,7 @@ M: V >pprint-sequence ; M: V pprint* pprint-object ; -: V{ \ } [ >V execute ] parse-literal ; parsing +: V{ \ } [ >V ] parse-literal ; parsing INSTANCE: V growable From 1a409b92138cf072f876fbf622a657ced8fda59a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 28 Jan 2009 15:46:04 -0600 Subject: [PATCH 04/21] Fix specialized-arrays.direct.functor --- basis/specialized-arrays/direct/functor/functor.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/specialized-arrays/direct/functor/functor.factor b/basis/specialized-arrays/direct/functor/functor.factor index 14fb739947..ce23186fc6 100755 --- a/basis/specialized-arrays/direct/functor/functor.factor +++ b/basis/specialized-arrays/direct/functor/functor.factor @@ -27,8 +27,8 @@ TUPLE: A M: A length length>> ; M: A nth-unsafe underlying>> NTH call ; M: A set-nth-unsafe underlying>> SET-NTH call ; -M: A like drop dup A instance? [ >A' execute ] unless ; -M: A new-sequence drop execute ; +M: A like drop dup A instance? [ >A' ] unless ; +M: A new-sequence drop ; INSTANCE: A sequence From d5160ce79198521f8ad3eb00776849d53331ab6b Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 28 Jan 2009 15:46:34 -0600 Subject: [PATCH 05/21] Fixing USING: lines --- basis/http/client/client.factor | 2 +- basis/http/server/server.factor | 1 + basis/xml/data/data.factor | 7 ++----- basis/xmode/marker/marker.factor | 2 +- 4 files changed, 5 insertions(+), 7 deletions(-) diff --git a/basis/http/client/client.factor b/basis/http/client/client.factor index edfc6e312b..e7305ed372 100644 --- a/basis/http/client/client.factor +++ b/basis/http/client/client.factor @@ -5,7 +5,7 @@ sequences strings splitting calendar continuations accessors vectors math.order hashtables byte-arrays destructors io io.sockets io.streams.string io.files io.timeouts io.pathnames io.encodings io.encodings.string io.encodings.ascii -io.encodings.utf8 io.encodings.8-bit io.encodings.binary +io.encodings.utf8 io.encodings.8-bit io.encodings.binary io.crlf io.streams.duplex fry ascii urls urls.encoding present http http.parsers http.client.post-data ; IN: http.client diff --git a/basis/http/server/server.factor b/basis/http/server/server.factor index c9ec2c7f3e..b4af727caa 100755 --- a/basis/http/server/server.factor +++ b/basis/http/server/server.factor @@ -14,6 +14,7 @@ io.encodings.binary io.streams.limited io.servers.connection io.timeouts +io.crlf fry logging logging.insomniac calendar urls urls.encoding mime.multipart unicode.categories diff --git a/basis/xml/data/data.factor b/basis/xml/data/data.factor index 74ad348bab..6cd975d42d 100644 --- a/basis/xml/data/data.factor +++ b/basis/xml/data/data.factor @@ -150,10 +150,10 @@ TUPLE: tag [ assure-name ] [ T{ attrs } assoc-like ] [ ] tri* tag boa ; -: attr ( tag name -- string ) +: attr ( tag/xml name -- string ) swap attrs>> at ; -: set-attr ( tag value name -- ) +: set-attr ( tag/xml value name -- ) rot attrs>> set-at ; ! They also follow the sequence protocol (for children) @@ -188,9 +188,6 @@ C: xml CONSULT: sequence-protocol xml body>> ; INSTANCE: xml sequence -CONSULT: assoc-protocol xml body>> ; -INSTANCE: xml assoc - CONSULT: tag xml body>> ; CONSULT: name xml body>> ; diff --git a/basis/xmode/marker/marker.factor b/basis/xmode/marker/marker.factor index 5d10d2ed02..ce942fbc67 100644 --- a/basis/xmode/marker/marker.factor +++ b/basis/xmode/marker/marker.factor @@ -5,7 +5,7 @@ USING: kernel namespaces make xmode.rules xmode.tokens xmode.marker.state xmode.marker.context xmode.utilities xmode.catalog sequences math assocs combinators strings parser-combinators.regexp splitting parser-combinators ascii -ascii combinators.short-circuit accessors ; +ascii combinators.short-circuit accessors xml.data ; ! Based on org.gjt.sp.jedit.syntax.TokenMarker From 940a0853252387c18c0cf9a8a1e946511b66cca9 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 28 Jan 2009 16:17:20 -0600 Subject: [PATCH 06/21] XML interpolation efficiency/cleanup --- .../xml/interpolate/interpolate-tests.factor | 15 ++++++-- basis/xml/interpolate/interpolate.factor | 38 ++++++++++--------- 2 files changed, 32 insertions(+), 21 deletions(-) diff --git a/basis/xml/interpolate/interpolate-tests.factor b/basis/xml/interpolate/interpolate-tests.factor index 4a7c64dd16..35c4e793ea 100644 --- a/basis/xml/interpolate/interpolate-tests.factor +++ b/basis/xml/interpolate/interpolate-tests.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: tools.test xml.interpolate multiline kernel assocs sequences accessors xml.writer xml.interpolate.private -locals splitting urls xml.data ; +locals splitting urls xml.data classes ; IN: xml.interpolate.tests [ "a" "c" { "a" "c" f } ] [ @@ -54,6 +54,15 @@ IN: xml.interpolate.tests [ "3" ] [ 3 [XML <-> XML] xml-chunk>string ] unit-test [ "" ] [ f [XML <-> XML] xml-chunk>string ] unit-test -\ parse-def must-infer -[ "" interpolate-chunk ] must-infer +\ <-> /> XML] ] must-infer + +[ xml-chunk ] [ [ [XML XML] ] first class ] unit-test +[ xml ] [ [ XML> ] first class ] unit-test +[ xml-chunk ] [ [ [XML /> XML] ] third class ] unit-test +[ xml ] [ [ /> XML> ] third class ] unit-test +[ 1 ] [ [ [XML XML] ] length ] unit-test +[ 1 ] [ [ XML> ] length ] unit-test + +[ "" ] [ [XML XML] concat ] unit-test diff --git a/basis/xml/interpolate/interpolate.factor b/basis/xml/interpolate/interpolate.factor index b9535fba39..e28e83e47f 100644 --- a/basis/xml/interpolate/interpolate.factor +++ b/basis/xml/interpolate/interpolate.factor @@ -64,14 +64,18 @@ M: interpolated interpolate-item : number<-> ( doc -- dup ) 0 over [ - dup var>> [ over >>var [ 1+ ] dip ] unless drop + dup var>> [ + over >>var [ 1+ ] dip + ] unless drop ] each-interpolated drop ; -MACRO: interpolate-xml ( string -- doc ) - string>doc number<-> '[ _ interpolate-xml-doc ] ; +GENERIC: interpolate-xml ( table xml -- xml ) -MACRO: interpolate-chunk ( string -- chunk ) - string>chunk number<-> '[ _ interpolate-sequence ] ; +M: xml interpolate-xml + interpolate-xml-doc ; + +M: xml-chunk interpolate-xml + interpolate-sequence ; : >search-hash ( seq -- hash ) [ dup search ] H{ } map>assoc ; @@ -82,26 +86,24 @@ MACRO: interpolate-chunk ( string -- chunk ) : nenum ( ... n -- assoc ) narray ; inline -: collect ( accum seq -- accum ) +: collect ( accum variables -- accum ? ) { - { [ dup [ ] all? ] [ >search-hash parsed ] } ! locals - { [ dup [ not ] all? ] [ ! fry - length parsed \ nenum parsed - ] } + { [ dup empty? ] [ drop f ] } ! Just a literal + { [ dup [ ] all? ] [ >search-hash parsed t ] } ! locals + { [ dup [ not ] all? ] [ length parsed \ nenum parsed t ] } ! fry [ drop "XML interpolation contains both fry and locals" throw ] ! mixed } cond ; -: parse-def ( accum delimiter word -- accum ) - [ - parse-multiline-string but-last - [ string>chunk extract-variables collect ] keep - parsed - ] dip parsed ; +: parse-def ( accum delimiter quot -- accum ) + [ parse-multiline-string 1 short head* ] dip call + [ extract-variables collect ] keep swap + [ number<-> parsed ] dip + [ \ interpolate-xml parsed ] when ; inline PRIVATE> : " \ interpolate-xml parse-def ; parsing + "XML>" [ string>doc ] parse-def ; parsing : [XML - "XML]" \ interpolate-chunk parse-def ; parsing + "XML]" [ string>chunk ] parse-def ; parsing From 88e8b95cf7ef4a3a39554ef1f4332611adcc34c0 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 28 Jan 2009 16:25:41 -0600 Subject: [PATCH 07/21] Reverting xmode.marker (it's not using XML!) --- basis/xmode/marker/marker.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/xmode/marker/marker.factor b/basis/xmode/marker/marker.factor index ce942fbc67..798807f198 100644 --- a/basis/xmode/marker/marker.factor +++ b/basis/xmode/marker/marker.factor @@ -5,7 +5,7 @@ USING: kernel namespaces make xmode.rules xmode.tokens xmode.marker.state xmode.marker.context xmode.utilities xmode.catalog sequences math assocs combinators strings parser-combinators.regexp splitting parser-combinators ascii -ascii combinators.short-circuit accessors xml.data ; +ascii combinators.short-circuit accessors ; ! Based on org.gjt.sp.jedit.syntax.TokenMarker @@ -297,7 +297,7 @@ M: mark-previous-rule handle-rule-start : tokenize-line ( line-context line rules -- line-context' seq ) [ - "MAIN" attr -rot + "MAIN" swap at -rot init-token-marker mark-token-loop mark-remaining From 4de41f94e91529b828bbbeab690c18525a20beda Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 28 Jan 2009 17:07:31 -0600 Subject: [PATCH 08/21] Fixing wrappers with locals --- basis/functors/functors-tests.factor | 18 ++++++++++++++++++ basis/functors/functors.factor | 11 +++++++++-- basis/locals/locals-docs.factor | 6 ++++-- basis/locals/locals-tests.factor | 6 +++++- basis/locals/rewrite/sugar/sugar.factor | 10 +++++++--- basis/locals/types/types.factor | 9 +++++++-- .../specialized-arrays/functor/functor.factor | 2 +- core/quotations/quotations-docs.factor | 4 ++++ core/syntax/syntax.factor | 2 +- 9 files changed, 56 insertions(+), 12 deletions(-) diff --git a/basis/functors/functors-tests.factor b/basis/functors/functors-tests.factor index 577debd398..a5f3042b38 100644 --- a/basis/functors/functors-tests.factor +++ b/basis/functors/functors-tests.factor @@ -45,3 +45,21 @@ WHERE \ sqsq must-infer [ 16 ] [ 2 sqsq ] unit-test + +<< + +FUNCTOR: wrapper-test-2 ( W -- ) + +W DEFINES ${W} + +WHERE + +: W ( a b -- c ) \ + execute ; + +;FUNCTOR + +"blah" wrapper-test-2 + +>> + +[ 4 ] [ 1 3 blah ] unit-test \ No newline at end of file diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor index b13ee8ff7c..f4d35b6932 100644 --- a/basis/functors/functors.factor +++ b/basis/functors/functors.factor @@ -9,8 +9,9 @@ IN: functors ! This is a hack -: scan-param ( -- obj ) - scan-object dup special? [ literalize ] unless ; + ; [ scan interpolate-locals ] dip '[ _ with-string-writer @ ] parsed ; +PRIVATE> + : IS [ dup search [ ] [ no-word ] ?if ] (INTERPOLATE) ; parsing : DEFINES [ create-in ] (INTERPOLATE) ; parsing DEFER: ;FUNCTOR delimiter + rewrite-closures first ; +PRIVATE> + : FUNCTOR: (FUNCTOR:) define ; parsing diff --git a/basis/locals/locals-docs.factor b/basis/locals/locals-docs.factor index efaad748cf..a4a9ca448b 100644 --- a/basis/locals/locals-docs.factor +++ b/basis/locals/locals-docs.factor @@ -113,7 +113,7 @@ HELP: MEMO:: { POSTPONE: MEMO: POSTPONE: MEMO:: } related-words -ARTICLE: "locals-literals" "Locals in array and hashtable literals" +ARTICLE: "locals-literals" "Locals in literals" "Certain data type literals are permitted to contain free variables. Any such literals are written into code which constructs an instance of the type with the free variable values spliced in. Conceptually, this is similar to the transformation applied to quotations containing free variables." $nl "The data types which receive this special handling are the following:" @@ -122,7 +122,9 @@ $nl { $link "hashtables" } { $link "vectors" } { $link "tuples" } + { $link "wrappers" } } +{ $heading "Object identity" } "This feature changes the semantics of literal object identity. An ordinary word containing a literal pushes the same literal on the stack every time it is invoked:" { $example "IN: scratchpad" @@ -143,7 +145,7 @@ $nl "f" } "One exception to the above rule is that array instances containing no free variables do retain identity. This allows macros such as " { $link cond } " to recognize that the array is constant and expand at compile-time." -$nl +{ $heading "Example" } "For example, here is an implementation of the " { $link 3array } " word which uses this feature:" { $code ":: 3array ( x y z -- array ) { x y z } ;" } ; diff --git a/basis/locals/locals-tests.factor b/basis/locals/locals-tests.factor index e3aa504fbc..bd9e7cf103 100644 --- a/basis/locals/locals-tests.factor +++ b/basis/locals/locals-tests.factor @@ -496,4 +496,8 @@ M:: integer lambda-method-forget-test ( a -- b ) ; [ "bar" ] [ [let | a [ [let | foo [ "bar" ] | foo ] ] | a ] ] unit-test [ 10 ] [ [let | a [ 10 ] | [let | b [ a ] | b ] ] ] unit-test -[ { \ + } ] [ [let | x [ \ + ] | { \ x } ] ] unit-test \ No newline at end of file +[ { \ + } ] [ [let | x [ \ + ] | { \ x } ] ] unit-test + +[ { \ + 3 } ] [ [let | a [ 3 ] | { \ + a } ] ] unit-test + +[ 3 ] [ [let | a [ \ + ] | 1 2 [ \ a execute ] ] call ] unit-test \ No newline at end of file diff --git a/basis/locals/rewrite/sugar/sugar.factor b/basis/locals/rewrite/sugar/sugar.factor index 6e7e156ced..515473c467 100644 --- a/basis/locals/rewrite/sugar/sugar.factor +++ b/basis/locals/rewrite/sugar/sugar.factor @@ -81,10 +81,14 @@ M: local-writer rewrite-element M: local-word rewrite-element local-word-in-literal-error ; -M: word rewrite-element literalize , ; +M: word rewrite-element , ; + +: rewrite-wrapper ( wrapper -- ) + dup rewrite-literal? + [ wrapped>> rewrite-element ] [ , ] if ; M: wrapper rewrite-element - dup rewrite-literal? [ wrapped>> rewrite-element \ literalize , ] [ , ] if ; + rewrite-wrapper \ , ; M: object rewrite-element , ; @@ -99,7 +103,7 @@ M: def rewrite-sugar* , ; M: hashtable rewrite-sugar* rewrite-element ; M: wrapper rewrite-sugar* - dup rewrite-literal? [ wrapped>> rewrite-element ] [ , ] if ; + rewrite-wrapper ; M: word rewrite-sugar* dup { load-locals get-local drop-locals } memq? diff --git a/basis/locals/types/types.factor b/basis/locals/types/types.factor index 7a8dac1947..3ed753e094 100644 --- a/basis/locals/types/types.factor +++ b/basis/locals/types/types.factor @@ -1,6 +1,7 @@ -! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos. +! Copyright (C) 2007, 2009 Slava Pestov, Eduardo Cavazos. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors combinators kernel sequences words ; +USING: accessors combinators kernel sequences words +quotations ; IN: locals.types TUPLE: lambda vars body ; @@ -38,6 +39,8 @@ PREDICATE: local < word "local?" word-prop ; f dup t "local?" set-word-prop ; +M: local literalize ; + PREDICATE: local-word < word "local-word?" word-prop ; : ( name -- word ) @@ -49,6 +52,8 @@ PREDICATE: local-reader < word "local-reader?" word-prop ; f dup t "local-reader?" set-word-prop ; +M: local-reader literalize ; + PREDICATE: local-writer < word "local-writer?" word-prop ; : ( reader -- word ) diff --git a/basis/specialized-arrays/functor/functor.factor b/basis/specialized-arrays/functor/functor.factor index 718a1a7aa1..9a56346be4 100644 --- a/basis/specialized-arrays/functor/functor.factor +++ b/basis/specialized-arrays/functor/functor.factor @@ -64,7 +64,7 @@ M: A resize M: A byte-length underlying>> length ; -M: A pprint-delims drop A{ \ } ; +M: A pprint-delims drop \ A{ \ } ; M: A >pprint-sequence ; diff --git a/core/quotations/quotations-docs.factor b/core/quotations/quotations-docs.factor index 1a16d0f92a..f2629a36c4 100644 --- a/core/quotations/quotations-docs.factor +++ b/core/quotations/quotations-docs.factor @@ -14,6 +14,10 @@ $nl "Quotations implement the " { $link "sequence-protocol" } ", and existing sequences can be converted into quotations:" { $subsection >quotation } { $subsection 1quotation } +"Wrappers:" +{ $subsection "wrappers" } ; + +ARTICLE: "wrappers" "Wrappers" "Wrappers are used to push words on the data stack; they evaluate to the object being wrapped:" { $subsection wrapper } { $subsection literalize } diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index c81fc9201e..af5fa38aeb 100644 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -103,7 +103,7 @@ IN: bootstrap.syntax "W{" [ \ } [ first ] parse-literal ] define-syntax "POSTPONE:" [ scan-word parsed ] define-syntax - "\\" [ scan-word literalize parsed ] define-syntax + "\\" [ scan-word parsed ] define-syntax "inline" [ word make-inline ] define-syntax "recursive" [ word make-recursive ] define-syntax "foldable" [ word make-foldable ] define-syntax From 9dc60a552dfcf56d08e70eb7e00d04284d670c1e Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 28 Jan 2009 17:18:14 -0600 Subject: [PATCH 09/21] Fixing xmode bug --- basis/xmode/utilities/utilities.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/xmode/utilities/utilities.factor b/basis/xmode/utilities/utilities.factor index 871767ccf5..d6407d8180 100644 --- a/basis/xmode/utilities/utilities.factor +++ b/basis/xmode/utilities/utilities.factor @@ -22,7 +22,7 @@ IN: xmode.utilities ] } { [ dup length 3 = ] [ first3 '[ - _ tag get at + tag get _ attr _ [ execute ] when* object get _ execute ] ] } From dcad3ad2258ab2b026fdfb9a2f06e18a6315e9c7 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 28 Jan 2009 17:49:21 -0600 Subject: [PATCH 10/21] Un-breaking Chloe --- .../html/templates/chloe/compiler/compiler.factor | 8 ++++---- basis/html/templates/chloe/syntax/syntax.factor | 14 +++++++------- 2 files changed, 11 insertions(+), 11 deletions(-) diff --git a/basis/html/templates/chloe/compiler/compiler.factor b/basis/html/templates/chloe/compiler/compiler.factor index 331b565b98..4410cd7599 100644 --- a/basis/html/templates/chloe/compiler/compiler.factor +++ b/basis/html/templates/chloe/compiler/compiler.factor @@ -7,16 +7,16 @@ html.templates html.templates.chloe.syntax continuations ; IN: html.templates.chloe.compiler : chloe-attrs-only ( assoc -- assoc' ) - [ drop url>> chloe-ns = ] assoc-filter ; + [ drop chloe-name? ] assoc-filter ; : non-chloe-attrs-only ( assoc -- assoc' ) - [ drop url>> chloe-ns = not ] assoc-filter ; + [ drop chloe-name? not ] assoc-filter ; : chloe-tag? ( tag -- ? ) dup xml? [ body>> ] when { { [ dup tag? not ] [ f ] } - { [ dup url>> chloe-ns = not ] [ f ] } + { [ dup chloe-name? not ] [ f ] } [ t ] } cond nip ; @@ -49,7 +49,7 @@ DEFER: compile-element reset-buffer "@" ?head [ , [ value present ] % ] [ , ] if ; : compile-attrs ( assoc -- ) - [ + attrs>> [ " " [write] swap name>string [write] "=\"" [write] diff --git a/basis/html/templates/chloe/syntax/syntax.factor b/basis/html/templates/chloe/syntax/syntax.factor index 90c171917b..fb457ff1df 100644 --- a/basis/html/templates/chloe/syntax/syntax.factor +++ b/basis/html/templates/chloe/syntax/syntax.factor @@ -21,14 +21,14 @@ tags global [ H{ } clone or ] change-at : chloe-ns "http://factorcode.org/chloe/1.0" ; inline -: chloe-name ( string -- name ) - name new - swap >>main - chloe-ns >>url ; +: chloe-name? ( name -- ? ) + url>> chloe-ns = ; + +XML-NS: chloe-name http://factorcode.org/chloe/1.0 : required-attr ( tag name -- value ) - dup chloe-name rot at* - [ nip ] [ drop " attribute is required" append throw ] if ; + tuck chloe-name attr + [ nip ] [ " attribute is required" append throw ] if* ; : optional-attr ( tag name -- value ) - chloe-name swap at ; + chloe-name attr ; From dc49f138c4a684e84e3a8758e89db35372f9e1fc Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 28 Jan 2009 18:21:37 -0600 Subject: [PATCH 11/21] Fix to xmode --- basis/xmode/catalog/catalog.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/xmode/catalog/catalog.factor b/basis/xmode/catalog/catalog.factor index f8f1788bcf..8a8e5fad4a 100644 --- a/basis/xmode/catalog/catalog.factor +++ b/basis/xmode/catalog/catalog.factor @@ -1,6 +1,6 @@ USING: xmode.loader xmode.utilities xmode.rules namespaces strings splitting assocs sequences kernel io.files xml memoize -words globs combinators io.encodings.utf8 sorting accessors ; +words globs combinators io.encodings.utf8 sorting accessors xml.data ; IN: xmode.catalog TUPLE: mode file file-name-glob first-line-glob ; @@ -8,7 +8,7 @@ TUPLE: mode file file-name-glob first-line-glob ; >file) } { "FILE_NAME_GLOB" f (>>file-name-glob) } From e5760bf64428db4e650b6b0c9bb554093e99b8b3 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 28 Jan 2009 18:48:07 -0600 Subject: [PATCH 12/21] Slava is a hack, and specialized-vectors might work now --- basis/specialized-vectors/functor/functor.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/specialized-vectors/functor/functor.factor b/basis/specialized-vectors/functor/functor.factor index e6f1986874..2410cc284e 100644 --- a/basis/specialized-vectors/functor/functor.factor +++ b/basis/specialized-vectors/functor/functor.factor @@ -33,7 +33,7 @@ M: V equal? over V instance? [ sequence= ] [ 2drop f ] if ; : >V ( seq -- vector ) V new clone-like ; inline -M: V pprint-delims drop V{ \ } ; +M: V pprint-delims drop \ V{ \ } ; M: V >pprint-sequence ; From 41af194074bc56a5534dd5e69f31edcc68d6e074 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 28 Jan 2009 19:19:25 -0600 Subject: [PATCH 13/21] Update io.files docs --- core/io/files/files-docs.factor | 3 +++ 1 file changed, 3 insertions(+) diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index 7948a2e912..263b5c19b0 100644 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -22,16 +22,19 @@ ABOUT: "io.files" HELP: { $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "stream" "an input stream" } } { $description "Outputs an input stream for reading from the specified pathname using the given encoding." } +{ $notes "Most code should use " { $link with-file-reader } " instead, to ensure the stream is properly disposed of after." } { $errors "Throws an error if the file is unreadable." } ; HELP: { $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "stream" "an output stream" } } { $description "Outputs an output stream for writing to the specified pathname using the given encoding. The file's length is truncated to zero." } +{ $notes "Most code should use " { $link with-file-writer } " instead, to ensure the stream is properly disposed of after." } { $errors "Throws an error if the file cannot be opened for writing." } ; HELP: { $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "stream" "an output stream" } } { $description "Outputs an output stream for writing to the specified pathname using the given encoding. The stream begins writing at the end of the file." } +{ $notes "Most code should use " { $link with-file-appender } " instead, to ensure the stream is properly disposed of after." } { $errors "Throws an error if the file cannot be opened for writing." } ; HELP: with-file-reader From a45c91659ac4e0185998b53add41a613d6012804 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 28 Jan 2009 23:33:10 -0600 Subject: [PATCH 14/21] Update mmap docs --- basis/io/mmap/mmap-docs.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/basis/io/mmap/mmap-docs.factor b/basis/io/mmap/mmap-docs.factor index bd971656d4..5ef3400a6d 100644 --- a/basis/io/mmap/mmap-docs.factor +++ b/basis/io/mmap/mmap-docs.factor @@ -19,6 +19,7 @@ HELP: HELP: with-mapped-file { $values { "path" "a pathname string" } { "quot" { $quotation "( mmap -- )" } } } { $contract "Opens a file and maps its contents into memory, passing the " { $link mapped-file } " instance to the quotation. The mapped file is disposed of when the quotation returns, or if an error is thrown." } +{ $notes "This is a low-level word, because " { $link mapped-file } " objects simply expose their base address and length. Most applications should use " { $link "io.mmap.arrays" } " instead." } { $errors "Throws an error if a memory mapping could not be established." } ; HELP: close-mapped-file From 87e0110ff15b92169a2d985b5fd805342de7b339 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 28 Jan 2009 23:33:26 -0600 Subject: [PATCH 15/21] O(1) equal? and hashcode* for ranges --- basis/math/ranges/ranges-tests.factor | 8 ++++++-- basis/math/ranges/ranges.factor | 10 ++++++++-- core/classes/tuple/tuple.factor | 24 ++++++++++++++---------- 3 files changed, 28 insertions(+), 14 deletions(-) diff --git a/basis/math/ranges/ranges-tests.factor b/basis/math/ranges/ranges-tests.factor index 825c68d1b9..aedd2f7933 100644 --- a/basis/math/ranges/ranges-tests.factor +++ b/basis/math/ranges/ranges-tests.factor @@ -1,4 +1,4 @@ -USING: math.ranges sequences tools.test arrays ; +USING: math math.ranges sequences sets tools.test arrays ; IN: math.ranges.tests [ { } ] [ 1 1 (a,b) >array ] unit-test @@ -11,7 +11,7 @@ IN: math.ranges.tests [ { 1 } ] [ 1 2 [a,b) >array ] unit-test [ { 1 2 } ] [ 1 2 [a,b] >array ] unit-test -[ { } ] [ 2 1 (a,b) >array ] unit-test +[ { } ] [ 2 1 (a,b) >array ] unit-test [ { 1 } ] [ 2 1 (a,b] >array ] unit-test [ { 2 } ] [ 2 1 [a,b) >array ] unit-test [ { 2 1 } ] [ 2 1 [a,b] >array ] unit-test @@ -32,3 +32,7 @@ IN: math.ranges.tests [ 0 ] [ -1 5 [0,b] clamp-to-range ] unit-test [ 5 ] [ 6 5 [0,b] clamp-to-range ] unit-test [ { 0 1 2 3 4 } ] [ 5 sequence-index-range >array ] unit-test + +[ 100 ] [ + 1 100 [a,b] [ 2^ [1,b] ] map prune length +] unit-test \ No newline at end of file diff --git a/basis/math/ranges/ranges.factor b/basis/math/ranges/ranges.factor index 1a28904705..068f599b6f 100644 --- a/basis/math/ranges/ranges.factor +++ b/basis/math/ranges/ranges.factor @@ -1,7 +1,7 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel layouts math math.order namespaces sequences -sequences.private accessors ; +sequences.private accessors classes.tuple arrays ; IN: math.ranges TUPLE: range @@ -18,6 +18,12 @@ M: range length ( seq -- n ) M: range nth-unsafe ( n range -- obj ) [ step>> * ] keep from>> + ; +! For ranges with many elements, the default element-wise methods +! sequences define are unsuitable because they're O(n) +M: range equal? over range? [ tuple= ] [ 2drop f ] if ; + +M: range hashcode* tuple-hashcode ; + INSTANCE: range immutable-sequence : twiddle ( a b -- a b step ) 2dup > -1 1 ? ; inline diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 3ee9b8e40b..4f40d838b7 100644 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -79,16 +79,16 @@ M: tuple-class slots>tuple ERROR: bad-superclass class ; - ] ?if ; From 3e685b2eb44c027cb5a2e9bb8ab832dedef77531 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 28 Jan 2009 23:35:41 -0600 Subject: [PATCH 16/21] Add test case for bug discovered by erg --- basis/compiler/tests/codegen.factor | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/basis/compiler/tests/codegen.factor b/basis/compiler/tests/codegen.factor index 8ee120012d..bb3f9d6aa7 100644 --- a/basis/compiler/tests/codegen.factor +++ b/basis/compiler/tests/codegen.factor @@ -276,3 +276,9 @@ TUPLE: id obj ; [ 4 ] [ 2 [ dup fixnum* ] compile-call ] unit-test [ 7 ] [ 2 [ dup fixnum* 3 fixnum+fast ] compile-call ] unit-test + +SINGLETON: cucumber + +M: cucumber equal? "The cucumber has no equal" throw ; + +[ t ] [ [ cucumber ] compile-call cucumber eq? ] unit-test \ No newline at end of file From 1e5259198ce6cb10fc8ee0fd89a955ca163579b4 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 28 Jan 2009 23:45:00 -0600 Subject: [PATCH 17/21] Fixing Farkup tests --- basis/farkup/farkup-tests.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/farkup/farkup-tests.factor b/basis/farkup/farkup-tests.factor index ee09486a03..49c4dab0db 100644 --- a/basis/farkup/farkup-tests.factor +++ b/basis/farkup/farkup-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: farkup kernel peg peg.ebnf tools.test namespaces xml -urls.encoding assocs xml.utilities ; +urls.encoding assocs xml.utilities xml.data ; IN: farkup.tests relative-link-prefix off @@ -161,7 +161,7 @@ link-no-follow? off : check-link-escaping ( string -- link ) convert-farkup string>xml-chunk - "a" deep-tag-named "href" swap at url-decode ; + "a" deep-tag-named "href" attr url-decode ; [ "Trader Joe\"s" ] [ "[[Trader Joe\"s]]" check-link-escaping ] unit-test [ "" ] [ "[[]]" check-link-escaping ] unit-test From 391d6db9fe57287a2c2168d1574962d1649378af Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 28 Jan 2009 23:45:12 -0600 Subject: [PATCH 18/21] Cleaning up Unicode docs --- basis/unicode/collation/collation-docs.factor | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/basis/unicode/collation/collation-docs.factor b/basis/unicode/collation/collation-docs.factor index 183ca85b69..990390e82f 100644 --- a/basis/unicode/collation/collation-docs.factor +++ b/basis/unicode/collation/collation-docs.factor @@ -1,11 +1,12 @@ -USING: help.syntax help.markup strings byte-arrays ; +USING: help.syntax help.markup strings byte-arrays math.order ; IN: unicode.collation ARTICLE: "unicode.collation" "Collation and weak comparison" -"The " { $vocab-link "unicode.collation" "unicode.collation" } " vocabulary implements the Unicode Collation Algorithm. The Unicode Collation Algorithm (UTS #10) forms a reasonable way to sort strings when accouting for all of the characters in Unicode. It is far preferred over code point order when sorting for human consumption, in user interfaces. At the moment, only the default Unicode collation element table (DUCET) is used, but a more accurate collation would take locale into account. The following words are defined:" +"The " { $vocab-link "unicode.collation" "unicode.collation" } " vocabulary implements the Unicode Collation Algorithm. The Unicode Collation Algorithm (UTS #10) forms a reasonable way to sort strings when accouting for all of the characters in Unicode. It is far preferred over code point order when sorting for human consumption, in user interfaces. At the moment, only the default Unicode collation element table (DUCET) is used, but a more accurate collation would take locale into account. The following words are useful for collation directly:" { $subsection sort-strings } { $subsection collation-key } { $subsection string<=> } +"Predicates for weak equality testing:" { $subsection primary= } { $subsection secondary= } { $subsection tertiary= } @@ -14,12 +15,12 @@ ARTICLE: "unicode.collation" "Collation and weak comparison" ABOUT: "unicode.collation" HELP: sort-strings -{ $values { "strings" "a sequence of strings" } { "sorted" "the strings in DUCET order" } } -{ $description "This word takes a sequence of strings and sorts them according to the UCA, using code point order as a tie-breaker." } ; +{ $values { "strings" "a sequence of strings" } { "sorted" "the strings in lexicographical order" } } +{ $description "This word takes a sequence of strings and sorts them according to the Unicode Collation Algorithm with the default collation order described in the DUCET. It uses code point order as a tie-breaker." } ; HELP: collation-key { $values { "string" string } { "key" byte-array } } -{ $description "This takes a string and gives a representation of the collation key, which can be compared with <=>" } ; +{ $description "This takes a string and gives a representation of the collation key, which can be compared with " { $link <=> } ". The representation is according to the DUCET." } ; HELP: string<=> { $values { "str1" string } { "str2" string } { "<=>" "one of +lt+, +gt+ or +eq+" } } @@ -27,16 +28,16 @@ HELP: string<=> HELP: primary= { $values { "str1" string } { "str2" string } { "?" "t or f" } } -{ $description "This checks whether the first level of collation is identical. This is the least specific kind of equality test. In Latin script, it can be understood as ignoring case, punctuation and accent marks." } ; +{ $description "This checks whether the first level of collation key is identical. This is the least specific kind of equality test. In Latin script, it can be understood as ignoring case, punctuation, whitespace and accent marks." } ; HELP: secondary= { $values { "str1" string } { "str2" string } { "?" "t or f" } } -{ $description "This checks whether the first two levels of collation are equal. For Latin script, this means accent marks are significant again, and it is otherwise similar to primary=." } ; +{ $description "This checks whether the first two levels of collation key are equal. For Latin script, this means accent marks are significant again, and it is otherwise similar to " { $link primary= } "." } ; HELP: tertiary= { $values { "str1" string } { "str2" string } { "?" "t or f" } } -{ $description "Along the same lines as secondary=, but case is significant." } ; +{ $description "This checks if the first three levels of collation key are equal. For Latin-based scripts, it can be understood as testing for what " { $link secondary= } " tests for, but case is significant." } ; HELP: quaternary= { $values { "str1" string } { "str2" string } { "?" "t or f" } } -{ $description "This is similar to tertiary= but it makes punctuation significant again, while still leaving out things like null bytes and Hebrew vowel marks, which mean absolutely nothing in collation." } ; +{ $description "This checks if the first four levels of collation key are equal. This is similar to " { $link tertiary= } " but it makes punctuation significant again, while still leaving out things like null bytes and Hebrew vowel marks, which mean absolutely nothing in collation." } ; From d684e24ee8891571790203e0da57b543a85da74a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 29 Jan 2009 00:08:40 -0600 Subject: [PATCH 19/21] file-contents and set-file-contents deal in sequences, not strings --- core/io/files/files-docs.factor | 10 +++++----- core/io/files/files-tests.factor | 7 +++---- core/io/files/files.factor | 6 +++--- 3 files changed, 11 insertions(+), 12 deletions(-) diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index 263b5c19b0..cf0aea787b 100644 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -1,5 +1,5 @@ USING: help.markup help.syntax io strings arrays io.backend -io.files.private quotations ; +io.files.private quotations sequences ; IN: io.files ARTICLE: "io.files" "Reading and writing files" @@ -63,13 +63,13 @@ HELP: file-lines { $errors "Throws an error if the file cannot be opened for reading." } ; HELP: set-file-contents -{ $values { "str" "a string" } { "path" "a pathname string" } { "encoding" "an encoding descriptor" } } -{ $description "Sets the contents of a file to a string with the given encoding." } +{ $values { "seq" sequence } { "path" "a pathname string" } { "encoding" "an encoding descriptor" } } +{ $description "Sets the contents of a file to a sequence with the given encoding." } { $errors "Throws an error if the file cannot be opened for writing." } ; HELP: file-contents -{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "str" "a string" } } -{ $description "Opens the file at the given path using the given encoding, and the contents of that file as a string." } +{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "seq" sequence } } +{ $description "Opens the file at the given path using the given encoding, and the contents of that file as a sequence." } { $errors "Throws an error if the file cannot be opened for reading." } ; { set-file-lines file-lines set-file-contents file-contents } related-words diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index d2611d73a9..f9702fd133 100644 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -1,9 +1,8 @@ USING: tools.test io.files io.files.private io.files.temp io.directories io.encodings.8-bit arrays make system -io.encodings.binary io -threads kernel continuations io.encodings.ascii sequences -strings accessors io.encodings.utf8 math destructors namespaces -; +io.encodings.binary io threads kernel continuations +io.encodings.ascii sequences strings accessors +io.encodings.utf8 math destructors namespaces ; IN: io.files.tests \ exists? must-infer diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 19659ee5bb..1bc282e956 100644 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -25,7 +25,7 @@ HOOK: (file-appender) io-backend ( path -- stream ) : with-file-reader ( path encoding quot -- ) [ ] dip with-input-stream ; inline -: file-contents ( path encoding -- str ) +: file-contents ( path encoding -- seq ) contents ; : with-file-writer ( path encoding quot -- ) @@ -34,7 +34,7 @@ HOOK: (file-appender) io-backend ( path -- stream ) : set-file-lines ( seq path encoding -- ) [ [ print ] each ] with-file-writer ; -: set-file-contents ( str path encoding -- ) +: set-file-contents ( seq path encoding -- ) [ write ] with-file-writer ; : with-file-appender ( path encoding quot -- ) @@ -58,4 +58,4 @@ PRIVATE> 13 getenv cwd prepend-path \ image set-global 14 getenv cwd prepend-path \ vm set-global image parent-directory "resource-path" set-global -] "io.files" add-init-hook \ No newline at end of file +] "io.files" add-init-hook From 31e662043b3c60ea6d2ce903b50834cbf22ad3f9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 29 Jan 2009 01:44:09 -0600 Subject: [PATCH 20/21] Add unit test for xmode bug discovered by anonymous pastebin user --- basis/xmode/code2html/code2html-tests.factor | 12 ++++++++++++ 1 file changed, 12 insertions(+) create mode 100644 basis/xmode/code2html/code2html-tests.factor diff --git a/basis/xmode/code2html/code2html-tests.factor b/basis/xmode/code2html/code2html-tests.factor new file mode 100644 index 0000000000..cd11ba50d0 --- /dev/null +++ b/basis/xmode/code2html/code2html-tests.factor @@ -0,0 +1,12 @@ +IN: xmode.code2html.tests +USING: xmode.code2html xmode.catalog +tools.test multiline splitting memoize +kernel ; + +[ ] [ \ (load-mode) reset-memoized ] unit-test + +[ ] [ + <"