] if-empty ;
:: [fortran-invoke] ( [args>args] return library function parameters -- [args>args] quot )
- return parameters fortran-sig>c-sig :> c-parameters :> c-return
+ return parameters fortran-sig>c-sig :> ( c-return c-parameters )
function fortran-name>symbol-name :> c-function
[args>args]
c-return library c-function c-parameters \ alien-invoke
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 )) ;
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
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)
:: 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 )
] 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
:: 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
[ 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
] [ 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<= ]
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 ;
[ [ ^^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
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
:: (emit-set-slot-imm) ( infos -- )
ds-drop
- 2inputs :> obj :> src
+ 2inputs :> ( src obj )
infos third literal>> :> slot
infos second value-tag :> tag
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 ;
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
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 ]
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 ;
\ 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-->
: 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 ;
IN: concurrency.exchangers.tests\r
\r
:: exchanger-test ( -- string )\r
- [let |\r
- ex [ <exchanger> ]\r
- c [ 2 <count-down> ]\r
- v1! [ f ]\r
- v2! [ f ]\r
- pr [ <promise> ] |\r
+ <exchanger> :> ex\r
+ 2 <count-down> :> c\r
+ f :> v1!\r
+ f :> v2!\r
+ <promise> :> pr\r
\r
- [\r
- c await\r
- v1 ", " v2 3append pr fulfill\r
- ] "Awaiter" spawn drop\r
+ [\r
+ c await\r
+ v1 ", " v2 3append pr fulfill\r
+ ] "Awaiter" spawn drop\r
\r
- [\r
- "Goodbye world" ex exchange v1! c count-down\r
- ] "Exchanger 1" spawn drop\r
+ [\r
+ "Goodbye world" ex exchange v1! c count-down\r
+ ] "Exchanger 1" spawn drop\r
\r
- [\r
- "Hello world" ex exchange v2! c count-down\r
- ] "Exchanger 2" spawn drop\r
+ [\r
+ "Hello world" ex exchange v2! c count-down\r
+ ] "Exchanger 2" spawn drop\r
\r
- pr ?promise\r
- ] ;\r
+ pr ?promise ;\r
\r
[ "Hello world, Goodbye world" ] [ exchanger-test ] unit-test\r
IN: concurrency.flags.tests\r
\r
:: flag-test-1 ( -- val )\r
- [let | f [ <flag> ] |\r
- [ f raise-flag ] "Flag test" spawn drop\r
- f lower-flag\r
- f value>>\r
- ] ;\r
+ <flag> :> f\r
+ [ f raise-flag ] "Flag test" spawn drop\r
+ f lower-flag\r
+ f value>> ;\r
\r
[ f ] [ flag-test-1 ] unit-test\r
\r
:: flag-test-2 ( -- ? )\r
- [let | f [ <flag> ] |\r
- [ 1 seconds sleep f raise-flag ] "Flag test" spawn drop\r
- f lower-flag\r
- f value>>\r
- ] ;\r
+ <flag> :> f\r
+ [ 1 seconds sleep f raise-flag ] "Flag test" spawn drop\r
+ f lower-flag\r
+ f value>> ;\r
\r
[ f ] [ flag-test-2 ] unit-test\r
\r
:: flag-test-3 ( -- val )\r
- [let | f [ <flag> ] |\r
- f raise-flag\r
- f value>>\r
- ] ;\r
+ <flag> :> f\r
+ f raise-flag\r
+ f value>> ;\r
\r
[ t ] [ flag-test-3 ] unit-test\r
\r
:: flag-test-4 ( -- val )\r
- [let | f [ <flag> ] |\r
- [ f raise-flag ] "Flag test" spawn drop\r
- f wait-for-flag\r
- f value>>\r
- ] ;\r
+ <flag> :> f\r
+ [ f raise-flag ] "Flag test" spawn drop\r
+ f wait-for-flag\r
+ f value>> ;\r
\r
[ t ] [ flag-test-4 ] unit-test\r
\r
:: flag-test-5 ( -- val )\r
- [let | f [ <flag> ] |\r
- [ 1 seconds sleep f raise-flag ] "Flag test" spawn drop\r
- f wait-for-flag\r
- f value>>\r
- ] ;\r
+ <flag> :> f\r
+ [ 1 seconds sleep f raise-flag ] "Flag test" spawn drop\r
+ f wait-for-flag\r
+ f value>> ;\r
\r
[ t ] [ flag-test-5 ] unit-test\r
\r
IN: concurrency.locks.tests\r
\r
:: lock-test-0 ( -- v )\r
- [let | v [ V{ } clone ]\r
- c [ 2 <count-down> ] |\r
-\r
- [\r
- yield\r
- 1 v push\r
- yield\r
- 2 v push\r
- c count-down\r
- ] "Lock test 1" spawn drop\r
-\r
- [\r
- yield\r
- 3 v push\r
- yield\r
- 4 v push\r
- c count-down\r
- ] "Lock test 2" spawn drop\r
-\r
- c await\r
- v\r
- ] ;\r
+ V{ } clone :> v\r
+ 2 <count-down> :> c\r
+\r
+ [\r
+ yield\r
+ 1 v push\r
+ yield\r
+ 2 v push\r
+ c count-down\r
+ ] "Lock test 1" spawn drop\r
+\r
+ [\r
+ yield\r
+ 3 v push\r
+ yield\r
+ 4 v push\r
+ c count-down\r
+ ] "Lock test 2" spawn drop\r
+\r
+ c await\r
+ v ;\r
\r
:: lock-test-1 ( -- v )\r
- [let | v [ V{ } clone ]\r
- l [ <lock> ]\r
- c [ 2 <count-down> ] |\r
-\r
- [\r
- l [\r
- yield\r
- 1 v push\r
- yield\r
- 2 v push\r
- ] with-lock\r
- c count-down\r
- ] "Lock test 1" spawn drop\r
-\r
- [\r
- l [\r
- yield\r
- 3 v push\r
- yield\r
- 4 v push\r
- ] with-lock\r
- c count-down\r
- ] "Lock test 2" spawn drop\r
-\r
- c await\r
- v\r
- ] ;\r
+ V{ } clone :> v\r
+ <lock> :> l\r
+ 2 <count-down> :> c\r
+\r
+ [\r
+ l [\r
+ yield\r
+ 1 v push\r
+ yield\r
+ 2 v push\r
+ ] with-lock\r
+ c count-down\r
+ ] "Lock test 1" spawn drop\r
+\r
+ [\r
+ l [\r
+ yield\r
+ 3 v push\r
+ yield\r
+ 4 v push\r
+ ] with-lock\r
+ c count-down\r
+ ] "Lock test 2" spawn drop\r
+\r
+ c await\r
+ v ;\r
\r
[ V{ 1 3 2 4 } ] [ lock-test-0 ] unit-test\r
[ V{ 1 2 3 4 } ] [ lock-test-1 ] unit-test\r
[ ] [ <rw-lock> dup [ [ ] with-read-lock ] with-write-lock ] unit-test\r
\r
:: rw-lock-test-1 ( -- v )\r
- [let | l [ <rw-lock> ]\r
- c [ 1 <count-down> ]\r
- c' [ 1 <count-down> ]\r
- c'' [ 4 <count-down> ]\r
- v [ V{ } clone ] |\r
-\r
- [\r
- l [\r
- 1 v push\r
- c count-down\r
- yield\r
- 3 v push\r
- ] with-read-lock\r
- c'' count-down\r
- ] "R/W lock test 1" spawn drop\r
-\r
- [\r
- c await\r
- l [\r
- 4 v push\r
- 1 seconds sleep\r
- 5 v push\r
- ] with-write-lock\r
- c'' count-down\r
- ] "R/W lock test 2" spawn drop\r
-\r
- [\r
- c await\r
- l [\r
- 2 v push\r
- c' count-down\r
- ] with-read-lock\r
- c'' count-down\r
- ] "R/W lock test 4" spawn drop\r
-\r
- [\r
- c' await\r
- l [\r
- 6 v push\r
- ] with-write-lock\r
- c'' count-down\r
- ] "R/W lock test 5" spawn drop\r
-\r
- c'' await\r
- v\r
- ] ;\r
+ <rw-lock> :> l\r
+ 1 <count-down> :> c\r
+ 1 <count-down> :> c'\r
+ 4 <count-down> :> c''\r
+ V{ } clone :> v\r
+\r
+ [\r
+ l [\r
+ 1 v push\r
+ c count-down\r
+ yield\r
+ 3 v push\r
+ ] with-read-lock\r
+ c'' count-down\r
+ ] "R/W lock test 1" spawn drop\r
+\r
+ [\r
+ c await\r
+ l [\r
+ 4 v push\r
+ 1 seconds sleep\r
+ 5 v push\r
+ ] with-write-lock\r
+ c'' count-down\r
+ ] "R/W lock test 2" spawn drop\r
+\r
+ [\r
+ c await\r
+ l [\r
+ 2 v push\r
+ c' count-down\r
+ ] with-read-lock\r
+ c'' count-down\r
+ ] "R/W lock test 4" spawn drop\r
+\r
+ [\r
+ c' await\r
+ l [\r
+ 6 v push\r
+ ] with-write-lock\r
+ c'' count-down\r
+ ] "R/W lock test 5" spawn drop\r
+\r
+ c'' await\r
+ v ;\r
\r
[ V{ 1 2 3 4 5 6 } ] [ rw-lock-test-1 ] unit-test\r
\r
:: rw-lock-test-2 ( -- v )\r
- [let | l [ <rw-lock> ]\r
- c [ 1 <count-down> ]\r
- c' [ 2 <count-down> ]\r
- v [ V{ } clone ] |\r
-\r
- [\r
- l [\r
- 1 v push\r
- c count-down\r
- 1 seconds sleep\r
- 2 v push\r
- ] with-write-lock\r
- c' count-down\r
- ] "R/W lock test 1" spawn drop\r
-\r
- [\r
- c await\r
- l [\r
- 3 v push\r
- ] with-read-lock\r
- c' count-down\r
- ] "R/W lock test 2" spawn drop\r
-\r
- c' await\r
- v\r
- ] ;\r
+ <rw-lock> :> l\r
+ 1 <count-down> :> c\r
+ 2 <count-down> :> c'\r
+ V{ } clone :> v\r
+\r
+ [\r
+ l [\r
+ 1 v push\r
+ c count-down\r
+ 1 seconds sleep\r
+ 2 v push\r
+ ] with-write-lock\r
+ c' count-down\r
+ ] "R/W lock test 1" spawn drop\r
+\r
+ [\r
+ c await\r
+ l [\r
+ 3 v push\r
+ ] with-read-lock\r
+ c' count-down\r
+ ] "R/W lock test 2" spawn drop\r
+\r
+ c' await\r
+ v ;\r
\r
[ V{ 1 2 3 } ] [ rw-lock-test-2 ] unit-test\r
\r
! Test lock timeouts\r
:: lock-timeout-test ( -- v )\r
- [let | l [ <lock> ] |\r
- [\r
- l [ 1 seconds sleep ] with-lock\r
- ] "Lock holder" spawn drop\r
+ <lock> :> l\r
\r
- [\r
- l 1/10 seconds [ ] with-lock-timeout\r
- ] "Lock timeout-er" spawn-linked drop\r
+ [\r
+ l [ 1 seconds sleep ] with-lock\r
+ ] "Lock holder" spawn drop\r
+\r
+ [\r
+ l 1/10 seconds [ ] with-lock-timeout\r
+ ] "Lock timeout-er" spawn-linked drop\r
\r
- receive\r
- ] ;\r
+ receive ;\r
\r
[ lock-timeout-test ] [\r
thread>> name>> "Lock timeout-er" =\r
[
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 ;
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 -- )
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 -- )
:: (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
"'[ [ _ key? ] all? ] filter"\r
"[ [ key? ] curry all? ] curry filter"\r
}\r
-"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:"\r
+"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:"\r
{ $code\r
"'[ 3 _ + 4 _ / ]"\r
- "[let | a [ ] b [ ] | [ 3 a + 4 b / ] ]"\r
+ "[| a b | 3 a + 4 b / ]"\r
} ;\r
\r
ARTICLE: "fry" "Fried quotations"\r
! 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
: 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 )
! Password recovery support\r
\r
:: issue-ticket ( email username provider -- user/f )\r
- [let | user [ username provider get-user ] |\r
- user [\r
- user email>> length 0 > [\r
- user email>> email = [\r
- user\r
- 256 random-bits >hex >>ticket\r
- dup provider update-user\r
- ] [ f ] if\r
+ username provider get-user :> user\r
+ user [\r
+ user email>> length 0 > [\r
+ user email>> email = [\r
+ user\r
+ 256 random-bits >hex >>ticket\r
+ dup provider update-user\r
] [ f ] if\r
] [ f ] if\r
- ] ;\r
+ ] [ f ] if ;\r
\r
:: claim-ticket ( ticket username provider -- user/f )\r
- [let | user [ username provider get-user ] |\r
- user [\r
- user ticket>> ticket = [\r
- user f >>ticket dup provider update-user\r
- ] [ f ] if\r
+ username provider get-user :> user\r
+ user [\r
+ user ticket>> ticket = [\r
+ user f >>ticket dup provider update-user\r
] [ f ] if\r
- ] ;\r
+ ] [ f ] if ;\r
\r
! For configuration\r
\r
] 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
] 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>> {
[ 2drop ]
} case
] [ drop ] if
- ] each-element mapping ranges
+ ] each-element mapping ranges
] ;
: unlinear ( num -- bytes )
! 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
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 ;
'[ 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 ;
[| 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 )
[ 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
[ [ + ] curry map ] with map ;\r
\r
:: run-lcs ( old new init step -- matrix )\r
- [let | matrix [ old length 1 + new length 1 + init call ] |\r
- old length [| i |\r
- new length\r
- [| j | i j matrix old new step loop-step ] each\r
- ] each matrix ] ; inline\r
+ old length 1 + new length 1 + init call :> matrix\r
+ old length [| i |\r
+ new length\r
+ [| j | i j matrix old new step loop-step ] each\r
+ ] each matrix ; inline\r
PRIVATE>\r
\r
: levenshtein ( old new -- n )\r
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 ;
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 ;
! 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 ;
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 , ;
{ $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" } "." } ;
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" } "." } ;
"""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"""
}
"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."
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: [| }
[ { 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! ] ;
[ 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
[ ] [ 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
[ ] [ \ 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! | ]" ] [
[ 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 + ;
{ 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 -- ) ;
[ 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
]
] ;
[ 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
]
] ;
[ { 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
[ 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
[ 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
[ 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
[ 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
] 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 ;
{ [ 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
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 ;
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 '[ @ ] ;
(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) ;
[ 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
[
[ parse-definition ]
parse-locals-definition drop
- ] with-method-definition ;
\ No newline at end of file
+ ] with-method-definition ;
: 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 ;
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
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 , ;
M: def rewrite-sugar* , ;
+M: multi-def rewrite-sugar* locals>> <reversed> [ <def> , ] each ;
+
M: hashtable rewrite-sugar* rewrite-element ;
M: wrapper 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 % ;
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
C: <def> def
+TUPLE: multi-def locals ;
+
+C: <multi-def> multi-def
+
PREDICATE: local < word "local?" word-prop ;
: <local> ( name -- word )
:: 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
:: 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 }
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 }
} ;
:: 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 }
[ 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
:: (miller-rabin) ( n trials -- ? )
n 1 - :> n-1
- n-1 factor-2s :> s :> r
+ n-1 factor-2s :> ( r s )
0 :> a!
trials [
drop
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
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
M: an-observer model-changed nip [ 1 + ] change-i drop ;\r
\r
[ 1 0 ] [\r
- [let* | m1 [ 1 <model> ]\r
- m2 [ 2 <model> ]\r
- c [ { m1 m2 } <product> ]\r
- o1 [ an-observer new ]\r
- o2 [ an-observer new ] |\r
+ [let\r
+ 1 <model> :> m1\r
+ 2 <model> :> m2\r
+ { m1 m2 } <product> :> c\r
+ an-observer new :> o1\r
+ an-observer new :> o2\r
\r
o1 m1 add-connection\r
o2 m2 add-connection\r
#! 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 +
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
] 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 ;
drop \r
] [ \r
[\r
- "FROM: locals => [let* ; FROM: sequences => nth ; [let* | " %\r
- dup length swap [\r
- dup ebnf-var? [\r
+ "FROM: locals => [let :> ; FROM: sequences => nth ; [let " %\r
+ dup length [\r
+ over ebnf-var? [\r
+ " " % # " over nth :> " %\r
name>> % \r
- " [ " % # " over nth ] " %\r
] [\r
2drop\r
] if\r
] 2each\r
- " | " %\r
+ " " %\r
% \r
" nip ]" % \r
] "" make \r
\r
M: ebnf-var build-locals ( code ast -- )\r
[\r
- "FROM: locals => [let* ; FROM: kernel => dup nip ; [let* | " %\r
- name>> % " [ dup ] " %\r
- " | " %\r
+ "FROM: locals => [let :> ; FROM: kernel => dup nip ; [let " %\r
+ " dup :> " % name>> %\r
+ " " %\r
% \r
" nip ]" % \r
] "" make ;\r
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? [
] 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
] 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>> [
] [
ans m (>>ans)
ans
- ] if
- ] ; inline
+ ] if ; inline
: apply-memo-rule ( r m -- ast )
[ ans>> ] [ pos>> ] bi pos set
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 ;
: 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% ;
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 ;
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
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 ;
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
\ 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
[ [ 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
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>> ;
drop [ 0 ] unless* tail-slice ;\r
\r
:: ?combine ( char slice i -- ? )\r
- [let | str [ i slice nth char suffix ] |\r
- str ducet key? dup\r
- [ str i slice set-nth ] when\r
- ] ;\r
+ i slice nth char suffix :> str\r
+ str ducet key? dup\r
+ [ str i slice set-nth ] when ;\r
\r
: add ( char -- )\r
dup blocked? [ 1string , ] [\r
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 )
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
"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->
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
:: (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 -- )
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
[ 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 ;
{ 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
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>
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 ;
:: 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
+++ /dev/null
-
-USING: kernel assocs locals combinators
- math math.functions system unicode.case ;
-
-IN: dns.cache.nx
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: nx-cache ( -- table ) H{ } ;
-
-: nx-cache-at ( name -- time ) >lower nx-cache at ;
-: nx-cache-delete-at ( name -- ) >lower nx-cache delete-at ;
-: nx-cache-set-at ( time name -- ) >lower nx-cache set-at ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: now ( -- seconds ) millis 1000.0 / round >integer ;
-
-:: non-existent-name? ( NAME -- ? )
- [let | TIME [ NAME nx-cache-at ] |
- {
- { [ TIME f = ] [ f ] }
- { [ TIME now <= ] [ NAME nx-cache-delete-at f ] }
- { [ t ] [ t ] }
- }
- cond
- ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: cache-non-existent-name ( NAME TTL -- )
- [let | TIME [ TTL now + ] | TIME NAME nx-cache-set-at ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
+++ /dev/null
-
-USING: kernel sequences assocs sets locals combinators
- accessors system math math.functions unicode.case prettyprint
- combinators.smart dns ;
-
-IN: dns.cache.rr
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: <entry> time data ;
-
-: now ( -- seconds ) millis 1000.0 / round >integer ;
-
-: expired? ( <entry> -- ? ) time>> now <= ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: make-cache-key ( obj -- key )
- [ [ name>> >lower ] [ type>> ] [ class>> ] tri ] output>array ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: cache ( -- table ) H{ } ;
-
-: cache-at ( obj -- ent ) make-cache-key cache at ;
-: cache-delete ( obj -- ) make-cache-key cache delete-at ;
-: cache-set-at ( ent obj -- ) make-cache-key cache set-at ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: cache-get ( OBJ -- rrs/f )
- [let | ENT [ OBJ cache-at ] |
- {
- { [ ENT f = ] [ f ] }
- { [ ENT expired? ] [ OBJ cache-delete f ] }
- {
- [ t ]
- [
- [let | NAME [ OBJ name>> ]
- TYPE [ OBJ type>> ]
- CLASS [ OBJ class>> ]
- TTL [ ENT time>> now - ] |
- ENT data>>
- [| RDATA | T{ rr f NAME TYPE CLASS TTL RDATA } ]
- map
- ]
- ]
- }
- }
- cond
- ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: cache-add ( RR -- )
- [let | ENT [ RR cache-at ]
- TIME [ RR ttl>> now + ]
- RDATA [ RR rdata>> ] |
- {
- { [ ENT f = ] [ T{ <entry> f TIME V{ RDATA } } RR cache-set-at ] }
- { [ ENT expired? ] [ RR cache-delete RR cache-add ] }
- { [ t ] [ TIME ENT (>>time) RDATA ENT data>> adjoin ] }
- }
- cond
- ] ;
\ No newline at end of file
+++ /dev/null
-
-USING: kernel byte-arrays combinators strings arrays sequences splitting
- grouping
- math math.functions math.parser random
- destructors
- io io.binary io.sockets io.encodings.binary
- accessors
- combinators.smart
- assocs
- ;
-
-IN: dns
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: query name type class ;
-
-TUPLE: rr name type class ttl rdata ;
-
-TUPLE: hinfo cpu os ;
-
-TUPLE: mx preference exchange ;
-
-TUPLE: soa mname rname serial refresh retry expire minimum ;
-
-TUPLE: message
- id qr opcode aa tc rd ra z rcode
- question-section
- answer-section
- authority-section
- additional-section ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: random-id ( -- id ) 2 16 ^ random ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! TYPE
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOLS: A NS MD MF CNAME SOA MB MG MR NULL WKS PTR HINFO MINFO MX TXT AAAA ;
-
-: type-table ( -- table )
- {
- { A 1 }
- { NS 2 }
- { MD 3 }
- { MF 4 }
- { CNAME 5 }
- { SOA 6 }
- { MB 7 }
- { MG 8 }
- { MR 9 }
- { NULL 10 }
- { WKS 11 }
- { PTR 12 }
- { HINFO 13 }
- { MINFO 14 }
- { MX 15 }
- { TXT 16 }
- { AAAA 28 }
- } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! CLASS
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOLS: IN CS CH HS ;
-
-: class-table ( -- table )
- {
- { IN 1 }
- { CS 2 }
- { CH 3 }
- { HS 4 }
- } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! OPCODE
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOLS: QUERY IQUERY STATUS ;
-
-: opcode-table ( -- table )
- {
- { QUERY 0 }
- { IQUERY 1 }
- { STATUS 2 }
- } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! RCODE
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
- REFUSED ;
-
-: rcode-table ( -- table )
- {
- { NO-ERROR 0 }
- { FORMAT-ERROR 1 }
- { SERVER-FAILURE 2 }
- { NAME-ERROR 3 }
- { NOT-IMPLEMENTED 4 }
- { REFUSED 5 }
- } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: <message> ( -- message )
- message new
- random-id >>id
- 0 >>qr
- QUERY >>opcode
- 0 >>aa
- 0 >>tc
- 1 >>rd
- 0 >>ra
- 0 >>z
- NO-ERROR >>rcode
- { } >>question-section
- { } >>answer-section
- { } >>authority-section
- { } >>additional-section ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: ip->ba ( ip -- ba ) "." split [ string>number ] map >byte-array ;
-
-: ipv6->ba ( ip -- ba ) ":" split [ 16 base> ] map [ 2 >be ] map concat ;
-
-: label->ba ( label -- ba ) [ >byte-array ] [ length ] bi prefix ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: uint8->ba ( n -- ba ) 1 >be ;
-: uint16->ba ( n -- ba ) 2 >be ;
-: uint32->ba ( n -- ba ) 4 >be ;
-: uint64->ba ( n -- ba ) 8 >be ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: dn->ba ( dn -- ba ) "." split [ label->ba ] map concat ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: query->ba ( query -- ba )
- [
- {
- [ name>> dn->ba ]
- [ type>> type-table at uint16->ba ]
- [ class>> class-table at uint16->ba ]
- } cleave
- ] output>array concat ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: hinfo->ba ( rdata -- ba )
- [ cpu>> label->ba ]
- [ os>> label->ba ]
- bi append ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: mx->ba ( rdata -- ba )
- [ preference>> uint16->ba ]
- [ exchange>> dn->ba ]
- bi append ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: soa->ba ( rdata -- ba )
- [
- {
- [ mname>> dn->ba ]
- [ rname>> dn->ba ]
- [ serial>> uint32->ba ]
- [ refresh>> uint32->ba ]
- [ retry>> uint32->ba ]
- [ expire>> uint32->ba ]
- [ minimum>> uint32->ba ]
- } cleave
- ] output>array concat ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: rdata->ba ( type rdata -- ba )
- swap
- {
- { CNAME [ dn->ba ] }
- { HINFO [ hinfo->ba ] }
- { MX [ mx->ba ] }
- { NS [ dn->ba ] }
- { PTR [ dn->ba ] }
- { SOA [ soa->ba ] }
- { A [ ip->ba ] }
- }
- case ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: rr->ba ( rr -- ba )
- [
- {
- [ name>> dn->ba ]
- [ type>> type-table at uint16->ba ]
- [ class>> class-table at uint16->ba ]
- [ ttl>> uint32->ba ]
- [
- [ type>> ] [ rdata>> ] bi rdata->ba
- [ length uint16->ba ] [ ] bi append
- ]
- } cleave
- ] output>array concat ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: header-bits-ba ( message -- ba )
- [
- {
- [ qr>> 15 shift ]
- [ opcode>> opcode-table at 11 shift ]
- [ aa>> 10 shift ]
- [ tc>> 9 shift ]
- [ rd>> 8 shift ]
- [ ra>> 7 shift ]
- [ z>> 4 shift ]
- [ rcode>> rcode-table at 0 shift ]
- } cleave
- ] sum-outputs uint16->ba ;
-
-: message->ba ( message -- ba )
- [
- {
- [ id>> uint16->ba ]
- [ header-bits-ba ]
- [ question-section>> length uint16->ba ]
- [ answer-section>> length uint16->ba ]
- [ authority-section>> length uint16->ba ]
- [ additional-section>> length uint16->ba ]
- [ question-section>> [ query->ba ] map concat ]
- [ answer-section>> [ rr->ba ] map concat ]
- [ authority-section>> [ rr->ba ] map concat ]
- [ additional-section>> [ rr->ba ] map concat ]
- } cleave
- ] output>array concat ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: get-single ( ba i -- n ) at ;
-: get-double ( ba i -- n ) dup 2 + subseq be> ;
-: get-quad ( ba i -- n ) dup 4 + subseq be> ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: label-length ( ba i -- length ) get-single ;
-
-: skip-label ( ba i -- ba i ) 2dup label-length + 1 + ;
-
-: null-label? ( ba i -- ? ) get-single 0 = ;
-
-: get-label ( ba i -- label ) [ 1 + ] [ skip-label nip ] 2bi subseq >string ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: bit-test ( a b -- ? ) bitand 0 = not ;
-
-: pointer? ( ba i -- ? ) get-single BIN: 11000000 bit-test ;
-
-: pointer ( ba i -- val ) get-double BIN: 0011111111111111 bitand ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: skip-name ( ba i -- ba i )
- {
- { [ 2dup null-label? ] [ 1 + ] }
- { [ 2dup pointer? ] [ 2 + ] }
- { [ t ] [ skip-label skip-name ] }
- }
- cond ;
-
-: get-name ( ba i -- name )
- {
- { [ 2dup null-label? ] [ 2drop "" ] }
- { [ 2dup pointer? ] [ dupd pointer get-name ] }
- {
- [ t ]
- [
- [ get-label ]
- [ skip-label get-name ]
- 2bi
- "." glue
- ]
- }
- }
- cond ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: get-query ( ba i -- query )
- [ get-name ]
- [
- skip-name
- [ 0 + get-double type-table value-at ]
- [ 2 + get-double class-table value-at ]
- 2bi
- ]
- 2bi query boa ;
-
-: skip-query ( ba i -- ba i ) skip-name 4 + ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: get-mx ( ba i -- mx ) [ get-double ] [ 2 + get-double ] 2bi mx boa ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: get-soa ( ba i -- soa )
- {
- [ get-name ]
- [ skip-name get-name ]
- [
- skip-name
- skip-name
- {
- [ 0 + get-quad ]
- [ 4 + get-quad ]
- [ 8 + get-quad ]
- [ 12 + get-quad ]
- [ 16 + get-quad ]
- }
- 2cleave
- ]
- }
- 2cleave soa boa ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: get-ip ( ba i -- ip ) dup 4 + subseq >array [ number>string ] map "." join ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: get-ipv6 ( ba i -- ip )
- dup 16 + subseq 2 group [ be> 16 >base ] map ":" join ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: get-rdata ( ba i type -- rdata )
- {
- { CNAME [ get-name ] }
- { NS [ get-name ] }
- { PTR [ get-name ] }
- { MX [ get-mx ] }
- { SOA [ get-soa ] }
- { A [ get-ip ] }
- { AAAA [ get-ipv6 ] }
- }
- case ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: get-rr ( ba i -- rr )
- [ get-name ]
- [
- skip-name
- {
- [ 0 + get-double type-table value-at ]
- [ 2 + get-double class-table value-at ]
- [ 4 + get-quad ]
- [ [ 10 + ] [ get-double type-table value-at ] 2bi get-rdata ]
- }
- 2cleave
- ]
- 2bi rr boa ;
-
-: skip-rr ( ba i -- ba i ) skip-name 8 + 2dup get-double + 2 + ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: get-question-section ( ba i count -- seq ba i )
- [ drop [ skip-query ] [ get-query ] 2bi ] map -rot ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: get-rr-section ( ba i count -- seq ba i )
- [ drop [ skip-rr ] [ get-rr ] 2bi ] map -rot ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: >> ( x n -- y ) neg shift ;
-
-: get-header-bits ( ba i -- qr opcode aa tc rd ra z rcode )
- get-double
- {
- [ 15 >> BIN: 1 bitand ]
- [ 11 >> BIN: 111 bitand opcode-table value-at ]
- [ 10 >> BIN: 1 bitand ]
- [ 9 >> BIN: 1 bitand ]
- [ 8 >> BIN: 1 bitand ]
- [ 7 >> BIN: 1 bitand ]
- [ 4 >> BIN: 111 bitand ]
- [ BIN: 1111 bitand rcode-table value-at ]
- }
- cleave ;
-
-: parse-message ( ba -- message )
- 0
- {
- [ get-double ]
- [ 2 + get-header-bits ]
- [
- 4 +
- {
- [ 8 + ]
- [ 0 + get-double ]
- [ 2 + get-double ]
- [ 4 + get-double ]
- [ 6 + get-double ]
- }
- 2cleave
- {
- [ get-question-section ]
- [ get-rr-section ]
- [ get-rr-section ]
- [ get-rr-section ]
- } spread
- 2drop
- ]
- }
- 2cleave message boa ;
-
-: ba->message ( ba -- message ) parse-message ;
-
-: with-message-bytes ( ba quot -- ) [ ba->message ] dip call message->ba ; inline
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: send-receive-udp ( ba server -- ba )
- f 0 <inet4> <datagram>
- [
- [ send ] [ receive drop ] bi
- ]
- with-disposal ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: send-receive-tcp ( ba server -- ba )
- [ dup length 2 >be prepend ] [ ] bi*
- binary
- [
- write flush
- 2 read be> read
- ]
- with-client ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: >dns-inet4 ( obj -- inet4 )
- dup string?
- [ 53 <inet4> ]
- [ ]
- if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: ask-server ( message server -- message )
- [ message->ba ] [ >dns-inet4 ] bi*
- 2dup
- send-receive-udp parse-message
- dup tc>> 1 =
- [ drop send-receive-tcp parse-message ]
- [ nip nip ]
- if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: dns-servers ( -- seq ) V{ } ;
-
-: dns-server ( -- server ) dns-servers random ;
-
-: ask ( message -- message ) dns-server ask-server ;
-
-: query->message ( query -- message ) <message> swap 1array >>question-section ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: message-query ( message -- query ) question-section>> first ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-ERROR: name-error name ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: fully-qualified ( name -- name )
- {
- { [ dup empty? ] [ "." append ] }
- { [ dup last CHAR: . = ] [ ] }
- { [ t ] [ "." append ] }
- }
- cond ;
+++ /dev/null
-
-USING: kernel sequences combinators accessors locals random
- combinators.short-circuit
- io.sockets
- dns dns.util dns.cache.rr dns.cache.nx
- dns.resolver ;
-
-IN: dns.forwarding
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: query->rrs ( QUERY -- rrs/f )
- [let | RRS [ QUERY cache-get ] |
- RRS
- [ RRS ]
- [
- [let | NAME [ QUERY name>> ]
- TYPE [ QUERY type>> ]
- CLASS [ QUERY class>> ] |
-
- [let | RRS/CNAME [ T{ query f NAME CNAME CLASS } cache-get ] |
-
- RRS/CNAME f =
- [ f ]
- [
- [let | RR/CNAME [ RRS/CNAME first ] |
-
- [let | REAL-NAME [ RR/CNAME rdata>> ] |
-
- [let | RRS [
- T{ query f REAL-NAME TYPE CLASS } query->rrs
- ] |
-
- RRS
- [ RRS/CNAME RRS append ]
- [ f ]
- if
- ] ] ]
- ]
- if
- ] ]
- ]
- if
- ] ;
-
-:: answer-from-cache ( MSG -- msg/f )
- [let | QUERY [ MSG message-query ] |
-
- [let | NX [ QUERY name>> non-existent-name? ]
- RRS [ QUERY query->rrs ] |
-
- {
- { [ NX ] [ MSG NAME-ERROR >>rcode ] }
- { [ RRS ] [ MSG RRS >>answer-section ] }
- { [ t ] [ f ] }
- }
- cond
- ]
- ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: message-soa ( message -- rr/soa )
- authority-section>> [ type>> SOA = ] filter first ;
-
-! :: cache-message ( MSG -- msg )
-! MSG rcode>> NAME-ERROR =
-! [
-! [let | NAME [ MSG message-query name>> ]
-! TTL [ MSG message-soa ttl>> ] |
-! NAME TTL cache-non-existent-name
-! ]
-! ]
-! when
-! MSG answer-section>> [ cache-add ] each
-! MSG authority-section>> [ cache-add ] each
-! MSG additional-section>> [ cache-add ] each
-! MSG ;
-
-:: cache-message ( MSG -- msg )
- MSG rcode>> NAME-ERROR =
- [
- [let | RR/SOA [ MSG
- authority-section>>
- [ type>> SOA = ] filter
- dup empty? [ drop f ] [ first ] if ] |
- RR/SOA
- [
- [let | NAME [ MSG message-query name>> ]
- TTL [ MSG message-soa ttl>> ] |
- NAME TTL cache-non-existent-name
- ]
- ]
- when
- ]
- ]
- when
- MSG answer-section>> [ cache-add ] each
- MSG authority-section>> [ cache-add ] each
- MSG additional-section>> [ cache-add ] each
- MSG ;
-
-! : answer-from-server ( msg servers -- msg ) random ask-server cache-message ;
-
-: answer-from-server ( msg servers -- msg ) ask-servers cache-message ;
-
-:: find-answer ( MSG SERVERS -- msg )
- { [ MSG answer-from-cache ] [ MSG SERVERS answer-from-server ] } 0|| ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: start-server ( ADDR-SPEC SERVERS -- )
-
- [let | SOCKET [ ADDR-SPEC <datagram> ] |
-
- [
- SOCKET receive-packet
- [ parse-message SERVERS find-answer message->ba ]
- change-data
- respond
- ]
- forever
-
- ] ;
+++ /dev/null
-
-USING: kernel combinators sequences splitting math
- io.files io.encodings.utf8 random dns.util ;
-
-IN: dns.misc
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: resolv-conf-servers ( -- seq )
- "/etc/resolv.conf" utf8 file-lines
- [ " " split ] map
- [ first "nameserver" = ] filter
- [ second ] map ;
-
-: resolv-conf-server ( -- ip ) resolv-conf-servers random ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: cdr-name ( name -- name ) dup CHAR: . index 1 + tail ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: domain-has-name? ( domain name -- ? )
- {
- { [ 2dup = ] [ 2drop t ] }
- { [ 2dup longer? ] [ 2drop f ] }
- { [ t ] [ cdr-name domain-has-name? ] }
- }
- cond ;
-
-: name-in-domain? ( name domain -- ? ) swap domain-has-name? ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
+++ /dev/null
-
-USING: kernel accessors namespaces continuations
- io io.sockets io.binary io.timeouts io.encodings.binary
- destructors
- locals strings sequences random prettyprint calendar dns dns.misc ;
-
-IN: dns.resolver
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: send-receive-udp ( BA SERVER -- ba )
- T{ inet4 f f 0 } <datagram>
- T{ duration { second 3 } } over set-timeout
- [| SOCKET | BA SERVER SOCKET send SOCKET receive drop ]
- with-disposal ;
-
-:: send-receive-tcp ( BA SERVER -- ba )
- [let | BA [ BA length 2 >be BA append ] |
- SERVER binary
- [
- T{ duration { second 3 } } input-stream get set-timeout
- BA write flush 2 read be> read
- ]
- with-client ] ;
-
-:: send-receive-server ( BA SERVER -- msg )
- [let | RESULT [ BA SERVER send-receive-udp parse-message ] |
- RESULT tc>> 1 =
- [ BA SERVER send-receive-tcp parse-message ]
- [ RESULT ]
- if ] ;
-
-: >dns-inet4 ( obj -- inet4 ) dup string? [ 53 <inet4> ] [ ] if ;
-
-:: send-receive-servers ( BA SERVERS -- msg )
- SERVERS empty? [ "send-receive-servers: servers list empty" throw ] when
- [let | SERVER [ SERVERS random >dns-inet4 ] |
- ! if this throws an error ...
- [ BA SERVER send-receive-server ]
- ! we try with the other servers...
- [ drop BA SERVER SERVERS remove send-receive-servers ]
- recover ] ;
-
-:: ask-servers ( MSG SERVERS -- msg )
- MSG message->ba SERVERS send-receive-servers ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: fully-qualified ( name -- name ) dup "." tail? [ ] [ "." append ] if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: dns-servers ( -- seq )
- \ dns-servers get
- [ ]
- [ resolv-conf-servers \ dns-servers set dns-servers ]
- if* ;
-
-! : dns-server ( -- server ) dns-servers random ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: dns-ip4 ( name -- ips )
- fully-qualified
- [let | MSG [ A IN query boa query->message dns-servers ask-servers ] |
- MSG rcode>> NO-ERROR =
- [ MSG answer-section>> [ type>> A = ] filter [ rdata>> ] map ]
- [ "dns-ip: rcode = " MSG rcode>> unparse append throw ]
- if ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
+++ /dev/null
-
-USING: kernel combinators sequences sets math threads namespaces continuations
- debugger io io.sockets unicode.case accessors destructors
- combinators.short-circuit combinators.smart
- fry arrays
- dns dns.util dns.misc ;
-
-IN: dns.server
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: records-var
-
-: records ( -- records ) records-var get ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: {name-type-class} ( obj -- array )
- [ [ name>> >lower ] [ type>> ] [ class>> ] tri ] output>array ;
-
-: rr=query? ( obj obj -- ? ) [ {name-type-class} ] bi@ = ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: matching-rrs ( query -- rrs ) records [ rr=query? ] with filter ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! zones
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: zones ( -- names ) records [ type>> NS = ] filter [ name>> ] map prune ;
-: my-zones ( -- names ) records [ type>> SOA = ] filter [ name>> ] map ;
-
-: delegated-zones ( -- names ) zones my-zones diff ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! name->zone
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: name->zone ( name -- zone/f )
- zones sort-largest-first [ name-in-domain? ] with find nip ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! name->authority
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: name->authority ( name -- rrs-ns ) name->zone NS IN query boa matching-rrs ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! extract-names
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: rr->rdata-names ( rr -- names/f )
- {
- { [ dup type>> NS = ] [ rdata>> 1array ] }
- { [ dup type>> MX = ] [ rdata>> exchange>> 1array ] }
- { [ dup type>> CNAME = ] [ rdata>> 1array ] }
- { [ t ] [ drop f ] }
- }
- cond ;
-
-: extract-rdata-names ( message -- names )
- [ answer-section>> ] [ authority-section>> ] bi append
- [ rr->rdata-names ] map concat ;
-
-: extract-names ( message -- names )
- [ message-query name>> ] [ extract-rdata-names ] bi swap prefix ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! fill-authority
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: fill-authority ( message -- message )
- dup
- extract-names [ name->authority ] map concat prune
- over answer-section>> diff
- >>authority-section ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! fill-additional
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: name->rrs-a ( name -- rrs-a ) A IN query boa matching-rrs ;
-
-: fill-additional ( message -- message )
- dup
- extract-rdata-names [ name->rrs-a ] map concat prune
- over answer-section>> diff
- >>additional-section ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! query->rrs
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-DEFER: query->rrs
-
-: matching-rrs? ( query -- rrs/f ) matching-rrs [ empty? ] [ drop f ] [ ] 1if ;
-
-: matching-cname? ( query -- rrs/f )
- [ ] [ clone CNAME >>type matching-rrs ] bi ! query rrs
- [ empty? not ]
- [ first swap clone over rdata>> >>name query->rrs swap prefix ]
- [ 2drop f ]
- 1if ;
-
-: query->rrs ( query -- rrs/f ) { [ matching-rrs? ] [ matching-cname? ] } 1|| ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! have-answers
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: have-answers ( message -- message/f )
- dup message-query query->rrs
- [ empty? ]
- [ 2drop f ]
- [ >>answer-section fill-authority fill-additional ]
- 1if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! have-delegates?
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: cdr-name ( name -- name ) dup CHAR: . index 1 + tail ;
-
-: is-soa? ( name -- ? ) SOA IN query boa matching-rrs empty? not ;
-
-: have-ns? ( name -- rrs/f )
- NS IN query boa matching-rrs [ empty? ] [ drop f ] [ ] 1if ;
-
-: name->delegates ( name -- rrs-ns )
- {
- [ "" = { } and ]
- [ is-soa? { } and ]
- [ have-ns? ]
- [ cdr-name name->delegates ]
- }
- 1|| ;
-
-: have-delegates ( message -- message/f )
- dup message-query name>> name->delegates ! message rrs-ns
- [ empty? ]
- [ 2drop f ]
- [
- dup [ rdata>> A IN query boa matching-rrs ] map concat
- ! message rrs-ns rrs-a
- [ >>authority-section ]
- [ >>additional-section ]
- bi*
- ]
- 1if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! outsize-zones
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: outside-zones ( message -- message/f )
- dup message-query name>> name->zone f =
- [ ]
- [ drop f ]
- if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! is-nx
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: is-nx ( message -- message/f )
- [ message-query name>> records [ name>> = ] with filter empty? ]
- [
- NAME-ERROR >>rcode
- dup
- message-query name>> name->zone SOA IN query boa matching-rrs
- >>authority-section
- ]
- [ drop f ]
- 1if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: none-of-type ( message -- message )
- dup
- message-query name>> name->zone SOA IN query boa matching-rrs
- >>authority-section ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: find-answer ( message -- message )
- {
- [ have-answers ]
- [ have-delegates ]
- [ outside-zones ]
- [ is-nx ]
- [ none-of-type ]
- }
- 1|| ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: (handle-request) ( packet -- )
- [ [ find-answer ] with-message-bytes ] change-data respond ;
-
-: handle-request ( packet -- ) [ (handle-request) ] curry in-thread ;
-
-: receive-loop ( socket -- )
- [ receive-packet handle-request ] [ receive-loop ] bi ;
-
-: loop ( addr-spec -- )
- [ <datagram> '[ _ [ receive-loop ] with-disposal ] try ] [ loop ] bi ;
-
+++ /dev/null
-
-USING: kernel sequences random accessors dns ;
-
-IN: dns.stub
-
-! Stub resolver
-!
-! Generally useful, but particularly when running a forwarding,
-! caching, nameserver on localhost with multiple Factor instances
-! querying it.
-
-: name->ip ( name -- ip )
- A IN query boa
- query->message
- ask
- dup rcode>> NAME-ERROR =
- [ message-query name>> name-error ]
- [ answer-section>> [ type>> A = ] filter random rdata>> ]
- if ;
-
+++ /dev/null
-
-USING: kernel sequences sorting math math.order macros fry ;
-
-IN: dns.util
-
-: tri-chain ( obj p q r -- x y z )
- [ [ call dup ] dip call dup ] dip call ; inline
-
-MACRO: 1if ( test then else -- ) '[ dup @ _ _ if ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: sort-largest-first ( seq -- seq ) [ length ] sort-with reverse ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: longer? ( seq seq -- ? ) [ length ] bi@ > ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USING: io.sockets accessors ;
-
-TUPLE: packet data addr socket ;
-
-: receive-packet ( socket -- packet ) [ receive ] keep packet boa ;
-
-: respond ( packet -- ) [ data>> ] [ addr>> ] [ socket>> ] tri send ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: forever ( quot: ( -- ) -- ) [ call ] [ forever ] bi ; inline recursive
\ No newline at end of file
}
{ $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"
}
{ $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"
] [
{ [ ] }
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 ;
} 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 ;
] 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 ;
}
} ;
-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:"
$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:"
-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
[ 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
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! ;
] 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 ]
} 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 ;
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 )
'[ 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
:: 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
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
] 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+
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 )
[ dispose f ] change-handle drop ;
M: mdb-connection dispose
- mdb-close ;
\ No newline at end of file
+ mdb-close ;
[ "$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
! [ 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>
:: (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
<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>
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 ;
\r
M: let noise body>> noise ;\r
\r
-M: wlet noise body>> noise ;\r
-\r
M: lambda noise body>> noise ;\r
\r
M: object noise drop { 0 0 } ;\r
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
:: 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
: 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
[ [ <model-border-btn> [ close-window ] >>hook -> ] map ] <hbox> , ] <vbox>
"" open-window
] dip firstn
- ] 2curry ;
\ No newline at end of file
+ ] 2curry ;
}
{ $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"
<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>
("\\(\n\\| \\);\\_>" (1 ">b"))
;; Let and lambda:
("\\_<\\(!(\\) .* \\()\\)" (1 "<") (2 ">"))
- ("\\(\\[\\)\\(let\\|wlet\\|let\\*\\)\\( \\|$\\)" (1 "(]"))
+ ("\\(\\[\\)\\(let\\|let\\*\\)\\( \\|$\\)" (1 "(]"))
("\\(\\[\\)\\(|\\) +[^|]* \\(|\\)" (1 "(]") (2 "(|") (3 ")|"))
(" \\(|\\) " (1 "(|"))
(" \\(|\\)$" (1 ")"))
--- /dev/null
+
+USING: kernel assocs locals combinators
+ math math.functions system unicode.case ;
+
+IN: dns.cache.nx
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: nx-cache ( -- table ) H{ } ;
+
+: nx-cache-at ( name -- time ) >lower nx-cache at ;
+: nx-cache-delete-at ( name -- ) >lower nx-cache delete-at ;
+: nx-cache-set-at ( time name -- ) >lower nx-cache set-at ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: now ( -- seconds ) millis 1000.0 / round >integer ;
+
+:: non-existent-name? ( NAME -- ? )
+ [let | TIME [ NAME nx-cache-at ] |
+ {
+ { [ TIME f = ] [ f ] }
+ { [ TIME now <= ] [ NAME nx-cache-delete-at f ] }
+ { [ t ] [ t ] }
+ }
+ cond
+ ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: cache-non-existent-name ( NAME TTL -- )
+ [let | TIME [ TTL now + ] | TIME NAME nx-cache-set-at ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
--- /dev/null
+
+USING: kernel sequences assocs sets locals combinators
+ accessors system math math.functions unicode.case prettyprint
+ combinators.smart dns ;
+
+IN: dns.cache.rr
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <entry> time data ;
+
+: now ( -- seconds ) millis 1000.0 / round >integer ;
+
+: expired? ( <entry> -- ? ) time>> now <= ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: make-cache-key ( obj -- key )
+ [ [ name>> >lower ] [ type>> ] [ class>> ] tri ] output>array ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: cache ( -- table ) H{ } ;
+
+: cache-at ( obj -- ent ) make-cache-key cache at ;
+: cache-delete ( obj -- ) make-cache-key cache delete-at ;
+: cache-set-at ( ent obj -- ) make-cache-key cache set-at ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: cache-get ( OBJ -- rrs/f )
+ [let | ENT [ OBJ cache-at ] |
+ {
+ { [ ENT f = ] [ f ] }
+ { [ ENT expired? ] [ OBJ cache-delete f ] }
+ {
+ [ t ]
+ [
+ [let | NAME [ OBJ name>> ]
+ TYPE [ OBJ type>> ]
+ CLASS [ OBJ class>> ]
+ TTL [ ENT time>> now - ] |
+ ENT data>>
+ [| RDATA | T{ rr f NAME TYPE CLASS TTL RDATA } ]
+ map
+ ]
+ ]
+ }
+ }
+ cond
+ ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: cache-add ( RR -- )
+ [let | ENT [ RR cache-at ]
+ TIME [ RR ttl>> now + ]
+ RDATA [ RR rdata>> ] |
+ {
+ { [ ENT f = ] [ T{ <entry> f TIME V{ RDATA } } RR cache-set-at ] }
+ { [ ENT expired? ] [ RR cache-delete RR cache-add ] }
+ { [ t ] [ TIME ENT (>>time) RDATA ENT data>> adjoin ] }
+ }
+ cond
+ ] ;
\ No newline at end of file
--- /dev/null
+
+USING: kernel byte-arrays combinators strings arrays sequences splitting
+ grouping
+ math math.functions math.parser random
+ destructors
+ io io.binary io.sockets io.encodings.binary
+ accessors
+ combinators.smart
+ assocs
+ ;
+
+IN: dns
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: query name type class ;
+
+TUPLE: rr name type class ttl rdata ;
+
+TUPLE: hinfo cpu os ;
+
+TUPLE: mx preference exchange ;
+
+TUPLE: soa mname rname serial refresh retry expire minimum ;
+
+TUPLE: message
+ id qr opcode aa tc rd ra z rcode
+ question-section
+ answer-section
+ authority-section
+ additional-section ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: random-id ( -- id ) 2 16 ^ random ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! TYPE
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOLS: A NS MD MF CNAME SOA MB MG MR NULL WKS PTR HINFO MINFO MX TXT AAAA ;
+
+: type-table ( -- table )
+ {
+ { A 1 }
+ { NS 2 }
+ { MD 3 }
+ { MF 4 }
+ { CNAME 5 }
+ { SOA 6 }
+ { MB 7 }
+ { MG 8 }
+ { MR 9 }
+ { NULL 10 }
+ { WKS 11 }
+ { PTR 12 }
+ { HINFO 13 }
+ { MINFO 14 }
+ { MX 15 }
+ { TXT 16 }
+ { AAAA 28 }
+ } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! CLASS
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOLS: IN CS CH HS ;
+
+: class-table ( -- table )
+ {
+ { IN 1 }
+ { CS 2 }
+ { CH 3 }
+ { HS 4 }
+ } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! OPCODE
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOLS: QUERY IQUERY STATUS ;
+
+: opcode-table ( -- table )
+ {
+ { QUERY 0 }
+ { IQUERY 1 }
+ { STATUS 2 }
+ } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! RCODE
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
+ REFUSED ;
+
+: rcode-table ( -- table )
+ {
+ { NO-ERROR 0 }
+ { FORMAT-ERROR 1 }
+ { SERVER-FAILURE 2 }
+ { NAME-ERROR 3 }
+ { NOT-IMPLEMENTED 4 }
+ { REFUSED 5 }
+ } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: <message> ( -- message )
+ message new
+ random-id >>id
+ 0 >>qr
+ QUERY >>opcode
+ 0 >>aa
+ 0 >>tc
+ 1 >>rd
+ 0 >>ra
+ 0 >>z
+ NO-ERROR >>rcode
+ { } >>question-section
+ { } >>answer-section
+ { } >>authority-section
+ { } >>additional-section ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: ip->ba ( ip -- ba ) "." split [ string>number ] map >byte-array ;
+
+: ipv6->ba ( ip -- ba ) ":" split [ 16 base> ] map [ 2 >be ] map concat ;
+
+: label->ba ( label -- ba ) [ >byte-array ] [ length ] bi prefix ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: uint8->ba ( n -- ba ) 1 >be ;
+: uint16->ba ( n -- ba ) 2 >be ;
+: uint32->ba ( n -- ba ) 4 >be ;
+: uint64->ba ( n -- ba ) 8 >be ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: dn->ba ( dn -- ba ) "." split [ label->ba ] map concat ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: query->ba ( query -- ba )
+ [
+ {
+ [ name>> dn->ba ]
+ [ type>> type-table at uint16->ba ]
+ [ class>> class-table at uint16->ba ]
+ } cleave
+ ] output>array concat ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: hinfo->ba ( rdata -- ba )
+ [ cpu>> label->ba ]
+ [ os>> label->ba ]
+ bi append ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: mx->ba ( rdata -- ba )
+ [ preference>> uint16->ba ]
+ [ exchange>> dn->ba ]
+ bi append ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: soa->ba ( rdata -- ba )
+ [
+ {
+ [ mname>> dn->ba ]
+ [ rname>> dn->ba ]
+ [ serial>> uint32->ba ]
+ [ refresh>> uint32->ba ]
+ [ retry>> uint32->ba ]
+ [ expire>> uint32->ba ]
+ [ minimum>> uint32->ba ]
+ } cleave
+ ] output>array concat ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: rdata->ba ( type rdata -- ba )
+ swap
+ {
+ { CNAME [ dn->ba ] }
+ { HINFO [ hinfo->ba ] }
+ { MX [ mx->ba ] }
+ { NS [ dn->ba ] }
+ { PTR [ dn->ba ] }
+ { SOA [ soa->ba ] }
+ { A [ ip->ba ] }
+ }
+ case ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: rr->ba ( rr -- ba )
+ [
+ {
+ [ name>> dn->ba ]
+ [ type>> type-table at uint16->ba ]
+ [ class>> class-table at uint16->ba ]
+ [ ttl>> uint32->ba ]
+ [
+ [ type>> ] [ rdata>> ] bi rdata->ba
+ [ length uint16->ba ] [ ] bi append
+ ]
+ } cleave
+ ] output>array concat ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: header-bits-ba ( message -- ba )
+ [
+ {
+ [ qr>> 15 shift ]
+ [ opcode>> opcode-table at 11 shift ]
+ [ aa>> 10 shift ]
+ [ tc>> 9 shift ]
+ [ rd>> 8 shift ]
+ [ ra>> 7 shift ]
+ [ z>> 4 shift ]
+ [ rcode>> rcode-table at 0 shift ]
+ } cleave
+ ] sum-outputs uint16->ba ;
+
+: message->ba ( message -- ba )
+ [
+ {
+ [ id>> uint16->ba ]
+ [ header-bits-ba ]
+ [ question-section>> length uint16->ba ]
+ [ answer-section>> length uint16->ba ]
+ [ authority-section>> length uint16->ba ]
+ [ additional-section>> length uint16->ba ]
+ [ question-section>> [ query->ba ] map concat ]
+ [ answer-section>> [ rr->ba ] map concat ]
+ [ authority-section>> [ rr->ba ] map concat ]
+ [ additional-section>> [ rr->ba ] map concat ]
+ } cleave
+ ] output>array concat ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: get-single ( ba i -- n ) at ;
+: get-double ( ba i -- n ) dup 2 + subseq be> ;
+: get-quad ( ba i -- n ) dup 4 + subseq be> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: label-length ( ba i -- length ) get-single ;
+
+: skip-label ( ba i -- ba i ) 2dup label-length + 1 + ;
+
+: null-label? ( ba i -- ? ) get-single 0 = ;
+
+: get-label ( ba i -- label ) [ 1 + ] [ skip-label nip ] 2bi subseq >string ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: bit-test ( a b -- ? ) bitand 0 = not ;
+
+: pointer? ( ba i -- ? ) get-single BIN: 11000000 bit-test ;
+
+: pointer ( ba i -- val ) get-double BIN: 0011111111111111 bitand ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: skip-name ( ba i -- ba i )
+ {
+ { [ 2dup null-label? ] [ 1 + ] }
+ { [ 2dup pointer? ] [ 2 + ] }
+ { [ t ] [ skip-label skip-name ] }
+ }
+ cond ;
+
+: get-name ( ba i -- name )
+ {
+ { [ 2dup null-label? ] [ 2drop "" ] }
+ { [ 2dup pointer? ] [ dupd pointer get-name ] }
+ {
+ [ t ]
+ [
+ [ get-label ]
+ [ skip-label get-name ]
+ 2bi
+ "." glue
+ ]
+ }
+ }
+ cond ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: get-query ( ba i -- query )
+ [ get-name ]
+ [
+ skip-name
+ [ 0 + get-double type-table value-at ]
+ [ 2 + get-double class-table value-at ]
+ 2bi
+ ]
+ 2bi query boa ;
+
+: skip-query ( ba i -- ba i ) skip-name 4 + ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: get-mx ( ba i -- mx ) [ get-double ] [ 2 + get-double ] 2bi mx boa ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: get-soa ( ba i -- soa )
+ {
+ [ get-name ]
+ [ skip-name get-name ]
+ [
+ skip-name
+ skip-name
+ {
+ [ 0 + get-quad ]
+ [ 4 + get-quad ]
+ [ 8 + get-quad ]
+ [ 12 + get-quad ]
+ [ 16 + get-quad ]
+ }
+ 2cleave
+ ]
+ }
+ 2cleave soa boa ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: get-ip ( ba i -- ip ) dup 4 + subseq >array [ number>string ] map "." join ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: get-ipv6 ( ba i -- ip )
+ dup 16 + subseq 2 group [ be> 16 >base ] map ":" join ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: get-rdata ( ba i type -- rdata )
+ {
+ { CNAME [ get-name ] }
+ { NS [ get-name ] }
+ { PTR [ get-name ] }
+ { MX [ get-mx ] }
+ { SOA [ get-soa ] }
+ { A [ get-ip ] }
+ { AAAA [ get-ipv6 ] }
+ }
+ case ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: get-rr ( ba i -- rr )
+ [ get-name ]
+ [
+ skip-name
+ {
+ [ 0 + get-double type-table value-at ]
+ [ 2 + get-double class-table value-at ]
+ [ 4 + get-quad ]
+ [ [ 10 + ] [ get-double type-table value-at ] 2bi get-rdata ]
+ }
+ 2cleave
+ ]
+ 2bi rr boa ;
+
+: skip-rr ( ba i -- ba i ) skip-name 8 + 2dup get-double + 2 + ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: get-question-section ( ba i count -- seq ba i )
+ [ drop [ skip-query ] [ get-query ] 2bi ] map -rot ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: get-rr-section ( ba i count -- seq ba i )
+ [ drop [ skip-rr ] [ get-rr ] 2bi ] map -rot ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: >> ( x n -- y ) neg shift ;
+
+: get-header-bits ( ba i -- qr opcode aa tc rd ra z rcode )
+ get-double
+ {
+ [ 15 >> BIN: 1 bitand ]
+ [ 11 >> BIN: 111 bitand opcode-table value-at ]
+ [ 10 >> BIN: 1 bitand ]
+ [ 9 >> BIN: 1 bitand ]
+ [ 8 >> BIN: 1 bitand ]
+ [ 7 >> BIN: 1 bitand ]
+ [ 4 >> BIN: 111 bitand ]
+ [ BIN: 1111 bitand rcode-table value-at ]
+ }
+ cleave ;
+
+: parse-message ( ba -- message )
+ 0
+ {
+ [ get-double ]
+ [ 2 + get-header-bits ]
+ [
+ 4 +
+ {
+ [ 8 + ]
+ [ 0 + get-double ]
+ [ 2 + get-double ]
+ [ 4 + get-double ]
+ [ 6 + get-double ]
+ }
+ 2cleave
+ {
+ [ get-question-section ]
+ [ get-rr-section ]
+ [ get-rr-section ]
+ [ get-rr-section ]
+ } spread
+ 2drop
+ ]
+ }
+ 2cleave message boa ;
+
+: ba->message ( ba -- message ) parse-message ;
+
+: with-message-bytes ( ba quot -- ) [ ba->message ] dip call message->ba ; inline
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: send-receive-udp ( ba server -- ba )
+ f 0 <inet4> <datagram>
+ [
+ [ send ] [ receive drop ] bi
+ ]
+ with-disposal ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: send-receive-tcp ( ba server -- ba )
+ [ dup length 2 >be prepend ] [ ] bi*
+ binary
+ [
+ write flush
+ 2 read be> read
+ ]
+ with-client ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: >dns-inet4 ( obj -- inet4 )
+ dup string?
+ [ 53 <inet4> ]
+ [ ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: ask-server ( message server -- message )
+ [ message->ba ] [ >dns-inet4 ] bi*
+ 2dup
+ send-receive-udp parse-message
+ dup tc>> 1 =
+ [ drop send-receive-tcp parse-message ]
+ [ nip nip ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: dns-servers ( -- seq ) V{ } ;
+
+: dns-server ( -- server ) dns-servers random ;
+
+: ask ( message -- message ) dns-server ask-server ;
+
+: query->message ( query -- message ) <message> swap 1array >>question-section ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: message-query ( message -- query ) question-section>> first ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ERROR: name-error name ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: fully-qualified ( name -- name )
+ {
+ { [ dup empty? ] [ "." append ] }
+ { [ dup last CHAR: . = ] [ ] }
+ { [ t ] [ "." append ] }
+ }
+ cond ;
--- /dev/null
+
+USING: kernel sequences combinators accessors locals random
+ combinators.short-circuit
+ io.sockets
+ dns dns.util dns.cache.rr dns.cache.nx
+ dns.resolver ;
+
+IN: dns.forwarding
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: query->rrs ( QUERY -- rrs/f )
+ [let | RRS [ QUERY cache-get ] |
+ RRS
+ [ RRS ]
+ [
+ [let | NAME [ QUERY name>> ]
+ TYPE [ QUERY type>> ]
+ CLASS [ QUERY class>> ] |
+
+ [let | RRS/CNAME [ T{ query f NAME CNAME CLASS } cache-get ] |
+
+ RRS/CNAME f =
+ [ f ]
+ [
+ [let | RR/CNAME [ RRS/CNAME first ] |
+
+ [let | REAL-NAME [ RR/CNAME rdata>> ] |
+
+ [let | RRS [
+ T{ query f REAL-NAME TYPE CLASS } query->rrs
+ ] |
+
+ RRS
+ [ RRS/CNAME RRS append ]
+ [ f ]
+ if
+ ] ] ]
+ ]
+ if
+ ] ]
+ ]
+ if
+ ] ;
+
+:: answer-from-cache ( MSG -- msg/f )
+ [let | QUERY [ MSG message-query ] |
+
+ [let | NX [ QUERY name>> non-existent-name? ]
+ RRS [ QUERY query->rrs ] |
+
+ {
+ { [ NX ] [ MSG NAME-ERROR >>rcode ] }
+ { [ RRS ] [ MSG RRS >>answer-section ] }
+ { [ t ] [ f ] }
+ }
+ cond
+ ]
+ ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: message-soa ( message -- rr/soa )
+ authority-section>> [ type>> SOA = ] filter first ;
+
+! :: cache-message ( MSG -- msg )
+! MSG rcode>> NAME-ERROR =
+! [
+! [let | NAME [ MSG message-query name>> ]
+! TTL [ MSG message-soa ttl>> ] |
+! NAME TTL cache-non-existent-name
+! ]
+! ]
+! when
+! MSG answer-section>> [ cache-add ] each
+! MSG authority-section>> [ cache-add ] each
+! MSG additional-section>> [ cache-add ] each
+! MSG ;
+
+:: cache-message ( MSG -- msg )
+ MSG rcode>> NAME-ERROR =
+ [
+ [let | RR/SOA [ MSG
+ authority-section>>
+ [ type>> SOA = ] filter
+ dup empty? [ drop f ] [ first ] if ] |
+ RR/SOA
+ [
+ [let | NAME [ MSG message-query name>> ]
+ TTL [ MSG message-soa ttl>> ] |
+ NAME TTL cache-non-existent-name
+ ]
+ ]
+ when
+ ]
+ ]
+ when
+ MSG answer-section>> [ cache-add ] each
+ MSG authority-section>> [ cache-add ] each
+ MSG additional-section>> [ cache-add ] each
+ MSG ;
+
+! : answer-from-server ( msg servers -- msg ) random ask-server cache-message ;
+
+: answer-from-server ( msg servers -- msg ) ask-servers cache-message ;
+
+:: find-answer ( MSG SERVERS -- msg )
+ { [ MSG answer-from-cache ] [ MSG SERVERS answer-from-server ] } 0|| ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: start-server ( ADDR-SPEC SERVERS -- )
+
+ [let | SOCKET [ ADDR-SPEC <datagram> ] |
+
+ [
+ SOCKET receive-packet
+ [ parse-message SERVERS find-answer message->ba ]
+ change-data
+ respond
+ ]
+ forever
+
+ ] ;
--- /dev/null
+
+USING: kernel combinators sequences splitting math
+ io.files io.encodings.utf8 random dns.util ;
+
+IN: dns.misc
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: resolv-conf-servers ( -- seq )
+ "/etc/resolv.conf" utf8 file-lines
+ [ " " split ] map
+ [ first "nameserver" = ] filter
+ [ second ] map ;
+
+: resolv-conf-server ( -- ip ) resolv-conf-servers random ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: cdr-name ( name -- name ) dup CHAR: . index 1 + tail ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: domain-has-name? ( domain name -- ? )
+ {
+ { [ 2dup = ] [ 2drop t ] }
+ { [ 2dup longer? ] [ 2drop f ] }
+ { [ t ] [ cdr-name domain-has-name? ] }
+ }
+ cond ;
+
+: name-in-domain? ( name domain -- ? ) swap domain-has-name? ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
--- /dev/null
+
+USING: kernel accessors namespaces continuations
+ io io.sockets io.binary io.timeouts io.encodings.binary
+ destructors
+ locals strings sequences random prettyprint calendar dns dns.misc ;
+
+IN: dns.resolver
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: send-receive-udp ( BA SERVER -- ba )
+ T{ inet4 f f 0 } <datagram>
+ T{ duration { second 3 } } over set-timeout
+ [| SOCKET | BA SERVER SOCKET send SOCKET receive drop ]
+ with-disposal ;
+
+:: send-receive-tcp ( BA SERVER -- ba )
+ [let | BA [ BA length 2 >be BA append ] |
+ SERVER binary
+ [
+ T{ duration { second 3 } } input-stream get set-timeout
+ BA write flush 2 read be> read
+ ]
+ with-client ] ;
+
+:: send-receive-server ( BA SERVER -- msg )
+ [let | RESULT [ BA SERVER send-receive-udp parse-message ] |
+ RESULT tc>> 1 =
+ [ BA SERVER send-receive-tcp parse-message ]
+ [ RESULT ]
+ if ] ;
+
+: >dns-inet4 ( obj -- inet4 ) dup string? [ 53 <inet4> ] [ ] if ;
+
+:: send-receive-servers ( BA SERVERS -- msg )
+ SERVERS empty? [ "send-receive-servers: servers list empty" throw ] when
+ [let | SERVER [ SERVERS random >dns-inet4 ] |
+ ! if this throws an error ...
+ [ BA SERVER send-receive-server ]
+ ! we try with the other servers...
+ [ drop BA SERVER SERVERS remove send-receive-servers ]
+ recover ] ;
+
+:: ask-servers ( MSG SERVERS -- msg )
+ MSG message->ba SERVERS send-receive-servers ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: fully-qualified ( name -- name ) dup "." tail? [ ] [ "." append ] if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: dns-servers ( -- seq )
+ \ dns-servers get
+ [ ]
+ [ resolv-conf-servers \ dns-servers set dns-servers ]
+ if* ;
+
+! : dns-server ( -- server ) dns-servers random ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: dns-ip4 ( name -- ips )
+ fully-qualified
+ [let | MSG [ A IN query boa query->message dns-servers ask-servers ] |
+ MSG rcode>> NO-ERROR =
+ [ MSG answer-section>> [ type>> A = ] filter [ rdata>> ] map ]
+ [ "dns-ip: rcode = " MSG rcode>> unparse append throw ]
+ if ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
--- /dev/null
+
+USING: kernel combinators sequences sets math threads namespaces continuations
+ debugger io io.sockets unicode.case accessors destructors
+ combinators.short-circuit combinators.smart
+ fry arrays
+ dns dns.util dns.misc ;
+
+IN: dns.server
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: records-var
+
+: records ( -- records ) records-var get ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: {name-type-class} ( obj -- array )
+ [ [ name>> >lower ] [ type>> ] [ class>> ] tri ] output>array ;
+
+: rr=query? ( obj obj -- ? ) [ {name-type-class} ] bi@ = ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: matching-rrs ( query -- rrs ) records [ rr=query? ] with filter ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! zones
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: zones ( -- names ) records [ type>> NS = ] filter [ name>> ] map prune ;
+: my-zones ( -- names ) records [ type>> SOA = ] filter [ name>> ] map ;
+
+: delegated-zones ( -- names ) zones my-zones diff ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! name->zone
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: name->zone ( name -- zone/f )
+ zones sort-largest-first [ name-in-domain? ] with find nip ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! name->authority
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: name->authority ( name -- rrs-ns ) name->zone NS IN query boa matching-rrs ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! extract-names
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: rr->rdata-names ( rr -- names/f )
+ {
+ { [ dup type>> NS = ] [ rdata>> 1array ] }
+ { [ dup type>> MX = ] [ rdata>> exchange>> 1array ] }
+ { [ dup type>> CNAME = ] [ rdata>> 1array ] }
+ { [ t ] [ drop f ] }
+ }
+ cond ;
+
+: extract-rdata-names ( message -- names )
+ [ answer-section>> ] [ authority-section>> ] bi append
+ [ rr->rdata-names ] map concat ;
+
+: extract-names ( message -- names )
+ [ message-query name>> ] [ extract-rdata-names ] bi swap prefix ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! fill-authority
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: fill-authority ( message -- message )
+ dup
+ extract-names [ name->authority ] map concat prune
+ over answer-section>> diff
+ >>authority-section ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! fill-additional
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: name->rrs-a ( name -- rrs-a ) A IN query boa matching-rrs ;
+
+: fill-additional ( message -- message )
+ dup
+ extract-rdata-names [ name->rrs-a ] map concat prune
+ over answer-section>> diff
+ >>additional-section ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! query->rrs
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+DEFER: query->rrs
+
+: matching-rrs? ( query -- rrs/f ) matching-rrs [ empty? ] [ drop f ] [ ] 1if ;
+
+: matching-cname? ( query -- rrs/f )
+ [ ] [ clone CNAME >>type matching-rrs ] bi ! query rrs
+ [ empty? not ]
+ [ first swap clone over rdata>> >>name query->rrs swap prefix ]
+ [ 2drop f ]
+ 1if ;
+
+: query->rrs ( query -- rrs/f ) { [ matching-rrs? ] [ matching-cname? ] } 1|| ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! have-answers
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: have-answers ( message -- message/f )
+ dup message-query query->rrs
+ [ empty? ]
+ [ 2drop f ]
+ [ >>answer-section fill-authority fill-additional ]
+ 1if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! have-delegates?
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: cdr-name ( name -- name ) dup CHAR: . index 1 + tail ;
+
+: is-soa? ( name -- ? ) SOA IN query boa matching-rrs empty? not ;
+
+: have-ns? ( name -- rrs/f )
+ NS IN query boa matching-rrs [ empty? ] [ drop f ] [ ] 1if ;
+
+: name->delegates ( name -- rrs-ns )
+ {
+ [ "" = { } and ]
+ [ is-soa? { } and ]
+ [ have-ns? ]
+ [ cdr-name name->delegates ]
+ }
+ 1|| ;
+
+: have-delegates ( message -- message/f )
+ dup message-query name>> name->delegates ! message rrs-ns
+ [ empty? ]
+ [ 2drop f ]
+ [
+ dup [ rdata>> A IN query boa matching-rrs ] map concat
+ ! message rrs-ns rrs-a
+ [ >>authority-section ]
+ [ >>additional-section ]
+ bi*
+ ]
+ 1if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! outsize-zones
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: outside-zones ( message -- message/f )
+ dup message-query name>> name->zone f =
+ [ ]
+ [ drop f ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! is-nx
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: is-nx ( message -- message/f )
+ [ message-query name>> records [ name>> = ] with filter empty? ]
+ [
+ NAME-ERROR >>rcode
+ dup
+ message-query name>> name->zone SOA IN query boa matching-rrs
+ >>authority-section
+ ]
+ [ drop f ]
+ 1if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: none-of-type ( message -- message )
+ dup
+ message-query name>> name->zone SOA IN query boa matching-rrs
+ >>authority-section ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: find-answer ( message -- message )
+ {
+ [ have-answers ]
+ [ have-delegates ]
+ [ outside-zones ]
+ [ is-nx ]
+ [ none-of-type ]
+ }
+ 1|| ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: (handle-request) ( packet -- )
+ [ [ find-answer ] with-message-bytes ] change-data respond ;
+
+: handle-request ( packet -- ) [ (handle-request) ] curry in-thread ;
+
+: receive-loop ( socket -- )
+ [ receive-packet handle-request ] [ receive-loop ] bi ;
+
+: loop ( addr-spec -- )
+ [ <datagram> '[ _ [ receive-loop ] with-disposal ] try ] [ loop ] bi ;
+
--- /dev/null
+
+USING: kernel sequences random accessors dns ;
+
+IN: dns.stub
+
+! Stub resolver
+!
+! Generally useful, but particularly when running a forwarding,
+! caching, nameserver on localhost with multiple Factor instances
+! querying it.
+
+: name->ip ( name -- ip )
+ A IN query boa
+ query->message
+ ask
+ dup rcode>> NAME-ERROR =
+ [ message-query name>> name-error ]
+ [ answer-section>> [ type>> A = ] filter random rdata>> ]
+ if ;
+
--- /dev/null
+
+USING: kernel sequences sorting math math.order macros fry ;
+
+IN: dns.util
+
+: tri-chain ( obj p q r -- x y z )
+ [ [ call dup ] dip call dup ] dip call ; inline
+
+MACRO: 1if ( test then else -- ) '[ dup @ _ _ if ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: sort-largest-first ( seq -- seq ) [ length ] sort-with reverse ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: longer? ( seq seq -- ? ) [ length ] bi@ > ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USING: io.sockets accessors ;
+
+TUPLE: packet data addr socket ;
+
+: receive-packet ( socket -- packet ) [ receive ] keep packet boa ;
+
+: respond ( packet -- ) [ data>> ] [ addr>> ] [ socket>> ] tri send ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: forever ( quot: ( -- ) -- ) [ call ] [ forever ] bi ; inline recursive
\ No newline at end of file
projects / factor.git / commitdiff