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

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

db4
John Benediktsson 2009-01-16 21:39:11 -08:00
parent f29f625787 ca2f01e0d0
commit ee9d90e72f
86 changed files with 1322 additions and 745 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Factor.app/Contents/Info.plist
View File

@ -32,7 +32,7 @@
<key>CFBundlePackageType</key>
<string>APPL</string>
<key>NSHumanReadableCopyright</key>
<string>Copyright © 2003-2008, Slava Pestov and friends</string>
<string>Copyright © 2003-2009, Slava Pestov and friends</string>
<key>NSServices</key>
<array>
<dict>

44
basis/alien/remote-control/remote-control-tests.factor Normal file
View File

@ -0,0 +1,44 @@
USING: interpolate multiline
io io.directories io.encodings.ascii io.files
io.files.temp io.launcher io.streams.string kernel locals system
tools.test sequences ;
IN: alien.remote-control.tests
: compile-file ( contents -- )
"test.c" ascii set-file-contents
{ "gcc" "-I../" "-L.." "-lfactor" "test.c" }
os macosx? cpu x86.64? and [ "-m64" suffix ] when
try-process ;
: run-test ( -- line )
os windows? "temp/a.exe" "temp/a.out" ?
ascii [ readln ] with-process-reader ;
:: test-embedding ( code -- line )
image :> image
[
I[
#include <vm/master.h>
#include <stdio.h>
#include <stdbool.h>
int main(int argc, char **argv)
{
F_PARAMETERS p;
default_parameters(&p);
p.image_path = STRING_LITERAL("${image}");
init_factor(&p);
start_embedded_factor(&p);
${code}
printf("Done.\n");
return 0;
}
]I
] with-string-writer
"resource:temp" [ compile-file ] with-directory
"resource:" [ run-test ] with-directory ;
! [ "Done." ] [ "" test-embedding ] unit-test
! [ "Done." ] [ "factor_yield();" test-embedding ] unit-test

204
basis/checksums/md5/md5.factor
View File

@ -2,9 +2,9 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel io io.binary io.files io.streams.byte-array math
math.functions math.parser namespaces splitting grouping strings
sequences byte-arrays locals sequences.private
sequences byte-arrays locals sequences.private macros fry
io.encodings.binary math.bitwise checksums
checksums.common checksums.stream ;
checksums.common checksums.stream combinators ;
IN: checksums.md5
! See http://www.faqs.org/rfcs/rfc1321.html
@ -29,7 +29,7 @@ SYMBOLS: a b c d old-a old-b old-c old-d ;
old-c c update-old-new
old-d d update-old-new ;
:: (ABCD) ( x s i k func a b c d -- )
:: (ABCD) ( x a b c d k s i func -- )
#! a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s)
a [
b get c get d get func call w+
@ -39,11 +39,6 @@ SYMBOLS: a b c d old-a old-b old-c old-d ;
b get w+
] change ; inline
: ABCD a b c d (ABCD) ; inline
: BCDA b c d a (ABCD) ; inline
: CDAB c d a b (ABCD) ; inline
: DABC d a b c (ABCD) ; inline
: F ( X Y Z -- FXYZ )
#! F(X,Y,Z) = XY v not(X) Z
pick bitnot bitand [ bitand ] [ bitor ] bi* ;
@ -60,104 +55,113 @@ SYMBOLS: a b c d old-a old-b old-c old-d ;
#! I(X,Y,Z) = Y xor (X v not(Z))
rot swap bitnot bitor bitxor ;
: S11 7 ; inline
: S12 12 ; inline
: S13 17 ; inline
: S14 22 ; inline
: S21 5 ; inline
: S22 9 ; inline
: S23 14 ; inline
: S24 20 ; inline
: S31 4 ; inline
: S32 11 ; inline
: S33 16 ; inline
: S34 23 ; inline
: S41 6 ; inline
: S42 10 ; inline
: S43 15 ; inline
: S44 21 ; inline
CONSTANT: S11 7
CONSTANT: S12 12
CONSTANT: S13 17
CONSTANT: S14 22
CONSTANT: S21 5
CONSTANT: S22 9
CONSTANT: S23 14
CONSTANT: S24 20
CONSTANT: S31 4
CONSTANT: S32 11
CONSTANT: S33 16
CONSTANT: S34 23
CONSTANT: S41 6
CONSTANT: S42 10
CONSTANT: S43 15
CONSTANT: S44 21
: (process-md5-block-F) ( block -- block )
dup S11 1 0 [ F ] ABCD
dup S12 2 1 [ F ] DABC
dup S13 3 2 [ F ] CDAB
dup S14 4 3 [ F ] BCDA
dup S11 5 4 [ F ] ABCD
dup S12 6 5 [ F ] DABC
dup S13 7 6 [ F ] CDAB
dup S14 8 7 [ F ] BCDA
dup S11 9 8 [ F ] ABCD
dup S12 10 9 [ F ] DABC
dup S13 11 10 [ F ] CDAB
dup S14 12 11 [ F ] BCDA
dup S11 13 12 [ F ] ABCD
dup S12 14 13 [ F ] DABC
dup S13 15 14 [ F ] CDAB
dup S14 16 15 [ F ] BCDA ;
MACRO: with-md5-round ( ops func -- )
'[ [ _ (ABCD) ] compose ] map '[ _ cleave ] ;
: (process-md5-block-G) ( block -- block )
dup S21 17 1 [ G ] ABCD
dup S22 18 6 [ G ] DABC
dup S23 19 11 [ G ] CDAB
dup S24 20 0 [ G ] BCDA
dup S21 21 5 [ G ] ABCD
dup S22 22 10 [ G ] DABC
dup S23 23 15 [ G ] CDAB
dup S24 24 4 [ G ] BCDA
dup S21 25 9 [ G ] ABCD
dup S22 26 14 [ G ] DABC
dup S23 27 3 [ G ] CDAB
dup S24 28 8 [ G ] BCDA
dup S21 29 13 [ G ] ABCD
dup S22 30 2 [ G ] DABC
dup S23 31 7 [ G ] CDAB
dup S24 32 12 [ G ] BCDA ;
: (process-md5-block-F) ( block -- )
{
[ a b c d 0 S11 1 ]
[ d a b c 1 S12 2 ]
[ c d a b 2 S13 3 ]
[ b c d a 3 S14 4 ]
[ a b c d 4 S11 5 ]
[ d a b c 5 S12 6 ]
[ c d a b 6 S13 7 ]
[ b c d a 7 S14 8 ]
[ a b c d 8 S11 9 ]
[ d a b c 9 S12 10 ]
[ c d a b 10 S13 11 ]
[ b c d a 11 S14 12 ]
[ a b c d 12 S11 13 ]
[ d a b c 13 S12 14 ]
[ c d a b 14 S13 15 ]
[ b c d a 15 S14 16 ]
} [ F ] with-md5-round ;
: (process-md5-block-H) ( block -- block )
dup S31 33 5 [ H ] ABCD
dup S32 34 8 [ H ] DABC
dup S33 35 11 [ H ] CDAB
dup S34 36 14 [ H ] BCDA
dup S31 37 1 [ H ] ABCD
dup S32 38 4 [ H ] DABC
dup S33 39 7 [ H ] CDAB
dup S34 40 10 [ H ] BCDA
dup S31 41 13 [ H ] ABCD
dup S32 42 0 [ H ] DABC
dup S33 43 3 [ H ] CDAB
dup S34 44 6 [ H ] BCDA
dup S31 45 9 [ H ] ABCD
dup S32 46 12 [ H ] DABC
dup S33 47 15 [ H ] CDAB
dup S34 48 2 [ H ] BCDA ;
: (process-md5-block-G) ( block -- )
{
[ a b c d 1 S21 17 ]
[ d a b c 6 S22 18 ]
[ c d a b 11 S23 19 ]
[ b c d a 0 S24 20 ]
[ a b c d 5 S21 21 ]
[ d a b c 10 S22 22 ]
[ c d a b 15 S23 23 ]
[ b c d a 4 S24 24 ]
[ a b c d 9 S21 25 ]
[ d a b c 14 S22 26 ]
[ c d a b 3 S23 27 ]
[ b c d a 8 S24 28 ]
[ a b c d 13 S21 29 ]
[ d a b c 2 S22 30 ]
[ c d a b 7 S23 31 ]
[ b c d a 12 S24 32 ]
} [ G ] with-md5-round ;
: (process-md5-block-I) ( block -- block )
dup S41 49 0 [ I ] ABCD
dup S42 50 7 [ I ] DABC
dup S43 51 14 [ I ] CDAB
dup S44 52 5 [ I ] BCDA
dup S41 53 12 [ I ] ABCD
dup S42 54 3 [ I ] DABC
dup S43 55 10 [ I ] CDAB
dup S44 56 1 [ I ] BCDA
dup S41 57 8 [ I ] ABCD
dup S42 58 15 [ I ] DABC
dup S43 59 6 [ I ] CDAB
dup S44 60 13 [ I ] BCDA
dup S41 61 4 [ I ] ABCD
dup S42 62 11 [ I ] DABC
dup S43 63 2 [ I ] CDAB
dup S44 64 9 [ I ] BCDA ;
: (process-md5-block-H) ( block -- )
{
[ a b c d 5 S31 33 ]
[ d a b c 8 S32 34 ]
[ c d a b 11 S33 35 ]
[ b c d a 14 S34 36 ]
[ a b c d 1 S31 37 ]
[ d a b c 4 S32 38 ]
[ c d a b 7 S33 39 ]
[ b c d a 10 S34 40 ]
[ a b c d 13 S31 41 ]
[ d a b c 0 S32 42 ]
[ c d a b 3 S33 43 ]
[ b c d a 6 S34 44 ]
[ a b c d 9 S31 45 ]
[ d a b c 12 S32 46 ]
[ c d a b 15 S33 47 ]
[ b c d a 2 S34 48 ]
} [ H ] with-md5-round ;
: (process-md5-block-I) ( block -- )
{
[ a b c d 0 S41 49 ]
[ d a b c 7 S42 50 ]
[ c d a b 14 S43 51 ]
[ b c d a 5 S44 52 ]
[ a b c d 12 S41 53 ]
[ d a b c 3 S42 54 ]
[ c d a b 10 S43 55 ]
[ b c d a 1 S44 56 ]
[ a b c d 8 S41 57 ]
[ d a b c 15 S42 58 ]
[ c d a b 6 S43 59 ]
[ b c d a 13 S44 60 ]
[ a b c d 4 S41 61 ]
[ d a b c 11 S42 62 ]
[ c d a b 2 S43 63 ]
[ b c d a 9 S44 64 ]
} [ I ] with-md5-round ;
: (process-md5-block) ( block -- )
4 <groups> [ le> ] map
(process-md5-block-F)
(process-md5-block-G)
(process-md5-block-H)
(process-md5-block-I)
drop
4 <groups> [ le> ] map {
[ (process-md5-block-F) ]
[ (process-md5-block-G) ]
[ (process-md5-block-H) ]
[ (process-md5-block-I) ]
} cleave
update-md ;

2
basis/compiler/cfg/linear-scan/linear-scan-tests.factor
View File

@ -1,7 +1,7 @@
IN: compiler.cfg.linear-scan.tests
USING: tools.test random sorting sequences sets hashtables assocs
kernel fry arrays splitting namespaces math accessors vectors
math.order
math.order grouping
cpu.architecture
compiler.cfg.instructions
compiler.cfg.registers

2
basis/compiler/tree/checker/checker.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: sequences kernel sets namespaces accessors assocs
arrays combinators continuations columns math vectors
stack-checker.branches
grouping stack-checker.branches
compiler.tree
compiler.tree.def-use
compiler.tree.combinators ;

2
basis/compiler/tree/escape-analysis/branches/branches.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces sequences sets fry columns
stack-checker.branches
grouping stack-checker.branches
compiler.tree
compiler.tree.propagation.branches
compiler.tree.escape-analysis.nodes

2
basis/compiler/tree/propagation/copy/copy.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces sequences assocs math kernel accessors fry
combinators sets locals columns
combinators sets locals columns grouping
stack-checker.branches
compiler.tree
compiler.tree.def-use

1
basis/editors/editpadlite/editpadlite.factor
View File

@ -6,6 +6,7 @@ IN: editors.editpadlite
: editpadlite-path ( -- path )
\ editpadlite-path get-global [
"JGsoft" t [ >lower "editpadlite.exe" tail? ] find-in-program-files
[ "editpadlite.exe" ] unless*
] unless* ;
: editpadlite ( file line -- )

1
basis/editors/editpadpro/editpadpro.factor
View File

@ -6,6 +6,7 @@ IN: editors.editpadpro
: editpadpro-path ( -- path )
\ editpadpro-path get-global [
"JGsoft" t [ >lower "editpadpro.exe" tail? ] find-in-program-files
[ "editpadpro.exe" ] unless*
] unless* ;
: editpadpro ( file line -- )

1
basis/editors/editplus/editplus.factor
View File

@ -6,6 +6,7 @@ IN: editors.editplus
: editplus-path ( -- path )
\ editplus-path get-global [
"EditPlus 2" t [ "editplus.exe" tail? ] find-in-program-files
[ "editplus.exe" ] unless*
] unless* ;
: editplus ( file line -- )

1
basis/editors/emeditor/emeditor.factor
View File

@ -6,6 +6,7 @@ IN: editors.emeditor
: emeditor-path ( -- path )
\ emeditor-path get-global [
"EmEditor" t [ "EmEditor.exe" tail? ] find-in-program-files
[ "EmEditor.exe" ] unless*
] unless* ;
: emeditor ( file line -- )

1
basis/editors/etexteditor/etexteditor.factor
View File

@ -7,6 +7,7 @@ IN: editors.etexteditor
: etexteditor-path ( -- str )
\ etexteditor-path get-global [
"e" t [ "e.exe" tail? ] find-in-program-files
[ "e" ] unless*
] unless* ;
: etexteditor ( file line -- )

1
basis/editors/gvim/windows/windows.factor
View File

@ -6,4 +6,5 @@ IN: editors.gvim.windows
M: windows gvim-path
\ gvim-path get-global [
"vim" t [ "gvim.exe" tail? ] find-in-program-files
[ "gvim.exe" ] unless*
] unless* ;

1
basis/editors/notepad/authors.txt Executable file
View File

@ -0,0 +1 @@
Doug Coleman

18
basis/editors/notepad/notepad.factor Executable file
View File

@ -0,0 +1,18 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: editors io.launcher kernel io.directories.search.windows
math.parser namespaces sequences io.files arrays windows.shell32
io.directories.search ;
IN: editors.notepad
: notepad-path ( -- path )
\ notepad-path get [
windows-directory t
[ "notepad.exe" tail? ] find-file
] unless* ;
: notepad ( file line -- )
drop notepad-path swap 2array run-detached drop ;
[ notepad ] edit-hook set-global

1
basis/editors/notepad2/notepad2.factor
View File

@ -5,6 +5,7 @@ IN: editors.notepad2
: notepad2-path ( -- path )
\ notepad2-path get-global [
windows-directory "system32\\notepad.exe" append-path
[ "notepad.exe" ] unless*
] unless* ;
: notepad2 ( file line -- )

1
basis/editors/notepadpp/notepadpp.factor
View File

@ -5,6 +5,7 @@ IN: editors.notepadpp
: notepadpp-path ( -- path )
\ notepadpp-path get-global [
"notepad++" t [ "notepad++.exe" tail? ] find-in-program-files
[ "notepad++.exe" ] unless*
] unless* ;
: notepadpp ( file line -- )

6
basis/editors/scite/scite.factor
View File

@ -9,6 +9,12 @@ IN: editors.scite
\ scite-path get-global [
"Scintilla Text Editor" t
[ >lower "scite.exe" tail? ] find-in-program-files
[
"SciTE Source Code Editor" t
[ >lower "scite.exe" tail? ] find-in-program-files
] unless*
[ "scite.exe" ] unless*
] unless* ;
: scite-command ( file line -- cmd )

1
basis/editors/ted-notepad/ted-notepad.factor
View File

@ -5,6 +5,7 @@ IN: editors.ted-notepad
: ted-notepad-path ( -- path )
\ ted-notepad-path get-global [
"TED Notepad" t [ "TedNPad.exe" tail? ] find-in-program-files
[ "TedNPad.exe" ] unless*
] unless* ;
: ted-notepad ( file line -- )

1
basis/editors/textpad/textpad.factor
View File

@ -6,6 +6,7 @@ IN: editors.textpad
: textpad-path ( -- path )
\ textpad-path get-global [
"TextPad 5" t [ "TextPad.exe" tail? ] find-in-program-files
[ "TextPad.exe" ] unless*
] unless* ;
: textpad ( file line -- )

1
basis/editors/ultraedit/ultraedit.factor
View File

@ -5,6 +5,7 @@ IN: editors.ultraedit
: ultraedit-path ( -- path )
\ ultraedit-path get-global [
"IDM Computer Solutions" t [ "uedit32.exe" tail? ] find-in-program-files
[ "uedit32.exe" ] unless*
] unless* ;
: ultraedit ( file line -- )

27
basis/grouping/grouping-docs.factor
View File

