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

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

db4
Doug Coleman 2007-04-14 04:27:38 -05:00
parent b993a1c588 8638430185
commit ff0098c0d1
208 changed files with 9106 additions and 2067 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitignore vendored
View File

@ -18,4 +18,4 @@ factor
temp
logs
work
buildsupport/wordsize
build-support/wordsize

70
build-support/target
View File

@ -1,38 +1,38 @@
#!/bin/sh
if [ \( `uname -s ` = FreeBSD \) -a \( `uname -p` = i386 \) ]
then
echo freebsd-x86-32
elif [ \( `uname -s` = FreeBSD \) -a \( `uname -m` = amd64 \) ]
then
echo freebsd-x86-64
elif [ \( `uname -s` = OpenBSD \) -a \( `uname -m` = i386 \) ]
then
echo openbsd-x86-32
elif [ \( `uname -s` = OpenBSD \) -a \( `uname -m` = amd64 \) ]
then
echo openbsd-x86-64
elif [ \( `uname -s` = NetBSD \) -a \( `uname -p` = i386 \) ]
then
echo netbsd-x86-32
elif [ \( `uname -s` = NetBSD \) -a \( `uname -p` = x86_64 \) ]
then
echo netbsd-x86-64
elif [ \( `uname -s` = Darwin \) -a \( `uname -p` = powerpc \) ]
then
echo macosx-ppc
elif [ `uname -s` = Darwin ]
then
echo macosx-x86-`./build-support/wordsize`
elif [ \( `uname -s` = Linux \) -a \( `uname -m` = i686 \) ]
then
echo linux-x86-32
elif [ \( `uname -s` = Linux \) -a \( `uname -m` = x86_64 \) ]
then
echo linux-x86-64
elif [ \( `uname -o` = Cygwin \) -a \( `uname -m` = i686 \) ]
then
echo winnt-x86-`./build-support/wordsize`
else
echo help
uname_s=`uname -s`
case $uname_s in
CYGWIN_NT-5.2-WOW64) OS=winnt;;
*CYGWIN_NT*) OS=winnt;;
*CYGWIN*) OS=winnt;;
*darwin*) OS=macosx;;
*Darwin*) OS=macosx;;
*linux*) OS=linux;;
*Linux*) OS=linux;;
*NetBSD*) OS=netbsd;;
*FreeBSD*) OS=freebsd;;
*OpenBSD*) OS=openbsd;;
*DragonFly*) OS=dragonflybsd;;
esac
uname_m=`uname -m`
case $uname_m in
i386) ARCH=x86;;
i686) ARCH=x86;;
amd64) ARCH=x86;;
*86) ARCH=x86;;
*86_64) ARCH=x86;;
"Power Macintosh") ARCH=ppc;;
esac
WORD=`./build-support/wordsize`
MAKE_TARGET=$OS-$ARCH-$WORD
if [[ $OS == macosx && $ARCH == ppc ]] ; then
MAKE_TARGET=$OS-$ARCH
fi
if [[ $OS == linux && $ARCH == ppc ]] ; then
MAKE_TARGET=$OS-$ARCH
fi
echo $MAKE_TARGET

4
core/alien/alien.factor
View File

@ -7,7 +7,7 @@ IN: alien
! Some predicate classes used by the compiler for optimization
! purposes
PREDICATE: alien simple-alien
PREDICATE: simple-alien < alien
underlying-alien not ;
UNION: simple-c-ptr
@ -18,7 +18,7 @@ alien POSTPONE: f byte-array bit-array float-array ;
DEFER: pinned-c-ptr?
PREDICATE: alien pinned-alien
PREDICATE: pinned-alien < alien
underlying-alien pinned-c-ptr? ;
UNION: pinned-c-ptr

2
core/arrays/arrays.factor Normal file → Executable file
View File

@ -31,4 +31,4 @@ INSTANCE: array sequence
: 4array ( w x y z -- array ) { } 4sequence ; flushable
PREDICATE: array pair length 2 number= ;
PREDICATE: pair < array length 2 number= ;

11
core/assocs/assocs-tests.factor Normal file → Executable file
View File

@ -93,3 +93,14 @@ unit-test
] [
F{ 1.0 2.0 } [ dup ] H{ } map>assoc
] unit-test
[ { 3 } ] [
[
3
H{ } clone
2 [
2dup [ , f ] cache drop
] times
2drop
] { } make
] unit-test

6
core/assocs/assocs.factor
View File

@ -134,11 +134,11 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
(substitute) map ;
: cache ( key assoc quot -- value )
2over at [
2over at* [
>r 3drop r>
] [
pick rot >r >r call dup r> r> set-at
] if* ; inline
drop pick rot >r >r call dup r> r> set-at
] if ; inline
: change-at ( key assoc quot -- )
[ >r at r> call ] 3keep drop set-at ; inline

2
core/bootstrap/compiler/compiler.factor
View File

