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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

52
core/bootstrap/primitives.factor
View File

@ -295,23 +295,6 @@ define-builtin
"float-array?" "float-arrays" create "float-array?" "float-arrays" create
{ } define-builtin { } 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 "callstack" "kernel" create "callstack?" "kernel" create
{ } define-builtin { } define-builtin
@ -440,14 +423,44 @@ builtins get num-tags get tail f union-class define-class
} }
} define-tuple-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 ! Primitive words
: make-primitive ( word vocab n -- ) : 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" } { "(execute)" "words.private" }
{ "(call)" "kernel.private" } { "(call)" "kernel.private" }
{ "uncurry" "kernel.private" }
{ "bignum>fixnum" "math.private" } { "bignum>fixnum" "math.private" }
{ "float>fixnum" "math.private" } { "float>fixnum" "math.private" }
{ "fixnum>bignum" "math.private" } { "fixnum>bignum" "math.private" }
@ -622,7 +635,6 @@ builtins get num-tags get tail f union-class define-class
{ "become" "kernel.private" } { "become" "kernel.private" }
{ "(sleep)" "threads.private" } { "(sleep)" "threads.private" }
{ "<float-array>" "float-arrays" } { "<float-array>" "float-arrays" }
{ "curry" "kernel" }
{ "<tuple-boa>" "tuples.private" } { "<tuple-boa>" "tuples.private" }
{ "class-hash" "kernel.private" } { "class-hash" "kernel.private" }
{ "callstack>array" "kernel" } { "callstack>array" "kernel" }

2
core/continuations/continuations.factor
View File

