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

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

db4
Eduardo Cavazos 2008-01-30 02:00:13 -06:00
parent b7191f3706 10015b70c1
commit 4312baa31c
68 changed files with 1206 additions and 715 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

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

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

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

33
core/bit-vectors/bit-vectors-docs.factor Executable file
View File

@ -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." } ;

14
core/bit-vectors/bit-vectors-tests.factor Executable file
View File

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

33
core/bit-vectors/bit-vectors.factor Executable file
View File

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

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

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

11
core/bootstrap/layouts/layouts.factor Normal file → Executable file
View File

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

198
core/bootstrap/primitives.factor
View File

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

3
core/bootstrap/syntax.factor
View File

@ -16,12 +16,15 @@ f swap set-vocab-source-loaded?
";"
"<PRIVATE"
"?{"
"?V{"
"BIN:"
"B{"
"BV{"
"C:"
"CHAR:"
"DEFER:"
"F{"
"FV{"
"FORGET:"
"GENERIC#"
"GENERIC:"

8
core/byte-arrays/byte-arrays-tests.factor Executable file
View File

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

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

@ -15,6 +15,9 @@ M: byte-array new drop <byte-array> ;
M: byte-array equal?
over byte-array? [ sequence= ] [ 2drop f ] if ;
M: byte-array resize
resize-byte-array ;
INSTANCE: byte-array sequence
INSTANCE: byte-array simple-c-ptr
INSTANCE: byte-array c-ptr

34
core/byte-vectors/byte-vectors-docs.factor Executable file
View File

@ -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." } ;

14
core/byte-vectors/byte-vectors-tests.factor Executable file
View File

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

33
core/byte-vectors/byte-vectors.factor Executable file
View File

@ -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 ) V{ } 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

1
core/cpu/architecture/tags.txt Normal file
View File

@ -0,0 +1 @@
compiler

35
core/cpu/arm/intrinsics/intrinsics.factor
View File

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

1
core/cpu/arm/tags.txt Normal file
View File

@ -0,0 +1 @@
compiler

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

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

1
core/cpu/ppc/tags.txt Normal file
View File

@ -0,0 +1 @@
compiler

1
core/cpu/x86/32/tags.txt Normal file
View File

@ -0,0 +1 @@
compiler

1
core/cpu/x86/64/tags.txt Normal file
View File

@ -0,0 +1 @@
compiler

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

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

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

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

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

@ -29,6 +29,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

34
core/float-vectors/float-vectors-docs.factor Executable file
View File

@ -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." } ;

14
core/float-vectors/float-vectors-tests.factor Executable file
View File

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

33
core/float-vectors/float-vectors.factor Executable file
View File

@ -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 ) V{ } 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

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

@ -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." } ;

2
core/hashtables/hashtables.factor
View File

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

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

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

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

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

11
core/sbufs/sbufs.factor Normal file → Executable file
View File

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

19
core/slots/slots.factor
View File

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

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

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

17
core/syntax/syntax.factor
View File

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

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

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

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

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

13
core/vectors/vectors.factor
View File

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

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

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

1
extra/math/combinatorics/authors.txt
View File

@ -1,2 +1,3 @@
Slava Pestov
Doug Coleman
Aaron Schaefer

49
extra/math/combinatorics/combinatorics-docs.factor Normal file
View File

@ -0,0 +1,49 @@
USING: help.markup help.syntax kernel math sequences ;
IN: math.combinatorics
HELP: factorial
{ $values { "n" "a non-negative integer" } { "n!" integer } }
{ $description "Outputs the product of all positive integers less than or equal to " { $snippet "n" } "." }
{ $examples { $example "4 factorial ." "24" } } ;
HELP: nPk
{ $values { "n" "a non-negative integer" } { "k" "a non-negative integer" } { "nPk" integer } }
{ $description "Outputs the total number of unique permutations of size " { $snippet "k" } " (order does matter) that can be taken from a set of size " { $snippet "n" } "." }
{ $examples { $example "10 4 nPk ." "5040" } } ;
HELP: nCk
{ $values { "n" "a non-negative integer" } { "k" "a non-negative integer" } { "nCk" integer } }
{ $description "Outputs the total number of unique combinations of size " { $snippet "k" } " (order does not matter) that can be taken from a set of size " { $snippet "n" } ". Commonly written as \"n choose k\"." }
{ $examples { $example "10 4 nCk ." "210" } } ;
HELP: permutation
{ $values { "n" "a non-negative integer" } { "seq" sequence } { "seq" sequence } }
{ $description "Outputs the " { $snippet "nth" } " lexicographical permutation of " { $snippet "seq" } "." }
{ $notes "Permutations are 0-based and a bounds error will be thrown if " { $snippet "n" } " is larger than " { $snippet "seq length factorial 1-" } "." }
{ $examples { $example "1 3 permutation ." "{ 0 2 1 }" } { $example "5 { \"apple\" \"banana\" \"orange\" } permutation ." "{ \"orange\" \"banana\" \"apple\"}" } } ;
HELP: all-permutations
{ $values { "seq" sequence } { "seq" sequence } }
{ $description "Outputs a sequence containing all permutations of " { $snippet "seq" } " in lexicographical order." }
{ $examples { $example "3 all-permutations ." "{ { 0 1 2 } { 0 2 1 } { 1 0 2 } { 1 2 0 } { 2 0 1 } { 2 1 0 } }" } } ;
HELP: inverse-permutation
{ $values { "seq" sequence } { "permutation" sequence } }
{ $description "Outputs a sequence of indices representing the lexicographical permutation of " { $snippet "seq" } "." }
{ $notes "All items in " { $snippet "seq" } " must be comparable by " { $link <=> } "." }
{ $examples { $example "\"dcba\" inverse-permutation ." "{ 3 2 1 0 }" } { $example "{ 12 56 34 78 } inverse-permutation ." "{ 0 2 1 3 }" } } ;
IN: math.combinatorics.private
HELP: factoradic
{ $values { "n" integer } { "seq" sequence } }
{ $description "Converts a positive integer " { $snippet "n" } " to factoradic form. The factoradic of an integer is its representation based on a mixed radix numerical system that corresponds to the values of " { $snippet "n" } " factorial." }
{ $examples { $example "859 factoradic ." "{ 1 1 0 3 0 1 0 }" } } ;
HELP: >permutation
{ $values { "factoradic" sequence } { "permutation" sequence } }
{ $description "Converts an integer represented in factoradic form into its corresponding unique permutation (0-based)." }
{ $notes "For clarification, the following two statements are equivalent:" { $code "10 factoradic >permutation" "{ 1 2 0 0 } >permutation" } }
{ $examples { $example "{ 0 0 0 0 } >permutation ." "{ 0 1 2 3 }" } } ;

