Merge branch 'master' of git://factorcode.org/git/factor
commit
d7a5f9f505
|
@ -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
|
||||
|
|
|
@ -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" }
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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? ;
|
||||
|
|
|
@ -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) } [
|
||||
[
|
||||
|
|
|
@ -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 <= ;
|
||||
|
||||
|
|
|
@ -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 }
|
||||
|
|
|
@ -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>
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -15,4 +15,4 @@ IN: temporary
|
|||
|
||||
[ [ "hi" ] ] [ "hi" 1quotation ] unit-test
|
||||
|
||||
[ 1 \ + curry ] must-fail
|
||||
! [ 1 \ + curry ] must-fail
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -49,7 +49,7 @@ PRIVATE>
|
|||
V{ } set-catchstack
|
||||
{ } set-retainstack
|
||||
[ [ print-error ] recover stop ] call-clear
|
||||
] (throw)
|
||||
] 1 (throw)
|
||||
] curry callcc0 ;
|
||||
|
||||
<PRIVATE
|
||||
|
|
|
@ -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" ;
|
||||
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
|
@ -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
|
|
@ -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
|
||||
|
|
|
@ -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 " %
|
||||
|
|
|
@ -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> [
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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) ] }
|
||||
|
|
|
@ -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 -- )
|
||||
|
||||
|
|
|
@ -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 -- )
|
||||
|
|
|
@ -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." }
|
||||
|
|
|
@ -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." } ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
11
vm/alien.c
|
@ -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);
|
||||
|
|
|
@ -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));
|
||||
|
|
|
@ -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);
|
||||
}
|
||||
|
|
|
@ -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)
|
||||
{
|
||||
|
|
|
@ -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,
|
||||
|
|
|
@ -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)
|
||||
{
|
||||
|
|
|
@ -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);
|
||||
|
|
Loading…
Reference in New Issue