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

Merge git://factorcode.org/git/factor

db4
Doug Coleman 2008-02-01 18:27:43 -06:00
parent 161c3ec156 4b7034384c
commit 0f8dc54b3d
135 changed files with 655 additions and 582 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
core/alien/alien-docs.factor
View File

@ -1,6 +1,7 @@
USING: byte-arrays arrays help.syntax help.markup
alien.syntax compiler definitions math libc
debugger parser io io.backend system bit-arrays float-arrays ;
debugger parser io io.backend system bit-arrays float-arrays
alien.accessors ;
IN: alien
HELP: alien

6
core/alien/alien-tests.factor Normal file → Executable file
View File

@ -1,7 +1,7 @@
IN: temporary
USING: alien byte-arrays
arrays kernel kernel.private namespaces tools.test sequences
libc math system prettyprint ;
USING: alien alien.accessors byte-arrays arrays kernel
kernel.private namespaces tools.test sequences libc math system
prettyprint ;
[ t ] [ -1 <alien> alien-address 0 > ] unit-test

15
core/alien/alien.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel math namespaces sequences system
kernel.private tuples ;
kernel.private tuples bit-arrays byte-arrays float-arrays ;
IN: alien
! Some predicate classes used by the compiler for optimization
@ -9,16 +9,11 @@ IN: alien
PREDICATE: alien simple-alien
underlying-alien not ;
! These mixins are not intended to be extended by user code.
! They are not unions, because if they were we'd have a circular
! dependency between alien and {byte,bit,float}-arrays.
MIXIN: simple-c-ptr
INSTANCE: simple-alien simple-c-ptr
INSTANCE: f simple-c-ptr
UNION: simple-c-ptr
simple-alien POSTPONE: f byte-array bit-array float-array ;
MIXIN: c-ptr
INSTANCE: alien c-ptr
INSTANCE: f c-ptr
UNION: c-ptr
alien POSTPONE: f byte-array bit-array float-array ;
DEFER: pinned-c-ptr?

8
core/alien/c-types/c-types-tests.factor Normal file → Executable file
View File

@ -2,16 +2,16 @@ IN: temporary
USING: alien alien.syntax alien.c-types kernel tools.test
sequences system libc ;
[ "\u00ff" ]
[ "\u00ff" string>char-alien alien>char-string ]
[ "\u0000ff" ]
[ "\u0000ff" string>char-alien alien>char-string ]
unit-test
[ "hello world" ]
[ "hello world" string>char-alien alien>char-string ]
unit-test
[ "hello\uabcdworld" ]
[ "hello\uabcdworld" string>u16-alien alien>u16-string ]
[ "hello\u00abcdworld" ]
[ "hello\u00abcdworld" string>u16-alien alien>u16-string ]
unit-test
[ t ] [ f expired? ] unit-test

2
core/alien/c-types/c-types.factor
View File

@ -3,7 +3,7 @@
USING: byte-arrays arrays generator.registers assocs
kernel kernel.private libc math namespaces parser sequences
strings words assocs splitting math.parser cpu.architecture
alien quotations system compiler.units ;
alien alien.accessors quotations system compiler.units ;
IN: alien.c-types
TUPLE: c-type

4
core/bit-arrays/bit-arrays.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: math alien kernel kernel.private sequences
USING: math alien.accessors kernel kernel.private sequences
sequences.private ;
IN: bit-arrays
@ -52,5 +52,3 @@ M: bit-array resize
resize-bit-array ;
INSTANCE: bit-array sequence
INSTANCE: bit-array simple-c-ptr
INSTANCE: bit-array c-ptr

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

@ -17,8 +17,6 @@ IN: bootstrap.image
: image-magic HEX: 0f0e0d0c ; inline
: image-version 4 ; inline
: char bootstrap-cell 2/ ; inline
: data-base 1024 ; inline
: userenv-size 40 ; inline
@ -244,21 +242,19 @@ M: wrapper '
[ emit ] emit-object ;
! Strings
: 16be> 0 [ swap 16 shift bitor ] reduce ;
: 16le> <reversed> 16be> ;
: emit-chars ( seq -- )
char <groups>
big-endian get [ [ 16be> ] map ] [ [ 16le> ] map ] if
bootstrap-cell <groups>
big-endian get [ [ be> ] map ] [ [ le> ] map ] if
emit-seq ;
: pack-string ( string -- newstr )
dup length 1+ char align 0 pad-right ;
dup length 1+ bootstrap-cell align 0 pad-right ;
: emit-string ( string -- ptr )
string type-number object tag-number [
dup length emit-fixnum
f ' emit
f ' emit
pack-string emit-chars
] emit-object ;

62
core/bootstrap/primitives.factor
View File

@ -40,6 +40,7 @@ call
! classes will go
{
"alien"
"alien.accessors"
"arrays"
"bit-arrays"
"bit-vectors"
@ -190,6 +191,11 @@ num-types get f <array> builtins set
"length"
{ "length" "sequences" }
f
} {
{ "object" "kernel" }
"aux"
{ "string-aux" "strings.private" }
{ "set-string-aux" "strings.private" }
}
} define-builtin
@ -556,32 +562,32 @@ builtins get num-tags get tail f union-class define-class
{ "<byte-array>" "byte-arrays" }
{ "<bit-array>" "bit-arrays" }
{ "<displaced-alien>" "alien" }
{ "alien-signed-cell" "alien" }
{ "set-alien-signed-cell" "alien" }
{ "alien-unsigned-cell" "alien" }
{ "set-alien-unsigned-cell" "alien" }
{ "alien-signed-8" "alien" }
{ "set-alien-signed-8" "alien" }
{ "alien-unsigned-8" "alien" }
{ "set-alien-unsigned-8" "alien" }
{ "alien-signed-4" "alien" }
{ "set-alien-signed-4" "alien" }
{ "alien-unsigned-4" "alien" }
{ "set-alien-unsigned-4" "alien" }
{ "alien-signed-2" "alien" }
{ "set-alien-signed-2" "alien" }
{ "alien-unsigned-2" "alien" }
{ "set-alien-unsigned-2" "alien" }
{ "alien-signed-1" "alien" }
{ "set-alien-signed-1" "alien" }
{ "alien-unsigned-1" "alien" }
{ "set-alien-unsigned-1" "alien" }
{ "alien-float" "alien" }
{ "set-alien-float" "alien" }
{ "alien-double" "alien" }
{ "set-alien-double" "alien" }
{ "alien-cell" "alien" }
{ "set-alien-cell" "alien" }
{ "alien-signed-cell" "alien.accessors" }
{ "set-alien-signed-cell" "alien.accessors" }
{ "alien-unsigned-cell" "alien.accessors" }
{ "set-alien-unsigned-cell" "alien.accessors" }
{ "alien-signed-8" "alien.accessors" }
{ "set-alien-signed-8" "alien.accessors" }
{ "alien-unsigned-8" "alien.accessors" }
{ "set-alien-unsigned-8" "alien.accessors" }
{ "alien-signed-4" "alien.accessors" }
{ "set-alien-signed-4" "alien.accessors" }
{ "alien-unsigned-4" "alien.accessors" }
{ "set-alien-unsigned-4" "alien.accessors" }
{ "alien-signed-2" "alien.accessors" }
{ "set-alien-signed-2" "alien.accessors" }
{ "alien-unsigned-2" "alien.accessors" }
{ "set-alien-unsigned-2" "alien.accessors" }
{ "alien-signed-1" "alien.accessors" }
{ "set-alien-signed-1" "alien.accessors" }
{ "alien-unsigned-1" "alien.accessors" }
{ "set-alien-unsigned-1" "alien.accessors" }
{ "alien-float" "alien.accessors" }
{ "set-alien-float" "alien.accessors" }
{ "alien-double" "alien.accessors" }
{ "set-alien-double" "alien.accessors" }
{ "alien-cell" "alien.accessors" }
{ "set-alien-cell" "alien.accessors" }
{ "alien>char-string" "alien" }
{ "string>char-alien" "alien" }
{ "alien>u16-string" "alien" }
@ -590,8 +596,8 @@ builtins get num-tags get tail f union-class define-class
{ "alien-address" "alien" }
{ "slot" "slots.private" }
{ "set-slot" "slots.private" }
{ "char-slot" "strings.private" }
{ "set-char-slot" "strings.private" }
{ "string-nth" "strings.private" }
{ "set-string-nth" "strings.private" }
{ "resize-array" "arrays" }
{ "resize-string" "strings" }
{ "<array>" "arrays" }

2
core/bootstrap/stage2.factor
View File

