steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Slava Pestov 2008-05-07 00:40:17 -05:00
parent 732b84bcf9 0acbdcdcc6
commit 9fd7b12534
53 changed files with 365 additions and 314 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
core/classes/tuple/tuple.factor
View File

@ -102,7 +102,7 @@ ERROR: bad-superclass class ;
dup tuple-predicate-quot define-predicate ; dup tuple-predicate-quot define-predicate ;
: superclass-size ( class -- n ) : superclass-size ( class -- n )
superclasses 1 head-slice* superclasses butlast-slice
[ slot-names length ] map sum ; [ slot-names length ] map sum ;
: generate-tuple-slots ( class slots -- slot-specs ) : generate-tuple-slots ( class slots -- slot-specs )

2
core/debugger/debugger-docs.factor
View File

@ -1,7 +1,7 @@
USING: alien arrays generic generic.math help.markup help.syntax USING: alien arrays generic generic.math help.markup help.syntax
kernel math memory strings sbufs vectors io io.files classes kernel math memory strings sbufs vectors io io.files classes
help generic.standard continuations system debugger.private help generic.standard continuations system debugger.private
io.files.private ; io.files.private listener ;
IN: debugger IN: debugger
ARTICLE: "errors-assert" "Assertions" ARTICLE: "errors-assert" "Assertions"

2
core/inference/transforms/transforms.factor
View File