@ -98,7 +98,7 @@ PRIVATE>
: continue-with ( obj continuation -- ) : continue-with ( obj continuation -- )
[ [
walker-hook [ >r 2array r> ] when* (continue-with) walker-hook [ >r 2array r> ] when* (continue-with)
] 2curry (throw) ; ] 2 (throw) ;
: continue ( continuation -- ) : continue ( continuation -- )
f swap continue-with ; 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 [ swap predicate-constraints ] [ 2drop ] if
] 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 ) : compute-output-classes ( node word -- classes intervals )
dup node-param "output-classes" word-prop dup dup node-param "output-classes" word-prop
[ call ] [ 2drop f f ] if ; dup [ call ] [ 2drop f f ] if ;
: output-classes ( node -- classes intervals ) : output-classes ( node -- classes intervals )
dup compute-output-classes dup compute-output-classes >r
>r [ ] [ node-param default-output-classes ] ?if r> ; [ ] [ node-param "default-output-classes" word-prop ] ?if
r> ;
M: #call infer-classes-before M: #call infer-classes-before
dup compute-constraints 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 pop-d pop-d swap <curried> push-d
] "infer" set-word-prop ] "infer" set-word-prop
\ curry { object object } { curry } <effect> "inferred-effect" set-word-prop
\ compose [ \ compose [
2 ensure-values 2 ensure-values
pop-d pop-d swap <composed> push-d pop-d pop-d swap <composed> push-d
] "infer" set-word-prop ] "infer" set-word-prop
\ compose { object object } { curry } <effect> "inferred-effect" set-word-prop
! Variadic tuple constructor ! Variadic tuple constructor
\ <tuple-boa> [ \ <tuple-boa> [
\ <tuple-boa> \ <tuple-boa>
@ -142,457 +138,461 @@ M: object infer-call
make-call-node make-call-node
] "infer" set-word-prop ] "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 ! Non-standard control flow
\ (throw) { callable } { } <effect> \ (throw) [
t over set-effect-terminated? \ (throw)
"inferred-effect" set-word-prop 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 ! 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< make-foldable
\ fixnum<= { fixnum fixnum } { object } <effect> "inferred-effect" set-word-prop \ fixnum<= { fixnum fixnum } { object } <effect> set-primitive-effect
\ fixnum<= make-foldable \ 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> make-foldable
\ fixnum>= { fixnum fixnum } { object } <effect> "inferred-effect" set-word-prop \ fixnum>= { fixnum fixnum } { object } <effect> set-primitive-effect
\ fixnum>= make-foldable \ fixnum>= make-foldable
\ eq? { object object } { object } <effect> "inferred-effect" set-word-prop \ eq? { object object } { object } <effect> set-primitive-effect
\ eq? make-foldable \ 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 \ 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 \ 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 \ 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 \ 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 \ 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 \ 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 \ <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 \ 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>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 \ 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 \ 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>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 \ 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 \ <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+ 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+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- 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-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* 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*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/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 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/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-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-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-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-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 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 \ 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= make-foldable
\ bignum+ { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop \ bignum+ { bignum bignum } { bignum } <effect> set-primitive-effect
\ bignum+ make-foldable \ 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- make-foldable
\ bignum* { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop \ bignum* { bignum bignum } { bignum } <effect> set-primitive-effect
\ bignum* make-foldable \ 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/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 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/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-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-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-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-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-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< make-foldable
\ bignum<= { bignum bignum } { object } <effect> "inferred-effect" set-word-prop \ bignum<= { bignum bignum } { object } <effect> set-primitive-effect
\ bignum<= make-foldable \ 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> make-foldable
\ bignum>= { bignum bignum } { object } <effect> "inferred-effect" set-word-prop \ bignum>= { bignum bignum } { object } <effect> set-primitive-effect
\ bignum>= make-foldable \ 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-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 \ 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 \ 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= make-foldable
\ float+ { float float } { float } <effect> "inferred-effect" set-word-prop \ float+ { float float } { float } <effect> set-primitive-effect
\ float+ make-foldable \ 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- make-foldable
\ float* { float float } { float } <effect> "inferred-effect" set-word-prop \ float* { float float } { float } <effect> set-primitive-effect
\ float* make-foldable \ 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/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< 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-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<= make-foldable
\ float> { float float } { object } <effect> "inferred-effect" set-word-prop \ float> { float float } { object } <effect> set-primitive-effect
\ float> make-foldable \ 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>= make-foldable
\ <word> { object object } { word } <effect> "inferred-effect" set-word-prop \ <word> { object object } { word } <effect> set-primitive-effect
\ <word> make-flushable \ <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 \ word-xt make-flushable
\ getenv { fixnum } { object } <effect> "inferred-effect" set-word-prop \ getenv { fixnum } { object } <effect> set-primitive-effect
\ getenv make-flushable \ 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> \ exit { integer } { } <effect>
t over set-effect-terminated? 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 \ 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 \ 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 \ millis make-flushable
\ type { object } { fixnum } <effect> "inferred-effect" set-word-prop \ type { object } { fixnum } <effect> set-primitive-effect
\ type make-foldable \ type make-foldable
\ tag { object } { fixnum } <effect> "inferred-effect" set-word-prop \ tag { object } { fixnum } <effect> set-primitive-effect
\ tag make-foldable \ 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 \ 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 \ <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 \ <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 \ <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 \ <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 \ 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 \ 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 \ 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 \ 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 \ 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 \ 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 \ 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 \ 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 \ 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 \ 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 \ 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 \ 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 \ 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 \ 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 \ 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 \ 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 \ 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 \ 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 \ 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 \ 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-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-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-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-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 \ 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 \ <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 \ 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 \ expired? make-flushable
\ <wrapper> { object } { wrapper } <effect> "inferred-effect" set-word-prop \ <wrapper> { object } { wrapper } <effect> set-primitive-effect
\ <wrapper> make-foldable \ <wrapper> make-foldable
\ (clone) { object } { object } <effect> "inferred-effect" set-word-prop \ (clone) { object } { object } <effect> set-primitive-effect
\ (clone) make-flushable \ (clone) make-flushable
\ <string> { integer integer } { string } <effect> "inferred-effect" set-word-prop \ <string> { integer integer } { string } <effect> set-primitive-effect
\ <string> make-flushable \ <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 \ 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 \ 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> make-flushable
\ (>tuple) { array } { tuple } <effect> "inferred-effect" set-word-prop \ (>tuple) { array } { tuple } <effect> set-primitive-effect
\ (>tuple) make-flushable \ (>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 \ tuple>array make-flushable
\ datastack { } { array } <effect> "inferred-effect" set-word-prop \ datastack { } { array } <effect> set-primitive-effect
\ datastack make-flushable \ datastack make-flushable
\ retainstack { } { array } <effect> "inferred-effect" set-word-prop \ retainstack { } { array } <effect> set-primitive-effect
\ retainstack make-flushable \ retainstack make-flushable
\ callstack { } { callstack } <effect> "inferred-effect" set-word-prop \ callstack { } { callstack } <effect> set-primitive-effect
\ callstack make-flushable \ 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 \ 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 \ 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 \ construct-empty 1 1 <effect> make-call-node
] if ] if
] "infer" set-word-prop ] "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" "compose call"
"append 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 HELP: 3compose

