Merge branch 'master' of git://factorcode.org/git/factor
Doug Coleman
commit
17f0a5d41a
|
|
@ -330,7 +330,7 @@ M: character-type (<fortran-result>)
|
|||
] if-empty ;
|
||||
|
||||
:: [fortran-invoke] ( [args>args] return library function parameters -- [args>args] quot )
|
||||
return parameters fortran-sig>c-sig :> c-parameters :> c-return
|
||||
return parameters fortran-sig>c-sig :> ( c-return c-parameters )
|
||||
function fortran-name>symbol-name :> c-function
|
||||
[args>args]
|
||||
c-return library c-function c-parameters \ alien-invoke
|
||||
|
|
|
|||
|
|
@ -98,7 +98,7 @@ IN: alien.parser
|
|||
type-name current-vocab create :> type-word
|
||||
type-word [ reset-generic ] [ reset-c-type ] bi
|
||||
void* type-word typedef
|
||||
parameters return parse-arglist :> callback-effect :> types
|
||||
parameters return parse-arglist :> ( types callback-effect )
|
||||
type-word callback-effect "callback-effect" set-word-prop
|
||||
type-word lib "callback-library" set-word-prop
|
||||
type-word return types lib library-abi callback-quot (( quot -- alien )) ;
|
||||
|
|
|
|||
|
|
@ -113,7 +113,7 @@ PRIVATE>
|
|||
M:: lsb0-bit-writer poke ( value n bs -- )
|
||||
value n <widthed> :> widthed
|
||||
widthed
|
||||
bs widthed>> #bits>> 8 swap - split-widthed :> remainder :> byte
|
||||
bs widthed>> #bits>> 8 swap - split-widthed :> ( byte remainder )
|
||||
byte bs widthed>> |widthed :> new-byte
|
||||
new-byte #bits>> 8 = [
|
||||
new-byte bits>> bs bytes>> push
|
||||
|
|
@ -143,7 +143,7 @@ ERROR: not-enough-bits n bit-reader ;
|
|||
neg shift n bits ;
|
||||
|
||||
:: adjust-bits ( n bs -- )
|
||||
n 8 /mod :> #bits :> #bytes
|
||||
n 8 /mod :> ( #bytes #bits )
|
||||
bs [ #bytes + ] change-byte-pos
|
||||
bit-pos>> #bits + dup 8 >= [
|
||||
8 - bs (>>bit-pos)
|
||||
|
|
|
|||
|
|
@ -119,16 +119,16 @@ GENERIC: easter ( obj -- obj' )
|
|||
|
||||
:: easter-month-day ( year -- month day )
|
||||
year 19 mod :> a
|
||||
year 100 /mod :> c :> b
|
||||
b 4 /mod :> e :> d
|
||||
year 100 /mod :> ( b c )
|
||||
b 4 /mod :> ( d e )
|
||||
b 8 + 25 /i :> f
|
||||
b f - 1 + 3 /i :> g
|
||||
19 a * b + d - g - 15 + 30 mod :> h
|
||||
c 4 /mod :> k :> i
|
||||
c 4 /mod :> ( i k )
|
||||
32 2 e * + 2 i * + h - k - 7 mod :> l
|
||||
a 11 h * + 22 l * + 451 /i :> m
|
||||
|
||||
h l + 7 m * - 114 + 31 /mod 1 + :> day :> month
|
||||
h l + 7 m * - 114 + 31 /mod 1 + :> ( month day )
|
||||
month day ;
|
||||
|
||||
M: integer easter ( year -- timestamp )
|
||||
|
|
|
|||
|
|
@ -25,12 +25,11 @@ IN: channels.examples
|
|||
] 3keep filter ;
|
||||
|
||||
:: (sieve) ( prime c -- )
|
||||
[let | p [ c from ]
|
||||
newc [ <channel> ] |
|
||||
c from :> p
|
||||
<channel> :> newc
|
||||
p prime to
|
||||
[ newc p c filter ] "Filter" spawn drop
|
||||
prime newc (sieve)
|
||||
] ;
|
||||
prime newc (sieve) ;
|
||||
|
||||
: sieve ( prime -- )
|
||||
#! Send prime numbers to 'prime' channel
|
||||
|
|
|
|||
|
|
@ -24,7 +24,7 @@ PRIVATE>
|
|||
|
||||
:: hmac-stream ( stream key checksum -- value )
|
||||
checksum initialize-checksum-state :> checksum-state
|
||||
checksum key checksum-state init-key :> Ki :> Ko
|
||||
checksum key checksum-state init-key :> ( Ko Ki )
|
||||
checksum-state Ki add-checksum-bytes
|
||||
stream add-checksum-stream get-checksum
|
||||
checksum initialize-checksum-state
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@ IN: classes.struct.bit-accessors
|
|||
[ 2^ 1 - ] bi@ swap bitnot bitand ;
|
||||
|
||||
:: manipulate-bits ( offset bits step-quot -- quot shift-amount offset' bits' )
|
||||
offset 8 /mod :> start-bit :> i
|
||||
offset 8 /mod :> ( i start-bit )
|
||||
start-bit bits + 8 min :> end-bit
|
||||
start-bit end-bit ones-between :> mask
|
||||
end-bit start-bit - :> used-bits
|
||||
|
|
|
|||
|
|
@ -22,12 +22,10 @@ IN: compiler.cfg.intrinsics.alien
|
|||
] [ emit-primitive ] if ;
|
||||
|
||||
:: inline-alien ( node quot test -- )
|
||||
[let | infos [ node node-input-infos ] |
|
||||
node node-input-infos :> infos
|
||||
infos test call
|
||||
[ infos quot call ]
|
||||
[ node emit-primitive ]
|
||||
if
|
||||
] ; inline
|
||||
[ node emit-primitive ] if ; inline
|
||||
|
||||
: inline-alien-getter? ( infos -- ? )
|
||||
[ first class>> c-ptr class<= ]
|
||||
|
|
|
|||
|
|
@ -43,17 +43,15 @@ IN: compiler.cfg.intrinsics.allot
|
|||
2 + cells array ^^allot ;
|
||||
|
||||
:: emit-<array> ( node -- )
|
||||
[let | len [ node node-input-infos first literal>> ] |
|
||||
node node-input-infos first literal>> :> len
|
||||
len expand-<array>? [
|
||||
[let | elt [ ds-pop ]
|
||||
reg [ len ^^allot-array ] |
|
||||
ds-pop :> elt
|
||||
len ^^allot-array :> reg
|
||||
ds-drop
|
||||
len reg array store-length
|
||||
len reg elt array store-initial-element
|
||||
reg ds-push
|
||||
]
|
||||
] [ node emit-primitive ] if
|
||||
] ;
|
||||
] [ node emit-primitive ] if ;
|
||||
|
||||
: expand-(byte-array)? ( obj -- ? )
|
||||
dup integer? [ 0 1024 between? ] [ drop f ] if ;
|
||||
|
|
|
|||
|
|
@ -156,18 +156,18 @@ MACRO: if-literals-match ( quots -- )
|
|||
[ [ ^^fill-vector ] [ ^^xor-vector ] bi ] if ;
|
||||
|
||||
:: ((generate-compare-vector)) ( src1 src2 rep {cc,swap} -- dst )
|
||||
{cc,swap} first2 :> swap? :> cc
|
||||
{cc,swap} first2 :> ( cc swap? )
|
||||
swap?
|
||||
[ src2 src1 rep cc ^^compare-vector ]
|
||||
[ src1 src2 rep cc ^^compare-vector ] if ;
|
||||
|
||||
:: (generate-compare-vector) ( src1 src2 rep orig-cc -- dst )
|
||||
rep orig-cc %compare-vector-ccs :> not? :> ccs
|
||||
rep orig-cc %compare-vector-ccs :> ( ccs not? )
|
||||
|
||||
ccs empty?
|
||||
[ rep not? [ ^^fill-vector ] [ ^^zero-vector ] if ]
|
||||
[
|
||||
ccs unclip :> first-cc :> rest-ccs
|
||||
ccs unclip :> ( rest-ccs first-cc )
|
||||
src1 src2 rep first-cc ((generate-compare-vector)) :> first-dst
|
||||
|
||||
rest-ccs first-dst
|
||||
|
|
|
|||
|
|
@ -42,7 +42,7 @@ IN: compiler.cfg.intrinsics.slots
|
|||
first class>> immediate class<= not ;
|
||||
|
||||
:: (emit-set-slot) ( infos -- )
|
||||
3inputs :> slot :> obj :> src
|
||||
3inputs :> ( src obj slot )
|
||||
|
||||
slot infos second value-tag ^^tag-offset>slot :> slot
|
||||
|
||||
|
|
@ -54,7 +54,7 @@ IN: compiler.cfg.intrinsics.slots
|
|||
:: (emit-set-slot-imm) ( infos -- )
|
||||
ds-drop
|
||||
|
||||
2inputs :> obj :> src
|
||||
2inputs :> ( src obj )
|
||||
|
||||
infos third literal>> :> slot
|
||||
infos second value-tag :> tag
|
||||
|
|
|
|||
|
|
@ -121,10 +121,9 @@ PRIVATE>
|
|||
PRIVATE>
|
||||
|
||||
:: live-out? ( vreg node -- ? )
|
||||
[let | def [ vreg def-of ] |
|
||||
vreg def-of :> def
|
||||
{
|
||||
{ [ node def eq? ] [ vreg uses-of def only? not ] }
|
||||
{ [ def node strictly-dominates? ] [ vreg node (live-out?) ] }
|
||||
[ f ]
|
||||
} cond
|
||||
] ;
|
||||
} cond ;
|
||||
|
|
|
|||
|
|
@ -39,14 +39,13 @@ M: #enter-recursive remove-dead-code*
|
|||
2bi ;
|
||||
|
||||
:: (drop-call-recursive-outputs) ( inputs outputs -- #shuffle )
|
||||
[let* | new-live-outputs [ inputs outputs filter-corresponding make-values ]
|
||||
live-outputs [ outputs filter-live ] |
|
||||
inputs outputs filter-corresponding make-values :> new-live-outputs
|
||||
outputs filter-live :> live-outputs
|
||||
new-live-outputs
|
||||
live-outputs
|
||||
live-outputs
|
||||
new-live-outputs
|
||||
drop-values
|
||||
] ;
|
||||
drop-values ;
|
||||
|
||||
: drop-call-recursive-outputs ( node -- #shuffle )
|
||||
dup [ label>> return>> in-d>> ] [ out-d>> ] bi
|
||||
|
|
@ -60,22 +59,20 @@ M: #call-recursive remove-dead-code*
|
|||
tri 3array ;
|
||||
|
||||
:: drop-recursive-inputs ( node -- shuffle )
|
||||
[let* | shuffle [ node [ in-d>> ] [ label>> enter-out>> ] bi drop-dead-inputs ]
|
||||
new-outputs [ shuffle out-d>> ] |
|
||||
node [ in-d>> ] [ label>> enter-out>> ] bi drop-dead-inputs :> shuffle
|
||||
shuffle out-d>> :> new-outputs
|
||||
node new-outputs
|
||||
[ [ label>> enter-recursive>> ] dip >>in-d drop ] [ >>in-d drop ] 2bi
|
||||
shuffle
|
||||
] ;
|
||||
shuffle ;
|
||||
|
||||
:: drop-recursive-outputs ( node -- shuffle )
|
||||
[let* | return [ node label>> return>> ]
|
||||
new-inputs [ return in-d>> filter-live ]
|
||||
new-outputs [ return [ in-d>> ] [ out-d>> ] bi filter-corresponding ] |
|
||||
node label>> return>> :> return
|
||||
return in-d>> filter-live :> new-inputs
|
||||
return [ in-d>> ] [ out-d>> ] bi filter-corresponding :> new-outputs
|
||||
return
|
||||
[ new-inputs >>in-d new-outputs >>out-d drop ]
|
||||
[ drop-dead-outputs ]
|
||||
bi
|
||||
] ;
|
||||
bi ;
|
||||
|
||||
M: #recursive remove-dead-code* ( node -- nodes )
|
||||
[ drop-recursive-inputs ]
|
||||
|
|
|
|||
|
|
@ -71,14 +71,13 @@ M: #alien-indirect compute-live-values* nip look-at-inputs ;
|
|||
filter-corresponding zip #data-shuffle ; inline
|
||||
|
||||
:: drop-dead-values ( outputs -- #shuffle )
|
||||
[let* | new-outputs [ outputs make-values ]
|
||||
live-outputs [ outputs filter-live ] |
|
||||
outputs make-values :> new-outputs
|
||||
outputs filter-live :> live-outputs
|
||||
new-outputs
|
||||
live-outputs
|
||||
outputs
|
||||
new-outputs
|
||||
drop-values
|
||||
] ;
|
||||
drop-values ;
|
||||
|
||||
: drop-dead-outputs ( node -- #shuffle )
|
||||
dup out-d>> drop-dead-values [ in-d>> >>out-d drop ] keep ;
|
||||
|
|
|
|||
|
|
@ -159,12 +159,11 @@ IN: compiler.tree.propagation.known-words
|
|||
\ bitxor [ [ interval-bitxor ] [ integer-valued ] binary-op ] each-derived-op
|
||||
|
||||
:: (comparison-constraints) ( in1 in2 op -- constraint )
|
||||
[let | i1 [ in1 value-info interval>> ]
|
||||
i2 [ in2 value-info interval>> ] |
|
||||
in1 value-info interval>> :> i1
|
||||
in2 value-info interval>> :> i2
|
||||
in1 i1 i2 op assumption is-in-interval
|
||||
in2 i2 i1 op swap-comparison assumption is-in-interval
|
||||
/\
|
||||
] ;
|
||||
/\ ;
|
||||
|
||||
:: comparison-constraints ( in1 in2 out op -- constraint )
|
||||
in1 in2 op (comparison-constraints) out t-->
|
||||
|
|
|
|||
|
|
@ -36,13 +36,11 @@ yield-hook [ [ ] ] initialize
|
|||
: penultimate ( seq -- elt ) [ length 2 - ] keep nth ;
|
||||
|
||||
:: compress-path ( source assoc -- destination )
|
||||
[let | destination [ source assoc at ] |
|
||||
source assoc at :> destination
|
||||
source destination = [ source ] [
|
||||
[let | destination' [ destination assoc compress-path ] |
|
||||
destination assoc compress-path :> destination'
|
||||
destination' destination = [
|
||||
destination' source assoc set-at
|
||||
] unless
|
||||
destination'
|
||||
]
|
||||
] if
|
||||
] ;
|
||||
] if ;
|
||||
|
|
|
|||
|
|
@ -5,12 +5,11 @@ FROM: sequences => 3append ;
|
|||
IN: concurrency.exchangers.tests
|
||||
|
||||
:: exchanger-test ( -- string )
|
||||
[let |
|
||||
ex [ <exchanger> ]
|
||||
c [ 2 <count-down> ]
|
||||
v1! [ f ]
|
||||
v2! [ f ]
|
||||
pr [ <promise> ] |
|
||||
<exchanger> :> ex
|
||||
2 <count-down> :> c
|
||||
f :> v1!
|
||||
f :> v2!
|
||||
<promise> :> pr
|
||||
|
||||
[
|
||||
c await
|
||||
|
|
@ -25,7 +24,6 @@ IN: concurrency.exchangers.tests
|
|||
"Hello world" ex exchange v2! c count-down
|
||||
] "Exchanger 2" spawn drop
|
||||
|
||||
pr ?promise
|
||||
] ;
|
||||
pr ?promise ;
|
||||
|
||||
[ "Hello world, Goodbye world" ] [ exchanger-test ] unit-test
|
||||
|
|
|
|||
|
|
@ -3,46 +3,41 @@ kernel threads locals accessors calendar ;
|
|||
IN: concurrency.flags.tests
|
||||
|
||||
:: flag-test-1 ( -- val )
|
||||
[let | f [ <flag> ] |
|
||||
<flag> :> f
|
||||
[ f raise-flag ] "Flag test" spawn drop
|
||||
f lower-flag
|
||||
f value>>
|
||||
] ;
|
||||
f value>> ;
|
||||
|
||||
[ f ] [ flag-test-1 ] unit-test
|
||||
|
||||
:: flag-test-2 ( -- ? )
|
||||
[let | f [ <flag> ] |
|
||||
<flag> :> f
|
||||
[ 1 seconds sleep f raise-flag ] "Flag test" spawn drop
|
||||
f lower-flag
|
||||
f value>>
|
||||
] ;
|
||||
f value>> ;
|
||||
|
||||
[ f ] [ flag-test-2 ] unit-test
|
||||
|
||||
:: flag-test-3 ( -- val )
|
||||
[let | f [ <flag> ] |
|
||||
<flag> :> f
|
||||
f raise-flag
|
||||
f value>>
|
||||
] ;
|
||||
f value>> ;
|
||||
|
||||
[ t ] [ flag-test-3 ] unit-test
|
||||
|
||||
:: flag-test-4 ( -- val )
|
||||
[let | f [ <flag> ] |
|
||||
<flag> :> f
|
||||
[ f raise-flag ] "Flag test" spawn drop
|
||||
f wait-for-flag
|
||||
f value>>
|
||||
] ;
|
||||
f value>> ;
|
||||
|
||||
[ t ] [ flag-test-4 ] unit-test
|
||||
|
||||
:: flag-test-5 ( -- val )
|
||||
[let | f [ <flag> ] |
|
||||
<flag> :> f
|
||||
[ 1 seconds sleep f raise-flag ] "Flag test" spawn drop
|
||||
f wait-for-flag
|
||||
f value>>
|
||||
] ;
|
||||
f value>> ;
|
||||
|
||||
[ t ] [ flag-test-5 ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -4,8 +4,8 @@ threads sequences calendar accessors ;
|
|||
IN: concurrency.locks.tests
|
||||
|
||||
:: lock-test-0 ( -- v )
|
||||
[let | v [ V{ } clone ]
|
||||
c [ 2 <count-down> ] |
|
||||
V{ } clone :> v
|
||||
2 <count-down> :> c
|
||||
|
||||
[
|
||||
yield
|
||||
|
|
@ -24,13 +24,12 @@ IN: concurrency.locks.tests
|
|||
] "Lock test 2" spawn drop
|
||||
|
||||
c await
|
||||
v
|
||||
] ;
|
||||
v ;
|
||||
|
||||
:: lock-test-1 ( -- v )
|
||||
[let | v [ V{ } clone ]
|
||||
l [ <lock> ]
|
||||
c [ 2 <count-down> ] |
|
||||
V{ } clone :> v
|
||||
<lock> :> l
|
||||
2 <count-down> :> c
|
||||
|
||||
[
|
||||
l [
|
||||
|
|
@ -53,8 +52,7 @@ IN: concurrency.locks.tests
|
|||
] "Lock test 2" spawn drop
|
||||
|
||||
c await
|
||||
v
|
||||
] ;
|
||||
v ;
|
||||
|
||||
[ V{ 1 3 2 4 } ] [ lock-test-0 ] unit-test
|
||||
[ V{ 1 2 3 4 } ] [ lock-test-1 ] unit-test
|
||||
|
|
@ -80,11 +78,11 @@ IN: concurrency.locks.tests
|
|||
[ ] [ <rw-lock> dup [ [ ] with-read-lock ] with-write-lock ] unit-test
|
||||
|
||||
:: rw-lock-test-1 ( -- v )
|
||||
[let | l [ <rw-lock> ]
|
||||
c [ 1 <count-down> ]
|
||||
c' [ 1 <count-down> ]
|
||||
c'' [ 4 <count-down> ]
|
||||
v [ V{ } clone ] |
|
||||
<rw-lock> :> l
|
||||
1 <count-down> :> c
|
||||
1 <count-down> :> c'
|
||||
4 <count-down> :> c''
|
||||
V{ } clone :> v
|
||||
|
||||
[
|
||||
l [
|
||||
|
|
@ -124,16 +122,15 @@ IN: concurrency.locks.tests
|
|||
] "R/W lock test 5" spawn drop
|
||||
|
||||
c'' await
|
||||
v
|
||||
] ;
|
||||
v ;
|
||||
|
||||
[ V{ 1 2 3 4 5 6 } ] [ rw-lock-test-1 ] unit-test
|
||||
|
||||
:: rw-lock-test-2 ( -- v )
|
||||
[let | l [ <rw-lock> ]
|
||||
c [ 1 <count-down> ]
|
||||
c' [ 2 <count-down> ]
|
||||
v [ V{ } clone ] |
|
||||
<rw-lock> :> l
|
||||
1 <count-down> :> c
|
||||
2 <count-down> :> c'
|
||||
V{ } clone :> v
|
||||
|
||||
[
|
||||
l [
|
||||
|
|
@ -154,14 +151,14 @@ IN: concurrency.locks.tests
|
|||
] "R/W lock test 2" spawn drop
|
||||
|
||||
c' await
|
||||
v
|
||||
] ;
|
||||
v ;
|
||||
|
||||
[ V{ 1 2 3 } ] [ rw-lock-test-2 ] unit-test
|
||||
|
||||
! Test lock timeouts
|
||||
:: lock-timeout-test ( -- v )
|
||||
[let | l [ <lock> ] |
|
||||
<lock> :> l
|
||||
|
||||
[
|
||||
l [ 1 seconds sleep ] with-lock
|
||||
] "Lock holder" spawn drop
|
||||
|
|
@ -170,8 +167,7 @@ IN: concurrency.locks.tests
|
|||
l 1/10 seconds [ ] with-lock-timeout
|
||||
] "Lock timeout-er" spawn-linked drop
|
||||
|
||||
receive
|
||||
] ;
|
||||
receive ;
|
||||
|
||||
[ lock-timeout-test ] [
|
||||
thread>> name>> "Lock timeout-er" =
|
||||
|
|
|
|||
|
|
@ -112,17 +112,17 @@ TUPLE: line < disposable line metrics image loc dim ;
|
|||
[
|
||||
line new-disposable
|
||||
|
||||
[let* | open-font [ font cache-font ]
|
||||
line [ string open-font font foreground>> <CTLine> |CFRelease ]
|
||||
font cache-font :> open-font
|
||||
string open-font font foreground>> <CTLine> |CFRelease :> line
|
||||
|
||||
rect [ line line-rect ]
|
||||
(loc) [ rect origin>> CGPoint>loc ]
|
||||
(dim) [ rect size>> CGSize>dim ]
|
||||
(ext) [ (loc) (dim) v+ ]
|
||||
loc [ (loc) [ floor ] map ]
|
||||
ext [ (loc) (dim) [ + ceiling ] 2map ]
|
||||
dim [ ext loc [ - >integer 1 max ] 2map ]
|
||||
metrics [ open-font line compute-line-metrics ] |
|
||||
line line-rect :> rect
|
||||
rect origin>> CGPoint>loc :> (loc)
|
||||
rect size>> CGSize>dim :> (dim)
|
||||
(loc) (dim) v+ :> (ext)
|
||||
(loc) [ floor ] map :> loc
|
||||
(loc) (dim) [ + ceiling ] 2map :> ext
|
||||
ext loc [ - >integer 1 max ] 2map :> dim
|
||||
open-font line compute-line-metrics :> metrics
|
||||
|
||||
line >>line
|
||||
|
||||
|
|
@ -140,7 +140,6 @@ TUPLE: line < disposable line metrics image loc dim ;
|
|||
metrics loc dim line-loc >>loc
|
||||
|
||||
metrics metrics>dim >>dim
|
||||
]
|
||||
] with-destructors ;
|
||||
|
||||
M: line dispose* line>> CFRelease ;
|
||||
|
|
|
|||
|
|
@ -504,11 +504,11 @@ M: ppc %compare [ (%compare) ] 2dip %boolean ;
|
|||
M: ppc %compare-imm [ (%compare-imm) ] 2dip %boolean ;
|
||||
|
||||
M:: ppc %compare-float-ordered ( dst src1 src2 cc temp -- )
|
||||
src1 src2 cc negate-cc \ (%compare-float-ordered) (%compare-float) :> branch2 :> branch1
|
||||
src1 src2 cc negate-cc \ (%compare-float-ordered) (%compare-float) :> ( branch1 branch2 )
|
||||
dst temp branch1 branch2 (%boolean) ;
|
||||
|
||||
M:: ppc %compare-float-unordered ( dst src1 src2 cc temp -- )
|
||||
src1 src2 cc negate-cc \ (%compare-float-unordered) (%compare-float) :> branch2 :> branch1
|
||||
src1 src2 cc negate-cc \ (%compare-float-unordered) (%compare-float) :> ( branch1 branch2 )
|
||||
dst temp branch1 branch2 (%boolean) ;
|
||||
|
||||
:: %branch ( label cc -- )
|
||||
|
|
@ -534,11 +534,11 @@ M:: ppc %compare-imm-branch ( label src1 src2 cc -- )
|
|||
branch2 [ label branch2 execute( label -- ) ] when ; inline
|
||||
|
||||
M:: ppc %compare-float-ordered-branch ( label src1 src2 cc -- )
|
||||
src1 src2 cc \ (%compare-float-ordered) (%compare-float) :> branch2 :> branch1
|
||||
src1 src2 cc \ (%compare-float-ordered) (%compare-float) :> ( branch1 branch2 )
|
||||
label branch1 branch2 (%branch) ;
|
||||
|
||||
M:: ppc %compare-float-unordered-branch ( label src1 src2 cc -- )
|
||||
src1 src2 cc \ (%compare-float-unordered) (%compare-float) :> branch2 :> branch1
|
||||
src1 src2 cc \ (%compare-float-unordered) (%compare-float) :> ( branch1 branch2 )
|
||||
label branch1 branch2 (%branch) ;
|
||||
|
||||
: load-from-frame ( dst n rep -- )
|
||||
|
|
|
|||
|
|
@ -114,8 +114,8 @@ DEFER: (parse-paragraph)
|
|||
|
||||
:: (take-until) ( state delimiter accum -- string/f state' )
|
||||
state empty? [ accum "\n" join f ] [
|
||||
state unclip-slice :> first :> rest
|
||||
first delimiter split1 :> after :> before
|
||||
state unclip-slice :> ( rest first )
|
||||
first delimiter split1 :> ( before after )
|
||||
before accum push
|
||||
after [
|
||||
accum "\n" join
|
||||
|
|
|
|||
|
|
@ -68,10 +68,10 @@ ARTICLE: "fry.philosophy" "Fried quotation philosophy"
|
|||
"'[ [ _ key? ] all? ] filter"
|
||||
"[ [ key? ] curry all? ] curry filter"
|
||||
}
|
||||
"There is a mapping from fried quotations to lexical closures as defined in the " { $vocab-link "locals" } " vocabulary. Namely, a fried quotation is equivalent to a “let” form where each local binding is only used once, and bindings are used in the same order in which they are defined. The following two lines are equivalent:"
|
||||
"There is a mapping from fried quotations to lexical closures as defined in the " { $vocab-link "locals" } " vocabulary. Namely, a fried quotation is equivalent to a " { $snippet "[| | ]" } " form where each local binding is only used once, and bindings are used in the same order in which they are defined. The following two lines are equivalent:"
|
||||
{ $code
|
||||
"'[ 3 _ + 4 _ / ]"
|
||||
"[let | a [ ] b [ ] | [ 3 a + 4 b / ] ]"
|
||||
"[| a b | 3 a + 4 b / ]"
|
||||
} ;
|
||||
|
||||
ARTICLE: "fry" "Fried quotations"
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays classes.mixin classes.parser
|
||||
USING: accessors arrays assocs classes.mixin classes.parser
|
||||
classes.singleton classes.tuple classes.tuple.parser
|
||||
combinators effects.parser fry functors.backend generic
|
||||
generic.parser interpolate io.streams.string kernel lexer
|
||||
|
|
@ -144,10 +144,31 @@ DEFER: ;FUNCTOR delimiter
|
|||
: pop-functor-words ( -- )
|
||||
functor-words unuse-words ;
|
||||
|
||||
: (parse-bindings) ( end -- )
|
||||
dup parse-binding dup [
|
||||
first2 [ make-local ] dip 2array ,
|
||||
(parse-bindings)
|
||||
] [ 2drop ] if ;
|
||||
|
||||
: with-bindings ( quot -- words assoc )
|
||||
'[
|
||||
in-lambda? on
|
||||
_ H{ } make-assoc
|
||||
] { } make swap ; inline
|
||||
|
||||
: parse-bindings ( end -- words assoc )
|
||||
[
|
||||
namespace use-words
|
||||
(parse-bindings)
|
||||
namespace unuse-words
|
||||
] with-bindings ;
|
||||
|
||||
: parse-functor-body ( -- form )
|
||||
push-functor-words
|
||||
"WHERE" parse-bindings*
|
||||
[ \ ;FUNCTOR parse-until >quotation ] ((parse-lambda)) <let*> 1quotation
|
||||
"WHERE" parse-bindings
|
||||
[ [ swap <def> suffix ] { } assoc>map concat ]
|
||||
[ [ \ ;FUNCTOR parse-until >quotation ] ((parse-lambda)) ] bi*
|
||||
[ ] append-as
|
||||
pop-functor-words ;
|
||||
|
||||
: (FUNCTOR:) ( -- word def effect )
|
||||
|
|
|
|||
|
|
@ -23,7 +23,7 @@ GENERIC: new-user ( user provider -- user/f )
|
|||
! Password recovery support
|
||||
|
||||
:: issue-ticket ( email username provider -- user/f )
|
||||
[let | user [ username provider get-user ] |
|
||||
username provider get-user :> user
|
||||
user [
|
||||
user email>> length 0 > [
|
||||
user email>> email = [
|
||||
|
|
@ -32,17 +32,15 @@ GENERIC: new-user ( user provider -- user/f )
|
|||
dup provider update-user
|
||||
] [ f ] if
|
||||
] [ f ] if
|
||||
] [ f ] if
|
||||
] ;
|
||||
] [ f ] if ;
|
||||
|
||||
:: claim-ticket ( ticket username provider -- user/f )
|
||||
[let | user [ username provider get-user ] |
|
||||
username provider get-user :> user
|
||||
user [
|
||||
user ticket>> ticket = [
|
||||
user f >>ticket dup provider update-user
|
||||
] [ f ] if
|
||||
] [ f ] if
|
||||
] ;
|
||||
] [ f ] if ;
|
||||
|
||||
! For configuration
|
||||
|
||||
|
|
|
|||
|
|
@ -16,7 +16,8 @@ IN: interpolate.tests
|
|||
] unit-test
|
||||
|
||||
[ "Oops, I accidentally the whole economy..." ] [
|
||||
[let | noun [ "economy" ] |
|
||||
[let
|
||||
"economy" :> noun
|
||||
[ I[ Oops, I accidentally the whole ${noun}...]I ] with-string-writer
|
||||
]
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -48,7 +48,8 @@ TUPLE: range ufirst ulast bfirst blast ;
|
|||
] dip set-at ;
|
||||
|
||||
: xml>gb-data ( stream -- mapping ranges )
|
||||
[let | mapping [ H{ } clone ] ranges [ V{ } clone ] |
|
||||
[let
|
||||
H{ } clone :> mapping V{ } clone :> ranges
|
||||
[
|
||||
dup contained? [
|
||||
dup name>> main>> {
|
||||
|
|
|
|||
|
|
@ -125,8 +125,9 @@ concurrency.promises threads unix.process ;
|
|||
|
||||
! Killed processes were exiting with code 0 on FreeBSD
|
||||
[ f ] [
|
||||
[let | p [ <promise> ]
|
||||
s [ <promise> ] |
|
||||
[let
|
||||
<promise> :> p
|
||||
<promise> :> s
|
||||
[
|
||||
"sleep 1000" run-detached
|
||||
[ p fulfill ] [ wait-for-process s fulfill ] bi
|
||||
|
|
|
|||
|
|
@ -12,14 +12,13 @@ IN: io.mmap.windows
|
|||
MapViewOfFile [ win32-error=0/f ] keep ;
|
||||
|
||||
:: mmap-open ( path length access-mode create-mode protect access -- handle handle address )
|
||||
[let | lo [ length 32 bits ]
|
||||
hi [ length -32 shift 32 bits ] |
|
||||
length 32 bits :> lo
|
||||
length -32 shift 32 bits :> hi
|
||||
{ "SeCreateGlobalPrivilege" "SeLockMemoryPrivilege" } [
|
||||
path access-mode create-mode 0 open-file |dispose
|
||||
dup handle>> f protect hi lo f create-file-mapping |dispose
|
||||
dup handle>> access 0 0 0 map-view-of-file
|
||||
] with-privileges
|
||||
] ;
|
||||
] with-privileges ;
|
||||
|
||||
TUPLE: win32-mapped-file file mapping ;
|
||||
|
||||
|
|
|
|||
|
|
@ -11,11 +11,10 @@ TUPLE: macosx-monitor < monitor handle ;
|
|||
'[ first { +modify-file+ } _ queue-change ] each ;
|
||||
|
||||
M:: macosx (monitor) ( path recursive? mailbox -- monitor )
|
||||
[let | path [ path normalize-path ] |
|
||||
path normalize-path :> path
|
||||
path mailbox macosx-monitor new-monitor
|
||||
dup [ enqueue-notifications ] curry
|
||||
path 1array 0 0 <event-stream> >>handle
|
||||
] ;
|
||||
path 1array 0 0 <event-stream> >>handle ;
|
||||
|
||||
M: macosx-monitor dispose* handle>> dispose ;
|
||||
|
||||
|
|
|
|||
|
|
@ -35,10 +35,9 @@ TUPLE: openssl-context < secure-context aliens sessions ;
|
|||
[| buf size rwflag password! |
|
||||
password [ B{ 0 } password! ] unless
|
||||
|
||||
[let | len [ password strlen ] |
|
||||
password strlen :> len
|
||||
buf password len 1 + size min memcpy
|
||||
len
|
||||
]
|
||||
] alien-callback ;
|
||||
|
||||
: default-pasword ( ctx -- alien )
|
||||
|
|
|
|||
|
|
@ -120,7 +120,7 @@ CONSTANT: packet-size 65536
|
|||
[ packet-size malloc receive-buffer set-global ] "io.sockets.unix" add-init-hook
|
||||
|
||||
:: do-receive ( port -- packet sockaddr )
|
||||
port addr>> empty-sockaddr/size :> len :> sockaddr
|
||||
port addr>> empty-sockaddr/size :> ( sockaddr len )
|
||||
port handle>> handle-fd ! s
|
||||
receive-buffer get-global ! buf
|
||||
packet-size ! nbytes
|
||||
|
|
|
|||
|
|
@ -25,11 +25,11 @@ IN: lcs
|
|||
[ [ + ] curry map ] with map ;
|
||||
|
||||
:: run-lcs ( old new init step -- matrix )
|
||||
[let | matrix [ old length 1 + new length 1 + init call ] |
|
||||
old length 1 + new length 1 + init call :> matrix
|
||||
old length [| i |
|
||||
new length
|
||||
[| j | i j matrix old new step loop-step ] each
|
||||
] each matrix ] ; inline
|
||||
] each matrix ; inline
|
||||
PRIVATE>
|
||||
|
||||
: levenshtein ( old new -- n )
|
||||
|
|
|
|||
|
|
@ -9,10 +9,10 @@ M: >r/r>-in-lambda-error summary
|
|||
drop
|
||||
"Explicit retain stack manipulation is not permitted in lambda bodies" ;
|
||||
|
||||
ERROR: binding-form-in-literal-error ;
|
||||
ERROR: let-form-in-literal-error ;
|
||||
|
||||
M: binding-form-in-literal-error summary
|
||||
drop "[let, [let* and [wlet not permitted inside literals" ;
|
||||
M: let-form-in-literal-error summary
|
||||
drop "[let not permitted inside literals" ;
|
||||
|
||||
ERROR: local-writer-in-literal-error ;
|
||||
|
||||
|
|
@ -27,7 +27,7 @@ M: local-word-in-literal-error summary
|
|||
ERROR: :>-outside-lambda-error ;
|
||||
|
||||
M: :>-outside-lambda-error summary
|
||||
drop ":> cannot be used outside of lambda expressions" ;
|
||||
drop ":> cannot be used outside of [let, [|, or :: forms" ;
|
||||
|
||||
ERROR: bad-local args obj ;
|
||||
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@ IN: locals.fry
|
|||
|
||||
! Support for mixing locals with fry
|
||||
|
||||
M: binding-form count-inputs body>> count-inputs ;
|
||||
M: let count-inputs body>> count-inputs ;
|
||||
|
||||
M: lambda count-inputs body>> count-inputs ;
|
||||
|
||||
|
|
@ -14,5 +14,5 @@ M: lambda deep-fry
|
|||
clone [ shallow-fry swap ] change-body
|
||||
[ [ vars>> length ] keep '[ _ _ mnswap @ ] , ] [ drop [ncurry] % ] 2bi ;
|
||||
|
||||
M: binding-form deep-fry
|
||||
M: let deep-fry
|
||||
clone [ fry '[ @ call ] ] change-body , ;
|
||||
|
|
|
|||
|
|
@ -8,45 +8,30 @@ HELP: [|
|
|||
{ $examples "See " { $link "locals-examples" } "." } ;
|
||||
|
||||
HELP: [let
|
||||
{ $syntax "[let | var-1 [ value-1... ]\n var-2 [ value-2... ]\n ... |\n body... ]" }
|
||||
{ $description "Evaluates each " { $snippet "value-n" } " form and binds its result to a new local variable named " { $snippet "var-n" } " lexically scoped to the " { $snippet "body" } ", then evaluates " { $snippet "body" } ". The " { $snippet "value-n" } " forms are evaluated in parallel, so a " { $snippet "value-n" } " form may not refer to previous " { $snippet "var-n" } " definitions inside the same " { $link POSTPONE: [let } " form, unlike " { $link POSTPONE: [let* } "." }
|
||||
{ $syntax "[let code :> var code :> var code... ]" }
|
||||
{ $description "Establishes a new lexical scope for local 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." }
|
||||
{ $examples "See " { $link "locals-examples" } "." } ;
|
||||
|
||||
HELP: [let*
|
||||
{ $syntax "[let* | var-1 [ value-1... ]\n var-2 [ value-2... ]\n ... |\n body... ]" }
|
||||
{ $description "Evaluates each " { $snippet "value-n" } " form and binds its result to a new local variable named " { $snippet "var-n" } " lexically scoped to the " { $snippet "body" } ", then evaluates " { $snippet "body" } ". The " { $snippet "value-n" } " forms are evaluated sequentially, so a " { $snippet "value-n" } " form may refer to previous " { $snippet "var-n" } " definitions inside the same " { $link POSTPONE: [let* } " form." }
|
||||
{ $examples "See " { $link "locals-examples" } "." } ;
|
||||
|
||||
{ POSTPONE: [let POSTPONE: [let* } related-words
|
||||
|
||||
HELP: [wlet
|
||||
{ $syntax "[wlet | binding1 [ body1... ]\n binding2 [ body2... ]\n ... |\n body... ]" }
|
||||
{ $description "Introduces a set of lexically-scoped non-recursive local functions. The bodies may not refer to other bindings within the same " { $link POSTPONE: [wlet } " form." }
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: locals math prettyprint sequences ;"
|
||||
"IN: scratchpad"
|
||||
":: quuxify ( n seq -- newseq )"
|
||||
" [wlet | add-n [| m | m n + ] |"
|
||||
" seq [ add-n ] map ] ;"
|
||||
"2 { 1 2 3 } quuxify ."
|
||||
"{ 3 4 5 }"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: :>
|
||||
{ $syntax ":> var" ":> var!" }
|
||||
{ $description "Binds the value on the top of the datastack to a new local variable named " { $snippet "var" } ", lexically scoped to the enclosing quotation or definition."
|
||||
{ $syntax ":> var" ":> var!" ":> ( var-1 var-2 ... )" }
|
||||
{ $description "Binds one or more new local variables. In the " { $snippet ":> var" } " form, the value on the top of the datastack to a new local variable named " { $snippet "var" } ", lexically scoped to the enclosing quotation, " { $link POSTPONE: [let } " form, or " { $link POSTPONE: :: } " definition."
|
||||
$nl
|
||||
"If the " { $snippet "var" } " name is followed by an exclamation point (" { $snippet "!" } "), the new variable will be mutable. See " { $link "locals-mutable" } " for more information on mutable local bindings." }
|
||||
"The " { $snippet ":> ( var-1 ... )" } " form binds multiple local variables from the top of the datastack in left to right order. These two snippets would have the same effect:"
|
||||
{ $code ":> c :> b :> a" }
|
||||
{ $code ":> ( a b c )" }
|
||||
$nl
|
||||
"If any " { $snippet "var" } " name is followed by an exclamation point (" { $snippet "!" } "), that new variable will be mutable. See " { $link "locals-mutable" } " for more information on mutable local bindings." }
|
||||
{ $notes
|
||||
"This syntax can only be used inside a " { $link POSTPONE: :: } " word, " { $link POSTPONE: [let } ", " { $link POSTPONE: [let* } ", or " { $link POSTPONE: [wlet } " form, or inside a quotation literal inside one of those forms."
|
||||
}
|
||||
"This syntax can only be used inside a lexical scope established by a " { $link POSTPONE: :: } " definition, " { $link POSTPONE: [let } " form, or " { $link POSTPONE: [| } " quotation. Definition forms such as " { $link POSTPONE: : } " do not establish a lexical scope by themselves, nor is there a lexical scope available at the top level of source files or in the listener. To use local variable bindings in these situations, use " { $link POSTPONE: [let } " to provide a scope for them." }
|
||||
{ $examples "See " { $link "locals-examples" } "." } ;
|
||||
|
||||
{ POSTPONE: [let POSTPONE: :> } related-words
|
||||
|
||||
HELP: ::
|
||||
{ $syntax ":: word ( bindings... -- outputs... ) body... ;" }
|
||||
{ $description "Defines a word with named inputs; it reads datastack values into local variable bindings from left to right, then executes the body with those bindings in lexical scope." }
|
||||
{ $syntax ":: word ( vars... -- outputs... ) body... ;" }
|
||||
{ $description "Defines a word with named inputs; it reads datastack values into local variable bindings from left to right, then executes the body with those bindings in lexical scope."
|
||||
$nl
|
||||
"If any of the " { $snippet "vars" } "' names is followed by an exclamation point (" { $snippet "!" } "), that variable will be mutable. See " { $link "locals-mutable" } " for more information on mutable local bindings." }
|
||||
{ $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." }
|
||||
{ $examples "See " { $link "locals-examples" } "." } ;
|
||||
|
||||
|
|
@ -54,21 +39,27 @@ HELP: ::
|
|||
|
||||
HELP: MACRO::
|
||||
{ $syntax "MACRO:: word ( bindings... -- outputs... ) body... ;" }
|
||||
{ $description "Defines a macro with named inputs; it reads datastack values into local variable bindings from left to right, then executes the body with those bindings in lexical scope." }
|
||||
{ $description "Defines a macro with named inputs; it reads datastack values into local variable bindings from left to right, then executes the body with those bindings in lexical scope."
|
||||
$nl
|
||||
"If any of the " { $snippet "vars" } "' names is followed by an exclamation point (" { $snippet "!" } "), that variable will be mutable. See " { $link "locals-mutable" } " for more information on mutable local bindings." }
|
||||
{ $examples "See " { $link "locals-examples" } "." } ;
|
||||
|
||||
{ POSTPONE: MACRO: POSTPONE: MACRO:: } related-words
|
||||
|
||||
HELP: MEMO::
|
||||
{ $syntax "MEMO:: word ( bindings... -- outputs... ) body... ;" }
|
||||
{ $description "Defines a macro with named inputs; it reads datastack values into local variable bindings from left to right, then executes the body with those bindings in lexical scope." }
|
||||
{ $description "Defines a memoized word with named inputs; it reads datastack values into local variable bindings from left to right, then executes the body with those bindings in lexical scope."
|
||||
$nl
|
||||
"If any of the " { $snippet "vars" } "' names is followed by an exclamation point (" { $snippet "!" } "), that variable will be mutable. See " { $link "locals-mutable" } " for more information on mutable local bindings." }
|
||||
{ $examples "See " { $link "locals-examples" } "." } ;
|
||||
|
||||
{ POSTPONE: MEMO: POSTPONE: MEMO:: } related-words
|
||||
|
||||
HELP: M::
|
||||
{ $syntax "M:: class generic ( bindings... -- outputs... ) body... ;" }
|
||||
{ $description "Defines a macro with named inputs; it reads datastack values into local variable bindings from left to right, then executes the body with those bindings in lexical scope." }
|
||||
{ $description "Defines a new method on " { $snippet "generic" } " for " { $snippet "class" } " with named inputs; it reads datastack values into local variable bindings from left to right, then executes the body with those bindings in lexical scope."
|
||||
$nl
|
||||
"If any of the " { $snippet "vars" } "' names is followed by an exclamation point (" { $snippet "!" } "), that variable will be mutable. See " { $link "locals-mutable" } " for more information on mutable local bindings." }
|
||||
{ $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." }
|
||||
{ $examples "See " { $link "locals-examples" } "." } ;
|
||||
|
||||
|
|
@ -86,14 +77,13 @@ IN: scratchpad
|
|||
"""2.0
|
||||
-3.0"""
|
||||
}
|
||||
{ $snippet "quadratic-roots" } " can also be expressed with " { $link POSTPONE: [let } ":"
|
||||
"If you wanted to perform the quadratic formula interactively from the listener, you could use " { $link POSTPONE: [let } " to provide a scope for the local variables:"
|
||||
{ $example """USING: locals math math.functions kernel ;
|
||||
IN: scratchpad
|
||||
:: quadratic-roots ( a b c -- x y )
|
||||
[let | disc [ b sq 4 a c * * - sqrt ] |
|
||||
[let 1.0 :> a 1.0 :> b -6.0 :> c
|
||||
b sq 4 a c * * - sqrt :> disc
|
||||
b neg disc [ + ] [ - ] 2bi [ 2 a * / ] bi@
|
||||
] ;
|
||||
1.0 1.0 -6.0 quadratic-roots [ . ] bi@"""
|
||||
] [ . ] bi@"""
|
||||
"""2.0
|
||||
-3.0"""
|
||||
}
|
||||
|
|
@ -216,11 +206,11 @@ $nl
|
|||
"One exception to the above rule is that array instances containing free local variables (that is, immutable local variables not referenced in a closure) do retain identity. This allows macros such as " { $link cond } " to recognize that the array is constant and expand at compile time." ;
|
||||
|
||||
ARTICLE: "locals-mutable" "Mutable locals"
|
||||
"In the list of bindings supplied to " { $link POSTPONE: :: } ", " { $link POSTPONE: [let } ", " { $link POSTPONE: [let* } " or " { $link POSTPONE: [| } ", a mutable binding may be introduced by suffixing its named with " { $snippet "!" } ". Mutable bindings are read by giving their name as usual; the suffix is not part of the binding's name. To write to a mutable binding, use the binding's name with the " { $snippet "!" } " suffix."
|
||||
"Whenever a local 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 "!" } ") when it is bound. The variable's value can be 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 the ML language; each mutable binding is actually an immutable binding of a mutable cell (in Factor's case, a 1-element array); reading the binding automatically dereferences the array, and writing to the binding stores into the array."
|
||||
$nl
|
||||
"Writing to mutable locals in outer scopes is fully supported and has the expected semantics. See " { $link "locals-examples" } " for examples of mutable local variables in action." ;
|
||||
"Writing to mutable locals in outer scopes is fully supported and has full closure semantics. See " { $link "locals-examples" } " for examples of mutable local variables in action." ;
|
||||
|
||||
ARTICLE: "locals-fry" "Locals and fry"
|
||||
"Locals integrate with " { $link "fry" } " so that mixing locals with fried quotations gives intuitive results."
|
||||
|
|
@ -296,12 +286,10 @@ ARTICLE: "locals" "Lexical variables and closures"
|
|||
POSTPONE: MEMO::
|
||||
POSTPONE: MACRO::
|
||||
}
|
||||
"Lexical binding forms:"
|
||||
"Lexical scoping and binding forms:"
|
||||
{ $subsections
|
||||
POSTPONE: :>
|
||||
POSTPONE: [let
|
||||
POSTPONE: [let*
|
||||
POSTPONE: [wlet
|
||||
POSTPONE: :>
|
||||
}
|
||||
"Quotation literals where the inputs are named local variables:"
|
||||
{ $subsections POSTPONE: [| }
|
||||
|
|
|
|||
|
|
@ -26,58 +26,35 @@ IN: locals.tests
|
|||
[ { 5 6 7 } ] [ { 1 2 3 } 4 map-test-2 ] unit-test
|
||||
|
||||
:: let-test ( c -- d )
|
||||
[let | a [ 1 ] b [ 2 ] | a b + c + ] ;
|
||||
[let 1 :> a 2 :> b a b + c + ] ;
|
||||
|
||||
[ 7 ] [ 4 let-test ] unit-test
|
||||
|
||||
:: let-test-2 ( a -- a )
|
||||
a [let | a [ ] | [let | b [ a ] | a ] ] ;
|
||||
a [let :> a [let a :> b a ] ] ;
|
||||
|
||||
[ 3 ] [ 3 let-test-2 ] unit-test
|
||||
|
||||
:: let-test-3 ( a -- a )
|
||||
a [let | a [ ] | [let | b [ [ a ] ] | [let | a [ 3 ] | b ] ] ] ;
|
||||
a [let :> a [let [ a ] :> b [let 3 :> a b ] ] ] ;
|
||||
|
||||
:: let-test-4 ( a -- b )
|
||||
a [let | a [ 1 ] b [ ] | a b 2array ] ;
|
||||
a [let 1 :> a :> 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 :> a :> b a b 2array ] ;
|
||||
|
||||
[ { 2 1 } ] [ 1 2 let-test-5 ] unit-test
|
||||
|
||||
:: let-test-6 ( a -- b )
|
||||
a [let | a [ ] b [ 1 ] | a b 2array ] ;
|
||||
a [let :> a 1 :> b a b 2array ] ;
|
||||
|
||||
[ { 2 1 } ] [ 2 let-test-6 ] unit-test
|
||||
|
||||
[ -1 ] [ -1 let-test-3 call ] unit-test
|
||||
|
||||
[ 5 ] [
|
||||
[let | a [ 3 ] | [wlet | func [ a + ] | 2 func ] ]
|
||||
] unit-test
|
||||
|
||||
:: wlet-test-2 ( a b -- seq )
|
||||
[wlet | add-b [ b + ] |
|
||||
a [ add-b ] map ] ;
|
||||
|
||||
|
||||
[ { 4 5 6 } ] [ { 2 3 4 } 2 wlet-test-2 ] unit-test
|
||||
|
||||
:: wlet-test-3 ( a -- b )
|
||||
[wlet | add-a [ a + ] | [ add-a ] ]
|
||||
[let | a [ 3 ] | a swap call ] ;
|
||||
|
||||
[ 5 ] [ 2 wlet-test-3 ] unit-test
|
||||
|
||||
:: wlet-test-4 ( a -- b )
|
||||
[wlet | sub-a [| b | b a - ] |
|
||||
3 sub-a ] ;
|
||||
|
||||
[ -7 ] [ 10 wlet-test-4 ] unit-test
|
||||
|
||||
:: write-test-1 ( n! -- q )
|
||||
[| i | n i + dup n! ] ;
|
||||
|
||||
|
|
@ -94,8 +71,7 @@ IN: locals.tests
|
|||
[ 5 ] [ 2 "q" get call ] unit-test
|
||||
|
||||
:: write-test-2 ( -- q )
|
||||
[let | n! [ 0 ] |
|
||||
[| i | n i + dup n! ] ] ;
|
||||
[let 0 :> n! [| i | n i + dup n! ] ] ;
|
||||
|
||||
write-test-2 "q" set
|
||||
|
||||
|
|
@ -116,17 +92,11 @@ write-test-2 "q" set
|
|||
|
||||
[ ] [ 1 2 write-test-3 call ] unit-test
|
||||
|
||||
:: write-test-4 ( x! -- q ) [ [let | y! [ 0 ] | f x! ] ] ;
|
||||
:: write-test-4 ( x! -- q ) [ [let 0 :> y! f x! ] ] ;
|
||||
|
||||
[ ] [ 5 write-test-4 drop ] unit-test
|
||||
|
||||
! Not really a write test; just enforcing consistency
|
||||
:: write-test-5 ( x -- y )
|
||||
[wlet | fun! [ x + ] | 5 fun! ] ;
|
||||
|
||||
[ 9 ] [ 4 write-test-5 ] unit-test
|
||||
|
||||
:: let-let-test ( n -- n ) [let | n [ n 3 + ] | n ] ;
|
||||
:: let-let-test ( n -- n ) [let n 3 + :> n n ] ;
|
||||
|
||||
[ 13 ] [ 10 let-let-test ] unit-test
|
||||
|
||||
|
|
@ -164,18 +134,12 @@ M:: string lambda-generic ( a b -- c ) a b lambda-generic-2 ;
|
|||
|
||||
[ ] [ \ lambda-generic see ] unit-test
|
||||
|
||||
:: unparse-test-1 ( a -- ) [let | a! [ 3 ] | ] ;
|
||||
:: unparse-test-1 ( a -- ) [let 3 :> a! 4 :> b ] ;
|
||||
|
||||
[ "[let | a! [ 3 ] | ]" ] [
|
||||
[ "[let 3 :> a! 4 :> b ]" ] [
|
||||
\ unparse-test-1 "lambda" word-prop body>> first unparse
|
||||
] unit-test
|
||||
|
||||
:: unparse-test-2 ( -- ) [wlet | a! [ ] | ] ;
|
||||
|
||||
[ "[wlet | a! [ ] | ]" ] [
|
||||
\ unparse-test-2 "lambda" word-prop body>> first unparse
|
||||
] unit-test
|
||||
|
||||
:: unparse-test-3 ( -- b ) [| a! | ] ;
|
||||
|
||||
[ "[| a! | ]" ] [
|
||||
|
|
@ -198,38 +162,6 @@ DEFER: xyzzy
|
|||
|
||||
[ 5 ] [ 10 xyzzy ] unit-test
|
||||
|
||||
:: let*-test-1 ( a -- b )
|
||||
[let* | b [ a 1 + ]
|
||||
c [ b 1 + ] |
|
||||
a b c 3array ] ;
|
||||
|
||||
[ { 1 2 3 } ] [ 1 let*-test-1 ] unit-test
|
||||
|
||||
:: let*-test-2 ( a -- b )
|
||||
[let* | b [ a 1 + ]
|
||||
c! [ b 1 + ] |
|
||||
a b c 3array ] ;
|
||||
|
||||
[ { 1 2 3 } ] [ 1 let*-test-2 ] unit-test
|
||||
|
||||
:: let*-test-3 ( a -- b )
|
||||
[let* | b [ a 1 + ]
|
||||
c! [ b 1 + ] |
|
||||
c 1 + c! a b c 3array ] ;
|
||||
|
||||
[ { 1 2 4 } ] [ 1 let*-test-3 ] unit-test
|
||||
|
||||
:: let*-test-4 ( a b -- c d )
|
||||
[let | a [ b ]
|
||||
b [ a ] |
|
||||
[let* | a' [ a ]
|
||||
a'' [ a' ]
|
||||
b' [ b ]
|
||||
b'' [ b' ] |
|
||||
a'' b'' ] ] ;
|
||||
|
||||
[ "xxx" "yyy" ] [ "yyy" "xxx" let*-test-4 ] unit-test
|
||||
|
||||
GENERIC: next-method-test ( a -- b )
|
||||
|
||||
M: integer next-method-test 3 + ;
|
||||
|
|
@ -244,11 +176,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 :> a ] ] unit-test
|
||||
|
||||
[ 3 ] [ 1 [let | a [ ] | 3 ] ] unit-test
|
||||
[ 3 ] [ 1 [let :> a 3 ] ] unit-test
|
||||
|
||||
[ ] [ 1 2 [let | a [ ] b [ ] | ] ] unit-test
|
||||
[ ] [ 1 2 [let :> a :> b ] ] unit-test
|
||||
|
||||
:: a-word-with-locals ( a b -- ) ;
|
||||
|
||||
|
|
@ -306,10 +238,10 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
|
|||
[ t ] [ 12 &&-test ] unit-test
|
||||
|
||||
:: let-and-cond-test-1 ( -- a )
|
||||
[let | a [ 10 ] |
|
||||
[let | a [ 20 ] |
|
||||
[let 10 :> a
|
||||
[let 20 :> a
|
||||
{
|
||||
{ [ t ] [ [let | c [ 30 ] | a ] ] }
|
||||
{ [ t ] [ [let 30 :> c a ] ] }
|
||||
} cond
|
||||
]
|
||||
] ;
|
||||
|
|
@ -319,8 +251,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 | A [ 10 ] |
|
||||
[let | B [ 20 ] |
|
||||
[let 10 :> A
|
||||
[let 20 :> B
|
||||
{ { [ t ] [ { A B } ] } } cond
|
||||
]
|
||||
] ;
|
||||
|
|
@ -333,7 +265,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 | a [ 10 ] b [ 20 ] c [ 30 ] | { a b c } ] ] unit-test
|
||||
[ { 10 20 30 } ] [ [let 10 :> a 20 :> b 30 :> c { a b c } ] ] unit-test
|
||||
|
||||
[ V{ 10 20 30 } ] [ 10 20 30 [| a b c | V{ a b c } ] call ] unit-test
|
||||
|
||||
|
|
@ -453,7 +385,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 | A [ 10 ] | A _ + ] ]"
|
||||
"USING: locals fry math ; 1 '[ [let 10 :> A A _ + ] ]"
|
||||
eval( -- ) call
|
||||
] [ error>> >r/r>-in-fry-error? ] must-fail-with
|
||||
|
||||
|
|
@ -465,10 +397,7 @@ M:: integer lambda-method-forget-test ( a -- b ) a ;
|
|||
[ t ] [ 3 funny-macro-test ] unit-test
|
||||
[ f ] [ 2 funny-macro-test ] unit-test
|
||||
|
||||
! Some odd parser corner cases
|
||||
[ "USE: locals [let" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with
|
||||
[ "USE: locals [let |" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with
|
||||
[ "USE: locals [let | a" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with
|
||||
[ "USE: locals [|" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with
|
||||
|
||||
[ 25 ] [ 5 [| a | { [ a sq ] } cond ] call ] unit-test
|
||||
|
|
@ -484,15 +413,9 @@ M:: integer lambda-method-forget-test ( a -- b ) a ;
|
|||
|
||||
[ 3 ] [ 3 [| a | \ a ] call ] unit-test
|
||||
|
||||
[ "USE: locals [| | { [let | a [ 0 ] | a ] } ]" eval( -- ) ] must-fail
|
||||
[ "USE: locals [| | { [let 0 :> a a ] } ]" eval( -- ) ] must-fail
|
||||
|
||||
[ "USE: locals [| | { [wlet | a [ 0 ] | a ] } ]" eval( -- ) ] must-fail
|
||||
|
||||
[ "USE: locals [| | { [let* | a [ 0 ] | a ] } ]" eval( -- ) ] must-fail
|
||||
|
||||
[ "USE: locals [| | [let | a! [ 0 ] | { a! } ] ]" eval( -- ) ] must-fail
|
||||
|
||||
[ "USE: locals [| | [wlet | a [ 0 ] | { a } ] ]" eval( -- ) ] must-fail
|
||||
[ "USE: locals [| | [let 0 :> a! { a! } ] ]" eval( -- ) ] must-fail
|
||||
|
||||
[ "USE: locals [| | { :> a } ]" eval( -- ) ] must-fail
|
||||
|
||||
|
|
@ -504,27 +427,14 @@ M:: integer lambda-method-forget-test ( a -- b ) a ;
|
|||
|
||||
[ 3 ] [ 2 [| | :> a! a 1 + a! a ] call ] unit-test
|
||||
|
||||
:: wlet-&&-test ( a -- ? )
|
||||
[wlet | is-integer? [ a integer? ]
|
||||
is-even? [ a even? ]
|
||||
>10? [ a 10 > ] |
|
||||
{ [ is-integer? ] [ is-even? ] [ >10? ] } &&
|
||||
] ;
|
||||
|
||||
\ wlet-&&-test def>> must-infer
|
||||
[ f ] [ 1.5 wlet-&&-test ] unit-test
|
||||
[ f ] [ 3 wlet-&&-test ] unit-test
|
||||
[ f ] [ 8 wlet-&&-test ] unit-test
|
||||
[ t ] [ 12 wlet-&&-test ] unit-test
|
||||
|
||||
: fry-locals-test-1 ( -- n )
|
||||
[let | | 6 '[ [let | A [ 4 ] | A _ + ] ] call ] ;
|
||||
[let 6 '[ [let 4 :> 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 | A [ 4 ] | A _ + ] ] call ] ;
|
||||
[let 6 '[ [let 4 :> A A _ + ] ] call ] ;
|
||||
|
||||
\ fry-locals-test-2 def>> must-infer
|
||||
[ 10 ] [ fry-locals-test-2 ] unit-test
|
||||
|
|
@ -542,18 +452,18 @@ M:: integer lambda-method-forget-test ( a -- b ) a ;
|
|||
] unit-test
|
||||
|
||||
[ 10 ] [
|
||||
[| | 0 '[ [let | A [ 10 ] | A _ + ] ] call ] call
|
||||
[| | 0 '[ [let 10 :> A A _ + ] ] call ] call
|
||||
] unit-test
|
||||
|
||||
! littledan found this problem
|
||||
[ "bar" ] [ [let | a [ [let | foo [ "bar" ] | foo ] ] | a ] ] unit-test
|
||||
[ 10 ] [ [let | a [ 10 ] | [let | b [ a ] | b ] ] ] unit-test
|
||||
[ "bar" ] [ [let [let "bar" :> foo foo ] :> a a ] ] unit-test
|
||||
[ 10 ] [ [let 10 :> a [let a :> b b ] ] ] unit-test
|
||||
|
||||
[ { \ + } ] [ [let | x [ \ + ] | { \ x } ] ] unit-test
|
||||
[ { \ + } ] [ [let \ + :> x { \ x } ] ] unit-test
|
||||
|
||||
[ { \ + 3 } ] [ [let | a [ 3 ] | { \ + a } ] ] unit-test
|
||||
[ { \ + 3 } ] [ [let 3 :> a { \ + a } ] ] unit-test
|
||||
|
||||
[ 3 ] [ [let | a [ \ + ] | 1 2 [ \ a execute ] ] call ] unit-test
|
||||
[ 3 ] [ [let \ + :> a 1 2 [ \ a execute ] ] call ] unit-test
|
||||
|
||||
! erg found this problem
|
||||
:: erg's-:>-bug ( n ? -- n ) ? [ n :> n n ] [ n :> b b ] if ;
|
||||
|
|
@ -578,3 +488,6 @@ M: integer ed's-bug neg ;
|
|||
{ [ a ed's-bug ] } && ;
|
||||
|
||||
[ t ] [ \ ed's-test-case optimized? ] unit-test
|
||||
|
||||
! multiple bind
|
||||
[ 3 1 2 ] [ [let 1 2 3 :> ( a b c ) c a b ] ] unit-test
|
||||
|
|
|
|||
|
|
@ -7,16 +7,12 @@ IN: locals
|
|||
|
||||
SYNTAX: :>
|
||||
scan locals get [ :>-outside-lambda-error ] unless*
|
||||
[ make-local ] bind <def> suffix! ;
|
||||
parse-def suffix! ;
|
||||
|
||||
SYNTAX: [| parse-lambda append! ;
|
||||
|
||||
SYNTAX: [let parse-let append! ;
|
||||
|
||||
SYNTAX: [let* parse-let* append! ;
|
||||
|
||||
SYNTAX: [wlet parse-wlet append! ;
|
||||
|
||||
SYNTAX: :: (::) define-declared ;
|
||||
|
||||
SYNTAX: M:: (M::) define ;
|
||||
|
|
|
|||
|
|
@ -7,12 +7,10 @@ M: lambda expand-macros clone [ expand-macros ] change-body ;
|
|||
|
||||
M: lambda expand-macros* expand-macros literal ;
|
||||
|
||||
M: binding-form expand-macros
|
||||
clone
|
||||
[ [ expand-macros ] assoc-map ] change-bindings
|
||||
[ expand-macros ] change-body ;
|
||||
M: let expand-macros
|
||||
clone [ expand-macros ] change-body ;
|
||||
|
||||
M: binding-form expand-macros* expand-macros literal ;
|
||||
M: let expand-macros* expand-macros literal ;
|
||||
|
||||
M: lambda condomize? drop t ;
|
||||
|
||||
|
|
|
|||
|
|
@ -46,6 +46,12 @@ SYMBOL: locals
|
|||
(parse-lambda) <lambda>
|
||||
?rewrite-closures ;
|
||||
|
||||
: parse-multi-def ( locals -- multi-def )
|
||||
")" parse-tokens swap [ [ make-local ] map ] bind <multi-def> ;
|
||||
|
||||
: parse-def ( name/paren locals -- def )
|
||||
over "(" = [ nip parse-multi-def ] [ [ make-local ] bind <def> ] if ;
|
||||
|
||||
M: lambda-parser parse-quotation ( -- quotation )
|
||||
H{ } clone (parse-lambda) ;
|
||||
|
||||
|
|
@ -56,48 +62,8 @@ M: lambda-parser parse-quotation ( -- quotation )
|
|||
[ nip scan-object 2array ]
|
||||
} cond ;
|
||||
|
||||
: (parse-bindings) ( end -- )
|
||||
dup parse-binding dup [
|
||||
first2 [ make-local ] dip 2array ,
|
||||
(parse-bindings)
|
||||
] [ 2drop ] if ;
|
||||
|
||||
: with-bindings ( quot -- words assoc )
|
||||
'[
|
||||
in-lambda? on
|
||||
_ H{ } make-assoc
|
||||
] { } make swap ; inline
|
||||
|
||||
: parse-bindings ( end -- bindings vars )
|
||||
[ (parse-bindings) ] with-bindings ;
|
||||
|
||||
: parse-let ( -- form )
|
||||
"|" expect "|" parse-bindings
|
||||
(parse-lambda) <let> ?rewrite-closures ;
|
||||
|
||||
: parse-bindings* ( end -- words assoc )
|
||||
[
|
||||
namespace use-words
|
||||
(parse-bindings)
|
||||
namespace unuse-words
|
||||
] with-bindings ;
|
||||
|
||||
: parse-let* ( -- form )
|
||||
"|" expect "|" parse-bindings*
|
||||
(parse-lambda) <let*> ?rewrite-closures ;
|
||||
|
||||
: (parse-wbindings) ( end -- )
|
||||
dup parse-binding dup [
|
||||
first2 [ make-local-word ] keep 2array ,
|
||||
(parse-wbindings)
|
||||
] [ 2drop ] if ;
|
||||
|
||||
: parse-wbindings ( end -- bindings vars )
|
||||
[ (parse-wbindings) ] with-bindings ;
|
||||
|
||||
: parse-wlet ( -- form )
|
||||
"|" expect "|" parse-wbindings
|
||||
(parse-lambda) <wlet> ?rewrite-closures ;
|
||||
H{ } clone (parse-lambda) <let> ?rewrite-closures ;
|
||||
|
||||
: parse-locals ( -- effect vars assoc )
|
||||
complete-effect
|
||||
|
|
|
|||
|
|
@ -27,22 +27,17 @@ M: lambda pprint*
|
|||
|
||||
: pprint-let ( let word -- )
|
||||
pprint-word
|
||||
[ body>> ] [ bindings>> ] bi
|
||||
\ | pprint-word
|
||||
t <inset
|
||||
<block
|
||||
[ <block [ pprint-var ] dip pprint* block> ] assoc-each
|
||||
block>
|
||||
\ | pprint-word
|
||||
<block pprint-elements block>
|
||||
block>
|
||||
<block body>> pprint-elements block>
|
||||
\ ] pprint-word ;
|
||||
|
||||
M: let pprint* \ [let pprint-let ;
|
||||
|
||||
M: wlet pprint* \ [wlet pprint-let ;
|
||||
|
||||
M: let* pprint* \ [let* pprint-let ;
|
||||
|
||||
M: def pprint*
|
||||
<block \ :> pprint-word local>> pprint-word block> ;
|
||||
dup local>> word?
|
||||
[ <block \ :> pprint-word local>> pprint-var block> ]
|
||||
[ pprint-tuple ] if ;
|
||||
|
||||
M: multi-def pprint*
|
||||
dup locals>> [ word? ] all?
|
||||
[ <block \ :> pprint-word "(" text locals>> [ pprint-var ] each ")" text block> ]
|
||||
[ pprint-tuple ] if ;
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@ locals.errors locals.types make quotations sequences vectors
|
|||
words ;
|
||||
IN: locals.rewrite.sugar
|
||||
|
||||
! Step 1: rewrite [| [let [let* [wlet into :> forms, turn
|
||||
! Step 1: rewrite [| into :> forms, turn
|
||||
! literals with locals in them into code which constructs
|
||||
! the literal after pushing locals on the stack
|
||||
|
||||
|
|
@ -73,7 +73,7 @@ M: quotation rewrite-element rewrite-sugar* ;
|
|||
|
||||
M: lambda rewrite-element rewrite-sugar* ;
|
||||
|
||||
M: binding-form rewrite-element binding-form-in-literal-error ;
|
||||
M: let rewrite-element let-form-in-literal-error ;
|
||||
|
||||
M: local rewrite-element , ;
|
||||
|
||||
|
|
@ -104,6 +104,8 @@ M: tuple rewrite-sugar* rewrite-element ;
|
|||
|
||||
M: def rewrite-sugar* , ;
|
||||
|
||||
M: multi-def rewrite-sugar* locals>> <reversed> [ <def> , ] each ;
|
||||
|
||||
M: hashtable rewrite-sugar* rewrite-element ;
|
||||
|
||||
M: wrapper rewrite-sugar*
|
||||
|
|
@ -115,17 +117,5 @@ M: word rewrite-sugar*
|
|||
|
||||
M: object rewrite-sugar* , ;
|
||||
|
||||
: let-rewrite ( body bindings -- )
|
||||
[ quotation-rewrite % <def> , ] assoc-each
|
||||
quotation-rewrite % ;
|
||||
|
||||
M: let rewrite-sugar*
|
||||
[ body>> ] [ bindings>> ] bi let-rewrite ;
|
||||
|
||||
M: let* rewrite-sugar*
|
||||
[ body>> ] [ bindings>> ] bi let-rewrite ;
|
||||
|
||||
M: wlet rewrite-sugar*
|
||||
[ body>> ] [ bindings>> ] bi
|
||||
[ '[ _ ] ] assoc-map
|
||||
let-rewrite ;
|
||||
body>> quotation-rewrite % ;
|
||||
|
|
|
|||
|
|
@ -8,20 +8,10 @@ TUPLE: lambda vars body ;
|
|||
|
||||
C: <lambda> lambda
|
||||
|
||||
TUPLE: binding-form bindings body ;
|
||||
|
||||
TUPLE: let < binding-form ;
|
||||
TUPLE: let body ;
|
||||
|
||||
C: <let> let
|
||||
|
||||
TUPLE: let* < binding-form ;
|
||||
|
||||
C: <let*> let*
|
||||
|
||||
TUPLE: wlet < binding-form ;
|
||||
|
||||
C: <wlet> wlet
|
||||
|
||||
TUPLE: quote local ;
|
||||
|
||||
C: <quote> quote
|
||||
|
|
@ -32,6 +22,10 @@ TUPLE: def local ;
|
|||
|
||||
C: <def> def
|
||||
|
||||
TUPLE: multi-def locals ;
|
||||
|
||||
C: <multi-def> multi-def
|
||||
|
||||
PREDICATE: local < word "local?" word-prop ;
|
||||
|
||||
: <local> ( name -- word )
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@ IN: math.matrices
|
|||
:: rotation-matrix3 ( axis theta -- matrix )
|
||||
theta cos :> c
|
||||
theta sin :> s
|
||||
axis first3 :> z :> y :> x
|
||||
axis first3 :> ( x y z )
|
||||
x sq 1.0 x sq - c * + x y * 1.0 c - * z s * - x z * 1.0 c - * y s * + 3array
|
||||
x y * 1.0 c - * z s * + y sq 1.0 y sq - c * + y z * 1.0 c - * x s * - 3array
|
||||
x z * 1.0 c - * y s * - y z * 1.0 c - * x s * + z sq 1.0 z sq - c * + 3array
|
||||
|
|
@ -25,14 +25,14 @@ IN: math.matrices
|
|||
:: rotation-matrix4 ( axis theta -- matrix )
|
||||
theta cos :> c
|
||||
theta sin :> s
|
||||
axis first3 :> z :> y :> x
|
||||
axis first3 :> ( x y z )
|
||||
x sq 1.0 x sq - c * + x y * 1.0 c - * z s * - x z * 1.0 c - * y s * + 0 4array
|
||||
x y * 1.0 c - * z s * + y sq 1.0 y sq - c * + y z * 1.0 c - * x s * - 0 4array
|
||||
x z * 1.0 c - * y s * - y z * 1.0 c - * x s * + z sq 1.0 z sq - c * + 0 4array
|
||||
{ 0.0 0.0 0.0 1.0 } 4array ;
|
||||
|
||||
:: translation-matrix4 ( offset -- matrix )
|
||||
offset first3 :> z :> y :> x
|
||||
offset first3 :> ( x y z )
|
||||
{
|
||||
{ 1.0 0.0 0.0 x }
|
||||
{ 0.0 1.0 0.0 y }
|
||||
|
|
@ -44,7 +44,7 @@ IN: math.matrices
|
|||
dup number? [ dup dup ] [ first3 ] if ;
|
||||
|
||||
:: scale-matrix3 ( factors -- matrix )
|
||||
factors >scale-factors :> z :> y :> x
|
||||
factors >scale-factors :> ( x y z )
|
||||
{
|
||||
{ x 0.0 0.0 }
|
||||
{ 0.0 y 0.0 }
|
||||
|
|
@ -52,7 +52,7 @@ IN: math.matrices
|
|||
} ;
|
||||
|
||||
:: scale-matrix4 ( factors -- matrix )
|
||||
factors >scale-factors :> z :> y :> x
|
||||
factors >scale-factors :> ( x y z )
|
||||
{
|
||||
{ x 0.0 0.0 0.0 }
|
||||
{ 0.0 y 0.0 0.0 }
|
||||
|
|
@ -64,7 +64,7 @@ IN: math.matrices
|
|||
[ recip ] map scale-matrix4 ;
|
||||
|
||||
:: frustum-matrix4 ( xy-dim near far -- matrix )
|
||||
xy-dim first2 :> y :> x
|
||||
xy-dim first2 :> ( x y )
|
||||
near x /f :> xf
|
||||
near y /f :> yf
|
||||
near far + near far - /f :> zf
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ IN: math.primes.miller-rabin
|
|||
|
||||
:: (miller-rabin) ( n trials -- ? )
|
||||
n 1 - :> n-1
|
||||
n-1 factor-2s :> s :> r
|
||||
n-1 factor-2s :> ( r s )
|
||||
0 :> a!
|
||||
trials [
|
||||
drop
|
||||
|
|
|
|||
|
|
@ -81,8 +81,8 @@ ERROR: bad-vconvert-input value expected-type ;
|
|||
PRIVATE>
|
||||
|
||||
MACRO:: vconvert ( from-type to-type -- )
|
||||
from-type new [ element-type ] [ byte-length ] bi :> from-length :> from-element
|
||||
to-type new [ element-type ] [ byte-length ] bi :> to-length :> to-element
|
||||
from-type new [ element-type ] [ byte-length ] bi :> ( from-element from-length )
|
||||
to-type new [ element-type ] [ byte-length ] bi :> ( to-element to-length )
|
||||
from-element heap-size :> from-size
|
||||
to-element heap-size :> to-size
|
||||
|
||||
|
|
|
|||
|
|
@ -391,8 +391,8 @@ TUPLE: inconsistent-vector-test bool branch ;
|
|||
2dup = [ drop ] [ inconsistent-vector-test boa ] if ;
|
||||
|
||||
:: test-vector-tests ( vector decl -- none? any? all? )
|
||||
vector decl test-vector-tests-bool :> bool-all :> bool-any :> bool-none
|
||||
vector decl test-vector-tests-branch :> branch-all :> branch-any :> branch-none
|
||||
vector decl test-vector-tests-bool :> ( bool-none bool-any bool-all )
|
||||
vector decl test-vector-tests-branch :> ( branch-none branch-any branch-all )
|
||||
|
||||
bool-none branch-none ?inconsistent
|
||||
bool-any branch-any ?inconsistent
|
||||
|
|
|
|||
|
|
@ -27,11 +27,12 @@ TUPLE: an-observer { i integer } ;
|
|||
M: an-observer model-changed nip [ 1 + ] change-i drop ;
|
||||
|
||||
[ 1 0 ] [
|
||||
[let* | m1 [ 1 <model> ]
|
||||
m2 [ 2 <model> ]
|
||||
c [ { m1 m2 } <product> ]
|
||||
o1 [ an-observer new ]
|
||||
o2 [ an-observer new ] |
|
||||
[let
|
||||
1 <model> :> m1
|
||||
2 <model> :> m2
|
||||
{ m1 m2 } <product> :> c
|
||||
an-observer new :> o1
|
||||
an-observer new :> o2
|
||||
|
||||
o1 m1 add-connection
|
||||
o2 m2 add-connection
|
||||
|
|
|
|||
|
|
@ -95,8 +95,8 @@ MACRO: all-enabled-client-state ( seq 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 :> y :> x
|
||||
dim first2 :> h :> w
|
||||
loc first2 :> ( x y )
|
||||
dim first2 :> ( w h )
|
||||
[
|
||||
x 0.5 + y 0.5 +
|
||||
x w + 0.3 - y 0.5 +
|
||||
|
|
@ -115,8 +115,8 @@ MACRO: all-enabled-client-state ( seq quot -- )
|
|||
rect-vertices (gl-rect) ;
|
||||
|
||||
:: (fill-rect-vertices) ( loc dim -- vertices )
|
||||
loc first2 :> y :> x
|
||||
dim first2 :> h :> w
|
||||
loc first2 :> ( x y )
|
||||
dim first2 :> ( w h )
|
||||
[
|
||||
x y
|
||||
x w + y
|
||||
|
|
|
|||
|
|
@ -278,7 +278,7 @@ TUPLE: single-texture < disposable image dim loc texture-coords texture display-
|
|||
] unless ;
|
||||
|
||||
:: tex-image ( image bitmap -- )
|
||||
image image-format :> type :> format :> internal-format
|
||||
image image-format :> ( internal-format format type )
|
||||
GL_TEXTURE_2D 0 internal-format
|
||||
image dim>> adjust-texture-dim first2 0
|
||||
format type bitmap glTexImage2D ;
|
||||
|
|
|
|||
|
|
@ -445,16 +445,16 @@ M: ebnf-sequence build-locals ( code ast -- code )
|
|||
drop
|
||||
] [
|
||||
[
|
||||
"FROM: locals => [let* ; FROM: sequences => nth ; [let* | " %
|
||||
dup length swap [
|
||||
dup ebnf-var? [
|
||||
"FROM: locals => [let :> ; FROM: sequences => nth ; [let " %
|
||||
dup length [
|
||||
over ebnf-var? [
|
||||
" " % # " over nth :> " %
|
||||
name>> %
|
||||
" [ " % # " over nth ] " %
|
||||
] [
|
||||
2drop
|
||||
] if
|
||||
] 2each
|
||||
" | " %
|
||||
" " %
|
||||
%
|
||||
" nip ]" %
|
||||
] "" make
|
||||
|
|
@ -463,9 +463,9 @@ M: ebnf-sequence build-locals ( code ast -- code )
|
|||
|
||||
M: ebnf-var build-locals ( code ast -- )
|
||||
[
|
||||
"FROM: locals => [let* ; FROM: kernel => dup nip ; [let* | " %
|
||||
name>> % " [ dup ] " %
|
||||
" | " %
|
||||
"FROM: locals => [let :> ; FROM: kernel => dup nip ; [let " %
|
||||
" dup :> " % name>> %
|
||||
" " %
|
||||
%
|
||||
" nip ]" %
|
||||
] "" make ;
|
||||
|
|
|
|||
|
|
@ -172,9 +172,7 @@ TUPLE: peg-head rule-id involved-set eval-set ;
|
|||
l lrstack get (setup-lr) ;
|
||||
|
||||
:: lr-answer ( r p m -- ast )
|
||||
[let* |
|
||||
h [ m ans>> head>> ]
|
||||
|
|
||||
m ans>> head>> :> h
|
||||
h rule-id>> r rule-id eq? [
|
||||
m ans>> seed>> m (>>ans)
|
||||
m ans>> failed? [
|
||||
|
|
@ -184,14 +182,11 @@ TUPLE: peg-head rule-id involved-set eval-set ;
|
|||
] if
|
||||
] [
|
||||
m ans>> seed>>
|
||||
] if
|
||||
] ; inline
|
||||
] if ; inline
|
||||
|
||||
:: recall ( r p -- memo-entry )
|
||||
[let* |
|
||||
m [ p r rule-id memo ]
|
||||
h [ p heads at ]
|
||||
|
|
||||
p r rule-id memo :> m
|
||||
p heads at :> h
|
||||
h [
|
||||
m r rule-id h involved-set>> h rule-id>> suffix member? not and [
|
||||
fail p memo-entry boa
|
||||
|
|
@ -207,15 +202,12 @@ TUPLE: peg-head rule-id involved-set eval-set ;
|
|||
] if
|
||||
] [
|
||||
m
|
||||
] if
|
||||
] ; inline
|
||||
] if ; inline
|
||||
|
||||
:: apply-non-memo-rule ( r p -- ast )
|
||||
[let* |
|
||||
lr [ fail r rule-id f lrstack get left-recursion boa ]
|
||||
m [ lr lrstack set lr p memo-entry boa dup p r rule-id set-memo ]
|
||||
ans [ r eval-rule ]
|
||||
|
|
||||
fail r rule-id f lrstack get left-recursion boa :> lr
|
||||
lr lrstack set lr p memo-entry boa dup p r rule-id set-memo :> m
|
||||
r eval-rule :> ans
|
||||
lrstack get next>> lrstack set
|
||||
pos get m (>>pos)
|
||||
lr head>> [
|
||||
|
|
@ -226,8 +218,7 @@ TUPLE: peg-head rule-id involved-set eval-set ;
|
|||
] [
|
||||
ans m (>>ans)
|
||||
ans
|
||||
] if
|
||||
] ; inline
|
||||
] if ; inline
|
||||
|
||||
: apply-memo-rule ( r m -- ast )
|
||||
[ ans>> ] [ pos>> ] bi pos set
|
||||
|
|
@ -622,17 +613,16 @@ PRIVATE>
|
|||
ERROR: parse-failed input word ;
|
||||
|
||||
SYNTAX: PEG:
|
||||
(:)
|
||||
[let | effect [ ] def [ ] word [ ] |
|
||||
[let
|
||||
(:) :> ( word def effect )
|
||||
[
|
||||
[
|
||||
[let | compiled-def [ def call compile ] |
|
||||
def call compile :> compiled-def
|
||||
[
|
||||
dup compiled-def compiled-parse
|
||||
[ ast>> ] [ word parse-failed ] ?if
|
||||
]
|
||||
word swap effect define-declared
|
||||
]
|
||||
] with-compilation-unit
|
||||
] append!
|
||||
] ;
|
||||
|
|
|
|||
|
|
@ -10,35 +10,33 @@ 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 )
|
||||
[let* | shift [ bitmap-node shift>> ]
|
||||
bit [ hashcode shift bitpos ]
|
||||
bitmap [ bitmap-node bitmap>> ]
|
||||
nodes [ bitmap-node nodes>> ] |
|
||||
bitmap-node shift>> :> shift
|
||||
hashcode shift bitpos :> bit
|
||||
bitmap-node bitmap>> :> bitmap
|
||||
bitmap-node nodes>> :> nodes
|
||||
bitmap bit bitand 0 eq? [ f ] [
|
||||
key hashcode
|
||||
bit bitmap index nodes nth-unsafe
|
||||
(entry-at)
|
||||
] if
|
||||
] ;
|
||||
] if ;
|
||||
|
||||
M:: bitmap-node (new-at) ( shift value key hashcode bitmap-node -- node' added-leaf )
|
||||
[let* | shift [ bitmap-node shift>> ]
|
||||
bit [ hashcode shift bitpos ]
|
||||
bitmap [ bitmap-node bitmap>> ]
|
||||
idx [ bit bitmap index ]
|
||||
nodes [ bitmap-node nodes>> ] |
|
||||
bitmap-node shift>> :> shift
|
||||
hashcode shift bitpos :> bit
|
||||
bitmap-node bitmap>> :> bitmap
|
||||
bit bitmap index :> idx
|
||||
bitmap-node nodes>> :> nodes
|
||||
|
||||
bitmap bit bitand 0 eq? [
|
||||
[let | new-leaf [ value key hashcode <leaf-node> ] |
|
||||
value key hashcode <leaf-node> :> new-leaf
|
||||
bitmap bit bitor
|
||||
new-leaf idx nodes insert-nth
|
||||
shift
|
||||
<bitmap-node>
|
||||
new-leaf
|
||||
]
|
||||
] [
|
||||
[let | n [ idx nodes nth ] |
|
||||
shift radix-bits + value key hashcode n (new-at)
|
||||
[let | new-leaf [ ] n' [ ] |
|
||||
idx nodes nth :> n
|
||||
shift radix-bits + value key hashcode n (new-at) :> ( n' new-leaf )
|
||||
n n' eq? [
|
||||
bitmap-node
|
||||
] [
|
||||
|
|
@ -48,20 +46,17 @@ M:: bitmap-node (new-at) ( shift value key hashcode bitmap-node -- node' added-l
|
|||
<bitmap-node>
|
||||
] if
|
||||
new-leaf
|
||||
]
|
||||
]
|
||||
] if
|
||||
] ;
|
||||
] if ;
|
||||
|
||||
M:: bitmap-node (pluck-at) ( key hashcode bitmap-node -- node' )
|
||||
[let | bit [ hashcode bitmap-node shift>> bitpos ]
|
||||
bitmap [ bitmap-node bitmap>> ]
|
||||
nodes [ bitmap-node nodes>> ]
|
||||
shift [ bitmap-node shift>> ] |
|
||||
hashcode bitmap-node shift>> bitpos :> bit
|
||||
bitmap-node bitmap>> :> bitmap
|
||||
bitmap-node nodes>> :> nodes
|
||||
bitmap-node shift>> :> shift
|
||||
bit bitmap bitand 0 eq? [ bitmap-node ] [
|
||||
[let* | idx [ bit bitmap index ]
|
||||
n [ idx nodes nth-unsafe ]
|
||||
n' [ key hashcode n (pluck-at) ] |
|
||||
bit bitmap index :> idx
|
||||
idx nodes nth-unsafe :> n
|
||||
key hashcode n (pluck-at) :> n'
|
||||
n n' eq? [
|
||||
bitmap-node
|
||||
] [
|
||||
|
|
@ -79,8 +74,6 @@ M:: bitmap-node (pluck-at) ( key hashcode bitmap-node -- node' )
|
|||
] if
|
||||
] if
|
||||
] if
|
||||
]
|
||||
] if
|
||||
] ;
|
||||
] if ;
|
||||
|
||||
M: bitmap-node >alist% ( node -- ) nodes>> >alist-each% ;
|
||||
|
|
|
|||
|
|
@ -15,20 +15,18 @@ 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? [
|
||||
[let | idx [ key hashcode collision-node find-index drop ] |
|
||||
key hashcode collision-node find-index drop :> idx
|
||||
idx [
|
||||
idx collision-node leaves>> smash [
|
||||
collision-node hashcode>>
|
||||
<collision-node>
|
||||
] when
|
||||
] [ collision-node ] if
|
||||
]
|
||||
] [ collision-node ] if ;
|
||||
|
||||
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
|
||||
[let | leaf-node [ ] idx [ ] |
|
||||
key hashcode collision-node find-index :> ( idx leaf-node )
|
||||
idx [
|
||||
value leaf-node value>> = [
|
||||
collision-node f
|
||||
|
|
@ -42,16 +40,14 @@ M:: collision-node (new-at) ( shift value key hashcode collision-node -- node' a
|
|||
f
|
||||
] if
|
||||
] [
|
||||
[let | new-leaf-node [ value key hashcode <leaf-node> ] |
|
||||
value key hashcode <leaf-node> :> new-leaf-node
|
||||
hashcode
|
||||
collision-node leaves>>
|
||||
new-leaf-node
|
||||
suffix
|
||||
<collision-node>
|
||||
new-leaf-node
|
||||
]
|
||||
] if
|
||||
]
|
||||
] [
|
||||
shift collision-node value key hashcode make-bitmap-node
|
||||
] if ;
|
||||
|
|
|
|||
|
|
@ -8,24 +8,23 @@ persistent.hashtables.nodes ;
|
|||
IN: persistent.hashtables.nodes.full
|
||||
|
||||
M:: full-node (new-at) ( shift value key hashcode full-node -- node' added-leaf )
|
||||
[let* | nodes [ full-node nodes>> ]
|
||||
idx [ hashcode full-node shift>> mask ]
|
||||
n [ idx nodes nth-unsafe ] |
|
||||
shift radix-bits + value key hashcode n (new-at)
|
||||
[let | new-leaf [ ] n' [ ] |
|
||||
full-node nodes>> :> nodes
|
||||
hashcode full-node shift>> mask :> idx
|
||||
idx nodes nth-unsafe :> n
|
||||
|
||||
shift radix-bits + value key hashcode n (new-at) :> ( n' new-leaf )
|
||||
n n' eq? [
|
||||
full-node
|
||||
] [
|
||||
n' idx nodes new-nth shift <full-node>
|
||||
] if
|
||||
new-leaf
|
||||
]
|
||||
] ;
|
||||
new-leaf ;
|
||||
|
||||
M:: full-node (pluck-at) ( key hashcode full-node -- node' )
|
||||
[let* | idx [ hashcode full-node shift>> mask ]
|
||||
n [ idx full-node nodes>> nth ]
|
||||
n' [ key hashcode n (pluck-at) ] |
|
||||
hashcode full-node shift>> mask :> idx
|
||||
idx full-node nodes>> nth :> n
|
||||
key hashcode n (pluck-at) :> n'
|
||||
|
||||
n n' eq? [
|
||||
full-node
|
||||
] [
|
||||
|
|
@ -39,8 +38,7 @@ M:: full-node (pluck-at) ( key hashcode full-node -- node' )
|
|||
full-node shift>>
|
||||
<bitmap-node>
|
||||
] if
|
||||
] if
|
||||
] ;
|
||||
] if ;
|
||||
|
||||
M:: full-node (entry-at) ( key hashcode full-node -- node' )
|
||||
key hashcode
|
||||
|
|
|
|||
|
|
@ -19,10 +19,9 @@ 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
|
||||
] [
|
||||
[let | new-leaf [ value key hashcode <leaf-node> ] |
|
||||
value key hashcode <leaf-node> :> new-leaf
|
||||
hashcode leaf-node new-leaf 2array <collision-node>
|
||||
new-leaf
|
||||
]
|
||||
] if
|
||||
] [ shift leaf-node value key hashcode make-bitmap-node ] if ;
|
||||
|
||||
|
|
|
|||
|
|
@ -46,7 +46,7 @@ GENERIC: nfa-node ( node -- start-state end-state )
|
|||
epsilon nfa-table get add-transition ;
|
||||
|
||||
M:: star nfa-node ( node -- start end )
|
||||
node term>> nfa-node :> s1 :> s0
|
||||
node term>> nfa-node :> ( s0 s1 )
|
||||
next-state :> s2
|
||||
next-state :> s3
|
||||
s1 s0 epsilon-transition
|
||||
|
|
|
|||
|
|
@ -192,17 +192,17 @@ M: bad-executable summary
|
|||
|
||||
\ load-local [ infer-load-local ] "special" set-word-prop
|
||||
|
||||
: infer-get-local ( -- )
|
||||
[let* | n [ pop-literal nip 1 swap - ]
|
||||
in-r [ n consume-r ]
|
||||
out-d [ in-r first copy-value 1array ]
|
||||
out-r [ in-r copy-values ] |
|
||||
:: 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
|
||||
|
||||
out-d output-d
|
||||
out-r output-r
|
||||
f out-d in-r out-r
|
||||
out-r in-r zip out-d first in-r first 2array suffix
|
||||
#shuffle,
|
||||
] ;
|
||||
#shuffle, ;
|
||||
|
||||
\ get-local [ infer-get-local ] "special" set-word-prop
|
||||
|
||||
|
|
|
|||
|
|
@ -32,13 +32,12 @@ yield
|
|||
[ [ 3 throw ] "A" suspend ] [ 3 = ] must-fail-with
|
||||
|
||||
:: spawn-namespace-test ( -- ? )
|
||||
[let | p [ <promise> ] g [ gensym ] |
|
||||
<promise> :> p gensym :> g
|
||||
[
|
||||
g "x" set
|
||||
[ "x" get p fulfill ] "B" spawn drop
|
||||
] with-scope
|
||||
p ?promise g eq?
|
||||
] ;
|
||||
p ?promise g eq? ;
|
||||
|
||||
[ t ] [ spawn-namespace-test ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@ namespaces namespaces.private assocs accessors ;
|
|||
IN: tools.walker.debug
|
||||
|
||||
:: test-walker ( quot -- data )
|
||||
[let | p [ <promise> ] |
|
||||
<promise> :> p
|
||||
[
|
||||
H{ } clone >n
|
||||
|
||||
|
|
@ -27,5 +27,4 @@ IN: tools.walker.debug
|
|||
|
||||
p ?promise
|
||||
variables>> walker-continuation swap at
|
||||
value>> data>>
|
||||
] ;
|
||||
value>> data>> ;
|
||||
|
|
|
|||
|
|
@ -76,10 +76,9 @@ ducet insert-helpers
|
|||
drop [ 0 ] unless* tail-slice ;
|
||||
|
||||
:: ?combine ( char slice i -- ? )
|
||||
[let | str [ i slice nth char suffix ] |
|
||||
i slice nth char suffix :> str
|
||||
str ducet key? dup
|
||||
[ str i slice set-nth ] when
|
||||
] ;
|
||||
[ str i slice set-nth ] when ;
|
||||
|
||||
: add ( char -- )
|
||||
dup blocked? [ 1string , ] [
|
||||
|
|
|
|||
|
|
@ -48,8 +48,8 @@ ERROR: unix-error errno message ;
|
|||
ERROR: unix-system-call-error args errno message word ;
|
||||
|
||||
MACRO:: unix-system-call ( quot -- )
|
||||
[let | n [ quot infer in>> ]
|
||||
word [ quot first ] |
|
||||
quot infer in>> :> n
|
||||
quot first :> word
|
||||
[
|
||||
n ndup quot call dup 0 < [
|
||||
drop
|
||||
|
|
@ -59,7 +59,6 @@ MACRO:: unix-system-call ( quot -- )
|
|||
] [
|
||||
n nnip
|
||||
] if
|
||||
]
|
||||
] ;
|
||||
|
||||
HOOK: open-file os ( path flags mode -- fd )
|
||||
|
|
|
|||
|
|
@ -56,13 +56,12 @@ M: array array-base-type first ;
|
|||
DIOBJECTDATAFORMAT <struct-boa> ;
|
||||
|
||||
:: make-DIOBJECTDATAFORMAT-array ( struct array -- alien )
|
||||
[let | alien [ array length malloc-DIOBJECTDATAFORMAT-array ] |
|
||||
array length malloc-DIOBJECTDATAFORMAT-array :> alien
|
||||
array [| args i |
|
||||
struct args <DIOBJECTDATAFORMAT>
|
||||
i alien set-nth
|
||||
] each-index
|
||||
alien
|
||||
] ;
|
||||
alien ;
|
||||
|
||||
: <DIDATAFORMAT> ( dwFlags dwDataSize struct rgodf-array -- alien )
|
||||
[ DIDATAFORMAT heap-size DIOBJECTDATAFORMAT heap-size ] 4 ndip
|
||||
|
|
|
|||
|
|
@ -74,12 +74,12 @@ $nl
|
|||
"Here is an example of the locals version:"
|
||||
{ $example
|
||||
"""USING: locals urls xml.syntax xml.writer ;
|
||||
[let |
|
||||
number [ 3 ]
|
||||
false [ f ]
|
||||
url [ URL" http://factorcode.org/" ]
|
||||
string [ "hello" ]
|
||||
word [ \\ drop ] |
|
||||
[let
|
||||
3 :> number
|
||||
f :> false
|
||||
URL" http://factorcode.org/" :> url
|
||||
"hello" :> string
|
||||
\\ drop :> word
|
||||
<XML
|
||||
<x
|
||||
number=<-number->
|
||||
|
|
|
|||
|
|
@ -54,8 +54,7 @@ XML-NS: foo http://blah.com
|
|||
y
|
||||
<foo/>
|
||||
</x>""" ] [
|
||||
[let* | a [ "one" ] c [ "two" ] x [ "y" ]
|
||||
d [ [XML <-x-> <foo/> XML] ] |
|
||||
[let "one" :> a "two" :> c "y" :> x [XML <-x-> <foo/> XML] :> d
|
||||
<XML
|
||||
<x> <-a-> <b val=<-c->/> <-d-> </x>
|
||||
XML> pprint-xml>string
|
||||
|
|
|
|||
|
|
@ -7,9 +7,9 @@ IN: benchmark.beust2
|
|||
|
||||
:: (count-numbers) ( remaining first value used max listener: ( -- ) -- ? )
|
||||
10 first - iota [| i |
|
||||
[let* | digit [ i first + ]
|
||||
mask [ digit 2^ ]
|
||||
value' [ i value + ] |
|
||||
i first + :> digit
|
||||
digit 2^ :> mask
|
||||
i value + :> value'
|
||||
used mask bitand zero? [
|
||||
value max > [ t ] [
|
||||
remaining 1 <= [
|
||||
|
|
@ -25,7 +25,6 @@ IN: benchmark.beust2
|
|||
] if
|
||||
] if
|
||||
] [ f ] if
|
||||
]
|
||||
] any? ; inline recursive
|
||||
|
||||
:: count-numbers ( max listener -- )
|
||||
|
|
@ -33,9 +32,8 @@ IN: benchmark.beust2
|
|||
inline
|
||||
|
||||
:: beust ( -- )
|
||||
[let | i! [ 0 ] |
|
||||
0 :> i!
|
||||
5000000000 [ i 1 + i! ] count-numbers
|
||||
i number>string " unique numbers." append print
|
||||
] ;
|
||||
i number>string " unique numbers." append print ;
|
||||
|
||||
MAIN: beust
|
||||
|
|
|
|||
|
|
@ -71,37 +71,35 @@ CONSTANT: homo-sapiens
|
|||
[ make-random-fasta ] 2curry split-lines ; inline
|
||||
|
||||
:: make-repeat-fasta ( k len alu -- k' )
|
||||
[let | kn [ alu length ] |
|
||||
alu length :> kn
|
||||
len [ k + kn mod alu nth-unsafe ] "" map-as print
|
||||
k len +
|
||||
] ; inline
|
||||
k len + ; inline
|
||||
|
||||
: write-repeat-fasta ( n alu desc id -- )
|
||||
write-description
|
||||
[let | k! [ 0 ] alu [ ] |
|
||||
[let
|
||||
:> alu
|
||||
0 :> k!
|
||||
[| len | k len alu make-repeat-fasta k! ] split-lines
|
||||
] ; inline
|
||||
|
||||
: fasta ( n out -- )
|
||||
homo-sapiens make-cumulative
|
||||
IUB make-cumulative
|
||||
[let | homo-sapiens-floats [ ]
|
||||
homo-sapiens-chars [ ]
|
||||
IUB-floats [ ]
|
||||
IUB-chars [ ]
|
||||
out [ ]
|
||||
n [ ]
|
||||
seed [ initial-seed ] |
|
||||
[let
|
||||
:> ( n out IUB-chars IUB-floats homo-sapiens-chars homo-sapiens-floats )
|
||||
initial-seed :> seed
|
||||
|
||||
out ascii [
|
||||
n 2 * ALU "Homo sapiens alu" "ONE" write-repeat-fasta
|
||||
|
||||
initial-seed
|
||||
n 3 * homo-sapiens-chars homo-sapiens-floats "IUB ambiguity codes" "TWO" write-random-fasta
|
||||
n 5 * IUB-chars IUB-floats "Homo sapiens frequency" "THREE" write-random-fasta
|
||||
n 3 * homo-sapiens-chars homo-sapiens-floats
|
||||
"IUB ambiguity codes" "TWO" write-random-fasta
|
||||
n 5 * IUB-chars IUB-floats
|
||||
"Homo sapiens frequency" "THREE" write-random-fasta
|
||||
drop
|
||||
] with-file-writer
|
||||
|
||||
] ;
|
||||
|
||||
: run-fasta ( -- ) 2500000 reverse-complement-in fasta ;
|
||||
|
|
|
|||
|
|
@ -17,10 +17,10 @@ STRUCT: yuv_buffer
|
|||
{ v void* } ;
|
||||
|
||||
:: fake-data ( -- rgb yuv )
|
||||
[let* | w [ 1600 ]
|
||||
h [ 1200 ]
|
||||
buffer [ yuv_buffer <struct> ]
|
||||
rgb [ w h * 3 * <byte-array> ] |
|
||||
1600 :> w
|
||||
1200 :> h
|
||||
yuv_buffer <struct> :> buffer
|
||||
w h * 3 * <byte-array> :> rgb
|
||||
rgb buffer
|
||||
w >>y_width
|
||||
h >>y_height
|
||||
|
|
@ -29,8 +29,7 @@ STRUCT: yuv_buffer
|
|||
w >>uv_stride
|
||||
w h * [ dup * ] B{ } map-as malloc-byte-array &free >>y
|
||||
w h * 2/ [ dup dup * * ] B{ } map-as malloc-byte-array &free >>u
|
||||
w h * 2/ [ dup * dup * ] B{ } map-as malloc-byte-array &free >>v
|
||||
] ;
|
||||
w h * 2/ [ dup * dup * ] B{ } map-as malloc-byte-array &free >>v ;
|
||||
|
||||
: clamp ( n -- n )
|
||||
255 min 0 max ; inline
|
||||
|
|
|
|||
|
|
@ -61,37 +61,33 @@ CONSTANT: AES_BLOCK_SIZE 16
|
|||
bitor bitor bitor 32 bits ;
|
||||
|
||||
:: set-t ( T i -- )
|
||||
[let* |
|
||||
a1 [ i sbox nth ]
|
||||
a2 [ a1 xtime ]
|
||||
a3 [ a1 a2 bitxor ] |
|
||||
i sbox nth :> a1
|
||||
a1 xtime :> a2
|
||||
a1 a2 bitxor :> a3
|
||||
|
||||
a2 a1 a1 a3 ui32 i T set-nth
|
||||
a3 a2 a1 a1 ui32 i HEX: 100 + T set-nth
|
||||
a1 a3 a2 a1 ui32 i HEX: 200 + T set-nth
|
||||
a1 a1 a3 a2 ui32 i HEX: 300 + T set-nth
|
||||
] ;
|
||||
|
||||
a1 a1 a3 a2 ui32 i HEX: 300 + T set-nth ;
|
||||
|
||||
MEMO:: t-table ( -- array )
|
||||
1024 0 <array>
|
||||
dup 256 [ set-t ] with each ;
|
||||
|
||||
:: set-d ( D i -- )
|
||||
[let* |
|
||||
a1 [ i inv-sbox nth ]
|
||||
a2 [ a1 xtime ]
|
||||
a4 [ a2 xtime ]
|
||||
a8 [ a4 xtime ]
|
||||
a9 [ a8 a1 bitxor ]
|
||||
ab [ a9 a2 bitxor ]
|
||||
ad [ a9 a4 bitxor ]
|
||||
ae [ a8 a4 a2 bitxor bitxor ]
|
||||
|
|
||||
i inv-sbox nth :> a1
|
||||
a1 xtime :> a2
|
||||
a2 xtime :> a4
|
||||
a4 xtime :> a8
|
||||
a8 a1 bitxor :> a9
|
||||
a9 a2 bitxor :> ab
|
||||
a9 a4 bitxor :> ad
|
||||
a8 a4 a2 bitxor bitxor :> ae
|
||||
|
||||
ae a9 ad ab ui32 i D set-nth
|
||||
ab ae a9 ad ui32 i HEX: 100 + D set-nth
|
||||
ad ab ae a9 ui32 i HEX: 200 + D set-nth
|
||||
a9 ad ab ae ui32 i HEX: 300 + D set-nth
|
||||
] ;
|
||||
a9 ad ab ae ui32 i HEX: 300 + D set-nth ;
|
||||
|
||||
MEMO:: d-table ( -- array )
|
||||
1024 0 <array>
|
||||
|
|
|
|||
|
|
@ -17,15 +17,16 @@ IN: crypto.passwd-md5
|
|||
PRIVATE>
|
||||
|
||||
:: passwd-md5 ( magic salt password -- bytes )
|
||||
[let* | final! [ password magic salt 3append
|
||||
password magic salt 3append
|
||||
salt password tuck 3append md5 checksum-bytes
|
||||
password length
|
||||
[ 16 / ceiling swap <repetition> concat ] keep
|
||||
head-slice append
|
||||
password [ length make-bits ] [ first ] bi
|
||||
'[ CHAR: \0 _ ? ] "" map-as append
|
||||
md5 checksum-bytes ] |
|
||||
1000 [
|
||||
md5 checksum-bytes :> final!
|
||||
|
||||
1000 iota [
|
||||
"" swap
|
||||
{
|
||||
[ 0 bit? password final ? append ]
|
||||
|
|
@ -38,7 +39,7 @@ PRIVATE>
|
|||
magic salt "$" 3append
|
||||
{ 12 0 6 13 1 7 14 2 8 15 3 9 5 4 10 } final nths 3 group
|
||||
[ first3 [ 16 shift ] [ 8 shift ] bi* + + 4 to64 ] map concat
|
||||
11 final nth 2 to64 3append ] ;
|
||||
11 final nth 2 to64 3append ;
|
||||
|
||||
: parse-shadow-password ( string -- magic salt password )
|
||||
"$" split harvest first3 [ "$" tuck 3append ] 2dip ;
|
||||
|
|
|
|||
|
|
@ -75,8 +75,8 @@ M: decimal before?
|
|||
|
||||
:: D/ ( D1 D2 a -- D3 )
|
||||
D1 D2 guard-decimals 2drop
|
||||
D1 >decimal< :> e1 :> m1
|
||||
D2 >decimal< :> e2 :> m2
|
||||
D1 >decimal< :> ( m1 e1 )
|
||||
D2 >decimal< :> ( m2 e2 )
|
||||
m1 a 10^ *
|
||||
m2 /i
|
||||
|
||||
|
|
|
|||
|
|
@ -189,7 +189,7 @@ CONSTANT: galois-slides
|
|||
}
|
||||
{ $slide "Locals and lexical scope"
|
||||
{ "Define lambda words with " { $link POSTPONE: :: } }
|
||||
{ "Establish bindings with " { $link POSTPONE: [let } " and " { $link POSTPONE: [let* } }
|
||||
{ "Establish bindings with " { $link POSTPONE: [let } " and " { $snippet "[let*" } }
|
||||
"Mutable bindings with correct semantics"
|
||||
{ "Named inputs for quotations with " { $link POSTPONE: [| } }
|
||||
"Full closures"
|
||||
|
|
|
|||
|
|
@ -272,7 +272,7 @@ CONSTANT: google-slides
|
|||
}
|
||||
{ $slide "Locals and lexical scope"
|
||||
{ "Define lambda words with " { $link POSTPONE: :: } }
|
||||
{ "Establish bindings with " { $link POSTPONE: [let } " and " { $link POSTPONE: [let* } }
|
||||
{ "Establish bindings with " { $link POSTPONE: [let } " and " { $snippet "[let*" } }
|
||||
"Mutable bindings with correct semantics"
|
||||
{ "Named inputs for quotations with " { $link POSTPONE: [| } }
|
||||
"Full closures"
|
||||
|
|
|
|||
|
|
@ -332,13 +332,13 @@ DEFER: [bind-uniform-tuple]
|
|||
] [
|
||||
{ [ ] }
|
||||
name "." append 1array
|
||||
] if* :> name-prefixes :> quot-prefixes
|
||||
] if* :> ( quot-prefixes name-prefixes )
|
||||
type all-uniform-tuple-slots :> uniforms
|
||||
|
||||
texture-unit quot-prefixes name-prefixes [| quot-prefix name-prefix |
|
||||
uniforms name-prefix [bind-uniform-tuple]
|
||||
quot-prefix prepend
|
||||
] 2map :> value-cleave :> texture-unit'
|
||||
] 2map :> ( texture-unit' value-cleave )
|
||||
|
||||
texture-unit'
|
||||
value>>-quot { value-cleave 2cleave } append ;
|
||||
|
|
@ -356,7 +356,7 @@ DEFER: [bind-uniform-tuple]
|
|||
} cond ;
|
||||
|
||||
:: [bind-uniform-tuple] ( texture-unit uniforms prefix -- texture-unit' quot )
|
||||
texture-unit uniforms [ prefix [bind-uniform] ] map :> uniforms-cleave :> texture-unit'
|
||||
texture-unit uniforms [ prefix [bind-uniform] ] map :> ( texture-unit' uniforms-cleave )
|
||||
|
||||
texture-unit'
|
||||
{ uniforms-cleave 2cleave } >quotation ;
|
||||
|
|
|
|||
|
|
@ -26,11 +26,11 @@ CONSTANT: fill-value 255
|
|||
] B{ } map-as ;
|
||||
|
||||
:: permute ( bytes src-order dst-order -- new-bytes )
|
||||
[let | src [ src-order name>> ]
|
||||
dst [ dst-order name>> ] |
|
||||
src-order name>> :> src
|
||||
dst-order name>> :> dst
|
||||
bytes src length group
|
||||
[ pad4 src dst permutation shuffle dst length head ]
|
||||
map concat ] ;
|
||||
map concat ;
|
||||
|
||||
: (reorder-components) ( image src-order dest-order -- image )
|
||||
[ permute ] 2curry change-bitmap ;
|
||||
|
|
|
|||
|
|
@ -25,25 +25,10 @@ HELP: [infix
|
|||
}
|
||||
} ;
|
||||
|
||||
HELP: [infix|
|
||||
{ $syntax "[infix| binding1 [ value1... ]\n binding2 [ value2... ]\n ... |\n infix-expression infix]" }
|
||||
{ $description "Introduces a set of lexical bindings and evaluates the body as a snippet of infix code. The values are evaluated in parallel, and may not refer to other bindings within the same " { $link POSTPONE: [infix| } " form, as it is based on " { $link POSTPONE: [let } "." }
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: infix prettyprint ;"
|
||||
"IN: scratchpad"
|
||||
"[infix| pi [ 3.14 ] r [ 12 ] | r*r*pi infix] ."
|
||||
"452.16"
|
||||
}
|
||||
} ;
|
||||
|
||||
{ POSTPONE: [infix POSTPONE: [infix| } related-words
|
||||
|
||||
ARTICLE: "infix" "Infix notation"
|
||||
"The " { $vocab-link "infix" } " vocabulary implements support for infix notation in Factor source code."
|
||||
{ $subsections
|
||||
POSTPONE: [infix
|
||||
POSTPONE: [infix|
|
||||
}
|
||||
$nl
|
||||
"The usual infix math operators are supported:"
|
||||
|
|
@ -76,8 +61,8 @@ $nl
|
|||
$nl
|
||||
"You can access " { $vocab-link "sequences" } " inside infix expressions with the familiar " { $snippet "arr[index]" } " notation."
|
||||
{ $example
|
||||
"USING: arrays infix ;"
|
||||
"[infix| myarr [ { 1 2 3 4 } ] | myarr[4/2]*3 infix] ."
|
||||
"USING: arrays locals infix ;"
|
||||
"[let { 1 2 3 4 } :> myarr [infix myarr[4/2]*3 infix] ] ."
|
||||
"9"
|
||||
}
|
||||
"Please note: in Factor " { $emphasis "fixnums are sequences too." } " If you are not careful with sequence accesses you may introduce subtle bugs:"
|
||||
|
|
|
|||
|
|
@ -13,17 +13,6 @@ IN: infix.tests
|
|||
-5*
|
||||
0 infix] ] unit-test
|
||||
|
||||
[ 452.16 ] [ [infix| r [ 12 ] pi [ 3.14 ] |
|
||||
r*r*pi infix] ] unit-test
|
||||
[ 0 ] [ [infix| a [ 3 ] | 0 infix] ] unit-test
|
||||
[ 4/5 ] [ [infix| x [ 3 ] f [ 12 ] | f/(f+x) infix] ] unit-test
|
||||
[ 144 ] [ [infix| a [ 0 ] b [ 12 ] | b*b-a infix] ] unit-test
|
||||
|
||||
[ 0 ] [ [infix| a [ { 0 1 2 3 } ] | a[0] infix] ] unit-test
|
||||
[ 0 ] [ [infix| a [ { 0 1 2 3 } ] | 3*a[0]*2*a[1] infix] ] unit-test
|
||||
[ 6 ] [ [infix| a [ { 0 1 2 3 } ] | a[0]+a[10%3]+a[3-1]+a[18/6] infix] ] unit-test
|
||||
[ -1 ] [ [infix| a [ { 0 1 2 3 } ] | -a[+1] infix] ] unit-test
|
||||
|
||||
[ 0.0 ] [ [infix sin(0) infix] ] unit-test
|
||||
[ 10 ] [ [infix lcm(2,5) infix] ] unit-test
|
||||
[ 1.0 ] [ [infix +cos(-0*+3) infix] ] unit-test
|
||||
|
|
@ -42,4 +31,4 @@ IN: infix.tests
|
|||
[ t ] [ 5 \ stupid_function check-word ] unit-test
|
||||
[ 10 ] [ [infix stupid_function (0, 1, 2, 3, 4) infix] ] unit-test
|
||||
|
||||
[ -1 ] [ [let | a [ 1 ] | [infix -a infix] ] ] unit-test
|
||||
[ -1 ] [ [let 1 :> a [infix -a infix] ] ] unit-test
|
||||
|
|
|
|||
|
|
@ -83,14 +83,3 @@ PRIVATE>
|
|||
|
||||
SYNTAX: [infix
|
||||
"infix]" [infix-parse suffix! \ call suffix! ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: parse-infix-locals ( assoc end -- quot )
|
||||
'[ _ [infix-parse prepare-operand ] ((parse-lambda)) ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
SYNTAX: [infix|
|
||||
"|" parse-bindings "infix]" parse-infix-locals <let>
|
||||
?rewrite-closures append! ;
|
||||
|
|
|
|||
|
|
@ -101,11 +101,12 @@ CONSTANT: max-speed 30.0
|
|||
] if ;
|
||||
|
||||
:: move-player-on-heading ( d-left player distance heading -- d-left' player )
|
||||
[let* | d-to-move [ d-left distance min ]
|
||||
move-v [ d-to-move heading n*v ] |
|
||||
d-left distance min :> d-to-move
|
||||
d-to-move heading n*v :> move-v
|
||||
|
||||
move-v player location+
|
||||
heading player update-nearest-segment2
|
||||
d-left d-to-move - player ] ;
|
||||
d-left d-to-move - player ;
|
||||
|
||||
: distance-to-move-freely ( player -- distance )
|
||||
[ almost-to-collision ]
|
||||
|
|
|
|||
|
|
@ -107,13 +107,13 @@ CONSTANT: default-segment-radius 1
|
|||
} case ;
|
||||
|
||||
:: distance-to-next-segment ( current next location heading -- distance )
|
||||
[let | cf [ current forward>> ] |
|
||||
cf next location>> v. cf location v. - cf heading v. / ] ;
|
||||
current forward>> :> cf
|
||||
cf next location>> v. cf location v. - cf heading v. / ;
|
||||
|
||||
:: distance-to-next-segment-area ( current next location heading -- distance )
|
||||
[let | cf [ current forward>> ]
|
||||
h [ next current half-way-between-oints ] |
|
||||
cf h v. cf location v. - cf heading v. / ] ;
|
||||
current forward>> :> cf
|
||||
next current half-way-between-oints :> h
|
||||
cf h v. cf location v. - cf heading v. / ;
|
||||
|
||||
: vector-to-centre ( seg loc -- v )
|
||||
over location>> swap v- swap forward>> proj-perp ;
|
||||
|
|
@ -138,10 +138,10 @@ CONSTANT: distant 1000
|
|||
v norm 0 = [
|
||||
distant
|
||||
] [
|
||||
[let* | a [ v dup v. ]
|
||||
b [ v w v. 2 * ]
|
||||
c [ w dup v. r sq - ] |
|
||||
c b a quadratic max-real ]
|
||||
v dup v. :> a
|
||||
v w v. 2 * :> b
|
||||
w dup v. r sq - :> c
|
||||
c b a quadratic max-real
|
||||
] if ;
|
||||
|
||||
: sideways-heading ( oint segment -- v )
|
||||
|
|
|
|||
|
|
@ -33,13 +33,12 @@ M: unix really-delete-tree delete-tree ;
|
|||
'[ drop @ f ] attempt-all drop ; inline
|
||||
|
||||
:: upload-safely ( local username host remote -- )
|
||||
[let* | temp [ remote ".incomplete" append ]
|
||||
scp-remote [ { username "@" host ":" temp } concat ]
|
||||
scp [ scp-command get ]
|
||||
ssh [ ssh-command get ] |
|
||||
remote ".incomplete" append :> temp
|
||||
{ username "@" host ":" temp } concat :> scp-remote
|
||||
scp-command get :> scp
|
||||
ssh-command get :> ssh
|
||||
5 [ { scp local scp-remote } short-running-process ] retry
|
||||
5 [ { ssh host "-l" username "mv" temp remote } short-running-process ] retry
|
||||
] ;
|
||||
5 [ { ssh host "-l" username "mv" temp remote } short-running-process ] retry ;
|
||||
|
||||
: eval-file ( file -- obj )
|
||||
dup utf8 file-lines parse-fresh
|
||||
|
|
|
|||
|
|
@ -35,8 +35,8 @@ M: matrix4 new-sequence 2drop matrix4 (struct) ; inline
|
|||
|
||||
:: 2map-columns ( a b quot -- c )
|
||||
[
|
||||
a columns :> a4 :> a3 :> a2 :> a1
|
||||
b columns :> b4 :> b3 :> b2 :> b1
|
||||
a columns :> ( a1 a2 a3 a4 )
|
||||
b columns :> ( b1 b2 b3 b4 )
|
||||
|
||||
a1 b1 quot call
|
||||
a2 b2 quot call
|
||||
|
|
@ -61,8 +61,8 @@ TYPED: n/m4 ( a: float b: matrix4 -- c: matrix4 ) [ n/v ] with map-columns ;
|
|||
|
||||
TYPED:: m4. ( a: matrix4 b: matrix4 -- c: matrix4 )
|
||||
[
|
||||
a columns :> a4 :> a3 :> a2 :> a1
|
||||
b columns :> b4 :> b3 :> b2 :> b1
|
||||
a columns :> ( a1 a2 a3 a4 )
|
||||
b columns :> ( b1 b2 b3 b4 )
|
||||
|
||||
b1 first a1 n*v :> c1a
|
||||
b2 first a1 n*v :> c2a
|
||||
|
|
@ -86,7 +86,7 @@ TYPED:: m4. ( a: matrix4 b: matrix4 -- c: matrix4 )
|
|||
] make-matrix4 ;
|
||||
|
||||
TYPED:: m4.v ( m: matrix4 v: float-4 -- v': float-4 )
|
||||
m columns :> m4 :> m3 :> m2 :> m1
|
||||
m columns :> ( m1 m2 m3 m4 )
|
||||
|
||||
v first m1 n*v
|
||||
v second m2 n*v v+
|
||||
|
|
|
|||
|
|
@ -123,15 +123,16 @@ CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ;
|
|||
PRIVATE>
|
||||
|
||||
:: verify-nodes ( mdb -- )
|
||||
[ [let* | acc [ V{ } clone ]
|
||||
node1 [ mdb dup master-node [ check-node ] keep ]
|
||||
node2 [ mdb node1 remote>>
|
||||
[
|
||||
V{ } clone :> acc
|
||||
mdb dup master-node [ check-node ] keep :> node1
|
||||
mdb node1 remote>>
|
||||
[ [ check-node ] keep ]
|
||||
[ drop f ] if* ]
|
||||
| node1 [ acc push ] when*
|
||||
[ drop f ] if* :> node2
|
||||
|
||||
node1 [ acc push ] when*
|
||||
node2 [ acc push ] when*
|
||||
mdb acc nodelist>table >>nodes drop
|
||||
]
|
||||
] with-destructors ;
|
||||
|
||||
: mdb-open ( mdb -- mdb-connection )
|
||||
|
|
|
|||
|
|
@ -151,14 +151,16 @@ M: mdb-collection create-collection
|
|||
[ "$cmd" = ] [ "system" head? ] bi or ;
|
||||
|
||||
: check-collection ( collection -- fq-collection )
|
||||
[let* | instance [ mdb-instance ]
|
||||
instance-name [ instance name>> ] |
|
||||
[let
|
||||
mdb-instance :> instance
|
||||
instance name>> :> instance-name
|
||||
dup mdb-collection? [ name>> ] when
|
||||
"." split1 over instance-name =
|
||||
[ nip ] [ drop ] if
|
||||
[ ] [ reserved-namespace? ] bi
|
||||
[ instance (ensure-collection) ] unless
|
||||
[ instance-name ] dip "." glue ] ;
|
||||
[ instance-name ] dip "." glue
|
||||
] ;
|
||||
|
||||
: fix-query-collection ( mdb-query -- mdb-query )
|
||||
[ check-collection ] change-collection ; inline
|
||||
|
|
|
|||
|
|
@ -105,15 +105,14 @@ USE: tools.walker
|
|||
! [ dump-to-file ] keep
|
||||
write flush ; inline
|
||||
|
||||
: build-query-object ( query -- selector )
|
||||
[let | selector [ H{ } clone ] |
|
||||
{ [ orderby>> [ "orderby" selector set-at ] when* ]
|
||||
:: build-query-object ( query -- selector )
|
||||
H{ } clone :> selector
|
||||
query { [ orderby>> [ "orderby" selector set-at ] when* ]
|
||||
[ explain>> [ "$explain" selector set-at ] when* ]
|
||||
[ hint>> [ "$hint" selector set-at ] when* ]
|
||||
[ query>> "query" selector set-at ]
|
||||
} cleave
|
||||
selector
|
||||
] ;
|
||||
selector ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
|
|||
|
|
@ -60,7 +60,7 @@ TUPLE: nurbs-curve
|
|||
|
||||
:: (eval-bases) ( curve t interval values order -- values' )
|
||||
order 2 - curve (knot-constants)>> nth :> all-knot-constants
|
||||
interval order interval + all-knot-constants clip-range :> to :> from
|
||||
interval order interval + all-knot-constants clip-range :> ( from to )
|
||||
from to all-knot-constants subseq :> knot-constants
|
||||
values { 0.0 } { 0.0 } surround 2 <clumps> :> bases
|
||||
|
||||
|
|
|
|||
|
|
@ -33,13 +33,12 @@ IN: project-euler.073
|
|||
<PRIVATE
|
||||
|
||||
:: (euler073) ( counter limit lo hi -- counter' )
|
||||
[let | m [ lo hi mediant ] |
|
||||
lo hi mediant :> m
|
||||
m denominator limit <= [
|
||||
counter 1 +
|
||||
limit lo m (euler073)
|
||||
limit m hi (euler073)
|
||||
] [ counter ] if
|
||||
] ;
|
||||
] [ counter ] if ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
|
|||
|
|
@ -54,7 +54,7 @@ IN: project-euler.150
|
|||
0 1000 [1,b] [ [ next ] replicate partial-sums ] map nip ;
|
||||
|
||||
:: (euler150) ( m -- n )
|
||||
[let | table [ sums-triangle ] |
|
||||
sums-triangle :> table
|
||||
m [| x |
|
||||
x 1 + [| y |
|
||||
m x - [0,b) [| z |
|
||||
|
|
@ -63,8 +63,7 @@ IN: project-euler.150
|
|||
[ y swap nth-unsafe ] bi -
|
||||
] map partial-sum-infimum
|
||||
] map-infimum
|
||||
] map-infimum
|
||||
] ;
|
||||
] map-infimum ;
|
||||
|
||||
HINTS: (euler150) fixnum ;
|
||||
|
||||
|
|
|
|||
|
|
@ -81,8 +81,6 @@ M: wrapper noise wrapped>> noise ;
|
|||
|
||||
M: let noise body>> noise ;
|
||||
|
||||
M: wlet noise body>> noise ;
|
||||
|
||||
M: lambda noise body>> noise ;
|
||||
|
||||
M: object noise drop { 0 0 } ;
|
||||
|
|
|
|||
|
|
@ -49,7 +49,7 @@ M: product-sequence nth
|
|||
product@ nths ;
|
||||
|
||||
:: product-each ( sequences quot -- )
|
||||
sequences start-product-iter :> lengths :> ns
|
||||
sequences start-product-iter :> ( ns lengths )
|
||||
lengths [ 0 = ] any? [
|
||||
[ ns lengths end-product-iter? ]
|
||||
[ ns sequences nths quot call ns lengths product-iter ] until
|
||||
|
|
|
|||
|
|
@ -69,12 +69,12 @@ fetched-in parsed-html links processed-in fetched-at ;
|
|||
|
||||
:: fill-spidered-result ( spider spider-result -- )
|
||||
f spider-result url>> spider spidered>> set-at
|
||||
[ spider-result url>> http-get ] benchmark :> fetched-in :> html :> headers
|
||||
[ spider-result url>> http-get ] benchmark :> ( headers html fetched-in )
|
||||
[
|
||||
html parse-html
|
||||
spider currently-spidering>>
|
||||
over find-all-links normalize-hrefs
|
||||
] benchmark :> processed-in :> links :> parsed-html
|
||||
] benchmark :> ( parsed-html links processed-in )
|
||||
spider-result
|
||||
headers >>headers
|
||||
fetched-in >>fetched-in
|
||||
|
|
|
|||
|
|
@ -12,12 +12,13 @@ IN: ui.gadgets.alerts
|
|||
: alert* ( str -- ) [ ] swap alert ;
|
||||
|
||||
:: ask-user ( string -- model' )
|
||||
[ [let | lbl [ string <label> T{ font { name "sans-serif" } { size 14 } } >>font dup , ]
|
||||
fldm [ <model-field*> ->% 1 ]
|
||||
btn [ "okay" <model-border-btn> ] |
|
||||
[
|
||||
string <label> T{ font { name "sans-serif" } { size 14 } } >>font dup , :> lbl
|
||||
<model-field*> ->% 1 :> fldm
|
||||
"okay" <model-border-btn> :> btn
|
||||
btn -> [ fldm swap updates ]
|
||||
[ [ drop lbl close-window ] $> , ] bi
|
||||
] ] <vbox> { 161 86 } >>pref-dim "" open-window ;
|
||||
] <vbox> { 161 86 } >>pref-dim "" open-window ;
|
||||
|
||||
MACRO: ask-buttons ( buttons -- quot ) dup length [
|
||||
[ swap
|
||||
|
|
|
|||
|
|
@ -209,7 +209,7 @@ CONSTANT: vpri-slides
|
|||
}
|
||||
{ $slide "Locals and lexical scope"
|
||||
{ "Define lambda words with " { $link POSTPONE: :: } }
|
||||
{ "Establish bindings with " { $link POSTPONE: [let } " and " { $link POSTPONE: [let* } }
|
||||
{ "Establish bindings with " { $link POSTPONE: [let } " and " { $snippet "[let*" } }
|
||||
"Mutable bindings with correct semantics"
|
||||
{ "Named inputs for quotations with " { $link POSTPONE: [| } }
|
||||
"Full closures"
|
||||
|
|
|
|||
|
|
@ -3,10 +3,7 @@
|
|||
<plist version="1.0">
|
||||
<dict>
|
||||
<key>content</key>
|
||||
<string>
|
||||
[let | $1 [ $2 ] $3|
|
||||
$0
|
||||
]</string>
|
||||
<string>[let $0 ]</string>
|
||||
<key>name</key>
|
||||
<string>let</string>
|
||||
<key>scope</key>
|
||||
|
|
|
|||
|
|
@ -272,7 +272,7 @@
|
|||
("\\(\n\\| \\);\\_>" (1 ">b"))
|
||||
;; Let and lambda:
|
||||
("\\_<\\(!(\\) .* \\()\\)" (1 "<") (2 ">"))
|
||||
("\\(\\[\\)\\(let\\|wlet\\|let\\*\\)\\( \\|$\\)" (1 "(]"))
|
||||
("\\(\\[\\)\\(let\\|let\\*\\)\\( \\|$\\)" (1 "(]"))
|
||||
("\\(\\[\\)\\(|\\) +[^|]* \\(|\\)" (1 "(]") (2 "(|") (3 ")|"))
|
||||
(" \\(|\\) " (1 "(|"))
|
||||
(" \\(|\\)$" (1 ")"))
|
||||
|
|
|
|||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue