diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index 5addd273c8..854e6add5a 100755 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -207,3 +207,14 @@ DEFER: mixin-forget-test-g [ { } mixin-forget-test-g ] unit-test-fails [ H{ } ] [ H{ } mixin-forget-test-g ] unit-test + +! Method flattening interfered with mixin update +MIXIN: flat-mx-1 +TUPLE: flat-mx-1-1 ; INSTANCE: flat-mx-1-1 flat-mx-1 +TUPLE: flat-mx-1-2 ; INSTANCE: flat-mx-1-2 flat-mx-1 +TUPLE: flat-mx-1-3 ; INSTANCE: flat-mx-1-3 flat-mx-1 +TUPLE: flat-mx-1-4 ; INSTANCE: flat-mx-1-4 flat-mx-1 +MIXIN: flat-mx-2 INSTANCE: flat-mx-2 flat-mx-1 +TUPLE: flat-mx-2-1 ; INSTANCE: flat-mx-2-1 flat-mx-2 + +[ t ] [ T{ flat-mx-2-1 } flat-mx-1? ] unit-test diff --git a/core/compiler/test/redefine.factor b/core/compiler/test/redefine.factor index 266b331ffc..c1561f38d4 100755 --- a/core/compiler/test/redefine.factor +++ b/core/compiler/test/redefine.factor @@ -238,3 +238,15 @@ DEFER: flushable-test-2 [ \ bx forget ] with-compilation-unit [ t ] [ \ ax compiled-usage [ drop interned? ] assoc-all? ] unit-test + +DEFER: defer-redefine-test-2 + +[ ] [ "IN: temporary DEFER: defer-redefine-test-1" eval ] unit-test + +[ ] [ "IN: temporary : defer-redefine-test-2 defer-redefine-test-1 1 ;" eval ] unit-test + +[ defer-redefine-test-2 ] unit-test-fails + +[ ] [ "IN: temporary : defer-redefine-test-1 2 ;" eval ] unit-test + +[ 1 ] [ defer-redefine-test-2 ] unit-test diff --git a/extra/const/const.factor b/extra/const/const.factor index 59d65edaae..8efef7e372 100644 --- a/extra/const/const.factor +++ b/extra/const/const.factor @@ -14,3 +14,11 @@ IN: const : ENUM: ";" parse-tokens [ create-in ] map define-enum ; parsing + +: define-value ( word -- ) + { f } clone [ first ] curry define ; + +: VALUE: CREATE define-value ; parsing + +: set-value ( value word -- ) + word-def first set-first ; diff --git a/extra/unicode/breaks/breaks.factor b/extra/unicode/breaks/breaks.factor index 9c9242edc3..70a9c781a2 100644 --- a/extra/unicode/breaks/breaks.factor +++ b/extra/unicode/breaks/breaks.factor @@ -1,7 +1,7 @@ USING: unicode.categories kernel math combinators splitting sequences math.parser io.files io assocs arrays namespaces combinators.lib assocs.lib math.ranges unicode.normalize -unicode.syntax unicode.data compiler.units alien.syntax ; +unicode.syntax unicode.data compiler.units alien.syntax const ; IN: unicode.breaks C-ENUM: Any L V T Extend Control CR LF graphemes ; @@ -32,7 +32,7 @@ CATEGORY: grapheme-control Zl Zp Cc Cf ; : other-extend-lines ( -- lines ) "extra/unicode/PropList.txt" resource-path file-lines ; -DEFER: other-extend +VALUE: other-extend CATEGORY: (extend) Me Mn ; : extend? ( ch -- ? ) @@ -77,7 +77,7 @@ SYMBOL: table T T connect graphemes Extend connect-after ; -DEFER: grapheme-table +VALUE: grapheme-table : grapheme-break? ( class1 class2 -- ? ) grapheme-table nth nth not ; @@ -113,10 +113,10 @@ DEFER: grapheme-table [ grapheme-class dup rot grapheme-break? ] find-last-index nip -1 or 1+ ; -<< - other-extend-lines process-other-extend \ other-extend define-value +[ + other-extend-lines process-other-extend \ other-extend set-value init-grapheme-table table [ make-grapheme-table finish-table ] with-variable - \ grapheme-table define-value ->> + \ grapheme-table set-value +] with-compilation-unit diff --git a/extra/unicode/data/data.factor b/extra/unicode/data/data.factor index e112471c28..c579d1fdfd 100644 --- a/extra/unicode/data/data.factor +++ b/extra/unicode/data/data.factor @@ -1,15 +1,12 @@ USING: assocs math kernel sequences io.files hashtables quotations splitting arrays math.parser combinators.lib hash2 -byte-arrays words namespaces words compiler.units ; +byte-arrays words namespaces words compiler.units const ; IN: unicode.data ! Convenience functions : 1+* ( n/f _ -- n+1 ) drop [ 1+ ] [ 0 ] if* ; -: define-value ( value word -- ) - swap 1quotation define ; - : ?between? ( n/f from to -- ? ) pick [ between? ] [ 3drop f ] if ; @@ -107,16 +104,16 @@ C: code-point 4 head [ multihex ] map first4 swap first set ; -DEFER: simple-lower -DEFER: simple-upper -DEFER: simple-title -DEFER: canonical-map -DEFER: combine-map -DEFER: class-map -DEFER: compat-map -DEFER: category-map -DEFER: name-map -DEFER: special-casing +VALUE: simple-lower +VALUE: simple-upper +VALUE: simple-title +VALUE: canonical-map +VALUE: combine-map +VALUE: class-map +VALUE: compat-map +VALUE: category-map +VALUE: name-map +VALUE: special-casing : canonical-entry ( char -- seq ) canonical-map at ; : combine-chars ( a b -- char/f ) combine-map hash2 ; @@ -132,16 +129,14 @@ DEFER: special-casing [ length 5 = ] subset [ [ set-code-point ] each ] H{ } make-assoc ; -[ - load-data - dup process-names \ name-map define-value - 13 over process-data \ simple-lower define-value - 12 over process-data tuck \ simple-upper define-value - 14 over process-data swapd union \ simple-title define-value - dup process-combining \ class-map define-value - dup process-canonical \ canonical-map define-value - \ combine-map define-value - dup process-compat \ compat-map define-value - process-category \ category-map define-value - load-special-casing \ special-casing define-value -] with-compilation-unit +load-data +dup process-names \ name-map set-value +13 over process-data \ simple-lower set-value +12 over process-data tuck \ simple-upper set-value +14 over process-data swapd union \ simple-title set-value +dup process-combining \ class-map set-value +dup process-canonical \ canonical-map set-value + \ combine-map set-value +dup process-compat \ compat-map set-value +process-category \ category-map set-value +load-special-casing \ special-casing set-value diff --git a/extra/unicode/normalize/normalize.factor b/extra/unicode/normalize/normalize.factor index 86a922793f..b018d115f8 100644 --- a/extra/unicode/normalize/normalize.factor +++ b/extra/unicode/normalize/normalize.factor @@ -2,7 +2,7 @@ USING: sequences namespaces unicode.data kernel combinators.lib math arrays ; IN: unicode.normalize -! Utility word +! Utility word--probably unnecessary : make* ( seq quot exemplar -- newseq ) ! quot has access to original seq on stack ! this just makes the new-resizable the same length as seq @@ -89,7 +89,7 @@ IN: unicode.normalize swap [ [ dup hangul? [ hangul>jamo % drop ] [ dup rot call [ % ] [ , ] ?if ] if - ] with each ] "" make* + ] with each ] "" make dup reorder ] if ; inline @@ -167,7 +167,7 @@ SYMBOL: char 0 ind set SBUF" " clone after set pass-combining (compose) - ] "" make* ; + ] "" make ; : nfc ( string -- nfc ) nfd compose ; diff --git a/extra/unicode/syntax/syntax.factor b/extra/unicode/syntax/syntax.factor index 5119663872..6c75a77c76 100644 --- a/extra/unicode/syntax/syntax.factor +++ b/extra/unicode/syntax/syntax.factor @@ -1,5 +1,5 @@ USING: unicode.data kernel math sequences parser bit-arrays namespaces -sequences.private arrays quotations classes.predicate ; +sequences.private arrays quotations classes.predicate assocs ; IN: unicode.syntax ! Character classes (categories) @@ -48,5 +48,5 @@ IN: unicode.syntax categories swap seq-minus define-category ; parsing : UNICHAR: - ! This should be part of CHAR: + ! This should be part of CHAR:. Also, name-map at ==> name>char scan name>char [ parsed ] [ "Invalid character" throw ] if* ; parsing diff --git a/extra/xml/entities/entities.factor b/extra/xml/entities/entities.factor index a52f5be3dc..b90613ec79 100644 --- a/extra/xml/entities/entities.factor +++ b/extra/xml/entities/entities.factor @@ -1,8 +1,32 @@ ! Copyright (C) 2005, 2006 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: namespaces kernel ; +USING: namespaces kernel assocs sequences ; IN: xml.entities +: entities-out + H{ + { CHAR: < "<" } + { CHAR: > ">" } + { CHAR: & "&" } + } ; + +: quoted-entities-out + H{ + { CHAR: & "&" } + { CHAR: ' "'" } + { CHAR: " """ } + } ; + +: escape-string-by ( str table -- escaped ) + #! Convert <, >, &, ' and " to HTML entities. + [ [ dupd at [ % ] [ , ] ?if ] curry each ] "" make ; + +: escape-string ( str -- newstr ) + entities-out escape-string-by ; + +: escape-quoted-string ( str -- newstr ) + quoted-entities-out escape-string-by ; + : entities H{ { "lt" CHAR: < } diff --git a/extra/xml/test/templating.factor b/extra/xml/test/templating.factor index 0ee4ae51b0..2dd69ca99b 100644 --- a/extra/xml/test/templating.factor +++ b/extra/xml/test/templating.factor @@ -1,4 +1,3 @@ -IN: templating USING: kernel xml sequences assocs tools.test io arrays namespaces xml.data xml.utilities xml.writer generic sequences.deep ; @@ -9,10 +8,10 @@ SYMBOL: ref-table GENERIC: (r-ref) ( xml -- ) M: tag (r-ref) - sub-tag over at [ + sub-tag over at* [ ref-table get at swap set-tag-children - ] [ drop ] if* ; + ] [ 2drop ] if ; M: object (r-ref) drop ; : template ( xml -- ) @@ -40,4 +39,4 @@ M: object (r-ref) drop ; sample-doc string>xml dup template xml>string ] with-scope ; -[ "\nfoo
blah

" ] [ test-refs ] unit-test +[ "foo

blah

" ] [ test-refs ] unit-test diff --git a/extra/xml/test/test.factor b/extra/xml/test/test.factor index 80a508787e..ec59d3564e 100644 --- a/extra/xml/test/test.factor +++ b/extra/xml/test/test.factor @@ -26,7 +26,7 @@ SYMBOL: xml-file ] unit-test [ V{ "fa&g" } ] [ xml-file get "x" get-id tag-children ] unit-test [ "that" ] [ xml-file get "this" swap at ] unit-test -[ "\n" ] +[ "" ] [ "" string>xml xml>string ] unit-test [ "abcd" ] [ "

abcd
" string>xml @@ -44,7 +44,7 @@ SYMBOL: xml-file at swap "z" >r tuck r> swap set-at T{ name f "blah" "z" f } swap at ] unit-test [ "foo" ] [ "" string>xml children>string ] unit-test -[ "\nbar baz" ] +[ "bar baz" ] [ "bar" string>xml [ " baz" append ] map xml>string ] unit-test [ "\n\n bar\n" ] [ " bar " string>xml pprint-xml>string ] unit-test diff --git a/extra/xml/writer/writer.factor b/extra/xml/writer/writer.factor index 7bd1cc3046..95f38f3da9 100644 --- a/extra/xml/writer/writer.factor +++ b/extra/xml/writer/writer.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2006 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. USING: hashtables kernel math namespaces sequences strings -io io.streams.string xml.data assocs ; +io io.streams.string xml.data assocs wrap xml.entities ; IN: xml.writer SYMBOL: xml-pprint? @@ -13,10 +13,13 @@ SYMBOL: indenter : sensitive? ( tag -- ? ) sensitive-tags get swap [ names-match? ] curry contains? ; +: indent-string ( -- string ) + xml-pprint? get + [ indentation get indenter get concat ] + [ "" ] if ; + : ?indent ( -- ) - xml-pprint? get [ - nl indentation get indenter get [ write ] each - ] when ; + xml-pprint? get [ nl indent-string write ] when ; : indent ( -- ) xml-pprint? get [ 1 indentation +@ ] when ; @@ -35,30 +38,6 @@ SYMBOL: indenter [ dup empty? swap string? and not ] subset ] when ; -: entities-out - H{ - { CHAR: < "<" } - { CHAR: > ">" } - { CHAR: & "&" } - } ; - -: quoted-entities-out - H{ - { CHAR: & "&" } - { CHAR: ' "'" } - { CHAR: " """ } - } ; - -: escape-string-by ( str table -- escaped ) - #! Convert <, >, &, ' and " to HTML entities. - [ [ dupd at [ % ] [ , ] ?if ] curry each ] "" make ; - -: escape-string ( str -- newstr ) - entities-out escape-string-by ; - -: escape-quoted-string ( str -- newstr ) - quoted-entities-out escape-string-by ; - : print-name ( name -- ) dup name-space f like [ write CHAR: : write1 ] when* @@ -76,10 +55,11 @@ SYMBOL: indenter GENERIC: write-item ( object -- ) M: string write-item - escape-string write ; + escape-string dup empty? not xml-pprint? get and + [ nl 80 indent-string indented-break ] when write ; : write-tag ( tag -- ) - CHAR: < write1 + ?indent CHAR: < write1 dup print-name tag-attrs print-attrs ; M: contained-tag write-item @@ -87,7 +67,7 @@ M: contained-tag write-item : write-children ( tag -- ) indent tag-children ?filter-children - [ ?indent write-item ] each unindent ; + [ write-item ] each unindent ; : write-end-tag ( tag -- ) ?indent " write1 ; @@ -112,7 +92,7 @@ M: instruction write-item "\n" write ; + "\"?>" write ; : write-chunk ( seq -- ) [ write-item ] each ;