@ -36,7 +36,7 @@ nl
{
roll -roll declare not
tuple-class-eq? array? hashtable? vector?
array? hashtable? vector?
tuple? sbuf? node? tombstone?
array-capacity array-nth set-array-nth

45
core/bootstrap/image/image.factor
View File

@ -4,7 +4,7 @@ USING: alien arrays bit-arrays byte-arrays generic assocs
hashtables assocs hashtables.private io kernel kernel.private
math namespaces parser prettyprint sequences sequences.private
strings sbufs vectors words quotations assocs system layouts
splitting growable classes tuples words.private
splitting growable classes tuples tuples.private words.private
io.binary io.files vocabs vocabs.loader source-files
definitions debugger float-arrays quotations.private
sequences.private combinators io.encodings.binary ;
@ -294,17 +294,14 @@ M: bit-array ' bit-array emit-dummy-array ;
M: float-array ' float-array emit-dummy-array ;
! Arrays
: emit-array ( list type tag -- pointer )
>r >r [ ' ] map r> r> [
dup length emit-fixnum
emit-seq
] emit-object ;
: emit-tuple ( obj -- pointer )
! Tuples
: emit-tuple ( tuple -- pointer )
[
[ tuple>array unclip transfer-word , % ] { } make
tuple type-number dup emit-array
[
dup class transfer-word tuple-layout ' ,
tuple>array 1 tail-slice [ ' ] map %
] { } make
tuple type-number dup [ emit-seq ] emit-object
]
! Hack
over class word-name "tombstone" =
@ -312,11 +309,31 @@ M: float-array ' float-array emit-dummy-array ;
M: tuple ' emit-tuple ;
M: tuple-layout '
objects get [
[
dup layout-hashcode ' ,
dup layout-class ' ,
dup layout-size ' ,
dup layout-superclasses ' ,
layout-echelon ' ,
] { } make
\ tuple-layout type-number
object tag-number [ emit-seq ] emit-object
] cache ;
M: tombstone '
delegate
"((tombstone))" "((empty))" ? "hashtables.private" lookup
word-def first objects get [ emit-tuple ] cache ;
! Arrays
: emit-array ( list type tag -- pointer )
>r >r [ ' ] map r> r> [
dup length emit-fixnum
emit-seq
] emit-object ;
M: array '
array type-number object tag-number emit-array ;
@ -348,8 +365,10 @@ M: curry '
: emit-global ( -- )
[
{
dictionary source-files
typemap builtins class<map class-map update-map
dictionary source-files builtins
update-map class<-cache class-not-cache
classes-intersect-cache class-and-cache
class-or-cache
} [ dup get swap bootstrap-word set ] each
] H{ } make-assoc
bootstrap-global set

5
core/bootstrap/layouts/layouts.factor
View File

@ -2,13 +2,13 @@
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces math words kernel alien byte-arrays
hashtables vectors strings sbufs arrays bit-arrays
float-arrays quotations assocs layouts tuples ;
float-arrays quotations assocs layouts tuples tuples.private ;
BIN: 111 tag-mask set
8 num-tags set
3 tag-bits set
19 num-types set
20 num-types set
H{
{ fixnum BIN: 000 }
@ -33,4 +33,5 @@ tag-numbers get H{
{ alien 16 }
{ word 17 }
{ byte-array 18 }
{ tuple-layout 19 }
} union type-numbers set

93
core/bootstrap/primitives.factor
View File

@ -3,8 +3,8 @@
USING: alien arrays byte-arrays generic hashtables
hashtables.private io kernel math namespaces parser sequences
strings vectors words quotations assocs layouts classes tuples
kernel.private vocabs vocabs.loader source-files definitions
slots.deprecated classes.union compiler.units
tuples.private kernel.private vocabs vocabs.loader source-files
definitions slots.deprecated classes.union compiler.units
bootstrap.image.private io.files ;
IN: bootstrap.primitives
@ -31,6 +31,9 @@ crossref off
H{ } clone dictionary set
H{ } clone changed-words set
H{ } clone root-cache set
H{ } clone source-files set
H{ } clone update-map set
init-caches
! Vocabulary for slot accessors
"accessors" create-vocab drop
@ -43,6 +46,9 @@ call
call
call
! After we execute bootstrap/layouts
num-types get f <array> builtins set
! Create some empty vocabs where the below primitives and
! classes will go
{
@ -93,11 +99,6 @@ call
"vectors.private"
} [ create-vocab drop ] each
H{ } clone source-files set
H{ } clone update-map set
H{ } clone class<map set
H{ } clone class-map set
! Builtin classes
: builtin-predicate-quot ( class -- quot )
[
@ -130,9 +131,6 @@ H{ } clone class-map set
dup define-builtin-predicate
r> define-builtin-slots ;
H{ } clone typemap set
num-types get f <array> builtins set
! Forward definitions
"object" "kernel" create t "class" set-word-prop
"object" "kernel" create union-class "metaclass" set-word-prop
@ -145,8 +143,6 @@ num-types get f <array> builtins set
"bignum" "math" create { } define-builtin
"bignum" "math" create ">bignum" "math" create 1quotation "coercer" set-word-prop
"tuple" "kernel" create { } define-builtin
"ratio" "math" create {
{
{ "integer" "math" }
@ -182,8 +178,6 @@ num-types get f <array> builtins set
"f" "syntax" lookup { } define-builtin
! do not word...
"array" "arrays" create { } define-builtin
"wrapper" "kernel" create {
@ -297,6 +291,54 @@ define-builtin
"callstack" "kernel" create { } define-builtin
"tuple-layout" "tuples.private" create {
{
{ "fixnum" "math" }
"hashcode"
{ "layout-hashcode" "tuples.private" }
f
}
{
{ "word" "words" }
"class"
{ "layout-class" "tuples.private" }
f
}
{
{ "fixnum" "math" }
"size"
{ "layout-size" "tuples.private" }
f
}
{
{ "array" "arrays" }
"superclasses"
{ "layout-superclasses" "tuples.private" }
f
}
{
{ "fixnum" "math" }
"echelon"
{ "layout-echelon" "tuples.private" }
f
}
} define-builtin
"tuple" "kernel" create { } define-builtin
"tuple" "kernel" lookup
{
{
{ "object" "kernel" }
"delegate"
{ "delegate" "kernel" }
{ "set-delegate" "kernel" }
}
}
define-tuple-slots
"tuple" "kernel" lookup define-tuple-layout
! Define general-t type, which is any object that is not f.
"general-t" "kernel" create
"f" "syntax" lookup builtins get remove [ ] subset f union-class
@ -322,7 +364,9 @@ builtins get num-tags get tail f union-class define-class
"null" "kernel" create { } f union-class define-class
! Create special tombstone values
"tombstone" "hashtables.private" create { } define-tuple-class
"tombstone" "hashtables.private" create
"tuple" "kernel" lookup
{ } define-tuple-class
"((empty))" "hashtables.private" create
"tombstone" "hashtables.private" lookup f
@ -334,6 +378,7 @@ builtins get num-tags get tail f union-class define-class
! Some tuple classes
"hashtable" "hashtables" create
"tuple" "kernel" lookup
{
{
{ "array-capacity" "sequences.private" }
@ -354,6 +399,7 @@ builtins get num-tags get tail f union-class define-class
} define-tuple-class
"sbuf" "sbufs" create
"tuple" "kernel" lookup
{
{
{ "string" "strings" }
@ -369,6 +415,7 @@ builtins get num-tags get tail f union-class define-class
} define-tuple-class
"vector" "vectors" create
"tuple" "kernel" lookup
{
{
{ "array" "arrays" }
@ -384,6 +431,7 @@ builtins get num-tags get tail f union-class define-class
} define-tuple-class
"byte-vector" "byte-vectors" create
"tuple" "kernel" lookup
{
{
{ "byte-array" "byte-arrays" }
@ -399,6 +447,7 @@ builtins get num-tags get tail f union-class define-class
} define-tuple-class
"bit-vector" "bit-vectors" create
"tuple" "kernel" lookup
{
{
{ "bit-array" "bit-arrays" }
@ -414,6 +463,7 @@ builtins get num-tags get tail f union-class define-class
} define-tuple-class
"float-vector" "float-vectors" create
"tuple" "kernel" lookup
{
{
{ "float-array" "float-arrays" }
@ -429,6 +479,7 @@ builtins get num-tags get tail f union-class define-class
} define-tuple-class
"curry" "kernel" create
"tuple" "kernel" lookup
{
{
{ "object" "kernel" }
@ -443,7 +494,12 @@ builtins get num-tags get tail f union-class define-class
}
} define-tuple-class
"curry" "kernel" lookup
dup f "inline" set-word-prop
dup tuple-layout [ <tuple-boa> ] curry define
"compose" "kernel" create
"tuple" "kernel" lookup
{
{
{ "object" "kernel" }
@ -458,6 +514,10 @@ builtins get num-tags get tail f union-class define-class
}
} define-tuple-class
"compose" "kernel" lookup
dup f "inline" set-word-prop
dup tuple-layout [ <tuple-boa> ] curry define
! Primitive words
: make-primitive ( word vocab n -- )
>r create dup reset-word r>
@ -632,11 +692,10 @@ builtins get num-tags get tail f union-class define-class
{ "<wrapper>" "kernel" }
{ "(clone)" "kernel" }
{ "<string>" "strings" }
{ "(>tuple)" "tuples.private" }
{ "array>quotation" "quotations.private" }
{ "quotation-xt" "quotations" }
{ "<tuple>" "tuples.private" }
{ "tuple>array" "tuples" }
{ "<tuple-layout>" "tuples.private" }
{ "profiling" "tools.profiler.private" }
{ "become" "kernel.private" }
{ "(sleep)" "threads.private" }

2
core/bootstrap/stage1.factor
View File

@ -39,7 +39,7 @@ vocabs.loader system debugger continuations ;
[
"resource:core/bootstrap/stage2.factor"
dup resource-exists? [
dup exists? [
[ run-file ]
[
:c

55
core/classes/algebra/algebra-docs.factor Executable file
View File

@ -0,0 +1,55 @@
USING: help.markup help.syntax kernel classes ;
IN: classes.algebra
ARTICLE: "class-operations" "Class operations"
"Set-theoretic operations on classes:"
{ $subsection class< }
{ $subsection class-and }
{ $subsection class-or }
{ $subsection classes-intersect? }
"Topological sort:"
{ $subsection sort-classes }
{ $subsection min-class }
"Low-level implementation detail:"
{ $subsection class-types }
{ $subsection flatten-class }
{ $subsection flatten-builtin-class }
{ $subsection class-types }
{ $subsection class-tags } ;
HELP: flatten-builtin-class
{ $values { "class" class } { "assoc" "an assoc whose keys are classes" } }
{ $description "Outputs a set of tuple classes whose union is the smallest cover of " { $snippet "class" } " intersected with " { $link tuple } "." } ;
HELP: flatten-class
{ $values { "class" class } { "assoc" "an assoc whose keys are classes" } }
{ $description "Outputs a set of builtin and tuple classes whose union is the smallest cover of " { $snippet "class" } "." } ;
HELP: class-types
{ $values { "class" class } { "seq" "an increasing sequence of integers" } }
{ $description "Outputs a sequence of builtin type numbers whose instances can possibly be instances of the given class." } ;
HELP: class<
{ $values { "first" "a class" } { "second" "a class" } { "?" "a boolean" } }
{ $description "Tests if all instances of " { $snippet "class1" } " are also instances of " { $snippet "class2" } "." }
{ $notes "Classes are partially ordered. This means that if " { $snippet "class1 <= class2" } " and " { $snippet "class2 <= class1" } ", then " { $snippet "class1 = class2" } ". Also, if " { $snippet "class1 <= class2" } " and " { $snippet "class2 <= class3" } ", then " { $snippet "class1 <= class3" } "." } ;
HELP: sort-classes
{ $values { "seq" "a sequence of class" } { "newseq" "a new seqence of classes" } }
{ $description "Outputs a topological sort of a sequence of classes. Larger classes come before their subclasses." } ;
HELP: class-or
{ $values { "first" class } { "second" class } { "class" class } }
{ $description "Outputs the smallest anonymous class containing both " { $snippet "class1" } " and " { $snippet "class2" } "." } ;
HELP: class-and
{ $values { "first" class } { "second" class } { "class" class } }
{ $description "Outputs the largest anonymous class contained in both " { $snippet "class1" } " and " { $snippet "class2" } "." } ;
HELP: classes-intersect?
{ $values { "first" class } { "second" class } { "?" "a boolean" } }
{ $description "Tests if two classes have a non-empty intersection. If the intersection is empty, no object can be an instance of both classes at once." } ;
HELP: min-class
{ $values { "class" class } { "seq" "a sequence of class words" } { "class/f" "a class word or " { $link f } } }
{ $description "If all classes in " { $snippet "seq" } " that intersect " { $snippet "class" } " are subtypes of " { $snippet "class" } ", outputs the last such element of " { $snippet "seq" } ". If any conditions fail to hold, outputs " { $link f } "." } ;

201
core/classes/algebra/algebra-tests.factor Executable file
View File

@ -0,0 +1,201 @@
IN: classes.algebra.tests
USING: alien arrays definitions generic assocs hashtables io
kernel math namespaces parser prettyprint sequences strings
tools.test vectors words quotations classes classes.algebra
classes.private classes.union classes.mixin classes.predicate
vectors definitions source-files compiler.units growable
random inference effects ;
: class= [ class< ] 2keep swap class< and ;
: class-and* >r class-and r> class= ;
: class-or* >r class-or r> class= ;
[ t ] [ object object object class-and* ] unit-test
[ t ] [ fixnum object fixnum class-and* ] unit-test
[ t ] [ object fixnum fixnum class-and* ] unit-test
[ t ] [ fixnum fixnum fixnum class-and* ] unit-test
[ t ] [ fixnum integer fixnum class-and* ] unit-test
[ t ] [ integer fixnum fixnum class-and* ] unit-test
[ t ] [ vector fixnum null class-and* ] unit-test
[ t ] [ number object number class-and* ] unit-test
[ t ] [ object number number class-and* ] unit-test
[ t ] [ slice reversed null class-and* ] unit-test
[ t ] [ general-t \ f null class-and* ] unit-test
[ t ] [ general-t \ f object class-or* ] unit-test
TUPLE: first-one ;
TUPLE: second-one ;
UNION: both first-one union-class ;
[ t ] [ both tuple classes-intersect? ] unit-test
[ t ] [ vector virtual-sequence null class-and* ] unit-test
[ f ] [ vector virtual-sequence classes-intersect? ] unit-test
[ t ] [ number vector class-or sequence classes-intersect? ] unit-test
[ f ] [ number vector class-and sequence classes-intersect? ] unit-test
[ t ] [ \ fixnum \ integer class< ] unit-test
[ t ] [ \ fixnum \ fixnum class< ] unit-test
[ f ] [ \ integer \ fixnum class< ] unit-test
[ t ] [ \ integer \ object class< ] unit-test
[ f ] [ \ integer \ null class< ] unit-test
[ t ] [ \ null \ object class< ] unit-test
[ t ] [ \ generic \ word class< ] unit-test
[ f ] [ \ word \ generic class< ] unit-test
[ f ] [ \ reversed \ slice class< ] unit-test
[ f ] [ \ slice \ reversed class< ] unit-test
PREDICATE: no-docs < word "documentation" word-prop not ;
UNION: no-docs-union no-docs integer ;
[ t ] [ no-docs no-docs-union class< ] unit-test
[ f ] [ no-docs-union no-docs class< ] unit-test
TUPLE: a ;
TUPLE: b ;
UNION: c a b ;
[ t ] [ \ c \ tuple class< ] unit-test
[ f ] [ \ tuple \ c class< ] unit-test
[ t ] [ \ tuple-class \ class class< ] unit-test
[ f ] [ \ class \ tuple-class class< ] unit-test
TUPLE: delegate-clone ;
[ t ] [ \ null \ delegate-clone class< ] unit-test
[ f ] [ \ object \ delegate-clone class< ] unit-test
[ f ] [ \ object \ delegate-clone class< ] unit-test
[ t ] [ \ delegate-clone \ tuple class< ] unit-test
[ f ] [ \ tuple \ delegate-clone class< ] unit-test
TUPLE: a1 ;
TUPLE: b1 ;
TUPLE: c1 ;
UNION: x1 a1 b1 ;
UNION: y1 a1 c1 ;
UNION: z1 b1 c1 ;
[ f ] [ z1 x1 y1 class-and class< ] unit-test
[ t ] [ x1 y1 class-and a1 class< ] unit-test
[ f ] [ y1 z1 class-and x1 classes-intersect? ] unit-test
[ f ] [ b1 c1 class-or a1 b1 class-or a1 c1 class-and class-and class< ] unit-test
[ t ] [ a1 b1 class-or a1 c1 class-or class-and a1 class< ] unit-test
[ f ] [ a1 c1 class-or b1 c1 class-or class-and a1 b1 class-or classes-intersect? ] unit-test
[ f ] [ growable hi-tag classes-intersect? ] unit-test
[ t ] [
growable tuple sequence class-and class<
] unit-test
[ t ] [
growable assoc class-and tuple class<
] unit-test
[ t ] [ object \ f \ f class-not class-or class< ] unit-test
[ t ] [ fixnum class-not integer class-and bignum class= ] unit-test
[ f ] [ integer integer class-not classes-intersect? ] unit-test
[ t ] [ array number class-not class< ] unit-test
[ f ] [ bignum number class-not class< ] unit-test
[ vector ] [ vector class-not class-not ] unit-test
[ t ] [ fixnum fixnum bignum class-or class< ] unit-test
[ f ] [ fixnum class-not integer class-and array class< ] unit-test
[ f ] [ fixnum class-not integer class< ] unit-test
[ f ] [ number class-not array class< ] unit-test
[ f ] [ fixnum class-not array class< ] unit-test
[ t ] [ number class-not integer class-not class< ] unit-test
[ t ] [ vector array class-not class-and vector class= ] unit-test
[ f ] [ fixnum class-not number class-and array classes-intersect? ] unit-test
[ f ] [ fixnum class-not integer class< ] unit-test
[ t ] [ null class-not object class= ] unit-test
[ t ] [ object class-not null class= ] unit-test
[ f ] [ object class-not object class= ] unit-test
[ f ] [ null class-not null class= ] unit-test
! Test for hangs?
: random-class classes random ;
: random-op
{
class-and
class-or
class-not
} random ;
10 [
[ ] [
20 [ drop random-op ] map >quotation
[ infer effect-in [ random-class ] times ] keep
call
drop
] unit-test
] times
: random-boolean
{ t f } random ;
: boolean>class
object null ? ;
: random-boolean-op
{
and
or
not
xor
} random ;
: class-xor [ class-or ] 2keep class-and class-not class-and ;
: boolean-op>class-op
{
{ and class-and }
{ or class-or }
{ not class-not }
{ xor class-xor }
} at ;
20 [
[ t ] [
20 [ drop random-boolean-op ] [ ] map-as dup .
[ infer effect-in [ drop random-boolean ] map dup . ] keep
[ >r [ ] each r> call ] 2keep
>r [ boolean>class ] each r> [ boolean-op>class-op ] map call object class=
=
] unit-test
] times

233
core/classes/algebra/algebra.factor Executable file
View File

@ -0,0 +1,233 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel classes combinators accessors sequences arrays
vectors assocs namespaces words sorting layouts math hashtables
;
IN: classes.algebra
: 2cache ( key1 key2 assoc quot -- value )
>r >r 2array r> [ first2 ] r> compose cache ; inline
DEFER: (class<)
: class< ( first second -- ? )
class<-cache get [ (class<) ] 2cache ;
DEFER: (class-not)
: class-not ( class -- complement )
class-not-cache get [ (class-not) ] cache ;
DEFER: (classes-intersect?) ( first second -- ? )
: classes-intersect? ( first second -- ? )
classes-intersect-cache get [ (classes-intersect?) ] 2cache ;
DEFER: (class-and)
: class-and ( first second -- class )
class-and-cache get [ (class-and) ] 2cache ;
DEFER: (class-or)
: class-or ( first second -- class )
class-or-cache get [ (class-or) ] 2cache ;
TUPLE: anonymous-union members ;
C: <anonymous-union> anonymous-union
TUPLE: anonymous-intersection members ;
C: <anonymous-intersection> anonymous-intersection
TUPLE: anonymous-complement class ;
C: <anonymous-complement> anonymous-complement
: superclass< ( first second -- ? )
>r superclass r> class< ;
: left-union-class< ( first second -- ? )
>r members r> [ class< ] curry all? ;
: right-union-class< ( first second -- ? )
members [ class< ] with contains? ;
: left-anonymous-union< ( first second -- ? )
>r members>> r> [ class< ] curry all? ;
: right-anonymous-union< ( first second -- ? )
members>> [ class< ] with contains? ;
: left-anonymous-intersection< ( first second -- ? )
>r members>> r> [ class< ] curry contains? ;
: right-anonymous-intersection< ( first second -- ? )
members>> [ class< ] with all? ;
: anonymous-complement< ( first second -- ? )
[ class>> ] 2apply swap class< ;
: (class<) ( first second -- -1/0/1 )
{
{ [ 2dup eq? ] [ 2drop t ] }
{ [ dup object eq? ] [ 2drop t ] }
{ [ over null eq? ] [ 2drop t ] }
{ [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement< ] }
{ [ over anonymous-union? ] [ left-anonymous-union< ] }
{ [ over anonymous-intersection? ] [ left-anonymous-intersection< ] }
{ [ over anonymous-complement? ] [ 2drop f ] }
{ [ over members ] [ left-union-class< ] }
{ [ dup anonymous-union? ] [ right-anonymous-union< ] }
{ [ dup anonymous-intersection? ] [ right-anonymous-intersection< ] }
{ [ dup anonymous-complement? ] [ class>> classes-intersect? not ] }
{ [ dup members ] [ right-union-class< ] }
{ [ over superclass ] [ superclass< ] }
{ [ t ] [ 2drop f ] }
} cond ;
: anonymous-union-intersect? ( first second -- ? )
members>> [ classes-intersect? ] with contains? ;
: anonymous-intersection-intersect? ( first second -- ? )
members>> [ classes-intersect? ] with all? ;
: anonymous-complement-intersect? ( first second -- ? )
class>> class< not ;
: union-class-intersect? ( first second -- ? )
members [ classes-intersect? ] with contains? ;
: tuple-class-intersect? ( first second -- ? )
{
{ [ over tuple eq? ] [ 2drop t ] }
{ [ over builtin-class? ] [ 2drop f ] }
{ [ over tuple-class? ] [ [ class< ] 2keep swap class< or ] }
{ [ t ] [ swap classes-intersect? ] }
} cond ;
: builtin-class-intersect? ( first second -- ? )
{
{ [ 2dup eq? ] [ 2drop t ] }
{ [ over builtin-class? ] [ 2drop f ] }
{ [ t ] [ swap classes-intersect? ] }
} cond ;
: (classes-intersect?) ( first second -- ? )
{
{ [ dup anonymous-union? ] [ anonymous-union-intersect? ] }
{ [ dup anonymous-intersection? ] [ anonymous-intersection-intersect? ] }
{ [ dup anonymous-complement? ] [ anonymous-complement-intersect? ] }
{ [ dup tuple-class? ] [ tuple-class-intersect? ] }
{ [ dup builtin-class? ] [ builtin-class-intersect? ] }
{ [ dup superclass ] [ superclass classes-intersect? ] }
{ [ dup members ] [ union-class-intersect? ] }
} cond ;
: left-union-and ( first second -- class )
>r members r> [ class-and ] curry map <anonymous-union> ;
: right-union-and ( first second -- class )
members [ class-and ] with map <anonymous-union> ;
: left-anonymous-union-and ( first second -- class )
>r members>> r> [ class-and ] curry map <anonymous-union> ;
: right-anonymous-union-and ( first second -- class )
members>> [ class-and ] with map <anonymous-union> ;
: left-anonymous-intersection-and ( first second -- class )
>r members>> r> add <anonymous-intersection> ;
: right-anonymous-intersection-and ( first second -- class )
members>> swap add <anonymous-intersection> ;
: (class-and) ( first second -- class )
{
{ [ 2dup class< ] [ drop ] }
{ [ 2dup swap class< ] [ nip ] }
{ [ 2dup classes-intersect? not ] [ 2drop null ] }
{ [ dup members ] [ right-union-and ] }
{ [ dup anonymous-union? ] [ right-anonymous-union-and ] }
{ [ dup anonymous-intersection? ] [ right-anonymous-intersection-and ] }
{ [ over members ] [ left-union-and ] }
{ [ over anonymous-union? ] [ left-anonymous-union-and ] }
{ [ over anonymous-intersection? ] [ left-anonymous-intersection-and ] }
{ [ t ] [ 2array <anonymous-intersection> ] }
} cond ;
: left-anonymous-union-or ( first second -- class )
>r members>> r> add <anonymous-union> ;
: right-anonymous-union-or ( first second -- class )
members>> swap add <anonymous-union> ;
: (class-or) ( first second -- class )
{
{ [ 2dup class< ] [ nip ] }
{ [ 2dup swap class< ] [ drop ] }
{ [ dup anonymous-union? ] [ right-anonymous-union-or ] }
{ [ over anonymous-union? ] [ left-anonymous-union-or ] }
{ [ t ] [ 2array <anonymous-union> ] }
} cond ;
: (class-not) ( class -- complement )
{
{ [ dup anonymous-complement? ] [ class>> ] }
{ [ dup object eq? ] [ drop null ] }
{ [ dup null eq? ] [ drop object ] }
{ [ t ] [ <anonymous-complement> ] }
} cond ;
: largest-class ( seq -- n elt )
dup [
[ 2dup class< >r swap class< not r> and ]
with subset empty?
] curry find [ "Topological sort failed" throw ] unless* ;
: sort-classes ( seq -- newseq )
>vector
[ dup empty? not ]
[ dup largest-class >r over delete-nth r> ]
[ ] unfold nip ;
: min-class ( class seq -- class/f )
[ dupd classes-intersect? ] subset dup empty? [
2drop f
] [
tuck [ class< ] with all? [ peek ] [ drop f ] if
] if ;
: (flatten-class) ( class -- )
{
{ [ dup tuple-class? ] [ dup set ] }
{ [ dup builtin-class? ] [ dup set ] }
{ [ dup members ] [ members [ (flatten-class) ] each ] }
{ [ dup superclass ] [ superclass (flatten-class) ] }
{ [ t ] [ drop ] }
} cond ;
: flatten-class ( class -- assoc )
[ (flatten-class) ] H{ } make-assoc ;
: class-hashes ( class -- seq )
flatten-class keys [
dup builtin-class?
[ "type" word-prop ] [ hashcode ] if
] map ;
: flatten-builtin-class ( class -- assoc )
flatten-class [
dup tuple class< [ 2drop tuple tuple ] when
] assoc-map ;
: class-types ( class -- seq )
flatten-builtin-class keys
[ "type" word-prop ] map natural-sort ;
: class-tags ( class -- tag/f )
class-types [
dup num-tags get >=
[ drop object tag-number ] when
] map prune ;

82
core/classes/classes-docs.factor
View File

@ -12,21 +12,6 @@ $nl
{ $subsection builtin-class? }
"See " { $link "type-index" } " for a list of built-in classes." ;
ARTICLE: "class-operations" "Class operations"
"Set-theoretic operations on classes:"
{ $subsection class< }
{ $subsection class-and }
{ $subsection class-or }
{ $subsection classes-intersect? }
"Topological sort:"
{ $subsection sort-classes }
{ $subsection min-class }
"Low-level implementation detail:"
{ $subsection types }
{ $subsection flatten-class }
{ $subsection flatten-builtin-class }
{ $subsection flatten-union-class } ;
ARTICLE: "class-predicates" "Class predicate words"
"With a handful of exceptions, each class has a membership predicate word, named " { $snippet { $emphasis "class" } "?" } " . A quotation calling this predicate is stored in the " { $snippet "\"predicate\"" } " word property."
$nl
@ -93,15 +78,9 @@ HELP: tuple-class
{ $class-description "The class of tuple class words." }
{ $examples { $example "USING: classes prettyprint ;" "TUPLE: name title first last ;" "name tuple-class? ." "t" } } ;
HELP: typemap
{ $var-description "Hashtable mapping unions to class words, used to implement " { $link class-and } " and " { $link class-or } "." } ;
HELP: builtins
{ $var-description "Vector mapping type numbers to builtin class words." } ;
HELP: class<map
{ $var-description "Hashtable mapping each class to a set of classes which are contained in that class under the " { $link (class<) } " relation. The " { $link class< } " word uses this hashtable to avoid frequent expensive calls to " { $link (class<) } "." } ;
HELP: update-map
{ $var-description "Hashtable mapping each class to a set of classes defined in terms of this class. The " { $link define-class } " word uses this information to update generic words when classes are redefined." } ;
@ -121,70 +100,13 @@ $low-level-note ;
HELP: superclass
{ $values { "class" class } { "super" class } }
{ $description "Outputs the superclass of a class. All instances of this class are also instances of the superclass." }
{ $notes "If " { $link class< } " yields that one class is a subtype of another, it does not imply that a superclass relation is involved. The superclass relation is a technical implementation detail of predicate and tuple classes." } ;
{ $description "Outputs the superclass of a class. All instances of this class are also instances of the superclass." } ;
HELP: members
{ $values { "class" class } { "seq" "a sequence of union members, or " { $link f } } }
{ $description "If " { $snippet "class" } " is a union class, outputs a sequence of its member classes, otherwise outputs " { $link f } "." } ;
HELP: flatten-union-class
{ $values { "class" class } { "assoc" "an assoc whose keys are classes" } }
{ $description "Outputs the set of classes whose union is equal to " { $snippet "class" } ". Unions are expanded recursively so the output assoc does not contain any union classes. However, it may contain predicate classes whose superclasses are unions." } ;
HELP: flatten-builtin-class
{ $values { "class" class } { "assoc" "an assoc whose keys are classes" } }
{ $description "Outputs a set of tuple classes whose union is the smallest cover of " { $snippet "class" } " intersected with " { $link tuple } "." } ;
HELP: flatten-class
{ $values { "class" class } { "assoc" "an assoc whose keys are classes" } }
{ $description "Outputs a set of builtin and tuple classes whose union is the smallest cover of " { $snippet "class" } "." } ;
HELP: types
{ $values { "class" class } { "seq" "an increasing sequence of integers" } }
{ $description "Outputs a sequence of builtin type numbers whose instances can possibly be instances of the given class." } ;
HELP: class-empty?
{ $values { "class" "a class" } { "?" "a boolean" } }
{ $description "Tests if a class is a union class with no members." }
{ $examples { $example "USING: classes kernel prettyprint ;" "null class-empty? ." "t" } } ;
HELP: (class<)
{ $values { "class1" "a class" } { "class2" "a class" } { "?" "a boolean" } }
{ $description "Performs the calculation for " { $link class< } ". There is never any reason to call this word from user code since " { $link class< } " outputs identical values and caches results for better performance." } ;
HELP: class<
{ $values { "class1" "a class" } { "class2" "a class" } { "?" "a boolean" } }
{ $description "Tests if all instances of " { $snippet "class1" } " are also instances of " { $snippet "class2" } "." }
{ $notes "Classes are partially ordered. This means that if " { $snippet "class1 <= class2" } " and " { $snippet "class2 <= class1" } ", then " { $snippet "class1 = class2" } ". Also, if " { $snippet "class1 <= class2" } " and " { $snippet "class2 <= class3" } ", then " { $snippet "class1 <= class3" } "." } ;
HELP: sort-classes
{ $values { "seq" "a sequence of class" } { "newseq" "a new seqence of classes" } }
{ $description "Outputs a topological sort of a sequence of classes. Larger classes come before their subclasses." } ;
HELP: lookup-union
{ $values { "classes" "a hashtable mapping class words to themselves" } { "class" class } }
{ $description "Given a set of classes represented as a hashtable with equal keys and values, looks up a previously-defined union class having those members. If no union is defined, outputs " { $link object } "." } ;
{ class-and class-or lookup-union } related-words
HELP: class-or
{ $values { "class1" class } { "class2" class } { "class" class } }
{ $description "Outputs the smallest known class containing both " { $snippet "class1" } " and " { $snippet "class2" } "." } ;
HELP: class-and
{ $values { "class1" class } { "class2" class } { "class" class } }
{ $description "Outputs the largest known class contained in both " { $snippet "class1" } " and " { $snippet "class2" } ". If the intersection is non-empty but no union class with those exact members is defined, outputs " { $link object } ". If the intersection is empty, outputs " { $link null } "." } ;
HELP: classes-intersect?
{ $values { "class1" class } { "class2" class } { "?" "a boolean" } }
{ $description "Tests if two classes have a non-empty intersection. If the intersection is empty, no object can be an instance of both classes at once." } ;
HELP: min-class
{ $values { "class" class } { "seq" "a sequence of class words" } { "class/f" "a class word or " { $link f } } }
{ $description "If all classes in " { $snippet "seq" } " that intersect " { $snippet "class" } " are subtypes of " { $snippet "class" } ", outputs the last such element of " { $snippet "seq" } ". If any conditions fail to hold, outputs " { $link f } "." } ;
HELP: define-class
{ $values { "word" word } { "members" "a sequence of class words" } { "superclass" class } { "metaclass" class } }
{ $description "Sets a property indicating this word is a class word, thus making it an instance of " { $link class } ", and registers it with " { $link typemap } " and " { $link class<map } "." }
{ $description "Sets a property indicating this word is a class word, thus making it an instance of " { $link class } ", and registers it with " { $link update-map } "." }
$low-level-note ;

87
core/classes/classes-tests.factor
View File

@ -2,64 +2,10 @@ USING: alien arrays definitions generic assocs hashtables io
kernel math namespaces parser prettyprint sequences strings
tools.test vectors words quotations classes
classes.private classes.union classes.mixin classes.predicate
vectors definitions source-files compiler.units ;
classes.algebra vectors definitions source-files
compiler.units ;
IN: classes.tests
H{ } "s" set
[ ] [ 1 2 "s" get push-at ] unit-test
[ 1 ] [ 2 "s" get at first ] unit-test
[ ] [ 1 2 "s" get pop-at ] unit-test
[ t ] [ 2 "s" get at empty? ] unit-test
[ object ] [ object object class-and ] unit-test
[ fixnum ] [ fixnum object class-and ] unit-test
[ fixnum ] [ object fixnum class-and ] unit-test
[ fixnum ] [ fixnum fixnum class-and ] unit-test
[ fixnum ] [ fixnum integer class-and ] unit-test
[ fixnum ] [ integer fixnum class-and ] unit-test
[ null ] [ vector fixnum class-and ] unit-test
[ number ] [ number object class-and ] unit-test
[ number ] [ object number class-and ] unit-test
[ null ] [ slice reversed class-and ] unit-test
[ null ] [ general-t \ f class-and ] unit-test
[ object ] [ general-t \ f class-or ] unit-test
TUPLE: first-one ;
TUPLE: second-one ;
UNION: both first-one union-class ;
[ t ] [ both tuple classes-intersect? ] unit-test
[ null ] [ vector virtual-sequence class-and ] unit-test
[ f ] [ vector virtual-sequence classes-intersect? ] unit-test
[ t ] [ \ fixnum \ integer class< ] unit-test
[ t ] [ \ fixnum \ fixnum class< ] unit-test
[ f ] [ \ integer \ fixnum class< ] unit-test
[ t ] [ \ integer \ object class< ] unit-test
[ f ] [ \ integer \ null class< ] unit-test
[ t ] [ \ null \ object class< ] unit-test
[ t ] [ \ generic \ word class< ] unit-test
[ f ] [ \ word \ generic class< ] unit-test
[ f ] [ \ reversed \ slice class< ] unit-test
[ f ] [ \ slice \ reversed class< ] unit-test
PREDICATE: word no-docs "documentation" word-prop not ;
UNION: no-docs-union no-docs integer ;
[ t ] [ no-docs no-docs-union class< ] unit-test
[ f ] [ no-docs-union no-docs class< ] unit-test
TUPLE: a ;
TUPLE: b ;
UNION: c a b ;
[ t ] [ \ c \ tuple class< ] unit-test
[ f ] [ \ tuple \ c class< ] unit-test
! DEFER: bah
! FORGET: bah
UNION: bah fixnum alien ;
@ -76,17 +22,13 @@ M: union-1 generic-update-test drop "union-1" ;
[ t ] [ union-1 number class< ] unit-test
[ "union-1" ] [ 1.0 generic-update-test ] unit-test
[ union-1 ] [ fixnum float class-or ] unit-test
"IN: classes.tests USE: math USE: arrays UNION: union-1 rational array ;" eval
[ t ] [ bignum union-1 class< ] unit-test
[ f ] [ union-1 number class< ] unit-test
[ "union-1" ] [ { 1.0 } generic-update-test ] unit-test
[ object ] [ fixnum float class-or ] unit-test
"IN: classes.tests USE: math PREDICATE: integer union-1 even? ;" eval
"IN: classes.tests USE: math PREDICATE: union-1 < integer even? ;" eval
[ f ] [ union-1 union-class? ] unit-test
[ t ] [ union-1 predicate-class? ] unit-test
@ -118,6 +60,9 @@ M: assoc-mixin collection-size assoc-size ;
[ 2 ] [ H{ { 1 2 } { 2 3 } } collection-size ] unit-test
! Test mixing in of new classes after the fact
DEFER: mx1
FORGET: mx1
MIXIN: mx1
INSTANCE: integer mx1
@ -131,12 +76,8 @@ INSTANCE: integer mx1
[ t ] [ array mx1 class< ] unit-test
[ f ] [ mx1 number class< ] unit-test
[ mx1 ] [ array integer class-or ] unit-test
[ \ mx1 forget ] with-compilation-unit
[ f ] [ array integer class-or mx1 = ] unit-test
! Empty unions were causing problems
GENERIC: empty-union-test
@ -155,28 +96,12 @@ UNION: redefine-bug-2 redefine-bug-1 quotation ;
[ t ] [ fixnum redefine-bug-2 class< ] unit-test
[ t ] [ quotation redefine-bug-2 class< ] unit-test
[ redefine-bug-2 ] [ fixnum quotation class-or ] unit-test
[ ] [ "IN: classes.tests USE: math UNION: redefine-bug-1 bignum ;" eval ] unit-test
[ t ] [ bignum redefine-bug-1 class< ] unit-test
[ f ] [ fixnum redefine-bug-2 class< ] unit-test
[ t ] [ bignum redefine-bug-2 class< ] unit-test
[ f ] [ fixnum quotation class-or redefine-bug-2 eq? ] unit-test
[ redefine-bug-2 ] [ bignum quotation class-or ] unit-test
! Another issue similar to the above
UNION: forget-class-bug-1 integer ;
UNION: forget-class-bug-2 forget-class-bug-1 dll ;
[
\ forget-class-bug-1 forget
\ forget-class-bug-2 forget
] with-compilation-unit
[ f ] [ forget-class-bug-1 typemap get values [ memq? ] with contains? ] unit-test
[ f ] [ forget-class-bug-2 typemap get values [ memq? ] with contains? ] unit-test
USE: io.streams.string

273
core/classes/classes.factor
View File

@ -1,25 +1,42 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays definitions assocs kernel kernel.private
slots.private namespaces sequences strings words vectors math
quotations combinators sorting effects graphs vocabs ;
IN: classes
USING: arrays definitions assocs kernel
kernel.private slots.private namespaces sequences strings words
vectors math quotations combinators sorting effects graphs ;
PREDICATE: word class ( obj -- ? ) "class" word-prop ;
SYMBOL: class<-cache
SYMBOL: class-not-cache
SYMBOL: classes-intersect-cache
SYMBOL: class-and-cache
SYMBOL: class-or-cache
: init-caches ( -- )
H{ } clone class<-cache set
H{ } clone class-not-cache set
H{ } clone classes-intersect-cache set
H{ } clone class-and-cache set
H{ } clone class-or-cache set ;
: reset-caches ( -- )
class<-cache get clear-assoc
class-not-cache get clear-assoc
classes-intersect-cache get clear-assoc
class-and-cache get clear-assoc
class-or-cache get clear-assoc ;
PREDICATE: class < word ( obj -- ? ) "class" word-prop ;
SYMBOL: typemap
SYMBOL: class-map
SYMBOL: class<map
SYMBOL: update-map
SYMBOL: builtins
PREDICATE: class builtin-class
PREDICATE: builtin-class < class
"metaclass" word-prop builtin-class eq? ;
PREDICATE: class tuple-class
PREDICATE: tuple-class < class
"metaclass" word-prop tuple-class eq? ;
: classes ( -- seq ) class<map get keys ;
: classes ( -- seq ) all-words [ class? ] subset ;
: type>class ( n -- class ) builtins get-global nth ;
@ -30,153 +47,22 @@ PREDICATE: class tuple-class
: predicate-effect 1 { "?" } <effect> ;
PREDICATE: word predicate "predicating" word-prop >boolean ;
PREDICATE: predicate < word "predicating" word-prop >boolean ;
: define-predicate ( class quot -- )
>r "predicate" word-prop first
r> predicate-effect define-declared ;
: superclass ( class -- super )
"superclass" word-prop ;
#! Output f for non-classes to work with algebra code
dup class? [ "superclass" word-prop ] [ drop f ] if ;
: members ( class -- seq ) "members" word-prop ;
: superclasses ( class -- supers )
[ dup ] [ dup superclass swap ] [ ] unfold reverse nip ;
: class-empty? ( class -- ? ) members dup [ empty? ] when ;
: (flatten-union-class) ( class -- )
dup members [
[ (flatten-union-class) ] each
] [
dup set
] ?if ;
: flatten-union-class ( class -- assoc )
[ (flatten-union-class) ] H{ } make-assoc ;
: (flatten-class) ( class -- )
{
{ [ dup tuple-class? ] [ dup set ] }
{ [ dup builtin-class? ] [ dup set ] }
{ [ dup members ] [ members [ (flatten-class) ] each ] }
{ [ dup superclass ] [ superclass (flatten-class) ] }
{ [ t ] [ drop ] }
} cond ;
: flatten-class ( class -- assoc )
[ (flatten-class) ] H{ } make-assoc ;
: class-hashes ( class -- seq )
flatten-class keys [
dup builtin-class?
[ "type" word-prop ] [ hashcode ] if
] map ;
: (flatten-builtin-class) ( class -- )
{
{ [ dup members ] [ members [ (flatten-builtin-class) ] each ] }
{ [ dup superclass ] [ superclass (flatten-builtin-class) ] }
{ [ t ] [ dup set ] }
} cond ;
: flatten-builtin-class ( class -- assoc )
[ (flatten-builtin-class) ] H{ } make-assoc ;
: types ( class -- seq )
flatten-builtin-class keys
[ "type" word-prop ] map natural-sort ;
: class< ( class1 class2 -- ? ) swap class<map get at key? ;
<PRIVATE
DEFER: (class<)
: superclass< ( cls1 cls2 -- ? )
>r superclass r> 2dup and [ (class<) ] [ 2drop f ] if ;
: union-class< ( cls1 cls2 -- ? )
[ flatten-union-class ] 2apply keys
[ nip [ (class<) ] with contains? ] curry assoc-all? ;
: (class<) ( class1 class2 -- ? )
{
{ [ 2dup eq? ] [ 2drop t ] }
{ [ over class-empty? ] [ 2drop t ] }
{ [ 2dup superclass< ] [ 2drop t ] }
{ [ 2dup [ members not ] both? ] [ 2drop f ] }
{ [ t ] [ union-class< ] }
} cond ;
: lookup-union ( classes -- class )
typemap get at dup empty? [ drop object ] [ first ] if ;
: lookup-tuple-union ( classes -- class )
class-map get at dup empty? [ drop object ] [ first ] if ;
! : (class-or) ( class class -- class )
! [ flatten-builtin-class ] 2apply union lookup-union ;
!
! : (class-and) ( class class -- class )
! [ flatten-builtin-class ] 2apply intersect lookup-union ;
: class-or-fixup ( set set -- set )
union
tuple over key?
[ [ drop tuple-class? not ] assoc-subset ] when ;
: (class-or) ( class class -- class )
[ flatten-class ] 2apply class-or-fixup lookup-tuple-union ;
: (class-and) ( class class -- class )
2dup [ tuple swap class< ] either? [
[ flatten-builtin-class ] 2apply
intersect lookup-union
] [
[ flatten-class ] 2apply
intersect lookup-tuple-union
] if ;
: tuple-class-and ( class1 class2 -- class )
dupd eq? [ drop null ] unless ;
: largest-class ( seq -- n elt )
dup [
[ 2dup class< >r swap class< not r> and ]
with subset empty?
] curry find [ "Topological sort failed" throw ] unless* ;
PRIVATE>
: sort-classes ( seq -- newseq )
>vector
[ dup empty? not ]
[ dup largest-class >r over delete-nth r> ]
[ ] unfold nip ;
: class-or ( class1 class2 -- class )
{
{ [ 2dup class< ] [ nip ] }
{ [ 2dup swap class< ] [ drop ] }
{ [ t ] [ (class-or) ] }
} cond ;
: class-and ( class1 class2 -- class )
{
{ [ 2dup class< ] [ drop ] }
{ [ 2dup swap class< ] [ nip ] }
{ [ 2dup [ tuple-class? ] both? ] [ tuple-class-and ] }
{ [ t ] [ (class-and) ] }
} cond ;
: classes-intersect? ( class1 class2 -- ? )
class-and class-empty? not ;
: min-class ( class seq -- class/f )
[ dupd classes-intersect? ] subset dup empty? [
2drop f
] [
tuck [ class< ] with all? [ peek ] [ drop f ] if
] if ;
: members ( class -- seq )
#! Output f for non-classes to work with algebra code
dup class? [ "members" word-prop ] [ drop f ] if ;
GENERIC: reset-class ( class -- )
@ -184,36 +70,9 @@ M: word reset-class drop ;
<PRIVATE
! class<map
: bigger-classes ( class -- seq )
classes [ (class<) ] with subset ;
: bigger-classes+ ( class -- )
[ bigger-classes [ dup ] H{ } map>assoc ] keep
class<map get set-at ;
: bigger-classes- ( class -- )
class<map get delete-at ;
: smaller-classes ( class -- seq )
classes swap [ (class<) ] curry subset ;
: smaller-classes+ ( class -- )
dup smaller-classes class<map get add-vertex ;
: smaller-classes- ( class -- )
dup smaller-classes class<map get remove-vertex ;
: class<map+ ( class -- )
H{ } clone over class<map get set-at
dup smaller-classes+ bigger-classes+ ;
: class<map- ( class -- )
dup smaller-classes- bigger-classes- ;
! update-map
: class-uses ( class -- seq )
[ dup members % superclass [ , ] when* ] { } make ;
dup members swap superclass [ add ] when* ;
: class-usages ( class -- assoc )
[ update-map get at ] closure ;
@ -224,47 +83,6 @@ M: word reset-class drop ;
: update-map- ( class -- )
dup class-uses update-map get remove-vertex ;
! typemap
: push-at ( value key assoc -- )
2dup at* [
2nip push
] [
drop >r >r 1vector r> r> set-at
] if ;
: typemap+ ( class -- )
dup flatten-builtin-class typemap get push-at ;
: pop-at ( value key assoc -- )
at* [ delete ] [ 2drop ] if ;
: typemap- ( class -- )
dup flatten-builtin-class typemap get pop-at ;
! class-map
: class-map+ ( class -- )
dup flatten-class class-map get push-at ;
: class-map- ( class -- )
dup flatten-class class-map get pop-at ;
! Class definition
: cache-class ( class -- )
dup typemap+ dup class-map+ dup class<map+ update-map+ ;
: cache-classes ( assoc -- )
[ drop cache-class ] assoc-each ;
GENERIC: uncache-class ( class -- )
M: class uncache-class
dup update-map- dup class<map- dup class-map- typemap- ;
M: word uncache-class drop ;
: uncache-classes ( assoc -- )
[ drop uncache-class ] assoc-each ;
PRIVATE>
: define-class-props ( members superclass metaclass -- assoc )
@ -293,22 +111,13 @@ GENERIC: update-methods ( assoc -- )
: define-class ( word members superclass metaclass -- )
#! If it was already a class, update methods after.
reset-caches
define-class-props
over class? >r
over class-usages [
uncache-classes
dupd (define-class)
] keep cache-classes r>
[ class-usages dup update-predicates update-methods ]
[ drop ] if ;
over update-map-
dupd (define-class)
dup update-map+
class-usages dup update-predicates update-methods ;
GENERIC: class ( object -- class ) inline
M: object class type type>class ;
<PRIVATE
: class-of-tuple ( obj -- class )
2 slot { word } declare ; inline
PRIVATE>

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

@ -4,7 +4,7 @@ USING: classes classes.union words kernel sequences
definitions combinators arrays ;
IN: classes.mixin
PREDICATE: union-class mixin-class "mixin" word-prop ;
PREDICATE: mixin-class < union-class "mixin" word-prop ;
M: mixin-class reset-class
{ "metaclass" "members" "mixin" } reset-props ;

2
core/classes/predicate/predicate-docs.factor
View File

@ -14,7 +14,7 @@ ARTICLE: "predicates" "Predicate classes"
ABOUT: "predicates"
HELP: define-predicate-class
{ $values { "superclass" class } { "class" class } { "definition" "a quotation with stack effect " { $snippet "( superclass -- ? )" } } }
{ $values { "class" class } { "superclass" class } { "definition" "a quotation with stack effect " { $snippet "( superclass -- ? )" } } }
{ $description "Defines a predicate class. This is the run time equivalent of " { $link POSTPONE: PREDICATE: } "." }
{ $notes "This word must be called from inside " { $link with-compilation-unit } "." }
{ $side-effects "class" } ;

8
core/classes/predicate/predicate.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2004, 2007 Slava Pestov.
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: classes kernel namespaces words ;
IN: classes.predicate
PREDICATE: class predicate-class
PREDICATE: predicate-class < class
"metaclass" word-prop predicate-class eq? ;
: predicate-quot ( class -- quot )
@ -13,8 +13,8 @@ PREDICATE: class predicate-class
"predicate-definition" word-prop , [ drop f ] , \ if ,
] [ ] make ;
: define-predicate-class ( superclass class definition -- )
>r dup f roll predicate-class define-class r>
: define-predicate-class ( class superclass definition -- )
>r >r dup f r> predicate-class define-class r>
dupd "predicate-definition" set-word-prop
dup predicate-quot define-predicate ;

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

@ -4,7 +4,7 @@ USING: words sequences kernel assocs combinators classes
generic.standard namespaces arrays math quotations ;
IN: classes.union
PREDICATE: class union-class
PREDICATE: union-class < class
"metaclass" word-prop union-class eq? ;
! Union classes for dispatch on multiple classes.

2
core/compiler/constants/constants.factor
View File

@ -15,7 +15,7 @@ IN: compiler.constants
: byte-array-offset 2 bootstrap-cells object tag-number - ;
: alien-offset 3 bootstrap-cells object tag-number - ;
: underlying-alien-offset bootstrap-cell object tag-number - ;
: tuple-class-offset 2 bootstrap-cells tuple tag-number - ;
: tuple-class-offset bootstrap-cell tuple tag-number - ;
: class-hash-offset bootstrap-cell object tag-number - ;
: word-xt-offset 8 bootstrap-cells object tag-number - ;
: word-code-offset 9 bootstrap-cells object tag-number - ;

4
core/compiler/tests/templates.factor
View File

@ -81,8 +81,8 @@ unit-test
-12 -13 [ [ 0 swap fixnum- ] 2apply ] compile-call
] unit-test
[ 2 ] [
SBUF" " [ 2 slot 2 [ slot ] keep ] compile-call nip
[ 1 ] [
SBUF" " [ 1 slot 1 [ slot ] keep ] compile-call nip
] unit-test
! Test slow shuffles

6
core/cpu/architecture/architecture.factor
View File

@ -153,11 +153,11 @@ M: f v>operand drop \ f tag-number ;
M: object load-literal v>operand load-indirect ;
PREDICATE: integer small-slot cells small-enough? ;
PREDICATE: small-slot < integer cells small-enough? ;
PREDICATE: integer small-tagged v>operand small-enough? ;
PREDICATE: small-tagged < integer v>operand small-enough? ;
PREDICATE: integer inline-array 32 < ;
PREDICATE: inline-array < integer 32 < ;
: if-small-struct ( n size true false -- ? )
>r >r over not over struct-small-enough? and

2
core/cpu/arm/assembler/assembler.factor
View File

@ -27,7 +27,7 @@ SYMBOL: R15
{ R0 R1 R2 R3 R4 R5 R6 R7 R8 R9 R10 R11 R12 R13 R14 R15 }
define-registers
PREDICATE: word register register >boolean ;
PREDICATE: register < word register >boolean ;
GENERIC: register ( register -- n )
M: word register "register" word-prop ;

12
core/cpu/ppc/intrinsics/intrinsics.factor
View File

@ -479,19 +479,17 @@ IN: cpu.ppc.intrinsics
} define-intrinsic
\ <tuple> [
tuple "n" get 2 + cells %allot
! Store length
"n" operand 12 LI
tuple "layout" get layout-size 2 + cells %allot
! Store layout
"layout" get 12 load-indirect
12 11 cell STW
! Store class
"class" operand 11 2 cells STW
! Zero out the rest of the tuple
f v>operand 12 LI
"n" get 1- [ 12 11 rot 3 + cells STW ] each
"layout" get layout-size [ 12 11 rot 2 + cells STW ] each
! Store tagged ptr in reg
"tuple" get tuple %store-tagged
] H{
{ +input+ { { f "class" } { [ inline-array? ] "n" } } }
{ +input+ { { [ tuple-layout? ] "layout" } } }
{ +scratch+ { { f "tuple" } } }
{ +output+ { "tuple" } }
} define-intrinsic

2
core/cpu/x86/32/32.factor
View File

@ -8,7 +8,7 @@ alien.compiler combinators command-line
compiler compiler.units io vocabs.loader accessors ;
IN: cpu.x86.32
PREDICATE: x86-backend x86-32-backend
PREDICATE: x86-32-backend < x86-backend
x86-backend-cell 4 = ;
! We implement the FFI for Linux, OS X and Windows all at once.

2
core/cpu/x86/64/64.factor
View File

@ -8,7 +8,7 @@ layouts alien alien.accessors alien.compiler alien.structs slots
splitting assocs ;
IN: cpu.x86.64
PREDICATE: x86-backend amd64-backend
PREDICATE: amd64-backend < x86-backend
x86-backend-cell 8 = ;
M: amd64-backend ds-reg R14 ;

2
core/cpu/x86/architecture/architecture.factor
View File

@ -156,7 +156,7 @@ M: x86-backend %unbox-small-struct ( size -- )
M: x86-backend struct-small-enough? ( size -- ? )
{ 1 2 4 8 } member?
os { "linux" "solaris" } member? not and ;
os { "linux" "netbsd" "solaris" } member? not and ;
M: x86-backend %return ( -- ) 0 %unwind ;

24
core/cpu/x86/assembler/assembler.factor
View File

@ -52,13 +52,23 @@ GENERIC: extended? ( op -- ? )
M: object extended? drop f ;
PREDICATE: word register "register" word-prop ;
PREDICATE: register < word
"register" word-prop ;
PREDICATE: register register-8 "register-size" word-prop 8 = ;
PREDICATE: register register-16 "register-size" word-prop 16 = ;
PREDICATE: register register-32 "register-size" word-prop 32 = ;
PREDICATE: register register-64 "register-size" word-prop 64 = ;
PREDICATE: register register-128 "register-size" word-prop 128 = ;
PREDICATE: register-8 < register
"register-size" word-prop 8 = ;
PREDICATE: register-16 < register
"register-size" word-prop 16 = ;
PREDICATE: register-32 < register
"register-size" word-prop 32 = ;
PREDICATE: register-64 < register
"register-size" word-prop 64 = ;
PREDICATE: register-128 < register
"register-size" word-prop 128 = ;
M: register extended? "register" word-prop 7 > ;
@ -285,7 +295,7 @@ GENERIC: (MOV-I) ( src dst -- )
M: register (MOV-I) t HEX: b8 short-operand cell, ;
M: operand (MOV-I) BIN: 000 t HEX: c7 1-operand 4, ;
PREDICATE: word callable register? not ;
PREDICATE: callable < word register? not ;
GENERIC: MOV ( dst src -- )
M: integer MOV swap (MOV-I) ;

17
core/cpu/x86/intrinsics/intrinsics.factor
View File

@ -336,19 +336,20 @@ IN: cpu.x86.intrinsics
} define-intrinsic
\ <tuple> [
tuple "n" get 2 + cells [
! Store length
1 object@ "n" operand MOV
! Store class
2 object@ "class" operand MOV
tuple "layout" get layout-size 2 + cells [
! Store layout
"layout" get "scratch" get load-literal
1 object@ "scratch" operand MOV
! Zero out the rest of the tuple
"n" operand 1- [ 3 + object@ f v>operand MOV ] each
"layout" get layout-size [
2 + object@ f v>operand MOV
] each
! Store tagged ptr in reg
"tuple" get tuple %store-tagged
] %allot
] H{
{ +input+ { { f "class" } { [ inline-array? ] "n" } } }
{ +scratch+ { { f "tuple" } } }
{ +input+ { { [ tuple-layout? ] "layout" } } }
{ +scratch+ { { f "tuple" } { f "scratch" } } }
{ +output+ { "tuple" } }
} define-intrinsic

2
core/debugger/debugger.factor
View File

@ -156,7 +156,7 @@ M: relative-overflow summary
: primitive-error.
"Unimplemented primitive" print drop ;
PREDICATE: array kernel-error ( obj -- ? )
PREDICATE: kernel-error < array
{
{ [ dup empty? ] [ drop f ] }
{ [ dup first "kernel-error" = not ] [ drop f ] }

21
core/generator/registers/registers.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2006, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs classes classes.private combinators
cpu.architecture generator.fixup hashtables kernel layouts math
namespaces quotations sequences system vectors words effects
alien byte-arrays bit-arrays float-arrays ;
USING: arrays assocs classes classes.private classes.algebra
combinators cpu.architecture generator.fixup hashtables kernel
layouts math namespaces quotations sequences system vectors
words effects alien byte-arrays bit-arrays float-arrays ;
IN: generator.registers
SYMBOL: +input+
@ -581,13 +581,14 @@ M: loc lazy-store
2drop t
] if ;
: class-tags ( class -- tag/f )
class-types [
dup num-tags get >=
[ drop object tag-number ] when
] map prune ;
: class-tag ( class -- tag/f )
dup hi-tag class< [
drop object tag-number
] [
flatten-builtin-class keys
dup length 1 = [ first tag-number ] [ drop f ] if
] if ;
class-tags dup length 1 = [ first ] [ drop f ] if ;
: class-matches? ( actual expected -- ? )
{

6
core/generic/generic-docs.factor
View File

@ -1,6 +1,6 @@
USING: help.markup help.syntax words classes definitions kernel
alien sequences math quotations generic.standard generic.math
combinators ;
USING: help.markup help.syntax words classes classes.algebra
definitions kernel alien sequences math quotations
generic.standard generic.math combinators ;
IN: generic
ARTICLE: "method-order" "Method precedence"

6
core/generic/generic-tests.factor
View File

@ -1,8 +1,8 @@
USING: alien arrays definitions generic generic.standard
generic.math assocs hashtables io kernel math namespaces parser
prettyprint sequences strings tools.test vectors words
quotations classes continuations layouts classes.union sorting
compiler.units ;
quotations classes classes.algebra continuations layouts
classes.union sorting compiler.units ;
IN: generic.tests
GENERIC: foobar ( x -- y )
@ -44,7 +44,7 @@ M: object funny drop 0 ;
[ 2 ] [ [ { } ] funny ] unit-test
[ 0 ] [ { } funny ] unit-test
PREDICATE: funnies very-funny number? ;
PREDICATE: very-funny < funnies number? ;
GENERIC: gooey ( x -- y )
M: very-funny gooey sq ;

11
core/generic/generic.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: words kernel sequences namespaces assocs hashtables
definitions kernel.private classes classes.private
quotations arrays vocabs effects ;
classes.algebra quotations arrays vocabs effects ;
IN: generic
! Method combination protocol
@ -19,7 +19,8 @@ M: object perform-combination
GENERIC: make-default-method ( generic combination -- method )
PREDICATE: word generic "combination" word-prop >boolean ;
PREDICATE: generic < word
"combination" word-prop >boolean ;
M: generic definition drop f ;
@ -30,7 +31,7 @@ M: generic definition drop f ;
: method ( class generic -- method/f )
"methods" word-prop at ;
PREDICATE: pair method-spec
PREDICATE: method-spec < pair
first2 generic? swap class? and ;
: order ( generic -- seq )
@ -55,7 +56,7 @@ TUPLE: check-method class generic ;
: method-word-name ( class word -- string )
word-name "/" rot word-name 3append ;
PREDICATE: word method-body
PREDICATE: method-body < word
"method-generic" word-prop >boolean ;
M: method-body stack-effect
@ -138,7 +139,7 @@ M: method-body forget*
M: class forget* ( class -- )
dup forget-methods
dup uncache-class
dup update-map-
forget-word ;
M: assoc update-methods ( assoc -- )

12
core/generic/math/math.factor
View File

@ -1,11 +1,11 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic hashtables kernel kernel.private
math namespaces sequences words quotations layouts combinators
sequences.private classes definitions ;
sequences.private classes classes.algebra definitions ;
IN: generic.math
PREDICATE: class math-class ( object -- ? )
PREDICATE: math-class < class
dup null bootstrap-word eq? [
drop f
] [
@ -16,8 +16,8 @@ PREDICATE: class math-class ( object -- ? )
: math-precedence ( class -- n )
{
{ [ dup class-empty? ] [ drop { -1 -1 } ] }
{ [ dup math-class? ] [ types last/first ] }
{ [ dup null class< ] [ drop { -1 -1 } ] }
{ [ dup math-class? ] [ class-types last/first ] }
{ [ t ] [ drop { 100 100 } ] }
} cond ;
@ -79,7 +79,7 @@ M: math-combination perform-combination
] if nip
] math-vtable nip ;
PREDICATE: generic math-generic ( word -- ? )
PREDICATE: math-generic < generic ( word -- ? )
"combination" word-prop math-combination? ;
M: math-generic definer drop \ MATH: f ;

8
core/generic/standard/standard.factor
View File

@ -3,7 +3,7 @@
USING: arrays assocs kernel kernel.private slots.private math
namespaces sequences vectors words quotations definitions
hashtables layouts combinators sequences.private generic
classes classes.private ;
classes classes.algebra classes.private ;
IN: generic.standard
TUPLE: standard-combination # ;
@ -174,13 +174,13 @@ M: hook-combination perform-combination
: define-simple-generic ( word -- )
T{ standard-combination f 0 } define-generic ;
PREDICATE: generic standard-generic
PREDICATE: standard-generic < generic
"combination" word-prop standard-combination? ;
PREDICATE: standard-generic simple-generic
PREDICATE: simple-generic < standard-generic
"combination" word-prop standard-combination-# zero? ;
PREDICATE: generic hook-generic
PREDICATE: hook-generic < generic
"combination" word-prop hook-combination? ;
GENERIC: dispatch# ( word -- n )

11
core/inference/class/class.factor
View File

@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic assocs hashtables inference kernel
math namespaces sequences words parser math.intervals
effects classes inference.dataflow inference.backend
combinators ;
effects classes classes.algebra inference.dataflow
inference.backend combinators ;
IN: inference.class
! Class inference
@ -88,8 +88,11 @@ M: interval-constraint apply-constraint
swap interval-constraint-value intersect-value-interval ;
: set-class-interval ( class value -- )
>r "interval" word-prop dup
[ r> set-value-interval* ] [ r> 2drop ] if ;
over class? [
over "interval" word-prop [
>r "interval" word-prop r> set-value-interval*
] [ 2drop ] if
] [ 2drop ] if ;
: value-class* ( value -- class )
value-classes get at object or ;

6
core/inference/dataflow/dataflow.factor
View File

@ -102,7 +102,7 @@ TUPLE: #label word loop? ;
: #label ( word label -- node )
\ #label param-node [ set-#label-word ] keep ;
PREDICATE: #label #loop #label-loop? ;
PREDICATE: #loop < #label #label-loop? ;
TUPLE: #entry ;
@ -309,9 +309,9 @@ SYMBOL: node-stack
DEFER: #tail?
PREDICATE: #merge #tail-merge node-successor #tail? ;
PREDICATE: #tail-merge < #merge node-successor #tail? ;
PREDICATE: #values #tail-values node-successor #tail? ;
PREDICATE: #tail-values < #values node-successor #tail? ;
UNION: #tail
POSTPONE: f #return #tail-values #tail-merge #terminate ;

11
core/inference/known-words/known-words.factor
View File

@ -135,7 +135,7 @@ M: object infer-call
! Variadic tuple constructor
\ <tuple-boa> [
\ <tuple-boa>
peek-d value-literal { tuple } <effect>
peek-d value-literal layout-size { tuple } <effect>
make-call-node
] "infer" set-word-prop
@ -565,14 +565,11 @@ set-primitive-effect
\ quotation-xt { quotation } { integer } <effect> set-primitive-effect
\ quotation-xt make-flushable
\ <tuple> { word integer } { quotation } <effect> set-primitive-effect
\ <tuple> { tuple-layout } { tuple } <effect> set-primitive-effect
\ <tuple> make-flushable
\ (>tuple) { array } { tuple } <effect> set-primitive-effect
\ (>tuple) make-flushable
\ tuple>array { tuple } { array } <effect> set-primitive-effect
\ tuple>array make-flushable
\ <tuple-layout> { word fixnum array fixnum } { tuple-layout } <effect> set-primitive-effect
\ <tuple-layout> make-foldable
\ datastack { } { array } <effect> set-primitive-effect
\ datastack make-flushable

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

@ -76,7 +76,7 @@ M: duplicated-slots-error summary
\ construct-boa [
dup +inlined+ depends-on
dup tuple-size [ <tuple-boa> ] 2curry
tuple-layout [ <tuple-boa> ] curry
] 1 define-transform
\ construct-empty [
@ -84,7 +84,7 @@ M: duplicated-slots-error summary
peek-d value? [
pop-literal
dup +inlined+ depends-on
dup tuple-size [ <tuple> ] 2curry
tuple-layout [ <tuple> ] curry
swap infer-quot
] [
\ construct-empty 1 1 <effect> make-call-node

10
core/io/backend/backend.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: init kernel system namespaces io io.encodings io.encodings.utf8 ;
USING: init kernel system namespaces io io.encodings
io.encodings.utf8 init assocs ;
IN: io.backend
SYMBOL: io-backend
@ -17,14 +18,13 @@ HOOK: io-multiplex io-backend ( ms -- )
HOOK: normalize-directory io-backend ( str -- newstr )
M: object normalize-directory ;
HOOK: normalize-pathname io-backend ( str -- newstr )
M: object normalize-pathname ;
M: object normalize-directory normalize-pathname ;
: set-io-backend ( io-backend -- )
io-backend set-global init-io init-stdio ;
io-backend set-global init-io init-stdio
"io.files" init-hooks get at call ;
[ init-io embedded? [ init-stdio ] unless ]
"io.backend" add-init-hook

5
core/io/encodings/binary/binary-docs.factor
View File

@ -2,4 +2,7 @@ USING: help.syntax help.markup ;
IN: io.encodings.binary
HELP: binary
{ $class-description "This is the encoding descriptor for binary I/O. Making an encoded stream with the binary encoding is a no-op; streams with this encoding deal with byte-arrays, not strings." } ;
{ $class-description "This is the encoding descriptor for binary I/O. Making an encoded stream with the binary encoding is a no-op; streams with this encoding deal with byte-arrays, not strings." }
{ $see-also "encodings-introduction" } ;
ABOUT: binary

42
core/io/encodings/encodings-docs.factor
View File

@ -1,15 +1,16 @@
USING: help.markup help.syntax ;
IN: io.encodings
ABOUT: "encodings"
ABOUT: "io.encodings"
ARTICLE: "io.encodings" "I/O encodings"
"Many streams deal with bytes, rather than Unicode code points, at some level. The translation between these two things is specified by an encoding. To abstract this away from the programmer, Factor provides a system where these streams are associated with an encoding which is always used when the stream is read from or written to. For most purposes, an encoding descriptor consisting of a symbol is all that is needed when initializing a stream."
"Bytes can't be understood in isolation as text. They must be interpreted under a certain encoding. Factor provides utilities for dealing with encoded text by declaring that a stream has a particular encoding, and utilities to encode and decode strings."
{ $subsection "encodings-constructors" }
{ $subsection "encodings-descriptors" }
{ $subsection "encodings-protocol" } ;
ARTICLE: "encodings-constructors" "Constructing an encoded stream"
ARTICLE: "encodings-constructors" "Manually constructing an encoded stream"
"The following words can be used to construct encoded streams. Note that they are usually not used directly, but rather by the stream constructors themselves. Most stream constructors take an encoding descriptor as a parameter and internally call these constructors."
{ $subsection <encoder> }
{ $subsection <decoder> }
{ $subsection <encoder-duplex> } ;
@ -18,47 +19,56 @@ HELP: <encoder>
{ $values { "stream" "an output stream" }
{ "encoding" "an encoding descriptor" }
{ "newstream" "an encoded output stream" } }
{ $description "Wraps the given stream in a new stream using the given encoding for all output. The encoding descriptor can either be a class or an instance of something conforming to the " { $link "encodings-protocol" } "." } ;
{ $description "Wraps the given stream in a new stream using the given encoding for all output. The encoding descriptor can either be a class or an instance of something conforming to the " { $link "encodings-protocol" } "." }
$low-level-note ;
HELP: <decoder>
{ $values { "stream" "an input stream" }
{ "encoding" "an encoding descriptor" }
{ "newstream" "an encoded output stream" } }
{ $description "Wraps the given stream in a new stream using the given encoding for all input. The encoding descriptor can either be a class or an instance of something conforming to the " { $link "encodings-protocol" } "." } ;
{ $description "Wraps the given stream in a new stream using the given encoding for all input. The encoding descriptor can either be a class or an instance of something conforming to the " { $link "encodings-protocol" } "." }
$low-level-note ;
HELP: <encoder-duplex>
{ $values { "stream-in" "an input stream" }
{ "stream-out" "an output stream" }
{ "encoding" "an encoding descriptor" }
{ "duplex" "an encoded duplex stream" } }
{ $description "Wraps the given streams in an encoder or decoder stream, and puts them together in a duplex stream for input and output. If either input stream is already encoded, that encoding is stripped off before it is reencoded. The encoding descriptor must conform to the " { $link "encodings-protocol" } "." } ;
{ $description "Wraps the given streams in an encoder or decoder stream, and puts them together in a duplex stream for input and output. If either input stream is already encoded, that encoding is stripped off before it is reencoded. The encoding descriptor must conform to the " { $link "encodings-protocol" } "." }
$low-level-note ;
{ <encoder> <decoder> <encoder-duplex> } related-words
ARTICLE: "encodings-descriptors" "Encoding descriptors"
"An encoding descriptor is something which can be used for input or output streams to encode or decode files. It must conform to the " { $link "encodings-protocol" } ". Encodings which you can use are defined in the following vocabularies:"
$nl { $vocab-link "io.encodings.utf8" }
$nl { $vocab-link "io.encodings.ascii" }
$nl { $vocab-link "io.encodings.binary" }
$nl { $vocab-link "io.encodings.utf16" } ;
{ $vocab-subsection "ASCII" "io.encodings.ascii" }
{ $vocab-subsection "Binary" "io.encodings.binary" }
{ $vocab-subsection "Strict encodings" "io.encodings.strict" }
{ $vocab-subsection "8-bit encodings" "io.encodings.8-bit" }
{ $vocab-subsection "UTF-8" "io.encodings.utf8" }
{ $vocab-subsection "UTF-16" "io.encodings.utf16" }
{ $see-also "encodings-introduction" } ;
ARTICLE: "encodings-protocol" "Encoding protocol"
"An encoding descriptor must implement the following methods. The methods are implemented on tuple classes by instantiating the class and calling the method again."
"There are two parts to implementing a new encoding. First, methods for creating an encoded or decoded stream must be provided. These have defaults, however, which wrap a stream in an encoder or decoder wrapper with the given encoding descriptor."
{ $subsection <encoder> }
{ $subsection <decoder> }
"If an encoding might be contained in the code slot of an encoder or decoder tuple, then the following methods must be implemented to read or write one code point from a stream:"
{ $subsection decode-char }
{ $subsection encode-char }
"The following methods are optional:"
{ $subsection <encoder> }
{ $subsection <decoder> } ;
{ $see-also "encodings-introduction" } ;
HELP: decode-char
{ $values { "stream" "an underlying input stream" }
{ "encoding" "An encoding descriptor tuple" } { "char/f" "a code point or " { $link f } } }
{ $description "Reads a single code point from the underlying stream, interpreting it by the encoding. This should not be used directly." } ;
{ $contract "Reads a single code point from the underlying stream, interpreting it by the encoding." }
$low-level-note ;
HELP: encode-char
{ $values { "char" "a character" }
{ "stream" "an underlying output stream" }
{ "encoding" "an encoding descriptor" } }
{ $description "Writes the code point in the encoding to the underlying stream given. This should not be used directly." } ;
{ $contract "Writes the code point in the encoding to the underlying stream given." }
$low-level-note ;
{ encode-char decode-char } related-words

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

@ -6,7 +6,7 @@ IN: io.streams.encodings.tests
resource-path ascii <file-reader> ;
[ { } ]
[ "/core/io/test/empty-file.txt" <resource-reader> lines ]
[ "core/io/test/empty-file.txt" <resource-reader> lines ]
unit-test
: lines-test ( stream -- line1 line2 )
@ -16,21 +16,21 @@ unit-test
"This is a line."
"This is another line."
] [
"/core/io/test/windows-eol.txt" <resource-reader> lines-test
"core/io/test/windows-eol.txt" <resource-reader> lines-test
] unit-test
[
"This is a line."
"This is another line."
] [
"/core/io/test/mac-os-eol.txt" <resource-reader> lines-test
"core/io/test/mac-os-eol.txt" <resource-reader> lines-test
] unit-test
[
"This is a line."
"This is another line."
] [
"/core/io/test/unix-eol.txt" <resource-reader> lines-test
"core/io/test/unix-eol.txt" <resource-reader> lines-test
] unit-test
[

11
core/io/encodings/utf8/utf8-docs.factor
View File

@ -1,11 +1,8 @@
USING: help.markup help.syntax io.encodings strings io.files ;
USING: help.markup help.syntax ;
IN: io.encodings.utf8
ARTICLE: "io.encodings.utf8" "Working with UTF8-encoded data"
"The UTF8 encoding is a variable-width encoding. 7-bit ASCII characters are encoded as single bytes, and other Unicode code points are encoded as 2 to 4 byte sequences. The encoding descriptor for UTF-8:"
{ $subsection utf8 } ;
HELP: utf8
{ $class-description "This is the class of encoding tuples which denote a UTF-8 encoding. This conforms to the " { $link "encodings-protocol" } "." } ;
{ $class-description "This is the encoding descriptor for a UTF-8 encoding. UTF-8 is a variable-width encoding. 7-bit ASCII characters are encoded as single bytes, and other Unicode code points are encoded as 2 to 4 byte sequences." }
{ $see-also "encodings-introduction" } ;
ABOUT: "io.encodings.utf8"
ABOUT: utf8

9
core/io/files/files-docs.factor
View File

@ -20,9 +20,6 @@ ARTICLE: "pathnames" "Pathname manipulation"
{ $subsection file-name }
{ $subsection last-path-separator }
{ $subsection append-path }
"Pathnames relative to Factor's install directory:"
{ $subsection resource-path }
{ $subsection ?resource-path }
"Pathnames relative to Factor's temporary files directory:"
{ $subsection temp-directory }
{ $subsection temp-file }
@ -248,12 +245,6 @@ HELP: resource-path
{ $values { "path" "a pathname string" } { "newpath" "a pathname string" } }
{ $description "Resolve a path relative to the Factor source code location. This first checks if the " { $link resource-path } " variable is set to a path, and if not, uses the parent directory of the current image." } ;
HELP: ?resource-path
{ $values { "path" "a pathname string" } { "newpath" "a string" } }
{ $description "If the path is prefixed with " { $snippet "\"resource:\"" } ", prepends the resource path." } ;
{ resource-path ?resource-path } related-words
HELP: pathname
{ $class-description "Class of pathname presentations. Path name presentations can be created by calling " { $link <pathname> } ". Instances can be passed to " { $link write-object } " to output a clickable pathname." } ;

75
core/io/files/files-tests.factor
View File

@ -1,6 +1,7 @@
IN: io.files.tests
USING: tools.test io.files io threads kernel continuations io.encodings.ascii
io.files.unique sequences strings accessors ;
USING: tools.test io.files io threads kernel continuations
io.encodings.ascii io.files.unique sequences strings accessors
io.encodings.utf8 ;
[ ] [ "blahblah" temp-file dup exists? [ delete-directory ] [ drop ] if ] unit-test
[ ] [ "blahblah" temp-file make-directory ] unit-test
@ -9,6 +10,7 @@ io.files.unique sequences strings accessors ;
[ "passwd" ] [ "/etc/passwd" file-name ] unit-test
[ "awk" ] [ "/usr/libexec/awk/" file-name ] unit-test
[ "awk" ] [ "/usr/libexec/awk///" file-name ] unit-test
[ "" ] [ "" file-name ] unit-test
[ ] [
{ "Hello world." }
@ -81,6 +83,18 @@ io.files.unique sequences strings accessors ;
"delete-tree-test" temp-file delete-tree
] unit-test
[ { { "kernel" t } } ] [
"core" resource-path [
"." directory [ first "kernel" = ] subset
] with-directory
] unit-test
[ { { "kernel" t } } ] [
"resource:core" [
"." directory [ first "kernel" = ] subset
] with-directory
] unit-test
[ ] [
"copy-tree-test/a/b/c" temp-file make-directories
] unit-test
@ -129,6 +143,15 @@ io.files.unique sequences strings accessors ;
[ t ] [ cwd "misc" resource-path [ ] with-directory cwd = ] unit-test
[ t ] [
temp-directory [ "hi41" "test41" utf8 set-file-contents ] with-directory
temp-directory "test41" append-path utf8 file-contents "hi41" =
] unit-test
[ t ] [
temp-directory [ "test41" file-info size>> ] with-directory 4 =
] unit-test
[ ] [ "append-test" temp-file dup exists? [ delete-file ] [ drop ] if ] unit-test
[ ] [ "append-test" temp-file ascii <file-appender> dispose ] unit-test
@ -144,3 +167,51 @@ io.files.unique sequences strings accessors ;
] keep file-info size>>
] with-unique-file
] unit-test
[ "/usr/lib" ] [ "/usr" "lib" append-path ] unit-test
[ "/usr/lib" ] [ "/usr/" "lib" append-path ] unit-test
[ "/lib" ] [ "/usr/" "/lib" append-path ] unit-test
[ "/lib/" ] [ "/usr/" "/lib/" append-path ] unit-test
[ "/usr/lib" ] [ "/usr" "./lib" append-path ] unit-test
[ "/usr/lib/" ] [ "/usr" "./lib/" append-path ] unit-test
[ "/lib" ] [ "/usr" "../lib" append-path ] unit-test
[ "/lib/" ] [ "/usr" "../lib/" append-path ] unit-test
[ "" ] [ "" "." append-path ] unit-test
[ "" ".." append-path ] must-fail
[ "/" ] [ "/" "./." append-path ] unit-test
[ "/" ] [ "/" "././" append-path ] unit-test
[ "/a/b/lib" ] [ "/a/b/c/d/e/f/" "../../../../lib" append-path ] unit-test
[ "/a/b/lib/" ] [ "/a/b/c/d/e/f/" "../../../../lib/" append-path ] unit-test
[ "" "../lib/" append-path ] must-fail
[ "lib" ] [ "" "lib" append-path ] unit-test
[ "lib" ] [ "" "./lib" append-path ] unit-test
[ "/lib/bux" ] [ "/usr" "/lib/bux" append-path ] unit-test
[ "/lib/bux/" ] [ "/usr" "/lib/bux/" append-path ] unit-test
[ "foo/bar/." parent-directory ] must-fail
[ "foo/bar/./" parent-directory ] must-fail
[ "foo/bar/baz/.." parent-directory ] must-fail
[ "foo/bar/baz/../" parent-directory ] must-fail
[ "." parent-directory ] must-fail
[ "./" parent-directory ] must-fail
[ ".." parent-directory ] must-fail
[ "../" parent-directory ] must-fail
[ "../../" parent-directory ] must-fail
[ "foo/.." parent-directory ] must-fail
[ "foo/../" parent-directory ] must-fail
[ "" parent-directory ] must-fail
[ "." ] [ "boot.x86.64.image" parent-directory ] unit-test
[ "bar/foo" ] [ "bar/baz" "..///foo" append-path ] unit-test
[ "bar/baz/foo" ] [ "bar/baz" ".///foo" append-path ] unit-test
[ "bar/foo" ] [ "bar/baz" "./..//foo" append-path ] unit-test
[ "bar/foo" ] [ "bar/baz" "./../././././././///foo" append-path ] unit-test
[ t ] [ "resource:core" absolute-path? ] unit-test
[ t ] [ "/foo" absolute-path? ] unit-test
[ f ] [ "" absolute-path? ] unit-test

185
core/io/files/files.factor
View File

@ -3,7 +3,7 @@
USING: io.backend io.files.private io hashtables kernel math
memory namespaces sequences strings assocs arrays definitions
system combinators splitting sbufs continuations io.encodings
io.encodings.binary ;
io.encodings.binary init ;
IN: io.files
HOOK: (file-reader) io-backend ( path -- stream )
@ -13,15 +13,34 @@ HOOK: (file-writer) io-backend ( path -- stream )
HOOK: (file-appender) io-backend ( path -- stream )
: <file-reader> ( path encoding -- stream )
swap (file-reader) swap <decoder> ;
swap normalize-pathname (file-reader) swap <decoder> ;
: <file-writer> ( path encoding -- stream )
swap (file-writer) swap <encoder> ;
swap normalize-pathname (file-writer) swap <encoder> ;
: <file-appender> ( path encoding -- stream )
swap (file-appender) swap <encoder> ;
swap normalize-pathname (file-appender) swap <encoder> ;
HOOK: rename-file io-backend ( from to -- )
: file-lines ( path encoding -- seq )
<file-reader> lines ;
: with-file-reader ( path encoding quot -- )
>r <file-reader> r> with-stream ; inline
: file-contents ( path encoding -- str )
<file-reader> contents ;
: with-file-writer ( path encoding quot -- )
>r <file-writer> r> with-stream ; inline
: set-file-lines ( seq path encoding -- )
[ [ print ] each ] with-file-writer ;
: set-file-contents ( str path encoding -- )
[ write ] with-file-writer ;
: with-file-appender ( path encoding quot -- )
>r <file-appender> r> with-stream ; inline
! Pathnames
: path-separator? ( ch -- ? ) windows? "/\\" "/" ? member? ;
@ -32,42 +51,95 @@ HOOK: rename-file io-backend ( from to -- )
: left-trim-separators ( str -- newstr )
[ path-separator? ] left-trim ;
: append-path ( str1 str2 -- str )
>r right-trim-separators "/" r>
left-trim-separators 3append ;
: prepend-path ( str1 str2 -- str )
swap append-path ; inline
: last-path-separator ( path -- n ? )
[ length 1- ] keep [ path-separator? ] find-last* ;
HOOK: root-directory? io-backend ( path -- ? )
M: object root-directory? ( path -- ? ) path-separator? ;
: special-directory? ( name -- ? ) { "." ".." } member? ;
M: object root-directory? ( path -- ? )
dup empty? [ drop f ] [ [ path-separator? ] all? ] if ;
ERROR: no-parent-directory path ;
: parent-directory ( path -- parent )
right-trim-separators {
{ [ dup empty? ] [ drop "/" ] }
{ [ dup root-directory? ] [ ] }
{ [ dup [ path-separator? ] contains? not ] [ drop "." ] }
dup root-directory? [
right-trim-separators
dup last-path-separator [
1+ cut
] [
drop "." swap
] if
{ "" "." ".." } member? [
no-parent-directory
] when
] unless ;
<PRIVATE
: head-path-separator? ( path1 ? -- ?' )
[
dup empty? [ drop t ] [ first path-separator? ] if
] [
drop f
] if ;
: head.? ( path -- ? ) "." ?head head-path-separator? ;
: head..? ( path -- ? ) ".." ?head head-path-separator? ;
: append-path-empty ( path1 path2 -- path' )
{
{ [ dup head.? ] [
1 tail left-trim-separators append-path-empty
] }
{ [ dup head..? ] [ drop no-parent-directory ] }
{ [ t ] [ nip ] }
} cond ;
PRIVATE>
: windows-absolute-path? ( path -- path ? )
{
{ [ dup length 2 < ] [ f ] }
{ [ dup second CHAR: : = ] [ t ] }
{ [ t ] [ f ] }
} cond ;
: absolute-path? ( path -- ? )
{
{ [ dup empty? ] [ f ] }
{ [ dup "resource:" head? ] [ t ] }
{ [ dup first path-separator? ] [ t ] }
{ [ windows? ] [ windows-absolute-path? ] }
{ [ t ] [ f ] }
} cond nip ;
: append-path ( str1 str2 -- str )
{
{ [ over empty? ] [ append-path-empty ] }
{ [ dup empty? ] [ drop ] }
{ [ dup absolute-path? ] [ nip ] }
{ [ dup head.? ] [ 1 tail left-trim-separators append-path ] }
{ [ dup head..? ] [
2 tail left-trim-separators
>r parent-directory r> append-path
] }
{ [ t ] [
dup last-path-separator drop 1+ cut
special-directory? [ no-parent-directory ] when
>r right-trim-separators "/" r>
left-trim-separators 3append
] }
} cond ;
: file-name ( path -- string )
right-trim-separators {
{ [ dup empty? ] [ drop "/" ] }
{ [ dup last-path-separator ] [ 1+ tail ] }
{ [ t ] [ drop ] }
} cond ;
: prepend-path ( str1 str2 -- str )
swap append-path ; inline
: file-name ( path -- string )
dup root-directory? [
right-trim-separators
dup last-path-separator [ 1+ tail ] [ drop ] if
] unless ;
! File info
TUPLE: file-info type size permissions modified ;
HOOK: file-info io-backend ( path -- info )
@ -94,8 +166,18 @@ HOOK: cd io-backend ( path -- )
HOOK: cwd io-backend ( -- path )
SYMBOL: current-directory
M: object cwd ( -- path ) "." ;
[ cwd current-directory set-global ] "io.files" add-init-hook
: with-directory ( path quot -- )
cwd [ cd ] curry rot cd [ ] cleanup ; inline
>r normalize-pathname r>
current-directory swap with-variable ; inline
: set-current-directory ( path -- )
normalize-pathname current-directory set ;
! Creating directories
HOOK: make-directory io-backend ( path -- )
@ -118,7 +200,7 @@ HOOK: make-directory io-backend ( path -- )
dup string?
[ tuck append-path directory? 2array ] [ nip ] if
] with map
[ first special-directory? not ] subset ;
[ first { "." ".." } member? not ] subset ;
: directory ( path -- seq )
normalize-directory dup (directory) fixup-directory ;
@ -193,11 +275,19 @@ DEFER: copy-tree-into
"resource-path" get [ image parent-directory ] unless*
prepend-path ;
: ?resource-path ( path -- newpath )
"resource:" ?head [ resource-path ] when ;
: temp-directory ( -- path )
"temp" resource-path dup make-directories ;
: resource-exists? ( path -- ? )
?resource-path exists? ;
: temp-file ( name -- path )
temp-directory prepend-path ;
M: object normalize-pathname ( path -- path' )
"resource:" ?head [
left-trim-separators resource-path
normalize-pathname
] [
current-directory get prepend-path
] if ;
! Pathname presentations
TUPLE: pathname string ;
@ -206,35 +296,6 @@ C: <pathname> pathname
M: pathname <=> [ pathname-string ] compare ;
: file-lines ( path encoding -- seq )
<file-reader> lines ;
: with-file-reader ( path encoding quot -- )
>r <file-reader> r> with-stream ; inline
: file-contents ( path encoding -- str )
<file-reader> contents ;
: with-file-writer ( path encoding quot -- )
>r <file-writer> r> with-stream ; inline
: set-file-lines ( seq path encoding -- )
[ [ print ] each ] with-file-writer ;
: set-file-contents ( str path encoding -- )
[ write ] with-file-writer ;
: with-file-appender ( path encoding quot -- )
>r <file-appender> r> with-stream ; inline
: temp-directory ( -- path )
"temp" resource-path
dup exists? not
[ dup make-directory ]
when ;
: temp-file ( name -- path ) temp-directory prepend-path ;
! Home directory
: home ( -- dir )
{

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

@ -1,10 +1,10 @@
USING: arrays io io.files kernel math parser strings system
tools.test words namespaces io.encodings.latin1
tools.test words namespaces io.encodings.8-bit
io.encodings.binary ;
IN: io.tests
[ f ] [
"resource:/core/io/test/no-trailing-eol.factor" run-file
"resource:core/io/test/no-trailing-eol.factor" run-file
"foo" "io.tests" lookup
] unit-test
@ -14,14 +14,14 @@ IN: io.tests
[
"This is a line.\rThis is another line.\r"
] [
"/core/io/test/mac-os-eol.txt" <resource-reader>
"core/io/test/mac-os-eol.txt" <resource-reader>
[ 500 read ] with-stream
] unit-test
[
255
] [
"/core/io/test/binary.txt" <resource-reader>
"core/io/test/binary.txt" <resource-reader>
[ read1 ] with-stream >fixnum
] unit-test
@ -36,7 +36,7 @@ IN: io.tests
}
] [
[
"/core/io/test/separator-test.txt" <resource-reader> [
"core/io/test/separator-test.txt" <resource-reader> [
"J" read-until 2array ,
"i" read-until 2array ,
"X" read-until 2array ,

39
core/kernel/kernel.factor
View File

@ -67,29 +67,7 @@ DEFER: if
[ >r tuck 2slip r> while ]
[ 2nip call ] if ; inline
! Quotation building
USE: tuples.private
: curry ( obj quot -- curry )
\ curry 4 <tuple-boa> ;
: 2curry ( obj1 obj2 quot -- curry )
curry curry ; inline
: 3curry ( obj1 obj2 obj3 quot -- curry )
curry curry curry ; inline
: with ( param obj quot -- obj curry )
swapd [ swapd call ] 2curry ; inline
: compose ( quot1 quot2 -- curry )
\ compose 4 <tuple-boa> ;
: 3compose ( quot1 quot2 quot3 -- curry )
compose compose ; inline
! Object protocol
GENERIC: delegate ( obj -- delegate )
M: object delegate drop f ;
@ -118,7 +96,6 @@ M: object clone ;
M: callstack clone (clone) ;
! Tuple construction
GENERIC# get-slots 1 ( tuple slots -- ... )
GENERIC# set-slots 1 ( ... tuple slots -- )
@ -132,8 +109,22 @@ GENERIC: construct-boa ( ... class -- tuple )
: construct-delegate ( delegate class -- tuple )
>r { set-delegate } r> construct ; inline
! Booleans
! Quotation building
USE: tuples.private
: 2curry ( obj1 obj2 quot -- curry )
curry curry ; inline
: 3curry ( obj1 obj2 obj3 quot -- curry )
curry curry curry ; inline
: with ( param obj quot -- obj curry )
swapd [ swapd call ] 2curry ; inline
: 3compose ( quot1 quot2 quot3 -- curry )
compose compose ; inline
! Booleans
: not ( obj -- ? ) f eq? ; inline
: >boolean ( obj -- ? ) t f ? ; inline

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

@ -5,7 +5,7 @@ TUPLE: foo bar baz ;
C: <foo> foo
[ { "bar" "baz" } ] [ 1 2 <foo> <mirror> keys ] unit-test
[ { "delegate" "bar" "baz" } ] [ 1 2 <foo> <mirror> keys ] unit-test
[ 1 t ] [ "bar" 1 2 <foo> <mirror> at* ] unit-test

10
core/mirrors/mirrors.factor
View File

@ -5,13 +5,11 @@ arrays classes slots slots.private tuples math vectors
quotations sorting prettyprint ;
IN: mirrors
GENERIC: object-slots ( obj -- seq )
: all-slots ( class -- slots )
superclasses [ "slots" word-prop ] map concat ;
M: object object-slots class "slots" word-prop ;
M: tuple object-slots
dup class "slots" word-prop
swap delegate [ 1 tail-slice ] unless ;
: object-slots ( obj -- seq )
class all-slots ;
TUPLE: mirror object slots ;

4
core/optimizer/control/control.factor
View File

@ -3,8 +3,8 @@
USING: arrays generic assocs inference inference.class
inference.dataflow inference.backend inference.state io kernel
math namespaces sequences vectors words quotations hashtables
combinators classes generic.math continuations optimizer.def-use
optimizer.backend generic.standard ;
combinators classes classes.algebra generic.math continuations
optimizer.def-use optimizer.backend generic.standard ;
IN: optimizer.control
! ! ! Rudimentary CFA

10
core/optimizer/inlining/inlining.factor
View File

@ -3,10 +3,10 @@
USING: arrays generic assocs inference inference.class
inference.dataflow inference.backend inference.state io kernel
math namespaces sequences vectors words quotations hashtables
combinators classes generic.math continuations optimizer.def-use
optimizer.backend generic.standard optimizer.specializers
optimizer.def-use optimizer.pattern-match generic.standard
optimizer.control kernel.private ;
combinators classes classes.algebra generic.math continuations
optimizer.def-use optimizer.backend generic.standard
optimizer.specializers optimizer.def-use optimizer.pattern-match
generic.standard optimizer.control kernel.private ;
IN: optimizer.inlining
: remember-inlining ( node history -- )
@ -175,7 +175,7 @@ DEFER: (flat-length)
: optimistic-inline? ( #call -- ? )
dup node-param "specializer" word-prop dup [
>r node-input-classes r> specialized-length tail*
[ types length 1 = ] all?
[ class-types length 1 = ] all?
] [
2drop f
] if ;

16
core/optimizer/known-words/known-words.factor
View File

@ -7,15 +7,15 @@ sequences words parser vectors strings sbufs io namespaces
assocs quotations sequences.private io.binary io.crc32
io.streams.string layouts splitting math.intervals
math.floats.private tuples tuples.private classes
optimizer.def-use optimizer.backend optimizer.pattern-match
optimizer.inlining float-arrays sequences.private combinators ;
classes.algebra optimizer.def-use optimizer.backend
optimizer.pattern-match optimizer.inlining float-arrays
sequences.private combinators ;
! the output of <tuple> and <tuple-boa> has the class which is
! its second-to-last input
{ <tuple> <tuple-boa> } [
[
dup node-in-d dup length 2 - swap nth node-literal
dup class? [ drop tuple ] unless 1array f
dup node-in-d peek node-literal
dup tuple-layout? [ layout-class ] [ drop tuple ] if
1array f
] "output-classes" set-word-prop
] each
@ -89,10 +89,10 @@ optimizer.inlining float-arrays sequences.private combinators ;
! type applied to an object of a known type can be folded
: known-type? ( node -- ? )
node-class-first types length 1 number= ;
node-class-first class-types length 1 number= ;
: fold-known-type ( node -- node )
dup node-class-first types inline-literals ;
dup node-class-first class-types inline-literals ;
\ type [
{ [ dup known-type? ] [ fold-known-type ] }

7
core/optimizer/math/math.factor
View File

@ -5,9 +5,10 @@ USING: alien alien.accessors arrays generic hashtables kernel
assocs math math.private kernel.private sequences words parser
inference.class inference.dataflow vectors strings sbufs io
namespaces assocs quotations math.intervals sequences.private
combinators splitting layouts math.parser classes generic.math
optimizer.pattern-match optimizer.backend optimizer.def-use
optimizer.inlining generic.standard system ;
combinators splitting layouts math.parser classes
classes.algebra generic.math optimizer.pattern-match
optimizer.backend optimizer.def-use optimizer.inlining
generic.standard system ;
{ + bignum+ float+ fixnum+fast } {
{ { number 0 } [ drop ] }

5
core/optimizer/optimizer-tests.factor
View File

@ -1,8 +1,9 @@
USING: arrays compiler.units generic hashtables inference kernel
kernel.private math optimizer prettyprint sequences sbufs
strings tools.test vectors words sequences.private quotations
optimizer.backend classes inference.dataflow tuples.private
continuations growable optimizer.inlining namespaces hints ;
optimizer.backend classes classes.algebra inference.dataflow
tuples.private continuations growable optimizer.inlining
namespaces hints ;
IN: optimizer.tests
[ H{ { 1 5 } { 3 4 } { 2 5 } } ] [

2
core/optimizer/pattern-match/pattern-match.factor Normal file → Executable file
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
IN: optimizer.pattern-match
USING: kernel sequences inference namespaces generic
combinators classes inference.dataflow ;
combinators classes classes.algebra inference.dataflow ;
! Funny pattern matching
SYMBOL: @

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

@ -389,7 +389,7 @@ IN: parser.tests
] with-scope
[ ] [
"IN: parser.tests USE: kernel PREDICATE: object foo ( x -- y ) ;" eval
"IN: parser.tests USE: kernel PREDICATE: foo < object ( x -- y ) ;" eval
] unit-test
[ t ] [

14
core/parser/parser.factor
View File

@ -214,7 +214,7 @@ SYMBOL: in
ERROR: unexpected want got ;
PREDICATE: unexpected unexpected-eof
PREDICATE: unexpected-eof < unexpected
unexpected-got not ;
: unexpected-eof ( word -- * ) f unexpected ;
@ -288,6 +288,14 @@ M: no-word summary
: CREATE-METHOD ( -- method )
scan-word bootstrap-word scan-word create-method-in ;
: parse-tuple-definition ( -- class superclass slots )
CREATE-CLASS
scan {
{ ";" [ tuple f ] }
{ "<" [ scan-word ";" parse-tokens ] }
[ >r tuple ";" parse-tokens r> add* ]
} case ;
ERROR: staging-violation word ;
M: staging-violation summary
@ -512,7 +520,7 @@ SYMBOL: interactive-vocabs
[
[
[ parsing-file ] keep
[ ?resource-path utf8 <file-reader> ] keep
[ utf8 <file-reader> ] keep
parse-stream
] with-compiler-errors
] [
@ -524,7 +532,7 @@ SYMBOL: interactive-vocabs
[ dup parse-file call ] assert-depth drop ;
: ?run-file ( path -- )
dup resource-exists? [ run-file ] [ drop ] if ;
dup exists? [ run-file ] [ drop ] if ;
: bootstrap-file ( path -- )
[ parse-file % ] [ run-file ] if-bootstrapping ;

5
core/prettyprint/backend/backend.factor
View File

@ -4,7 +4,7 @@ USING: arrays byte-arrays byte-vectors bit-arrays bit-vectors
generic hashtables io assocs kernel math namespaces sequences
strings sbufs io.styles vectors words prettyprint.config
prettyprint.sections quotations io io.files math.parser effects
tuples classes float-arrays float-vectors ;
tuples tuples.private classes float-arrays float-vectors ;
IN: prettyprint.backend
GENERIC: pprint* ( obj -- )
@ -202,3 +202,6 @@ M: wrapper pprint*
] [
pprint-object
] if ;
M: tuple-layout pprint*
"( tuple layout )" swap present-text ;

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

@ -329,3 +329,9 @@ M: f generic-see-test-with-f ;
[ "USING: prettyprint.tests ;\nM: f generic-see-test-with-f ;\n" ] [
[ \ f \ generic-see-test-with-f method see ] with-string-writer
] unit-test
PREDICATE: predicate-see-test < integer even? ;
[ "USING: math ;\nIN: prettyprint.tests\nPREDICATE: predicate-see-test < integer even? ;\n" ] [
[ \ predicate-see-test see ] with-string-writer
] unit-test

6
core/prettyprint/prettyprint.factor
View File

@ -247,8 +247,9 @@ M: mixin-class see-class*
M: predicate-class see-class*
<colon \ PREDICATE: pprint-word
dup superclass pprint-word
dup pprint-word
"<" text
dup superclass pprint-word
<block
"predicate-definition" word-prop pprint-elements
pprint-; block> block> ;
@ -256,6 +257,9 @@ M: predicate-class see-class*
M: tuple-class see-class*
<colon \ TUPLE: pprint-word
dup pprint-word
dup superclass tuple eq? [
"<" text dup superclass pprint-word
] unless
"slot-names" word-prop [ text ] each
pprint-; block> ;

4
core/quotations/quotations.factor
View File

@ -7,9 +7,9 @@ IN: quotations
M: quotation call (call) ;
M: curry call dup 4 slot swap 5 slot call ;
M: curry call dup 3 slot swap 4 slot call ;
M: compose call dup 4 slot swap 5 slot slip call ;
M: compose call dup 3 slot swap 4 slot slip call ;
M: wrapper equal?
over wrapper? [ [ wrapped ] 2apply = ] [ 2drop f ] if ;

2
core/sequences/sequences.factor
View File

@ -60,7 +60,7 @@ INSTANCE: immutable-sequence sequence
#! A bit of a pain; can't call cell-bits here
7 getenv 8 * 5 - 2^ 1- ; foldable
PREDICATE: fixnum array-capacity
PREDICATE: array-capacity < fixnum
0 max-array-capacity between? ;
: array-capacity ( array -- n )

4
core/slots/deprecated/deprecated.factor
View File

@ -8,7 +8,7 @@ IN: slots.deprecated
: reader-effect ( class spec -- effect )
>r ?word-name 1array r> slot-spec-name 1array <effect> ;
PREDICATE: word slot-reader "reading" word-prop >boolean ;
PREDICATE: slot-reader < word "reading" word-prop >boolean ;
: set-reader-props ( class spec -- )
2dup reader-effect
@ -30,7 +30,7 @@ PREDICATE: word slot-reader "reading" word-prop >boolean ;
: writer-effect ( class spec -- effect )
slot-spec-name swap ?word-name 2array 0 <effect> ;
PREDICATE: word slot-writer "writing" word-prop >boolean ;
PREDICATE: slot-writer < word "writing" word-prop >boolean ;
: set-writer-props ( class spec -- )
2dup writer-effect

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

@ -12,7 +12,7 @@ ARTICLE: "accessors" "Slot accessors"
}
"In addition, two utility words are defined for each distinct slot name used in the system:"
{ $list
{ "The " { $emphasis "setter" } " is named " { $snippet "(>>" { $emphasis "slot" } ")" } " and stores a value into a slot. It has stack effect " { $snippet "( object value -- object )" } "." }
{ "The " { $emphasis "setter" } " is named " { $snippet ">>" { $emphasis "slot" } } " and stores a value into a slot. It has stack effect " { $snippet "( object value -- object )" } "." }
{ "The " { $emphasis "changer" } " is named " { $snippet "change-" { $emphasis "slot" } } ". It applies a quotation to the current slot value and stores the result back in the slot; it has stack effect " { $snippet "( object quot -- object )" } "." }
}
"Since the reader and writer are generic, words can be written which do not depend on the specific class of tuple passed in, but instead work on any tuple that defines slots with certain names."

2
core/slots/slots.factor
View File

@ -46,7 +46,7 @@ C: <slot-spec> slot-spec
: define-writer ( class slot name -- )
writer-word [ set-slot ] define-slot-word ;
: setter-effect T{ effect f { "object" "value" } { "value" } } ; inline
: setter-effect T{ effect f { "object" "value" } { "object" } } ; inline
: setter-word ( name -- word )
">>" prepend setter-effect create-accessor ;

2
core/source-files/source-files.factor
View File

@ -48,7 +48,7 @@ uses definitions ;
: reset-checksums ( -- )
source-files get [
swap ?resource-path dup exists? [
swap dup exists? [
utf8 file-lines swap record-checksum
] [ 2drop ] if
] assoc-each ;

10
core/syntax/syntax-docs.factor
View File

@ -543,8 +543,8 @@ HELP: INSTANCE:
{ $description "Makes " { $snippet "instance" } " an instance of " { $snippet "mixin" } "." } ;
HELP: PREDICATE:
{ $syntax "PREDICATE: superclass class predicate... ;" }
{ $values { "superclass" "an existing class word" } { "class" "a new class word to define" } { "predicate" "membership test with stack effect " { $snippet "( superclass -- ? )" } } }
{ $syntax "PREDICATE: class < superclass predicate... ;" }
{ $values { "class" "a new class word to define" } { "superclass" "an existing class word" } { "predicate" "membership test with stack effect " { $snippet "( superclass -- ? )" } } }
{ $description
"Defines a predicate class deriving from " { $snippet "superclass" } "."
$nl
@ -557,11 +557,9 @@ HELP: PREDICATE:
} ;
HELP: TUPLE:
{ $syntax "TUPLE: class slots... ;" }
{ $syntax "TUPLE: class slots... ;" "TUPLE: class < superclass slots ... ;" }
{ $values { "class" "a new tuple class to define" } { "slots" "a list of slot names" } }
{ $description "Defines a new tuple class."
$nl
"Tuples are user-defined classes with instances composed of named slots. All tuple classes are subtypes of the built-in " { $link tuple } " type." } ;
{ $description "Defines a new tuple class. The superclass is optional; if left unspecified, it defaults to " { $link tuple } "." } ;
HELP: ERROR:
{ $syntax "ERROR: class slots... ;" }

13
core/syntax/syntax.factor
View File

@ -6,7 +6,7 @@ namespaces parser sequences strings sbufs vectors words
quotations io assocs splitting tuples generic.standard
generic.math classes io.files vocabs float-arrays float-vectors
classes.union classes.mixin classes.predicate compiler.units
combinators ;
combinators debugger ;
IN: bootstrap.syntax
! These words are defined as a top-level form, instead of with
@ -148,13 +148,14 @@ IN: bootstrap.syntax
] define-syntax
"PREDICATE:" [
scan-word
CREATE-CLASS
scan "<" assert=
scan-word
parse-definition define-predicate-class
] define-syntax
"TUPLE:" [
CREATE-CLASS ";" parse-tokens define-tuple-class
parse-tuple-definition define-tuple-class
] define-syntax
"C:" [
@ -164,9 +165,9 @@ IN: bootstrap.syntax
] define-syntax
"ERROR:" [
CREATE-CLASS dup ";" parse-tokens define-tuple-class
dup save-location
dup [ construct-boa throw ] curry define
parse-tuple-definition
pick save-location
define-error-class
] define-syntax
"FORGET:" [

24
core/tuples/tuples-docs.factor
View File

@ -153,10 +153,6 @@ HELP: tuple=
{ $description "Low-level tuple equality test. User code should use " { $link = } " instead." }
{ $warning "This word is in the " { $vocab-link "tuples.private" } " vocabulary because it does not do any type checking. Passing values which are not tuples can result in memory corruption." } ;
HELP: tuple-class-eq?
{ $values { "obj" object } { "class" tuple-class } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "obj" } " is an instance of " { $snippet "class" } "." } ;
HELP: permutation
{ $values { "seq1" sequence } { "seq2" sequence } { "permutation" "a sequence whose elements are integers or " { $link f } } }
{ $description "Outputs a permutation for taking " { $snippet "seq1" } " to " { $snippet "seq2" } "." } ;
@ -169,7 +165,7 @@ HELP: reshape-tuples
{ $values { "class" tuple-class } { "newslots" "a sequence of strings" } }
{ $description "Changes the shape of every instance of " { $snippet "class" } " for a new slot layout." } ;
HELP: old-slots
HELP: removed-slots
{ $values { "class" tuple-class } { "newslots" "a sequence of strings" } { "seq" "a sequence of strings" } }
{ $description "Outputs the sequence of existing tuple slot names not in " { $snippet "newslots" } "." } ;
@ -194,8 +190,8 @@ HELP: define-tuple-predicate
{ $description "Defines a predicate word that tests if the top of the stack is an instance of " { $snippet "class" } ". This will only work if " { $snippet "class" } " is a tuple class." }
$low-level-note ;
HELP: check-shape
{ $values { "class" class } { "newslots" "a sequence of strings" } }
HELP: redefine-tuple-class
{ $values { "class" class } { "superclass" class } { "slots" "a sequence of strings" } }
{ $description "If the new slot layout differs from the existing one, updates all existing instances of this tuple class, and forgets any slot accessor words which are no longer needed."
$nl
"If the class is not a tuple class word, this word does nothing." }
@ -218,8 +214,8 @@ HELP: check-tuple
{ $error-description "Thrown if " { $link POSTPONE: C: } " is called with a word which does not name a tuple class." } ;
HELP: define-tuple-class
{ $values { "class" word } { "slots" "a sequence of strings" } }
{ $description "Defines a tuple class with slots named by " { $snippet "slots" } ". This is the run time equivalent of " { $link POSTPONE: TUPLE: } "." }
{ $values { "class" word } { "superclass" class } { "slots" "a sequence of strings" } }
{ $description "Defines a tuple class inheriting from " { $snippet "superclass" } " with slots named by " { $snippet "slots" } ". This is the run time equivalent of " { $link POSTPONE: TUPLE: } "." }
{ $notes "This word must be called from inside " { $link with-compilation-unit } "." }
{ $side-effects "class" } ;
@ -246,9 +242,13 @@ HELP: tuple>array ( tuple -- array )
{ $values { "tuple" tuple } { "array" array } }
{ $description "Outputs an array having the tuple's slots as elements. The first element is the tuple class word and the second is the delegate; the remainder are declared slots." } ;
HELP: <tuple> ( class n -- tuple )
{ $values { "class" tuple-class } { "n" "a non-negative integer" } { "tuple" tuple } }
{ $description "Low-level tuple constructor. User code should never call this directly, and instead use the constructor word which is defined for each tuple. See " { $link "tuples" } "." } ;
HELP: <tuple> ( layout -- tuple )
{ $values { "layout" tuple-layout } { "tuple" tuple } }
{ $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link construct-empty } "." } ;
HELP: <tuple-boa> ( ... layout -- tuple )
{ $values { "..." "values" } { "layout" tuple-layout } { "tuple" tuple } }
{ $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link construct-boa } "." } ;
HELP: construct-empty
{ $values { "class" tuple-class } { "tuple" tuple } }

156
core/tuples/tuples-tests.factor
View File

@ -2,21 +2,19 @@ USING: definitions generic kernel kernel.private math
math.constants parser sequences tools.test words assocs
namespaces quotations sequences.private classes continuations
generic.standard effects tuples tuples.private arrays vectors
strings compiler.units ;
strings compiler.units accessors classes.algebra calendar
prettyprint io.streams.string splitting ;
IN: tuples.tests
[ t ] [ \ tuple-class \ class class< ] unit-test
[ f ] [ \ class \ tuple-class class< ] unit-test
TUPLE: rect x y w h ;
: <rect> rect construct-boa ;
: move ( x rect -- )
[ rect-x + ] keep set-rect-x ;
: move ( x rect -- rect )
[ + ] change-x ;
[ f ] [ 10 20 30 40 <rect> dup clone 5 swap [ move ] keep = ] unit-test
[ f ] [ 10 20 30 40 <rect> dup clone 5 swap move = ] unit-test
[ t ] [ 10 20 30 40 <rect> dup clone 0 swap [ move ] keep = ] unit-test
[ t ] [ 10 20 30 40 <rect> dup clone 0 swap move = ] unit-test
GENERIC: delegation-test
M: object delegation-test drop 3 ;
@ -37,27 +35,46 @@ TUPLE: quuux-tuple-2 ;
[ 4 ] [ <quux-tuple-2> <quuux-tuple-2> delegation-test-2 ] unit-test
! Make sure we handle tuple class redefinition
TUPLE: redefinition-test ;
C: <redefinition-test> redefinition-test
<redefinition-test> "redefinition-test" set
[ t ] [ "redefinition-test" get redefinition-test? ] unit-test
"IN: tuples.tests TUPLE: redefinition-test ;" eval
[ t ] [ "redefinition-test" get redefinition-test? ] unit-test
! Make sure we handle changing shapes!
TUPLE: point x y ;
C: <point> point
100 200 <point> "p" set
[ ] [ 100 200 <point> "p" set ] unit-test
! Use eval to sequence parsing explicitly
"IN: tuples.tests TUPLE: point x y z ;" eval
[ ] [ "IN: tuples.tests TUPLE: point x y z ;" eval ] unit-test
[ 100 ] [ "p" get point-x ] unit-test
[ 200 ] [ "p" get point-y ] unit-test
[ f ] [ "p" get "point-z" "tuples.tests" lookup execute ] unit-test
[ 100 ] [ "p" get x>> ] unit-test
[ 200 ] [ "p" get y>> ] unit-test
[ f ] [ "p" get "z>>" "accessors" lookup execute ] unit-test
300 "p" get "set-point-z" "tuples.tests" lookup execute
"p" get 300 ">>z" "accessors" lookup execute drop
[ 4 ] [ "p" get tuple-size ] unit-test
[ 300 ] [ "p" get "z>>" "accessors" lookup execute ] unit-test
"IN: tuples.tests TUPLE: point z y ;" eval
[ "p" get point-x ] must-fail
[ 200 ] [ "p" get point-y ] unit-test
[ 300 ] [ "p" get "point-z" "tuples.tests" lookup execute ] unit-test
[ 3 ] [ "p" get tuple-size ] unit-test
[ "p" get x>> ] must-fail
[ 200 ] [ "p" get y>> ] unit-test
[ 300 ] [ "p" get "z>>" "accessors" lookup execute ] unit-test
TUPLE: predicate-test ;
@ -67,14 +84,14 @@ C: <predicate-test> predicate-test
[ t ] [ <predicate-test> predicate-test? ] unit-test
PREDICATE: tuple silly-pred
PREDICATE: silly-pred < tuple
class \ rect = ;
GENERIC: area
M: silly-pred area dup rect-w swap rect-h * ;
M: silly-pred area dup w>> swap h>> * ;
TUPLE: circle radius ;
M: circle area circle-radius sq pi * ;
M: circle area radius>> sq pi * ;
[ 200 ] [ T{ rect f 0 0 10 20 } area ] unit-test
@ -90,14 +107,8 @@ TUPLE: delegate-clone ;
[ T{ delegate-clone T{ empty f } } ]
[ T{ delegate-clone T{ empty f } } clone ] unit-test
[ t ] [ \ null \ delegate-clone class< ] unit-test
[ f ] [ \ object \ delegate-clone class< ] unit-test
[ f ] [ \ object \ delegate-clone class< ] unit-test
[ t ] [ \ delegate-clone \ tuple class< ] unit-test
[ f ] [ \ tuple \ delegate-clone class< ] unit-test
! Compiler regression
[ t length ] [ no-method-object t eq? ] must-fail-with
[ t length ] [ object>> t eq? ] must-fail-with
[ "<constructor-test>" ]
[ "TUPLE: constructor-test ; C: <constructor-test> constructor-test" eval word word-name ] unit-test
@ -105,7 +116,7 @@ TUPLE: delegate-clone ;
TUPLE: size-test a b c d ;
[ t ] [
T{ size-test } array-capacity
T{ size-test } tuple-size
size-test tuple-size =
] unit-test
@ -121,7 +132,7 @@ TUPLE: yo-momma ;
[
[ t ] [ \ yo-momma class? ] unit-test
[ ] [ \ yo-momma forget ] unit-test
[ f ] [ \ yo-momma typemap get values memq? ] unit-test
[ f ] [ \ yo-momma update-map get values memq? ] unit-test
[ f ] [ \ yo-momma crossref get at ] unit-test
] with-compilation-unit
@ -222,22 +233,89 @@ C: <erg's-reshape-problem> erg's-reshape-problem
! tuples are reshaped
: cons-test-1 \ erg's-reshape-problem construct-empty ;
: cons-test-2 \ erg's-reshape-problem construct-boa ;
: cons-test-3
{ set-erg's-reshape-problem-a }
\ erg's-reshape-problem construct ;
"IN: tuples.tests TUPLE: erg's-reshape-problem a b c d e f ;" eval
[ ] [ 1 2 3 4 5 6 cons-test-2 "a" set ] unit-test
[ t ] [ cons-test-1 array-capacity "a" get array-capacity = ] unit-test
[ t ] [ 1 cons-test-3 array-capacity "a" get array-capacity = ] unit-test
[ t ] [ cons-test-1 tuple-size "a" get tuple-size = ] unit-test
[
"IN: tuples.tests SYMBOL: not-a-class C: <not-a-class> not-a-class" eval
] [ [ no-tuple-class? ] is? ] must-fail-with
! Inheritance
TUPLE: computer cpu ram ;
C: <computer> computer
[ "TUPLE: computer cpu ram ;" ] [
[ \ computer see ] with-string-writer string-lines second
] unit-test
TUPLE: laptop < computer battery ;
C: <laptop> laptop
[ t ] [ laptop tuple-class? ] unit-test
[ t ] [ laptop tuple class< ] unit-test
[ t ] [ laptop computer class< ] unit-test
[ t ] [ laptop computer classes-intersect? ] unit-test
[ ] [ "Pentium" 128 3 hours <laptop> "laptop" set ] unit-test
[ t ] [ "laptop" get laptop? ] unit-test
[ t ] [ "laptop" get computer? ] unit-test
[ t ] [ "laptop" get tuple? ] unit-test
[ "Pentium" ] [ "laptop" get cpu>> ] unit-test
[ 128 ] [ "laptop" get ram>> ] unit-test
[ t ] [ "laptop" get battery>> 3 hours = ] unit-test
[ laptop ] [
"laptop" get tuple-layout
dup layout-echelon swap
layout-superclasses nth
] unit-test
[ "TUPLE: laptop < computer battery ;" ] [
[ \ laptop see ] with-string-writer string-lines second
] unit-test
[ { tuple computer laptop } ] [ laptop superclasses ] unit-test
TUPLE: server < computer rackmount ;
C: <server> server
[ t ] [ server tuple-class? ] unit-test
[ t ] [ server tuple class< ] unit-test
[ t ] [ server computer class< ] unit-test
[ t ] [ server computer classes-intersect? ] unit-test
[ ] [ "PowerPC" 64 "1U" <server> "server" set ] unit-test
[ t ] [ "server" get server? ] unit-test
[ t ] [ "server" get computer? ] unit-test
[ t ] [ "server" get tuple? ] unit-test
[ "PowerPC" ] [ "server" get cpu>> ] unit-test
[ 64 ] [ "server" get ram>> ] unit-test
[ "1U" ] [ "server" get rackmount>> ] unit-test
[ f ] [ "server" get laptop? ] unit-test
[ f ] [ "laptop" get server? ] unit-test
[ f ] [ server laptop class< ] unit-test
[ f ] [ laptop server class< ] unit-test
[ f ] [ laptop server classes-intersect? ] unit-test
[ f ] [ 1 2 <computer> laptop? ] unit-test
[ f ] [ \ + server? ] unit-test
[ "TUPLE: server < computer rackmount ;" ] [
[ \ server see ] with-string-writer string-lines second
] unit-test
[
"IN: tuples.tests TUPLE: bad-superclass < word ;" eval
] must-fail
! Hardcore unit tests
USE: threads
@ -245,14 +323,14 @@ USE: threads
[ ] [
[
\ thread { "xxx" } "slot-names" get append
\ thread tuple { "xxx" } "slot-names" get append
define-tuple-class
] with-compilation-unit
[ 1337 sleep ] "Test" spawn drop
[
\ thread "slot-names" get
\ thread tuple "slot-names" get
define-tuple-class
] with-compilation-unit
] unit-test
@ -263,14 +341,14 @@ USE: vocabs
[ ] [
[
\ vocab { "xxx" } "slot-names" get append
\ vocab tuple { "xxx" } "slot-names" get append
define-tuple-class
] with-compilation-unit
all-words drop
[
\ vocab "slot-names" get
\ vocab tuple "slot-names" get
define-tuple-class
] with-compilation-unit
] unit-test

203
core/tuples/tuples.factor
View File

@ -1,31 +1,120 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays definitions hashtables kernel
kernel.private math namespaces sequences sequences.private
strings vectors words quotations memory combinators generic
classes classes.private slots slots.deprecated slots.private
compiler.units ;
classes classes.private slots.deprecated slots.private slots
compiler.units math.private ;
IN: tuples
M: tuple delegate 3 slot ;
M: tuple delegate 2 slot ;
M: tuple set-delegate 3 set-slot ;
M: tuple set-delegate 2 set-slot ;
M: tuple class class-of-tuple ;
M: tuple class 1 slot 2 slot { word } declare ;
ERROR: no-tuple-class class ;
<PRIVATE
GENERIC: tuple-layout ( object -- layout )
M: class tuple-layout "layout" word-prop ;
M: tuple tuple-layout 1 slot ;
: tuple-size tuple-layout layout-size ; inline
PRIVATE>
: check-tuple ( class -- )
dup tuple-class?
[ drop ] [ no-tuple-class ] if ;
: tuple>array ( tuple -- array )
dup tuple-layout
[ layout-size swap [ array-nth ] curry map ] keep
layout-class add* ;
: >tuple ( seq -- tuple )
dup first tuple-layout <tuple> [
>r 1 tail-slice dup length r>
[ tuple-size min ] keep
[ set-array-nth ] curry
2each
] keep ;
<PRIVATE
: tuple= ( tuple1 tuple2 -- ? )
over array-capacity over array-capacity tuck number= [
-rot
over tuple-layout over tuple-layout eq? [
dup tuple-size -rot
[ >r over r> array-nth >r array-nth r> = ] 2curry
all-integers?
] [
3drop f
2drop f
] if ;
: tuple-class-eq? ( obj class -- ? )
over tuple? [ swap 2 slot eq? ] [ 2drop f ] if ; inline
! Predicate generation. We optimize at the expense of simplicity
: (tuple-predicate-quot) ( class -- quot )
#! 4 slot == layout-superclasses
#! 5 slot == layout-echelon
[
[ 1 slot dup 5 slot ] %
dup tuple-layout layout-echelon ,
[ fixnum>= ] %
[
dup tuple-layout layout-echelon ,
[ swap 4 slot array-nth ] %
literalize ,
[ eq? ] %
] [ ] make ,
[ drop f ] ,
\ if ,
] [ ] make ;
: tuple-predicate-quot ( class -- quot )
[
[ dup tuple? ] %
(tuple-predicate-quot) ,
[ drop f ] ,
\ if ,
] [ ] make ;
: define-tuple-predicate ( class -- )
dup tuple-predicate-quot define-predicate ;
: superclass-size ( class -- n )
superclasses 1 head-slice*
[ "slot-names" word-prop length ] map sum ;
: generate-tuple-slots ( class slots -- slot-specs slot-names )
over superclass-size 2 + simple-slots
dup [ slot-spec-name ] map ;
: define-tuple-slots ( class slots -- )
dupd generate-tuple-slots
>r dupd "slots" set-word-prop
r> dupd "slot-names" set-word-prop
dup "slots" word-prop 2dup define-slots define-accessors ;
: make-tuple-layout ( class -- layout )
dup superclass-size over "slot-names" word-prop length +
over superclasses dup length 1- <tuple-layout> ;
: define-tuple-layout ( class -- )
dup make-tuple-layout "layout" set-word-prop ;
: removed-slots ( class newslots -- seq )
swap "slot-names" word-prop seq-diff ;
: forget-slots ( class newslots -- )
dupd removed-slots [
2dup
reader-word forget-method
writer-word forget-method
] with each ;
: permutation ( seq1 seq2 -- permutation )
swap [ index ] curry map ;
@ -33,7 +122,7 @@ M: tuple class class-of-tuple ;
: reshape-tuple ( oldtuple permutation -- newtuple )
>r tuple>array 2 cut r>
[ [ swap ?nth ] [ drop f ] if* ] with map
append (>tuple) ;
append >tuple ;
: reshape-tuples ( class newslots -- )
>r dup "slot-names" word-prop r> permutation
@ -43,63 +132,40 @@ M: tuple class class-of-tuple ;
become
] 2curry after-compilation ;
: old-slots ( class newslots -- seq )
swap "slots" word-prop 1 tail-slice
[ slot-spec-name swap member? not ] with subset ;
: tuple-class-unchanged ( class superclass slots -- ) 3drop ;
: forget-slots ( class newslots -- )
dupd old-slots [
2dup
slot-spec-reader 2array forget
slot-spec-writer 2array forget
] with each ;
: prepare-tuple-class ( class slots -- )
dupd define-tuple-slots
dup define-tuple-layout
define-tuple-predicate ;
: check-shape ( class newslots -- )
over tuple-class? [
over "slot-names" word-prop over = [
2dup forget-slots
2dup reshape-tuples
over changed-word
over redefined
] unless
] when 2drop ;
: change-superclass "not supported" throw ;
GENERIC: tuple-size ( class -- size )
: redefine-tuple-class ( class superclass slots -- )
>r 2dup swap superclass eq?
[ drop ] [ dupd change-superclass ] if r>
2dup forget-slots
2dup reshape-tuples
over changed-word
over redefined
prepare-tuple-class ;
M: tuple-class tuple-size "slot-names" word-prop length 2 + ;
: define-new-tuple-class ( class superclass slots -- )
>r dupd f swap tuple-class define-class r>
prepare-tuple-class ;
PRIVATE>
: define-tuple-predicate ( class -- )
dup [ tuple-class-eq? ] curry define-predicate ;
: define-tuple-class ( class superclass slots -- )
{
{ [ pick tuple-class? not ] [ define-new-tuple-class ] }
{ [ pick "slot-names" word-prop over = ] [ tuple-class-unchanged ] }
{ [ t ] [ redefine-tuple-class ] }
} cond ;
: delegate-slot-spec
T{ slot-spec f
object
"delegate"
3
delegate
set-delegate
} ;
: define-tuple-slots ( class slots -- )
dupd 4 simple-slots
2dup [ slot-spec-name ] map "slot-names" set-word-prop
2dup delegate-slot-spec add* "slots" set-word-prop
2dup define-slots
define-accessors ;
ERROR: no-tuple-class class ;
: check-tuple ( class -- )
dup tuple-class?
[ drop ] [ no-tuple-class ] if ;
: define-tuple-class ( class slots -- )
2dup check-shape
over f tuple tuple-class define-class
over define-tuple-predicate
define-tuple-slots ;
: define-error-class ( class superclass slots -- )
pick >r define-tuple-class r>
dup [ construct-boa throw ] curry define ;
M: tuple clone
(clone) dup delegate clone over set-delegate ;
@ -107,21 +173,14 @@ M: tuple clone
M: tuple equal?
over tuple? [ tuple= ] [ 2drop f ] if ;
: (delegates) ( obj -- )
[ dup , delegate (delegates) ] when* ;
: delegates ( obj -- seq )
[ dup ] [ [ delegate ] keep ] [ ] unfold nip ;
: is? ( obj quot -- ? ) >r delegates r> contains? ; inline
: >tuple ( seq -- tuple )
>vector dup first tuple-size over set-length
>array (>tuple) ;
M: tuple hashcode*
[
dup array-capacity -rot 0 -rot [
dup tuple-size -rot 0 -rot [
swapd array-nth hashcode* bitxor
] 2curry reduce
] recursive-hashcode ;
@ -131,7 +190,7 @@ M: tuple hashcode*
! Definition protocol
M: tuple-class reset-class
{
"metaclass" "superclass" "slot-names" "slots"
"metaclass" "superclass" "slot-names" "slots" "layout"
} reset-props ;
M: object get-slots ( obj slots -- ... )
@ -141,10 +200,10 @@ M: object set-slots ( ... obj slots -- )
<reversed> get-slots ;
M: object construct-empty ( class -- tuple )
dup tuple-size <tuple> ;
tuple-layout <tuple> ;
M: object construct ( ... slots class -- tuple )
construct-empty [ swap set-slots ] keep ;
M: object construct-boa ( ... class -- tuple )
dup tuple-size <tuple-boa> ;
tuple-layout <tuple-boa> ;

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

@ -25,7 +25,7 @@ V{
: vocab-dir? ( root name -- ? )
over [
".factor" vocab-dir+ append-path resource-exists?
".factor" vocab-dir+ append-path exists?
] [
2drop f
] if ;

6
core/words/words.factor
View File

@ -23,17 +23,17 @@ M: word definition word-def ;
ERROR: undefined ;
PREDICATE: word deferred ( obj -- ? )
PREDICATE: deferred < word ( obj -- ? )
word-def [ undefined ] = ;
M: deferred definer drop \ DEFER: f ;
M: deferred definition drop f ;
PREDICATE: word symbol ( obj -- ? )
PREDICATE: symbol < word ( obj -- ? )
dup <wrapper> 1array swap word-def sequence= ;
M: symbol definer drop \ SYMBOL: f ;
M: symbol definition drop f ;
PREDICATE: word primitive ( obj -- ? )
PREDICATE: primitive < word ( obj -- ? )
word-def [ do-primitive ] tail? ;
M: primitive definer drop \ PRIMITIVE: f ;
M: primitive definition drop f ;

6
extra/benchmark/reverse-complement/reverse-complement.factor
View File

@ -1,6 +1,6 @@
USING: io io.files io.streams.duplex kernel sequences
sequences.private strings vectors words memoize splitting
hints unicode.case continuations io.encodings.latin1 ;
hints unicode.case continuations io.encodings.ascii ;
IN: benchmark.reverse-complement
MEMO: trans-map ( -- str )
@ -32,8 +32,8 @@ HINTS: do-line vector string ;
readln [ do-line (reverse-complement) ] [ show-seq ] if* ;
: reverse-complement ( infile outfile -- )
latin1 <file-writer> [
swap latin1 <file-reader> [
ascii <file-writer> [
swap ascii <file-reader> [
swap <duplex-stream> [
500000 <vector> (reverse-complement)
] with-stream

36
extra/builder/release/release.factor
View File

@ -1,6 +1,6 @@
USING: kernel system namespaces sequences splitting combinators
io.files io.launcher
io io.files io.launcher
bake combinators.cleave builder.common builder.util ;
IN: builder.release
@ -91,6 +91,39 @@ IN: builder.release
: remove-factor-app ( -- )
macosx? not [ { "rm" "-rf" "Factor.app" } try-process ] when ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: upload-to-factorcode
: platform ( -- string ) { os cpu- } to-strings "-" join ;
: remote-location ( -- dest )
"factorcode.org:/var/www/factorcode.org/newsite/downloads"
platform
append-path ;
: upload ( -- )
{ "scp" archive-name remote-location } to-strings
[ "Error uploading binary to factorcode" print ]
run-or-bail ;
: maybe-upload ( -- )
upload-to-factorcode get
[ upload ]
when ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! : release ( -- )
! "factor"
! [
! remove-factor-app
! remove-common-files
! ]
! with-directory
! make-archive
! archive-name releases move-file-into ;
: release ( -- )
"factor"
[
@ -99,6 +132,7 @@ IN: builder.release
]
with-directory
make-archive
maybe-upload
archive-name releases move-file-into ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

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

@ -46,3 +46,8 @@ IN: combinators.lib.tests
[ dup array? ] [ dup vector? ] [ dup float? ]
} || nip
] unit-test
{ 1 1 } [
[ even? ] [ drop 1 ] [ drop 2 ] ifte
] must-infer-as

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

@ -1,7 +1,8 @@
! Copyright (C) 2007 Slava Pestov, Chris Double, Doug Coleman,
! Eduardo Cavazos, Daniel Ehrenberg.
! Copyright (C) 2007, 2008 Slava Pestov, Chris Double,
! Doug Coleman, Eduardo Cavazos,
! Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel combinators namespaces quotations hashtables
USING: kernel combinators fry namespaces quotations hashtables
sequences assocs arrays inference effects math math.ranges
arrays.lib shuffle macros bake combinators.cleave
continuations ;
@ -34,9 +35,8 @@ MACRO: nwith ( quot n -- )
MACRO: napply ( n -- )
2 [a,b]
[ [ ] [ 1- ] bi
[ , ntuck , nslip ]
bake ]
[ [ 1- ] [ ] bi
'[ , ntuck , nslip ] ]
map concat >quotation [ call ] append ;
: 3apply ( obj obj obj quot -- ) 3 napply ; inline
@ -88,26 +88,21 @@ MACRO: || ( quots -- ? ) [ [ t ] ] f short-circuit ;
! ifte
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
MACRO: preserving ( predicate -- quot )
dup infer effect-in
dup 1+
'[ , , nkeep , nrot ] ;
MACRO: ifte ( quot quot quot -- )
pick infer effect-in
dup 1+ swap
[ >r >r , nkeep , nrot r> r> if ]
bake ;
'[ , preserving , , if ] ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! switch
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: preserving ( predicate -- quot )
dup infer effect-in
dup 1+ spin
[ , , nkeep , nrot ]
bake ;
MACRO: switch ( quot -- )
[ [ preserving ] [ ] bi* ] assoc-map
[ , cond ]
bake ;
[ [ [ preserving ] curry ] dip ] assoc-map
[ cond ] curry ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

2
extra/delegate/delegate.factor
View File

@ -10,7 +10,7 @@ IN: delegate
CREATE-WORD dup define-symbol
parse-definition swap define-protocol ; parsing
PREDICATE: word protocol "protocol-words" word-prop ;
PREDICATE: protocol < word "protocol-words" word-prop ;
GENERIC: group-words ( group -- words )

4
extra/editors/editors.factor
View File

@ -26,7 +26,7 @@ SYMBOL: edit-hook
: edit-location ( file line -- )
edit-hook get [
>r >r ?resource-path r> r> call
call
] [
no-edit-hook edit-location
] if* ;
@ -39,7 +39,7 @@ SYMBOL: edit-hook
: :edit ( -- )
error get delegates [ parse-error? ] find-last nip [
dup parse-error-file source-file-path ?resource-path
dup parse-error-file source-file-path
swap parse-error-line edit-location
] when* ;

2
extra/editors/jedit/jedit.factor Normal file → Executable file
View File

@ -8,7 +8,7 @@ io.encodings.utf8 ;
IN: editors.jedit
: jedit-server-info ( -- port auth )
home "/.jedit/server" append-path ascii [
home ".jedit/server" append-path ascii [
readln drop
readln string>number
readln string>number

20
extra/help/handbook/handbook.factor
View File

@ -170,7 +170,24 @@ ARTICLE: "collections" "Collections"
{ $subsection "graphs" }
{ $subsection "buffers" } ;
USING: io.sockets io.launcher io.mmap io.monitors ;
USING: io.sockets io.launcher io.mmap io.monitors
io.encodings.utf8 io.encodings.binary io.encodings.ascii io.files ;
ARTICLE: "encodings-introduction" "An introduction to encodings"
"In order to express text in terms of binary, some sort of encoding has to be used. In a modern context, this is understood as a two-way mapping between Unicode code points (characters) and some amount of binary. Since English isn't the only language in the world, ASCII is not sufficient as a mapping from binary to Unicode; it can't even express em-dashes or curly quotes. Unicode was designed as a universal character set that could potentially represent everything." $nl
"Not all encodings can represent all Unicode code points, but Unicode can represent basically everything that exists in modern encodings. Some encodings are language-specific, and some can represent everything in Unicode. Though the world is moving toward Unicode and UTF-8, the reality today is that there are several encodings which must be taken into account." $nl
"Factor uses a system of encoding descriptors to denote encodings. Encoding descriptors are objects which describe encodings. Examples are " { $link utf8 } ", " { $link ascii } " and " { $link binary } ". Encoding descriptors can be passed around independently. Each encoding descriptor has some method for constructing an encoded or decoded stream, and the resulting stream has an encoding descriptor stored which has methods for reading or writing characters." $nl
"Constructors for streams which deal with bytes usually take an encoding as an explicit parameter. For example, to open a text file for reading whose contents are in UTF-8, use the following"
{ $code "\"file.txt\" utf8 <file-reader>" }
"If there is an error in the encoded stream, a replacement character (0xFFFD) will be inserted. To throw an exception upon error, use a strict encoding as follows"
{ $code "\"file.txt\" utf8 strict <file-reader>" }
"In a similar way, encodings can be specified when opening a file for writing."
{ $code "\"file.txt\" ascii <file-writer>" }
"An encoding is also needed for some words that don't return streams, such as " { $link file-contents } ", for example"
{ $code "\"file.txt\" utf16 file-contents" }
"Encoding descriptors are also used by " { $link "io.streams.byte-array" } " and taken by combinators like " { $link with-file-writer } " and " { $link with-byte-reader } " which deal with streams. It is " { $emphasis "not" } " used with " { $link "io.streams.string" } " because these deal with abstract text."
$nl
"When the " { $link binary } " encoding is used, a " { $link byte-array } " is expected for writing and returned for reading, since the stream deals with bytes. All other encodings deal with strings, since they are used to represent text." ;
ARTICLE: "io" "Input and output"
{ $heading "Streams" }
@ -188,6 +205,7 @@ ARTICLE: "io" "Input and output"
{ $subsection "io.mmap" }
{ $subsection "io.monitors" }
{ $heading "Encodings" }
{ $subsection "encodings-introduction" }
{ $subsection "io.encodings" }
{ $subsection "io.encodings.string" }
{ $heading "Other features" }

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

@ -14,7 +14,7 @@ IN: help.markup
! Element types are words whose name begins with $.
PREDICATE: array simple-element
PREDICATE: simple-element < array
dup empty? [ drop t ] [ first word? not ] if ;
SYMBOL: last-element

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

@ -16,7 +16,7 @@ M: link >link ;
M: vocab-spec >link ;
M: object >link link construct-boa ;
PREDICATE: link word-link link-name word? ;
PREDICATE: word-link < link link-name word? ;
M: link summary
[

2
extra/http/client/client.factor
View File

@ -3,7 +3,7 @@
USING: assocs http kernel math math.parser namespaces sequences
io io.sockets io.streams.string io.files io.timeouts strings
splitting calendar continuations accessors vectors
io.encodings.latin1 io.encodings.binary fry ;
io.encodings.8-bit io.encodings.binary fry ;
IN: http.client
DEFER: http-request

2
extra/http/server/server.factor
View File

@ -4,7 +4,7 @@ USING: assocs kernel namespaces io io.timeouts strings splitting
threads http sequences prettyprint io.server logging calendar
html.elements accessors math.parser combinators.lib
tools.vocabs debugger html continuations random combinators
destructors io.encodings.latin1 fry combinators.cleave ;
destructors io.encodings.8-bit fry combinators.cleave ;
IN: http.server
GENERIC: call-responder ( path responder -- response )

4
extra/http/server/static/static.factor
View File

@ -39,7 +39,9 @@ TUPLE: file-responder root hook special ;
[ 2drop <304> ] [ file-responder get hook>> call ] if ;
: serving-path ( filename -- filename )
"" or file-responder get root>> prepend-path ;
file-responder get root>> right-trim-separators
"/"
rot "" or left-trim-separators 3append ;
: serve-file ( filename -- response )
dup mime-type

2
extra/http/server/templating/fhtml/fhtml-tests.factor
View File

@ -9,7 +9,7 @@ IN: http.server.templating.fhtml.tests
[
".fhtml" append [ run-template ] with-string-writer
] keep
".html" append ?resource-path utf8 file-contents = ;
".html" append utf8 file-contents = ;
[ t ] [ "example" test-template ] unit-test
[ t ] [ "bug" test-template ] unit-test

2
extra/http/server/templating/fhtml/fhtml.factor
View File

@ -83,7 +83,7 @@ DEFER: <% delimiter
templating-vocab use+
! so that reload works properly
dup source-file file set
?resource-path utf8 file-contents
utf8 file-contents
[ eval-template ] [ html-error. drop ] recover
] with-file-vocabs
] assert-depth ;

10
extra/inverse/inverse.factor
View File

@ -1,7 +1,7 @@
USING: kernel words inspector slots quotations sequences assocs
math arrays inference effects shuffle continuations debugger
tuples namespaces vectors bit-arrays byte-arrays strings sbufs
math.functions macros sequences.private combinators ;
math.functions macros sequences.private combinators mirrors ;
IN: inverse
TUPLE: fail ;
@ -54,9 +54,9 @@ M: no-inverse summary
: undo-literal ( object -- quot )
[ =/fail ] curry ;
PREDICATE: word normal-inverse "inverse" word-prop ;
PREDICATE: word math-inverse "math-inverse" word-prop ;
PREDICATE: word pop-inverse "pop-length" word-prop ;
PREDICATE: normal-inverse < word "inverse" word-prop ;
PREDICATE: math-inverse < word "math-inverse" word-prop ;
PREDICATE: pop-inverse < word "pop-length" word-prop ;
UNION: explicit-inverse normal-inverse math-inverse pop-inverse ;
: inline-word ( word -- )
@ -191,7 +191,7 @@ MACRO: undo ( quot -- ) [undo] ;
"predicate" word-prop [ dupd call assure ] curry ;
: slot-readers ( class -- quot )
"slots" word-prop 1 tail ! tail gets rid of delegate
all-slots 1 tail ! tail gets rid of delegate
[ slot-spec-reader 1quotation [ keep ] curry ] map concat
[ ] like [ drop ] compose ;

114
extra/io/encodings/8-bit/8-bit-docs.factor Normal file
View File

@ -0,0 +1,114 @@
! Copyright (C) 2008 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: help.syntax help.markup io.encodings.8-bit.private ;
IN: io.encodings.8-bit
ARTICLE: "io.encodings.8-bit" "8-bit encodings"
"Many encodings are a simple mapping of bytes onto characters. The " { $vocab-link "io.encodings.8-bit" } " vocabulary implements these generically using existing resource files. These encodings should be used with extreme caution, as fully general Unicode encodings like UTF-8 are nearly always more appropriate. The following 8-bit encodings are already defined:"
{ $subsection latin1 }
{ $subsection latin2 }
{ $subsection latin3 }
{ $subsection latin4 }
{ $subsection latin/cyrillic }
{ $subsection latin/arabic }
{ $subsection latin/greek }
{ $subsection latin/hebrew }
{ $subsection latin5 }
{ $subsection latin6 }
{ $subsection latin/thai }
{ $subsection latin7 }
{ $subsection latin8 }
{ $subsection latin9 }
{ $subsection latin10 }
{ $subsection koi8-r }
{ $subsection windows-1252 }
{ $subsection ebcdic }
{ $subsection mac-roman }
"Words used in defining these"
{ $subsection 8-bit }
{ $subsection define-8-bit-encoding } ;
ABOUT: "io.encodings.8-bit"
HELP: 8-bit
{ $class-description "Describes an 8-bit encoding, including its name (a symbol) and a table used for encoding and decoding." } ;
HELP: define-8-bit-encoding
{ $values { "name" "a string" } { "path" "a path" } }
{ $description "Creates a new encoding with the given name, using the resource file at the path to tell how to encode and decode octets. The resource file should be in a similar format to those at " { $url "ftp://ftp.unicode.org/Public/MAPPINGS/ISO8859/" } } ;
HELP: latin1
{ $description "This is the ISO-8859-1 encoding, also called Latin-1: Western European. It is an 8-bit superset of ASCII which is the default for a mimetype starting with 'text' and provides the characters necessary for most western European languages." }
{ $see-also "encodings-introduction" } ;
HELP: latin2
{ $description "This is the ISO-8859-2 encoding, also called Latin-2: Eastern European. It is an 8-bit superset of ASCII and provides the characters necessary for most eastern European languages." }
{ $see-also "encodings-introduction" } ;
HELP: latin3
{ $description "This is the ISO-8859-3 encoding, also called Latin-3: South European. It is an 8-bit superset of ASCII and provides the characters necessary for Turkish, Maltese and Esperanto." }
{ $see-also "encodings-introduction" } ;
HELP: latin4
{ $description "This is the ISO-8859-4 encoding, also called Latin-4: North European. It is an 8-bit superset of ASCII and provides the characters necessary for Latvian, Lithuanian, Estonian, Greenlandic and Sami." }
{ $see-also "encodings-introduction" } ;
HELP: latin/cyrillic
{ $description "This is the ISO-8859-5 encoding, also called Latin/Cyrillic. It is an 8-bit superset of ASCII and provides the characters necessary for most languages which use Cyrilic, including Russian, Macedonian, Belarusian, Bulgarian, Serbian, and Ukrainian. KOI8-R is used much more commonly." }
{ $see-also "encodings-introduction" } ;
HELP: latin/arabic
{ $description "This is the ISO-8859-6 encoding, also called Latin/Arabic. It is an 8-bit superset of ASCII and provides the characters necessary for Arabic, though not other languages which use Arabic script." }
{ $see-also "encodings-introduction" } ;
HELP: latin/greek
{ $description "This is the ISO-8859-7 encoding, also called Latin/Greek. It is an 8-bit superset of ASCII and provides the characters necessary for Greek written in modern monotonic orthography, or ancient Greek without accent marks." }
{ $see-also "encodings-introduction" } ;
HELP: latin/hebrew
{ $description "This is the ISO-8859-8 encoding, also called Latin/Hebrew. It is an 8-bit superset of ASCII and provides the characters necessary for modern Hebrew without explicit vowels. Generally, this is interpreted in logical order, making it ISO-8859-8-I, technically." }
{ $see-also "encodings-introduction" } ;
HELP: latin5
{ $description "This is the ISO-8859-9 encoding, also called Latin-5: Turkish. It is an 8-bit superset of ASCII and provides the characters necessary for Turkish, similar to Latin-1 but replacing the spots used for Icelandic with characters used in Turkish." }
{ $see-also "encodings-introduction" } ;
HELP: latin6
{ $description "This is the ISO-8859-10 encoding, also called Latin-6: Nordic. It is an 8-bit superset of ASCII containing the same characters as Latin-4, but rearranged to be of better use to nordic languages." }
{ $see-also "encodings-introduction" } ;
HELP: latin/thai
{ $description "This is the ISO-8859-11 encoding, also called Latin/Thai. It is an 8-bit superset of ASCII containing the characters necessary to represent Thai. It is basically identical to TIS-620." }
{ $see-also "encodings-introduction" } ;
HELP: latin7
{ $description "This is the ISO-8859-13 encoding, also called Latin-7: Baltic Rim. It is an 8-bit superset of ASCII containing all characters necesary to represent Baltic Rim languages, as previous character sets were incomplete." }
{ $see-also "encodings-introduction" } ;
HELP: latin8
{ $description "This is the ISO-8859-14 encoding, also called Latin-8: Celtic. It is an 8-bit superset of ASCII designed for Celtic languages like Gaelic and Breton." }
{ $see-also "encodings-introduction" } ;
HELP: latin9
{ $description "This is the ISO-8859-15 encoding, also called Latin-9 and unoffically as Latin-0. It is an 8-bit superset of ASCII designed as a modification of Latin-1, removing little-used characters in favor of the Euro symbol and other characters." }
{ $see-also "encodings-introduction" } ;
HELP: latin10
{ $description "This is the ISO-8859-16 encoding, also called Latin-10: South-Eastern European. It is an 8-bit superset of ASCII." }
{ $see-also "encodings-introduction" } ;
HELP: windows-1252
{ $description "Windows 1252 is an 8-bit superset of ASCII which is closely related to Latin-1. Control characters in the 0x80 to 0x9F range are replaced with printable characters such as the Euro symbol." }
{ $see-also "encodings-introduction" } ;
HELP: ebcdic
{ $description "EBCDIC is an 8-bit legacy encoding designed for IBM mainframes like System/360 in the 1960s. It has since fallen into disuse. It contains large unallocated regions, and the version included here (code page 37) contains auxiliary characters in this region for English- and Portugese-speaking countries." }
{ $see-also "encodings-introduction" } ;
HELP: mac-roman
{ $description "Mac Roman is an 8-bit superset of ASCII which was the standard encoding on Mac OS prior to version 10. It is incompatible with Latin-1 in all but a few places and ASCII, and it is suitable for encoding many Western European languages." }
{ $see-also "encodings-introduction" } ;
HELP: koi8-r
{ $description "KOI8-R is an 8-bit superset of ASCII which encodes the Cyrillic alphabet, as used in Russian and Bulgarian. Characters are in such an order that, if the eight bit is stripped, text is still interpretable as ASCII. Block-building characters also exist." }
{ $see-also "encodings-introduction" } ;

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

@ -1,5 +1,5 @@
USING: io.encodings.string io.encodings.latin1 tools.test strings arrays ;
IN: io.encodings.latin1.tests
USING: io.encodings.string io.encodings.8-bit tools.test strings arrays ;
IN: io.encodings.8-bit.tests
[ B{ CHAR: f CHAR: o CHAR: o } ] [ "foo" latin1 encode ] unit-test
[ { 256 } >string latin1 encode ] must-fail
@ -7,3 +7,4 @@ IN: io.encodings.latin1.tests
[ "bar" ] [ "bar" latin1 decode ] unit-test
[ { CHAR: b 233 CHAR: r } ] [ { CHAR: b 233 CHAR: r } latin1 decode >array ] unit-test
[ { HEX: fffd HEX: 20AC } ] [ { HEX: 81 HEX: 80 } windows-1252 decode >array ] unit-test

84
extra/io/encodings/8-bit/8-bit.factor Executable file
View File

@ -0,0 +1,84 @@
! Copyright (C) 2008 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: math.parser arrays io.encodings sequences kernel
assocs hashtables io.encodings.ascii combinators.cleave
generic parser tuples words io io.files splitting namespaces
math compiler.units accessors ;
IN: io.encodings.8-bit
<PRIVATE
: mappings {
{ "latin1" "8859-1" }
{ "latin2" "8859-2" }
{ "latin3" "8859-3" }
{ "latin4" "8859-4" }
{ "latin/cyrillic" "8859-5" }
{ "latin/arabic" "8859-6" }
{ "latin/greek" "8859-7" }
{ "latin/hebrew" "8859-8" }
{ "latin5" "8859-9" }
{ "latin6" "8859-10" }
{ "latin/thai" "8859-11" }
{ "latin7" "8859-13" }
{ "latin8" "8859-14" }
{ "latin9" "8859-15" }
{ "latin10" "8859-16" }
{ "koi8-r" "KOI8-R" }
{ "windows-1252" "CP1252" }
{ "ebcdic" "CP037" }
{ "mac-roman" "ROMAN" }
} ;
: full-path ( file-name -- path )
"extra/io/encodings/8-bit/" ".TXT"
swapd 3append resource-path ;
: tail-if ( seq n -- newseq )
2dup swap length <= [ tail ] [ drop ] if ;
: process-contents ( lines -- assoc )
[ "#" split1 drop ] map
[ empty? not ] subset
[ "\t" split 2 head [ 2 tail-if hex> ] map ] map ;
: byte>ch ( assoc -- array )
256 replacement-char <array>
[ [ swapd set-nth ] curry assoc-each ] keep ;
: ch>byte ( assoc -- newassoc )
[ swap ] assoc-map >hashtable ;
: parse-file ( file-name -- byte>ch ch>byte )
ascii file-lines process-contents
[ byte>ch ] [ ch>byte ] bi ;
TUPLE: 8-bit name decode encode ;
: encode-8-bit ( char stream assoc -- )
swapd at* [ encode-error ] unless swap stream-write1 ;
M: 8-bit encode-char
encode>> encode-8-bit ;
: decode-8-bit ( stream array -- char/f )
swap stream-read1 dup
[ swap nth [ replacement-char ] unless* ]
[ nip ] if ;
M: 8-bit decode-char
decode>> decode-8-bit ;
: make-8-bit ( word byte>ch ch>byte -- )
[ 8-bit construct-boa ] 2curry dupd curry define ;
: define-8-bit-encoding ( name path -- )
>r in get create r> parse-file make-8-bit ;
PRIVATE>
[
"io.encodings.8-bit" in [
mappings [ full-path define-8-bit-encoding ] assoc-each
] with-variable
] with-compilation-unit

303
extra/io/encodings/8-bit/8859-1.TXT Normal file
View File

@ -0,0 +1,303 @@
#
# Name: ISO/IEC 8859-1:1998 to Unicode
# Unicode version: 3.0
# Table version: 1.0
# Table format: Format A
# Date: 1999 July 27
# Authors: Ken Whistler <kenw@sybase.com>
#
# Copyright (c) 1991-1999 Unicode, Inc. All Rights reserved.
#
# This file is provided as-is by Unicode, Inc. (The Unicode Consortium).
# No claims are made as to fitness for any particular purpose. No
# warranties of any kind are expressed or implied. The recipient
# agrees to determine applicability of information provided. If this
# file has been provided on optical media by Unicode, Inc., the sole
# remedy for any claim will be exchange of defective media within 90
# days of receipt.
#
# Unicode, Inc. hereby grants the right to freely use the information
# supplied in this file in the creation of products supporting the
# Unicode Standard, and to make copies of this file in any form for
# internal or external distribution as long as this notice remains
# attached.
#
# General notes:
#
# This table contains the data the Unicode Consortium has on how
# ISO/IEC 8859-1:1998 characters map into Unicode.
#
# Format: Three tab-separated columns
# Column #1 is the ISO/IEC 8859-1 code (in hex as 0xXX)
# Column #2 is the Unicode (in hex as 0xXXXX)
# Column #3 the Unicode name (follows a comment sign, '#')
#
# The entries are in ISO/IEC 8859-1 order.
#
# Version history
# 1.0 version updates 0.1 version by adding mappings for all
# control characters.
#
# Updated versions of this file may be found in:
# <ftp://ftp.unicode.org/Public/MAPPINGS/>
#
# Any comments or problems, contact <errata@unicode.org>
# Please note that <errata@unicode.org> is an archival address;
# notices will be checked, but do not expect an immediate response.
#
0x00 0x0000 # NULL
0x01 0x0001 # START OF HEADING
0x02 0x0002 # START OF TEXT
0x03 0x0003 # END OF TEXT
0x04 0x0004 # END OF TRANSMISSION
0x05 0x0005 # ENQUIRY
0x06 0x0006 # ACKNOWLEDGE
0x07 0x0007 # BELL
0x08 0x0008 # BACKSPACE
0x09 0x0009 # HORIZONTAL TABULATION
0x0A 0x000A # LINE FEED
0x0B 0x000B # VERTICAL TABULATION
0x0C 0x000C # FORM FEED
0x0D 0x000D # CARRIAGE RETURN
0x0E 0x000E # SHIFT OUT
0x0F 0x000F # SHIFT IN
0x10 0x0010 # DATA LINK ESCAPE
0x11 0x0011 # DEVICE CONTROL ONE
0x12 0x0012 # DEVICE CONTROL TWO
0x13 0x0013 # DEVICE CONTROL THREE
0x14 0x0014 # DEVICE CONTROL FOUR
0x15 0x0015 # NEGATIVE ACKNOWLEDGE
0x16 0x0016 # SYNCHRONOUS IDLE
0x17 0x0017 # END OF TRANSMISSION BLOCK
0x18 0x0018 # CANCEL
0x19 0x0019 # END OF MEDIUM
0x1A 0x001A # SUBSTITUTE
0x1B 0x001B # ESCAPE
0x1C 0x001C # FILE SEPARATOR
0x1D 0x001D # GROUP SEPARATOR
0x1E 0x001E # RECORD SEPARATOR
0x1F 0x001F # UNIT SEPARATOR
0x20 0x0020 # SPACE
0x21 0x0021 # EXCLAMATION MARK
0x22 0x0022 # QUOTATION MARK
0x23 0x0023 # NUMBER SIGN
0x24 0x0024 # DOLLAR SIGN
0x25 0x0025 # PERCENT SIGN
0x26 0x0026 # AMPERSAND
0x27 0x0027 # APOSTROPHE
0x28 0x0028 # LEFT PARENTHESIS
0x29 0x0029 # RIGHT PARENTHESIS
0x2A 0x002A # ASTERISK
0x2B 0x002B # PLUS SIGN
0x2C 0x002C # COMMA
0x2D 0x002D # HYPHEN-MINUS
0x2E 0x002E # FULL STOP
0x2F 0x002F # SOLIDUS
0x30 0x0030 # DIGIT ZERO
0x31 0x0031 # DIGIT ONE
0x32 0x0032 # DIGIT TWO
0x33 0x0033 # DIGIT THREE
0x34 0x0034 # DIGIT FOUR
0x35 0x0035 # DIGIT FIVE
0x36 0x0036 # DIGIT SIX
0x37 0x0037 # DIGIT SEVEN
0x38 0x0038 # DIGIT EIGHT
0x39 0x0039 # DIGIT NINE
0x3A 0x003A # COLON
0x3B 0x003B # SEMICOLON
0x3C 0x003C # LESS-THAN SIGN
0x3D 0x003D # EQUALS SIGN
0x3E 0x003E # GREATER-THAN SIGN
0x3F 0x003F # QUESTION MARK
0x40 0x0040 # COMMERCIAL AT
0x41 0x0041 # LATIN CAPITAL LETTER A
0x42 0x0042 # LATIN CAPITAL LETTER B
0x43 0x0043 # LATIN CAPITAL LETTER C
0x44 0x0044 # LATIN CAPITAL LETTER D
0x45 0x0045 # LATIN CAPITAL LETTER E
0x46 0x0046 # LATIN CAPITAL LETTER F
0x47 0x0047 # LATIN CAPITAL LETTER G
0x48 0x0048 # LATIN CAPITAL LETTER H
0x49 0x0049 # LATIN CAPITAL LETTER I
0x4A 0x004A # LATIN CAPITAL LETTER J
0x4B 0x004B # LATIN CAPITAL LETTER K
0x4C 0x004C # LATIN CAPITAL LETTER L
0x4D 0x004D # LATIN CAPITAL LETTER M
0x4E 0x004E # LATIN CAPITAL LETTER N
0x4F 0x004F # LATIN CAPITAL LETTER O
0x50 0x0050 # LATIN CAPITAL LETTER P
0x51 0x0051 # LATIN CAPITAL LETTER Q
0x52 0x0052 # LATIN CAPITAL LETTER R
0x53 0x0053 # LATIN CAPITAL LETTER S
0x54 0x0054 # LATIN CAPITAL LETTER T
0x55 0x0055 # LATIN CAPITAL LETTER U
0x56 0x0056 # LATIN CAPITAL LETTER V
0x57 0x0057 # LATIN CAPITAL LETTER W
0x58 0x0058 # LATIN CAPITAL LETTER X
0x59 0x0059 # LATIN CAPITAL LETTER Y
0x5A 0x005A # LATIN CAPITAL LETTER Z
0x5B 0x005B # LEFT SQUARE BRACKET
0x5C 0x005C # REVERSE SOLIDUS
0x5D 0x005D # RIGHT SQUARE BRACKET
0x5E 0x005E # CIRCUMFLEX ACCENT
0x5F 0x005F # LOW LINE
0x60 0x0060 # GRAVE ACCENT
0x61 0x0061 # LATIN SMALL LETTER A
0x62 0x0062 # LATIN SMALL LETTER B
0x63 0x0063 # LATIN SMALL LETTER C
0x64 0x0064 # LATIN SMALL LETTER D
0x65 0x0065 # LATIN SMALL LETTER E
0x66 0x0066 # LATIN SMALL LETTER F
0x67 0x0067 # LATIN SMALL LETTER G
0x68 0x0068 # LATIN SMALL LETTER H
0x69 0x0069 # LATIN SMALL LETTER I
0x6A 0x006A # LATIN SMALL LETTER J
0x6B 0x006B # LATIN SMALL LETTER K
0x6C 0x006C # LATIN SMALL LETTER L
0x6D 0x006D # LATIN SMALL LETTER M
0x6E 0x006E # LATIN SMALL LETTER N
0x6F 0x006F # LATIN SMALL LETTER O
0x70 0x0070 # LATIN SMALL LETTER P
0x71 0x0071 # LATIN SMALL LETTER Q
0x72 0x0072 # LATIN SMALL LETTER R
0x73 0x0073 # LATIN SMALL LETTER S
0x74 0x0074 # LATIN SMALL LETTER T
0x75 0x0075 # LATIN SMALL LETTER U
0x76 0x0076 # LATIN SMALL LETTER V
0x77 0x0077 # LATIN SMALL LETTER W
0x78 0x0078 # LATIN SMALL LETTER X
0x79 0x0079 # LATIN SMALL LETTER Y
0x7A 0x007A # LATIN SMALL LETTER Z
0x7B 0x007B # LEFT CURLY BRACKET
0x7C 0x007C # VERTICAL LINE
0x7D 0x007D # RIGHT CURLY BRACKET
0x7E 0x007E # TILDE
0x7F 0x007F # DELETE
0x80 0x0080 # <control>
0x81 0x0081 # <control>
0x82 0x0082 # <control>
0x83 0x0083 # <control>
0x84 0x0084 # <control>
0x85 0x0085 # <control>
0x86 0x0086 # <control>
0x87 0x0087 # <control>
0x88 0x0088 # <control>
0x89 0x0089 # <control>
0x8A 0x008A # <control>
0x8B 0x008B # <control>
0x8C 0x008C # <control>
0x8D 0x008D # <control>
0x8E 0x008E # <control>
0x8F 0x008F # <control>
0x90 0x0090 # <control>
0x91 0x0091 # <control>
0x92 0x0092 # <control>
0x93 0x0093 # <control>
0x94 0x0094 # <control>
0x95 0x0095 # <control>
0x96 0x0096 # <control>
0x97 0x0097 # <control>
0x98 0x0098 # <control>
0x99 0x0099 # <control>
0x9A 0x009A # <control>
0x9B 0x009B # <control>
0x9C 0x009C # <control>
0x9D 0x009D # <control>
0x9E 0x009E # <control>
0x9F 0x009F # <control>
0xA0 0x00A0 # NO-BREAK SPACE
0xA1 0x00A1 # INVERTED EXCLAMATION MARK
0xA2 0x00A2 # CENT SIGN
0xA3 0x00A3 # POUND SIGN
0xA4 0x00A4 # CURRENCY SIGN
0xA5 0x00A5 # YEN SIGN
0xA6 0x00A6 # BROKEN BAR
0xA7 0x00A7 # SECTION SIGN
0xA8 0x00A8 # DIAERESIS
0xA9 0x00A9 # COPYRIGHT SIGN
0xAA 0x00AA # FEMININE ORDINAL INDICATOR
0xAB 0x00AB # LEFT-POINTING DOUBLE ANGLE QUOTATION MARK
0xAC 0x00AC # NOT SIGN
0xAD 0x00AD # SOFT HYPHEN
0xAE 0x00AE # REGISTERED SIGN
0xAF 0x00AF # MACRON
0xB0 0x00B0 # DEGREE SIGN
0xB1 0x00B1 # PLUS-MINUS SIGN
0xB2 0x00B2 # SUPERSCRIPT TWO
0xB3 0x00B3 # SUPERSCRIPT THREE
0xB4 0x00B4 # ACUTE ACCENT
0xB5 0x00B5 # MICRO SIGN
0xB6 0x00B6 # PILCROW SIGN
0xB7 0x00B7 # MIDDLE DOT
0xB8 0x00B8 # CEDILLA
0xB9 0x00B9 # SUPERSCRIPT ONE
0xBA 0x00BA # MASCULINE ORDINAL INDICATOR
0xBB 0x00BB # RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK
0xBC 0x00BC # VULGAR FRACTION ONE QUARTER
0xBD 0x00BD # VULGAR FRACTION ONE HALF
0xBE 0x00BE # VULGAR FRACTION THREE QUARTERS
0xBF 0x00BF # INVERTED QUESTION MARK
0xC0 0x00C0 # LATIN CAPITAL LETTER A WITH GRAVE
0xC1 0x00C1 # LATIN CAPITAL LETTER A WITH ACUTE
0xC2 0x00C2 # LATIN CAPITAL LETTER A WITH CIRCUMFLEX
0xC3 0x00C3 # LATIN CAPITAL LETTER A WITH TILDE
0xC4 0x00C4 # LATIN CAPITAL LETTER A WITH DIAERESIS
0xC5 0x00C5 # LATIN CAPITAL LETTER A WITH RING ABOVE
0xC6 0x00C6 # LATIN CAPITAL LETTER AE
0xC7 0x00C7 # LATIN CAPITAL LETTER C WITH CEDILLA
0xC8 0x00C8 # LATIN CAPITAL LETTER E WITH GRAVE
0xC9 0x00C9 # LATIN CAPITAL LETTER E WITH ACUTE
0xCA 0x00CA # LATIN CAPITAL LETTER E WITH CIRCUMFLEX
0xCB 0x00CB # LATIN CAPITAL LETTER E WITH DIAERESIS
0xCC 0x00CC # LATIN CAPITAL LETTER I WITH GRAVE
0xCD 0x00CD # LATIN CAPITAL LETTER I WITH ACUTE
0xCE 0x00CE # LATIN CAPITAL LETTER I WITH CIRCUMFLEX
0xCF 0x00CF # LATIN CAPITAL LETTER I WITH DIAERESIS
0xD0 0x00D0 # LATIN CAPITAL LETTER ETH (Icelandic)
0xD1 0x00D1 # LATIN CAPITAL LETTER N WITH TILDE
0xD2 0x00D2 # LATIN CAPITAL LETTER O WITH GRAVE
0xD3 0x00D3 # LATIN CAPITAL LETTER O WITH ACUTE
0xD4 0x00D4 # LATIN CAPITAL LETTER O WITH CIRCUMFLEX
0xD5 0x00D5 # LATIN CAPITAL LETTER O WITH TILDE
0xD6 0x00D6 # LATIN CAPITAL LETTER O WITH DIAERESIS
0xD7 0x00D7 # MULTIPLICATION SIGN
0xD8 0x00D8 # LATIN CAPITAL LETTER O WITH STROKE
0xD9 0x00D9 # LATIN CAPITAL LETTER U WITH GRAVE
0xDA 0x00DA # LATIN CAPITAL LETTER U WITH ACUTE
0xDB 0x00DB # LATIN CAPITAL LETTER U WITH CIRCUMFLEX
0xDC 0x00DC # LATIN CAPITAL LETTER U WITH DIAERESIS
0xDD 0x00DD # LATIN CAPITAL LETTER Y WITH ACUTE
0xDE 0x00DE # LATIN CAPITAL LETTER THORN (Icelandic)
0xDF 0x00DF # LATIN SMALL LETTER SHARP S (German)
0xE0 0x00E0 # LATIN SMALL LETTER A WITH GRAVE
0xE1 0x00E1 # LATIN SMALL LETTER A WITH ACUTE
0xE2 0x00E2 # LATIN SMALL LETTER A WITH CIRCUMFLEX
0xE3 0x00E3 # LATIN SMALL LETTER A WITH TILDE
0xE4 0x00E4 # LATIN SMALL LETTER A WITH DIAERESIS
0xE5 0x00E5 # LATIN SMALL LETTER A WITH RING ABOVE
0xE6 0x00E6 # LATIN SMALL LETTER AE
0xE7 0x00E7 # LATIN SMALL LETTER C WITH CEDILLA
0xE8 0x00E8 # LATIN SMALL LETTER E WITH GRAVE
0xE9 0x00E9 # LATIN SMALL LETTER E WITH ACUTE
0xEA 0x00EA # LATIN SMALL LETTER E WITH CIRCUMFLEX
0xEB 0x00EB # LATIN SMALL LETTER E WITH DIAERESIS
0xEC 0x00EC # LATIN SMALL LETTER I WITH GRAVE
0xED 0x00ED # LATIN SMALL LETTER I WITH ACUTE
0xEE 0x00EE # LATIN SMALL LETTER I WITH CIRCUMFLEX
0xEF 0x00EF # LATIN SMALL LETTER I WITH DIAERESIS
0xF0 0x00F0 # LATIN SMALL LETTER ETH (Icelandic)
0xF1 0x00F1 # LATIN SMALL LETTER N WITH TILDE
0xF2 0x00F2 # LATIN SMALL LETTER O WITH GRAVE
0xF3 0x00F3 # LATIN SMALL LETTER O WITH ACUTE
0xF4 0x00F4 # LATIN SMALL LETTER O WITH CIRCUMFLEX
0xF5 0x00F5 # LATIN SMALL LETTER O WITH TILDE
0xF6 0x00F6 # LATIN SMALL LETTER O WITH DIAERESIS
0xF7 0x00F7 # DIVISION SIGN
0xF8 0x00F8 # LATIN SMALL LETTER O WITH STROKE
0xF9 0x00F9 # LATIN SMALL LETTER U WITH GRAVE
0xFA 0x00FA # LATIN SMALL LETTER U WITH ACUTE
0xFB 0x00FB # LATIN SMALL LETTER U WITH CIRCUMFLEX
0xFC 0x00FC # LATIN SMALL LETTER U WITH DIAERESIS
0xFD 0x00FD # LATIN SMALL LETTER Y WITH ACUTE
0xFE 0x00FE # LATIN SMALL LETTER THORN (Icelandic)
0xFF 0x00FF # LATIN SMALL LETTER Y WITH DIAERESIS

303
extra/io/encodings/8-bit/8859-10.TXT Normal file
View File

@ -0,0 +1,303 @@
#
# Name: ISO/IEC 8859-10:1998 to Unicode
# Unicode version: 3.0
# Table version: 1.1
# Table format: Format A
# Date: 1999 October 11
# Authors: Ken Whistler <kenw@sybase.com>
#
# Copyright (c) 1999 Unicode, Inc. All Rights reserved.
#
# This file is provided as-is by Unicode, Inc. (The Unicode Consortium).
# No claims are made as to fitness for any particular purpose. No
# warranties of any kind are expressed or implied. The recipient
# agrees to determine applicability of information provided. If this
# file has been provided on optical media by Unicode, Inc., the sole
# remedy for any claim will be exchange of defective media within 90
# days of receipt.
#
# Unicode, Inc. hereby grants the right to freely use the information
# supplied in this file in the creation of products supporting the
# Unicode Standard, and to make copies of this file in any form for
# internal or external distribution as long as this notice remains
# attached.
#
# General notes:
#
# This table contains the data the Unicode Consortium has on how
# ISO/IEC 8859-10:1998 characters map into Unicode.
#
# Format: Three tab-separated columns
# Column #1 is the ISO/IEC 8859-10 code (in hex as 0xXX)
# Column #2 is the Unicode (in hex as 0xXXXX)
# Column #3 the Unicode name (follows a comment sign, '#')
#
# The entries are in ISO/IEC 8859-10 order.
#
# Version history
# 1.0 version new.
# 1.1 corrected mistake in mapping of 0xA4
#
# Updated versions of this file may be found in:
# <ftp://ftp.unicode.org/Public/MAPPINGS/>
#
# Any comments or problems, contact <errata@unicode.org>
# Please note that <errata@unicode.org> is an archival address;
# notices will be checked, but do not expect an immediate response.
#
0x00 0x0000 # NULL
0x01 0x0001 # START OF HEADING
0x02 0x0002 # START OF TEXT
0x03 0x0003 # END OF TEXT
0x04 0x0004 # END OF TRANSMISSION
0x05 0x0005 # ENQUIRY
0x06 0x0006 # ACKNOWLEDGE
0x07 0x0007 # BELL
0x08 0x0008 # BACKSPACE
0x09 0x0009 # HORIZONTAL TABULATION
0x0A 0x000A # LINE FEED
0x0B 0x000B # VERTICAL TABULATION
0x0C 0x000C # FORM FEED
0x0D 0x000D # CARRIAGE RETURN
0x0E 0x000E # SHIFT OUT
0x0F 0x000F # SHIFT IN
0x10 0x0010 # DATA LINK ESCAPE
0x11 0x0011 # DEVICE CONTROL ONE
0x12 0x0012 # DEVICE CONTROL TWO
0x13 0x0013 # DEVICE CONTROL THREE
0x14 0x0014 # DEVICE CONTROL FOUR
0x15 0x0015 # NEGATIVE ACKNOWLEDGE
0x16 0x0016 # SYNCHRONOUS IDLE
0x17 0x0017 # END OF TRANSMISSION BLOCK
0x18 0x0018 # CANCEL
0x19 0x0019 # END OF MEDIUM
0x1A 0x001A # SUBSTITUTE
0x1B 0x001B # ESCAPE
0x1C 0x001C # FILE SEPARATOR
0x1D 0x001D # GROUP SEPARATOR
0x1E 0x001E # RECORD SEPARATOR
0x1F 0x001F # UNIT SEPARATOR
0x20 0x0020 # SPACE
0x21 0x0021 # EXCLAMATION MARK
0x22 0x0022 # QUOTATION MARK
0x23 0x0023 # NUMBER SIGN
0x24 0x0024 # DOLLAR SIGN
0x25 0x0025 # PERCENT SIGN
0x26 0x0026 # AMPERSAND
0x27 0x0027 # APOSTROPHE
0x28 0x0028 # LEFT PARENTHESIS
0x29 0x0029 # RIGHT PARENTHESIS
0x2A 0x002A # ASTERISK
0x2B 0x002B # PLUS SIGN
0x2C 0x002C # COMMA
0x2D 0x002D # HYPHEN-MINUS
0x2E 0x002E # FULL STOP
0x2F 0x002F # SOLIDUS
0x30 0x0030 # DIGIT ZERO
0x31 0x0031 # DIGIT ONE
0x32 0x0032 # DIGIT TWO
0x33 0x0033 # DIGIT THREE
0x34 0x0034 # DIGIT FOUR
0x35 0x0035 # DIGIT FIVE
0x36 0x0036 # DIGIT SIX
0x37 0x0037 # DIGIT SEVEN
0x38 0x0038 # DIGIT EIGHT
0x39 0x0039 # DIGIT NINE
0x3A 0x003A # COLON
0x3B 0x003B # SEMICOLON
0x3C 0x003C # LESS-THAN SIGN
0x3D 0x003D # EQUALS SIGN
0x3E 0x003E # GREATER-THAN SIGN
0x3F 0x003F # QUESTION MARK
0x40 0x0040 # COMMERCIAL AT
0x41 0x0041 # LATIN CAPITAL LETTER A
0x42 0x0042 # LATIN CAPITAL LETTER B
0x43 0x0043 # LATIN CAPITAL LETTER C
0x44 0x0044 # LATIN CAPITAL LETTER D
0x45 0x0045 # LATIN CAPITAL LETTER E
0x46 0x0046 # LATIN CAPITAL LETTER F
0x47 0x0047 # LATIN CAPITAL LETTER G
0x48 0x0048 # LATIN CAPITAL LETTER H
0x49 0x0049 # LATIN CAPITAL LETTER I
0x4A 0x004A # LATIN CAPITAL LETTER J
0x4B 0x004B # LATIN CAPITAL LETTER K
0x4C 0x004C # LATIN CAPITAL LETTER L
0x4D 0x004D # LATIN CAPITAL LETTER M
0x4E 0x004E # LATIN CAPITAL LETTER N
0x4F 0x004F # LATIN CAPITAL LETTER O
0x50 0x0050 # LATIN CAPITAL LETTER P
0x51 0x0051 # LATIN CAPITAL LETTER Q
0x52 0x0052 # LATIN CAPITAL LETTER R
0x53 0x0053 # LATIN CAPITAL LETTER S
0x54 0x0054 # LATIN CAPITAL LETTER T
0x55 0x0055 # LATIN CAPITAL LETTER U
0x56 0x0056 # LATIN CAPITAL LETTER V
0x57 0x0057 # LATIN CAPITAL LETTER W
0x58 0x0058 # LATIN CAPITAL LETTER X
0x59 0x0059 # LATIN CAPITAL LETTER Y
0x5A 0x005A # LATIN CAPITAL LETTER Z
0x5B 0x005B # LEFT SQUARE BRACKET
0x5C 0x005C # REVERSE SOLIDUS
0x5D 0x005D # RIGHT SQUARE BRACKET
0x5E 0x005E # CIRCUMFLEX ACCENT
0x5F 0x005F # LOW LINE
0x60 0x0060 # GRAVE ACCENT
0x61 0x0061 # LATIN SMALL LETTER A
0x62 0x0062 # LATIN SMALL LETTER B
0x63 0x0063 # LATIN SMALL LETTER C
0x64 0x0064 # LATIN SMALL LETTER D
0x65 0x0065 # LATIN SMALL LETTER E
0x66 0x0066 # LATIN SMALL LETTER F
0x67 0x0067 # LATIN SMALL LETTER G
0x68 0x0068 # LATIN SMALL LETTER H
0x69 0x0069 # LATIN SMALL LETTER I
0x6A 0x006A # LATIN SMALL LETTER J
0x6B 0x006B # LATIN SMALL LETTER K
0x6C 0x006C # LATIN SMALL LETTER L
0x6D 0x006D # LATIN SMALL LETTER M
0x6E 0x006E # LATIN SMALL LETTER N
0x6F 0x006F # LATIN SMALL LETTER O
0x70 0x0070 # LATIN SMALL LETTER P
0x71 0x0071 # LATIN SMALL LETTER Q
0x72 0x0072 # LATIN SMALL LETTER R
0x73 0x0073 # LATIN SMALL LETTER S
0x74 0x0074 # LATIN SMALL LETTER T
0x75 0x0075 # LATIN SMALL LETTER U
0x76 0x0076 # LATIN SMALL LETTER V
0x77 0x0077 # LATIN SMALL LETTER W
0x78 0x0078 # LATIN SMALL LETTER X
0x79 0x0079 # LATIN SMALL LETTER Y
0x7A 0x007A # LATIN SMALL LETTER Z
0x7B 0x007B # LEFT CURLY BRACKET
0x7C 0x007C # VERTICAL LINE
0x7D 0x007D # RIGHT CURLY BRACKET
0x7E 0x007E # TILDE
0x7F 0x007F # DELETE
0x80 0x0080 # <control>
0x81 0x0081 # <control>
0x82 0x0082 # <control>
0x83 0x0083 # <control>
0x84 0x0084 # <control>
0x85 0x0085 # <control>
0x86 0x0086 # <control>
0x87 0x0087 # <control>
0x88 0x0088 # <control>
0x89 0x0089 # <control>
0x8A 0x008A # <control>
0x8B 0x008B # <control>
0x8C 0x008C # <control>
0x8D 0x008D # <control>
0x8E 0x008E # <control>
0x8F 0x008F # <control>
0x90 0x0090 # <control>
0x91 0x0091 # <control>
0x92 0x0092 # <control>
0x93 0x0093 # <control>
0x94 0x0094 # <control>
0x95 0x0095 # <control>
0x96 0x0096 # <control>
0x97 0x0097 # <control>
0x98 0x0098 # <control>
0x99 0x0099 # <control>
0x9A 0x009A # <control>
0x9B 0x009B # <control>
0x9C 0x009C # <control>
0x9D 0x009D # <control>
0x9E 0x009E # <control>
0x9F 0x009F # <control>
0xA0 0x00A0 # NO-BREAK SPACE
0xA1 0x0104 # LATIN CAPITAL LETTER A WITH OGONEK
0xA2 0x0112 # LATIN CAPITAL LETTER E WITH MACRON
0xA3 0x0122 # LATIN CAPITAL LETTER G WITH CEDILLA
0xA4 0x012A # LATIN CAPITAL LETTER I WITH MACRON
0xA5 0x0128 # LATIN CAPITAL LETTER I WITH TILDE
0xA6 0x0136 # LATIN CAPITAL LETTER K WITH CEDILLA
0xA7 0x00A7 # SECTION SIGN
0xA8 0x013B # LATIN CAPITAL LETTER L WITH CEDILLA
0xA9 0x0110 # LATIN CAPITAL LETTER D WITH STROKE
0xAA 0x0160 # LATIN CAPITAL LETTER S WITH CARON
0xAB 0x0166 # LATIN CAPITAL LETTER T WITH STROKE
0xAC 0x017D # LATIN CAPITAL LETTER Z WITH CARON
0xAD 0x00AD # SOFT HYPHEN
0xAE 0x016A # LATIN CAPITAL LETTER U WITH MACRON
0xAF 0x014A # LATIN CAPITAL LETTER ENG
0xB0 0x00B0 # DEGREE SIGN
0xB1 0x0105 # LATIN SMALL LETTER A WITH OGONEK
0xB2 0x0113 # LATIN SMALL LETTER E WITH MACRON
0xB3 0x0123 # LATIN SMALL LETTER G WITH CEDILLA
0xB4 0x012B # LATIN SMALL LETTER I WITH MACRON
0xB5 0x0129 # LATIN SMALL LETTER I WITH TILDE
0xB6 0x0137 # LATIN SMALL LETTER K WITH CEDILLA
0xB7 0x00B7 # MIDDLE DOT
0xB8 0x013C # LATIN SMALL LETTER L WITH CEDILLA
0xB9 0x0111 # LATIN SMALL LETTER D WITH STROKE
0xBA 0x0161 # LATIN SMALL LETTER S WITH CARON
0xBB 0x0167 # LATIN SMALL LETTER T WITH STROKE
0xBC 0x017E # LATIN SMALL LETTER Z WITH CARON
0xBD 0x2015 # HORIZONTAL BAR
0xBE 0x016B # LATIN SMALL LETTER U WITH MACRON
0xBF 0x014B # LATIN SMALL LETTER ENG
0xC0 0x0100 # LATIN CAPITAL LETTER A WITH MACRON
0xC1 0x00C1 # LATIN CAPITAL LETTER A WITH ACUTE
0xC2 0x00C2 # LATIN CAPITAL LETTER A WITH CIRCUMFLEX
0xC3 0x00C3 # LATIN CAPITAL LETTER A WITH TILDE
0xC4 0x00C4 # LATIN CAPITAL LETTER A WITH DIAERESIS
0xC5 0x00C5 # LATIN CAPITAL LETTER A WITH RING ABOVE
0xC6 0x00C6 # LATIN CAPITAL LETTER AE
0xC7 0x012E # LATIN CAPITAL LETTER I WITH OGONEK
0xC8 0x010C # LATIN CAPITAL LETTER C WITH CARON
0xC9 0x00C9 # LATIN CAPITAL LETTER E WITH ACUTE
0xCA 0x0118 # LATIN CAPITAL LETTER E WITH OGONEK
0xCB 0x00CB # LATIN CAPITAL LETTER E WITH DIAERESIS
0xCC 0x0116 # LATIN CAPITAL LETTER E WITH DOT ABOVE
0xCD 0x00CD # LATIN CAPITAL LETTER I WITH ACUTE
0xCE 0x00CE # LATIN CAPITAL LETTER I WITH CIRCUMFLEX
0xCF 0x00CF # LATIN CAPITAL LETTER I WITH DIAERESIS
0xD0 0x00D0 # LATIN CAPITAL LETTER ETH (Icelandic)
0xD1 0x0145 # LATIN CAPITAL LETTER N WITH CEDILLA
0xD2 0x014C # LATIN CAPITAL LETTER O WITH MACRON
0xD3 0x00D3 # LATIN CAPITAL LETTER O WITH ACUTE
0xD4 0x00D4 # LATIN CAPITAL LETTER O WITH CIRCUMFLEX
0xD5 0x00D5 # LATIN CAPITAL LETTER O WITH TILDE
0xD6 0x00D6 # LATIN CAPITAL LETTER O WITH DIAERESIS
0xD7 0x0168 # LATIN CAPITAL LETTER U WITH TILDE
0xD8 0x00D8 # LATIN CAPITAL LETTER O WITH STROKE
0xD9 0x0172 # LATIN CAPITAL LETTER U WITH OGONEK
0xDA 0x00DA # LATIN CAPITAL LETTER U WITH ACUTE
0xDB 0x00DB # LATIN CAPITAL LETTER U WITH CIRCUMFLEX
0xDC 0x00DC # LATIN CAPITAL LETTER U WITH DIAERESIS
0xDD 0x00DD # LATIN CAPITAL LETTER Y WITH ACUTE
0xDE 0x00DE # LATIN CAPITAL LETTER THORN (Icelandic)
0xDF 0x00DF # LATIN SMALL LETTER SHARP S (German)
0xE0 0x0101 # LATIN SMALL LETTER A WITH MACRON
0xE1 0x00E1 # LATIN SMALL LETTER A WITH ACUTE
0xE2 0x00E2 # LATIN SMALL LETTER A WITH CIRCUMFLEX
0xE3 0x00E3 # LATIN SMALL LETTER A WITH TILDE
0xE4 0x00E4 # LATIN SMALL LETTER A WITH DIAERESIS
0xE5 0x00E5 # LATIN SMALL LETTER A WITH RING ABOVE
0xE6 0x00E6 # LATIN SMALL LETTER AE
0xE7 0x012F # LATIN SMALL LETTER I WITH OGONEK
0xE8 0x010D # LATIN SMALL LETTER C WITH CARON
0xE9 0x00E9 # LATIN SMALL LETTER E WITH ACUTE
0xEA 0x0119 # LATIN SMALL LETTER E WITH OGONEK
0xEB 0x00EB # LATIN SMALL LETTER E WITH DIAERESIS
0xEC 0x0117 # LATIN SMALL LETTER E WITH DOT ABOVE
0xED 0x00ED # LATIN SMALL LETTER I WITH ACUTE
0xEE 0x00EE # LATIN SMALL LETTER I WITH CIRCUMFLEX
0xEF 0x00EF # LATIN SMALL LETTER I WITH DIAERESIS
0xF0 0x00F0 # LATIN SMALL LETTER ETH (Icelandic)
0xF1 0x0146 # LATIN SMALL LETTER N WITH CEDILLA
0xF2 0x014D # LATIN SMALL LETTER O WITH MACRON
0xF3 0x00F3 # LATIN SMALL LETTER O WITH ACUTE
0xF4 0x00F4 # LATIN SMALL LETTER O WITH CIRCUMFLEX
0xF5 0x00F5 # LATIN SMALL LETTER O WITH TILDE
0xF6 0x00F6 # LATIN SMALL LETTER O WITH DIAERESIS
0xF7 0x0169 # LATIN SMALL LETTER U WITH TILDE
0xF8 0x00F8 # LATIN SMALL LETTER O WITH STROKE
0xF9 0x0173 # LATIN SMALL LETTER U WITH OGONEK
0xFA 0x00FA # LATIN SMALL LETTER U WITH ACUTE
0xFB 0x00FB # LATIN SMALL LETTER U WITH CIRCUMFLEX
0xFC 0x00FC # LATIN SMALL LETTER U WITH DIAERESIS
0xFD 0x00FD # LATIN SMALL LETTER Y WITH ACUTE
0xFE 0x00FE # LATIN SMALL LETTER THORN (Icelandic)
0xFF 0x0138 # LATIN SMALL LETTER KRA

297
extra/io/encodings/8-bit/8859-11.TXT Normal file
View File

@ -0,0 +1,297 @@
#
# Name: ISO/IEC 8859-11:2001 to Unicode
# Unicode version: 3.2
# Table version: 1.0
# Table format: Format A
# Date: 2002 October 7
# Authors: Ken Whistler <kenw@sybase.com>
#
# Copyright (c) 2002 Unicode, Inc. All Rights reserved.
#
# This file is provided as-is by Unicode, Inc. (The Unicode Consortium).
# No claims are made as to fitness for any particular purpose. No
# warranties of any kind are expressed or implied. The recipient
# agrees to determine applicability of information provided. If this
# file has been provided on optical media by Unicode, Inc., the sole
# remedy for any claim will be exchange of defective media within 90
# days of receipt.
#
# Unicode, Inc. hereby grants the right to freely use the information
# supplied in this file in the creation of products supporting the
# Unicode Standard, and to make copies of this file in any form for
# internal or external distribution as long as this notice remains
# attached.
#
# General notes:
#
# This table contains the data the Unicode Consortium has on how
# ISO/IEC 8859-11:2001 characters map into Unicode.
#
# ISO/IEC 8859-11:2001 is equivalent to TIS 620-2533 (1990) with
# the addition of 0xA0 NO-BREAK SPACE.
#
# Format: Three tab-separated columns
# Column #1 is the ISO/IEC 8859-11 code (in hex as 0xXX)
# Column #2 is the Unicode (in hex as 0xXXXX)
# Column #3 the Unicode name (follows a comment sign, '#')
#
# The entries are in ISO/IEC 8859-11 order.
#
# Version history:
# 2002 October 7 Created
#
# Updated versions of this file may be found in:
# <ftp://ftp.unicode.org/Public/MAPPINGS/>
#
# For any comments or problems, please use the Unicode
# web contact form at:
# http://www.unicode.org/unicode/reporting.html
#
0x00 0x0000 # NULL
0x01 0x0001 # START OF HEADING
0x02 0x0002 # START OF TEXT
0x03 0x0003 # END OF TEXT
0x04 0x0004 # END OF TRANSMISSION
0x05 0x0005 # ENQUIRY
0x06 0x0006 # ACKNOWLEDGE
0x07 0x0007 # BELL
0x08 0x0008 # BACKSPACE
0x09 0x0009 # HORIZONTAL TABULATION
0x0A 0x000A # LINE FEED
0x0B 0x000B # VERTICAL TABULATION
0x0C 0x000C # FORM FEED
0x0D 0x000D # CARRIAGE RETURN
0x0E 0x000E # SHIFT OUT
0x0F 0x000F # SHIFT IN
0x10 0x0010 # DATA LINK ESCAPE
0x11 0x0011 # DEVICE CONTROL ONE
0x12 0x0012 # DEVICE CONTROL TWO
0x13 0x0013 # DEVICE CONTROL THREE
0x14 0x0014 # DEVICE CONTROL FOUR
0x15 0x0015 # NEGATIVE ACKNOWLEDGE
0x16 0x0016 # SYNCHRONOUS IDLE
0x17 0x0017 # END OF TRANSMISSION BLOCK
0x18 0x0018 # CANCEL
0x19 0x0019 # END OF MEDIUM
0x1A 0x001A # SUBSTITUTE
0x1B 0x001B # ESCAPE
0x1C 0x001C # FILE SEPARATOR
0x1D 0x001D # GROUP SEPARATOR
0x1E 0x001E # RECORD SEPARATOR
0x1F 0x001F # UNIT SEPARATOR
0x20 0x0020 # SPACE
0x21 0x0021 # EXCLAMATION MARK
0x22 0x0022 # QUOTATION MARK
0x23 0x0023 # NUMBER SIGN
0x24 0x0024 # DOLLAR SIGN
0x25 0x0025 # PERCENT SIGN
0x26 0x0026 # AMPERSAND
0x27 0x0027 # APOSTROPHE
0x28 0x0028 # LEFT PARENTHESIS
0x29 0x0029 # RIGHT PARENTHESIS
0x2A 0x002A # ASTERISK
0x2B 0x002B # PLUS SIGN
0x2C 0x002C # COMMA
0x2D 0x002D # HYPHEN-MINUS
0x2E 0x002E # FULL STOP
0x2F 0x002F # SOLIDUS
0x30 0x0030 # DIGIT ZERO
0x31 0x0031 # DIGIT ONE
0x32 0x0032 # DIGIT TWO
0x33 0x0033 # DIGIT THREE
0x34 0x0034 # DIGIT FOUR
0x35 0x0035 # DIGIT FIVE
0x36 0x0036 # DIGIT SIX
0x37 0x0037 # DIGIT SEVEN
0x38 0x0038 # DIGIT EIGHT
0x39 0x0039 # DIGIT NINE
0x3A 0x003A # COLON
0x3B 0x003B # SEMICOLON
0x3C 0x003C # LESS-THAN SIGN
0x3D 0x003D # EQUALS SIGN
0x3E 0x003E # GREATER-THAN SIGN
0x3F 0x003F # QUESTION MARK
0x40 0x0040 # COMMERCIAL AT
0x41 0x0041 # LATIN CAPITAL LETTER A
0x42 0x0042 # LATIN CAPITAL LETTER B
0x43 0x0043 # LATIN CAPITAL LETTER C
0x44 0x0044 # LATIN CAPITAL LETTER D
0x45 0x0045 # LATIN CAPITAL LETTER E
0x46 0x0046 # LATIN CAPITAL LETTER F
0x47 0x0047 # LATIN CAPITAL LETTER G
0x48 0x0048 # LATIN CAPITAL LETTER H
0x49 0x0049 # LATIN CAPITAL LETTER I
0x4A 0x004A # LATIN CAPITAL LETTER J
0x4B 0x004B # LATIN CAPITAL LETTER K
0x4C 0x004C # LATIN CAPITAL LETTER L
0x4D 0x004D # LATIN CAPITAL LETTER M
0x4E 0x004E # LATIN CAPITAL LETTER N
0x4F 0x004F # LATIN CAPITAL LETTER O
0x50 0x0050 # LATIN CAPITAL LETTER P
0x51 0x0051 # LATIN CAPITAL LETTER Q
0x52 0x0052 # LATIN CAPITAL LETTER R
0x53 0x0053 # LATIN CAPITAL LETTER S
0x54 0x0054 # LATIN CAPITAL LETTER T
0x55 0x0055 # LATIN CAPITAL LETTER U
0x56 0x0056 # LATIN CAPITAL LETTER V
0x57 0x0057 # LATIN CAPITAL LETTER W
0x58 0x0058 # LATIN CAPITAL LETTER X
0x59 0x0059 # LATIN CAPITAL LETTER Y
0x5A 0x005A # LATIN CAPITAL LETTER Z
0x5B 0x005B # LEFT SQUARE BRACKET
0x5C 0x005C # REVERSE SOLIDUS
0x5D 0x005D # RIGHT SQUARE BRACKET
0x5E 0x005E # CIRCUMFLEX ACCENT
0x5F 0x005F # LOW LINE
0x60 0x0060 # GRAVE ACCENT
0x61 0x0061 # LATIN SMALL LETTER A
0x62 0x0062 # LATIN SMALL LETTER B
0x63 0x0063 # LATIN SMALL LETTER C
0x64 0x0064 # LATIN SMALL LETTER D
0x65 0x0065 # LATIN SMALL LETTER E
0x66 0x0066 # LATIN SMALL LETTER F
0x67 0x0067 # LATIN SMALL LETTER G
0x68 0x0068 # LATIN SMALL LETTER H
0x69 0x0069 # LATIN SMALL LETTER I
0x6A 0x006A # LATIN SMALL LETTER J
0x6B 0x006B # LATIN SMALL LETTER K
0x6C 0x006C # LATIN SMALL LETTER L
0x6D 0x006D # LATIN SMALL LETTER M
0x6E 0x006E # LATIN SMALL LETTER N
0x6F 0x006F # LATIN SMALL LETTER O
0x70 0x0070 # LATIN SMALL LETTER P
0x71 0x0071 # LATIN SMALL LETTER Q
0x72 0x0072 # LATIN SMALL LETTER R
0x73 0x0073 # LATIN SMALL LETTER S
0x74 0x0074 # LATIN SMALL LETTER T
0x75 0x0075 # LATIN SMALL LETTER U
0x76 0x0076 # LATIN SMALL LETTER V
0x77 0x0077 # LATIN SMALL LETTER W
0x78 0x0078 # LATIN SMALL LETTER X
0x79 0x0079 # LATIN SMALL LETTER Y
0x7A 0x007A # LATIN SMALL LETTER Z
0x7B 0x007B # LEFT CURLY BRACKET
0x7C 0x007C # VERTICAL LINE
0x7D 0x007D # RIGHT CURLY BRACKET
0x7E 0x007E # TILDE
0x7F 0x007F # DELETE
0x80 0x0080 # <control>
0x81 0x0081 # <control>
0x82 0x0082 # <control>
0x83 0x0083 # <control>
0x84 0x0084 # <control>
0x85 0x0085 # <control>
0x86 0x0086 # <control>
0x87 0x0087 # <control>
0x88 0x0088 # <control>
0x89 0x0089 # <control>
0x8A 0x008A # <control>
0x8B 0x008B # <control>
0x8C 0x008C # <control>
0x8D 0x008D # <control>
0x8E 0x008E # <control>
0x8F 0x008F # <control>
0x90 0x0090 # <control>
0x91 0x0091 # <control>
0x92 0x0092 # <control>
0x93 0x0093 # <control>
0x94 0x0094 # <control>
0x95 0x0095 # <control>
0x96 0x0096 # <control>
0x97 0x0097 # <control>
0x98 0x0098 # <control>
0x99 0x0099 # <control>
0x9A 0x009A # <control>
0x9B 0x009B # <control>
0x9C 0x009C # <control>
0x9D 0x009D # <control>
0x9E 0x009E # <control>
0x9F 0x009F # <control>
0xA0 0x00A0 # NO-BREAK SPACE
0xA1 0x0E01 # THAI CHARACTER KO KAI
0xA2 0x0E02 # THAI CHARACTER KHO KHAI
0xA3 0x0E03 # THAI CHARACTER KHO KHUAT
0xA4 0x0E04 # THAI CHARACTER KHO KHWAI
0xA5 0x0E05 # THAI CHARACTER KHO KHON
0xA6 0x0E06 # THAI CHARACTER KHO RAKHANG
0xA7 0x0E07 # THAI CHARACTER NGO NGU
0xA8 0x0E08 # THAI CHARACTER CHO CHAN
0xA9 0x0E09 # THAI CHARACTER CHO CHING
0xAA 0x0E0A # THAI CHARACTER CHO CHANG
0xAB 0x0E0B # THAI CHARACTER SO SO
0xAC 0x0E0C # THAI CHARACTER CHO CHOE
0xAD 0x0E0D # THAI CHARACTER YO YING
0xAE 0x0E0E # THAI CHARACTER DO CHADA
0xAF 0x0E0F # THAI CHARACTER TO PATAK
0xB0 0x0E10 # THAI CHARACTER THO THAN
0xB1 0x0E11 # THAI CHARACTER THO NANGMONTHO
0xB2 0x0E12 # THAI CHARACTER THO PHUTHAO
0xB3 0x0E13 # THAI CHARACTER NO NEN
0xB4 0x0E14 # THAI CHARACTER DO DEK
0xB5 0x0E15 # THAI CHARACTER TO TAO
0xB6 0x0E16 # THAI CHARACTER THO THUNG
0xB7 0x0E17 # THAI CHARACTER THO THAHAN
0xB8 0x0E18 # THAI CHARACTER THO THONG
0xB9 0x0E19 # THAI CHARACTER NO NU
0xBA 0x0E1A # THAI CHARACTER BO BAIMAI
0xBB 0x0E1B # THAI CHARACTER PO PLA
0xBC 0x0E1C # THAI CHARACTER PHO PHUNG
0xBD 0x0E1D # THAI CHARACTER FO FA
0xBE 0x0E1E # THAI CHARACTER PHO PHAN
0xBF 0x0E1F # THAI CHARACTER FO FAN
0xC0 0x0E20 # THAI CHARACTER PHO SAMPHAO
0xC1 0x0E21 # THAI CHARACTER MO MA
0xC2 0x0E22 # THAI CHARACTER YO YAK
0xC3 0x0E23 # THAI CHARACTER RO RUA
0xC4 0x0E24 # THAI CHARACTER RU
0xC5 0x0E25 # THAI CHARACTER LO LING
0xC6 0x0E26 # THAI CHARACTER LU
0xC7 0x0E27 # THAI CHARACTER WO WAEN
0xC8 0x0E28 # THAI CHARACTER SO SALA
0xC9 0x0E29 # THAI CHARACTER SO RUSI
0xCA 0x0E2A # THAI CHARACTER SO SUA
0xCB 0x0E2B # THAI CHARACTER HO HIP
0xCC 0x0E2C # THAI CHARACTER LO CHULA
0xCD 0x0E2D # THAI CHARACTER O ANG
0xCE 0x0E2E # THAI CHARACTER HO NOKHUK
0xCF 0x0E2F # THAI CHARACTER PAIYANNOI
0xD0 0x0E30 # THAI CHARACTER SARA A
0xD1 0x0E31 # THAI CHARACTER MAI HAN-AKAT
0xD2 0x0E32 # THAI CHARACTER SARA AA
0xD3 0x0E33 # THAI CHARACTER SARA AM
0xD4 0x0E34 # THAI CHARACTER SARA I
0xD5 0x0E35 # THAI CHARACTER SARA II
0xD6 0x0E36 # THAI CHARACTER SARA UE
0xD7 0x0E37 # THAI CHARACTER SARA UEE
0xD8 0x0E38 # THAI CHARACTER SARA U
0xD9 0x0E39 # THAI CHARACTER SARA UU
0xDA 0x0E3A # THAI CHARACTER PHINTHU
0xDF 0x0E3F # THAI CURRENCY SYMBOL BAHT
0xE0 0x0E40 # THAI CHARACTER SARA E
0xE1 0x0E41 # THAI CHARACTER SARA AE
0xE2 0x0E42 # THAI CHARACTER SARA O
0xE3 0x0E43 # THAI CHARACTER SARA AI MAIMUAN
0xE4 0x0E44 # THAI CHARACTER SARA AI MAIMALAI
0xE5 0x0E45 # THAI CHARACTER LAKKHANGYAO
0xE6 0x0E46 # THAI CHARACTER MAIYAMOK
0xE7 0x0E47 # THAI CHARACTER MAITAIKHU
0xE8 0x0E48 # THAI CHARACTER MAI EK
0xE9 0x0E49 # THAI CHARACTER MAI THO
0xEA 0x0E4A # THAI CHARACTER MAI TRI
0xEB 0x0E4B # THAI CHARACTER MAI CHATTAWA
0xEC 0x0E4C # THAI CHARACTER THANTHAKHAT
0xED 0x0E4D # THAI CHARACTER NIKHAHIT
0xEE 0x0E4E # THAI CHARACTER YAMAKKAN
0xEF 0x0E4F # THAI CHARACTER FONGMAN
0xF0 0x0E50 # THAI DIGIT ZERO
0xF1 0x0E51 # THAI DIGIT ONE
0xF2 0x0E52 # THAI DIGIT TWO
0xF3 0x0E53 # THAI DIGIT THREE
0xF4 0x0E54 # THAI DIGIT FOUR
0xF5 0x0E55 # THAI DIGIT FIVE
0xF6 0x0E56 # THAI DIGIT SIX
0xF7 0x0E57 # THAI DIGIT SEVEN
0xF8 0x0E58 # THAI DIGIT EIGHT
0xF9 0x0E59 # THAI DIGIT NINE
0xFA 0x0E5A # THAI CHARACTER ANGKHANKHU
0xFB 0x0E5B # THAI CHARACTER KHOMUT

Some files were not shown because too many files have changed in this diff Show More