@ -12,7 +12,7 @@ IN: bootstrap.stage2
! you can see what went wrong, instead of dealing with a
! fep
[
vm file-name windows? [ >lower ".exe" ?tail drop ] when
vm file-name windows? [ "." split1 drop ] when
".image" append "output-image" set-global
"math tools help compiler ui ui.tools io" "include" set-global

6
core/byte-arrays/byte-arrays.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel kernel.private alien sequences sequences.private
math ;
USING: kernel kernel.private alien.accessors sequences
sequences.private math ;
IN: byte-arrays
M: byte-array clone (clone) ;
@ -19,5 +19,3 @@ M: byte-array resize
resize-byte-array ;
INSTANCE: byte-array sequence
INSTANCE: byte-array simple-c-ptr
INSTANCE: byte-array c-ptr

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

@ -10,7 +10,7 @@ IN: compiler.constants
! These constants must match vm/layouts.h
: header-offset object tag-number neg ;
: float-offset 8 float tag-number - ;
: string-offset 3 bootstrap-cells object tag-number - ;
: string-offset 4 bootstrap-cells object tag-number - ;
: profile-count-offset 7 bootstrap-cells object tag-number - ;
: byte-array-offset 2 bootstrap-cells object tag-number - ;
: alien-offset 3 bootstrap-cells object tag-number - ;

26
core/compiler/test/intrinsics.factor
View File

@ -1,10 +1,10 @@
IN: temporary
USING: arrays compiler kernel kernel.private math
math.constants math.private sequences strings tools.test words
continuations sequences.private hashtables.private byte-arrays
strings.private system random layouts vectors.private
sbufs.private strings.private slots.private alien alien.c-types
alien.syntax namespaces libc combinators.private ;
USING: arrays compiler kernel kernel.private math math.constants
math.private sequences strings tools.test words continuations
sequences.private hashtables.private byte-arrays strings.private
system random layouts vectors.private sbufs.private
strings.private slots.private alien alien.accessors
alien.c-types alien.syntax namespaces libc combinators.private ;
! Make sure that intrinsic ops compile to correct code.
[ ] [ 1 [ drop ] compile-call ] unit-test
@ -36,13 +36,13 @@ alien.syntax namespaces libc combinators.private ;
! Write barrier hits on the wrong value were causing segfaults
[ -3 ] [ -3 1 2 [ 2array [ 3 set-slot ] keep ] compile-call second ] unit-test
[ CHAR: b ] [ 1 "abc" [ char-slot ] compile-call ] unit-test
[ CHAR: b ] [ 1 [ "abc" char-slot ] compile-call ] unit-test
[ CHAR: b ] [ [ 1 "abc" char-slot ] compile-call ] unit-test
[ "axc" ] [ CHAR: x 1 "abc" [ [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test
[ "axc" ] [ CHAR: x 1 [ "abc" [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test
[ "axc" ] [ CHAR: x [ 1 "abc" [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test
! [ CHAR: b ] [ 1 "abc" [ char-slot ] compile-call ] unit-test
! [ CHAR: b ] [ 1 [ "abc" char-slot ] compile-call ] unit-test
! [ CHAR: b ] [ [ 1 "abc" char-slot ] compile-call ] unit-test
!
! [ "axc" ] [ CHAR: x 1 "abc" [ [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test
! [ "axc" ] [ CHAR: x 1 [ "abc" [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test
! [ "axc" ] [ CHAR: x [ 1 "abc" [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test
[ ] [ [ 0 getenv ] compile-call drop ] unit-test
[ ] [ 1 getenv [ 1 setenv ] compile-call ] unit-test

2
core/compiler/test/redefine.factor
View File

@ -249,4 +249,4 @@ DEFER: defer-redefine-test-2
[ ] [ "IN: temporary : defer-redefine-test-1 2 ;" eval ] unit-test
[ 1 ] [ defer-redefine-test-2 ] unit-test
[ 2 1 ] [ defer-redefine-test-2 ] unit-test

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

@ -2,8 +2,8 @@
USING: arrays compiler kernel kernel.private math
hashtables.private math.private namespaces sequences
sequences.private tools.test namespaces.private slots.private
combinators.private byte-arrays alien layouts words definitions
compiler.units ;
combinators.private byte-arrays alien alien.accessors layouts
words definitions compiler.units ;
IN: temporary
! Oops!

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

@ -1,6 +1,6 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays cpu.ppc.assembler
USING: alien alien.accessors alien.c-types arrays cpu.ppc.assembler
cpu.ppc.architecture cpu.ppc.allot cpu.architecture kernel
kernel.private math math.private namespaces sequences words
generic quotations byte-arrays hashtables hashtables.private
@ -93,30 +93,6 @@ IN: cpu.ppc.intrinsics
}
} define-intrinsics
: (%char-slot)
"offset" operand "n" operand 2 SRAWI
"offset" operand dup "obj" operand ADD ;
\ char-slot [
(%char-slot)
"out" operand "offset" operand string-offset LHZ
"out" operand dup %tag-fixnum
] H{
{ +input+ { { f "n" } { f "obj" } } }
{ +scratch+ { { f "out" } { f "offset" } } }
{ +output+ { "out" } }
} define-intrinsic
\ set-char-slot [
(%char-slot)
"val" operand dup %untag-fixnum
"val" operand "offset" operand string-offset STH
] H{
{ +input+ { { f "val" } { f "n" } { f "obj" } } }
{ +scratch+ { { f "offset" } } }
{ +clobber+ { "val" } }
} define-intrinsic
: fixnum-register-op ( op -- pair )
[ "out" operand "y" operand "x" operand ] swap add H{
{ +input+ { { f "x" } { f "y" } } }

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

@ -1,12 +1,13 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays cpu.x86.assembler cpu.x86.allot
cpu.x86.architecture cpu.architecture kernel kernel.private math
math.private namespaces quotations sequences
USING: alien alien.accessors arrays cpu.x86.assembler
cpu.x86.allot cpu.x86.architecture cpu.architecture kernel
kernel.private math math.private namespaces quotations sequences
words generic byte-arrays hashtables hashtables.private
generator generator.registers generator.fixup sequences.private
sbufs sbufs.private vectors vectors.private layouts system
tuples.private strings.private slots.private compiler.constants ;
tuples.private strings.private slots.private compiler.constants
;
IN: cpu.x86.intrinsics
! Type checks
@ -153,34 +154,6 @@ IN: cpu.x86.intrinsics
: small-reg-16 BX ; inline
: small-reg-32 EBX ; inline
\ char-slot [
small-reg PUSH
"n" operand 2 SHR
small-reg dup XOR
"obj" operand "n" operand ADD
small-reg-16 "obj" operand string-offset [+] MOV
small-reg %tag-fixnum
"obj" operand small-reg MOV
small-reg POP
] H{
{ +input+ { { f "n" } { f "obj" } } }
{ +output+ { "obj" } }
{ +clobber+ { "obj" "n" } }
} define-intrinsic
\ set-char-slot [
small-reg PUSH
"val" operand %untag-fixnum
"slot" operand 2 SHR
"obj" operand "slot" operand ADD
small-reg "val" operand MOV
"obj" operand string-offset [+] small-reg-16 MOV
small-reg POP
] H{
{ +input+ { { f "val" } { f "slot" } { f "obj" } } }
{ +clobber+ { "val" "slot" "obj" } }
} define-intrinsic
! Fixnums
: fixnum-op ( op hash -- pair )
>r [ "x" operand "y" operand ] swap add r> 2array ;

10
core/cpu/x86/sse2/sse2.factor Normal file → Executable file
View File

@ -1,10 +1,10 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays cpu.x86.assembler cpu.x86.architecture
cpu.x86.intrinsics generic kernel kernel.private math
math.private memory namespaces sequences words generator
generator.registers cpu.architecture math.floats.private layouts
quotations ;
USING: alien alien.accessors arrays cpu.x86.assembler
cpu.x86.architecture cpu.x86.intrinsics generic kernel
kernel.private math math.private memory namespaces sequences
words generator generator.registers cpu.architecture
math.floats.private layouts quotations ;
IN: cpu.x86.sse2
: define-float-op ( word op -- )

4
core/float-arrays/float-arrays.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel kernel.private alien sequences
USING: kernel kernel.private alien.accessors sequences
sequences.private math math.private ;
IN: float-arrays
@ -33,8 +33,6 @@ M: float-array resize
resize-float-array ;
INSTANCE: float-array sequence
INSTANCE: float-array simple-c-ptr
INSTANCE: float-array c-ptr
: 1float-array ( x -- array ) 1 swap <float-array> ; flushable

4
core/growable/growable-docs.factor Normal file → Executable file
View File

@ -21,7 +21,7 @@ HELP: set-fill
{ $values { "n" "a new fill pointer" } { "seq" "a resizable sequence" } }
{ $contract "Sets the fill pointer (number of occupied elements in the underlying storage) of a resizable sequence." }
{ $side-effects "seq" }
{ $warning "This word is in the " { $vocab-link "sequences.private" } " vocabulary because it is not safe. Changing the fill pointer to a negative value, or a value higher than the underlying sequence length can lead to memory corruption. User code should use " { $link set-length } " instead." } ;
{ $warning "This word is in the " { $vocab-link "growable.private" } " vocabulary because it is not safe. Changing the fill pointer to a negative value, or a value higher than the underlying sequence length can lead to memory corruption. User code should use " { $link set-length } " instead." } ;
HELP: underlying
{ $values { "seq" "a resizable sequence" } { "underlying" "the underlying sequence" } }
@ -30,7 +30,7 @@ HELP: underlying
HELP: set-underlying
{ $values { "underlying" "a sequence" } { "seq" "a resizable sequence" } }
{ $contract "Modifies the underlying storage of a resizable sequence." }
{ $warning "This word is in the " { $vocab-link "sequences.private" } " vocabulary because it is not safe. Setting an underlying sequence shorter than the fill pointer can lead to memory corruption." } ;
{ $warning "This word is in the " { $vocab-link "growable.private" } " vocabulary because it is not safe. Setting an underlying sequence shorter than the fill pointer can lead to memory corruption." } ;
HELP: capacity
{ $values { "seq" "a vector or string buffer" } { "n" "the capacity of the sequence" } }

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

@ -1,15 +1,16 @@
! Copyright (C) 2004, 2007 Slava Pestov.
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays bit-arrays byte-arrays classes
combinators.private continuations.private effects float-arrays
generic hashtables hashtables.private inference.state
inference.backend inference.dataflow io io.backend io.files
io.files.private io.streams.c kernel kernel.private math
math.private memory namespaces namespaces.private parser
prettyprint quotations quotations.private sbufs sbufs.private
sequences sequences.private slots.private strings
strings.private system threads.private tuples tuples.private
vectors vectors.private words words.private assocs inspector ;
USING: alien alien.accessors arrays bit-arrays byte-arrays
classes combinators.private continuations.private effects
float-arrays generic hashtables hashtables.private
inference.state inference.backend inference.dataflow io
io.backend io.files io.files.private io.streams.c kernel
kernel.private math math.private memory namespaces
namespaces.private parser prettyprint quotations
quotations.private sbufs sbufs.private sequences
sequences.private slots.private strings strings.private system
threads.private tuples tuples.private vectors vectors.private
words words.private assocs inspector ;
IN: inference.known-words
! Shuffle words
@ -480,10 +481,10 @@ t over set-effect-terminated?
\ set-slot { object object fixnum } { } <effect> "inferred-effect" set-word-prop
\ char-slot { fixnum object } { fixnum } <effect> "inferred-effect" set-word-prop
\ char-slot make-flushable
\ string-nth { fixnum string } { fixnum } <effect> "inferred-effect" set-word-prop
\ string-nth make-flushable
\ set-char-slot { fixnum fixnum object } { } <effect> "inferred-effect" set-word-prop
\ set-string-nth { fixnum fixnum string } { } <effect> "inferred-effect" set-word-prop
\ resize-array { integer array } { array } <effect> "inferred-effect" set-word-prop
\ resize-array make-flushable

4
core/io/binary/binary-tests.factor Normal file → Executable file
View File

@ -1,8 +1,8 @@
USING: io.binary tools.test ;
IN: temporary
[ "\0\0\u0004\u00d2" ] [ 1234 4 >be ] unit-test
[ "\u00d2\u0004\0\0" ] [ 1234 4 >le ] unit-test
[ "\0\0\u000004\u0000d2" ] [ 1234 4 >be ] unit-test
[ "\u0000d2\u000004\0\0" ] [ 1234 4 >le ] unit-test
[ 1234 ] [ 1234 4 >be be> ] unit-test
[ 1234 ] [ 1234 4 >le le> ] unit-test

4
core/io/encodings/encodings.factor Normal file → Executable file
View File

@ -18,8 +18,8 @@ SYMBOL: begin
over push 0 begin ;
: finish-decoding ( buf ch state -- str )
begin eq? [ decode-error ] unless drop { } like ;
begin eq? [ decode-error ] unless drop "" like ;
: decode ( seq quot -- str )
>r [ length <vector> 0 begin ] keep r> each
>r [ length <sbuf> 0 begin ] keep r> each
finish-decoding ; inline

20
core/io/utf16/utf16-tests.factor Normal file → Executable file
View File

@ -1,15 +1,15 @@
USING: tools.test io.utf16 ;
[ { CHAR: x } ] [ { 0 CHAR: x } decode-utf16be ] unit-test
[ { HEX: 1D11E } ] [ { HEX: D8 HEX: 34 HEX: DD HEX: 1E } decode-utf16be ] unit-test
[ { BIN: 11011111 CHAR: q } decode-utf16be ] unit-test-fails
[ { BIN: 11011011 CHAR: x BIN: 11011011 CHAR: x } decode-utf16be ] unit-test-fails
[ { CHAR: x } ] [ { 0 CHAR: x } decode-utf16be >array ] unit-test
[ { HEX: 1D11E } ] [ { HEX: D8 HEX: 34 HEX: DD HEX: 1E } decode-utf16be >array ] unit-test
[ { BIN: 11011111 CHAR: q } decode-utf16be >array ] unit-test-fails
[ { BIN: 11011011 CHAR: x BIN: 11011011 CHAR: x } decode-utf16be >array ] unit-test-fails
[ B{ 0 120 216 52 221 30 } ] [ { CHAR: x HEX: 1d11e } encode-utf16be ] unit-test
[ B{ 0 120 216 52 221 30 } ] [ { CHAR: x HEX: 1d11e } encode-utf16be >array ] unit-test
[ { CHAR: x } ] [ { CHAR: x 0 } decode-utf16le ] unit-test
[ { 119070 } ] [ { HEX: 34 HEX: D8 HEX: 1E HEX: DD } decode-utf16le ] unit-test
[ { 0 BIN: 11011111 } decode-utf16le ] unit-test-fails
[ { 0 BIN: 11011011 0 0 } decode-utf16le ] unit-test-fails
[ { CHAR: x } ] [ { CHAR: x 0 } decode-utf16le >array ] unit-test
[ { 119070 } ] [ { HEX: 34 HEX: D8 HEX: 1E HEX: DD } decode-utf16le >array ] unit-test
[ { 0 BIN: 11011111 } decode-utf16le >array ] unit-test-fails
[ { 0 BIN: 11011011 0 0 } decode-utf16le >array ] unit-test-fails
[ B{ 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } encode-utf16le ] unit-test
[ B{ 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } encode-utf16le >array ] unit-test

1
core/io/utf16/utf16.factor
View File

@ -110,4 +110,3 @@ SYMBOL: quad3
{ [ utf16be? ] [ decode-utf16be ] }
{ [ t ] [ decode-error ] }
} cond ;

34
core/math/parser/parser.factor Normal file → Executable file
View File

@ -1,7 +1,7 @@
! Copyright (C) 2004, 2007 Slava Pestov.
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math.private namespaces sequences strings arrays
combinators splitting math ;
combinators splitting math assocs ;
IN: math.parser
DEFER: base>
@ -11,12 +11,30 @@ DEFER: base>
2dup and [ / ] [ 2drop f ] if ;
: digit> ( ch -- n )
{
{ [ dup digit? ] [ CHAR: 0 - ] }
{ [ dup letter? ] [ CHAR: a - 10 + ] }
{ [ dup LETTER? ] [ CHAR: A - 10 + ] }
{ [ t ] [ drop f ] }
} cond ;
H{
{ CHAR: 0 0 }
{ CHAR: 1 1 }
{ CHAR: 2 2 }
{ CHAR: 3 3 }
{ CHAR: 4 4 }
{ CHAR: 5 5 }
{ CHAR: 6 6 }
{ CHAR: 7 7 }
{ CHAR: 8 8 }
{ CHAR: 9 9 }
{ CHAR: A 10 }
{ CHAR: B 11 }
{ CHAR: C 12 }
{ CHAR: D 13 }
{ CHAR: E 14 }
{ CHAR: F 15 }
{ CHAR: a 10 }
{ CHAR: b 11 }
{ CHAR: c 12 }
{ CHAR: d 13 }
{ CHAR: e 14 }
{ CHAR: f 15 }
} at ;
: digits>integer ( radix seq -- n )
0 rot [ swapd * + ] curry reduce ;

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

@ -1,13 +1,13 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: optimizer.math
USING: alien arrays generic hashtables kernel assocs math
math.private kernel.private sequences words parser
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 generic.standard system ;
combinators splitting layouts math.parser classes generic.math
optimizer.pattern-match optimizer.backend optimizer.def-use
generic.standard system ;
{ + bignum+ float+ fixnum+fast } {
{ { number 0 } [ drop ] }

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

@ -8,14 +8,14 @@ IN: temporary
[ 1 CHAR: a ]
[ 0 "abcd" next-char ] unit-test
[ 6 CHAR: \s ]
[ 1 "\\u0020hello" next-escape ] unit-test
[ 8 CHAR: \s ]
[ 1 "\\u000020hello" next-escape ] unit-test
[ 2 CHAR: \n ]
[ 1 "\\nhello" next-escape ] unit-test
[ 6 CHAR: \s ]
[ 0 "\\u0020hello" next-char ] unit-test
[ 8 CHAR: \s ]
[ 0 "\\u000020hello" next-char ] unit-test
[ 1 [ 2 [ 3 ] 4 ] 5 ]
[ "1\n[\n2\n[\n3\n]\n4\n]\n5" eval ]
@ -46,15 +46,13 @@ IN: temporary
! Test escapes
[ " " ]
[ "\"\\u0020\"" eval ]
[ "\"\\u000020\"" eval ]
unit-test
[ "'" ]
[ "\"\\u0027\"" eval ]
[ "\"\\u000027\"" eval ]
unit-test
[ "\\u123" eval ] unit-test-fails
! Test EOL comments in multiline strings.
[ "Hello" ] [ "#! This calls until-eol.\n\"Hello\"" eval ] unit-test

14
core/parser/parser.factor Normal file → Executable file
View File

@ -1,4 +1,4 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays definitions generic assocs kernel math
namespaces prettyprint sequences strings vectors words
@ -54,8 +54,9 @@ t parser-notes set-global
0 over set-lexer-column
dup lexer-line 1+ swap set-lexer-line ;
: skip ( i seq quot -- n )
over >r find* drop
: skip ( i seq ? -- n )
over >r
[ swap CHAR: \s eq? xor ] curry find* drop
[ r> drop ] [ r> length ] if* ; inline
: change-column ( lexer quot -- )
@ -66,14 +67,13 @@ t parser-notes set-global
GENERIC: skip-blank ( lexer -- )
M: lexer skip-blank ( lexer -- )
[ [ blank? not ] skip ] change-column ;
[ t skip ] change-column ;
GENERIC: skip-word ( lexer -- )
M: lexer skip-word ( lexer -- )
[
2dup nth CHAR: " =
[ drop 1+ ] [ [ blank? ] skip ] if
2dup nth CHAR: " = [ drop 1+ ] [ f skip ] if
] change-column ;
: still-parsing? ( lexer -- ? )
@ -119,7 +119,7 @@ M: bad-escape summary drop "Bad escape code" ;
: next-escape ( m str -- n ch )
2dup nth CHAR: u =
[ >r 1+ dup 4 + tuck r> subseq hex> ]
[ >r 1+ dup 6 + tuck r> subseq hex> ]
[ over 1+ -rot nth escape ] if ;
: next-char ( m str -- n ch )

2
core/prettyprint/backend/backend-docs.factor Normal file → Executable file
View File

@ -20,7 +20,7 @@ HELP: ch>ascii-escape
HELP: ch>unicode-escape
{ $values { "ch" "a character" } { "str" string } }
{ $description "Converts a character to a Unicode escape code (" { $snippet "\\u1234"} ")." } ;
{ $description "Converts a character to a Unicode escape code (" { $snippet "\\u123456"} ")." } ;
HELP: unparse-ch
{ $values { "ch" "a character" } }

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

@ -58,24 +58,17 @@ M: f pprint* drop \ f pprint-word ;
! Strings
: ch>ascii-escape ( ch -- str )
H{
{ CHAR: \e "\\e" }
{ CHAR: \n "\\n" }
{ CHAR: \r "\\r" }
{ CHAR: \t "\\t" }
{ CHAR: \0 "\\0" }
{ CHAR: \\ "\\\\" }
{ CHAR: \" "\\\"" }
{ CHAR: \e CHAR: \\e }
{ CHAR: \n CHAR: \\n }
{ CHAR: \r CHAR: \\r }
{ CHAR: \t CHAR: \\t }
{ CHAR: \0 CHAR: \\0 }
{ CHAR: \\ CHAR: \\\\ }
{ CHAR: \" CHAR: \\\" }
} at ;
: ch>unicode-escape ( ch -- str )
>hex 4 CHAR: 0 pad-left "\\u" swap append ;
: unparse-ch ( ch -- )
dup quotable? [
,
] [
dup ch>ascii-escape [ ] [ ch>unicode-escape ] ?if %
] if ;
dup ch>ascii-escape [ ] [ ] ?if , ;
: do-string-limit ( str -- trimmed )
string-limit get [

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

@ -21,8 +21,8 @@ IN: temporary
[ "hello\\backslash" unparse ]
unit-test
[ "\"\\u1234\"" ]
[ "\u1234" unparse ]
[ "\"\\u123456\"" ]
[ "\u123456" unparse ]
unit-test
[ "\"\\e\"" ]

2
core/sbufs/sbufs.factor
View File

@ -14,7 +14,7 @@ PRIVATE>
: <sbuf> ( n -- sbuf ) 0 <string> 0 string>sbuf ; inline
M: sbuf set-nth-unsafe
underlying >r >r >fixnum r> >fixnum r> set-char-slot ;
underlying >r >r >fixnum r> >fixnum r> set-string-nth ;
M: sbuf new drop [ 0 <string> ] keep >fixnum string>sbuf ;

1
core/sbufs/tags.txt
View File

@ -1 +1,2 @@
text
collections

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

@ -151,7 +151,7 @@ unit-test
[ 5 ] [ 1 >bignum { 1 5 7 } nth-unsafe ] unit-test
[ 5 ] [ 1 >bignum { 1 5 7 } nth-unsafe ] unit-test
[ 5 ] [ 1 >bignum "\u0001\u0005\u0007" nth-unsafe ] unit-test
[ 5 ] [ 1 >bignum "\u000001\u000005\u000007" nth-unsafe ] unit-test
[ SBUF" before&after" ] [
"&" 6 11 SBUF" before and after" [ replace-slice ] keep
@ -235,12 +235,12 @@ unit-test
[ 11 10 nth ] unit-test-fails
[ -1./0. 0 delete-nth ] unit-test-fails
[ "" ] [ "" [ blank? ] trim ] unit-test
[ "" ] [ "" [ blank? ] left-trim ] unit-test
[ "" ] [ "" [ blank? ] right-trim ] unit-test
[ "" ] [ " " [ blank? ] left-trim ] unit-test
[ "" ] [ " " [ blank? ] right-trim ] unit-test
[ "asdf" ] [ " asdf " [ blank? ] trim ] unit-test
[ "asdf " ] [ " asdf " [ blank? ] left-trim ] unit-test
[ " asdf" ] [ " asdf " [ blank? ] right-trim ] unit-test
[ "" ] [ "" [ CHAR: \s = ] trim ] unit-test
[ "" ] [ "" [ CHAR: \s = ] left-trim ] unit-test
[ "" ] [ "" [ CHAR: \s = ] right-trim ] unit-test
[ "" ] [ " " [ CHAR: \s = ] left-trim ] unit-test
[ "" ] [ " " [ CHAR: \s = ] right-trim ] unit-test
[ "asdf" ] [ " asdf " [ CHAR: \s = ] trim ] unit-test
[ "asdf " ] [ " asdf " [ CHAR: \s = ] left-trim ] unit-test
[ " asdf" ] [ " asdf " [ CHAR: \s = ] right-trim ] unit-test

81
core/strings/strings-docs.factor
View File

@ -4,7 +4,11 @@ sbufs math ;
IN: strings
ARTICLE: "strings" "Strings"
"A string is a fixed-size mutable sequence of characters. The literal syntax is covered in " { $link "syntax-strings" } "."
"A string is a fixed-size mutable sequence of Unicode 5.0 code points."
$nl
"Characters are not a first-class type; they are simply represented as integers between 0 and 16777216 (2^24). Only characters up to 2097152 (2^21) have a defined meaning in Unicode."
$nl
"String literal syntax is covered in " { $link "syntax-strings" } "."
$nl
"String words are found in the " { $vocab-link "strings" } " vocabulary."
$nl
@ -16,28 +20,25 @@ $nl
{ $subsection <string> }
"Creating a string from a single character:"
{ $subsection 1string }
"Characters are not a first-class type; they are simply represented as integers between 0 and 65535. A few words operate on characters:"
{ $subsection blank? }
{ $subsection letter? }
{ $subsection LETTER? }
{ $subsection digit? }
{ $subsection printable? }
{ $subsection control? }
{ $subsection quotable? }
{ $subsection ch>lower }
{ $subsection ch>upper } ;
"Since strings are sequences, basic string manipulation can be performed using sequence operations (" { $link "sequences" } "). More advanced functionality can be found in other vocabularies, including but not limited to:"
{ $list
{ { $vocab-link "ascii" } " - traditional ASCII character classes" }
{ { $vocab-link "unicode" } " - Unicode 5.0-aware character classes, case conversion, word breaks, ..." }
{ { $vocab-link "regexp" } " - regular expressions" }
{ { $vocab-link "peg" } " - parser expression grammars" }
} ;
ABOUT: "strings"
HELP: string
{ $description "The class of fixed-length character strings. See " { $link "syntax-strings" } " for syntax and " { $link "strings" } " for general information." } ;
HELP: char-slot ( n string -- ch )
HELP: string-nth ( n string -- ch )
{ $values { "n" fixnum } { "string" string } { "ch" "the character at the " { $snippet "n" } "th index" } }
{ $description "Unsafe string accessor, used to define " { $link nth } " on strings." }
{ $warning "This word is in the " { $vocab-link "strings.private" } " vocabulary because it does not perform type or bounds checking. User code should call " { $link nth } " instead." } ;
HELP: set-char-slot ( ch n string -- )
HELP: set-string-nth ( ch n string -- )
{ $values { "ch" "a character" } { "n" fixnum } { "string" string } }
{ $description "Unsafe string mutator, used to define " { $link set-nth } " on strings." }
{ $warning "This word is in the " { $vocab-link "strings.private" } " vocabulary because it does not perform type or bounds checking. User code should call " { $link set-nth } " instead." } ;
@ -46,58 +47,6 @@ HELP: <string> ( n ch -- string )
{ $values { "n" "a positive integer specifying string length" } { "ch" "an initial character" } { "string" string } }
{ $description "Creates a new string with the given length and all characters initially set to " { $snippet "ch" } "." } ;
HELP: blank?
{ $values { "ch" "a character" } { "?" "a boolean" } }
{ $description "Tests for an ASCII whitespace character." } ;
HELP: letter?
{ $values { "ch" "a character" } { "?" "a boolean" } }
{ $description "Tests for a lowercase alphabet ASCII character." } ;
HELP: LETTER?
{ $values { "ch" "a character" } { "?" "a boolean" } }
{ $description "Tests for a uppercase alphabet ASCII character." } ;
HELP: digit?
{ $values { "ch" "a character" } { "?" "a boolean" } }
{ $description "Tests for an ASCII decimal digit character." } ;
HELP: Letter?
{ $values { "ch" "a character" } { "?" "a boolean" } }
{ $description "Tests for an ASCII alphabet character, both upper and lower case." } ;
HELP: alpha?
{ $values { "ch" "a character" } { "?" "a boolean" } }
{ $description "Tests for an alphanumeric ASCII character." } ;
HELP: printable?
{ $values { "ch" "a character" } { "?" "a boolean" } }
{ $description "Tests for a printable ASCII character." } ;
HELP: control?
{ $values { "ch" "a character" } { "?" "a boolean" } }
{ $description "Tests for an ASCII control character." } ;
HELP: quotable?
{ $values { "ch" "a character" } { "?" "a boolean" } }
{ $description "Tests for characters which may appear in a Factor string literal without escaping." } ;
HELP: ch>lower
{ $values { "ch" "a character" } { "lower" "a character" } }
{ $description "Converts a character to lowercase." } ;
HELP: ch>upper
{ $values { "ch" "a character" } { "upper" "a character" } }
{ $description "Converts a character to uppercase." } ;
HELP: >lower
{ $values { "str" string } { "lower" string } }
{ $description "Converts a string to lowercase." } ;
HELP: >upper
{ $values { "str" string } { "upper" string } }
{ $description "Converts a string to uppercase." } ;
HELP: 1string
{ $values { "ch" "a character"} { "str" string } }
{ $description "Outputs a string of one character." } ;
@ -109,4 +58,4 @@ HELP: >string
HELP: resize-string ( n str -- newstr )
{ $values { "n" "a non-negative integer" } { "str" string } { "newstr" string } }
{ $description "Creates a new string " { $snippet "n" } " characters long The contents of the existing string are copied into the new string; if the new string is shorter, only an initial segment is copied, and if the new string is longer the remaining space is filled with " { $snippet "\\u0000" } "." } ;
{ $description "Creates a new string " { $snippet "n" } " characters long The contents of the existing string are copied into the new string; if the new string is shorter, only an initial segment is copied, and if the new string is longer the remaining space is filled with " { $snippet "\\u000000" } "." } ;

48
core/strings/strings-tests.factor Normal file → Executable file
View File

@ -1,5 +1,5 @@
USING: continuations kernel math namespaces strings sbufs
tools.test sequences vectors ;
tools.test sequences vectors arrays ;
IN: temporary
[ CHAR: b ] [ 1 >bignum "abc" nth ] unit-test
@ -28,23 +28,11 @@ IN: temporary
[ "end" ] [ "Beginning and end" 14 tail ] unit-test
[ t ] [ CHAR: a letter? ] unit-test
[ f ] [ CHAR: A letter? ] unit-test
[ f ] [ CHAR: a LETTER? ] unit-test
[ t ] [ CHAR: A LETTER? ] unit-test
[ t ] [ CHAR: 0 digit? ] unit-test
[ f ] [ CHAR: x digit? ] unit-test
[ t ] [ "abc" "abd" <=> 0 < ] unit-test
[ t ] [ "z" "abd" <=> 0 > ] unit-test
[ f ] [ [ 0 10 "hello" subseq ] catch not ] unit-test
[ 4 ] [
0 "There are Four Upper Case characters"
[ LETTER? [ 1+ ] when ] each
] unit-test
[ "Replacing+spaces+with+plus" ]
[
"Replacing spaces with plus"
@ -66,3 +54,37 @@ unit-test
! Random tester found this
[ { "kernel-error" 3 12 -7 } ]
[ [ 2 -7 resize-string ] catch ] unit-test
! Make sure 24-bit strings work
"hello world" "s" set
[ ] [ HEX: 1234 1 "s" get set-nth ] unit-test
[ ] [ HEX: 4321 3 "s" get set-nth ] unit-test
[ ] [ HEX: 654321 5 "s" get set-nth ] unit-test
[
{
CHAR: h
HEX: 1234
CHAR: l
HEX: 4321
CHAR: o
HEX: 654321
CHAR: w
CHAR: o
CHAR: r
CHAR: l
CHAR: d
}
] [
"s" get >array
] unit-test
! Make sure we clear aux vector when storing octets
[ "\u123456hi" ] [ "ih\u123456" clone dup reverse-here ] unit-test
! Make sure aux vector is not shared
[ "\udeadbe" ] [
"\udeadbe" clone
CHAR: \u123456 over clone set-first
] unit-test

46
core/strings/strings.factor
View File

@ -1,14 +1,15 @@
! Copyright (C) 2003, 2007 Slava Pestov.
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math.private sequences kernel.private
math sequences.private slots.private ;
math sequences.private slots.private byte-arrays
alien.accessors ;
IN: strings
<PRIVATE
: string-hashcode 2 slot ; inline
: string-hashcode 3 slot ; inline
: set-string-hashcode 2 set-slot ; inline
: set-string-hashcode 3 set-slot ; inline
: reset-string-hashcode f swap set-string-hashcode ; inline
@ -29,43 +30,18 @@ M: string hashcode*
nip dup string-hashcode [ ]
[ dup rehash-string string-hashcode ] ?if ;
M: string nth-unsafe >r >fixnum r> char-slot ;
M: string nth-unsafe
>r >fixnum r> string-nth ;
M: string set-nth-unsafe
M: string set-nth-unsafe
dup reset-string-hashcode
>r >fixnum >r >fixnum r> r> set-char-slot ;
>r >fixnum >r >fixnum r> r> set-string-nth ;
M: string clone (clone) ;
M: string clone
(clone) dup string-aux clone over set-string-aux ;
M: string resize resize-string ;
! Characters
: blank? ( ch -- ? ) " \t\n\r" member? ; inline
: letter? ( ch -- ? ) CHAR: a CHAR: z between? ; inline
: LETTER? ( ch -- ? ) CHAR: A CHAR: Z between? ; inline
: digit? ( ch -- ? ) CHAR: 0 CHAR: 9 between? ; inline
: printable? ( ch -- ? ) CHAR: \s CHAR: ~ between? ; inline
: control? ( ch -- ? ) "\0\e\r\n\t\u0008\u007f" member? ; inline
: quotable? ( ch -- ? )
dup printable? [ "\"\\" member? not ] [ drop f ] if ; inline
: Letter? ( ch -- ? )
dup letter? [ drop t ] [ LETTER? ] if ; inline
: alpha? ( ch -- ? )
dup Letter? [ drop t ] [ digit? ] if ; inline
: ch>lower ( ch -- lower )
dup LETTER? [ HEX: 20 + ] when ; inline
: ch>upper ( ch -- upper )
dup letter? [ HEX: 20 - ] when ; inline
: >lower ( str -- lower ) [ ch>lower ] map ;
: >upper ( str -- upper ) [ ch>upper ] map ;
: 1string ( ch -- str ) 1 swap <string> ;
: >string ( seq -- str ) "" clone-like ;

1
core/strings/tags.txt
View File

@ -1 +1,2 @@
text
collections

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

@ -99,9 +99,9 @@ ARTICLE: "escape" "Character escape codes"
{ { $snippet "\\e" } "escape (ASCII 27)" }
{ { $snippet "\\\"" } { $snippet "\"" } }
}
"A Unicode character can be specified by its code number by writing " { $snippet "\\u" } " followed by a four-digit hexadecimal number. That is, the following two expressions are equivalent:"
"A Unicode character can be specified by its code number by writing " { $snippet "\\u" } " followed by a six-digit hexadecimal number. That is, the following two expressions are equivalent:"
{ $code
"CHAR: \\u0078"
"CHAR: \\u000078"
"78"
}
"While not useful for single characters, this syntax is also permitted inside strings." ;

0
core/syntax/tags.txt Executable file
View File

51
extra/ascii/ascii-docs.factor Executable file
View File

@ -0,0 +1,51 @@
USING: help.markup help.syntax ;
IN: ascii
HELP: blank?
{ $values { "ch" "a character" } { "?" "a boolean" } }
{ $description "Tests for an ASCII whitespace character." } ;
HELP: letter?
{ $values { "ch" "a character" } { "?" "a boolean" } }
{ $description "Tests for a lowercase alphabet ASCII character." } ;
HELP: LETTER?
{ $values { "ch" "a character" } { "?" "a boolean" } }
{ $description "Tests for a uppercase alphabet ASCII character." } ;
HELP: digit?
{ $values { "ch" "a character" } { "?" "a boolean" } }
{ $description "Tests for an ASCII decimal digit character." } ;
HELP: Letter?
{ $values { "ch" "a character" } { "?" "a boolean" } }
{ $description "Tests for an ASCII alphabet character, both upper and lower case." } ;
HELP: alpha?
{ $values { "ch" "a character" } { "?" "a boolean" } }
{ $description "Tests for an alphanumeric ASCII character." } ;
HELP: printable?
{ $values { "ch" "a character" } { "?" "a boolean" } }
{ $description "Tests for a printable ASCII character." } ;
HELP: control?
{ $values { "ch" "a character" } { "?" "a boolean" } }
{ $description "Tests for an ASCII control character." } ;
HELP: quotable?
{ $values { "ch" "a character" } { "?" "a boolean" } }
{ $description "Tests for characters which may appear in a Factor string literal without escaping." } ;
ARTICLE: "ascii" "ASCII character classes"
"Traditional ASCII character classes:"
{ $subsection blank? }
{ $subsection letter? }
{ $subsection LETTER? }
{ $subsection digit? }
{ $subsection printable? }
{ $subsection control? }
{ $subsection quotable? }
"Modern applications should use Unicode 5.0 instead (" { $vocab-link "unicode" } ")." ;
ABOUT: "ascii"

15
extra/ascii/ascii-tests.factor Normal file
View File

@ -0,0 +1,15 @@
IN: temporary
USING: ascii tools.test sequences kernel math ;
[ t ] [ CHAR: a letter? ] unit-test
[ f ] [ CHAR: A letter? ] unit-test
[ f ] [ CHAR: a LETTER? ] unit-test
[ t ] [ CHAR: A LETTER? ] unit-test
[ t ] [ CHAR: 0 digit? ] unit-test
[ f ] [ CHAR: x digit? ] unit-test
[ 4 ] [
0 "There are Four Upper Case characters"
[ LETTER? [ 1+ ] when ] each
] unit-test

26
extra/ascii/ascii.factor Executable file
View File

@ -0,0 +1,26 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: sequences math kernel ;
IN: ascii
: blank? ( ch -- ? ) " \t\n\r" member? ; inline
: letter? ( ch -- ? ) CHAR: a CHAR: z between? ; inline
: LETTER? ( ch -- ? ) CHAR: A CHAR: Z between? ; inline
: digit? ( ch -- ? ) CHAR: 0 CHAR: 9 between? ; inline
: printable? ( ch -- ? ) CHAR: \s CHAR: ~ between? ; inline
: control? ( ch -- ? )
"\0\e\r\n\t\u000008\u00007f" member? ; inline
: quotable? ( ch -- ? )
dup printable? [ "\"\\" member? not ] [ drop f ] if ; inline
: Letter? ( ch -- ? )
dup letter? [ drop t ] [ LETTER? ] if ; inline
: alpha? ( ch -- ? )
dup Letter? [ drop t ] [ digit? ] if ; inline

1
extra/ascii/authors.txt Executable file
View File

@ -0,0 +1 @@
Slava Pestov

1
extra/ascii/summary.txt Executable file
View File

@ -0,0 +1 @@
ASCII character classes

1
extra/ascii/tags.txt Executable file
View File

@ -0,0 +1 @@
text

2
extra/asn1/asn1-tests.factor Normal file → Executable file
View File

@ -1,7 +1,7 @@
USING: asn1 asn1.ldap io io.streams.string tools.test ;
[ 6 ] [
"\u0002\u0001\u0006" <string-reader> [ asn-syntax read-ber ] with-stream
"\u000002\u000001\u000006" <string-reader> [ asn-syntax read-ber ] with-stream
] unit-test
[ "testing" ] [

8
extra/cel-shading/cel-shading.factor
View File

@ -1,5 +1,5 @@
USING: arrays bunny combinators.lib io io.files kernel
math math.functions multiline
math math.functions multiline continuations debugger
opengl opengl.gl opengl-demo-support
sequences ui ui.gadgets ui.render ;
IN: cel-shading
@ -58,14 +58,14 @@ main()
<simple-gl-program> ;
M: cel-shading-gadget graft* ( gadget -- )
"2.0" { "GL_ARB_shader_objects" } require-gl-version-or-extensions
[ "2.0" { "GL_ARB_shader_objects" } require-gl-version-or-extensions
0.0 0.0 0.0 1.0 glClearColor
GL_CULL_FACE glEnable
GL_DEPTH_TEST glEnable
cel-shading-program swap set-cel-shading-gadget-program ;
cel-shading-program swap set-cel-shading-gadget-program ] [ ] [ :c ] cleanup ;
M: cel-shading-gadget ungraft* ( gadget -- )
cel-shading-gadget-program delete-gl-program ;
cel-shading-gadget-program [ delete-gl-program ] when* ;
: cel-shading-draw-setup ( gadget -- gadget )
[ demo-gadget-set-matrices ] keep

4
extra/concurrency/concurrency-docs.factor
View File

@ -127,7 +127,7 @@ ARTICLE: { "concurrency" "processes" } "Processes"
{ $code ": odd? ( n -- ? ) 2 mod 1 = ;\n1 self send 2 self send 3 self send\n\nreceive .\n => 1\n\n[ odd? ] receive-if .\n => 3\n\nreceive .\n => 2" } ;
ARTICLE: { "concurrency" "self" } "Self"
"A process can get access to its own process object using " { $link self } " so it can pass it to other processes. This allows the other processes to send messages back. A simple example of using this gets the current processes 'self' and spawns a process which sends a message to it. We then receive the message from the original process:"
"A process can get access to its own process object using " { $link self } " so it can pass it to other processes. This allows the other processes to send messages back. A simple example of using this gets the current process' 'self' and spawns a process which sends a message to it. We then receive the message from the original process:"
{ $code "self [ \"Hello!\" swap send ] spawn 2drop receive .\n => \"Hello!\"" } ;
ARTICLE: { "concurrency" "servers" } "Servers"
@ -150,7 +150,7 @@ ARTICLE: { "concurrency" "exceptions" } "Exceptions"
"Exceptions are only raised in the parent when the parent does a " { $link receive } " or " { $link receive-if } ". This is because the exception is sent from the child to the parent as a message." ;
ARTICLE: { "concurrency" "futures" } "Futures"
"A future is a placeholder for the result of a computation that is being calculated in a process. When the process has completed the computation the future can be queried to find out the result. If the computation has not completed when the future is queried them the process will block until the result is completed. <p>A future is created using " { $link future } ".\n\nThe quotation will be run in a spawned process, and a future object is immediately returned. This future object can be resolved using " { $link ?future } ".\n\nFutures are useful for starting calculations that take a long time to run but aren't needed until later in the process. When the process needs the value it can use '?future' to get the result or block until the result is available. For example:"
"A future is a placeholder for the result of a computation that is being calculated in a process. When the process has completed the computation the future can be queried to find out the result. If the computation has not completed when the future is queried them the process will block until the result is completed. A future is created using " { $link future } ".\n\nThe quotation will be run in a spawned process, and a future object is immediately returned. This future object can be resolved using " { $link ?future } ".\n\nFutures are useful for starting calculations that take a long time to run but aren't needed until later in the process. When the process needs the value it can use '?future' to get the result or block until the result is available. For example:"
{ $code "[ 30 fib ] future\n...do stuff...\n?future" } ;
ARTICLE: { "concurrency" "promises" } "Promises"

2
extra/cryptlib/streams/streams.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2007 Matthew Willis
! See http://factorcode.org/license.txt for BSD license.
USING: cryptlib cryptlib.libcl kernel alien sequences
USING: cryptlib cryptlib.libcl kernel alien sequences continuations
byte-arrays namespaces io.buffers math generic io strings
io.streams.lines io.streams.plain io.streams.duplex combinators
alien.c-types ;

12
extra/crypto/hmac/hmac-tests.factor Normal file → Executable file
View File

@ -1,11 +1,11 @@
USING: kernel io strings sequences namespaces math parser crypto.hmac tools.test ;
IN: temporary
[ "\u0092\u0094rz68\u00bb\u001c\u0013\u00f4\u008e\u00f8\u0015\u008b\u00fc\u009d" ] [ 16 11 <string> "Hi There" string>md5-hmac >string ] unit-test
[ "u\u000cx>j\u00b0\u00b5\u0003\u00ea\u00a8n1\n]\u00b78" ] [ "Jefe" "what do ya want for nothing?" string>md5-hmac >string ] unit-test
[ "V\u00be4R\u001d\u0014L\u0088\u00db\u00b8\u00c73\u00f0\u00e8\u00b3\u00f6" ] [ 16 HEX: aa <string> 50 HEX: dd <string> string>md5-hmac >string ] unit-test
[ "\u000092\u000094rz68\u0000bb\u00001c\u000013\u0000f4\u00008e\u0000f8\u000015\u00008b\u0000fc\u00009d" ] [ 16 11 <string> "Hi There" string>md5-hmac >string ] unit-test
[ "u\u00000cx>j\u0000b0\u0000b5\u000003\u0000ea\u0000a8n1\n]\u0000b78" ] [ "Jefe" "what do ya want for nothing?" string>md5-hmac >string ] unit-test
[ "V\u0000be4R\u00001d\u000014L\u000088\u0000db\u0000b8\u0000c73\u0000f0\u0000e8\u0000b3\u0000f6" ] [ 16 HEX: aa <string> 50 HEX: dd <string> string>md5-hmac >string ] unit-test
[ "g[\u000b:\eM\u00dfN\u0012Hr\u00dal/c+\u00fe\u00d9W\u00e9" ] [ 16 11 <string> "Hi There" string>sha1-hmac >string ] unit-test
[ "\u00ef\u00fc\u00dfj\u00e5\u00eb/\u00a2\u00d2t\u0016\u00d5\u00f1\u0084\u00df\u009c%\u009a|y" ] [ "Jefe" "what do ya want for nothing?" string>sha1-hmac >string ] unit-test
[ "\u00d70YM\u0016~5\u00d5\u0095o\u00d8\0=\r\u00b3\u00d3\u00f4m\u00c7\u00bb" ] [ 16 HEX: aa <string> 50 HEX: dd <string> string>sha1-hmac >string ] unit-test
[ "g[\u00000b:\eM\u0000dfN\u000012Hr\u0000dal/c+\u0000fe\u0000d9W\u0000e9" ] [ 16 11 <string> "Hi There" string>sha1-hmac >string ] unit-test
[ "\u0000ef\u0000fc\u0000dfj\u0000e5\u0000eb/\u0000a2\u0000d2t\u000016\u0000d5\u0000f1\u000084\u0000df\u00009c%\u00009a|y" ] [ "Jefe" "what do ya want for nothing?" string>sha1-hmac >string ] unit-test
[ "\u0000d70YM\u000016~5\u0000d5\u000095o\u0000d8\0=\r\u0000b3\u0000d3\u0000f4m\u0000c7\u0000bb" ] [ 16 HEX: aa <string> 50 HEX: dd <string> string>sha1-hmac >string ] unit-test

4
extra/crypto/sha1/sha1-tests.factor Normal file → Executable file
View File

@ -7,8 +7,8 @@ USING: arrays kernel math namespaces sequences tools.test crypto.sha1 ;
10 swap <array> concat string>sha1str ] unit-test
[
";\u009b\u00fd\u00cdK\u00a3^s\u00d0*\u00e3\\\u00b5\u0013<\u00e8wA\u00b2\u0083\u00d20\u00f1\u00e6\u00cc\u00d8\u001e\u009c\u0004\u00d7PT]\u00ce,\u0001\u0012\u0080\u0096\u0099"
";\u00009b\u0000fd\u0000cdK\u0000a3^s\u0000d0*\u0000e3\\\u0000b5\u000013<\u0000e8wA\u0000b2\u000083\u0000d20\u0000f1\u0000e6\u0000cc\u0000d8\u00001e\u00009c\u000004\u0000d7PT]\u0000ce,\u000001\u000012\u000080\u000096\u000099"
] [
"\u0066\u0053\u00f1\u000c\u001a\u00fa\u00b5\u004c\u0061\u00c8\u0025\u0075\u00a8\u004a\u00fe\u0030\u00d8\u00aa\u001a\u003a\u0096\u0096\u00b3\u0018\u0099\u0092\u00bf\u00e1\u00cb\u007f\u00a6\u00a7"
"\u000066\u000053\u0000f1\u00000c\u00001a\u0000fa\u0000b5\u00004c\u000061\u0000c8\u000025\u000075\u0000a8\u00004a\u0000fe\u000030\u0000d8\u0000aa\u00001a\u00003a\u000096\u000096\u0000b3\u000018\u000099\u000092\u0000bf\u0000e1\u0000cb\u00007f\u0000a6\u0000a7"
string>sha1-interleave
] unit-test

2
extra/documents/documents.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2006, 2007 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: arrays io kernel math models namespaces sequences strings
splitting io.streams.lines combinators ;
splitting io.streams.lines combinators unicode.categories ;
IN: documents
: +col ( loc n -- newloc ) >r first2 r> + 2array ;

5
extra/help/tutorial/tutorial.factor
View File

@ -1,6 +1,7 @@
USING: help.markup help.syntax ui.commands ui.operations
ui.tools.search ui.tools.workspace editors vocabs.loader
kernel sequences prettyprint tools.test strings ;
kernel sequences prettyprint tools.test strings
unicode.categories unicode.case ;
IN: help.tutorial
ARTICLE: "first-program-start" "Creating a vocabulary for your first program"
@ -134,7 +135,7 @@ $nl
{ $code "[ Letter? ] subset >lower" }
"This code starts with a string on the stack, removes non-alphabetical characters, and converts the result to lower case, leaving a new string on the stack. We put this code in a new word, and add the new word to " { $snippet "palindrome.factor" } ":"
{ $code ": normalize ( str -- newstr ) [ Letter? ] subset >lower ;" }
"You will need to add " { $vocab-link "strings" } " to the vocabulary search path, so that " { $link Letter? } " can be used in the source file."
"You will need to add " { $vocab-link "unicode.categories" } " to the vocabulary search path, so that " { $link Letter? } " can be used in the source file."
$nl
"We modify " { $snippet "palindrome?" } " to first apply " { $snippet "normalize" } " to its input:"
{ $code ": palindrome? ( str -- ? ) normalize dup reverse = ;" }

2
extra/html/elements/elements.factor
View File

@ -4,7 +4,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: io kernel namespaces prettyprint quotations
sequences strings words xml.writer compiler.units effects ;
sequences strings words xml.writer xml.entities compiler.units effects ;
IN: html.elements

4
extra/html/html.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2004, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: generic assocs help http io io.styles io.files
USING: generic assocs help http io io.styles io.files continuations
io.streams.string kernel math math.parser namespaces
quotations assocs sequences strings words html.elements
xml.writer sbufs ;
xml.writer xml.entities sbufs ;
IN: html
GENERIC: browser-link-href ( presented -- href )

4
extra/io/buffers/buffers.factor
View File

@ -2,8 +2,8 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: io.buffers
USING: alien alien.c-types alien.syntax kernel kernel.private
libc math sequences strings hints ;
USING: alien alien.accessors alien.c-types alien.syntax kernel
kernel.private libc math sequences strings hints ;
TUPLE: buffer size ptr fill pos ;

4
extra/io/mmap/mmap.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007 Doug Coleman.
! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: continuations io.backend kernel quotations sequences
system alien sequences.private ;
system alien alien.accessors sequences.private ;
IN: io.mmap
TUPLE: mapped-file length address handle closed? ;

33
extra/io/monitor/monitor-docs.factor
View File

@ -8,35 +8,32 @@ $nl
"Not all operating systems support recursive monitors; if recursive monitoring is not available, an error is thrown and the caller must implement alternative logic for monitoring subdirectories." } ;
HELP: next-change
{ $values { "monitor" "a monitor" } { "path" "a pathname string" } { "changes" "a sequence of change descriptors" } }
{ $description "Waits for file system changes and outputs the pathname of the first changed file. The change descriptor is a sequence containing at least one change descriptor; see " { $link "io.monitor.descriptors" } "." } ;
{ $values { "monitor" "a monitor" } { "path" "a pathname string" } { "changes" "a change descriptor" } }
{ $description "Waits for file system changes and outputs the pathname of the first changed file. The change descriptor is aq sequence of symbols documented in " { $link "io.monitor.descriptors" } "." } ;
HELP: with-monitor
{ $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "quot" "a quotation with stack effect " { $snippet "( monitor -- )" } } }
{ $description "Opens a file system change monitor and passes it to the quotation. Closes the monitor after the quotation returns or throws an error." } ;
HELP: +change-file+
{ $description "Indicates that the contents of the file have changed." } ;
HELP: +add-file+
{ $description "Indicates that the file has been added to the directory." } ;
HELP: +change-name+
{ $description "Indicates that the file name has changed." } ;
HELP: +remove-file+
{ $description "Indicates that the file has been removed from the directory." } ;
HELP: +change-size+
{ $description "Indicates that the file size has changed." } ;
HELP: +modify-file+
{ $description "Indicates that the file contents have changed." } ;
HELP: +change-attributes+
{ $description "Indicates that file attributes has changed. Attributes are operating system-specific but may include the creation time and permissions." } ;
HELP: +change-modified+
{ $description "Indicates that the last modification time of the file has changed." } ;
HELP: +rename-file+
{ $description "Indicates that file has been renamed." } ;
ARTICLE: "io.monitor.descriptors" "File system change descriptors"
"Change descriptors output by " { $link next-change } ":"
{ $subsection +change-file+ }
{ $subsection +change-name+ }
{ $subsection +change-size+ }
{ $subsection +change-attributes+ }
{ $subsection +change-modified+ } ;
{ $subsection +add-file+ }
{ $subsection +remove-file+ }
{ $subsection +modify-file+ }
{ $subsection +rename-file+ }
{ $subsection +add-file+ } ;
ARTICLE: "io.monitor" "File system change monitors"
"File system change monitors listen for changes to file names, attributes and contents under a specified directory. They can optionally be recursive, in which case subdirectories are also monitored."

9
extra/io/monitor/monitor.factor
View File

@ -7,11 +7,10 @@ HOOK: <monitor> io-backend ( path recursive? -- monitor )
HOOK: next-change io-backend ( monitor -- path changes )
SYMBOL: +change-file+
SYMBOL: +change-name+
SYMBOL: +change-size+
SYMBOL: +change-attributes+
SYMBOL: +change-modified+
SYMBOL: +add-file+
SYMBOL: +remove-file+
SYMBOL: +modify-file+
SYMBOL: +rename-file+
: with-monitor ( path recursive? quot -- )
>r <monitor> r> with-disposal ; inline

35
extra/io/nonblocking/nonblocking.factor
View File

@ -67,17 +67,17 @@ timeout-queue global [ [ <dlist> ] unless* ] change-at
dup timeout-queue get-global push-front*
swap set-port-timeout-entry ;
HOOK: expire-port io-backend ( port -- )
HOOK: cancel-io io-backend ( port -- )
M: object expire-port drop ;
M: object cancel-io drop ;
: expire-timeouts ( -- )
timeout-queue get-global dup dlist-empty? [ drop ] [
dup peek-back timeout?
[ pop-back expire-port expire-timeouts ] [ drop ] if
[ pop-back cancel-io expire-timeouts ] [ drop ] if
] if ;
: touch-port ( port -- )
: begin-timeout ( port -- )
dup port-timeout dup zero? [
2drop
] [
@ -85,8 +85,13 @@ M: object expire-port drop ;
dup unqueue-timeout queue-timeout
] if ;
M: port set-timeout
[ set-port-timeout ] keep touch-port ;
: end-timeout ( port -- )
unqueue-timeout ;
: with-port-timeout ( port quot -- )
over begin-timeout keep end-timeout ; inline
M: port set-timeout set-port-timeout ;
GENERIC: (wait-to-read) ( port -- )
@ -188,14 +193,18 @@ GENERIC: port-flush ( port -- )
M: output-port stream-flush ( port -- )
dup port-flush pending-error ;
: close-port ( port type -- )
output-port eq? [ dup port-flush ] when
dup cancel-io
dup port-handle close-handle
dup delegate [ buffer-free ] when*
f swap set-delegate ;
M: port dispose
dup port-type closed eq? [
dup port-type >r closed over set-port-type r>
output-port eq? [ dup port-flush ] when
dup port-handle close-handle
dup delegate [ buffer-free ] when*
f over set-delegate
] unless drop ;
dup port-type closed eq?
[ drop ]
[ dup port-type >r closed over set-port-type r> close-port ]
if ;
TUPLE: server-port addr client ;

2
extra/io/streams/null/null.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: io.streams.null
USING: kernel io ;
USING: kernel io continuations ;
TUPLE: null-stream ;

14
extra/io/unix/backend/backend.factor
View File

@ -57,7 +57,11 @@ GENERIC: wait-for-events ( ms mx -- )
M: mx register-io-task ( task mx -- )
2dup check-io-task fd/container set-at ;
: add-io-task ( task -- ) mx get-global register-io-task ;
: add-io-task ( task -- )
mx get-global register-io-task stop ;
: with-port-continuation ( port quot -- port )
[ callcc0 ] curry with-port-timeout ; inline
M: mx unregister-io-task ( task mx -- )
fd/container delete-at drop ;
@ -98,7 +102,6 @@ M: integer close-handle ( fd -- )
io-task-callbacks [ schedule-thread ] each ;
: handle-io-task ( mx task -- )
dup io-task-port touch-port
dup do-io-task [ pop-callbacks ] [ 2drop ] if ;
: handle-timeout ( mx task -- )
@ -133,7 +136,8 @@ M: read-task do-io-task
[ [ reader-eof ] [ drop ] if ] keep ;
M: input-port (wait-to-read)
[ <read-task> add-io-task stop ] callcc0 pending-error ;
[ <read-task> add-io-task ] with-port-continuation
pending-error ;
! Writers
: write-step ( port -- ? )
@ -151,11 +155,11 @@ M: write-task do-io-task
: add-write-io-task ( port continuation -- )
over port-handle mx get-global mx-writes at*
[ io-task-callbacks push drop ]
[ io-task-callbacks push stop ]
[ drop <write-task> add-io-task ] if ;
: (wait-to-write) ( port -- )
[ add-write-io-task stop ] callcc0 drop ;
[ add-write-io-task ] with-port-continuation drop ;
M: port port-flush ( port -- )
dup buffer-empty? [ drop ] [ (wait-to-write) ] if ;

9
extra/io/unix/sockets/sockets.factor
View File

@ -40,7 +40,7 @@ M: connect-task do-io-task
0 < [ defer-error ] [ drop t ] if ;
: wait-to-connect ( port -- )
[ <connect-task> add-io-task stop ] callcc0 drop ;
[ <connect-task> add-io-task ] with-port-continuation drop ;
M: unix-io (client) ( addrspec -- stream )
dup make-sockaddr/size >r >r
@ -82,7 +82,7 @@ M: accept-task do-io-task
over 0 >= [ do-accept t ] [ 2drop defer-error ] if ;
: wait-to-accept ( server -- )
[ <accept-task> add-io-task stop ] callcc0 drop ;
[ <accept-task> add-io-task ] with-port-continuation drop ;
USE: io.sockets
@ -147,7 +147,7 @@ M: receive-task do-io-task
] if ;
: wait-receive ( stream -- )
[ <receive-task> add-io-task stop ] callcc0 drop ;
[ <receive-task> add-io-task ] with-port-continuation drop ;
M: unix-io receive ( datagram -- packet addrspec )
dup check-datagram-port
@ -178,7 +178,8 @@ M: send-task do-io-task
swap 0 < [ io-task-port defer-error ] [ drop t ] if ;
: wait-send ( packet sockaddr len stream -- )
[ <send-task> add-io-task stop ] callcc0 2drop 2drop ;
[ <send-task> add-io-task ] with-port-continuation
2drop 2drop ;
M: unix-io send ( packet addrspec datagram -- )
3dup check-datagram-send

4
extra/io/unix/unix-tests.factor
View File

@ -56,7 +56,7 @@ yield
"Receive 2" print
"d" get receive >r >upper r>
"d" get receive >r " world" append r>
"Send 1" print
dup .
@ -98,7 +98,7 @@ client-addr <datagram>
"d" get send
] unit-test
[ "HELLO" t ] [
[ "hello world" t ] [
"d" get receive
server-addr =
>r >string r>

25
extra/io/windows/ce/sockets/sockets.factor
View File

@ -42,19 +42,20 @@ M: windows-ce-io <server> ( addrspec -- duplex-stream )
] keep <server-port> ;
M: windows-ce-io accept ( server -- client )
dup check-server-port
[
dup touch-port
dup port-handle win32-file-handle
swap server-port-addr sockaddr-type heap-size
dup <byte-array> [
swap <int> f 0
windows.winsock:WSAAccept
dup windows.winsock:INVALID_SOCKET =
[ windows.winsock:winsock-error ] when
] keep
] keep server-port-addr parse-sockaddr swap
<win32-socket> dup handle>duplex-stream <client-stream> ;
dup check-server-port
[
dup port-handle win32-file-handle
swap server-port-addr sockaddr-type heap-size
dup <byte-array> [
swap <int> f 0
windows.winsock:WSAAccept
dup windows.winsock:INVALID_SOCKET =
[ windows.winsock:winsock-error ] when
] keep
] keep server-port-addr parse-sockaddr swap
<win32-socket> dup handle>duplex-stream <client-stream>
] with-port-timeout ;
M: windows-ce-io <datagram> ( addrspec -- datagram )
[

11
extra/io/windows/launcher/launcher.factor
View File

@ -119,8 +119,15 @@ TUPLE: CreateProcess-args
drop STD_ERROR_HANDLE GetStdHandle ;
: redirect-stderr ( args -- handle )
+stderr+ get GENERIC_WRITE CREATE_ALWAYS redirect
swap inherited-stderr ?closed ;
+stderr+ get
dup +stdout+ eq? [
drop
CreateProcess-args-lpStartupInfo
STARTUPINFO-hStdOutput
] [
GENERIC_WRITE CREATE_ALWAYS redirect
swap inherited-stderr ?closed
] if ;
: inherited-stdin ( args -- handle )
CreateProcess-args-stdin-pipe

4
extra/io/windows/nt/backend/backend.factor
View File

@ -2,7 +2,7 @@ USING: alien alien.c-types arrays assocs combinators
continuations destructors io io.backend io.nonblocking
io.windows libc kernel math namespaces sequences
threads tuples.lib windows windows.errors windows.kernel32
strings splitting io.files qualified ;
strings splitting io.files qualified ascii ;
QUALIFIED: windows.winsock
IN: io.windows.nt.backend
@ -122,7 +122,7 @@ M: windows-nt-io add-completion ( handle -- )
: drain-overlapped ( timeout -- )
handle-overlapped [ 0 drain-overlapped ] unless ;
M: windows-nt-io expire-port
M: windows-nt-io cancel-io
port-handle win32-file-handle CancelIo drop ;
M: windows-nt-io io-multiplex ( ms -- )

11
extra/io/windows/nt/files/files.factor
View File

@ -24,7 +24,6 @@ M: windows-nt-io FileArgs-overlapped ( port -- overlapped )
swap buffer-consume ;
: (flush-output) ( port -- )
dup touch-port
dup make-FileArgs
tuck setup-write WriteFile
dupd overlapped-error? [
@ -37,7 +36,7 @@ M: windows-nt-io FileArgs-overlapped ( port -- overlapped )
] if ;
: flush-output ( port -- )
[ (flush-output) ] with-destructors ;
[ [ (flush-output) ] with-port-timeout ] with-destructors ;
M: port port-flush
dup buffer-empty? [ dup flush-output ] unless drop ;
@ -52,17 +51,13 @@ M: port port-flush
] if ;
: ((wait-to-read)) ( port -- )
dup touch-port
dup make-FileArgs
tuck setup-read ReadFile
dupd overlapped-error? [
>r FileArgs-lpOverlapped r>
[ save-callback ] 2keep
finish-read
] [
2drop
] if ;
] [ 2drop ] if ;
M: input-port (wait-to-read) ( port -- )
[ ((wait-to-read)) ] with-destructors ;
[ [ ((wait-to-read)) ] with-port-timeout ] with-destructors ;

39
extra/io/windows/nt/monitor/monitor.factor
View File

@ -4,7 +4,7 @@ USING: alien.c-types destructors io.windows
io.windows.nt.backend kernel math windows windows.kernel32
windows.types libc assocs alien namespaces continuations
io.monitor io.nonblocking io.buffers io.files io sequences
hashtables sorting arrays ;
hashtables sorting arrays combinators ;
IN: io.windows.nt.monitor
TUPLE: monitor path recursive? queue closed? ;
@ -46,29 +46,24 @@ M: windows-nt-io <monitor> ( path recursive? -- monitor )
: read-changes ( monitor -- bytes )
[
dup begin-reading-changes swap [ save-callback ] 2keep
get-overlapped-result
[
dup begin-reading-changes
swap [ save-callback ] 2keep
get-overlapped-result
] with-port-timeout
] with-destructors ;
: parse-action-flag ( action mask symbol -- action )
>r over bitand 0 > [ r> , ] [ r> drop ] if ;
: parse-action ( action -- changed )
{
{ [ dup FILE_ACTION_ADDED = ] [ +add-file+ ] }
{ [ dup FILE_ACTION_REMOVED = ] [ +remove-file+ ] }
{ [ dup FILE_ACTION_MODIFIED = ] [ +modify-file+ ] }
{ [ dup FILE_ACTION_RENAMED_OLD_NAME = ] [ +rename-file+ ] }
{ [ dup FILE_ACTION_RENAMED_NEW_NAME = ] [ +rename-file+ ] }
{ [ t ] [ +modify-file+ ] }
} cond nip ;
: parse-action ( action -- changes )
[
FILE_NOTIFY_CHANGE_FILE +change-file+ parse-action-flag
FILE_NOTIFY_CHANGE_DIR_NAME +change-name+ parse-action-flag
FILE_NOTIFY_CHANGE_ATTRIBUTES +change-attributes+ parse-action-flag
FILE_NOTIFY_CHANGE_SIZE +change-size+ parse-action-flag
FILE_NOTIFY_CHANGE_LAST_WRITE +change-modified+ parse-action-flag
FILE_NOTIFY_CHANGE_LAST_ACCESS +change-attributes+ parse-action-flag
FILE_NOTIFY_CHANGE_EA +change-attributes+ parse-action-flag
FILE_NOTIFY_CHANGE_CREATION +change-attributes+ parse-action-flag
FILE_NOTIFY_CHANGE_SECURITY +change-attributes+ parse-action-flag
FILE_NOTIFY_CHANGE_FILE_NAME +change-name+ parse-action-flag
drop
] { } make ;
: changed-file ( directory buffer -- changes path )
: changed-file ( directory buffer -- changed path )
{
FILE_NOTIFY_INFORMATION-FileName
FILE_NOTIFY_INFORMATION-FileNameLength
@ -76,7 +71,7 @@ M: windows-nt-io <monitor> ( path recursive? -- monitor )
} get-slots >r memory>u16-string path+ r> parse-action swap ;
: (changed-files) ( directory buffer -- )
2dup changed-file namespace [ append ] change-at
2dup changed-file namespace [ swap add ] change-at
dup FILE_NOTIFY_INFORMATION-NextEntryOffset dup zero?
[ 3drop ] [ swap <displaced-alien> (changed-files) ] if ;

28
extra/io/windows/nt/sockets/sockets.factor
View File

@ -1,7 +1,8 @@
USING: alien alien.c-types byte-arrays continuations destructors
io.nonblocking io io.sockets io.sockets.impl namespaces
io.streams.duplex io.windows io.windows.nt.backend
windows.winsock kernel libc math sequences threads tuples.lib ;
USING: alien alien.accessors alien.c-types byte-arrays
continuations destructors io.nonblocking io io.sockets
io.sockets.impl namespaces io.streams.duplex io.windows
io.windows.nt.backend windows.winsock kernel libc math sequences
threads tuples.lib ;
IN: io.windows.nt.sockets
: malloc-int ( object -- object )
@ -129,15 +130,16 @@ TUPLE: AcceptEx-args port
M: windows-nt-io accept ( server -- client )
[
dup check-server-port
dup touch-port
\ AcceptEx-args construct-empty
[ init-accept ] keep
[ (accept) ] keep
[ accept-continuation ] keep
AcceptEx-args-port pending-error
dup duplex-stream-in pending-error
dup duplex-stream-out pending-error
[
dup check-server-port
\ AcceptEx-args construct-empty
[ init-accept ] keep
[ (accept) ] keep
[ accept-continuation ] keep
AcceptEx-args-port pending-error
dup duplex-stream-in pending-error
dup duplex-stream-out pending-error
] with-port-timeout
] with-destructors ;
M: windows-nt-io <server> ( addrspec -- server )

19
extra/line-art/line-art.factor
View File

@ -1,6 +1,6 @@
USING: arrays bunny combinators.lib continuations io io.files kernel
math math.functions math.vectors multiline
namespaces
namespaces debugger
opengl opengl.gl opengl-demo-support
prettyprint
sequences ui ui.gadgets ui.gestures ui.render ;
@ -187,7 +187,7 @@ main()
] if ;
M: line-art-gadget graft* ( gadget -- )
"2.0" { "GL_ARB_draw_buffers"
[ "2.0" { "GL_ARB_draw_buffers"
"GL_ARB_shader_objects"
"GL_ARB_multitexture"
"GL_ARB_texture_float" }
@ -196,16 +196,17 @@ M: line-art-gadget graft* ( gadget -- )
GL_CULL_FACE glEnable
GL_DEPTH_TEST glEnable
(line-art-step1-program) over set-line-art-gadget-step1-program
(line-art-step2-program) swap set-line-art-gadget-step2-program ;
(line-art-step2-program) swap set-line-art-gadget-step2-program
] [ ] [ :c ] cleanup ;
M: line-art-gadget ungraft* ( gadget -- )
dup line-art-gadget-framebuffer [
{ [ line-art-gadget-step1-program delete-gl-program ]
[ line-art-gadget-step2-program delete-gl-program ]
[ line-art-gadget-framebuffer delete-framebuffer ]
[ line-art-gadget-color-texture delete-texture ]
[ line-art-gadget-normal-texture delete-texture ]
[ line-art-gadget-depth-texture delete-texture ]
{ [ line-art-gadget-step1-program [ delete-gl-program ] when* ]
[ line-art-gadget-step2-program [ delete-gl-program ] when* ]
[ line-art-gadget-framebuffer [ delete-framebuffer ] when* ]
[ line-art-gadget-color-texture [ delete-texture ] when* ]
[ line-art-gadget-normal-texture [ delete-texture ] when* ]
[ line-art-gadget-depth-texture [ delete-texture ] when* ]
[ f swap set-line-art-gadget-framebuffer-dim ]
[ f swap set-line-art-gadget-framebuffer ] } call-with
] [ drop ] if ;

1
extra/multiline/tags.txt Executable file
View File

@ -0,0 +1 @@
reflection

3
extra/opengl/tags.txt
View File

@ -1 +1,4 @@
opengl.glu
opengl.gl
opengl
bindings

2
extra/pack/pack-tests.factor Normal file → Executable file
View File

@ -43,5 +43,5 @@ USING: io io.streams.string kernel namespaces pack strings tools.test ;
[ "FRAM" ] [ "FRAM\0" [ read-c-string ] string-in ] unit-test
[ f ] [ "" [ read-c-string ] string-in ] unit-test
[ 5 ] [ "FRAM\0\u0005\0\0\0\0\0\0\0" [ read-c-string drop read-u64 ] string-in ] unit-test
[ 5 ] [ "FRAM\0\u000005\0\0\0\0\0\0\0" [ read-c-string drop read-u64 ] string-in ] unit-test

3
extra/parser-combinators/parser-combinators-tests.factor
View File

@ -1,8 +1,7 @@
! Copyright (C) 2005 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
!
USING: kernel lazy-lists tools.test strings math
sequences parser-combinators arrays math.parser ;
sequences parser-combinators arrays math.parser unicode.categories ;
IN: scratchpad
! Testing <&>

3
extra/parser-combinators/parser-combinators.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2004 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: lazy-lists promises kernel sequences strings math
arrays splitting quotations combinators namespaces ;
arrays splitting quotations combinators namespaces
unicode.case unicode.categories ;
IN: parser-combinators
! Parser combinator protocol

1
extra/parser-combinators/simple/tags.txt Executable file
View File

@ -0,0 +1 @@
parsing

1
extra/parser-combinators/tags.txt Executable file
View File

@ -0,0 +1 @@
parsing

1
extra/peg/tags.txt
View File

@ -1 +1,2 @@
text
parsing

2
extra/prolog/tags.txt
View File

@ -1 +1 @@
prolog
languages

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

@ -158,8 +158,8 @@ IN: regexp-tests
[ t ] [ "SXY" "\\0123XY" f <regexp> matches? ] unit-test
[ t ] [ "x" "\\x78" f <regexp> matches? ] unit-test
[ f ] [ "y" "\\x78" f <regexp> matches? ] unit-test
[ t ] [ "x" "\\u0078" f <regexp> matches? ] unit-test
[ f ] [ "y" "\\u0078" f <regexp> matches? ] unit-test
[ t ] [ "x" "\\u000078" f <regexp> matches? ] unit-test
[ f ] [ "y" "\\u000078" f <regexp> matches? ] unit-test
[ t ] [ "ab" "a+b" f <regexp> matches? ] unit-test
[ f ] [ "b" "a+b" f <regexp> matches? ] unit-test

2
extra/regexp/tags.txt Executable file
View File

@ -0,0 +1,2 @@
parsing
text

2
extra/slides/slides.factor
View File

@ -33,7 +33,7 @@ IN: slides
{ list-style
H{ { table-gap { 10 20 } } }
}
{ bullet "\u00b7" }
{ bullet "\u0000b7" }
} ;
: $title ( string -- )

BIN
extra/space-invaders/resources/invaders.rom Normal file
View File

Binary file not shown.

5
extra/tar/tar.factor
View File

@ -1,7 +1,6 @@
USING: combinators io io.files io.streams.duplex
USING: combinators io io.files io.streams.duplex continuations
io.streams.string kernel math math.parser
namespaces pack prettyprint sequences strings system ;
USING: hexdump tools.interpreter ;
namespaces pack prettyprint sequences strings system hexdump ;
IN: tar
: zero-checksum 256 ;

5
extra/tools/completion/completion.factor
View File

@ -1,8 +1,9 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: tools.completion
USING: kernel arrays sequences math namespaces strings io
vectors words assocs combinators sorting ;
vectors words assocs combinators sorting unicode.case
unicode.categories ;
: (fuzzy) ( accum ch i full -- accum i ? )
index*

2
extra/tuple-syntax/tags.txt
View File

@ -1 +1 @@
syntax
reflection

4
extra/ui/commands/commands.factor Normal file → Executable file
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays definitions kernel sequences strings math assocs
words generic namespaces assocs quotations splitting
ui.gestures ;
ui.gestures unicode.case unicode.categories ;
IN: ui.commands
SYMBOL: +nullary+
@ -51,7 +51,7 @@ GENERIC: command-word ( command -- word )
update-gestures ;
: (command-name) ( string -- newstring )
"-" split " " join unclip ch>upper add* ;
"-" split " " join >title ;
M: word command-name ( word -- str )
word-name

4
extra/ui/freetype/freetype.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays io kernel libc math
math.vectors namespaces opengl opengl.gl prettyprint assocs
USING: alien alien.accessors alien.c-types arrays io kernel libc
math math.vectors namespaces opengl opengl.gl prettyprint assocs
sequences io.files io.styles continuations freetype
ui.gadgets.worlds ui.render ui.backend byte-arrays ;
IN: ui.freetype

2
extra/ui/gadgets/buttons/buttons-tests.factor
View File

@ -17,7 +17,7 @@ TUPLE: foo-gadget ;
T{ foo-gadget } <toolbar> "t" set
[ 2 ] [ "t" get gadget-children length ] unit-test
[ "Foo a" ] [ "t" get gadget-child gadget-child label-string ] unit-test
[ "Foo A" ] [ "t" get gadget-child gadget-child label-string ] unit-test
[ ] [
2 <model> {

2
extra/ui/tools/search/search.factor
View File

@ -7,7 +7,7 @@ source-files strings tools.completion tools.crossref tuples
ui.commands ui.gadgets ui.gadgets.editors
ui.gadgets.lists ui.gadgets.scrollers ui.gadgets.tracks
ui.gestures ui.operations vocabs words vocabs.loader
tools.browser ;
tools.browser unicode.case ;
IN: ui.tools.search
TUPLE: live-search field list ;

4
extra/ui/ui.factor
View File

@ -120,7 +120,9 @@ SYMBOL: ui-hook
[ dup update-hand draw-world ] each ;
: notify ( gadget -- )
dup gadget-graft-state dup first { f f } { t t } ? pick set-gadget-graft-state {
dup gadget-graft-state
dup first { f f } { t t } ?
pick set-gadget-graft-state {
{ { f t } [ dup activate-control graft* ] }
{ { t f } [ dup deactivate-control ungraft* ] }
} case ;

7
extra/ui/windows/windows.factor
View File

@ -6,7 +6,7 @@ math math.vectors namespaces prettyprint sequences strings
vectors words windows.kernel32 windows.gdi32 windows.user32
windows.opengl32 windows.messages windows.types
windows.nt windows threads timers libc combinators continuations
command-line shuffle opengl ui.render ;
command-line shuffle opengl ui.render unicode.case ascii ;
IN: ui.windows
TUPLE: windows-ui-backend ;
@ -140,7 +140,10 @@ SYMBOL: mouse-captured
: ctrl? ( -- ? ) left-ctrl? right-ctrl? or ;
: alt? ( -- ? ) left-alt? right-alt? or ;
: caps-lock? ( -- ? ) VK_CAPITAL GetKeyState zero? not ;
: switch-case ( seq -- seq ) dup first CHAR: a >= [ >upper ] [ >lower ] if ;
: switch-case ( seq -- seq )
dup first CHAR: a >= [ >upper ] [ >lower ] if ;
: switch-case? ( -- ? ) shift? caps-lock? xor not ;
: key-modifiers ( -- seq )

6
extra/unicode/breaks/breaks-tests.factor Normal file → Executable file
View File

@ -1,7 +1,7 @@
USING: tools.test unicode.breaks sequences math kernel ;
[ "\u1112\u1161\u11abA\u0300a\r\r\n" ]
[ "\r\n\raA\u0300\u1112\u1161\u11ab" string-reverse ] unit-test
[ "\u001112\u001161\u0011abA\u000300a\r\r\n" ]
[ "\r\n\raA\u000300\u001112\u001161\u0011ab" string-reverse ] unit-test
[ "dcba" ] [ "abcd" string-reverse ] unit-test
[ 3 ] [ "\u1112\u1161\u11abA\u0300a"
[ 3 ] [ "\u001112\u001161\u0011abA\u000300a"
dup last-grapheme head last-grapheme ] unit-test

1
extra/unicode/breaks/tags.txt Executable file
View File

@ -0,0 +1 @@
text

10
extra/unicode/case/case-tests.factor Normal file → Executable file
View File

@ -1,14 +1,14 @@
USING: unicode.case tools.test namespaces ;
[ "Hello How Are You? I'M Good" ] [ "hEllo how ARE yOU? I'm good" >title ] unit-test
[ "FUSS" ] [ "Fu\u00DF" >upper ] unit-test
[ "\u03C3\u03C2" ] [ "\u03A3\u03A3" >lower ] unit-test
[ "FUSS" ] [ "Fu\u0000DF" >upper ] unit-test
[ "\u0003C3\u0003C2" ] [ "\u0003A3\u0003A3" >lower ] unit-test
[ t ] [ "hello how are you?" lower? ] unit-test
[
"tr" locale set
[ "i\u0131i \u0131jj" ] [ "i\u0131I\u0307 IJj" >lower ] unit-test
! [ "I\u307\u0131i Ijj" ] [ "i\u0131I\u0307 IJj" >title ] unit-test
[ "I\u0307II\u0307 IJJ" ] [ "i\u0131I\u0307 IJj" >upper ] unit-test
[ "i\u000131i \u000131jj" ] [ "i\u000131I\u000307 IJj" >lower ] unit-test
! [ "I\u00307\u000131i Ijj" ] [ "i\u000131I\u000307 IJj" >title ] unit-test
[ "I\u000307II\u000307 IJJ" ] [ "i\u000131I\u000307 IJj" >upper ] unit-test
"lt" locale set
! Lithuanian casing tests
] with-scope

4
extra/unicode/case/case.factor Normal file → Executable file
View File

@ -13,7 +13,7 @@ SYMBOL: locale ! Just casing locale, or overall?
: lithuanian? ( -- ? ) locale get "lt" = ;
: dot-over ( -- ch ) CHAR: \u0307 ;
: dot-over ( -- ch ) HEX: 307 ;
: lithuanian-ch>upper ( ? next ch -- ? )
rot [ 2drop f ]
@ -46,7 +46,7 @@ SYMBOL: locale ! Just casing locale, or overall?
{ [ rot ] [ 2drop f ] }
{ [ dup CHAR: I = ] [
drop dot-over =
dup CHAR: i CHAR: \u0131 ? ,
dup CHAR: i HEX: 131 ? ,
] }
{ [ t ] [ , drop f ] }
} cond ;

1
extra/unicode/case/tags.txt Executable file
View File

@ -0,0 +1 @@
text

1
extra/unicode/categories/tags.txt Executable file
View File

@ -0,0 +1 @@
text

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