50
extra/math/combinatorics/combinatorics-tests.factor Normal file
View File

@ -0,0 +1,50 @@
USING: math.combinatorics math.combinatorics.private tools.test ;
IN: temporary
[ { } ] [ 0 factoradic ] unit-test
[ { 1 0 } ] [ 1 factoradic ] unit-test
[ { 1 1 0 3 0 1 0 } ] [ 859 factoradic ] unit-test
[ { 0 1 2 3 } ] [ { 0 0 0 0 } >permutation ] unit-test
[ { 0 1 3 2 } ] [ { 0 0 1 0 } >permutation ] unit-test
[ { 1 2 0 6 3 5 4 } ] [ { 1 1 0 3 0 1 0 } >permutation ] unit-test
[ { 0 1 2 3 } ] [ 0 4 permutation-indices ] unit-test
[ { 0 1 3 2 } ] [ 1 4 permutation-indices ] unit-test
[ { 1 2 0 6 3 5 4 } ] [ 859 7 permutation-indices ] unit-test
[ { "b" "d" } ] [ { "a" "b" "c" "d" } { 1 3 } reorder ] unit-test
[ { "a" "b" "c" "d" } ] [ { "a" "b" "c" "d" } { 0 1 2 3 } reorder ] unit-test
[ { "d" "c" "b" "a" } ] [ { "a" "b" "c" "d" } { 3 2 1 0 } reorder ] unit-test
[ { "d" "a" "b" "c" } ] [ { "a" "b" "c" "d" } { 3 0 1 2 } reorder ] unit-test
[ 1 ] [ 0 factorial ] unit-test
[ 1 ] [ 1 factorial ] unit-test
[ 3628800 ] [ 10 factorial ] unit-test
[ 1 ] [ 3 0 nPk ] unit-test
[ 6 ] [ 3 2 nPk ] unit-test
[ 6 ] [ 3 3 nPk ] unit-test
[ 0 ] [ 3 4 nPk ] unit-test
[ 311875200 ] [ 52 5 nPk ] unit-test
[ 672151459757865654763838640470031391460745878674027315200000000000 ] [ 52 47 nPk ] unit-test
[ 1 ] [ 3 0 nCk ] unit-test
[ 3 ] [ 3 2 nCk ] unit-test
[ 1 ] [ 3 3 nCk ] unit-test
[ 0 ] [ 3 4 nCk ] unit-test
[ 2598960 ] [ 52 5 nCk ] unit-test
[ 2598960 ] [ 52 47 nCk ] unit-test
[ { "a" "b" "c" "d" } ] [ 0 { "a" "b" "c" "d" } permutation ] unit-test
[ { "d" "c" "b" "a" } ] [ 23 { "a" "b" "c" "d" } permutation ] unit-test
[ { "d" "a" "b" "c" } ] [ 18 { "a" "b" "c" "d" } permutation ] unit-test
[ { { "a" "b" "c" } { "a" "c" "b" }
{ "b" "a" "c" } { "b" "c" "a" }
{ "c" "a" "b" } { "c" "b" "a" } } ] [ { "a" "b" "c" } all-permutations ] unit-test
[ { 0 1 2 } ] [ { "a" "b" "c" } inverse-permutation ] unit-test
[ { 2 1 0 } ] [ { "c" "b" "a" } inverse-permutation ] unit-test
[ { 3 0 2 1 } ] [ { 12 45 34 2 } inverse-permutation ] unit-test

54
extra/math/combinatorics/combinatorics.factor
View File

@ -1,21 +1,53 @@
USING: kernel math math.ranges math.vectors
sequences sorting mirrors assocs ;
! Copyright (c) 2007, 2008 Slava Pestov, Doug Coleman, Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel math math.ranges mirrors namespaces sequences sorting ;
IN: math.combinatorics
: possible? 0 rot between? ; inline
<PRIVATE
: nPk ( n k -- n!/k! )
2dup possible? [ [a,b) product ] [ 2drop 0 ] if ;
: possible? ( n m -- ? )
0 rot between? ; inline
: factorial ( n -- n! ) 1 nPk ;
: twiddle ( n k -- n k )
2dup - dupd > [ dupd - ] when ; inline
: (nCk) ( n k -- nCk )
[ nPk ] 2keep - factorial / ;
! See this article for explanation of the factoradic-based permutation methodology:
! http://msdn2.microsoft.com/en-us/library/aa302371.aspx
: twiddle 2dup - dupd < [ dupd - ] when ; inline
: factoradic ( n -- factoradic )
0 [ over 0 > ] [ 1+ [ /mod ] keep swap ] [ ] unfold reverse 2nip ;
: (>permutation) ( seq n -- seq )
[ [ dupd >= [ 1+ ] when ] curry map ] keep add* ;
: >permutation ( factoradic -- permutation )
reverse 1 cut [ (>permutation) ] each ;
: permutation-indices ( n seq -- permutation )
length [ factoradic ] dip 0 pad-left >permutation ;
: reorder ( seq indices -- seq )
[ [ over nth , ] each drop ] { } make ;
PRIVATE>
: factorial ( n -- n! )
1 [ 1+ * ] reduce ;
: nPk ( n k -- nPk )
2dup possible? [ dupd - [a,b) product ] [ 2drop 0 ] if ;
: nCk ( n k -- nCk )
2dup possible? [ twiddle (nCk) ] [ 2drop 0 ] if ;
twiddle [ nPk ] keep factorial / ;
: inverse-permutation ( seq -- seq )
: permutation ( n seq -- seq )
tuck permutation-indices reorder ;
: all-permutations ( seq -- seq )
[
[ length factorial ] keep [ permutation , ] curry each
] { } make ;
: inverse-permutation ( seq -- permutation )
<enum> >alist sort-values keys ;

2
extra/math/constants/constants.factor
View File

@ -4,6 +4,6 @@ IN: math.constants
: e ( -- e ) 2.7182818284590452354 ; inline
: gamma ( -- gamma ) 0.57721566490153286060 ; inline
: pi ( -- pi ) 3.14159265358979323846 ; inline
: phi ( -- phi ) 1.61803398874989484820 ; inline
: pi ( -- pi ) 3.14159265358979323846 ; inline
: epsilon ( -- epsilon ) 2.2204460492503131e-16 ; inline

19
extra/project-euler/024/024.factor
View File

