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

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

db4
Doug Coleman 2008-02-11 16:28:19 -06:00
parent 34c1170963 bacc5dc610
commit d7a5f9f505
47 changed files with 492 additions and 376 deletions

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

@ -1,4 +1,4 @@
! Copyright (C) 2007 Slava Pestov.
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces math words kernel alien byte-arrays
hashtables vectors strings sbufs arrays bit-arrays
@ -8,7 +8,7 @@ BIN: 111 tag-mask set
8 num-tags set
3 tag-bits set
20 num-types set
19 num-types set
H{
{ fixnum BIN: 000 }
@ -27,11 +27,10 @@ tag-numbers get H{
{ float-array 10 }
{ callstack 11 }
{ string 12 }
{ curry 13 }
{ bit-array 13 }
{ quotation 14 }
{ dll 15 }
{ alien 16 }
{ word 17 }
{ byte-array 18 }
{ bit-array 19 }
} union type-numbers set

52
core/bootstrap/primitives.factor
View File

@ -295,23 +295,6 @@ define-builtin
"float-array?" "float-arrays" create
{ } define-builtin
"curry" "kernel" create
"curry?" "kernel" create
{
{
{ "object" "kernel" }
"obj"
{ "curry-obj" "kernel" }
f
}
{
{ "object" "kernel" }
"obj"
{ "curry-quot" "kernel" }
f
}
} define-builtin
"callstack" "kernel" create "callstack?" "kernel" create
{ } define-builtin
@ -440,14 +423,44 @@ builtins get num-tags get tail f union-class define-class
}
} define-tuple-class
"curry" "kernel" create
{
{
{ "object" "kernel" }
"obj"
{ "curry-obj" "kernel" }
f
} {
{ "object" "kernel" }
"quot"
{ "curry-quot" "kernel" }
f
}
} define-tuple-class
"compose" "kernel" create
{
{
{ "object" "kernel" }
"first"
{ "compose-first" "kernel" }
f
} {
{ "object" "kernel" }
"second"
{ "compose-second" "kernel" }
f
}
} define-tuple-class
! Primitive words
: make-primitive ( word vocab n -- )
>r create dup reset-word r> [ do-primitive ] curry [ ] like define ;
>r create dup reset-word r>
[ do-primitive ] curry [ ] like define ;
{
{ "(execute)" "words.private" }
{ "(call)" "kernel.private" }
{ "uncurry" "kernel.private" }
{ "bignum>fixnum" "math.private" }
{ "float>fixnum" "math.private" }
{ "fixnum>bignum" "math.private" }
@ -622,7 +635,6 @@ builtins get num-tags get tail f union-class define-class
{ "become" "kernel.private" }
{ "(sleep)" "threads.private" }
{ "<float-array>" "float-arrays" }
{ "curry" "kernel" }
{ "<tuple-boa>" "tuples.private" }
{ "class-hash" "kernel.private" }
{ "callstack>array" "kernel" }

2
core/continuations/continuations.factor
View File

@ -98,7 +98,7 @@ PRIVATE>
: continue-with ( obj continuation -- )
[
walker-hook [ >r 2array r> ] when* (continue-with)
] 2curry (throw) ;
] 2 (throw) ;
: continue ( continuation -- )
f swap continue-with ;

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

@ -185,20 +185,14 @@ M: pair constraint-satisfied?
[ swap predicate-constraints ] [ 2drop ] if
] if* ;
: default-output-classes ( word -- classes )
"inferred-effect" word-prop {
{ [ dup not ] [ drop f ] }
{ [ dup effect-out [ class? ] all? not ] [ drop f ] }
{ [ t ] [ effect-out ] }
} cond ;
: compute-output-classes ( node word -- classes intervals )
dup node-param "output-classes" word-prop dup
[ call ] [ 2drop f f ] if ;
dup node-param "output-classes" word-prop
dup [ call ] [ 2drop f f ] if ;
: output-classes ( node -- classes intervals )
dup compute-output-classes
>r [ ] [ node-param default-output-classes ] ?if r> ;
dup compute-output-classes >r
[ ] [ node-param "default-output-classes" word-prop ] ?if
r> ;
M: #call infer-classes-before
dup compute-constraints

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