@ -22,7 +22,12 @@ ARTICLE: "grouping" "Groups and clumps"
{ "With clumps, collecting the first element of each subsequence but the last one, together with the last subseqence, yields the original sequence:"
{ $unchecked-example "dup n clumps unclip-last [ [ first ] map ] dip append sequence= ." "t" }
}
} ;
}
"A combinator built using clumps:"
{ $subsection monotonic? }
"Testing how elements are related:"
{ $subsection all-eq? }
{ $subsection all-equal? } ;
ABOUT: "grouping"
@ -123,3 +128,23 @@ HELP: <sliced-clumps>
{ <clumps> <groups> } related-words
{ <sliced-clumps> <sliced-groups> } related-words
HELP: monotonic?
{ $values { "seq" sequence } { "quot" { $quotation "( elt elt -- ? )" } } { "?" "a boolean" } }
{ $description "Applies the relation to successive pairs of elements in the sequence, testing for a truth value. The relation should be a transitive relation, such as a total order or an equality relation." }
{ $examples
"Testing if a sequence is non-decreasing:"
{ $example "USING: grouping math prettyprint ;" "{ 1 1 2 } [ <= ] monotonic? ." "t" }
"Testing if a sequence is decreasing:"
{ $example "USING: grouping math prettyprint ;" "{ 9 8 6 7 } [ < ] monotonic? ." "f" }
} ;
HELP: all-equal?
{ $values { "seq" sequence } { "?" "a boolean" } }
{ $description "Tests if all elements in the sequence are equal. Yields true with an empty sequence." } ;
HELP: all-eq?
{ $values { "seq" sequence } { "?" "a boolean" } }
{ $description "Tests if all elements in the sequence are the same identical object. Yields true with an empty sequence." } ;
{ monotonic? all-eq? all-equal? } related-words

11
basis/grouping/grouping-tests.factor
View File

@ -1,4 +1,5 @@
USING: grouping tools.test kernel sequences arrays ;
USING: grouping tools.test kernel sequences arrays
math ;
IN: grouping.tests
[ { 1 2 3 } 0 group ] must-fail
@ -12,3 +13,11 @@ IN: grouping.tests
] unit-test
[ { { 1 2 } { 2 3 } } ] [ { 1 2 3 } 2 <sliced-clumps> [ >array ] map ] unit-test
[ f ] [ [ { } { } "Hello" ] all-equal? ] unit-test
[ f ] [ [ { 2 } { } { } ] all-equal? ] unit-test
[ t ] [ [ ] all-equal? ] unit-test
[ t ] [ [ 1234 ] all-equal? ] unit-test
[ f ] [ [ 1.0 1 1 ] all-equal? ] unit-test
[ t ] [ { 1 2 3 4 } [ < ] monotonic? ] unit-test
[ f ] [ { 1 2 3 4 } [ > ] monotonic? ] unit-test

16
basis/grouping/grouping.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.order strings arrays vectors sequences
sequences.private accessors ;
@ -87,3 +87,17 @@ INSTANCE: sliced-clumps slice-chunking
: group ( seq n -- array ) <groups> { } like ;
: clump ( seq n -- array ) <clumps> { } like ;
: monotonic? ( seq quot -- ? )
over length 2 < [ 2drop t ] [
over length 2 = [
[ first2-unsafe ] dip call
] [
[ 2 <sliced-clumps> ] dip
[ first2-unsafe ] prepose all?
] if
] if ; inline
: all-equal? ( seq -- ? ) [ = ] monotonic? ;
: all-eq? ( seq -- ? ) [ eq? ] monotonic? ;

24
basis/help/lint/lint.factor
View File

