factor: rename :> to set:
Doug Coleman
parent
a0d1316c8d
commit
0efa16c1f1
|
|
@ -12,10 +12,10 @@ IN: benchmark.3d-matrix-scalar
|
|||
location vneg translation-matrix4 m. m. ;
|
||||
|
||||
:: 3d-matrix-scalar-benchmark ( -- )
|
||||
f :> result!
|
||||
f set: result!
|
||||
100000 [
|
||||
{ 1024.0 768.0 } 0.7 0.25 1024.0 p-matrix :> p
|
||||
3.0 1.0 { 10.0 -0.0 2.0 } mv-matrix :> mv
|
||||
{ 1024.0 768.0 } 0.7 0.25 1024.0 p-matrix set: p
|
||||
3.0 1.0 { 10.0 -0.0 2.0 } mv-matrix set: mv
|
||||
mv p m. result!
|
||||
] times
|
||||
result . ;
|
||||
|
|
|
|||
|
|
@ -16,10 +16,10 @@ TYPED:: mv-matrix ( pitch: float yaw: float location: float-4 -- matrix: matrix4
|
|||
location vneg translation-matrix4 m4. m4. ;
|
||||
|
||||
:: 3d-matrix-vector-benchmark ( -- )
|
||||
f :> result!
|
||||
f set: result!
|
||||
100000 [
|
||||
float-4{ 1024.0 768.0 0.0 0.0 } 0.7 0.25 1024.0 p-matrix :> p
|
||||
3.0 1.0 float-4{ 10.0 -0.0 2.0 0.0 } mv-matrix :> mv
|
||||
float-4{ 1024.0 768.0 0.0 0.0 } 0.7 0.25 1024.0 p-matrix set: p
|
||||
3.0 1.0 float-4{ 10.0 -0.0 2.0 0.0 } mv-matrix set: mv
|
||||
mv p m4. result!
|
||||
] times
|
||||
result . ;
|
||||
|
|
|
|||
|
|
@ -35,14 +35,14 @@ C: <point> point ;
|
|||
[ x>> ] [ y>> ] bi [ sum-digits ] bi@ + 25 <= ; inline
|
||||
|
||||
:: ant-benchmark ( -- )
|
||||
200000 <hash-set> :> seen
|
||||
100000 <vector> :> stack
|
||||
0 :> total!
|
||||
200000 <hash-set> set: seen
|
||||
100000 <vector> set: stack
|
||||
0 set: total!
|
||||
|
||||
1000 1000 <point> stack push
|
||||
|
||||
[ stack empty? ] [
|
||||
stack pop :> p
|
||||
stack pop set: p
|
||||
p seen ?adjoin [
|
||||
p walkable? [
|
||||
total 1 + total!
|
||||
|
|
|
|||
|
|
@ -7,9 +7,9 @@ IN: benchmark.beust2
|
|||
|
||||
:: (count-numbers) ( remaining first value used max listener: ( -- ) -- ? )
|
||||
10 first - iota |[ i |
|
||||
i first + :> digit
|
||||
digit 2^ :> mask
|
||||
i value + :> value'
|
||||
i first + set: digit
|
||||
digit 2^ set: mask
|
||||
i value + set: value'
|
||||
used mask bitand zero? [
|
||||
value max > [ t ] [
|
||||
remaining 1 <= [
|
||||
|
|
@ -31,7 +31,7 @@ IN: benchmark.beust2
|
|||
10 iota [ 1 + 1 1 0 max listener (count-numbers) ] any? drop ; inline
|
||||
|
||||
:: beust2-benchmark ( -- )
|
||||
0 :> i!
|
||||
0 set: i!
|
||||
5000000000 [ i 1 + i! ] count-numbers
|
||||
i 7063290 assert= ;
|
||||
|
||||
|
|
|
|||
|
|
@ -68,15 +68,15 @@ TYPED: write-random-fasta ( seed: float n: fixnum chars: byte-array floats: doub
|
|||
$[ _ _ make-random-fasta ] split-lines ;
|
||||
|
||||
TYPED:: make-repeat-fasta ( k: fixnum len: fixnum alu: string -- k': fixnum )
|
||||
alu length :> kn
|
||||
alu length set: kn
|
||||
len iota [ k + kn mod alu nth-unsafe ] "" map-as print
|
||||
k len + ;
|
||||
|
||||
: write-repeat-fasta ( n alu desc id -- )
|
||||
write-description
|
||||
let[
|
||||
:> alu
|
||||
0 :> k!
|
||||
set: alu
|
||||
0 set: k!
|
||||
|[ len | k len alu make-repeat-fasta k! ] split-lines
|
||||
] ;
|
||||
|
||||
|
|
@ -84,8 +84,8 @@ TYPED:: make-repeat-fasta ( k: fixnum len: fixnum alu: string -- k': fixnum )
|
|||
homo-sapiens make-cumulative
|
||||
IUB make-cumulative
|
||||
let[
|
||||
:> ( n out IUB-chars IUB-floats homo-sapiens-chars homo-sapiens-floats )
|
||||
initial-seed :> seed
|
||||
set: ( n out IUB-chars IUB-floats homo-sapiens-chars homo-sapiens-floats )
|
||||
initial-seed set: seed
|
||||
|
||||
out ascii [
|
||||
n 2 * ALU "Homo sapiens alu" "ONE" write-repeat-fasta
|
||||
|
|
|
|||
|
|
@ -3,8 +3,8 @@ IN: benchmark.fib7
|
|||
|
||||
:: matrix-fib ( m -- n )
|
||||
m 0 >= [ m throw ] unless
|
||||
m 2 >base [ char: 1 = ] { } map-as :> bits
|
||||
1 :> a! 0 :> b! 1 :> c!
|
||||
m 2 >base [ char: 1 = ] { } map-as set: bits
|
||||
1 set: a! 0 set: b! 1 set: c!
|
||||
bits [
|
||||
[
|
||||
a c + b *
|
||||
|
|
|
|||
|
|
@ -14,8 +14,8 @@ IN: benchmark.matrix-exponential-scalar
|
|||
] each ;
|
||||
|
||||
:: matrix-exponential-scalar-benchmark ( -- )
|
||||
f :> result!
|
||||
4 identity-matrix :> i4
|
||||
f set: result!
|
||||
4 identity-matrix set: i4
|
||||
10000 [
|
||||
i4 20 e^m result!
|
||||
] times
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ TYPED:: e^m4 ( m: matrix4 iterations: fixnum -- e^m: matrix4 )
|
|||
] each ;
|
||||
|
||||
:: matrix-exponential-simd-benchmark ( -- )
|
||||
f :> result!
|
||||
f set: result!
|
||||
10000 [
|
||||
identity-matrix4 20 e^m4 result!
|
||||
] times
|
||||
|
|
|
|||
|
|
@ -36,7 +36,7 @@ IN: benchmark.pidigits
|
|||
|
||||
:: (pidigits) ( k z n row col -- )
|
||||
n 0 > [
|
||||
z next :> y
|
||||
z next set: y
|
||||
z y safe? [
|
||||
col 10 = [
|
||||
row 10 + y "\t:%d\n%d" printf
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@ sequences ;
|
|||
IN: benchmark.sieve
|
||||
|
||||
:: sieve ( n -- #primes )
|
||||
n dup odd? [ 1 + ] when 2/ <bit-array> :> sieve
|
||||
n dup odd? [ 1 + ] when 2/ <bit-array> set: sieve
|
||||
t 0 sieve set-nth
|
||||
|
||||
3 n sqrt 2 <range> |[ i |
|
||||
|
|
|
|||
|
|
@ -18,10 +18,10 @@ STRUCT: yuv-buffer
|
|||
{ v void* } ;
|
||||
|
||||
:: fake-data ( -- rgb yuv )
|
||||
1600 :> w
|
||||
1200 :> h
|
||||
yuv-buffer <struct> :> buffer
|
||||
w h * 3 * <byte-array> :> rgb
|
||||
1600 set: w
|
||||
1200 set: h
|
||||
yuv-buffer <struct> set: buffer
|
||||
w h * 3 * <byte-array> set: rgb
|
||||
rgb buffer
|
||||
w >>y_width
|
||||
h >>y_height
|
||||
|
|
|
|||
|
|
@ -109,20 +109,20 @@ ERROR: not-enough-widthed-bits widthed n ;
|
|||
[ swap bits>> ] B{ } produce-as nip swap ;
|
||||
|
||||
:: |widthed ( widthed1 widthed2 -- widthed3 )
|
||||
widthed1 bits>> :> bits1
|
||||
widthed1 #bits>> :> #bits1
|
||||
widthed2 bits>> :> bits2
|
||||
widthed2 #bits>> :> #bits2
|
||||
widthed1 bits>> set: bits1
|
||||
widthed1 #bits>> set: #bits1
|
||||
widthed2 bits>> set: bits2
|
||||
widthed2 #bits>> set: #bits2
|
||||
bits1 #bits2 shift bits2 bitor
|
||||
#bits1 #bits2 + <widthed> ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
M:: lsb0-bit-writer poke ( value n bs -- )
|
||||
value n <widthed> :> widthed
|
||||
value n <widthed> set: widthed
|
||||
widthed
|
||||
bs widthed>> #bits>> 8 swap - split-widthed :> ( byte remainder )
|
||||
byte bs widthed>> |widthed :> new-byte
|
||||
bs widthed>> #bits>> 8 swap - split-widthed set: ( byte remainder )
|
||||
byte bs widthed>> |widthed set: new-byte
|
||||
new-byte #bits>> 8 = [
|
||||
new-byte bits>> bs bytes>> push
|
||||
zero-widthed bs widthed<<
|
||||
|
|
@ -151,7 +151,7 @@ ERROR: not-enough-bits n bit-reader ;
|
|||
neg shift n bits ;
|
||||
|
||||
:: adjust-bits ( n bs -- )
|
||||
n 8 /mod :> ( #bytes #bits )
|
||||
n 8 /mod set: ( #bytes #bits )
|
||||
bs [ #bytes + ] change-byte-pos
|
||||
bit-pos>> #bits + dup 8 >= [
|
||||
8 - bs bit-pos<<
|
||||
|
|
@ -173,7 +173,7 @@ M: msb0-bit-reader peek ( n bs -- bits )
|
|||
\ be> \ subseq>bits-be (peek) ;
|
||||
|
||||
:: bit-writer-bytes ( writer -- bytes )
|
||||
writer widthed>> #bits>> :> n
|
||||
writer widthed>> #bits>> set: n
|
||||
n 0 = [
|
||||
writer widthed>> bits>> 8 n - shift
|
||||
writer bytes>> push
|
||||
|
|
|
|||
|
|
@ -28,7 +28,7 @@ PRIVATE>
|
|||
GENERIC: representative ( a disjoint-set -- p ) ;
|
||||
|
||||
M:: disjoint-set representative ( a disjoint-set -- p )
|
||||
a disjoint-set parents>> at :> p
|
||||
a disjoint-set parents>> at set: p
|
||||
a p = [ a ] [
|
||||
p disjoint-set representative [
|
||||
a disjoint-set set-parent
|
||||
|
|
|
|||
|
|
@ -118,30 +118,30 @@ TUPLE: my-node < dlist-link { obj fixnum } ;
|
|||
|
||||
{ V{ } } [ <dlist> 1 <my-node> over push-node-back [ [ back>> ] [ ] bi delete-node ] [ ] bi dlist>sequence ] unit-test
|
||||
[ V{ 1 2 } t ] |[ |
|
||||
<dlist> :> dl
|
||||
1 <my-node> :> n1 n1 dl push-node-back
|
||||
2 <my-node> :> n2 n2 dl push-node-back
|
||||
3 <my-node> :> n3 n3 dl push-node-back
|
||||
<dlist> set: dl
|
||||
1 <my-node> set: n1 n1 dl push-node-back
|
||||
2 <my-node> set: n2 n2 dl push-node-back
|
||||
3 <my-node> set: n3 n3 dl push-node-back
|
||||
|
||||
n3 dl delete-node n3 assert-links
|
||||
dl dlist>sequence dup >dlist dl =
|
||||
] unit-test
|
||||
|
||||
[ V{ 1 3 } t ] |[ |
|
||||
<dlist> :> dl
|
||||
1 <my-node> :> n1 n1 dl push-node-back
|
||||
2 <my-node> :> n2 n2 dl push-node-back
|
||||
3 <my-node> :> n3 n3 dl push-node-back
|
||||
<dlist> set: dl
|
||||
1 <my-node> set: n1 n1 dl push-node-back
|
||||
2 <my-node> set: n2 n2 dl push-node-back
|
||||
3 <my-node> set: n3 n3 dl push-node-back
|
||||
|
||||
n2 dl delete-node n2 assert-links
|
||||
dl dlist>sequence dup >dlist dl =
|
||||
] unit-test
|
||||
|
||||
[ V{ 2 3 } t ] |[ |
|
||||
<dlist> :> dl
|
||||
1 <my-node> :> n1 n1 dl push-node-back
|
||||
2 <my-node> :> n2 n2 dl push-node-back
|
||||
3 <my-node> :> n3 n3 dl push-node-back
|
||||
<dlist> set: dl
|
||||
1 <my-node> set: n1 n1 dl push-node-back
|
||||
2 <my-node> set: n2 n2 dl push-node-back
|
||||
3 <my-node> set: n3 n3 dl push-node-back
|
||||
|
||||
n1 dl delete-node n1 assert-links
|
||||
dl dlist>sequence dup >dlist dl =
|
||||
|
|
|
|||
|
|
@ -143,9 +143,9 @@ PRIVATE>
|
|||
|
||||
:: set-doc-range ( string from to document -- )
|
||||
from to = string empty? and [
|
||||
string split-lines :> new-lines
|
||||
new-lines from text+loc :> new-to
|
||||
from to document doc-range :> old-string
|
||||
string split-lines set: new-lines
|
||||
new-lines from text+loc set: new-to
|
||||
from to document doc-range set: old-string
|
||||
old-string string from to new-to <edit> document add-undo
|
||||
new-lines from to document [ (set-doc-range) ] models:change-model
|
||||
new-to document update-locs
|
||||
|
|
|
|||
|
|
@ -93,7 +93,7 @@ M: heap heap-peek ( heap -- value key )
|
|||
PRIVATE<
|
||||
|
||||
:: sift-down ( heap from to -- )
|
||||
to heap data-nth :> tmp
|
||||
to heap data-nth set: tmp
|
||||
|
||||
to t [ over from > and ] [
|
||||
dup up
|
||||
|
|
@ -121,8 +121,8 @@ M: heap heap-push*
|
|||
PRIVATE<
|
||||
|
||||
:: sift-up ( heap n -- )
|
||||
heap heap-size :> end
|
||||
n heap data-nth :> tmp
|
||||
heap heap-size set: end
|
||||
n heap data-nth set: tmp
|
||||
|
||||
n dup left [ dup end < ] [
|
||||
dup 1 fixnum+fast
|
||||
|
|
|
|||
|
|
@ -49,8 +49,8 @@ PRIVATE>
|
|||
|
||||
:: acl-entry-each ( path quot -- )
|
||||
[
|
||||
path file-acl &free-acl :> acl
|
||||
f :> acl-entry!
|
||||
path file-acl &free-acl set: acl
|
||||
f set: acl-entry!
|
||||
acl [
|
||||
acl first-acl-entry void* deref quot call
|
||||
[ acl next-acl-entry dup acl-entry! ]
|
||||
|
|
@ -60,7 +60,7 @@ PRIVATE>
|
|||
|
||||
:: acl-each ( path quot -- )
|
||||
[
|
||||
path file-acl &free-acl :> acl
|
||||
path file-acl &free-acl set: acl
|
||||
acl [
|
||||
acl first-acl-entry drop
|
||||
acl quot call
|
||||
|
|
|
|||
|
|
@ -17,12 +17,12 @@ PRIVATE>
|
|||
f [ random zero? [ nip ] [ drop ] if ] each-numbered-line ;
|
||||
|
||||
:: random-lines ( n -- lines )
|
||||
V{ } clone :> accum
|
||||
V{ } clone set: accum
|
||||
|[ line line# |
|
||||
line# n <= [
|
||||
line accum push
|
||||
] [
|
||||
line# random :> r
|
||||
line# random set: r
|
||||
r n < [ line r accum set-nth-unsafe ] when
|
||||
] if
|
||||
] each-numbered-line accum ;
|
||||
|
|
|
|||
|
|
@ -17,5 +17,5 @@ IN: io.serial.windows
|
|||
SetCommState win32-error=0/f ;
|
||||
|
||||
:: with-comm-state ( duplex quot: ( dcb -- ) -- )
|
||||
duplex get-comm-state :> dcb
|
||||
duplex get-comm-state set: dcb
|
||||
dcb clone quot curry [ dcb set-comm-state ] recover ; inline
|
||||
|
|
|
|||
|
|
@ -36,8 +36,8 @@ M: peek-stream stream-read1
|
|||
] if-empty ;
|
||||
|
||||
M:: peek-stream stream-read-unsafe ( n buf stream -- count )
|
||||
stream peeked>> :> peeked
|
||||
peeked length :> #peeked
|
||||
stream peeked>> set: peeked
|
||||
peeked length set: #peeked
|
||||
#peeked 0 = [
|
||||
n buf stream stream>> stream-read-unsafe
|
||||
] [
|
||||
|
|
@ -48,12 +48,12 @@ M:: peek-stream stream-read-unsafe ( n buf stream -- count )
|
|||
] [
|
||||
peeked <reversed> 0 buf copy
|
||||
0 peeked shorten
|
||||
n #peeked - :> n'
|
||||
n #peeked - set: n'
|
||||
stream stream>> input-port? [
|
||||
#peeked buf <displaced-alien>
|
||||
] [
|
||||
buf #peeked tail-slice
|
||||
] if :> buf'
|
||||
] if set: buf'
|
||||
n' buf' stream stream-read-unsafe #peeked +
|
||||
] if
|
||||
] if ;
|
||||
|
|
|
|||
|
|
@ -19,7 +19,7 @@ TUPLE: pool
|
|||
PRIVATE<
|
||||
|
||||
:: copy-tuple ( from to -- to )
|
||||
from tuple-size :> size
|
||||
from tuple-size set: size
|
||||
size |[ n | n from array-nth n to set-array-nth ] each-integer
|
||||
to ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -10,10 +10,10 @@ IN: persistent.hashtables.nodes.bitmap
|
|||
: index ( bit bitmap -- n ) [ 1 - ] dip bitand bit-count ; inline
|
||||
|
||||
M:: bitmap-node (entry-at) ( key hashcode bitmap-node -- entry )
|
||||
bitmap-node shift>> :> shift
|
||||
hashcode shift bitpos :> bit
|
||||
bitmap-node bitmap>> :> bitmap
|
||||
bitmap-node nodes>> :> nodes
|
||||
bitmap-node shift>> set: shift
|
||||
hashcode shift bitpos set: bit
|
||||
bitmap-node bitmap>> set: bitmap
|
||||
bitmap-node nodes>> set: nodes
|
||||
bitmap bit bitand 0 eq? [ f ] [
|
||||
key hashcode
|
||||
bit bitmap index nodes nth-unsafe
|
||||
|
|
@ -21,22 +21,22 @@ M:: bitmap-node (entry-at) ( key hashcode bitmap-node -- entry )
|
|||
] if ;
|
||||
|
||||
M:: bitmap-node (new-at) ( shift value key hashcode bitmap-node -- node' added-leaf )
|
||||
bitmap-node shift>> :> shift
|
||||
hashcode shift bitpos :> bit
|
||||
bitmap-node bitmap>> :> bitmap
|
||||
bit bitmap index :> idx
|
||||
bitmap-node nodes>> :> nodes
|
||||
bitmap-node shift>> set: shift
|
||||
hashcode shift bitpos set: bit
|
||||
bitmap-node bitmap>> set: bitmap
|
||||
bit bitmap index set: idx
|
||||
bitmap-node nodes>> set: nodes
|
||||
|
||||
bitmap bit bitand 0 eq? [
|
||||
value key hashcode <leaf-node> :> new-leaf
|
||||
value key hashcode <leaf-node> set: new-leaf
|
||||
bitmap bit bitor
|
||||
new-leaf idx nodes insert-nth
|
||||
shift
|
||||
<bitmap-node>
|
||||
new-leaf
|
||||
] [
|
||||
idx nodes nth :> n
|
||||
shift radix-bits + value key hashcode n (new-at) :> ( n' new-leaf )
|
||||
idx nodes nth set: n
|
||||
shift radix-bits + value key hashcode n (new-at) set: ( n' new-leaf )
|
||||
n n' eq? [
|
||||
bitmap-node
|
||||
] [
|
||||
|
|
@ -49,14 +49,14 @@ M:: bitmap-node (new-at) ( shift value key hashcode bitmap-node -- node' added-l
|
|||
] if ;
|
||||
|
||||
M:: bitmap-node (pluck-at) ( key hashcode bitmap-node -- node' )
|
||||
hashcode bitmap-node shift>> bitpos :> bit
|
||||
bitmap-node bitmap>> :> bitmap
|
||||
bitmap-node nodes>> :> nodes
|
||||
bitmap-node shift>> :> shift
|
||||
hashcode bitmap-node shift>> bitpos set: bit
|
||||
bitmap-node bitmap>> set: bitmap
|
||||
bitmap-node nodes>> set: nodes
|
||||
bitmap-node shift>> set: shift
|
||||
bit bitmap bitand 0 eq? [ bitmap-node ] [
|
||||
bit bitmap index :> idx
|
||||
idx nodes nth-unsafe :> n
|
||||
key hashcode n (pluck-at) :> n'
|
||||
bit bitmap index set: idx
|
||||
idx nodes nth-unsafe set: n
|
||||
key hashcode n (pluck-at) set: n'
|
||||
n n' eq? [
|
||||
bitmap-node
|
||||
] [
|
||||
|
|
|
|||
|
|
@ -15,7 +15,7 @@ M:: collision-node (entry-at) ( key hashcode collision-node -- leaf-node )
|
|||
|
||||
M:: collision-node (pluck-at) ( key hashcode collision-node -- leaf-node )
|
||||
hashcode collision-node hashcode>> eq? [
|
||||
key hashcode collision-node find-index drop :> idx
|
||||
key hashcode collision-node find-index drop set: idx
|
||||
idx [
|
||||
idx collision-node leaves>> smash [
|
||||
collision-node hashcode>>
|
||||
|
|
@ -26,7 +26,7 @@ M:: collision-node (pluck-at) ( key hashcode collision-node -- leaf-node )
|
|||
|
||||
M:: collision-node (new-at) ( shift value key hashcode collision-node -- node' added-leaf )
|
||||
hashcode collision-node hashcode>> eq? [
|
||||
key hashcode collision-node find-index :> ( idx leaf-node )
|
||||
key hashcode collision-node find-index set: ( idx leaf-node )
|
||||
idx [
|
||||
value leaf-node value>> = [
|
||||
collision-node f
|
||||
|
|
@ -40,7 +40,7 @@ M:: collision-node (new-at) ( shift value key hashcode collision-node -- node' a
|
|||
f
|
||||
] if
|
||||
] [
|
||||
value key hashcode <leaf-node> :> new-leaf-node
|
||||
value key hashcode <leaf-node> set: new-leaf-node
|
||||
hashcode
|
||||
collision-node leaves>>
|
||||
new-leaf-node
|
||||
|
|
|
|||
|
|
@ -8,11 +8,11 @@ persistent.hashtables.nodes ;
|
|||
IN: persistent.hashtables.nodes.full
|
||||
|
||||
M:: full-node (new-at) ( shift value key hashcode full-node -- node' added-leaf )
|
||||
full-node nodes>> :> nodes
|
||||
hashcode full-node shift>> mask :> idx
|
||||
idx nodes nth-unsafe :> n
|
||||
full-node nodes>> set: nodes
|
||||
hashcode full-node shift>> mask set: idx
|
||||
idx nodes nth-unsafe set: n
|
||||
|
||||
shift radix-bits + value key hashcode n (new-at) :> ( n' new-leaf )
|
||||
shift radix-bits + value key hashcode n (new-at) set: ( n' new-leaf )
|
||||
n n' eq? [
|
||||
full-node
|
||||
] [
|
||||
|
|
@ -21,9 +21,9 @@ M:: full-node (new-at) ( shift value key hashcode full-node -- node' added-leaf
|
|||
new-leaf ;
|
||||
|
||||
M:: full-node (pluck-at) ( key hashcode full-node -- node' )
|
||||
hashcode full-node shift>> mask :> idx
|
||||
idx full-node nodes>> nth :> n
|
||||
key hashcode n (pluck-at) :> n'
|
||||
hashcode full-node shift>> mask set: idx
|
||||
idx full-node nodes>> nth set: n
|
||||
key hashcode n (pluck-at) set: n'
|
||||
|
||||
n n' eq? [
|
||||
full-node
|
||||
|
|
|
|||
|
|
@ -19,7 +19,7 @@ M:: leaf-node (new-at) ( shift value key hashcode leaf-node -- node' added-leaf
|
|||
value leaf-node value>> =
|
||||
[ leaf-node f ] [ value key hashcode <leaf-node> f ] if
|
||||
] [
|
||||
value key hashcode <leaf-node> :> new-leaf
|
||||
value key hashcode <leaf-node> set: new-leaf
|
||||
hashcode leaf-node new-leaf 2array <collision-node>
|
||||
new-leaf
|
||||
] if
|
||||
|
|
|
|||
|
|
@ -30,7 +30,7 @@ IN: sequences.extras
|
|||
[ swap ] 2dip each-from ; inline
|
||||
|
||||
:: subseq* ( from to seq -- subseq )
|
||||
seq length :> len
|
||||
seq length set: len
|
||||
from [ dup 0 < [ len + ] when ] [ 0 ] if*
|
||||
to [ dup 0 < [ len + ] when ] [ len ] if*
|
||||
[ 0 len clamp ] bi@ dupd max seq subseq ;
|
||||
|
|
@ -42,11 +42,11 @@ IN: sequences.extras
|
|||
dup length [1,b] [ clump ] with map concat ;
|
||||
|
||||
:: each-subseq ( ... seq quot: ( ... x -- ... ) -- ... )
|
||||
seq length :> len
|
||||
seq length set: len
|
||||
len [0,b] [
|
||||
:> from
|
||||
set: from
|
||||
from len (a,b] [
|
||||
:> to
|
||||
set: to
|
||||
from to seq subseq quot call
|
||||
] each
|
||||
] each ; inline
|
||||
|
|
@ -63,16 +63,16 @@ IN: sequences.extras
|
|||
[ dup length [1,b] ] dip filter-all-subseqs-range ; inline
|
||||
|
||||
:: longest-subseq ( seq1 seq2 -- subseq )
|
||||
seq1 length :> len1
|
||||
seq2 length :> len2
|
||||
0 :> n!
|
||||
0 :> end!
|
||||
len1 1 + [ len2 1 + 0 <array> ] replicate :> table
|
||||
seq1 length set: len1
|
||||
seq2 length set: len2
|
||||
0 set: n!
|
||||
0 set: end!
|
||||
len1 1 + [ len2 1 + 0 <array> ] replicate set: table
|
||||
len1 [1,b] |[ x |
|
||||
len2 [1,b] |[ y |
|
||||
x 1 - seq1 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 + set: len
|
||||
len y x table nth-unsafe set-nth-unsafe
|
||||
len n > [ len n! x end! ] when
|
||||
] [ 0 y x table nth-unsafe set-nth-unsafe ] if
|
||||
|
|
@ -139,7 +139,7 @@ PRIVATE>
|
|||
2tri ; inline
|
||||
|
||||
:: slice-when ( seq quot: ( elt -- ? ) -- seq' )
|
||||
seq length :> len
|
||||
seq length set: len
|
||||
0 [ len dupd < ] [
|
||||
dup seq quot find-from drop
|
||||
[ 2dup = [ 1 + ] when ] [ len ] if*
|
||||
|
|
@ -211,7 +211,7 @@ ERROR: underlying-mismatch slice1 slice2 ;
|
|||
2dup and [ span-slices ] [ or ] if ;
|
||||
|
||||
:: rotate! ( seq n -- )
|
||||
seq length :> len
|
||||
seq length set: len
|
||||
n len mod dup 0 < [ len + ] when seq bounds-check drop 0 over
|
||||
[ 2dup = ] [
|
||||
[ seq exchange-unsafe ] [ [ 1 + ] bi@ ] 2bi
|
||||
|
|
|
|||
|
|
@ -28,9 +28,9 @@ C: <appender> appender ;
|
|||
INSTANCE: appender inserter ;
|
||||
|
||||
M:: appender new-sequence ( len inserter -- sequence )
|
||||
inserter underlying>> :> underlying
|
||||
underlying length :> old-length
|
||||
old-length len + :> new-length
|
||||
inserter underlying>> set: underlying
|
||||
underlying length set: old-length
|
||||
old-length len + set: new-length
|
||||
new-length underlying set-length
|
||||
underlying old-length <offset-growable> ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@ TUPLE: sequence-parser sequence n ;
|
|||
0 >>n ;
|
||||
|
||||
:: with-sequence-parser ( sequence-parser quot -- seq/f )
|
||||
sequence-parser n>> :> n
|
||||
sequence-parser n>> set: n
|
||||
sequence-parser quot call [
|
||||
n sequence-parser n<< f
|
||||
] unless* ; inline
|
||||
|
|
@ -79,13 +79,13 @@ TUPLE: sequence-parser sequence n ;
|
|||
take-sequence drop ;
|
||||
|
||||
:: take-until-sequence ( sequence-parser sequence -- sequence'/f )
|
||||
sequence-parser n>> :> saved
|
||||
sequence length <growing-circular> :> growing
|
||||
sequence-parser n>> set: saved
|
||||
sequence length <growing-circular> set: growing
|
||||
sequence-parser
|
||||
[
|
||||
current growing growing-circular-push
|
||||
sequence growing sequence=
|
||||
] take-until :> found
|
||||
] take-until set: found
|
||||
growing sequence sequence= [
|
||||
found dup length
|
||||
growing length 1 - - head
|
||||
|
|
@ -97,7 +97,7 @@ TUPLE: sequence-parser sequence n ;
|
|||
] if ;
|
||||
|
||||
:: take-until-sequence* ( sequence-parser sequence -- sequence'/f )
|
||||
sequence-parser sequence take-until-sequence :> out
|
||||
sequence-parser sequence take-until-sequence set: out
|
||||
out [
|
||||
sequence-parser [ sequence length + ] change-n drop
|
||||
] when out ;
|
||||
|
|
|
|||
|
|
@ -53,14 +53,14 @@ M: product-sequence nth
|
|||
product@ nths ;
|
||||
|
||||
:: product-each ( ... sequences quot: ( ... seq -- ... ) -- ... )
|
||||
sequences start-product-iter :> ( ns lengths )
|
||||
sequences start-product-iter set: ( ns lengths )
|
||||
lengths [ 0 = ] any? [
|
||||
[ ns lengths end-product-iter? ]
|
||||
[ ns sequences nths quot call ns lengths product-iter ] until
|
||||
] unless ; inline
|
||||
|
||||
:: product-map-as ( ... sequences quot: ( ... seq -- ... value ) exemplar -- ... sequence )
|
||||
0 :> i!
|
||||
0 set: i!
|
||||
sequences product-length exemplar
|
||||
|[ result |
|
||||
sequences [ quot call i result set-nth-unsafe i 1 + i! ] product-each
|
||||
|
|
@ -71,7 +71,7 @@ M: product-sequence nth
|
|||
over product-map-as ; inline
|
||||
|
||||
:: product-map>assoc ( ... sequences quot: ( ... seq -- ... key value ) exemplar -- ... assoc )
|
||||
0 :> i!
|
||||
0 set: i!
|
||||
sequences product-length { }
|
||||
|[ result |
|
||||
sequences [ quot call 2array i result set-nth-unsafe i 1 + i! ] product-each
|
||||
|
|
|
|||
|
|
@ -20,8 +20,8 @@ IN: sets.extras
|
|||
intersects? not ;
|
||||
|
||||
:: non-repeating ( seq -- seq' )
|
||||
HS{ } clone :> visited
|
||||
0 seq new-resizable :> accum
|
||||
HS{ } clone set: visited
|
||||
0 seq new-resizable set: accum
|
||||
seq [
|
||||
accum over visited ?adjoin
|
||||
[ push ] [ remove-first! drop ] if
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ IN: splitting.monotonic
|
|||
PRIVATE<
|
||||
|
||||
:: monotonic-split-impl ( seq quot slice-quot n -- pieces )
|
||||
V{ 0 } clone :> accum
|
||||
V{ 0 } clone set: accum
|
||||
|
||||
0 seq [ ] [
|
||||
[ 1 + ] 2dip [
|
||||
|
|
|
|||
|
|
@ -108,7 +108,7 @@ IN: bootstrap.syntax
|
|||
"SBUF\""
|
||||
|
||||
"::" "M::" "MEMO:" "MEMO::" "MACRO:" "MACRO::" "IDENTITY-MEMO:" "IDENTITY-MEMO::" "TYPED:" "TYPED::"
|
||||
":>" "|[" "let[" "MEMO["
|
||||
"set:" "|[" "let[" "MEMO["
|
||||
"$["
|
||||
"_"
|
||||
"@"
|
||||
|
|
|
|||
|
|
@ -19,10 +19,10 @@ ERROR: local-writer-in-literal-error ;
|
|||
M: local-writer-in-literal-error summary
|
||||
drop "Local writer words not permitted inside literals" ;
|
||||
|
||||
ERROR: :>-outside-lambda-error ;
|
||||
ERROR: set:-outside-lambda-error ;
|
||||
|
||||
M: :>-outside-lambda-error summary
|
||||
drop ":> cannot be used outside of let[, |[, or :: forms" ;
|
||||
M: set:-outside-lambda-error summary
|
||||
drop "set: cannot be used outside of let[, |[, or :: forms" ;
|
||||
|
||||
ERROR: bad-local args obj ;
|
||||
|
||||
|
|
|
|||
|
|
@ -8,34 +8,34 @@ HELP: \ |[
|
|||
{ $examples "See " { $link "locals-examples" } "." } ;
|
||||
|
||||
HELP: \ let[
|
||||
{ $syntax "let[ code :> var code :> var code... ]" }
|
||||
{ $description "Establishes a new scope for lexical variable bindings. Variables bound with " { $link postpone\ :> } " within the body of the " { $snippet "let[" } " will be lexically scoped to the body of the " { $snippet "let[" } " form." }
|
||||
{ $syntax "let[ code set: var code set: var code... ]" }
|
||||
{ $description "Establishes a new scope for lexical variable bindings. Variables bound with " { $link \ set: } " within the body of the " { $snippet "let[" } " will be lexically scoped to the body of the " { $snippet "let[" } " form." }
|
||||
{ $examples "See " { $link "locals-examples" } "." } ;
|
||||
|
||||
HELP: \ :>
|
||||
{ $syntax ":> var" ":> var!" ":> ( var-1 var-2 ... )" }
|
||||
{ $description "Binds one or more new lexical variables. In the " { $snippet ":> var" } " form, the value on the top of the datastack is bound to a new lexical variable named " { $snippet "var" } " and is scoped to the enclosing quotation, " { $link postpone\ let[ } " form, or " { $link postpone\ :: } " definition."
|
||||
HELP: \ set:
|
||||
{ $syntax "set: var" "set: var!" "set: ( var-1 var-2 ... )" }
|
||||
{ $description "Binds one or more new lexical variables. In the " { $snippet "set: var" } " form, the value on the top of the datastack is bound to a new lexical variable named " { $snippet "var" } " and is scoped to the enclosing quotation, " { $link \ let[ } " form, or " { $link \ :: } " definition."
|
||||
$nl
|
||||
"The " { $snippet ":> ( var-1 ... )" } " form binds multiple variables to the top values of the datastack in right to left order, with the last variable bound to the top of the datastack. These two snippets have the same effect:"
|
||||
{ $code ":> c :> b :> a" }
|
||||
{ $code ":> ( a b c )" }
|
||||
"The " { $snippet "set: ( var-1 ... )" } " form binds multiple variables to the top values of the datastack in right to left order, with the last variable bound to the top of the datastack. These two snippets have the same effect:"
|
||||
{ $code "set: c set: b set: a" }
|
||||
{ $code "set: ( a b c )" }
|
||||
$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." }
|
||||
{ $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 \ :: } " definition, " { $link \ let[ } " form, or " { $link \ |[ } " quotation. Normal quotations have their own lexical scope only if they are inside an outer scope. Definition forms such as " { $link \ : } " 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 \ let[ } " can be used to create a lexical scope where one is not otherwise available." }
|
||||
{ $examples "See " { $link "locals-examples" } "." } ;
|
||||
|
||||
{ postpone\ let[ postpone\ :> } related-words
|
||||
{ \ let[ \ set: } related-words
|
||||
|
||||
HELP: \ ::
|
||||
{ $syntax ":: word ( vars... -- outputs... ) body... ;" }
|
||||
{ $description "Defines a word with named inputs. The word binds its input values to lexical variables from left to right, then executes the body with those bindings in scope."
|
||||
$nl
|
||||
"If any " { $snippet "var" } " name is followed by an exclamation point (" { $snippet "!" } "), the corresponding new variable is made mutable. See " { $link "locals-mutable" } " for more information." }
|
||||
{ $notes "The names of the " { $snippet "outputs" } " do not affect the word's behavior. However, the compiler verifies that the stack effect accurately represents the number of outputs as with " { $link postpone\ : } " definitions." }
|
||||
{ $notes "The names of the " { $snippet "outputs" } " do not affect the word's behavior. However, the compiler verifies that the stack effect accurately represents the number of outputs as with " { $link \ : } " definitions." }
|
||||
{ $examples "See " { $link "locals-examples" } "." } ;
|
||||
|
||||
{ postpone\ : postpone\ :: } related-words
|
||||
{ \ : \ :: } related-words
|
||||
|
||||
HELP: \ MACRO::
|
||||
{ $syntax "MACRO:: word ( vars... -- outputs... ) body... ;" }
|
||||
|
|
@ -45,7 +45,7 @@ $nl
|
|||
{ $notes "The expansion of a macro cannot reference lexical variables bound in the outer scope. There are also limitations on passing arguments involving lexical variables into macros. See " { $link "locals-limitations" } " for details." }
|
||||
{ $examples "See " { $link "locals-examples" } "." } ;
|
||||
|
||||
{ postpone\ MACRO: postpone\ MACRO:: } related-words
|
||||
{ \ MACRO: \ MACRO:: } related-words
|
||||
|
||||
HELP: \ MEMO::
|
||||
{ $syntax "MEMO:: word ( vars... -- outputs... ) body... ;" }
|
||||
|
|
@ -54,35 +54,35 @@ $nl
|
|||
"If any " { $snippet "var" } " name is followed by an exclamation point (" { $snippet "!" } "), the corresponding new variable is made mutable. See " { $link "locals-mutable" } " for more information." }
|
||||
{ $examples "See " { $link "locals-examples" } "." } ;
|
||||
|
||||
{ postpone\ MEMO: postpone\ MEMO:: } related-words
|
||||
{ \ MEMO: \ MEMO:: } related-words
|
||||
|
||||
HELP: \ M::
|
||||
{ $syntax "M:: class generic ( vars... -- outputs... ) body... ;" }
|
||||
{ $description "Defines a new method on " { $snippet "generic" } " for " { $snippet "class" } " with named inputs. The method binds its input values to lexical variables from left to right, then executes the body with those bindings in scope."
|
||||
$nl
|
||||
"If any " { $snippet "var" } " name is followed by an exclamation point (" { $snippet "!" } "), the corresponding new variable is made mutable. See " { $link "locals-mutable" } " for more information." }
|
||||
{ $notes "The names of the " { $snippet "outputs" } " do not affect the word's behavior. However, the compiler verifies that the stack effect accurately represents the number of outputs as with " { $link postpone\ M: } " definitions." }
|
||||
{ $notes "The names of the " { $snippet "outputs" } " do not affect the word's behavior. However, the compiler verifies that the stack effect accurately represents the number of outputs as with " { $link \ M: } " definitions." }
|
||||
{ $examples "See " { $link "locals-examples" } "." } ;
|
||||
|
||||
{ postpone\ M: postpone\ M:: } related-words
|
||||
{ \ M: \ M:: } related-words
|
||||
|
||||
ARTICLE: "locals-examples" "Examples of lexical variables"
|
||||
{ $heading "Definitions with lexical variables" }
|
||||
"The following example demonstrates lexical variable bindings in word definitions. The " { $snippet "quadratic-roots" } " word is defined with " { $link postpone\ :: } ", so it takes its inputs from the top three elements of the datastack and binds them to the variables " { $snippet "a" } ", " { $snippet "b" } ", and " { $snippet "c" } ". In the body, the " { $snippet "disc" } " variable is bound using " { $link postpone\ :> } " and then used in the following line of code."
|
||||
"The following example demonstrates lexical variable bindings in word definitions. The " { $snippet "quadratic-roots" } " word is defined with " { $link \ :: } ", so it takes its inputs from the top three elements of the datastack and binds them to the variables " { $snippet "a" } ", " { $snippet "b" } ", and " { $snippet "c" } ". In the body, the " { $snippet "disc" } " variable is bound using " { $link \ set: } " and then used in the following line of code."
|
||||
{ $example "USING: locals math math.functions kernel ;
|
||||
IN: scratchpad
|
||||
:: quadratic-roots ( a b c -- x y )
|
||||
b sq 4 a c * * - sqrt :> disc
|
||||
b sq 4 a c * * - sqrt set: disc
|
||||
b neg disc [ + ] [ - ] 2bi [ 2 a * / ] bi@ ;
|
||||
1.0 1.0 -6.0 quadratic-roots [ . ] bi@"
|
||||
"2.0
|
||||
-3.0"
|
||||
}
|
||||
"If you wanted to perform the quadratic formula interactively from the listener, you could use " { $link postpone\ let[ } " to provide a scope for the variables:"
|
||||
"If you wanted to perform the quadratic formula interactively from the listener, you could use " { $link \ let[ } " to provide a scope for the variables:"
|
||||
{ $example "USING: locals math math.functions kernel ;
|
||||
IN: scratchpad
|
||||
let[ 1.0 :> a 1.0 :> b -6.0 :> c
|
||||
b sq 4 a c * * - sqrt :> disc
|
||||
let[ 1.0 set: a 1.0 set: b -6.0 set: c
|
||||
b sq 4 a c * * - sqrt set: disc
|
||||
b neg disc [ + ] [ - ] 2bi [ 2 a * / ] bi@
|
||||
] [ . ] bi@"
|
||||
"2.0
|
||||
|
|
@ -92,7 +92,7 @@ let[ 1.0 :> a 1.0 :> b -6.0 :> c
|
|||
$nl
|
||||
|
||||
{ $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 \ |[ } ". 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
|
||||
"USING: kernel locals math prettyprint ;"
|
||||
"IN: scratchpad"
|
||||
|
|
@ -120,7 +120,7 @@ IN: scratchpad
|
|||
TUPLE: counter adder subtractor ;
|
||||
|
||||
:: <counter> ( -- counter )
|
||||
0 :> value!
|
||||
0 set: value!
|
||||
counter new
|
||||
[ value 1 + dup value! ] >>adder
|
||||
[ value 1 - dup value! ] >>subtractor ;
|
||||
|
|
@ -138,10 +138,10 @@ TUPLE: counter adder subtractor ;
|
|||
"USING: kernel locals prettyprint ;
|
||||
IN: scratchpad
|
||||
:: rebinding-example ( -- quot1 quot2 )
|
||||
5 :> a [ a ]
|
||||
6 :> a [ a ] ;
|
||||
5 set: a [ a ]
|
||||
6 set: a [ a ] ;
|
||||
:: mutable-example ( -- quot1 quot2 )
|
||||
5 :> a! [ a ]
|
||||
5 set: a! [ a ]
|
||||
6 a! [ a ] ;
|
||||
rebinding-example [ call . ] bi@
|
||||
mutable-example [ call . ] bi@"
|
||||
|
|
@ -199,7 +199,7 @@ $nl
|
|||
"IN: scratchpad"
|
||||
"TUPLE: person first-name last-name ;"
|
||||
":: constructor-test ( -- tuple )"
|
||||
" \"Jane Smith\" \" \" split1 :> last :> first"
|
||||
" \"Jane Smith\" \" \" split1 set: last set: first"
|
||||
" T{ person { first-name first } { last-name last } } ;"
|
||||
"constructor-test constructor-test eq? ."
|
||||
"f"
|
||||
|
|
@ -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." ;
|
||||
|
||||
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 \ set: } ", " { $link \ :: } ", or " { $link \ |[ } ", 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
|
||||
"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
|
||||
|
|
@ -224,7 +224,7 @@ $nl
|
|||
"Conceptually, " { $link curry } " is defined so that the following two code snippets are equivalent:"
|
||||
{ $code "3 [ - ] curry" }
|
||||
{ $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 \ |[ } ", " { $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 "|[ 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:"
|
||||
|
|
@ -233,7 +233,7 @@ $nl
|
|||
"Instead, the first line above expands into something like the following:"
|
||||
{ $code "[ [ swap |[ a | a - ] ] curry call ]" }
|
||||
$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 \ |[ } " 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"
|
||||
"There are two main limitations of the current implementation, and both concern macros."
|
||||
|
|
@ -282,18 +282,18 @@ ARTICLE: "locals" "Lexical variables"
|
|||
}
|
||||
"Word definitions where the inputs are bound to lexical variables:"
|
||||
{ $subsections
|
||||
postpone\ ::
|
||||
postpone\ M::
|
||||
postpone\ MEMO::
|
||||
postpone\ MACRO::
|
||||
\ ::
|
||||
\ M::
|
||||
\ MEMO::
|
||||
\ MACRO::
|
||||
}
|
||||
"Lexical scoping and binding forms:"
|
||||
{ $subsections
|
||||
postpone\ let[
|
||||
postpone\ :>
|
||||
\ let[
|
||||
\ set:
|
||||
}
|
||||
"Quotation literals where the inputs are bound to lexical variables:"
|
||||
{ $subsections postpone\ |[ }
|
||||
{ $subsections \ |[ }
|
||||
"Additional topics:"
|
||||
{ $subsections
|
||||
"locals-literals"
|
||||
|
|
|
|||
|
|
@ -27,30 +27,30 @@ IN: locals.tests
|
|||
{ { 5 6 7 } } [ { 1 2 3 } 4 map-test-2 ] unit-test
|
||||
|
||||
:: let-test ( c -- d )
|
||||
let[ 1 :> a 2 :> b a b + c + ] ;
|
||||
let[ 1 set: a 2 set: b a b + c + ] ;
|
||||
|
||||
{ 7 } [ 4 let-test ] unit-test
|
||||
|
||||
:: let-test-2 ( a -- a )
|
||||
a let[ :> a let[ a :> b a ] ] ;
|
||||
a let[ set: a let[ a set: b a ] ] ;
|
||||
|
||||
{ 3 } [ 3 let-test-2 ] unit-test
|
||||
|
||||
:: let-test-3 ( a -- a )
|
||||
a let[ :> a let[ [ a ] :> b let[ 3 :> a b ] ] ] ;
|
||||
a let[ set: a let[ [ a ] set: b let[ 3 set: a b ] ] ] ;
|
||||
|
||||
:: let-test-4 ( a -- b )
|
||||
a let[ 1 :> a :> b a b 2array ] ;
|
||||
a let[ 1 set: a set: b a b 2array ] ;
|
||||
|
||||
{ { 1 2 } } [ 2 let-test-4 ] unit-test
|
||||
|
||||
:: let-test-5 ( a b -- b )
|
||||
a b let[ :> a :> b a b 2array ] ;
|
||||
a b let[ set: a set: b a b 2array ] ;
|
||||
|
||||
{ { 2 1 } } [ 1 2 let-test-5 ] unit-test
|
||||
|
||||
:: let-test-6 ( a -- b )
|
||||
a let[ :> a 1 :> b a b 2array ] ;
|
||||
a let[ set: a 1 set: b a b 2array ] ;
|
||||
|
||||
{ { 2 1 } } [ 2 let-test-6 ] unit-test
|
||||
|
||||
|
|
@ -72,7 +72,7 @@ IN: locals.tests
|
|||
{ 5 } [ 2 "q" get call ] unit-test
|
||||
|
||||
:: write-test-2 ( -- q )
|
||||
let[ 0 :> n! |[ i | n i + dup n! ] ] ;
|
||||
let[ 0 set: n! |[ i | n i + dup n! ] ] ;
|
||||
|
||||
write-test-2 "q" set
|
||||
|
||||
|
|
@ -93,11 +93,11 @@ write-test-2 "q" set
|
|||
|
||||
{ } [ 1 2 write-test-3 call ] unit-test
|
||||
|
||||
:: write-test-4 ( x! -- q ) [ let[ 0 :> y! f x! ] ] ;
|
||||
:: write-test-4 ( x! -- q ) [ let[ 0 set: y! f x! ] ] ;
|
||||
|
||||
{ } [ 5 write-test-4 drop ] unit-test
|
||||
|
||||
:: let-let-test ( n -- n ) let[ n 3 + :> n n ] ;
|
||||
:: let-let-test ( n -- n ) let[ n 3 + set: n n ] ;
|
||||
|
||||
{ 13 } [ 10 let-let-test ] unit-test
|
||||
|
||||
|
|
@ -135,9 +135,9 @@ M:: string lambda-generic ( a b -- c ) a b lambda-generic-2 ;
|
|||
|
||||
{ } [ \ lambda-generic see ] unit-test
|
||||
|
||||
:: unparse-test-1 ( a -- ) let[ 3 :> a! 4 :> b ] ;
|
||||
:: unparse-test-1 ( a -- ) let[ 3 set: a! 4 set: b ] ;
|
||||
|
||||
{ "let[ 3 :> a! 4 :> b ]" } [
|
||||
{ "let[ 3 set: a! 4 set: b ]" } [
|
||||
\ unparse-test-1 "lambda" word-prop body>> first unparse
|
||||
] unit-test
|
||||
|
||||
|
|
@ -177,11 +177,11 @@ M:: fixnum next-method-test ( a -- b ) a call-next-method 1 + ;
|
|||
|
||||
{ 3 0 } |[ a b c | ] must-infer-as
|
||||
|
||||
{ } [ 1 let[ :> a ] ] unit-test
|
||||
{ } [ 1 let[ set: a ] ] unit-test
|
||||
|
||||
{ 3 } [ 1 let[ :> a 3 ] ] unit-test
|
||||
{ 3 } [ 1 let[ set: a 3 ] ] unit-test
|
||||
|
||||
{ } [ 1 2 let[ :> a :> b ] ] unit-test
|
||||
{ } [ 1 2 let[ set: a set: b ] ] unit-test
|
||||
|
||||
:: a-word-with-locals ( a b -- ) ;
|
||||
|
||||
|
|
@ -239,10 +239,10 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
|
|||
{ t } [ 12 &&-test ] unit-test
|
||||
|
||||
:: let-and-cond-test-1 ( -- a )
|
||||
let[ 10 :> a
|
||||
let[ 20 :> a
|
||||
let[ 10 set: a
|
||||
let[ 20 set: a
|
||||
{
|
||||
{ [ t ] [ let[ 30 :> c a ] ] }
|
||||
{ [ t ] [ let[ 30 set: c a ] ] }
|
||||
} cond
|
||||
]
|
||||
] ;
|
||||
|
|
@ -252,8 +252,8 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
|
|||
{ 20 } [ let-and-cond-test-1 ] unit-test
|
||||
|
||||
:: let-and-cond-test-2 ( -- pair )
|
||||
let[ 10 :> A
|
||||
let[ 20 :> B
|
||||
let[ 10 set: A
|
||||
let[ 20 set: B
|
||||
{ { [ t ] [ { A B } ] } } cond
|
||||
]
|
||||
] ;
|
||||
|
|
@ -266,7 +266,7 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
|
|||
{ { 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 } } [ let[ 10 :> a 20 :> b 30 :> c { a b c } ] ] unit-test
|
||||
{ { 10 20 30 } } [ let[ 10 set: a 20 set: b 30 set: c { a b c } ] ] unit-test
|
||||
|
||||
{ V{ 10 20 30 } } [ 10 20 30 |[ a b c | V{ a b c } ] call ] unit-test
|
||||
|
||||
|
|
@ -388,7 +388,7 @@ M:: integer lambda-method-forget-test ( a -- b ) a ;
|
|||
{ 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 set: A A _ + ] ]"
|
||||
eval( -- ) call
|
||||
] [ error>> >r/r>-in-fry-error? ] must-fail-with
|
||||
|
||||
|
|
@ -416,28 +416,28 @@ M:: integer lambda-method-forget-test ( a -- b ) a ;
|
|||
|
||||
{ 3 } [ 3 |[ a | \ a ] call ] unit-test
|
||||
|
||||
[ "USE: locals |[ | { let[ 0 :> a a ] } ]" eval( -- ) ] must-fail
|
||||
[ "USE: locals |[ | { let[ 0 set: a a ] } ]" eval( -- ) ] must-fail
|
||||
|
||||
[ "USE: locals |[ | let[ 0 :> a! { a! } ] ]" eval( -- ) ] must-fail
|
||||
[ "USE: locals |[ | let[ 0 set: a! { a! } ] ]" eval( -- ) ] must-fail
|
||||
|
||||
[ "USE: locals |[ | { :> a } ]" eval( -- ) ] must-fail
|
||||
[ "USE: locals |[ | { set: a } ]" eval( -- ) ] must-fail
|
||||
|
||||
[ "USE: locals 3 :> a" eval( -- ) ] must-fail
|
||||
[ "USE: locals 3 set: a" eval( -- ) ] must-fail
|
||||
|
||||
{ 3 } [ 3 |[ | :> a a ] call ] unit-test
|
||||
{ 3 } [ 3 |[ | set: a a ] call ] unit-test
|
||||
|
||||
{ 3 } [ 3 |[ | :> a! a ] call ] unit-test
|
||||
{ 3 } [ 3 |[ | set: a! a ] call ] unit-test
|
||||
|
||||
{ 3 } [ 2 |[ | :> a! a 1 + a! a ] call ] unit-test
|
||||
{ 3 } [ 2 |[ | set: a! a 1 + a! a ] call ] unit-test
|
||||
|
||||
: fry-locals-test-1 ( -- n )
|
||||
let[ 6 $[ let[ 4 :> A A _ + ] ] call ] ;
|
||||
let[ 6 $[ let[ 4 set: A A _ + ] ] call ] ;
|
||||
|
||||
\ fry-locals-test-1 def>> must-infer
|
||||
{ 10 } [ fry-locals-test-1 ] unit-test
|
||||
|
||||
:: fry-locals-test-2 ( -- n )
|
||||
let[ 6 $[ let[ 4 :> A A _ + ] ] call ] ;
|
||||
let[ 6 $[ let[ 4 set: A A _ + ] ] call ] ;
|
||||
|
||||
\ fry-locals-test-2 def>> must-infer
|
||||
{ 10 } [ fry-locals-test-2 ] unit-test
|
||||
|
|
@ -455,31 +455,31 @@ M:: integer lambda-method-forget-test ( a -- b ) a ;
|
|||
] unit-test
|
||||
|
||||
{ 10 } [
|
||||
|[ | 0 $[ let[ 10 :> A A _ + ] ] call ] call
|
||||
|[ | 0 $[ let[ 10 set: A A _ + ] ] call ] call
|
||||
] unit-test
|
||||
|
||||
! littledan found this problem
|
||||
{ "bar" } [ let[ let[ "bar" :> foo foo ] :> a a ] ] unit-test
|
||||
{ 10 } [ let[ 10 :> a let[ a :> b b ] ] ] unit-test
|
||||
{ "bar" } [ let[ let[ "bar" set: foo foo ] set: a a ] ] unit-test
|
||||
{ 10 } [ let[ 10 set: a let[ a set: b b ] ] ] unit-test
|
||||
|
||||
{ { \ + } } [ let[ \ + :> x { \ x } ] ] unit-test
|
||||
{ { \ + } } [ let[ \ + set: x { \ x } ] ] unit-test
|
||||
|
||||
{ { \ + 3 } } [ let[ 3 :> a { \ + a } ] ] unit-test
|
||||
{ { \ + 3 } } [ let[ 3 set: a { \ + a } ] ] unit-test
|
||||
|
||||
{ 3 } [ let[ \ + :> a 1 2 [ \ a execute ] ] call ] unit-test
|
||||
{ 3 } [ let[ \ + set: a 1 2 [ \ a execute ] ] call ] unit-test
|
||||
|
||||
! erg found this problem
|
||||
:: erg's-:>-bug ( n ? -- n ) ? [ n :> n n ] [ n :> b b ] if ;
|
||||
:: erg's-set:-bug ( n ? -- n ) ? [ n set: n n ] [ n set: b b ] if ;
|
||||
|
||||
{ 3 } [ 3 f erg's-:>-bug ] unit-test
|
||||
{ 3 } [ 3 f erg's-set:-bug ] unit-test
|
||||
|
||||
{ 3 } [ 3 t erg's-:>-bug ] unit-test
|
||||
{ 3 } [ 3 t erg's-set:-bug ] unit-test
|
||||
|
||||
:: erg's-:>-bug-2 ( n ? -- n ) ? n $[ _ :> n n ] [ n :> b b ] if ;
|
||||
:: erg's-set:-bug-2 ( n ? -- n ) ? n $[ _ set: n n ] [ n set: b b ] if ;
|
||||
|
||||
{ 3 } [ 3 f erg's-:>-bug-2 ] unit-test
|
||||
{ 3 } [ 3 f erg's-set:-bug-2 ] unit-test
|
||||
|
||||
{ 3 } [ 3 t erg's-:>-bug-2 ] unit-test
|
||||
{ 3 } [ 3 t erg's-set:-bug-2 ] unit-test
|
||||
|
||||
! dharmatech found this problem
|
||||
GENERIC: ed's-bug ( a -- b ) ;
|
||||
|
|
@ -493,7 +493,7 @@ M: integer ed's-bug neg ;
|
|||
{ t } [ \ ed's-test-case word-optimized? ] unit-test
|
||||
|
||||
! multiple bind
|
||||
{ 3 1 2 } [ let[ 1 2 3 :> ( a b c ) c a b ] ] unit-test
|
||||
{ 3 1 2 } [ let[ 1 2 3 set: ( a b c ) c a b ] ] unit-test
|
||||
|
||||
! Test smart combinators and locals interaction
|
||||
:: smart-combinator-locals ( a b c -- seq ) [ a b c ] output>array ;
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@ HELP: parse-def
|
|||
{ "name/paren" string }
|
||||
{ "def" "a " { $link def } " or a " { $link multi-def } }
|
||||
}
|
||||
{ $description "Parses the lexical variable bindings following a " { $link postpone\ :> } " token." } ;
|
||||
{ $description "Parses the lexical variable bindings following a " { $link postpone\ set: } " token." } ;
|
||||
|
||||
HELP: with-lambda-scope
|
||||
{ $values { "assoc" "local variables" } { "reader-quot" quotation } { "quot" quotation } }
|
||||
|
|
|
|||
|
|
@ -60,11 +60,11 @@ COMPILE>
|
|||
|
||||
COMPILE<
|
||||
{
|
||||
"V{ 99 :> kkk kkk }"
|
||||
"V{ 99 set: kkk kkk }"
|
||||
} [
|
||||
[
|
||||
"locals" use-vocab
|
||||
{ "99 :> kkk kkk ;" } <lexer> [
|
||||
{ "99 set: kkk kkk ;" } <lexer> [
|
||||
H{ } clone [ \ ; parse-until ] with-lambda-scope
|
||||
] with-lexer
|
||||
] with-compilation-unit unparse
|
||||
|
|
|
|||
|
|
@ -35,7 +35,7 @@ M: def localize
|
|||
|
||||
M: object localize 1quotation ;
|
||||
|
||||
! We special-case all the :> at the start of a quotation
|
||||
! We special-case all the set: at the start of a quotation
|
||||
: load-locals-quot ( args -- quot )
|
||||
[ [ ] ] [
|
||||
dup [ local-reader? ] any? [
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@ locals.errors locals.types make quotations sequences vectors
|
|||
words ;
|
||||
IN: locals.rewrite.sugar
|
||||
|
||||
! Step 1: rewrite |[ into :> forms, turn
|
||||
! Step 1: rewrite |[ into set: forms, turn
|
||||
! literals with locals in them into code which constructs
|
||||
! the literal after pushing locals on the stack
|
||||
|
||||
|
|
|
|||
|
|
@ -43,12 +43,12 @@ ERROR: unexpected-end n string ;
|
|||
n [
|
||||
n string $[ tokens member? ] find-from
|
||||
dup "\s\r\n" member? [
|
||||
:> ( n' ch )
|
||||
set: ( n' ch )
|
||||
n' string
|
||||
n n' string ?<slice>
|
||||
ch
|
||||
] [
|
||||
[ dup [ 1 + ] when ] dip :> ( n' ch )
|
||||
[ dup [ 1 + ] when ] dip set: ( n' ch )
|
||||
n' string
|
||||
n n' string ?<slice>
|
||||
ch
|
||||
|
|
@ -60,12 +60,12 @@ ERROR: unexpected-end n string ;
|
|||
! ":foo" with partial>> slot broke this
|
||||
:: lex-til-either ( lexer tokens -- n'/f string' slice/f ch/f )
|
||||
lexer >lexer<
|
||||
lexer partial>> :> partial
|
||||
lexer partial>> set: partial
|
||||
partial [
|
||||
[ dup [ 1 - ] when ] dip
|
||||
f lexer partial<<
|
||||
] when
|
||||
tokens slice-til-either :> ( n' string' slice ch )
|
||||
tokens slice-til-either set: ( n' string' slice ch )
|
||||
lexer
|
||||
n' >>n drop
|
||||
n' string'
|
||||
|
|
@ -74,13 +74,13 @@ ERROR: unexpected-end n string ;
|
|||
|
||||
|
||||
:: slice-til-separator-inclusive ( n string tokens -- n' string slice/f ch/f )
|
||||
n string $[ tokens member? ] find-from [ dup [ 1 + ] when ] dip :> ( n' ch )
|
||||
n string $[ tokens member? ] find-from [ dup [ 1 + ] when ] dip set: ( n' ch )
|
||||
n' string
|
||||
n n' string ?<slice>
|
||||
ch ; inline
|
||||
|
||||
:: lex-til-separator-inclusive ( lexer tokens -- n' string' slice/f ch/f )
|
||||
lexer >lexer< tokens slice-til-separator-inclusive :> ( n' string' slice ch )
|
||||
lexer >lexer< tokens slice-til-separator-inclusive set: ( n' string' slice ch )
|
||||
|
||||
lexer
|
||||
n' >>n drop
|
||||
|
|
@ -94,7 +94,7 @@ ERROR: unexpected-end n string ;
|
|||
] when ;
|
||||
|
||||
:: lex-til-separator-exclusive ( lexer tokens -- n'/f string' slice/f ch/f )
|
||||
lexer >lexer< tokens slice-til-separator-exclusive :> ( n' string' slice ch )
|
||||
lexer >lexer< tokens slice-til-separator-exclusive set: ( n' string' slice ch )
|
||||
lexer
|
||||
n' >>n drop
|
||||
n' string' slice ch ;
|
||||
|
|
@ -102,7 +102,7 @@ ERROR: unexpected-end n string ;
|
|||
! Don't include the whitespace in the slice
|
||||
:: slice-til-whitespace ( n string -- n'/f string slice/f ch/f )
|
||||
n [
|
||||
n string [ "\s\r\n" member? ] find-from :> ( n' ch )
|
||||
n string [ "\s\r\n" member? ] find-from set: ( n' ch )
|
||||
n' string
|
||||
n n' string ?<slice>
|
||||
ch
|
||||
|
|
@ -111,14 +111,14 @@ ERROR: unexpected-end n string ;
|
|||
] if ; inline
|
||||
|
||||
:: lex-til-whitespace ( lexer -- n'/f string slice/f ch/f )
|
||||
lexer >lexer< slice-til-whitespace :> ( n' string' slice ch )
|
||||
lexer >lexer< slice-til-whitespace set: ( n' string' slice ch )
|
||||
lexer
|
||||
n' >>n drop
|
||||
n' string' slice ch ;
|
||||
|
||||
! rollback only n, other state is not rolled back
|
||||
:: with-lexer-rollback ( lexer quot -- )
|
||||
lexer n>> :> n
|
||||
lexer n>> set: n
|
||||
lexer quot call lexer n >>n drop ; inline
|
||||
|
||||
|
||||
|
|
@ -130,7 +130,7 @@ ERROR: unexpected-end n string ;
|
|||
|
||||
:: slice-til-eol ( n string -- n'/f string slice/f ch/f )
|
||||
n [
|
||||
n string $[ "\r\n" member? ] find-from :> ( n' ch )
|
||||
n string $[ "\r\n" member? ] find-from set: ( n' ch )
|
||||
n' string
|
||||
n n' string ?<slice>
|
||||
ch
|
||||
|
|
@ -139,7 +139,7 @@ ERROR: unexpected-end n string ;
|
|||
] if ; inline
|
||||
|
||||
:: lex-til-eol ( lexer -- n' string' slice/f ch/f )
|
||||
lexer >lexer< slice-til-eol :> ( n' string' slice ch )
|
||||
lexer >lexer< slice-til-eol set: ( n' string' slice ch )
|
||||
lexer
|
||||
n' >>n drop
|
||||
n' string' slice ch ;
|
||||
|
|
@ -148,14 +148,14 @@ ERROR: unexpected-end n string ;
|
|||
ERROR: subseq-expected-but-got-eof n string expected ;
|
||||
|
||||
:: slice-til-string ( n string search -- n' string payload closing )
|
||||
search string n start* :> n'
|
||||
search string n start* set: n'
|
||||
n' [ n string search subseq-expected-but-got-eof ] unless
|
||||
n' search length + string
|
||||
n n' string ?<slice>
|
||||
n' dup search length + string ?<slice> ;
|
||||
|
||||
:: lex-til-string ( lexer search -- n'/f string' payload closing )
|
||||
lexer >lexer< search slice-til-string :> ( n' string' payload closing )
|
||||
lexer >lexer< search slice-til-string set: ( n' string' payload closing )
|
||||
lexer
|
||||
n' >>n drop
|
||||
n' string' payload closing ;
|
||||
|
|
@ -174,14 +174,14 @@ ERROR: subseq-expected-but-got-eof n string expected ;
|
|||
ERROR: char-expected-but-got-eof n string expected ;
|
||||
|
||||
:: slice-til-not-char ( n string slice char -- n' string found )
|
||||
n string [ char = not ] find-from drop :> n'
|
||||
n string [ char = not ] find-from drop set: n'
|
||||
n' [ n string char char-expected-but-got-eof ] unless
|
||||
n'
|
||||
string
|
||||
slice from>> n' string ?<slice> ;
|
||||
|
||||
:: lex-til-not-char ( lexer slice char -- n'/f string' found )
|
||||
lexer >lexer< slice char slice-til-not-char :> ( n' string' found )
|
||||
lexer >lexer< slice char slice-til-not-char set: ( n' string' found )
|
||||
lexer
|
||||
n' >>n drop
|
||||
n' string' found ;
|
||||
|
|
|
|||
|
|
@ -261,21 +261,21 @@ MACRO:: read-double-matched ( open-ch -- quot: ( lexer tag ch -- seq ) )
|
|||
[ drop 2 swap <string> ]
|
||||
[ drop 1string ]
|
||||
[ nip 2 swap <string> ]
|
||||
} 2cleave :> ( openstr2 openstr1 closestr2 )
|
||||
} 2cleave set: ( openstr2 openstr1 closestr2 )
|
||||
|[ lexer tag! ch |
|
||||
ch {
|
||||
{ char: = [
|
||||
lexer openstr1 lex-til-separator-inclusive [ -1 modify-from ] dip :> ( n' string' opening ch )
|
||||
lexer openstr1 lex-til-separator-inclusive [ -1 modify-from ] dip set: ( n' string' opening ch )
|
||||
ch open-ch = [ tag openstr2 lexer ch long-opening-mismatch ] unless
|
||||
opening matching-delimiter-string :> needle
|
||||
opening matching-delimiter-string set: needle
|
||||
|
||||
lexer needle lex-til-string :> ( n'' string'' payload closing )
|
||||
lexer needle lex-til-string set: ( n'' string'' payload closing )
|
||||
payload closing tag but-last-slice opening double-matched-literal make-matched-literal
|
||||
[ >string ] change-payload
|
||||
] }
|
||||
{ open-ch [
|
||||
tag 1 cut-slice* swap tag! 1 modify-to :> opening
|
||||
lexer [ 1 + ] change-n closestr2 lex-til-string :> ( n' string' payload closing )
|
||||
tag 1 cut-slice* swap tag! 1 modify-to set: opening
|
||||
lexer [ 1 + ] change-n closestr2 lex-til-string set: ( n' string' payload closing )
|
||||
payload closing tag opening double-matched-literal make-matched-literal
|
||||
[ >string ] change-payload
|
||||
] }
|
||||
|
|
@ -317,7 +317,7 @@ MACRO:: read-matched ( ch -- quot: ( lexer tag -- slice' ) )
|
|||
ch dup matching-delimiter {
|
||||
[ drop "=" swap prefix ]
|
||||
[ nip 1string ]
|
||||
} 2cleave :> ( openstreq closestr1 ) ! [= ]
|
||||
} 2cleave set: ( openstreq closestr1 ) ! [= ]
|
||||
|
||||
|[ lexer tag |
|
||||
lexer tag
|
||||
|
|
@ -339,7 +339,7 @@ MACRO:: read-matched ( ch -- quot: ( lexer tag -- slice' ) )
|
|||
|
||||
:: read-string-payload ( lexer -- n' string slice )
|
||||
lexer dup ?lexer-nth [
|
||||
{ char: \\ char: \" } lex-til-separator-inclusive :> ( n' string' slice ch )
|
||||
{ char: \\ char: \" } lex-til-separator-inclusive set: ( n' string' slice ch )
|
||||
ch {
|
||||
{ f [ n' string' slice ] }
|
||||
{ char: \" [ n' string' slice ] }
|
||||
|
|
@ -350,8 +350,8 @@ MACRO:: read-matched ( ch -- quot: ( lexer tag -- slice' ) )
|
|||
] if ;
|
||||
|
||||
:: read-string ( lexer tag -- seq )
|
||||
lexer n>> :> n
|
||||
lexer read-string-payload :> ( n' string slice )
|
||||
lexer n>> set: n
|
||||
lexer read-string-payload set: ( n' string slice )
|
||||
n' [ n string string-expected-got-eof ] unless
|
||||
n n' 1 - string <slice>
|
||||
n' 1 - n' string <slice>
|
||||
|
|
@ -426,11 +426,11 @@ ERROR: closing-tag-required lexer tag ;
|
|||
(trim-tail) [ length ] dip - ; inline
|
||||
|
||||
:: read-backtick ( lexer slice -- obj )
|
||||
lexer slice char: \` lex-til-not-char 2nip :> tag-opening
|
||||
tag-opening [ char: \` = ] count-tail :> count
|
||||
tag-opening count cut-slice* :> ( tag opening )
|
||||
lexer slice char: \` lex-til-not-char 2nip set: tag-opening
|
||||
tag-opening [ char: \` = ] count-tail set: count
|
||||
tag-opening count cut-slice* set: ( tag opening )
|
||||
count 1 > [
|
||||
lexer opening lex-til-string :> ( n' string' payload closing )
|
||||
lexer opening lex-til-string set: ( n' string' payload closing )
|
||||
payload closing tag opening matched-backtick-literal make-matched-literal
|
||||
[ >string ] change-payload
|
||||
] [
|
||||
|
|
|
|||
|
|
@ -61,13 +61,13 @@ ERROR: unexpected-end n string ;
|
|||
|
||||
! Don't include the whitespace in the slice
|
||||
:: slice-til-whitespace ( n string -- n' string slice/f ch/f )
|
||||
n string [ "\s\r\n" member? ] find-from :> ( n' ch )
|
||||
n string [ "\s\r\n" member? ] find-from set: ( n' ch )
|
||||
n' string
|
||||
n n' string ?<slice>
|
||||
ch ; inline
|
||||
|
||||
:: (slice-until) ( n string quot -- n' string slice/f ch/f )
|
||||
n string quot find-from :> ( n' ch )
|
||||
n string quot find-from set: ( n' ch )
|
||||
n' string
|
||||
n n' string ?<slice>
|
||||
ch ; inline
|
||||
|
|
@ -76,7 +76,7 @@ ERROR: unexpected-end n string ;
|
|||
(slice-until) drop ; inline
|
||||
|
||||
:: slice-til-not-whitespace ( n string -- n' string slice/f ch/f )
|
||||
n string [ "\s\r\n" member? not ] find-from :> ( n' ch )
|
||||
n string [ "\s\r\n" member? not ] find-from set: ( n' ch )
|
||||
n' string
|
||||
n n' string ?<slice>
|
||||
ch ; inline
|
||||
|
|
@ -92,7 +92,7 @@ ERROR: unexpected-end n string ;
|
|||
|
||||
:: slice-til-eol ( n string -- n' string slice/f ch/f )
|
||||
n [
|
||||
n string $[ "\r\n" member? ] find-from :> ( n' ch )
|
||||
n string $[ "\r\n" member? ] find-from set: ( n' ch )
|
||||
n' string
|
||||
n n' string ?<slice>
|
||||
ch
|
||||
|
|
@ -102,7 +102,7 @@ ERROR: unexpected-end n string ;
|
|||
|
||||
:: ((merge-slice-til-eol-slash)) ( n string -- n' string slice/f ch/f )
|
||||
n [
|
||||
n string $[ "\r\n\\" member? ] find-from :> ( n' ch )
|
||||
n string $[ "\r\n\\" member? ] find-from set: ( n' ch )
|
||||
n' string
|
||||
n n' string ?<slice>
|
||||
ch
|
||||
|
|
@ -129,7 +129,7 @@ ERROR: unexpected-end n string ;
|
|||
over [ ?nth ] [ 2drop f ] if ;
|
||||
|
||||
:: (merge-slice-til-eol-slash) ( n string slice -- n' string slice/f ch/f )
|
||||
n string ((merge-slice-til-eol-slash)) :> ( n' string' slice' ch' )
|
||||
n string ((merge-slice-til-eol-slash)) set: ( n' string' slice' ch' )
|
||||
ch' char: \ = [
|
||||
n' 1 + string' ?nth' "\r\n" member? [
|
||||
n' 2 + string' slice slice' span-slices (merge-slice-til-eol-slash)
|
||||
|
|
@ -145,7 +145,7 @@ ERROR: unexpected-end n string ;
|
|||
2dup empty-slice-from (merge-slice-til-eol-slash) ;
|
||||
|
||||
:: slice-til-separator-inclusive ( n string tokens -- n' string slice/f ch/f )
|
||||
n string $[ tokens member? ] find-from [ dup [ 1 + ] when ] dip :> ( n' ch )
|
||||
n string $[ tokens member? ] find-from [ dup [ 1 + ] when ] dip set: ( n' ch )
|
||||
n' string
|
||||
n n' string ?<slice>
|
||||
ch ; inline
|
||||
|
|
@ -159,12 +159,12 @@ ERROR: unexpected-end n string ;
|
|||
n [
|
||||
n string $[ tokens member? ] find-from
|
||||
dup "\s\r\n" member? [
|
||||
:> ( n' ch )
|
||||
set: ( n' ch )
|
||||
n' string
|
||||
n n' string ?<slice>
|
||||
ch
|
||||
] [
|
||||
[ dup [ 1 + ] when ] dip :> ( n' ch )
|
||||
[ dup [ 1 + ] when ] dip set: ( n' ch )
|
||||
n' string
|
||||
n n' string ?<slice>
|
||||
ch
|
||||
|
|
@ -176,7 +176,7 @@ ERROR: unexpected-end n string ;
|
|||
ERROR: subseq-expected-but-got-eof n string expected ;
|
||||
|
||||
:: slice-til-string ( n string search -- n' string payload end-string )
|
||||
search string n start* :> n'
|
||||
search string n start* set: n'
|
||||
n' [ n string search subseq-expected-but-got-eof ] unless
|
||||
n' search length + string
|
||||
n n' string ?<slice>
|
||||
|
|
@ -185,7 +185,7 @@ ERROR: subseq-expected-but-got-eof n string expected ;
|
|||
ERROR: char-expected-but-got-eof n string expected ;
|
||||
|
||||
:: slice-til-not-char ( n string slice char -- n' string found )
|
||||
n string [ char = not ] find-from drop :> n'
|
||||
n string [ char = not ] find-from drop set: n'
|
||||
n' [ n string char char-expected-but-got-eof ] unless
|
||||
B
|
||||
n'
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@ IN: multiline
|
|||
PRIVATE<
|
||||
|
||||
:: scan-multiline-string ( i end lexer -- j )
|
||||
lexer line-text>> :> text
|
||||
lexer line-text>> set: text
|
||||
lexer still-parsing? [
|
||||
end text i start* |[ j |
|
||||
i j text subseq % j end length +
|
||||
|
|
|
|||
|
|
@ -166,19 +166,19 @@ M: object apply-object push-literal ;
|
|||
dup pair? [ second dup effect? [ drop f ] unless ] [ drop f ] if ;
|
||||
|
||||
:: declare-effect-d ( word effect variables branches n -- )
|
||||
meta-d length :> d-length
|
||||
meta-d length set: d-length
|
||||
n d-length < [
|
||||
d-length 1 - n - :> n'
|
||||
n' meta-d nth :> value
|
||||
value known :> known
|
||||
known word effect variables branches <declared-effect> :> known'
|
||||
d-length 1 - n - set: n'
|
||||
n' meta-d nth set: value
|
||||
value known set: known
|
||||
known word effect variables branches <declared-effect> set: known'
|
||||
known' value set-known
|
||||
known' branches push
|
||||
] [ word unknown-macro-input ] if ;
|
||||
|
||||
:: declare-input-effects ( word -- )
|
||||
H{ } clone :> variables
|
||||
V{ } clone :> branches
|
||||
H{ } clone set: variables
|
||||
V{ } clone set: branches
|
||||
word stack-effect in>> <reversed> |[ in n |
|
||||
in ?quotation-effect |[ effect |
|
||||
word effect variables branches n declare-effect-d
|
||||
|
|
|
|||
|
|
@ -206,10 +206,10 @@ M: object infer-call* \ call bad-macro-input ;
|
|||
\ load-local [ infer-load-local ] "special" set-word-prop
|
||||
|
||||
:: infer-get-local ( -- )
|
||||
pop-literal nip 1 swap - :> n
|
||||
n consume-r :> in-r
|
||||
in-r first copy-value 1array :> out-d
|
||||
in-r copy-values :> out-r
|
||||
pop-literal nip 1 swap - set: n
|
||||
n consume-r set: in-r
|
||||
in-r first copy-value 1array set: out-d
|
||||
in-r copy-values set: out-r
|
||||
|
||||
out-d output-d
|
||||
out-r output-r
|
||||
|
|
|
|||
|
|
@ -410,8 +410,8 @@ IN: bootstrap.syntax
|
|||
"IDENTITY-MEMO:" [ (:) define-identity-memoized ] define-core-syntax
|
||||
"IDENTITY-MEMO::" [ (::) define-identity-memoized ] define-core-syntax
|
||||
|
||||
":>" [
|
||||
in-lambda? get [ :>-outside-lambda-error ] unless
|
||||
"set:" [
|
||||
in-lambda? get [ set:-outside-lambda-error ] unless
|
||||
scan-token parse-def suffix!
|
||||
] define-core-syntax
|
||||
|
||||
|
|
|
|||
|
|
@ -18,7 +18,7 @@ MACRO: declare1 ( type -- quot: ( value -- value ) )
|
|||
PRIVATE>
|
||||
|
||||
:: (typed-get) ( name type getter: ( name -- value ) -- value )
|
||||
name getter call :> value
|
||||
name getter call set: value
|
||||
value type instance? [ name value type variable-type-error ] unless
|
||||
value type declare1 ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -67,7 +67,7 @@ PRIVATE<
|
|||
[ (unboxed-types) ] map concat ;
|
||||
|
||||
:: typed-inputs ( quot word types -- quot' )
|
||||
types unboxed-types :> unboxed-types
|
||||
types unboxed-types set: unboxed-types
|
||||
|
||||
[ input-mismatch-error ] word types make-unboxer
|
||||
unboxed-types quot $[ _ declare @ ]
|
||||
|
|
|
|||
|
|
@ -137,7 +137,7 @@ M: range-observer model-changed
|
|||
|
||||
:: create-gadgets ( -- gadgets )
|
||||
<shelf>
|
||||
<boids-gadget> :> boids-gadget
|
||||
<boids-gadget> set: boids-gadget
|
||||
boids-gadget [ start-boids-thread ] keep
|
||||
add-gadget
|
||||
|
||||
|
|
|
|||
|
|
@ -65,10 +65,10 @@ GENERIC: force ( neighbors boid behaviour -- force ) ;
|
|||
:: simulate ( boids behaviours dt -- boids )
|
||||
boids |[ boid |
|
||||
boid boids behaviours
|
||||
[ [ (force) ] keep weight>> v*n ] 2with map vsum :> a
|
||||
[ [ (force) ] keep weight>> v*n ] 2with map vsum set: a
|
||||
|
||||
boid vel>> a dt v*n v+ normalize :> vel
|
||||
boid pos>> vel dt v*n v+ wrap-pos :> pos
|
||||
boid vel>> a dt v*n v+ normalize set: vel
|
||||
boid pos>> vel dt v*n v+ wrap-pos set: pos
|
||||
|
||||
pos vel <boid>
|
||||
] map ;
|
||||
|
|
@ -95,6 +95,6 @@ M: alignment force ( neighbors boid behaviour -- force )
|
|||
2drop [ vel>> ] map vsum normalize ;
|
||||
|
||||
M:: separation force ( neighbors boid behaviour -- force )
|
||||
behaviour radius>> :> r
|
||||
behaviour radius>> set: r
|
||||
boid pos>> neighbors
|
||||
[ pos>> v- [ normalize ] [ r v/n ] bi v- ] with map vsum ;
|
||||
|
|
|
|||
|
|
@ -33,7 +33,7 @@ IN: project-euler.073
|
|||
PRIVATE<
|
||||
|
||||
:: (euler073) ( counter limit lo hi -- counter' )
|
||||
lo hi mediant :> m
|
||||
lo hi mediant set: m
|
||||
m denominator limit <= [
|
||||
counter 1 +
|
||||
limit lo m (euler073)
|
||||
|
|
|
|||
|
|
@ -51,7 +51,7 @@ PRIVATE<
|
|||
0 1000 [1,b] [ [ next ] replicate partial-sums ] map nip ; inline
|
||||
|
||||
:: (euler150) ( m -- n )
|
||||
sums-triangle :> table
|
||||
sums-triangle set: table
|
||||
m iota |[ x |
|
||||
x 1 + iota |[ y |
|
||||
m x - iota |[ z |
|
||||
|
|
|
|||
|
|
@ -22,8 +22,8 @@ IN: rosetta-code.balanced-brackets
|
|||
! [[][]] OK []][[] NOT OK
|
||||
|
||||
:: balanced? ( str -- ? )
|
||||
0 :> counter!
|
||||
t :> ok!
|
||||
0 set: counter!
|
||||
t set: ok!
|
||||
str [
|
||||
{
|
||||
{ char: \[ [ 1 ] }
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@ IN: rosetta-code.bitmap-bezier
|
|||
! draw a cubic bezier curves (definition on Wikipedia).
|
||||
|
||||
:: (cubic-bezier) ( P0 P1 P2 P3 -- bezier )
|
||||
[ :> x
|
||||
[ set: x
|
||||
1 x - 3 ^ P0 n*v
|
||||
1 x - sq 3 * x * P1 n*v
|
||||
1 x - 3 * x sq * P2 n*v
|
||||
|
|
|
|||
|
|
@ -12,9 +12,9 @@ IN: rosetta-code.bitmap-line
|
|||
! algorithm.
|
||||
|
||||
:: line-points ( pt1 pt2 -- points )
|
||||
pt1 first2 :> y0! :> x0!
|
||||
pt2 first2 :> y1! :> x1!
|
||||
y1 y0 - abs x1 x0 - abs > :> steep
|
||||
pt1 first2 set: y0! set: x0!
|
||||
pt2 first2 set: y1! set: x1!
|
||||
y1 y0 - abs x1 x0 - abs > set: steep
|
||||
steep [
|
||||
y0 x0 y0! x0!
|
||||
y1 x1 y1! x1!
|
||||
|
|
@ -23,12 +23,12 @@ IN: rosetta-code.bitmap-line
|
|||
x0 x1 x0! x1!
|
||||
y0 y1 y0! y1!
|
||||
] when
|
||||
x1 x0 - :> deltax
|
||||
y1 y0 - abs :> deltay
|
||||
0 :> current-error!
|
||||
deltay deltax / abs :> deltaerr
|
||||
0 :> ystep!
|
||||
y0 :> y!
|
||||
x1 x0 - set: deltax
|
||||
y1 y0 - abs set: deltay
|
||||
0 set: current-error!
|
||||
deltay deltax / abs set: deltaerr
|
||||
0 set: ystep!
|
||||
y0 set: y!
|
||||
y0 y1 < [ 1 ystep! ] [ -1 ystep! ] if
|
||||
x0 x1 1 <range> [
|
||||
y steep [ swap ] when 2array
|
||||
|
|
|
|||
|
|
@ -50,7 +50,7 @@ M: pi cfrac-b
|
|||
|
||||
:: cfrac-estimate ( cfrac terms -- number )
|
||||
terms cfrac cfrac-a ! top = last a_n
|
||||
terms 1 - 1 [a,b] [ :> n
|
||||
terms 1 - 1 [a,b] [ set: n
|
||||
n cfrac cfrac-b swap / ! top = b_n / top
|
||||
n cfrac cfrac-a + ! top = top + a_n
|
||||
] each ;
|
||||
|
|
@ -59,7 +59,7 @@ M: pi cfrac-b
|
|||
rational 1 /mod ! split whole, fractional parts
|
||||
prec 10^ * ! multiply fraction by 10 ^ prec
|
||||
[ >integer unparse ] bi@ ! convert digits to strings
|
||||
:> fraction
|
||||
set: fraction
|
||||
"." ! push decimal point
|
||||
prec fraction length -
|
||||
dup 0 < [ drop 0 ] when
|
||||
|
|
|
|||
|
|
@ -29,7 +29,7 @@ IN: rosetta-code.count-the-coins
|
|||
PRIVATE<
|
||||
|
||||
:: (make-change) ( cents coins -- ways )
|
||||
cents 1 + 0 <array> :> ways
|
||||
cents 1 + 0 <array> set: ways
|
||||
1 ways set-first
|
||||
coins |[ coin |
|
||||
coin cents [a,b] |[ j |
|
||||
|
|
|
|||
|
|
@ -70,7 +70,7 @@ IN: rosetta-code.dice7
|
|||
! deviation from the ideal number of items in each bucket,
|
||||
! expressed as a fraction of the total count.
|
||||
:: test-distribution ( #sides #trials quot error -- )
|
||||
#sides #trials quot replicate count-outcomes :> outcomes
|
||||
#sides #trials quot replicate count-outcomes set: outcomes
|
||||
outcomes .
|
||||
outcomes error fair-counts?
|
||||
"Random enough" "Not random enough" ? . ; inline
|
||||
|
|
|
|||
|
|
@ -37,7 +37,7 @@ IN: rosetta-code.gray-code
|
|||
: gray-encode ( n -- n' ) dup -1 shift bitxor ;
|
||||
|
||||
:: gray-decode ( n! -- n' )
|
||||
n :> p!
|
||||
n set: p!
|
||||
[ n -1 shift dup n! 0 = not ] [
|
||||
p n bitxor p!
|
||||
] while
|
||||
|
|
|
|||
|
|
@ -21,8 +21,8 @@ IN: rosetta-code.hamming-lazy
|
|||
! a convenient library – supports arbitrary-precision integers).
|
||||
|
||||
:: sort-merge ( xs ys -- result )
|
||||
xs car :> x
|
||||
ys car :> y
|
||||
xs car set: x
|
||||
ys car set: y
|
||||
{
|
||||
{ [ x y < ] [ [ x ] [ xs cdr ys sort-merge ] lazy-cons ] }
|
||||
{ [ x y > ] [ [ y ] [ ys cdr xs sort-merge ] lazy-cons ] }
|
||||
|
|
@ -30,7 +30,7 @@ IN: rosetta-code.hamming-lazy
|
|||
} cond ;
|
||||
|
||||
:: hamming ( -- hamming )
|
||||
f :> h!
|
||||
f set: h!
|
||||
[ 1 ] [
|
||||
h 2 3 5 [ $[ _ * ] lmap-lazy ] tri-curry@ tri
|
||||
sort-merge sort-merge
|
||||
|
|
|
|||
|
|
@ -60,9 +60,9 @@ CONSTANT: limit 400 ;
|
|||
items length 1 + [ limit 1 + 0 <array> ] replicate ;
|
||||
|
||||
:: iterate ( item-no table -- )
|
||||
item-no table nth :> prev
|
||||
item-no 1 + table nth :> curr
|
||||
item-no items nth :> item
|
||||
item-no table nth set: prev
|
||||
item-no 1 + table nth set: curr
|
||||
item-no items nth set: item
|
||||
limit [1,b] |[ weight |
|
||||
weight prev nth
|
||||
weight item weight>> - dup 0 >=
|
||||
|
|
@ -77,10 +77,10 @@ CONSTANT: limit 400 ;
|
|||
|
||||
:: extract-packed-items ( table -- items )
|
||||
[
|
||||
limit :> weight!
|
||||
limit set: weight!
|
||||
items length iota <reversed> |[ item-no |
|
||||
item-no table nth :> prev
|
||||
item-no 1 + table nth :> curr
|
||||
item-no table nth set: prev
|
||||
item-no 1 + table nth set: curr
|
||||
weight [ curr nth ] [ prev nth ] bi =
|
||||
[
|
||||
item-no items nth
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ IN: rosetta-code.n-queens
|
|||
! solve the puzzle with a board of side NxN.
|
||||
|
||||
:: safe? ( board q -- ? )
|
||||
let[ q board nth :> x
|
||||
let[ q board nth set: x
|
||||
q iota [
|
||||
x swap
|
||||
[ board nth ] keep
|
||||
|
|
|
|||
|
|
@ -50,9 +50,9 @@ PRIVATE<
|
|||
PRIVATE>
|
||||
|
||||
:: read-odd-word ( -- )
|
||||
f :> first-continuation!
|
||||
f :> last-continuation!
|
||||
f :> reverse!
|
||||
f set: first-continuation!
|
||||
f set: last-continuation!
|
||||
f set: reverse!
|
||||
! Read characters. Loop until end of stream.
|
||||
[ read1 dup ] [
|
||||
dup Letter? [
|
||||
|
|
|
|||
|
|
@ -87,7 +87,7 @@ M: ast-return compile-ast
|
|||
[ <def> [ f ] swap suffix ] map [ ] join ;
|
||||
|
||||
:: compile-sequence ( lexenv block -- vars quot )
|
||||
lexenv block block-lexenv lexenv-union :> lexenv
|
||||
lexenv block block-lexenv lexenv-union set: lexenv
|
||||
block arguments>> lexenv lookup-block-vars
|
||||
lexenv block body>> (compile-sequence) block lexenv make-temporaries prepend ;
|
||||
|
||||
|
|
|
|||
|
|
@ -129,7 +129,7 @@ CONSTANT: otug-slides
|
|||
"Area of a triangle using Heron's formula"
|
||||
{ $code
|
||||
":: area ( a b c -- x )
|
||||
a b c + + 2 / :> p
|
||||
a b c + + 2 / set: p
|
||||
p
|
||||
p a - *
|
||||
p b - *
|
||||
|
|
|
|||
|
|
@ -12,11 +12,11 @@ IN: cairo-samples
|
|||
|
||||
TUPLE: arc-gadget < cairo-gadget ;
|
||||
M:: arc-gadget render-cairo* ( gadget -- )
|
||||
128.0 :> xc
|
||||
128.0 :> yc
|
||||
100.0 :> radius
|
||||
pi 1/4 * :> angle1
|
||||
pi :> angle2
|
||||
128.0 set: xc
|
||||
128.0 set: yc
|
||||
100.0 set: radius
|
||||
pi 1/4 * set: angle1
|
||||
pi set: angle2
|
||||
cr 10.0 cairo_set_line_width
|
||||
cr xc yc radius angle1 angle2 cairo_arc
|
||||
cr cairo_stroke
|
||||
|
|
@ -55,9 +55,9 @@ M: clip-gadget render-cairo* ( gadget -- )
|
|||
TUPLE: clip-image-gadget < cairo-gadget ;
|
||||
M:: clip-image-gadget render-cairo* ( gadget -- )
|
||||
"resource:misc/icons/Factor_128x128.png"
|
||||
normalize-path cairo_image_surface_create_from_png :> png
|
||||
png cairo_image_surface_get_width :> w
|
||||
png cairo_image_surface_get_height :> h
|
||||
normalize-path cairo_image_surface_create_from_png set: png
|
||||
png cairo_image_surface_get_width set: w
|
||||
png cairo_image_surface_get_height set: h
|
||||
cr 128 128 76.8 0 2 pi * cairo_arc
|
||||
cr cairo_clip
|
||||
cr cairo_new_path
|
||||
|
|
@ -69,8 +69,8 @@ M:: clip-image-gadget render-cairo* ( gadget -- )
|
|||
|
||||
TUPLE: dash-gadget < cairo-gadget ;
|
||||
M:: dash-gadget render-cairo* ( gadget -- )
|
||||
double-array{ 50 10 10 10 } underlying>> :> dashes
|
||||
4 :> ndash
|
||||
double-array{ 50 10 10 10 } underlying>> set: dashes
|
||||
4 set: ndash
|
||||
cr dashes ndash -50 cairo_set_dash
|
||||
cr 10 cairo_set_line_width
|
||||
cr 128.0 25.6 cairo_move_to
|
||||
|
|
@ -81,9 +81,9 @@ M:: dash-gadget render-cairo* ( gadget -- )
|
|||
|
||||
TUPLE: gradient-gadget < cairo-gadget ;
|
||||
M:: gradient-gadget render-cairo* ( gadget -- )
|
||||
0 0 0 256 cairo_pattern_create_linear :> pat
|
||||
0 0 0 256 cairo_pattern_create_linear set: pat
|
||||
115.2 102.4 25.6 102.4 102.4 128.0
|
||||
cairo_pattern_create_radial :> radial
|
||||
cairo_pattern_create_radial set: radial
|
||||
pat 1 0 0 0 1 cairo_pattern_add_color_stop_rgba
|
||||
pat 0 1 1 1 1 cairo_pattern_add_color_stop_rgba
|
||||
cr 0 0 256 256 cairo_rectangle
|
||||
|
|
|
|||
|
|
@ -17,9 +17,9 @@ CONSTANT: NS-EACH-BUFFER-SIZE 16 ;
|
|||
] with-destructors ; inline
|
||||
|
||||
:: (NSFastEnumeration-each) ( ... object quot: ( ... elt -- ) state stackbuf count -- ... )
|
||||
object state stackbuf count send\ countByEnumeratingWithState:objects:count: :> items-count
|
||||
object state stackbuf count send\ countByEnumeratingWithState:objects:count: set: items-count
|
||||
items-count 0 = [
|
||||
state itemsPtr>> [ items-count id <c-direct-array> ] [ stackbuf ] if* :> items
|
||||
state itemsPtr>> [ items-count id <c-direct-array> ] [ stackbuf ] if* set: items
|
||||
items-count iota [ items nth quot call ] each
|
||||
object quot state stackbuf count (NSFastEnumeration-each)
|
||||
] unless ; inline recursive
|
||||
|
|
|
|||
|
|
@ -49,7 +49,7 @@ IN: cocoa.subclassing
|
|||
] with-nested-compilation-unit ;
|
||||
|
||||
:: (redefine-objc-method) ( class method -- )
|
||||
method init-method :> ( sel imp types )
|
||||
method init-method set: ( sel imp types )
|
||||
|
||||
class sel class_getInstanceMethod [
|
||||
imp method_setImplementation drop
|
||||
|
|
@ -63,7 +63,7 @@ IN: cocoa.subclassing
|
|||
] [ 2drop ] if ;
|
||||
|
||||
:: define-objc-class ( name superclass protocols methods -- )
|
||||
methods prepare-methods :> methods
|
||||
methods prepare-methods set: methods
|
||||
name "cocoa.classes" create-word drop
|
||||
methods name redefine-objc-methods
|
||||
name [ methods protocols superclass name (define-objc-class) ] import-objc-class ;
|
||||
|
|
|
|||
|
|
@ -20,8 +20,8 @@ IN: core-text.tests
|
|||
|
||||
:: test-typographic-bounds ( string font -- ? )
|
||||
[
|
||||
font test-font &CFRelease :> ctfont
|
||||
string ctfont color: white <CTLine> &CFRelease :> ctline
|
||||
font test-font &CFRelease set: ctfont
|
||||
string ctfont color: white <CTLine> &CFRelease set: ctline
|
||||
ctfont ctline compute-line-metrics {
|
||||
[ width>> float? ]
|
||||
[ ascent>> float? ]
|
||||
|
|
|
|||
|
|
@ -116,8 +116,8 @@ render-loc render-dim ;
|
|||
:: <line> ( font string -- line )
|
||||
[
|
||||
line new-disposable
|
||||
font retina? get-global [ cache-font@2x ] [ cache-font ] if :> open-font
|
||||
string open-font font foreground>> <CTLine> |CFRelease :> line
|
||||
font retina? get-global [ cache-font@2x ] [ cache-font ] if set: open-font
|
||||
string open-font font foreground>> <CTLine> |CFRelease set: line
|
||||
open-font line compute-line-metrics
|
||||
[ >>metrics ] [ metrics>dim >>dim ] bi
|
||||
font >>font
|
||||
|
|
@ -126,18 +126,18 @@ render-loc render-dim ;
|
|||
] with-destructors ;
|
||||
|
||||
:: render ( line -- line image )
|
||||
line line>> :> ctline
|
||||
line string>> :> string
|
||||
line font>> :> font
|
||||
line line>> set: ctline
|
||||
line string>> set: string
|
||||
line font>> set: font
|
||||
|
||||
line render-loc>> [
|
||||
|
||||
ctline line-rect :> rect
|
||||
rect origin>> CGPoint>loc :> (loc)
|
||||
rect size>> CGSize>dim :> (dim)
|
||||
(loc) vfloor :> loc
|
||||
(loc) (dim) v+ vceiling :> ext
|
||||
ext loc [ - >integer 1 max ] 2map :> dim
|
||||
ctline line-rect set: rect
|
||||
rect origin>> CGPoint>loc set: (loc)
|
||||
rect size>> CGSize>dim set: (dim)
|
||||
(loc) vfloor set: loc
|
||||
(loc) (dim) v+ vceiling set: ext
|
||||
ext loc [ - >integer 1 max ] 2map set: dim
|
||||
|
||||
loc line render-loc<<
|
||||
dim line render-dim<<
|
||||
|
|
@ -146,8 +146,8 @@ render-loc render-dim ;
|
|||
|
||||
] unless
|
||||
|
||||
line render-loc>> :> loc
|
||||
line render-dim>> :> dim
|
||||
line render-loc>> set: loc
|
||||
line render-dim>> set: dim
|
||||
|
||||
line dim [
|
||||
{
|
||||
|
|
|
|||
|
|
@ -75,10 +75,10 @@ IN: cuda.devices
|
|||
:: (distribute-jobs) ( job-count per-job-shared max-shared-size max-block-size
|
||||
-- grid-size block-size per-block-shared )
|
||||
per-job-shared [ max-block-size ] [ max-shared-size swap /i max-block-size min ] if-zero
|
||||
job-count min :> job-max-block-size
|
||||
job-count job-max-block-size up/i :> grid-size
|
||||
job-count grid-size up/i :> block-size
|
||||
block-size per-job-shared * :> per-block-shared
|
||||
job-count min set: job-max-block-size
|
||||
job-count job-max-block-size up/i set: grid-size
|
||||
job-count grid-size up/i set: block-size
|
||||
block-size per-job-shared * set: per-block-shared
|
||||
|
||||
grid-size block-size per-block-shared ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -23,7 +23,7 @@ M: macosx nvcc-path "/usr/local/cuda/bin/nvcc" ;
|
|||
ERROR: nvcc-failed n path ;
|
||||
|
||||
:: compile-cu ( path -- path' )
|
||||
path normalize-path :> path2
|
||||
path normalize-path set: path2
|
||||
path2 parent-directory [
|
||||
path2 nvcc-command
|
||||
run-process wait-for-process [ path2 nvcc-failed ] unless-zero
|
||||
|
|
|
|||
|
|
@ -290,7 +290,7 @@ PRIVATE<
|
|||
|
||||
:: (wcread) ( n encoding window-ptr -- string )
|
||||
[
|
||||
n 1 + malloc &free :> str
|
||||
n 1 + malloc &free set: str
|
||||
window-ptr str n ffi:wgetnstr curses-error
|
||||
str encoding alien>string
|
||||
] with-destructors ; inline
|
||||
|
|
|
|||
|
|
@ -39,11 +39,11 @@ PRIVATE>
|
|||
[ &BN_clear_free EC_KEY_set_private_key ssl-error ] with-destructors ;
|
||||
|
||||
:: set-public-key ( BIN -- )
|
||||
ec-key-handle :> KEY
|
||||
KEY EC_KEY_get0_group :> GROUP
|
||||
ec-key-handle set: KEY
|
||||
KEY EC_KEY_get0_group set: GROUP
|
||||
GROUP EC_POINT_new dup ssl-error
|
||||
[
|
||||
&EC_POINT_clear_free :> POINT
|
||||
&EC_POINT_clear_free set: POINT
|
||||
GROUP POINT BIN dup length f EC_POINT_oct2point ssl-error
|
||||
KEY POINT EC_KEY_set_public_key ssl-error
|
||||
] with-destructors ;
|
||||
|
|
@ -53,21 +53,21 @@ PRIVATE>
|
|||
dup [ dup BN_num_bits bits>bytes <byte-array> [ BN_bn2bin drop ] keep ] when ;
|
||||
|
||||
:: get-public-key ( -- bin/f )
|
||||
ec-key-handle :> KEY
|
||||
ec-key-handle set: KEY
|
||||
KEY EC_KEY_get0_public_key dup
|
||||
|[ PUB |
|
||||
KEY EC_KEY_get0_group :> GROUP
|
||||
GROUP EC_GROUP_get_degree bits>bytes 1 + :> LEN
|
||||
LEN <byte-array> :> BIN
|
||||
KEY EC_KEY_get0_group set: GROUP
|
||||
GROUP EC_GROUP_get_degree bits>bytes 1 + set: LEN
|
||||
LEN <byte-array> set: BIN
|
||||
GROUP PUB POINT_CONVERSION_COMPRESSED BIN LEN f
|
||||
EC_POINT_point2oct ssl-error
|
||||
BIN
|
||||
] when ;
|
||||
|
||||
:: ecdsa-sign ( DGST -- sig )
|
||||
ec-key-handle :> KEY
|
||||
KEY ECDSA_size dup ssl-error <byte-array> :> SIG
|
||||
0 uint <ref> :> LEN
|
||||
ec-key-handle set: KEY
|
||||
KEY ECDSA_size dup ssl-error <byte-array> set: SIG
|
||||
0 uint <ref> set: LEN
|
||||
0 DGST dup length SIG LEN KEY ECDSA_sign ssl-error
|
||||
LEN uint deref SIG resize ;
|
||||
|
||||
|
|
|
|||
|
|
@ -25,7 +25,7 @@ PRIVATE<
|
|||
[ first2 rect> ] { } map-as ;
|
||||
|
||||
:: (fft1d) ( seq sign -- seq' )
|
||||
seq length :> n
|
||||
seq length set: n
|
||||
[
|
||||
n
|
||||
seq >fftw-array
|
||||
|
|
|
|||
|
|
@ -83,7 +83,7 @@ DESTRUCTOR: gdbm-close
|
|||
|
||||
:: (setopt) ( value option -- )
|
||||
[
|
||||
int heap-size dup malloc &free :> ( size ptr )
|
||||
int heap-size dup malloc &free set: ( size ptr )
|
||||
value ptr 0 int set-alien-value
|
||||
dbf option ptr size gdbm_setopt check-error
|
||||
] with-destructors ;
|
||||
|
|
|
|||
|
|
@ -37,7 +37,7 @@ PRIVATE<
|
|||
path exists?
|
||||
[ path ] [
|
||||
current-vocab-dirs custom-gir-dirs system-gir-dirs
|
||||
3append sift :> paths
|
||||
3append sift set: paths
|
||||
paths [ path append-path exists? ] find nip
|
||||
[ path append-path ] [ path paths gir-not-found ] if*
|
||||
] if ;
|
||||
|
|
|
|||
|
|
@ -8,21 +8,21 @@ IN: gtk-samples.hello-world
|
|||
nip "Hello! :)" utf8 string>alien gtk_label_set_text ;
|
||||
|
||||
:: hello-world-win ( -- window )
|
||||
GTK_WINDOW_TOPLEVEL gtk_window_new :> window
|
||||
GTK_WINDOW_TOPLEVEL gtk_window_new set: window
|
||||
|
||||
window
|
||||
[ "Hello world!" utf8 string>alien gtk_window_set_title ]
|
||||
[ 300 200 gtk_window_set_default_size ]
|
||||
[ GTK_WIN_POS_CENTER gtk_window_set_position ] tri
|
||||
|
||||
gtk_fixed_new :> frame
|
||||
gtk_fixed_new set: frame
|
||||
window frame gtk_container_add
|
||||
|
||||
"Say 'Hello!'" utf8 string>alien gtk_button_new_with_label :> button
|
||||
"Say 'Hello!'" utf8 string>alien gtk_button_new_with_label set: button
|
||||
button 140 30 gtk_widget_set_size_request
|
||||
frame button 80 60 gtk_fixed_put
|
||||
|
||||
"" utf8 string>alien gtk_label_new :> label
|
||||
"" utf8 string>alien gtk_label_new set: label
|
||||
frame label 120 110 gtk_fixed_put
|
||||
|
||||
button "clicked" utf8 string>alien
|
||||
|
|
@ -33,7 +33,7 @@ IN: gtk-samples.hello-world
|
|||
|
||||
:: hello-world-main ( -- )
|
||||
f f gtk_init
|
||||
hello-world-win :> window
|
||||
hello-world-win set: window
|
||||
|
||||
window "destroy" utf8 string>alien
|
||||
[ 2drop gtk_main_quit ] GtkObject:destroy f
|
||||
|
|
|
|||
|
|
@ -8,8 +8,8 @@ IN: gtk-samples.opengl
|
|||
! http://code.valaide.org/content/simple-opengl-sample-using-gtkglext
|
||||
|
||||
:: on-configure ( sender event user-data -- result )
|
||||
sender gtk_widget_get_gl_context :> gl-context
|
||||
sender gtk_widget_get_gl_window :> gl-drawable
|
||||
sender gtk_widget_get_gl_context set: gl-context
|
||||
sender gtk_widget_get_gl_window set: gl-drawable
|
||||
|
||||
gl-drawable gl-context gdk_gl_drawable_gl_begin dup
|
||||
[
|
||||
|
|
@ -18,8 +18,8 @@ IN: gtk-samples.opengl
|
|||
] when ;
|
||||
|
||||
:: on-expose ( sender event user-data -- result )
|
||||
sender gtk_widget_get_gl_context :> gl-context
|
||||
sender gtk_widget_get_gl_window :> gl-drawable
|
||||
sender gtk_widget_get_gl_context set: gl-context
|
||||
sender gtk_widget_get_gl_window set: gl-drawable
|
||||
|
||||
gl-drawable gl-context gdk_gl_drawable_gl_begin dup
|
||||
[
|
||||
|
|
@ -42,14 +42,14 @@ IN: gtk-samples.opengl
|
|||
] when ;
|
||||
|
||||
:: opengl-win ( -- window )
|
||||
GTK_WINDOW_TOPLEVEL gtk_window_new :> window
|
||||
GTK_WINDOW_TOPLEVEL gtk_window_new set: window
|
||||
|
||||
window
|
||||
[ "OpenGL" utf8 string>alien gtk_window_set_title ]
|
||||
[ 200 200 gtk_window_set_default_size ]
|
||||
[ GTK_WIN_POS_CENTER gtk_window_set_position ] tri
|
||||
|
||||
GDK_GL_MODE_RGBA gdk_gl_config_new_by_mode :> gl-config
|
||||
GDK_GL_MODE_RGBA gdk_gl_config_new_by_mode set: gl-config
|
||||
|
||||
window gl-config f t GDK_GL_RGBA_TYPE
|
||||
gtk_widget_set_gl_capability drop
|
||||
|
|
@ -67,7 +67,7 @@ IN: gtk-samples.opengl
|
|||
:: opengl-main ( -- )
|
||||
f f gtk_init
|
||||
f f gtk_gl_init
|
||||
opengl-win :> window
|
||||
opengl-win set: window
|
||||
|
||||
window "destroy" utf8 string>alien
|
||||
[ 2drop gtk_main_quit ] GtkObject:destroy
|
||||
|
|
|
|||
|
|
@ -943,7 +943,7 @@ TYPED: load-commands ( macho: mach_header_32/64 -- load-commands )
|
|||
|
||||
: macho-nm ( path -- )
|
||||
|[ macho |
|
||||
macho load-commands segment-commands sections-array :> sections
|
||||
macho load-commands segment-commands sections-array set: sections
|
||||
macho load-commands symtab-commands |[ symtab |
|
||||
macho symtab symbols [
|
||||
[ drop n_value>> "%016x " printf ]
|
||||
|
|
|
|||
|
|
@ -132,11 +132,11 @@ PRIVATE>
|
|||
|
||||
:: verify-nodes ( mdb -- )
|
||||
[
|
||||
V{ } clone :> acc
|
||||
mdb dup master-node [ check-node ] keep :> node1
|
||||
V{ } clone set: acc
|
||||
mdb dup master-node [ check-node ] keep set: node1
|
||||
mdb node1 remote>>
|
||||
[ [ check-node ] keep ]
|
||||
[ drop f ] if* :> node2
|
||||
[ drop f ] if* set: node2
|
||||
node1 [ acc push ] when*
|
||||
node2 [ acc push ] when*
|
||||
mdb acc nodelist>table >>nodes drop
|
||||
|
|
|
|||
|
|
@ -164,8 +164,8 @@ PRIVATE<
|
|||
|
||||
: check-collection ( collection -- fq-collection )
|
||||
let[
|
||||
mdb-instance :> instance
|
||||
instance name>> :> instance-name
|
||||
mdb-instance set: instance
|
||||
instance name>> set: instance-name
|
||||
dup mdb-collection? [ name>> ] when
|
||||
"." split1 over instance-name =
|
||||
[ nip ] [ drop ] if
|
||||
|
|
|
|||
|
|
@ -88,7 +88,7 @@ PRIVATE<
|
|||
] with-output-stream* write flush ; inline
|
||||
|
||||
:: build-query-object ( query -- selector )
|
||||
H{ } clone :> selector
|
||||
H{ } clone set: selector
|
||||
query {
|
||||
[ orderby>> [ "$orderby" selector set-at ] when* ]
|
||||
[ explain>> [ "$explain" selector set-at ] when* ]
|
||||
|
|
|
|||
|
|
@ -24,16 +24,16 @@ ERROR: cl-error err ;
|
|||
dup CL_SUCCESS = [ drop ] [ cl-error ] if ;
|
||||
|
||||
:: cl-string-array ( str -- alien )
|
||||
str ascii encode 0 suffix :> str-buffer
|
||||
str-buffer length malloc &free :> str-alien
|
||||
str ascii encode 0 suffix set: str-buffer
|
||||
str-buffer length malloc &free set: str-alien
|
||||
str-alien str-buffer dup length memcpy str-alien ;
|
||||
|
||||
:: opencl-square ( in -- out )
|
||||
0 f 0 uint <ref> [ clGetPlatformIDs cl-success ] keep uint deref
|
||||
dup void* <c-array> [ f clGetPlatformIDs cl-success ] keep first
|
||||
CL_DEVICE_TYPE_DEFAULT 1 f void* <ref> [ f clGetDeviceIDs cl-success ] keep void* deref :> device-id
|
||||
f 1 device-id void* <ref> f f 0 int <ref> [ clCreateContext ] keep int deref cl-success :> context
|
||||
context device-id 0 0 int <ref> [ clCreateCommandQueue ] keep int deref cl-success :> queue
|
||||
CL_DEVICE_TYPE_DEFAULT 1 f void* <ref> [ f clGetDeviceIDs cl-success ] keep void* deref set: device-id
|
||||
f 1 device-id void* <ref> f f 0 int <ref> [ clCreateContext ] keep int deref cl-success set: context
|
||||
context device-id 0 0 int <ref> [ clCreateCommandQueue ] keep int deref cl-success set: queue
|
||||
|
||||
[
|
||||
context 1 kernel-source cl-string-array void* <ref>
|
||||
|
|
@ -41,13 +41,13 @@ ERROR: cl-error err ;
|
|||
[ 0 f f f f clBuildProgram cl-success ]
|
||||
[ "square" cl-string-array 0 int <ref> [ clCreateKernel ] keep int deref cl-success ]
|
||||
[ ] tri
|
||||
] with-destructors :> ( kernel program )
|
||||
] with-destructors set: ( kernel program )
|
||||
|
||||
context CL_MEM_READ_ONLY in byte-length f
|
||||
0 int <ref> [ clCreateBuffer ] keep int deref cl-success :> input
|
||||
0 int <ref> [ clCreateBuffer ] keep int deref cl-success set: input
|
||||
|
||||
context CL_MEM_WRITE_ONLY in byte-length f
|
||||
0 int <ref> [ clCreateBuffer ] keep int deref cl-success :> output
|
||||
0 int <ref> [ clCreateBuffer ] keep int deref cl-success set: output
|
||||
|
||||
queue input CL_TRUE 0 in byte-length in 0 f f clEnqueueWriteBuffer cl-success
|
||||
|
||||
|
|
|
|||
|
|
@ -21,16 +21,16 @@ __kernel void square(
|
|||
|
||||
:: opencl-square ( in -- out )
|
||||
[
|
||||
in byte-length :> num-bytes
|
||||
in length :> num-floats
|
||||
cl-platforms first devices>> first :> device
|
||||
device 1array <cl-context> &dispose :> context
|
||||
context device f f <cl-queue> &dispose :> queue
|
||||
in byte-length set: num-bytes
|
||||
in length set: num-floats
|
||||
cl-platforms first devices>> first set: device
|
||||
device 1array <cl-context> &dispose set: context
|
||||
context device f f <cl-queue> &dispose set: queue
|
||||
|
||||
context device queue [
|
||||
"" kernel-source 1array <cl-program> &dispose "square" <cl-kernel> &dispose :> kernel
|
||||
cl-read-access num-bytes in <cl-buffer> &dispose :> in-buffer
|
||||
cl-write-access num-bytes f <cl-buffer> &dispose :> out-buffer
|
||||
"" kernel-source 1array <cl-program> &dispose "square" <cl-kernel> &dispose set: kernel
|
||||
cl-read-access num-bytes in <cl-buffer> &dispose set: in-buffer
|
||||
cl-write-access num-bytes f <cl-buffer> &dispose set: out-buffer
|
||||
|
||||
kernel in-buffer out-buffer num-floats uint <ref> 3array
|
||||
{ num-floats } [ ] cl-queue-kernel &dispose drop
|
||||
|
|
|
|||
|
|
@ -119,8 +119,8 @@ MACRO: all-enabled-client-state ( seq quot -- quot )
|
|||
! We use GL_LINE_STRIP with a duplicated first vertex
|
||||
! instead of GL_LINE_LOOP to work around a bug in Apple's
|
||||
! X3100 driver.
|
||||
loc first2 [ 0.3 + ] bi@ :> ( x y )
|
||||
dim first2 [ 0.6 - ] bi@ :> ( w h )
|
||||
loc first2 [ 0.3 + ] bi@ set: ( x y )
|
||||
dim first2 [ 0.6 - ] bi@ set: ( w h )
|
||||
[
|
||||
x y
|
||||
x w + y
|
||||
|
|
@ -139,8 +139,8 @@ MACRO: all-enabled-client-state ( seq quot -- quot )
|
|||
rect-vertices (gl-rect) ;
|
||||
|
||||
:: (fill-rect-vertices) ( loc dim -- vertices )
|
||||
loc first2 :> ( x y )
|
||||
dim first2 :> ( w h )
|
||||
loc first2 set: ( x y )
|
||||
dim first2 set: ( w h )
|
||||
[
|
||||
x y
|
||||
x w + y
|
||||
|
|
|
|||
|
|
@ -282,7 +282,7 @@ TUPLE: single-texture < disposable image dim loc texture-coords texture display-
|
|||
] unless ;
|
||||
|
||||
:: tex-image ( image bitmap -- )
|
||||
image image-format :> ( internal-format format type )
|
||||
image image-format set: ( internal-format format type )
|
||||
GL_TEXTURE_2D 0 internal-format
|
||||
image dim>> adjust-texture-dim first2 0
|
||||
format type bitmap glTexImage2D ;
|
||||
|
|
|
|||
|
|
@ -41,7 +41,7 @@ SYMBOL: current-context
|
|||
[ py-import ] dip getattr ;
|
||||
|
||||
:: add-function ( name effect module prefix? -- )
|
||||
module name prefix? make-factor-words :> ( call-word obj-word )
|
||||
module name prefix? make-factor-words set: ( call-word obj-word )
|
||||
obj-word module name $[ _ _ import-getattr ] ( -- o ) define-inline
|
||||
call-word obj-word def>> effect make-function-quot effect define-inline ;
|
||||
|
||||
|
|
|
|||
|
|
@ -16,10 +16,10 @@ ERROR: unix-system-call-error args errno message word ;
|
|||
} 1|| ;
|
||||
|
||||
MACRO:: unix-system-call ( quot -- quot )
|
||||
quot inputs :> n
|
||||
quot first :> word
|
||||
0 :> ret!
|
||||
f :> failed!
|
||||
quot inputs set: n
|
||||
quot first set: word
|
||||
0 set: ret!
|
||||
f set: failed!
|
||||
[
|
||||
[
|
||||
n ndup quot call ret!
|
||||
|
|
@ -39,9 +39,9 @@ MACRO:: unix-system-call ( quot -- quot )
|
|||
] ;
|
||||
|
||||
MACRO:: unix-system-call-allow-eintr ( quot -- quot )
|
||||
quot inputs :> n
|
||||
quot first :> word
|
||||
0 :> ret!
|
||||
quot inputs set: n
|
||||
quot first set: word
|
||||
0 set: ret!
|
||||
[
|
||||
n ndup quot call ret!
|
||||
ret unix-call-failed? [
|
||||
|
|
|
|||
|
|
@ -24,7 +24,7 @@ CONSTANT: registry-value-max-length 16384 ;
|
|||
] keep HKEY deref ;
|
||||
|
||||
:: create-key* ( hKey lpSubKey lpClass dwOptions samDesired lpSecurityAttributes -- hkey new? )
|
||||
f :> ret!
|
||||
f set: ret!
|
||||
hKey lpSubKey 0 lpClass dwOptions samDesired lpSecurityAttributes
|
||||
0 HKEY <ref>
|
||||
0 DWORD <ref>
|
||||
|
|
@ -50,13 +50,13 @@ CONSTANT: registry-value-max-length 16384 ;
|
|||
] if ;
|
||||
|
||||
:: with-open-registry-key ( key subkey mode quot -- )
|
||||
key subkey mode open-key :> hkey
|
||||
key subkey mode open-key set: hkey
|
||||
[ hkey quot call ]
|
||||
[ hkey close-key ]
|
||||
[ ] cleanup ; inline
|
||||
|
||||
:: with-create-registry-key ( key subkey quot -- )
|
||||
key subkey create-key :> hkey
|
||||
key subkey create-key set: hkey
|
||||
[ hkey quot call ]
|
||||
[ hkey close-key ]
|
||||
[ ] cleanup ; inline
|
||||
|
|
@ -67,9 +67,9 @@ PRIVATE<
|
|||
length 2 * <byte-array> ;
|
||||
|
||||
:: reg-query-value-ex ( key subkey ptr1 ptr2 buffer -- buffer )
|
||||
buffer length uint <ref> :> pdword
|
||||
buffer length uint <ref> set: pdword
|
||||
key subkey ptr1 ptr2 buffer pdword [ RegQueryValueEx ] 2keep
|
||||
rot :> ret
|
||||
rot set: ret
|
||||
ret ERROR_SUCCESS = [
|
||||
uint deref head
|
||||
] [
|
||||
|
|
@ -100,12 +100,12 @@ TUPLE: registry-enum-key ;
|
|||
:: reg-enum-keys ( registry-info -- seq )
|
||||
registry-info sub-keys>> iota [
|
||||
[ registry-info key>> ] dip
|
||||
registry-value-max-length TCHAR <c-array> dup :> registry-value
|
||||
registry-value length dup :> registry-value-length
|
||||
registry-value-max-length TCHAR <c-array> dup set: registry-value
|
||||
registry-value length dup set: registry-value-length
|
||||
f
|
||||
0 DWORD <ref> dup :> type
|
||||
f ! 0 BYTE <ref> dup :> data
|
||||
f ! 0 BYTE <ref> dup :> buffer
|
||||
0 DWORD <ref> dup set: type
|
||||
f ! 0 BYTE <ref> dup set: data
|
||||
f ! 0 BYTE <ref> dup set: buffer
|
||||
RegEnumKeyEx dup ERROR_SUCCESS = [
|
||||
|
||||
] [
|
||||
|
|
@ -115,18 +115,18 @@ TUPLE: registry-enum-key ;
|
|||
:: reg-query-info-key ( key -- n )
|
||||
key
|
||||
MAX_PATH
|
||||
dup TCHAR <c-array> dup :> class-buffer
|
||||
swap int <ref> dup :> class-buffer-length
|
||||
dup TCHAR <c-array> dup set: class-buffer
|
||||
swap int <ref> dup set: class-buffer-length
|
||||
f
|
||||
0 DWORD <ref> dup :> sub-keys
|
||||
0 DWORD <ref> dup :> longest-subkey
|
||||
0 DWORD <ref> dup :> longest-class-string
|
||||
0 DWORD <ref> dup :> #values
|
||||
0 DWORD <ref> dup :> max-value
|
||||
0 DWORD <ref> dup :> max-value-data
|
||||
0 DWORD <ref> dup :> security-descriptor
|
||||
FILETIME <struct> dup :> last-write-time
|
||||
RegQueryInfoKey :> ret
|
||||
0 DWORD <ref> dup set: sub-keys
|
||||
0 DWORD <ref> dup set: longest-subkey
|
||||
0 DWORD <ref> dup set: longest-class-string
|
||||
0 DWORD <ref> dup set: #values
|
||||
0 DWORD <ref> dup set: max-value
|
||||
0 DWORD <ref> dup set: max-value-data
|
||||
0 DWORD <ref> dup set: security-descriptor
|
||||
FILETIME <struct> dup set: last-write-time
|
||||
RegQueryInfoKey set: ret
|
||||
ret ERROR_SUCCESS = [
|
||||
key
|
||||
class-buffer
|
||||
|
|
|
|||
|
|
@ -14,8 +14,8 @@ PRIVATE<
|
|||
|
||||
:: IStream-read ( stream pv cb out-read -- hresult )
|
||||
[
|
||||
cb stream stream-read :> buf
|
||||
buf length :> bytes
|
||||
cb stream stream-read set: buf
|
||||
buf length set: bytes
|
||||
pv buf bytes memcpy
|
||||
out-read [ bytes out-read 0 ULONG set-alien-value ] when
|
||||
|
||||
|
|
@ -50,8 +50,8 @@ PRIVATE<
|
|||
|
||||
:: IStream-copy-to ( stream other-stream cb out-read out-written -- hresult )
|
||||
[
|
||||
cb stream stream-read :> buf
|
||||
buf length :> bytes
|
||||
cb stream stream-read set: buf
|
||||
buf length set: bytes
|
||||
out-read [ bytes out-read 0 ULONG set-alien-value ] when
|
||||
|
||||
other-stream buf bytes out-written IStream::Write
|
||||
|
|
@ -70,9 +70,9 @@ PRIVATE<
|
|||
STG_E_INVALIDFUNCTION ;
|
||||
|
||||
:: stream-size ( stream -- size )
|
||||
stream stream-tell :> old-pos
|
||||
stream stream-tell set: old-pos
|
||||
0 seek-end stream stream-seek
|
||||
stream stream-tell :> size
|
||||
stream stream-tell set: size
|
||||
old-pos seek-absolute stream stream-seek
|
||||
size ;
|
||||
|
||||
|
|
|
|||
|
|
@ -68,7 +68,7 @@ CONSTANT: ssa-dwFlags flags{ SSA_GLYPHS SSA_FALLBACK SSA_TAB } ;
|
|||
ScriptStringOut check-ole32-error ;
|
||||
|
||||
:: render-image ( dc ssa script-string -- image )
|
||||
script-string size>> :> size
|
||||
script-string size>> set: size
|
||||
size dc
|
||||
[ ssa size script-string draw-script-string ] make-bitmap-image ;
|
||||
|
||||
|
|
|
|||
|
|
@ -19,17 +19,17 @@ PRIVATE<
|
|||
PRIVATE>
|
||||
|
||||
:: XISetMask ( mask event -- )
|
||||
event mask-index :> index
|
||||
event mask-index set: index
|
||||
event bitmask index mask nth bitor
|
||||
index mask set-nth ; inline
|
||||
|
||||
:: XIClearMask ( mask event -- )
|
||||
event mask-index :> index
|
||||
event mask-index set: index
|
||||
event bitmask bitnot index mask nth bitand
|
||||
index mask set-nth ; inline
|
||||
|
||||
:: XIMaskIsSet ( mask event -- n )
|
||||
event mask-index :> index
|
||||
event mask-index set: index
|
||||
event bitmask index mask nth bitand ;
|
||||
|
||||
: XIMaskLen ( event -- n ) 7 + -3 shift ;
|
||||
|
|
|
|||
|
|
@ -83,8 +83,8 @@ M: literal-bind sqlite-bind-conversion ( tuple literal-bind -- array )
|
|||
<sqlite-low-level-binding> ;
|
||||
|
||||
M:: generator-bind sqlite-bind-conversion ( tuple generate-bind -- array )
|
||||
generate-bind generator-singleton>> eval-generator :> obj
|
||||
generate-bind slot-name>> :> name
|
||||
generate-bind generator-singleton>> eval-generator set: obj
|
||||
generate-bind slot-name>> set: name
|
||||
obj name tuple set-slot-named
|
||||
generate-bind key>> obj generate-bind type>> <sqlite-low-level-binding> ;
|
||||
|
||||
|
|
|
|||
|
|
@ -23,7 +23,7 @@ GENERIC: new-user ( user provider -- user/f ) ;
|
|||
! Password recovery support
|
||||
|
||||
:: issue-ticket ( email username provider -- user/f )
|
||||
username provider get-user :> user
|
||||
username provider get-user set: user
|
||||
user [
|
||||
user email>> length 0 > [
|
||||
user email>> email = [
|
||||
|
|
@ -35,7 +35,7 @@ GENERIC: new-user ( user provider -- user/f ) ;
|
|||
] [ f ] if ;
|
||||
|
||||
:: claim-ticket ( ticket username provider -- user/f )
|
||||
username provider get-user :> user
|
||||
username provider get-user set: user
|
||||
user [
|
||||
user ticket>> ticket = [
|
||||
user f >>ticket dup provider update-user
|
||||
|
|
|
|||
|
|
@ -50,8 +50,8 @@ PRIVATE<
|
|||
"\n" split first2 [ "true" = ] dip ;
|
||||
|
||||
:: (validate-recaptcha) ( challenge response recaptcha -- valid? error )
|
||||
recaptcha private-key>> :> private-key
|
||||
remote-address get host>> :> remote-ip
|
||||
recaptcha private-key>> set: private-key
|
||||
remote-address get host>> set: remote-ip
|
||||
H{
|
||||
{ "challenge" challenge }
|
||||
{ "response" response }
|
||||
|
|
|
|||
|
|
@ -105,7 +105,7 @@ CONSTANT: debug-text-texture-parameters
|
|||
:: screen-quad ( image pt dim -- float-array )
|
||||
pt dim v/ 2.0 v*n 1.0 v-n
|
||||
dup image dim>> dim v/ 2.0 v*n v+
|
||||
[ first2 ] bi@ :> ( x0 y0 x1 y1 )
|
||||
[ first2 ] bi@ set: ( x0 y0 x1 y1 )
|
||||
image upside-down?>>
|
||||
[ { x0 y0 0 0 x1 y0 1 0 x1 y1 1 1 x0 y1 0 1 } ]
|
||||
[ { x0 y0 0 1 x1 y0 1 1 x1 y1 1 0 x0 y1 0 0 } ]
|
||||
|
|
|
|||
|
|
@ -17,7 +17,7 @@ IN: game.debug.tests
|
|||
180 / pi * ;
|
||||
|
||||
:: draw-debug-tests ( world -- )
|
||||
world [ wasd-p-matrix ] [ wasd-mv-matrix ] bi m. :> mvp-matrix
|
||||
world [ wasd-p-matrix ] [ wasd-mv-matrix ] bi m. set: mvp-matrix
|
||||
{ 0 0 0 } clear-screen
|
||||
|
||||
[
|
||||
|
|
|
|||
|
|
@ -51,7 +51,7 @@ CONSTANT: pov-polygons
|
|||
[ (xy>loc) ] dip (z>loc) ;
|
||||
|
||||
:: move-axis ( gadget x y z -- )
|
||||
x y z (xyz>loc) :> ( xy z )
|
||||
x y z (xyz>loc) set: ( xy z )
|
||||
xy gadget indicator>> loc<<
|
||||
z gadget z-indicator>> loc<< ;
|
||||
|
||||
|
|
|
|||
|
|
@ -281,7 +281,7 @@ M: iokit-game-input-backend reset-mouse
|
|||
} cond ;
|
||||
|
||||
:: (device-input-callback) ( context result sender value -- )
|
||||
sender get-input-device :> device
|
||||
sender get-input-device set: device
|
||||
{
|
||||
{ [ device mouse-device? ] [ +mouse-state+ get-global value record-mouse ] }
|
||||
{ [ device controller-device? ] [
|
||||
|
|
|
|||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue