Merge git://factorcode.org/git/factor
commit
8b0e61b18b
8
Makefile
8
Makefile
|
@ -56,6 +56,8 @@ default:
|
|||
@echo "linux-arm"
|
||||
@echo "openbsd-x86-32"
|
||||
@echo "openbsd-x86-64"
|
||||
@echo "netbsd-x86-32"
|
||||
@echo "netbsd-x86-64"
|
||||
@echo "macosx-x86-32"
|
||||
@echo "macosx-x86-64"
|
||||
@echo "macosx-ppc"
|
||||
|
@ -83,6 +85,12 @@ freebsd-x86-32:
|
|||
freebsd-x86-64:
|
||||
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.freebsd.x86.64
|
||||
|
||||
netbsd-x86-32:
|
||||
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.netbsd.x86.32
|
||||
|
||||
netbsd-x86-64:
|
||||
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.netbsd.x86.64
|
||||
|
||||
macosx-freetype:
|
||||
ln -sf libfreetype.6.dylib \
|
||||
Factor.app/Contents/Frameworks/libfreetype.dylib
|
||||
|
|
|
@ -46,3 +46,9 @@ IN: temporary
|
|||
[ ?{ f } ] [
|
||||
1 2 { t f t f } <slice> >bit-array
|
||||
] unit-test
|
||||
|
||||
[ ?{ t f t f f f } ] [ 6 ?{ t f t } resize-bit-array ] unit-test
|
||||
|
||||
[ ?{ t t } ] [ 2 ?{ t t f t f t f t t t f t } resize-bit-array ] unit-test
|
||||
|
||||
[ -10 ?{ } resize-bit-array ] unit-test-fails
|
||||
|
|
|
@ -48,6 +48,9 @@ M: bit-array new drop <bit-array> ;
|
|||
M: bit-array equal?
|
||||
over bit-array? [ sequence= ] [ 2drop f ] if ;
|
||||
|
||||
M: bit-array resize
|
||||
resize-bit-array ;
|
||||
|
||||
INSTANCE: bit-array sequence
|
||||
INSTANCE: bit-array simple-c-ptr
|
||||
INSTANCE: bit-array c-ptr
|
||||
|
|
|
@ -0,0 +1,33 @@
|
|||
USING: arrays bit-arrays help.markup help.syntax kernel
|
||||
bit-vectors.private combinators ;
|
||||
IN: bit-vectors
|
||||
|
||||
ARTICLE: "bit-vectors" "Bit vectors"
|
||||
"A bit vector is a resizable mutable sequence of bits. The literal syntax is covered in " { $link "syntax-bit-vectors" } ". Bit vector words are found in the " { $vocab-link "bit-vectors" } " vocabulary."
|
||||
$nl
|
||||
"Bit vectors form a class:"
|
||||
{ $subsection bit-vector }
|
||||
{ $subsection bit-vector? }
|
||||
"Creating bit vectors:"
|
||||
{ $subsection >bit-vector }
|
||||
{ $subsection <bit-vector> }
|
||||
"If you don't care about initial capacity, a more elegant way to create a new bit vector is to write:"
|
||||
{ $code "?V{ } clone" } ;
|
||||
|
||||
ABOUT: "bit-vectors"
|
||||
|
||||
HELP: bit-vector
|
||||
{ $description "The class of resizable bit vectors. See " { $link "syntax-bit-vectors" } " for syntax and " { $link "bit-vectors" } " for general information." } ;
|
||||
|
||||
HELP: <bit-vector>
|
||||
{ $values { "n" "a positive integer specifying initial capacity" } { "bit-vector" bit-vector } }
|
||||
{ $description "Creates a new bit vector that can hold " { $snippet "n" } " bits before resizing." } ;
|
||||
|
||||
HELP: >bit-vector
|
||||
{ $values { "seq" "a sequence" } { "bit-vector" bit-vector } }
|
||||
{ $description "Outputs a freshly-allocated bit vector with the same elements as a given sequence." } ;
|
||||
|
||||
HELP: bit-array>vector
|
||||
{ $values { "bit-array" "an array" } { "length" "a non-negative integer" } { "bit-vector" bit-vector } }
|
||||
{ $description "Creates a new bit vector using the array for underlying storage with the specified initial length." }
|
||||
{ $warning "This word is in the " { $vocab-link "bit-vectors.private" } " vocabulary because it does not perform type or bounds checks. User code should call " { $link >bit-vector } " instead." } ;
|
|
@ -0,0 +1,14 @@
|
|||
IN: temporary
|
||||
USING: tools.test bit-vectors vectors sequences kernel math ;
|
||||
|
||||
[ 0 ] [ 123 <bit-vector> length ] unit-test
|
||||
|
||||
: do-it
|
||||
1234 swap [ >r even? r> push ] curry each ;
|
||||
|
||||
[ t ] [
|
||||
3 <bit-vector> dup do-it
|
||||
3 <vector> dup do-it sequence=
|
||||
] unit-test
|
||||
|
||||
[ t ] [ ?V{ } bit-vector? ] unit-test
|
|
@ -0,0 +1,33 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays kernel kernel.private math sequences
|
||||
sequences.private growable bit-arrays ;
|
||||
IN: bit-vectors
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: bit-array>vector ( bit-array length -- bit-vector )
|
||||
bit-vector construct-boa ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: <bit-vector> ( n -- bit-vector )
|
||||
<bit-array> 0 bit-array>vector ; inline
|
||||
|
||||
: >bit-vector ( seq -- bit-vector ) ?V{ } clone-like ;
|
||||
|
||||
M: bit-vector like
|
||||
drop dup bit-vector? [
|
||||
dup bit-array?
|
||||
[ dup length bit-array>vector ] [ >bit-vector ] if
|
||||
] unless ;
|
||||
|
||||
M: bit-vector new
|
||||
drop [ <bit-array> ] keep >fixnum bit-array>vector ;
|
||||
|
||||
M: bit-vector equal?
|
||||
over bit-vector? [ sequence= ] [ 2drop f ] if ;
|
||||
|
||||
M: bit-array new-resizable drop <bit-vector> ;
|
||||
|
||||
INSTANCE: bit-vector growable
|
|
@ -320,24 +320,33 @@ M: quotation '
|
|||
! Vectors and sbufs
|
||||
|
||||
M: vector '
|
||||
dup underlying ' swap length
|
||||
vector type-number object tag-number [
|
||||
emit-fixnum ! length
|
||||
dup length swap underlying '
|
||||
tuple type-number tuple tag-number [
|
||||
4 emit-fixnum
|
||||
vector ' emit
|
||||
f ' emit
|
||||
emit ! array ptr
|
||||
emit-fixnum ! length
|
||||
] emit-object ;
|
||||
|
||||
M: sbuf '
|
||||
dup underlying ' swap length
|
||||
sbuf type-number object tag-number [
|
||||
emit-fixnum ! length
|
||||
dup length swap underlying '
|
||||
tuple type-number tuple tag-number [
|
||||
4 emit-fixnum
|
||||
sbuf ' emit
|
||||
f ' emit
|
||||
emit ! array ptr
|
||||
emit-fixnum ! length
|
||||
] emit-object ;
|
||||
|
||||
! Hashes
|
||||
|
||||
M: hashtable '
|
||||
[ hash-array ' ] keep
|
||||
hashtable type-number object tag-number [
|
||||
tuple type-number tuple tag-number [
|
||||
5 emit-fixnum
|
||||
hashtable ' emit
|
||||
f ' emit
|
||||
dup hash-count emit-fixnum
|
||||
hash-deleted emit-fixnum
|
||||
emit ! array ptr
|
||||
|
|
|
@ -8,7 +8,7 @@ BIN: 111 tag-mask set
|
|||
8 num-tags set
|
||||
3 tag-bits set
|
||||
|
||||
23 num-types set
|
||||
20 num-types set
|
||||
|
||||
H{
|
||||
{ fixnum BIN: 000 }
|
||||
|
@ -24,17 +24,14 @@ H{
|
|||
tag-numbers get H{
|
||||
{ array 8 }
|
||||
{ wrapper 9 }
|
||||
{ hashtable 10 }
|
||||
{ vector 11 }
|
||||
{ float-array 10 }
|
||||
{ callstack 11 }
|
||||
{ string 12 }
|
||||
{ sbuf 13 }
|
||||
{ curry 13 }
|
||||
{ quotation 14 }
|
||||
{ dll 15 }
|
||||
{ alien 16 }
|
||||
{ word 17 }
|
||||
{ byte-array 18 }
|
||||
{ bit-array 19 }
|
||||
{ float-array 20 }
|
||||
{ curry 21 }
|
||||
{ callstack 22 }
|
||||
} union type-numbers set
|
||||
|
|
|
@ -22,7 +22,9 @@ crossref off
|
|||
{ "arm" "arm" }
|
||||
} at "/bootstrap.factor" 3append parse-file
|
||||
|
||||
! Now we have ( syntax-quot arch-quot ) on the stack
|
||||
"resource:core/bootstrap/layouts/layouts.factor" parse-file
|
||||
|
||||
! Now we have ( syntax-quot arch-quot layouts-quot ) on the stack
|
||||
|
||||
! Bring up a bare cross-compiling vocabulary.
|
||||
"syntax" vocab vocab-words bootstrap-syntax set
|
||||
|
@ -30,6 +32,7 @@ H{ } clone dictionary set
|
|||
H{ } clone changed-words set
|
||||
[ drop ] recompile-hook set
|
||||
|
||||
call
|
||||
call
|
||||
call
|
||||
|
||||
|
@ -39,11 +42,14 @@ call
|
|||
"alien"
|
||||
"arrays"
|
||||
"bit-arrays"
|
||||
"bit-vectors"
|
||||
"byte-arrays"
|
||||
"byte-vectors"
|
||||
"classes.private"
|
||||
"compiler.units"
|
||||
"continuations.private"
|
||||
"float-arrays"
|
||||
"float-vectors"
|
||||
"generator"
|
||||
"growable"
|
||||
"hashtables"
|
||||
|
@ -96,12 +102,6 @@ H{ } clone update-map set
|
|||
: register-builtin ( class -- )
|
||||
dup "type" word-prop builtins get set-nth ;
|
||||
|
||||
: intern-slots ( spec -- spec )
|
||||
[
|
||||
[ dup array? [ first2 create ] when ] map
|
||||
{ slot-spec f } swap append >tuple
|
||||
] map ;
|
||||
|
||||
: lookup-type-number ( word -- n )
|
||||
global [ target-word ] bind type-number ;
|
||||
|
||||
|
@ -110,8 +110,8 @@ H{ } clone update-map set
|
|||
dup dup lookup-type-number "type" set-word-prop
|
||||
dup f f builtin-class define-class
|
||||
dup r> builtin-predicate
|
||||
dup r> intern-slots 2dup "slots" set-word-prop
|
||||
define-slots
|
||||
dup r> 1 simple-slots 2dup "slots" set-word-prop
|
||||
dupd define-slots
|
||||
register-builtin ;
|
||||
|
||||
H{ } clone typemap set
|
||||
|
@ -137,14 +137,12 @@ num-types get f <array> builtins set
|
|||
{
|
||||
{ "integer" "math" }
|
||||
"numerator"
|
||||
1
|
||||
{ "numerator" "math" }
|
||||
f
|
||||
}
|
||||
{
|
||||
{ "integer" "math" }
|
||||
"denominator"
|
||||
2
|
||||
{ "denominator" "math" }
|
||||
f
|
||||
}
|
||||
|
@ -158,14 +156,12 @@ num-types get f <array> builtins set
|
|||
{
|
||||
{ "real" "math" }
|
||||
"real-part"
|
||||
1
|
||||
{ "real-part" "math" }
|
||||
f
|
||||
}
|
||||
{
|
||||
{ "real" "math" }
|
||||
"imaginary-part"
|
||||
2
|
||||
{ "imaginary-part" "math" }
|
||||
f
|
||||
}
|
||||
|
@ -182,94 +178,32 @@ num-types get f <array> builtins set
|
|||
{
|
||||
{ "object" "kernel" }
|
||||
"wrapped"
|
||||
1
|
||||
{ "wrapped" "kernel" }
|
||||
f
|
||||
}
|
||||
} define-builtin
|
||||
|
||||
"hashtable" "hashtables" create "hashtable?" "hashtables" create
|
||||
{
|
||||
{
|
||||
{ "array-capacity" "sequences.private" }
|
||||
"count"
|
||||
1
|
||||
{ "hash-count" "hashtables.private" }
|
||||
{ "set-hash-count" "hashtables.private" }
|
||||
} {
|
||||
{ "array-capacity" "sequences.private" }
|
||||
"deleted"
|
||||
2
|
||||
{ "hash-deleted" "hashtables.private" }
|
||||
{ "set-hash-deleted" "hashtables.private" }
|
||||
} {
|
||||
{ "array" "arrays" }
|
||||
"array"
|
||||
3
|
||||
{ "hash-array" "hashtables.private" }
|
||||
{ "set-hash-array" "hashtables.private" }
|
||||
}
|
||||
} define-builtin
|
||||
|
||||
"vector" "vectors" create "vector?" "vectors" create
|
||||
{
|
||||
{
|
||||
{ "array-capacity" "sequences.private" }
|
||||
"fill"
|
||||
1
|
||||
{ "length" "sequences" }
|
||||
{ "set-fill" "growable" }
|
||||
} {
|
||||
{ "array" "arrays" }
|
||||
"underlying"
|
||||
2
|
||||
{ "underlying" "growable" }
|
||||
{ "set-underlying" "growable" }
|
||||
}
|
||||
} define-builtin
|
||||
|
||||
"string" "strings" create "string?" "strings" create
|
||||
{
|
||||
{
|
||||
{ "array-capacity" "sequences.private" }
|
||||
"length"
|
||||
1
|
||||
{ "length" "sequences" }
|
||||
f
|
||||
}
|
||||
} define-builtin
|
||||
|
||||
"sbuf" "sbufs" create "sbuf?" "sbufs" create
|
||||
{
|
||||
{
|
||||
{ "array-capacity" "sequences.private" }
|
||||
"length"
|
||||
1
|
||||
{ "length" "sequences" }
|
||||
{ "set-fill" "growable" }
|
||||
}
|
||||
{
|
||||
{ "string" "strings" }
|
||||
"underlying"
|
||||
2
|
||||
{ "underlying" "growable" }
|
||||
{ "set-underlying" "growable" }
|
||||
}
|
||||
} define-builtin
|
||||
|
||||
"quotation" "quotations" create "quotation?" "quotations" create
|
||||
{
|
||||
{
|
||||
{ "object" "kernel" }
|
||||
"array"
|
||||
1
|
||||
{ "quotation-array" "quotations.private" }
|
||||
f
|
||||
}
|
||||
{
|
||||
{ "object" "kernel" }
|
||||
"compiled?"
|
||||
2
|
||||
{ "quotation-compiled?" "quotations" }
|
||||
f
|
||||
}
|
||||
|
@ -280,7 +214,6 @@ num-types get f <array> builtins set
|
|||
{
|
||||
{ "byte-array" "byte-arrays" }
|
||||
"path"
|
||||
1
|
||||
{ "(dll-path)" "alien" }
|
||||
f
|
||||
}
|
||||
|
@ -292,13 +225,11 @@ define-builtin
|
|||
{
|
||||
{ "c-ptr" "alien" }
|
||||
"alien"
|
||||
1
|
||||
{ "underlying-alien" "alien" }
|
||||
f
|
||||
} {
|
||||
{ "object" "kernel" }
|
||||
"expired?"
|
||||
2
|
||||
{ "expired?" "alien" }
|
||||
f
|
||||
}
|
||||
|
@ -307,45 +238,40 @@ define-builtin
|
|||
|
||||
"word" "words" create "word?" "words" create
|
||||
{
|
||||
f
|
||||
{
|
||||
{ "object" "kernel" }
|
||||
"name"
|
||||
2
|
||||
{ "word-name" "words" }
|
||||
{ "set-word-name" "words" }
|
||||
}
|
||||
{
|
||||
{ "object" "kernel" }
|
||||
"vocabulary"
|
||||
3
|
||||
{ "word-vocabulary" "words" }
|
||||
{ "set-word-vocabulary" "words" }
|
||||
}
|
||||
{
|
||||
{ "quotation" "quotations" }
|
||||
"def"
|
||||
4
|
||||
{ "word-def" "words" }
|
||||
{ "set-word-def" "words.private" }
|
||||
}
|
||||
{
|
||||
{ "object" "kernel" }
|
||||
"props"
|
||||
5
|
||||
{ "word-props" "words" }
|
||||
{ "set-word-props" "words" }
|
||||
}
|
||||
{
|
||||
{ "object" "kernel" }
|
||||
"?"
|
||||
6
|
||||
{ "compiled?" "words" }
|
||||
f
|
||||
}
|
||||
{
|
||||
{ "fixnum" "math" }
|
||||
"counter"
|
||||
7
|
||||
{ "profile-counter" "tools.profiler.private" }
|
||||
{ "set-profile-counter" "tools.profiler.private" }
|
||||
}
|
||||
|
@ -369,14 +295,12 @@ define-builtin
|
|||
{
|
||||
{ "object" "kernel" }
|
||||
"obj"
|
||||
1
|
||||
{ "curry-obj" "kernel" }
|
||||
f
|
||||
}
|
||||
{
|
||||
{ "object" "kernel" }
|
||||
"obj"
|
||||
2
|
||||
{ "curry-quot" "kernel" }
|
||||
f
|
||||
}
|
||||
|
@ -414,6 +338,102 @@ builtins get num-tags get tail f union-class define-class
|
|||
"tombstone" "hashtables.private" lookup t
|
||||
2array >tuple 1quotation define-inline
|
||||
|
||||
! Some tuple classes
|
||||
"hashtable" "hashtables" create
|
||||
{
|
||||
{
|
||||
{ "array-capacity" "sequences.private" }
|
||||
"count"
|
||||
{ "hash-count" "hashtables.private" }
|
||||
{ "set-hash-count" "hashtables.private" }
|
||||
} {
|
||||
{ "array-capacity" "sequences.private" }
|
||||
"deleted"
|
||||
{ "hash-deleted" "hashtables.private" }
|
||||
{ "set-hash-deleted" "hashtables.private" }
|
||||
} {
|
||||
{ "array" "arrays" }
|
||||
"array"
|
||||
{ "hash-array" "hashtables.private" }
|
||||
{ "set-hash-array" "hashtables.private" }
|
||||
}
|
||||
} define-tuple-class
|
||||
|
||||
"sbuf" "sbufs" create
|
||||
{
|
||||
{
|
||||
{ "string" "strings" }
|
||||
"underlying"
|
||||
{ "underlying" "growable" }
|
||||
{ "set-underlying" "growable" }
|
||||
} {
|
||||
{ "array-capacity" "sequences.private" }
|
||||
"length"
|
||||
{ "length" "sequences" }
|
||||
{ "set-fill" "growable" }
|
||||
}
|
||||
} define-tuple-class
|
||||
|
||||
"vector" "vectors" create
|
||||
{
|
||||
{
|
||||
{ "array" "arrays" }
|
||||
"underlying"
|
||||
{ "underlying" "growable" }
|
||||
{ "set-underlying" "growable" }
|
||||
} {
|
||||
{ "array-capacity" "sequences.private" }
|
||||
"fill"
|
||||
{ "length" "sequences" }
|
||||
{ "set-fill" "growable" }
|
||||
}
|
||||
} define-tuple-class
|
||||
|
||||
"byte-vector" "byte-vectors" create
|
||||
{
|
||||
{
|
||||
{ "byte-array" "byte-arrays" }
|
||||
"underlying"
|
||||
{ "underlying" "growable" }
|
||||
{ "set-underlying" "growable" }
|
||||
} {
|
||||
{ "array-capacity" "sequences.private" }
|
||||
"fill"
|
||||
{ "length" "sequences" }
|
||||
{ "set-fill" "growable" }
|
||||
}
|
||||
} define-tuple-class
|
||||
|
||||
"bit-vector" "bit-vectors" create
|
||||
{
|
||||
{
|
||||
{ "bit-array" "bit-arrays" }
|
||||
"underlying"
|
||||
{ "underlying" "growable" }
|
||||
{ "set-underlying" "growable" }
|
||||
} {
|
||||
{ "array-capacity" "sequences.private" }
|
||||
"fill"
|
||||
{ "length" "sequences" }
|
||||
{ "set-fill" "growable" }
|
||||
}
|
||||
} define-tuple-class
|
||||
|
||||
"float-vector" "float-vectors" create
|
||||
{
|
||||
{
|
||||
{ "float-array" "float-arrays" }
|
||||
"underlying"
|
||||
{ "underlying" "growable" }
|
||||
{ "set-underlying" "growable" }
|
||||
} {
|
||||
{ "array-capacity" "sequences.private" }
|
||||
"fill"
|
||||
{ "length" "sequences" }
|
||||
{ "set-fill" "growable" }
|
||||
}
|
||||
} define-tuple-class
|
||||
|
||||
! Primitive words
|
||||
: make-primitive ( word vocab n -- )
|
||||
>r create dup reset-word r> [ do-primitive ] curry [ ] like define ;
|
||||
|
@ -422,7 +442,6 @@ builtins get num-tags get tail f union-class define-class
|
|||
{ "(execute)" "words.private" }
|
||||
{ "(call)" "kernel.private" }
|
||||
{ "uncurry" "kernel.private" }
|
||||
{ "string>sbuf" "sbufs.private" }
|
||||
{ "bignum>fixnum" "math.private" }
|
||||
{ "float>fixnum" "math.private" }
|
||||
{ "fixnum>bignum" "math.private" }
|
||||
|
@ -575,7 +594,6 @@ builtins get num-tags get tail f union-class define-class
|
|||
{ "set-char-slot" "strings.private" }
|
||||
{ "resize-array" "arrays" }
|
||||
{ "resize-string" "strings" }
|
||||
{ "(hashtable)" "hashtables.private" }
|
||||
{ "<array>" "arrays" }
|
||||
{ "begin-scan" "memory" }
|
||||
{ "next-object" "memory" }
|
||||
|
@ -590,7 +608,6 @@ builtins get num-tags get tail f union-class define-class
|
|||
{ "fclose" "io.streams.c" }
|
||||
{ "<wrapper>" "kernel" }
|
||||
{ "(clone)" "kernel" }
|
||||
{ "array>vector" "vectors.private" }
|
||||
{ "<string>" "strings" }
|
||||
{ "(>tuple)" "tuples.private" }
|
||||
{ "array>quotation" "quotations.private" }
|
||||
|
@ -610,6 +627,9 @@ builtins get num-tags get tail f union-class define-class
|
|||
{ "set-innermost-frame-quot" "kernel.private" }
|
||||
{ "call-clear" "kernel" }
|
||||
{ "(os-envs)" "system" }
|
||||
{ "resize-byte-array" "byte-arrays" }
|
||||
{ "resize-bit-array" "bit-arrays" }
|
||||
{ "resize-float-array" "float-arrays" }
|
||||
}
|
||||
dup length [ >r first2 r> make-primitive ] 2each
|
||||
|
||||
|
|
|
@ -87,5 +87,5 @@ IN: bootstrap.stage2
|
|||
"output-image" get resource-path save-image-and-exit
|
||||
] if
|
||||
] [
|
||||
error. :c "listener" vocab-main execute
|
||||
print-error :c "listener" vocab-main execute
|
||||
] recover
|
||||
|
|
|
@ -16,12 +16,15 @@ f swap set-vocab-source-loaded?
|
|||
";"
|
||||
"<PRIVATE"
|
||||
"?{"
|
||||
"?V{"
|
||||
"BIN:"
|
||||
"B{"
|
||||
"BV{"
|
||||
"C:"
|
||||
"CHAR:"
|
||||
"DEFER:"
|
||||
"F{"
|
||||
"FV{"
|
||||
"FORGET:"
|
||||
"GENERIC#"
|
||||
"GENERIC:"
|
||||
|
|
|
@ -0,0 +1,8 @@
|
|||
IN: temporary
|
||||
USING: tools.test byte-arrays ;
|
||||
|
||||
[ B{ 1 2 3 0 0 0 } ] [ 6 B{ 1 2 3 } resize-byte-array ] unit-test
|
||||
|
||||
[ B{ 1 2 } ] [ 2 B{ 1 2 3 4 5 6 7 8 9 } resize-byte-array ] unit-test
|
||||
|
||||
[ -10 B{ } resize-byte-array ] unit-test-fails
|
|
@ -17,6 +17,8 @@ M: byte-array equal?
|
|||
|
||||
M: byte-array byte-length
|
||||
length ;
|
||||
M: byte-array resize
|
||||
resize-byte-array ;
|
||||
|
||||
INSTANCE: byte-array sequence
|
||||
INSTANCE: byte-array simple-c-ptr
|
||||
|
|
|
@ -0,0 +1,34 @@
|
|||
USING: arrays byte-arrays help.markup help.syntax kernel
|
||||
byte-vectors.private combinators ;
|
||||
IN: byte-vectors
|
||||
|
||||
ARTICLE: "byte-vectors" "Byte vectors"
|
||||
"A byte vector is a resizable mutable sequence of unsigned bytes. The literal syntax is covered in " { $link "syntax-byte-vectors" } ". Byte vector words are found in the " { $vocab-link "byte-vectors" } " vocabulary."
|
||||
$nl
|
||||
"Byte vectors form a class:"
|
||||
{ $subsection byte-vector }
|
||||
{ $subsection byte-vector? }
|
||||
"Creating byte vectors:"
|
||||
{ $subsection >byte-vector }
|
||||
{ $subsection <byte-vector> }
|
||||
"If you don't care about initial capacity, a more elegant way to create a new byte vector is to write:"
|
||||
{ $code "BV{ } clone" } ;
|
||||
|
||||
ABOUT: "byte-vectors"
|
||||
|
||||
HELP: byte-vector
|
||||
{ $description "The class of resizable byte vectors. See " { $link "syntax-byte-vectors" } " for syntax and " { $link "byte-vectors" } " for general information." } ;
|
||||
|
||||
HELP: <byte-vector>
|
||||
{ $values { "n" "a positive integer specifying initial capacity" } { "byte-vector" byte-vector } }
|
||||
{ $description "Creates a new byte vector that can hold " { $snippet "n" } " bytes before resizing." } ;
|
||||
|
||||
HELP: >byte-vector
|
||||
{ $values { "seq" "a sequence" } { "byte-vector" byte-vector } }
|
||||
{ $description "Outputs a freshly-allocated byte vector with the same elements as a given sequence." }
|
||||
{ $errors "Throws an error if the sequence contains elements other than integers." } ;
|
||||
|
||||
HELP: byte-array>vector
|
||||
{ $values { "byte-array" "an array" } { "length" "a non-negative integer" } { "byte-vector" byte-vector } }
|
||||
{ $description "Creates a new byte vector using the array for underlying storage with the specified initial length." }
|
||||
{ $warning "This word is in the " { $vocab-link "byte-vectors.private" } " vocabulary because it does not perform type or bounds checks. User code should call " { $link >byte-vector } " instead." } ;
|
|
@ -0,0 +1,14 @@
|
|||
IN: temporary
|
||||
USING: tools.test byte-vectors vectors sequences kernel ;
|
||||
|
||||
[ 0 ] [ 123 <byte-vector> length ] unit-test
|
||||
|
||||
: do-it
|
||||
123 [ over push ] each ;
|
||||
|
||||
[ t ] [
|
||||
3 <byte-vector> do-it
|
||||
3 <vector> do-it sequence=
|
||||
] unit-test
|
||||
|
||||
[ t ] [ BV{ } byte-vector? ] unit-test
|
|
@ -0,0 +1,33 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays kernel kernel.private math sequences
|
||||
sequences.private growable byte-arrays ;
|
||||
IN: byte-vectors
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: byte-array>vector ( byte-array capacity -- byte-vector )
|
||||
byte-vector construct-boa ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: <byte-vector> ( n -- byte-vector )
|
||||
<byte-array> 0 byte-array>vector ; inline
|
||||
|
||||
: >byte-vector ( seq -- byte-vector ) BV{ } clone-like ;
|
||||
|
||||
M: byte-vector like
|
||||
drop dup byte-vector? [
|
||||
dup byte-array?
|
||||
[ dup length byte-array>vector ] [ >byte-vector ] if
|
||||
] unless ;
|
||||
|
||||
M: byte-vector new
|
||||
drop [ <byte-array> ] keep >fixnum byte-array>vector ;
|
||||
|
||||
M: byte-vector equal?
|
||||
over byte-vector? [ sequence= ] [ 2drop f ] if ;
|
||||
|
||||
M: byte-array new-resizable drop <byte-vector> ;
|
||||
|
||||
INSTANCE: byte-vector growable
|
|
@ -207,3 +207,14 @@ DEFER: mixin-forget-test-g
|
|||
|
||||
[ { } mixin-forget-test-g ] unit-test-fails
|
||||
[ H{ } ] [ H{ } mixin-forget-test-g ] unit-test
|
||||
|
||||
! Method flattening interfered with mixin update
|
||||
MIXIN: flat-mx-1
|
||||
TUPLE: flat-mx-1-1 ; INSTANCE: flat-mx-1-1 flat-mx-1
|
||||
TUPLE: flat-mx-1-2 ; INSTANCE: flat-mx-1-2 flat-mx-1
|
||||
TUPLE: flat-mx-1-3 ; INSTANCE: flat-mx-1-3 flat-mx-1
|
||||
TUPLE: flat-mx-1-4 ; INSTANCE: flat-mx-1-4 flat-mx-1
|
||||
MIXIN: flat-mx-2 INSTANCE: flat-mx-2 flat-mx-1
|
||||
TUPLE: flat-mx-2-1 ; INSTANCE: flat-mx-2-1 flat-mx-2
|
||||
|
||||
[ t ] [ T{ flat-mx-2-1 } flat-mx-1? ] unit-test
|
||||
|
|
|
@ -255,7 +255,14 @@ PRIVATE>
|
|||
>r dup word-props r> union over set-word-props
|
||||
t "class" set-word-prop ;
|
||||
|
||||
GENERIC: update-methods ( class -- )
|
||||
GENERIC: update-predicate ( class -- )
|
||||
|
||||
M: class update-predicate drop ;
|
||||
|
||||
: update-predicates ( assoc -- )
|
||||
[ drop update-predicate ] assoc-each ;
|
||||
|
||||
GENERIC: update-methods ( assoc -- )
|
||||
|
||||
: define-class ( word members superclass metaclass -- )
|
||||
#! If it was already a class, update methods after.
|
||||
|
@ -264,8 +271,9 @@ GENERIC: update-methods ( class -- )
|
|||
over class-usages [
|
||||
uncache-classes
|
||||
dupd (define-class)
|
||||
] keep cache-classes
|
||||
r> [ update-methods ] [ drop ] if ;
|
||||
] keep cache-classes r>
|
||||
[ class-usages dup update-predicates update-methods ]
|
||||
[ drop ] if ;
|
||||
|
||||
GENERIC: class ( object -- class ) inline
|
||||
|
||||
|
|
|
@ -20,6 +20,8 @@ PREDICATE: class union-class
|
|||
over members union-predicate-quot
|
||||
define-predicate ;
|
||||
|
||||
M: union-class update-predicate define-union-predicate ;
|
||||
|
||||
: define-union-class ( class members -- )
|
||||
dupd f union-class define-class define-union-predicate ;
|
||||
|
||||
|
|
|
@ -334,10 +334,6 @@ cell 8 = [
|
|||
|
||||
[ \ + ] [ \ + [ <wrapper> ] compile-call ] unit-test
|
||||
|
||||
[ H{ } ] [
|
||||
100 [ (hashtable) ] compile-call [ reset-hash ] keep
|
||||
] unit-test
|
||||
|
||||
[ B{ 0 0 0 0 0 } ] [
|
||||
[ 5 <byte-array> ] compile-call
|
||||
] unit-test
|
||||
|
|
|
@ -238,3 +238,15 @@ DEFER: flushable-test-2
|
|||
[ \ bx forget ] with-compilation-unit
|
||||
|
||||
[ t ] [ \ ax compiled-usage [ drop interned? ] assoc-all? ] unit-test
|
||||
|
||||
DEFER: defer-redefine-test-2
|
||||
|
||||
[ ] [ "IN: temporary DEFER: defer-redefine-test-1" eval ] unit-test
|
||||
|
||||
[ ] [ "IN: temporary : defer-redefine-test-2 defer-redefine-test-1 1 ;" eval ] unit-test
|
||||
|
||||
[ defer-redefine-test-2 ] unit-test-fails
|
||||
|
||||
[ ] [ "IN: temporary : defer-redefine-test-1 2 ;" eval ] unit-test
|
||||
|
||||
[ 1 ] [ defer-redefine-test-2 ] unit-test
|
||||
|
|
|
@ -68,6 +68,15 @@ $nl
|
|||
|
||||
ABOUT: "continuations"
|
||||
|
||||
HELP: dispose
|
||||
{ $values { "object" "a disposable object" } }
|
||||
{ $contract "Releases operating system resources associated with a disposable object. No further operations can be performed on a disposable object after this call. Disposable objects include streams, memory mapped files, and so on." }
|
||||
{ $notes "You must close disposable objects after you are finished working with them, to avoid leaking operating system resources. A convenient way to automate this is by using the " { $link with-disposal } " word." } ;
|
||||
|
||||
HELP: with-disposal
|
||||
{ $values { "object" "a disposable object" } { "quot" "a quotation with stack effect " { $snippet "( object -- )" } } }
|
||||
{ $description "Calls the quotation, disposing the object with " { $link dispose } " after the quotation returns or if it throws an error." } ;
|
||||
|
||||
HELP: catchstack*
|
||||
{ $values { "catchstack" "a vector of continuations" } }
|
||||
{ $description "Outputs the current catchstack." } ;
|
||||
|
|
|
@ -135,6 +135,11 @@ PRIVATE>
|
|||
[ [ , f ] compose [ , drop t ] recover ] curry all?
|
||||
] { } make peek swap [ rethrow ] when ; inline
|
||||
|
||||
GENERIC: dispose ( object -- )
|
||||
|
||||
: with-disposal ( object quot -- )
|
||||
over [ dispose ] curry [ ] cleanup ; inline
|
||||
|
||||
TUPLE: condition restarts continuation ;
|
||||
|
||||
: <condition> ( error restarts cc -- condition )
|
||||
|
|
|
@ -0,0 +1 @@
|
|||
compiler
|
|
@ -383,41 +383,6 @@ IN: cpu.arm.intrinsics
|
|||
{ +output+ { "out" } }
|
||||
} define-intrinsic
|
||||
|
||||
\ (hashtable) [
|
||||
hashtable 4 cells %allot
|
||||
R12 f v>operand MOV
|
||||
R12 1 %set-slot
|
||||
R12 2 %set-slot
|
||||
R12 3 %set-slot
|
||||
! Store tagged ptr in reg
|
||||
"out" get object %store-tagged
|
||||
] H{
|
||||
{ +scratch+ { { f "out" } } }
|
||||
{ +output+ { "out" } }
|
||||
} define-intrinsic
|
||||
|
||||
\ string>sbuf [
|
||||
sbuf 3 cells %allot
|
||||
"length" operand 1 %set-slot
|
||||
"string" operand 2 %set-slot
|
||||
"out" get object %store-tagged
|
||||
] H{
|
||||
{ +input+ { { f "string" } { f "length" } } }
|
||||
{ +scratch+ { { f "out" } } }
|
||||
{ +output+ { "out" } }
|
||||
} define-intrinsic
|
||||
|
||||
\ array>vector [
|
||||
vector 3 cells %allot
|
||||
"length" operand 1 %set-slot
|
||||
"array" operand 2 %set-slot
|
||||
"out" get object %store-tagged
|
||||
] H{
|
||||
{ +input+ { { f "array" } { f "length" } } }
|
||||
{ +scratch+ { { f "out" } } }
|
||||
{ +output+ { "out" } }
|
||||
} define-intrinsic
|
||||
|
||||
! Alien intrinsics
|
||||
: %alien-accessor ( quot -- )
|
||||
"offset" operand dup %untag-fixnum
|
||||
|
|
|
@ -0,0 +1 @@
|
|||
compiler
|
|
@ -586,43 +586,6 @@ IN: cpu.ppc.intrinsics
|
|||
{ +output+ { "wrapper" } }
|
||||
} define-intrinsic
|
||||
|
||||
\ (hashtable) [
|
||||
hashtable 4 cells %allot
|
||||
f v>operand 12 LI
|
||||
12 11 1 cells STW
|
||||
12 11 2 cells STW
|
||||
12 11 3 cells STW
|
||||
! Store tagged ptr in reg
|
||||
"hashtable" get object %store-tagged
|
||||
] H{
|
||||
{ +scratch+ { { f "hashtable" } } }
|
||||
{ +output+ { "hashtable" } }
|
||||
} define-intrinsic
|
||||
|
||||
\ string>sbuf [
|
||||
sbuf 3 cells %allot
|
||||
"length" operand 11 1 cells STW
|
||||
"string" operand 11 2 cells STW
|
||||
! Store tagged ptr in reg
|
||||
"sbuf" get object %store-tagged
|
||||
] H{
|
||||
{ +input+ { { f "string" } { f "length" } } }
|
||||
{ +scratch+ { { f "sbuf" } } }
|
||||
{ +output+ { "sbuf" } }
|
||||
} define-intrinsic
|
||||
|
||||
\ array>vector [
|
||||
vector 3 cells %allot
|
||||
"length" operand 11 1 cells STW
|
||||
"array" operand 11 2 cells STW
|
||||
! Store tagged ptr in reg
|
||||
"vector" get object %store-tagged
|
||||
] H{
|
||||
{ +input+ { { f "array" } { f "length" } } }
|
||||
{ +scratch+ { { f "vector" } } }
|
||||
{ +output+ { "vector" } }
|
||||
} define-intrinsic
|
||||
|
||||
! Alien intrinsics
|
||||
: %alien-accessor ( quot -- )
|
||||
"offset" operand dup %untag-fixnum
|
||||
|
|
|
@ -0,0 +1 @@
|
|||
compiler
|
|
@ -0,0 +1 @@
|
|||
compiler
|
|
@ -0,0 +1 @@
|
|||
compiler
|
|
@ -447,45 +447,6 @@ IN: cpu.x86.intrinsics
|
|||
{ +output+ { "wrapper" } }
|
||||
} define-intrinsic
|
||||
|
||||
\ (hashtable) [
|
||||
hashtable 4 cells [
|
||||
1 object@ f v>operand MOV
|
||||
2 object@ f v>operand MOV
|
||||
3 object@ f v>operand MOV
|
||||
! Store tagged ptr in reg
|
||||
"hashtable" get object %store-tagged
|
||||
] %allot
|
||||
] H{
|
||||
{ +scratch+ { { f "hashtable" } } }
|
||||
{ +output+ { "hashtable" } }
|
||||
} define-intrinsic
|
||||
|
||||
\ string>sbuf [
|
||||
sbuf 3 cells [
|
||||
1 object@ "length" operand MOV
|
||||
2 object@ "string" operand MOV
|
||||
! Store tagged ptr in reg
|
||||
"sbuf" get object %store-tagged
|
||||
] %allot
|
||||
] H{
|
||||
{ +input+ { { f "string" } { f "length" } } }
|
||||
{ +scratch+ { { f "sbuf" } } }
|
||||
{ +output+ { "sbuf" } }
|
||||
} define-intrinsic
|
||||
|
||||
\ array>vector [
|
||||
vector 3 cells [
|
||||
1 object@ "length" operand MOV
|
||||
2 object@ "array" operand MOV
|
||||
! Store tagged ptr in reg
|
||||
"vector" get object %store-tagged
|
||||
] %allot
|
||||
] H{
|
||||
{ +input+ { { f "array" } { f "length" } } }
|
||||
{ +scratch+ { { f "vector" } } }
|
||||
{ +output+ { "vector" } }
|
||||
} define-intrinsic
|
||||
|
||||
! Alien intrinsics
|
||||
: %alien-accessor ( quot -- )
|
||||
"offset" operand %untag-fixnum
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
USING: help.markup help.syntax kernel ;
|
||||
USING: help.markup help.syntax kernel quotations ;
|
||||
IN: dlists
|
||||
|
||||
ARTICLE: "dlists" "Doubly-linked lists"
|
||||
|
@ -13,23 +13,31 @@ $nl
|
|||
{ $subsection dlist? }
|
||||
"Constructing a dlist:"
|
||||
{ $subsection <dlist> }
|
||||
"Double-ended queue protocol:"
|
||||
{ $subsection dlist-empty? }
|
||||
"Working with the front of the list:"
|
||||
{ $subsection push-front }
|
||||
{ $subsection push-front* }
|
||||
{ $subsection peek-front }
|
||||
{ $subsection pop-front }
|
||||
{ $subsection pop-front* }
|
||||
"Working with the back of the list:"
|
||||
{ $subsection push-back }
|
||||
{ $subsection push-back* }
|
||||
{ $subsection peek-back }
|
||||
{ $subsection pop-back }
|
||||
{ $subsection pop-back* }
|
||||
"Finding out the length:"
|
||||
{ $subsection dlist-empty? }
|
||||
{ $subsection dlist-length }
|
||||
"Iterating over elements:"
|
||||
{ $subsection dlist-each }
|
||||
{ $subsection dlist-find }
|
||||
{ $subsection dlist-contains? }
|
||||
"Deleting a node matching a predicate:"
|
||||
{ $subsection delete-node* }
|
||||
"Deleting a node:"
|
||||
{ $subsection delete-node }
|
||||
{ $subsection dlist-delete }
|
||||
"Deleting a node matching a predicate:"
|
||||
{ $subsection delete-node-if* }
|
||||
{ $subsection delete-node-if }
|
||||
"Consuming all nodes:"
|
||||
{ $subsection dlist-slurp } ;
|
||||
|
||||
|
@ -77,7 +85,7 @@ HELP: pop-back*
|
|||
{ $see-also push-front push-back pop-front pop-front* pop-back } ;
|
||||
|
||||
HELP: dlist-find
|
||||
{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } }
|
||||
{ $values { "quot" quotation } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } }
|
||||
{ $description "Applies the quotation to each element of the " { $link dlist } " in turn, until it outputs a true value or the end of the " { $link dlist } " is reached. Outputs either the object it found or " { $link f } ", and a boolean which is true if an object is found." }
|
||||
{ $notes "Returns a boolean to allow dlists to store " { $link f } "."
|
||||
$nl
|
||||
|
@ -85,20 +93,20 @@ HELP: dlist-find
|
|||
} ;
|
||||
|
||||
HELP: dlist-contains?
|
||||
{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } { "?" "a boolean" } }
|
||||
{ $values { "quot" quotation } { "dlist" { $link dlist } } { "?" "a boolean" } }
|
||||
{ $description "Just like " { $link dlist-find } " except it doesn't return the object." }
|
||||
{ $notes "This operation is O(n)." } ;
|
||||
|
||||
HELP: delete-node*
|
||||
{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } }
|
||||
HELP: delete-node-if*
|
||||
{ $values { "quot" quotation } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } }
|
||||
{ $description "Calls " { $link dlist-find } " on the " { $link dlist } " and deletes the node returned, if any. Returns the value of the deleted node and a boolean to allow the deleted value to distinguished from " { $link f } ", for nothing deleted." }
|
||||
{ $notes "This operation is O(n)." } ;
|
||||
|
||||
HELP: delete-node
|
||||
{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } }
|
||||
{ $description "Like " { $link delete-node* } " but cannot distinguish from deleting a node whose value is " { $link f } " or not deleting an element." }
|
||||
HELP: delete-node-if
|
||||
{ $values { "quot" quotation } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } }
|
||||
{ $description "Like " { $link delete-node-if* } " but cannot distinguish from deleting a node whose value is " { $link f } " or not deleting an element." }
|
||||
{ $notes "This operation is O(n)." } ;
|
||||
|
||||
HELP: dlist-each
|
||||
{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } }
|
||||
{ $values { "quot" quotation } { "dlist" { $link dlist } } }
|
||||
{ $description "Iterate a " { $link dlist } ", calling quot on each element." } ;
|
||||
|
|
|
@ -49,14 +49,14 @@ IN: temporary
|
|||
[ f ] [ <dlist> 1 over push-back [ 2 = ] swap dlist-contains? ] unit-test
|
||||
[ t ] [ <dlist> 1 over push-back [ 1 = ] swap dlist-contains? ] unit-test
|
||||
|
||||
[ 1 ] [ <dlist> 1 over push-back [ 1 = ] swap delete-node ] unit-test
|
||||
[ t ] [ <dlist> 1 over push-back [ 1 = ] over delete-node drop dlist-empty? ] unit-test
|
||||
[ t ] [ <dlist> 1 over push-back [ 1 = ] over delete-node drop dlist-empty? ] unit-test
|
||||
[ 0 ] [ <dlist> 1 over push-back [ 1 = ] over delete-node drop dlist-length ] unit-test
|
||||
[ 1 ] [ <dlist> 1 over push-back 2 over push-back [ 1 = ] over delete-node drop dlist-length ] unit-test
|
||||
[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back [ 1 = ] over delete-node drop dlist-length ] unit-test
|
||||
[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back [ 2 = ] over delete-node drop dlist-length ] unit-test
|
||||
[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back [ 3 = ] over delete-node drop dlist-length ] unit-test
|
||||
[ 1 ] [ <dlist> 1 over push-back [ 1 = ] swap delete-node-if ] unit-test
|
||||
[ t ] [ <dlist> 1 over push-back [ 1 = ] over delete-node-if drop dlist-empty? ] unit-test
|
||||
[ t ] [ <dlist> 1 over push-back [ 1 = ] over delete-node-if drop dlist-empty? ] unit-test
|
||||
[ 0 ] [ <dlist> 1 over push-back [ 1 = ] over delete-node-if drop dlist-length ] unit-test
|
||||
[ 1 ] [ <dlist> 1 over push-back 2 over push-back [ 1 = ] over delete-node-if drop dlist-length ] unit-test
|
||||
[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back [ 1 = ] over delete-node-if drop dlist-length ] unit-test
|
||||
[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back [ 2 = ] over delete-node-if drop dlist-length ] unit-test
|
||||
[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back [ 3 = ] over delete-node-if drop dlist-length ] unit-test
|
||||
|
||||
[ 0 ] [ <dlist> dlist-length ] unit-test
|
||||
[ 1 ] [ <dlist> 1 over push-front dlist-length ] unit-test
|
||||
|
|
|
@ -63,12 +63,22 @@ C: <dlist-node> dlist-node
|
|||
>r dlist-front r> (dlist-each-node) ; inline
|
||||
PRIVATE>
|
||||
|
||||
: push-front ( obj dlist -- )
|
||||
[ dlist-front f swap <dlist-node> dup set-next-prev ] keep
|
||||
: push-front* ( obj dlist -- dlist-node )
|
||||
[ dlist-front f swap <dlist-node> dup dup set-next-prev ] keep
|
||||
[ set-dlist-front ] keep
|
||||
[ set-back-to-front ] keep
|
||||
inc-length ;
|
||||
|
||||
: push-front ( obj dlist -- )
|
||||
push-front* drop ;
|
||||
|
||||
: push-back* ( obj dlist -- dlist-node )
|
||||
[ dlist-back f <dlist-node> ] keep
|
||||
[ dlist-back set-next-when ] 2keep
|
||||
[ set-dlist-back ] 2keep
|
||||
[ set-front-to-back ] keep
|
||||
inc-length ;
|
||||
|
||||
: push-back ( obj dlist -- )
|
||||
[ dlist-back f <dlist-node> ] keep
|
||||
[ dlist-back set-next-when ] 2keep
|
||||
|
@ -76,6 +86,9 @@ PRIVATE>
|
|||
[ set-front-to-back ] keep
|
||||
inc-length ;
|
||||
|
||||
: peek-front ( dlist -- obj )
|
||||
dlist-front dlist-node-obj ;
|
||||
|
||||
: pop-front ( dlist -- obj )
|
||||
dup dlist-front [
|
||||
dup dlist-node-next
|
||||
|
@ -87,6 +100,9 @@ PRIVATE>
|
|||
|
||||
: pop-front* ( dlist -- ) pop-front drop ;
|
||||
|
||||
: peek-back ( dlist -- obj )
|
||||
dlist-back dlist-node-obj ;
|
||||
|
||||
: pop-back ( dlist -- obj )
|
||||
dup dlist-back [
|
||||
dup dlist-node-prev
|
||||
|
@ -108,25 +124,25 @@ PRIVATE>
|
|||
dup dlist-node-prev over dlist-node-next set-prev-when
|
||||
dup dlist-node-next swap dlist-node-prev set-next-when ;
|
||||
|
||||
: (delete-node) ( dlist dlist-node -- )
|
||||
: delete-node ( dlist dlist-node -- )
|
||||
{
|
||||
{ [ over dlist-front over eq? ] [ drop pop-front* ] }
|
||||
{ [ over dlist-back over eq? ] [ drop pop-back* ] }
|
||||
{ [ t ] [ unlink-node dec-length ] }
|
||||
} cond ;
|
||||
|
||||
: delete-node* ( quot dlist -- obj/f ? )
|
||||
: delete-node-if* ( quot dlist -- obj/f ? )
|
||||
tuck dlist-find-node [
|
||||
[ (delete-node) ] keep [ dlist-node-obj t ] [ f f ] if*
|
||||
[ delete-node ] keep [ dlist-node-obj t ] [ f f ] if*
|
||||
] [
|
||||
2drop f f
|
||||
] if ; inline
|
||||
|
||||
: delete-node ( quot dlist -- obj/f )
|
||||
delete-node* drop ; inline
|
||||
: delete-node-if ( quot dlist -- obj/f )
|
||||
delete-node-if* drop ; inline
|
||||
|
||||
: dlist-delete ( obj dlist -- obj/f )
|
||||
>r [ eq? ] curry r> delete-node ;
|
||||
>r [ eq? ] curry r> delete-node-if ;
|
||||
|
||||
: dlist-each ( dlist quot -- )
|
||||
[ dlist-node-obj ] swap compose dlist-each-node ; inline
|
||||
|
|
|
@ -2,3 +2,9 @@ IN: temporary
|
|||
USING: float-arrays tools.test ;
|
||||
|
||||
[ F{ 1.0 1.0 1.0 } ] [ 3 1.0 <float-array> ] unit-test
|
||||
|
||||
[ F{ 1 2 3 0 0 0 } ] [ 6 F{ 1 2 3 } resize-float-array ] unit-test
|
||||
|
||||
[ F{ 1 2 } ] [ 2 F{ 1 2 3 4 5 6 7 8 9 } resize-float-array ] unit-test
|
||||
|
||||
[ -10 F{ } resize-float-array ] unit-test-fails
|
||||
|
|
|
@ -30,6 +30,9 @@ M: float-array new drop 0.0 <float-array> ;
|
|||
M: float-array equal?
|
||||
over float-array? [ sequence= ] [ 2drop f ] if ;
|
||||
|
||||
M: float-array resize
|
||||
resize-float-array ;
|
||||
|
||||
INSTANCE: float-array sequence
|
||||
INSTANCE: float-array simple-c-ptr
|
||||
INSTANCE: float-array c-ptr
|
||||
|
|
|
@ -0,0 +1,34 @@
|
|||
USING: arrays float-arrays help.markup help.syntax kernel
|
||||
float-vectors.private combinators ;
|
||||
IN: float-vectors
|
||||
|
||||
ARTICLE: "float-vectors" "Float vectors"
|
||||
"A float vector is a resizable mutable sequence of unsigned floats. The literal syntax is covered in " { $link "syntax-float-vectors" } ". Float vector words are found in the " { $vocab-link "float-vectors" } " vocabulary."
|
||||
$nl
|
||||
"Float vectors form a class:"
|
||||
{ $subsection float-vector }
|
||||
{ $subsection float-vector? }
|
||||
"Creating float vectors:"
|
||||
{ $subsection >float-vector }
|
||||
{ $subsection <float-vector> }
|
||||
"If you don't care about initial capacity, a more elegant way to create a new float vector is to write:"
|
||||
{ $code "BV{ } clone" } ;
|
||||
|
||||
ABOUT: "float-vectors"
|
||||
|
||||
HELP: float-vector
|
||||
{ $description "The class of resizable float vectors. See " { $link "syntax-float-vectors" } " for syntax and " { $link "float-vectors" } " for general information." } ;
|
||||
|
||||
HELP: <float-vector>
|
||||
{ $values { "n" "a positive integer specifying initial capacity" } { "float-vector" float-vector } }
|
||||
{ $description "Creates a new float vector that can hold " { $snippet "n" } " floats before resizing." } ;
|
||||
|
||||
HELP: >float-vector
|
||||
{ $values { "seq" "a sequence" } { "float-vector" float-vector } }
|
||||
{ $description "Outputs a freshly-allocated float vector with the same elements as a given sequence." }
|
||||
{ $errors "Throws an error if the sequence contains elements other than real numbers." } ;
|
||||
|
||||
HELP: float-array>vector
|
||||
{ $values { "float-array" "an array" } { "length" "a non-negative integer" } { "float-vector" float-vector } }
|
||||
{ $description "Creates a new float vector using the array for underlying storage with the specified initial length." }
|
||||
{ $warning "This word is in the " { $vocab-link "float-vectors.private" } " vocabulary because it does not perform type or bounds checks. User code should call " { $link >float-vector } " instead." } ;
|
|
@ -0,0 +1,14 @@
|
|||
IN: temporary
|
||||
USING: tools.test float-vectors vectors sequences kernel ;
|
||||
|
||||
[ 0 ] [ 123 <float-vector> length ] unit-test
|
||||
|
||||
: do-it
|
||||
12345 [ over push ] each ;
|
||||
|
||||
[ t ] [
|
||||
3 <float-vector> do-it
|
||||
3 <vector> do-it sequence=
|
||||
] unit-test
|
||||
|
||||
[ t ] [ FV{ } float-vector? ] unit-test
|
|
@ -0,0 +1,33 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays kernel kernel.private math sequences
|
||||
sequences.private growable float-arrays ;
|
||||
IN: float-vectors
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: float-array>vector ( float-array length -- float-vector )
|
||||
float-vector construct-boa ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: <float-vector> ( n -- float-vector )
|
||||
0.0 <float-array> 0 float-array>vector ; inline
|
||||
|
||||
: >float-vector ( seq -- float-vector ) FV{ } clone-like ;
|
||||
|
||||
M: float-vector like
|
||||
drop dup float-vector? [
|
||||
dup float-array?
|
||||
[ dup length float-array>vector ] [ >float-vector ] if
|
||||
] unless ;
|
||||
|
||||
M: float-vector new
|
||||
drop [ 0.0 <float-array> ] keep >fixnum float-array>vector ;
|
||||
|
||||
M: float-vector equal?
|
||||
over float-vector? [ sequence= ] [ 2drop f ] if ;
|
||||
|
||||
M: float-array new-resizable drop <float-vector> ;
|
||||
|
||||
INSTANCE: float-vector growable
|
|
@ -19,8 +19,8 @@ SYMBOL: compiled
|
|||
: queue-compile ( word -- )
|
||||
{
|
||||
{ [ dup compiled get key? ] [ drop ] }
|
||||
{ [ dup inlined-block? ] [ drop ] }
|
||||
{ [ dup primitive? ] [ drop ] }
|
||||
{ [ dup deferred? ] [ drop ] }
|
||||
{ [ t ] [ dup compile-queue get set-at ] }
|
||||
} cond ;
|
||||
|
||||
|
|
|
@ -107,5 +107,5 @@ M: class forget* ( class -- )
|
|||
dup uncache-class
|
||||
forget-word ;
|
||||
|
||||
M: class update-methods ( class -- )
|
||||
class-usages implementors* [ make-generic ] each ;
|
||||
M: assoc update-methods ( assoc -- )
|
||||
implementors* [ make-generic ] each ;
|
||||
|
|
|
@ -116,10 +116,6 @@ HELP: <hashtable>
|
|||
{ $values { "n" "a positive integer specifying hashtable capacity" } { "hash" "a new hashtable" } }
|
||||
{ $description "Create a new hashtable capable of storing " { $snippet "n" } " key/value pairs before growing." } ;
|
||||
|
||||
HELP: (hashtable) ( -- hash )
|
||||
{ $values { "hash" "a new hashtable" } }
|
||||
{ $description "Allocates a hashtable stub object without an underlying array. User code should call " { $link <hashtable> } " instead." } ;
|
||||
|
||||
HELP: associate
|
||||
{ $values { "value" "a value" } { "key" "a key" } { "hash" "a new " { $link hashtable } } }
|
||||
{ $description "Create a new hashtable holding one key/value pair." } ;
|
||||
|
|
|
@ -122,7 +122,7 @@ IN: hashtables
|
|||
PRIVATE>
|
||||
|
||||
: <hashtable> ( n -- hash )
|
||||
(hashtable) [ reset-hash ] keep ;
|
||||
hashtable construct-empty [ reset-hash ] keep ;
|
||||
|
||||
M: hashtable at* ( key hash -- value ? )
|
||||
key@ [ 3 fixnum+fast slot t ] [ 2drop f f ] if ;
|
||||
|
|
|
@ -402,10 +402,14 @@ TUPLE: recursive-declare-error word ;
|
|||
dup node-param #return node,
|
||||
dataflow-graph get 1array over set-node-children ;
|
||||
|
||||
: inlined-block? "inlined-block" word-prop ;
|
||||
|
||||
: <inlined-block> gensym dup t "inlined-block" set-word-prop ;
|
||||
|
||||
: inline-block ( word -- node-block data )
|
||||
[
|
||||
copy-inference nest-node
|
||||
dup word-def swap gensym
|
||||
dup word-def swap <inlined-block>
|
||||
[ infer-quot-recursive ] 2keep
|
||||
#label unnest-node
|
||||
] H{ } make-assoc ;
|
||||
|
|
|
@ -421,6 +421,8 @@ DEFER: bar
|
|||
{ 2 1 } [ [ + ] [ ] [ ] cleanup ] unit-test-effect
|
||||
{ 2 1 } [ [ + ] [ 3drop 0 ] recover ] unit-test-effect
|
||||
|
||||
\ dispose must-infer
|
||||
|
||||
! Test stream protocol
|
||||
\ set-timeout must-infer
|
||||
\ stream-read must-infer
|
||||
|
@ -430,7 +432,6 @@ DEFER: bar
|
|||
\ stream-write must-infer
|
||||
\ stream-write1 must-infer
|
||||
\ stream-nl must-infer
|
||||
\ stream-close must-infer
|
||||
\ stream-format must-infer
|
||||
\ stream-write-table must-infer
|
||||
\ stream-flush must-infer
|
||||
|
|
|
@ -167,9 +167,6 @@ t over set-effect-terminated?
|
|||
|
||||
\ rehash-string { string } { } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ string>sbuf { string integer } { sbuf } <effect> "inferred-effect" set-word-prop
|
||||
\ string>sbuf make-flushable
|
||||
|
||||
\ bignum>fixnum { bignum } { fixnum } <effect> "inferred-effect" set-word-prop
|
||||
\ bignum>fixnum make-foldable
|
||||
|
||||
|
@ -491,12 +488,18 @@ t over set-effect-terminated?
|
|||
\ resize-array { integer array } { array } <effect> "inferred-effect" set-word-prop
|
||||
\ resize-array make-flushable
|
||||
|
||||
\ resize-byte-array { integer byte-array } { byte-array } <effect> "inferred-effect" set-word-prop
|
||||
\ resize-byte-array make-flushable
|
||||
|
||||
\ resize-bit-array { integer bit-array } { bit-array } <effect> "inferred-effect" set-word-prop
|
||||
\ resize-bit-array make-flushable
|
||||
|
||||
\ resize-float-array { integer float-array } { float-array } <effect> "inferred-effect" set-word-prop
|
||||
\ resize-float-array make-flushable
|
||||
|
||||
\ resize-string { integer string } { string } <effect> "inferred-effect" set-word-prop
|
||||
\ resize-string make-flushable
|
||||
|
||||
\ (hashtable) { } { hashtable } <effect> "inferred-effect" set-word-prop
|
||||
\ (hashtable) make-flushable
|
||||
|
||||
\ <array> { integer object } { array } <effect> "inferred-effect" set-word-prop
|
||||
\ <array> make-flushable
|
||||
|
||||
|
@ -532,9 +535,6 @@ t over set-effect-terminated?
|
|||
\ (clone) { object } { object } <effect> "inferred-effect" set-word-prop
|
||||
\ (clone) make-flushable
|
||||
|
||||
\ array>vector { array integer } { vector } <effect> "inferred-effect" set-word-prop
|
||||
\ array>vector make-flushable
|
||||
|
||||
\ <string> { integer integer } { string } <effect> "inferred-effect" set-word-prop
|
||||
\ <string> make-flushable
|
||||
|
||||
|
|
|
@ -1,5 +1,5 @@
|
|||
IN: temporary
|
||||
USING: tools.test io.files io threads kernel ;
|
||||
USING: tools.test io.files io threads kernel continuations ;
|
||||
|
||||
[ "passwd" ] [ "/etc/passwd" file-name ] unit-test
|
||||
[ "awk/" ] [ "/usr/libexec/awk/" file-name ] unit-test
|
||||
|
@ -41,7 +41,7 @@ USING: tools.test io.files io threads kernel ;
|
|||
[ ] [ "test-blah" resource-path make-directory ] unit-test
|
||||
|
||||
[ ] [
|
||||
"test-blah/fooz" resource-path <file-writer> stream-close
|
||||
"test-blah/fooz" resource-path <file-writer> dispose
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
|
|
|
@ -1,12 +1,12 @@
|
|||
USING: help.markup help.syntax quotations hashtables kernel
|
||||
classes strings ;
|
||||
classes strings continuations ;
|
||||
IN: io
|
||||
|
||||
ARTICLE: "stream-protocol" "Stream protocol"
|
||||
"The stream protocol consists of a large number of generic words, many of which are optional."
|
||||
$nl
|
||||
"A word required to be implemented for all streams:"
|
||||
{ $subsection stream-close }
|
||||
"All streams must implement the " { $link dispose } " word in addition to the stream protocol."
|
||||
$nl
|
||||
"Three words are required for input streams:"
|
||||
{ $subsection stream-read1 }
|
||||
{ $subsection stream-read }
|
||||
|
@ -73,16 +73,10 @@ ARTICLE: "streams" "Streams"
|
|||
|
||||
ABOUT: "streams"
|
||||
|
||||
HELP: stream-close
|
||||
{ $values { "stream" "a stream" } }
|
||||
{ $contract "Closes the stream. This releases any external resources associated with the stream, such as file handles and network connections. No further operations can be performed on the stream after this call." }
|
||||
{ $notes "You must close streams after you are finished working with them. A convenient way to automate this is by using the " { $link with-stream } " word." }
|
||||
$io-error ;
|
||||
|
||||
HELP: set-timeout
|
||||
{ $values { "n" "an integer" } { "stream" "a stream" } }
|
||||
{ $contract "Sets a timeout, in milliseconds, for closing the stream if there is no activity. Not all streams support timeouts." }
|
||||
$io-error ;
|
||||
{ $contract "Sets a timeout, in milliseconds, for input and output operations on the stream. If a read or a write is initiated and no activity is seen before the timeout expires, an error will be thrown to the caller of the operation being performed." }
|
||||
{ $notes "Whether or not the stream is closed when the error is thrown is implementation-specific, and user code should take care to close the stream on all error conditions in any case." } ;
|
||||
|
||||
HELP: stream-readln
|
||||
{ $values { "stream" "an input stream" } { "str" string } }
|
||||
|
|
|
@ -4,7 +4,6 @@ USING: hashtables generic kernel math namespaces sequences strings
|
|||
continuations assocs io.styles sbufs ;
|
||||
IN: io
|
||||
|
||||
GENERIC: stream-close ( stream -- )
|
||||
GENERIC: set-timeout ( n stream -- )
|
||||
GENERIC: stream-readln ( stream -- str )
|
||||
GENERIC: stream-read1 ( stream -- ch/f )
|
||||
|
@ -29,7 +28,7 @@ GENERIC: stream-write-table ( table-cells style stream -- )
|
|||
[ over stream-write (stream-copy) ] [ 2drop ] if* ;
|
||||
|
||||
: stream-copy ( in out -- )
|
||||
[ 2dup (stream-copy) ] [ stream-close stream-close ] [ ]
|
||||
[ 2dup (stream-copy) ] [ dispose dispose ] [ ]
|
||||
cleanup ;
|
||||
|
||||
! Default stream
|
||||
|
@ -54,9 +53,7 @@ SYMBOL: stderr
|
|||
stdio swap with-variable ; inline
|
||||
|
||||
: with-stream ( stream quot -- )
|
||||
swap [
|
||||
[ stdio get stream-close ] [ ] cleanup
|
||||
] with-stream* ; inline
|
||||
[ with-stream* ] curry with-disposal ; inline
|
||||
|
||||
: tabular-output ( style quot -- )
|
||||
swap >r { } make r> stdio get stream-write-table ; inline
|
||||
|
|
|
@ -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: kernel kernel.private namespaces io
|
||||
strings sequences math generic threads.private classes
|
||||
io.backend io.streams.lines io.streams.plain io.streams.duplex
|
||||
io.files ;
|
||||
io.files continuations ;
|
||||
IN: io.streams.c
|
||||
|
||||
TUPLE: c-writer handle ;
|
||||
|
@ -19,7 +19,7 @@ M: c-writer stream-write
|
|||
M: c-writer stream-flush
|
||||
c-writer-handle fflush ;
|
||||
|
||||
M: c-writer stream-close
|
||||
M: c-writer dispose
|
||||
c-writer-handle fclose ;
|
||||
|
||||
TUPLE: c-reader handle ;
|
||||
|
@ -46,7 +46,7 @@ M: c-reader stream-read-until
|
|||
[ swap read-until-loop ] "" make swap
|
||||
over empty? over not and [ 2drop f f ] when ;
|
||||
|
||||
M: c-reader stream-close
|
||||
M: c-reader dispose
|
||||
c-reader-handle fclose ;
|
||||
|
||||
: <duplex-c-stream> ( in out -- stream )
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
USING: help.markup help.syntax io ;
|
||||
USING: help.markup help.syntax io continuations ;
|
||||
IN: io.streams.duplex
|
||||
|
||||
ARTICLE: "io.streams.duplex" "Duplex streams"
|
||||
|
@ -19,4 +19,4 @@ HELP: <duplex-stream>
|
|||
HELP: check-closed
|
||||
{ $values { "stream" "a duplex stream" } }
|
||||
{ $description "Throws a " { $link check-closed } " error if the stream has already been closed." }
|
||||
{ $error-description "This error is thrown when performing an I/O operation on a " { $link duplex-stream } " which has been closed with " { $link stream-close } "." } ;
|
||||
{ $error-description "This error is thrown when performing an I/O operation on a " { $link duplex-stream } " which has been closed with " { $link dispose } "." } ;
|
||||
|
|
|
@ -6,7 +6,7 @@ TUPLE: closing-stream closed? ;
|
|||
|
||||
: <closing-stream> closing-stream construct-empty ;
|
||||
|
||||
M: closing-stream stream-close
|
||||
M: closing-stream dispose
|
||||
dup closing-stream-closed? [
|
||||
"Closing twice!" throw
|
||||
] [
|
||||
|
@ -17,24 +17,24 @@ TUPLE: unclosable-stream ;
|
|||
|
||||
: <unclosable-stream> unclosable-stream construct-empty ;
|
||||
|
||||
M: unclosable-stream stream-close
|
||||
M: unclosable-stream dispose
|
||||
"Can't close me!" throw ;
|
||||
|
||||
[ ] [
|
||||
<closing-stream> <closing-stream> <duplex-stream>
|
||||
dup stream-close stream-close
|
||||
dup dispose dispose
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
<unclosable-stream> <closing-stream> [
|
||||
<duplex-stream>
|
||||
[ dup stream-close ] catch 2drop
|
||||
[ dup dispose ] catch 2drop
|
||||
] keep closing-stream-closed?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
<closing-stream> [ <unclosable-stream>
|
||||
<duplex-stream>
|
||||
[ dup stream-close ] catch 2drop
|
||||
[ dup dispose ] catch 2drop
|
||||
] keep closing-stream-closed?
|
||||
] unit-test
|
||||
|
|
|
@ -65,14 +65,14 @@ M: duplex-stream make-cell-stream
|
|||
M: duplex-stream stream-write-table
|
||||
duplex-stream-out+ stream-write-table ;
|
||||
|
||||
M: duplex-stream stream-close
|
||||
M: duplex-stream dispose
|
||||
#! The output stream is closed first, in case both streams
|
||||
#! are attached to the same file descriptor, the output
|
||||
#! buffer needs to be flushed before we close the fd.
|
||||
dup duplex-stream-closed? [
|
||||
t over set-duplex-stream-closed?
|
||||
[ dup duplex-stream-out stream-close ]
|
||||
[ dup duplex-stream-in stream-close ] [ ] cleanup
|
||||
[ dup duplex-stream-out dispose ]
|
||||
[ dup duplex-stream-in dispose ] [ ] cleanup
|
||||
] unless drop ;
|
||||
|
||||
M: duplex-stream set-timeout
|
||||
|
|
|
@ -1,14 +1,14 @@
|
|||
! Copyright (C) 2006, 2007 Slava Pestov.
|
||||
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: io.streams.nested
|
||||
USING: arrays generic assocs kernel namespaces strings
|
||||
quotations io ;
|
||||
quotations io continuations ;
|
||||
|
||||
TUPLE: ignore-close-stream ;
|
||||
|
||||
: <ignore-close-stream> ignore-close-stream construct-delegate ;
|
||||
|
||||
M: ignore-close-stream stream-close drop ;
|
||||
M: ignore-close-stream dispose drop ;
|
||||
|
||||
TUPLE: style-stream style ;
|
||||
|
||||
|
@ -44,4 +44,4 @@ TUPLE: block-stream ;
|
|||
|
||||
: <block-stream> block-stream construct-delegate ;
|
||||
|
||||
M: block-stream stream-close drop ;
|
||||
M: block-stream dispose drop ;
|
||||
|
|
|
@ -2,11 +2,13 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: io.streams.string
|
||||
USING: io kernel math namespaces sequences sbufs strings
|
||||
generic splitting io.streams.plain io.streams.lines ;
|
||||
generic splitting io.streams.plain io.streams.lines
|
||||
continuations ;
|
||||
|
||||
M: sbuf dispose drop ;
|
||||
|
||||
M: sbuf stream-write1 push ;
|
||||
M: sbuf stream-write push-all ;
|
||||
M: sbuf stream-close drop ;
|
||||
M: sbuf stream-flush drop ;
|
||||
|
||||
: <string-writer> ( -- stream )
|
||||
|
|
|
@ -18,11 +18,10 @@ GENERIC: stream-read-quot ( stream -- quot/f )
|
|||
[ parse-lines in get ] with-compilation-unit in set ;
|
||||
|
||||
: read-quot-step ( lines -- quot/f )
|
||||
[ parse-lines-interactive ] catch {
|
||||
{ [ dup delegate unexpected-eof? ] [ 2drop f ] }
|
||||
{ [ dup not ] [ drop ] }
|
||||
{ [ t ] [ rethrow ] }
|
||||
} cond ;
|
||||
[ parse-lines-interactive ] [
|
||||
dup delegate unexpected-eof?
|
||||
[ 2drop f ] [ rethrow ] if
|
||||
] recover ;
|
||||
|
||||
: read-quot-loop ( stream accum -- quot/f )
|
||||
over stream-readln dup [
|
||||
|
|
|
@ -1,9 +1,10 @@
|
|||
! Copyright (C) 2003, 2007 Slava Pestov.
|
||||
! Copyright (C) 2003, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays byte-arrays bit-arrays 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 ;
|
||||
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 ;
|
||||
IN: prettyprint.backend
|
||||
|
||||
GENERIC: pprint* ( obj -- )
|
||||
|
@ -143,8 +144,11 @@ M: quotation pprint-delims drop \ [ \ ] ;
|
|||
M: curry pprint-delims drop \ [ \ ] ;
|
||||
M: array pprint-delims drop \ { \ } ;
|
||||
M: byte-array pprint-delims drop \ B{ \ } ;
|
||||
M: byte-vector pprint-delims drop \ BV{ \ } ;
|
||||
M: bit-array pprint-delims drop \ ?{ \ } ;
|
||||
M: bit-vector pprint-delims drop \ ?V{ \ } ;
|
||||
M: float-array pprint-delims drop \ F{ \ } ;
|
||||
M: float-vector pprint-delims drop \ FV{ \ } ;
|
||||
M: vector pprint-delims drop \ V{ \ } ;
|
||||
M: hashtable pprint-delims drop \ H{ \ } ;
|
||||
M: tuple pprint-delims drop \ T{ \ } ;
|
||||
|
@ -155,6 +159,10 @@ GENERIC: >pprint-sequence ( obj -- seq )
|
|||
|
||||
M: object >pprint-sequence ;
|
||||
|
||||
M: vector >pprint-sequence ;
|
||||
M: bit-vector >pprint-sequence ;
|
||||
M: byte-vector >pprint-sequence ;
|
||||
M: float-vector >pprint-sequence ;
|
||||
M: hashtable >pprint-sequence >alist ;
|
||||
M: tuple >pprint-sequence tuple>array ;
|
||||
M: wrapper >pprint-sequence wrapped 1array ;
|
||||
|
|
|
@ -1,9 +1,16 @@
|
|||
! Copyright (C) 2004, 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math strings kernel.private sequences.private
|
||||
sequences strings growable strings.private sbufs.private ;
|
||||
USING: kernel math strings sequences.private sequences strings
|
||||
growable strings.private ;
|
||||
IN: sbufs
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: string>sbuf ( string length -- sbuf )
|
||||
sbuf construct-boa ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: <sbuf> ( n -- sbuf ) 0 <string> 0 string>sbuf ; inline
|
||||
|
||||
M: sbuf set-nth-unsafe
|
||||
|
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2005, 2007 Slava Pestov.
|
||||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays kernel kernel.private math namespaces
|
||||
sequences strings words effects generic generic.standard
|
||||
classes slots.private ;
|
||||
classes slots.private combinators ;
|
||||
IN: slots
|
||||
|
||||
TUPLE: slot-spec type name offset reader writer ;
|
||||
|
@ -87,14 +87,23 @@ PREDICATE: word slot-writer "writing" word-prop >boolean ;
|
|||
: simple-writer-word ( class name -- word )
|
||||
(simple-slot-word) writer-word ;
|
||||
|
||||
: simple-slot ( class name # -- spec )
|
||||
: short-slot ( class name # -- spec )
|
||||
>r object bootstrap-word over r> f f <slot-spec>
|
||||
2over simple-reader-word over set-slot-spec-reader
|
||||
-rot simple-writer-word over set-slot-spec-writer ;
|
||||
|
||||
: long-slot ( spec # -- spec )
|
||||
>r [ dup array? [ first2 create ] when ] map first4 r>
|
||||
-rot <slot-spec> ;
|
||||
|
||||
: simple-slots ( class slots base -- specs )
|
||||
over length [ + ] with map
|
||||
[ >r >r dup r> r> simple-slot ] 2map nip ;
|
||||
over length [ + ] with map [
|
||||
{
|
||||
{ [ over not ] [ 2drop f ] }
|
||||
{ [ over string? ] [ >r dupd r> short-slot ] }
|
||||
{ [ over array? ] [ long-slot ] }
|
||||
} cond
|
||||
] 2map [ ] subset nip ;
|
||||
|
||||
: slot-of-reader ( reader specs -- spec/f )
|
||||
[ slot-spec-reader eq? ] with find nip ;
|
||||
|
|
|
@ -151,6 +151,18 @@ ARTICLE: "syntax-byte-arrays" "Byte array syntax"
|
|||
{ $subsection POSTPONE: B{ }
|
||||
"Byte arrays are documented in " { $link "byte-arrays" } "." ;
|
||||
|
||||
ARTICLE: "syntax-bit-vectors" "Bit vector syntax"
|
||||
{ $subsection POSTPONE: ?V{ }
|
||||
"Bit vectors are documented in " { $link "bit-vectors" } "." ;
|
||||
|
||||
ARTICLE: "syntax-float-vectors" "Float vector syntax"
|
||||
{ $subsection POSTPONE: FV{ }
|
||||
"Float vectors are documented in " { $link "float-vectors" } "." ;
|
||||
|
||||
ARTICLE: "syntax-byte-vectors" "Byte vector syntax"
|
||||
{ $subsection POSTPONE: BV{ }
|
||||
"Byte vectors are documented in " { $link "byte-vectors" } "." ;
|
||||
|
||||
ARTICLE: "syntax-pathnames" "Pathname syntax"
|
||||
{ $subsection POSTPONE: P" }
|
||||
"Pathnames are documented in " { $link "file-streams" } "." ;
|
||||
|
@ -165,11 +177,15 @@ $nl
|
|||
{ $subsection "syntax-words" }
|
||||
{ $subsection "syntax-quots" }
|
||||
{ $subsection "syntax-arrays" }
|
||||
{ $subsection "syntax-vectors" }
|
||||
{ $subsection "syntax-strings" }
|
||||
{ $subsection "syntax-sbufs" }
|
||||
{ $subsection "syntax-byte-arrays" }
|
||||
{ $subsection "syntax-bit-arrays" }
|
||||
{ $subsection "syntax-byte-arrays" }
|
||||
{ $subsection "syntax-float-arrays" }
|
||||
{ $subsection "syntax-vectors" }
|
||||
{ $subsection "syntax-sbufs" }
|
||||
{ $subsection "syntax-bit-vectors" }
|
||||
{ $subsection "syntax-byte-vectors" }
|
||||
{ $subsection "syntax-float-vectors" }
|
||||
{ $subsection "syntax-hashtables" }
|
||||
{ $subsection "syntax-tuples" }
|
||||
{ $subsection "syntax-pathnames" } ;
|
||||
|
@ -273,12 +289,30 @@ HELP: B{
|
|||
{ $description "Marks the beginning of a literal byte array. Literal byte arrays are terminated by " { $link POSTPONE: } } "." }
|
||||
{ $examples { $code "B{ 1 2 3 }" } } ;
|
||||
|
||||
HELP: BV{
|
||||
{ $syntax "BV{ elements... }" }
|
||||
{ $values { "elements" "a list of bytes" } }
|
||||
{ $description "Marks the beginning of a literal byte vector. Literal byte vectors are terminated by " { $link POSTPONE: } } "." }
|
||||
{ $examples { $code "BV{ 1 2 3 12 }" } } ;
|
||||
|
||||
HELP: ?{
|
||||
{ $syntax "?{ elements... }" }
|
||||
{ $values { "elements" "a list of booleans" } }
|
||||
{ $description "Marks the beginning of a literal bit array. Literal bit arrays are terminated by " { $link POSTPONE: } } "." }
|
||||
{ $examples { $code "?{ t f t }" } } ;
|
||||
|
||||
HELP: ?V{
|
||||
{ $syntax "?V{ elements... }" }
|
||||
{ $values { "elements" "a list of booleans" } }
|
||||
{ $description "Marks the beginning of a literal bit vector. Literal bit vectors are terminated by " { $link POSTPONE: } } "." }
|
||||
{ $examples { $code "?V{ t f t }" } } ;
|
||||
|
||||
HELP: FV{
|
||||
{ $syntax "FV{ elements... }" }
|
||||
{ $values { "elements" "a list of real numbers" } }
|
||||
{ $description "Marks the beginning of a literal float vector. Literal float vectors are terminated by " { $link POSTPONE: } } "." }
|
||||
{ $examples { $code "FV{ 1.0 2.0 3.0 }" } } ;
|
||||
|
||||
HELP: F{
|
||||
{ $syntax "F{ elements... }" }
|
||||
{ $values { "elements" "a list of real numbers" } }
|
||||
|
|
|
@ -1,11 +1,11 @@
|
|||
! 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 definitions generic
|
||||
hashtables kernel math namespaces parser sequences strings sbufs
|
||||
vectors words quotations io assocs splitting tuples
|
||||
generic.standard generic.math classes io.files vocabs
|
||||
float-arrays classes.union classes.mixin classes.predicate
|
||||
compiler.units ;
|
||||
USING: alien arrays bit-arrays bit-vectors byte-arrays
|
||||
byte-vectors definitions generic hashtables kernel math
|
||||
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 ;
|
||||
IN: bootstrap.syntax
|
||||
|
||||
! These words are defined as a top-level form, instead of with
|
||||
|
@ -71,8 +71,11 @@ IN: bootstrap.syntax
|
|||
"{" [ \ } [ >array ] parse-literal ] define-syntax
|
||||
"V{" [ \ } [ >vector ] parse-literal ] define-syntax
|
||||
"B{" [ \ } [ >byte-array ] parse-literal ] define-syntax
|
||||
"BV{" [ \ } [ >byte-vector ] parse-literal ] define-syntax
|
||||
"?{" [ \ } [ >bit-array ] parse-literal ] define-syntax
|
||||
"?V{" [ \ } [ >bit-vector ] parse-literal ] define-syntax
|
||||
"F{" [ \ } [ >float-array ] parse-literal ] define-syntax
|
||||
"FV{" [ \ } [ >float-vector ] parse-literal ] define-syntax
|
||||
"H{" [ \ } [ >hashtable ] parse-literal ] define-syntax
|
||||
"T{" [ \ } [ >tuple ] parse-literal ] define-syntax
|
||||
"W{" [ \ } [ first <wrapper> ] parse-literal ] define-syntax
|
||||
|
|
|
@ -49,6 +49,7 @@ HELP: os
|
|||
"linux"
|
||||
"macosx"
|
||||
"openbsd"
|
||||
"netbsd"
|
||||
"solaris"
|
||||
"windows"
|
||||
}
|
||||
|
|
|
@ -39,11 +39,11 @@ splitting assocs ;
|
|||
|
||||
: unix? ( -- ? )
|
||||
os {
|
||||
"freebsd" "openbsd" "linux" "macosx" "solaris"
|
||||
"freebsd" "openbsd" "netbsd" "linux" "macosx" "solaris"
|
||||
} member? ;
|
||||
|
||||
: bsd? ( -- ? )
|
||||
os { "freebsd" "openbsd" "macosx" } member? ;
|
||||
os { "freebsd" "openbsd" "netbsd" "macosx" } member? ;
|
||||
|
||||
: linux? ( -- ? )
|
||||
os "linux" = ;
|
||||
|
|
|
@ -80,8 +80,8 @@ PRIVATE>
|
|||
} ;
|
||||
|
||||
: define-tuple-slots ( class slots -- )
|
||||
2dup "slot-names" set-word-prop
|
||||
dupd 4 simple-slots
|
||||
2dup [ slot-spec-name ] map "slot-names" set-word-prop
|
||||
2dup delegate-slot-spec add* "slots" set-word-prop
|
||||
define-slots ;
|
||||
|
||||
|
|
|
@ -30,10 +30,10 @@ HELP: >vector
|
|||
{ $values { "seq" "a sequence" } { "vector" vector } }
|
||||
{ $description "Outputs a freshly-allocated vector with the same elements as a given sequence." } ;
|
||||
|
||||
HELP: array>vector ( array length -- vector )
|
||||
HELP: array>vector
|
||||
{ $values { "array" "an array" } { "length" "a non-negative integer" } { "vector" vector } }
|
||||
{ $description "Creates a new vector using the array for underlying storage with the specified initial length." }
|
||||
{ $warning "This word is in the " { $vocab-link "sequences.private" } " vocabulary because it does not perform type or bounds checks. User code should call " { $link >vector } " instead." } ;
|
||||
{ $warning "This word is in the " { $vocab-link "vectors.private" } " vocabulary because it does not perform type or bounds checks. User code should call " { $link >vector } " instead." } ;
|
||||
|
||||
HELP: 1vector
|
||||
{ $values { "x" object } { "vector" vector } }
|
||||
|
|
|
@ -1,10 +1,15 @@
|
|||
! Copyright (C) 2004, 2007 Slava Pestov.
|
||||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays kernel kernel.private math
|
||||
math.private sequences sequences.private vectors.private
|
||||
growable ;
|
||||
USING: arrays kernel math sequences sequences.private growable ;
|
||||
IN: vectors
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: array>vector ( byte-array capacity -- byte-vector )
|
||||
vector construct-boa ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: <vector> ( n -- vector ) f <array> 0 array>vector ; inline
|
||||
|
||||
: >vector ( seq -- vector ) V{ } clone-like ;
|
||||
|
|
|
@ -148,8 +148,16 @@ SYMBOL: load-help?
|
|||
dup update-roots
|
||||
dup modified-sources swap modified-docs ;
|
||||
|
||||
: require-restart { { "Ignore this vocabulary" t } } ;
|
||||
|
||||
: require-all ( seq -- )
|
||||
[ [ require ] each ] with-compiler-errors ;
|
||||
[
|
||||
[
|
||||
[ require ]
|
||||
[ require-restart rethrow-restarts 2drop ]
|
||||
recover
|
||||
] each
|
||||
] with-compiler-errors ;
|
||||
|
||||
: do-refresh ( modified-sources modified-docs -- )
|
||||
2dup
|
||||
|
|
|
@ -1,9 +1,14 @@
|
|||
USING: tools.deploy.private io.files system
|
||||
tools.deploy.backend ;
|
||||
USING: io.files io.launcher system tools.deploy.backend
|
||||
namespaces sequences kernel ;
|
||||
IN: benchmark.bootstrap2
|
||||
|
||||
: bootstrap-benchmark
|
||||
"." resource-path cd
|
||||
vm { "-output-image=foo.image" "-no-user-init" } stage2 ;
|
||||
[
|
||||
vm ,
|
||||
"-i=" boot-image-name append ,
|
||||
"-output-image=foo.image" ,
|
||||
"-no-user-init" ,
|
||||
] { } make run-process drop ;
|
||||
|
||||
MAIN: bootstrap-benchmark
|
||||
|
|
|
@ -145,20 +145,20 @@ VARS: population-label cohesion-label alignment-label separation-label ;
|
|||
slate> over @center grid-add
|
||||
|
||||
H{ } clone
|
||||
T{ key-down f f "1" } C[ drop randomize ] put-hash
|
||||
T{ key-down f f "2" } C[ drop sub-10-boids ] put-hash
|
||||
T{ key-down f f "3" } C[ drop add-10-boids ] put-hash
|
||||
T{ key-down f f "1" } C[ drop randomize ] put-at
|
||||
T{ key-down f f "2" } C[ drop sub-10-boids ] put-at
|
||||
T{ key-down f f "3" } C[ drop add-10-boids ] put-at
|
||||
|
||||
T{ key-down f f "q" } C[ drop inc-cohesion-weight ] put-hash
|
||||
T{ key-down f f "a" } C[ drop dec-cohesion-weight ] put-hash
|
||||
T{ key-down f f "q" } C[ drop inc-cohesion-weight ] put-at
|
||||
T{ key-down f f "a" } C[ drop dec-cohesion-weight ] put-at
|
||||
|
||||
T{ key-down f f "w" } C[ drop inc-alignment-weight ] put-hash
|
||||
T{ key-down f f "s" } C[ drop dec-alignment-weight ] put-hash
|
||||
T{ key-down f f "w" } C[ drop inc-alignment-weight ] put-at
|
||||
T{ key-down f f "s" } C[ drop dec-alignment-weight ] put-at
|
||||
|
||||
T{ key-down f f "e" } C[ drop inc-separation-weight ] put-hash
|
||||
T{ key-down f f "d" } C[ drop dec-separation-weight ] put-hash
|
||||
T{ key-down f f "e" } C[ drop inc-separation-weight ] put-at
|
||||
T{ key-down f f "d" } C[ drop dec-separation-weight ] put-at
|
||||
|
||||
T{ key-down f f "ESC" } C[ drop toggle-loop ] put-hash
|
||||
T{ key-down f f "ESC" } C[ drop toggle-loop ] put-at
|
||||
<handler> tuck set-gadget-delegate "Boids" open-window ;
|
||||
|
||||
: boids-window ( -- ) [ [ boids-window* ] with-scope ] with-ui ;
|
||||
|
|
|
@ -0,0 +1,113 @@
|
|||
|
||||
USING: kernel io io.files io.launcher
|
||||
system namespaces sequences splitting math.parser
|
||||
unix prettyprint tools.time calendar bake vars ;
|
||||
|
||||
IN: builder
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: datestamp ( -- string )
|
||||
now `{ ,[ dup timestamp-year ]
|
||||
,[ dup timestamp-month ]
|
||||
,[ dup timestamp-day ]
|
||||
,[ dup timestamp-hour ]
|
||||
,[ timestamp-minute ] }
|
||||
[ number>string 2 CHAR: 0 pad-left ] map "-" join ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYMBOL: builder-recipients
|
||||
|
||||
: quote ( str -- str ) "'" swap "'" 3append ;
|
||||
|
||||
: email-file ( subject file -- )
|
||||
`{
|
||||
"cat" ,
|
||||
"| mutt -s" ,[ quote ]
|
||||
"-x" %[ builder-recipients get ]
|
||||
}
|
||||
" " join system drop ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: boot-image ( -- filename ) `{ "boot" ,[ cpu ] "image" } "." join ;
|
||||
|
||||
: target ( -- target ) `{ ,[ os ] %[ cpu "." split ] } "-" join ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
VAR: stamp
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: build ( -- )
|
||||
|
||||
datestamp >stamp
|
||||
|
||||
"/builds/factor" cd
|
||||
"git pull git://factorcode.org/git/factor.git" system
|
||||
0 =
|
||||
[ ]
|
||||
[
|
||||
"builder: git pull" "/dev/null" email-file
|
||||
"builder: git pull" throw
|
||||
]
|
||||
if
|
||||
|
||||
"/builds/" stamp> append make-directory
|
||||
"/builds/" stamp> append cd
|
||||
"git clone /builds/factor" system drop
|
||||
|
||||
"factor" cd
|
||||
|
||||
{ "/usr/bin/git" "show" } <process-stream>
|
||||
[ readln ] with-stream
|
||||
" " split second
|
||||
"../git-id" <file-writer> [ print ] with-stream
|
||||
|
||||
"make clean" system drop
|
||||
|
||||
"make " target " > ../compile-log" 3append system
|
||||
0 =
|
||||
[ ]
|
||||
[
|
||||
"builder: vm compile" "../compile-log" email-file
|
||||
"builder: vm compile" throw
|
||||
] if
|
||||
|
||||
"wget http://factorcode.org/images/latest/" boot-image append system
|
||||
0 =
|
||||
[ ]
|
||||
[
|
||||
"builder: image download" "/dev/null" email-file
|
||||
"builder: image download" throw
|
||||
] if
|
||||
|
||||
[ "./factor -i=" boot-image " -no-user-init > ../boot-log" 3append system ]
|
||||
benchmark nip
|
||||
"../boot-time" <file-writer> [ . ] with-stream
|
||||
0 =
|
||||
[ ]
|
||||
[
|
||||
"builder: bootstrap" "../boot-log" email-file
|
||||
"builder: bootstrap" throw
|
||||
] if
|
||||
|
||||
[
|
||||
"./factor -e='USE: tools.browser load-everything' > ../load-everything-log"
|
||||
system
|
||||
] benchmark nip
|
||||
"../load-everything-time" <file-writer> [ . ] with-stream
|
||||
0 =
|
||||
[ ]
|
||||
[
|
||||
"builder: load-everything" "../load-everything-log" email-file
|
||||
"builder: load-everything" throw
|
||||
] if
|
||||
|
||||
;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
MAIN: build
|
|
@ -64,7 +64,7 @@ IN: bunny
|
|||
model-path resource-path dup exists? [
|
||||
"Downloading bunny from " write
|
||||
model-url dup print flush
|
||||
over download
|
||||
over download-to
|
||||
] unless ;
|
||||
|
||||
: draw-triangle ( ns vs triple -- )
|
||||
|
|
|
@ -41,7 +41,7 @@ VARS: input user ;
|
|||
: ((send-input)) ( other -- ) [ input> print flush ] with-stream* ;
|
||||
|
||||
: (send-input) ( other -- )
|
||||
[ ((send-input)) ] catch [ print dup stream-close users> delete ] when ;
|
||||
[ ((send-input)) ] catch [ print dup dispose users> delete ] when ;
|
||||
|
||||
: send-input ( other -- )
|
||||
dup duplex-stream-closed? [ users> delete ] [ (send-input) ] if ;
|
||||
|
|
|
@ -14,3 +14,11 @@ IN: const
|
|||
|
||||
: ENUM:
|
||||
";" parse-tokens [ create-in ] map define-enum ; parsing
|
||||
|
||||
: define-value ( word -- )
|
||||
{ f } clone [ first ] curry define ;
|
||||
|
||||
: VALUE: CREATE define-value ; parsing
|
||||
|
||||
: set-value ( value word -- )
|
||||
word-def first set-first ;
|
||||
|
|
|
@ -84,7 +84,7 @@ M: crypt-stream stream-write1 ( ch stream -- )
|
|||
: check-close ( err -- )
|
||||
dup CRYPT_ERROR_PARAM1 = [ drop ] [ check-result ] if ;
|
||||
|
||||
M: crypt-stream stream-close ( stream -- )
|
||||
M: crypt-stream dispose ( stream -- )
|
||||
crypt-stream-handle cryptDestroySession check-close ;
|
||||
|
||||
: create-session ( format -- session )
|
||||
|
@ -115,7 +115,7 @@ M: crypt-stream stream-close ( stream -- )
|
|||
|
||||
dup stream-readln print
|
||||
|
||||
stream-close
|
||||
dispose
|
||||
end
|
||||
;
|
||||
|
||||
|
@ -130,7 +130,7 @@ M: crypt-stream stream-close ( stream -- )
|
|||
"Thanks!" over stream-print
|
||||
dup stream-flush
|
||||
|
||||
stream-close
|
||||
dispose
|
||||
end
|
||||
;
|
||||
|
||||
|
@ -152,6 +152,6 @@ M: crypt-stream stream-close ( stream -- )
|
|||
|
||||
(rpl)
|
||||
|
||||
stream-close
|
||||
dispose
|
||||
end
|
||||
;
|
|
@ -15,7 +15,7 @@ PROTOCOL: assoc-protocol
|
|||
! everything should work, just slower (with >alist)
|
||||
|
||||
PROTOCOL: stream-protocol
|
||||
stream-close stream-read1 stream-read stream-read-until
|
||||
stream-read1 stream-read stream-read-until
|
||||
stream-flush stream-write1 stream-write stream-format
|
||||
stream-nl make-span-stream make-block-stream stream-readln
|
||||
make-cell-stream stream-write-table set-timeout ;
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
USING: editors.gvim io.files io.windows kernel namespaces
|
||||
USING: editors.gvim.backend io.files io.windows kernel namespaces
|
||||
sequences windows.shell32 ;
|
||||
IN: editors.gvim.windows
|
||||
|
||||
|
|
|
@ -1,5 +1,5 @@
|
|||
USING: editors io.files io.launcher kernel math.parser
|
||||
namespaces windows.shell32 ;
|
||||
namespaces sequences windows.shell32 ;
|
||||
IN: editors.notepadpp
|
||||
|
||||
: notepadpp-path
|
||||
|
@ -11,6 +11,6 @@ IN: editors.notepadpp
|
|||
[
|
||||
notepadpp-path ,
|
||||
"-n" swap number>string append , ,
|
||||
] "" make run-detached drop ;
|
||||
] { } make run-detached drop ;
|
||||
|
||||
[ notepadpp ] edit-hook set-global
|
||||
|
|
|
@ -8,18 +8,19 @@
|
|||
! variable to point to your executable,
|
||||
! if not on the path.
|
||||
!
|
||||
USING: io.launcher kernel namespaces math math.parser
|
||||
editors ;
|
||||
USING: io.files io.launcher kernel namespaces math
|
||||
math.parser editors sequences windows.shell32 ;
|
||||
IN: editors.scite
|
||||
|
||||
SYMBOL: scite-path
|
||||
|
||||
"scite" scite-path set-global
|
||||
: scite-path ( -- path )
|
||||
\ scite-path get-global [
|
||||
program-files "wscite\\SciTE.exe" path+
|
||||
] unless* ;
|
||||
|
||||
: scite-command ( file line -- cmd )
|
||||
swap
|
||||
[
|
||||
scite-path get ,
|
||||
scite-path ,
|
||||
,
|
||||
"-goto:" swap number>string append ,
|
||||
] { } make ;
|
||||
|
|
|
@ -10,7 +10,7 @@ IN: editors.ultraedit
|
|||
|
||||
: ultraedit ( file line -- )
|
||||
[
|
||||
ultraedit-path , [ % "/" % # "/1" % ] "" make ,
|
||||
ultraedit-path , [ swap % "/" % # "/1" % ] "" make ,
|
||||
] { } make run-detached drop ;
|
||||
|
||||
|
||||
|
|
|
@ -11,4 +11,3 @@ HOOK: available-page-file os ( -- n )
|
|||
HOOK: total-virtual-mem os ( -- n )
|
||||
HOOK: available-virtual-mem os ( -- n )
|
||||
HOOK: available-virtual-extended-mem os ( -- n )
|
||||
|
||||
|
|
|
@ -0,0 +1,6 @@
|
|||
IN: hardware-info.windows.backend
|
||||
|
||||
TUPLE: wince ;
|
||||
TUPLE: winnt ;
|
||||
UNION: windows wince winnt ;
|
||||
|
|
@ -1,8 +1,8 @@
|
|||
USING: alien.c-types hardware-info hardware-info.windows
|
||||
kernel math namespaces windows windows.kernel32
|
||||
hardware-info.backend ;
|
||||
USING: alien.c-types hardware-info kernel math namespaces
|
||||
windows windows.kernel32 hardware-info.backend ;
|
||||
IN: hardware-info.windows.ce
|
||||
|
||||
TUPLE: wince ;
|
||||
T{ wince } os set-global
|
||||
|
||||
: memory-status ( -- MEMORYSTATUS )
|
||||
|
@ -10,6 +10,8 @@ T{ wince } os set-global
|
|||
"MEMORYSTATUS" heap-size over set-MEMORYSTATUS-dwLength
|
||||
[ GlobalMemoryStatus ] keep ;
|
||||
|
||||
M: wince cpus ( -- n ) 1 ;
|
||||
|
||||
M: wince memory-load ( -- n )
|
||||
memory-status MEMORYSTATUS-dwMemoryLoad ;
|
||||
|
||||
|
|
|
@ -1,10 +1,18 @@
|
|||
USING: alien alien.c-types hardware-info hardware-info.windows
|
||||
USING: alien alien.c-types hardware-info.windows.backend
|
||||
kernel libc math namespaces hardware-info.backend
|
||||
windows windows.advapi32 windows.kernel32 ;
|
||||
IN: hardware-info.windows.nt
|
||||
|
||||
TUPLE: winnt ;
|
||||
|
||||
T{ winnt } os set-global
|
||||
|
||||
: system-info ( -- SYSTEM_INFO )
|
||||
"SYSTEM_INFO" <c-object> [ GetSystemInfo ] keep ;
|
||||
|
||||
M: winnt cpus ( -- n )
|
||||
system-info SYSTEM_INFO-dwNumberOfProcessors ;
|
||||
|
||||
: memory-status ( -- MEMORYSTATUSEX )
|
||||
"MEMORYSTATUSEX" <c-object>
|
||||
"MEMORYSTATUSEX" heap-size over set-MEMORYSTATUSEX-dwLength
|
||||
|
|
|
@ -1,22 +1,15 @@
|
|||
USING: alien alien.c-types kernel libc math namespaces
|
||||
windows windows.kernel32 windows.advapi32
|
||||
hardware-info.windows.backend
|
||||
words combinators vocabs.loader hardware-info.backend ;
|
||||
IN: hardware-info.windows
|
||||
|
||||
TUPLE: wince ;
|
||||
TUPLE: winnt ;
|
||||
UNION: windows wince winnt ;
|
||||
USE: system
|
||||
|
||||
: system-info ( -- SYSTEM_INFO )
|
||||
"SYSTEM_INFO" <c-object> [ GetSystemInfo ] keep ;
|
||||
|
||||
: page-size ( -- n )
|
||||
system-info SYSTEM_INFO-dwPageSize ;
|
||||
|
||||
M: windows cpus ( -- n )
|
||||
system-info SYSTEM_INFO-dwNumberOfProcessors ;
|
||||
|
||||
! 386, 486, 586, 2200 (IA64), 8664 (AMD_X8664)
|
||||
: processor-type ( -- n )
|
||||
system-info SYSTEM_INFO-dwProcessorType ;
|
||||
|
@ -70,8 +63,7 @@ M: windows cpus ( -- n )
|
|||
: system-windows-directory ( -- str )
|
||||
\ GetSystemWindowsDirectory get-directory ;
|
||||
|
||||
<< {
|
||||
{
|
||||
{ [ wince? ] [ "hardware-info.windows.ce" ] }
|
||||
{ [ winnt? ] [ "hardware-info.windows.nt" ] }
|
||||
{ [ t ] [ f ] }
|
||||
} cond [ require ] when* >>
|
||||
} cond [ require ] when*
|
||||
|
|
|
@ -110,15 +110,21 @@ USE: io.buffers
|
|||
ARTICLE: "collections" "Collections"
|
||||
{ $heading "Sequences" }
|
||||
{ $subsection "sequences" }
|
||||
"Sequence implementations:"
|
||||
"Fixed-length sequences:"
|
||||
{ $subsection "arrays" }
|
||||
{ $subsection "vectors" }
|
||||
{ $subsection "quotations" }
|
||||
"Fixed-length specialized sequences:"
|
||||
{ $subsection "strings" }
|
||||
{ $subsection "bit-arrays" }
|
||||
{ $subsection "byte-arrays" }
|
||||
{ $subsection "float-arrays" }
|
||||
{ $subsection "strings" }
|
||||
"Resizable sequence:"
|
||||
{ $subsection "vectors" }
|
||||
"Resizable specialized sequences:"
|
||||
{ $subsection "sbufs" }
|
||||
{ $subsection "quotations" }
|
||||
{ $subsection "bit-vectors" }
|
||||
{ $subsection "byte-vectors" }
|
||||
{ $subsection "float-vectors" }
|
||||
{ $heading "Associative mappings" }
|
||||
{ $subsection "assocs" }
|
||||
{ $subsection "namespaces" }
|
||||
|
@ -131,22 +137,25 @@ ARTICLE: "collections" "Collections"
|
|||
{ $subsection "graphs" }
|
||||
{ $subsection "buffers" } ;
|
||||
|
||||
USING: io.sockets io.launcher io.mmap ;
|
||||
USING: io.sockets io.launcher io.mmap io.monitor ;
|
||||
|
||||
ARTICLE: "io" "Input and output"
|
||||
{ $subsection "streams" }
|
||||
"Stream implementations:"
|
||||
"External streams:"
|
||||
{ $subsection "file-streams" }
|
||||
{ $subsection "network-streams" }
|
||||
"Wrapper streams:"
|
||||
{ $subsection "io.streams.duplex" }
|
||||
{ $subsection "io.streams.lines" }
|
||||
{ $subsection "io.streams.plain" }
|
||||
{ $subsection "io.streams.string" }
|
||||
"Advanced features:"
|
||||
"Stream utilities:"
|
||||
{ $subsection "stream-binary" }
|
||||
{ $subsection "styles" }
|
||||
{ $subsection "network-streams" }
|
||||
"Advanced features:"
|
||||
{ $subsection "io.launcher" }
|
||||
{ $subsection "io.mmap" } ;
|
||||
{ $subsection "io.mmap" }
|
||||
{ $subsection "io.monitor" } ;
|
||||
|
||||
ARTICLE: "tools" "Developer tools"
|
||||
{ $subsection "tools.annotations" }
|
||||
|
|
|
@ -23,7 +23,7 @@ $nl
|
|||
$nl
|
||||
"Now, we tell Factor that all definitions in this source file should go into the " { $snippet "palindrome" } " vocabulary using the " { $link POSTPONE: IN: } " word:"
|
||||
{ $code "IN: palindrome" }
|
||||
"You are now ready to go onto the nex section." ;
|
||||
"You are now ready to go on to the next section: " { $link "first-program-logic" } "." ;
|
||||
|
||||
ARTICLE: "first-program-logic" "Writing some logic in your first program"
|
||||
"Your " { $snippet "palindrome.factor" } " file should look like the following after the previous section:"
|
||||
|
@ -56,7 +56,7 @@ $nl
|
|||
{ $code "\\ = see" }
|
||||
"It's in the " { $vocab-link "kernel" } " vocabulary, which we've already added to the search path."
|
||||
|
||||
"Now press " { $command workspace "workflow" refresh-all } " again, and the source file should reload without any errors." ;
|
||||
"Now press " { $command workspace "workflow" refresh-all } " again, and the source file should reload without any errors. You can now go on and learn about " { $link "first-program-test" } "." ;
|
||||
|
||||
ARTICLE: "first-program-test" "Testing your first program"
|
||||
"Your " { $snippet "palindrome.factor" } " file should look like the following after the previous section:"
|
||||
|
@ -92,7 +92,7 @@ $nl
|
|||
}
|
||||
"Now, you can run unit tests:"
|
||||
{ $code "\"palindrome\" test" }
|
||||
"It should report that all tests have passed." ;
|
||||
"It should report that all tests have passed. Now you can read about " { $link "first-program-extend" } "." ;
|
||||
|
||||
ARTICLE: "first-program-extend" "Extending your first program"
|
||||
"Our palindrome program works well, however we'd like to extend it to ignore spaces and non-alphabetical characters in the input."
|
||||
|
|
|
@ -105,7 +105,7 @@ TUPLE: html-sub-stream style stream ;
|
|||
|
||||
TUPLE: html-span-stream ;
|
||||
|
||||
M: html-span-stream stream-close
|
||||
M: html-span-stream dispose
|
||||
end-sub-stream not-a-div format-html-span ;
|
||||
|
||||
: border-css, ( border -- )
|
||||
|
@ -138,7 +138,7 @@ M: html-span-stream stream-close
|
|||
|
||||
TUPLE: html-block-stream ;
|
||||
|
||||
M: html-block-stream stream-close ( quot style stream -- )
|
||||
M: html-block-stream dispose ( quot style stream -- )
|
||||
end-sub-stream a-div format-html-div ;
|
||||
|
||||
: border-spacing-css,
|
||||
|
|
|
@ -7,3 +7,8 @@ USING: http.client tools.test ;
|
|||
[ 404 ] [ "404 File not found" parse-response ] unit-test
|
||||
[ 200 ] [ "HTTP/1.0 200" parse-response ] unit-test
|
||||
[ 200 ] [ "HTTP/1.0 200 Success" parse-response ] unit-test
|
||||
|
||||
[ "foo.txt" ] [ "http://www.paulgraham.com/foo.txt" download-name ] unit-test
|
||||
[ "foo.txt" ] [ "http://www.arcsucks.com/foo.txt?xxx" download-name ] unit-test
|
||||
[ "foo.txt" ] [ "http://www.arcsucks.com/foo.txt/" download-name ] unit-test
|
||||
[ "www.arcsucks.com" ] [ "http://www.arcsucks.com////" download-name ] unit-test
|
||||
|
|
|
@ -44,14 +44,14 @@ DEFER: http-get-stream
|
|||
#! Should this support Location: headers that are
|
||||
#! relative URLs?
|
||||
pick 100 /i 3 = [
|
||||
stream-close "Location" swap at nip http-get-stream
|
||||
dispose "Location" swap at nip http-get-stream
|
||||
] when ;
|
||||
|
||||
: http-get-stream ( url -- code headers stream )
|
||||
#! Opens a stream for reading from an HTTP URL.
|
||||
parse-url over parse-host <inet> <client> [
|
||||
[ [ get-request read-response ] with-stream* ] keep
|
||||
] [ >r stream-close r> rethrow ] recover do-redirect ;
|
||||
] [ ] [ dispose ] cleanup do-redirect ;
|
||||
|
||||
: http-get ( url -- code headers string )
|
||||
#! Opens a stream for reading from an HTTP URL.
|
||||
|
@ -59,9 +59,23 @@ DEFER: http-get-stream
|
|||
http-get-stream [ stdio get contents ] with-stream
|
||||
] with-scope ;
|
||||
|
||||
: download ( url file -- )
|
||||
: download-name ( url -- name )
|
||||
file-name "?" split1 drop "/" ?tail drop ;
|
||||
|
||||
: default-timeout 60 1000 * over set-timeout ;
|
||||
|
||||
: success? ( code -- ? ) 200 = ;
|
||||
|
||||
: download-to ( url file -- )
|
||||
#! Downloads the contents of a URL to a file.
|
||||
>r http-get 2nip r> <file-writer> [ write ] with-stream ;
|
||||
>r http-get-stream nip default-timeout swap success? [
|
||||
r> <file-writer> stream-copy
|
||||
] [
|
||||
r> drop dispose "HTTP download failed" throw
|
||||
] if ;
|
||||
|
||||
: download ( url -- )
|
||||
dup download-name download-to ;
|
||||
|
||||
: post-request ( content-type content host resource -- )
|
||||
#! Note: It is up to the caller to url encode the content if
|
||||
|
|
|
@ -93,7 +93,7 @@ HELP: run-process*
|
|||
{ $notes "User code should call " { $link run-process } " instead." } ;
|
||||
|
||||
HELP: >descriptor
|
||||
{ $values { "obj" object } { "desc" "a launch descriptor" } }
|
||||
{ $values { "desc" "a launch descriptor" } { "desc" "a launch descriptor" } }
|
||||
{ $description "Creates a launch descriptor from an object, which must be one of the following:"
|
||||
{ $list
|
||||
{ "a string -- this is wrapped in a launch descriptor with a single " { $link +command+ } " key" }
|
||||
|
@ -103,12 +103,12 @@ HELP: >descriptor
|
|||
} ;
|
||||
|
||||
HELP: run-process
|
||||
{ $values { "obj" object } { "process" process } }
|
||||
{ $values { "desc" "a launch descriptor" } { "process" process } }
|
||||
{ $description "Launches a process. The object can either be a string, a sequence of strings or a launch descriptor. See " { $link >descriptor } " for details." }
|
||||
{ $notes "The output value can be passed to " { $link wait-for-process } " to get an exit code." } ;
|
||||
|
||||
HELP: run-detached
|
||||
{ $values { "obj" object } { "process" process } }
|
||||
{ $values { "desc" "a launch descriptor" } { "process" process } }
|
||||
{ $contract "Launches a process without waiting for it to complete. The object can either be a string, a sequence of strings or a launch descriptor. See " { $link >descriptor } " for details." }
|
||||
{ $notes
|
||||
"This word is functionally identical to passing a launch descriptor to " { $link run-process } " having the " { $link +detached+ } " key set."
|
||||
|
@ -127,12 +127,17 @@ HELP: process-stream
|
|||
{ $class-description "A bidirectional stream for interacting with a running process. Instances are created by calling " { $link <process-stream> } ". The " { $link process-stream-process } " slot holds a " { $link process } " instance." } ;
|
||||
|
||||
HELP: <process-stream>
|
||||
{ $values { "obj" object } { "stream" "a bidirectional stream" } }
|
||||
{ $values
|
||||
{ "desc" "a launch descriptor" }
|
||||
{ "stream" "a bidirectional stream" } }
|
||||
{ $description "Launches a process and redirects its input and output via a pair of pipes which may be read and written as a stream." }
|
||||
{ $notes "Closing the stream will block until the process exits." } ;
|
||||
|
||||
HELP: with-process-stream
|
||||
{ $values { "obj" object } { "quot" quotation } { "process" process } }
|
||||
{ $values
|
||||
{ "desc" "a launch descriptor" }
|
||||
{ "quot" quotation }
|
||||
{ "process" process } }
|
||||
{ $description "Calls " { $snippet "quot" } " in a dynamic scope where " { $link stdio } " is rebound to a " { $link process-stream } ". When the quotation returns, the " { $link process } " instance is output." } ;
|
||||
|
||||
HELP: wait-for-process
|
||||
|
|
|
@ -63,7 +63,7 @@ SYMBOL: append-environment
|
|||
{ replace-environment [ ] }
|
||||
} case ;
|
||||
|
||||
GENERIC: >descriptor ( obj -- desc )
|
||||
GENERIC: >descriptor ( desc -- desc )
|
||||
|
||||
M: string >descriptor +command+ associate ;
|
||||
M: sequence >descriptor +arguments+ associate ;
|
||||
|
@ -76,24 +76,24 @@ HOOK: run-process* io-backend ( desc -- handle )
|
|||
dup [ processes get at push stop ] curry callcc0
|
||||
] when process-status ;
|
||||
|
||||
: run-process ( obj -- process )
|
||||
: run-process ( desc -- process )
|
||||
>descriptor
|
||||
dup run-process*
|
||||
+detached+ rot at [ dup wait-for-process drop ] unless ;
|
||||
|
||||
: run-detached ( obj -- process )
|
||||
: run-detached ( desc -- process )
|
||||
>descriptor H{ { +detached+ t } } union run-process ;
|
||||
|
||||
HOOK: process-stream* io-backend ( desc -- stream process )
|
||||
|
||||
TUPLE: process-stream process ;
|
||||
|
||||
: <process-stream> ( obj -- stream )
|
||||
: <process-stream> ( desc -- stream )
|
||||
>descriptor process-stream*
|
||||
{ set-delegate set-process-stream-process }
|
||||
process-stream construct ;
|
||||
|
||||
: with-process-stream ( obj quot -- process )
|
||||
: with-process-stream ( desc quot -- process )
|
||||
swap <process-stream>
|
||||
[ swap with-stream ] keep
|
||||
process-stream-process ; inline
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
USING: help.markup help.syntax alien math ;
|
||||
USING: help.markup help.syntax alien math continuations ;
|
||||
IN: io.mmap
|
||||
|
||||
HELP: mapped-file
|
||||
|
@ -15,21 +15,17 @@ HELP: <mapped-file>
|
|||
{ $notes "You must call " { $link close-mapped-file } " when you are finished working with the returned object, to reclaim resources. The " { $link with-mapped-file } " provides an abstraction which can close the mapped file for you." }
|
||||
{ $errors "Throws an error if a memory mapping could not be established." } ;
|
||||
|
||||
HELP: (close-mapped-file)
|
||||
{ $values { "mmap" mapped-file } }
|
||||
{ $contract "Releases system resources associated with the mapped file. This word should not be called by user code; use " { $link close-mapped-file } " instead." }
|
||||
{ $errors "Throws an error if a memory mapping could not be established." } ;
|
||||
|
||||
HELP: close-mapped-file
|
||||
{ $values { "mmap" mapped-file } }
|
||||
{ $description "Releases system resources associated with the mapped file." }
|
||||
{ $contract "Releases system resources associated with the mapped file. This word should not be called by user code; use " { $link dispose } " instead." }
|
||||
{ $errors "Throws an error if a memory mapping could not be established." } ;
|
||||
|
||||
ARTICLE: "io.mmap" "Memory-mapped files"
|
||||
"The " { $vocab-link "io.mmap" } " vocabulary implements support for memory-mapped files."
|
||||
{ $subsection <mapped-file> }
|
||||
{ $subsection close-mapped-file }
|
||||
"A combinator which wraps the above two words:"
|
||||
"Memory-mapped files are disposable and can be closed with " { $link dispose } " or " { $link with-disposal } "."
|
||||
$nl
|
||||
"A utility combinator which wraps the above:"
|
||||
{ $subsection with-mapped-file }
|
||||
"Memory mapped files implement the " { $link "sequence-protocol" } " and present themselves as a sequence of bytes. The underlying memory area can also be accessed directly:"
|
||||
{ $subsection mapped-file-address }
|
||||
|
|
|
@ -23,14 +23,12 @@ INSTANCE: mapped-file sequence
|
|||
|
||||
HOOK: <mapped-file> io-backend ( path length -- mmap )
|
||||
|
||||
HOOK: (close-mapped-file) io-backend ( mmap -- )
|
||||
HOOK: close-mapped-file io-backend ( mmap -- )
|
||||
|
||||
: close-mapped-file ( mmap -- )
|
||||
M: mapped-file dispose ( mmap -- )
|
||||
check-closed
|
||||
t over set-mapped-file-closed?
|
||||
(close-mapped-file) ;
|
||||
close-mapped-file ;
|
||||
|
||||
: with-mapped-file ( path length quot -- )
|
||||
>r <mapped-file> r>
|
||||
[ keep ] curry
|
||||
[ close-mapped-file ] [ ] cleanup ; inline
|
||||
>r <mapped-file> r> with-disposal ; inline
|
||||
|
|
|
@ -0,0 +1,61 @@
|
|||
IN: io.monitor
|
||||
USING: help.markup help.syntax continuations ;
|
||||
|
||||
HELP: <monitor>
|
||||
{ $values { "path" "a pathname string" } { "recursive?" "a boolean" } }
|
||||
{ $description "Opens a file system change monitor which listens for changes on " { $snippet "path" } ". The boolean indicates whether changes in subdirectories should be reported."
|
||||
$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" } "." } ;
|
||||
|
||||
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: +change-name+
|
||||
{ $description "Indicates that the file name has changed." } ;
|
||||
|
||||
HELP: +change-size+
|
||||
{ $description "Indicates that the file size has 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." } ;
|
||||
|
||||
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+ } ;
|
||||
|
||||
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."
|
||||
$nl
|
||||
"Creating a file system change monitor and listening for changes:"
|
||||
{ $subsection <monitor> }
|
||||
{ $subsection next-change }
|
||||
{ $subsection "io.monitor.descriptors" }
|
||||
"Monitors are closed by calling " { $link dispose } " or " { $link with-disposal } "."
|
||||
$nl
|
||||
"A utility combinator which opens a monitor and cleans it up after:"
|
||||
{ $subsection with-monitor }
|
||||
"An example which watches the Factor directory for changes:"
|
||||
{ $code
|
||||
"USE: io.monitor"
|
||||
": watch-loop ( monitor -- )"
|
||||
" dup next-change . . nl nl flush watch-loop ;"
|
||||
""
|
||||
"\"\" resource-path f [ watch-loop ] with-monitor"
|
||||
} ;
|
||||
|
||||
ABOUT: "io.monitor"
|
|
@ -5,8 +5,6 @@ IN: io.monitor
|
|||
|
||||
HOOK: <monitor> io-backend ( path recursive? -- monitor )
|
||||
|
||||
HOOK: close-monitor io-backend ( monitor -- )
|
||||
|
||||
HOOK: next-change io-backend ( monitor -- path changes )
|
||||
|
||||
SYMBOL: +change-file+
|
||||
|
@ -16,4 +14,4 @@ SYMBOL: +change-attributes+
|
|||
SYMBOL: +change-modified+
|
||||
|
||||
: with-monitor ( path recursive? quot -- )
|
||||
>r <monitor> r> over [ close-monitor ] curry [ ] cleanup ;
|
||||
>r <monitor> r> with-disposal ; inline
|
||||
|
|
|
@ -1,5 +1,5 @@
|
|||
USING: io io.buffers io.backend help.markup help.syntax kernel
|
||||
strings sbufs words ;
|
||||
strings sbufs words continuations ;
|
||||
IN: io.nonblocking
|
||||
|
||||
ARTICLE: "io.nonblocking" "Non-blocking I/O implementation"
|
||||
|
@ -23,7 +23,7 @@ $nl
|
|||
"Per-port native I/O protocol:"
|
||||
{ $subsection init-handle }
|
||||
{ $subsection (wait-to-read) }
|
||||
"Additionally, the I/O backend must provide an implementation of the " { $link stream-flush } " and " { $link stream-close } " generic words."
|
||||
"Additionally, the I/O backend must provide an implementation of the " { $link stream-flush } " and " { $link dispose } " generic words."
|
||||
$nl
|
||||
"Dummy ports which should be used to implement networking:"
|
||||
{ $subsection server-port }
|
||||
|
|
|
@ -1,16 +1,20 @@
|
|||
! Copyright (C) 2005, 2007 Slava Pestov, Doug Coleman
|
||||
! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: io.nonblocking
|
||||
USING: math kernel io sequences io.buffers generic sbufs
|
||||
system io.streams.lines io.streams.plain io.streams.duplex
|
||||
continuations debugger classes byte-arrays namespaces
|
||||
splitting ;
|
||||
USING: math kernel io sequences io.buffers generic sbufs system
|
||||
io.streams.lines io.streams.plain io.streams.duplex io.backend
|
||||
continuations debugger classes byte-arrays namespaces splitting
|
||||
dlists assocs ;
|
||||
|
||||
SYMBOL: default-buffer-size
|
||||
64 1024 * default-buffer-size set-global
|
||||
|
||||
! Common delegate of native stream readers and writers
|
||||
TUPLE: port handle error timeout cutoff type eof? ;
|
||||
TUPLE: port
|
||||
handle
|
||||
error
|
||||
timeout-entry timeout cutoff
|
||||
type eof? ;
|
||||
|
||||
SYMBOL: closed
|
||||
|
||||
|
@ -41,19 +45,46 @@ GENERIC: close-handle ( handle -- )
|
|||
|
||||
: handle>duplex-stream ( in-handle out-handle -- stream )
|
||||
<writer>
|
||||
[ >r <reader> r> <duplex-stream> ] [ ] [ stream-close ]
|
||||
[ >r <reader> r> <duplex-stream> ] [ ] [ dispose ]
|
||||
cleanup ;
|
||||
|
||||
: touch-port ( port -- )
|
||||
dup port-timeout dup zero?
|
||||
[ 2drop ] [ millis + swap set-port-cutoff ] if ;
|
||||
|
||||
: timeout? ( port -- ? )
|
||||
port-cutoff dup zero? not swap millis < and ;
|
||||
|
||||
: pending-error ( port -- )
|
||||
dup port-error f rot set-port-error [ throw ] when* ;
|
||||
|
||||
SYMBOL: timeout-queue
|
||||
|
||||
timeout-queue global [ [ <dlist> ] unless* ] change-at
|
||||
|
||||
: unqueue-timeout ( port -- )
|
||||
port-timeout-entry [
|
||||
timeout-queue get-global swap delete-node
|
||||
] when* ;
|
||||
|
||||
: queue-timeout ( port -- )
|
||||
dup timeout-queue get-global push-front*
|
||||
swap set-port-timeout-entry ;
|
||||
|
||||
HOOK: expire-port io-backend ( port -- )
|
||||
|
||||
M: object expire-port drop ;
|
||||
|
||||
: expire-timeouts ( -- )
|
||||
timeout-queue get-global dup dlist-empty? [ drop ] [
|
||||
dup peek-back timeout?
|
||||
[ pop-back expire-port expire-timeouts ] [ drop ] if
|
||||
] if ;
|
||||
|
||||
: touch-port ( port -- )
|
||||
dup port-timeout dup zero? [
|
||||
2drop
|
||||
] [
|
||||
millis + over set-port-cutoff
|
||||
dup unqueue-timeout queue-timeout
|
||||
] if ;
|
||||
|
||||
M: port set-timeout
|
||||
[ set-port-timeout ] keep touch-port ;
|
||||
|
||||
|
@ -157,7 +188,7 @@ GENERIC: port-flush ( port -- )
|
|||
M: output-port stream-flush ( port -- )
|
||||
dup port-flush pending-error ;
|
||||
|
||||
M: port stream-close
|
||||
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
|
||||
|
|
|
@ -29,8 +29,7 @@ SYMBOL: log-stream
|
|||
|
||||
: with-log-file ( file quot -- )
|
||||
>r <file-appender> r>
|
||||
[ [ with-log-stream ] 2keep ]
|
||||
[ drop stream-close ] [ ] cleanup ; inline
|
||||
[ with-log-stream ] with-disposal ; inline
|
||||
|
||||
: with-log-stdio ( quot -- )
|
||||
stdio get swap with-log-stream ;
|
||||
|
@ -52,7 +51,7 @@ SYMBOL: log-stream
|
|||
[ swap accept with-client ] 2keep accept-loop ; inline
|
||||
|
||||
: server-loop ( server quot -- )
|
||||
[ accept-loop ] [ drop stream-close ] [ ] cleanup ; inline
|
||||
[ accept-loop ] compose with-disposal ; inline
|
||||
|
||||
: spawn-server ( addrspec quot -- )
|
||||
"Waiting for connections on " pick unparse append
|
||||
|
@ -87,8 +86,7 @@ SYMBOL: log-stream
|
|||
|
||||
: spawn-datagrams ( quot addrspec -- )
|
||||
"Waiting for datagrams on " over unparse append log-message
|
||||
<datagram> [ datagram-loop ] [ stream-close ] [ ] cleanup ;
|
||||
inline
|
||||
<datagram> [ datagram-loop ] with-disposal ; inline
|
||||
|
||||
: with-datagrams ( seq service quot -- )
|
||||
[
|
||||
|
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2007 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types alien.syntax byte-arrays io
|
||||
io.sockets.impl kernel structs math prettyprint ;
|
||||
io.sockets.impl kernel structs math math.parser
|
||||
prettyprint sequences ;
|
||||
IN: io.sockets.headers
|
||||
|
||||
C-STRUCT: etherneth
|
||||
|
|
|
@ -1,5 +1,5 @@
|
|||
USING: help.markup help.syntax io io.backend threads
|
||||
strings byte-arrays ;
|
||||
strings byte-arrays continuations ;
|
||||
IN: io.sockets
|
||||
|
||||
ARTICLE: "network-addressing" "Address specifiers"
|
||||
|
@ -19,7 +19,7 @@ ARTICLE: "network-connection" "Connection-oriented networking"
|
|||
{ $subsection accept }
|
||||
"The stream returned by " { $link accept } " holds the address specifier of the remote client:"
|
||||
{ $subsection client-stream-addr }
|
||||
"Server sockets are closed by calling " { $link stream-close } ", but they do not respond to the rest of the stream protocol."
|
||||
"Server sockets are closed by calling " { $link dispose } "."
|
||||
$nl
|
||||
"Address specifiers have the following interpretation with connection-oriented networking words:"
|
||||
{ $list
|
||||
|
@ -36,7 +36,7 @@ ARTICLE: "network-packet" "Packet-oriented networking"
|
|||
"Packets can be sent and received with a pair of words:"
|
||||
{ $subsection send }
|
||||
{ $subsection receive }
|
||||
"Packet-oriented sockets are closed by calling " { $link stream-close } ", but they do not respond to the rest of the stream protocol."
|
||||
"Packet-oriented sockets are closed by calling " { $link dispose } "."
|
||||
$nl
|
||||
"Address specifiers have the following interpretation with connection-oriented networking words:"
|
||||
{ $list
|
||||
|
@ -104,7 +104,7 @@ HELP: <server>
|
|||
{ $description
|
||||
"Begins listening for network connections to a local address. Server objects responds to two words:"
|
||||
{ $list
|
||||
{ { $link stream-close } " - stops listening on the port and frees all associated resources" }
|
||||
{ { $link dispose } " - stops listening on the port and frees all associated resources" }
|
||||
{ { $link accept } " - blocks until there is a connection" }
|
||||
}
|
||||
}
|
||||
|
@ -128,7 +128,7 @@ HELP: <datagram>
|
|||
{ $values { "addrspec" "an address specifier" } { "datagram" "a handle" } }
|
||||
{ $description "Creates a datagram socket bound to a local address. Datagram socket objects responds to three words:"
|
||||
{ $list
|
||||
{ { $link stream-close } " - stops listening on the port and frees all associated resources" }
|
||||
{ { $link dispose } " - stops listening on the port and frees all associated resources" }
|
||||
{ { $link receive } " - waits for a packet" }
|
||||
{ { $link send } " - sends a packet" }
|
||||
}
|
||||
|
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue