From 9a897f91fff46ea32bedc48d3cfb5dc486184f94 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Mon, 28 Jan 2008 19:09:49 -0600 Subject: [PATCH 1/8] Fixing compiler bug with redefining deferred words --- core/compiler/test/redefine.factor | 2 ++ core/generator/generator.factor | 1 - 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/core/compiler/test/redefine.factor b/core/compiler/test/redefine.factor index 266b331ffc..aa53068e36 100755 --- a/core/compiler/test/redefine.factor +++ b/core/compiler/test/redefine.factor @@ -238,3 +238,5 @@ DEFER: flushable-test-2 [ \ bx forget ] with-compilation-unit [ t ] [ \ ax compiled-usage [ drop interned? ] assoc-all? ] unit-test + +[ "one" "two" ] [ "DEFER: redefine-test1 : redefine-test2 redefine-test1 \"two\" ; : redefine-test1 \"one\" ; redefine-test2" eval ] unit-test diff --git a/core/generator/generator.factor b/core/generator/generator.factor index 0e499cf90f..4d985ff164 100755 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -20,7 +20,6 @@ SYMBOL: compiled { { [ dup compiled get key? ] [ drop ] } { [ dup primitive? ] [ drop ] } - { [ dup deferred? ] [ drop ] } { [ t ] [ dup compile-queue get set-at ] } } cond ; From 58668874adc3ad6fa5df32620b13bdecfbfef9b1 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Tue, 29 Jan 2008 13:12:04 -0600 Subject: [PATCH 2/8] Unit test for recompiling deferred words --- core/compiler/test/redefine.factor | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/core/compiler/test/redefine.factor b/core/compiler/test/redefine.factor index aa53068e36..c1561f38d4 100755 --- a/core/compiler/test/redefine.factor +++ b/core/compiler/test/redefine.factor @@ -239,4 +239,14 @@ DEFER: flushable-test-2 [ t ] [ \ ax compiled-usage [ drop interned? ] assoc-all? ] unit-test -[ "one" "two" ] [ "DEFER: redefine-test1 : redefine-test2 redefine-test1 \"two\" ; : redefine-test1 \"one\" ; redefine-test2" eval ] 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 From edf1f2724728b9088b9a746814c7dc9f912e7cd0 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Tue, 29 Jan 2008 13:33:14 -0600 Subject: [PATCH 3/8] Changes to Unicode --- extra/const/const.factor | 8 ++++ extra/unicode/breaks/breaks.factor | 14 +++---- extra/unicode/data/data.factor | 49 +++++++++++------------- extra/unicode/normalize/normalize.factor | 6 +-- extra/unicode/syntax/syntax.factor | 4 +- 5 files changed, 42 insertions(+), 39 deletions(-) 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 From a263784f94e19781ab8cd021a46a10777374bf8f Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Tue, 29 Jan 2008 13:33:33 -0600 Subject: [PATCH 4/8] Fixing opengl's use --- extra/opengl/opengl.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/opengl/opengl.factor b/extra/opengl/opengl.factor index 656c514cd1..ea3577c037 100755 --- a/extra/opengl/opengl.factor +++ b/extra/opengl/opengl.factor @@ -4,7 +4,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types continuations kernel libc math macros namespaces math.vectors math.constants math.functions math.parser opengl.gl opengl.glu -combinators arrays sequences splitting words ; +combinators arrays sequences splitting words byte-arrays ; IN: opengl : coordinates [ first2 ] 2apply ; From f2dbf50c6c892d0296ced94cff0419c9fc6d97cd Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Tue, 29 Jan 2008 13:53:54 -0600 Subject: [PATCH 5/8] Back out change --- core/generator/generator.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/core/generator/generator.factor b/core/generator/generator.factor index 4d985ff164..0e499cf90f 100755 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -20,6 +20,7 @@ SYMBOL: compiled { { [ dup compiled get key? ] [ drop ] } { [ dup primitive? ] [ drop ] } + { [ dup deferred? ] [ drop ] } { [ t ] [ dup compile-queue get set-at ] } } cond ; From e37ccf190eb2fe52c440a5b684d9832c17274872 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Tue, 29 Jan 2008 13:58:37 -0600 Subject: [PATCH 6/8] Add failing unit test --- core/classes/classes-tests.factor | 11 +++++++++++ 1 file changed, 11 insertions(+) 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 From 99172b6f79132e840719adae02489162228f02c7 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 30 Jan 2008 15:03:02 -0600 Subject: [PATCH 7/8] Changes in XML prettyprinter --- extra/xml/entities/entities.factor | 26 +++++++++++++++++- extra/xml/writer/writer.factor | 42 +++++++----------------------- 2 files changed, 35 insertions(+), 33 deletions(-) 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/writer/writer.factor b/extra/xml/writer/writer.factor index 7bd1cc3046..f943f24ccd 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,11 @@ SYMBOL: indenter : sensitive? ( tag -- ? ) sensitive-tags get swap [ names-match? ] curry contains? ; +: indent-string ( -- string ) + indentation get indenter get concat ; + : ?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 +36,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 +53,11 @@ SYMBOL: indenter GENERIC: write-item ( object -- ) M: string write-item - escape-string write ; + escape-string xml-pprint? over empty? not 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 +65,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 +90,7 @@ M: instruction write-item "\n" write ; + "\"?>" write ; : write-chunk ( seq -- ) [ write-item ] each ; From cea24feaa9f01eb86bc198af671d924cfd89a2c3 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 31 Jan 2008 00:47:11 -0600 Subject: [PATCH 8/8] Fixing failing XML unit tests --- extra/xml/test/templating.factor | 7 +++---- extra/xml/test/test.factor | 4 ++-- extra/xml/writer/writer.factor | 6 ++++-- 3 files changed, 9 insertions(+), 8 deletions(-) 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

" ] [ 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 f943f24ccd..95f38f3da9 100644 --- a/extra/xml/writer/writer.factor +++ b/extra/xml/writer/writer.factor @@ -14,7 +14,9 @@ SYMBOL: indenter sensitive-tags get swap [ names-match? ] curry contains? ; : indent-string ( -- string ) - indentation get indenter get concat ; + xml-pprint? get + [ indentation get indenter get concat ] + [ "" ] if ; : ?indent ( -- ) xml-pprint? get [ nl indent-string write ] when ; @@ -53,7 +55,7 @@ SYMBOL: indenter GENERIC: write-item ( object -- ) M: string write-item - escape-string xml-pprint? over empty? not and + escape-string dup empty? not xml-pprint? get and [ nl 80 indent-string indented-break ] when write ; : write-tag ( tag -- )