@ -126,15 +126,11 @@ M: object infer-call
pop-d pop-d swap <curried> push-d
] "infer" set-word-prop
\ curry { object object } { curry } <effect> "inferred-effect" set-word-prop
\ compose [
2 ensure-values
pop-d pop-d swap <composed> push-d
] "infer" set-word-prop
\ compose { object object } { curry } <effect> "inferred-effect" set-word-prop
! Variadic tuple constructor
\ <tuple-boa> [
\ <tuple-boa>
@ -142,457 +138,461 @@ M: object infer-call
make-call-node
] "infer" set-word-prop
! We need this for default-output-classes
\ <tuple-boa> 2 { tuple } <effect> "inferred-effect" set-word-prop
! Non-standard control flow
\ (throw) { callable } { } <effect>
t over set-effect-terminated?
"inferred-effect" set-word-prop
\ (throw) [
\ (throw)
peek-d value-literal 2 + { } <effect>
t over set-effect-terminated?
make-call-node
] "infer" set-word-prop
: set-primitive-effect ( word effect -- )
2dup effect-out "default-output-classes" set-word-prop
dupd [ make-call-node ] 2curry "infer" set-word-prop ;
! Stack effects for all primitives
\ fixnum< { fixnum fixnum } { object } <effect> "inferred-effect" set-word-prop
\ fixnum< { fixnum fixnum } { object } <effect> set-primitive-effect
\ fixnum< make-foldable
\ fixnum<= { fixnum fixnum } { object } <effect> "inferred-effect" set-word-prop
\ fixnum<= { fixnum fixnum } { object } <effect> set-primitive-effect
\ fixnum<= make-foldable
\ fixnum> { fixnum fixnum } { object } <effect> "inferred-effect" set-word-prop
\ fixnum> { fixnum fixnum } { object } <effect> set-primitive-effect
\ fixnum> make-foldable
\ fixnum>= { fixnum fixnum } { object } <effect> "inferred-effect" set-word-prop
\ fixnum>= { fixnum fixnum } { object } <effect> set-primitive-effect
\ fixnum>= make-foldable
\ eq? { object object } { object } <effect> "inferred-effect" set-word-prop
\ eq? { object object } { object } <effect> set-primitive-effect
\ eq? make-foldable
\ rehash-string { string } { } <effect> "inferred-effect" set-word-prop
\ rehash-string { string } { } <effect> set-primitive-effect
\ bignum>fixnum { bignum } { fixnum } <effect> "inferred-effect" set-word-prop
\ bignum>fixnum { bignum } { fixnum } <effect> set-primitive-effect
\ bignum>fixnum make-foldable
\ float>fixnum { float } { fixnum } <effect> "inferred-effect" set-word-prop
\ float>fixnum { float } { fixnum } <effect> set-primitive-effect
\ bignum>fixnum make-foldable
\ fixnum>bignum { fixnum } { bignum } <effect> "inferred-effect" set-word-prop
\ fixnum>bignum { fixnum } { bignum } <effect> set-primitive-effect
\ fixnum>bignum make-foldable
\ float>bignum { float } { bignum } <effect> "inferred-effect" set-word-prop
\ float>bignum { float } { bignum } <effect> set-primitive-effect
\ float>bignum make-foldable
\ fixnum>float { fixnum } { float } <effect> "inferred-effect" set-word-prop
\ fixnum>float { fixnum } { float } <effect> set-primitive-effect
\ fixnum>float make-foldable
\ bignum>float { bignum } { float } <effect> "inferred-effect" set-word-prop
\ bignum>float { bignum } { float } <effect> set-primitive-effect
\ bignum>float make-foldable
\ <ratio> { integer integer } { ratio } <effect> "inferred-effect" set-word-prop
\ <ratio> { integer integer } { ratio } <effect> set-primitive-effect
\ <ratio> make-foldable
\ string>float { string } { float } <effect> "inferred-effect" set-word-prop
\ string>float { string } { float } <effect> set-primitive-effect
\ string>float make-foldable
\ float>string { float } { string } <effect> "inferred-effect" set-word-prop
\ float>string { float } { string } <effect> set-primitive-effect
\ float>string make-foldable
\ float>bits { real } { integer } <effect> "inferred-effect" set-word-prop
\ float>bits { real } { integer } <effect> set-primitive-effect
\ float>bits make-foldable
\ double>bits { real } { integer } <effect> "inferred-effect" set-word-prop
\ double>bits { real } { integer } <effect> set-primitive-effect
\ double>bits make-foldable
\ bits>float { integer } { float } <effect> "inferred-effect" set-word-prop
\ bits>float { integer } { float } <effect> set-primitive-effect
\ bits>float make-foldable
\ bits>double { integer } { float } <effect> "inferred-effect" set-word-prop
\ bits>double { integer } { float } <effect> set-primitive-effect
\ bits>double make-foldable
\ <complex> { real real } { complex } <effect> "inferred-effect" set-word-prop
\ <complex> { real real } { complex } <effect> set-primitive-effect
\ <complex> make-foldable
\ fixnum+ { fixnum fixnum } { integer } <effect> "inferred-effect" set-word-prop
\ fixnum+ { fixnum fixnum } { integer } <effect> set-primitive-effect
\ fixnum+ make-foldable
\ fixnum+fast { fixnum fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
\ fixnum+fast { fixnum fixnum } { fixnum } <effect> set-primitive-effect
\ fixnum+fast make-foldable
\ fixnum- { fixnum fixnum } { integer } <effect> "inferred-effect" set-word-prop
\ fixnum- { fixnum fixnum } { integer } <effect> set-primitive-effect
\ fixnum- make-foldable
\ fixnum-fast { fixnum fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
\ fixnum-fast { fixnum fixnum } { fixnum } <effect> set-primitive-effect
\ fixnum-fast make-foldable
\ fixnum* { fixnum fixnum } { integer } <effect> "inferred-effect" set-word-prop
\ fixnum* { fixnum fixnum } { integer } <effect> set-primitive-effect
\ fixnum* make-foldable
\ fixnum*fast { fixnum fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
\ fixnum*fast { fixnum fixnum } { fixnum } <effect> set-primitive-effect
\ fixnum*fast make-foldable
\ fixnum/i { fixnum fixnum } { integer } <effect> "inferred-effect" set-word-prop
\ fixnum/i { fixnum fixnum } { integer } <effect> set-primitive-effect
\ fixnum/i make-foldable
\ fixnum-mod { fixnum fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
\ fixnum-mod { fixnum fixnum } { fixnum } <effect> set-primitive-effect
\ fixnum-mod make-foldable
\ fixnum/mod { fixnum fixnum } { integer fixnum } <effect> "inferred-effect" set-word-prop
\ fixnum/mod { fixnum fixnum } { integer fixnum } <effect> set-primitive-effect
\ fixnum/mod make-foldable
\ fixnum-bitand { fixnum fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
\ fixnum-bitand { fixnum fixnum } { fixnum } <effect> set-primitive-effect
\ fixnum-bitand make-foldable
\ fixnum-bitor { fixnum fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
\ fixnum-bitor { fixnum fixnum } { fixnum } <effect> set-primitive-effect
\ fixnum-bitor make-foldable
\ fixnum-bitxor { fixnum fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
\ fixnum-bitxor { fixnum fixnum } { fixnum } <effect> set-primitive-effect
\ fixnum-bitxor make-foldable
\ fixnum-bitnot { fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
\ fixnum-bitnot { fixnum } { fixnum } <effect> set-primitive-effect
\ fixnum-bitnot make-foldable
\ fixnum-shift { fixnum fixnum } { integer } <effect> "inferred-effect" set-word-prop
\ fixnum-shift { fixnum fixnum } { integer } <effect> set-primitive-effect
\ fixnum-shift make-foldable
\ fixnum-shift-fast { fixnum fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
\ fixnum-shift-fast { fixnum fixnum } { fixnum } <effect> set-primitive-effect
\ fixnum-shift-fast make-foldable
\ bignum= { bignum bignum } { object } <effect> "inferred-effect" set-word-prop
\ bignum= { bignum bignum } { object } <effect> set-primitive-effect
\ bignum= make-foldable
\ bignum+ { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
\ bignum+ { bignum bignum } { bignum } <effect> set-primitive-effect
\ bignum+ make-foldable
\ bignum- { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
\ bignum- { bignum bignum } { bignum } <effect> set-primitive-effect
\ bignum- make-foldable
\ bignum* { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
\ bignum* { bignum bignum } { bignum } <effect> set-primitive-effect
\ bignum* make-foldable
\ bignum/i { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
\ bignum/i { bignum bignum } { bignum } <effect> set-primitive-effect
\ bignum/i make-foldable
\ bignum-mod { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
\ bignum-mod { bignum bignum } { bignum } <effect> set-primitive-effect
\ bignum-mod make-foldable
\ bignum/mod { bignum bignum } { bignum bignum } <effect> "inferred-effect" set-word-prop
\ bignum/mod { bignum bignum } { bignum bignum } <effect> set-primitive-effect
\ bignum/mod make-foldable
\ bignum-bitand { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
\ bignum-bitand { bignum bignum } { bignum } <effect> set-primitive-effect
\ bignum-bitand make-foldable
\ bignum-bitor { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
\ bignum-bitor { bignum bignum } { bignum } <effect> set-primitive-effect
\ bignum-bitor make-foldable
\ bignum-bitxor { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
\ bignum-bitxor { bignum bignum } { bignum } <effect> set-primitive-effect
\ bignum-bitxor make-foldable
\ bignum-bitnot { bignum } { bignum } <effect> "inferred-effect" set-word-prop
\ bignum-bitnot { bignum } { bignum } <effect> set-primitive-effect
\ bignum-bitnot make-foldable
\ bignum-shift { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
\ bignum-shift { bignum bignum } { bignum } <effect> set-primitive-effect
\ bignum-shift make-foldable
\ bignum< { bignum bignum } { object } <effect> "inferred-effect" set-word-prop
\ bignum< { bignum bignum } { object } <effect> set-primitive-effect
\ bignum< make-foldable
\ bignum<= { bignum bignum } { object } <effect> "inferred-effect" set-word-prop
\ bignum<= { bignum bignum } { object } <effect> set-primitive-effect
\ bignum<= make-foldable
\ bignum> { bignum bignum } { object } <effect> "inferred-effect" set-word-prop
\ bignum> { bignum bignum } { object } <effect> set-primitive-effect
\ bignum> make-foldable
\ bignum>= { bignum bignum } { object } <effect> "inferred-effect" set-word-prop
\ bignum>= { bignum bignum } { object } <effect> set-primitive-effect
\ bignum>= make-foldable
\ bignum-bit? { bignum integer } { object } <effect> "inferred-effect" set-word-prop
\ bignum-bit? { bignum integer } { object } <effect> set-primitive-effect
\ bignum-bit? make-foldable
\ bignum-log2 { bignum } { bignum } <effect> "inferred-effect" set-word-prop
\ bignum-log2 { bignum } { bignum } <effect> set-primitive-effect
\ bignum-log2 make-foldable
\ byte-array>bignum { byte-array } { bignum } <effect> "inferred-effect" set-word-prop
\ byte-array>bignum { byte-array } { bignum } <effect> set-primitive-effect
\ byte-array>bignum make-foldable
\ float= { float float } { object } <effect> "inferred-effect" set-word-prop
\ float= { float float } { object } <effect> set-primitive-effect
\ float= make-foldable
\ float+ { float float } { float } <effect> "inferred-effect" set-word-prop
\ float+ { float float } { float } <effect> set-primitive-effect
\ float+ make-foldable
\ float- { float float } { float } <effect> "inferred-effect" set-word-prop
\ float- { float float } { float } <effect> set-primitive-effect
\ float- make-foldable
\ float* { float float } { float } <effect> "inferred-effect" set-word-prop
\ float* { float float } { float } <effect> set-primitive-effect
\ float* make-foldable
\ float/f { float float } { float } <effect> "inferred-effect" set-word-prop
\ float/f { float float } { float } <effect> set-primitive-effect
\ float/f make-foldable
\ float< { float float } { object } <effect> "inferred-effect" set-word-prop
\ float< { float float } { object } <effect> set-primitive-effect
\ float< make-foldable
\ float-mod { float float } { float } <effect> "inferred-effect" set-word-prop
\ float-mod { float float } { float } <effect> set-primitive-effect
\ float-mod make-foldable
\ float<= { float float } { object } <effect> "inferred-effect" set-word-prop
\ float<= { float float } { object } <effect> set-primitive-effect
\ float<= make-foldable
\ float> { float float } { object } <effect> "inferred-effect" set-word-prop
\ float> { float float } { object } <effect> set-primitive-effect
\ float> make-foldable
\ float>= { float float } { object } <effect> "inferred-effect" set-word-prop
\ float>= { float float } { object } <effect> set-primitive-effect
\ float>= make-foldable
\ <word> { object object } { word } <effect> "inferred-effect" set-word-prop
\ <word> { object object } { word } <effect> set-primitive-effect
\ <word> make-flushable
\ word-xt { word } { integer } <effect> "inferred-effect" set-word-prop
\ word-xt { word } { integer } <effect> set-primitive-effect
\ word-xt make-flushable
\ getenv { fixnum } { object } <effect> "inferred-effect" set-word-prop
\ getenv { fixnum } { object } <effect> set-primitive-effect
\ getenv make-flushable
\ setenv { object fixnum } { } <effect> "inferred-effect" set-word-prop
\ setenv { object fixnum } { } <effect> set-primitive-effect
\ (stat) { string } { object object object object } <effect> "inferred-effect" set-word-prop
\ (stat) { string } { object object object object } <effect> set-primitive-effect
\ (directory) { string } { array } <effect> "inferred-effect" set-word-prop
\ (directory) { string } { array } <effect> set-primitive-effect
\ data-gc { } { } <effect> "inferred-effect" set-word-prop
\ data-gc { } { } <effect> set-primitive-effect
\ code-gc { } { } <effect> "inferred-effect" set-word-prop
\ code-gc { } { } <effect> set-primitive-effect
\ gc-time { } { integer } <effect> "inferred-effect" set-word-prop
\ gc-time { } { integer } <effect> set-primitive-effect
\ save-image { string } { } <effect> "inferred-effect" set-word-prop
\ save-image { string } { } <effect> set-primitive-effect
\ save-image-and-exit { string } { } <effect> "inferred-effect" set-word-prop
\ save-image-and-exit { string } { } <effect> set-primitive-effect
\ exit { integer } { } <effect>
t over set-effect-terminated?
"inferred-effect" set-word-prop
set-primitive-effect
\ data-room { } { integer array } <effect> "inferred-effect" set-word-prop
\ data-room { } { integer array } <effect> set-primitive-effect
\ data-room make-flushable
\ code-room { } { integer integer } <effect> "inferred-effect" set-word-prop
\ code-room { } { integer integer } <effect> set-primitive-effect
\ code-room make-flushable
\ os-env { string } { object } <effect> "inferred-effect" set-word-prop
\ os-env { string } { object } <effect> set-primitive-effect
\ millis { } { integer } <effect> "inferred-effect" set-word-prop
\ millis { } { integer } <effect> set-primitive-effect
\ millis make-flushable
\ type { object } { fixnum } <effect> "inferred-effect" set-word-prop
\ type { object } { fixnum } <effect> set-primitive-effect
\ type make-foldable
\ tag { object } { fixnum } <effect> "inferred-effect" set-word-prop
\ tag { object } { fixnum } <effect> set-primitive-effect
\ tag make-foldable
\ class-hash { object } { fixnum } <effect> "inferred-effect" set-word-prop
\ class-hash { object } { fixnum } <effect> set-primitive-effect
\ class-hash make-foldable
\ cwd { } { string } <effect> "inferred-effect" set-word-prop
\ cwd { } { string } <effect> set-primitive-effect
\ cd { string } { } <effect> "inferred-effect" set-word-prop
\ cd { string } { } <effect> set-primitive-effect
\ dlopen { string } { dll } <effect> "inferred-effect" set-word-prop
\ dlopen { string } { dll } <effect> set-primitive-effect
\ dlsym { string object } { c-ptr } <effect> "inferred-effect" set-word-prop
\ dlsym { string object } { c-ptr } <effect> set-primitive-effect
\ dlclose { dll } { } <effect> "inferred-effect" set-word-prop
\ dlclose { dll } { } <effect> set-primitive-effect
\ <byte-array> { integer } { byte-array } <effect> "inferred-effect" set-word-prop
\ <byte-array> { integer } { byte-array } <effect> set-primitive-effect
\ <byte-array> make-flushable
\ <bit-array> { integer } { bit-array } <effect> "inferred-effect" set-word-prop
\ <bit-array> { integer } { bit-array } <effect> set-primitive-effect
\ <bit-array> make-flushable
\ <float-array> { integer float } { float-array } <effect> "inferred-effect" set-word-prop
\ <float-array> { integer float } { float-array } <effect> set-primitive-effect
\ <float-array> make-flushable
\ <displaced-alien> { integer c-ptr } { c-ptr } <effect> "inferred-effect" set-word-prop
\ <displaced-alien> { integer c-ptr } { c-ptr } <effect> set-primitive-effect
\ <displaced-alien> make-flushable
\ alien-signed-cell { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
\ alien-signed-cell { c-ptr integer } { integer } <effect> set-primitive-effect
\ alien-signed-cell make-flushable
\ set-alien-signed-cell { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
\ set-alien-signed-cell { integer c-ptr integer } { } <effect> set-primitive-effect
\ alien-unsigned-cell { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
\ alien-unsigned-cell { c-ptr integer } { integer } <effect> set-primitive-effect
\ alien-unsigned-cell make-flushable
\ set-alien-unsigned-cell { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
\ set-alien-unsigned-cell { integer c-ptr integer } { } <effect> set-primitive-effect
\ alien-signed-8 { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
\ alien-signed-8 { c-ptr integer } { integer } <effect> set-primitive-effect
\ alien-signed-8 make-flushable
\ set-alien-signed-8 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
\ set-alien-signed-8 { integer c-ptr integer } { } <effect> set-primitive-effect
\ alien-unsigned-8 { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
\ alien-unsigned-8 { c-ptr integer } { integer } <effect> set-primitive-effect
\ alien-unsigned-8 make-flushable
\ set-alien-unsigned-8 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
\ set-alien-unsigned-8 { integer c-ptr integer } { } <effect> set-primitive-effect
\ alien-signed-4 { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
\ alien-signed-4 { c-ptr integer } { integer } <effect> set-primitive-effect
\ alien-signed-4 make-flushable
\ set-alien-signed-4 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
\ set-alien-signed-4 { integer c-ptr integer } { } <effect> set-primitive-effect
\ alien-unsigned-4 { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
\ alien-unsigned-4 { c-ptr integer } { integer } <effect> set-primitive-effect
\ alien-unsigned-4 make-flushable
\ set-alien-unsigned-4 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
\ set-alien-unsigned-4 { integer c-ptr integer } { } <effect> set-primitive-effect
\ alien-signed-2 { c-ptr integer } { fixnum } <effect> "inferred-effect" set-word-prop
\ alien-signed-2 { c-ptr integer } { fixnum } <effect> set-primitive-effect
\ alien-signed-2 make-flushable
\ set-alien-signed-2 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
\ set-alien-signed-2 { integer c-ptr integer } { } <effect> set-primitive-effect
\ alien-unsigned-2 { c-ptr integer } { fixnum } <effect> "inferred-effect" set-word-prop
\ alien-unsigned-2 { c-ptr integer } { fixnum } <effect> set-primitive-effect
\ alien-unsigned-2 make-flushable
\ set-alien-unsigned-2 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
\ set-alien-unsigned-2 { integer c-ptr integer } { } <effect> set-primitive-effect
\ alien-signed-1 { c-ptr integer } { fixnum } <effect> "inferred-effect" set-word-prop
\ alien-signed-1 { c-ptr integer } { fixnum } <effect> set-primitive-effect
\ alien-signed-1 make-flushable
\ set-alien-signed-1 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
\ set-alien-signed-1 { integer c-ptr integer } { } <effect> set-primitive-effect
\ alien-unsigned-1 { c-ptr integer } { fixnum } <effect> "inferred-effect" set-word-prop
\ alien-unsigned-1 { c-ptr integer } { fixnum } <effect> set-primitive-effect
\ alien-unsigned-1 make-flushable
\ set-alien-unsigned-1 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
\ set-alien-unsigned-1 { integer c-ptr integer } { } <effect> set-primitive-effect
\ alien-float { c-ptr integer } { float } <effect> "inferred-effect" set-word-prop
\ alien-float { c-ptr integer } { float } <effect> set-primitive-effect
\ alien-float make-flushable
\ set-alien-float { float c-ptr integer } { } <effect> "inferred-effect" set-word-prop
\ set-alien-float { float c-ptr integer } { } <effect> set-primitive-effect
\ alien-double { c-ptr integer } { float } <effect> "inferred-effect" set-word-prop
\ alien-double { c-ptr integer } { float } <effect> set-primitive-effect
\ alien-double make-flushable
\ set-alien-double { float c-ptr integer } { } <effect> "inferred-effect" set-word-prop
\ set-alien-double { float c-ptr integer } { } <effect> set-primitive-effect
\ alien-cell { c-ptr integer } { simple-c-ptr } <effect> "inferred-effect" set-word-prop
\ alien-cell { c-ptr integer } { simple-c-ptr } <effect> set-primitive-effect
\ alien-cell make-flushable
\ set-alien-cell { c-ptr c-ptr integer } { } <effect> "inferred-effect" set-word-prop
\ set-alien-cell { c-ptr c-ptr integer } { } <effect> set-primitive-effect
\ alien>char-string { c-ptr } { string } <effect> "inferred-effect" set-word-prop
\ alien>char-string { c-ptr } { string } <effect> set-primitive-effect
\ alien>char-string make-flushable
\ string>char-alien { string } { byte-array } <effect> "inferred-effect" set-word-prop
\ string>char-alien { string } { byte-array } <effect> set-primitive-effect
\ string>char-alien make-flushable
\ alien>u16-string { c-ptr } { string } <effect> "inferred-effect" set-word-prop
\ alien>u16-string { c-ptr } { string } <effect> set-primitive-effect
\ alien>u16-string make-flushable
\ string>u16-alien { string } { byte-array } <effect> "inferred-effect" set-word-prop
\ string>u16-alien { string } { byte-array } <effect> set-primitive-effect
\ string>u16-alien make-flushable
\ alien-address { alien } { integer } <effect> "inferred-effect" set-word-prop
\ alien-address { alien } { integer } <effect> set-primitive-effect
\ alien-address make-flushable
\ slot { object fixnum } { object } <effect> "inferred-effect" set-word-prop
\ slot { object fixnum } { object } <effect> set-primitive-effect
\ slot make-flushable
\ set-slot { object object fixnum } { } <effect> "inferred-effect" set-word-prop
\ set-slot { object object fixnum } { } <effect> set-primitive-effect
\ string-nth { fixnum string } { fixnum } <effect> "inferred-effect" set-word-prop
\ string-nth { fixnum string } { fixnum } <effect> set-primitive-effect
\ string-nth make-flushable
\ set-string-nth { fixnum fixnum string } { } <effect> "inferred-effect" set-word-prop
\ set-string-nth { fixnum fixnum string } { } <effect> set-primitive-effect
\ resize-array { integer array } { array } <effect> "inferred-effect" set-word-prop
\ resize-array { integer array } { array } <effect> set-primitive-effect
\ resize-array make-flushable
\ resize-byte-array { integer byte-array } { byte-array } <effect> "inferred-effect" set-word-prop
\ resize-byte-array { integer byte-array } { byte-array } <effect> set-primitive-effect
\ resize-byte-array make-flushable
\ resize-bit-array { integer bit-array } { bit-array } <effect> "inferred-effect" set-word-prop
\ resize-bit-array { integer bit-array } { bit-array } <effect> set-primitive-effect
\ resize-bit-array make-flushable
\ resize-float-array { integer float-array } { float-array } <effect> "inferred-effect" set-word-prop
\ resize-float-array { integer float-array } { float-array } <effect> set-primitive-effect
\ resize-float-array make-flushable
\ resize-string { integer string } { string } <effect> "inferred-effect" set-word-prop
\ resize-string { integer string } { string } <effect> set-primitive-effect
\ resize-string make-flushable
\ <array> { integer object } { array } <effect> "inferred-effect" set-word-prop
\ <array> { integer object } { array } <effect> set-primitive-effect
\ <array> make-flushable
\ begin-scan { } { } <effect> "inferred-effect" set-word-prop
\ begin-scan { } { } <effect> set-primitive-effect
\ next-object { } { object } <effect> "inferred-effect" set-word-prop
\ next-object { } { object } <effect> set-primitive-effect
\ end-scan { } { } <effect> "inferred-effect" set-word-prop
\ end-scan { } { } <effect> set-primitive-effect
\ size { object } { fixnum } <effect> "inferred-effect" set-word-prop
\ size { object } { fixnum } <effect> set-primitive-effect
\ size make-flushable
\ die { } { } <effect> "inferred-effect" set-word-prop
\ die { } { } <effect> set-primitive-effect
\ fopen { string string } { alien } <effect> "inferred-effect" set-word-prop
\ fopen { string string } { alien } <effect> set-primitive-effect
\ fgetc { alien } { object } <effect> "inferred-effect" set-word-prop
\ fgetc { alien } { object } <effect> set-primitive-effect
\ fwrite { string alien } { } <effect> "inferred-effect" set-word-prop
\ fwrite { string alien } { } <effect> set-primitive-effect
\ fread { integer string } { object } <effect> "inferred-effect" set-word-prop
\ fread { integer string } { object } <effect> set-primitive-effect
\ fflush { alien } { } <effect> "inferred-effect" set-word-prop
\ fflush { alien } { } <effect> set-primitive-effect
\ fclose { alien } { } <effect> "inferred-effect" set-word-prop
\ fclose { alien } { } <effect> set-primitive-effect
\ expired? { object } { object } <effect> "inferred-effect" set-word-prop
\ expired? { object } { object } <effect> set-primitive-effect
\ expired? make-flushable
\ <wrapper> { object } { wrapper } <effect> "inferred-effect" set-word-prop
\ <wrapper> { object } { wrapper } <effect> set-primitive-effect
\ <wrapper> make-foldable
\ (clone) { object } { object } <effect> "inferred-effect" set-word-prop
\ (clone) { object } { object } <effect> set-primitive-effect
\ (clone) make-flushable
\ <string> { integer integer } { string } <effect> "inferred-effect" set-word-prop
\ <string> { integer integer } { string } <effect> set-primitive-effect
\ <string> make-flushable
\ array>quotation { array } { quotation } <effect> "inferred-effect" set-word-prop
\ array>quotation { array } { quotation } <effect> set-primitive-effect
\ array>quotation make-flushable
\ quotation-xt { quotation } { integer } <effect> "inferred-effect" set-word-prop
\ quotation-xt { quotation } { integer } <effect> set-primitive-effect
\ quotation-xt make-flushable
\ <tuple> { word integer } { quotation } <effect> "inferred-effect" set-word-prop
\ <tuple> { word integer } { quotation } <effect> set-primitive-effect
\ <tuple> make-flushable
\ (>tuple) { array } { tuple } <effect> "inferred-effect" set-word-prop
\ (>tuple) { array } { tuple } <effect> set-primitive-effect
\ (>tuple) make-flushable
\ tuple>array { tuple } { array } <effect> "inferred-effect" set-word-prop
\ tuple>array { tuple } { array } <effect> set-primitive-effect
\ tuple>array make-flushable
\ datastack { } { array } <effect> "inferred-effect" set-word-prop
\ datastack { } { array } <effect> set-primitive-effect
\ datastack make-flushable
\ retainstack { } { array } <effect> "inferred-effect" set-word-prop
\ retainstack { } { array } <effect> set-primitive-effect
\ retainstack make-flushable
\ callstack { } { callstack } <effect> "inferred-effect" set-word-prop
\ callstack { } { callstack } <effect> set-primitive-effect
\ callstack make-flushable
\ callstack>array { callstack } { array } <effect> "inferred-effect" set-word-prop
\ callstack>array { callstack } { array } <effect> set-primitive-effect
\ callstack>array make-flushable
\ (sleep) { integer } { } <effect> "inferred-effect" set-word-prop
\ (sleep) { integer } { } <effect> set-primitive-effect
\ become { array array } { } <effect> "inferred-effect" set-word-prop
\ become { array array } { } <effect> set-primitive-effect
\ innermost-frame-quot { callstack } { quotation } <effect> "inferred-effect" set-word-prop
\ innermost-frame-quot { callstack } { quotation } <effect> set-primitive-effect
\ innermost-frame-scan { callstack } { fixnum } <effect> "inferred-effect" set-word-prop
\ innermost-frame-scan { callstack } { fixnum } <effect> set-primitive-effect
\ set-innermost-frame-quot { quotation callstack } { } <effect> "inferred-effect" set-word-prop
\ set-innermost-frame-quot { quotation callstack } { } <effect> set-primitive-effect
\ (os-envs) { } { array } <effect> "inferred-effect" set-word-prop
\ (os-envs) { } { array } <effect> set-primitive-effect
\ do-primitive [ \ do-primitive no-effect ] "infer" set-word-prop

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

@ -93,5 +93,3 @@ M: duplicated-slots-error summary
\ construct-empty 1 1 <effect> make-call-node
] if
] "infer" set-word-prop
\ construct-empty 1 1 <effect> "inferred-effect" set-word-prop

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

@ -532,7 +532,7 @@ HELP: compose
"compose call"
"append call"
}
"However, " { $link compose } " runs in constant time, and the compiler is able to compile code which calls composed quotations."
"However, " { $link compose } " runs in constant time, and the optimizing compiler is able to compile code which calls composed quotations."
} ;
HELP: 3compose

15
core/kernel/kernel.factor
View File

@ -17,8 +17,7 @@ IN: kernel
: clear ( -- ) { } set-datastack ;
! Combinators
: call ( callable -- ) uncurry (call) ;
GENERIC: call ( callable -- )
DEFER: if
@ -71,6 +70,10 @@ DEFER: if
[ 2nip call ] if ; inline
! Quotation building
USE: tuples.private
: curry ( obj quot -- curry )
\ curry 4 <tuple-boa> ;
: 2curry ( obj1 obj2 quot -- curry )
curry curry ; inline
@ -82,12 +85,10 @@ DEFER: if
swapd [ swapd call ] 2curry ; inline
: compose ( quot1 quot2 -- curry )
! Not inline because this is treated as a primitive by
! the compiler
[ slip call ] 2curry ;
\ compose 4 <tuple-boa> ;
: 3compose ( quot1 quot2 quot3 -- curry )
[ 2slip slip call ] 3curry ; inline
compose compose ; inline
! Object protocol
@ -156,7 +157,7 @@ GENERIC: construct-boa ( ... class -- tuple )
! Error handling -- defined early so that other files can
! throw errors before continuations are loaded
: throw ( error -- * ) 5 getenv [ die ] or curry (throw) ;
: throw ( error -- * ) 5 getenv [ die ] or 1 (throw) ;
<PRIVATE

2
core/optimizer/def-use/def-use-tests.factor Normal file → Executable file
View File

@ -8,7 +8,7 @@ namespaces assocs kernel sequences math tools.test words ;
] unit-test
: kill-set ( quot -- seq )
dataflow compute-def-use dead-literals keys
dataflow compute-def-use compute-dead-literals keys
[ value-literal ] map ;
: subset? [ member? ] curry all? ;

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

@ -19,6 +19,11 @@ float-arrays sequences.private combinators ;
] "output-classes" set-word-prop
] each
\ construct-empty [
dup node-in-d peek node-literal
dup class? [ drop tuple ] unless 1array f
] "output-classes" set-word-prop
! the output of clone has the same type as the input
{ clone (clone) } [
[

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

@ -288,10 +288,10 @@ TUPLE: silly-tuple a b ;
[ t ] [ \ node-successor-f-bug compiled? ] unit-test
: construct-empty-bug construct-empty ;
[ ] [ [ construct-empty ] dataflow optimize drop ] unit-test
[ ] [ [ <tuple> ] dataflow optimize drop ] unit-test
! Make sure we have sane heuristics
: should-inline? method method-word flat-length 10 <= ;

1
core/parser/parser.factor
View File

@ -107,6 +107,7 @@ M: bad-escape summary drop "Bad escape code" ;
: escape ( escape -- ch )
H{
{ CHAR: a CHAR: \a }
{ CHAR: e CHAR: \e }
{ CHAR: n CHAR: \n }
{ CHAR: r CHAR: \r }

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

@ -58,6 +58,7 @@ M: f pprint* drop \ f pprint-word ;
! Strings
: ch>ascii-escape ( ch -- str )
H{
{ CHAR: \a CHAR: a }
{ CHAR: \e CHAR: e }
{ CHAR: \n CHAR: n }
{ CHAR: \r CHAR: r }
@ -135,6 +136,7 @@ GENERIC: pprint-delims ( obj -- start end )
M: quotation pprint-delims drop \ [ \ ] ;
M: curry pprint-delims drop \ [ \ ] ;
M: compose pprint-delims drop \ [ \ ] ;
M: array pprint-delims drop \ { \ } ;
M: byte-array pprint-delims drop \ B{ \ } ;
M: byte-vector pprint-delims drop \ BV{ \ } ;
@ -156,6 +158,8 @@ M: vector >pprint-sequence ;
M: bit-vector >pprint-sequence ;
M: byte-vector >pprint-sequence ;
M: float-vector >pprint-sequence ;
M: curry >pprint-sequence ;
M: compose >pprint-sequence ;
M: hashtable >pprint-sequence >alist ;
M: tuple >pprint-sequence tuple>array ;
M: wrapper >pprint-sequence wrapped 1array ;
@ -178,9 +182,20 @@ M: tuple pprint-narrow? drop t ;
>pprint-sequence pprint-elements
block> r> pprint-word block>
] check-recursion ;
M: object pprint* pprint-object ;
M: curry pprint*
dup curry-quot callable? [ pprint-object ] [
"( invalid curry )" swap present-text
] if ;
M: compose pprint*
dup compose-first over compose-second [ callable? ] both?
[ pprint-object ] [
"( invalid compose )" swap present-text
] if ;
M: wrapper pprint*
dup wrapped word? [
<block \ \ pprint-word wrapped pprint-word block>

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

@ -321,3 +321,7 @@ unit-test
[ [ 2 . ] ] [
[ 2 \ break (step-into) . ] (remove-breakpoints)
] unit-test
[ ] [ 1 \ + curry unparse drop ] unit-test
[ ] [ 1 \ + compose unparse drop ] unit-test

2
core/quotations/quotations-tests.factor Normal file → Executable file
View File

@ -15,4 +15,4 @@ IN: temporary
[ [ "hi" ] ] [ "hi" 1quotation ] unit-test
[ 1 \ + curry ] must-fail
! [ 1 \ + curry ] must-fail

30
core/quotations/quotations.factor
View File

@ -1,13 +1,20 @@
! Copyright (C) 2006, 2007 Slava Pestov.
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays sequences sequences.private
kernel kernel.private math assocs quotations.private ;
kernel kernel.private math assocs quotations.private
slots.private ;
IN: quotations
M: quotation call (call) ;
M: curry call dup 4 slot swap 5 slot call ;
M: compose call dup 4 slot swap 5 slot slip call ;
M: wrapper equal?
over wrapper? [ [ wrapped ] 2apply = ] [ 2drop f ] if ;
UNION: callable quotation curry ;
UNION: callable quotation curry compose ;
M: callable equal?
over callable? [ sequence= ] [ 2drop f ] if ;
@ -19,7 +26,7 @@ M: quotation nth-unsafe quotation-array nth-unsafe ;
: >quotation ( seq -- quot )
>array array>quotation ; inline
M: quotation like drop dup quotation? [ >quotation ] unless ;
M: callable like drop dup quotation? [ >quotation ] unless ;
INSTANCE: quotation immutable-sequence
@ -40,6 +47,17 @@ M: curry nth
>r 1- r> curry-quot nth
] if ;
M: curry like drop dup callable? [ >quotation ] unless ;
INSTANCE: curry immutable-sequence
M: compose length
dup compose-first length
swap compose-second length + ;
M: compose nth
2dup compose-first length < [
compose-first
] [
[ compose-first length - ] keep compose-second
] if nth ;
INSTANCE: compose immutable-sequence

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

@ -49,7 +49,7 @@ PRIVATE>
V{ } set-catchstack
{ } set-retainstack
[ [ print-error ] recover stop ] call-clear
] (throw)
] 1 (throw)
] curry callcc0 ;
<PRIVATE

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

@ -71,7 +71,8 @@ M: vocab-link vocab-root
TUPLE: no-vocab name ;
: no-vocab ( name -- * ) \ no-vocab construct-boa throw ;
: no-vocab ( name -- * )
vocab-name \ no-vocab construct-boa throw ;
M: no-vocab summary drop "Vocabulary does not exist" ;

7
core/vocabs/vocabs.factor
View File

@ -85,7 +85,8 @@ SYMBOL: load-vocab-hook
TUPLE: vocab-link name root ;
C: <vocab-link> vocab-link
: <vocab-link> ( name root -- vocab-link )
[ dup vocab-root ] unless* vocab-link construct-boa ;
M: vocab-link equal?
over vocab-link?
@ -103,9 +104,7 @@ M: vocab >vocab-link drop ;
M: vocab-link >vocab-link drop ;
M: string >vocab-link
over vocab dup [ 2nip ] [
drop [ dup vocab-root ] unless* <vocab-link>
] if ;
over vocab dup [ 2nip ] [ drop <vocab-link> ] if ;
UNION: vocab-spec vocab vocab-link ;

2
core/words/words.factor
View File

@ -115,7 +115,7 @@ compiled-crossref global [ H{ } assoc-like ] change-at
compiled-crossref get at ;
M: word redefined* ( word -- )
{ "inferred-effect" "base-case" "no-effect" } reset-props ;
{ "inferred-effect" "no-effect" } reset-props ;
SYMBOL: changed-words

43
extra/benchmark/sockets/sockets.factor Executable file
View File

@ -0,0 +1,43 @@
USING: io.sockets io.server io kernel math threads debugger
concurrency tools.time prettyprint ;
IN: benchmark.sockets
: simple-server ( -- )
7777 local-server "benchmark.sockets" [
read1 CHAR: x = [
stop-server
] [
20 [ read1 write1 flush ] times
] if
] with-server ;
: simple-client ( -- )
"localhost" 7777 <inet> <client> [
CHAR: b write1 flush
20 [ CHAR: a dup write1 flush read1 assert= ] times
] with-stream ;
: stop-server ( -- )
"localhost" 7777 <inet> <client> [
CHAR: x write1
] with-stream ;
: socket-benchmark ( n -- )
dup pprint " clients: " write
[
[ simple-server ] in-thread
100 sleep
[ drop simple-client ] parallel-each
stop-server
yield yield
] time ;
: socket-benchmarks
10 socket-benchmark
20 socket-benchmark
40 socket-benchmark
80 socket-benchmark
160 socket-benchmark
320 socket-benchmark ;
MAIN: socket-benchmarks

46
extra/builder/builder.factor
View File

@ -1,5 +1,5 @@
USING: kernel io io.files io.launcher io.sockets hashtables
USING: kernel io io.files io.launcher io.sockets hashtables math threads
system continuations namespaces sequences splitting math.parser
prettyprint tools.time calendar bake vars http.client
combinators bootstrap.image bootstrap.image.download
@ -95,9 +95,10 @@ VAR: stamp
stamp> make-directory
stamp> cd ;
: record-git-id ( -- )
{ "git" "show" } <process-stream> [ readln ] with-stream " " split second
"../git-id" log-object ;
: git-id ( -- id )
{ "git" "show" } <process-stream> [ readln ] with-stream " " split second ;
: record-git-id ( -- ) git-id "../git-id" log-object ;
: make-clean ( -- desc ) { "make" "clean" } ;
@ -113,7 +114,8 @@ VAR: stamp
[ my-arch download-image ]
[ ]
[ "builder: image download" email-string ]
cleanup ;
cleanup
flush ;
: bootstrap ( -- desc )
`{
@ -135,12 +137,6 @@ SYMBOL: build-status
: build ( -- )
"running" build-status set-global
"/builds/factor" cd
git-pull "git pull error" run-or-notify
enter-build-dir
git-clone "git clone error" run-or-notify
@ -165,10 +161,30 @@ SYMBOL: build-status
"../failing-tests" exists?
[ "failing tests" "../failing-tests" email-file ]
when
"ready" build-status set-global ;
when ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
MAIN: build
: minutes>ms ( min -- ms ) 60 * 1000 * ;
: updates-available? ( -- ? )
git-id
git-pull run-process drop
git-id
= not ;
: build-loop ( -- )
[
"/builds/factor" cd
updates-available?
[ build ]
when
]
[ drop ]
recover
5 minutes>ms sleep
build-loop ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
MAIN: build-loop

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

@ -4,11 +4,7 @@ IN: temporary
[ 5 ] [ [ 10 random ] [ 5 = ] generate ] unit-test
[ t ] [ [ 10 random ] [ even? ] generate even? ] unit-test
[ 50 ] [ 100 [1,b] [ even? ] count ] unit-test
[ 50 ] [ 100 [1,b] [ odd? ] count ] unit-test
[ 328350 ] [ 100 [ sq ] sigma ] unit-test
[ { 910 911 912 } ] [ 10 900 3 [ + + ] map-with2 ] unit-test
{ 6 2 } [ 1 2 [ 5 + ] dip ] unit-test
{ 6 2 1 } [ 1 2 1 [ 5 + ] dipd ] unit-test
@ -17,11 +13,6 @@ IN: temporary
[ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] must-infer
{ 2 1 2 3 4 5 } [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] unit-test
[ [ 1 2 3 + ] ] [ 1 2 3 [ + ] 3 ncurry ] unit-test
[ 1 2 { 3 4 } [ + + ] 2 map-withn ] must-infer
{ { 6 7 } } [ 1 2 { 3 4 } [ + + ] 2 map-withn ] unit-test
{ { 16 17 18 19 20 } } [ 1 2 3 4 { 6 7 8 9 10 } [ + + + + ] 4 map-withn ] unit-test
[ 1 2 { 3 4 } [ + + drop ] 2 each-withn ] must-infer
{ 13 } [ 1 2 { 3 4 } [ + + ] 2 each-withn + ] unit-test
[ 1 1 2 2 3 3 ] [ 1 2 3 [ dup ] 3apply ] unit-test
[ 1 4 9 ] [ 1 2 3 [ sq ] 3apply ] unit-test
[ [ sq ] 3apply ] must-infer
@ -55,5 +46,3 @@ IN: temporary
[ dup array? ] [ dup vector? ] [ dup float? ]
} || nip
] unit-test
[ 1 2 3 4 ] [ { 1 2 3 4 } 4 nfirst ] unit-test

6
extra/db/sqlite/sqlite.factor
View File

@ -84,6 +84,11 @@ M: sqlite-db create-sql ( columns table -- sql )
] interleave ")" %
] "" make ;
M: sqlite-db drop-sql ( table -- sql )
[
"drop table " % %
] "" make ;
M: sqlite-db insert-sql* ( columns table -- sql )
[
"insert into " %
@ -109,7 +114,6 @@ M: sqlite-db update-sql* ( columns table -- sql )
M: sqlite-db delete-sql* ( columns table -- sql )
[
break
"delete from " %
%
" where " %

20
extra/db/tuples/tuples-tests.factor
View File

@ -1,4 +1,5 @@
USING: io.files kernel tools.test db db.sqlite db.tuples ;
USING: io.files kernel tools.test db db.sqlite db.tuples
db.types continuations namespaces ;
IN: temporary
TUPLE: person the-id the-name the-number ;
@ -13,16 +14,23 @@ person "PERSON"
} define-persistent
SYMBOL: the-person
: test-tuples ( -- )
f "billy" 100 person construct-boa dup insert-tuple
[ person drop-table ] [ ] recover
person create-table
f "billy" 100 person construct-boa
the-person set
[ ] [ the-person get insert-tuple ] unit-test
[ 1 ] [ dup person-id ] unit-test
[ 1 ] [ the-person get person-the-id ] unit-test
200 over set-person-the-number
200 the-person get set-person-the-number
[ ] [ dup update-tuple ] unit-test
[ ] [ the-person get update-tuple ] unit-test
[ ] [ delete-tuple ] unit-test ;
[ ] [ the-person get delete-tuple ] unit-test ;
: test-sqlite ( -- )
"tuples-test.db" resource-path <sqlite-db> [

5
extra/db/tuples/tuples.factor
View File

@ -49,7 +49,7 @@ IN: db.tuples
[ <prepared-statement> ] 3compose cache nip ; inline
HOOK: create-sql db ( columns table -- sql )
HOOK: drop-sql db ( columns table -- sql )
HOOK: drop-sql db ( table -- sql )
HOOK: insert-sql* db ( columns table -- sql )
HOOK: update-sql* db ( columns table -- sql )
HOOK: delete-sql* db ( columns table -- sql )
@ -80,6 +80,9 @@ HOOK: tuple>params db ( columns tuple -- obj )
: create-table ( class -- )
dup db-columns swap db-table create-sql sql-command ;
: drop-table ( class -- )
db-table drop-sql sql-command ;
: insert-tuple ( tuple -- )
[
[ maybe-remove-id ] [ insert-sql ] do-tuple-statement

8
extra/io/server/server.factor
View File

@ -26,8 +26,10 @@ LOG: accepted-connection NOTICE
: server-loop ( server quot -- )
[ accept-loop ] curry with-disposal ; inline
SYMBOL: servers
: spawn-server ( addrspec quot -- )
>r <server> r> server-loop ; inline
>r <server> dup servers get push r> server-loop ; inline
\ spawn-server NOTICE add-error-logging
@ -39,9 +41,13 @@ LOG: accepted-connection NOTICE
: with-server ( seq service quot -- )
[
V{ } clone servers set
[ spawn-server ] curry concurrency:parallel-each
] curry with-logging ; inline
: stop-server ( -- )
servers get [ dispose ] each ;
: received-datagram ( addrspec -- ) drop ;
\ received-datagram NOTICE add-input-logging

24
extra/new-slots/new-slots.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: effects words kernel sequences slots slots.private
assocs parser mirrors namespaces math vocabs ;
assocs parser mirrors namespaces math vocabs tuples ;
IN: new-slots
: create-accessor ( name effect -- word )
@ -19,11 +19,21 @@ IN: new-slots
: writer-effect T{ effect f { "value" "object" } { } } ; inline
: writer-word ( name -- word )
">>" swap append writer-effect create-accessor ;
"(>>" swap ")" 3append writer-effect create-accessor ;
: define-writer ( class slot name -- )
writer-word [ set-slot ] define-slot-word ;
: setter-effect T{ effect f { "object" "value" } { "value" } } ; inline
: setter-word ( name -- word )
">>" swap append setter-effect create-accessor ;
: define-setter ( name -- )
dup setter-word dup deferred? [
[ \ over , swap writer-word , ] [ ] make define-inline
] [ 2drop ] if ;
: changer-effect T{ effect f { "object" "quot" } } ; inline
: changer-word ( name -- word )
@ -40,12 +50,18 @@ IN: new-slots
] [ 2drop ] if ;
: define-new-slot ( class slot name -- )
dup define-changer 3dup define-reader define-writer ;
dup define-changer
dup define-setter
3dup define-reader
define-writer ;
: define-new-slots ( tuple-class -- )
[ "slot-names" word-prop <enum> >alist ] keep
[ swap first2 >r 4 + r> define-new-slot ] curry each ;
: NEW-SLOTS: scan-word define-new-slots ; parsing
: TUPLE:
CREATE-CLASS
dup ";" parse-tokens define-tuple-class
define-new-slots ; parsing
"accessors" create-vocab drop

15
extra/sequences/lib/lib-tests.factor Normal file → Executable file
View File

@ -1,5 +1,5 @@
USING: arrays kernel sequences sequences.lib math
math.functions tools.test strings ;
math.functions tools.test strings math.ranges ;
[ 4 ] [ { 1 2 } [ sq ] [ * ] map-reduce ] unit-test
[ 36 ] [ { 2 3 } [ sq ] [ * ] map-reduce ] unit-test
@ -53,3 +53,16 @@ math.functions tools.test strings ;
[ 2 ] [ { 1 2 3 } ?second ] unit-test
[ 3 ] [ { 1 2 3 } ?third ] unit-test
[ f ] [ { 1 2 3 } ?fourth ] unit-test
[ 50 ] [ 100 [1,b] [ even? ] count ] unit-test
[ 50 ] [ 100 [1,b] [ odd? ] count ] unit-test
[ 328350 ] [ 100 [ sq ] sigma ] unit-test
[ 1 2 { 3 4 } [ + + ] 2 map-withn ] must-infer
{ { 6 7 } } [ 1 2 { 3 4 } [ + + ] 2 map-withn ] unit-test
{ { 16 17 18 19 20 } } [ 1 2 3 4 { 6 7 8 9 10 } [ + + + + ] 4 map-withn ] unit-test
[ 1 2 { 3 4 } [ + + drop ] 2 each-withn ] must-infer
{ 13 } [ 1 2 { 3 4 } [ + + ] 2 each-withn + ] unit-test
[ { 910 911 912 } ] [ 10 900 3 [ + + ] map-with2 ] unit-test
[ 1 2 3 4 ] [ { 1 2 3 4 } 4 nfirst ] unit-test

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

@ -1,6 +1,4 @@
IN: temporary
USING: tools.browser tools.test help.markup ;
[ t ] [ "resource:core" "kernel" vocab-dir? ] unit-test
[ ] [ { $describe-vocab "scratchpad" } print-content ] unit-test

3
extra/tools/interpreter/interpreter-tests.factor Normal file → Executable file
View File

@ -98,6 +98,9 @@ IN: temporary
[ { 6 } ]
[ [ [ 3 swap continue-with ] callcc1 2 * ] test-interpreter ] unit-test
[ { } ]
[ [ [ ] [ ] recover ] test-interpreter ] unit-test
[ { 6 } ]
[ [ [ 3 throw ] [ 2 * ] recover ] test-interpreter ] unit-test

2
extra/tools/interpreter/interpreter.factor
View File

@ -55,7 +55,7 @@ M: word (step-into) (step-into-execute) ;
{
{ call [ walk ] }
{ (throw) [ walk ] }
{ (throw) [ drop walk ] }
{ execute [ (step-into-execute) ] }
{ if [ (step-into-if) ] }
{ dispatch [ (step-into-dispatch) ] }

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

@ -7,9 +7,9 @@ SYMBOL: ui-backend
HOOK: set-title ui-backend ( string world -- )
HOOK: set-fullscreen? ui-backend ( ? world -- )
HOOK: set-fullscreen* ui-backend ( ? world -- )
HOOK: fullscreen? ui-backend ( world -- ? )
HOOK: fullscreen* ui-backend ( world -- ? )
HOOK: (open-window) ui-backend ( world -- )

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

@ -59,10 +59,10 @@ M: cocoa-ui-backend set-title ( string world -- )
: exit-fullscreen ( world -- )
world-handle first f -> exitFullScreenModeWithOptions: ;
M: cocoa-ui-backend set-fullscreen? ( ? world -- )
M: cocoa-ui-backend set-fullscreen* ( ? world -- )
swap [ enter-fullscreen ] [ exit-fullscreen ] if ;
M: cocoa-ui-backend fullscreen? ( world -- ? )
M: cocoa-ui-backend fullscreen* ( world -- ? )
world-handle first -> isInFullScreenMode zero? not ;
: auto-position ( world -- )

9
extra/ui/gadgets/worlds/worlds-docs.factor
View File

@ -13,15 +13,6 @@ HELP: set-title
{ $description "Sets the title bar of the native window containing the world." }
{ $notes "This word should not be called directly by user code. Instead, change the " { $link world-title } " model; see " { $link "models" } "." } ;
HELP: set-fullscreen?
{ $values { "?" "a boolean" } { "world" world } }
{ $description "Sets and unsets fullscreen mode for the world." }
{ $notes "Find a world using " { $link find-world } "." } ;
HELP: fullscreen?
{ $values { "world" world } { "?" "a boolean" } }
{ $description "Queries the world to see if it is running in fullscreen mode." } ;
HELP: raise-window
{ $values { "world" world } }
{ $description "Makes the native window containing the given world the front-most window." }

10
extra/ui/ui-docs.factor
View File

@ -14,6 +14,16 @@ HELP: open-window
{ $values { "gadget" gadget } { "title" string } }
{ $description "Opens a native window with the specified title." } ;
HELP: set-fullscreen?
{ $values { "?" "a boolean" } { "gadget" gadget } }
{ $description "Sets and unsets fullscreen mode for the gadget's world." } ;
HELP: fullscreen?
{ $values { "gadget" gadget } { "?" "a boolean" } }
{ $description "Queries the gadget's world to see if it is running in fullscreen mode." } ;
{ fullscreen? set-fullscreen? } related-words
HELP: find-window
{ $values { "quot" "a quotation with stack effect " { $snippet "( world -- ? )" } } { "world" "a " { $link world } " or " { $link f } } }
{ $description "Finds a native window whose world satisfies the quotation, outputting " { $link f } " if no such world could be found. The front-most native window is checked first." } ;

6
extra/ui/ui.factor
View File

@ -145,6 +145,12 @@ SYMBOL: ui-hook
>r [ 1 track, ] { 0 1 } make-track r>
f <world> open-world-window ;
: set-fullscreen? ( ? gadget -- )
find-world set-fullscreen* ;
: fullscreen? ( gadget -- ? )
find-world fullscreen* ;
HOOK: close-window ui-backend ( gadget -- )
M: object close-window

0
misc/Factor.tmbundle/Commands/Eval Selection Normal file
View File

0
misc/Factor.tmbundle/Commands/Run Selection Normal file
View File

59
misc/factor.sh
View File

@ -1,4 +1,4 @@
#!/bin/bash -e
#!/usr/bin/env bash
# Programs returning != 0 will not cause script to exit
set +e
@ -11,6 +11,9 @@ OS=
ARCH=
WORD=
NO_UI=
GIT_PROTOCOL=${GIT_PROTOCOL:="git"}
GIT_URL=${GIT_URL:=$GIT_PROTOCOL"://factorcode.org/git/factor.git"}
ensure_program_installed() {
echo -n "Checking for $1..."
@ -51,6 +54,9 @@ check_installed_programs() {
ensure_program_installed wget
ensure_program_installed gcc
ensure_program_installed make
case $OS in
netbsd) ensure_program_installed gmake;;
esac
check_gcc_version
}
@ -106,6 +112,7 @@ find_os() {
*Darwin*) OS=macosx;;
*linux*) OS=linux;;
*Linux*) OS=linux;;
*NetBSD*) OS=netbsd;;
esac
}
@ -153,6 +160,8 @@ echo_build_info() {
echo MAKE_TARGET=$MAKE_TARGET
echo BOOT_IMAGE=$BOOT_IMAGE
echo MAKE_IMAGE_TARGET=$MAKE_IMAGE_TARGET
echo GIT_PROTOCOL=$GIT_PROTOCOL
echo GIT_URL=$GIT_URL
}
set_build_info() {
@ -188,22 +197,19 @@ find_build_info() {
echo_build_info
}
invoke_git() {
git $*
check_ret git
}
git_clone() {
echo "Downloading the git repository from factorcode.org..."
git clone git://factorcode.org/git/factor.git
check_ret git
invoke_git clone $GIT_URL
}
git_pull_factorcode() {
echo "Updating the git repository from factorcode.org..."
git pull git://factorcode.org/git/factor.git master
check_ret git
}
http_git_pull_factorcode() {
echo "Updating the git repository from factorcode.org..."
git pull http://factorcode.org/git/factor.git master
check_ret git
invoke_git pull $GIT_URL master
}
cd_factor() {
@ -211,21 +217,28 @@ cd_factor() {
check_ret cd
}
invoke_make() {
case $OS in
netbsd) make='gmake';;
*) make='make';;
esac
$make $*
check_ret $make
}
make_clean() {
make clean
check_ret make
invoke_make clean
}
make_factor() {
make NO_UI=$NO_UI $MAKE_TARGET -j5
check_ret make
invoke_make NO_UI=$NO_UI $MAKE_TARGET -j5
}
delete_boot_images() {
echo "Deleting old images..."
rm $BOOT_IMAGE > /dev/null 2>&1
rm $BOOT_IMAGE.* > /dev/null 2>&1
rm staging.*.image > /dev/null 2>&1
rm staging.*.image > /dev/null 2>&1
}
get_boot_image() {
@ -257,8 +270,8 @@ maybe_download_dlls() {
}
get_config_info() {
check_installed_programs
find_build_info
check_installed_programs
check_libraries
}
@ -285,13 +298,6 @@ update() {
make_factor
}
http_update() {
get_config_info
http_git_pull_factorcode
make_clean
make_factor
}
update_bootstrap() {
delete_boot_images
get_boot_image
@ -299,7 +305,7 @@ update_bootstrap() {
}
refresh_image() {
./$FACTOR_BINARY -script -e="refresh-all save 0 USE: system exit"
./$FACTOR_BINARY -script -e="USE: vocabs.loader refresh-all USE: memory save 0 USE: system exit"
check_ret factor
}
@ -316,6 +322,8 @@ install_libraries() {
usage() {
echo "usage: $0 install|install-x11|self-update|quick-update|update|bootstrap|wget-bootstrap"
echo "If you are behind a firewall, invoke as:"
echo "env GIT_PROTOCOL=http $0 <command>"
}
case "$1" in
@ -324,7 +332,6 @@ case "$1" in
self-update) update; make_boot_image; bootstrap;;
quick-update) update; refresh_image ;;
update) update; update_bootstrap ;;
http-update) http_update; update_bootstrap ;;
bootstrap) get_config_info; bootstrap ;;
wget-bootstrap) get_config_info; delete_boot_images; get_boot_image; bootstrap ;;
*) usage ;;

11
vm/alien.c
View File

@ -59,7 +59,16 @@ CELL allot_alien(CELL delegate, CELL displacement)
REGISTER_ROOT(delegate);
F_ALIEN *alien = allot_object(ALIEN_TYPE,sizeof(F_ALIEN));
UNREGISTER_ROOT(delegate);
alien->alien = delegate;
if(type_of(delegate) == ALIEN_TYPE)
{
F_ALIEN *delegate_alien = untag_object(delegate);
displacement += delegate_alien->displacement;
alien->alien = F;
}
else
alien->alien = delegate;
alien->displacement = displacement;
alien->expired = F;
return tag_object(alien);

2
vm/data_gc.c
View File

@ -189,8 +189,6 @@ CELL unaligned_object_size(CELL pointer)
return sizeof(F_ALIEN);
case WRAPPER_TYPE:
return sizeof(F_WRAPPER);
case CURRY_TYPE:
return sizeof(F_CURRY);
case CALLSTACK_TYPE:
return callstack_size(
untag_fixnum_fast(((F_CALLSTACK *)pointer)->length));

3
vm/errors.c
View File

@ -137,12 +137,11 @@ void misc_signal_handler_impl(void)
DEFINE_PRIMITIVE(throw)
{
uncurry(dpop());
dpop();
throw_impl(dpop(),stack_chain->callstack_top);
}
DEFINE_PRIMITIVE(call_clear)
{
uncurry(dpop());
throw_impl(dpop(),stack_chain->callstack_bottom);
}

5
vm/layouts.h
View File

@ -52,15 +52,14 @@ typedef signed long long s64;
#define FLOAT_ARRAY_TYPE 10
#define CALLSTACK_TYPE 11
#define STRING_TYPE 12
#define CURRY_TYPE 13
#define BIT_ARRAY_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 TYPE_COUNT 20
#define TYPE_COUNT 19
INLINE bool immediate_p(CELL obj)
{

2
vm/primitives.c
View File

@ -3,7 +3,6 @@
void *primitives[] = {
primitive_execute,
primitive_call,
primitive_uncurry,
primitive_bignum_to_fixnum,
primitive_float_to_fixnum,
primitive_fixnum_to_bignum,
@ -178,7 +177,6 @@ void *primitives[] = {
primitive_become,
primitive_sleep,
primitive_float_array,
primitive_curry,
primitive_tuple_boa,
primitive_class_hash,
primitive_callstack_to_array,

44
vm/quotations.c
View File

@ -350,50 +350,6 @@ F_FASTCALL CELL primitive_jit_compile(CELL quot, F_STACK_FRAME *stack)
return quot;
}
DEFINE_PRIMITIVE(curry)
{
F_CURRY *curry;
switch(type_of(dpeek()))
{
case QUOTATION_TYPE:
case CURRY_TYPE:
curry = allot_object(CURRY_TYPE,sizeof(F_CURRY));
curry->quot = dpop();
curry->obj = dpop();
dpush(tag_object(curry));
break;
default:
type_error(QUOTATION_TYPE,dpeek());
break;
}
}
void uncurry(CELL obj)
{
F_CURRY *curry;
switch(type_of(obj))
{
case QUOTATION_TYPE:
dpush(obj);
break;
case CURRY_TYPE:
curry = untag_object(obj);
dpush(curry->obj);
uncurry(curry->quot);
break;
default:
type_error(QUOTATION_TYPE,obj);
break;
}
}
DEFINE_PRIMITIVE(uncurry)
{
uncurry(dpop());
}
/* push a new quotation on the stack */
DEFINE_PRIMITIVE(array_to_quotation)
{

3
vm/quotations.h
View File

@ -2,8 +2,5 @@ void set_quot_xt(F_QUOTATION *quot, F_COMPILED *code);
void jit_compile(CELL quot, bool relocate);
F_FASTCALL CELL primitive_jit_compile(CELL quot, F_STACK_FRAME *stack);
F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset);
void uncurry(CELL obj);
DECLARE_PRIMITIVE(curry);
DECLARE_PRIMITIVE(array_to_quotation);
DECLARE_PRIMITIVE(quotation_xt);
DECLARE_PRIMITIVE(uncurry);