@ -1,6 +1,6 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.parser math.ranges namespaces sequences ;
USING: kernel math.combinatorics math.parser ;
IN: project-euler.024
! http://projecteuler.net/index.php?section=problems&id=24
@ -22,23 +22,6 @@ IN: project-euler.024
! SOLUTION
! --------
<PRIVATE
: (>permutation) ( seq n -- seq )
[ [ dupd >= [ 1+ ] when ] curry map ] keep add* ;
PRIVATE>
: >permutation ( factoradic -- permutation )
reverse 1 cut [ (>permutation) ] each ;
: factoradic ( k order -- factoradic )
[ [1,b] [ 2dup mod , /i ] each ] { } make reverse nip ;
: permutation ( k seq -- seq )
dup length swapd factoradic >permutation
[ [ dupd swap nth , ] each drop ] { } make ;
: euler024 ( -- answer )
999999 10 permutation 10 swap digits>integer ;

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

@ -1,7 +1,7 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.lib hashtables kernel math math.combinatorics math.parser
math.ranges project-euler.common project-euler.024 sequences sorting ;
math.ranges project-euler.common sequences sorting ;
IN: project-euler.032
! http://projecteuler.net/index.php?section=problems&id=32

55
extra/project-euler/033/033.factor Normal file
View File

@ -0,0 +1,55 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.ranges project-euler.common sequences ;
IN: project-euler.033
! http://projecteuler.net/index.php?section=problems&id=33
! DESCRIPTION
! -----------
! The fraction 49/98 is a curious fraction, as an inexperienced mathematician
! in attempting to simplify it may incorrectly believe that 49/98 = 4/8, which
! is correct, is obtained by cancelling the 9s.
! We shall consider fractions like, 30/50 = 3/5, to be trivial examples.
! There are exactly four non-trivial examples of this type of fraction, less
! than one in value, and containing two digits in the numerator and
! denominator.
! If the product of these four fractions is given in its lowest common terms,
! find the value of the denominator.
! SOLUTION
! --------
! Through analysis, you only need to check fractions fitting the pattern ax/xb
<PRIVATE
: source-033 ( -- seq )
10 99 [a,b] dup cartesian-product [ first2 < ] subset ;
: safe? ( ax xb -- ? )
[ 10 /mod ] 2apply -roll = rot zero? not and nip ;
: ax/xb ( ax xb -- z/f )
2dup safe? [ [ 10 /mod ] 2apply 2nip / ] [ 2drop f ] if ;
: curious? ( m n -- ? )
2dup / [ ax/xb ] dip = ;
: curious-fractions ( seq -- seq )
[ first2 curious? ] subset [ first2 / ] map ;
PRIVATE>
: euler033 ( -- answer )
source-033 curious-fractions product denominator ;
! [ euler033 ] 100 ave-time
! 5 ms run / 0 ms GC ave time - 100 trials
MAIN: euler033

47
extra/project-euler/034/034.factor Normal file
View File

@ -0,0 +1,47 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.lib kernel math.ranges project-euler.common sequences ;
IN: project-euler.034
! http://projecteuler.net/index.php?section=problems&id=34
! DESCRIPTION
! -----------
! 145 is a curious number, as 1! + 4! + 5! = 1 + 24 + 120 = 145.
! Find the sum of all numbers which are equal to the sum of the factorial of
! their digits.
! Note: as 1! = 1 and 2! = 2 are not sums they are not included.
! SOLUTION
! --------
! We can reduce the upper bound a little by calculating 7 * 9! = 2540160, and
! then reducing one of the 9! to 2! (since the 7th digit cannot exceed 2), so we
! get 2! + 6 * 9! = 2177282 as an upper bound.
! We can then take that one more step, and notice that the largest factorial
! sum a 7 digit number starting with 21 or 20 is 2! + 1! + 5 * 9! or 1814403.
! So there can't be any 7 digit solutions starting with 21 or 20, and therefore
! our numbers must be less that 2000000.
<PRIVATE
: digit-factorial ( n -- n! )
{ 1 1 2 6 24 120 720 5040 40320 362880 } nth ;
: factorion? ( n -- ? )
dup number>digits [ digit-factorial ] sigma = ;
PRIVATE>
: euler034 ( -- answer )
3 2000000 [a,b] [ factorion? ] subset sum ;
! [ euler034 ] 10 ave-time
! 15089 ms run / 725 ms GC ave time - 10 trials
MAIN: euler034

61
extra/project-euler/035/035.factor Normal file
View File

@ -0,0 +1,61 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.lib kernel math math.combinatorics math.parser math.primes
project-euler.common sequences ;
IN: project-euler.035
! http://projecteuler.net/index.php?section=problems&id=35
! DESCRIPTION
! -----------
! The number, 197, is called a circular prime because all rotations of the
! digits: 197, 971, and 719, are themselves prime.
! There are thirteen such primes below 100:
! 2, 3, 5, 7, 11, 13, 17, 31, 37, 71, 73, 79, and 97.
! How many circular primes are there below one million?
! SOLUTION
! --------
<PRIVATE
: source-035 ( -- seq )
1000000 primes-upto [ number>digits ] map ;
: possible? ( seq -- ? )
dup length 1 > [
dup { 0 2 4 5 6 8 } swap seq-diff =
] [
drop t
] if ;
: rotate ( seq n -- seq )
cut* swap append ;
: (circular?) ( seq n -- ? )
dup 0 > [
2dup rotate 10 swap digits>integer
prime? [ 1- (circular?) ] [ 2drop f ] if
] [
2drop t
] if ;
: circular? ( seq -- ? )
dup length 1- (circular?) ;
PRIVATE>
: euler035 ( -- answer )
source-035 [ possible? ] subset [ circular? ] count ;
! [ euler035 ] 100 ave-time
! 904 ms run / 86 ms GC ave time - 100 trials
! TODO: try using bit arrays or other methods outlined here:
! http://home.comcast.net/~babdulbaki/Circular_Primes.html
MAIN: euler035

42
extra/project-euler/036/036.factor Normal file
View File

@ -0,0 +1,42 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.lib kernel math.parser math.ranges sequences ;
IN: project-euler.036
! http://projecteuler.net/index.php?section=problems&id=36
! DESCRIPTION
! -----------
! The decimal number, 585 = 1001001001 (binary), is palindromic in both bases.
! Find the sum of all numbers, less than one million, which are palindromic in
! base 10 and base 2.
! (Please note that the palindromic number, in either base, may not include
! leading zeros.)
! SOLUTION
! --------
! Only check odd numbers since the binary number must begin and end with 1
<PRIVATE
: palindrome? ( str -- ? )
dup reverse = ;
: both-bases? ( n -- ? )
{ [ dup number>string palindrome? ]
[ dup >bin palindrome? ] } && nip ;
PRIVATE>
: euler036 ( -- answer )
1 1000000 2 <range> [ both-bases? ] subset sum ;
! [ euler036 ] 100 ave-time
! 3891 ms run / 173 ms GC ave time - 100 trials
MAIN: euler036

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