@ -6,7 +6,7 @@ io io.streams.string prettyprint definitions arrays vectors
combinators combinators.short-circuit splitting debugger
hashtables sorting effects vocabs vocabs.loader assocs editors
continuations classes.predicate macros math sets eval
vocabs.parser words.symbol ;
vocabs.parser words.symbol values ;
IN: help.lint
: check-example ( element -- )
@ -42,15 +42,25 @@ IN: help.lint
$error-description
} swap '[ _ elements empty? not ] contains? ;
: don't-check-word? ( word -- ? )
{
[ macro? ]
[ symbol? ]
[ value-word? ]
[ parsing-word? ]
[ "declared-effect" word-prop not ]
} 1|| ;
: check-values ( word element -- )
{
[ drop { [ symbol? ] [ macro? ] [ parsing-word? ] } 1|| ]
[ drop "declared-effect" word-prop not ]
[ nip contains-funky-elements? ]
[
[ effect-values >array ]
[ extract-values >array ]
bi* =
[ don't-check-word? ]
[ contains-funky-elements? ]
bi* or
] [
[ effect-values ]
[ extract-values ]
bi* sequence=
]
} 2|| [ "$values don't match stack effect" throw ] unless ;

2
basis/io/directories/directories-docs.factor
View File

@ -6,7 +6,7 @@ HELP: cwd
{ $values { "path" "a pathname string" } }
{ $description "Outputs the current working directory of the Factor process." }
{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." }
{ $notes "User code should use " { $link with-directory } " or " { $link set-current-directory } " instead." } ;
{ $notes "User code should use the value of the " { $link current-directory } " variable instead." } ;
HELP: cd
{ $values { "path" "a pathname string" } }

6
basis/io/directories/search/search-docs.factor
View File

@ -32,21 +32,21 @@ HELP: find-file
HELP: find-in-directories
{ $values
{ "directories" "a sequence of pathnames" } { "bfs?" "a boolean, breadth-first or depth-first" } { "quot" quotation }
{ "path'" "a pathname string" }
{ "path'/f" "a pathname string or f" }
}
{ $description "Finds the first file in the input directories matching the predicate quotation in a breadth-first or depth-first traversal." } ;
HELP: find-all-files
{ $values
{ "path" "a pathname string" } { "bfs?" "a boolean, breadth-first or depth-first" } { "quot" quotation }
{ "paths" "a sequence of pathname strings" }
{ "paths/f" "a sequence of pathname strings or f" }
}
{ $description "Finds all files in the input directory matching the predicate quotation in a breadth-first or depth-first traversal." } ;
HELP: find-all-in-directories
{ $values
{ "directories" "a sequence of directory paths" } { "bfs?" "a boolean, breadth-first or depth-first" } { "quot" quotation }
{ "paths" "a sequence of pathname strings" }
{ "paths/f" "a sequence of pathname strings or f" }
}
{ $description "Finds all files in the input directories matching the predicate quotation in a breadth-first or depth-first traversal." } ;

18
basis/io/directories/search/search.factor
View File

@ -46,17 +46,21 @@ PRIVATE>
[ ] accumulator [ each-file ] dip ;
: find-file ( path bfs? quot: ( obj -- ? ) -- path/f )
[ <directory-iterator> ] dip
[ keep and ] curry iterate-directory ; inline
'[
_ _ _ [ <directory-iterator> ] dip
[ keep and ] curry iterate-directory
] [ drop f ] recover ; inline
: find-all-files ( path bfs? quot: ( obj -- ? ) -- paths )
[ <directory-iterator> ] dip
pusher [ [ f ] compose iterate-directory drop ] dip ; inline
: find-all-files ( path bfs? quot: ( obj -- ? ) -- paths/f )
'[
_ _ _ [ <directory-iterator> ] dip
pusher [ [ f ] compose iterate-directory drop ] dip
] [ drop f ] recover ; inline
: find-in-directories ( directories bfs? quot: ( obj -- ? ) -- path' )
: find-in-directories ( directories bfs? quot: ( obj -- ? ) -- path'/f )
'[ _ _ find-file ] attempt-all ;
: find-all-in-directories ( directories bfs? quot: ( obj -- ? ) -- paths )
: find-all-in-directories ( directories bfs? quot: ( obj -- ? ) -- paths/f )
'[ _ _ find-all-files ] map concat ;
os windows? [ "io.directories.search.windows" require ] when

2
basis/io/directories/search/windows/windows.factor
View File

@ -5,7 +5,7 @@ io.directories.search ;
IN: io.directories.search.windows
: program-files-directories ( -- array )
program-files program-files-x86 2array ; inline
program-files program-files-x86 2array harvest ; inline
: find-in-program-files ( base-directory bfs? quot -- path )
[

3
basis/io/files/unix/unix-tests.factor
View File

@ -1,7 +1,8 @@
USING: tools.test io.files io.files.temp io.pathnames
io.directories io.files.info io.files.info.unix continuations
kernel io.files.unix math.bitwise calendar accessors
math.functions math unix.users unix.groups arrays sequences ;
math.functions math unix.users unix.groups arrays sequences
grouping ;
IN: io.files.unix.tests
[ "/usr/libexec/" ] [ "/usr/libexec/awk/" parent-directory ] unit-test

35
basis/io/sockets/sockets-docs.factor
View File

@ -3,11 +3,20 @@ strings byte-arrays continuations destructors quotations ;
IN: io.sockets
ARTICLE: "network-addressing" "Address specifiers"
"The networking words are quite general and work with " { $emphasis "address specifiers" } " rather than concrete concepts such as host names. There are four types of address specifiers:"
"The networking words are quite general and work with " { $emphasis "address specifiers" } " rather than concrete concepts such as host names. There are four types of address specifiers."
$nl
"Unix domain sockets:"
{ $subsection local }
{ $subsection <local> }
"Internet host name/port number pairs; the host name is resolved to an IPv4 or IPv6 address using the operating system's resolver:"
{ $subsection inet }
{ $subsection <inet> }
"IPv4 addresses, with no host name resolution:"
{ $subsection inet4 }
{ $subsection <inet4> }
"IPv6 addresses, with no host name resolution:"
{ $subsection inet6 }
{ $subsection <inet6> }
"While the " { $link inet } " addressing specifier is capable of performing name lookups when passed to " { $link <client> } ", sometimes it is necessary to look up a host name without making a connection:"
{ $subsection resolve-host } ;
@ -73,34 +82,42 @@ HELP: inet
"This address specifier is only supported by " { $link <client> } ", which calls " { $link resolve-host } " to obtain a list of IP addresses associated with the host name, and attempts a connection to each one in turn until one succeeds. Other network words do not accept this address specifier, and " { $link resolve-host } " must be called directly; it is then up to the application to pick the correct address from the (possibly several) addresses associated to the host name."
}
{ $examples
{ $code "\"www.apple.com\" \"http\" <inet>" }
{ $code "\"localhost\" 8080 <inet>" }
{ $code "\"www.apple.com\" 80 <inet>" }
} ;
HELP: <inet>
{ $values { "host" "a host name" } { "port" "a port number" } { "inet" inet } }
{ $description "Creates a new " { $link inet } " address specifier." } ;
HELP: inet4
{ $class-description "IPv4 address/port number specifier for TCP/IP and UDP/IP connections. The " { $snippet "host" } " and " { $snippet "port" } " slots hold the IPv4 address and port number, respectively. New instances are created by calling " { $link <inet4> } "." }
{ $notes
"Most applications do not operate on IPv4 addresses directly, and instead should use " { $link resolve-host } " to look up the address associated to a host name. Also, try to support IPv6 where possible."
}
{ $notes "Most applications do not operate on IPv4 addresses directly, and instead should use the " { $link inet } " address specifier, or call " { $link resolve-host } "." }
{ $examples
{ $code "\"127.0.0.1\" 8080 <inet4>" }
} ;
HELP: <inet4>
{ $values { "host" "an IPv4 address" } { "port" "a port number" } { "inet4" inet4 } }
{ $description "Creates a new " { $link inet4 } " address specifier." } ;
HELP: inet6
{ $class-description "IPv6 address/port number specifier for TCP/IP and UDP/IP connections. The " { $snippet "host" } " and " { $snippet "port" } " slots hold the IPv6 address and port number, respectively. New instances are created by calling " { $link <inet6> } "." }
{ $notes
"Most applications do not operate on IPv6 addresses directly, and instead should use " { $link resolve-host } " to look up the address associated to a host name." }
{ $notes "Most applications do not operate on IPv6 addresses directly, and instead should use the " { $link inet } " address specifier, or call " { $link resolve-host } "." }
{ $examples
{ $code "\"::1\" 8080 <inet6>" }
} ;
HELP: <inet6>
{ $values { "host" "an IPv6 address" } { "port" "a port number" } { "inet6" inet6 } }
{ $description "Creates a new " { $link inet6 } " address specifier." } ;
HELP: <client>
{ $values { "remote" "an address specifier" } { "encoding" "an encding descriptor" } { "stream" "a bidirectional stream" } { "local" "an address specifier" } }
{ $description "Opens a network connection and outputs a bidirectional stream using the given encoding, together with the local address the socket was bound to." }
{ $errors "Throws an error if the connection cannot be established." }
{ $notes "The " { $link with-client } " word is easier to use in most situations." }
{ $examples
{ $code "\"www.apple.com\" \"http\" <inet> utf8 <client>" }
{ $code "\"www.apple.com\" 80 <inet> utf8 <client>" }
} ;
HELP: with-client

6
basis/io/sockets/sockets-tests.factor
View File

@ -33,6 +33,9 @@ concurrency.promises threads io.streams.string ;
[ B{ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 } ]
[ "::1" T{ inet6 } inet-pton ] unit-test
[ B{ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 } ]
[ "::100" T{ inet6 } inet-pton ] unit-test
[ B{ 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 2 } ]
[ "1::2" T{ inet6 } inet-pton ] unit-test
@ -45,6 +48,9 @@ concurrency.promises threads io.streams.string ;
[ "1:2:0:0:0:0:3:4" ]
[ B{ 0 1 0 2 0 0 0 0 0 0 0 0 0 3 0 4 } T{ inet6 } inet-ntop ] unit-test
[ "2001:6f8:37a:5:0:0:0:1" ]
[ "2001:6f8:37a:5::1" T{ inet6 } [ inet-pton ] [ inet-ntop ] bi ] unit-test
[ t ] [ "localhost" 80 <inet> resolve-host length 1 >= ] unit-test
! Smoke-test UDP

2
basis/io/sockets/sockets.factor
View File

@ -109,7 +109,7 @@ M: invalid-inet6 summary drop "Invalid IPv6 address" ;
[ f ] [
":" split [
hex> [ "Component not a number" throw ] unless*
] B{ } map-as
] { } map-as
] if-empty ;
: pad-inet6 ( string1 string2 -- seq )

7
basis/pack/pack-tests.factor
View File

@ -46,3 +46,10 @@ pack strings tools.test ;
[ f ] [ "" [ read-c-string ] with-string-reader ] unit-test
[ 5 ] [ "FRAM\0\u000005\0\0\0\0\0\0\0" [ read-c-string drop read-u64 ] with-string-reader ] unit-test
[ 9 ] [ "iic" packed-length ] unit-test
[ "iii" read-packed-le ] must-infer
[ "iii" read-packed-be ] must-infer
[ "iii" read-packed-native ] must-infer
[ "iii" unpack-le ] must-infer
[ "iii" unpack-be ] must-infer
[ "iii" unpack-native ] must-infer

117
basis/pack/pack.factor
View File

@ -1,7 +1,9 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays assocs byte-arrays io
io.binary io.streams.string kernel math math.parser namespaces
make parser prettyprint quotations sequences strings vectors
words macros math.functions math.bitwise ;
words macros math.functions math.bitwise fry ;
IN: pack
SYMBOL: big-endian
@ -9,6 +11,13 @@ SYMBOL: big-endian
: big-endian? ( -- ? )
1 <int> *char zero? ;
<PRIVATE
: set-big-endian ( -- )
big-endian? big-endian set ; inline
PRIVATE>
: >endian ( obj n -- str )
big-endian get [ >be ] [ >le ] if ; inline
@ -39,6 +48,8 @@ M: string b, ( n string -- ) heap-size b, ;
: double, ( n -- ) double>bits 8 b, ;
: c-string, ( str -- ) % 0 u8, ;
<PRIVATE
: (>128-ber) ( n -- )
dup 0 > [
[ HEX: 7f bitand HEX: 80 bitor , ] keep -7 shift
@ -47,6 +58,8 @@ M: string b, ( n string -- ) heap-size b, ;
drop
] if ;
PRIVATE>
: >128-ber ( n -- str )
[
[ HEX: 7f bitand , ] keep -7 shift
@ -70,7 +83,7 @@ M: string b, ( n string -- ) heap-size b, ;
: read-s32 ( -- n ) 4 read-signed ;
: read-u32 ( -- n ) 4 read-unsigned ;
: read-s64 ( -- n ) 8 read-signed ;
: read-u64 ( -- n ) 8 read-signed ;
: read-u64 ( -- n ) 8 read-unsigned ;
: read-s128 ( -- n ) 16 read-signed ;
: read-u128 ( -- n ) 16 read-unsigned ;
@ -81,7 +94,7 @@ M: string b, ( n string -- ) heap-size b, ;
8 read endian> bits>double ;
: read-c-string ( -- str/f )
"\0" read-until [ drop f ] unless ;
"\0" read-until swap and ;
: read-c-string* ( n -- str/f )
read [ zero? ] trim-right [ f ] when-empty ;
@ -94,7 +107,9 @@ M: string b, ( n string -- ) heap-size b, ;
: read-128-ber ( -- n )
0 (read-128-ber) ;
: pack-table ( -- hash )
<PRIVATE
CONSTANT: pack-table
H{
{ CHAR: c s8, }
{ CHAR: C u8, }
@ -110,9 +125,9 @@ M: string b, ( n string -- ) heap-size b, ;
{ CHAR: F float, }
{ CHAR: d double, }
{ CHAR: D double, }
} ;
}
: unpack-table ( -- hash )
CONSTANT: unpack-table
H{
{ CHAR: c read-s8 }
{ CHAR: C read-u8 }
@ -128,47 +143,79 @@ M: string b, ( n string -- ) heap-size b, ;
{ CHAR: F read-float }
{ CHAR: d read-double }
{ CHAR: D read-double }
} ;
}
MACRO: (pack) ( seq str -- quot )
[
[
[
swap , pack-table at ,
] 2each
] [ ] make 1quotation %
[ B{ } make ] %
] [ ] make ;
CONSTANT: packed-length-table
H{
{ CHAR: c 1 }
{ CHAR: C 1 }
{ CHAR: s 2 }
{ CHAR: S 2 }
{ CHAR: t 3 }
{ CHAR: T 3 }
{ CHAR: i 4 }
{ CHAR: I 4 }
{ CHAR: q 8 }
{ CHAR: Q 8 }
{ CHAR: f 4 }
{ CHAR: F 4 }
{ CHAR: d 8 }
{ CHAR: D 8 }
}
MACRO: pack ( seq str -- quot )
[ pack-table at 1quotation '[ _ @ ] ] [ ] 2map-as concat
'[ _ B{ } make ] ;
PRIVATE>
: pack-native ( seq str -- seq )
[
big-endian? big-endian set (pack)
] with-scope ;
[ set-big-endian pack ] with-scope ; inline
: pack-be ( seq str -- seq )
[ big-endian on (pack) ] with-scope ;
[ big-endian on pack ] with-scope ; inline
: pack-le ( seq str -- seq )
[ big-endian off (pack) ] with-scope ;
[ big-endian off pack ] with-scope ; inline
<PRIVATE
MACRO: (unpack) ( str -- quot )
[
[
[ unpack-table at , \ , , ] each
] [ ] make
1quotation [ { } make ] append
1quotation %
\ with-string-reader ,
] [ ] make ;
MACRO: unpack ( str -- quot )
[ unpack-table at 1quotation '[ @ , ] ] { } map-as concat
'[ [ _ { } make ] with-string-reader ] ;
PRIVATE>
: unpack-native ( seq str -- seq )
[
big-endian? big-endian set (unpack)
] with-scope ;
[ set-big-endian unpack ] with-scope ; inline
: unpack-be ( seq str -- seq )
[ big-endian on (unpack) ] with-scope ;
[ big-endian on unpack ] with-scope ; inline
: unpack-le ( seq str -- seq )
[ big-endian off (unpack) ] with-scope ;
[ big-endian off unpack ] with-scope ; inline
: packed-length ( str -- n )
[ packed-length-table at ] sigma ;
ERROR: packed-read-fail str bytes ;
<PRIVATE
: read-packed-bytes ( str -- bytes )
dup packed-length [ read dup length ] keep =
[ nip ] [ packed-read-fail ] if ; inline
PRIVATE>
: read-packed ( str quot -- seq )
[ read-packed-bytes ] swap bi ; inline
: read-packed-le ( str -- seq )
[ unpack-le ] read-packed ; inline
: read-packed-be ( str -- seq )
[ unpack-be ] read-packed ; inline
: read-packed-native ( str -- seq )
[ unpack-native ] read-packed ; inline

13
basis/roman/roman.factor
View File

@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs kernel math math.order math.vectors
namespaces make quotations sequences splitting.monotonic
sequences.private strings unicode.case lexer parser ;
sequences.private strings unicode.case lexer parser
grouping ;
IN: roman
<PRIVATE
@ -39,16 +40,14 @@ ERROR: roman-range-error n ;
PRIVATE>
: >roman ( n -- str )
dup roman-range-check [
(>roman)
] "" make ;
dup roman-range-check
[ (>roman) ] "" make ;
: >ROMAN ( n -- str ) >roman >upper ;
: roman> ( str -- n )
>lower [ roman<= ] monotonic-split [
(roman>)
] map sum ;
>lower [ roman<= ] monotonic-split
[ (roman>) ] sigma ;
<PRIVATE

2
basis/stack-checker/branches/branches.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry vectors sequences assocs math accessors kernel
combinators quotations namespaces stack-checker.state
combinators quotations namespaces grouping stack-checker.state
stack-checker.backend stack-checker.errors stack-checker.visitor
stack-checker.values stack-checker.recursive-state ;
IN: stack-checker.branches

2
basis/syndication/syndication.factor
View File

@ -3,7 +3,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: xml.utilities kernel assocs xml.generator math.order
strings sequences xml.data xml.writer
io.streams.string combinators xml xml.entities io.files io
io.streams.string combinators xml xml.entities.html io.files io
http.client namespaces make xml.generator hashtables
calendar.format accessors continuations urls present ;
IN: syndication

14
basis/unicode/breaks/breaks.factor
View File

@ -61,7 +61,7 @@ SYMBOL: table
: eval-seq ( seq -- seq ) [ dup word? [ execute ] when ] map ;
: (set-table) ( class1 class2 val -- )
-rot table get nth [ swap or ] change-nth ;
[ table get nth ] dip '[ _ or ] change-nth ;
: set-table ( classes1 classes2 val -- )
[ [ eval-seq ] bi@ ] dip
@ -199,8 +199,8 @@ to: word-table
: walk-down ( str i -- j )
dupd (walk-down) [ 1- (walk-down) ] [ drop f ] if* ;
: word-break? ( table-entry i str -- ? )
spin {
: word-break? ( str i table-entry -- ? )
{
{ t [ 2drop f ] }
{ f [ 2drop t ] }
{ check-letter-after
@ -214,10 +214,10 @@ to: word-table
} case ;
:: word-break-next ( old-class new-char i str -- next-class ? )
new-char dup format/extended?
[ drop old-class dup { 1 2 3 } member? ] [
word-break-prop old-class over word-table-nth
i str word-break?
new-char format/extended?
[ old-class dup { 1 2 3 } member? ] [
new-char word-break-prop old-class over word-table-nth
[ str i ] dip word-break?
] if ;
PRIVATE>

16
basis/values/values.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2008 Daniel Ehrenberg.
! Copyright (C) 2008, 2009 Daniel Ehrenberg, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel parser words sequences quotations ;
USING: accessors kernel parser words sequences quotations
combinators.short-circuit definitions ;
IN: values
! Mutating literals in word definitions is not really allowed,
@ -22,12 +23,23 @@ TUPLE: value-holder < identity-tuple obj ;
PRIVATE>
PREDICATE: value-word < word
def>> {
[ length 2 = ]
[ first value-holder? ]
[ second \ obj>> = ]
} 1&& ;
: VALUE:
CREATE-WORD
dup t "no-def-strip" set-word-prop
T{ value-holder } clone [ obj>> ] curry
(( -- value )) define-declared ; parsing
M: value-word definer drop \ VALUE: f ;
M: value-word definition drop f ;
: set-value ( value word -- )
def>> first (>>obj) ;

9
basis/windows/shell32/shell32.factor
View File

@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings alien.syntax
combinators io.encodings.utf16n io.files io.pathnames kernel
windows windows.com windows.com.syntax windows.ole32
windows.user32 ;
windows windows.com windows.com.syntax windows.user32
windows.ole32 ;
IN: windows.shell32
CONSTANT: CSIDL_DESKTOP HEX: 00
@ -88,13 +88,10 @@ ALIAS: ShellExecute ShellExecuteW
: open-in-explorer ( dir -- )
f "open" rot (normalize-path) f f SW_SHOWNORMAL ShellExecute drop ;
: shell32-error ( n -- )
ole32-error ; inline
: shell32-directory ( n -- str )
f swap f SHGFP_TYPE_DEFAULT
MAX_UNICODE_PATH "ushort" <c-array>
[ SHGetFolderPath shell32-error ] keep utf16n alien>string ;
[ SHGetFolderPath drop ] keep utf16n alien>string ;
: desktop ( -- str )
CSIDL_DESKTOPDIRECTORY shell32-directory ;

261
basis/xml/entities/entities.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2005, 2006 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces make kernel assocs sequences fry ;
USING: namespaces make kernel assocs sequences fry values
io.files io.encodings.binary ;
IN: xml.entities
: entities-out
@ -36,265 +37,7 @@ IN: xml.entities
{ "quot" CHAR: " }
} ;
: html-entities
#! generated from:
#! http://www.w3.org/TR/REC-html40/sgml/entities.html
H{
{ "nbsp" 160 }
{ "iexcl" 161 }
{ "cent" 162 }
{ "pound" 163 }
{ "curren" 164 }
{ "yen" 165 }
{ "brvbar" 166 }
{ "sect" 167 }
{ "uml" 168 }
{ "copy" 169 }
{ "ordf" 170 }
{ "laquo" 171 }
{ "not" 172 }
{ "shy" 173 }
{ "reg" 174 }
{ "macr" 175 }
{ "deg" 176 }
{ "plusmn" 177 }
{ "sup2" 178 }
{ "sup3" 179 }
{ "acute" 180 }
{ "micro" 181 }
{ "para" 182 }
{ "middot" 183 }
{ "cedil" 184 }
{ "sup1" 185 }
{ "ordm" 186 }
{ "raquo" 187 }
{ "frac14" 188 }
{ "frac12" 189 }
{ "frac34" 190 }
{ "iquest" 191 }
{ "Agrave" 192 }
{ "Aacute" 193 }
{ "Acirc" 194 }
{ "Atilde" 195 }
{ "Auml" 196 }
{ "Aring" 197 }
{ "AElig" 198 }
{ "Ccedil" 199 }
{ "Egrave" 200 }
{ "Eacute" 201 }
{ "Ecirc" 202 }
{ "Euml" 203 }
{ "Igrave" 204 }
{ "Iacute" 205 }
{ "Icirc" 206 }
{ "Iuml" 207 }
{ "ETH" 208 }
{ "Ntilde" 209 }
{ "Ograve" 210 }
{ "Oacute" 211 }
{ "Ocirc" 212 }
{ "Otilde" 213 }
{ "Ouml" 214 }
{ "times" 215 }
{ "Oslash" 216 }
{ "Ugrave" 217 }
{ "Uacute" 218 }
{ "Ucirc" 219 }
{ "Uuml" 220 }
{ "Yacute" 221 }
{ "THORN" 222 }
{ "szlig" 223 }
{ "agrave" 224 }
{ "aacute" 225 }
{ "acirc" 226 }
{ "atilde" 227 }
{ "auml" 228 }
{ "aring" 229 }
{ "aelig" 230 }
{ "ccedil" 231 }
{ "egrave" 232 }
{ "eacute" 233 }
{ "ecirc" 234 }
{ "euml" 235 }
{ "igrave" 236 }
{ "iacute" 237 }
{ "icirc" 238 }
{ "iuml" 239 }
{ "eth" 240 }
{ "ntilde" 241 }
{ "ograve" 242 }
{ "oacute" 243 }
{ "ocirc" 244 }
{ "otilde" 245 }
{ "ouml" 246 }
{ "divide" 247 }
{ "oslash" 248 }
{ "ugrave" 249 }
{ "uacute" 250 }
{ "ucirc" 251 }
{ "uuml" 252 }
{ "yacute" 253 }
{ "thorn" 254 }
{ "yuml" 255 }
{ "fnof" 402 }
{ "Alpha" 913 }
{ "Beta" 914 }
{ "Gamma" 915 }
{ "Delta" 916 }
{ "Epsilon" 917 }
{ "Zeta" 918 }
{ "Eta" 919 }
{ "Theta" 920 }
{ "Iota" 921 }
{ "Kappa" 922 }
{ "Lambda" 923 }
{ "Mu" 924 }
{ "Nu" 925 }
{ "Xi" 926 }
{ "Omicron" 927 }
{ "Pi" 928 }
{ "Rho" 929 }
{ "Sigma" 931 }
{ "Tau" 932 }
{ "Upsilon" 933 }
{ "Phi" 934 }
{ "Chi" 935 }
{ "Psi" 936 }
{ "Omega" 937 }
{ "alpha" 945 }
{ "beta" 946 }
{ "gamma" 947 }
{ "delta" 948 }
{ "epsilon" 949 }
{ "zeta" 950 }
{ "eta" 951 }
{ "theta" 952 }
{ "iota" 953 }
{ "kappa" 954 }
{ "lambda" 955 }
{ "mu" 956 }
{ "nu" 957 }
{ "xi" 958 }
{ "omicron" 959 }
{ "pi" 960 }
{ "rho" 961 }
{ "sigmaf" 962 }
{ "sigma" 963 }
{ "tau" 964 }
{ "upsilon" 965 }
{ "phi" 966 }
{ "chi" 967 }
{ "psi" 968 }
{ "omega" 969 }
{ "thetasym" 977 }
{ "upsih" 978 }
{ "piv" 982 }
{ "bull" 8226 }
{ "hellip" 8230 }
{ "prime" 8242 }
{ "Prime" 8243 }
{ "oline" 8254 }
{ "frasl" 8260 }
{ "weierp" 8472 }
{ "image" 8465 }
{ "real" 8476 }
{ "trade" 8482 }
{ "alefsym" 8501 }
{ "larr" 8592 }
{ "uarr" 8593 }
{ "rarr" 8594 }
{ "darr" 8595 }
{ "harr" 8596 }
{ "crarr" 8629 }
{ "lArr" 8656 }
{ "uArr" 8657 }
{ "rArr" 8658 }
{ "dArr" 8659 }
{ "hArr" 8660 }
{ "forall" 8704 }
{ "part" 8706 }
{ "exist" 8707 }
{ "empty" 8709 }
{ "nabla" 8711 }
{ "isin" 8712 }
{ "notin" 8713 }
{ "ni" 8715 }
{ "prod" 8719 }
{ "sum" 8721 }
{ "minus" 8722 }
{ "lowast" 8727 }
{ "radic" 8730 }
{ "prop" 8733 }
{ "infin" 8734 }
{ "ang" 8736 }
{ "and" 8743 }
{ "or" 8744 }
{ "cap" 8745 }
{ "cup" 8746 }
{ "int" 8747 }
{ "there4" 8756 }
{ "sim" 8764 }
{ "cong" 8773 }
{ "asymp" 8776 }
{ "ne" 8800 }
{ "equiv" 8801 }
{ "le" 8804 }
{ "ge" 8805 }
{ "sub" 8834 }
{ "sup" 8835 }
{ "nsub" 8836 }
{ "sube" 8838 }
{ "supe" 8839 }
{ "oplus" 8853 }
{ "otimes" 8855 }
{ "perp" 8869 }
{ "sdot" 8901 }
{ "lceil" 8968 }
{ "rceil" 8969 }
{ "lfloor" 8970 }
{ "rfloor" 8971 }
{ "lang" 9001 }
{ "rang" 9002 }
{ "loz" 9674 }
{ "spades" 9824 }
{ "clubs" 9827 }
{ "hearts" 9829 }
{ "diams" 9830 }
{ "OElig" 338 }
{ "oelig" 339 }
{ "Scaron" 352 }
{ "scaron" 353 }
{ "Yuml" 376 }
{ "circ" 710 }
{ "tilde" 732 }
{ "ensp" 8194 }
{ "emsp" 8195 }
{ "thinsp" 8201 }
{ "zwnj" 8204 }
{ "zwj" 8205 }
{ "lrm" 8206 }
{ "rlm" 8207 }
{ "ndash" 8211 }
{ "mdash" 8212 }
{ "lsquo" 8216 }
{ "rsquo" 8217 }
{ "sbquo" 8218 }
{ "ldquo" 8220 }
{ "rdquo" 8221 }
{ "bdquo" 8222 }
{ "dagger" 8224 }
{ "Dagger" 8225 }
{ "permil" 8240 }
{ "lsaquo" 8249 }
{ "rsaquo" 8250 }
{ "euro" 8364 }
} ;
SYMBOL: extra-entities
f extra-entities set-global
: with-entities ( entities quot -- )
[ swap extra-entities set call ] with-scope ; inline
: with-html-entities ( quot -- )
html-entities swap with-entities ; inline

1
basis/xml/entities/html/authors.txt Normal file
View File

@ -0,0 +1 @@
Daniel Ehrenberg

4
basis/xml/entities/html/html-tests.factor Normal file
View File

@ -0,0 +1,4 @@
! Copyright (C) 2009 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test xml.entities.html ;
IN: xml.entities.html.tests

22
basis/xml/entities/html/html.factor Normal file
View File

@ -0,0 +1,22 @@
! Copyright (C) 2009 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs io.encodings.binary io.files kernel namespaces sequences
values xml xml.entities ;
IN: xml.entities.html
VALUE: html-entities
: read-entities-file ( file -- table )
f swap binary <file-reader>
[ 2drop extra-entities get ] sax ;
: get-html ( -- table )
{ "lat1" "special" "symbol" } [
"resource:basis/xml/entities/html/xhtml-"
swap ".ent" 3append read-entities-file
] map first3 assoc-union assoc-union ;
get-html to: html-entities
: with-html-entities ( quot -- )
html-entities swap with-entities ; inline

196
basis/xml/entities/html/xhtml-lat1.ent Normal file
View File

@ -0,0 +1,196 @@
<!-- Portions (C) International Organization for Standardization 1986
Permission to copy in any form is granted for use with
conforming SGML systems and applications as defined in
ISO 8879, provided this notice is included in all copies.
-->
<!-- Character entity set. Typical invocation:
<!ENTITY % HTMLlat1 PUBLIC
"-//W3C//ENTITIES Latin 1 for XHTML//EN"
"http://www.w3.org/TR/xhtml1/DTD/xhtml-lat1.ent">
%HTMLlat1;
-->
<!ENTITY nbsp "&#160;"> <!-- no-break space = non-breaking space,
U+00A0 ISOnum -->
<!ENTITY iexcl "&#161;"> <!-- inverted exclamation mark, U+00A1 ISOnum -->
<!ENTITY cent "&#162;"> <!-- cent sign, U+00A2 ISOnum -->
<!ENTITY pound "&#163;"> <!-- pound sign, U+00A3 ISOnum -->
<!ENTITY curren "&#164;"> <!-- currency sign, U+00A4 ISOnum -->
<!ENTITY yen "&#165;"> <!-- yen sign = yuan sign, U+00A5 ISOnum -->
<!ENTITY brvbar "&#166;"> <!-- broken bar = broken vertical bar,
U+00A6 ISOnum -->
<!ENTITY sect "&#167;"> <!-- section sign, U+00A7 ISOnum -->
<!ENTITY uml "&#168;"> <!-- diaeresis = spacing diaeresis,
U+00A8 ISOdia -->
<!ENTITY copy "&#169;"> <!-- copyright sign, U+00A9 ISOnum -->
<!ENTITY ordf "&#170;"> <!-- feminine ordinal indicator, U+00AA ISOnum -->
<!ENTITY laquo "&#171;"> <!-- left-pointing double angle quotation mark
= left pointing guillemet, U+00AB ISOnum -->
<!ENTITY not "&#172;"> <!-- not sign = angled dash,
U+00AC ISOnum -->
<!ENTITY shy "&#173;"> <!-- soft hyphen = discretionary hyphen,
U+00AD ISOnum -->
<!ENTITY reg "&#174;"> <!-- registered sign = registered trade mark sign,
U+00AE ISOnum -->
<!ENTITY macr "&#175;"> <!-- macron = spacing macron = overline
= APL overbar, U+00AF ISOdia -->
<!ENTITY deg "&#176;"> <!-- degree sign, U+00B0 ISOnum -->
<!ENTITY plusmn "&#177;"> <!-- plus-minus sign = plus-or-minus sign,
U+00B1 ISOnum -->
<!ENTITY sup2 "&#178;"> <!-- superscript two = superscript digit two
= squared, U+00B2 ISOnum -->
<!ENTITY sup3 "&#179;"> <!-- superscript three = superscript digit three
= cubed, U+00B3 ISOnum -->
<!ENTITY acute "&#180;"> <!-- acute accent = spacing acute,
U+00B4 ISOdia -->
<!ENTITY micro "&#181;"> <!-- micro sign, U+00B5 ISOnum -->
<!ENTITY para "&#182;"> <!-- pilcrow sign = paragraph sign,
U+00B6 ISOnum -->
<!ENTITY middot "&#183;"> <!-- middle dot = Georgian comma
= Greek middle dot, U+00B7 ISOnum -->
<!ENTITY cedil "&#184;"> <!-- cedilla = spacing cedilla, U+00B8 ISOdia -->
<!ENTITY sup1 "&#185;"> <!-- superscript one = superscript digit one,
U+00B9 ISOnum -->
<!ENTITY ordm "&#186;"> <!-- masculine ordinal indicator,
U+00BA ISOnum -->
<!ENTITY raquo "&#187;"> <!-- right-pointing double angle quotation mark
= right pointing guillemet, U+00BB ISOnum -->
<!ENTITY frac14 "&#188;"> <!-- vulgar fraction one quarter
= fraction one quarter, U+00BC ISOnum -->
<!ENTITY frac12 "&#189;"> <!-- vulgar fraction one half
= fraction one half, U+00BD ISOnum -->
<!ENTITY frac34 "&#190;"> <!-- vulgar fraction three quarters
= fraction three quarters, U+00BE ISOnum -->
<!ENTITY iquest "&#191;"> <!-- inverted question mark
= turned question mark, U+00BF ISOnum -->
<!ENTITY Agrave "&#192;"> <!-- latin capital letter A with grave
= latin capital letter A grave,
U+00C0 ISOlat1 -->
<!ENTITY Aacute "&#193;"> <!-- latin capital letter A with acute,
U+00C1 ISOlat1 -->
<!ENTITY Acirc "&#194;"> <!-- latin capital letter A with circumflex,
U+00C2 ISOlat1 -->
<!ENTITY Atilde "&#195;"> <!-- latin capital letter A with tilde,
U+00C3 ISOlat1 -->
<!ENTITY Auml "&#196;"> <!-- latin capital letter A with diaeresis,
U+00C4 ISOlat1 -->
<!ENTITY Aring "&#197;"> <!-- latin capital letter A with ring above
= latin capital letter A ring,
U+00C5 ISOlat1 -->
<!ENTITY AElig "&#198;"> <!-- latin capital letter AE
= latin capital ligature AE,
U+00C6 ISOlat1 -->
<!ENTITY Ccedil "&#199;"> <!-- latin capital letter C with cedilla,
U+00C7 ISOlat1 -->
<!ENTITY Egrave "&#200;"> <!-- latin capital letter E with grave,
U+00C8 ISOlat1 -->
<!ENTITY Eacute "&#201;"> <!-- latin capital letter E with acute,
U+00C9 ISOlat1 -->
<!ENTITY Ecirc "&#202;"> <!-- latin capital letter E with circumflex,
U+00CA ISOlat1 -->
<!ENTITY Euml "&#203;"> <!-- latin capital letter E with diaeresis,
U+00CB ISOlat1 -->
<!ENTITY Igrave "&#204;"> <!-- latin capital letter I with grave,
U+00CC ISOlat1 -->
<!ENTITY Iacute "&#205;"> <!-- latin capital letter I with acute,
U+00CD ISOlat1 -->
<!ENTITY Icirc "&#206;"> <!-- latin capital letter I with circumflex,
U+00CE ISOlat1 -->
<!ENTITY Iuml "&#207;"> <!-- latin capital letter I with diaeresis,
U+00CF ISOlat1 -->
<!ENTITY ETH "&#208;"> <!-- latin capital letter ETH, U+00D0 ISOlat1 -->
<!ENTITY Ntilde "&#209;"> <!-- latin capital letter N with tilde,
U+00D1 ISOlat1 -->
<!ENTITY Ograve "&#210;"> <!-- latin capital letter O with grave,
U+00D2 ISOlat1 -->
<!ENTITY Oacute "&#211;"> <!-- latin capital letter O with acute,
U+00D3 ISOlat1 -->
<!ENTITY Ocirc "&#212;"> <!-- latin capital letter O with circumflex,
U+00D4 ISOlat1 -->
<!ENTITY Otilde "&#213;"> <!-- latin capital letter O with tilde,
U+00D5 ISOlat1 -->
<!ENTITY Ouml "&#214;"> <!-- latin capital letter O with diaeresis,
U+00D6 ISOlat1 -->
<!ENTITY times "&#215;"> <!-- multiplication sign, U+00D7 ISOnum -->
<!ENTITY Oslash "&#216;"> <!-- latin capital letter O with stroke
= latin capital letter O slash,
U+00D8 ISOlat1 -->
<!ENTITY Ugrave "&#217;"> <!-- latin capital letter U with grave,
U+00D9 ISOlat1 -->
<!ENTITY Uacute "&#218;"> <!-- latin capital letter U with acute,
U+00DA ISOlat1 -->
<!ENTITY Ucirc "&#219;"> <!-- latin capital letter U with circumflex,
U+00DB ISOlat1 -->
<!ENTITY Uuml "&#220;"> <!-- latin capital letter U with diaeresis,
U+00DC ISOlat1 -->
<!ENTITY Yacute "&#221;"> <!-- latin capital letter Y with acute,
U+00DD ISOlat1 -->
<!ENTITY THORN "&#222;"> <!-- latin capital letter THORN,
U+00DE ISOlat1 -->
<!ENTITY szlig "&#223;"> <!-- latin small letter sharp s = ess-zed,
U+00DF ISOlat1 -->
<!ENTITY agrave "&#224;"> <!-- latin small letter a with grave
= latin small letter a grave,
U+00E0 ISOlat1 -->
<!ENTITY aacute "&#225;"> <!-- latin small letter a with acute,
U+00E1 ISOlat1 -->
<!ENTITY acirc "&#226;"> <!-- latin small letter a with circumflex,
U+00E2 ISOlat1 -->
<!ENTITY atilde "&#227;"> <!-- latin small letter a with tilde,
U+00E3 ISOlat1 -->
<!ENTITY auml "&#228;"> <!-- latin small letter a with diaeresis,
U+00E4 ISOlat1 -->
<!ENTITY aring "&#229;"> <!-- latin small letter a with ring above
= latin small letter a ring,
U+00E5 ISOlat1 -->
<!ENTITY aelig "&#230;"> <!-- latin small letter ae
= latin small ligature ae, U+00E6 ISOlat1 -->
<!ENTITY ccedil "&#231;"> <!-- latin small letter c with cedilla,
U+00E7 ISOlat1 -->
<!ENTITY egrave "&#232;"> <!-- latin small letter e with grave,
U+00E8 ISOlat1 -->
<!ENTITY eacute "&#233;"> <!-- latin small letter e with acute,
U+00E9 ISOlat1 -->
<!ENTITY ecirc "&#234;"> <!-- latin small letter e with circumflex,
U+00EA ISOlat1 -->
<!ENTITY euml "&#235;"> <!-- latin small letter e with diaeresis,
U+00EB ISOlat1 -->
<!ENTITY igrave "&#236;"> <!-- latin small letter i with grave,
U+00EC ISOlat1 -->
<!ENTITY iacute "&#237;"> <!-- latin small letter i with acute,
U+00ED ISOlat1 -->
<!ENTITY icirc "&#238;"> <!-- latin small letter i with circumflex,
U+00EE ISOlat1 -->
<!ENTITY iuml "&#239;"> <!-- latin small letter i with diaeresis,
U+00EF ISOlat1 -->
<!ENTITY eth "&#240;"> <!-- latin small letter eth, U+00F0 ISOlat1 -->
<!ENTITY ntilde "&#241;"> <!-- latin small letter n with tilde,
U+00F1 ISOlat1 -->
<!ENTITY ograve "&#242;"> <!-- latin small letter o with grave,
U+00F2 ISOlat1 -->
<!ENTITY oacute "&#243;"> <!-- latin small letter o with acute,
U+00F3 ISOlat1 -->
<!ENTITY ocirc "&#244;"> <!-- latin small letter o with circumflex,
U+00F4 ISOlat1 -->
<!ENTITY otilde "&#245;"> <!-- latin small letter o with tilde,
U+00F5 ISOlat1 -->
<!ENTITY ouml "&#246;"> <!-- latin small letter o with diaeresis,
U+00F6 ISOlat1 -->
<!ENTITY divide "&#247;"> <!-- division sign, U+00F7 ISOnum -->
<!ENTITY oslash "&#248;"> <!-- latin small letter o with stroke,
= latin small letter o slash,
U+00F8 ISOlat1 -->
<!ENTITY ugrave "&#249;"> <!-- latin small letter u with grave,
U+00F9 ISOlat1 -->
<!ENTITY uacute "&#250;"> <!-- latin small letter u with acute,
U+00FA ISOlat1 -->
<!ENTITY ucirc "&#251;"> <!-- latin small letter u with circumflex,
U+00FB ISOlat1 -->
<!ENTITY uuml "&#252;"> <!-- latin small letter u with diaeresis,
U+00FC ISOlat1 -->
<!ENTITY yacute "&#253;"> <!-- latin small letter y with acute,
U+00FD ISOlat1 -->
<!ENTITY thorn "&#254;"> <!-- latin small letter thorn,
U+00FE ISOlat1 -->
<!ENTITY yuml "&#255;"> <!-- latin small letter y with diaeresis,
U+00FF ISOlat1 -->

80
basis/xml/entities/html/xhtml-special.ent Normal file
View File

@ -0,0 +1,80 @@
<!-- Special characters for XHTML -->
<!-- Character entity set. Typical invocation:
<!ENTITY % HTMLspecial PUBLIC
"-//W3C//ENTITIES Special for XHTML//EN"
"http://www.w3.org/TR/xhtml1/DTD/xhtml-special.ent">
%HTMLspecial;
-->
<!-- Portions (C) International Organization for Standardization 1986:
Permission to copy in any form is granted for use with
conforming SGML systems and applications as defined in
ISO 8879, provided this notice is included in all copies.
-->
<!-- Relevant ISO entity set is given unless names are newly introduced.
New names (i.e., not in ISO 8879 list) do not clash with any
existing ISO 8879 entity names. ISO 10646 character numbers
are given for each character, in hex. values are decimal
conversions of the ISO 10646 values and refer to the document
character set. Names are Unicode names.
-->
<!-- C0 Controls and Basic Latin -->
<!ENTITY quot "&#34;"> <!-- quotation mark, U+0022 ISOnum -->
<!ENTITY amp "&#38;#38;"> <!-- ampersand, U+0026 ISOnum -->
<!ENTITY lt "&#38;#60;"> <!-- less-than sign, U+003C ISOnum -->
<!ENTITY gt "&#62;"> <!-- greater-than sign, U+003E ISOnum -->
<!ENTITY apos "&#39;"> <!-- apostrophe = APL quote, U+0027 ISOnum -->
<!-- Latin Extended-A -->
<!ENTITY OElig "&#338;"> <!-- latin capital ligature OE,
U+0152 ISOlat2 -->
<!ENTITY oelig "&#339;"> <!-- latin small ligature oe, U+0153 ISOlat2 -->
<!-- ligature is a misnomer, this is a separate character in some languages -->
<!ENTITY Scaron "&#352;"> <!-- latin capital letter S with caron,
U+0160 ISOlat2 -->
<!ENTITY scaron "&#353;"> <!-- latin small letter s with caron,
U+0161 ISOlat2 -->
<!ENTITY Yuml "&#376;"> <!-- latin capital letter Y with diaeresis,
U+0178 ISOlat2 -->
<!-- Spacing Modifier Letters -->
<!ENTITY circ "&#710;"> <!-- modifier letter circumflex accent,
U+02C6 ISOpub -->
<!ENTITY tilde "&#732;"> <!-- small tilde, U+02DC ISOdia -->
<!-- General Punctuation -->
<!ENTITY ensp "&#8194;"> <!-- en space, U+2002 ISOpub -->
<!ENTITY emsp "&#8195;"> <!-- em space, U+2003 ISOpub -->
<!ENTITY thinsp "&#8201;"> <!-- thin space, U+2009 ISOpub -->
<!ENTITY zwnj "&#8204;"> <!-- zero width non-joiner,
U+200C NEW RFC 2070 -->
<!ENTITY zwj "&#8205;"> <!-- zero width joiner, U+200D NEW RFC 2070 -->
<!ENTITY lrm "&#8206;"> <!-- left-to-right mark, U+200E NEW RFC 2070 -->
<!ENTITY rlm "&#8207;"> <!-- right-to-left mark, U+200F NEW RFC 2070 -->
<!ENTITY ndash "&#8211;"> <!-- en dash, U+2013 ISOpub -->
<!ENTITY mdash "&#8212;"> <!-- em dash, U+2014 ISOpub -->
<!ENTITY lsquo "&#8216;"> <!-- left single quotation mark,
U+2018 ISOnum -->
<!ENTITY rsquo "&#8217;"> <!-- right single quotation mark,
U+2019 ISOnum -->
<!ENTITY sbquo "&#8218;"> <!-- single low-9 quotation mark, U+201A NEW -->
<!ENTITY ldquo "&#8220;"> <!-- left double quotation mark,
U+201C ISOnum -->
<!ENTITY rdquo "&#8221;"> <!-- right double quotation mark,
U+201D ISOnum -->
<!ENTITY bdquo "&#8222;"> <!-- double low-9 quotation mark, U+201E NEW -->
<!ENTITY dagger "&#8224;"> <!-- dagger, U+2020 ISOpub -->
<!ENTITY Dagger "&#8225;"> <!-- double dagger, U+2021 ISOpub -->
<!ENTITY permil "&#8240;"> <!-- per mille sign, U+2030 ISOtech -->
<!ENTITY lsaquo "&#8249;"> <!-- single left-pointing angle quotation mark,
U+2039 ISO proposed -->
<!-- lsaquo is proposed but not yet ISO standardized -->
<!ENTITY rsaquo "&#8250;"> <!-- single right-pointing angle quotation mark,
U+203A ISO proposed -->
<!-- rsaquo is proposed but not yet ISO standardized -->
<!-- Currency Symbols -->
<!ENTITY euro "&#8364;"> <!-- euro sign, U+20AC NEW -->

237
basis/xml/entities/html/xhtml-symbol.ent Normal file
View File

@ -0,0 +1,237 @@
<!-- Mathematical, Greek and Symbolic characters for XHTML -->
<!-- Character entity set. Typical invocation:
<!ENTITY % HTMLsymbol PUBLIC
"-//W3C//ENTITIES Symbols for XHTML//EN"
"http://www.w3.org/TR/xhtml1/DTD/xhtml-symbol.ent">
%HTMLsymbol;
-->
<!-- Portions (C) International Organization for Standardization 1986:
Permission to copy in any form is granted for use with
conforming SGML systems and applications as defined in
ISO 8879, provided this notice is included in all copies.
-->
<!-- Relevant ISO entity set is given unless names are newly introduced.
New names (i.e., not in ISO 8879 list) do not clash with any
existing ISO 8879 entity names. ISO 10646 character numbers
are given for each character, in hex. values are decimal
conversions of the ISO 10646 values and refer to the document
character set. Names are Unicode names.
-->
<!-- Latin Extended-B -->
<!ENTITY fnof "&#402;"> <!-- latin small letter f with hook = function
= florin, U+0192 ISOtech -->
<!-- Greek -->
<!ENTITY Alpha "&#913;"> <!-- greek capital letter alpha, U+0391 -->
<!ENTITY Beta "&#914;"> <!-- greek capital letter beta, U+0392 -->
<!ENTITY Gamma "&#915;"> <!-- greek capital letter gamma,
U+0393 ISOgrk3 -->
<!ENTITY Delta "&#916;"> <!-- greek capital letter delta,
U+0394 ISOgrk3 -->
<!ENTITY Epsilon "&#917;"> <!-- greek capital letter epsilon, U+0395 -->
<!ENTITY Zeta "&#918;"> <!-- greek capital letter zeta, U+0396 -->
<!ENTITY Eta "&#919;"> <!-- greek capital letter eta, U+0397 -->
<!ENTITY Theta "&#920;"> <!-- greek capital letter theta,
U+0398 ISOgrk3 -->
<!ENTITY Iota "&#921;"> <!-- greek capital letter iota, U+0399 -->
<!ENTITY Kappa "&#922;"> <!-- greek capital letter kappa, U+039A -->
<!ENTITY Lambda "&#923;"> <!-- greek capital letter lamda,
U+039B ISOgrk3 -->
<!ENTITY Mu "&#924;"> <!-- greek capital letter mu, U+039C -->
<!ENTITY Nu "&#925;"> <!-- greek capital letter nu, U+039D -->
<!ENTITY Xi "&#926;"> <!-- greek capital letter xi, U+039E ISOgrk3 -->
<!ENTITY Omicron "&#927;"> <!-- greek capital letter omicron, U+039F -->
<!ENTITY Pi "&#928;"> <!-- greek capital letter pi, U+03A0 ISOgrk3 -->
<!ENTITY Rho "&#929;"> <!-- greek capital letter rho, U+03A1 -->
<!-- there is no Sigmaf, and no U+03A2 character either -->
<!ENTITY Sigma "&#931;"> <!-- greek capital letter sigma,
U+03A3 ISOgrk3 -->
<!ENTITY Tau "&#932;"> <!-- greek capital letter tau, U+03A4 -->
<!ENTITY Upsilon "&#933;"> <!-- greek capital letter upsilon,
U+03A5 ISOgrk3 -->
<!ENTITY Phi "&#934;"> <!-- greek capital letter phi,
U+03A6 ISOgrk3 -->
<!ENTITY Chi "&#935;"> <!-- greek capital letter chi, U+03A7 -->
<!ENTITY Psi "&#936;"> <!-- greek capital letter psi,
U+03A8 ISOgrk3 -->
<!ENTITY Omega "&#937;"> <!-- greek capital letter omega,
U+03A9 ISOgrk3 -->
<!ENTITY alpha "&#945;"> <!-- greek small letter alpha,
U+03B1 ISOgrk3 -->
<!ENTITY beta "&#946;"> <!-- greek small letter beta, U+03B2 ISOgrk3 -->
<!ENTITY gamma "&#947;"> <!-- greek small letter gamma,
U+03B3 ISOgrk3 -->
<!ENTITY delta "&#948;"> <!-- greek small letter delta,
U+03B4 ISOgrk3 -->
<!ENTITY epsilon "&#949;"> <!-- greek small letter epsilon,
U+03B5 ISOgrk3 -->
<!ENTITY zeta "&#950;"> <!-- greek small letter zeta, U+03B6 ISOgrk3 -->
<!ENTITY eta "&#951;"> <!-- greek small letter eta, U+03B7 ISOgrk3 -->
<!ENTITY theta "&#952;"> <!-- greek small letter theta,
U+03B8 ISOgrk3 -->
<!ENTITY iota "&#953;"> <!-- greek small letter iota, U+03B9 ISOgrk3 -->
<!ENTITY kappa "&#954;"> <!-- greek small letter kappa,
U+03BA ISOgrk3 -->
<!ENTITY lambda "&#955;"> <!-- greek small letter lamda,
U+03BB ISOgrk3 -->
<!ENTITY mu "&#956;"> <!-- greek small letter mu, U+03BC ISOgrk3 -->
<!ENTITY nu "&#957;"> <!-- greek small letter nu, U+03BD ISOgrk3 -->
<!ENTITY xi "&#958;"> <!-- greek small letter xi, U+03BE ISOgrk3 -->
<!ENTITY omicron "&#959;"> <!-- greek small letter omicron, U+03BF NEW -->
<!ENTITY pi "&#960;"> <!-- greek small letter pi, U+03C0 ISOgrk3 -->
<!ENTITY rho "&#961;"> <!-- greek small letter rho, U+03C1 ISOgrk3 -->
<!ENTITY sigmaf "&#962;"> <!-- greek small letter final sigma,
U+03C2 ISOgrk3 -->
<!ENTITY sigma "&#963;"> <!-- greek small letter sigma,
U+03C3 ISOgrk3 -->
<!ENTITY tau "&#964;"> <!-- greek small letter tau, U+03C4 ISOgrk3 -->
<!ENTITY upsilon "&#965;"> <!-- greek small letter upsilon,
U+03C5 ISOgrk3 -->
<!ENTITY phi "&#966;"> <!-- greek small letter phi, U+03C6 ISOgrk3 -->
<!ENTITY chi "&#967;"> <!-- greek small letter chi, U+03C7 ISOgrk3 -->
<!ENTITY psi "&#968;"> <!-- greek small letter psi, U+03C8 ISOgrk3 -->
<!ENTITY omega "&#969;"> <!-- greek small letter omega,
U+03C9 ISOgrk3 -->
<!ENTITY thetasym "&#977;"> <!-- greek theta symbol,
U+03D1 NEW -->
<!ENTITY upsih "&#978;"> <!-- greek upsilon with hook symbol,
U+03D2 NEW -->
<!ENTITY piv "&#982;"> <!-- greek pi symbol, U+03D6 ISOgrk3 -->
<!-- General Punctuation -->
<!ENTITY bull "&#8226;"> <!-- bullet = black small circle,
U+2022 ISOpub -->
<!-- bullet is NOT the same as bullet operator, U+2219 -->
<!ENTITY hellip "&#8230;"> <!-- horizontal ellipsis = three dot leader,
U+2026 ISOpub -->
<!ENTITY prime "&#8242;"> <!-- prime = minutes = feet, U+2032 ISOtech -->
<!ENTITY Prime "&#8243;"> <!-- double prime = seconds = inches,
U+2033 ISOtech -->
<!ENTITY oline "&#8254;"> <!-- overline = spacing overscore,
U+203E NEW -->
<!ENTITY frasl "&#8260;"> <!-- fraction slash, U+2044 NEW -->
<!-- Letterlike Symbols -->
<!ENTITY weierp "&#8472;"> <!-- script capital P = power set
= Weierstrass p, U+2118 ISOamso -->
<!ENTITY image "&#8465;"> <!-- black-letter capital I = imaginary part,
U+2111 ISOamso -->
<!ENTITY real "&#8476;"> <!-- black-letter capital R = real part symbol,
U+211C ISOamso -->
<!ENTITY trade "&#8482;"> <!-- trade mark sign, U+2122 ISOnum -->
<!ENTITY alefsym "&#8501;"> <!-- alef symbol = first transfinite cardinal,
U+2135 NEW -->
<!-- alef symbol is NOT the same as hebrew letter alef,
U+05D0 although the same glyph could be used to depict both characters -->
<!-- Arrows -->
<!ENTITY larr "&#8592;"> <!-- leftwards arrow, U+2190 ISOnum -->
<!ENTITY uarr "&#8593;"> <!-- upwards arrow, U+2191 ISOnum-->
<!ENTITY rarr "&#8594;"> <!-- rightwards arrow, U+2192 ISOnum -->
<!ENTITY darr "&#8595;"> <!-- downwards arrow, U+2193 ISOnum -->
<!ENTITY harr "&#8596;"> <!-- left right arrow, U+2194 ISOamsa -->
<!ENTITY crarr "&#8629;"> <!-- downwards arrow with corner leftwards
= carriage return, U+21B5 NEW -->
<!ENTITY lArr "&#8656;"> <!-- leftwards double arrow, U+21D0 ISOtech -->
<!-- Unicode does not say that lArr is the same as the 'is implied by' arrow
but also does not have any other character for that function. So lArr can
be used for 'is implied by' as ISOtech suggests -->
<!ENTITY uArr "&#8657;"> <!-- upwards double arrow, U+21D1 ISOamsa -->
<!ENTITY rArr "&#8658;"> <!-- rightwards double arrow,
U+21D2 ISOtech -->
<!-- Unicode does not say this is the 'implies' character but does not have
another character with this function so rArr can be used for 'implies'
as ISOtech suggests -->
<!ENTITY dArr "&#8659;"> <!-- downwards double arrow, U+21D3 ISOamsa -->
<!ENTITY hArr "&#8660;"> <!-- left right double arrow,
U+21D4 ISOamsa -->
<!-- Mathematical Operators -->
<!ENTITY forall "&#8704;"> <!-- for all, U+2200 ISOtech -->
<!ENTITY part "&#8706;"> <!-- partial differential, U+2202 ISOtech -->
<!ENTITY exist "&#8707;"> <!-- there exists, U+2203 ISOtech -->
<!ENTITY empty "&#8709;"> <!-- empty set = null set, U+2205 ISOamso -->
<!ENTITY nabla "&#8711;"> <!-- nabla = backward difference,
U+2207 ISOtech -->
<!ENTITY isin "&#8712;"> <!-- element of, U+2208 ISOtech -->
<!ENTITY notin "&#8713;"> <!-- not an element of, U+2209 ISOtech -->
<!ENTITY ni "&#8715;"> <!-- contains as member, U+220B ISOtech -->
<!ENTITY prod "&#8719;"> <!-- n-ary product = product sign,
U+220F ISOamsb -->
<!-- prod is NOT the same character as U+03A0 'greek capital letter pi' though
the same glyph might be used for both -->
<!ENTITY sum "&#8721;"> <!-- n-ary summation, U+2211 ISOamsb -->
<!-- sum is NOT the same character as U+03A3 'greek capital letter sigma'
though the same glyph might be used for both -->
<!ENTITY minus "&#8722;"> <!-- minus sign, U+2212 ISOtech -->
<!ENTITY lowast "&#8727;"> <!-- asterisk operator, U+2217 ISOtech -->
<!ENTITY radic "&#8730;"> <!-- square root = radical sign,
U+221A ISOtech -->
<!ENTITY prop "&#8733;"> <!-- proportional to, U+221D ISOtech -->
<!ENTITY infin "&#8734;"> <!-- infinity, U+221E ISOtech -->
<!ENTITY ang "&#8736;"> <!-- angle, U+2220 ISOamso -->
<!ENTITY and "&#8743;"> <!-- logical and = wedge, U+2227 ISOtech -->
<!ENTITY or "&#8744;"> <!-- logical or = vee, U+2228 ISOtech -->
<!ENTITY cap "&#8745;"> <!-- intersection = cap, U+2229 ISOtech -->
<!ENTITY cup "&#8746;"> <!-- union = cup, U+222A ISOtech -->
<!ENTITY int "&#8747;"> <!-- integral, U+222B ISOtech -->
<!ENTITY there4 "&#8756;"> <!-- therefore, U+2234 ISOtech -->
<!ENTITY sim "&#8764;"> <!-- tilde operator = varies with = similar to,
U+223C ISOtech -->
<!-- tilde operator is NOT the same character as the tilde, U+007E,
although the same glyph might be used to represent both -->
<!ENTITY cong "&#8773;"> <!-- approximately equal to, U+2245 ISOtech -->
<!ENTITY asymp "&#8776;"> <!-- almost equal to = asymptotic to,
U+2248 ISOamsr -->
<!ENTITY ne "&#8800;"> <!-- not equal to, U+2260 ISOtech -->
<!ENTITY equiv "&#8801;"> <!-- identical to, U+2261 ISOtech -->
<!ENTITY le "&#8804;"> <!-- less-than or equal to, U+2264 ISOtech -->
<!ENTITY ge "&#8805;"> <!-- greater-than or equal to,
U+2265 ISOtech -->
<!ENTITY sub "&#8834;"> <!-- subset of, U+2282 ISOtech -->
<!ENTITY sup "&#8835;"> <!-- superset of, U+2283 ISOtech -->
<!ENTITY nsub "&#8836;"> <!-- not a subset of, U+2284 ISOamsn -->
<!ENTITY sube "&#8838;"> <!-- subset of or equal to, U+2286 ISOtech -->
<!ENTITY supe "&#8839;"> <!-- superset of or equal to,
U+2287 ISOtech -->
<!ENTITY oplus "&#8853;"> <!-- circled plus = direct sum,
U+2295 ISOamsb -->
<!ENTITY otimes "&#8855;"> <!-- circled times = vector product,
U+2297 ISOamsb -->
<!ENTITY perp "&#8869;"> <!-- up tack = orthogonal to = perpendicular,
U+22A5 ISOtech -->
<!ENTITY sdot "&#8901;"> <!-- dot operator, U+22C5 ISOamsb -->
<!-- dot operator is NOT the same character as U+00B7 middle dot -->
<!-- Miscellaneous Technical -->
<!ENTITY lceil "&#8968;"> <!-- left ceiling = APL upstile,
U+2308 ISOamsc -->
<!ENTITY rceil "&#8969;"> <!-- right ceiling, U+2309 ISOamsc -->
<!ENTITY lfloor "&#8970;"> <!-- left floor = APL downstile,
U+230A ISOamsc -->
<!ENTITY rfloor "&#8971;"> <!-- right floor, U+230B ISOamsc -->
<!ENTITY lang "&#9001;"> <!-- left-pointing angle bracket = bra,
U+2329 ISOtech -->
<!-- lang is NOT the same character as U+003C 'less than sign'
or U+2039 'single left-pointing angle quotation mark' -->
<!ENTITY rang "&#9002;"> <!-- right-pointing angle bracket = ket,
U+232A ISOtech -->
<!-- rang is NOT the same character as U+003E 'greater than sign'
or U+203A 'single right-pointing angle quotation mark' -->
<!-- Geometric Shapes -->
<!ENTITY loz "&#9674;"> <!-- lozenge, U+25CA ISOpub -->
<!-- Miscellaneous Symbols -->
<!ENTITY spades "&#9824;"> <!-- black spade suit, U+2660 ISOpub -->
<!-- black here seems to mean filled as opposed to hollow -->
<!ENTITY clubs "&#9827;"> <!-- black club suit = shamrock,
U+2663 ISOpub -->
<!ENTITY hearts "&#9829;"> <!-- black heart suit = valentine,
U+2665 ISOpub -->
<!ENTITY diams "&#9830;"> <!-- black diamond suit, U+2666 ISOpub -->

23
basis/xml/errors/errors-tests.factor
View File

@ -6,22 +6,27 @@ IN: xml.errors.tests
'[ _ string>xml ] swap '[ _ = ] must-fail-with ;
T{ no-entity f 1 10 "nbsp" } "<x>&nbsp;</x>" xml-error-test
T{ mismatched f 1 8 T{ name f "" "x" "" } T{ name f "" "y" "" }
} "<x></y>" xml-error-test
T{ mismatched f 1 8 T{ name f "" "x" "" } T{ name f "" "y" "" } }
"<x></y>" xml-error-test
T{ unclosed f 1 4 V{ T{ name f "" "x" "" } } } "<x>" xml-error-test
T{ nonexist-ns f 1 5 "x" } "<x:y/>" xml-error-test
T{ unopened f 1 5 } "</x>" xml-error-test
T{ not-yes/no f 1 41 "maybe" } "<?xml version='1.0' standalone='maybe'?><x/>" xml-error-test
T{ not-yes/no f 1 41 "maybe" }
"<?xml version='1.0' standalone='maybe'?><x/>" xml-error-test
T{ extra-attrs f 1 32 V{ T{ name f "" "foo" f } }
} "<?xml version='1.1' foo='bar'?><x/>" xml-error-test
T{ bad-version f 1 28 "5 million" } "<?xml version='5 million'?><x/>" xml-error-test
T{ bad-version f 1 28 "5 million" }
"<?xml version='5 million'?><x/>" xml-error-test
T{ notags f } "" xml-error-test
T{ multitags } "<x/><y/>" xml-error-test
T{ bad-prolog f 1 26 T{ prolog f "1.0" "UTF-8" f }
} "<x/><?xml version='1.0'?>" xml-error-test
T{ bad-prolog f 1 26 T{ prolog f "1.0" "UTF-8" f } }
"<x/><?xml version='1.0'?>" xml-error-test
T{ capitalized-prolog f 1 6 "XmL" } "<?XmL version='1.0'?><x/>"
xml-error-test
xml-error-test
T{ pre/post-content f "x" t } "x<y/>" xml-error-test
T{ versionless-prolog f 1 8 } "<?xml?><x/>" xml-error-test
T{ bad-instruction f 1 11 T{ instruction f "xsl" }
} "<x><?xsl?></x>" xml-error-test
T{ bad-instruction f 1 11 T{ instruction f "xsl" } }
"<x><?xsl?></x>" xml-error-test
T{ unclosed-quote f 1 13 } "<x value='/>" xml-error-test
T{ bad-name f 1 3 "-" } "<-/>" xml-error-test
T{ quoteless-attr f 1 10 } "<x value=3/>" xml-error-test

42
basis/xml/errors/errors.factor
View File

@ -32,17 +32,6 @@ M: no-entity summary ( obj -- str )
"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 parsing-error swap >>string throw ;
M: xml-string-error summary ( obj -- str )
[
dup call-next-method write
string>> print
] with-string-writer ;
TUPLE: mismatched < parsing-error open close ;
: mismatched ( open close -- * )
@ -233,7 +222,34 @@ M: misplaced-directive summary ( obj -- str )
dir>> write-xml-chunk nl
] with-string-writer ;
TUPLE: bad-name < parsing-error name ;
: bad-name ( name -- * )
\ bad-name parsing-error swap >>name throw ;
M: bad-name summary ( obj -- str )
[ call-next-method ]
[ "Invalid name: " swap name>> "\n" 3append ]
bi append ;
TUPLE: unclosed-quote < parsing-error ;
: unclosed-quote ( -- * )
\ unclosed-quote parsing-error throw ;
M: unclosed-quote summary
call-next-method
"XML document ends with quote still open\n" append ;
TUPLE: quoteless-attr < parsing-error ;
: quoteless-attr ( -- * )
\ quoteless-attr parsing-error throw ;
M: quoteless-attr summary
call-next-method "Attribute lacks quotes around value\n" append ;
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 expected no-entity
bad-prolog versionless-prolog capitalized-prolog bad-instruction
bad-directive ;
bad-directive bad-name unclosed-quote quoteless-attr ;

4
basis/xml/tests/encodings.factor
View File

@ -1,7 +1,8 @@
USING: xml xml.data xml.utilities tools.test ;
USING: xml xml.data xml.utilities tools.test accessors kernel ;
[ "\u000131" ] [ "resource:basis/xml/tests/latin5.xml" file>xml children>string ] unit-test
[ "\u0000e9" ] [ "resource:basis/xml/tests/latin1.xml" file>xml children>string ] unit-test
[ "\u0000e9" ] [ "resource:basis/xml/tests/spaces.xml" file>xml children>string ] unit-test
[ "\u0000e9" ] [ "resource:basis/xml/tests/utf8.xml" file>xml children>string ] unit-test
[ "\u0000e9" ] [ "resource:basis/xml/tests/utf16.xml" file>xml children>string ] unit-test
[ "\u0000e9" ] [ "resource:basis/xml/tests/utf16be.xml" file>xml children>string ] unit-test
@ -10,3 +11,4 @@ USING: xml xml.data xml.utilities tools.test ;
[ "\u0000e9" ] [ "resource:basis/xml/tests/utf16le-bom.xml" file>xml children>string ] unit-test
[ "\u0000e9" ] [ "resource:basis/xml/tests/prologless.xml" file>xml children>string ] unit-test
[ "e" ] [ "resource:basis/xml/tests/ascii.xml" file>xml children>string ] unit-test
[ "\u0000e9" "x" ] [ "resource:basis/xml/tests/unitag.xml" file>xml [ name>> main>> ] [ children>string ] bi ] unit-test

3
basis/xml/tests/spaces.xml Normal file
View File

@ -0,0 +1,3 @@
<x>é</x>

5
basis/xml/tests/test.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
IN: xml.tests
USING: kernel xml tools.test io namespaces make sequences
xml.errors xml.entities parser strings xml.data io.files
xml.errors xml.entities.html parser strings xml.data io.files
xml.writer xml.utilities state-parser continuations assocs
sequences.deep accessors io.streams.string ;
@ -62,3 +62,6 @@ SYMBOL: xml-file
[ T{ doctype-decl f "foo" T{ system-id f "blah.dtd" } } ] [ "<!DOCTYPE foo SYSTEM 'blah.dtd'>" string>xml-chunk first ] unit-test
[ T{ doctype-decl f "foo" T{ system-id f "blah.dtd" } } ] [ "<!DOCTYPE foo SYSTEM \"blah.dtd\" >" string>xml-chunk first ] unit-test
[ t ] [ "<!DOCTYPE html PUBLIC '-//W3C//DTD XHTML 1.1//EN' 'http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd' >" dup string>xml-chunk [ write-xml-chunk ] with-string-writer = ] unit-test
[ "foo" ] [ "<!ENTITY bar 'foo'><x>&bar;</x>" string>xml children>string ] unit-test
[ V{ "hello" } ] [ "hello" string>xml-chunk ] unit-test
[ 958 ] [ [ "&xi;" string>xml-chunk ] with-html-entities first first ] unit-test

1
basis/xml/tests/unitag.xml Normal file
View File

@ -0,0 +1 @@
<é>x</é>

146
basis/xml/tokenize/tokenize.factor
View File

@ -1,9 +1,10 @@
! Copyright (C) 2005, 2006 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays ascii assocs combinators fry io.encodings
io.encodings.iana io.encodings.utf16 io.encodings.utf8 kernel
make math.parser namespaces sequences sets splitting state-parser
xml.char-classes xml.data xml.entities xml.errors strings ;
USING: accessors arrays ascii assocs combinators
combinators.short-circuit fry io.encodings io.encodings.iana
io.encodings.string io.encodings.utf16 io.encodings.utf8 kernel make
math math.parser namespaces sequences sets splitting state-parser
strings xml.char-classes xml.data xml.entities xml.errors hashtables ;
IN: xml.tokenize
! XML namespace processing: ns = namespace
@ -53,34 +54,37 @@ SYMBOL: ns-stack
! version=1.0? is calculated once and passed around for efficiency
: (parse-name) ( -- str )
version=1.0? dup
get-char name-start? [
[ dup get-char name-char? not ] take-until nip
] [
"Malformed name" xml-string-error
] if ;
: assure-name ( str version=1.0? -- str )
over {
[ first name-start? ]
[ rest-slice [ name-char? ] with all? ]
} 2&& [ bad-name ] unless ;
: (parse-name) ( start -- str )
version=1.0?
[ [ get-char name-char? not ] curry take-until append ]
[ assure-name ] bi ;
: parse-name-starting ( start -- name )
(parse-name) get-char CHAR: : =
[ next "" (parse-name) ] [ "" swap ] if f <name> ;
: parse-name ( -- name )
(parse-name) get-char CHAR: : =
[ next (parse-name) ] [ "" swap ] if f <name> ;
"" parse-name-starting ;
! -- Parsing strings
: (parse-entity) ( string -- )
: parse-named-entity ( string -- )
dup entities at [ , ] [
prolog-data get standalone>>
[ no-entity ] [
dup extra-entities get at
[ , ] [ no-entity ] ?if
] if
dup extra-entities get at
[ dup number? [ , ] [ % ] if ] [ no-entity ] ?if ! Make less hackish
] ?if ;
: parse-entity ( -- )
next CHAR: ; take-char next
"#" ?head [
"x" ?head 16 10 ? base> ,
] [ (parse-entity) ] if ;
] [ parse-named-entity ] if ;
: (parse-char) ( ch -- )
get-char {
@ -93,13 +97,9 @@ SYMBOL: ns-stack
: parse-char ( ch -- string )
[ (parse-char) ] "" make ;
: parse-quot ( ch -- string )
parse-char get-char
[ "XML file ends in a quote" xml-string-error ] unless ;
: parse-text ( -- string )
CHAR: < parse-char ;
! Parsing tags
: start-tag ( -- name ? )
@ -107,17 +107,18 @@ SYMBOL: ns-stack
get-char CHAR: / = dup [ next ] when
parse-name swap ;
: parse-attr-value ( -- seq )
get-char dup "'\"" member? [
next parse-quot
] [
"Attribute lacks quote" xml-string-error
] if ;
: (parse-quote) ( ch -- string )
parse-char get-char
[ unclosed-quote ] unless ;
: parse-quote ( -- seq )
pass-blank get-char dup "'\"" member?
[ next (parse-quote) ] [ quoteless-attr ] if ;
: parse-attr ( -- )
[ parse-name ] with-scope
pass-blank CHAR: = expect pass-blank
[ parse-attr-value ] with-scope
parse-name
pass-blank CHAR: = expect
parse-quote
2array , ;
: (middle-tag) ( -- )
@ -153,7 +154,7 @@ SYMBOL: ns-stack
: only-blanks ( str -- )
[ blank? ] all? [ bad-doctype-decl ] unless ;
: take-system-literal ( -- str )
: take-system-literal ( -- str ) ! replace with parse-quote?
pass-blank get-char next {
{ CHAR: ' [ "'" take-string ] }
{ CHAR: " [ "\"" take-string ] }
@ -207,15 +208,18 @@ DEFER: direct
: take-entity-def ( -- entity-name entity-def )
" " take-string pass-blank get-char {
{ CHAR: ' [ take-system-literal ] }
{ CHAR: " [ take-system-literal ] }
{ CHAR: ' [ parse-quote ] }
{ CHAR: " [ parse-quote ] }
[ drop take-external-id ]
} case ;
: associate-entity ( entity-name entity-def -- )
swap extra-entities [ ?set-at ] change ;
: take-entity-decl ( -- entity-decl )
pass-blank get-char {
{ CHAR: % [ next pass-blank take-entity-def ] }
[ drop take-entity-def ]
[ drop take-entity-def 2dup associate-entity ]
} case
">" take-string only-blanks <entity-decl> ;
@ -253,14 +257,22 @@ DEFER: direct
: good-version ( version -- version )
dup { "1.0" "1.1" } member? [ bad-version ] unless ;
: prolog-attrs ( alist -- prolog )
[ T{ name f "" "version" f } swap at
[ good-version ] [ versionless-prolog ] if* ] keep
[ T{ name f "" "encoding" f } swap at
"UTF-8" or ] keep
: prolog-version ( alist -- version )
T{ name f "" "version" f } swap at
[ good-version ] [ versionless-prolog ] if* ;
: prolog-encoding ( alist -- encoding )
T{ name f "" "encoding" f } swap at "UTF-8" or ;
: prolog-standalone ( alist -- version )
T{ name f "" "standalone" f } swap at
[ yes/no>bool ] [ f ] if*
<prolog> ;
[ yes/no>bool ] [ f ] if* ;
: prolog-attrs ( alist -- prolog )
[ prolog-version ]
[ prolog-encoding ]
[ prolog-standalone ]
tri <prolog> ;
SYMBOL: string-input?
: decode-input-if ( encoding -- )
@ -274,7 +286,7 @@ SYMBOL: string-input?
dup prolog-data set ;
: instruct ( -- instruction )
(parse-name) dup "xml" =
"" (parse-name) dup "xml" =
[ drop parse-prolog ] [
dup >lower "xml" =
[ capitalized-prolog ]
@ -284,7 +296,7 @@ SYMBOL: string-input?
: make-tag ( -- tag )
{
{ [ get-char dup CHAR: ! = ] [ drop next direct ] }
{ [ CHAR: ? = ] [ next instruct ] }
{ [ CHAR: ? = ] [ next instruct ] }
[
start-tag [ dup add-ns pop-ns <closer> ]
[ middle-tag end-tag ] if
@ -294,36 +306,50 @@ SYMBOL: string-input?
! Autodetecting encodings
: continue-make-tag ( str -- tag )
parse-name-starting middle-tag end-tag CHAR: > expect ;
: start-utf16le ( -- tag )
utf16le decode-input-if
CHAR: ? expect
0 expect instruct ;
: 10xxxxxx? ( ch -- ? )
-6 shift 3 bitand 2 = ;
: start<name ( ch -- tag )
ascii?
[ utf8 decode-input-if next make-tag ] [
next
[ get-next 10xxxxxx? not ] take-until
get-char suffix utf8 decode
utf8 decode-input-if next
continue-make-tag
] if ;
: start< ( -- tag )
get-next {
{ 0 [ next next start-utf16le ] }
{ CHAR: ? [ next next instruct ] } ! XML prolog parsing sets the encoding
[ drop utf8 decode-input-if next make-tag ]
! That is a hack. It fails if you have <nonascii
{ CHAR: ! [ utf8 decode-input next next direct ] }
[ start<name ]
} case ;
: skip-utf8-bom ( -- tag )
"\u0000bb\u0000bf" expect utf8 decode-input
CHAR: < expect make-tag ;
: decode-expecting ( encoding string -- tag )
[ decode-input-if next ] [ expect-string ] bi* make-tag ;
: start-utf16be ( -- tag )
utf16be decode-input-if
next CHAR: < expect make-tag ;
utf16be "<" decode-expecting ;
: skip-utf16le-bom ( -- tag )
utf16le decode-input-if
next HEX: FE expect
CHAR: < expect make-tag ;
utf16le "\u0000fe<" decode-expecting ;
: skip-utf16be-bom ( -- tag )
utf16be decode-input-if
next HEX: FF expect
CHAR: < expect make-tag ;
utf16be "\u0000ff<" decode-expecting ;
: start-document ( -- tag )
get-char {
@ -333,8 +359,6 @@ SYMBOL: string-input?
{ HEX: FF [ skip-utf16le-bom ] }
{ HEX: FE [ skip-utf16be-bom ] }
{ f [ "" ] }
[ dup blank?
[ drop pass-blank utf8 decode-input-if CHAR: < expect make-tag ]
[ 1string ] if ! Replace with proper error
]
[ drop utf8 decode-input-if f ]
! Same problem as with <e`>, in the case of XML chunks?
} case ;

19
basis/xml/xml-docs.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax kernel xml.data xml.errors
xml.writer state-parser xml.tokenize xml.utilities xml.entities
strings sequences io ;
strings sequences io xml.entities.html ;
IN: xml
HELP: string>xml
@ -295,9 +295,6 @@ HELP: expected
HELP: no-entity
{ $class-description "XML parsing error describing the use of an undefined entity in a case where standalone is marked yes. Delegates to " { $link parsing-error } ". Contains one slot, thing, containing a string representing the entity." } ;
HELP: xml-string-error
{ $class-description "XML parsing error that delegates to " { $link parsing-error } " and represents an other, unspecified error, which is represented by the slot string, containing a string describing the error." } ;
HELP: open-tag
{ $class-description "represents a tag that does have children, ie is not a contained tag" }
{ $notes "the constructor used for this class is simply " { $link <tag> } "." }
@ -324,6 +321,15 @@ HELP: state-parse
HELP: pre/post-content
{ $class-description "describes the error where a non-whitespace string is used before or after the main tag in an XML document. Contains two slots: string contains the offending string, and pre? is t if it occured before the main tag and f if it occured after" } ;
HELP: unclosed-quote
{ $class-description "describes the error where a quotation for an attribute value is opened but not closed before the end of the document." } ;
HELP: bad-name
{ $class-description "describes the error where a name is used, for example in an XML tag or attribute key, which is invalid." } ;
HELP: quoteless-attr
{ $class-description "describes the error where an attribute of an XML tag is missing quotes around a value." } ;
HELP: entities
{ $description "a hash table from default XML entity names (like &amp; and &lt;) to the characters they represent. This is automatically included when parsing any XML document." }
{ $see-also html-entities } ;
@ -444,6 +450,9 @@ ARTICLE: { "xml" "errors" } "XML parsing errors"
{ $subsection expected }
{ $subsection no-entity }
{ $subsection pre/post-content }
{ $subsection unclosed-quote }
{ $subsection bad-name }
{ $subsection quoteless-attr }
"Additionally, most of these errors delegate to " { $link parsing-error } " in order to provide more information"
$nl
"Note that, in parsing an XML document, only the first error is reported." ;
@ -456,7 +465,7 @@ ARTICLE: { "xml" "entities" } "XML entities"
{ $subsection with-html-entities } ;
ARTICLE: "xml" "XML parser"
"The " { $vocab-link "xml" } " vocabulary implements the XML 1.1 standard, converting strings of text into XML and vice versa."
"The " { $vocab-link "xml" } " vocabulary implements the XML 1.0 and 1.1 standards, converting strings of text into XML and vice versa."
{ $subsection { "xml" "reading" } }
{ $subsection { "xml" "writing" } }
{ $subsection { "xml" "classes" } }

4
basis/xml/xml.factor
View File

@ -133,12 +133,12 @@ TUPLE: pull-xml scope ;
: sax ( stream quot: ( xml-elem -- ) -- )
swap [
reset-prolog init-ns-stack
start-document call-under
start-document [ call-under ] when*
sax-loop
] state-parse ; inline recursive
: (read-xml) ( -- )
start-document process
start-document [ process ] when*
[ process ] sax-loop ; inline
: (read-xml-chunk) ( stream -- prolog seq )

3
core/generic/standard/standard-tests.factor
View File

@ -4,7 +4,8 @@ generic.standard strings sequences arrays kernel accessors words
specialized-arrays.double byte-arrays bit-arrays parser
namespaces make quotations stack-checker vectors growable
hashtables sbufs prettyprint byte-vectors bit-vectors
specialized-vectors.double definitions generic sets graphs assocs ;
specialized-vectors.double definitions generic sets graphs assocs
grouping ;
GENERIC: lo-tag-test ( obj -- obj' )

11
core/growable/growable-docs.factor
View File

@ -28,7 +28,12 @@ HELP: new-size
HELP: ensure
{ $values { "n" "a positive integer" } { "seq" growable } }
{ $description "If " { $snippet "n" } " is less than the length of the sequence, does nothing. Otherwise, if " { $snippet "n" } " also exceeds the capacity of the underlying storage, the underlying storage is grown, and the fill pointer is reset. Finally, if " { $snippet "n" } " is greater than or equal to the length but less than the capacity of the underlying storage, the fill pointer is moved and nothing else is done."
$nl
"This word is used in the implementation of the " { $link set-nth } " generic for sequences supporting the resizable sequence protocol (see " { $link "growable" } ")."
{ $description "This word behaves as follows, depending on the relation between " { $snippet "n" } " and the length of the sequence:"
{ $list
{ "If " { $snippet "n" } " is less than the length of the sequence, does nothing." }
{ "If " { $snippet "n" } " exceeds the capacity of the underlying storage, the underlying storage is grown." }
{ "If " { $snippet "n" } " is greater than or equal to the length but less than the capacity of the underlying storage, the fill pointer is moved and nothing else is done." }
}
"In the case that new elements are added to the sequence (last two cases), the new elements are undefined." }
{ $notes "This word is used in the implementation of the " { $link set-nth } " generic for sequences supporting the resizable sequence protocol (see " { $link "growable" } ")."
} ;

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

@ -168,7 +168,7 @@ HELP: lines
HELP: each-line
{ $values { "quot" { $quotation "( str -- )" } } }
{ $description "Calls the quotatin with successive lines of text, until the current " { $link input-stream } " is exhausted." } ;
{ $description "Calls the quotation with successive lines of text, until the current " { $link input-stream } " is exhausted." } ;
HELP: contents
{ $values { "stream" "an input stream" } { "str" string } }

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

@ -1,7 +1,7 @@
USING: arrays byte-arrays kernel kernel.private math memory
namespaces sequences tools.test math.private quotations
continuations prettyprint io.streams.string debugger assocs
sequences.private accessors locals.backend ;
sequences.private accessors locals.backend grouping ;
IN: kernel.tests
[ 0 ] [ f size ] unit-test

3
core/math/floats/floats-tests.factor
View File

@ -1,4 +1,5 @@
USING: kernel math math.constants tools.test sequences ;
USING: kernel math math.constants tools.test sequences
grouping ;
IN: math.floats.tests
[ t ] [ 0.0 float? ] unit-test

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

@ -415,18 +415,6 @@ HELP: filter-here
{ $description "Applies the quotation to each element in turn, and removes elements for which the quotation outputs a false value." }
{ $side-effects "seq" } ;
HELP: monotonic?
{ $values { "seq" sequence } { "quot" { $quotation "( elt elt -- ? )" } } { "?" "a boolean" } }
{ $description "Applies the relation to successive pairs of elements in the sequence, testing for a truth value. The relation should be a transitive relation, such as a total order or an equality relation." }
{ $examples
"Testing if a sequence is non-decreasing:"
{ $example "USING: math prettyprint sequences ;" "{ 1 1 2 } [ <= ] monotonic? ." "t" }
"Testing if a sequence is decreasing:"
{ $example "USING: math prettyprint sequences ;" "{ 9 8 6 7 } [ < ] monotonic? ." "f" }
} ;
{ monotonic? all-eq? all-equal? } related-words
HELP: interleave
{ $values { "seq" sequence } { "between" "a quotation" } { "quot" { $quotation "( elt -- )" } } }
{ $description "Applies " { $snippet "quot" } " to each element in turn, also invoking " { $snippet "between" } " in-between each pair of elements." }
@ -565,14 +553,6 @@ HELP: pop
{ $side-effects "seq" }
{ $errors "Throws an error if the sequence is empty." } ;
HELP: all-equal?
{ $values { "seq" sequence } { "?" "a boolean" } }
{ $description "Tests if all elements in the sequence are equal. Yields true with an empty sequence." } ;
HELP: all-eq?
{ $values { "seq" sequence } { "?" "a boolean" } }
{ $description "Tests if all elements in the sequence are the same identical object. Yields true with an empty sequence." } ;
HELP: mismatch
{ $values { "seq1" sequence } { "seq2" sequence } { "i" "an index" } }
{ $description "Compares pairs of elements up to the minimum of the sequences' lengths, outputting the first index where the two sequences have non-equal elements, or " { $link f } " if all tested elements were equal." } ;
@ -1443,8 +1423,6 @@ ARTICLE: "sequences-combinators" "Sequence combinators"
"Testing if a sequence contains elements satisfying a predicate:"
{ $subsection contains? }
{ $subsection all? }
"Testing how elements are related:"
{ $subsection monotonic? }
{ $subsection "sequence-2combinators" }
{ $subsection "sequence-3combinators" } ;
@ -1473,10 +1451,7 @@ ARTICLE: "sequences-tests" "Testing sequences"
"Testing if a sequence contains a subsequence:"
{ $subsection head? }
{ $subsection tail? }
{ $subsection subseq? }
"Testing how elements are related:"
{ $subsection all-eq? }
{ $subsection all-equal? } ;
{ $subsection subseq? } ;
ARTICLE: "sequences-search" "Searching sequences"
"Finding the index of an element:"

7
core/sequences/sequences-tests.factor
View File

@ -73,13 +73,6 @@ unit-test
[ { { 1 4 } { 2 5 } { 3 6 } } ]
[ { { 1 2 3 } { 4 5 6 } } flip ] unit-test
[ f ] [ [ { } { } "Hello" ] all-equal? ] unit-test
[ f ] [ [ { 2 } { } { } ] all-equal? ] unit-test
[ t ] [ [ ] all-equal? ] unit-test
[ t ] [ [ 1234 ] all-equal? ] unit-test
[ f ] [ [ 1.0 1 1 ] all-equal? ] unit-test
[ t ] [ { 1 2 3 4 } [ < ] monotonic? ] unit-test
[ f ] [ { 1 2 3 4 } [ > ] monotonic? ] unit-test
[ [ 2 3 4 ] ] [ [ 1 2 3 ] 1 [ + ] curry map ] unit-test
[ 1 ] [ 0 [ 1 2 ] nth ] unit-test

15
core/sequences/sequences.factor
View File

@ -386,10 +386,6 @@ PRIVATE>
[ 2drop f f ]
if ; inline
: (monotonic) ( seq quot -- ? )
[ 2dup nth-unsafe rot 1+ rot nth-unsafe ]
prepose curry ; inline
: (interleave) ( n elt between quot -- )
roll 0 = [ nip ] [ swapd 2slip ] if call ; inline
@ -479,9 +475,6 @@ PRIVATE>
: partition ( seq quot -- trueseq falseseq )
over [ 2pusher [ each ] 2dip ] dip tuck [ like ] 2bi@ ; inline
: monotonic? ( seq quot -- ? )
[ [ length 1- ] keep ] dip (monotonic) all? ; inline
: interleave ( seq between quot -- )
[ (interleave) ] 2curry [ [ length ] keep ] dip 2each ; inline
@ -671,10 +664,6 @@ PRIVATE>
: pop ( seq -- elt )
[ length 1- ] [ [ nth ] [ shorten ] 2bi ] bi ;
: all-equal? ( seq -- ? ) [ = ] monotonic? ;
: all-eq? ( seq -- ? ) [ eq? ] monotonic? ;
: exchange ( m n seq -- )
pick over bounds-check 2drop 2dup bounds-check 2drop
exchange-unsafe ;
@ -696,9 +685,7 @@ PRIVATE>
0 [ length + ] reduce ;
: concat ( seq -- newseq )
[
{ }
] [
[ { } ] [
[ sum-lengths ] keep
[ first new-resizable ] keep
[ [ over push-all ] each ] keep

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

@ -1,5 +1,5 @@
USING: sorting sequences kernel math math.order random
tools.test vectors sets vocabs ;
tools.test vectors sets vocabs grouping ;
IN: sorting.tests
[ { } ] [ { } natural-sort ] unit-test

2
core/vocabs/loader/loader-tests.factor
View File

@ -3,7 +3,7 @@ USING: vocabs.loader tools.test continuations vocabs math
kernel arrays sequences namespaces io.streams.string
parser source-files words assocs classes.tuple definitions
debugger compiler.units tools.vocabs accessors eval
combinators vocabs.parser ;
combinators vocabs.parser grouping ;
! This vocab should not exist, but just in case...
[ ] [

2
extra/fuel/fuel.factor
View File

@ -141,7 +141,7 @@ PRIVATE>
: fuel-get-article ( name -- ) article fuel-eval-set-result ;
MEMO: fuel-get-article-title ( name -- )
: fuel-get-article-title ( name -- )
articles get at [ article-title ] [ f ] if* fuel-eval-set-result ;
: fuel-word-help ( name -- ) (fuel-word-help) fuel-eval-set-result ;

3
extra/project-euler/052/052.factor
View File

@ -1,7 +1,8 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.short-circuit kernel math
project-euler.common sequences sorting ;
project-euler.common sequences sorting
grouping ;
IN: project-euler.052
! http://projecteuler.net/index.php?section=problems&id=52

7
misc/fuel/README
View File

@ -18,16 +18,11 @@ beast.
(load-file "<path/to/factor/installation>/misc/fuel/fu.el")
or
(add-to-list load-path "<path/to/factor/installation>/fuel")
(require 'fuel)
If all you want is a major mode for editing Factor code with pretty
font colors and indentation, without running the factor listener
inside Emacs, you can use instead:
(add-to-list load-path "<path/to/factor/installation>/fuel")
(add-to-list 'load-path "<path/to/factor/installation>/fuel")
(setq factor-mode-use-fuel nil)
(require 'factor-mode)

1
misc/fuel/fuel-eval.el
View File

@ -31,6 +31,7 @@
((listp sexp)
(case (car sexp)
(:array (factor--seq 'V{ '} (cdr sexp)))
(:seq (factor--seq '{ '} (cdr sexp)))
(:quote (format "\\ %s" (factor `(:factor ,(cadr sexp)))))
(:quotation (factor--seq '\[ '\] (cdr sexp)))
(:using (factor `(USING: ,@(cdr sexp) :end)))

26
misc/fuel/fuel-font-lock.el
View File

@ -72,11 +72,21 @@
;;; Font lock:
(defun fuel-font-lock--syntactic-face (state)
(cond ((nth 3 state) 'factor-font-lock-string)
((char-equal (char-after (nth 8 state)) ?\ )
(save-excursion
(goto-char (nth 8 state))
(beginning-of-line)
(cond ((looking-at "USING: ") 'factor-font-lock-vocabulary-name)
((looking-at "\\(TUPLE\\|SYMBOLS\\|VARS\\): ")
'factor-font-lock-symbol)
(t 'default))))
(t 'factor-font-lock-comment)))
(defconst fuel-font-lock--font-lock-keywords
`((,fuel-syntax--stack-effect-regex . 'factor-font-lock-stack-effect)
(,fuel-syntax--parsing-words-regex . 'factor-font-lock-parsing-word)
(,fuel-syntax--brace-words-regex 1 'factor-font-lock-parsing-word)
("\\(P\\|SBUF\\)\"" 1 'factor-font-lock-parsing-word)
(,fuel-syntax--vocab-ref-regexp 2 'factor-font-lock-vocabulary-name)
(,fuel-syntax--declaration-words-regex . 'factor-font-lock-declaration)
(,fuel-syntax--word-definition-regex 2 'factor-font-lock-word)
@ -89,24 +99,26 @@
(,fuel-syntax--type-definition-regex 2 'factor-font-lock-type-name)
(,fuel-syntax--method-definition-regex (1 'factor-font-lock-type-name)
(2 'factor-font-lock-word))
(,fuel-syntax--parent-type-regex 2 'factor-font-lock-type-name)
(,fuel-syntax--tuple-decl-regex 2 'factor-font-lock-type-name)
(,fuel-syntax--constructor-regex . 'factor-font-lock-constructor)
(,fuel-syntax--setter-regex . 'factor-font-lock-setter-word)
(,fuel-syntax--getter-regex . 'factor-font-lock-getter-word)
(,fuel-syntax--symbol-definition-regex 2 'factor-font-lock-symbol)
(,fuel-syntax--bad-string-regex . 'factor-font-lock-invalid-syntax)))
(,fuel-syntax--bad-string-regex . 'factor-font-lock-invalid-syntax)
("\\(P\\|SBUF\\)\"" 1 'factor-font-lock-parsing-word)
(,fuel-syntax--parsing-words-regex . 'factor-font-lock-parsing-word)))
(defun fuel-font-lock--font-lock-setup (&optional keywords no-syntax)
(set (make-local-variable 'comment-start) "! ")
(set (make-local-variable 'parse-sexp-lookup-properties) t)
(set (make-local-variable 'font-lock-comment-face) 'factor-font-lock-comment)
(set (make-local-variable 'font-lock-string-face) 'factor-font-lock-string)
(set (make-local-variable 'font-lock-defaults)
`(,(or keywords 'fuel-font-lock--font-lock-keywords)
nil nil nil nil
,@(if no-syntax nil
(list (cons 'font-lock-syntactic-keywords
fuel-syntax--syntactic-keywords))))))
fuel-syntax--syntactic-keywords)
(cons 'font-lock-syntactic-face-function
'fuel-font-lock--syntactic-face))))))
;;; Fontify strings as Factor code:

3
misc/fuel/fuel-help.el
View File

@ -137,7 +137,8 @@
(defun fuel-help--get-article (name label)
(message "Retrieving article ...")
(let* ((cmd `(:fuel* ((,name fuel-get-article)) "fuel" t))
(let* ((name (if (listp name) (cons :seq name) name))
(cmd `(:fuel* ((,name fuel-get-article)) "fuel" t))
(ret (fuel-eval--send/wait cmd))
(res (fuel-eval--retort-result ret)))
(if (not res)

11
misc/fuel/fuel-listener.el
View File

@ -31,7 +31,12 @@
:group 'fuel)
(defcustom fuel-listener-factor-binary
(expand-file-name "factor" fuel-factor-root-dir)
(expand-file-name (cond ((eq system-type 'windows-nt)
"factor.exe")
((eq system-type 'darwin)
"Factor.app/Contents/MacOS/factor")
(t "factor"))
fuel-factor-root-dir)
"Full path to the factor executable to use when starting a listener."
:type '(file :must-match t)
:group 'fuel-listener)
@ -132,8 +137,7 @@ buffer."
(defun fuel-listener--setup-completion ()
(setq fuel-syntax--current-vocab-function 'fuel-listener--current-vocab)
(setq fuel-syntax--usings-function 'fuel-listener--usings)
(set-syntax-table fuel-syntax--syntax-table))
(setq fuel-syntax--usings-function 'fuel-listener--usings))
;;; Stack mode support
@ -160,7 +164,6 @@ buffer."
(set (make-local-variable 'comint-prompt-regexp) fuel-con--prompt-regex)
(set (make-local-variable 'comint-use-prompt-regexp) t)
(set (make-local-variable 'comint-prompt-read-only) t)
(set-syntax-table fuel-syntax--syntax-table)
(fuel-listener--setup-completion)
(fuel-listener--setup-stack-mode))

7
misc/fuel/fuel-markup.el
View File

@ -61,7 +61,7 @@
(defun fuel-markup--insert-button (label link type)
(let ((label (format "%s" label))
(link (format "%s" link)))
(link (if (listp link) link (format "%s" link))))
(insert-text-button label
:type 'fuel-markup--button
'markup-link link
@ -70,8 +70,9 @@
'help-echo (format "%s (%s)" label type))))
(defun fuel-markup--article-title (name)
(fuel-eval--retort-result
(fuel-eval--send/wait `(:fuel* ((,name fuel-get-article-title)) "fuel"))))
(let ((name (if (listp name) (cons :seq name) name)))
(fuel-eval--retort-result
(fuel-eval--send/wait `(:fuel* ((,name fuel-get-article-title)) "fuel")))))
(defun fuel-markup--link-at-point ()
(let ((button (condition-case nil (forward-button 0) (error nil))))

79
misc/fuel/fuel-syntax.el
View File

@ -79,7 +79,7 @@
(regexp-opt fuel-syntax--declaration-words 'words))
(defsubst fuel-syntax--second-word-regex (prefixes)
(format "^%s +\\([^ \r\n]+\\)" (regexp-opt prefixes t)))
(format "%s +\\([^ \r\n]+\\)" (regexp-opt prefixes t)))
(defconst fuel-syntax--method-definition-regex
"^M: +\\([^ ]+\\) +\\([^ ]+\\)")
@ -87,14 +87,22 @@
(defconst fuel-syntax--integer-regex
"\\_<-?[0-9]+\\_>")
(defconst fuel-syntax--ratio-regex
"\\_<-?\\([0-9]+\\+\\)?[0-9]+/-?[0-9]+\\_>")
(defconst fuel-syntax--raw-float-regex
"[0-9]*\\.[0-9]*\\([eE][+-]?[0-9]+\\)?")
(defconst fuel-syntax--float-regex
"\\_<-?[0-9]+\\.[0-9]*\\([eE][+-]?[0-9]+\\)?\\_>")
(format "\\_<-?%s\\_>" fuel-syntax--raw-float-regex))
(defconst fuel-syntax--number-regex
(format "\\([0-9]+\\|%s\\)" fuel-syntax--raw-float-regex))
(defconst fuel-syntax--ratio-regex
(format "\\_<[+-]?%s/-?%s\\_>"
fuel-syntax--number-regex
fuel-syntax--number-regex))
(defconst fuel-syntax--bad-string-regex
"\"\\([^\"]\\|\\\\\"\\)*\n")
"\\_<\"[^>]\\([^\"\n]\\|\\\\\"\\)*\n")
(defconst fuel-syntax--word-definition-regex
(fuel-syntax--second-word-regex
@ -114,8 +122,8 @@
(defconst fuel-syntax--type-definition-regex
(fuel-syntax--second-word-regex '("MIXIN:" "TUPLE:" "SINGLETON:" "UNION:")))
(defconst fuel-syntax--parent-type-regex
"^\\(TUPLE\\|PREDICTE\\): +[^ ]+ +< +\\([^ ]+\\)")
(defconst fuel-syntax--tuple-decl-regex
"^TUPLE: +\\([^ \n]+\\) +< +\\([^ \n]+\\)\\_>")
(defconst fuel-syntax--constructor-regex "<[^ >]+>")
@ -125,7 +133,8 @@
(defconst fuel-syntax--symbol-definition-regex
(fuel-syntax--second-word-regex '("SYMBOL:" "VAR:")))
(defconst fuel-syntax--stack-effect-regex " ( .* )")
(defconst fuel-syntax--stack-effect-regex
"\\( ( .* )\\)\\|\\( (( .* ))\\)")
(defconst fuel-syntax--using-lines-regex "^USING: +\\([^;]+\\);")
@ -163,26 +172,26 @@
fuel-syntax--declaration-words-regex))
(defconst fuel-syntax--single-liner-regex
(format "^%s" (regexp-opt '("ABOUT:"
"ARTICLE:"
"ALIAS:"
"CONSTANT:" "C:"
"DEFER:"
"FORGET:"
"GENERIC:" "GENERIC#"
"HELP:" "HEX:" "HOOK:"
"IN:" "INSTANCE:"
"MAIN:" "MATH:" "MIXIN:"
"OCT:"
"POSTPONE:" "PRIVATE>" "<PRIVATE"
"QUALIFIED-WITH:" "QUALIFIED:"
"RENAME:"
"SINGLETON:" "SLOT:" "SYMBOL:"
"USE:"
"VAR:"))))
(regexp-opt '("ABOUT:"
"ARTICLE:"
"ALIAS:"
"CONSTANT:" "C:"
"DEFER:"
"FORGET:"
"GENERIC:" "GENERIC#"
"HELP:" "HEX:" "HOOK:"
"IN:" "INSTANCE:"
"MAIN:" "MATH:" "MIXIN:"
"OCT:"
"POSTPONE:" "PRIVATE>" "<PRIVATE"
"QUALIFIED-WITH:" "QUALIFIED:"
"RENAME:"
"SINGLETON:" "SLOT:" "SYMBOL:"
"USE:"
"VAR:")))
(defconst fuel-syntax--begin-of-def-regex
(format "^USING: \\|\\(%s\\)\\|\\(%s .*\\)"
(format "^USING: \\|\\(%s\\)\\|\\(^%s .*\\)"
fuel-syntax--definition-start-regex
fuel-syntax--single-liner-regex))
@ -190,7 +199,7 @@
(format "^.*%s" fuel-syntax--definition-end-regex))
(defconst fuel-syntax--end-of-def-regex
(format "\\(%s\\)\\|\\(%s .*\\)"
(format "\\(%s\\)\\|\\(^%s .*\\)"
fuel-syntax--end-of-def-line-regex
fuel-syntax--single-liner-regex))
@ -220,13 +229,21 @@
table))
(defconst fuel-syntax--syntactic-keywords
`(;; Comments:
`(;; CHARs:
("CHAR: \\(.\\)\\( \\|$\\)" (1 "w"))
;; Comments:
("\\_<\\(#?!\\) .*\\(\n\\|$\\)" (1 "<") (2 ">"))
("\\_<\\(#?!\\)\\(\n\\|$\\)" (1 "<") (2 ">"))
;; CHARs:
("CHAR: \\(.\\)\\( \\|$\\)" (1 "w"))
;; Strings
("\\(\"\\)\\([^\n\r\f\\\"]\\|\\\\\"?\\)*\\(\"\\)" (1 "\"") (3 "\""))
("\\_<\\(\"\\)\\([^\n\r\f\"]\\|\\\\\"\\)*\\(\"\\)\\_>" (1 "\"") (3 "\""))
("\\_<<\\(\"\\)\\_>" (1 "\""))
("\\_<\\(\"\\)>\\_>" (1 "\""))
;; Multiline constructs
("\\_<USING:\\( \\)\\(;\\)" (1 "<b") (2 ">b"))
("\\_<USING:\\( \\)" (1 "<b"))
("\\_<TUPLE: +\\w+? +< +\\w+? *\\( \\)" (1 "<b"))
("\\_<\\(TUPLE\\|SYMBOLS\\|VARS\\): +\\w+? *\\( \\)\\([^<]\\|\\_>\\)" (2 "<b"))
("\\(\n\\| \\);\\_>" (1 ">b"))
;; Let and lambda:
("\\_<\\(!(\\) .* \\()\\)" (1 "<") (2 ">"))
("\\(\\[\\)\\(let\\|wlet\\|let\\*\\)\\( \\|$\\)" (1 "(]"))

2
vm/debug.c
View File

@ -456,7 +456,7 @@ void factorbug(void)
else if(strcmp(cmd,"x") == 0)
exit(1);
else if(strcmp(cmd,"im") == 0)
save_image(STR_FORMAT("fep.image"));
save_image(STRING_LITERAL("fep.image"));
else if(strcmp(cmd,"data") == 0)
dump_objects(-1);
else if(strcmp(cmd,"refs") == 0)

134
vm/factor.c
View File

@ -2,7 +2,7 @@
void default_parameters(F_PARAMETERS *p)
{
p->image = NULL;
p->image_path = NULL;
/* We make a wild guess here that if we're running on ARM, we don't
have a lot of memory. */
@ -38,6 +38,41 @@ void default_parameters(F_PARAMETERS *p)
p->stack_traces = true;
}
INLINE bool factor_arg(const F_CHAR* str, const F_CHAR* arg, CELL* value)
{
int val;
if(SSCANF(str,arg,&val) > 0)
{
*value = val;
return true;
}
else
return false;
}
void init_parameters_from_args(F_PARAMETERS *p, int argc, F_CHAR **argv)
{
default_parameters(p);
int i;
for(i = 1; i < argc; i++)
{
if(factor_arg(argv[i],STRING_LITERAL("-datastack=%d"),&p->ds_size));
else if(factor_arg(argv[i],STRING_LITERAL("-retainstack=%d"),&p->rs_size));
else if(factor_arg(argv[i],STRING_LITERAL("-generations=%d"),&p->gen_count));
else if(factor_arg(argv[i],STRING_LITERAL("-young=%d"),&p->young_size));
else if(factor_arg(argv[i],STRING_LITERAL("-aging=%d"),&p->aging_size));
else if(factor_arg(argv[i],STRING_LITERAL("-tenured=%d"),&p->tenured_size));
else if(factor_arg(argv[i],STRING_LITERAL("-codeheap=%d"),&p->code_size));
else if(STRCMP(argv[i],STRING_LITERAL("-securegc")) == 0) p->secure_gc = true;
else if(STRCMP(argv[i],STRING_LITERAL("-fep")) == 0) p->fep = true;
else if(STRNCMP(argv[i],STRING_LITERAL("-i="),3) == 0) p->image_path = argv[i] + 3;
else if(STRCMP(argv[i],STRING_LITERAL("-console")) == 0) p->console = true;
else if(STRCMP(argv[i],STRING_LITERAL("-no-stack-traces")) == 0) p->stack_traces = false;
}
}
/* Do some initialization that we do once only */
void do_stage1_init(void)
{
@ -51,7 +86,6 @@ void do_stage1_init(void)
fflush(stdout);
}
/* Get things started */
void init_factor(F_PARAMETERS *p)
{
/* Kilobytes */
@ -70,8 +104,12 @@ void init_factor(F_PARAMETERS *p)
/* OS-specific initialization */
early_init();
if(p->image == NULL)
p->image = default_image_path();
if(p->image_path == NULL)
p->image_path = default_image_path();
const F_CHAR *executable_path = vm_executable_path();
if(executable_path)
p->executable_path = executable_path;
srand(current_micros());
init_ffi();
@ -93,6 +131,10 @@ void init_factor(F_PARAMETERS *p)
userenv[OS_ENV] = tag_object(from_char_string(FACTOR_OS_STRING));
userenv[CELL_SIZE_ENV] = tag_fixnum(sizeof(CELL));
userenv[STACK_TRACES_ENV] = tag_boolean(p->stack_traces);
userenv[EXECUTABLE_ENV] = (p->executable_path ?
tag_object(from_native_string(p->executable_path)) : F);
userenv[ARGS_ENV] = F;
userenv[EMBEDDED_ENV] = F;
/* We can GC now */
gc_off = false;
@ -101,57 +143,11 @@ void init_factor(F_PARAMETERS *p)
do_stage1_init();
}
INLINE bool factor_arg(const F_CHAR* str, const F_CHAR* arg, CELL* value)
/* May allocate memory */
void pass_args_to_factor(int argc, F_CHAR **argv)
{
int val;
if(SSCANF(str,arg,&val) > 0)
{
*value = val;
return true;
}
else
return false;
}
void init_factor_from_args(F_CHAR *image, int argc, F_CHAR **argv, bool embedded)
{
F_PARAMETERS p;
default_parameters(&p);
if(image) p.image = image;
CELL i;
posix_argc = argc;
posix_argv = safe_malloc(argc * sizeof(F_CHAR*));
posix_argv[0] = safe_strdup(argv[0]);
for(i = 1; i < argc; i++)
{
posix_argv[i] = safe_strdup(argv[i]);
if(factor_arg(argv[i],STR_FORMAT("-datastack=%d"),&p.ds_size));
else if(factor_arg(argv[i],STR_FORMAT("-retainstack=%d"),&p.rs_size));
else if(factor_arg(argv[i],STR_FORMAT("-generations=%d"),&p.gen_count));
else if(factor_arg(argv[i],STR_FORMAT("-young=%d"),&p.young_size));
else if(factor_arg(argv[i],STR_FORMAT("-aging=%d"),&p.aging_size));
else if(factor_arg(argv[i],STR_FORMAT("-tenured=%d"),&p.tenured_size));
else if(factor_arg(argv[i],STR_FORMAT("-codeheap=%d"),&p.code_size));
else if(STRCMP(argv[i],STR_FORMAT("-securegc")) == 0)
p.secure_gc = true;
else if(STRCMP(argv[i],STR_FORMAT("-fep")) == 0)
p.fep = true;
else if(STRNCMP(argv[i],STR_FORMAT("-i="),3) == 0)
p.image = argv[i] + 3;
else if(STRCMP(argv[i],STR_FORMAT("-console")) == 0)
p.console = true;
else if(STRCMP(argv[i],STR_FORMAT("-no-stack-traces")) == 0)
p.stack_traces = false;
}
init_factor(&p);
nest_stacks();
F_ARRAY *args = allot_array(ARRAY_TYPE,argc,F);
int i;
for(i = 1; i < argc; i++)
{
@ -162,23 +158,31 @@ void init_factor_from_args(F_CHAR *image, int argc, F_CHAR **argv, bool embedded
}
userenv[ARGS_ENV] = tag_object(args);
}
const F_CHAR *executable_path = vm_executable_path();
if(!executable_path)
executable_path = argv[0];
userenv[EXECUTABLE_ENV] = tag_object(from_native_string(executable_path));
userenv[EMBEDDED_ENV] = (embedded ? T : F);
if(p.fep)
factorbug();
void start_factor(F_PARAMETERS *p)
{
if(p->fep) factorbug();
nest_stacks();
c_to_factor_toplevel(userenv[BOOT_ENV]);
unnest_stacks();
}
for(i = 0; i < argc; i++)
free(posix_argv[i]);
free(posix_argv);
void start_embedded_factor(F_PARAMETERS *p)
{
userenv[EMBEDDED_ENV] = T;
start_factor(p);
}
void start_standalone_factor(int argc, F_CHAR **argv)
{
F_PARAMETERS p;
default_parameters(&p);
init_parameters_from_args(&p,argc,argv);
init_factor(&p);
pass_args_to_factor(argc,argv);
start_factor(&p);
}
char *factor_eval_string(char *string)

9
vm/factor.h
View File

@ -1,7 +1,10 @@
int posix_argc;
F_CHAR **posix_argv;
DLLEXPORT void default_parameters(F_PARAMETERS *p);
DLLEXPORT void init_parameters_from_args(F_PARAMETERS *p, int argc, F_CHAR **argv);
DLLEXPORT void init_factor(F_PARAMETERS *p);
DLLEXPORT void pass_args_to_factor(int argc, F_CHAR **argv);
DLLEXPORT void start_embedded_factor(F_PARAMETERS *p);
DLLEXPORT void start_standalone_factor(int argc, F_CHAR **argv);
DLLEXPORT void init_factor_from_args(F_CHAR *image, int argc, F_CHAR **argv, bool embedded);
DLLEXPORT char *factor_eval_string(char *string);
DLLEXPORT void factor_eval_free(char *result);
DLLEXPORT void factor_yield(void);

6
vm/image.c
View File

@ -75,10 +75,10 @@ INLINE void load_code_heap(FILE *file, F_HEADER *h, F_PARAMETERS *p)
/* This function also initializes the data and code heaps */
void load_image(F_PARAMETERS *p)
{
FILE *file = OPEN_READ(p->image);
FILE *file = OPEN_READ(p->image_path);
if(file == NULL)
{
print_string("Cannot open image file: "); print_native_string(p->image); nl();
print_string("Cannot open image file: "); print_native_string(p->image_path); nl();
print_string(strerror(errno)); nl();
exit(1);
}
@ -103,7 +103,7 @@ void load_image(F_PARAMETERS *p)
relocate_code();
/* Store image path name */
userenv[IMAGE_ENV] = tag_object(from_native_string(p->image));
userenv[IMAGE_ENV] = tag_object(from_native_string(p->image_path));
}
/* Save the current image to disk */

3
vm/image.h
View File

@ -26,7 +26,8 @@ typedef struct {
} F_HEADER;
typedef struct {
const F_CHAR* image;
const F_CHAR *image_path;
const F_CHAR *executable_path;
CELL ds_size, rs_size;
CELL gen_count, young_size, aging_size, tenured_size;
CELL code_size;

2
vm/main-unix.c
View File

@ -2,6 +2,6 @@
int main(int argc, char **argv)
{
init_factor_from_args(NULL,argc,argv,false);
start_standalone_factor(argc,argv);
return 0;
}

8
vm/main-windows-ce.c
View File

@ -1,5 +1,3 @@
#include <windows.h>
#include <stdio.h>
#include "master.h"
/*
@ -8,7 +6,9 @@
This would not be necessary if Windows CE had CommandLineToArgvW.
Based on MinGW's public domain char** version. */
Based on MinGW's public domain char** version.
*/
int __argc;
wchar_t **__argv;
@ -128,7 +128,7 @@ WinMain(
int nCmdShow)
{
parse_args(&__argc, &__argv, lpCmdLine);
init_factor_from_args(NULL,__argc,(LPWSTR*)__argv,false);
start_standalone_factor(__argc,(LPWSTR*)__argv);
// memory leak from malloc, wcsdup
return 0;
}

2
vm/main-windows-nt.c
View File

@ -19,7 +19,7 @@ int WINAPI WinMain(
return 1;
}
init_factor_from_args(NULL,nArgs,szArglist,false);
start_standalone_factor(nArgs,szArglist);
LocalFree(szArglist);

2
vm/os-unix.h
View File

@ -16,7 +16,7 @@ typedef char F_SYMBOL;
#define string_to_native_alien(string) string_to_char_alien(string,true)
#define unbox_symbol_string unbox_char_string
#define STR_FORMAT(string) string
#define STRING_LITERAL(string) string
#define SSCANF sscanf
#define STRCMP strcmp

12
vm/os-windows.h
View File

@ -11,7 +11,7 @@ typedef wchar_t F_CHAR;
#define unbox_native_string unbox_u16_string
#define string_to_native_alien(string) string_to_u16_alien(string,true)
#define STR_FORMAT(string) L##string
#define STRING_LITERAL(string) L##string
#define MAX_UNICODE_PATH 32768
#define DLLEXPORT __declspec(dllexport)
@ -20,20 +20,18 @@ typedef wchar_t F_CHAR;
#define STRNCMP wcsncmp
#define STRDUP _wcsdup
#ifdef WIN64
#define CELL_FORMAT "%Iu"
#define CELL_HEX_FORMAT "%Ix"
#define CELL_HEX_FORMAT "%Ix"
#define CELL_HEX_PAD_FORMAT "%016Ix"
#define FIXNUM_FORMAT "%Id"
#define FIXNUM_FORMAT "%Id"
#else
#define CELL_FORMAT "%lu"
#define CELL_HEX_FORMAT "%lx"
#define CELL_HEX_FORMAT "%lx"
#define CELL_HEX_PAD_FORMAT "%08lx"
#define FIXNUM_FORMAT "%ld"
#define FIXNUM_FORMAT "%ld"
#endif
#define OPEN_READ(path) _wfopen(path,L"rb")
#define OPEN_WRITE(path) _wfopen(path,L"wb")