From be06663629def065abe5e4e827f1f7d6c92085f0 Mon Sep 17 00:00:00 2001 From: James Cash Date: Thu, 15 May 2008 21:21:33 -0400 Subject: [PATCH 01/18] Writing docs for lisp and lisp.parser --- extra/lisp/lisp-docs.factor | 15 +++++++++++++++ extra/lisp/parser/parser-docs.factor | 6 ++++++ 2 files changed, 21 insertions(+) create mode 100644 extra/lisp/lisp-docs.factor create mode 100644 extra/lisp/parser/parser-docs.factor diff --git a/extra/lisp/lisp-docs.factor b/extra/lisp/lisp-docs.factor new file mode 100644 index 0000000000..149f22864e --- /dev/null +++ b/extra/lisp/lisp-docs.factor @@ -0,0 +1,15 @@ +IN: lisp +USING: help.markup help.syntax ; + +ARTICLE: "lisp" "Lisp in Factor" +"This is a simple implementation of a Lisp dialect, which somewhat resembles Scheme." $nl +"It works in two main stages: " +{ $list + { "Parse (via " { $vocab-link "lisp.parser" } " the Lisp code into a " + { $snippet "s-exp" } " tuple." } + { "Transform the " { $snippet "s-exp" } " into a Factor quotation, via " { $link convert-form } } +} + +{ $subsection "lisp.parser" } ; + +ABOUT: "lisp" \ No newline at end of file diff --git a/extra/lisp/parser/parser-docs.factor b/extra/lisp/parser/parser-docs.factor new file mode 100644 index 0000000000..fc16a0a310 --- /dev/null +++ b/extra/lisp/parser/parser-docs.factor @@ -0,0 +1,6 @@ +IN: lisp.parser +USING: help.markup help.syntax ; + +ARTICLE: "lisp.parser" "Parsing strings of Lisp" +"This vocab uses " { $vocab-link "peg.ebnf" } " to turn strings of Lisp into " { $snippet "s-exp" } "s, which are then used by" +{ $vocab-link "lisp" } " to produce Factor quotations." ; \ No newline at end of file From 70ef7d005c79d5e8e09b07eb4bdf8a93859c674c Mon Sep 17 00:00:00 2001 From: James Cash Date: Thu, 15 May 2008 22:14:33 -0400 Subject: [PATCH 02/18] Changing wording of summary --- extra/lisp/summary.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/lisp/summary.txt b/extra/lisp/summary.txt index 8c36217f1c..7277c2a5b5 100644 --- a/extra/lisp/summary.txt +++ b/extra/lisp/summary.txt @@ -1 +1 @@ -A Lisp interpreter in Factor +A Lisp interpreter/compiler in Factor From 88576aefe45d74dbc6f24a792e3f6a514e5f79b7 Mon Sep 17 00:00:00 2001 From: James Cash Date: Thu, 15 May 2008 22:14:53 -0400 Subject: [PATCH 03/18] Adding define-primitive word --- extra/lisp/lisp-tests.factor | 10 ++++------ extra/lisp/lisp.factor | 17 ++++++++++------- 2 files changed, 14 insertions(+), 13 deletions(-) diff --git a/extra/lisp/lisp-tests.factor b/extra/lisp/lisp-tests.factor index df37de2475..06c2260d72 100644 --- a/extra/lisp/lisp-tests.factor +++ b/extra/lisp/lisp-tests.factor @@ -6,14 +6,12 @@ IN: lisp.test init-env -"+" [ first2 + ] lisp-define +"+" "math" "+" define-primitve -{ [ first2 + ] } [ - "+" lisp-get +{ 5 } [ + [ 2 3 ] "+" funcall ] unit-test { 3 } [ - [ - "((lambda (x y) (+ x y)) 1 2)" lisp-string>factor call - ] with-interactive-vocabs + "((lambda (x y) (+ x y)) 1 2)" lisp-string>factor call ] unit-test \ No newline at end of file diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor index 3e4cdca41f..32df8c5102 100644 --- a/extra/lisp/lisp.factor +++ b/extra/lisp/lisp.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel peg sequences arrays strings combinators.lib namespaces combinators math bake locals locals.private accessors -vectors syntax lisp.parser assocs parser sequences.lib ; +vectors syntax lisp.parser assocs parser sequences.lib words ; IN: lisp DEFER: convert-form @@ -24,7 +24,8 @@ DEFER: funcall : convert-general-form ( s-exp -- quot ) unclip convert-form swap convert-body [ , % funcall ] bake ; - + +! words for convert-lambda > ] dip at swap or ] @@ -34,8 +35,6 @@ DEFER: funcall : localize-lambda ( body vars -- newbody newvars ) make-locals dup push-locals swap [ swap localize-body convert-form swap pop-locals ] dip swap ; - -PRIVATE> : split-lambda ( s-exp -- body vars ) first3 -rot nip [ body>> ] bi@ [ name>> ] map ; inline @@ -47,6 +46,7 @@ PRIVATE> : normal-lambda ( body vars -- quot ) localize-lambda [ , compose ] bake ; +PRIVATE> : convert-lambda ( s-exp -- quot ) split-lambda dup "&rest" swap member? [ rest-lambda ] [ normal-lambda ] if ; @@ -68,7 +68,7 @@ PRIVATE> : convert-form ( lisp-form -- quot ) dup s-exp? [ body>> convert-list-form ] - [ [ , ] [ ] make ] if ; + [ [ , ] bake ] if ; : lisp-string>factor ( str -- quot ) lisp-expr parse-result-ast convert-form lambda-rewrite call ; @@ -85,7 +85,10 @@ ERROR: no-such-var var ; swap lisp-env get set-at ; : lisp-get ( name -- word ) - dup lisp-env get at [ ] [ no-such-var ] ?if ; + dup lisp-env get at [ ] [ no-such-var throw ] ?if ; : funcall ( quot sym -- * ) - dup lisp-symbol? [ name>> lisp-get ] when call ; inline \ No newline at end of file + dup lisp-symbol? [ name>> lisp-get ] when call ; inline + +: define-primitve ( name vocab word -- ) + swap lookup [ [ , ] compose call ] bake lisp-define ; \ No newline at end of file From ced3a4b632c583b620ad8388df14d1265781fd8f Mon Sep 17 00:00:00 2001 From: James Cash Date: Thu, 15 May 2008 22:58:32 -0400 Subject: [PATCH 04/18] Adding more tests to lisp --- extra/lisp/lisp-tests.factor | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/extra/lisp/lisp-tests.factor b/extra/lisp/lisp-tests.factor index 06c2260d72..98e1c9e943 100644 --- a/extra/lisp/lisp-tests.factor +++ b/extra/lisp/lisp-tests.factor @@ -14,4 +14,14 @@ init-env { 3 } [ "((lambda (x y) (+ x y)) 1 2)" lisp-string>factor call +] unit-test + +"-" "math" "-" define-primitve + +{ 8.3 } [ + [ 10.4 2.1 ] "-" funcall +] unit-test + +{ 42 } [ + "((lambda (x y z) (+ x (- y z))) 40 3 1)" lisp-string>factor call ] unit-test \ No newline at end of file From a2e1ad28142fe42f6e3bb788237320e505a934d5 Mon Sep 17 00:00:00 2001 From: James Cash Date: Sun, 18 May 2008 11:58:32 -0400 Subject: [PATCH 05/18] Allowing identifiers to begin with '#' --- extra/lisp/parser/parser.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/lisp/parser/parser.factor b/extra/lisp/parser/parser.factor index 32886f9367..44c79fd962 100644 --- a/extra/lisp/parser/parser.factor +++ b/extra/lisp/parser/parser.factor @@ -24,7 +24,7 @@ rational = integer "/" (digit)+ => [[ first3 nip string number = float | rational | integer -id-specials = "!" | "$" | "%" | "&" | "*" | "/" | ":" | "<" +id-specials = "!" | "$" | "%" | "&" | "*" | "/" | ":" | "<" | "#" | " =" | ">" | "?" | "^" | "_" | "~" | "+" | "-" | "." | "@" letters = [a-zA-Z] => [[ 1array >string ]] initials = letters | id-specials From 5c13565bc7c1da890eec9615d9cbd6433610add5 Mon Sep 17 00:00:00 2001 From: James Cash Date: Sun, 18 May 2008 11:59:11 -0400 Subject: [PATCH 06/18] Adding more tests to lisp --- extra/lisp/lisp-tests.factor | 22 ++++++++++++++++------ 1 file changed, 16 insertions(+), 6 deletions(-) diff --git a/extra/lisp/lisp-tests.factor b/extra/lisp/lisp-tests.factor index 98e1c9e943..fd6e2d93ae 100644 --- a/extra/lisp/lisp-tests.factor +++ b/extra/lisp/lisp-tests.factor @@ -6,22 +6,32 @@ IN: lisp.test init-env +"#f" [ f ] lisp-define +"#t" [ t ] lisp-define + "+" "math" "+" define-primitve +"-" "math" "-" define-primitve { 5 } [ [ 2 3 ] "+" funcall ] unit-test +{ 8.3 } [ + [ 10.4 2.1 ] "-" funcall +] unit-test + { 3 } [ "((lambda (x y) (+ x y)) 1 2)" lisp-string>factor call ] unit-test -"-" "math" "-" define-primitve - -{ 8.3 } [ - [ 10.4 2.1 ] "-" funcall -] unit-test - { 42 } [ "((lambda (x y z) (+ x (- y z))) 40 3 1)" lisp-string>factor call +] unit-test + +{ 1 } [ + "(if #t 1 2)" lisp-string>factor call +] unit-test + +{ "b" } [ + "(cond (#f \"a\") (#t \"b\"))" lisp-string>factor call ] unit-test \ No newline at end of file From 1acf9bc60b5e2589ccea776a99528bf8b99d5f22 Mon Sep 17 00:00:00 2001 From: James Cash Date: Sun, 18 May 2008 12:00:03 -0400 Subject: [PATCH 07/18] Lookup lisp-symbols in variable list --- extra/lisp/lisp.factor | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor index 32df8c5102..0c5ae34e3f 100644 --- a/extra/lisp/lisp.factor +++ b/extra/lisp/lisp.factor @@ -7,6 +7,7 @@ IN: lisp DEFER: convert-form DEFER: funcall +DEFER: lookup-vars ! Functions to convert s-exps to quotations ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -23,7 +24,7 @@ DEFER: funcall rest [ [ convert-form map ] map ] [ % cond ] bake ; : convert-general-form ( s-exp -- quot ) - unclip convert-form swap convert-body [ , % funcall ] bake ; + unclip convert-form swap convert-body [ , lookup-vars % funcall ] bake ; ! words for convert-lambda ] dip - [ , cut swap [ % , ] bake , compose ] bake ; + [ , lookup-vars cut swap [ % , ] bake , compose ] bake ; : normal-lambda ( body vars -- quot ) - localize-lambda [ , compose ] bake ; + localize-lambda [ lookup-vars , compose ] bake ; PRIVATE> : convert-lambda ( s-exp -- quot ) @@ -90,5 +91,8 @@ ERROR: no-such-var var ; : funcall ( quot sym -- * ) dup lisp-symbol? [ name>> lisp-get ] when call ; inline +: lookup-vars ( q -- p ) + [ dup lisp-symbol? [ name>> lisp-get ] when ] map ; + : define-primitve ( name vocab word -- ) swap lookup [ [ , ] compose call ] bake lisp-define ; \ No newline at end of file From eddb4f49949b35aed4c88dfc3083ee25764938a5 Mon Sep 17 00:00:00 2001 From: James Cash Date: Sun, 18 May 2008 12:53:44 -0400 Subject: [PATCH 08/18] Fixing cond, variable lookup --- extra/lisp/lisp.factor | 25 ++++++++++++++----------- 1 file changed, 14 insertions(+), 11 deletions(-) diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor index 0c5ae34e3f..c9bdf6c91a 100644 --- a/extra/lisp/lisp.factor +++ b/extra/lisp/lisp.factor @@ -7,7 +7,7 @@ IN: lisp DEFER: convert-form DEFER: funcall -DEFER: lookup-vars +DEFER: lookup-var ! Functions to convert s-exps to quotations ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -21,10 +21,11 @@ DEFER: lookup-vars rest convert-form ; : convert-cond ( s-exp -- quot ) - rest [ [ convert-form map ] map ] [ % cond ] bake ; + rest [ body>> >array [ convert-form ] map first2 swap `{ [ % funcall ] , } bake ] + map >array [ , cond ] bake ; : convert-general-form ( s-exp -- quot ) - unclip convert-form swap convert-body [ , lookup-vars % funcall ] bake ; + unclip convert-form swap convert-body [ , % funcall ] bake ; ! words for convert-lambda ] dip - [ , lookup-vars cut swap [ % , ] bake , compose ] bake ; + [ , cut swap [ % , ] bake , compose ] bake ; : normal-lambda ( body vars -- quot ) - localize-lambda [ lookup-vars , compose ] bake ; + localize-lambda [ , compose ] bake ; PRIVATE> : convert-lambda ( s-exp -- quot ) @@ -68,8 +69,10 @@ PRIVATE> [ drop convert-general-form ] if ; : convert-form ( lisp-form -- quot ) - dup s-exp? [ body>> convert-list-form ] - [ [ , ] bake ] if ; + { { [ dup s-exp? ] [ body>> convert-list-form ] } + { [ dup lisp-symbol? ] [ [ , lookup-var ] bake ] } + [ [ , ] bake ] + } cond ; : lisp-string>factor ( str -- quot ) lisp-expr parse-result-ast convert-form lambda-rewrite call ; @@ -88,11 +91,11 @@ ERROR: no-such-var var ; : lisp-get ( name -- word ) dup lisp-env get at [ ] [ no-such-var throw ] ?if ; +: lookup-var ( lisp-symbol -- quot ) + name>> lisp-get ; + : funcall ( quot sym -- * ) - dup lisp-symbol? [ name>> lisp-get ] when call ; inline - -: lookup-vars ( q -- p ) - [ dup lisp-symbol? [ name>> lisp-get ] when ] map ; + dup lisp-symbol? [ lookup-var ] when call ; inline : define-primitve ( name vocab word -- ) swap lookup [ [ , ] compose call ] bake lisp-define ; \ No newline at end of file From b2cbe83be8c7159d53a000d5b1c3f2711b2ac177 Mon Sep 17 00:00:00 2001 From: James Cash Date: Mon, 19 May 2008 17:09:30 -0400 Subject: [PATCH 09/18] Adding tests for 'begin' --- extra/lisp/lisp-tests.factor | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/extra/lisp/lisp-tests.factor b/extra/lisp/lisp-tests.factor index fd6e2d93ae..05ce63a69d 100644 --- a/extra/lisp/lisp-tests.factor +++ b/extra/lisp/lisp-tests.factor @@ -34,4 +34,12 @@ init-env { "b" } [ "(cond (#f \"a\") (#t \"b\"))" lisp-string>factor call +] unit-test + +{ 5 } [ + "(begin (+ 1 4))" lisp-string>factor call +] unit-test + +{ 3 } [ + "((lambda (x) (if x (begin (+ 1 2)) (- 3 5))) #t)" lisp-string>factor call ] unit-test \ No newline at end of file From 12d0367d73ad9b717c13c058a65b6cc9fb35c722 Mon Sep 17 00:00:00 2001 From: James Cash Date: Mon, 19 May 2008 17:09:43 -0400 Subject: [PATCH 10/18] Fixing 'begin' --- extra/lisp/lisp.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor index c9bdf6c91a..0f5e4b4d2e 100644 --- a/extra/lisp/lisp.factor +++ b/extra/lisp/lisp.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel peg sequences arrays strings combinators.lib namespaces combinators math bake locals locals.private accessors -vectors syntax lisp.parser assocs parser sequences.lib words ; +vectors syntax lisp.parser assocs parser sequences.lib words quotations ; IN: lisp DEFER: convert-form @@ -18,7 +18,7 @@ DEFER: lookup-var rest [ convert-form ] map reverse first3 [ % , , if ] bake ; : convert-begin ( s-exp -- quot ) - rest convert-form ; + rest [ convert-form ] map >quotation [ , [ funcall ] each ] bake ; : convert-cond ( s-exp -- quot ) rest [ body>> >array [ convert-form ] map first2 swap `{ [ % funcall ] , } bake ] From 56852d3ab861d86fd92bce9383f558648498e117 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 22 May 2008 15:45:30 -0500 Subject: [PATCH 11/18] Little cleanups --- core/debugger/debugger.factor | 2 +- core/kernel/kernel.factor | 6 ++++-- extra/concurrency/mailboxes/mailboxes.factor | 2 +- extra/shuffle/shuffle.factor | 2 -- extra/tools/test/ui/ui.factor | 2 +- extra/webapps/pastebin/pastebin.factor | 6 +++--- 6 files changed, 10 insertions(+), 10 deletions(-) diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor index e6dfb79e07..17219ba92b 100755 --- a/core/debugger/debugger.factor +++ b/core/debugger/debugger.factor @@ -93,7 +93,7 @@ M: relative-overflow summary drop "Superfluous items pushed to data stack" ; : assert-depth ( quot -- ) - >r datastack r> swap slip >r datastack r> + >r datastack r> dip >r datastack r> 2dup [ length ] compare { { +lt+ [ trim-datastacks nip relative-underflow ] } { +eq+ [ 2drop ] } diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index a989d6c833..9112dbf25e 100755 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -57,6 +57,8 @@ DEFER: if : dip ( obj quot -- obj ) swap slip ; inline +: 2dip ( obj1 obj2 quot -- obj1 obj2 ) -rot 2slip ; inline + ! Keepers : keep ( x quot -- x ) over slip ; inline @@ -88,14 +90,14 @@ DEFER: if ! Spreaders : bi* ( x y p q -- ) - >r swap slip r> call ; inline + >r dip r> call ; inline : tri* ( x y z p q r -- ) >r rot >r bi* r> r> call ; inline ! Double spreaders : 2bi* ( w x y z p q -- ) - >r -rot 2slip r> call ; inline + >r 2dip r> call ; inline ! Appliers : bi@ ( x y quot -- ) diff --git a/extra/concurrency/mailboxes/mailboxes.factor b/extra/concurrency/mailboxes/mailboxes.factor index faa3a29610..1f94e018c9 100755 --- a/extra/concurrency/mailboxes/mailboxes.factor +++ b/extra/concurrency/mailboxes/mailboxes.factor @@ -58,7 +58,7 @@ M: mailbox dispose* threads>> notify-all ; : while-mailbox-empty ( mailbox quot -- ) over mailbox-empty? [ - dup >r swap slip r> while-mailbox-empty + dup >r dip r> while-mailbox-empty ] [ 2drop ] if ; inline diff --git a/extra/shuffle/shuffle.factor b/extra/shuffle/shuffle.factor index 3d8a390d13..2366d15cff 100644 --- a/extra/shuffle/shuffle.factor +++ b/extra/shuffle/shuffle.factor @@ -5,8 +5,6 @@ USING: kernel sequences namespaces math inference.transforms IN: shuffle -: 2dip -rot 2slip ; inline - MACRO: npick ( n -- ) 1- dup saver [ dup ] rot [ r> swap ] n*quot 3append ; MACRO: ndup ( n -- ) dup [ npick ] curry n*quot ; diff --git a/extra/tools/test/ui/ui.factor b/extra/tools/test/ui/ui.factor index 8825cffa4d..666a7d24d9 100755 --- a/extra/tools/test/ui/ui.factor +++ b/extra/tools/test/ui/ui.factor @@ -10,7 +10,7 @@ IN: tools.test.ui \ graft-queue [ over graft notify-queued - swap slip + dip ungraft notify-queued ] with-variable ] with-string-writer print ; diff --git a/extra/webapps/pastebin/pastebin.factor b/extra/webapps/pastebin/pastebin.factor index a18eb8147c..273b250695 100644 --- a/extra/webapps/pastebin/pastebin.factor +++ b/extra/webapps/pastebin/pastebin.factor @@ -64,14 +64,14 @@ annotation "ANNOTATION" ] unless ; : ( -- form ) - "paste"
+ "annotation" + "annotation" pastebin-template >>view-template "id" hidden >>renderer add-field "aid" hidden >>renderer add-field - "annotation" pastebin-template >>view-template "summary" add-field "author" add-field "mode" add-field @@ -79,7 +79,7 @@ annotation "ANNOTATION" "date" add-field ; : ( -- form ) - "paste" + "annotation" "new-annotation" pastebin-template >>edit-template "id" hidden >>renderer From 17f6513602bc702551e8b93d6bf7c432875fd910 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 22 May 2008 17:28:15 -0500 Subject: [PATCH 12/18] Cleanup --- extra/strings/lib/lib.factor | 13 +++++-------- 1 file changed, 5 insertions(+), 8 deletions(-) diff --git a/extra/strings/lib/lib.factor b/extra/strings/lib/lib.factor index c6299e6b08..ec4c70f6bf 100644 --- a/extra/strings/lib/lib.factor +++ b/extra/strings/lib/lib.factor @@ -1,10 +1,7 @@ -USING: math arrays sequences kernel random splitting strings unicode.case ; +USING: math math.ranges arrays sequences kernel random splitting +strings unicode.case ; IN: strings.lib -: char>digit ( c -- i ) 48 - ; - -: string>digits ( s -- seq ) [ char>digit ] { } map-as ; - : >Upper ( str -- str ) dup empty? [ unclip ch>upper 1string prepend @@ -14,13 +11,13 @@ IN: strings.lib "-" split [ >Upper ] map "-" join ; : lower-alpha-chars ( -- seq ) - 26 [ CHAR: a + ] map ; + CHAR: a CHAR: z [a,b] ; : upper-alpha-chars ( -- seq ) - 26 [ CHAR: A + ] map ; + CHAR: A CHAR: Z [a,b] ; : numeric-chars ( -- seq ) - 10 [ CHAR: 0 + ] map ; + CHAR: 0 CHAR: 9 [a,b] ; : alpha-chars ( -- seq ) lower-alpha-chars upper-alpha-chars append ; From e22bc694619ad6a9595b1e186f2b2908870511ab Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 22 May 2008 17:38:51 -0500 Subject: [PATCH 13/18] Fix for builder --- extra/lisp/lisp-tests.factor | 80 ++++++++++++++++++------------------ 1 file changed, 41 insertions(+), 39 deletions(-) diff --git a/extra/lisp/lisp-tests.factor b/extra/lisp/lisp-tests.factor index 05ce63a69d..f1db203a78 100644 --- a/extra/lisp/lisp-tests.factor +++ b/extra/lisp/lisp-tests.factor @@ -4,42 +4,44 @@ USING: lisp lisp.parser tools.test sequences math kernel parser ; IN: lisp.test -init-env - -"#f" [ f ] lisp-define -"#t" [ t ] lisp-define - -"+" "math" "+" define-primitve -"-" "math" "-" define-primitve - -{ 5 } [ - [ 2 3 ] "+" funcall -] unit-test - -{ 8.3 } [ - [ 10.4 2.1 ] "-" funcall -] unit-test - -{ 3 } [ - "((lambda (x y) (+ x y)) 1 2)" lisp-string>factor call -] unit-test - -{ 42 } [ - "((lambda (x y z) (+ x (- y z))) 40 3 1)" lisp-string>factor call -] unit-test - -{ 1 } [ - "(if #t 1 2)" lisp-string>factor call -] unit-test - -{ "b" } [ - "(cond (#f \"a\") (#t \"b\"))" lisp-string>factor call -] unit-test - -{ 5 } [ - "(begin (+ 1 4))" lisp-string>factor call -] unit-test - -{ 3 } [ - "((lambda (x) (if x (begin (+ 1 2)) (- 3 5))) #t)" lisp-string>factor call -] unit-test \ No newline at end of file +[ + init-env + + "#f" [ f ] lisp-define + "#t" [ t ] lisp-define + + "+" "math" "+" define-primitve + "-" "math" "-" define-primitve + + { 5 } [ + [ 2 3 ] "+" funcall + ] unit-test + + { 8.3 } [ + [ 10.4 2.1 ] "-" funcall + ] unit-test + + { 3 } [ + "((lambda (x y) (+ x y)) 1 2)" lisp-string>factor call + ] unit-test + + { 42 } [ + "((lambda (x y z) (+ x (- y z))) 40 3 1)" lisp-string>factor call + ] unit-test + + { 1 } [ + "(if #t 1 2)" lisp-string>factor call + ] unit-test + + { "b" } [ + "(cond (#f \"a\") (#t \"b\"))" lisp-string>factor call + ] unit-test + + { 5 } [ + "(begin (+ 1 4))" lisp-string>factor call + ] unit-test + + { 3 } [ + "((lambda (x) (if x (begin (+ 1 2)) (- 3 5))) #t)" lisp-string>factor call + ] unit-test +] with-interactive-vocabs \ No newline at end of file From eee90b69c43a91339d70a0d65f13b6e8d39e721f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 22 May 2008 17:43:51 -0500 Subject: [PATCH 14/18] Another cleanup --- extra/strings/lib/lib.factor | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/extra/strings/lib/lib.factor b/extra/strings/lib/lib.factor index ec4c70f6bf..e1d88e479d 100644 --- a/extra/strings/lib/lib.factor +++ b/extra/strings/lib/lib.factor @@ -3,9 +3,7 @@ strings unicode.case ; IN: strings.lib : >Upper ( str -- str ) - dup empty? [ - unclip ch>upper 1string prepend - ] unless ; + dup empty? [ unclip ch>upper prefix ] unless ; : >Upper-dashes ( str -- str ) "-" split [ >Upper ] map "-" join ; From 6d457a3dc82e0bba6739b7252df787fc75f3d699 Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Thu, 22 May 2008 23:14:50 -0500 Subject: [PATCH 15/18] Fix typo --- extra/windows/com/wrapper/wrapper.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/windows/com/wrapper/wrapper.factor b/extra/windows/com/wrapper/wrapper.factor index 5b7bb63590..78073dbdc8 100755 --- a/extra/windows/com/wrapper/wrapper.factor +++ b/extra/windows/com/wrapper/wrapper.factor @@ -29,7 +29,7 @@ unless >r find-com-interface-definition family-tree r> 1quotation [ >r iid>> r> 2array ] curry map ] map-index concat - [ f ] prefix , + [ f ] suffix , \ case , "void*" heap-size [ * rot com-add-ref 0 rot set-void*-nth S_OK ] From 9650b46688af847598f8e22cb38fe155c36e7a27 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 23 May 2008 00:11:44 -0500 Subject: [PATCH 16/18] newfx: few more words for dns --- extra/newfx/newfx.factor | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/extra/newfx/newfx.factor b/extra/newfx/newfx.factor index 2b2f916aea..abe0449d06 100644 --- a/extra/newfx/newfx.factor +++ b/extra/newfx/newfx.factor @@ -160,6 +160,16 @@ METHOD: as-mutate { object object assoc } set-at ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: subseq ( seq from to -- subseq ) rot sequences:subseq ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: key ( table val -- key ) swap assocs:value-at ; + +: key-of ( val table -- key ) assocs:value-at ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + : 1st 0 at ; : 2nd 1 at ; : 3rd 2 at ; From 9c569034f63ac06558b53608cbb703358e815627 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 23 May 2008 00:12:01 -0500 Subject: [PATCH 17/18] factor.el: couple of font-lock words --- misc/factor.el | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/misc/factor.el b/misc/factor.el index 7513c3640d..9d90fb68f9 100644 --- a/misc/factor.el +++ b/misc/factor.el @@ -82,6 +82,7 @@ ("^!.*$" . font-lock-comment-face) (" !.*$" . font-lock-comment-face) ("( .* )" . font-lock-comment-face) + "BIN:" "MAIN:" "IN:" "USING:" "TUPLE:" "^C:" "^M:" "METHOD:" @@ -89,7 +90,9 @@ "REQUIRES:" "GENERIC:" "GENERIC#" "SYMBOL:" "PREDICATE:" "VAR:" "VARS:" "C-STRUCT:" - "C-UNION:" "" "MACRO:" "MACRO::" "DEFER:" "TYPEDEF:")) + "C-UNION:" "" "MACRO:" "MACRO::" "DEFER:" "TYPEDEF:" + "SYMBOLS:" +)) (defun factor-mode () "A mode for editing programs written in the Factor programming language." From ff553f6aa0a67039ff2f3a1822d265e83f3b7237 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 23 May 2008 00:12:38 -0500 Subject: [PATCH 18/18] New vocabulary: dns --- extra/dns/cache/cache.factor | 142 +++++++++++ extra/dns/dns.factor | 462 +++++++++++++++++++++++++++++++++++ 2 files changed, 604 insertions(+) create mode 100644 extra/dns/cache/cache.factor create mode 100644 extra/dns/dns.factor diff --git a/extra/dns/cache/cache.factor b/extra/dns/cache/cache.factor new file mode 100644 index 0000000000..e497192b04 --- /dev/null +++ b/extra/dns/cache/cache.factor @@ -0,0 +1,142 @@ + +USING: kernel system + combinators + vectors sequences assocs + math math.functions + prettyprint unicode.case + accessors + combinators.cleave + newfx + dns ; + +IN: dns.cache + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: cache ( -- table ) H{ } ; + +! key: 'name type class' (as string) +! val: entry + +TUPLE: entry time data ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: query->key ( query -- key ) + { [ name>> >lower ] [ type>> unparse ] [ class>> unparse ] } " " join ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: table-get ( query -- result ) query->key cache of ; + +: table-check ( query -- ? ) query->key cache key? ; + +: table-add ( query value -- ) [ query->key ] [ ] bi* cache at-mutate ; + +: table-rem ( query -- ) query->key cache delete-key-of drop ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: now ( -- seconds ) millis 1000.0 / round >integer ; + +: ttl->time ( ttl -- seconds ) now + ; + +: time->ttl ( time -- ttl ) now - ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: NX + +: cache-nx ( query ttl -- ) + ttl->time NX entry boa + table-add ; + +: nx? ( obj -- ? ) + dup entry? + [ data>> NX = ] + [ drop f ] + if ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: query->rr ( query -- rr ) [ name>> ] [ type>> ] [ class>> ] tri f f rr boa ; + +: query+entry->rrs ( query entry -- rrs ) + swap ! entry query + query->rr ! entry rr + over ! entry rr entry + time>> time->ttl >>ttl ! entry rr + swap ! rr entry + data>> [ >r dup clone r> >>rdata ] map + nip ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: entry-expired? ( entry -- ? ) time>> time->ttl 0 <= ; + +: cache-get ( query -- result ) + dup table-get ! query result + { + { + [ dup f = ] ! not in the cache + [ 2drop f ] + } + { + [ dup entry-expired? ] ! here but expired + [ drop table-rem f ] + } + { + [ dup nx? ] ! negative result has been cached + [ 2drop NX ] + } + { + [ t ] + [ query+entry->rrs ] + } + } + cond ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: rr->entry ( rr -- entry ) + [ ttl>> ttl->time ] [ rdata>> {1} >vector ] bi entry boa ; + +: maybe-pushed-on ( obj seq -- ) + 2dup member-of? + [ 2drop ] + [ pushed-on ] + if ; + +: add-rr-to-entry ( rr entry -- ) + over ttl>> ttl->time >>time + [ rdata>> ] [ data>> ] bi* maybe-pushed-on ; + +: cache-add ( query rr -- ) + over table-get ! query rr entry + { + { + [ dup f = ] ! not in the cache + [ drop rr->entry table-add ] + } + { + [ dup nx? ] + [ drop over table-rem rr->entry table-add ] + } + { + [ dup entry-expired? ] + [ drop rr->entry table-add ] + } + { + [ t ] + [ rot drop add-rr-to-entry ] + } + } + cond ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: rr->query ( rr -- query ) [ name>> ] [ type>> ] [ class>> ] tri query boa ; + +: cache-add-rr ( rr -- ) [ rr->query ] [ ] bi cache-add ; + +: cache-add-rrs ( rrs -- ) [ cache-add-rr ] each ; diff --git a/extra/dns/dns.factor b/extra/dns/dns.factor new file mode 100644 index 0000000000..560db69bb2 --- /dev/null +++ b/extra/dns/dns.factor @@ -0,0 +1,462 @@ + +USING: kernel byte-arrays combinators strings arrays sequences splitting + math math.functions math.parser random + destructors + io io.binary io.sockets io.encodings.binary + accessors + combinators.cleave + newfx + symbols + ; + +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 ; + +: 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 } + } ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! 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 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 ; + +: 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 of uint16->ba ] + [ class>> class-table of uint16->ba ] + } + 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 ] + } + 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 of uint16->ba ] + [ class>> class-table of uint16->ba ] + [ ttl>> uint32->ba ] + [ + [ type>> ] [ rdata>> ] bi rdata->ba + [ length uint16->ba ] [ ] bi append + ] + } + concat ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: header-bits-ba ( message -- ba ) + { + [ qr>> 15 shift ] + [ opcode>> opcode-table of 11 shift ] + [ aa>> 10 shift ] + [ tc>> 9 shift ] + [ rd>> 8 shift ] + [ ra>> 7 shift ] + [ z>> 4 shift ] + [ rcode>> rcode-table of 0 shift ] + } + sum 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 ] + } + 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 + "." swap 3append + ] + } + } + cond ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: get-query ( ba i -- query ) + [ get-name ] + [ + skip-name + [ 0 + get-double type-table key-of ] + [ 2 + get-double class-table key-of ] + 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-rdata ( ba i type -- rdata ) + { + { CNAME [ get-name ] } + { NS [ get-name ] } + { PTR [ get-name ] } + { MX [ get-mx ] } + { SOA [ get-soa ] } + { A [ get-ip ] } + } + case ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: get-rr ( ba i -- rr ) + [ get-name ] + [ + skip-name + { + [ 0 + get-double type-table key-of ] + [ 2 + get-double class-table key-of ] + [ 4 + get-quad ] + [ [ 10 + ] [ get-double type-table key-of ] 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 ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: >> 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 key-of ] + [ 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 key-of ] + } + 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 + >r >r >r + get-question-section r> + get-rr-section r> + get-rr-section r> + get-rr-section + 2drop + ] + } + 2cleave message boa ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: send-receive-udp ( ba server -- ba ) + f 0 + [ + [ 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 ] + [ ] + 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 ) swap {1} >>question-section ; \ No newline at end of file