@ -7,11 +7,11 @@ IN: project-euler.common
! Problems using each public word
! -------------------------------
! cartesian-product - #4, #27
! cartesian-product - #4, #27, #29, #32, #33
! collect-consecutive - #8, #11
! log10 - #25, #134
! max-path - #18, #67
! number>digits - #16, #20, #30
! number>digits - #16, #20, #30, #34
! propagate-all - #18, #67
! sum-proper-divisors - #21
! tau* - #12

8
extra/project-euler/project-euler.factor
View File

@ -1,4 +1,4 @@
! Copyright (c) 2007 Aaron Schaefer.
! Copyright (c) 2007, 2008 Aaron Schaefer, Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
USING: definitions io io.files kernel math.parser sequences vocabs
vocabs.loader project-euler.ave-time project-euler.common math
@ -9,8 +9,10 @@ USING: definitions io io.files kernel math.parser sequences vocabs
project-euler.017 project-euler.018 project-euler.019 project-euler.020
project-euler.021 project-euler.022 project-euler.023 project-euler.024
project-euler.025 project-euler.026 project-euler.027 project-euler.028
project-euler.029 project-euler.030 project-euler.067 project-euler.134
project-euler.169 project-euler.173 project-euler.175 ;
project-euler.029 project-euler.030 project-euler.031 project-euler.032
project-euler.033 project-euler.034 project-euler.035 project-euler.036
project-euler.067 project-euler.134 project-euler.169 project-euler.173
project-euler.175 ;
IN: project-euler
<PRIVATE

1
extra/store/authors.txt
View File

@ -1 +0,0 @@
Doug Coleman

1
extra/store/blob/authors.txt
View File

@ -1 +0,0 @@
Doug Coleman

22
extra/store/blob/blob.factor
View File

@ -1,22 +0,0 @@
! Copyright (C) 2006 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel io io.files namespaces serialize ;
IN: store.blob
: (save-blob) serialize ;
: save-blob ( obj path -- )
<file-appender> [ (save-blob) ] with-stream ;
: (load-blob) ( path -- seq/f )
dup exists? [
<file-reader> [
deserialize-sequence
] with-stream
] [
drop f
] if ;
: load-blob ( path -- seq/f )
resource-path (load-blob) ;

35
extra/store/store-tests.factor
View File

@ -1,35 +0,0 @@
USING: assocs continuations debugger io.files kernel
namespaces store tools.test ;
IN: temporary
SYMBOL: store
SYMBOL: foo
: the-store ( -- path )
"store-test.store" resource-path ;
: delete-the-store ( -- )
[ the-store delete-file ] catch drop ;
: load-the-store ( -- )
the-store load-store store set-global ;
: save-the-store ( -- )
store save-store ;
delete-the-store
load-the-store
[ f ] [ foo store get-persistent ] unit-test
USE: prettyprint
store get-global store-data .
[ ] [ 100 foo store set-persistent ] unit-test
[ ] [ save-the-store ] unit-test
[ 100 ] [ foo store get-persistent ] unit-test
delete-the-store
f store set-global

33
extra/store/store.factor
View File

@ -1,33 +0,0 @@
! Copyright (C) 2006, 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs io io.files kernel namespaces serialize init ;
IN: store
TUPLE: store path data ;
C: <store> store
: save-store ( store -- )
get-global dup store-data swap store-path
<file-writer> [ serialize ] with-stream ;
: load-store ( path -- store )
dup exists? [
dup <file-reader> [ deserialize ] with-stream
] [
H{ } clone
] if <store> ;
: define-store ( path id -- )
over >r
[ >r resource-path load-store r> set-global ] 2curry
r> add-init-hook ;
: get-persistent ( key store -- value )
get-global store-data at ;
: set-persistent ( value key store -- )
[ get-global store-data set-at ] keep save-store ;
: init-persistent ( value key store -- )
2dup get-persistent [ 3drop ] [ set-persistent ] if ;

4
extra/unicode/breaks/breaks-tests.factor
View File

@ -3,5 +3,5 @@ USING: tools.test unicode.breaks sequences math kernel ;
[ "\u1112\u1161\u11abA\u0300a\r\r\n" ]
[ "\r\n\raA\u0300\u1112\u1161\u11ab" string-reverse ] unit-test
[ "dcba" ] [ "abcd" string-reverse ] unit-test
[ 3 ] [ "\u1112\u1161\u11abA\u0300a" [ length 1- ] keep
[ prev-grapheme ] keep prev-grapheme ] unit-test
[ 3 ] [ "\u1112\u1161\u11abA\u0300a"
dup last-grapheme head last-grapheme ] unit-test

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

@ -85,45 +85,38 @@ DEFER: grapheme-table
: chars ( i str n -- str[i] str[i+n] )
swap >r dupd + r> [ ?nth ] curry 2apply ;
: next-grapheme-step ( i str -- i+1 str prev-class )
2dup nth grapheme-class >r >r 1+ r> r> ;
: find-index ( seq quot -- i ) find drop ; inline
: find-last-index ( seq quot -- i ) find-last drop ; inline
: (next-grapheme) ( i str prev-class -- next-i )
3dup drop bounds-check? [
>r next-grapheme-step r> over grapheme-break?
[ 2drop 1- ] [ (next-grapheme) ] if
] [ 2drop ] if ;
: first-grapheme ( str -- i )
unclip-slice grapheme-class over
[ grapheme-class tuck grapheme-break? ] find-index
nip swap length or 1+ ;
: next-grapheme ( i str -- next-i )
next-grapheme-step (next-grapheme) ;
: (>graphemes) ( str -- )
dup empty? [ drop ] [
dup first-grapheme cut-slice
swap , (>graphemes)
] if ;
: (>graphemes) ( i str -- )
2dup bounds-check? [
dupd [ next-grapheme ] keep
[ subseq , ] 2keep (>graphemes)
] [ 2drop ] if ;
: >graphemes ( str -- graphemes )
[ 0 swap (>graphemes) ] { } make* ;
[ (>graphemes) ] { } make ;
: string-reverse ( str -- rts )
>graphemes reverse concat ;
: prev-grapheme-step ( i str -- i-1 str prev-class )
2dup nth grapheme-class >r >r 1- r> r> ;
: unclip-last-slice ( seq -- beginning last )
dup 1 head-slice* swap peek ;
: (prev-grapheme) ( i str next-class -- prev-i )
pick zero? [
>r prev-grapheme-step r> dupd grapheme-break?
[ 2drop 1- ] [ (prev-grapheme) ] if
] [ 2drop ] if ;
: last-grapheme ( str -- i )
unclip-last-slice grapheme-class swap
[ grapheme-class dup rot grapheme-break? ] find-last-index
nip -1 or 1+ ;
: prev-grapheme ( i str -- prev-i )
prev-grapheme-step (prev-grapheme) ;
[
<<
other-extend-lines process-other-extend \ other-extend define-value
init-grapheme-table table
[ make-grapheme-table finish-table ] with-variable
\ grapheme-table define-value
] with-compilation-unit
>>