@ -32,7 +32,7 @@ IN: inference.transforms
drop [ no-case ] drop [ no-case ]
] [ ] [
dup peek quotation? [ dup peek quotation? [
dup peek swap 1 head* dup peek swap butlast
] [ ] [
[ no-case ] swap [ no-case ] swap
] if case>quot ] if case>quot

14
core/io/encodings/encodings-tests.factor
View File

@ -2,11 +2,8 @@ USING: io.files io.streams.string io
tools.test kernel io.encodings.ascii ; tools.test kernel io.encodings.ascii ;
IN: io.streams.encodings.tests 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 unit-test
: lines-test ( stream -- line1 line2 ) : lines-test ( stream -- line1 line2 )
@ -16,21 +13,24 @@ unit-test
"This is a line." "This is a line."
"This is another 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 ] unit-test
[ [
"This is a line." "This is a line."
"This is another 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 ] unit-test
[ [
"This is a line." "This is a line."
"This is another 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 ] unit-test
[ [

10
core/io/io-tests.factor
View File

@ -8,20 +8,17 @@ IN: io.tests
"foo" "io.tests" lookup "foo" "io.tests" lookup
] unit-test ] unit-test
: <resource-reader> ( resource -- stream )
resource-path latin1 <file-reader> ;
[ [
"This is a line.\rThis is another line.\r" "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 [ 500 read ] with-input-stream
] unit-test ] unit-test
[ [
255 255
] [ ] [
"core/io/test/binary.txt" <resource-reader> "resource:core/io/test/binary.txt" latin1 <file-reader>
[ read1 ] with-input-stream >fixnum [ read1 ] with-input-stream >fixnum
] unit-test ] 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 , "J" read-until 2array ,
"i" read-until 2array , "i" read-until 2array ,
"X" read-until 2array , "X" read-until 2array ,

2
core/prettyprint/prettyprint-tests.factor
View File

@ -114,7 +114,7 @@ unit-test
[ parse-fresh drop ] with-compilation-unit [ parse-fresh drop ] with-compilation-unit
[ [
"prettyprint.tests" lookup see "prettyprint.tests" lookup see
] with-string-writer "\n" split 1 head* ] with-string-writer "\n" split butlast
] keep = ] keep =
] with-scope ; ] with-scope ;

2
core/prettyprint/sections/sections.factor
View File

@ -284,7 +284,7 @@ M: colon unindent-first-line? drop t ;
! Long section layout algorithm ! Long section layout algorithm
: chop-break ( seq -- seq ) : 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: prev
SYMBOL: next SYMBOL: next

14
core/sequences/sequences-docs.factor
View File

@ -92,6 +92,7 @@ ARTICLE: "sequences-slices" "Subsequences and slices"
{ $subsection subseq } { $subsection subseq }
{ $subsection head } { $subsection head }
{ $subsection tail } { $subsection tail }
{ $subsection butlast }
{ $subsection rest } { $subsection rest }
{ $subsection head* } { $subsection head* }
{ $subsection tail* } { $subsection tail* }
@ -106,6 +107,7 @@ ARTICLE: "sequences-slices" "Subsequences and slices"
{ $subsection <slice> } { $subsection <slice> }
{ $subsection head-slice } { $subsection head-slice }
{ $subsection tail-slice } { $subsection tail-slice }
{ $subsection butlast-slice }
{ $subsection rest-slice } { $subsection rest-slice }
{ $subsection head-slice* } { $subsection head-slice* }
{ $subsection tail-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." } { $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." } ; { $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 HELP: rest-slice
{ $values { "seq" sequence } { "slice" "a 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." } { $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" } } { $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* HELP: head-slice*
{ $values { "seq" sequence } { "n" "a non-negative integer" } { "slice" "a 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." } { $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." } ; { $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 HELP: rest
{ $values { "seq" sequence } { "tailseq" "a new sequence" } } { $values { "seq" sequence } { "tailseq" "a new sequence" } }
{ $description "Outputs a new sequence consisting of the input sequence with the first item removed." } { $description "Outputs a new sequence consisting of the input sequence with the first item removed." }

8
core/sequences/sequences.factor
View File

@ -216,6 +216,8 @@ M: slice length dup slice-to swap slice-from - ;
: tail-slice* ( seq n -- slice ) from-end tail-slice ; : tail-slice* ( seq n -- slice ) from-end tail-slice ;
: butlast-slice ( seq -- slice ) 1 head-slice* ;
INSTANCE: slice virtual-sequence INSTANCE: slice virtual-sequence
! One element repeated many times ! One element repeated many times
@ -263,6 +265,8 @@ PRIVATE>
: tail* ( seq n -- tailseq ) from-end tail ; : tail* ( seq n -- tailseq ) from-end tail ;
: butlast ( seq -- headseq ) 1 head* ;
: copy ( src i dst -- ) : copy ( src i dst -- )
pick length >r 3dup check-copy spin 0 r> pick length >r 3dup check-copy spin 0 r>
(copy) drop ; inline (copy) drop ; inline
@ -671,13 +675,13 @@ PRIVATE>
[ rest ] [ first ] bi ; [ rest ] [ first ] bi ;
: unclip-last ( seq -- butfirst last ) : unclip-last ( seq -- butfirst last )
[ 1 head* ] [ peek ] bi ; [ butlast ] [ peek ] bi ;
: unclip-slice ( seq -- rest first ) : unclip-slice ( seq -- rest first )
[ rest-slice ] [ first ] bi ; [ rest-slice ] [ first ] bi ;
: unclip-last-slice ( seq -- butfirst last ) : unclip-last-slice ( seq -- butfirst last )
[ 1 head-slice* ] [ peek ] bi ; [ butlast-slice ] [ peek ] bi ;
: <flat-slice> ( seq -- slice ) : <flat-slice> ( seq -- slice )
dup slice? [ { } like ] when 0 over length rot <slice> ; dup slice? [ { } like ] when 0 over length rot <slice> ;

2
core/splitting/splitting.factor
View File

@ -104,7 +104,7 @@ M: sliced-clumps nth group@ <slice> ;
1array 1array
] [ ] [
"\n" split [ "\n" split [
1 head-slice* [ butlast-slice [
"\r" ?tail drop "\r" split "\r" ?tail drop "\r" split
] map ] map
] keep peek "\r" split suffix concat ] keep peek "\r" split suffix concat

2
extra/benchmark/knucleotide/knucleotide.factor
View File

@ -56,7 +56,7 @@ IN: benchmark.knucleotide
drop ; drop ;
: knucleotide ( -- ) : knucleotide ( -- )
"extra/benchmark/knucleotide/knucleotide-input.txt" resource-path "resource:extra/benchmark/knucleotide/knucleotide-input.txt"
ascii [ read-input ] with-file-reader ascii [ read-input ] with-file-reader
process-input ; process-input ;

5
extra/combinators/lib/lib.factor
View File

@ -169,3 +169,8 @@ MACRO: multikeep ( word out-indexes -- ... )
: generate ( generator predicate -- obj ) : generate ( generator predicate -- obj )
[ dup ] swap [ dup [ nip ] unless not ] 3compose [ dup ] swap [ dup [ nip ] unless not ] 3compose
swap [ ] do-while ; swap [ ] do-while ;
MACRO: predicates ( seq -- quot/f )
dup [ 1quotation [ drop ] prepend ] map
>r [ [ dup ] prepend ] map r> zip [ drop f ] suffix
[ cond ] curry ;

2
extra/help/lint/lint.factor
View File

@ -10,7 +10,7 @@ IN: help.lint
: check-example ( element -- ) : check-example ( element -- )
rest [ rest [
1 head* "\n" join 1vector butlast "\n" join 1vector
[ [
use [ clone ] change use [ clone ] change
[ eval>string ] with-datastack [ eval>string ] with-datastack

2
extra/html/parser/analyzer/analyzer.factor
View File

@ -99,7 +99,7 @@ IN: html.parser.analyzer
: find-between ( i/f tag/f vector -- vector ) : find-between ( i/f tag/f vector -- vector )
find-between* dup length 3 >= [ find-between* dup length 3 >= [
[ rest-slice 1 head-slice* ] keep like [ rest-slice butlast-slice ] keep like
] when ; ] when ;
: find-between-first ( string vector -- vector' ) : find-between-first ( string vector -- vector' )

2
extra/html/parser/utils/utils.factor
View File

@ -36,7 +36,7 @@ IN: html.parser.utils
dup quoted? [ quote ] unless ; dup quoted? [ quote ] unless ;
: unquote ( str -- newstr ) : unquote ( str -- newstr )
dup quoted? [ 1 head-slice* rest-slice >string ] when ; dup quoted? [ butlast-slice rest-slice >string ] when ;
: quote? ( ch -- ? ) "'\"" member? ; : quote? ( ch -- ? ) "'\"" member? ;

4
extra/http/http-tests.factor
View File

@ -166,7 +166,7 @@ test-db [
<dispatcher> <dispatcher>
add-quit-action add-quit-action
<dispatcher> <dispatcher>
"extra/http/test" resource-path <static> >>default "resource:extra/http/test" <static> >>default
"nested" add-responder "nested" add-responder
<action> <action>
[ "redirect-loop" f <standard-redirect> ] >>display [ "redirect-loop" f <standard-redirect> ] >>display
@ -178,7 +178,7 @@ test-db [
] unit-test ] unit-test
[ t ] [ [ 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 = "http://localhost:1237/nested/foo.html" http-get =
] unit-test ] unit-test

2
extra/icfp/2006/2006.factor
View File

@ -148,4 +148,4 @@ SYMBOL: open-arrays
init f exec-loop ; init f exec-loop ;
: run-sand ( -- ) : run-sand ( -- )
"extra/icfp/2006/sandmark.umz" resource-path run-prog ; "resource:extra/icfp/2006/sandmark.umz" run-prog ;

2
extra/inverse/inverse.factor
View File

@ -197,7 +197,7 @@ DEFER: _
\ prefix [ unclip ] define-inverse \ prefix [ unclip ] define-inverse
\ unclip [ prefix ] define-inverse \ unclip [ prefix ] define-inverse
\ suffix [ dup 1 head* swap peek ] define-inverse \ suffix [ dup butlast swap peek ] define-inverse
! Constructor inverse ! Constructor inverse
: deconstruct-pred ( class -- quot ) : deconstruct-pred ( class -- quot )

5
extra/io/encodings/8-bit/8-bit.factor
View File

@ -30,9 +30,8 @@ IN: io.encodings.8-bit
} ; } ;
: encoding-file ( file-name -- stream ) : encoding-file ( file-name -- stream )
"extra/io/encodings/8-bit/" ".TXT" "resource:extra/io/encodings/8-bit/" ".TXT"
swapd 3append resource-path swapd 3append ascii <file-reader> ;
ascii <file-reader> ;
: tail-if ( seq n -- newseq ) : tail-if ( seq n -- newseq )
2dup swap length <= [ tail ] [ drop ] if ; 2dup swap length <= [ tail ] [ drop ] if ;

14
extra/io/windows/nt/launcher/launcher-tests.factor
View File

@ -41,7 +41,7 @@ sequences parser assocs hashtables math continuations ;
] unit-test ] unit-test
[ ] [ [ ] [
"extra/io/windows/nt/launcher/test" resource-path [ "resource:extra/io/windows/nt/launcher/test" [
<process> <process>
vm "-script" "stderr.factor" 3array >>command vm "-script" "stderr.factor" 3array >>command
"out.txt" temp-file >>stdout "out.txt" temp-file >>stdout
@ -59,7 +59,7 @@ sequences parser assocs hashtables math continuations ;
] unit-test ] unit-test
[ ] [ [ ] [
"extra/io/windows/nt/launcher/test" resource-path [ "resource:extra/io/windows/nt/launcher/test" [
<process> <process>
vm "-script" "stderr.factor" 3array >>command vm "-script" "stderr.factor" 3array >>command
"out.txt" temp-file >>stdout "out.txt" temp-file >>stdout
@ -73,7 +73,7 @@ sequences parser assocs hashtables math continuations ;
] unit-test ] unit-test
[ "output" ] [ [ "output" ] [
"extra/io/windows/nt/launcher/test" resource-path [ "resource:extra/io/windows/nt/launcher/test" [
<process> <process>
vm "-script" "stderr.factor" 3array >>command vm "-script" "stderr.factor" 3array >>command
"err2.txt" temp-file >>stderr "err2.txt" temp-file >>stderr
@ -86,7 +86,7 @@ sequences parser assocs hashtables math continuations ;
] unit-test ] unit-test
[ t ] [ [ t ] [
"extra/io/windows/nt/launcher/test" resource-path [ "resource:extra/io/windows/nt/launcher/test" [
<process> <process>
vm "-script" "env.factor" 3array >>command vm "-script" "env.factor" 3array >>command
ascii <process-reader> contents ascii <process-reader> contents
@ -96,7 +96,7 @@ sequences parser assocs hashtables math continuations ;
] unit-test ] unit-test
[ t ] [ [ t ] [
"extra/io/windows/nt/launcher/test" resource-path [ "resource:extra/io/windows/nt/launcher/test" [
<process> <process>
vm "-script" "env.factor" 3array >>command vm "-script" "env.factor" 3array >>command
+replace-environment+ >>environment-mode +replace-environment+ >>environment-mode
@ -108,7 +108,7 @@ sequences parser assocs hashtables math continuations ;
] unit-test ] unit-test
[ "B" ] [ [ "B" ] [
"extra/io/windows/nt/launcher/test" resource-path [ "resource:extra/io/windows/nt/launcher/test" [
<process> <process>
vm "-script" "env.factor" 3array >>command vm "-script" "env.factor" 3array >>command
{ { "A" "B" } } >>environment { { "A" "B" } } >>environment
@ -119,7 +119,7 @@ sequences parser assocs hashtables math continuations ;
] unit-test ] unit-test
[ f ] [ [ f ] [
"extra/io/windows/nt/launcher/test" resource-path [ "resource:extra/io/windows/nt/launcher/test" [
<process> <process>
vm "-script" "env.factor" 3array >>command vm "-script" "env.factor" 3array >>command
{ { "HOME" "XXX" } } >>environment { { "HOME" "XXX" } } >>environment

2
extra/koszul/koszul.factor
View File

@ -184,7 +184,7 @@ DEFER: (d)
[ length ] keep [ (graded-ker/im-d) ] curry map ; [ length ] keep [ (graded-ker/im-d) ] curry map ;
: graded-betti ( generators -- seq ) : 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 ! Bi-graded for two-step complexes
: (bigraded-ker/im-d) ( u-deg z-deg bigraded-basis -- null/rank ) : (bigraded-ker/im-d) ( u-deg z-deg bigraded-basis -- null/rank )

2
extra/locals/locals.factor
View File

@ -101,7 +101,7 @@ UNION: special local quote local-word local-reader local-writer ;
] if ; ] if ;
: point-free-body ( quot args -- newquot ) : 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 ) : point-free-end ( quot args -- newquot )
over peek special? over peek special?

2
extra/mortar/mortar.factor
View File

@ -122,7 +122,7 @@ over class-class-methods assoc-stack call ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: send-message-next ( object message -- ) : 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 : <-~ scan parsed \ send-message-next parsed ; parsing

4
extra/multiline/multiline.factor
View File

@ -14,7 +14,7 @@ IN: multiline
] [ ";" unexpected-eof ] if* ; ] [ ";" unexpected-eof ] if* ;
: parse-here ( -- str ) : parse-here ( -- str )
[ (parse-here) ] "" make 1 head* [ (parse-here) ] "" make butlast
lexer get next-line ; lexer get next-line ;
: STRING: : STRING:
@ -34,7 +34,7 @@ IN: multiline
[ [
lexer get lexer-column swap (parse-multiline-string) lexer get lexer-column swap (parse-multiline-string)
lexer get set-lexer-column lexer get set-lexer-column
] "" make rest 1 head* ; ] "" make rest butlast ;
: <" : <"
"\">" parse-multiline-string parsed ; parsing "\">" parse-multiline-string parsed ; parsing

10
extra/openssl/openssl-tests.factor
View File

@ -27,7 +27,7 @@ math.parser openssl prettyprint sequences tools.test ;
[ ] [ ssl-v23 new-ctx ] unit-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' ! TODO: debug 'Memory protection fault at address 6c'
! get-ctx 1024 "char" malloc-array 1024 0 f password-cb set-default-passwd ! 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 [ ] [ get-ctx "password" ascii string>alien set-default-passwd-userdata ] unit-test
! Enter PEM pass phrase: password ! 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 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 verify-load-locations ] unit-test
[ ] [ get-ctx 1 set-verify-depth ] unit-test [ ] [ get-ctx 1 set-verify-depth ] unit-test
@ -47,7 +47,7 @@ verify-load-locations ] unit-test
! Load Diffie-Hellman parameters ! 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 [ ] [ get-bio f f f read-pem-dh-params ] unit-test
@ -131,7 +131,7 @@ verify-load-locations ] unit-test
! Dump errors to file ! 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 [ 6 ] [ get-bio "Hello\n" bio-print ] unit-test

6
extra/porter-stemmer/porter-stemmer-tests.factor
View File

@ -56,11 +56,9 @@ io.files io.encodings.utf8 ;
[ "hell" ] [ "hell" step5 "" like ] unit-test [ "hell" ] [ "hell" step5 "" like ] unit-test
[ "mate" ] [ "mate" 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 [ 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 [ 2array ] 2map [ first2 = not ] filter
] unit-test ] unit-test

12
extra/porter-stemmer/porter-stemmer.factor
View File

@ -66,8 +66,6 @@ USING: kernel math parser sequences combinators splitting ;
: r ( str oldsuffix newsuffix -- str ) : r ( str oldsuffix newsuffix -- str )
pick consonant-seq 0 > [ nip ] [ drop ] if append ; pick consonant-seq 0 > [ nip ] [ drop ] if append ;
: butlast ( seq -- seq ) 1 head-slice* ;
: step1a ( str -- newstr ) : step1a ( str -- newstr )
dup peek CHAR: s = [ dup peek CHAR: s = [
{ {
@ -95,7 +93,7 @@ USING: kernel math parser sequences combinators splitting ;
{ [ "iz" ?tail ] [ "ize" append ] } { [ "iz" ?tail ] [ "ize" append ] }
{ {
[ dup length 1- over double-consonant? ] [ dup length 1- over double-consonant? ]
[ dup "lsz" last-is? [ butlast ] unless ] [ dup "lsz" last-is? [ butlast-slice ] unless ]
} }
{ {
[ t ] [ t ]
@ -122,7 +120,7 @@ USING: kernel math parser sequences combinators splitting ;
} cond ; } cond ;
: step1c ( str -- newstr ) : step1c ( str -- newstr )
dup butlast stem-vowel? [ dup butlast-slice stem-vowel? [
"y" ?tail [ "i" append ] when "y" ?tail [ "i" append ] when
] when ; ] when ;
@ -198,18 +196,18 @@ USING: kernel math parser sequences combinators splitting ;
: remove-e? ( str -- ? ) : remove-e? ( str -- ? )
dup consonant-seq dup 1 > dup consonant-seq dup 1 >
[ 2drop t ] [ 2drop t ]
[ 1 = [ butlast cvc? not ] [ drop f ] if ] if ; [ 1 = [ butlast-slice cvc? not ] [ drop f ] if ] if ;
: remove-e ( str -- newstr ) : remove-e ( str -- newstr )
dup peek CHAR: e = [ dup peek CHAR: e = [
dup remove-e? [ butlast ] when dup remove-e? [ butlast-slice ] when
] when ; ] when ;
: ll->l ( str -- newstr ) : ll->l ( str -- newstr )
{ {
{ [ dup peek CHAR: l = not ] [ ] } { [ dup peek CHAR: l = not ] [ ] }
{ [ dup length 1- over double-consonant? not ] [ ] } { [ dup length 1- over double-consonant? not ] [ ] }
{ [ dup consonant-seq 1 > ] [ butlast ] } { [ dup consonant-seq 1 > ] [ butlast-slice ] }
[ ] [ ]
} cond ; } cond ;

2
extra/project-euler/002/002.factor
View File

@ -41,7 +41,7 @@ PRIVATE>
: fib-upto* ( n -- seq ) : fib-upto* ( n -- seq )
0 1 [ pick over >= ] [ tuck + dup ] [ ] unfold 3nip 0 1 [ pick over >= ] [ tuck + dup ] [ ] unfold 3nip
1 head-slice* { 0 1 } prepend ; butlast-slice { 0 1 } prepend ;
: euler002a ( -- answer ) : euler002a ( -- answer )
1000000 fib-upto* [ even? ] filter sum ; 1000000 fib-upto* [ even? ] filter sum ;

2
extra/project-euler/022/022.factor
View File

@ -28,7 +28,7 @@ IN: project-euler.022
<PRIVATE <PRIVATE
: source-022 ( -- seq ) : source-022 ( -- seq )
"extra/project-euler/022/names.txt" resource-path "resource:extra/project-euler/022/names.txt"
ascii file-contents [ quotable? ] filter "," split ; ascii file-contents [ quotable? ] filter "," split ;
: name-scores ( seq -- seq ) : name-scores ( seq -- seq )

2
extra/project-euler/042/042.factor
View File

@ -30,7 +30,7 @@ IN: project-euler.042
<PRIVATE <PRIVATE
: source-042 ( -- seq ) : source-042 ( -- seq )
"extra/project-euler/042/words.txt" resource-path "resource:extra/project-euler/042/words.txt"
ascii file-contents [ quotable? ] filter "," split ; ascii file-contents [ quotable? ] filter "," split ;
: (triangle-upto) ( limit n -- ) : (triangle-upto) ( limit n -- )

4
extra/project-euler/059/059.factor
View File

@ -52,7 +52,7 @@ IN: project-euler.059
<PRIVATE <PRIVATE
: source-059 ( -- seq ) : 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 ascii file-contents [ blank? ] right-trim "," split
[ string>number ] map ; [ string>number ] map ;
@ -78,7 +78,7 @@ INSTANCE: rollover immutable-sequence
frequency-analysis sort-values keys peek ; frequency-analysis sort-values keys peek ;
: crack-key ( seq key-length -- key ) : crack-key ( seq key-length -- key )
[ " " decrypt ] dip group 1 head-slice* [ " " decrypt ] dip group butlast-slice
flip [ most-frequent ] map ; flip [ most-frequent ] map ;
PRIVATE> PRIVATE>

2
extra/project-euler/067/067.factor
View File

@ -38,7 +38,7 @@ IN: project-euler.067
<PRIVATE <PRIVATE
: source-067 ( -- seq ) : 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 ; ascii file-lines [ " " split [ string>number ] map ] map ;
PRIVATE> PRIVATE>

2
extra/project-euler/079/079.factor
View File

@ -27,7 +27,7 @@ IN: project-euler.079
<PRIVATE <PRIVATE
: source-079 ( -- seq ) : 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 ) : >edges ( seq -- seq )
[ [

4
extra/rss/rss-tests.factor
View File

@ -22,7 +22,7 @@ IN: rss.tests
f f
} }
} }
} ] [ "extra/rss/rss1.xml" resource-path load-news-file ] unit-test } ] [ "resource:extra/rss/rss1.xml" load-news-file ] unit-test
[ T{ [ T{
feed feed
f 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 } } 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

20
extra/space-invaders/space-invaders.factor
View File

@ -45,21 +45,21 @@ TUPLE: space-invaders port1 port2i port2o port3o port4lo port4hi port5o bitmap s
: init-sound ( index cpu filename -- ) : init-sound ( index cpu filename -- )
swapd >r space-invaders-sounds nth AL_BUFFER r> 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-sounds ( cpu -- )
init-openal init-openal
[ 9 gen-sources swap set-space-invaders-sounds ] keep [ 9 gen-sources swap set-space-invaders-sounds ] keep
[ SOUND-SHOT "extra/space-invaders/resources/Shot.wav" init-sound ] keep [ SOUND-SHOT "resource:extra/space-invaders/resources/Shot.wav" init-sound ] keep
[ SOUND-UFO "extra/space-invaders/resources/Ufo.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 [ 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-BASE-HIT "resource:extra/space-invaders/resources/BaseHit.wav" init-sound ] keep
[ SOUND-INVADER-HIT "extra/space-invaders/resources/InvHit.wav" init-sound ] keep [ SOUND-INVADER-HIT "resource:extra/space-invaders/resources/InvHit.wav" init-sound ] keep
[ SOUND-WALK1 "extra/space-invaders/resources/Walk1.wav" init-sound ] keep [ SOUND-WALK1 "resource:extra/space-invaders/resources/Walk1.wav" init-sound ] keep
[ SOUND-WALK2 "extra/space-invaders/resources/Walk2.wav" init-sound ] keep [ SOUND-WALK2 "resource:extra/space-invaders/resources/Walk2.wav" init-sound ] keep
[ SOUND-WALK3 "extra/space-invaders/resources/Walk3.wav" init-sound ] keep [ SOUND-WALK3 "resource:extra/space-invaders/resources/Walk3.wav" init-sound ] keep
[ SOUND-WALK4 "extra/space-invaders/resources/Walk4.wav" init-sound ] keep [ SOUND-WALK4 "resource:extra/space-invaders/resources/Walk4.wav" init-sound ] keep
[ SOUND-UFO-HIT "extra/space-invaders/resources/UfoHit.wav" init-sound ] keep [ SOUND-UFO-HIT "resource:extra/space-invaders/resources/UfoHit.wav" init-sound ] keep
f swap set-space-invaders-looping? ; f swap set-space-invaders-looping? ;
: <space-invaders> ( -- cpu ) : <space-invaders> ( -- cpu )

115
extra/state-parser/state-parser.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2005, 2006 Daniel Ehrenberg ! Copyright (C) 2005, 2006 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: io io.streams.string kernel math namespaces sequences 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 IN: state-parser
! * Basic underlying words ! * Basic underlying words
@ -11,50 +12,56 @@ TUPLE: spot char line column next ;
C: <spot> spot C: <spot> spot
: get-char ( -- char ) spot get spot-char ; : get-char ( -- char ) spot get char>> ;
: set-char ( char -- ) spot get set-spot-char ; : set-char ( char -- ) spot get swap >>char drop ;
: get-line ( -- line ) spot get spot-line ; : get-line ( -- line ) spot get line>> ;
: set-line ( line -- ) spot get set-spot-line ; : set-line ( line -- ) spot get swap >>line drop ;
: get-column ( -- column ) spot get spot-column ; : get-column ( -- column ) spot get column>> ;
: set-column ( column -- ) spot get set-spot-column ; : set-column ( column -- ) spot get swap >>column drop ;
: get-next ( -- char ) spot get spot-next ; : get-next ( -- char ) spot get next>> ;
: set-next ( char -- ) spot get set-spot-next ; : set-next ( char -- ) spot get swap >>next drop ;
! * Errors ! * Errors
TUPLE: parsing-error line column ; TUPLE: parsing-error line column ;
: <parsing-error> ( -- parsing-error )
get-line get-column parsing-error boa ;
: construct-parsing-error ( ... slots class -- error ) : parsing-error ( class -- obj )
construct <parsing-error> over set-delegate ; inline new
get-line >>line
: parsing-error. ( parsing-error -- ) get-column >>column ;
M: parsing-error summary ( obj -- str )
[
"Parsing error" print "Parsing error" print
"Line: " write dup parsing-error-line . "Line: " write dup line>> .
"Column: " write parsing-error-column . ; "Column: " write column>> .
] with-string-writer ;
TUPLE: expected should-be was ; TUPLE: expected < parsing-error should-be was ;
: <expected> ( should-be was -- error ) : expected ( should-be was -- * )
{ set-expected-should-be set-expected-was } \ expected parsing-error
expected construct-parsing-error ; swap >>was
M: expected error. swap >>should-be throw ;
dup parsing-error. M: expected summary ( obj -- str )
"Token expected: " write dup expected-should-be print [
"Token present: " write expected-was print ; dup call-next-method write
"Token expected: " write dup should-be>> print
"Token present: " write was>> print
] with-string-writer ;
TUPLE: unexpected-end ; TUPLE: unexpected-end < parsing-error ;
: <unexpected-end> ( -- unexpected-end ) : unexpected-end \ unexpected-end parsing-error throw ;
{ } unexpected-end construct-parsing-error ; M: unexpected-end summary ( obj -- str )
M: unexpected-end error. [
parsing-error. call-next-method write
"File unexpectedly ended." print ; "File unexpectedly ended." print
] with-string-writer ;
TUPLE: missing-close ; TUPLE: missing-close < parsing-error ;
: <missing-close> ( -- missing-close ) : missing-close \ missing-close parsing-error throw ;
{ } missing-close construct-parsing-error ; M: missing-close summary ( obj -- str )
M: missing-close error. [
parsing-error. call-next-method write
"Missing closing token." print ; "Missing closing token." print
] with-string-writer ;
SYMBOL: prolog-data SYMBOL: prolog-data
@ -65,7 +72,8 @@ SYMBOL: prolog-data
[ 0 get-line 1+ set-line ] [ get-column 1+ ] if [ 0 get-line 1+ set-line ] [ get-column 1+ ] if
set-column ; set-column ;
: (next) ( -- char ) ! this normalizes \r\n and \r ! (next) normalizes \r\n and \r
: (next) ( -- char )
get-next read1 get-next read1
2dup swap CHAR: \r = [ 2dup swap CHAR: \r = [
CHAR: \n = CHAR: \n =
@ -75,10 +83,7 @@ SYMBOL: prolog-data
: next ( -- ) : next ( -- )
#! Increment spot. #! Increment spot.
get-char [ get-char [ unexpected-end ] unless (next) record ;
<unexpected-end> throw
] unless
(next) record ;
: next* ( -- ) : next* ( -- )
get-char [ (next) record ] when ; get-char [ (next) record ] when ;
@ -95,9 +100,9 @@ SYMBOL: prolog-data
#! Take the substring of a string starting at spot #! Take the substring of a string starting at spot
#! from code until the quotation given is true and #! from code until the quotation given is true and
#! advance spot to after the substring. #! advance spot to after the substring.
[ [ 10 <sbuf> [
dup slip swap dup [ get-char , ] unless '[ @ [ t ] [ get-char , push f ] if ] skip-until
] skip-until ] "" make nip ; inline ] keep >string ; inline
: take-rest ( -- string ) : take-rest ( -- string )
[ f ] take-until ; [ f ] take-until ;
@ -105,6 +110,20 @@ SYMBOL: prolog-data
: take-char ( ch -- string ) : take-char ( ch -- string )
[ dup get-char = ] take-until nip ; [ 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 ( -- ) : pass-blank ( -- )
#! Advance code past any whitespace, including newlines #! Advance code past any whitespace, including newlines
[ get-char blank? not ] skip-until ; [ get-char blank? not ] skip-until ;
@ -117,16 +136,16 @@ SYMBOL: prolog-data
dup length <circular-string> dup length <circular-string>
[ 2dup string-matches? ] take-until nip [ 2dup string-matches? ] take-until nip
dup length rot length 1- - head dup length rot length 1- - head
get-char [ <missing-close> throw ] unless next ; get-char [ missing-close ] unless next ;
: expect ( ch -- ) : expect ( ch -- )
get-char 2dup = [ 2drop ] [ get-char 2dup = [ 2drop ] [
>r 1string r> 1string <expected> throw >r 1string r> 1string expected
] if next ; ] if next ;
: expect-string ( string -- ) : expect-string ( string -- )
dup [ drop get-char next ] map 2dup = dup [ drop get-char next ] map 2dup =
[ 2drop ] [ <expected> throw ] if ; [ 2drop ] [ expected ] if ;
: init-parser ( -- ) : init-parser ( -- )
0 1 0 f <spot> spot set 0 1 0 f <spot> spot set

2
extra/tangle/tangle.factor
View File

@ -65,7 +65,7 @@ TUPLE: tangle-dispatcher < dispatcher tangle ;
: <tangle-dispatcher> ( tangle -- dispatcher ) : <tangle-dispatcher> ( tangle -- dispatcher )
tangle-dispatcher new-dispatcher swap >>tangle tangle-dispatcher new-dispatcher swap >>tangle
<path-responder> >>default <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 <node-responder> "node" add-responder
<action> [ all-node-ids <json-response> ] >>display "all" add-responder ; <action> [ all-node-ids <json-response> ] >>display "all" add-responder ;

18
extra/taxes/taxes-tests.factor
View File

@ -96,3 +96,21 @@ IN: taxes.tests
1000000 2008 3 t <w4> <minnesota> net 1000000 2008 3 t <w4> <minnesota> net
dollars/cents dollars/cents
] unit-test ] 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

4
extra/tools/deploy/backend/backend.factor
View File

@ -63,11 +63,11 @@ DEFER: ?make-staging-image
dup empty? [ dup empty? [
"-i=" my-boot-image-name append , "-i=" my-boot-image-name append ,
] [ ] [
dup 1 head* ?make-staging-image dup butlast ?make-staging-image
"-resource-path=" "" resource-path append , "-resource-path=" "" resource-path append ,
"-i=" over 1 head* staging-image-name append , "-i=" over butlast staging-image-name append ,
"-run=tools.deploy.restage" , "-run=tools.deploy.restage" ,
] if ] if

2
extra/tuple-syntax/tuple-syntax.factor
View File

@ -7,7 +7,7 @@ IN: tuple-syntax
: parse-slot-writer ( tuple -- slot# ) : parse-slot-writer ( tuple -- slot# )
scan dup "}" = [ 2drop f ] [ scan dup "}" = [ 2drop f ] [
1 head* swap object-slots slot-named slot-spec-offset butlast swap object-slots slot-named slot-spec-offset
] if ; ] if ;
: parse-slots ( accum tuple -- accum tuple ) : parse-slots ( accum tuple -- accum tuple )

2
extra/ui/gestures/gestures.factor
View File

@ -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 TUPLE: zoom-out-action ; C: <zoom-out-action> zoom-out-action
: generalize-gesture ( gesture -- newgesture ) : generalize-gesture ( gesture -- newgesture )
tuple>array 1 head* >tuple ; tuple>array butlast >tuple ;
! Modifiers ! Modifiers
SYMBOLS: C+ A+ M+ S+ ; SYMBOLS: C+ A+ M+ S+ ;

2
extra/unicode/breaks/breaks.factor
View File

@ -30,7 +30,7 @@ CATEGORY: grapheme-control Zl Zp Cc Cf ;
concat [ dup ] H{ } map>assoc ; concat [ dup ] H{ } map>assoc ;
: other-extend-lines ( -- lines ) : other-extend-lines ( -- lines )
"extra/unicode/PropList.txt" resource-path ascii file-lines ; "resource:extra/unicode/PropList.txt" ascii file-lines ;
VALUE: other-extend VALUE: other-extend

4
extra/unicode/data/data.factor
View File

@ -14,7 +14,7 @@ IN: unicode.data
ascii file-lines [ ";" split ] map ; ascii file-lines [ ";" split ] map ;
: load-data ( -- data ) : load-data ( -- data )
"extra/unicode/UnicodeData.txt" resource-path data ; "resource:extra/unicode/UnicodeData.txt" data ;
: (process-data) ( index data -- newdata ) : (process-data) ( index data -- newdata )
[ [ nth ] keep first swap 2array ] with map [ [ nth ] keep first swap 2array ] with map
@ -120,7 +120,7 @@ VALUE: special-casing
! Special casing data ! Special casing data
: load-special-casing ( -- special-casing ) : load-special-casing ( -- special-casing )
"extra/unicode/SpecialCasing.txt" resource-path data "resource:extra/unicode/SpecialCasing.txt" data
[ length 5 = ] filter [ length 5 = ] filter
[ [ set-code-point ] each ] H{ } make-assoc ; [ [ set-code-point ] each ] H{ } make-assoc ;

6
extra/xml/backend/backend.factor Normal file
View File

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

282
extra/xml/errors/errors.factor
View File

@ -1,150 +1,178 @@
! Copyright (C) 2005, 2006 Daniel Ehrenberg ! Copyright (C) 2005, 2006 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: xml.data xml.writer kernel generic io prettyprint math 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 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 ; TUPLE: multitags ;
C: <multitags> multitags C: <multitags> multitags
M: multitags error. M: multitags summary ( obj -- str )
drop "XML document contains multiple main tags" print ; drop "XML document contains multiple main tags" ;
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 ;
TUPLE: pre/post-content string pre? ; TUPLE: pre/post-content string pre? ;
C: <pre/post-content> pre/post-content C: <pre/post-content> pre/post-content
M: pre/post-content error. M: pre/post-content summary ( obj -- str )
[
"The text string:" print "The text string:" print
dup pre/post-content-string . dup string>> .
"was used " write "was used " write
pre/post-content-pre? "before" "after" ? write pre?>> "before" "after" ? write
" the main tag." print ; " 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> ( -- versionless-prolog )
{ } versionless-prolog construct-parsing-error ; \ versionless-prolog parsing-error ;
M: versionless-prolog error. M: versionless-prolog summary ( obj -- str )
parsing-error. [
"XML prolog lacks a version declaration" print ; 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 ) : <bad-instruction> ( instruction -- bad-instruction )
{ set-bad-instruction-inst } \ bad-instruction parsing-error swap >>instruction ;
bad-instruction construct-parsing-error ; M: bad-instruction summary ( obj -- str )
M: bad-instruction error. [
dup parsing-error. dup call-next-method write
"Misplaced processor instruction:" print "Misplaced processor instruction:" print
bad-instruction-inst write-item nl ; instruction>> write-item nl
] with-string-writer ;
TUPLE: bad-directive dir ; TUPLE: bad-directive < parsing-error dir ;
: <bad-directive> ( directive -- bad-directive ) : <bad-directive> ( directive -- bad-directive )
{ set-bad-directive-dir } \ bad-directive parsing-error swap >>dir ;
bad-directive construct-parsing-error ; M: bad-directive summary ( obj -- str )
M: bad-directive error. [
dup parsing-error. dup call-next-method write
"Misplaced directive:" print "Misplaced directive:" print
bad-directive-dir write-item nl ; bad-directive-dir write-item nl
] with-string-writer ;
UNION: xml-parse-error multitags notags extra-attrs nonexist-ns UNION: xml-parse-error multitags notags extra-attrs nonexist-ns
not-yes/no unclosed mismatched xml-string-error expected no-entity not-yes/no unclosed mismatched xml-string-error expected no-entity

28
extra/xml/tests/errors.factor
View File

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

2
extra/xml/tests/soap.factor
View File

@ -10,6 +10,6 @@ IN: xml.tests
[ assemble-data ] map ; [ assemble-data ] map ;
[ "http://www.foxnews.com/oreilly/" ] [ [ "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 parse-result first first
] unit-test ] unit-test

2
extra/xml/tests/test.factor
View File

@ -9,7 +9,7 @@ USING: kernel xml tools.test io namespaces sequences xml.errors xml.entities
\ read-xml must-infer \ read-xml must-infer
SYMBOL: xml-file 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 [ file>xml ] with-html-entities xml-file set ] unit-test
[ "1.0" ] [ xml-file get xml-prolog prolog-version ] unit-test [ "1.0" ] [ xml-file get xml-prolog prolog-version ] unit-test
[ f ] [ xml-file get xml-prolog prolog-standalone ] unit-test [ f ] [ xml-file get xml-prolog prolog-standalone ] unit-test

10
extra/xml/xml.factor
View File

@ -3,18 +3,12 @@
USING: io io.streams.string io.files kernel math namespaces USING: io io.streams.string io.files kernel math namespaces
prettyprint sequences arrays generic strings vectors prettyprint sequences arrays generic strings vectors
xml.char-classes xml.data xml.errors xml.tokenize xml.writer 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 IN: xml
! -- Overall parser with data tree ! -- 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 -- ) : add-child ( object -- )
xml-stack get peek second push ; xml-stack get peek second push ;

6
extra/xmode/catalog/catalog.factor
View File

@ -24,7 +24,7 @@ TAGS>
] keep ; ] keep ;
: load-catalog ( -- modes ) : load-catalog ( -- modes )
"extra/xmode/modes/catalog" resource-path "resource:extra/xmode/modes/catalog"
file>xml parse-modes-tag ; file>xml parse-modes-tag ;
: modes ( -- assoc ) : modes ( -- assoc )
@ -38,8 +38,8 @@ TAGS>
MEMO: (load-mode) ( name -- rule-sets ) MEMO: (load-mode) ( name -- rule-sets )
modes at [ modes at [
mode-file mode-file
"extra/xmode/modes/" prepend "resource:extra/xmode/modes/" prepend
resource-path utf8 <file-reader> parse-mode utf8 <file-reader> parse-mode
] [ ] [
"text" (load-mode) "text" (load-mode)
] if* ; ] if* ;

4
extra/xmode/code2html/code2html.factor
View File

@ -20,8 +20,8 @@ IN: xmode.code2html
: default-stylesheet ( -- ) : default-stylesheet ( -- )
<style> <style>
"extra/xmode/code2html/stylesheet.css" "resource:extra/xmode/code2html/stylesheet.css"
resource-path utf8 file-contents write utf8 file-contents write
</style> ; </style> ;
: htmlize-stream ( path stream -- ) : htmlize-stream ( path stream -- )

4
extra/xmode/utilities/utilities-tests.factor
View File

@ -48,6 +48,6 @@ TAGS>
"This is a great company" "This is a great company"
} }
] [ ] [
"extra/xmode/utilities/test.xml" "resource:extra/xmode/utilities/test.xml"
resource-path file>xml parse-company-tag file>xml parse-company-tag
] unit-test ] unit-test

2
extra/yahoo/yahoo-tests.factor
View File

@ -6,6 +6,6 @@ USING: tools.test yahoo kernel io.files xml sequences ;
"Official Foo Fighters" "Official Foo Fighters"
"http://www.foofighters.com/" "http://www.foofighters.com/"
"Official site with news, tour dates, discography, store, community, and more." "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 [ "http://search.yahooapis.com/WebSearchService/V1/webSearch?appid=Factor-search&query=hi&results=1" ] [ "hi" 1 query ] unit-test