Merge branch 'master' of git://factorcode.org/git/factor

2008-05-07 00:40:17 -05:00 · 2008-05-07 00:40:17 -05:00 · 9fd7b12534
parent 732b84bcf9 0acbdcdcc6
commit 9fd7b12534
53 changed files with 365 additions and 314 deletions
--- 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 )
--- 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"
--- 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
--- 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-reader> ( resource -- stream )
-    resource-path ascii <file-reader> ;
-    
 [ { } ]
-[ "core/io/test/empty-file.txt" <resource-reader> lines ]
+[ "resource:core/io/test/empty-file.txt" ascii <file-reader> 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" <resource-reader> lines-test
+    "resource:core/io/test/windows-eol.txt"
+    ascii <file-reader> lines-test
 ] unit-test

 [
    "This is a line."
    "This is another line."
 ] [
-    "core/io/test/mac-os-eol.txt" <resource-reader> lines-test
+    "resource:core/io/test/mac-os-eol.txt"
+    ascii <file-reader> lines-test
 ] unit-test

 [
    "This is a line."
    "This is another line."
 ] [
-    "core/io/test/unix-eol.txt" <resource-reader> lines-test
+    "resource:core/io/test/unix-eol.txt"
+    ascii <file-reader> lines-test
 ] unit-test

 [
--- 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-reader> ( resource -- stream )
-    resource-path latin1 <file-reader> ;
-
 [
    "This is a line.\rThis is another line.\r"
 ] [
-    "core/io/test/mac-os-eol.txt" <resource-reader>
+    "resource:core/io/test/mac-os-eol.txt" latin1 <file-reader>
    [ 500 read ] with-input-stream
 ] unit-test

 [
    255
 ] [
-    "core/io/test/binary.txt" <resource-reader>
+    "resource:core/io/test/binary.txt" latin1 <file-reader>
    [ read1 ] with-input-stream >fixnum
 ] unit-test

@ -36,7 +33,8 @@ IN: io.tests
    }
 ] [
    [
-        "core/io/test/separator-test.txt" <resource-reader> [
+        "resource:core/io/test/separator-test.txt"
+        latin1 <file-reader> [
            "J" read-until 2array ,
            "i" read-until 2array ,
            "X" read-until 2array ,
--- 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 ;

--- 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
--- 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 <slice> }
 { $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." }
--- 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 ;

 : <flat-slice> ( seq -- slice )
    dup slice? [ { } like ] when 0 over length rot <slice> ;
--- a/core/splitting/splitting.factor
+++ b/core/splitting/splitting.factor
@ -104,7 +104,7 @@ M: sliced-clumps nth group@ <slice> ;
        1array
    ] [
        "\n" split [
-            1 head-slice* [
+            butlast-slice [
                "\r" ?tail drop "\r" split
            ] map
        ] keep peek "\r" split suffix concat
--- 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 ;

--- 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 ;
--- 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
--- 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' )
--- 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? ;

--- a/extra/http/http-tests.factor
+++ b/extra/http/http-tests.factor
@ -166,7 +166,7 @@ test-db [
        <dispatcher>
            add-quit-action
            <dispatcher>
-                "extra/http/test" resource-path <static> >>default
+                "resource:extra/http/test" <static> >>default
            "nested" add-responder
            <action>
                [ "redirect-loop" f <standard-redirect> ] >>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

--- 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 ;
--- 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 )
--- 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 <file-reader> ;
+    "resource:extra/io/encodings/8-bit/" ".TXT"
+    swapd 3append ascii <file-reader> ;

 : tail-if ( seq n -- newseq )
    2dup swap length <= [ tail ] [ drop ] if ;
--- 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" [
        <process>
            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" [
        <process>
            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" [
        <process>
            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" [
        <process>
            vm "-script" "env.factor" 3array >>command
        ascii <process-reader> 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" [
        <process>
            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" [
        <process>
            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" [
        <process>
            vm "-script" "env.factor" 3array >>command
            { { "HOME" "XXX" } } >>environment
--- 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 )
--- 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?
--- 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

--- 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
--- 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

--- 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
--- 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 ;

--- 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 ;
--- a/extra/project-euler/022/022.factor
+++ b/extra/project-euler/022/022.factor
@ -28,7 +28,7 @@ IN: project-euler.022
 <PRIVATE

 : source-022 ( -- seq )
-    "extra/project-euler/022/names.txt" resource-path
+    "resource:extra/project-euler/022/names.txt"
    ascii file-contents [ quotable? ] filter "," split ;

 : name-scores ( seq -- seq )
--- a/extra/project-euler/042/042.factor
+++ b/extra/project-euler/042/042.factor
@ -30,7 +30,7 @@ IN: project-euler.042
 <PRIVATE

 : source-042 ( -- seq )
-    "extra/project-euler/042/words.txt" resource-path
+    "resource:extra/project-euler/042/words.txt"
    ascii file-contents [ quotable? ] filter "," split ;

 : (triangle-upto) ( limit n -- )
--- a/extra/project-euler/059/059.factor
+++ b/extra/project-euler/059/059.factor
@ -52,7 +52,7 @@ IN: project-euler.059
 <PRIVATE

 : source-059 ( -- seq )
-    "extra/project-euler/059/cipher1.txt" resource-path
+    "resource:extra/project-euler/059/cipher1.txt"
    ascii file-contents [ blank? ] right-trim "," split
    [ string>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>
--- a/extra/project-euler/067/067.factor
+++ b/extra/project-euler/067/067.factor
@ -38,7 +38,7 @@ IN: project-euler.067
 <PRIVATE

 : source-067 ( -- seq )
-    "extra/project-euler/067/triangle.txt" resource-path
+    "resource:extra/project-euler/067/triangle.txt"
    ascii file-lines [ " " split [ string>number ] map ] map ;

 PRIVATE>
--- a/extra/project-euler/079/079.factor
+++ b/extra/project-euler/079/079.factor
@ -27,7 +27,7 @@ IN: project-euler.079
 <PRIVATE

 : source-079 ( -- seq )
-    "extra/project-euler/079/keylog.txt" resource-path ascii file-lines ;
+    "resource:extra/project-euler/079/keylog.txt" ascii file-lines ;

 : >edges ( seq -- seq )
    [
--- 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
--- 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? ;

 : <space-invaders> ( -- cpu )
--- 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> 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> ( -- parsing-error )
-    get-line get-column parsing-error boa ;

-: construct-parsing-error ( ... slots class -- error )
-    construct <parsing-error> 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 ;
-: <expected> ( 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 )
-    { } unexpected-end construct-parsing-error ;
-M: unexpected-end error.
-    parsing-error.
-    "File unexpectedly ended." print ;
-
-TUPLE: missing-close ;
-: <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 [
-        <unexpected-end> 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 <sbuf> [
+        '[ @ [ 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- ] [ <sbuf> ] 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 <circular-string>
    [ 2dup string-matches? ] take-until nip
    dup length rot length 1- - head
-    get-char [ <missing-close> throw ] unless next ;
+    get-char [ missing-close ] unless next ;

 : expect ( ch -- )
    get-char 2dup = [ 2drop ] [
-        >r 1string r> 1string <expected> throw
+        >r 1string r> 1string expected
    ] if next ;

 : expect-string ( string -- )
    dup [ drop get-char next ] map 2dup =
-    [ 2drop ] [ <expected> throw ] if ;
+    [ 2drop ] [ expected ] if ;

 : init-parser ( -- )
    0 1 0 f <spot> spot set
--- a/extra/tangle/tangle.factor
+++ b/extra/tangle/tangle.factor
@ -65,7 +65,7 @@ TUPLE: tangle-dispatcher < dispatcher tangle ;
 : <tangle-dispatcher> ( tangle -- dispatcher )
    tangle-dispatcher new-dispatcher swap >>tangle
    <path-responder> >>default
-    "extra/tangle/resources" resource-path <static> "resources" add-responder
+    "resource:extra/tangle/resources" <static> "resources" add-responder
    <node-responder> "node" add-responder
    <action> [ all-node-ids <json-response> ] >>display "all" add-responder ;

--- a/extra/taxes/taxes-tests.factor
+++ b/extra/taxes/taxes-tests.factor
@ -96,3 +96,21 @@ IN: taxes.tests
    1000000 2008 3 t <w4> <minnesota> net
    dollars/cents
 ] unit-test
+
+
+[ 30 97 ] [
+    24000 2008 2 f <w4> <minnesota> withholding biweekly dollars/cents
+] unit-test
+
+[ 173 66 ] [
+    78250 2008 2 f <w4> <minnesota> withholding biweekly dollars/cents
+] unit-test
+
+
+[ 138 69 ] [
+    24000 2008 2 f <w4> <federal> withholding biweekly dollars/cents
+] unit-test
+
+[ 754 22 ] [
+    78250 2008 2 f <w4> <federal> withholding biweekly dollars/cents
+] unit-test
--- 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
--- 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 )
--- a/extra/ui/gestures/gestures.factor
+++ b/extra/ui/gestures/gestures.factor
@ -54,7 +54,7 @@ TUPLE: zoom-in-action ;  C: <zoom-in-action> zoom-in-action
 TUPLE: zoom-out-action ; C: <zoom-out-action> zoom-out-action

 : generalize-gesture ( gesture -- newgesture )
-    tuple>array 1 head* >tuple ;
+    tuple>array butlast >tuple ;

 ! Modifiers
 SYMBOLS: C+ A+ M+ S+ ;
--- 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

--- 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 ;

--- a/extra/xml/backend/backend.factor
+++ 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
--- 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 ;
-: <no-entity> ( 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
-: <xml-string-error> ( 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 ;
-: <mismatched>
-    { 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: </" write mismatched-close print-name ">" print ;
-
-TUPLE: unclosed tags ;
-! <unclosed> is ( -- unclosed ), see presentation.factor
-M: unclosed error.
-    "Unclosed tags" print
-    "Tags: " print
-    unclosed-tags [ "  <" write print-name ">" print ] each ;
-
-TUPLE: bad-uri string ;
-: <bad-uri> ( 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 ;
-: <nonexist-ns> ( 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 )
-    { } unopened construct-parsing-error ;
-M: unopened error.
-    parsing-error.
-    "Closed an unopened tag" print ;
-
-TUPLE: not-yes/no text ;
-: <not-yes/no> ( 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
-: <extra-attrs> ( 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 ;
-: <bad-version>
-    { 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> notags
-M: notags error.
-    drop "XML document lacks a main tag" print ;
-
 TUPLE: multitags ;
 C: <multitags> multitags
-M: multitags error.
-    drop "XML document contains multiple main tags" print ;
-
-TUPLE: bad-prolog prolog ;
-: <bad-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 ;
-: <capitalized-prolog> ( 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 capitalized-prolog-name write "...?>" write
-    " instead of <?xml...?>" print ;
+M: multitags summary ( obj -- str )
+    drop "XML document contains multiple main tags" ;

 TUPLE: pre/post-content string pre? ;
 C: <pre/post-content> 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 ;
+: <no-entity> ( 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
+: <xml-string-error> ( 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>
+    \ 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: </" write close>> print-name ">" print
+    ] with-string-writer ;
+
+TUPLE: unclosed < parsing-error tags ;
+: <unclosed> ( -- 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 ;
+: <bad-uri> ( 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 ;
+: <nonexist-ns> ( 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 )
+    \ 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 ;
+: <not-yes/no> ( 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 ;
+: <extra-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>
+    \ 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> notags
+M: notags summary ( obj -- str )
+    drop "XML document lacks a main tag" ;
+
+TUPLE: bad-prolog < parsing-error prolog ;
+: <bad-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 ;
+: <capitalized-prolog> ( 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 name>> write "...?>" write
+        " instead of <?xml...?>" print
+    ] with-string-writer ;
+
+TUPLE: versionless-prolog < parsing-error ;
 : <versionless-prolog> ( -- 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 ;
 : <bad-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 ;
 : <bad-directive> ( 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
--- a/extra/xml/tests/errors.factor
+++ b/extra/xml/tests/errors.factor
@ -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" } "<x>&nbsp;</x>" xml-error-test
-T{ mismatched T{ parsing-error f 1 8 } T{ name f "" "x" "" } T{ name f "" "y" "" }
-} "<x></y>" xml-error-test
-T{ unclosed f V{ T{ name f "" "x" "" } } } "<x>" xml-error-test
-T{ nonexist-ns T{ parsing-error f 1 5 } "x" } "<x:y/>" xml-error-test
-T{ unopened T{ parsing-error f 1 5 } } "</x>" xml-error-test
-T{ not-yes/no T{ parsing-error f 1 41 } "maybe" } "<?xml version='1.0' standalone='maybe'?><x/>" xml-error-test
-T{ extra-attrs T{ parsing-error f 1 32 } V{ T{ name f "" "foo" f } }
-} "<?xml version='1.1' foo='bar'?><x/>" xml-error-test
-T{ bad-version T{ parsing-error f 1 28 } "5 million" } "<?xml version='5 million'?><x/>" xml-error-test
-T{ notags f } "" xml-error-test
-T{ multitags f } "<x/><y/>" xml-error-test
-T{ bad-prolog T{ parsing-error f 1 26 } T{ prolog f "1.0" "UTF-8" f }
-} "<x/><?xml version='1.0'?>" xml-error-test
-T{ capitalized-prolog T{ parsing-error f 1 6 } "XmL" } "<?XmL version='1.0'?><x/>"
-xml-error-test
-T{ pre/post-content f "x" t } "x<y/>" xml-error-test
-T{ versionless-prolog T{ parsing-error f 1 8 } } "<?xml?><x/>" xml-error-test
-T{ bad-instruction T{ parsing-error f 1 11 } T{ instruction f "xsl" }
-} "<x><?xsl?></x>" xml-error-test
-T{ bad-directive T{ parsing-error f 1 15 } T{ directive f "DOCTYPE" }
-} "<x/><!DOCTYPE>" xml-error-test
--- 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
--- 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
--- 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> ( -- unclosed )
-    xml-stack get rest-slice [ first opener-name ] map
-    { set-unclosed-tags } unclosed construct ;
-
 : add-child ( object -- )
    xml-stack get peek second push ;

--- 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 <file-reader> parse-mode
+        "resource:extra/xmode/modes/" prepend
+        utf8 <file-reader> parse-mode
    ] [
        "text" (load-mode)
    ] if* ;
--- a/extra/xmode/code2html/code2html.factor
+++ b/extra/xmode/code2html/code2html.factor
@ -20,8 +20,8 @@ IN: xmode.code2html

 : default-stylesheet ( -- )
    <style>
-        "extra/xmode/code2html/stylesheet.css"
-        resource-path utf8 file-contents write
+        "resource:extra/xmode/code2html/stylesheet.css"
+        utf8 file-contents write
    </style> ;

 : htmlize-stream ( path stream -- )
--- 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
--- 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