15
core/kernel/kernel.factor
View File

@ -17,8 +17,7 @@ IN: kernel
: clear ( -- ) { } set-datastack ; : clear ( -- ) { } set-datastack ;
! Combinators ! Combinators
GENERIC: call ( callable -- )
: call ( callable -- ) uncurry (call) ;
DEFER: if DEFER: if
@ -71,6 +70,10 @@ DEFER: if
[ 2nip call ] if ; inline [ 2nip call ] if ; inline
! Quotation building ! Quotation building
USE: tuples.private
: curry ( obj quot -- curry )
\ curry 4 <tuple-boa> ;
: 2curry ( obj1 obj2 quot -- curry ) : 2curry ( obj1 obj2 quot -- curry )
curry curry ; inline curry curry ; inline
@ -82,12 +85,10 @@ DEFER: if
swapd [ swapd call ] 2curry ; inline swapd [ swapd call ] 2curry ; inline
: compose ( quot1 quot2 -- curry ) : compose ( quot1 quot2 -- curry )
! Not inline because this is treated as a primitive by \ compose 4 <tuple-boa> ;
! the compiler
[ slip call ] 2curry ;
: 3compose ( quot1 quot2 quot3 -- curry ) : 3compose ( quot1 quot2 quot3 -- curry )
[ 2slip slip call ] 3curry ; inline compose compose ; inline
! Object protocol ! Object protocol
@ -156,7 +157,7 @@ GENERIC: construct-boa ( ... class -- tuple )
! Error handling -- defined early so that other files can ! Error handling -- defined early so that other files can
! throw errors before continuations are loaded ! throw errors before continuations are loaded
: throw ( error -- * ) 5 getenv [ die ] or curry (throw) ; : throw ( error -- * ) 5 getenv [ die ] or 1 (throw) ;
<PRIVATE <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 ] unit-test
: kill-set ( quot -- seq ) : kill-set ( quot -- seq )
dataflow compute-def-use dead-literals keys dataflow compute-def-use compute-dead-literals keys
[ value-literal ] map ; [ value-literal ] map ;
: subset? [ member? ] curry all? ; : 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 ] "output-classes" set-word-prop
] each ] 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 ! the output of clone has the same type as the input
{ clone (clone) } [ { 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 [ t ] [ \ node-successor-f-bug compiled? ] unit-test
: construct-empty-bug construct-empty ;
[ ] [ [ construct-empty ] dataflow optimize drop ] unit-test [ ] [ [ construct-empty ] dataflow optimize drop ] unit-test
[ ] [ [ <tuple> ] dataflow optimize drop ] unit-test
! Make sure we have sane heuristics ! Make sure we have sane heuristics
: should-inline? method method-word flat-length 10 <= ; : 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 ) : escape ( escape -- ch )
H{ H{
{ CHAR: a CHAR: \a }
{ CHAR: e CHAR: \e } { CHAR: e CHAR: \e }
{ CHAR: n CHAR: \n } { CHAR: n CHAR: \n }
{ CHAR: r CHAR: \r } { CHAR: r CHAR: \r }

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

@ -58,6 +58,7 @@ M: f pprint* drop \ f pprint-word ;
! Strings ! Strings
: ch>ascii-escape ( ch -- str ) : ch>ascii-escape ( ch -- str )
H{ H{
{ CHAR: \a CHAR: a }
{ CHAR: \e CHAR: e } { CHAR: \e CHAR: e }
{ CHAR: \n CHAR: n } { CHAR: \n CHAR: n }
{ CHAR: \r CHAR: r } { CHAR: \r CHAR: r }
@ -135,6 +136,7 @@ GENERIC: pprint-delims ( obj -- start end )
M: quotation pprint-delims drop \ [ \ ] ; M: quotation pprint-delims drop \ [ \ ] ;
M: curry pprint-delims drop \ [ \ ] ; M: curry pprint-delims drop \ [ \ ] ;
M: compose pprint-delims drop \ [ \ ] ;
M: array pprint-delims drop \ { \ } ; M: array pprint-delims drop \ { \ } ;
M: byte-array pprint-delims drop \ B{ \ } ; M: byte-array pprint-delims drop \ B{ \ } ;
M: byte-vector pprint-delims drop \ BV{ \ } ; M: byte-vector pprint-delims drop \ BV{ \ } ;
@ -156,6 +158,8 @@ M: vector >pprint-sequence ;
M: bit-vector >pprint-sequence ; M: bit-vector >pprint-sequence ;
M: byte-vector >pprint-sequence ; M: byte-vector >pprint-sequence ;
M: float-vector >pprint-sequence ; M: float-vector >pprint-sequence ;
M: curry >pprint-sequence ;
M: compose >pprint-sequence ;
M: hashtable >pprint-sequence >alist ; M: hashtable >pprint-sequence >alist ;
M: tuple >pprint-sequence tuple>array ; M: tuple >pprint-sequence tuple>array ;
M: wrapper >pprint-sequence wrapped 1array ; M: wrapper >pprint-sequence wrapped 1array ;
@ -181,6 +185,17 @@ M: tuple pprint-narrow? drop t ;
M: object pprint* pprint-object ; 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* M: wrapper pprint*
dup wrapped word? [ dup wrapped word? [
<block \ \ pprint-word wrapped pprint-word block> <block \ \ pprint-word wrapped pprint-word block>

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

@ -321,3 +321,7 @@ unit-test
[ [ 2 . ] ] [ [ [ 2 . ] ] [
[ 2 \ break (step-into) . ] (remove-breakpoints) [ 2 \ break (step-into) . ] (remove-breakpoints)
] unit-test ] 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 [ [ "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. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays sequences sequences.private USING: arrays sequences sequences.private
kernel kernel.private math assocs quotations.private ; kernel kernel.private math assocs quotations.private
slots.private ;
IN: quotations 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? M: wrapper equal?
over wrapper? [ [ wrapped ] 2apply = ] [ 2drop f ] if ; over wrapper? [ [ wrapped ] 2apply = ] [ 2drop f ] if ;
UNION: callable quotation curry ; UNION: callable quotation curry compose ;
M: callable equal? M: callable equal?
over callable? [ sequence= ] [ 2drop f ] if ; over callable? [ sequence= ] [ 2drop f ] if ;
@ -19,7 +26,7 @@ M: quotation nth-unsafe quotation-array nth-unsafe ;
: >quotation ( seq -- quot ) : >quotation ( seq -- quot )
>array array>quotation ; inline >array array>quotation ; inline
M: quotation like drop dup quotation? [ >quotation ] unless ; M: callable like drop dup quotation? [ >quotation ] unless ;
INSTANCE: quotation immutable-sequence INSTANCE: quotation immutable-sequence
@ -40,6 +47,17 @@ M: curry nth
>r 1- r> curry-quot nth >r 1- r> curry-quot nth
] if ; ] if ;
M: curry like drop dup callable? [ >quotation ] unless ;
INSTANCE: curry immutable-sequence 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 V{ } set-catchstack
{ } set-retainstack { } set-retainstack
[ [ print-error ] recover stop ] call-clear [ [ print-error ] recover stop ] call-clear
] (throw) ] 1 (throw)
] curry callcc0 ; ] curry callcc0 ;
<PRIVATE <PRIVATE

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

@ -71,7 +71,8 @@ M: vocab-link vocab-root
TUPLE: no-vocab name ; 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" ; 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 ; 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? M: vocab-link equal?
over vocab-link? over vocab-link?
@ -103,9 +104,7 @@ M: vocab >vocab-link drop ;
M: vocab-link >vocab-link drop ; M: vocab-link >vocab-link drop ;
M: string >vocab-link M: string >vocab-link
over vocab dup [ 2nip ] [ over vocab dup [ 2nip ] [ drop <vocab-link> ] if ;
drop [ dup vocab-root ] unless* <vocab-link>
] if ;
UNION: vocab-spec vocab vocab-link ; 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 ; compiled-crossref get at ;
M: word redefined* ( word -- ) M: word redefined* ( word -- )
{ "inferred-effect" "base-case" "no-effect" } reset-props ; { "inferred-effect" "no-effect" } reset-props ;
SYMBOL: changed-words 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 system continuations namespaces sequences splitting math.parser
prettyprint tools.time calendar bake vars http.client prettyprint tools.time calendar bake vars http.client
combinators bootstrap.image bootstrap.image.download combinators bootstrap.image bootstrap.image.download
@ -95,9 +95,10 @@ VAR: stamp
stamp> make-directory stamp> make-directory
stamp> cd ; stamp> cd ;
: record-git-id ( -- ) : git-id ( -- id )
{ "git" "show" } <process-stream> [ readln ] with-stream " " split second { "git" "show" } <process-stream> [ readln ] with-stream " " split second ;
"../git-id" log-object ;
: record-git-id ( -- ) git-id "../git-id" log-object ;
: make-clean ( -- desc ) { "make" "clean" } ; : make-clean ( -- desc ) { "make" "clean" } ;
@ -113,7 +114,8 @@ VAR: stamp
[ my-arch download-image ] [ my-arch download-image ]
[ ] [ ]
[ "builder: image download" email-string ] [ "builder: image download" email-string ]
cleanup ; cleanup
flush ;
: bootstrap ( -- desc ) : bootstrap ( -- desc )
`{ `{
@ -135,12 +137,6 @@ SYMBOL: build-status
: build ( -- ) : build ( -- )
"running" build-status set-global
"/builds/factor" cd
git-pull "git pull error" run-or-notify
enter-build-dir enter-build-dir
git-clone "git clone error" run-or-notify git-clone "git clone error" run-or-notify
@ -165,10 +161,30 @@ SYMBOL: build-status
"../failing-tests" exists? "../failing-tests" exists?
[ "failing tests" "../failing-tests" email-file ] [ "failing tests" "../failing-tests" email-file ]
when when ;
"ready" build-status set-global ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
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 [ 5 ] [ [ 10 random ] [ 5 = ] generate ] unit-test
[ t ] [ [ 10 random ] [ even? ] generate even? ] 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 2 [ 5 + ] dip ] unit-test
{ 6 2 1 } [ 1 2 1 [ 5 + ] dipd ] 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 [ 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 { 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 + ] ] [ 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 1 2 2 3 3 ] [ 1 2 3 [ dup ] 3apply ] unit-test
[ 1 4 9 ] [ 1 2 3 [ sq ] 3apply ] unit-test [ 1 4 9 ] [ 1 2 3 [ sq ] 3apply ] unit-test
[ [ sq ] 3apply ] must-infer [ [ sq ] 3apply ] must-infer
@ -55,5 +46,3 @@ IN: temporary
[ dup array? ] [ dup vector? ] [ dup float? ] [ dup array? ] [ dup vector? ] [ dup float? ]
} || nip } || nip
] unit-test ] 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 ")" % ] interleave ")" %
] "" make ; ] "" make ;
M: sqlite-db drop-sql ( table -- sql )
[
"drop table " % %
] "" make ;
M: sqlite-db insert-sql* ( columns table -- sql ) M: sqlite-db insert-sql* ( columns table -- sql )
[ [
"insert into " % "insert into " %
@ -109,7 +114,6 @@ M: sqlite-db update-sql* ( columns table -- sql )
M: sqlite-db delete-sql* ( columns table -- sql ) M: sqlite-db delete-sql* ( columns table -- sql )
[ [
break
"delete from " % "delete from " %
% %
" where " % " 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 IN: temporary
TUPLE: person the-id the-name the-number ; TUPLE: person the-id the-name the-number ;
@ -13,16 +14,23 @@ person "PERSON"
} define-persistent } define-persistent
SYMBOL: the-person
: test-tuples ( -- ) : 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
[ 1 ] [ dup person-id ] unit-test [ ] [ the-person get insert-tuple ] unit-test
200 over set-person-the-number [ 1 ] [ the-person get person-the-id ] unit-test
[ ] [ dup update-tuple ] unit-test 200 the-person get set-person-the-number
[ ] [ delete-tuple ] unit-test ; [ ] [ the-person get update-tuple ] unit-test
[ ] [ the-person get delete-tuple ] unit-test ;
: test-sqlite ( -- ) : test-sqlite ( -- )
"tuples-test.db" resource-path <sqlite-db> [ "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 [ <prepared-statement> ] 3compose cache nip ; inline
HOOK: create-sql db ( columns table -- sql ) 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: insert-sql* db ( columns table -- sql )
HOOK: update-sql* db ( columns table -- sql ) HOOK: update-sql* db ( columns table -- sql )
HOOK: delete-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 -- ) : create-table ( class -- )
dup db-columns swap db-table create-sql sql-command ; dup db-columns swap db-table create-sql sql-command ;
: drop-table ( class -- )
db-table drop-sql sql-command ;
: insert-tuple ( tuple -- ) : insert-tuple ( tuple -- )
[ [
[ maybe-remove-id ] [ insert-sql ] do-tuple-statement [ 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 -- ) : server-loop ( server quot -- )
[ accept-loop ] curry with-disposal ; inline [ accept-loop ] curry with-disposal ; inline
SYMBOL: servers
: spawn-server ( addrspec quot -- ) : 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 \ spawn-server NOTICE add-error-logging
@ -39,9 +41,13 @@ LOG: accepted-connection NOTICE
: with-server ( seq service quot -- ) : with-server ( seq service quot -- )
[ [
V{ } clone servers set
[ spawn-server ] curry concurrency:parallel-each [ spawn-server ] curry concurrency:parallel-each
] curry with-logging ; inline ] curry with-logging ; inline
: stop-server ( -- )
servers get [ dispose ] each ;
: received-datagram ( addrspec -- ) drop ; : received-datagram ( addrspec -- ) drop ;
\ received-datagram NOTICE add-input-logging \ received-datagram NOTICE add-input-logging

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

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: effects words kernel sequences slots slots.private USING: effects words kernel sequences slots slots.private
assocs parser mirrors namespaces math vocabs ; assocs parser mirrors namespaces math vocabs tuples ;
IN: new-slots IN: new-slots
: create-accessor ( name effect -- word ) : create-accessor ( name effect -- word )
@ -19,11 +19,21 @@ IN: new-slots
: writer-effect T{ effect f { "value" "object" } { } } ; inline : writer-effect T{ effect f { "value" "object" } { } } ; inline
: writer-word ( name -- word ) : writer-word ( name -- word )
">>" swap append writer-effect create-accessor ; "(>>" swap ")" 3append writer-effect create-accessor ;
: define-writer ( class slot name -- ) : define-writer ( class slot name -- )
writer-word [ set-slot ] define-slot-word ; 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-effect T{ effect f { "object" "quot" } } ; inline
: changer-word ( name -- word ) : changer-word ( name -- word )
@ -40,12 +50,18 @@ IN: new-slots
] [ 2drop ] if ; ] [ 2drop ] if ;
: define-new-slot ( class slot name -- ) : 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 -- ) : define-new-slots ( tuple-class -- )
[ "slot-names" word-prop <enum> >alist ] keep [ "slot-names" word-prop <enum> >alist ] keep
[ swap first2 >r 4 + r> define-new-slot ] curry each ; [ 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 "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 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 [ 4 ] [ { 1 2 } [ sq ] [ * ] map-reduce ] unit-test
[ 36 ] [ { 2 3 } [ 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 [ 2 ] [ { 1 2 3 } ?second ] unit-test
[ 3 ] [ { 1 2 3 } ?third ] unit-test [ 3 ] [ { 1 2 3 } ?third ] unit-test
[ f ] [ { 1 2 3 } ?fourth ] 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 IN: temporary
USING: tools.browser tools.test help.markup ; USING: tools.browser tools.test help.markup ;
[ t ] [ "resource:core" "kernel" vocab-dir? ] unit-test
[ ] [ { $describe-vocab "scratchpad" } print-content ] 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 } ] [ { 6 } ]
[ [ [ 3 swap continue-with ] callcc1 2 * ] test-interpreter ] unit-test [ [ [ 3 swap continue-with ] callcc1 2 * ] test-interpreter ] unit-test
[ { } ]
[ [ [ ] [ ] recover ] test-interpreter ] unit-test
[ { 6 } ] [ { 6 } ]
[ [ [ 3 throw ] [ 2 * ] recover ] test-interpreter ] unit-test [ [ [ 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 ] } { call [ walk ] }
{ (throw) [ walk ] } { (throw) [ drop walk ] }
{ execute [ (step-into-execute) ] } { execute [ (step-into-execute) ] }
{ if [ (step-into-if) ] } { if [ (step-into-if) ] }
{ dispatch [ (step-into-dispatch) ] } { 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-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 -- ) 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 -- ) : exit-fullscreen ( world -- )
world-handle first f -> exitFullScreenModeWithOptions: ; 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 ; swap [ enter-fullscreen ] [ exit-fullscreen ] if ;
M: cocoa-ui-backend fullscreen? ( world -- ? ) M: cocoa-ui-backend fullscreen* ( world -- ? )
world-handle first -> isInFullScreenMode zero? not ; world-handle first -> isInFullScreenMode zero? not ;
: auto-position ( world -- ) : 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." } { $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" } "." } ; { $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 HELP: raise-window
{ $values { "world" world } } { $values { "world" world } }
{ $description "Makes the native window containing the given world the front-most window." } { $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 } } { $values { "gadget" gadget } { "title" string } }
{ $description "Opens a native window with the specified title." } ; { $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 HELP: find-window
{ $values { "quot" "a quotation with stack effect " { $snippet "( world -- ? )" } } { "world" "a " { $link world } " or " { $link f } } } { $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." } ; { $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> >r [ 1 track, ] { 0 1 } make-track r>
f <world> open-world-window ; f <world> open-world-window ;
: set-fullscreen? ( ? gadget -- )
find-world set-fullscreen* ;
: fullscreen? ( gadget -- ? )
find-world fullscreen* ;
HOOK: close-window ui-backend ( gadget -- ) HOOK: close-window ui-backend ( gadget -- )
M: object close-window 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 # Programs returning != 0 will not cause script to exit
set +e set +e
@ -11,6 +11,9 @@ OS=
ARCH= ARCH=
WORD= WORD=
NO_UI= NO_UI=
GIT_PROTOCOL=${GIT_PROTOCOL:="git"}
GIT_URL=${GIT_URL:=$GIT_PROTOCOL"://factorcode.org/git/factor.git"}
ensure_program_installed() { ensure_program_installed() {
echo -n "Checking for $1..." echo -n "Checking for $1..."
@ -51,6 +54,9 @@ check_installed_programs() {
ensure_program_installed wget ensure_program_installed wget
ensure_program_installed gcc ensure_program_installed gcc
ensure_program_installed make ensure_program_installed make
case $OS in
netbsd) ensure_program_installed gmake;;
esac
check_gcc_version check_gcc_version
} }
@ -106,6 +112,7 @@ find_os() {
*Darwin*) OS=macosx;; *Darwin*) OS=macosx;;
*linux*) OS=linux;; *linux*) OS=linux;;
*Linux*) OS=linux;; *Linux*) OS=linux;;
*NetBSD*) OS=netbsd;;
esac esac
} }
@ -153,6 +160,8 @@ echo_build_info() {
echo MAKE_TARGET=$MAKE_TARGET echo MAKE_TARGET=$MAKE_TARGET
echo BOOT_IMAGE=$BOOT_IMAGE echo BOOT_IMAGE=$BOOT_IMAGE
echo MAKE_IMAGE_TARGET=$MAKE_IMAGE_TARGET echo MAKE_IMAGE_TARGET=$MAKE_IMAGE_TARGET
echo GIT_PROTOCOL=$GIT_PROTOCOL
echo GIT_URL=$GIT_URL
} }
set_build_info() { set_build_info() {
@ -188,22 +197,19 @@ find_build_info() {
echo_build_info echo_build_info
} }
invoke_git() {
git $*
check_ret git
}
git_clone() { git_clone() {
echo "Downloading the git repository from factorcode.org..." echo "Downloading the git repository from factorcode.org..."
git clone git://factorcode.org/git/factor.git invoke_git clone $GIT_URL
check_ret git
} }
git_pull_factorcode() { git_pull_factorcode() {
echo "Updating the git repository from factorcode.org..." echo "Updating the git repository from factorcode.org..."
git pull git://factorcode.org/git/factor.git master invoke_git pull $GIT_URL 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
} }
cd_factor() { cd_factor() {
@ -211,21 +217,28 @@ cd_factor() {
check_ret cd check_ret cd
} }
invoke_make() {
case $OS in
netbsd) make='gmake';;
*) make='make';;
esac
$make $*
check_ret $make
}
make_clean() { make_clean() {
make clean invoke_make clean
check_ret make
} }
make_factor() { make_factor() {
make NO_UI=$NO_UI $MAKE_TARGET -j5 invoke_make NO_UI=$NO_UI $MAKE_TARGET -j5
check_ret make
} }
delete_boot_images() { delete_boot_images() {
echo "Deleting old images..." echo "Deleting old images..."
rm $BOOT_IMAGE > /dev/null 2>&1 rm $BOOT_IMAGE > /dev/null 2>&1
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() { get_boot_image() {
@ -257,8 +270,8 @@ maybe_download_dlls() {
} }
get_config_info() { get_config_info() {
check_installed_programs
find_build_info find_build_info
check_installed_programs
check_libraries check_libraries
} }
@ -285,13 +298,6 @@ update() {
make_factor make_factor
} }
http_update() {
get_config_info
http_git_pull_factorcode
make_clean
make_factor
}
update_bootstrap() { update_bootstrap() {
delete_boot_images delete_boot_images
get_boot_image get_boot_image
@ -299,7 +305,7 @@ update_bootstrap() {
} }
refresh_image() { 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 check_ret factor
} }
@ -316,6 +322,8 @@ install_libraries() {
usage() { usage() {
echo "usage: $0 install|install-x11|self-update|quick-update|update|bootstrap|wget-bootstrap" 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 case "$1" in
@ -324,7 +332,6 @@ case "$1" in
self-update) update; make_boot_image; bootstrap;; self-update) update; make_boot_image; bootstrap;;
quick-update) update; refresh_image ;; quick-update) update; refresh_image ;;
update) update; update_bootstrap ;; update) update; update_bootstrap ;;
http-update) http_update; update_bootstrap ;;
bootstrap) get_config_info; bootstrap ;; bootstrap) get_config_info; bootstrap ;;
wget-bootstrap) get_config_info; delete_boot_images; get_boot_image; bootstrap ;; wget-bootstrap) get_config_info; delete_boot_images; get_boot_image; bootstrap ;;
*) usage ;; *) usage ;;