8
extra/unicode/syntax/syntax.factor
View File

@ -47,14 +47,6 @@ IN: unicode.syntax
CREATE ";" parse-tokens
categories swap seq-minus define-category ; parsing
TUPLE: code-point lower title upper ;
C: <code-point> code-point
: set-code-point ( seq -- )
4 head [ multihex ] map first4
<code-point> swap first set ;
: UNICHAR:
! This should be part of CHAR:
scan name>char [ parsed ] [ "Invalid character" throw ] if* ; parsing

25
extra/webapps/pastebin/pastebin.factor
View File

@ -1,6 +1,6 @@
USING: calendar furnace furnace.validator io.files kernel
namespaces sequences store http.server.responders html
math.parser rss xml.writer xmode.code2html ;
namespaces sequences http.server.responders html math.parser rss
xml.writer xmode.code2html ;
IN: webapps.pastebin
TUPLE: pastebin pastes ;
@ -8,11 +8,7 @@ TUPLE: pastebin pastes ;
: <pastebin> ( -- pastebin )
V{ } clone pastebin construct-boa ;
! Persistence
SYMBOL: store
"pastebin.store" store define-store
<pastebin> pastebin store init-persistent
<pastebin> pastebin set-global
TUPLE: paste
summary author channel mode contents date
@ -25,11 +21,8 @@ TUPLE: annotation summary author mode contents ;
C: <annotation> annotation
: get-pastebin ( -- pastebin )
pastebin store get-persistent ;
: get-paste ( n -- paste )
get-pastebin pastebin-pastes nth ;
pastebin get pastebin-pastes nth ;
: show-paste ( n -- )
serving-html
@ -49,7 +42,7 @@ C: <annotation> annotation
[
[ show-paste ] "show-paste-quot" set
[ new-paste ] "new-paste-quot" set
get-pastebin "paste-list" render-component
pastebin get "paste-list" render-component
] with-html-stream ;
\ paste-list { } define-action
@ -61,7 +54,7 @@ C: <annotation> annotation
over length min head ;
: paste-feed ( -- entries )
get-pastebin pastebin-pastes <reversed> 20 safe-head [
pastebin get pastebin-pastes <reversed> 20 safe-head [
{
paste-summary
paste-link
@ -82,10 +75,8 @@ C: <annotation> annotation
pastebin-pastes 2dup length swap set-paste-n push ;
: submit-paste ( summary author channel mode contents -- )
<paste> [
pastebin store get-persistent add-paste
store save-store
] keep paste-link permanent-redirect ;
<paste> [ pastebin get add-paste ] keep
paste-link permanent-redirect ;
\ new-paste
\ submit-paste {

6
vm/alien.h Normal file → Executable file
View File

@ -41,11 +41,7 @@ DLLEXPORT void to_value_struct(CELL src, void *dest, CELL size);
DLLEXPORT void box_value_struct(void *src, CELL size);
DLLEXPORT void box_small_struct(CELL x, CELL y, CELL size);
INLINE F_DLL *untag_dll(CELL tagged)
{
type_check(DLL_TYPE,tagged);
return (F_DLL*)UNTAG(tagged);
}
DEFINE_UNTAG(F_DLL,DLL_TYPE,dll)
DECLARE_PRIMITIVE(dlopen);
DECLARE_PRIMITIVE(dlsym);

6
vm/data_gc.c
View File

@ -177,12 +177,6 @@ CELL unaligned_object_size(CELL pointer)
return sizeof(F_QUOTATION);
case WORD_TYPE:
return sizeof(F_WORD);
case HASHTABLE_TYPE:
return sizeof(F_HASHTABLE);
case VECTOR_TYPE:
return sizeof(F_VECTOR);
case SBUF_TYPE:
return sizeof(F_SBUF);
case RATIO_TYPE:
return sizeof(F_RATIO);
case FLOAT_TYPE:

7
vm/errors.h
View File

@ -39,6 +39,13 @@ INLINE void type_check(CELL type, CELL tagged)
if(type_of(tagged) != type) type_error(type,tagged);
}
#define DEFINE_UNTAG(type,check,name) \
INLINE type *untag_##name(CELL obj) \
{ \
type_check(check,obj); \
return untag_object(obj); \
}
/* Global variables used to pass fault handler state from signal handler to
user-space */
CELL signal_number;

43
vm/layouts.h
View File

@ -52,21 +52,18 @@ typedef signed long long s64;
/*** Header types ***/
#define ARRAY_TYPE 8
#define WRAPPER_TYPE 9
#define HASHTABLE_TYPE 10
#define VECTOR_TYPE 11
#define FLOAT_ARRAY_TYPE 10
#define CALLSTACK_TYPE 11
#define STRING_TYPE 12
#define SBUF_TYPE 13
#define CURRY_TYPE 13
#define QUOTATION_TYPE 14
#define DLL_TYPE 15
#define ALIEN_TYPE 16
#define WORD_TYPE 17
#define BYTE_ARRAY_TYPE 18
#define BIT_ARRAY_TYPE 19
#define FLOAT_ARRAY_TYPE 20
#define CURRY_TYPE 21
#define CALLSTACK_TYPE 22
#define TYPE_COUNT 23
#define TYPE_COUNT 20
INLINE bool immediate_p(CELL obj)
{
@ -103,16 +100,6 @@ typedef F_ARRAY F_BIT_ARRAY;
typedef F_ARRAY F_FLOAT_ARRAY;
/* Assembly code makes assumptions about the layout of this struct */
typedef struct {
/* always tag_header(VECTOR_TYPE) */
CELL header;
/* tagged */
CELL top;
/* tagged */
CELL array;
} F_VECTOR;
/* Assembly code makes assumptions about the layout of this struct */
typedef struct {
CELL header;
@ -122,28 +109,6 @@ typedef struct {
CELL hashcode;
} F_STRING;
/* Assembly code makes assumptions about the layout of this struct */
typedef struct {
/* always tag_header(SBUF_TYPE) */
CELL header;
/* tagged */
CELL top;
/* tagged */
CELL string;
} F_SBUF;
/* Assembly code makes assumptions about the layout of this struct */
typedef struct {
/* always tag_header(HASHTABLE_TYPE) */
CELL header;
/* tagged */
CELL count;
/* tagged */
CELL deleted;
/* tagged */
CELL array;
} F_HASHTABLE;
/* The compiled code heap is structured into blocks. */
typedef struct
{

6
vm/primitives.c
View File

@ -4,7 +4,6 @@ void *primitives[] = {
primitive_execute,
primitive_call,
primitive_uncurry,
primitive_string_to_sbuf,
primitive_bignum_to_fixnum,
primitive_float_to_fixnum,
primitive_fixnum_to_bignum,
@ -157,7 +156,6 @@ void *primitives[] = {
primitive_set_char_slot,
primitive_resize_array,
primitive_resize_string,
primitive_hashtable,
primitive_array,
primitive_begin_scan,
primitive_next_object,
@ -172,7 +170,6 @@ void *primitives[] = {
primitive_fclose,
primitive_wrapper,
primitive_clone,
primitive_array_to_vector,
primitive_string,
primitive_to_tuple,
primitive_array_to_quotation,
@ -192,4 +189,7 @@ void *primitives[] = {
primitive_set_innermost_stack_frame_quot,
primitive_call_clear,
primitive_os_envs,
primitive_resize_byte_array,
primitive_resize_bit_array,
primitive_resize_float_array,
};

460
vm/types.c
View File

@ -12,6 +12,80 @@ bool to_boolean(CELL value)
return value != F;
}
CELL clone(CELL object)
{
CELL size = object_size(object);
if(size == 0)
return object;
else
{
REGISTER_ROOT(object);
void *new_obj = allot_object(type_of(object),size);
UNREGISTER_ROOT(object);
CELL tag = TAG(object);
memcpy(new_obj,(void*)UNTAG(object),size);
return RETAG(new_obj,tag);
}
}
DEFINE_PRIMITIVE(clone)
{
drepl(clone(dpeek()));
}
F_WORD *allot_word(CELL vocab, CELL name)
{
REGISTER_ROOT(vocab);
REGISTER_ROOT(name);
F_WORD *word = allot_object(WORD_TYPE,sizeof(F_WORD));
UNREGISTER_ROOT(name);
UNREGISTER_ROOT(vocab);
word->hashcode = tag_fixnum(rand());
word->vocabulary = vocab;
word->name = name;
word->def = userenv[UNDEFINED_ENV];
word->props = F;
word->counter = tag_fixnum(0);
word->compiledp = F;
word->profiling = NULL;
REGISTER_UNTAGGED(word);
default_word_code(word,true);
UNREGISTER_UNTAGGED(word);
REGISTER_UNTAGGED(word);
update_word_xt(word);
UNREGISTER_UNTAGGED(word);
return word;
}
/* <word> ( name vocabulary -- word ) */
DEFINE_PRIMITIVE(word)
{
CELL vocab = dpop();
CELL name = dpop();
dpush(tag_object(allot_word(vocab,name)));
}
/* word-xt ( word -- xt ) */
DEFINE_PRIMITIVE(word_xt)
{
F_WORD *word = untag_word(dpeek());
drepl(allot_cell((CELL)word->xt));
}
DEFINE_PRIMITIVE(wrapper)
{
F_WRAPPER *wrapper = allot_object(WRAPPER_TYPE,sizeof(F_WRAPPER));
wrapper->object = dpeek();
drepl(tag_object(wrapper));
}
/* Arrays */
/* the array is full of undefined data, and must be correctly filled before the
next GC. size is in cells */
F_ARRAY *allot_array_internal(CELL type, CELL capacity)
@ -38,41 +112,6 @@ F_ARRAY *allot_array(CELL type, CELL capacity, CELL fill)
return array;
}
/* size is in bytes this time */
F_BYTE_ARRAY *allot_byte_array(CELL size)
{
F_BYTE_ARRAY *array = allot_object(BYTE_ARRAY_TYPE,
byte_array_size(size));
array->capacity = tag_fixnum(size);
memset(array + 1,0,size);
return array;
}
/* size is in bits */
F_BIT_ARRAY *allot_bit_array(CELL size)
{
F_BIT_ARRAY *array = allot_object(BIT_ARRAY_TYPE,
bit_array_size(size));
array->capacity = tag_fixnum(size);
memset(array + 1,0,(size + 31) / 32 * 4);
return array;
}
/* size is in 8-byte doubles */
F_BIT_ARRAY *allot_float_array(CELL size, double initial)
{
F_FLOAT_ARRAY *array = allot_object(FLOAT_ARRAY_TYPE,
float_array_size(size));
array->capacity = tag_fixnum(size);
double *elements = (double *)AREF(array,0);
int i;
for(i = 0; i < size; i++)
elements[i] = initial;
return array;
}
/* push a new array on the stack */
DEFINE_PRIMITIVE(array)
{
@ -81,89 +120,6 @@ DEFINE_PRIMITIVE(array)
dpush(tag_object(allot_array(ARRAY_TYPE,size,initial)));
}
/* push a new tuple on the stack */
DEFINE_PRIMITIVE(tuple)
{
CELL size = unbox_array_size();
F_ARRAY *array = allot_array(TUPLE_TYPE,size,F);
set_array_nth(array,0,dpop());
dpush(tag_tuple(array));
}
/* push a new tuple on the stack, filling its slots from the stack */
DEFINE_PRIMITIVE(tuple_boa)
{
CELL size = unbox_array_size();
F_ARRAY *array = allot_array(TUPLE_TYPE,size,F);
set_array_nth(array,0,dpop());
CELL i;
for(i = size - 1; i >= 2; i--)
set_array_nth(array,i,dpop());
dpush(tag_tuple(array));
}
/* push a new byte array on the stack */
DEFINE_PRIMITIVE(byte_array)
{
CELL size = unbox_array_size();
dpush(tag_object(allot_byte_array(size)));
}
/* push a new bit array on the stack */
DEFINE_PRIMITIVE(bit_array)
{
CELL size = unbox_array_size();
dpush(tag_object(allot_bit_array(size)));
}
/* push a new float array on the stack */
DEFINE_PRIMITIVE(float_array)
{
double initial = untag_float(dpop());
CELL size = unbox_array_size();
dpush(tag_object(allot_float_array(size,initial)));
}
CELL clone(CELL object)
{
CELL size = object_size(object);
if(size == 0)
return object;
else
{
REGISTER_ROOT(object);
void *new_obj = allot_object(type_of(object),size);
UNREGISTER_ROOT(object);
CELL tag = TAG(object);
memcpy(new_obj,(void*)UNTAG(object),size);
return RETAG(new_obj,tag);
}
}
DEFINE_PRIMITIVE(clone)
{
drepl(clone(dpeek()));
}
DEFINE_PRIMITIVE(tuple_to_array)
{
CELL object = dpeek();
type_check(TUPLE_TYPE,object);
object = RETAG(clone(object),OBJECT_TYPE);
set_slot(object,0,tag_header(ARRAY_TYPE));
drepl(object);
}
DEFINE_PRIMITIVE(to_tuple)
{
CELL object = RETAG(clone(dpeek()),TUPLE_TYPE);
set_slot(object,0,tag_header(TUPLE_TYPE));
drepl(object);
}
CELL allot_array_1(CELL obj)
{
REGISTER_ROOT(obj);
@ -235,14 +191,6 @@ DEFINE_PRIMITIVE(resize_array)
dpush(tag_object(reallot_array(array,capacity,F)));
}
DEFINE_PRIMITIVE(array_to_vector)
{
F_VECTOR *vector = allot_object(VECTOR_TYPE,sizeof(F_VECTOR));
vector->top = dpop();
vector->array = dpop();
dpush(tag_object(vector));
}
F_ARRAY *growable_add(F_ARRAY *result, CELL elt, CELL *result_count)
{
REGISTER_ROOT(elt);
@ -279,6 +227,199 @@ F_ARRAY *growable_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_count)
return result;
}
/* Byte arrays */
/* must fill out array before next GC */
F_BYTE_ARRAY *allot_byte_array_internal(CELL size)
{
F_BYTE_ARRAY *array = allot_object(BYTE_ARRAY_TYPE,
byte_array_size(size));
array->capacity = tag_fixnum(size);
return array;
}
/* size is in bytes this time */
F_BYTE_ARRAY *allot_byte_array(CELL size)
{
F_BYTE_ARRAY *array = allot_byte_array_internal(size);
memset(array + 1,0,size);
return array;
}
/* push a new byte array on the stack */
DEFINE_PRIMITIVE(byte_array)
{
CELL size = unbox_array_size();
dpush(tag_object(allot_byte_array(size)));
}
F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity)
{
CELL to_copy = array_capacity(array);
if(capacity < to_copy)
to_copy = capacity;
REGISTER_UNTAGGED(array);
F_BYTE_ARRAY *new_array = allot_byte_array(capacity);
UNREGISTER_UNTAGGED(array);
memcpy(new_array + 1,array + 1,to_copy);
return new_array;
}
DEFINE_PRIMITIVE(resize_byte_array)
{
F_BYTE_ARRAY* array = untag_byte_array(dpop());
CELL capacity = unbox_array_size();
dpush(tag_object(reallot_byte_array(array,capacity)));
}
/* Bit arrays */
/* size is in bits */
F_BIT_ARRAY *allot_bit_array_internal(CELL size)
{
F_BIT_ARRAY *array = allot_object(BIT_ARRAY_TYPE,bit_array_size(size));
array->capacity = tag_fixnum(size);
return array;
}
F_BIT_ARRAY *allot_bit_array(CELL size)
{
F_BIT_ARRAY *array = allot_bit_array_internal(size);
memset(array + 1,0,bit_array_size(size));
return array;
}
/* push a new bit array on the stack */
DEFINE_PRIMITIVE(bit_array)
{
CELL size = unbox_array_size();
dpush(tag_object(allot_bit_array(size)));
}
F_BIT_ARRAY *reallot_bit_array(F_BIT_ARRAY *array, CELL capacity)
{
CELL to_copy = array_capacity(array);
if(capacity < to_copy)
to_copy = capacity;
REGISTER_UNTAGGED(array);
F_BIT_ARRAY *new_array = allot_bit_array(capacity);
UNREGISTER_UNTAGGED(array);
memcpy(new_array + 1,array + 1,bit_array_size(to_copy));
return new_array;
}
DEFINE_PRIMITIVE(resize_bit_array)
{
F_BYTE_ARRAY* array = untag_bit_array(dpop());
CELL capacity = unbox_array_size();
dpush(tag_object(reallot_bit_array(array,capacity)));
}
/* Float arrays */
/* size is in 8-byte doubles */
F_FLOAT_ARRAY *allot_float_array_internal(CELL size)
{
F_FLOAT_ARRAY *array = allot_object(FLOAT_ARRAY_TYPE,
float_array_size(size));
array->capacity = tag_fixnum(size);
return array;
}
F_FLOAT_ARRAY *allot_float_array(CELL size, double initial)
{
F_FLOAT_ARRAY *array = allot_float_array_internal(size);
double *elements = (double *)AREF(array,0);
int i;
for(i = 0; i < size; i++)
elements[i] = initial;
return array;
}
/* push a new float array on the stack */
DEFINE_PRIMITIVE(float_array)
{
double initial = untag_float(dpop());
CELL size = unbox_array_size();
dpush(tag_object(allot_float_array(size,initial)));
}
F_ARRAY *reallot_float_array(F_FLOAT_ARRAY* array, CELL capacity)
{
F_FLOAT_ARRAY* new_array;
CELL to_copy = array_capacity(array);
if(capacity < to_copy)
to_copy = capacity;
REGISTER_UNTAGGED(array);
new_array = allot_float_array(capacity,0.0);
UNREGISTER_UNTAGGED(array);
memcpy(new_array + 1,array + 1,to_copy * sizeof(double));
return new_array;
}
DEFINE_PRIMITIVE(resize_float_array)
{
F_FLOAT_ARRAY* array = untag_float_array(dpop());
CELL capacity = unbox_array_size();
dpush(tag_object(reallot_float_array(array,capacity)));
}
/* Tuples */
/* push a new tuple on the stack */
DEFINE_PRIMITIVE(tuple)
{
CELL size = unbox_array_size();
F_ARRAY *array = allot_array(TUPLE_TYPE,size,F);
set_array_nth(array,0,dpop());
dpush(tag_tuple(array));
}
/* push a new tuple on the stack, filling its slots from the stack */
DEFINE_PRIMITIVE(tuple_boa)
{
CELL size = unbox_array_size();
F_ARRAY *array = allot_array(TUPLE_TYPE,size,F);
set_array_nth(array,0,dpop());
CELL i;
for(i = size - 1; i >= 2; i--)
set_array_nth(array,i,dpop());
dpush(tag_tuple(array));
}
DEFINE_PRIMITIVE(tuple_to_array)
{
CELL object = dpeek();
type_check(TUPLE_TYPE,object);
object = RETAG(clone(object),OBJECT_TYPE);
set_slot(object,0,tag_header(ARRAY_TYPE));
drepl(object);
}
DEFINE_PRIMITIVE(to_tuple)
{
CELL object = RETAG(clone(dpeek()),TUPLE_TYPE);
set_slot(object,0,tag_header(TUPLE_TYPE));
drepl(object);
}
/* Strings */
/* untagged */
F_STRING* allot_string_internal(CELL capacity)
{
@ -469,70 +610,3 @@ DEFINE_PRIMITIVE(set_char_slot)
CELL value = untag_fixnum_fast(dpop());
set_string_nth(string,index,value);
}
DEFINE_PRIMITIVE(string_to_sbuf)
{
F_SBUF *sbuf = allot_object(SBUF_TYPE,sizeof(F_SBUF));
sbuf->top = dpop();
sbuf->string = dpop();
dpush(tag_object(sbuf));
}
DEFINE_PRIMITIVE(hashtable)
{
F_HASHTABLE* hash = allot_object(HASHTABLE_TYPE,sizeof(F_HASHTABLE));
hash->count = F;
hash->deleted = F;
hash->array = F;
dpush(tag_object(hash));
}
F_WORD *allot_word(CELL vocab, CELL name)
{
REGISTER_ROOT(vocab);
REGISTER_ROOT(name);
F_WORD *word = allot_object(WORD_TYPE,sizeof(F_WORD));
UNREGISTER_ROOT(name);
UNREGISTER_ROOT(vocab);
word->hashcode = tag_fixnum(rand());
word->vocabulary = vocab;
word->name = name;
word->def = userenv[UNDEFINED_ENV];
word->props = F;
word->counter = tag_fixnum(0);
word->compiledp = F;
word->profiling = NULL;
REGISTER_UNTAGGED(word);
default_word_code(word,true);
UNREGISTER_UNTAGGED(word);
REGISTER_UNTAGGED(word);
update_word_xt(word);
UNREGISTER_UNTAGGED(word);
return word;
}
/* <word> ( name vocabulary -- word ) */
DEFINE_PRIMITIVE(word)
{
CELL vocab = dpop();
CELL name = dpop();
dpush(tag_object(allot_word(vocab,name)));
}
/* word-xt ( word -- xt ) */
DEFINE_PRIMITIVE(word_xt)
{
F_WORD *word = untag_word(dpeek());
drepl(allot_cell((CELL)word->xt));
}
DEFINE_PRIMITIVE(wrapper)
{
F_WRAPPER *wrapper = allot_object(WRAPPER_TYPE,sizeof(F_WRAPPER));
wrapper->object = dpeek();
drepl(tag_object(wrapper));
}

39
vm/types.h
View File

@ -14,6 +14,8 @@ INLINE CELL string_size(CELL size)
return sizeof(F_STRING) + (size + 1) * CHARS;
}
DEFINE_UNTAG(F_BYTE_ARRAY,BYTE_ARRAY_TYPE,byte_array)
INLINE CELL byte_array_capacity(F_BYTE_ARRAY *array)
{
return untag_fixnum_fast(array->capacity);
@ -24,6 +26,8 @@ INLINE CELL byte_array_size(CELL size)
return sizeof(F_BYTE_ARRAY) + size;
}
DEFINE_UNTAG(F_BIT_ARRAY,BIT_ARRAY_TYPE,bit_array)
INLINE CELL bit_array_capacity(F_BIT_ARRAY *array)
{
return untag_fixnum_fast(array->capacity);
@ -34,6 +38,8 @@ INLINE CELL bit_array_size(CELL size)
return sizeof(F_BIT_ARRAY) + (size + 7) / 8;
}
DEFINE_UNTAG(F_FLOAT_ARRAY,FLOAT_ARRAY_TYPE,float_array)
INLINE CELL float_array_capacity(F_FLOAT_ARRAY *array)
{
return untag_fixnum_fast(array->capacity);
@ -49,22 +55,14 @@ INLINE CELL callstack_size(CELL size)
return sizeof(F_CALLSTACK) + size;
}
INLINE F_CALLSTACK *untag_callstack(CELL obj)
{
type_check(CALLSTACK_TYPE,obj);
return untag_object(obj);
}
DEFINE_UNTAG(F_CALLSTACK,CALLSTACK_TYPE,callstack)
INLINE CELL tag_boolean(CELL untagged)
{
return (untagged == false ? F : T);
}
INLINE F_ARRAY* untag_array(CELL tagged)
{
type_check(ARRAY_TYPE,tagged);
return untag_object(tagged);
}
DEFINE_UNTAG(F_ARRAY,ARRAY_TYPE,array)
#define AREF(array,index) ((CELL)(array) + sizeof(F_ARRAY) + (index) * CELLS)
#define UNAREF(array,ptr) (((CELL)(ptr)-(CELL)(array)-sizeof(F_ARRAY)) / CELLS)
@ -103,17 +101,9 @@ INLINE void set_string_nth(F_STRING* string, CELL index, u16 value)
cput(SREF(string,index),value);
}
INLINE F_QUOTATION *untag_quotation(CELL tagged)
{
type_check(QUOTATION_TYPE,tagged);
return untag_object(tagged);
}
DEFINE_UNTAG(F_QUOTATION,QUOTATION_TYPE,quotation)
INLINE F_WORD *untag_word(CELL tagged)
{
type_check(WORD_TYPE,tagged);
return untag_object(tagged);
}
DEFINE_UNTAG(F_WORD,WORD_TYPE,word)
INLINE CELL tag_tuple(F_ARRAY *tuple)
{
@ -144,8 +134,9 @@ DECLARE_PRIMITIVE(to_tuple);
F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity, CELL fill);
DECLARE_PRIMITIVE(resize_array);
DECLARE_PRIMITIVE(array_to_vector);
DECLARE_PRIMITIVE(resize_byte_array);
DECLARE_PRIMITIVE(resize_bit_array);
DECLARE_PRIMITIVE(resize_float_array);
F_STRING* allot_string_internal(CELL capacity);
F_STRING* allot_string(CELL capacity, CELL fill);
@ -178,10 +169,6 @@ DECLARE_PRIMITIVE(string_to_u16_alien);
DECLARE_PRIMITIVE(char_slot);
DECLARE_PRIMITIVE(set_char_slot);
DECLARE_PRIMITIVE(string_to_sbuf);
DECLARE_PRIMITIVE(hashtable);
F_WORD *allot_word(CELL vocab, CELL name);
DECLARE_PRIMITIVE(word);
DECLARE_PRIMITIVE(word_xt);