diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index ee7ff8c608..fb6f1ffba0 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -102,7 +102,7 @@ ERROR: bad-superclass class ; dup tuple-predicate-quot define-predicate ; : superclass-size ( class -- n ) - superclasses 1 head-slice* + superclasses butlast-slice [ slot-names length ] map sum ; : generate-tuple-slots ( class slots -- slot-specs ) diff --git a/core/debugger/debugger-docs.factor b/core/debugger/debugger-docs.factor index 071310b433..9dd23c6011 100755 --- a/core/debugger/debugger-docs.factor +++ b/core/debugger/debugger-docs.factor @@ -1,7 +1,7 @@ USING: alien arrays generic generic.math help.markup help.syntax kernel math memory strings sbufs vectors io io.files classes help generic.standard continuations system debugger.private -io.files.private ; +io.files.private listener ; IN: debugger ARTICLE: "errors-assert" "Assertions" diff --git a/core/inference/transforms/transforms.factor b/core/inference/transforms/transforms.factor index 624dcbbf98..cf3dcadd75 100755 --- a/core/inference/transforms/transforms.factor +++ b/core/inference/transforms/transforms.factor @@ -32,7 +32,7 @@ IN: inference.transforms drop [ no-case ] ] [ dup peek quotation? [ - dup peek swap 1 head* + dup peek swap butlast ] [ [ no-case ] swap ] if case>quot diff --git a/core/io/encodings/encodings-tests.factor b/core/io/encodings/encodings-tests.factor index 79922b019c..e6b180fde2 100755 --- a/core/io/encodings/encodings-tests.factor +++ b/core/io/encodings/encodings-tests.factor @@ -2,11 +2,8 @@ USING: io.files io.streams.string io tools.test kernel io.encodings.ascii ; IN: io.streams.encodings.tests -: ( resource -- stream ) - resource-path ascii ; - [ { } ] -[ "core/io/test/empty-file.txt" lines ] +[ "resource:core/io/test/empty-file.txt" ascii lines ] unit-test : lines-test ( stream -- line1 line2 ) @@ -16,21 +13,24 @@ unit-test "This is a line." "This is another line." ] [ - "core/io/test/windows-eol.txt" lines-test + "resource:core/io/test/windows-eol.txt" + ascii lines-test ] unit-test [ "This is a line." "This is another line." ] [ - "core/io/test/mac-os-eol.txt" lines-test + "resource:core/io/test/mac-os-eol.txt" + ascii lines-test ] unit-test [ "This is a line." "This is another line." ] [ - "core/io/test/unix-eol.txt" lines-test + "resource:core/io/test/unix-eol.txt" + ascii lines-test ] unit-test [ diff --git a/core/io/io-tests.factor b/core/io/io-tests.factor index 7204bde6fb..50a798d290 100755 --- a/core/io/io-tests.factor +++ b/core/io/io-tests.factor @@ -8,20 +8,17 @@ IN: io.tests "foo" "io.tests" lookup ] unit-test -: ( resource -- stream ) - resource-path latin1 ; - [ "This is a line.\rThis is another line.\r" ] [ - "core/io/test/mac-os-eol.txt" + "resource:core/io/test/mac-os-eol.txt" latin1 [ 500 read ] with-input-stream ] unit-test [ 255 ] [ - "core/io/test/binary.txt" + "resource:core/io/test/binary.txt" latin1 [ read1 ] with-input-stream >fixnum ] unit-test @@ -36,7 +33,8 @@ IN: io.tests } ] [ [ - "core/io/test/separator-test.txt" [ + "resource:core/io/test/separator-test.txt" + latin1 [ "J" read-until 2array , "i" read-until 2array , "X" read-until 2array , diff --git a/core/prettyprint/prettyprint-tests.factor b/core/prettyprint/prettyprint-tests.factor index e94670992c..834cad5b29 100755 --- a/core/prettyprint/prettyprint-tests.factor +++ b/core/prettyprint/prettyprint-tests.factor @@ -114,7 +114,7 @@ unit-test [ parse-fresh drop ] with-compilation-unit [ "prettyprint.tests" lookup see - ] with-string-writer "\n" split 1 head* + ] with-string-writer "\n" split butlast ] keep = ] with-scope ; diff --git a/core/prettyprint/sections/sections.factor b/core/prettyprint/sections/sections.factor index 5f32539115..0ce8841256 100644 --- a/core/prettyprint/sections/sections.factor +++ b/core/prettyprint/sections/sections.factor @@ -284,7 +284,7 @@ M: colon unindent-first-line? drop t ; ! Long section layout algorithm : chop-break ( seq -- seq ) - dup peek line-break? [ 1 head-slice* chop-break ] when ; + dup peek line-break? [ butlast-slice chop-break ] when ; SYMBOL: prev SYMBOL: next diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index 2a2fcf29cd..67d26089b0 100755 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -92,6 +92,7 @@ ARTICLE: "sequences-slices" "Subsequences and slices" { $subsection subseq } { $subsection head } { $subsection tail } +{ $subsection butlast } { $subsection rest } { $subsection head* } { $subsection tail* } @@ -106,6 +107,7 @@ ARTICLE: "sequences-slices" "Subsequences and slices" { $subsection } { $subsection head-slice } { $subsection tail-slice } +{ $subsection butlast-slice } { $subsection rest-slice } { $subsection head-slice* } { $subsection tail-slice* } @@ -836,11 +838,16 @@ HELP: tail-slice { $description "Outputs a virtual sequence sharing storage with all elements from the " { $snippet "n" } "th index until the end of the input sequence." } { $errors "Throws an error if the index is out of bounds." } ; +HELP: butlast-slice +{ $values { "seq" sequence } { "slice" "a slice" } } +{ $description "Outputs a virtual sequence sharing storage with all but the last element of the input sequence." } +{ $errors "Throws an error on an empty sequence." } ; + HELP: rest-slice { $values { "seq" sequence } { "slice" "a slice" } } { $description "Outputs a virtual sequence sharing storage with all elements from the 1st index until the end of the input sequence." } { $notes "Equivalent to " { $snippet "1 tail" } } -{ $errors "Throws an error if the index is out of bounds." } ; +{ $errors "Throws an error on an empty sequence." } ; HELP: head-slice* { $values { "seq" sequence } { "n" "a non-negative integer" } { "slice" "a slice" } } @@ -862,6 +869,11 @@ HELP: tail { $description "Outputs a new sequence consisting of the input sequence with the first n items removed." } { $errors "Throws an error if the index is out of bounds." } ; +HELP: butlast +{ $values { "seq" sequence } { "headseq" "a new sequence" } } +{ $description "Outputs a new sequence consisting of the input sequence with the last item removed." } +{ $errors "Throws an error on an empty sequence." } ; + HELP: rest { $values { "seq" sequence } { "tailseq" "a new sequence" } } { $description "Outputs a new sequence consisting of the input sequence with the first item removed." } diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index f39bf08e58..1e9d187c2d 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -216,6 +216,8 @@ M: slice length dup slice-to swap slice-from - ; : tail-slice* ( seq n -- slice ) from-end tail-slice ; +: butlast-slice ( seq -- slice ) 1 head-slice* ; + INSTANCE: slice virtual-sequence ! One element repeated many times @@ -263,6 +265,8 @@ PRIVATE> : tail* ( seq n -- tailseq ) from-end tail ; +: butlast ( seq -- headseq ) 1 head* ; + : copy ( src i dst -- ) pick length >r 3dup check-copy spin 0 r> (copy) drop ; inline @@ -671,13 +675,13 @@ PRIVATE> [ rest ] [ first ] bi ; : unclip-last ( seq -- butfirst last ) - [ 1 head* ] [ peek ] bi ; + [ butlast ] [ peek ] bi ; : unclip-slice ( seq -- rest first ) [ rest-slice ] [ first ] bi ; : unclip-last-slice ( seq -- butfirst last ) - [ 1 head-slice* ] [ peek ] bi ; + [ butlast-slice ] [ peek ] bi ; : ( seq -- slice ) dup slice? [ { } like ] when 0 over length rot ; diff --git a/core/splitting/splitting.factor b/core/splitting/splitting.factor index 62c5121e50..be0652fd98 100755 --- a/core/splitting/splitting.factor +++ b/core/splitting/splitting.factor @@ -104,7 +104,7 @@ M: sliced-clumps nth group@ ; 1array ] [ "\n" split [ - 1 head-slice* [ + butlast-slice [ "\r" ?tail drop "\r" split ] map ] keep peek "\r" split suffix concat diff --git a/extra/benchmark/knucleotide/knucleotide.factor b/extra/benchmark/knucleotide/knucleotide.factor index e06b81f6de..6bd2d69cfa 100644 --- a/extra/benchmark/knucleotide/knucleotide.factor +++ b/extra/benchmark/knucleotide/knucleotide.factor @@ -56,7 +56,7 @@ IN: benchmark.knucleotide drop ; : knucleotide ( -- ) - "extra/benchmark/knucleotide/knucleotide-input.txt" resource-path + "resource:extra/benchmark/knucleotide/knucleotide-input.txt" ascii [ read-input ] with-file-reader process-input ; diff --git a/extra/combinators/lib/lib.factor b/extra/combinators/lib/lib.factor index 84b41a91ff..5dfe8527c1 100755 --- a/extra/combinators/lib/lib.factor +++ b/extra/combinators/lib/lib.factor @@ -169,3 +169,8 @@ MACRO: multikeep ( word out-indexes -- ... ) : generate ( generator predicate -- obj ) [ dup ] swap [ dup [ nip ] unless not ] 3compose swap [ ] do-while ; + +MACRO: predicates ( seq -- quot/f ) + dup [ 1quotation [ drop ] prepend ] map + >r [ [ dup ] prepend ] map r> zip [ drop f ] suffix + [ cond ] curry ; diff --git a/extra/help/lint/lint.factor b/extra/help/lint/lint.factor index fc4b7f6f25..a120d791aa 100755 --- a/extra/help/lint/lint.factor +++ b/extra/help/lint/lint.factor @@ -10,7 +10,7 @@ IN: help.lint : check-example ( element -- ) rest [ - 1 head* "\n" join 1vector + butlast "\n" join 1vector [ use [ clone ] change [ eval>string ] with-datastack diff --git a/extra/html/parser/analyzer/analyzer.factor b/extra/html/parser/analyzer/analyzer.factor index 160b95ab1d..1912cfb65c 100755 --- a/extra/html/parser/analyzer/analyzer.factor +++ b/extra/html/parser/analyzer/analyzer.factor @@ -99,7 +99,7 @@ IN: html.parser.analyzer : find-between ( i/f tag/f vector -- vector ) find-between* dup length 3 >= [ - [ rest-slice 1 head-slice* ] keep like + [ rest-slice butlast-slice ] keep like ] when ; : find-between-first ( string vector -- vector' ) diff --git a/extra/html/parser/utils/utils.factor b/extra/html/parser/utils/utils.factor index 0ae75e41fd..c0eee57ead 100644 --- a/extra/html/parser/utils/utils.factor +++ b/extra/html/parser/utils/utils.factor @@ -36,7 +36,7 @@ IN: html.parser.utils dup quoted? [ quote ] unless ; : unquote ( str -- newstr ) - dup quoted? [ 1 head-slice* rest-slice >string ] when ; + dup quoted? [ butlast-slice rest-slice >string ] when ; : quote? ( ch -- ? ) "'\"" member? ; diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index 07b34f17c3..21eb241b84 100755 --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -166,7 +166,7 @@ test-db [ add-quit-action - "extra/http/test" resource-path >>default + "resource:extra/http/test" >>default "nested" add-responder [ "redirect-loop" f ] >>display @@ -178,7 +178,7 @@ test-db [ ] unit-test [ t ] [ - "extra/http/test/foo.html" resource-path ascii file-contents + "resource:extra/http/test/foo.html" ascii file-contents "http://localhost:1237/nested/foo.html" http-get = ] unit-test diff --git a/extra/icfp/2006/2006.factor b/extra/icfp/2006/2006.factor index e88301c7f8..ca6f9d5905 100755 --- a/extra/icfp/2006/2006.factor +++ b/extra/icfp/2006/2006.factor @@ -148,4 +148,4 @@ SYMBOL: open-arrays init f exec-loop ; : run-sand ( -- ) - "extra/icfp/2006/sandmark.umz" resource-path run-prog ; + "resource:extra/icfp/2006/sandmark.umz" run-prog ; diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor index 265675f8df..8c19ade499 100755 --- a/extra/inverse/inverse.factor +++ b/extra/inverse/inverse.factor @@ -197,7 +197,7 @@ DEFER: _ \ prefix [ unclip ] define-inverse \ unclip [ prefix ] define-inverse -\ suffix [ dup 1 head* swap peek ] define-inverse +\ suffix [ dup butlast swap peek ] define-inverse ! Constructor inverse : deconstruct-pred ( class -- quot ) diff --git a/extra/io/encodings/8-bit/8-bit.factor b/extra/io/encodings/8-bit/8-bit.factor index 3fbb3908e2..88414efd16 100755 --- a/extra/io/encodings/8-bit/8-bit.factor +++ b/extra/io/encodings/8-bit/8-bit.factor @@ -30,9 +30,8 @@ IN: io.encodings.8-bit } ; : encoding-file ( file-name -- stream ) - "extra/io/encodings/8-bit/" ".TXT" - swapd 3append resource-path - ascii ; + "resource:extra/io/encodings/8-bit/" ".TXT" + swapd 3append ascii ; : tail-if ( seq n -- newseq ) 2dup swap length <= [ tail ] [ drop ] if ; diff --git a/extra/io/windows/nt/launcher/launcher-tests.factor b/extra/io/windows/nt/launcher/launcher-tests.factor index c5c0e6dec2..254f845c48 100755 --- a/extra/io/windows/nt/launcher/launcher-tests.factor +++ b/extra/io/windows/nt/launcher/launcher-tests.factor @@ -41,7 +41,7 @@ sequences parser assocs hashtables math continuations ; ] unit-test [ ] [ - "extra/io/windows/nt/launcher/test" resource-path [ + "resource:extra/io/windows/nt/launcher/test" [ vm "-script" "stderr.factor" 3array >>command "out.txt" temp-file >>stdout @@ -59,7 +59,7 @@ sequences parser assocs hashtables math continuations ; ] unit-test [ ] [ - "extra/io/windows/nt/launcher/test" resource-path [ + "resource:extra/io/windows/nt/launcher/test" [ vm "-script" "stderr.factor" 3array >>command "out.txt" temp-file >>stdout @@ -73,7 +73,7 @@ sequences parser assocs hashtables math continuations ; ] unit-test [ "output" ] [ - "extra/io/windows/nt/launcher/test" resource-path [ + "resource:extra/io/windows/nt/launcher/test" [ vm "-script" "stderr.factor" 3array >>command "err2.txt" temp-file >>stderr @@ -86,7 +86,7 @@ sequences parser assocs hashtables math continuations ; ] unit-test [ t ] [ - "extra/io/windows/nt/launcher/test" resource-path [ + "resource:extra/io/windows/nt/launcher/test" [ vm "-script" "env.factor" 3array >>command ascii contents @@ -96,7 +96,7 @@ sequences parser assocs hashtables math continuations ; ] unit-test [ t ] [ - "extra/io/windows/nt/launcher/test" resource-path [ + "resource:extra/io/windows/nt/launcher/test" [ vm "-script" "env.factor" 3array >>command +replace-environment+ >>environment-mode @@ -108,7 +108,7 @@ sequences parser assocs hashtables math continuations ; ] unit-test [ "B" ] [ - "extra/io/windows/nt/launcher/test" resource-path [ + "resource:extra/io/windows/nt/launcher/test" [ vm "-script" "env.factor" 3array >>command { { "A" "B" } } >>environment @@ -119,7 +119,7 @@ sequences parser assocs hashtables math continuations ; ] unit-test [ f ] [ - "extra/io/windows/nt/launcher/test" resource-path [ + "resource:extra/io/windows/nt/launcher/test" [ vm "-script" "env.factor" 3array >>command { { "HOME" "XXX" } } >>environment diff --git a/extra/koszul/koszul.factor b/extra/koszul/koszul.factor index e9de82ebb6..5c337f8ce7 100755 --- a/extra/koszul/koszul.factor +++ b/extra/koszul/koszul.factor @@ -184,7 +184,7 @@ DEFER: (d) [ length ] keep [ (graded-ker/im-d) ] curry map ; : graded-betti ( generators -- seq ) - basis graded graded-ker/im-d flip first2 1 head* 0 prefix v- ; + basis graded graded-ker/im-d flip first2 butlast 0 prefix v- ; ! Bi-graded for two-step complexes : (bigraded-ker/im-d) ( u-deg z-deg bigraded-basis -- null/rank ) diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor index d18017f69b..4ad81ef00a 100755 --- a/extra/locals/locals.factor +++ b/extra/locals/locals.factor @@ -101,7 +101,7 @@ UNION: special local quote local-word local-reader local-writer ; ] if ; : point-free-body ( quot args -- newquot ) - >r 1 head-slice* r> [ localize ] curry map concat ; + >r butlast-slice r> [ localize ] curry map concat ; : point-free-end ( quot args -- newquot ) over peek special? diff --git a/extra/mortar/mortar.factor b/extra/mortar/mortar.factor index b7862af7ac..3d4d287ace 100644 --- a/extra/mortar/mortar.factor +++ b/extra/mortar/mortar.factor @@ -122,7 +122,7 @@ over class-class-methods assoc-stack call ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : send-message-next ( object message -- ) -over object-class class-methods 1 head* assoc-stack call ; +over object-class class-methods butlast assoc-stack call ; : <-~ scan parsed \ send-message-next parsed ; parsing diff --git a/extra/multiline/multiline.factor b/extra/multiline/multiline.factor index e140c5227c..acff8c8669 100755 --- a/extra/multiline/multiline.factor +++ b/extra/multiline/multiline.factor @@ -14,7 +14,7 @@ IN: multiline ] [ ";" unexpected-eof ] if* ; : parse-here ( -- str ) - [ (parse-here) ] "" make 1 head* + [ (parse-here) ] "" make butlast lexer get next-line ; : STRING: @@ -34,7 +34,7 @@ IN: multiline [ lexer get lexer-column swap (parse-multiline-string) lexer get set-lexer-column - ] "" make rest 1 head* ; + ] "" make rest butlast ; : <" "\">" parse-multiline-string parsed ; parsing diff --git a/extra/openssl/openssl-tests.factor b/extra/openssl/openssl-tests.factor index f42c611fc0..2b840bdb9c 100755 --- a/extra/openssl/openssl-tests.factor +++ b/extra/openssl/openssl-tests.factor @@ -27,7 +27,7 @@ math.parser openssl prettyprint sequences tools.test ; [ ] [ ssl-v23 new-ctx ] unit-test -[ ] [ get-ctx "extra/openssl/test/server.pem" resource-path use-cert-chain ] unit-test +[ ] [ get-ctx "resource:extra/openssl/test/server.pem" use-cert-chain ] unit-test ! TODO: debug 'Memory protection fault at address 6c' ! get-ctx 1024 "char" malloc-array 1024 0 f password-cb set-default-passwd @@ -35,10 +35,10 @@ math.parser openssl prettyprint sequences tools.test ; [ ] [ get-ctx "password" ascii string>alien set-default-passwd-userdata ] unit-test ! Enter PEM pass phrase: password -[ ] [ get-ctx "extra/openssl/test/server.pem" resource-path +[ ] [ get-ctx "resource:extra/openssl/test/server.pem" SSL_FILETYPE_PEM use-private-key ] unit-test -[ ] [ get-ctx "extra/openssl/test/root.pem" resource-path f +[ ] [ get-ctx "resource:extra/openssl/test/root.pem" f verify-load-locations ] unit-test [ ] [ get-ctx 1 set-verify-depth ] unit-test @@ -47,7 +47,7 @@ verify-load-locations ] unit-test ! Load Diffie-Hellman parameters ! ========================================================= -[ ] [ "extra/openssl/test/dh1024.pem" resource-path "r" bio-new-file ] unit-test +[ ] [ "resource:extra/openssl/test/dh1024.pem" "r" bio-new-file ] unit-test [ ] [ get-bio f f f read-pem-dh-params ] unit-test @@ -131,7 +131,7 @@ verify-load-locations ] unit-test ! Dump errors to file ! ========================================================= -[ ] [ "extra/openssl/test/errors.txt" resource-path "w" bio-new-file ] unit-test +[ ] [ "resource:extra/openssl/test/errors.txt" "w" bio-new-file ] unit-test [ 6 ] [ get-bio "Hello\n" bio-print ] unit-test diff --git a/extra/porter-stemmer/porter-stemmer-tests.factor b/extra/porter-stemmer/porter-stemmer-tests.factor index 32386fed2b..42c358646b 100644 --- a/extra/porter-stemmer/porter-stemmer-tests.factor +++ b/extra/porter-stemmer/porter-stemmer-tests.factor @@ -56,11 +56,9 @@ io.files io.encodings.utf8 ; [ "hell" ] [ "hell" step5 "" like ] unit-test [ "mate" ] [ "mate" step5 "" like ] unit-test -: resource-lines resource-path utf8 file-lines ; - [ { } ] [ - "extra/porter-stemmer/test/voc.txt" resource-lines + "resource:extra/porter-stemmer/test/voc.txt" utf8 file-lines [ stem ] map - "extra/porter-stemmer/test/output.txt" resource-lines + "resource:extra/porter-stemmer/test/output.txt" utf8 file-lines [ 2array ] 2map [ first2 = not ] filter ] unit-test diff --git a/extra/porter-stemmer/porter-stemmer.factor b/extra/porter-stemmer/porter-stemmer.factor index 81820e0152..f6975ccce7 100644 --- a/extra/porter-stemmer/porter-stemmer.factor +++ b/extra/porter-stemmer/porter-stemmer.factor @@ -66,8 +66,6 @@ USING: kernel math parser sequences combinators splitting ; : r ( str oldsuffix newsuffix -- str ) pick consonant-seq 0 > [ nip ] [ drop ] if append ; -: butlast ( seq -- seq ) 1 head-slice* ; - : step1a ( str -- newstr ) dup peek CHAR: s = [ { @@ -95,7 +93,7 @@ USING: kernel math parser sequences combinators splitting ; { [ "iz" ?tail ] [ "ize" append ] } { [ dup length 1- over double-consonant? ] - [ dup "lsz" last-is? [ butlast ] unless ] + [ dup "lsz" last-is? [ butlast-slice ] unless ] } { [ t ] @@ -122,7 +120,7 @@ USING: kernel math parser sequences combinators splitting ; } cond ; : step1c ( str -- newstr ) - dup butlast stem-vowel? [ + dup butlast-slice stem-vowel? [ "y" ?tail [ "i" append ] when ] when ; @@ -198,18 +196,18 @@ USING: kernel math parser sequences combinators splitting ; : remove-e? ( str -- ? ) dup consonant-seq dup 1 > [ 2drop t ] - [ 1 = [ butlast cvc? not ] [ drop f ] if ] if ; + [ 1 = [ butlast-slice cvc? not ] [ drop f ] if ] if ; : remove-e ( str -- newstr ) dup peek CHAR: e = [ - dup remove-e? [ butlast ] when + dup remove-e? [ butlast-slice ] when ] when ; : ll->l ( str -- newstr ) { { [ dup peek CHAR: l = not ] [ ] } { [ dup length 1- over double-consonant? not ] [ ] } - { [ dup consonant-seq 1 > ] [ butlast ] } + { [ dup consonant-seq 1 > ] [ butlast-slice ] } [ ] } cond ; diff --git a/extra/project-euler/002/002.factor b/extra/project-euler/002/002.factor index c2def03ace..6c9d331c90 100644 --- a/extra/project-euler/002/002.factor +++ b/extra/project-euler/002/002.factor @@ -41,7 +41,7 @@ PRIVATE> : fib-upto* ( n -- seq ) 0 1 [ pick over >= ] [ tuck + dup ] [ ] unfold 3nip - 1 head-slice* { 0 1 } prepend ; + butlast-slice { 0 1 } prepend ; : euler002a ( -- answer ) 1000000 fib-upto* [ even? ] filter sum ; diff --git a/extra/project-euler/022/022.factor b/extra/project-euler/022/022.factor index 452d2ec637..82054ce014 100644 --- a/extra/project-euler/022/022.factor +++ b/extra/project-euler/022/022.factor @@ -28,7 +28,7 @@ IN: project-euler.022 number ] map ; @@ -78,7 +78,7 @@ INSTANCE: rollover immutable-sequence frequency-analysis sort-values keys peek ; : crack-key ( seq key-length -- key ) - [ " " decrypt ] dip group 1 head-slice* + [ " " decrypt ] dip group butlast-slice flip [ most-frequent ] map ; PRIVATE> diff --git a/extra/project-euler/067/067.factor b/extra/project-euler/067/067.factor index 436ccde776..3e16996e04 100644 --- a/extra/project-euler/067/067.factor +++ b/extra/project-euler/067/067.factor @@ -38,7 +38,7 @@ IN: project-euler.067 number ] map ] map ; PRIVATE> diff --git a/extra/project-euler/079/079.factor b/extra/project-euler/079/079.factor index 3674804b0c..cde4dc079b 100644 --- a/extra/project-euler/079/079.factor +++ b/extra/project-euler/079/079.factor @@ -27,7 +27,7 @@ IN: project-euler.079 edges ( seq -- seq ) [ diff --git a/extra/rss/rss-tests.factor b/extra/rss/rss-tests.factor index 252defe99b..0e6bb0b9c1 100755 --- a/extra/rss/rss-tests.factor +++ b/extra/rss/rss-tests.factor @@ -22,7 +22,7 @@ IN: rss.tests f } } -} ] [ "extra/rss/rss1.xml" resource-path load-news-file ] unit-test +} ] [ "resource:extra/rss/rss1.xml" load-news-file ] unit-test [ T{ feed f @@ -39,4 +39,4 @@ IN: rss.tests T{ timestamp f 2003 12 13 8 29 29 T{ duration f 0 0 0 -4 0 0 } } } } -} ] [ "extra/rss/atom.xml" resource-path load-news-file ] unit-test +} ] [ "resource:extra/rss/atom.xml" load-news-file ] unit-test diff --git a/extra/space-invaders/space-invaders.factor b/extra/space-invaders/space-invaders.factor index 200257b31c..f773d331b1 100755 --- a/extra/space-invaders/space-invaders.factor +++ b/extra/space-invaders/space-invaders.factor @@ -45,21 +45,21 @@ TUPLE: space-invaders port1 port2i port2o port3o port4lo port4hi port5o bitmap s : init-sound ( index cpu filename -- ) swapd >r space-invaders-sounds nth AL_BUFFER r> - resource-path create-buffer-from-wav set-source-param ; + create-buffer-from-wav set-source-param ; : init-sounds ( cpu -- ) init-openal [ 9 gen-sources swap set-space-invaders-sounds ] keep - [ SOUND-SHOT "extra/space-invaders/resources/Shot.wav" init-sound ] keep - [ SOUND-UFO "extra/space-invaders/resources/Ufo.wav" init-sound ] keep + [ SOUND-SHOT "resource:extra/space-invaders/resources/Shot.wav" init-sound ] keep + [ SOUND-UFO "resource:extra/space-invaders/resources/Ufo.wav" init-sound ] keep [ space-invaders-sounds SOUND-UFO swap nth AL_LOOPING AL_TRUE set-source-param ] keep - [ SOUND-BASE-HIT "extra/space-invaders/resources/BaseHit.wav" init-sound ] keep - [ SOUND-INVADER-HIT "extra/space-invaders/resources/InvHit.wav" init-sound ] keep - [ SOUND-WALK1 "extra/space-invaders/resources/Walk1.wav" init-sound ] keep - [ SOUND-WALK2 "extra/space-invaders/resources/Walk2.wav" init-sound ] keep - [ SOUND-WALK3 "extra/space-invaders/resources/Walk3.wav" init-sound ] keep - [ SOUND-WALK4 "extra/space-invaders/resources/Walk4.wav" init-sound ] keep - [ SOUND-UFO-HIT "extra/space-invaders/resources/UfoHit.wav" init-sound ] keep + [ SOUND-BASE-HIT "resource:extra/space-invaders/resources/BaseHit.wav" init-sound ] keep + [ SOUND-INVADER-HIT "resource:extra/space-invaders/resources/InvHit.wav" init-sound ] keep + [ SOUND-WALK1 "resource:extra/space-invaders/resources/Walk1.wav" init-sound ] keep + [ SOUND-WALK2 "resource:extra/space-invaders/resources/Walk2.wav" init-sound ] keep + [ SOUND-WALK3 "resource:extra/space-invaders/resources/Walk3.wav" init-sound ] keep + [ SOUND-WALK4 "resource:extra/space-invaders/resources/Walk4.wav" init-sound ] keep + [ SOUND-UFO-HIT "resource:extra/space-invaders/resources/UfoHit.wav" init-sound ] keep f swap set-space-invaders-looping? ; : ( -- cpu ) diff --git a/extra/state-parser/state-parser.factor b/extra/state-parser/state-parser.factor index 6fdc6d9d32..b41d7f5023 100644 --- a/extra/state-parser/state-parser.factor +++ b/extra/state-parser/state-parser.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2005, 2006 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. USING: io io.streams.string kernel math namespaces sequences -strings circular prettyprint debugger ascii ; +strings circular prettyprint debugger ascii sbufs fry inspector +accessors sequences.lib ; IN: state-parser ! * Basic underlying words @@ -11,50 +12,56 @@ TUPLE: spot char line column next ; C: spot -: get-char ( -- char ) spot get spot-char ; -: set-char ( char -- ) spot get set-spot-char ; -: get-line ( -- line ) spot get spot-line ; -: set-line ( line -- ) spot get set-spot-line ; -: get-column ( -- column ) spot get spot-column ; -: set-column ( column -- ) spot get set-spot-column ; -: get-next ( -- char ) spot get spot-next ; -: set-next ( char -- ) spot get set-spot-next ; +: get-char ( -- char ) spot get char>> ; +: set-char ( char -- ) spot get swap >>char drop ; +: get-line ( -- line ) spot get line>> ; +: set-line ( line -- ) spot get swap >>line drop ; +: get-column ( -- column ) spot get column>> ; +: set-column ( column -- ) spot get swap >>column drop ; +: get-next ( -- char ) spot get next>> ; +: set-next ( char -- ) spot get swap >>next drop ; ! * Errors TUPLE: parsing-error line column ; -: ( -- parsing-error ) - get-line get-column parsing-error boa ; -: construct-parsing-error ( ... slots class -- error ) - construct over set-delegate ; inline +: parsing-error ( class -- obj ) + new + get-line >>line + get-column >>column ; +M: parsing-error summary ( obj -- str ) + [ + "Parsing error" print + "Line: " write dup line>> . + "Column: " write column>> . + ] with-string-writer ; -: parsing-error. ( parsing-error -- ) - "Parsing error" print - "Line: " write dup parsing-error-line . - "Column: " write parsing-error-column . ; +TUPLE: expected < parsing-error should-be was ; +: expected ( should-be was -- * ) + \ expected parsing-error + swap >>was + swap >>should-be throw ; +M: expected summary ( obj -- str ) + [ + dup call-next-method write + "Token expected: " write dup should-be>> print + "Token present: " write was>> print + ] with-string-writer ; -TUPLE: expected should-be was ; -: ( should-be was -- error ) - { set-expected-should-be set-expected-was } - expected construct-parsing-error ; -M: expected error. - dup parsing-error. - "Token expected: " write dup expected-should-be print - "Token present: " write expected-was print ; +TUPLE: unexpected-end < parsing-error ; +: unexpected-end \ unexpected-end parsing-error throw ; +M: unexpected-end summary ( obj -- str ) + [ + call-next-method write + "File unexpectedly ended." print + ] with-string-writer ; -TUPLE: unexpected-end ; -: ( -- unexpected-end ) - { } unexpected-end construct-parsing-error ; -M: unexpected-end error. - parsing-error. - "File unexpectedly ended." print ; - -TUPLE: missing-close ; -: ( -- missing-close ) - { } missing-close construct-parsing-error ; -M: missing-close error. - parsing-error. - "Missing closing token." print ; +TUPLE: missing-close < parsing-error ; +: missing-close \ missing-close parsing-error throw ; +M: missing-close summary ( obj -- str ) + [ + call-next-method write + "Missing closing token." print + ] with-string-writer ; SYMBOL: prolog-data @@ -65,7 +72,8 @@ SYMBOL: prolog-data [ 0 get-line 1+ set-line ] [ get-column 1+ ] if set-column ; -: (next) ( -- char ) ! this normalizes \r\n and \r +! (next) normalizes \r\n and \r +: (next) ( -- char ) get-next read1 2dup swap CHAR: \r = [ CHAR: \n = @@ -75,10 +83,7 @@ SYMBOL: prolog-data : next ( -- ) #! Increment spot. - get-char [ - throw - ] unless - (next) record ; + get-char [ unexpected-end ] unless (next) record ; : next* ( -- ) get-char [ (next) record ] when ; @@ -95,9 +100,9 @@ SYMBOL: prolog-data #! Take the substring of a string starting at spot #! from code until the quotation given is true and #! advance spot to after the substring. - [ [ - dup slip swap dup [ get-char , ] unless - ] skip-until ] "" make nip ; inline + 10 [ + '[ @ [ t ] [ get-char , push f ] if ] skip-until + ] keep >string ; inline : take-rest ( -- string ) [ f ] take-until ; @@ -105,6 +110,20 @@ SYMBOL: prolog-data : take-char ( ch -- string ) [ dup get-char = ] take-until nip ; +TUPLE: not-enough-characters < parsing-error ; +: not-enough-characters + \ not-enough-characters parsing-error throw ; +M: not-enough-characters summary ( obj -- str ) + [ + call-next-method write + "Not enough characters" print + ] with-string-writer ; + +: take ( n -- string ) + [ 1- ] [ ] bi [ + '[ drop get-char [ next , push f ] [ t ] if* ] attempt-each drop + ] keep get-char [ over push ] when* >string ; + : pass-blank ( -- ) #! Advance code past any whitespace, including newlines [ get-char blank? not ] skip-until ; @@ -117,16 +136,16 @@ SYMBOL: prolog-data dup length [ 2dup string-matches? ] take-until nip dup length rot length 1- - head - get-char [ throw ] unless next ; + get-char [ missing-close ] unless next ; : expect ( ch -- ) get-char 2dup = [ 2drop ] [ - >r 1string r> 1string throw + >r 1string r> 1string expected ] if next ; : expect-string ( string -- ) dup [ drop get-char next ] map 2dup = - [ 2drop ] [ throw ] if ; + [ 2drop ] [ expected ] if ; : init-parser ( -- ) 0 1 0 f spot set diff --git a/extra/tangle/tangle.factor b/extra/tangle/tangle.factor index afaf3da3cd..52c454f97f 100644 --- a/extra/tangle/tangle.factor +++ b/extra/tangle/tangle.factor @@ -65,7 +65,7 @@ TUPLE: tangle-dispatcher < dispatcher tangle ; : ( tangle -- dispatcher ) tangle-dispatcher new-dispatcher swap >>tangle >>default - "extra/tangle/resources" resource-path "resources" add-responder + "resource:extra/tangle/resources" "resources" add-responder "node" add-responder [ all-node-ids ] >>display "all" add-responder ; diff --git a/extra/taxes/taxes-tests.factor b/extra/taxes/taxes-tests.factor index 6aeb5aa098..32dbd0d625 100644 --- a/extra/taxes/taxes-tests.factor +++ b/extra/taxes/taxes-tests.factor @@ -96,3 +96,21 @@ IN: taxes.tests 1000000 2008 3 t net dollars/cents ] unit-test + + +[ 30 97 ] [ + 24000 2008 2 f withholding biweekly dollars/cents +] unit-test + +[ 173 66 ] [ + 78250 2008 2 f withholding biweekly dollars/cents +] unit-test + + +[ 138 69 ] [ + 24000 2008 2 f withholding biweekly dollars/cents +] unit-test + +[ 754 22 ] [ + 78250 2008 2 f withholding biweekly dollars/cents +] unit-test diff --git a/extra/tools/deploy/backend/backend.factor b/extra/tools/deploy/backend/backend.factor index ed466b6965..60d66e89cd 100755 --- a/extra/tools/deploy/backend/backend.factor +++ b/extra/tools/deploy/backend/backend.factor @@ -63,11 +63,11 @@ DEFER: ?make-staging-image dup empty? [ "-i=" my-boot-image-name append , ] [ - dup 1 head* ?make-staging-image + dup butlast ?make-staging-image "-resource-path=" "" resource-path append , - "-i=" over 1 head* staging-image-name append , + "-i=" over butlast staging-image-name append , "-run=tools.deploy.restage" , ] if diff --git a/extra/tuple-syntax/tuple-syntax.factor b/extra/tuple-syntax/tuple-syntax.factor index 219df5197c..2b9b2c3fb4 100755 --- a/extra/tuple-syntax/tuple-syntax.factor +++ b/extra/tuple-syntax/tuple-syntax.factor @@ -7,7 +7,7 @@ IN: tuple-syntax : parse-slot-writer ( tuple -- slot# ) scan dup "}" = [ 2drop f ] [ - 1 head* swap object-slots slot-named slot-spec-offset + butlast swap object-slots slot-named slot-spec-offset ] if ; : parse-slots ( accum tuple -- accum tuple ) diff --git a/extra/ui/gestures/gestures.factor b/extra/ui/gestures/gestures.factor index 0970bd6027..d13e284160 100755 --- a/extra/ui/gestures/gestures.factor +++ b/extra/ui/gestures/gestures.factor @@ -54,7 +54,7 @@ TUPLE: zoom-in-action ; C: zoom-in-action TUPLE: zoom-out-action ; C: zoom-out-action : generalize-gesture ( gesture -- newgesture ) - tuple>array 1 head* >tuple ; + tuple>array butlast >tuple ; ! Modifiers SYMBOLS: C+ A+ M+ S+ ; diff --git a/extra/unicode/breaks/breaks.factor b/extra/unicode/breaks/breaks.factor index 9ee65c0018..9635a62e49 100644 --- a/extra/unicode/breaks/breaks.factor +++ b/extra/unicode/breaks/breaks.factor @@ -30,7 +30,7 @@ CATEGORY: grapheme-control Zl Zp Cc Cf ; concat [ dup ] H{ } map>assoc ; : other-extend-lines ( -- lines ) - "extra/unicode/PropList.txt" resource-path ascii file-lines ; + "resource:extra/unicode/PropList.txt" ascii file-lines ; VALUE: other-extend diff --git a/extra/unicode/data/data.factor b/extra/unicode/data/data.factor index 85ce50acb9..f33338137a 100755 --- a/extra/unicode/data/data.factor +++ b/extra/unicode/data/data.factor @@ -14,7 +14,7 @@ IN: unicode.data ascii file-lines [ ";" split ] map ; : load-data ( -- data ) - "extra/unicode/UnicodeData.txt" resource-path data ; + "resource:extra/unicode/UnicodeData.txt" data ; : (process-data) ( index data -- newdata ) [ [ nth ] keep first swap 2array ] with map @@ -120,7 +120,7 @@ VALUE: special-casing ! Special casing data : load-special-casing ( -- special-casing ) - "extra/unicode/SpecialCasing.txt" resource-path data + "resource:extra/unicode/SpecialCasing.txt" data [ length 5 = ] filter [ [ set-code-point ] each ] H{ } make-assoc ; diff --git a/extra/xml/backend/backend.factor b/extra/xml/backend/backend.factor new file mode 100644 index 0000000000..5dee38695d --- /dev/null +++ b/extra/xml/backend/backend.factor @@ -0,0 +1,6 @@ +! Copyright (C) 2008 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +IN: xml.backend + +! A stack of { tag children } pairs +SYMBOL: xml-stack diff --git a/extra/xml/errors/errors.factor b/extra/xml/errors/errors.factor index 5b41a7ff9f..53f2046a54 100644 --- a/extra/xml/errors/errors.factor +++ b/extra/xml/errors/errors.factor @@ -1,150 +1,178 @@ ! Copyright (C) 2005, 2006 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. USING: xml.data xml.writer kernel generic io prettyprint math -debugger sequences state-parser ; +debugger sequences state-parser accessors inspector +namespaces io.streams.string xml.backend ; IN: xml.errors -TUPLE: no-entity thing ; -: ( string -- error ) - { set-no-entity-thing } no-entity construct-parsing-error ; -M: no-entity error. - dup parsing-error. - "Entity does not exist: &" write no-entity-thing write ";" print ; - -TUPLE: xml-string-error string ; ! this should not exist -: ( string -- xml-string-error ) - { set-xml-string-error-string } - xml-string-error construct-parsing-error ; -M: xml-string-error error. - dup parsing-error. - xml-string-error-string print ; - -TUPLE: mismatched open close ; -: - { set-mismatched-open set-mismatched-close } - mismatched construct-parsing-error ; -M: mismatched error. - dup parsing-error. - "Mismatched tags" print - "Opening tag: <" write dup mismatched-open print-name ">" print - "Closing tag: " print ; - -TUPLE: unclosed tags ; -! is ( -- unclosed ), see presentation.factor -M: unclosed error. - "Unclosed tags" print - "Tags: " print - unclosed-tags [ " <" write print-name ">" print ] each ; - -TUPLE: bad-uri string ; -: ( string -- bad-uri ) - { set-bad-uri-string } bad-uri construct-parsing-error ; -M: bad-uri error. - dup parsing-error. - "Bad URI:" print bad-uri-string . ; - -TUPLE: nonexist-ns name ; -: ( name-string -- nonexist-ns ) - { set-nonexist-ns-name } - nonexist-ns construct-parsing-error ; -M: nonexist-ns error. - dup parsing-error. - "Namespace " write nonexist-ns-name write " has not been declared" print ; - -TUPLE: unopened ; ! this should give which tag was unopened -: ( -- unopened ) - { } unopened construct-parsing-error ; -M: unopened error. - parsing-error. - "Closed an unopened tag" print ; - -TUPLE: not-yes/no text ; -: ( text -- not-yes/no ) - { set-not-yes/no-text } not-yes/no construct-parsing-error ; -M: not-yes/no error. - dup parsing-error. - "standalone must be either yes or no, not \"" write - not-yes/no-text write "\"." print ; - -TUPLE: extra-attrs attrs ; ! this should actually print the names -: ( attrs -- extra-attrs ) - { set-extra-attrs-attrs } - extra-attrs construct-parsing-error ; -M: extra-attrs error. - dup parsing-error. - "Extra attributes included in xml version declaration:" print - extra-attrs-attrs . ; - -TUPLE: bad-version num ; -: - { set-bad-version-num } - bad-version construct-parsing-error ; -M: bad-version error. - "XML version must be \"1.0\" or \"1.1\". Version here was " write - bad-version-num . ; - -TUPLE: notags ; -C: notags -M: notags error. - drop "XML document lacks a main tag" print ; - TUPLE: multitags ; C: multitags -M: multitags error. - drop "XML document contains multiple main tags" print ; - -TUPLE: bad-prolog prolog ; -: ( prolog -- bad-prolog ) - { set-bad-prolog-prolog } - bad-prolog construct-parsing-error ; -M: bad-prolog error. - dup parsing-error. - "Misplaced XML prolog" print - bad-prolog-prolog write-prolog nl ; - -TUPLE: capitalized-prolog name ; -: ( name -- capitalized-prolog ) - { set-capitalized-prolog-name } - capitalized-prolog construct-parsing-error ; -M: capitalized-prolog error. - dup parsing-error. - "XML prolog name was partially or totally capitalized, using" print - "" write - " instead of " print ; +M: multitags summary ( obj -- str ) + drop "XML document contains multiple main tags" ; TUPLE: pre/post-content string pre? ; C: 
 pre/post-content
-M: pre/post-content error.
-    "The text string:" print
-    dup pre/post-content-string .
-    "was used " write
-    pre/post-content-pre? "before" "after" ? write
-    " the main tag." print ;
+M: pre/post-content summary ( obj -- str )
+    [
+        "The text string:" print
+        dup string>> .
+        "was used " write
+        pre?>> "before" "after" ? write
+        " the main tag." print
+    ] with-string-writer ;
 
-TUPLE: versionless-prolog ;
+TUPLE: no-entity < parsing-error thing ;
+:  ( string -- error )
+    \ no-entity parsing-error swap >>thing ;
+M: no-entity summary ( obj -- str )
+    [
+        dup call-next-method write
+        "Entity does not exist: &" write thing>> write ";" print
+    ] with-string-writer ;
+
+TUPLE: xml-string-error < parsing-error string ; ! this should not exist
+:  ( string -- xml-string-error )
+    \ xml-string-error parsing-error swap >>string ;
+M: xml-string-error summary ( obj -- str )
+    [
+        dup call-next-method write
+        string>> print
+    ] with-string-writer ;
+
+TUPLE: mismatched < parsing-error open close ;
+: 
+    \ mismatched parsing-error swap >>close swap >>open ;
+M: mismatched summary ( obj -- str )
+    [
+        dup call-next-method write
+        "Mismatched tags" print
+        "Opening tag: <" write dup open>> print-name ">" print
+        "Closing tag: > print-name ">" print
+    ] with-string-writer ;
+
+TUPLE: unclosed < parsing-error tags ;
+:  ( -- unclosed )
+    unclosed parsing-error
+        xml-stack get rest-slice [ first opener-name ] map >>tags ;
+M: unclosed summary ( obj -- str )
+    [
+        dup call-next-method write
+        "Unclosed tags" print
+        "Tags: " print
+        tags>> [ "  <" write print-name ">" print ] each
+    ] with-string-writer ;
+
+TUPLE: bad-uri < parsing-error string ;
+:  ( string -- bad-uri )
+    \ bad-uri parsing-error swap >>string ;
+M: bad-uri summary ( obj -- str )
+    [
+        dup call-next-method write
+        "Bad URI:" print string>> .
+    ] with-string-writer ;
+
+TUPLE: nonexist-ns < parsing-error name ;
+:  ( name-string -- nonexist-ns )
+    \ nonexist-ns parsing-error swap >>name ;
+M: nonexist-ns summary ( obj -- str )
+    [
+        dup call-next-method write
+        "Namespace " write name>> write " has not been declared" print
+    ] with-string-writer ;
+
+TUPLE: unopened < parsing-error ; ! this should give which tag was unopened
+:  ( -- unopened )
+    \ unopened parsing-error ;
+M: unopened summary ( obj -- str )
+    [
+        call-next-method write
+        "Closed an unopened tag" print
+    ] with-string-writer ;
+
+TUPLE: not-yes/no < parsing-error text ;
+:  ( text -- not-yes/no )
+    \ not-yes/no parsing-error swap >>text ;
+M: not-yes/no summary ( obj -- str )
+    [
+        dup call-next-method write
+        "standalone must be either yes or no, not \"" write
+        text>> write "\"." print
+    ] with-string-writer ;
+
+! this should actually print the names
+TUPLE: extra-attrs < parsing-error attrs ;
+:  ( attrs -- extra-attrs )
+    \ extra-attrs parsing-error swap >>attrs ;
+M: extra-attrs summary ( obj -- str )
+    [
+        dup call-next-method write
+        "Extra attributes included in xml version declaration:" print
+        attrs>> .
+    ] with-string-writer ;
+
+TUPLE: bad-version < parsing-error num ;
+: 
+    \ bad-version parsing-error swap >>num ;
+M: bad-version summary ( obj -- str )
+    [
+        "XML version must be \"1.0\" or \"1.1\". Version here was " write
+        num>> .
+    ] with-string-writer ;
+
+TUPLE: notags ;
+C:  notags
+M: notags summary ( obj -- str )
+    drop "XML document lacks a main tag" ;
+
+TUPLE: bad-prolog < parsing-error prolog ;
+:  ( prolog -- bad-prolog )
+    \ bad-prolog parsing-error swap >>prolog ;
+M: bad-prolog summary ( obj -- str )
+    [
+        dup call-next-method write
+        "Misplaced XML prolog" print
+        prolog>> write-prolog nl
+    ] with-string-writer ;
+
+TUPLE: capitalized-prolog < parsing-error name ;
+:  ( name -- capitalized-prolog )
+    \ capitalized-prolog parsing-error swap >>name ;
+M: capitalized-prolog summary ( obj -- str )
+    [
+        dup call-next-method write
+        "XML prolog name was partially or totally capitalized, using" print
+        "> write "...?>" write
+        " instead of " print
+    ] with-string-writer ;
+
+TUPLE: versionless-prolog < parsing-error ;
 :  ( -- versionless-prolog )
-    { } versionless-prolog construct-parsing-error ;
-M: versionless-prolog error.
-    parsing-error.
-    "XML prolog lacks a version declaration" print ;
+    \ versionless-prolog parsing-error ;
+M: versionless-prolog summary ( obj -- str )
+    [
+        call-next-method write
+        "XML prolog lacks a version declaration" print
+    ] with-string-writer ;
 
-TUPLE: bad-instruction inst ;
+TUPLE: bad-instruction < parsing-error instruction ;
 :  ( instruction -- bad-instruction )
-    { set-bad-instruction-inst }
-    bad-instruction construct-parsing-error ;
-M: bad-instruction error.
-    dup parsing-error.
-    "Misplaced processor instruction:" print
-    bad-instruction-inst write-item nl ;
+    \ bad-instruction parsing-error swap >>instruction ;
+M: bad-instruction summary ( obj -- str )
+    [
+        dup call-next-method write
+        "Misplaced processor instruction:" print
+        instruction>> write-item nl
+    ] with-string-writer ;
 
-TUPLE: bad-directive dir ;
+TUPLE: bad-directive < parsing-error dir ;
 :  ( directive -- bad-directive )
-    { set-bad-directive-dir }
-    bad-directive construct-parsing-error ;
-M: bad-directive error.
-    dup parsing-error.
-    "Misplaced directive:" print
-    bad-directive-dir write-item nl ;
+    \ bad-directive parsing-error swap >>dir ;
+M: bad-directive summary ( obj -- str )
+    [
+        dup call-next-method write
+        "Misplaced directive:" print
+        bad-directive-dir write-item nl
+    ] with-string-writer ;
 
 UNION: xml-parse-error multitags notags extra-attrs nonexist-ns
        not-yes/no unclosed mismatched xml-string-error expected no-entity
diff --git a/extra/xml/tests/errors.factor b/extra/xml/tests/errors.factor
deleted file mode 100755
index 6ba0b0d560..0000000000
--- a/extra/xml/tests/errors.factor
+++ /dev/null
@@ -1,28 +0,0 @@
-USING: continuations xml xml.errors tools.test kernel arrays xml.data state-parser quotations ;
-IN: xml.tests
-
-: xml-error-test ( expected-error xml-string -- )
-    [ string>xml ] curry swap [ = ] curry must-fail-with ;
-
-T{ no-entity T{ parsing-error f 1 10 } "nbsp" } " " xml-error-test
-T{ mismatched T{ parsing-error f 1 8 } T{ name f "" "x" "" } T{ name f "" "y" "" }
-} "" xml-error-test
-T{ unclosed f V{ T{ name f "" "x" "" } } } "" xml-error-test
-T{ nonexist-ns T{ parsing-error f 1 5 } "x" } "" xml-error-test
-T{ unopened T{ parsing-error f 1 5 } } "" xml-error-test
-T{ not-yes/no T{ parsing-error f 1 41 } "maybe" } "" xml-error-test
-T{ extra-attrs T{ parsing-error f 1 32 } V{ T{ name f "" "foo" f } }
-} "" xml-error-test
-T{ bad-version T{ parsing-error f 1 28 } "5 million" } "" xml-error-test
-T{ notags f } "" xml-error-test
-T{ multitags f } "" xml-error-test
-T{ bad-prolog T{ parsing-error f 1 26 } T{ prolog f "1.0" "UTF-8" f }
-} "" xml-error-test
-T{ capitalized-prolog T{ parsing-error f 1 6 } "XmL" } ""
-xml-error-test
-T{ pre/post-content f "x" t } "x" xml-error-test
-T{ versionless-prolog T{ parsing-error f 1 8 } } "" xml-error-test
-T{ bad-instruction T{ parsing-error f 1 11 } T{ instruction f "xsl" }
-} "" xml-error-test
-T{ bad-directive T{ parsing-error f 1 15 } T{ directive f "DOCTYPE" }
-} "" xml-error-test
diff --git a/extra/xml/tests/soap.factor b/extra/xml/tests/soap.factor
index 775930025f..c7452bb079 100755
--- a/extra/xml/tests/soap.factor
+++ b/extra/xml/tests/soap.factor
@@ -10,6 +10,6 @@ IN: xml.tests
     [ assemble-data ] map ;
 
 [ "http://www.foxnews.com/oreilly/" ] [
-    "extra/xml/tests/soap.xml" resource-path file>xml
+    "resource:extra/xml/tests/soap.xml" file>xml
     parse-result first first
 ] unit-test
diff --git a/extra/xml/tests/test.factor b/extra/xml/tests/test.factor
index d85345b3c7..7794930144 100644
--- a/extra/xml/tests/test.factor
+++ b/extra/xml/tests/test.factor
@@ -9,7 +9,7 @@ USING: kernel xml tools.test io namespaces sequences xml.errors xml.entities
 \ read-xml must-infer
 
 SYMBOL: xml-file
-[ ] [ "extra/xml/tests/test.xml" resource-path
+[ ] [ "resource:extra/xml/tests/test.xml"
     [ file>xml ] with-html-entities xml-file set ] unit-test
 [ "1.0" ] [ xml-file get xml-prolog prolog-version ] unit-test
 [ f ] [ xml-file get xml-prolog prolog-standalone ] unit-test
diff --git a/extra/xml/xml.factor b/extra/xml/xml.factor
index 4cac3051c3..4e2ad7a672 100644
--- a/extra/xml/xml.factor
+++ b/extra/xml/xml.factor
@@ -3,18 +3,12 @@
 USING: io io.streams.string io.files kernel math namespaces
 prettyprint sequences arrays generic strings vectors
 xml.char-classes xml.data xml.errors xml.tokenize xml.writer
-xml.utilities state-parser assocs ascii io.encodings.utf8 ;
+xml.utilities state-parser assocs ascii io.encodings.utf8
+accessors xml.backend ;
 IN: xml
 
 !   -- Overall parser with data tree
 
-! A stack of { tag children } pairs
-SYMBOL: xml-stack
-
-:  ( -- unclosed )
-    xml-stack get rest-slice [ first opener-name ] map
-    { set-unclosed-tags } unclosed construct ;
-
 : add-child ( object -- )
     xml-stack get peek second push ;
 
diff --git a/extra/xmode/catalog/catalog.factor b/extra/xmode/catalog/catalog.factor
index 22d3217ee6..277439c0cd 100755
--- a/extra/xmode/catalog/catalog.factor
+++ b/extra/xmode/catalog/catalog.factor
@@ -24,7 +24,7 @@ TAGS>
     ] keep ;
 
 : load-catalog ( -- modes )
-    "extra/xmode/modes/catalog" resource-path
+    "resource:extra/xmode/modes/catalog"
     file>xml parse-modes-tag ;
 
 : modes ( -- assoc )
@@ -38,8 +38,8 @@ TAGS>
 MEMO: (load-mode) ( name -- rule-sets )
     modes at [
         mode-file
-        "extra/xmode/modes/" prepend
-        resource-path utf8  parse-mode
+        "resource:extra/xmode/modes/" prepend
+        utf8  parse-mode
     ] [
         "text" (load-mode)
     ] if* ;
diff --git a/extra/xmode/code2html/code2html.factor b/extra/xmode/code2html/code2html.factor
index f6df23b9b2..3977f4277c 100755
--- a/extra/xmode/code2html/code2html.factor
+++ b/extra/xmode/code2html/code2html.factor
@@ -20,8 +20,8 @@ IN: xmode.code2html
 
 : default-stylesheet ( -- )
      ;
 
 : htmlize-stream ( path stream -- )
diff --git a/extra/xmode/utilities/utilities-tests.factor b/extra/xmode/utilities/utilities-tests.factor
index 99689d8819..a2183edbc9 100755
--- a/extra/xmode/utilities/utilities-tests.factor
+++ b/extra/xmode/utilities/utilities-tests.factor
@@ -48,6 +48,6 @@ TAGS>
         "This is a great company"
     }
 ] [
-    "extra/xmode/utilities/test.xml"
-    resource-path file>xml parse-company-tag
+    "resource:extra/xmode/utilities/test.xml"
+    file>xml parse-company-tag
 ] unit-test
diff --git a/extra/yahoo/yahoo-tests.factor b/extra/yahoo/yahoo-tests.factor
index 197fa4900b..46d05ce720 100644
--- a/extra/yahoo/yahoo-tests.factor
+++ b/extra/yahoo/yahoo-tests.factor
@@ -6,6 +6,6 @@ USING: tools.test yahoo kernel io.files xml sequences ;
     "Official Foo Fighters"
     "http://www.foofighters.com/"
     "Official site with news, tour dates, discography, store, community, and more."
-} ] [ "extra/yahoo/test-results.xml" resource-path file>xml parse-yahoo first ] unit-test
+} ] [ "resource:extra/yahoo/test-results.xml" file>xml parse-yahoo first ] unit-test
 
 [ "http://search.yahooapis.com/WebSearchService/V1/webSearch?appid=Factor-search&query=hi&results=1" ] [ "hi" 1 query ] unit-test