11
vm/alien.c
View File

@ -59,7 +59,16 @@ CELL allot_alien(CELL delegate, CELL displacement)
REGISTER_ROOT(delegate); REGISTER_ROOT(delegate);
F_ALIEN *alien = allot_object(ALIEN_TYPE,sizeof(F_ALIEN)); F_ALIEN *alien = allot_object(ALIEN_TYPE,sizeof(F_ALIEN));
UNREGISTER_ROOT(delegate); 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->displacement = displacement;
alien->expired = F; alien->expired = F;
return tag_object(alien); 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); return sizeof(F_ALIEN);
case WRAPPER_TYPE: case WRAPPER_TYPE:
return sizeof(F_WRAPPER); return sizeof(F_WRAPPER);
case CURRY_TYPE:
return sizeof(F_CURRY);
case CALLSTACK_TYPE: case CALLSTACK_TYPE:
return callstack_size( return callstack_size(
untag_fixnum_fast(((F_CALLSTACK *)pointer)->length)); 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) DEFINE_PRIMITIVE(throw)
{ {
uncurry(dpop()); dpop();
throw_impl(dpop(),stack_chain->callstack_top); throw_impl(dpop(),stack_chain->callstack_top);
} }
DEFINE_PRIMITIVE(call_clear) DEFINE_PRIMITIVE(call_clear)
{ {
uncurry(dpop());
throw_impl(dpop(),stack_chain->callstack_bottom); 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 FLOAT_ARRAY_TYPE 10
#define CALLSTACK_TYPE 11 #define CALLSTACK_TYPE 11
#define STRING_TYPE 12 #define STRING_TYPE 12
#define CURRY_TYPE 13 #define BIT_ARRAY_TYPE 13
#define QUOTATION_TYPE 14 #define QUOTATION_TYPE 14
#define DLL_TYPE 15 #define DLL_TYPE 15
#define ALIEN_TYPE 16 #define ALIEN_TYPE 16
#define WORD_TYPE 17 #define WORD_TYPE 17
#define BYTE_ARRAY_TYPE 18 #define BYTE_ARRAY_TYPE 18
#define BIT_ARRAY_TYPE 19
#define TYPE_COUNT 20 #define TYPE_COUNT 19
INLINE bool immediate_p(CELL obj) INLINE bool immediate_p(CELL obj)
{ {

2
vm/primitives.c
View File

@ -3,7 +3,6 @@
void *primitives[] = { void *primitives[] = {
primitive_execute, primitive_execute,
primitive_call, primitive_call,
primitive_uncurry,
primitive_bignum_to_fixnum, primitive_bignum_to_fixnum,
primitive_float_to_fixnum, primitive_float_to_fixnum,
primitive_fixnum_to_bignum, primitive_fixnum_to_bignum,
@ -178,7 +177,6 @@ void *primitives[] = {
primitive_become, primitive_become,
primitive_sleep, primitive_sleep,
primitive_float_array, primitive_float_array,
primitive_curry,
primitive_tuple_boa, primitive_tuple_boa,
primitive_class_hash, primitive_class_hash,
primitive_callstack_to_array, 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; 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 */ /* push a new quotation on the stack */
DEFINE_PRIMITIVE(array_to_quotation) 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); void jit_compile(CELL quot, bool relocate);
F_FASTCALL CELL primitive_jit_compile(CELL quot, F_STACK_FRAME *stack); F_FASTCALL CELL primitive_jit_compile(CELL quot, F_STACK_FRAME *stack);
F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset); 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(array_to_quotation);
DECLARE_PRIMITIVE(quotation_xt); DECLARE_PRIMITIVE(quotation_xt);
DECLARE_PRIMITIVE(uncurry);