unmaintained/dns/cache/nx/nx.factor unmaintained/dns/cache/rr/rr.factor unmaintained/dns/dns.factor unmaintained/dns/forwarding/forwarding.factor unmaintained/dns/misc/misc.factor unmaintained/dns/resolver/resolver.factor unmaintained/dns/server/server.factor unmaintained/dns/stub/stub.factor unmaintained/dns/util/util.factor @@ -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 )) ; basis/alien/parser/parser.factor @@ -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) basis/bitstreams/bitstreams.factor @@ -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 ) basis/calendar/calendar.factor @@ -25,12 +25,11 @@ IN: channels.examples ] 3keep filter ; :: (sieve) ( prime c -- ) - [let | p [ c from ] - newc [ <channel> ] | - p prime to - [ newc p c filter ] "Filter" spawn drop - prime newc (sieve) - ] ; + c from :> p + <channel> :> newc + p prime to + [ newc p c filter ] "Filter" spawn drop + prime newc (sieve) ; : sieve ( prime -- ) #! Send prime numbers to 'prime' channel basis/channels/examples/examples.factor @@ -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 basis/checksums/hmac/hmac.factor @@ -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 basis/classes/struct/bit-accessors/bit-accessors.factor @@ -22,12 +22,10 @@ IN: compiler.cfg.intrinsics.alien ] [ emit-primitive ] if ; :: inline-alien ( node quot test -- ) - [let | infos [ node node-input-infos ] | - infos test call - [ infos quot call ] - [ node emit-primitive ] - if - ] ; inline + node node-input-infos :> infos + infos test call + [ infos quot call ] + [ node emit-primitive ] if ; inline : inline-alien-getter? ( infos -- ? ) [ first class>> c-ptr class<= ] basis/compiler/cfg/intrinsics/alien/alien.factor @@ -43,17 +43,15 @@ IN: compiler.cfg.intrinsics.allot 2 + cells array ^^allot ; :: emit-<array> ( node -- ) - [let | len [ node node-input-infos first literal>> ] | - len expand-<array>? [ - [let | elt [ ds-pop ] - reg [ len ^^allot-array ] | - ds-drop - len reg array store-length - len reg elt array store-initial-element - reg ds-push - ] - ] [ node emit-primitive ] if - ] ; + node node-input-infos first literal>> :> len + len expand-<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 ; : expand-(byte-array)? ( obj -- ? ) dup integer? [ 0 1024 between? ] [ drop f ] if ; basis/compiler/cfg/intrinsics/allot/allot.factor @@ -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 basis/compiler/cfg/intrinsics/simd/simd.factor @@ -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 basis/compiler/cfg/intrinsics/slots/slots.factor @@ -121,10 +121,9 @@ PRIVATE> PRIVATE> :: live-out? ( vreg node -- ? ) - [let | def [ vreg def-of ] | - { - { [ node def eq? ] [ vreg uses-of def only? not ] } - { [ def node strictly-dominates? ] [ vreg node (live-out?) ] } - [ f ] - } cond - ] ; + vreg def-of :> def + { + { [ node def eq? ] [ vreg uses-of def only? not ] } + { [ def node strictly-dominates? ] [ vreg node (live-out?) ] } + [ f ] + } cond ; basis/compiler/cfg/ssa/liveness/liveness.factor @@ -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 ] | - new-live-outputs - live-outputs - live-outputs - new-live-outputs - drop-values - ] ; + 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-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 new-outputs - [ [ label>> enter-recursive>> ] dip >>in-d drop ] [ >>in-d drop ] 2bi - shuffle - ] ; + 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 ; :: 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 ] | - return - [ new-inputs >>in-d new-outputs >>out-d drop ] - [ drop-dead-outputs ] - bi - ] ; + 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 ; M: #recursive remove-dead-code* ( node -- nodes ) [ drop-recursive-inputs ] basis/compiler/tree/dead-code/recursive/recursive.factor @@ -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 ] | - new-outputs - live-outputs - outputs - new-outputs - drop-values - ] ; + outputs make-values :> new-outputs + outputs filter-live :> live-outputs + new-outputs + live-outputs + outputs + new-outputs + drop-values ; : drop-dead-outputs ( node -- #shuffle ) dup out-d>> drop-dead-values [ in-d>> >>out-d drop ] keep ; basis/compiler/tree/dead-code/simple/simple.factor @@ -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 i1 i2 op assumption is-in-interval - in2 i2 i1 op swap-comparison assumption is-in-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--> basis/compiler/tree/propagation/known-words/known-words.factor @@ -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 destination = [ source ] [ - [let | destination' [ destination assoc compress-path ] | - destination' destination = [ - destination' source assoc set-at - ] unless - destination' - ] - ] if - ] ; + source assoc at :> destination + source destination = [ source ] [ + destination assoc compress-path :> destination' + destination' destination = [ + destination' source assoc set-at + ] unless + destination' + ] if ; basis/compiler/utilities/utilities.factor @@ -5,27 +5,25 @@ 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 - v1 ", " v2 3append pr fulfill - ] "Awaiter" spawn drop + [ + c await + v1 ", " v2 3append pr fulfill + ] "Awaiter" spawn drop - [ - "Goodbye world" ex exchange v1! c count-down - ] "Exchanger 1" spawn drop + [ + "Goodbye world" ex exchange v1! c count-down + ] "Exchanger 1" spawn drop - [ - "Hello world" ex exchange v2! c count-down - ] "Exchanger 2" spawn drop + [ + "Hello world" ex exchange v2! c count-down + ] "Exchanger 2" spawn drop - pr ?promise - ] ; + pr ?promise ; [ "Hello world, Goodbye world" ] [ exchanger-test ] unit-test basis/concurrency/exchangers/exchangers-tests.factor @@ -3,46 +3,41 @@ kernel threads locals accessors calendar ; IN: concurrency.flags.tests :: flag-test-1 ( -- val ) - [let | f [ <flag> ] | - [ f raise-flag ] "Flag test" spawn drop - f lower-flag - f value>> - ] ; + <flag> :> f + [ f raise-flag ] "Flag test" spawn drop + f lower-flag + f value>> ; [ f ] [ flag-test-1 ] unit-test :: flag-test-2 ( -- ? ) - [let | f [ <flag> ] | - [ 1 seconds sleep f raise-flag ] "Flag test" spawn drop - f lower-flag - f value>> - ] ; + <flag> :> f + [ 1 seconds sleep f raise-flag ] "Flag test" spawn drop + f lower-flag + f value>> ; [ f ] [ flag-test-2 ] unit-test :: flag-test-3 ( -- val ) - [let | f [ <flag> ] | - f raise-flag - f value>> - ] ; + <flag> :> f + f raise-flag + f value>> ; [ t ] [ flag-test-3 ] unit-test :: flag-test-4 ( -- val ) - [let | f [ <flag> ] | - [ f raise-flag ] "Flag test" spawn drop - f wait-for-flag - f value>> - ] ; + <flag> :> f + [ f raise-flag ] "Flag test" spawn drop + f wait-for-flag + f value>> ; [ t ] [ flag-test-4 ] unit-test :: flag-test-5 ( -- val ) - [let | f [ <flag> ] | - [ 1 seconds sleep f raise-flag ] "Flag test" spawn drop - f wait-for-flag - f value>> - ] ; + <flag> :> f + [ 1 seconds sleep f raise-flag ] "Flag test" spawn drop + f wait-for-flag + f value>> ; [ t ] [ flag-test-5 ] unit-test basis/concurrency/flags/flags-tests.factor @@ -4,57 +4,55 @@ threads sequences calendar accessors ; IN: concurrency.locks.tests :: lock-test-0 ( -- v ) - [let | v [ V{ } clone ] - c [ 2 <count-down> ] | - - [ - yield - 1 v push - yield - 2 v push - c count-down - ] "Lock test 1" spawn drop - - [ - yield - 3 v push - yield - 4 v push - c count-down - ] "Lock test 2" spawn drop - - c await - v - ] ; + V{ } clone :> v + 2 <count-down> :> c + + [ + yield + 1 v push + yield + 2 v push + c count-down + ] "Lock test 1" spawn drop + + [ + yield + 3 v push + yield + 4 v push + c count-down + ] "Lock test 2" spawn drop + + c await + v ; :: lock-test-1 ( -- v ) - [let | v [ V{ } clone ] - l [ <lock> ] - c [ 2 <count-down> ] | - - [ - l [ - yield - 1 v push - yield - 2 v push - ] with-lock - c count-down - ] "Lock test 1" spawn drop - - [ - l [ - yield - 3 v push - yield - 4 v push - ] with-lock - c count-down - ] "Lock test 2" spawn drop - - c await - v - ] ; + V{ } clone :> v + <lock> :> l + 2 <count-down> :> c + + [ + l [ + yield + 1 v push + yield + 2 v push + ] with-lock + c count-down + ] "Lock test 1" spawn drop + + [ + l [ + yield + 3 v push + yield + 4 v push + ] with-lock + c count-down + ] "Lock test 2" spawn drop + + c await + v ; [ V{ 1 3 2 4 } ] [ lock-test-0 ] unit-test [ V{ 1 2 3 4 } ] [ lock-test-1 ] unit-test @@ -80,98 +78,96 @@ 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 ] | - - [ - l [ - 1 v push - c count-down - yield - 3 v push - ] with-read-lock - c'' count-down - ] "R/W lock test 1" spawn drop - - [ - c await - l [ - 4 v push - 1 seconds sleep - 5 v push - ] with-write-lock - c'' count-down - ] "R/W lock test 2" spawn drop - - [ - c await - l [ - 2 v push - c' count-down - ] with-read-lock - c'' count-down - ] "R/W lock test 4" spawn drop - - [ - c' await - l [ - 6 v push - ] with-write-lock - c'' count-down - ] "R/W lock test 5" spawn drop - - c'' await - v - ] ; + <rw-lock> :> l + 1 <count-down> :> c + 1 <count-down> :> c' + 4 <count-down> :> c'' + V{ } clone :> v + + [ + l [ + 1 v push + c count-down + yield + 3 v push + ] with-read-lock + c'' count-down + ] "R/W lock test 1" spawn drop + + [ + c await + l [ + 4 v push + 1 seconds sleep + 5 v push + ] with-write-lock + c'' count-down + ] "R/W lock test 2" spawn drop + + [ + c await + l [ + 2 v push + c' count-down + ] with-read-lock + c'' count-down + ] "R/W lock test 4" spawn drop + + [ + c' await + l [ + 6 v push + ] with-write-lock + c'' count-down + ] "R/W lock test 5" spawn drop + + c'' await + 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 ] | - - [ - l [ - 1 v push - c count-down - 1 seconds sleep - 2 v push - ] with-write-lock - c' count-down - ] "R/W lock test 1" spawn drop - - [ - c await - l [ - 3 v push - ] with-read-lock - c' count-down - ] "R/W lock test 2" spawn drop - - c' await - v - ] ; + <rw-lock> :> l + 1 <count-down> :> c + 2 <count-down> :> c' + V{ } clone :> v + + [ + l [ + 1 v push + c count-down + 1 seconds sleep + 2 v push + ] with-write-lock + c' count-down + ] "R/W lock test 1" spawn drop + + [ + c await + l [ + 3 v push + ] with-read-lock + c' count-down + ] "R/W lock test 2" spawn drop + + c' await + v ; [ V{ 1 2 3 } ] [ rw-lock-test-2 ] unit-test ! Test lock timeouts :: lock-timeout-test ( -- v ) - [let | l [ <lock> ] | - [ - l [ 1 seconds sleep ] with-lock - ] "Lock holder" spawn drop + <lock> :> l - [ - l 1/10 seconds [ ] with-lock-timeout - ] "Lock timeout-er" spawn-linked drop + [ + l [ 1 seconds sleep ] with-lock + ] "Lock holder" spawn drop + + [ + l 1/10 seconds [ ] with-lock-timeout + ] "Lock timeout-er" spawn-linked drop - receive - ] ; + receive ; [ lock-timeout-test ] [ thread>> name>> "Lock timeout-er" = basis/concurrency/locks/locks-tests.factor @@ -112,35 +112,34 @@ 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 ] - - 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 - - metrics >>metrics - - dim [ - { - [ font dim fill-background ] - [ loc dim line string fill-selection-background ] - [ loc set-text-position ] - [ [ line ] dip CTLineDraw ] - } cleave - ] make-bitmap-image >>image - - metrics loc dim line-loc >>loc - - metrics metrics>dim >>dim - ] + font cache-font :> open-font + string open-font font foreground>> <CTLine> |CFRelease :> line + + 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 + + metrics >>metrics + + dim [ + { + [ font dim fill-background ] + [ loc dim line string fill-selection-background ] + [ loc set-text-position ] + [ [ line ] dip CTLineDraw ] + } cleave + ] make-bitmap-image >>image + + metrics loc dim line-loc >>loc + + metrics metrics>dim >>dim ] with-destructors ; M: line dispose* line>> CFRelease ; basis/core-text/core-text.factor @@ -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 -- ) basis/cpu/ppc/ppc.factor @@ -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 basis/farkup/farkup.factor @@ -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" basis/fry/fry-docs.factor @@ -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 ) basis/functors/functors.factor @@ -23,26 +23,24 @@ GENERIC: new-user ( user provider -- user/f ) ! Password recovery support :: issue-ticket ( email username provider -- user/f ) - [let | user [ username provider get-user ] | - user [ - user email>> length 0 > [ - user email>> email = [ - user - 256 random-bits >hex >>ticket - dup provider update-user - ] [ f ] if + username provider get-user :> user + user [ + user email>> length 0 > [ + user email>> email = [ + user + 256 random-bits >hex >>ticket + dup provider update-user ] [ f ] if ] [ f ] if - ] ; + ] [ f ] if ; :: claim-ticket ( ticket username provider -- user/f ) - [let | user [ username provider get-user ] | - user [ - user ticket>> ticket = [ - user f >>ticket dup provider update-user - ] [ f ] if + username provider get-user :> user + user [ + user ticket>> ticket = [ + user f >>ticket dup provider update-user ] [ f ] if - ] ; + ] [ f ] if ; ! For configuration basis/furnace/auth/providers/providers.factor @@ -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 basis/interpolate/interpolate-tests.factor @@ -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>> { @@ -57,7 +58,7 @@ TUPLE: range ufirst ulast bfirst blast ; [ 2drop ] } case ] [ drop ] if - ] each-element mapping ranges + ] each-element mapping ranges ] ; : unlinear ( num -- bytes ) basis/io/encodings/gb18030/gb18030.factor @@ -125,14 +125,15 @@ concurrency.promises threads unix.process ; ! Killed processes were exiting with code 0 on FreeBSD [ f ] [ - [let | p [ <promise> ] - s [ <promise> ] | - [ - "sleep 1000" run-detached - [ p fulfill ] [ wait-for-process s fulfill ] bi - ] in-thread - - p ?promise handle>> 9 kill drop - s ?promise 0 = + [let + <promise> :> p + <promise> :> s + [ + "sleep 1000" run-detached + [ p fulfill ] [ wait-for-process s fulfill ] bi + ] in-thread + + p ?promise handle>> 9 kill drop + s ?promise 0 = ] ] unit-test basis/io/launcher/unix/unix-tests.factor @@ -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 ] | - { "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 - ] ; + 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 ; TUPLE: win32-mapped-file file mapping ; basis/io/mmap/windows/windows.factor @@ -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 mailbox macosx-monitor new-monitor - dup [ enqueue-notifications ] curry - path 1array 0 0 <event-stream> >>handle - ] ; + path normalize-path :> path + path mailbox macosx-monitor new-monitor + dup [ enqueue-notifications ] curry + path 1array 0 0 <event-stream> >>handle ; M: macosx-monitor dispose* handle>> dispose ; basis/io/monitors/macosx/macosx.factor @@ -35,10 +35,9 @@ TUPLE: openssl-context < secure-context aliens sessions ; [| buf size rwflag password! | password [ B{ 0 } password! ] unless - [let | len [ password strlen ] | - buf password len 1 + size min memcpy - len - ] + password strlen :> len + buf password len 1 + size min memcpy + len ] alien-callback ; : default-pasword ( ctx -- alien ) basis/io/sockets/secure/openssl/openssl.factor @@ -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 basis/io/sockets/unix/unix.factor @@ -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 [| i | - new length - [| j | i j matrix old new step loop-step ] each - ] each matrix ] ; inline + 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 PRIVATE> : levenshtein ( old new -- n ) basis/lcs/lcs.factor @@ -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 ; basis/locals/errors/errors.factor @@ -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 , ; basis/locals/fry/fry.factor @@ -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 +"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 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." } +"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 ] | - b neg disc [ + ] [ - ] 2bi [ 2 a * / ] bi@ - ] ; -1.0 1.0 -6.0 quadratic-roots [ . ] bi@""" +[let 1.0 :> a 1.0 :> b -6.0 :> c + b sq 4 a c * * - sqrt :> disc + b neg disc [ + ] [ - ] 2bi [ 2 a * / ] 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: [| } basis/locals/locals-docs.factor @@ -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 basis/locals/locals-tests.factor @@ -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 ; basis/locals/locals.factor @@ -7,13 +7,11 @@ 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 ; -M: lambda condomize '[ @ ] ; \ No newline at end of file +M: lambda condomize '[ @ ] ; basis/locals/macros/macros.factor @@ -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 @@ -121,4 +87,4 @@ M: lambda-parser parse-quotation ( -- quotation ) [ [ parse-definition ] parse-locals-definition drop - ] with-method-definition ; \ No newline at end of file + ] with-method-definition ; basis/locals/parser/parser.factor @@ -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 ; basis/locals/prettyprint/prettyprint.factor @@ -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 % ; basis/locals/rewrite/sugar/sugar.factor @@ -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 ) basis/locals/types/types.factor @@ -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 basis/math/matrices/matrices.factor @@ -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 basis/math/primes/miller-rabin/miller-rabin.factor @@ -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 basis/math/vectors/conversion/conversion.factor @@ -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 basis/math/vectors/simd/simd-tests.factor @@ -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 basis/models/product/product-tests.factor @@ -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 basis/opengl/opengl.factor @@ -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 ; basis/opengl/textures/textures.factor @@ -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 ; basis/peg/ebnf/ebnf.factor @@ -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,20 +613,19 @@ PRIVATE> ERROR: parse-failed input word ; SYNTAX: PEG: - (:) - [let | effect [ ] def [ ] word [ ] | - [ - [ - [let | compiled-def [ def call compile ] | + [let + (:) :> ( word def effect ) + [ [ - dup compiled-def compiled-parse - [ ast>> ] [ word parse-failed ] ?if - ] - word swap effect define-declared - ] - ] with-compilation-unit - ] append! - ] ; + def call compile :> compiled-def + [ + dup compiled-def compiled-parse + [ ast>> ] [ word parse-failed ] ?if + ] + word swap effect define-declared + ] with-compilation-unit + ] append! + ] ; USING: vocabs vocabs.loader ; basis/peg/peg.factor @@ -10,77 +10,70 @@ 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 bit bitand 0 eq? [ f ] [ - key hashcode - bit bitmap index nodes nth-unsafe - (entry-at) - ] if - ] ; + 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 ; 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 bit bitand 0 eq? [ - [let | new-leaf [ value key hashcode <leaf-node> ] | - bitmap bit bitor - new-leaf idx nodes insert-nth - shift - <bitmap-node> - new-leaf - ] + 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? [ + value key hashcode <leaf-node> :> new-leaf + bitmap bit bitor + new-leaf idx nodes insert-nth + shift + <bitmap-node> + new-leaf + ] [ + idx nodes nth :> n + shift radix-bits + value key hashcode n (new-at) :> ( n' new-leaf ) + n n' eq? [ + bitmap-node ] [ - [let | n [ idx nodes nth ] | - shift radix-bits + value key hashcode n (new-at) - [let | new-leaf [ ] n' [ ] | - n n' eq? [ - bitmap-node - ] [ - bitmap - n' idx nodes new-nth - shift - <bitmap-node> - ] if - new-leaf - ] - ] + bitmap + n' idx nodes new-nth + shift + <bitmap-node> ] if - ] ; + new-leaf + ] 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>> ] | - bit bitmap bitand 0 eq? [ bitmap-node ] [ - [let* | idx [ bit bitmap index ] - n [ idx nodes nth-unsafe ] - n' [ key hashcode n (pluck-at) ] | - n n' eq? [ - bitmap-node - ] [ - n' [ - bitmap - n' idx nodes new-nth - shift - <bitmap-node> - ] [ - bitmap bit eq? [ f ] [ - bitmap bit bitnot bitand - idx nodes remove-nth - shift - <bitmap-node> - ] if - ] if + 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 ] [ + bit bitmap index :> idx + idx nodes nth-unsafe :> n + key hashcode n (pluck-at) :> n' + n n' eq? [ + bitmap-node + ] [ + n' [ + bitmap + n' idx nodes new-nth + shift + <bitmap-node> + ] [ + bitmap bit eq? [ f ] [ + bitmap bit bitnot bitand + idx nodes remove-nth + shift + <bitmap-node> ] if - ] + ] if ] if - ] ; + ] if ; M: bitmap-node >alist% ( node -- ) nodes>> >alist-each% ; basis/persistent/hashtables/nodes/bitmap/bitmap.factor @@ -15,43 +15,39 @@ 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 ] | - idx [ - idx collision-node leaves>> smash [ - collision-node hashcode>> - <collision-node> - ] when - ] [ collision-node ] if - ] + 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 [ ] | - idx [ - value leaf-node value>> = [ - collision-node f - ] [ - hashcode - value key hashcode <leaf-node> - idx - collision-node leaves>> - new-nth - <collision-node> - f - ] if + key hashcode collision-node find-index :> ( idx leaf-node ) + idx [ + value leaf-node value>> = [ + collision-node f ] [ - [let | new-leaf-node [ value key hashcode <leaf-node> ] | - hashcode - collision-node leaves>> - new-leaf-node - suffix - <collision-node> - new-leaf-node - ] + hashcode + value key hashcode <leaf-node> + idx + collision-node leaves>> + new-nth + <collision-node> + f ] if - ] + ] [ + 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 ; basis/persistent/hashtables/nodes/collision/collision.factor @@ -8,39 +8,37 @@ 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' [ ] | - n n' eq? [ - full-node - ] [ - n' idx nodes new-nth shift <full-node> - ] if - new-leaf - ] - ] ; + 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 ; 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) ] | - n n' eq? [ - full-node + hashcode full-node shift>> mask :> idx + idx full-node nodes>> nth :> n + key hashcode n (pluck-at) :> n' + + n n' eq? [ + full-node + ] [ + n' [ + n' idx full-node nodes>> new-nth + full-node shift>> + <full-node> ] [ - n' [ - n' idx full-node nodes>> new-nth - full-node shift>> - <full-node> - ] [ - hashcode full-node shift>> bitpos bitnot full-bitmap-mask bitand - idx full-node nodes>> remove-nth - full-node shift>> - <bitmap-node> - ] if + hashcode full-node shift>> bitpos bitnot full-bitmap-mask bitand + idx full-node nodes>> remove-nth + full-node shift>> + <bitmap-node> ] if - ] ; + ] if ; M:: full-node (entry-at) ( key hashcode full-node -- node' ) key hashcode basis/persistent/hashtables/nodes/full/full.factor @@ -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> ] | - hashcode leaf-node new-leaf 2array <collision-node> - new-leaf - ] + 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 ; basis/persistent/hashtables/nodes/leaf/leaf.factor @@ -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 basis/regexp/nfa/nfa.factor @@ -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 ] | - 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, - ] ; +:: 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, ; \ get-local [ infer-get-local ] "special" set-word-prop basis/stack-checker/known-words/known-words.factor @@ -32,13 +32,12 @@ yield [ [ 3 throw ] "A" suspend ] [ 3 = ] must-fail-with :: spawn-namespace-test ( -- ? ) - [let | p [ <promise> ] g [ gensym ] | - [ - g "x" set - [ "x" get p fulfill ] "B" spawn drop - ] with-scope - p ?promise g eq? - ] ; + <promise> :> p gensym :> g + [ + g "x" set + [ "x" get p fulfill ] "B" spawn drop + ] with-scope + p ?promise g eq? ; [ t ] [ spawn-namespace-test ] unit-test basis/threads/threads-tests.factor @@ -6,26 +6,25 @@ namespaces namespaces.private assocs accessors ; IN: tools.walker.debug :: test-walker ( quot -- data ) - [let | p [ <promise> ] | - [ - H{ } clone >n + <promise> :> p + [ + H{ } clone >n - [ - p promise-fulfilled? - [ drop ] [ p fulfill ] if - 2drop - ] show-walker-hook set + [ + p promise-fulfilled? + [ drop ] [ p fulfill ] if + 2drop + ] show-walker-hook set - break + break - quot call - ] "Walker test" spawn drop + quot call + ] "Walker test" spawn drop - step-into-all - p ?promise - send-synchronous drop + step-into-all + p ?promise + send-synchronous drop - p ?promise - variables>> walker-continuation swap at - value>> data>> - ] ; + p ?promise + variables>> walker-continuation swap at + value>> data>> ; basis/tools/walker/debug/debug.factor @@ -76,10 +76,9 @@ ducet insert-helpers drop [ 0 ] unless* tail-slice ; :: ?combine ( char slice i -- ? ) - [let | str [ i slice nth char suffix ] | - str ducet key? dup - [ str i slice set-nth ] when - ] ; + i slice nth char suffix :> str + str ducet key? dup + [ str i slice set-nth ] when ; : add ( char -- ) dup blocked? [ 1string , ] [ basis/unicode/collation/collation.factor @@ -48,18 +48,17 @@ 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 ] | - [ - n ndup quot call dup 0 < [ - drop - n narray - errno dup strerror - word unix-system-call-error - ] [ - n nnip - ] if - ] + quot infer in>> :> n + quot first :> word + [ + n ndup quot call dup 0 < [ + drop + n narray + errno dup strerror + word unix-system-call-error + ] [ + n nnip + ] if ] ; HOOK: open-file os ( path flags mode -- fd ) basis/unix/unix.factor @@ -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 [| args i | - struct args <DIOBJECTDATAFORMAT> - i alien set-nth - ] each-index - alien - ] ; + array length malloc-DIOBJECTDATAFORMAT-array :> alien + array [| args i | + struct args <DIOBJECTDATAFORMAT> + i alien set-nth + ] each-index + alien ; : <DIDATAFORMAT> ( dwFlags dwDataSize struct rgodf-array -- alien ) [ DIDATAFORMAT heap-size DIOBJECTDATAFORMAT heap-size ] 4 ndip basis/windows/dinput/constants/constants.factor @@ -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-> basis/xml/syntax/syntax-docs.factor @@ -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 basis/xml/syntax/syntax-tests.factor @@ -7,25 +7,24 @@ 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 + ] | - used mask bitand zero? [ - value max > [ t ] [ - remaining 1 <= [ - listener call f - ] [ - remaining 1 - - 0 - value' 10 * - used mask bitor - max - listener - (count-numbers) - ] if + i first + :> digit + digit 2^ :> mask + i value + :> value' + used mask bitand zero? [ + value max > [ t ] [ + remaining 1 <= [ + listener call f + ] [ + remaining 1 - + 0 + value' 10 * + used mask bitor + max + listener + (count-numbers) ] if - ] [ f ] if - ] + ] if + ] [ f ] if ] any? ; inline recursive :: count-numbers ( max listener -- ) @@ -33,9 +32,8 @@ IN: benchmark.beust2 inline :: beust ( -- ) - [let | i! [ 0 ] | - 5000000000 [ i 1 + i! ] count-numbers - i number>string " unique numbers." append print - ] ; + 0 :> i! + 5000000000 [ i 1 + i! ] count-numbers + i number>string " unique numbers." append print ; MAIN: beust extra/benchmark/beust2/beust2.factor @@ -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 ] | - len [ k + kn mod alu nth-unsafe ] "" map-as print - k len + - ] ; inline + alu length :> kn + len [ k + kn mod alu nth-unsafe ] "" map-as print + 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 ; extra/benchmark/fasta/fasta.factor @@ -17,20 +17,19 @@ STRUCT: yuv_buffer { v void* } ; :: fake-data ( -- rgb yuv ) - [let* | w [ 1600 ] - h [ 1200 ] - buffer [ yuv_buffer <struct> ] - rgb [ w h * 3 * <byte-array> ] | - rgb buffer - w >>y_width - h >>y_height - h >>uv_height - w >>y_stride - 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 - ] ; + 1600 :> w + 1200 :> h + yuv_buffer <struct> :> buffer + w h * 3 * <byte-array> :> rgb + rgb buffer + w >>y_width + h >>y_height + h >>uv_height + w >>y_stride + 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 ; : clamp ( n -- n ) 255 min 0 max ; inline extra/benchmark/yuv-to-rgb/yuv-to-rgb.factor @@ -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 ] | - 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 - ] ; + 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 ; 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 ] - | - 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 - ] ; + 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 ; MEMO:: d-table ( -- array ) 1024 0 <array> extra/crypto/aes/aes.factor @@ -17,28 +17,29 @@ IN: crypto.passwd-md5 PRIVATE> :: passwd-md5 ( magic salt password -- bytes ) - [let* | final! [ 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 [ - "" swap - { - [ 0 bit? password final ? append ] - [ 3 mod 0 > [ salt append ] when ] - [ 7 mod 0 > [ password append ] when ] - [ 0 bit? final password ? append ] - } cleave md5 checksum-bytes final! - ] each + 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 :> final! - 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 ] ; + 1000 iota [ + "" swap + { + [ 0 bit? password final ? append ] + [ 3 mod 0 > [ salt append ] when ] + [ 7 mod 0 > [ password append ] when ] + [ 0 bit? final password ? append ] + } cleave md5 checksum-bytes final! + ] each + + 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 ; : parse-shadow-password ( string -- magic salt password ) "$" split harvest first3 [ "$" tuck 3append ] 2dip ; extra/crypto/passwd-md5/passwd-md5.factor @@ -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 extra/decimals/decimals.factor @@ -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" extra/galois-talk/galois-talk.factor @@ -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" extra/google-tech-talk/google-tech-talk.factor @@ -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 ; extra/gpu/render/render.factor @@ -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>> ] | - bytes src length group - [ pad4 src dst permutation shuffle dst length head ] - map concat ] ; + src-order name>> :> src + dst-order name>> :> dst + bytes src length group + [ pad4 src dst permutation shuffle dst length head ] + map concat ; : (reorder-components) ( image src-order dest-order -- image ) [ permute ] 2curry change-bitmap ; extra/images/normalization/normalization.factor @@ -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:" extra/infix/infix-docs.factor @@ -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 extra/infix/infix-tests.factor @@ -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! ; extra/infix/infix.factor @@ -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 ] | - move-v player location+ - heading player update-nearest-segment2 - d-left d-to-move - player ] ; + 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 ; : distance-to-move-freely ( player -- distance ) [ almost-to-collision ] extra/jamshred/player/player.factor @@ -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 ) extra/jamshred/tunnel/tunnel.factor @@ -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 ] | - 5 [ { scp local scp-remote } short-running-process ] retry - 5 [ { ssh host "-l" username "mv" temp remote } short-running-process ] retry - ] ; + 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 ; : eval-file ( file -- obj ) dup utf8 file-lines parse-fresh extra/mason/common/common.factor @@ -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+ extra/math/matrices/simd/simd.factor @@ -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>> - [ [ check-node ] keep ] - [ drop f ] if* ] - | node1 [ acc push ] when* - node2 [ acc push ] when* - mdb acc nodelist>table >>nodes drop - ] + [ + V{ } clone :> acc + mdb dup master-node [ check-node ] keep :> node1 + mdb node1 remote>> + [ [ check-node ] keep ] + [ 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 ) @@ -143,4 +144,4 @@ PRIVATE> [ dispose f ] change-handle drop ; M: mdb-connection dispose - mdb-close ; \ No newline at end of file + mdb-close ; extra/mongodb/connection/connection.factor @@ -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 extra/mongodb/driver/driver.factor @@ -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* ] - [ explain>> [ "$explain" selector set-at ] when* ] - [ hint>> [ "$hint" selector set-at ] when* ] - [ query>> "query" selector set-at ] - } cleave - selector - ] ; +:: 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 ; PRIVATE> extra/mongodb/operations/operations.factor @@ -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 extra/nurbs/nurbs.factor @@ -33,13 +33,12 @@ IN: project-euler.073 <PRIVATE :: (euler073) ( counter limit lo hi -- counter' ) - [let | m [ lo hi mediant ] | - m denominator limit <= [ - counter 1 + - limit lo m (euler073) - limit m hi (euler073) - ] [ counter ] if - ] ; + lo hi mediant :> m + m denominator limit <= [ + counter 1 + + limit lo m (euler073) + limit m hi (euler073) + ] [ counter ] if ; PRIVATE> extra/project-euler/073/073.factor @@ -54,17 +54,16 @@ IN: project-euler.150 0 1000 [1,b] [ [ next ] replicate partial-sums ] map nip ; :: (euler150) ( m -- n ) - [let | table [ sums-triangle ] | - m [| x | - x 1 + [| y | - m x - [0,b) [| z | - x z + table nth-unsafe - [ y z + 1 + swap nth-unsafe ] - [ y swap nth-unsafe ] bi - - ] map partial-sum-infimum - ] map-infimum + sums-triangle :> table + m [| x | + x 1 + [| y | + m x - [0,b) [| z | + x z + table nth-unsafe + [ y z + 1 + swap nth-unsafe ] + [ y swap nth-unsafe ] bi - + ] map partial-sum-infimum ] map-infimum - ] ; + ] map-infimum ; HINTS: (euler150) fixnum ; extra/project-euler/150/150.factor @@ -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 } ; extra/reports/noise/noise.factor @@ -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 extra/sequences/product/product.factor @@ -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 extra/spider/spider.factor @@ -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> ] | - btn -> [ fldm swap updates ] - [ [ drop lbl close-window ] $> , ] bi - ] ] <vbox> { 161 86 } >>pref-dim "" open-window ; + [ + 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 ; MACRO: ask-buttons ( buttons -- quot ) dup length [ [ swap @@ -25,4 +26,4 @@ MACRO: ask-buttons ( buttons -- quot ) dup length [ [ [ <model-border-btn> [ close-window ] >>hook -> ] map ] <hbox> , ] <vbox> "" open-window ] dip firstn - ] 2curry ; \ No newline at end of file + ] 2curry ; extra/ui/gadgets/alerts/alerts.factor @@ -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" extra/vpri-talk/vpri-talk.factor @@ -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> misc/Factor.tmbundle/Snippets/let.tmSnippet @@ -272,7 +272,7 @@ ("\\(\n\\| \\);\\_>" (1 ">b")) ;; Let and lambda: ("\\_<\\(!(\\) .* \\()\\)" (1 "<") (2 ">")) - ("\\(\\[\\)\\(let\\|wlet\\|let\\*\\)\\( \\|$\\)" (1 "(]")) + ("\\(\\[\\)\\(let\\|let\\*\\)\\( \\|$\\)" (1 "(]")) ("\\(\\[\\)\\(|\\) +[^|]* \\(|\\)" (1 "(]") (2 "(|") (3 ")|")) (" \\(|\\) " (1 "(|")) (" \\(|\\)$" (1 ")")) misc/fuel/fuel-syntax.el extra/dns/cache/nx/nx.factor extra/dns/cache/rr/rr.factor extra/dns/dns.factor extra/dns/forwarding/forwarding.factor extra/dns/misc/misc.factor extra/dns/resolver/resolver.factor extra/dns/server/server.factor extra/dns/stub/stub.factor extra/dns/util/util.factor 9ff38fb56c12806a18f5bc4e494b12e07b443dc0 867267e6020904f9f056737f3a167bc5d02a463a Doug Coleman doug.coleman@gmail.com http://github.com/mrjbq7/factor/commit/ff14283c2db9e97928fbe18ff49e3c18ba167c4a ff14283c2db9e97928fbe18ff49e3c18ba167c4a 2009-10-28T15:26:23-07:00 2009-10-28T15:26:23-07:00 Merge branch 'master' of git://factorcode.org/git/factor 8680aab2691462d4d68654c3d077748b9f1d678b Doug Coleman doug.coleman@gmail.com