factor: [| to |[
Doug Coleman
parent
ed93a451a6
commit
deb7732a84
|
|
@ -32,10 +32,10 @@ MEMO: 24-from-4 ( a b c d -- ? )
|
||||||
[ some-rots do-something 24-from-3 ] [ 4drop ] if-amb ;
|
[ some-rots do-something 24-from-3 ] [ 4drop ] if-amb ;
|
||||||
|
|
||||||
: find-impossible-24 ( -- n )
|
: find-impossible-24 ( -- n )
|
||||||
10 [1,b] [| a |
|
10 [1,b] |[ a |
|
||||||
10 [1,b] [| b |
|
10 [1,b] |[ b |
|
||||||
10 [1,b] [| c |
|
10 [1,b] |[ c |
|
||||||
10 [1,b] [| d |
|
10 [1,b] |[ d |
|
||||||
a b c d 24-from-4
|
a b c d 24-from-4
|
||||||
] count
|
] count
|
||||||
] map-sum
|
] map-sum
|
||||||
|
|
|
||||||
|
|
@ -6,7 +6,7 @@ in: benchmark.beust2
|
||||||
! http://crazybob.org/BeustSequence.java.html
|
! http://crazybob.org/BeustSequence.java.html
|
||||||
|
|
||||||
:: (count-numbers) ( remaining first value used max listener: ( -- ) -- ? )
|
:: (count-numbers) ( remaining first value used max listener: ( -- ) -- ? )
|
||||||
10 first - iota [| i |
|
10 first - iota |[ i |
|
||||||
i first + :> digit
|
i first + :> digit
|
||||||
digit 2^ :> mask
|
digit 2^ :> mask
|
||||||
i value + :> value'
|
i value + :> value'
|
||||||
|
|
|
||||||
|
|
@ -35,7 +35,7 @@ CONSTANT: min-depth 4 ;
|
||||||
:: long-lived-tree ( max-depth -- )
|
:: long-lived-tree ( max-depth -- )
|
||||||
0 max-depth bottom-up-tree
|
0 max-depth bottom-up-tree
|
||||||
|
|
||||||
min-depth max-depth 2 <range> [| depth |
|
min-depth max-depth 2 <range> |[ depth |
|
||||||
max-depth depth - min-depth + 2^ [
|
max-depth depth - min-depth + 2^ [
|
||||||
[1,b] 0 [
|
[1,b] 0 [
|
||||||
dup neg
|
dup neg
|
||||||
|
|
|
||||||
|
|
@ -77,7 +77,7 @@ TYPED:: make-repeat-fasta ( k: fixnum len: fixnum alu: string -- k': fixnum )
|
||||||
let[
|
let[
|
||||||
:> alu
|
:> alu
|
||||||
0 :> k!
|
0 :> k!
|
||||||
[| len | k len alu make-repeat-fasta k! ] split-lines
|
|[ len | k len alu make-repeat-fasta k! ] split-lines
|
||||||
] ;
|
] ;
|
||||||
|
|
||||||
: fasta ( n out -- )
|
: fasta ( n out -- )
|
||||||
|
|
|
||||||
|
|
@ -8,7 +8,7 @@ MEMO: strings ( -- str )
|
||||||
0 100 [a,b) 1 [ + ] accumulate* [ number>string ] map ;
|
0 100 [a,b) 1 [ + ] accumulate* [ number>string ] map ;
|
||||||
|
|
||||||
:: add-delete-mix ( hash keys -- )
|
:: add-delete-mix ( hash keys -- )
|
||||||
keys [| k |
|
keys |[ k |
|
||||||
0 k hash set-at
|
0 k hash set-at
|
||||||
k hash delete-at
|
k hash delete-at
|
||||||
] each
|
] each
|
||||||
|
|
|
||||||
|
|
@ -9,7 +9,7 @@ in: benchmark.matrix-exponential-scalar
|
||||||
{ 0.0 0.0 0.0 0.0 }
|
{ 0.0 0.0 0.0 0.0 }
|
||||||
{ 0.0 0.0 0.0 0.0 }
|
{ 0.0 0.0 0.0 0.0 }
|
||||||
}
|
}
|
||||||
iterations iota [| i |
|
iterations iota |[ i |
|
||||||
m i m^n i factorial >float m/n m+
|
m i m^n i factorial >float m/n m+
|
||||||
] each ;
|
] each ;
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -4,7 +4,7 @@ in: benchmark.matrix-exponential-simd
|
||||||
|
|
||||||
TYPED:: e^m4 ( m: matrix4 iterations: fixnum -- e^m: matrix4 )
|
TYPED:: e^m4 ( m: matrix4 iterations: fixnum -- e^m: matrix4 )
|
||||||
zero-matrix4
|
zero-matrix4
|
||||||
iterations iota [| i |
|
iterations iota |[ i |
|
||||||
m i m4^n i factorial >float m4/n m4+
|
m i m4^n i factorial >float m4/n m4+
|
||||||
] each ;
|
] each ;
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -59,7 +59,7 @@ specialized-array: body
|
||||||
dup init-bodies ; inline
|
dup init-bodies ; inline
|
||||||
|
|
||||||
:: each-pair ( ... bodies pair-quot: ( ... other-body body -- ... ) each-quot: ( ... body -- ... ) -- )
|
:: each-pair ( ... bodies pair-quot: ( ... other-body body -- ... ) each-quot: ( ... body -- ... ) -- )
|
||||||
bodies [| body i |
|
bodies |[ body i |
|
||||||
body each-quot call
|
body each-quot call
|
||||||
bodies i 1 + tail-slice [
|
bodies i 1 + tail-slice [
|
||||||
body pair-quot call
|
body pair-quot call
|
||||||
|
|
|
||||||
|
|
@ -59,7 +59,7 @@ TUPLE: nbody-system { bodies array read-only } ;
|
||||||
dup bodies>> init-bodies ; inline
|
dup bodies>> init-bodies ; inline
|
||||||
|
|
||||||
:: each-pair ( ... bodies pair-quot: ( ... other-body body -- ... ) each-quot: ( ... body -- ... ) -- ... )
|
:: each-pair ( ... bodies pair-quot: ( ... other-body body -- ... ) each-quot: ( ... body -- ... ) -- ... )
|
||||||
bodies [| body i |
|
bodies |[ body i |
|
||||||
body each-quot call
|
body each-quot call
|
||||||
bodies i 1 + tail-slice [
|
bodies i 1 + tail-slice [
|
||||||
body pair-quot call
|
body pair-quot call
|
||||||
|
|
|
||||||
|
|
@ -6,9 +6,9 @@ in: benchmark.sieve
|
||||||
n dup odd? [ 1 + ] when 2/ <bit-array> :> sieve
|
n dup odd? [ 1 + ] when 2/ <bit-array> :> sieve
|
||||||
t 0 sieve set-nth
|
t 0 sieve set-nth
|
||||||
|
|
||||||
3 n sqrt 2 <range> [| i |
|
3 n sqrt 2 <range> |[ i |
|
||||||
i 2/ sieve nth [
|
i 2/ sieve nth [
|
||||||
i sq n i 2 * <range> [| j |
|
i sq n i 2 * <range> |[ j |
|
||||||
t j 2/ sieve set-nth
|
t j 2/ sieve set-nth
|
||||||
] each
|
] each
|
||||||
] unless
|
] unless
|
||||||
|
|
|
||||||
|
|
@ -8,8 +8,8 @@ SPECIALIZED-ARRAYS: double double-4 ;
|
||||||
in: benchmark.spectral-norm-simd
|
in: benchmark.spectral-norm-simd
|
||||||
|
|
||||||
:: inner-loop ( u n quot -- seq )
|
:: inner-loop ( u n quot -- seq )
|
||||||
n 4 /i iota [| i |
|
n 4 /i iota |[ i |
|
||||||
n iota [| j | u i j quot call ] [ v+ ] map-reduce
|
n iota |[ j | u i j quot call ] [ v+ ] map-reduce
|
||||||
] double-4-array{ } map-as ; inline
|
] double-4-array{ } map-as ; inline
|
||||||
|
|
||||||
: eval-A ( i j -- n )
|
: eval-A ( i j -- n )
|
||||||
|
|
|
||||||
|
|
@ -10,8 +10,8 @@ specialized-array: double
|
||||||
in: benchmark.spectral-norm
|
in: benchmark.spectral-norm
|
||||||
|
|
||||||
:: inner-loop ( u n quot -- seq )
|
:: inner-loop ( u n quot -- seq )
|
||||||
n iota [| i |
|
n iota |[ i |
|
||||||
n iota 0.0 [| j |
|
n iota 0.0 |[ j |
|
||||||
u i j quot call +
|
u i j quot call +
|
||||||
] reduce
|
] reduce
|
||||||
] double-array{ } map-as ; inline
|
] double-array{ } map-as ; inline
|
||||||
|
|
|
||||||
|
|
@ -117,7 +117,7 @@ TUPLE: my-node < dlist-link { obj fixnum } ;
|
||||||
[ prev>> ] [ next>> ] bi 2array { f f } assert= ;
|
[ prev>> ] [ next>> ] bi 2array { f f } assert= ;
|
||||||
|
|
||||||
{ V{ } } [ <dlist> 1 <my-node> over push-node-back [ [ back>> ] [ ] bi delete-node ] [ ] bi dlist>sequence ] unit-test
|
{ V{ } } [ <dlist> 1 <my-node> over push-node-back [ [ back>> ] [ ] bi delete-node ] [ ] bi dlist>sequence ] unit-test
|
||||||
[ V{ 1 2 } t ] [| |
|
[ V{ 1 2 } t ] |[ |
|
||||||
<dlist> :> dl
|
<dlist> :> dl
|
||||||
1 <my-node> :> n1 n1 dl push-node-back
|
1 <my-node> :> n1 n1 dl push-node-back
|
||||||
2 <my-node> :> n2 n2 dl push-node-back
|
2 <my-node> :> n2 n2 dl push-node-back
|
||||||
|
|
@ -127,7 +127,7 @@ TUPLE: my-node < dlist-link { obj fixnum } ;
|
||||||
dl dlist>sequence dup >dlist dl =
|
dl dlist>sequence dup >dlist dl =
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ V{ 1 3 } t ] [| |
|
[ V{ 1 3 } t ] |[ |
|
||||||
<dlist> :> dl
|
<dlist> :> dl
|
||||||
1 <my-node> :> n1 n1 dl push-node-back
|
1 <my-node> :> n1 n1 dl push-node-back
|
||||||
2 <my-node> :> n2 n2 dl push-node-back
|
2 <my-node> :> n2 n2 dl push-node-back
|
||||||
|
|
@ -137,7 +137,7 @@ TUPLE: my-node < dlist-link { obj fixnum } ;
|
||||||
dl dlist>sequence dup >dlist dl =
|
dl dlist>sequence dup >dlist dl =
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ V{ 2 3 } t ] [| |
|
[ V{ 2 3 } t ] |[ |
|
||||||
<dlist> :> dl
|
<dlist> :> dl
|
||||||
1 <my-node> :> n1 n1 dl push-node-back
|
1 <my-node> :> n1 n1 dl push-node-back
|
||||||
2 <my-node> :> n2 n2 dl push-node-back
|
2 <my-node> :> n2 n2 dl push-node-back
|
||||||
|
|
|
||||||
|
|
@ -63,7 +63,7 @@ PRIVATE>
|
||||||
! Makes 2array keys
|
! Makes 2array keys
|
||||||
[
|
[
|
||||||
alist sort-keys unclip swap [ first2 dupd ] dip
|
alist sort-keys unclip swap [ first2 dupd ] dip
|
||||||
[| oldkey oldval key val | ! Underneath is start
|
|[ oldkey oldval key val | ! Underneath is start
|
||||||
oldkey 1 + key =
|
oldkey 1 + key =
|
||||||
oldval val = and
|
oldval val = and
|
||||||
[ oldkey 2array oldval 2array , key ] unless
|
[ oldkey 2array oldval 2array , key ] unless
|
||||||
|
|
|
||||||
|
|
@ -18,7 +18,7 @@ PRIVATE>
|
||||||
|
|
||||||
:: random-lines ( n -- lines )
|
:: random-lines ( n -- lines )
|
||||||
V{ } clone :> accum
|
V{ } clone :> accum
|
||||||
[| line line# |
|
|[ line line# |
|
||||||
line# n <= [
|
line# n <= [
|
||||||
line accum push
|
line accum push
|
||||||
] [
|
] [
|
||||||
|
|
|
||||||
|
|
@ -36,9 +36,9 @@ CONSTANT: 256colors H{
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
! Add the RGB colors
|
! Add the RGB colors
|
||||||
intensities [| r i |
|
intensities |[ r i |
|
||||||
intensities [| g j |
|
intensities |[ g j |
|
||||||
intensities [| b k |
|
intensities |[ b k |
|
||||||
i 36 * j 6 * + k + 16 +
|
i 36 * j 6 * + k + 16 +
|
||||||
r g b 3array
|
r g b 3array
|
||||||
256colors set-at
|
256colors set-at
|
||||||
|
|
|
||||||
|
|
@ -20,7 +20,7 @@ TUPLE: pool
|
||||||
|
|
||||||
:: copy-tuple ( from to -- to )
|
:: copy-tuple ( from to -- to )
|
||||||
from tuple-size :> size
|
from tuple-size :> size
|
||||||
size [| n | n from array-nth n to set-array-nth ] each-integer
|
size |[ n | n from array-nth n to set-array-nth ] each-integer
|
||||||
to ; inline
|
to ; inline
|
||||||
|
|
||||||
: (pool-new) ( pool -- object )
|
: (pool-new) ( pool -- object )
|
||||||
|
|
|
||||||
|
|
@ -87,7 +87,7 @@ M: hash-0-b hashcode* 2drop 0 ;
|
||||||
: random-assocs ( n -- hash phash )
|
: random-assocs ( n -- hash phash )
|
||||||
[ random-string ] replicate
|
[ random-string ] replicate
|
||||||
[ H{ } clone [ '[ swap _ set-at ] each-index ] keep ]
|
[ H{ } clone [ '[ swap _ set-at ] each-index ] keep ]
|
||||||
[ PH{ } clone swap [| ph elt i | i elt ph new-at ] each-index ]
|
[ PH{ } clone swap |[ ph elt i | i elt ph new-at ] each-index ]
|
||||||
bi ;
|
bi ;
|
||||||
|
|
||||||
: ok? ( assoc1 assoc2 -- ? )
|
: ok? ( assoc1 assoc2 -- ? )
|
||||||
|
|
|
||||||
|
|
@ -44,7 +44,7 @@ M: persistent-hash keys >alist [ first ] map ;
|
||||||
M: persistent-hash values >alist [ second ] map ;
|
M: persistent-hash values >alist [ second ] map ;
|
||||||
|
|
||||||
:: >persistent-hash ( assoc -- phash )
|
:: >persistent-hash ( assoc -- phash )
|
||||||
T{ persistent-hash } assoc [| ph k v | v k ph new-at ] assoc-each ;
|
T{ persistent-hash } assoc |[ ph k v | v k ph new-at ] assoc-each ;
|
||||||
|
|
||||||
M: persistent-hash equal?
|
M: persistent-hash equal?
|
||||||
over persistent-hash? [ assoc= ] [ 2drop f ] if ;
|
over persistent-hash? [ assoc= ] [ 2drop f ] if ;
|
||||||
|
|
|
||||||
|
|
@ -68,8 +68,8 @@ in: sequences.extras
|
||||||
0 :> n!
|
0 :> n!
|
||||||
0 :> end!
|
0 :> end!
|
||||||
len1 1 + [ len2 1 + 0 <array> ] replicate :> table
|
len1 1 + [ len2 1 + 0 <array> ] replicate :> table
|
||||||
len1 [1,b] [| x |
|
len1 [1,b] |[ x |
|
||||||
len2 [1,b] [| y |
|
len2 [1,b] |[ y |
|
||||||
x 1 - seq1 nth-unsafe
|
x 1 - seq1 nth-unsafe
|
||||||
y 1 - seq2 nth-unsafe = [
|
y 1 - seq2 nth-unsafe = [
|
||||||
y 1 - x 1 - table nth-unsafe nth-unsafe 1 + :> len
|
y 1 - x 1 - table nth-unsafe nth-unsafe 1 + :> len
|
||||||
|
|
|
||||||
|
|
@ -62,7 +62,7 @@ M: product-sequence nth
|
||||||
:: product-map-as ( ... sequences quot: ( ... seq -- ... value ) exemplar -- ... sequence )
|
:: product-map-as ( ... sequences quot: ( ... seq -- ... value ) exemplar -- ... sequence )
|
||||||
0 :> i!
|
0 :> i!
|
||||||
sequences product-length exemplar
|
sequences product-length exemplar
|
||||||
[| result |
|
|[ result |
|
||||||
sequences [ quot call i result set-nth-unsafe i 1 + i! ] product-each
|
sequences [ quot call i result set-nth-unsafe i 1 + i! ] product-each
|
||||||
result
|
result
|
||||||
] new-like ; inline
|
] new-like ; inline
|
||||||
|
|
@ -73,7 +73,7 @@ M: product-sequence nth
|
||||||
:: product-map>assoc ( ... sequences quot: ( ... seq -- ... key value ) exemplar -- ... assoc )
|
:: product-map>assoc ( ... sequences quot: ( ... seq -- ... key value ) exemplar -- ... assoc )
|
||||||
0 :> i!
|
0 :> i!
|
||||||
sequences product-length { }
|
sequences product-length { }
|
||||||
[| result |
|
|[ result |
|
||||||
sequences [ quot call 2array i result set-nth-unsafe i 1 + i! ] product-each
|
sequences [ quot call 2array i result set-nth-unsafe i 1 + i! ] product-each
|
||||||
result
|
result
|
||||||
] new-like exemplar assoc-like ; inline
|
] new-like exemplar assoc-like ; inline
|
||||||
|
|
|
||||||
|
|
@ -17,7 +17,7 @@ use: delegate.private
|
||||||
<< forget: postpone\ :> >>
|
<< forget: postpone\ :> >>
|
||||||
<< forget: _ >>
|
<< forget: _ >>
|
||||||
<< forget: @ >>
|
<< forget: @ >>
|
||||||
<< forget: postpone\ [| >>
|
<< forget: postpone\ |[ >>
|
||||||
<< forget: postpone\ let[ >>
|
<< forget: postpone\ let[ >>
|
||||||
<< forget: postpone\ IH{ >>
|
<< forget: postpone\ IH{ >>
|
||||||
<< forget: postpone\ PROTOCOL: >>
|
<< forget: postpone\ PROTOCOL: >>
|
||||||
|
|
@ -45,7 +45,7 @@ SYNTAX: :>
|
||||||
in-lambda? get [ :>-outside-lambda-error ] unless
|
in-lambda? get [ :>-outside-lambda-error ] unless
|
||||||
scan-token parse-def suffix! ;
|
scan-token parse-def suffix! ;
|
||||||
|
|
||||||
SYNTAX: [| parse-lambda append! ;
|
SYNTAX: |[ parse-lambda append! ;
|
||||||
|
|
||||||
SYNTAX: let[ parse-let append! ;
|
SYNTAX: let[ parse-let append! ;
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -106,18 +106,12 @@ in: bootstrap.syntax
|
||||||
"read-only"
|
"read-only"
|
||||||
"call("
|
"call("
|
||||||
"execute("
|
"execute("
|
||||||
"<<<<<<"
|
|
||||||
"======"
|
|
||||||
">>>>>>"
|
|
||||||
"<<<<<<<"
|
|
||||||
"======="
|
|
||||||
">>>>>>>"
|
|
||||||
"\""
|
"\""
|
||||||
"P\""
|
"P\""
|
||||||
"SBUF\""
|
"SBUF\""
|
||||||
|
|
||||||
"::" "M::" "MEMO:" "MEMO::" "MACRO:" "MACRO::" "IDENTITY-MEMO:" "IDENTITY-MEMO::" "TYPED:" "TYPED::"
|
"::" "M::" "MEMO:" "MEMO::" "MACRO:" "MACRO::" "IDENTITY-MEMO:" "IDENTITY-MEMO::" "TYPED:" "TYPED::"
|
||||||
":>" "[|" "let[" "MEMO["
|
":>" "|[" "let[" "MEMO["
|
||||||
"'["
|
"'["
|
||||||
"_"
|
"_"
|
||||||
"@"
|
"@"
|
||||||
|
|
|
||||||
|
|
@ -70,10 +70,10 @@ ARTICLE: "fry.philosophy" "Fried quotation philosophy"
|
||||||
"'[ [ _ key? ] all? ] filter"
|
"'[ [ _ key? ] all? ] filter"
|
||||||
"[ [ key? ] curry all? ] curry filter"
|
"[ [ key? ] curry all? ] curry filter"
|
||||||
}
|
}
|
||||||
"There is a mapping from fried quotations to lexical closures as defined in the " { $vocab-link "locals" } " vocabulary. Namely, a fried quotation is equivalent to a " { $snippet "[| | ]" } " form where each local binding is only used once, and bindings are used in the same order in which they are defined. The following two lines are equivalent:"
|
"There is a mapping from fried quotations to lexical closures as defined in the " { $vocab-link "locals" } " vocabulary. Namely, a fried quotation is equivalent to a " { $snippet "|[ | ]" } " form where each local binding is only used once, and bindings are used in the same order in which they are defined. The following two lines are equivalent:"
|
||||||
{ $code
|
{ $code
|
||||||
"'[ 3 _ + 4 _ / ]"
|
"'[ 3 _ + 4 _ / ]"
|
||||||
"[| a b | 3 a + 4 b / ]"
|
"|[ a b | 3 a + 4 b / ]"
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
ARTICLE: "fry" "Fried quotations"
|
ARTICLE: "fry" "Fried quotations"
|
||||||
|
|
|
||||||
|
|
@ -42,7 +42,7 @@ specialized-array: int
|
||||||
[ " " read-until [ ascii decode ] dip ] with-file-reader
|
[ " " read-until [ ascii decode ] dip ] with-file-reader
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[| path |
|
|[ path |
|
||||||
{ } [
|
{ } [
|
||||||
"It seems Jobs has lost his grasp on reality again.\n"
|
"It seems Jobs has lost his grasp on reality again.\n"
|
||||||
path latin1 set-file-contents
|
path latin1 set-file-contents
|
||||||
|
|
@ -72,7 +72,7 @@ specialized-array: int
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
! Writing specialized arrays to binary streams should work
|
! Writing specialized arrays to binary streams should work
|
||||||
[| path |
|
|[ path |
|
||||||
{ } [
|
{ } [
|
||||||
path binary [
|
path binary [
|
||||||
int-array{ 1 2 3 } write
|
int-array{ 1 2 3 } write
|
||||||
|
|
@ -87,7 +87,7 @@ specialized-array: int
|
||||||
] unit-test
|
] unit-test
|
||||||
] with-test-file
|
] with-test-file
|
||||||
|
|
||||||
[| path |
|
|[ path |
|
||||||
{ } [
|
{ } [
|
||||||
BV{ 0 1 2 } path binary set-file-contents
|
BV{ 0 1 2 } path binary set-file-contents
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
@ -104,7 +104,7 @@ specialized-array: pt
|
||||||
CONSTANT: pt-array-1
|
CONSTANT: pt-array-1
|
||||||
pt-array{ S{ pt f 1 1 } S{ pt f 2 2 } S{ pt f 3 3 } } ;
|
pt-array{ S{ pt f 1 1 } S{ pt f 2 2 } S{ pt f 3 3 } } ;
|
||||||
|
|
||||||
[| path |
|
|[ path |
|
||||||
{ } [
|
{ } [
|
||||||
pt-array-1 path binary set-file-contents
|
pt-array-1 path binary set-file-contents
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
@ -116,7 +116,7 @@ CONSTANT: pt-array-1
|
||||||
] with-test-file
|
] with-test-file
|
||||||
|
|
||||||
! Slices should support >c-ptr and byte-length
|
! Slices should support >c-ptr and byte-length
|
||||||
[| path |
|
|[ path |
|
||||||
{ } [
|
{ } [
|
||||||
pt-array-1 rest-slice
|
pt-array-1 rest-slice
|
||||||
path binary set-file-contents
|
path binary set-file-contents
|
||||||
|
|
@ -136,7 +136,7 @@ CONSTANT: pt-array-1
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
! Writing strings to binary streams should fail
|
! Writing strings to binary streams should fail
|
||||||
[| path |
|
|[ path |
|
||||||
[
|
[
|
||||||
path binary [ "OMGFAIL" write ] with-file-writer
|
path binary [ "OMGFAIL" write ] with-file-writer
|
||||||
] must-fail
|
] must-fail
|
||||||
|
|
@ -166,7 +166,7 @@ CONSTANT: pt-array-1
|
||||||
] with-test-directory
|
] with-test-directory
|
||||||
|
|
||||||
! File seeking tests
|
! File seeking tests
|
||||||
[| path |
|
|[ path |
|
||||||
{ B{ 3 2 3 4 5 } } [
|
{ B{ 3 2 3 4 5 } } [
|
||||||
path binary [
|
path binary [
|
||||||
B{ 1 2 3 4 5 } write
|
B{ 1 2 3 4 5 } write
|
||||||
|
|
@ -179,7 +179,7 @@ CONSTANT: pt-array-1
|
||||||
] unit-test
|
] unit-test
|
||||||
] with-test-file
|
] with-test-file
|
||||||
|
|
||||||
[| path |
|
|[ path |
|
||||||
{ B{ 1 2 3 4 3 } } [
|
{ B{ 1 2 3 4 3 } } [
|
||||||
path binary [
|
path binary [
|
||||||
B{ 1 2 3 4 5 } write
|
B{ 1 2 3 4 5 } write
|
||||||
|
|
@ -192,7 +192,7 @@ CONSTANT: pt-array-1
|
||||||
] unit-test
|
] unit-test
|
||||||
] with-test-file
|
] with-test-file
|
||||||
|
|
||||||
[| path |
|
|[ path |
|
||||||
{ B{ 1 2 3 4 5 0 3 } } [
|
{ B{ 1 2 3 4 5 0 3 } } [
|
||||||
path binary [
|
path binary [
|
||||||
B{ 1 2 3 4 5 } write
|
B{ 1 2 3 4 5 } write
|
||||||
|
|
@ -205,7 +205,7 @@ CONSTANT: pt-array-1
|
||||||
] unit-test
|
] unit-test
|
||||||
] with-test-file
|
] with-test-file
|
||||||
|
|
||||||
[| path |
|
|[ path |
|
||||||
{ B{ 3 } } [
|
{ B{ 3 } } [
|
||||||
B{ 1 2 3 4 5 } path binary set-file-contents
|
B{ 1 2 3 4 5 } path binary set-file-contents
|
||||||
path binary [
|
path binary [
|
||||||
|
|
@ -218,7 +218,7 @@ CONSTANT: pt-array-1
|
||||||
] unit-test
|
] unit-test
|
||||||
] with-test-file
|
] with-test-file
|
||||||
|
|
||||||
[| path |
|
|[ path |
|
||||||
|
|
||||||
{ B{ 2 } } [
|
{ B{ 2 } } [
|
||||||
B{ 1 2 3 4 5 } path binary set-file-contents
|
B{ 1 2 3 4 5 } path binary set-file-contents
|
||||||
|
|
@ -249,17 +249,17 @@ CONSTANT: pt-array-1
|
||||||
] with-file-reader
|
] with-file-reader
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[| path |
|
|[ path |
|
||||||
[ path ascii [ { 129 } write ] with-file-writer ]
|
[ path ascii [ { 129 } write ] with-file-writer ]
|
||||||
[ encode-error? ] must-fail-with
|
[ encode-error? ] must-fail-with
|
||||||
] with-test-file
|
] with-test-file
|
||||||
|
|
||||||
[| path |
|
|[ path |
|
||||||
{ }
|
{ }
|
||||||
[ path ascii [ { } write ] with-file-writer ] unit-test
|
[ path ascii [ { } write ] with-file-writer ] unit-test
|
||||||
] with-test-file
|
] with-test-file
|
||||||
|
|
||||||
[| path |
|
|[ path |
|
||||||
[ path binary [ "" write ] with-file-writer ]
|
[ path binary [ "" write ] with-file-writer ]
|
||||||
[ no-method? ] must-fail-with
|
[ no-method? ] must-fail-with
|
||||||
] with-test-file
|
] with-test-file
|
||||||
|
|
|
||||||
|
|
@ -52,7 +52,7 @@ system tools.test ;
|
||||||
{ t } [ "resource:core" absolute-path? ] unit-test
|
{ t } [ "resource:core" absolute-path? ] unit-test
|
||||||
{ f } [ "" absolute-path? ] unit-test
|
{ f } [ "" absolute-path? ] unit-test
|
||||||
|
|
||||||
[| path |
|
|[ path |
|
||||||
{ } [ 2 [ path touch-file ] times ] unit-test
|
{ } [ 2 [ path touch-file ] times ] unit-test
|
||||||
] with-test-file
|
] with-test-file
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -22,7 +22,7 @@ M: local-writer-in-literal-error summary
|
||||||
ERROR: :>-outside-lambda-error ;
|
ERROR: :>-outside-lambda-error ;
|
||||||
|
|
||||||
M: :>-outside-lambda-error summary
|
M: :>-outside-lambda-error summary
|
||||||
drop ":> cannot be used outside of let[, [|, or :: forms" ;
|
drop ":> cannot be used outside of let[, |[, or :: forms" ;
|
||||||
|
|
||||||
ERROR: bad-local args obj ;
|
ERROR: bad-local args obj ;
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -2,8 +2,8 @@ USING: help.syntax help.markup kernel macros prettyprint
|
||||||
memoize combinators arrays generalizations see ;
|
memoize combinators arrays generalizations see ;
|
||||||
in: locals
|
in: locals
|
||||||
|
|
||||||
HELP: \ [|
|
HELP: \ |[
|
||||||
{ $syntax "[| bindings... | body... ]" }
|
{ $syntax "|[ bindings... | body... ]" }
|
||||||
{ $description "A literal quotation with named variable bindings. When the quotation is " { $link call } "ed, it will take values off the datastack and place them into the bindings from left to right. The body may then refer to these bindings. The quotation may also bind to named variables in an enclosing scope to create a closure." }
|
{ $description "A literal quotation with named variable bindings. When the quotation is " { $link call } "ed, it will take values off the datastack and place them into the bindings from left to right. The body may then refer to these bindings. The quotation may also bind to named variables in an enclosing scope to create a closure." }
|
||||||
{ $examples "See " { $link "locals-examples" } "." } ;
|
{ $examples "See " { $link "locals-examples" } "." } ;
|
||||||
|
|
||||||
|
|
@ -22,7 +22,7 @@ $nl
|
||||||
$nl
|
$nl
|
||||||
"If any " { $snippet "var" } " name is followed by an exclamation point (" { $snippet "!" } "), that new variable is mutable. See " { $link "locals-mutable" } " for more information." }
|
"If any " { $snippet "var" } " name is followed by an exclamation point (" { $snippet "!" } "), that new variable is mutable. See " { $link "locals-mutable" } " for more information." }
|
||||||
{ $notes
|
{ $notes
|
||||||
"This syntax can only be used inside a lexical scope established by a " { $link postpone\ :: } " definition, " { $link postpone\ let[ } " form, or " { $link postpone\ [| } " quotation. Normal quotations have their own lexical scope only if they are inside an outer scope. Definition forms such as " { $link postpone\ : } " do not establish a lexical scope by themselves unless documented otherwise, nor is there a lexical scope available at the top level of source files or in the listener. " { $link postpone\ let[ } " can be used to create a lexical scope where one is not otherwise available." }
|
"This syntax can only be used inside a lexical scope established by a " { $link postpone\ :: } " definition, " { $link postpone\ let[ } " form, or " { $link postpone\ |[ } " quotation. Normal quotations have their own lexical scope only if they are inside an outer scope. Definition forms such as " { $link postpone\ : } " do not establish a lexical scope by themselves unless documented otherwise, nor is there a lexical scope available at the top level of source files or in the listener. " { $link postpone\ let[ } " can be used to create a lexical scope where one is not otherwise available." }
|
||||||
{ $examples "See " { $link "locals-examples" } "." } ;
|
{ $examples "See " { $link "locals-examples" } "." } ;
|
||||||
|
|
||||||
{ postpone\ let[ postpone\ :> } related-words
|
{ postpone\ let[ postpone\ :> } related-words
|
||||||
|
|
@ -92,11 +92,11 @@ let[ 1.0 :> a 1.0 :> b -6.0 :> c
|
||||||
$nl
|
$nl
|
||||||
|
|
||||||
{ $heading "Quotations with lexical variables, and closures" }
|
{ $heading "Quotations with lexical variables, and closures" }
|
||||||
"These next two examples demonstrate lexical variable bindings in quotations defined with " { $link postpone\ [| } ". In this example, the values " { $snippet "5" } " and " { $snippet "3" } " are put on the datastack. When the quotation is called, it takes those values as inputs and binds them respectively to " { $snippet "m" } " and " { $snippet "n" } " before executing the quotation:"
|
"These next two examples demonstrate lexical variable bindings in quotations defined with " { $link postpone\ |[ } ". In this example, the values " { $snippet "5" } " and " { $snippet "3" } " are put on the datastack. When the quotation is called, it takes those values as inputs and binds them respectively to " { $snippet "m" } " and " { $snippet "n" } " before executing the quotation:"
|
||||||
{ $example
|
{ $example
|
||||||
"USING: kernel locals math prettyprint ;"
|
"USING: kernel locals math prettyprint ;"
|
||||||
"in: scratchpad"
|
"in: scratchpad"
|
||||||
"5 3 [| m n | m n - ] call ."
|
"5 3 |[ m n | m n - ] call ."
|
||||||
"2"
|
"2"
|
||||||
}
|
}
|
||||||
$nl
|
$nl
|
||||||
|
|
@ -105,7 +105,7 @@ $nl
|
||||||
{ $example
|
{ $example
|
||||||
"USING: kernel locals math prettyprint ;"
|
"USING: kernel locals math prettyprint ;"
|
||||||
"in: scratchpad"
|
"in: scratchpad"
|
||||||
":: adder ( n -- quot ) [| m | m n + ] ;"
|
":: adder ( n -- quot ) |[ m | m n + ] ;"
|
||||||
"3 5 adder call ."
|
"3 5 adder call ."
|
||||||
"8"
|
"8"
|
||||||
}
|
}
|
||||||
|
|
@ -207,7 +207,7 @@ $nl
|
||||||
"One exception to the above rule is that array instances containing free lexical variables (that is, immutable lexical variables not referenced in a closure) do retain identity. This allows macros such as " { $link cond } " to expand at compile time even when their arguments reference variables." ;
|
"One exception to the above rule is that array instances containing free lexical variables (that is, immutable lexical variables not referenced in a closure) do retain identity. This allows macros such as " { $link cond } " to expand at compile time even when their arguments reference variables." ;
|
||||||
|
|
||||||
ARTICLE: "locals-mutable" "Mutable lexical variables"
|
ARTICLE: "locals-mutable" "Mutable lexical variables"
|
||||||
"When a lexical variable is bound using " { $link postpone\ :> } ", " { $link postpone\ :: } ", or " { $link postpone\ [| } ", the variable may be made mutable by suffixing its name with an exclamation point (" { $snippet "!" } "). A mutable variable's value is read by giving its name without the exclamation point as usual. To write to the variable, use its name with the " { $snippet "!" } " suffix."
|
"When a lexical variable is bound using " { $link postpone\ :> } ", " { $link postpone\ :: } ", or " { $link postpone\ |[ } ", the variable may be made mutable by suffixing its name with an exclamation point (" { $snippet "!" } "). A mutable variable's value is read by giving its name without the exclamation point as usual. To write to the variable, use its name with the " { $snippet "!" } " suffix."
|
||||||
$nl
|
$nl
|
||||||
"Mutable bindings are implemented in a manner similar to that taken by the ML language. Each mutable binding is actually an immutable binding of a mutable cell. Reading the binding automatically unboxes the value from the cell, and writing to the binding stores into it."
|
"Mutable bindings are implemented in a manner similar to that taken by the ML language. Each mutable binding is actually an immutable binding of a mutable cell. Reading the binding automatically unboxes the value from the cell, and writing to the binding stores into it."
|
||||||
$nl
|
$nl
|
||||||
|
|
@ -224,16 +224,16 @@ $nl
|
||||||
"Conceptually, " { $link curry } " is defined so that the following two code snippets are equivalent:"
|
"Conceptually, " { $link curry } " is defined so that the following two code snippets are equivalent:"
|
||||||
{ $code "3 [ - ] curry" }
|
{ $code "3 [ - ] curry" }
|
||||||
{ $code "[ 3 - ]" }
|
{ $code "[ 3 - ]" }
|
||||||
"When quotations take named parameters using " { $link postpone\ [| } ", " { $link curry } " fills in the variable bindings from right to left. The following two snippets are equivalent:"
|
"When quotations take named parameters using " { $link postpone\ |[ } ", " { $link curry } " fills in the variable bindings from right to left. The following two snippets are equivalent:"
|
||||||
{ $code "3 [| a b | a b - ] curry" }
|
{ $code "3 |[ a b | a b - ] curry" }
|
||||||
{ $code "[| a | a 3 - ]" }
|
{ $code "|[ a | a 3 - ]" }
|
||||||
"Because of this, the behavior of " { $snippet "fry" } " changes when applied to such a quotation to ensure that fry conceptually behaves the same as with normal quotations, placing the fried values “underneath” the variable bindings. Thus, the following snippets are no longer equivalent:"
|
"Because of this, the behavior of " { $snippet "fry" } " changes when applied to such a quotation to ensure that fry conceptually behaves the same as with normal quotations, placing the fried values “underneath” the variable bindings. Thus, the following snippets are no longer equivalent:"
|
||||||
{ $code "'[ [| a | _ a - ] ]" }
|
{ $code "'[ |[ a | _ a - ] ]" }
|
||||||
{ $code "'[ [| a | a - ] curry ] call" }
|
{ $code "'[ |[ a | a - ] curry ] call" }
|
||||||
"Instead, the first line above expands into something like the following:"
|
"Instead, the first line above expands into something like the following:"
|
||||||
{ $code "[ [ swap [| a | a - ] ] curry call ]" }
|
{ $code "[ [ swap |[ a | a - ] ] curry call ]" }
|
||||||
$nl
|
$nl
|
||||||
"The precise behavior is as follows. When frying a " { $link postpone\ [| } " quotation, a stack shuffle (" { $link mnswap } ") is prepended so that the " { $snippet "m" } " curried values, which start off at the top of the stack, are transposed with the quotation's " { $snippet "n" } " named input bindings." ;
|
"The precise behavior is as follows. When frying a " { $link postpone\ |[ } " quotation, a stack shuffle (" { $link mnswap } ") is prepended so that the " { $snippet "m" } " curried values, which start off at the top of the stack, are transposed with the quotation's " { $snippet "n" } " named input bindings." ;
|
||||||
|
|
||||||
ARTICLE: "locals-limitations" "Limitations of lexical variables"
|
ARTICLE: "locals-limitations" "Limitations of lexical variables"
|
||||||
"There are two main limitations of the current implementation, and both concern macros."
|
"There are two main limitations of the current implementation, and both concern macros."
|
||||||
|
|
@ -293,7 +293,7 @@ ARTICLE: "locals" "Lexical variables"
|
||||||
postpone\ :>
|
postpone\ :>
|
||||||
}
|
}
|
||||||
"Quotation literals where the inputs are bound to lexical variables:"
|
"Quotation literals where the inputs are bound to lexical variables:"
|
||||||
{ $subsections postpone\ [| }
|
{ $subsections postpone\ |[ }
|
||||||
"Additional topics:"
|
"Additional topics:"
|
||||||
{ $subsections
|
{ $subsections
|
||||||
"locals-literals"
|
"locals-literals"
|
||||||
|
|
|
||||||
|
|
@ -22,7 +22,7 @@ in: locals.tests
|
||||||
|
|
||||||
{ { 5 6 7 } } [ { 1 2 3 } 4 map-test ] unit-test
|
{ { 5 6 7 } } [ { 1 2 3 } 4 map-test ] unit-test
|
||||||
|
|
||||||
:: map-test-2 ( seq inc -- seq ) seq [| elt | elt inc + ] map ;
|
:: map-test-2 ( seq inc -- seq ) seq |[ elt | elt inc + ] map ;
|
||||||
|
|
||||||
{ { 5 6 7 } } [ { 1 2 3 } 4 map-test-2 ] unit-test
|
{ { 5 6 7 } } [ { 1 2 3 } 4 map-test-2 ] unit-test
|
||||||
|
|
||||||
|
|
@ -57,7 +57,7 @@ in: locals.tests
|
||||||
{ -1 } [ -1 let-test-3 call ] unit-test
|
{ -1 } [ -1 let-test-3 call ] unit-test
|
||||||
|
|
||||||
:: write-test-1 ( n! -- q )
|
:: write-test-1 ( n! -- q )
|
||||||
[| i | n i + dup n! ] ;
|
|[ i | n i + dup n! ] ;
|
||||||
|
|
||||||
0 write-test-1 "q" set
|
0 write-test-1 "q" set
|
||||||
|
|
||||||
|
|
@ -72,7 +72,7 @@ in: locals.tests
|
||||||
{ 5 } [ 2 "q" get call ] unit-test
|
{ 5 } [ 2 "q" get call ] unit-test
|
||||||
|
|
||||||
:: write-test-2 ( -- q )
|
:: write-test-2 ( -- q )
|
||||||
let[ 0 :> n! [| i | n i + dup n! ] ] ;
|
let[ 0 :> n! |[ i | n i + dup n! ] ] ;
|
||||||
|
|
||||||
write-test-2 "q" set
|
write-test-2 "q" set
|
||||||
|
|
||||||
|
|
@ -86,10 +86,10 @@ write-test-2 "q" set
|
||||||
|
|
||||||
{ 10 20 }
|
{ 10 20 }
|
||||||
[
|
[
|
||||||
20 10 [| a! | [| b! | a b ] ] call call
|
20 10 |[ a! | |[ b! | a b ] ] call call
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
:: write-test-3 ( a! -- q ) [| b | b a! ] ;
|
:: write-test-3 ( a! -- q ) |[ b | b a! ] ;
|
||||||
|
|
||||||
{ } [ 1 2 write-test-3 call ] unit-test
|
{ } [ 1 2 write-test-3 call ] unit-test
|
||||||
|
|
||||||
|
|
@ -141,9 +141,9 @@ M:: string lambda-generic ( a b -- c ) a b lambda-generic-2 ;
|
||||||
\ unparse-test-1 "lambda" word-prop body>> first unparse
|
\ unparse-test-1 "lambda" word-prop body>> first unparse
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
:: unparse-test-3 ( -- b ) [| a! | ] ;
|
:: unparse-test-3 ( -- b ) |[ a! | ] ;
|
||||||
|
|
||||||
{ "[| a! | ]" } [
|
{ "|[ a! | ]" } [
|
||||||
\ unparse-test-3 "lambda" word-prop body>> first unparse
|
\ unparse-test-3 "lambda" word-prop body>> first unparse
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
|
@ -171,11 +171,11 @@ M:: fixnum next-method-test ( a -- b ) a call-next-method 1 + ;
|
||||||
|
|
||||||
{ 5 } [ 1 next-method-test ] unit-test
|
{ 5 } [ 1 next-method-test ] unit-test
|
||||||
|
|
||||||
: no-with-locals-test ( -- seq ) { 1 2 3 } [| x | x 3 + ] map ;
|
: no-with-locals-test ( -- seq ) { 1 2 3 } |[ x | x 3 + ] map ;
|
||||||
|
|
||||||
{ { 4 5 6 } } [ no-with-locals-test ] unit-test
|
{ { 4 5 6 } } [ no-with-locals-test ] unit-test
|
||||||
|
|
||||||
{ 3 0 } [| a b c | ] must-infer-as
|
{ 3 0 } |[ a b c | ] must-infer-as
|
||||||
|
|
||||||
{ } [ 1 let[ :> a ] ] unit-test
|
{ } [ 1 let[ :> a ] ] unit-test
|
||||||
|
|
||||||
|
|
@ -262,27 +262,27 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
|
||||||
|
|
||||||
{ { 10 20 } } [ let-and-cond-test-2 ] unit-test
|
{ { 10 20 } } [ let-and-cond-test-2 ] unit-test
|
||||||
|
|
||||||
{ { 10 } } [ 10 [| a | { a } ] call ] unit-test
|
{ { 10 } } [ 10 |[ a | { a } ] call ] unit-test
|
||||||
{ { 10 20 } } [ 10 20 [| a b | { a b } ] call ] unit-test
|
{ { 10 20 } } [ 10 20 |[ a b | { a b } ] call ] unit-test
|
||||||
{ { 10 20 30 } } [ 10 20 30 [| a b c | { a b c } ] call ] unit-test
|
{ { 10 20 30 } } [ 10 20 30 |[ a b c | { a b c } ] call ] unit-test
|
||||||
|
|
||||||
{ { 10 20 30 } } [ let[ 10 :> a 20 :> b 30 :> c { a b c } ] ] unit-test
|
{ { 10 20 30 } } [ let[ 10 :> a 20 :> b 30 :> c { a b c } ] ] unit-test
|
||||||
|
|
||||||
{ V{ 10 20 30 } } [ 10 20 30 [| a b c | V{ a b c } ] call ] unit-test
|
{ V{ 10 20 30 } } [ 10 20 30 |[ a b c | V{ a b c } ] call ] unit-test
|
||||||
|
|
||||||
{ H{ { 10 "a" } { 20 "b" } { 30 "c" } } }
|
{ H{ { 10 "a" } { 20 "b" } { 30 "c" } } }
|
||||||
[ 10 20 30 [| a b c | H{ { a "a" } { b "b" } { c "c" } } ] call ] unit-test
|
[ 10 20 30 |[ a b c | H{ { a "a" } { b "b" } { c "c" } } ] call ] unit-test
|
||||||
|
|
||||||
TUPLE: test-tuple a b c ;
|
TUPLE: test-tuple a b c ;
|
||||||
|
|
||||||
{ T{ test-tuple f 0 3 "abc" } }
|
{ T{ test-tuple f 0 3 "abc" } }
|
||||||
[ 0 3 "abc" [| a b c | T{ test-tuple f a b c } ] call ] unit-test
|
[ 0 3 "abc" |[ a b c | T{ test-tuple f a b c } ] call ] unit-test
|
||||||
|
|
||||||
{ 3 1 } [| a b c | T{ test-tuple f a b c } ] must-infer-as
|
{ 3 1 } |[ a b c | T{ test-tuple f a b c } ] must-infer-as
|
||||||
|
|
||||||
ERROR: punned-class x ;
|
ERROR: punned-class x ;
|
||||||
|
|
||||||
{ T{ punned-class f 3 } } [ 3 [| a | T{ punned-class f a } ] call ] unit-test
|
{ T{ punned-class f 3 } } [ 3 |[ a | T{ punned-class f a } ] call ] unit-test
|
||||||
|
|
||||||
:: literal-identity-test ( -- a b )
|
:: literal-identity-test ( -- a b )
|
||||||
{ 1 } V{ } ;
|
{ 1 } V{ } ;
|
||||||
|
|
@ -325,7 +325,7 @@ ERROR: punned-class x ;
|
||||||
{
|
{
|
||||||
{ t [ 3 ] }
|
{ t [ 3 ] }
|
||||||
{ f [ 4 ] }
|
{ f [ 4 ] }
|
||||||
[| x | x 12 + { "howdy" } nth ]
|
|[ x | x 12 + { "howdy" } nth ]
|
||||||
} case ;
|
} case ;
|
||||||
|
|
||||||
\ littledan-case-problem-1 def>> must-infer
|
\ littledan-case-problem-1 def>> must-infer
|
||||||
|
|
@ -337,7 +337,7 @@ ERROR: punned-class x ;
|
||||||
a {
|
a {
|
||||||
{ t [ a not ] }
|
{ t [ a not ] }
|
||||||
{ f [ 4 ] }
|
{ f [ 4 ] }
|
||||||
[| x | x a - { "howdy" } nth ]
|
|[ x | x a - { "howdy" } nth ]
|
||||||
} case ;
|
} case ;
|
||||||
|
|
||||||
\ littledan-case-problem-2 def>> must-infer
|
\ littledan-case-problem-2 def>> must-infer
|
||||||
|
|
@ -348,8 +348,8 @@ ERROR: punned-class x ;
|
||||||
:: littledan-cond-problem-1 ( a -- b )
|
:: littledan-cond-problem-1 ( a -- b )
|
||||||
a {
|
a {
|
||||||
{ [ dup 0 < ] [ drop a not ] }
|
{ [ dup 0 < ] [ drop a not ] }
|
||||||
{ [| y | y y 0 > ] [ drop 4 ] }
|
{ |[ y | y y 0 > ] [ drop 4 ] }
|
||||||
[| x | x a - { "howdy" } nth ]
|
|[ x | x a - { "howdy" } nth ]
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
\ littledan-cond-problem-1 def>> must-infer
|
\ littledan-cond-problem-1 def>> must-infer
|
||||||
|
|
@ -371,7 +371,7 @@ ERROR: punned-class x ;
|
||||||
|
|
||||||
{ f } [ t [ ] littledan-case-problem-3 ] unit-test
|
{ f } [ t [ ] littledan-case-problem-3 ] unit-test
|
||||||
{ 144 } [ 12 [ sq ] littledan-case-problem-3 ] unit-test
|
{ 144 } [ 12 [ sq ] littledan-case-problem-3 ] unit-test
|
||||||
[| | [| a | a ] littledan-case-problem-3 ] must-infer
|
|[ | |[ a | a ] littledan-case-problem-3 ] must-infer
|
||||||
|
|
||||||
: littledan-case-problem-4 ( a -- b )
|
: littledan-case-problem-4 ( a -- b )
|
||||||
[ 1 + ] littledan-case-problem-3 ;
|
[ 1 + ] littledan-case-problem-3 ;
|
||||||
|
|
@ -385,7 +385,7 @@ M:: integer lambda-method-forget-test ( a -- b ) a ;
|
||||||
|
|
||||||
{ } [ [ M\ integer lambda-method-forget-test forget ] with-compilation-unit ] unit-test
|
{ } [ [ M\ integer lambda-method-forget-test forget ] with-compilation-unit ] unit-test
|
||||||
|
|
||||||
{ 10 } [ 10 [| A | { [ A ] } ] call first call ] unit-test
|
{ 10 } [ 10 |[ A | { [ A ] } ] call first call ] unit-test
|
||||||
|
|
||||||
[
|
[
|
||||||
"USING: locals fry math ; 1 '[ let[ 10 :> A A _ + ] ]"
|
"USING: locals fry math ; 1 '[ let[ 10 :> A A _ + ] ]"
|
||||||
|
|
@ -401,34 +401,34 @@ M:: integer lambda-method-forget-test ( a -- b ) a ;
|
||||||
{ f } [ 2 funny-macro-test ] unit-test
|
{ f } [ 2 funny-macro-test ] unit-test
|
||||||
|
|
||||||
[ "use: locals let[" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with
|
[ "use: locals let[" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with
|
||||||
[ "use: locals [|" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with
|
[ "use: locals |[" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with
|
||||||
|
|
||||||
{ 25 } [ 5 [| a | { [ a sq ] } cond ] call ] unit-test
|
{ 25 } [ 5 |[ a | { [ a sq ] } cond ] call ] unit-test
|
||||||
{ 25 } [ 5 [| | { [| a | a sq ] } ] call first call ] unit-test
|
{ 25 } [ 5 |[ | { |[ a | a sq ] } ] call first call ] unit-test
|
||||||
|
|
||||||
:: FAILdog-1 ( -- b ) { [| c | c ] } ;
|
:: FAILdog-1 ( -- b ) { |[ c | c ] } ;
|
||||||
|
|
||||||
\ FAILdog-1 def>> must-infer
|
\ FAILdog-1 def>> must-infer
|
||||||
|
|
||||||
:: FAILdog-2 ( a -- b ) a { [| c | c ] } cond ;
|
:: FAILdog-2 ( a -- b ) a { |[ c | c ] } cond ;
|
||||||
|
|
||||||
\ FAILdog-2 def>> must-infer
|
\ FAILdog-2 def>> must-infer
|
||||||
|
|
||||||
{ 3 } [ 3 [| a | \ a ] call ] unit-test
|
{ 3 } [ 3 |[ a | \ a ] call ] unit-test
|
||||||
|
|
||||||
[ "use: locals [| | { let[ 0 :> a a ] } ]" eval( -- ) ] must-fail
|
[ "use: locals |[ | { let[ 0 :> a a ] } ]" eval( -- ) ] must-fail
|
||||||
|
|
||||||
[ "use: locals [| | let[ 0 :> a! { a! } ] ]" eval( -- ) ] must-fail
|
[ "use: locals |[ | let[ 0 :> a! { a! } ] ]" eval( -- ) ] must-fail
|
||||||
|
|
||||||
[ "use: locals [| | { :> a } ]" eval( -- ) ] must-fail
|
[ "use: locals |[ | { :> a } ]" eval( -- ) ] must-fail
|
||||||
|
|
||||||
[ "use: locals 3 :> a" eval( -- ) ] must-fail
|
[ "use: locals 3 :> a" eval( -- ) ] must-fail
|
||||||
|
|
||||||
{ 3 } [ 3 [| | :> a a ] call ] unit-test
|
{ 3 } [ 3 |[ | :> a a ] call ] unit-test
|
||||||
|
|
||||||
{ 3 } [ 3 [| | :> a! a ] call ] unit-test
|
{ 3 } [ 3 |[ | :> a! a ] call ] unit-test
|
||||||
|
|
||||||
{ 3 } [ 2 [| | :> a! a 1 + a! a ] call ] unit-test
|
{ 3 } [ 2 |[ | :> a! a 1 + a! a ] call ] unit-test
|
||||||
|
|
||||||
: fry-locals-test-1 ( -- n )
|
: fry-locals-test-1 ( -- n )
|
||||||
let[ 6 '[ let[ 4 :> A A _ + ] ] call ] ;
|
let[ 6 '[ let[ 4 :> A A _ + ] ] call ] ;
|
||||||
|
|
@ -442,20 +442,20 @@ M:: integer lambda-method-forget-test ( a -- b ) a ;
|
||||||
\ fry-locals-test-2 def>> must-infer
|
\ fry-locals-test-2 def>> must-infer
|
||||||
{ 10 } [ fry-locals-test-2 ] unit-test
|
{ 10 } [ fry-locals-test-2 ] unit-test
|
||||||
|
|
||||||
{ 1 } [ 3 4 [| | '[ [ _ swap - ] call ] call ] call ] unit-test
|
{ 1 } [ 3 4 |[ | '[ [ _ swap - ] call ] call ] call ] unit-test
|
||||||
{ -1 } [ 3 4 [| | [| a | a - ] call ] call ] unit-test
|
{ -1 } [ 3 4 |[ | |[ a | a - ] call ] call ] unit-test
|
||||||
{ -1 } [ 3 4 [| | [| a | a - ] curry call ] call ] unit-test
|
{ -1 } [ 3 4 |[ | |[ a | a - ] curry call ] call ] unit-test
|
||||||
{ -1 } [ 3 4 [| a | a - ] curry call ] unit-test
|
{ -1 } [ 3 4 |[ a | a - ] curry call ] unit-test
|
||||||
{ 1 } [ 3 4 [| | '[ [| a | _ a - ] call ] call ] call ] unit-test
|
{ 1 } [ 3 4 |[ | '[ |[ a | _ a - ] call ] call ] call ] unit-test
|
||||||
{ -1 } [ 3 4 [| | '[ [| a | a _ - ] call ] call ] call ] unit-test
|
{ -1 } [ 3 4 |[ | '[ |[ a | a _ - ] call ] call ] call ] unit-test
|
||||||
|
|
||||||
{ { 1 2 3 4 } } [
|
{ { 1 2 3 4 } } [
|
||||||
1 3 2 4
|
1 3 2 4
|
||||||
[| | '[ [| a b | a _ b _ 4array ] call ] call ] call
|
|[ | '[ |[ a b | a _ b _ 4array ] call ] call ] call
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
{ 10 } [
|
{ 10 } [
|
||||||
[| | 0 '[ let[ 10 :> A A _ + ] ] call ] call
|
|[ | 0 '[ let[ 10 :> A A _ + ] ] call ] call
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
! littledan found this problem
|
! littledan found this problem
|
||||||
|
|
|
||||||
|
|
@ -6,7 +6,7 @@ locals.errors locals.types make quotations sequences vectors
|
||||||
words ;
|
words ;
|
||||||
in: locals.rewrite.sugar
|
in: locals.rewrite.sugar
|
||||||
|
|
||||||
! Step 1: rewrite [| into :> forms, turn
|
! Step 1: rewrite |[ into :> forms, turn
|
||||||
! literals with locals in them into code which constructs
|
! literals with locals in them into code which constructs
|
||||||
! the literal after pushing locals on the stack
|
! the literal after pushing locals on the stack
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -189,7 +189,7 @@ MACRO:: read-double-matched ( open-ch -- quot: ( n string tag ch -- n' string se
|
||||||
[ drop 1string ]
|
[ drop 1string ]
|
||||||
[ nip 2 swap <string> ]
|
[ nip 2 swap <string> ]
|
||||||
} 2cleave :> ( openstr2 openstr1 closestr2 )
|
} 2cleave :> ( openstr2 openstr1 closestr2 )
|
||||||
[| n string tag! ch |
|
|[ n string tag! ch |
|
||||||
ch {
|
ch {
|
||||||
{ char: = [
|
{ char: = [
|
||||||
n string openstr1 slice-til-separator-inclusive [ -1 modify-from ] dip :> ( n' string' opening ch )
|
n string openstr1 slice-til-separator-inclusive [ -1 modify-from ] dip :> ( n' string' opening ch )
|
||||||
|
|
@ -248,7 +248,7 @@ MACRO:: read-matched ( ch -- quot: ( n string tag -- n' string slice' ) )
|
||||||
[ drop "=" swap prefix ]
|
[ drop "=" swap prefix ]
|
||||||
[ nip 1string ]
|
[ nip 1string ]
|
||||||
} 2cleave :> ( openstreq closestr1 ) ! [= ]
|
} 2cleave :> ( openstreq closestr1 ) ! [= ]
|
||||||
[| n string tag |
|
|[ n string tag |
|
||||||
n string tag
|
n string tag
|
||||||
2over nth-check-eof {
|
2over nth-check-eof {
|
||||||
{ [ dup openstreq member? ] [ ch read-double-matched ] } ! (=( or ((
|
{ [ dup openstreq member? ] [ ch read-double-matched ] } ! (=( or ((
|
||||||
|
|
|
||||||
|
|
@ -179,8 +179,8 @@ M: object apply-object push-literal ;
|
||||||
:: declare-input-effects ( word -- )
|
:: declare-input-effects ( word -- )
|
||||||
H{ } clone :> variables
|
H{ } clone :> variables
|
||||||
V{ } clone :> branches
|
V{ } clone :> branches
|
||||||
word stack-effect in>> <reversed> [| in n |
|
word stack-effect in>> <reversed> |[ in n |
|
||||||
in ?quotation-effect [| effect |
|
in ?quotation-effect |[ effect |
|
||||||
word effect variables branches n declare-effect-d
|
word effect variables branches n declare-effect-d
|
||||||
] when*
|
] when*
|
||||||
] each-index ;
|
] each-index ;
|
||||||
|
|
|
||||||
|
|
@ -29,7 +29,7 @@ ARTICLE: "inference-combinators" "Combinator stack effects"
|
||||||
{ $example "USING: math sequences ;" "[ [ + ] curry map ] infer." "( x x -- x )" }
|
{ $example "USING: math sequences ;" "[ [ + ] curry map ] infer." "( x x -- x )" }
|
||||||
"The equivalent code using " { $vocab-link "fry" } " and " { $vocab-link "locals" } " likewise passes the stack checker:"
|
"The equivalent code using " { $vocab-link "fry" } " and " { $vocab-link "locals" } " likewise passes the stack checker:"
|
||||||
{ $example "USING: fry math sequences ;" "[ '[ _ + ] map ] infer." "( x x -- x )" }
|
{ $example "USING: fry math sequences ;" "[ '[ _ + ] map ] infer." "( x x -- x )" }
|
||||||
{ $example "USING: locals math sequences ;" "[| a | [ a + ] map ] infer." "( x x -- x )" }
|
{ $example "USING: locals math sequences ;" "|[ a | [ a + ] map ] infer." "( x x -- x )" }
|
||||||
{ $subheading "Defining an inline combinator" }
|
{ $subheading "Defining an inline combinator" }
|
||||||
"The following word calls a quotation twice; the word is declared " { $link postpone\ inline } ", since it invokes " { $link call } " on the result of " { $link compose } " on an input parameter:"
|
"The following word calls a quotation twice; the word is declared " { $link postpone\ inline } ", since it invokes " { $link call } " on the result of " { $link compose } " on an input parameter:"
|
||||||
{ $code ": twice ( value quot -- result ) dup compose call ; inline" }
|
{ $code ": twice ( value quot -- result ) dup compose call ; inline" }
|
||||||
|
|
|
||||||
|
|
@ -353,14 +353,6 @@ in: bootstrap.syntax
|
||||||
|
|
||||||
"execute(" [ \ execute-effect parse-call-paren ] define-core-syntax
|
"execute(" [ \ execute-effect parse-call-paren ] define-core-syntax
|
||||||
|
|
||||||
"<<<<<<<" [ version-control-merge-conflict ] define-core-syntax
|
|
||||||
"=======" [ version-control-merge-conflict ] define-core-syntax
|
|
||||||
">>>>>>>" [ version-control-merge-conflict ] define-core-syntax
|
|
||||||
|
|
||||||
"<<<<<<" [ version-control-merge-conflict ] define-core-syntax
|
|
||||||
"======" [ version-control-merge-conflict ] define-core-syntax
|
|
||||||
">>>>>>" [ version-control-merge-conflict ] define-core-syntax
|
|
||||||
|
|
||||||
"::" [ (::) define-declared ] define-core-syntax
|
"::" [ (::) define-declared ] define-core-syntax
|
||||||
"M::" [ (M::) define ] define-core-syntax
|
"M::" [ (M::) define ] define-core-syntax
|
||||||
"MACRO:" [ (:) define-macro ] define-core-syntax
|
"MACRO:" [ (:) define-macro ] define-core-syntax
|
||||||
|
|
@ -377,7 +369,7 @@ in: bootstrap.syntax
|
||||||
scan-token parse-def suffix!
|
scan-token parse-def suffix!
|
||||||
] define-core-syntax
|
] define-core-syntax
|
||||||
|
|
||||||
"[|" [ parse-lambda append! ] define-core-syntax
|
"|[" [ parse-lambda append! ] define-core-syntax
|
||||||
"let[" [ parse-let append! ] define-core-syntax
|
"let[" [ parse-let append! ] define-core-syntax
|
||||||
"MEMO[" [ parse-quotation dup infer memoize-quot suffix! ] define-core-syntax
|
"MEMO[" [ parse-quotation dup infer memoize-quot suffix! ] define-core-syntax
|
||||||
"'[" [ parse-quotation fry append! ] define-core-syntax
|
"'[" [ parse-quotation fry append! ] define-core-syntax
|
||||||
|
|
|
||||||
|
|
@ -63,7 +63,7 @@ GENERIC: force ( neighbors boid behaviour -- force ) ;
|
||||||
[ [ + ] keep mod ] 2map ;
|
[ [ + ] keep mod ] 2map ;
|
||||||
|
|
||||||
:: simulate ( boids behaviours dt -- boids )
|
:: simulate ( boids behaviours dt -- boids )
|
||||||
boids [| boid |
|
boids |[ boid |
|
||||||
boid boids behaviours
|
boid boids behaviours
|
||||||
[ [ (force) ] keep weight>> v*n ] 2with map vsum :> a
|
[ [ (force) ] keep weight>> v*n ] 2with map vsum :> a
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -48,7 +48,7 @@ CONSTANT: model-url "http://duriansoftware.com/joe/media/bun_zipper.ply" ;
|
||||||
model-url model-path [ ?download-to ] keep ;
|
model-url model-path [ ?download-to ] keep ;
|
||||||
|
|
||||||
:: (draw-triangle) ( ns vs triple -- )
|
:: (draw-triangle) ( ns vs triple -- )
|
||||||
triple [| elt |
|
triple |[ elt |
|
||||||
elt ns nth gl-normal
|
elt ns nth gl-normal
|
||||||
elt vs nth gl-vertex
|
elt vs nth gl-vertex
|
||||||
] each ;
|
] each ;
|
||||||
|
|
|
||||||
|
|
@ -30,8 +30,8 @@ in: project-euler.085
|
||||||
2dup [ 1 + ] bi@ * * * 4 /i ; inline
|
2dup [ 1 + ] bi@ * * * 4 /i ; inline
|
||||||
|
|
||||||
:: each-unique-product ( ... a b quot: ( ... i j -- ... ) -- ... )
|
:: each-unique-product ( ... a b quot: ( ... i j -- ... ) -- ... )
|
||||||
a b [a,b] [| i |
|
a b [a,b] |[ i |
|
||||||
i b [a,b] [| j |
|
i b [a,b] |[ j |
|
||||||
i j quot call
|
i j quot call
|
||||||
] each
|
] each
|
||||||
] each ; inline
|
] each ; inline
|
||||||
|
|
|
||||||
|
|
@ -52,9 +52,9 @@ in: project-euler.150
|
||||||
|
|
||||||
:: (euler150) ( m -- n )
|
:: (euler150) ( m -- n )
|
||||||
sums-triangle :> table
|
sums-triangle :> table
|
||||||
m iota [| x |
|
m iota |[ x |
|
||||||
x 1 + iota [| y |
|
x 1 + iota |[ y |
|
||||||
m x - iota [| z |
|
m x - iota |[ z |
|
||||||
x z + table nth-unsafe
|
x z + table nth-unsafe
|
||||||
[ y z + 1 + swap nth-unsafe ]
|
[ y z + 1 + swap nth-unsafe ]
|
||||||
[ y swap nth-unsafe ] bi -
|
[ y swap nth-unsafe ] bi -
|
||||||
|
|
|
||||||
|
|
@ -43,7 +43,7 @@ in: project-euler.190
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
:: P_m ( m -- P_m )
|
:: P_m ( m -- P_m )
|
||||||
m [1,b] [| i | 2 i * m 1 + / i ^ ] PI ;
|
m [1,b] |[ i | 2 i * m 1 + / i ^ ] PI ;
|
||||||
|
|
||||||
: euler190 ( -- answer )
|
: euler190 ( -- answer )
|
||||||
2 15 [a,b] [ P_m truncate ] map-sum ;
|
2 15 [a,b] [ P_m truncate ] map-sum ;
|
||||||
|
|
|
||||||
|
|
@ -72,7 +72,7 @@ M: end h2 dup failure? [ <failure> <block> ] unless ;
|
||||||
|
|
||||||
: first-row ( n -- t )
|
: first-row ( n -- t )
|
||||||
[ <failure> <success> <failure> ] dip
|
[ <failure> <success> <failure> ] dip
|
||||||
1 - [| a b c | b c <block> a b ] times 2drop ;
|
1 - |[ a b c | b c <block> a b ] times 2drop ;
|
||||||
|
|
||||||
GENERIC: total ( t -- n ) ;
|
GENERIC: total ( t -- n ) ;
|
||||||
M: block total [ total ] dup choice + ;
|
M: block total [ total ] dup choice + ;
|
||||||
|
|
|
||||||
|
|
@ -31,8 +31,8 @@ in: rosetta-code.count-the-coins
|
||||||
:: (make-change) ( cents coins -- ways )
|
:: (make-change) ( cents coins -- ways )
|
||||||
cents 1 + 0 <array> :> ways
|
cents 1 + 0 <array> :> ways
|
||||||
1 ways set-first
|
1 ways set-first
|
||||||
coins [| coin |
|
coins |[ coin |
|
||||||
coin cents [a,b] [| j |
|
coin cents [a,b] |[ j |
|
||||||
j coin - ways nth j ways [ + ] change-nth
|
j coin - ways nth j ways [ + ] change-nth
|
||||||
] each
|
] each
|
||||||
] each ways last ;
|
] each ways last ;
|
||||||
|
|
|
||||||
|
|
@ -63,7 +63,7 @@ CONSTANT: limit 400 ;
|
||||||
item-no table nth :> prev
|
item-no table nth :> prev
|
||||||
item-no 1 + table nth :> curr
|
item-no 1 + table nth :> curr
|
||||||
item-no items nth :> item
|
item-no items nth :> item
|
||||||
limit [1,b] [| weight |
|
limit [1,b] |[ weight |
|
||||||
weight prev nth
|
weight prev nth
|
||||||
weight item weight>> - dup 0 >=
|
weight item weight>> - dup 0 >=
|
||||||
[ prev nth item value>> + max ]
|
[ prev nth item value>> + max ]
|
||||||
|
|
@ -78,7 +78,7 @@ CONSTANT: limit 400 ;
|
||||||
:: extract-packed-items ( table -- items )
|
:: extract-packed-items ( table -- items )
|
||||||
[
|
[
|
||||||
limit :> weight!
|
limit :> weight!
|
||||||
items length iota <reversed> [| item-no |
|
items length iota <reversed> |[ item-no |
|
||||||
item-no table nth :> prev
|
item-no table nth :> prev
|
||||||
item-no 1 + table nth :> curr
|
item-no 1 + table nth :> curr
|
||||||
weight [ curr nth ] [ prev nth ] bi =
|
weight [ curr nth ] [ prev nth ] bi =
|
||||||
|
|
|
||||||
|
|
@ -276,7 +276,7 @@ test = <foreign parse-smalltalk LocalVariableDeclarationList>
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
[ "class Test [|a|]" parse-smalltalk ] unit-test
|
[ "class Test |[a|]" parse-smalltalk ] unit-test
|
||||||
|
|
||||||
{
|
{
|
||||||
T{ ast-sequence f { }
|
T{ ast-sequence f { }
|
||||||
|
|
@ -295,7 +295,7 @@ test = <foreign parse-smalltalk LocalVariableDeclarationList>
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
[ "class Test1 [|a|]. class Test2 extends Test1 [|b|]" parse-smalltalk ] unit-test
|
[ "class Test1 |[a|]. class Test2 extends Test1 |[b|]" parse-smalltalk ] unit-test
|
||||||
|
|
||||||
{ } [ "class Foo []. Tests blah " parse-smalltalk drop ] unit-test
|
{ } [ "class Foo []. Tests blah " parse-smalltalk drop ] unit-test
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -191,7 +191,7 @@ CONSTANT: galois-slides
|
||||||
{ "Define lambda words with " { $link postpone\ :: } }
|
{ "Define lambda words with " { $link postpone\ :: } }
|
||||||
{ "Establish bindings with " { $link postpone\ let[ } " and " { $snippet "let[*" } }
|
{ "Establish bindings with " { $link postpone\ let[ } " and " { $snippet "let[*" } }
|
||||||
"Mutable bindings with correct semantics"
|
"Mutable bindings with correct semantics"
|
||||||
{ "Named inputs for quotations with " { $link postpone\ [| } }
|
{ "Named inputs for quotations with " { $link postpone\ |[ } }
|
||||||
"Full closures"
|
"Full closures"
|
||||||
}
|
}
|
||||||
{ $slide "Locals and lexical scope"
|
{ $slide "Locals and lexical scope"
|
||||||
|
|
|
||||||
|
|
@ -274,7 +274,7 @@ CONSTANT: google-slides
|
||||||
{ "Define lambda words with " { $link postpone\ :: } }
|
{ "Define lambda words with " { $link postpone\ :: } }
|
||||||
{ "Establish bindings with " { $link postpone\ let[ } " and " { $snippet "let[*" } }
|
{ "Establish bindings with " { $link postpone\ let[ } " and " { $snippet "let[*" } }
|
||||||
"Mutable bindings with correct semantics"
|
"Mutable bindings with correct semantics"
|
||||||
{ "Named inputs for quotations with " { $link postpone\ [| } }
|
{ "Named inputs for quotations with " { $link postpone\ |[ } }
|
||||||
"Full closures"
|
"Full closures"
|
||||||
}
|
}
|
||||||
{ $slide "Locals and lexical scope"
|
{ $slide "Locals and lexical scope"
|
||||||
|
|
|
||||||
|
|
@ -211,7 +211,7 @@ CONSTANT: vpri-slides
|
||||||
{ "Define lambda words with " { $link postpone\ :: } }
|
{ "Define lambda words with " { $link postpone\ :: } }
|
||||||
{ "Establish bindings with " { $link postpone\ let[ } " and " { $snippet "let[*" } }
|
{ "Establish bindings with " { $link postpone\ let[ } " and " { $snippet "let[*" } }
|
||||||
"Mutable bindings with correct semantics"
|
"Mutable bindings with correct semantics"
|
||||||
{ "Named inputs for quotations with " { $link postpone\ [| } }
|
{ "Named inputs for quotations with " { $link postpone\ |[ } }
|
||||||
"Full closures"
|
"Full closures"
|
||||||
}
|
}
|
||||||
{ $slide "Locals and lexical scope"
|
{ $slide "Locals and lexical scope"
|
||||||
|
|
|
||||||
|
|
@ -32,7 +32,7 @@ M: window-controls-demo-world pref-dim*
|
||||||
|
|
||||||
: window-controls-demo ( -- )
|
: window-controls-demo ( -- )
|
||||||
attributes-template V{ } clone window-control-sets-to-test
|
attributes-template V{ } clone window-control-sets-to-test
|
||||||
[| title attributes windows controls |
|
|[ title attributes windows controls |
|
||||||
f attributes
|
f attributes
|
||||||
title >>title
|
title >>title
|
||||||
controls >>window-controls
|
controls >>window-controls
|
||||||
|
|
|
||||||
|
|
@ -55,7 +55,7 @@ PRIVATE>
|
||||||
:: get-public-key ( -- bin/f )
|
:: get-public-key ( -- bin/f )
|
||||||
ec-key-handle :> KEY
|
ec-key-handle :> KEY
|
||||||
KEY EC_KEY_get0_public_key dup
|
KEY EC_KEY_get0_public_key dup
|
||||||
[| PUB |
|
|[ PUB |
|
||||||
KEY EC_KEY_get0_group :> GROUP
|
KEY EC_KEY_get0_group :> GROUP
|
||||||
GROUP EC_GROUP_get_degree bits>bytes 1 + :> LEN
|
GROUP EC_GROUP_get_degree bits>bytes 1 + :> LEN
|
||||||
LEN <byte-array> :> BIN
|
LEN <byte-array> :> BIN
|
||||||
|
|
|
||||||
|
|
@ -942,9 +942,9 @@ TYPED: load-commands ( macho: mach_header_32/64 -- load-commands )
|
||||||
] with-mapped-file-reader ; inline
|
] with-mapped-file-reader ; inline
|
||||||
|
|
||||||
: macho-nm ( path -- )
|
: macho-nm ( path -- )
|
||||||
[| macho |
|
|[ macho |
|
||||||
macho load-commands segment-commands sections-array :> sections
|
macho load-commands segment-commands sections-array :> sections
|
||||||
macho load-commands symtab-commands [| symtab |
|
macho load-commands symtab-commands |[ symtab |
|
||||||
macho symtab symbols [
|
macho symtab symbols [
|
||||||
[ drop n_value>> "%016x " printf ]
|
[ drop n_value>> "%016x " printf ]
|
||||||
[
|
[
|
||||||
|
|
@ -963,8 +963,8 @@ TYPED: load-commands ( macho: mach_header_32/64 -- load-commands )
|
||||||
} 1&& ;
|
} 1&& ;
|
||||||
|
|
||||||
: dylib-exports ( path -- symbol-names )
|
: dylib-exports ( path -- symbol-names )
|
||||||
[| macho |
|
|[ macho |
|
||||||
macho load-commands symtab-commands [| symtab |
|
macho load-commands symtab-commands |[ symtab |
|
||||||
macho symtab symbols
|
macho symtab symbols
|
||||||
[ [ dylib-export? ] filter ]
|
[ [ dylib-export? ] filter ]
|
||||||
[ [ c-symbol-name ] curry { } map-as ] bi*
|
[ [ c-symbol-name ] curry { } map-as ] bi*
|
||||||
|
|
|
||||||
|
|
@ -550,7 +550,7 @@ PRIVATE>
|
||||||
(current-cl-device) [ handle>> ] bi@ CL_KERNEL_WORK_GROUP_SIZE kernel-work-group-info-size_t ; inline
|
(current-cl-device) [ handle>> ] bi@ CL_KERNEL_WORK_GROUP_SIZE kernel-work-group-info-size_t ; inline
|
||||||
|
|
||||||
:: cl-queue-kernel ( kernel args sizes dependent-events -- event )
|
:: cl-queue-kernel ( kernel args sizes dependent-events -- event )
|
||||||
args [| arg idx | kernel idx arg bind-kernel-arg ] each-index
|
args |[ arg idx | kernel idx arg bind-kernel-arg ] each-index
|
||||||
(current-cl-queue) handle>>
|
(current-cl-queue) handle>>
|
||||||
kernel handle>>
|
kernel handle>>
|
||||||
sizes [ length f ] [ [ ] size_t-array{ } map-as f ] bi
|
sizes [ length f ] [ [ ] size_t-array{ } map-as f ] bi
|
||||||
|
|
|
||||||
|
|
@ -3,7 +3,7 @@
|
||||||
USING: accessors combinators.short-circuit db db.errors
|
USING: accessors combinators.short-circuit db db.errors
|
||||||
db.sqlite kernel locals tools.test ;
|
db.sqlite kernel locals tools.test ;
|
||||||
|
|
||||||
[| path |
|
|[ path |
|
||||||
|
|
||||||
path <sqlite-db> [
|
path <sqlite-db> [
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -25,7 +25,7 @@ M:: boilerplate call-responder* ( path responder -- response )
|
||||||
path responder call-next-method
|
path responder call-next-method
|
||||||
responder init>> call( -- )
|
responder init>> call( -- )
|
||||||
dup wrap-boilerplate? [
|
dup wrap-boilerplate? [
|
||||||
clone [| body |
|
clone |[ body |
|
||||||
[
|
[
|
||||||
body
|
body
|
||||||
responder template>> resolve-template-path <chloe>
|
responder template>> resolve-template-path <chloe>
|
||||||
|
|
|
||||||
|
|
@ -93,10 +93,10 @@ M: z-up >y-up-axis!
|
||||||
|
|
||||||
:: collect-sources ( sources vertices inputs -- seq )
|
:: collect-sources ( sources vertices inputs -- seq )
|
||||||
inputs
|
inputs
|
||||||
[| input |
|
|[ input |
|
||||||
input "source" x@ rest vertices first =
|
input "source" x@ rest vertices first =
|
||||||
[
|
[
|
||||||
vertices second [| vertex |
|
vertices second |[ vertex |
|
||||||
vertex first
|
vertex first
|
||||||
input "offset" x@ string>number
|
input "offset" x@ string>number
|
||||||
vertex second rest sources at source boa
|
vertex second rest sources at source boa
|
||||||
|
|
|
||||||
|
|
@ -164,11 +164,11 @@ M: renderbuffer framebuffer-attachment-dim
|
||||||
|
|
||||||
:: each-attachment-target ( framebuffer quot: ( attachment-target attachment -- ) -- )
|
:: each-attachment-target ( framebuffer quot: ( attachment-target attachment -- ) -- )
|
||||||
framebuffer color-attachments>>
|
framebuffer color-attachments>>
|
||||||
[| attachment n | n GL_COLOR_ATTACHMENT0 + attachment quot call ] each-index
|
|[ attachment n | n GL_COLOR_ATTACHMENT0 + attachment quot call ] each-index
|
||||||
framebuffer depth-attachment>>
|
framebuffer depth-attachment>>
|
||||||
[| attachment | GL_DEPTH_ATTACHMENT attachment quot call ] when*
|
|[ attachment | GL_DEPTH_ATTACHMENT attachment quot call ] when*
|
||||||
framebuffer stencil-attachment>>
|
framebuffer stencil-attachment>>
|
||||||
[| attachment | GL_STENCIL_ATTACHMENT attachment quot call ] when* ; inline
|
|[ attachment | GL_STENCIL_ATTACHMENT attachment quot call ] when* ; inline
|
||||||
|
|
||||||
GENERIC: bind-framebuffer-attachment ( attachment-target attachment -- ) ;
|
GENERIC: bind-framebuffer-attachment ( attachment-target attachment -- ) ;
|
||||||
|
|
||||||
|
|
@ -331,12 +331,12 @@ TYPED:: clear-framebuffer-attachment ( framebuffer: any-framebuffer
|
||||||
value -- )
|
value -- )
|
||||||
GL_DRAW_FRAMEBUFFER framebuffer framebuffer-handle glBindFramebuffer
|
GL_DRAW_FRAMEBUFFER framebuffer framebuffer-handle glBindFramebuffer
|
||||||
attachment-ref {
|
attachment-ref {
|
||||||
{ system-attachment [| side face |
|
{ system-attachment |[ side face |
|
||||||
float-type
|
float-type
|
||||||
side face gl-system-attachment
|
side face gl-system-attachment
|
||||||
value (clear-color-attachment)
|
value (clear-color-attachment)
|
||||||
] }
|
] }
|
||||||
{ color-attachment [| i |
|
{ color-attachment |[ i |
|
||||||
framebuffer i (color-attachment-type)
|
framebuffer i (color-attachment-type)
|
||||||
GL_COLOR_ATTACHMENT0 i +
|
GL_COLOR_ATTACHMENT0 i +
|
||||||
value (clear-color-attachment)
|
value (clear-color-attachment)
|
||||||
|
|
|
||||||
|
|
@ -459,7 +459,7 @@ defer: [bind-uniform-tuple]
|
||||||
] if* :> ( quot-prefixes name-prefixes )
|
] if* :> ( quot-prefixes name-prefixes )
|
||||||
type all-uniform-tuple-slots :> uniforms
|
type all-uniform-tuple-slots :> uniforms
|
||||||
|
|
||||||
texture-unit quot-prefixes name-prefixes [| quot-prefix name-prefix |
|
texture-unit quot-prefixes name-prefixes |[ quot-prefix name-prefix |
|
||||||
uniforms name-prefix [bind-uniform-tuple]
|
uniforms name-prefix [bind-uniform-tuple]
|
||||||
quot-prefix prepend
|
quot-prefix prepend
|
||||||
] 2map :> ( texture-unit' value-cleave )
|
] 2map :> ( texture-unit' value-cleave )
|
||||||
|
|
|
||||||
|
|
@ -551,7 +551,7 @@ SYNTAX: \ geometry-shader-vertices-out:
|
||||||
|
|
||||||
TYPED:: refresh-program ( program: program -- )
|
TYPED:: refresh-program ( program: program -- )
|
||||||
program shaders>> [ refresh-shader-source ] each
|
program shaders>> [ refresh-shader-source ] each
|
||||||
program instances>> [| world old-instance |
|
program instances>> |[ world old-instance |
|
||||||
old-instance valid-handle? [
|
old-instance valid-handle? [
|
||||||
world [
|
world [
|
||||||
[
|
[
|
||||||
|
|
@ -559,7 +559,7 @@ TYPED:: refresh-program ( program: program -- )
|
||||||
program new-shader-instances (link-program) |dispose :> new-program-instance
|
program new-shader-instances (link-program) |dispose :> new-program-instance
|
||||||
|
|
||||||
old-instance new-program-instance become-program-instance
|
old-instance new-program-instance become-program-instance
|
||||||
new-shader-instances [| new-shader-instance |
|
new-shader-instances |[ new-shader-instance |
|
||||||
world new-shader-instance shader>> instances>> at
|
world new-shader-instance shader>> instances>> at
|
||||||
new-shader-instance become-shader-instance
|
new-shader-instance become-shader-instance
|
||||||
] each
|
] each
|
||||||
|
|
|
||||||
|
|
@ -23,7 +23,7 @@ singleton: x11-ui-backend
|
||||||
|
|
||||||
: supported-net-wm-hints ( -- seq )
|
: supported-net-wm-hints ( -- seq )
|
||||||
{ Atom int ulong ulong pointer: Atom }
|
{ Atom int ulong ulong pointer: Atom }
|
||||||
[| type format n-atoms bytes-after atoms |
|
|[ type format n-atoms bytes-after atoms |
|
||||||
dpy get
|
dpy get
|
||||||
root get
|
root get
|
||||||
XA_NET_SUPPORTED
|
XA_NET_SUPPORTED
|
||||||
|
|
@ -40,7 +40,7 @@ singleton: x11-ui-backend
|
||||||
Success assert=
|
Success assert=
|
||||||
]
|
]
|
||||||
with-out-parameters
|
with-out-parameters
|
||||||
[| type format n-atoms bytes-after atoms |
|
|[ type format n-atoms bytes-after atoms |
|
||||||
atoms n-atoms ulong <c-direct-array> >array
|
atoms n-atoms ulong <c-direct-array> >array
|
||||||
atoms XFree
|
atoms XFree
|
||||||
] call ;
|
] call ;
|
||||||
|
|
|
||||||
|
|
@ -113,7 +113,7 @@ M: editor ungraft*
|
||||||
point second editor y>line {
|
point second editor y>line {
|
||||||
{ [ dup 0 < ] [ drop { 0 0 } ] }
|
{ [ dup 0 < ] [ drop { 0 0 } ] }
|
||||||
{ [ dup editor model>> last-line# > ] [ drop editor model>> doc-end ] }
|
{ [ dup editor model>> last-line# > ] [ drop editor model>> doc-end ] }
|
||||||
[| n |
|
|[ n |
|
||||||
n
|
n
|
||||||
point first
|
point first
|
||||||
editor font>>
|
editor font>>
|
||||||
|
|
|
||||||
|
|
@ -13,7 +13,7 @@ in: snake-game.sprites
|
||||||
|
|
||||||
:: image-part ( image x y w h -- image )
|
:: image-part ( image x y w h -- image )
|
||||||
image w h new-image-like :> new-image
|
image w h new-image-like :> new-image
|
||||||
h iota [| i |
|
h iota |[ i |
|
||||||
new-image bitmap>>
|
new-image bitmap>>
|
||||||
x y i + w image pixel-row-slice-at
|
x y i + w image pixel-row-slice-at
|
||||||
append! drop
|
append! drop
|
||||||
|
|
|
||||||
|
|
@ -99,7 +99,7 @@ HELP: \ CALLBACK:
|
||||||
{ $code
|
{ $code
|
||||||
"CALLBACK: bool FakeCallback ( int message, void* payload )"
|
"CALLBACK: bool FakeCallback ( int message, void* payload )"
|
||||||
": MyFakeCallback ( -- alien )"
|
": MyFakeCallback ( -- alien )"
|
||||||
" [| message payload |"
|
" |[ message payload |"
|
||||||
" \"message #\" write"
|
" \"message #\" write"
|
||||||
" message number>string write"
|
" message number>string write"
|
||||||
" \" received\" write nl"
|
" \" received\" write nl"
|
||||||
|
|
|
||||||
|
|
@ -40,18 +40,18 @@ M: object flatten-struct-type-return
|
||||||
:: explode-struct ( src c-type -- vregs reps )
|
:: explode-struct ( src c-type -- vregs reps )
|
||||||
c-type flatten-struct-type :> reps
|
c-type flatten-struct-type :> reps
|
||||||
reps keys dup component-offsets
|
reps keys dup component-offsets
|
||||||
[| rep offset | src offset rep f ^^load-memory-imm ] 2map
|
|[ rep offset | src offset rep f ^^load-memory-imm ] 2map
|
||||||
reps ;
|
reps ;
|
||||||
|
|
||||||
:: explode-struct-return ( src c-type -- vregs reps )
|
:: explode-struct-return ( src c-type -- vregs reps )
|
||||||
c-type flatten-struct-type-return :> reps
|
c-type flatten-struct-type-return :> reps
|
||||||
reps keys dup component-offsets
|
reps keys dup component-offsets
|
||||||
[| rep offset | src offset rep f ^^load-memory-imm ] 2map
|
|[ rep offset | src offset rep f ^^load-memory-imm ] 2map
|
||||||
reps ;
|
reps ;
|
||||||
|
|
||||||
:: implode-struct ( src vregs reps -- )
|
:: implode-struct ( src vregs reps -- )
|
||||||
vregs reps dup component-offsets
|
vregs reps dup component-offsets
|
||||||
[| vreg rep offset | vreg src offset rep f ##store-memory-imm, ] 3each ;
|
|[ vreg rep offset | vreg src offset rep f ##store-memory-imm, ] 3each ;
|
||||||
|
|
||||||
GENERIC: unbox ( src c-type -- vregs reps ) ;
|
GENERIC: unbox ( src c-type -- vregs reps ) ;
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -131,7 +131,7 @@ in: compiler.cfg.builder.tests
|
||||||
byte-array
|
byte-array
|
||||||
alien
|
alien
|
||||||
postpone\ f
|
postpone\ f
|
||||||
} [| class |
|
} |[ class |
|
||||||
{
|
{
|
||||||
alien-signed-1
|
alien-signed-1
|
||||||
alien-signed-2
|
alien-signed-2
|
||||||
|
|
@ -142,7 +142,7 @@ in: compiler.cfg.builder.tests
|
||||||
alien-cell
|
alien-cell
|
||||||
alien-float
|
alien-float
|
||||||
alien-double
|
alien-double
|
||||||
} [| word |
|
} |[ word |
|
||||||
{ class } word '[ _ declare 10 _ execute ] unit-test-builder
|
{ class } word '[ _ declare 10 _ execute ] unit-test-builder
|
||||||
{ class fixnum } word '[ _ declare _ execute ] unit-test-builder
|
{ class fixnum } word '[ _ declare _ execute ] unit-test-builder
|
||||||
] each
|
] each
|
||||||
|
|
@ -154,7 +154,7 @@ in: compiler.cfg.builder.tests
|
||||||
set-alien-unsigned-1
|
set-alien-unsigned-1
|
||||||
set-alien-unsigned-2
|
set-alien-unsigned-2
|
||||||
set-alien-unsigned-4
|
set-alien-unsigned-4
|
||||||
} [| word |
|
} |[ word |
|
||||||
{ fixnum class } word '[ _ declare 10 _ execute ] unit-test-builder
|
{ fixnum class } word '[ _ declare 10 _ execute ] unit-test-builder
|
||||||
{ fixnum class fixnum } word '[ _ declare _ execute ] unit-test-builder
|
{ fixnum class fixnum } word '[ _ declare _ execute ] unit-test-builder
|
||||||
] each
|
] each
|
||||||
|
|
|
||||||
|
|
@ -39,7 +39,7 @@ M: insn gc-check-offsets* 2drop ;
|
||||||
! Divide a basic block into sections, where every section
|
! Divide a basic block into sections, where every section
|
||||||
! other than the first requires a GC check.
|
! other than the first requires a GC check.
|
||||||
[
|
[
|
||||||
insns 0 seq [| insns' from to |
|
insns 0 seq |[ insns' from to |
|
||||||
from to insns' subseq ,
|
from to insns' subseq ,
|
||||||
insns' to
|
insns' to
|
||||||
] each
|
] each
|
||||||
|
|
@ -79,7 +79,7 @@ M: ##box-displaced-alien allocation-size* drop 5 cells ;
|
||||||
! the previous block, and the previous block's GC call.
|
! the previous block, and the previous block's GC call.
|
||||||
bbs length 1 - :> len
|
bbs length 1 - :> len
|
||||||
len [ <gc-call> ] replicate :> gc-calls
|
len [ <gc-call> ] replicate :> gc-calls
|
||||||
len [| n |
|
len |[ n |
|
||||||
n bbs nth :> bb
|
n bbs nth :> bb
|
||||||
n 1 + bbs nth :> next-bb
|
n 1 + bbs nth :> next-bb
|
||||||
n gc-calls nth :> gc-call
|
n gc-calls nth :> gc-call
|
||||||
|
|
|
||||||
|
|
@ -127,7 +127,7 @@ CONSTANT: rep>half {
|
||||||
{
|
{
|
||||||
[ ^(compare-vector) ]
|
[ ^(compare-vector) ]
|
||||||
[ ^minmax-compare-vector ]
|
[ ^minmax-compare-vector ]
|
||||||
{ unsigned-int-vector-rep [| src1 src2 rep cc |
|
{ unsigned-int-vector-rep |[ src1 src2 rep cc |
|
||||||
rep sign-bit-mask ^^load-literal :> sign-bits
|
rep sign-bit-mask ^^load-literal :> sign-bits
|
||||||
src1 sign-bits rep ^^xor-vector
|
src1 sign-bits rep ^^xor-vector
|
||||||
src2 sign-bits rep ^^xor-vector
|
src2 sign-bits rep ^^xor-vector
|
||||||
|
|
@ -139,12 +139,12 @@ CONSTANT: rep>half {
|
||||||
{
|
{
|
||||||
[ ^^unpack-vector-head ]
|
[ ^^unpack-vector-head ]
|
||||||
{ unsigned-int-vector-rep [ [ ^^zero-vector ] [ ^^merge-vector-head ] bi ] }
|
{ unsigned-int-vector-rep [ [ ^^zero-vector ] [ ^^merge-vector-head ] bi ] }
|
||||||
{ signed-int-vector-rep [| src rep |
|
{ signed-int-vector-rep |[ src rep |
|
||||||
src src rep ^^merge-vector-head :> merged
|
src src rep ^^merge-vector-head :> merged
|
||||||
rep rep-component-type heap-size 8 * :> bits
|
rep rep-component-type heap-size 8 * :> bits
|
||||||
merged bits rep widen-vector-rep ^^shr-vector-imm
|
merged bits rep widen-vector-rep ^^shr-vector-imm
|
||||||
] }
|
] }
|
||||||
{ signed-int-vector-rep [| src rep |
|
{ signed-int-vector-rep |[ src rep |
|
||||||
rep ^^zero-vector :> zero
|
rep ^^zero-vector :> zero
|
||||||
zero src rep cc> ^compare-vector :> sign
|
zero src rep cc> ^compare-vector :> sign
|
||||||
src sign rep ^^merge-vector-head
|
src sign rep ^^merge-vector-head
|
||||||
|
|
@ -156,12 +156,12 @@ CONSTANT: rep>half {
|
||||||
[ ^^unpack-vector-tail ]
|
[ ^^unpack-vector-tail ]
|
||||||
[ [ ^^tail>head-vector ] [ ^^unpack-vector-head ] bi ]
|
[ [ ^^tail>head-vector ] [ ^^unpack-vector-head ] bi ]
|
||||||
{ unsigned-int-vector-rep [ [ ^^zero-vector ] [ ^^merge-vector-tail ] bi ] }
|
{ unsigned-int-vector-rep [ [ ^^zero-vector ] [ ^^merge-vector-tail ] bi ] }
|
||||||
{ signed-int-vector-rep [| src rep |
|
{ signed-int-vector-rep |[ src rep |
|
||||||
src src rep ^^merge-vector-tail :> merged
|
src src rep ^^merge-vector-tail :> merged
|
||||||
rep rep-component-type heap-size 8 * :> bits
|
rep rep-component-type heap-size 8 * :> bits
|
||||||
merged bits rep widen-vector-rep ^^shr-vector-imm
|
merged bits rep widen-vector-rep ^^shr-vector-imm
|
||||||
] }
|
] }
|
||||||
{ signed-int-vector-rep [| src rep |
|
{ signed-int-vector-rep |[ src rep |
|
||||||
rep ^^zero-vector :> zero
|
rep ^^zero-vector :> zero
|
||||||
zero src rep cc> ^compare-vector :> sign
|
zero src rep cc> ^compare-vector :> sign
|
||||||
src sign rep ^^merge-vector-tail
|
src sign rep ^^merge-vector-tail
|
||||||
|
|
@ -174,7 +174,7 @@ PREDICATE: fixnum-vector-rep < int-vector-rep
|
||||||
: ^(sum-vector-2) ( src rep -- dst )
|
: ^(sum-vector-2) ( src rep -- dst )
|
||||||
{
|
{
|
||||||
[ dupd ^^horizontal-add-vector ]
|
[ dupd ^^horizontal-add-vector ]
|
||||||
[| src rep |
|
|[ src rep |
|
||||||
src src rep ^^merge-vector-head :> head
|
src src rep ^^merge-vector-head :> head
|
||||||
src src rep ^^merge-vector-tail :> tail
|
src src rep ^^merge-vector-tail :> tail
|
||||||
head tail rep ^^add-vector
|
head tail rep ^^add-vector
|
||||||
|
|
@ -187,7 +187,7 @@ PREDICATE: fixnum-vector-rep < int-vector-rep
|
||||||
[ dupd ^^horizontal-add-vector ]
|
[ dupd ^^horizontal-add-vector ]
|
||||||
[ dupd ^^horizontal-add-vector ] bi
|
[ dupd ^^horizontal-add-vector ] bi
|
||||||
]
|
]
|
||||||
[| src rep |
|
|[ src rep |
|
||||||
src src rep ^^merge-vector-head :> head
|
src src rep ^^merge-vector-head :> head
|
||||||
src src rep ^^merge-vector-tail :> tail
|
src src rep ^^merge-vector-tail :> tail
|
||||||
head tail rep ^^add-vector :> src'
|
head tail rep ^^add-vector :> src'
|
||||||
|
|
@ -206,7 +206,7 @@ PREDICATE: fixnum-vector-rep < int-vector-rep
|
||||||
[ dupd ^^horizontal-add-vector ]
|
[ dupd ^^horizontal-add-vector ]
|
||||||
[ dupd ^^horizontal-add-vector ] tri
|
[ dupd ^^horizontal-add-vector ] tri
|
||||||
]
|
]
|
||||||
[| src rep |
|
|[ src rep |
|
||||||
src src rep ^^merge-vector-head :> head
|
src src rep ^^merge-vector-head :> head
|
||||||
src src rep ^^merge-vector-tail :> tail
|
src src rep ^^merge-vector-tail :> tail
|
||||||
head tail rep ^^add-vector :> src'
|
head tail rep ^^add-vector :> src'
|
||||||
|
|
@ -233,7 +233,7 @@ PREDICATE: fixnum-vector-rep < int-vector-rep
|
||||||
[ dupd ^^horizontal-add-vector ]
|
[ dupd ^^horizontal-add-vector ]
|
||||||
} cleave
|
} cleave
|
||||||
]
|
]
|
||||||
[| src rep |
|
|[ src rep |
|
||||||
src src rep ^^merge-vector-head :> head
|
src src rep ^^merge-vector-head :> head
|
||||||
src src rep ^^merge-vector-tail :> tail
|
src src rep ^^merge-vector-tail :> tail
|
||||||
head tail rep ^^add-vector :> src'
|
head tail rep ^^add-vector :> src'
|
||||||
|
|
@ -268,7 +268,7 @@ PREDICATE: fixnum-vector-rep < int-vector-rep
|
||||||
: ^sum-vector ( src rep -- dst )
|
: ^sum-vector ( src rep -- dst )
|
||||||
{
|
{
|
||||||
{ float-vector-rep [ ^(sum-vector) ] }
|
{ float-vector-rep [ ^(sum-vector) ] }
|
||||||
{ fixnum-vector-rep [| src rep |
|
{ fixnum-vector-rep |[ src rep |
|
||||||
src rep ^unpack-vector-head :> head
|
src rep ^unpack-vector-head :> head
|
||||||
src rep ^unpack-vector-tail :> tail
|
src rep ^unpack-vector-tail :> tail
|
||||||
rep widen-vector-rep :> wide-rep
|
rep widen-vector-rep :> wide-rep
|
||||||
|
|
@ -287,7 +287,7 @@ PREDICATE: fixnum-vector-rep < int-vector-rep
|
||||||
|
|
||||||
: ^shuffle-2-vectors-imm ( src1 src2 shuffle rep -- dst )
|
: ^shuffle-2-vectors-imm ( src1 src2 shuffle rep -- dst )
|
||||||
[ rep-length 0 pad-tail ] keep {
|
[ rep-length 0 pad-tail ] keep {
|
||||||
{ double-2-rep [| src1 src2 shuffle rep |
|
{ double-2-rep |[ src1 src2 shuffle rep |
|
||||||
shuffle first2 [ 4 mod ] bi@ :> ( i j )
|
shuffle first2 [ 4 mod ] bi@ :> ( i j )
|
||||||
{
|
{
|
||||||
{ [ i j [ 2 < ] both? ] [
|
{ [ i j [ 2 < ] both? ] [
|
||||||
|
|
@ -339,12 +339,12 @@ PREDICATE: fixnum-vector-rep < int-vector-rep
|
||||||
: emit-simd-v+- ( node -- )
|
: emit-simd-v+- ( node -- )
|
||||||
{
|
{
|
||||||
[ ^^add-sub-vector ]
|
[ ^^add-sub-vector ]
|
||||||
{ float-vector-rep [| src1 src2 rep |
|
{ float-vector-rep |[ src1 src2 rep |
|
||||||
rep ^load-add-sub-vector :> signs
|
rep ^load-add-sub-vector :> signs
|
||||||
src2 signs rep ^^xor-vector :> src2'
|
src2 signs rep ^^xor-vector :> src2'
|
||||||
src1 src2' rep ^^add-vector
|
src1 src2' rep ^^add-vector
|
||||||
] }
|
] }
|
||||||
{ int-vector-rep [| src1 src2 rep |
|
{ int-vector-rep |[ src1 src2 rep |
|
||||||
rep ^load-add-sub-vector :> signs
|
rep ^load-add-sub-vector :> signs
|
||||||
src2 signs rep ^^xor-vector :> src2'
|
src2 signs rep ^^xor-vector :> src2'
|
||||||
src2' signs rep ^^sub-vector :> src2''
|
src2' signs rep ^^sub-vector :> src2''
|
||||||
|
|
@ -411,7 +411,7 @@ PREDICATE: fixnum-vector-rep < int-vector-rep
|
||||||
: emit-simd-vavg ( node -- )
|
: emit-simd-vavg ( node -- )
|
||||||
{
|
{
|
||||||
[ ^^avg-vector ]
|
[ ^^avg-vector ]
|
||||||
{ float-vector-rep [| src1 src2 rep |
|
{ float-vector-rep |[ src1 src2 rep |
|
||||||
src1 src2 rep ^^add-vector
|
src1 src2 rep ^^add-vector
|
||||||
rep ^load-half-vector rep ^^mul-vector
|
rep ^load-half-vector rep ^^mul-vector
|
||||||
] }
|
] }
|
||||||
|
|
@ -446,7 +446,7 @@ PREDICATE: fixnum-vector-rep < int-vector-rep
|
||||||
{ unsigned-int-vector-rep [ drop ] }
|
{ unsigned-int-vector-rep [ drop ] }
|
||||||
[ ^^abs-vector ]
|
[ ^^abs-vector ]
|
||||||
{ float-vector-rep [ [ ^load-neg-zero-vector ] [ swapd ^^andn-vector ] bi ] }
|
{ float-vector-rep [ [ ^load-neg-zero-vector ] [ swapd ^^andn-vector ] bi ] }
|
||||||
{ int-vector-rep [| src rep |
|
{ int-vector-rep |[ src rep |
|
||||||
rep ^^zero-vector :> zero
|
rep ^^zero-vector :> zero
|
||||||
zero src rep ^^sub-vector :> -src
|
zero src rep ^^sub-vector :> -src
|
||||||
zero src rep cc> ^compare-vector :> sign
|
zero src rep cc> ^compare-vector :> sign
|
||||||
|
|
@ -584,7 +584,7 @@ PREDICATE: fixnum-vector-rep < int-vector-rep
|
||||||
|
|
||||||
: emit-simd-vpack-signed ( node -- )
|
: emit-simd-vpack-signed ( node -- )
|
||||||
{
|
{
|
||||||
{ double-2-rep [| src1 src2 rep |
|
{ double-2-rep |[ src1 src2 rep |
|
||||||
src1 double-2-rep ^^float-pack-vector :> dst-head
|
src1 double-2-rep ^^float-pack-vector :> dst-head
|
||||||
src2 double-2-rep ^^float-pack-vector :> dst-tail
|
src2 double-2-rep ^^float-pack-vector :> dst-tail
|
||||||
dst-head dst-tail { 0 1 0 1 } float-4-rep ^^shuffle-vector-halves-imm
|
dst-head dst-tail { 0 1 0 1 } float-4-rep ^^shuffle-vector-halves-imm
|
||||||
|
|
|
||||||
|
|
@ -26,7 +26,7 @@ SYMBOLS: edge-copies phi-copies ;
|
||||||
{ dst dst' } phi-copies get push
|
{ dst dst' } phi-copies get push
|
||||||
dst' insn dst<<
|
dst' insn dst<<
|
||||||
|
|
||||||
preds [| pred |
|
preds |[ pred |
|
||||||
pred inputs [ pred rep convert-operand ] change-at
|
pred inputs [ pred rep convert-operand ] change-at
|
||||||
] each ;
|
] each ;
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -141,7 +141,7 @@ TUPLE: iterator seq n ;
|
||||||
|
|
||||||
:: linear-interference-test ( seq -- ? )
|
:: linear-interference-test ( seq -- ? )
|
||||||
V{ } clone :> dom
|
V{ } clone :> dom
|
||||||
seq [| vreg |
|
seq |[ vreg |
|
||||||
dom vreg find-parent
|
dom vreg find-parent
|
||||||
{ [ ] [ vreg same-sets? not ] [ vreg swap vregs-interfere? ] } 1&&
|
{ [ ] [ vreg same-sets? not ] [ vreg swap vregs-interfere? ] } 1&&
|
||||||
[ t ] [ vreg dom push f ] if
|
[ t ] [ vreg dom push f ] if
|
||||||
|
|
|
||||||
|
|
@ -46,7 +46,7 @@ in: compiler.tests.curry
|
||||||
[ call f ] curry assoc-find 3drop
|
[ call f ] curry assoc-find 3drop
|
||||||
] { } make ; inline
|
] { } make ; inline
|
||||||
|
|
||||||
[ t ] [| |
|
[ t ] |[ |
|
||||||
1000 iota [ drop 1,000,000 random 1,000,000 random ] H{ } map>assoc :> a-hashtable
|
1000 iota [ drop 1,000,000 random 1,000,000 random ] H{ } map>assoc :> a-hashtable
|
||||||
a-hashtable [ [ drop , ] funky-assoc>map ] compile-call
|
a-hashtable [ [ drop , ] funky-assoc>map ] compile-call
|
||||||
a-hashtable keys =
|
a-hashtable keys =
|
||||||
|
|
|
||||||
|
|
@ -97,7 +97,7 @@ M: #phi propagate-before ( #phi -- )
|
||||||
bi ;
|
bi ;
|
||||||
|
|
||||||
:: update-constraints ( new old -- )
|
:: update-constraints ( new old -- )
|
||||||
new [| key value | key old [ value union ] change-at ] assoc-each ;
|
new |[ key value | key old [ value union ] change-at ] assoc-each ;
|
||||||
|
|
||||||
: include-child-constraints ( i -- )
|
: include-child-constraints ( i -- )
|
||||||
infer-children-data get nth constraints of last
|
infer-children-data get nth constraints of last
|
||||||
|
|
|
||||||
|
|
@ -834,7 +834,7 @@ mixin: empty-mixin
|
||||||
[ { fixnum integer } declare bitand ] final-classes
|
[ { fixnum integer } declare bitand ] final-classes
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
{ V{ double-array } } [ [| | double-array{ } ] final-classes ] unit-test
|
{ V{ double-array } } [ |[ | double-array{ } ] final-classes ] unit-test
|
||||||
|
|
||||||
{ V{ t } } [ [ macosx unix? ] final-literals ] unit-test
|
{ V{ t } } [ [ macosx unix? ] final-literals ] unit-test
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -895,7 +895,7 @@ M: x86 %integer>scalar drop MOVD ;
|
||||||
] }
|
] }
|
||||||
{ char-scalar-rep [
|
{ char-scalar-rep [
|
||||||
dst 32-bit-version-of src MOVD
|
dst 32-bit-version-of src MOVD
|
||||||
dst { } 8 [| tmp-dst |
|
dst { } 8 |[ tmp-dst |
|
||||||
tmp-dst dst int-rep %copy
|
tmp-dst dst int-rep %copy
|
||||||
tmp-dst tmp-dst 8-bit-version-of MOVSX
|
tmp-dst tmp-dst 8-bit-version-of MOVSX
|
||||||
dst tmp-dst int-rep %copy
|
dst tmp-dst int-rep %copy
|
||||||
|
|
@ -903,7 +903,7 @@ M: x86 %integer>scalar drop MOVD ;
|
||||||
] }
|
] }
|
||||||
{ uchar-scalar-rep [
|
{ uchar-scalar-rep [
|
||||||
dst 32-bit-version-of src MOVD
|
dst 32-bit-version-of src MOVD
|
||||||
dst { } 8 [| tmp-dst |
|
dst { } 8 |[ tmp-dst |
|
||||||
tmp-dst dst int-rep %copy
|
tmp-dst dst int-rep %copy
|
||||||
tmp-dst tmp-dst 8-bit-version-of MOVZX
|
tmp-dst tmp-dst 8-bit-version-of MOVZX
|
||||||
dst tmp-dst int-rep %copy
|
dst tmp-dst int-rep %copy
|
||||||
|
|
|
||||||
|
|
@ -354,7 +354,7 @@ M: x86.64 has-small-reg? 2drop t ;
|
||||||
] if ; inline
|
] if ; inline
|
||||||
|
|
||||||
:: (%convert-integer) ( dst src bits quot -- )
|
:: (%convert-integer) ( dst src bits quot -- )
|
||||||
dst { src } bits [| new-dst |
|
dst { src } bits |[ new-dst |
|
||||||
new-dst src int-rep %copy
|
new-dst src int-rep %copy
|
||||||
new-dst dup bits n-bit-version-of quot call
|
new-dst dup bits n-bit-version-of quot call
|
||||||
dst new-dst int-rep %copy
|
dst new-dst int-rep %copy
|
||||||
|
|
@ -377,7 +377,7 @@ M: x86 %convert-integer ( dst src c-type -- )
|
||||||
} case ;
|
} case ;
|
||||||
|
|
||||||
:: %alien-integer-getter ( dst exclude address bits quot -- )
|
:: %alien-integer-getter ( dst exclude address bits quot -- )
|
||||||
dst exclude bits [| new-dst |
|
dst exclude bits |[ new-dst |
|
||||||
new-dst dup bits n-bit-version-of dup address MOV
|
new-dst dup bits n-bit-version-of dup address MOV
|
||||||
quot call
|
quot call
|
||||||
dst new-dst int-rep %copy
|
dst new-dst int-rep %copy
|
||||||
|
|
@ -390,7 +390,7 @@ M: x86 %convert-integer ( dst src c-type -- )
|
||||||
[ MOVSX ] %alien-integer-getter ; inline
|
[ MOVSX ] %alien-integer-getter ; inline
|
||||||
|
|
||||||
:: %alien-integer-setter ( value exclude address bits -- )
|
:: %alien-integer-setter ( value exclude address bits -- )
|
||||||
value exclude bits [| new-value |
|
value exclude bits |[ new-value |
|
||||||
new-value value int-rep %copy
|
new-value value int-rep %copy
|
||||||
address new-value bits n-bit-version-of MOV
|
address new-value bits n-bit-version-of MOV
|
||||||
] with-small-register ; inline
|
] with-small-register ; inline
|
||||||
|
|
|
||||||
|
|
@ -47,7 +47,7 @@ symbol: euc-table
|
||||||
[ flat-file>biassoc ] bi* ;
|
[ flat-file>biassoc ] bi* ;
|
||||||
|
|
||||||
:: define-recursive-methods ( class data words -- )
|
:: define-recursive-methods ( class data words -- )
|
||||||
words [| word |
|
words |[ word |
|
||||||
class word [ drop data word execute ] define-method
|
class word [ drop data word execute ] define-method
|
||||||
] each ;
|
] each ;
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -30,7 +30,7 @@ tools.test unix unix.groups unix.users ;
|
||||||
{ "/lib/bux/" } [ "/usr" "/lib/bux/" append-path ] unit-test
|
{ "/lib/bux/" } [ "/usr" "/lib/bux/" append-path ] unit-test
|
||||||
{ t } [ "/foo" absolute-path? ] unit-test
|
{ t } [ "/foo" absolute-path? ] unit-test
|
||||||
|
|
||||||
[| path |
|
|[ path |
|
||||||
|
|
||||||
{ 0o777 } [
|
{ 0o777 } [
|
||||||
path flags{ USER-ALL GROUP-ALL OTHER-ALL } set-file-permissions
|
path flags{ USER-ALL GROUP-ALL OTHER-ALL } set-file-permissions
|
||||||
|
|
@ -117,7 +117,7 @@ tools.test unix unix.groups unix.users ;
|
||||||
|
|
||||||
] with-test-file
|
] with-test-file
|
||||||
|
|
||||||
[| path |
|
|[ path |
|
||||||
|
|
||||||
{ t } [
|
{ t } [
|
||||||
path now
|
path now
|
||||||
|
|
|
||||||
|
|
@ -5,7 +5,7 @@ specialized-arrays.instances.alien.c-types.uint tools.test ;
|
||||||
|
|
||||||
specialized-array: uint
|
specialized-array: uint
|
||||||
|
|
||||||
[| path |
|
|[ path |
|
||||||
"12345" path ascii set-file-contents
|
"12345" path ascii set-file-contents
|
||||||
{ } [ path [ char <mapped-array> char: 2 0 pick set-nth drop ] with-mapped-file ] unit-test
|
{ } [ path [ char <mapped-array> char: 2 0 pick set-nth drop ] with-mapped-file ] unit-test
|
||||||
{ 5 } [ path [ char <mapped-array> length ] with-mapped-file ] unit-test
|
{ 5 } [ path [ char <mapped-array> length ] with-mapped-file ] unit-test
|
||||||
|
|
@ -15,7 +15,7 @@ specialized-array: uint
|
||||||
{ t } [ path uint [ sum ] with-mapped-array-reader integer? ] unit-test
|
{ t } [ path uint [ sum ] with-mapped-array-reader integer? ] unit-test
|
||||||
] with-test-file
|
] with-test-file
|
||||||
|
|
||||||
[| path |
|
|[ path |
|
||||||
[ path [ drop ] with-mapped-file ] [ bad-mmap-size? ] must-fail-with
|
[ path [ drop ] with-mapped-file ] [ bad-mmap-size? ] must-fail-with
|
||||||
] with-test-file
|
] with-test-file
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -6,7 +6,7 @@ locals math namespaces sequences tools.test ;
|
||||||
! Make sure that writing malloced storage to a file works, and
|
! Make sure that writing malloced storage to a file works, and
|
||||||
! also make sure that writes larger than the buffer size work
|
! also make sure that writes larger than the buffer size work
|
||||||
|
|
||||||
[| path |
|
|[ path |
|
||||||
|
|
||||||
{ } [
|
{ } [
|
||||||
path binary [
|
path binary [
|
||||||
|
|
|
||||||
|
|
@ -82,7 +82,7 @@ ERROR: file-expected path ;
|
||||||
|
|
||||||
: password-callback ( -- alien )
|
: password-callback ( -- alien )
|
||||||
int { void* int bool void* } cdecl
|
int { void* int bool void* } cdecl
|
||||||
[| buf size rwflag password! |
|
|[ buf size rwflag password! |
|
||||||
password [ B{ 0 } password! ] unless
|
password [ B{ 0 } password! ] unless
|
||||||
|
|
||||||
password strlen :> len
|
password strlen :> len
|
||||||
|
|
|
||||||
|
|
@ -7,7 +7,7 @@ in: locals.prettyprint
|
||||||
|
|
||||||
: pprint-var ( var -- )
|
: pprint-var ( var -- )
|
||||||
! Prettyprint a read/write local as its writer, just like
|
! Prettyprint a read/write local as its writer, just like
|
||||||
! in the input syntax: [| x! | ... x 3 + x! ]
|
! in the input syntax: |[ x! | ... x 3 + x! ]
|
||||||
dup local-reader? [
|
dup local-reader? [
|
||||||
"local-writer" word-prop
|
"local-writer" word-prop
|
||||||
] when pprint-word ;
|
] when pprint-word ;
|
||||||
|
|
@ -16,7 +16,7 @@ in: locals.prettyprint
|
||||||
|
|
||||||
M: lambda pprint*
|
M: lambda pprint*
|
||||||
<flow
|
<flow
|
||||||
\ [| pprint-word
|
\ |[ pprint-word
|
||||||
dup vars>> pprint-vars
|
dup vars>> pprint-vars
|
||||||
"|" text
|
"|" text
|
||||||
f <inset body>> pprint-elements block>
|
f <inset body>> pprint-elements block>
|
||||||
|
|
|
||||||
|
|
@ -28,11 +28,11 @@ M: monad fail monad-of fail ;
|
||||||
: >> ( mvalue k -- mvalue' ) '[ drop _ ] bind ;
|
: >> ( mvalue k -- mvalue' ) '[ drop _ ] bind ;
|
||||||
|
|
||||||
:: lift-m2 ( m1 m2 f monad -- m3 )
|
:: lift-m2 ( m1 m2 f monad -- m3 )
|
||||||
m1 [| x1 | m2 [| x2 | x1 x2 f monad return ] bind ] bind ;
|
m1 |[ x1 | m2 |[ x2 | x1 x2 f monad return ] bind ] bind ;
|
||||||
|
|
||||||
:: apply ( mvalue mquot monad -- result )
|
:: apply ( mvalue mquot monad -- result )
|
||||||
mvalue [| value |
|
mvalue |[ value |
|
||||||
mquot [| quot |
|
mquot |[ quot |
|
||||||
value quot call( value -- mvalue ) monad return
|
value quot call( value -- mvalue ) monad return
|
||||||
] bind
|
] bind
|
||||||
] bind ;
|
] bind ;
|
||||||
|
|
|
||||||
|
|
@ -42,7 +42,7 @@ SYNTAX: \ STRING:
|
||||||
:: (scan-multiline-string) ( i end lexer -- j )
|
:: (scan-multiline-string) ( i end lexer -- j )
|
||||||
lexer line-text>> :> text
|
lexer line-text>> :> text
|
||||||
lexer still-parsing? [
|
lexer still-parsing? [
|
||||||
end text i start* [| j |
|
end text i start* |[ j |
|
||||||
i j text subseq % j end length +
|
i j text subseq % j end length +
|
||||||
] [
|
] [
|
||||||
text i short tail % char: \n ,
|
text i short tail % char: \n ,
|
||||||
|
|
|
||||||
|
|
@ -172,8 +172,8 @@ ERROR: no-vorbis-in-ogg ;
|
||||||
len max-len min :> len'
|
len max-len min :> len'
|
||||||
pcm #channels void* <c-direct-array> :> channel*s
|
pcm #channels void* <c-direct-array> :> channel*s
|
||||||
|
|
||||||
len' iota [| sample |
|
len' iota |[ sample |
|
||||||
#channels iota [| channel |
|
#channels iota |[ channel |
|
||||||
channel channel*s nth len c:float <c-direct-array>
|
channel channel*s nth len c:float <c-direct-array>
|
||||||
sample swap nth
|
sample swap nth
|
||||||
float>short-sample short-buffer push
|
float>short-sample short-buffer push
|
||||||
|
|
|
||||||
|
|
@ -107,8 +107,8 @@ M:: chipmunk-world begin-game-world ( world -- )
|
||||||
space 2.0 10000 cpSpaceResizeActiveHash
|
space 2.0 10000 cpSpaceResizeActiveHash
|
||||||
space 1 >>iterations drop
|
space 1 >>iterations drop
|
||||||
|
|
||||||
image-height iota [| y |
|
image-height iota |[ y |
|
||||||
image-width iota [| x |
|
image-width iota |[ x |
|
||||||
x y get-pixel [
|
x y get-pixel [
|
||||||
x image-width 2 / - 0.05 random-unit * + 2 *
|
x image-width 2 / - 0.05 random-unit * + 2 *
|
||||||
image-height 2 / y - 0.05 random-unit * + 2 *
|
image-height 2 / y - 0.05 random-unit * + 2 *
|
||||||
|
|
|
||||||
|
|
@ -453,7 +453,7 @@ TYPED: cpPolyShapeContainsVert ( poly: cpPolyShape v: cpVect -- ? )
|
||||||
|
|
||||||
TYPED: cpPolyShapeContainsVertPartial ( poly: cpPolyShape v: cpVect n: cpVect -- ? )
|
TYPED: cpPolyShapeContainsVertPartial ( poly: cpPolyShape v: cpVect n: cpVect -- ? )
|
||||||
rot [ numVerts>> ] [ tAxes>> swap cpPolyShapeAxis <c-direct-array> ] bi -rot
|
rot [ numVerts>> ] [ tAxes>> swap cpPolyShapeAxis <c-direct-array> ] bi -rot
|
||||||
[| axis v n |
|
|[ axis v n |
|
||||||
axis n>> n cpvdot 0.0 < 0
|
axis n>> n cpvdot 0.0 < 0
|
||||||
[ 0.0 ]
|
[ 0.0 ]
|
||||||
[ axis n>> v cpvdot axis d>> - ]
|
[ axis n>> v cpvdot axis d>> - ]
|
||||||
|
|
|
||||||
|
|
@ -7,9 +7,9 @@ sequences tools.test ;
|
||||||
in: colors.cmyk
|
in: colors.cmyk
|
||||||
|
|
||||||
{ t } [
|
{ t } [
|
||||||
0.0 1.0 0.1 <range> [| r |
|
0.0 1.0 0.1 <range> |[ r |
|
||||||
0.0 1.0 0.1 <range> [| g |
|
0.0 1.0 0.1 <range> |[ g |
|
||||||
0.0 1.0 0.1 <range> [| b |
|
0.0 1.0 0.1 <range> |[ b |
|
||||||
r g b 1.0 <rgba> dup >cmyka >rgba
|
r g b 1.0 <rgba> dup >cmyka >rgba
|
||||||
[ >rgba-components 4array ] bi@
|
[ >rgba-components 4array ] bi@
|
||||||
[ 0.00000001 ~ ] 2all?
|
[ 0.00000001 ~ ] 2all?
|
||||||
|
|
|
||||||
|
|
@ -7,9 +7,9 @@ sequences tools.test ;
|
||||||
in: colors.hsl
|
in: colors.hsl
|
||||||
|
|
||||||
{ t } [
|
{ t } [
|
||||||
0.0 1.0 0.1 <range> [| r |
|
0.0 1.0 0.1 <range> |[ r |
|
||||||
0.0 1.0 0.1 <range> [| g |
|
0.0 1.0 0.1 <range> |[ g |
|
||||||
0.0 1.0 0.1 <range> [| b |
|
0.0 1.0 0.1 <range> |[ b |
|
||||||
r g b 1.0 <rgba> dup >hsla >rgba
|
r g b 1.0 <rgba> dup >hsla >rgba
|
||||||
[ >rgba-components 4array ] bi@
|
[ >rgba-components 4array ] bi@
|
||||||
[ 0.00000001 ~ ] 2all?
|
[ 0.00000001 ~ ] 2all?
|
||||||
|
|
|
||||||
|
|
@ -31,7 +31,7 @@ PRIVATE>
|
||||||
M: hsla >rgba
|
M: hsla >rgba
|
||||||
{
|
{
|
||||||
[ hue>> ] [ saturation>> ] [ lightness>> ] [ alpha>> ]
|
[ hue>> ] [ saturation>> ] [ lightness>> ] [ alpha>> ]
|
||||||
} cleave [| h s l |
|
} cleave |[ h s l |
|
||||||
s zero? [
|
s zero? [
|
||||||
l l l
|
l l l
|
||||||
] [
|
] [
|
||||||
|
|
@ -50,7 +50,7 @@ M: object >hsla >rgba >hsla ;
|
||||||
M: hsla >hsla ; inline
|
M: hsla >hsla ; inline
|
||||||
|
|
||||||
M: rgba >hsla
|
M: rgba >hsla
|
||||||
>rgba-components [| r g b |
|
>rgba-components |[ r g b |
|
||||||
r g b min min :> min-c
|
r g b min min :> min-c
|
||||||
r g b max max :> max-c
|
r g b max max :> max-c
|
||||||
min-c max-c + 2 / :> l
|
min-c max-c + 2 / :> l
|
||||||
|
|
|
||||||
|
|
@ -7,9 +7,9 @@ sequences tools.test ;
|
||||||
in: colors.lab
|
in: colors.lab
|
||||||
|
|
||||||
{ t } [
|
{ t } [
|
||||||
0.0 1.0 0.1 <range> [| r |
|
0.0 1.0 0.1 <range> |[ r |
|
||||||
0.0 1.0 0.1 <range> [| g |
|
0.0 1.0 0.1 <range> |[ g |
|
||||||
0.0 1.0 0.1 <range> [| b |
|
0.0 1.0 0.1 <range> |[ b |
|
||||||
r g b 1.0 <rgba> dup >laba >rgba
|
r g b 1.0 <rgba> dup >laba >rgba
|
||||||
[ >rgba-components 4array ] bi@
|
[ >rgba-components 4array ] bi@
|
||||||
[ 0.00001 ~ ] 2all?
|
[ 0.00001 ~ ] 2all?
|
||||||
|
|
|
||||||
|
|
@ -7,9 +7,9 @@ sequences tools.test ;
|
||||||
in: colors.lch
|
in: colors.lch
|
||||||
|
|
||||||
{ t } [
|
{ t } [
|
||||||
0.0 1.0 0.1 <range> [| r |
|
0.0 1.0 0.1 <range> |[ r |
|
||||||
0.0 1.0 0.1 <range> [| g |
|
0.0 1.0 0.1 <range> |[ g |
|
||||||
0.0 1.0 0.1 <range> [| b |
|
0.0 1.0 0.1 <range> |[ b |
|
||||||
r g b 1.0 <rgba> dup >LCHuv >rgba
|
r g b 1.0 <rgba> dup >LCHuv >rgba
|
||||||
[ >rgba-components 4array ] bi@
|
[ >rgba-components 4array ] bi@
|
||||||
[ 0.00001 ~ ] 2all?
|
[ 0.00001 ~ ] 2all?
|
||||||
|
|
@ -19,9 +19,9 @@ in: colors.lch
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
{ t } [
|
{ t } [
|
||||||
0.0 1.0 0.1 <range> [| r |
|
0.0 1.0 0.1 <range> |[ r |
|
||||||
0.0 1.0 0.1 <range> [| g |
|
0.0 1.0 0.1 <range> |[ g |
|
||||||
0.0 1.0 0.1 <range> [| b |
|
0.0 1.0 0.1 <range> |[ b |
|
||||||
r g b 1.0 <rgba> dup >LCHab >rgba
|
r g b 1.0 <rgba> dup >LCHab >rgba
|
||||||
[ >rgba-components 4array ] bi@
|
[ >rgba-components 4array ] bi@
|
||||||
[ 0.00001 ~ ] 2all?
|
[ 0.00001 ~ ] 2all?
|
||||||
|
|
|
||||||
|
|
@ -7,9 +7,9 @@ sequences tools.test ;
|
||||||
in: colors.luv
|
in: colors.luv
|
||||||
|
|
||||||
{ t } [
|
{ t } [
|
||||||
0.0 1.0 0.1 <range> [| r |
|
0.0 1.0 0.1 <range> |[ r |
|
||||||
0.0 1.0 0.1 <range> [| g |
|
0.0 1.0 0.1 <range> |[ g |
|
||||||
0.0 1.0 0.1 <range> [| b |
|
0.0 1.0 0.1 <range> |[ b |
|
||||||
r g b 1.0 <rgba> dup >luva >rgba
|
r g b 1.0 <rgba> dup >luva >rgba
|
||||||
[ >rgba-components 4array ] bi@
|
[ >rgba-components 4array ] bi@
|
||||||
[ 0.00001 ~ ] 2all?
|
[ 0.00001 ~ ] 2all?
|
||||||
|
|
|
||||||
|
|
@ -7,9 +7,9 @@ sequences tools.test ;
|
||||||
in: colors.ryb
|
in: colors.ryb
|
||||||
|
|
||||||
{ t } [
|
{ t } [
|
||||||
0.0 1.0 0.1 <range> [| r |
|
0.0 1.0 0.1 <range> |[ r |
|
||||||
0.0 1.0 0.1 <range> [| g |
|
0.0 1.0 0.1 <range> |[ g |
|
||||||
0.0 1.0 0.1 <range> [| b |
|
0.0 1.0 0.1 <range> |[ b |
|
||||||
r g b 1.0 <rgba> dup >ryba >rgba
|
r g b 1.0 <rgba> dup >ryba >rgba
|
||||||
[ >rgba-components 4array ] bi@
|
[ >rgba-components 4array ] bi@
|
||||||
[ 0.00000001 ~ ] 2all?
|
[ 0.00000001 ~ ] 2all?
|
||||||
|
|
|
||||||
|
|
@ -7,9 +7,9 @@ sequences tools.test ;
|
||||||
in: colors.xyy
|
in: colors.xyy
|
||||||
|
|
||||||
{ t } [
|
{ t } [
|
||||||
0.0 1.0 0.1 <range> [| r |
|
0.0 1.0 0.1 <range> |[ r |
|
||||||
0.0 1.0 0.1 <range> [| g |
|
0.0 1.0 0.1 <range> |[ g |
|
||||||
0.0 1.0 0.1 <range> [| b |
|
0.0 1.0 0.1 <range> |[ b |
|
||||||
r g b 1.0 <rgba> dup >xyYa >rgba
|
r g b 1.0 <rgba> dup >xyYa >rgba
|
||||||
[ >rgba-components 4array ] bi@
|
[ >rgba-components 4array ] bi@
|
||||||
[ 0.00001 ~ ] 2all?
|
[ 0.00001 ~ ] 2all?
|
||||||
|
|
|
||||||
|
|
@ -7,9 +7,9 @@ sequences tools.test ;
|
||||||
in: colors.xyz
|
in: colors.xyz
|
||||||
|
|
||||||
{ t } [
|
{ t } [
|
||||||
0.0 1.0 0.1 <range> [| r |
|
0.0 1.0 0.1 <range> |[ r |
|
||||||
0.0 1.0 0.1 <range> [| g |
|
0.0 1.0 0.1 <range> |[ g |
|
||||||
0.0 1.0 0.1 <range> [| b |
|
0.0 1.0 0.1 <range> |[ b |
|
||||||
r g b 1.0 <rgba> dup >xyza >rgba
|
r g b 1.0 <rgba> dup >xyza >rgba
|
||||||
[ >rgba-components 4array ] bi@
|
[ >rgba-components 4array ] bi@
|
||||||
[ 0.00001 ~ ] 2all?
|
[ 0.00001 ~ ] 2all?
|
||||||
|
|
|
||||||
|
|
@ -7,9 +7,9 @@ sequences tools.test ;
|
||||||
in: colors.yiq
|
in: colors.yiq
|
||||||
|
|
||||||
{ t } [
|
{ t } [
|
||||||
0.0 1.0 0.1 <range> [| r |
|
0.0 1.0 0.1 <range> |[ r |
|
||||||
0.0 1.0 0.1 <range> [| g |
|
0.0 1.0 0.1 <range> |[ g |
|
||||||
0.0 1.0 0.1 <range> [| b |
|
0.0 1.0 0.1 <range> |[ b |
|
||||||
r g b 1.0 <rgba> dup >yiqa >rgba
|
r g b 1.0 <rgba> dup >yiqa >rgba
|
||||||
[ >rgba-components 4array ] bi@
|
[ >rgba-components 4array ] bi@
|
||||||
[ 0.00000001 ~ ] 2all?
|
[ 0.00000001 ~ ] 2all?
|
||||||
|
|
|
||||||
|
|
@ -7,9 +7,9 @@ sequences tools.test ;
|
||||||
in: colors.yuv
|
in: colors.yuv
|
||||||
|
|
||||||
{ t } [
|
{ t } [
|
||||||
0.0 1.0 0.1 <range> [| r |
|
0.0 1.0 0.1 <range> |[ r |
|
||||||
0.0 1.0 0.1 <range> [| g |
|
0.0 1.0 0.1 <range> |[ g |
|
||||||
0.0 1.0 0.1 <range> [| b |
|
0.0 1.0 0.1 <range> |[ b |
|
||||||
r g b 1.0 <rgba> dup >yuva >rgba
|
r g b 1.0 <rgba> dup >yuva >rgba
|
||||||
[ >rgba-components 4array ] bi@
|
[ >rgba-components 4array ] bi@
|
||||||
[ 0.00000001 ~ ] 2all?
|
[ 0.00000001 ~ ] 2all?
|
||||||
|
|
|
||||||
|
|
@ -26,7 +26,7 @@ PRIVATE>
|
||||||
|
|
||||||
M: yuva >rgba
|
M: yuva >rgba
|
||||||
{ [ y>> ] [ u>> ] [ v>> ] [ alpha>> ] } cleave
|
{ [ y>> ] [ u>> ] [ v>> ] [ alpha>> ] } cleave
|
||||||
[| y u v |
|
|[ y u v |
|
||||||
y 1 Wr - Vmax / v * +
|
y 1 Wr - Vmax / v * +
|
||||||
|
|
||||||
y
|
y
|
||||||
|
|
|
||||||
|
|
@ -575,7 +575,7 @@ M:: elf sections ( elf -- sections )
|
||||||
elf elf-header>> :> elf-header
|
elf elf-header>> :> elf-header
|
||||||
|
|
||||||
elf-header elf-sections
|
elf-header elf-sections
|
||||||
[| name header |
|
|[ name header |
|
||||||
elf-header header elf-section-data :> data
|
elf-header header elf-section-data :> data
|
||||||
name elf-header header data section boa
|
name elf-header header data section boa
|
||||||
] { } assoc>map ;
|
] { } assoc>map ;
|
||||||
|
|
@ -584,7 +584,7 @@ M:: elf sections ( elf -- sections )
|
||||||
elf elf-header>> :> elf-header
|
elf elf-header>> :> elf-header
|
||||||
|
|
||||||
elf-header elf-program-headers
|
elf-header elf-program-headers
|
||||||
[| header |
|
|[ header |
|
||||||
elf-header header elf-segment-data :> data
|
elf-header header elf-segment-data :> data
|
||||||
elf-header header data segment boa
|
elf-header header data segment boa
|
||||||
] { } map-as ;
|
] { } map-as ;
|
||||||
|
|
@ -596,7 +596,7 @@ M:: segment sections ( segment -- sections )
|
||||||
program-header elf-header
|
program-header elf-header
|
||||||
elf-section-headers
|
elf-section-headers
|
||||||
elf-segment-sections
|
elf-segment-sections
|
||||||
[| header |
|
|[ header |
|
||||||
elf-header header elf-section-name :> name
|
elf-header header elf-section-name :> name
|
||||||
elf-header header elf-section-data :> data
|
elf-header header elf-section-data :> data
|
||||||
name elf-header header data section boa
|
name elf-header header data section boa
|
||||||
|
|
@ -607,7 +607,7 @@ M:: segment sections ( segment -- sections )
|
||||||
section data>> :> data
|
section data>> :> data
|
||||||
|
|
||||||
elf-header data elf-symbols
|
elf-header data elf-symbols
|
||||||
[| name sym |
|
|[ name sym |
|
||||||
name elf-header sym f symbol boa
|
name elf-header sym f symbol boa
|
||||||
] { } assoc>map ;
|
] { } assoc>map ;
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -226,7 +226,7 @@ ERROR: b-rep-not-empty b-rep ;
|
||||||
:: connecting-edge ( e0 e1 -- edge/f )
|
:: connecting-edge ( e0 e1 -- edge/f )
|
||||||
e1 vertex>> :> target-vertex
|
e1 vertex>> :> target-vertex
|
||||||
e0 vertex>> target-vertex eq? [ f ] [
|
e0 vertex>> target-vertex eq? [ f ] [
|
||||||
f e0 [| ret edge |
|
f e0 |[ ret edge |
|
||||||
edge opposite-edge>> vertex>> target-vertex eq?
|
edge opposite-edge>> vertex>> target-vertex eq?
|
||||||
[ edge edge f ]
|
[ edge edge f ]
|
||||||
[ f edge vertex-cw dup e0 eq? not ] if
|
[ f edge vertex-cw dup e0 eq? not ] if
|
||||||
|
|
|
||||||
|
|
@ -12,7 +12,7 @@ in: euler.b-rep.subdivision
|
||||||
:: edge-points ( edges edge-indices face-indices face-points -- edge-pts )
|
:: edge-points ( edges edge-indices face-indices face-points -- edge-pts )
|
||||||
edges length 0 <array> :> edge-pts
|
edges length 0 <array> :> edge-pts
|
||||||
|
|
||||||
edges [| edge n |
|
edges |[ edge n |
|
||||||
edge opposite-edge>> :> opposite-edge
|
edge opposite-edge>> :> opposite-edge
|
||||||
opposite-edge edge-indices at :> opposite-n
|
opposite-edge edge-indices at :> opposite-n
|
||||||
|
|
||||||
|
|
@ -31,9 +31,9 @@ in: euler.b-rep.subdivision
|
||||||
edge-pts ; inline
|
edge-pts ; inline
|
||||||
|
|
||||||
:: vertex-points ( vertices edge-indices face-indices edge-pts face-points -- vertex-pts )
|
:: vertex-points ( vertices edge-indices face-indices edge-pts face-points -- vertex-pts )
|
||||||
vertices [| vertex |
|
vertices |[ vertex |
|
||||||
0 double-4{ 0 0 0 0 } double-4{ 0 0 0 0 }
|
0 double-4{ 0 0 0 0 } double-4{ 0 0 0 0 }
|
||||||
vertex edge>> [| valence face-sum edge-sum edge |
|
vertex edge>> |[ valence face-sum edge-sum edge |
|
||||||
valence 1 +
|
valence 1 +
|
||||||
face-sum edge face>> face-indices at face-points nth position>> v+
|
face-sum edge face>> face-indices at face-points nth position>> v+
|
||||||
edge-sum edge next-edge>> vertex>> position>> v+
|
edge-sum edge next-edge>> vertex>> position>> v+
|
||||||
|
|
@ -63,7 +63,7 @@ TYPED:: subdivide ( brep: b-rep -- brep': b-rep )
|
||||||
V{ } clone :> sub-faces
|
V{ } clone :> sub-faces
|
||||||
|
|
||||||
vertices [
|
vertices [
|
||||||
edge>> [| edg |
|
edge>> |[ edg |
|
||||||
edg edge-indices at edge-pts nth :> point-a
|
edg edge-indices at edge-pts nth :> point-a
|
||||||
edg next-edge>> :> next-edg
|
edg next-edge>> :> next-edg
|
||||||
next-edg vertex>> :> next-vertex
|
next-edg vertex>> :> next-vertex
|
||||||
|
|
|
||||||
|
|
@ -11,24 +11,24 @@ ERROR: triangulated-face-must-be-base ;
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
: tess-begin ( -- callback )
|
: tess-begin ( -- callback )
|
||||||
[| primitive-type vertices-h |
|
|[ primitive-type vertices-h |
|
||||||
primitive-type GL_TRIANGLES =
|
primitive-type GL_TRIANGLES =
|
||||||
[ "unexpected primitive type" throw ] unless
|
[ "unexpected primitive type" throw ] unless
|
||||||
] GLUtessBeginDataCallback ;
|
] GLUtessBeginDataCallback ;
|
||||||
|
|
||||||
: tess-end ( -- callback )
|
: tess-end ( -- callback )
|
||||||
[| vertices-h |
|
|[ vertices-h |
|
||||||
! nop
|
! nop
|
||||||
] GLUtessEndDataCallback ;
|
] GLUtessEndDataCallback ;
|
||||||
|
|
||||||
: tess-vertex ( -- callback )
|
: tess-vertex ( -- callback )
|
||||||
[| vertex-h vertices-h |
|
|[ vertex-h vertices-h |
|
||||||
vertex-h alien-handle-ptr>
|
vertex-h alien-handle-ptr>
|
||||||
vertices-h alien-handle-ptr> push
|
vertices-h alien-handle-ptr> push
|
||||||
] GLUtessVertexDataCallback ;
|
] GLUtessVertexDataCallback ;
|
||||||
|
|
||||||
: tess-edge-flag ( -- callback )
|
: tess-edge-flag ( -- callback )
|
||||||
[| flag vertices-h |
|
|[ flag vertices-h |
|
||||||
! nop
|
! nop
|
||||||
] GLUtessEdgeFlagDataCallback ;
|
] GLUtessEdgeFlagDataCallback ;
|
||||||
|
|
||||||
|
|
@ -51,7 +51,7 @@ PRIVATE>
|
||||||
|
|
||||||
4 double malloc-array &free :> vertex-buf
|
4 double malloc-array &free :> vertex-buf
|
||||||
|
|
||||||
face [| ring |
|
face |[ ring |
|
||||||
tess gluTessBeginContour
|
tess gluTessBeginContour
|
||||||
|
|
||||||
ring edge>> [
|
ring edge>> [
|
||||||
|
|
|
||||||
|
|
@ -76,7 +76,7 @@ defer: glob%
|
||||||
globs ?second :> next-glob
|
globs ?second :> next-glob
|
||||||
next-glob dup pair? [ second ] [ drop f ] if :> next-glob-regexp
|
next-glob dup pair? [ second ] [ drop f ] if :> next-glob-regexp
|
||||||
|
|
||||||
root glob-entries [| entry |
|
root glob-entries |[ entry |
|
||||||
root entry name>> append-path
|
root entry name>> append-path
|
||||||
{
|
{
|
||||||
{ [ next-glob not ] [ dup , ] }
|
{ [ next-glob not ] [ dup , ] }
|
||||||
|
|
@ -113,7 +113,7 @@ defer: glob%
|
||||||
:: glob-pattern% ( root globs -- )
|
:: glob-pattern% ( root globs -- )
|
||||||
globs unclip second :> ( remaining glob )
|
globs unclip second :> ( remaining glob )
|
||||||
|
|
||||||
root glob-entries [| entry |
|
root glob-entries |[ entry |
|
||||||
entry name>> >case-fold glob matches? [
|
entry name>> >case-fold glob matches? [
|
||||||
root entry name>> append-path
|
root entry name>> append-path
|
||||||
remaining entry ?glob%
|
remaining entry ?glob%
|
||||||
|
|
|
||||||
|
|
@ -45,7 +45,7 @@ TUPLE: b-rep-vertices
|
||||||
float-4-vector{ } clone :> vertices
|
float-4-vector{ } clone :> vertices
|
||||||
ushort-vector{ } clone :> indices
|
ushort-vector{ } clone :> indices
|
||||||
|
|
||||||
0 b-rep faces>> [| count face |
|
0 b-rep faces>> |[ count face |
|
||||||
face selected face-selected? :> selected?
|
face selected face-selected? :> selected?
|
||||||
face dup base-face>> eq? [
|
face dup base-face>> eq? [
|
||||||
face edge>> face-color
|
face edge>> face-color
|
||||||
|
|
@ -94,7 +94,7 @@ M: sequence selected-vectors [ selected-vectors ] map concat ;
|
||||||
b-rep vertices>> >index-hash :> vertex-indices
|
b-rep vertices>> >index-hash :> vertex-indices
|
||||||
b-rep edges>> length <ushort-vector> :> edge-indices
|
b-rep edges>> length <ushort-vector> :> edge-indices
|
||||||
|
|
||||||
b-rep edges>> [| e |
|
b-rep edges>> |[ e |
|
||||||
e opposite-edge>> :> o
|
e opposite-edge>> :> o
|
||||||
e vertex-indices selected edge-vertex-index [ offset + ] dip :> ( from e-selected? )
|
e vertex-indices selected edge-vertex-index [ offset + ] dip :> ( from e-selected? )
|
||||||
o vertex-indices selected edge-vertex-index [ offset + ] dip :> ( to o-selected? )
|
o vertex-indices selected edge-vertex-index [ offset + ] dip :> ( to o-selected? )
|
||||||
|
|
|
||||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue