+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays classes kernel sequences sets
-io prettyprint multi-methods ;
-IN: boolean-expr
-
-! Demonstrates the use of Unicode symbols in source files, and
-! multi-method dispatch.
-
-TUPLE: ⋀ x y ;
-TUPLE: ⋁ x y ;
-TUPLE: ¬ x ;
-
-SINGLETONS: ⊤ ⊥ ;
-
-SINGLETONS: P Q R S T U V W X Y Z ;
-
-UNION: □ ⋀ ⋁ ¬ ⊤ ⊥ P Q R S T U V W X Y Z ;
-
-GENERIC: ⋀ ( x y -- expr )
-
-METHOD: ⋀ { ⊤ □ } nip ;
-METHOD: ⋀ { □ ⊤ } drop ;
-METHOD: ⋀ { ⊥ □ } drop ;
-METHOD: ⋀ { □ ⊥ } nip ;
-
-METHOD: ⋀ { ⋁ □ } [ [ x>> ] dip ⋀ ] [ [ y>> ] dip ⋀ ] 2bi ⋁ ;
-METHOD: ⋀ { □ ⋁ } [ x>> ⋀ ] [ y>> ⋀ ] 2bi ⋁ ;
-
-METHOD: ⋀ { □ □ } \ ⋀ boa ;
-
-GENERIC: ⋁ ( x y -- expr )
-
-METHOD: ⋁ { ⊤ □ } drop ;
-METHOD: ⋁ { □ ⊤ } nip ;
-METHOD: ⋁ { ⊥ □ } nip ;
-METHOD: ⋁ { □ ⊥ } drop ;
-
-METHOD: ⋁ { □ □ } \ ⋁ boa ;
-
-GENERIC: ¬ ( x -- expr )
-
-METHOD: ¬ { ⊤ } drop ⊥ ;
-METHOD: ¬ { ⊥ } drop ⊤ ;
-
-METHOD: ¬ { ⋀ } [ x>> ¬ ] [ y>> ¬ ] bi ⋁ ;
-METHOD: ¬ { ⋁ } [ x>> ¬ ] [ y>> ¬ ] bi ⋀ ;
-
-METHOD: ¬ { □ } \ ¬ boa ;
-
-: → ( x y -- expr ) ¬ ⋀ ;
-: ⊕ ( x y -- expr ) [ ⋁ ] [ ⋀ ¬ ] 2bi ⋀ ;
-: ≣ ( x y -- expr ) [ ⋀ ] [ [ ¬ ] bi@ ⋀ ] 2bi ⋁ ;
-
-GENERIC: (cnf) ( expr -- cnf )
-
-METHOD: (cnf) { ⋀ } [ x>> (cnf) ] [ y>> (cnf) ] bi append ;
-METHOD: (cnf) { □ } 1array ;
-
-GENERIC: cnf ( expr -- cnf )
-
-METHOD: cnf { ⋁ } [ x>> cnf ] [ y>> cnf ] bi append ;
-METHOD: cnf { □ } (cnf) 1array ;
-
-GENERIC: satisfiable? ( expr -- ? )
-
-METHOD: satisfiable? { ⊤ } drop t ;
-METHOD: satisfiable? { ⊥ } drop f ;
-
-: partition ( seq quot -- left right )
- [ [ not ] compose filter ] [ filter ] 2bi ; inline
-
-: (satisfiable?) ( seq -- ? )
- [ \ ¬ instance? ] partition [ x>> ] map intersect empty? ;
-
-METHOD: satisfiable? { □ }
- cnf [ (satisfiable?) ] any? ;
-
-GENERIC: (expr.) ( expr -- )
-
-METHOD: (expr.) { □ } pprint ;
-
-: op. ( expr -- )
- "(" write
- [ x>> (expr.) ]
- [ bl class pprint bl ]
- [ y>> (expr.) ]
- tri
- ")" write ;
-
-METHOD: (expr.) { ⋀ } op. ;
-METHOD: (expr.) { ⋁ } op. ;
-METHOD: (expr.) { ¬ } [ class pprint ] [ x>> (expr.) ] bi ;
-
-: expr. ( expr -- ) (expr.) nl ;
+++ /dev/null
-Simple boolean expression evaluator and simplifier
+++ /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
- newfx
- ;
-
-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 of uint16->ba ]
- [ class>> class-table of 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 of uint16->ba ]
- [ class>> class-table of 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 of 11 shift ]
- [ aa>> 10 shift ]
- [ tc>> 9 shift ]
- [ rd>> 8 shift ]
- [ ra>> 7 shift ]
- [ z>> 4 shift ]
- [ rcode>> rcode-table of 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 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-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 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 ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: >> ( 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 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
- {
- [ 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>> 1st ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-ERROR: name-error name ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: fully-qualified ( name -- name )
- {
- { [ dup empty? ] [ "." append ] }
- { [ dup peek 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 newfx dns.util ;
-
-IN: dns.misc
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: resolv-conf-servers ( -- seq )
- "/etc/resolv.conf" utf8 file-lines
- [ " " split ] map
- [ 1st "nameserver" = ] filter
- [ 2nd ] 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
- newfx 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 prefix-on ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! 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 ]
- [ 1st swap clone over rdata>> >>name query->rrs prefix-on ]
- [ 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 ] compare ] sort 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
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2008, 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math sequences vectors classes classes.algebra
-combinators arrays words assocs parser namespaces make
-definitions prettyprint prettyprint.backend prettyprint.custom
-quotations generalizations debugger io compiler.units
-kernel.private effects accessors hashtables sorting shuffle
-math.order sets see effects.parser ;
-IN: multi-methods
-
-! PART I: Converting hook specializers
-: canonicalize-specializer-0 ( specializer -- specializer' )
- [ \ f or ] map ;
-
-SYMBOL: args
-
-SYMBOL: hooks
-
-SYMBOL: total
-
-: canonicalize-specializer-1 ( specializer -- specializer' )
- [
- [ class? ] filter
- [ length <reversed> [ 1+ neg ] map ] keep zip
- [ length args [ max ] change ] keep
- ]
- [
- [ pair? ] filter
- [ keys [ hooks get adjoin ] each ] keep
- ] bi append ;
-
-: canonicalize-specializer-2 ( specializer -- specializer' )
- [
- [
- {
- { [ dup integer? ] [ ] }
- { [ dup word? ] [ hooks get index ] }
- } cond args get +
- ] dip
- ] assoc-map ;
-
-: canonicalize-specializer-3 ( specializer -- specializer' )
- [ total get object <array> dup <enum> ] dip update ;
-
-: canonicalize-specializers ( methods -- methods' hooks )
- [
- [ [ canonicalize-specializer-0 ] dip ] assoc-map
-
- 0 args set
- V{ } clone hooks set
-
- [ [ canonicalize-specializer-1 ] dip ] assoc-map
-
- hooks [ natural-sort ] change
-
- [ [ canonicalize-specializer-2 ] dip ] assoc-map
-
- args get hooks get length + total set
-
- [ [ canonicalize-specializer-3 ] dip ] assoc-map
-
- hooks get
- ] with-scope ;
-
-: drop-n-quot ( n -- quot ) \ drop <repetition> >quotation ;
-
-: prepare-method ( method n -- quot )
- [ 1quotation ] [ drop-n-quot ] bi* prepend ;
-
-: prepare-methods ( methods -- methods' prologue )
- canonicalize-specializers
- [ length [ prepare-method ] curry assoc-map ] keep
- [ [ get ] curry ] map concat [ ] like ;
-
-! Part II: Topologically sorting specializers
-: maximal-element ( seq quot -- n elt )
- dupd [
- swapd [ call +lt+ = ] 2curry filter empty?
- ] 2curry find [ "Topological sort failed" throw ] unless* ;
- inline
-
-: topological-sort ( seq quot -- newseq )
- [ >vector [ dup empty? not ] ] dip
- [ dupd maximal-element [ over delete-nth ] dip ] curry
- produce nip ; inline
-
-: classes< ( seq1 seq2 -- lt/eq/gt )
- [
- {
- { [ 2dup eq? ] [ +eq+ ] }
- { [ 2dup [ class<= ] [ swap class<= ] 2bi and ] [ +eq+ ] }
- { [ 2dup class<= ] [ +lt+ ] }
- { [ 2dup swap class<= ] [ +gt+ ] }
- [ +eq+ ]
- } cond 2nip
- ] 2map [ +eq+ eq? not ] find nip +eq+ or ;
-
-: sort-methods ( alist -- alist' )
- [ [ first ] bi@ classes< ] topological-sort ;
-
-! PART III: Creating dispatch quotation
-: picker ( n -- quot )
- {
- { 0 [ [ dup ] ] }
- { 1 [ [ over ] ] }
- { 2 [ [ pick ] ] }
- [ 1- picker [ dip swap ] curry ]
- } case ;
-
-: (multi-predicate) ( class picker -- quot )
- swap "predicate" word-prop append ;
-
-: multi-predicate ( classes -- quot )
- dup length <reversed>
- [ picker 2array ] 2map
- [ drop object eq? not ] assoc-filter
- [ [ t ] ] [
- [ (multi-predicate) ] { } assoc>map
- unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
- ] if-empty ;
-
-: argument-count ( methods -- n )
- keys 0 [ length max ] reduce ;
-
-ERROR: no-method arguments generic ;
-
-: make-default-method ( methods generic -- quot )
- [ argument-count ] dip [ [ narray ] dip no-method ] 2curry ;
-
-: multi-dispatch-quot ( methods generic -- quot )
- [ make-default-method ]
- [ drop [ [ multi-predicate ] dip ] assoc-map reverse ]
- 2bi alist>quot ;
-
-! Generic words
-PREDICATE: generic < word
- "multi-methods" word-prop >boolean ;
-
-: methods ( word -- alist )
- "multi-methods" word-prop >alist ;
-
-: make-generic ( generic -- quot )
- [
- [ methods prepare-methods % sort-methods ] keep
- multi-dispatch-quot %
- ] [ ] make ;
-
-: update-generic ( word -- )
- dup make-generic define ;
-
-! Methods
-PREDICATE: method-body < word
- "multi-method-generic" word-prop >boolean ;
-
-M: method-body stack-effect
- "multi-method-generic" word-prop stack-effect ;
-
-M: method-body crossref?
- "forgotten" word-prop not ;
-
-: method-word-name ( specializer generic -- string )
- [ name>> % "-" % unparse % ] "" make ;
-
-: method-word-props ( specializer generic -- assoc )
- [
- "multi-method-generic" set
- "multi-method-specializer" set
- ] H{ } make-assoc ;
-
-: <method> ( specializer generic -- word )
- [ method-word-props ] 2keep
- method-word-name f <word>
- swap >>props ;
-
-: with-methods ( word quot -- )
- over [
- [ "multi-methods" word-prop ] dip call
- ] dip update-generic ; inline
-
-: reveal-method ( method classes generic -- )
- [ set-at ] with-methods ;
-
-: method ( classes word -- method )
- "multi-methods" word-prop at ;
-
-: create-method ( classes generic -- method )
- 2dup method dup [
- 2nip
- ] [
- drop [ <method> dup ] 2keep reveal-method
- ] if ;
-
-: niceify-method ( seq -- seq )
- [ dup \ f eq? [ drop f ] when ] map ;
-
-M: no-method error.
- "Type check error" print
- nl
- "Generic word " write dup generic>> pprint
- " does not have a method applicable to inputs:" print
- dup arguments>> short.
- nl
- "Inputs have signature:" print
- dup arguments>> [ class ] map niceify-method .
- nl
- "Available methods: " print
- generic>> methods canonicalize-specializers drop sort-methods
- keys [ niceify-method ] map stack. ;
-
-: forget-method ( specializer generic -- )
- [ delete-at ] with-methods ;
-
-: method>spec ( method -- spec )
- [ "multi-method-specializer" word-prop ]
- [ "multi-method-generic" word-prop ] bi prefix ;
-
-: define-generic ( word effect -- )
- over set-stack-effect
- dup "multi-methods" word-prop [ drop ] [
- [ H{ } clone "multi-methods" set-word-prop ]
- [ update-generic ]
- bi
- ] if ;
-
-! Syntax
-SYNTAX: GENERIC: CREATE-WORD complete-effect define-generic ;
-
-: parse-method ( -- quot classes generic )
- parse-definition [ 2 tail ] [ second ] [ first ] tri ;
-
-: create-method-in ( specializer generic -- method )
- create-method dup save-location f set-word ;
-
-: CREATE-METHOD ( -- method )
- scan-word scan-object swap create-method-in ;
-
-: (METHOD:) ( -- method def ) CREATE-METHOD parse-definition ;
-
-SYNTAX: METHOD: (METHOD:) define ;
-
-! For compatibility
-SYNTAX: M:
- scan-word 1array scan-word create-method-in
- parse-definition
- define ;
-
-! Definition protocol. We qualify core generics here
-QUALIFIED: syntax
-
-syntax:M: generic definer drop \ GENERIC: f ;
-
-syntax:M: generic definition drop f ;
-
-PREDICATE: method-spec < array
- unclip generic? [ [ class? ] all? ] dip and ;
-
-syntax:M: method-spec where
- dup unclip method [ ] [ first ] ?if where ;
-
-syntax:M: method-spec set-where
- unclip method set-where ;
-
-syntax:M: method-spec definer
- unclip method definer ;
-
-syntax:M: method-spec definition
- unclip method definition ;
-
-syntax:M: method-spec synopsis*
- unclip method synopsis* ;
-
-syntax:M: method-spec forget*
- unclip method forget* ;
-
-syntax:M: method-body definer
- drop \ METHOD: \ ; ;
-
-syntax:M: method-body synopsis*
- dup definer.
- [ "multi-method-generic" word-prop pprint-word ]
- [ "multi-method-specializer" word-prop pprint* ] bi ;
+++ /dev/null
-Experimental multiple dispatch implementation
+++ /dev/null
-extensions
+++ /dev/null
-IN: multi-methods.tests
-USING: multi-methods tools.test math sequences namespaces system
-kernel strings ;
-
-[ { POSTPONE: f integer } ] [ { f integer } canonicalize-specializer-0 ] unit-test
-
-: setup-canon-test ( -- )
- 0 args set
- V{ } clone hooks set ;
-
-: canon-test-1 ( -- seq )
- { integer { cpu x86 } sequence } canonicalize-specializer-1 ;
-
-[ { { -2 integer } { -1 sequence } { cpu x86 } } ] [
- [
- setup-canon-test
- canon-test-1
- ] with-scope
-] unit-test
-
-[ { { 0 integer } { 1 sequence } { 2 x86 } } ] [
- [
- setup-canon-test
- canon-test-1
- canonicalize-specializer-2
- ] with-scope
-] unit-test
-
-[ { integer sequence x86 } ] [
- [
- setup-canon-test
- canon-test-1
- canonicalize-specializer-2
- args get hooks get length + total set
- canonicalize-specializer-3
- ] with-scope
-] unit-test
-
-CONSTANT: example-1
- {
- { { { cpu x86 } { os linux } } "a" }
- { { { cpu ppc } } "b" }
- { { string { os windows } } "c" }
- }
-
-[
- {
- { { object x86 linux } "a" }
- { { object ppc object } "b" }
- { { string object windows } "c" }
- }
- { cpu os }
-] [
- example-1 canonicalize-specializers
-] unit-test
-
-[
- {
- { { object x86 linux } [ drop drop "a" ] }
- { { object ppc object } [ drop drop "b" ] }
- { { string object windows } [ drop drop "c" ] }
- }
- [ \ cpu get \ os get ]
-] [
- example-1 prepare-methods
-] unit-test
+++ /dev/null
-IN: multi-methods.tests
-USING: multi-methods tools.test math sequences namespaces system
-kernel strings words compiler.units quotations ;
-
-DEFER: fake
-\ fake H{ } clone "multi-methods" set-word-prop
-
-[ "fake-{ }" ] [ { } \ fake method-word-name ] unit-test
-
-[ H{ { "multi-method-generic" fake } { "multi-method-specializer" { } } } ]
-[ { } \ fake method-word-props ] unit-test
-
-[ t ] [ { } \ fake <method> method-body? ] unit-test
-
-[
- [ { } [ ] ] [ \ fake methods prepare-methods [ sort-methods ] dip ] unit-test
-
- [ t ] [ { } \ fake multi-dispatch-quot callable? ] unit-test
-
- [ t ] [ \ fake make-generic quotation? ] unit-test
-
- [ ] [ \ fake update-generic ] unit-test
-
- DEFER: testing
-
- [ ] [ \ testing (( -- )) define-generic ] unit-test
-
- [ t ] [ \ testing generic? ] unit-test
-] with-compilation-unit
+++ /dev/null
-IN: multi-methods.tests
-USING: math strings sequences tools.test ;
-
-GENERIC: legacy-test ( a -- b )
-
-M: integer legacy-test sq ;
-M: string legacy-test " hey" append ;
-
-[ 25 ] [ 5 legacy-test ] unit-test
-[ "hello hey" ] [ "hello" legacy-test ] unit-test
+++ /dev/null
-IN: multi-methods.tests
-USING: multi-methods tools.test math sequences namespaces system
-kernel strings definitions prettyprint debugger arrays
-hashtables continuations classes assocs accessors see ;
-
-GENERIC: first-test ( -- )
-
-[ t ] [ \ first-test generic? ] unit-test
-
-MIXIN: thing
-
-SINGLETON: paper INSTANCE: paper thing
-SINGLETON: scissors INSTANCE: scissors thing
-SINGLETON: rock INSTANCE: rock thing
-
-GENERIC: beats? ( obj1 obj2 -- ? )
-
-METHOD: beats? { paper scissors } t ;
-METHOD: beats? { scissors rock } t ;
-METHOD: beats? { rock paper } t ;
-METHOD: beats? { thing thing } f ;
-
-: play ( obj1 obj2 -- ? ) beats? 2nip ;
-
-[ { } 3 play ] must-fail
-[ t ] [ error get no-method? ] unit-test
-[ ] [ error get error. ] unit-test
-[ { { } 3 } ] [ error get arguments>> ] unit-test
-[ t ] [ paper scissors play ] unit-test
-[ f ] [ scissors paper play ] unit-test
-
-[ t ] [ { beats? paper scissors } method-spec? ] unit-test
-[ ] [ { beats? paper scissors } see ] unit-test
-
-SYMBOL: some-var
-
-GENERIC: hook-test ( -- obj )
-
-METHOD: hook-test { array { some-var array } } reverse ;
-METHOD: hook-test { { some-var array } } class ;
-METHOD: hook-test { hashtable { some-var number } } assoc-size ;
-
-{ 1 2 3 } some-var set
-[ { f t t } ] [ { t t f } hook-test ] unit-test
-[ fixnum ] [ 3 hook-test ] unit-test
-5.0 some-var set
-[ 0 ] [ H{ } hook-test ] unit-test
-
-"error" some-var set
-[ H{ } hook-test ] must-fail
-[ t ] [ error get no-method? ] unit-test
-[ { H{ } "error" } ] [ error get arguments>> ] unit-test
-
-MIXIN: busted
-
-TUPLE: busted-1 ;
-TUPLE: busted-2 ; INSTANCE: busted-2 busted
-TUPLE: busted-3 ;
-
-GENERIC: busted-sort ( obj1 obj2 -- obj1 obj2 )
-
-METHOD: busted-sort { busted-1 busted-2 } ;
-METHOD: busted-sort { busted-2 busted-3 } ;
-METHOD: busted-sort { busted busted } ;
+++ /dev/null
-USING: kernel multi-methods tools.test math arrays sequences
-math.order ;
-IN: multi-methods.tests
-
-[ { 1 2 3 4 5 6 } ] [
- { 6 4 5 1 3 2 } [ <=> ] topological-sort
-] unit-test
-
-[ +lt+ ] [
- { fixnum array } { number sequence } classes<
-] unit-test
-
-[ +eq+ ] [
- { number sequence } { number sequence } classes<
-] unit-test
-
-[ +gt+ ] [
- { object object } { number sequence } classes<
-] unit-test
+++ /dev/null
-
-USING: kernel arrays strings sequences sequences.deep accessors peg peg.ebnf
- newfx ;
-
-IN: shell.parser
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: basic-expr command stdin stdout background ;
-TUPLE: pipeline-expr commands stdin stdout background ;
-TUPLE: single-quoted-expr expr ;
-TUPLE: double-quoted-expr expr ;
-TUPLE: back-quoted-expr expr ;
-TUPLE: glob-expr expr ;
-TUPLE: variable-expr expr ;
-TUPLE: factor-expr expr ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: ast>basic-expr ( ast -- obj ) first4 basic-expr boa ;
-
-: ast>pipeline-expr ( ast -- obj )
- pipeline-expr new
- over [ 1st ] [ 4th [ 1st ] map ] [ 5th ] tri suffix prefix-on >>commands
- over 2nd >>stdin
- over 6th >>stdout
- swap 7th >>background ;
-
-: ast>single-quoted-expr ( ast -- obj )
- 2nd >string single-quoted-expr boa ;
-
-: ast>double-quoted-expr ( ast -- obj )
- 2nd >string double-quoted-expr boa ;
-
-: ast>back-quoted-expr ( ast -- obj )
- 2nd >string back-quoted-expr boa ;
-
-: ast>glob-expr ( ast -- obj ) flatten concat glob-expr boa ;
-
-: ast>variable-expr ( ast -- obj ) 2nd variable-expr boa ;
-
-: ast>factor-expr ( ast -- obj ) 2nd >string factor-expr boa ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-EBNF: expr
-
-space = " "
-
-tab = "\t"
-
-white = (space | tab)
-
-_ = (white)* => [[ drop ignore ]]
-
-sq = "'"
-dq = '"'
-bq = "`"
-
-single-quoted = sq (!(sq) .)* sq => [[ ast>single-quoted-expr ]]
-double-quoted = dq (!(dq) .)* dq => [[ ast>double-quoted-expr ]]
-back-quoted = bq (!(bq) .)* bq => [[ ast>back-quoted-expr ]]
-
-factor = "$(" (!(")") .)* ")" => [[ ast>factor-expr ]]
-
-variable = "$" other => [[ ast>variable-expr ]]
-
-glob-char = ("*" | "?")
-
-non-glob-char = !(glob-char | white) .
-
-glob-beginning-string = (non-glob-char)* => [[ >string ]]
-
-glob-rest-string = (non-glob-char)+ => [[ >string ]]
-
-glob = glob-beginning-string glob-char (glob-rest-string | glob-char)* => [[ ast>glob-expr ]]
-
-other = (!(white | "&" | ">" | ">>" | "<" | "|") .)+ => [[ >string ]]
-
-element = (single-quoted | double-quoted | back-quoted | factor | variable | glob | other)
-
-command = (element _)+
-
-to-file = ">" _ other => [[ second ]]
-in-file = "<" _ other => [[ second ]]
-ap-file = ">>" _ other => [[ second ]]
-
-basic = _ command _ (in-file)? _ (to-file | ap-file)? _ ("&")? => [[ ast>basic-expr ]]
-
-pipeline = _ command _ (in-file)? _ "|" _ (command _ "|" _)* command _ (to-file | ap-file)? _ ("&")? => [[ ast>pipeline-expr ]]
-
-submission = (pipeline | basic)
-
-;EBNF
\ No newline at end of file
+++ /dev/null
-USING: kernel parser words continuations namespaces debugger
-sequences combinators splitting prettyprint system io io.files
-io.pathnames io.launcher io.directories io.encodings.utf8 io.pipes
-sequences.deep accessors multi-methods newfx shell.parser
-combinators.short-circuit eval environment ;
-IN: shell
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: cd ( args -- )
- dup empty?
- [ drop home set-current-directory ]
- [ first set-current-directory ]
- if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: pwd ( args -- )
- drop
- current-directory get
- print ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: swords ( -- seq ) { "cd" "pwd" } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: expand ( expr -- expr )
-
-METHOD: expand { single-quoted-expr } expr>> ;
-
-METHOD: expand { double-quoted-expr } expr>> ;
-
-METHOD: expand { variable-expr } expr>> os-env ;
-
-METHOD: expand { glob-expr }
- expr>>
- dup "*" =
- [ drop current-directory get directory-files ]
- [ ]
- if ;
-
-METHOD: expand { factor-expr } expr>> eval>string ;
-
-DEFER: expansion
-
-METHOD: expand { back-quoted-expr }
- expr>>
- expr
- command>>
- expansion
- utf8 <process-stream>
- contents
- " \n" split
- "" remove ;
-
-METHOD: expand { object } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: expansion ( command -- command ) [ expand ] map flatten ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: run-sword ( basic-expr -- )
- command>> expansion unclip "shell" lookup execute( arguments -- ) ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: run-foreground ( process -- )
- [ try-process ] [ print-error drop ] recover ;
-
-: run-background ( process -- ) run-detached drop ;
-
-: run-basic-expr ( basic-expr -- )
- <process>
- over command>> expansion >>command
- over stdin>> >>stdin
- over stdout>> >>stdout
- swap background>>
- [ run-background ]
- [ run-foreground ]
- if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: basic-chant ( basic-expr -- )
- dup command>> first swords member-of?
- [ run-sword ]
- [ run-basic-expr ]
- if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: pipeline-chant ( pipeline-chant -- ) commands>> run-pipeline drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: chant ( obj -- )
- dup basic-expr?
- [ basic-chant ]
- [ pipeline-chant ]
- if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: prompt ( -- )
- current-directory get write
- " $ " write
- flush ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-DEFER: shell
-
-: handle ( input -- )
- {
- { [ dup f = ] [ drop ] }
- { [ dup "exit" = ] [ drop ] }
- { [ dup "" = ] [ drop shell ] }
- { [ dup expr ] [ expr chant shell ] }
- { [ t ] [ drop "ix: ignoring input" print shell ] }
- }
- cond ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: shell ( -- )
- prompt
- readln
- handle ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: ix ( -- ) shell ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-MAIN: ix
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays classes kernel sequences sets
+io prettyprint multi-methods ;
+IN: boolean-expr
+
+! Demonstrates the use of Unicode symbols in source files, and
+! multi-method dispatch.
+
+TUPLE: ⋀ x y ;
+TUPLE: ⋁ x y ;
+TUPLE: ¬ x ;
+
+SINGLETONS: ⊤ ⊥ ;
+
+SINGLETONS: P Q R S T U V W X Y Z ;
+
+UNION: □ ⋀ ⋁ ¬ ⊤ ⊥ P Q R S T U V W X Y Z ;
+
+GENERIC: ⋀ ( x y -- expr )
+
+METHOD: ⋀ { ⊤ □ } nip ;
+METHOD: ⋀ { □ ⊤ } drop ;
+METHOD: ⋀ { ⊥ □ } drop ;
+METHOD: ⋀ { □ ⊥ } nip ;
+
+METHOD: ⋀ { ⋁ □ } [ [ x>> ] dip ⋀ ] [ [ y>> ] dip ⋀ ] 2bi ⋁ ;
+METHOD: ⋀ { □ ⋁ } [ x>> ⋀ ] [ y>> ⋀ ] 2bi ⋁ ;
+
+METHOD: ⋀ { □ □ } \ ⋀ boa ;
+
+GENERIC: ⋁ ( x y -- expr )
+
+METHOD: ⋁ { ⊤ □ } drop ;
+METHOD: ⋁ { □ ⊤ } nip ;
+METHOD: ⋁ { ⊥ □ } nip ;
+METHOD: ⋁ { □ ⊥ } drop ;
+
+METHOD: ⋁ { □ □ } \ ⋁ boa ;
+
+GENERIC: ¬ ( x -- expr )
+
+METHOD: ¬ { ⊤ } drop ⊥ ;
+METHOD: ¬ { ⊥ } drop ⊤ ;
+
+METHOD: ¬ { ⋀ } [ x>> ¬ ] [ y>> ¬ ] bi ⋁ ;
+METHOD: ¬ { ⋁ } [ x>> ¬ ] [ y>> ¬ ] bi ⋀ ;
+
+METHOD: ¬ { □ } \ ¬ boa ;
+
+: → ( x y -- expr ) ¬ ⋀ ;
+: ⊕ ( x y -- expr ) [ ⋁ ] [ ⋀ ¬ ] 2bi ⋀ ;
+: ≣ ( x y -- expr ) [ ⋀ ] [ [ ¬ ] bi@ ⋀ ] 2bi ⋁ ;
+
+GENERIC: (cnf) ( expr -- cnf )
+
+METHOD: (cnf) { ⋀ } [ x>> (cnf) ] [ y>> (cnf) ] bi append ;
+METHOD: (cnf) { □ } 1array ;
+
+GENERIC: cnf ( expr -- cnf )
+
+METHOD: cnf { ⋁ } [ x>> cnf ] [ y>> cnf ] bi append ;
+METHOD: cnf { □ } (cnf) 1array ;
+
+GENERIC: satisfiable? ( expr -- ? )
+
+METHOD: satisfiable? { ⊤ } drop t ;
+METHOD: satisfiable? { ⊥ } drop f ;
+
+: partition ( seq quot -- left right )
+ [ [ not ] compose filter ] [ filter ] 2bi ; inline
+
+: (satisfiable?) ( seq -- ? )
+ [ \ ¬ instance? ] partition [ x>> ] map intersect empty? ;
+
+METHOD: satisfiable? { □ }
+ cnf [ (satisfiable?) ] any? ;
+
+GENERIC: (expr.) ( expr -- )
+
+METHOD: (expr.) { □ } pprint ;
+
+: op. ( expr -- )
+ "(" write
+ [ x>> (expr.) ]
+ [ bl class pprint bl ]
+ [ y>> (expr.) ]
+ tri
+ ")" write ;
+
+METHOD: (expr.) { ⋀ } op. ;
+METHOD: (expr.) { ⋁ } op. ;
+METHOD: (expr.) { ¬ } [ class pprint ] [ x>> (expr.) ] bi ;
+
+: expr. ( expr -- ) (expr.) nl ;
--- /dev/null
+Simple boolean expression evaluator and simplifier
--- /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
+ newfx
+ ;
+
+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 of uint16->ba ]
+ [ class>> class-table of 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 of uint16->ba ]
+ [ class>> class-table of 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 of 11 shift ]
+ [ aa>> 10 shift ]
+ [ tc>> 9 shift ]
+ [ rd>> 8 shift ]
+ [ ra>> 7 shift ]
+ [ z>> 4 shift ]
+ [ rcode>> rcode-table of 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 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-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 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 ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: >> ( 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 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
+ {
+ [ 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>> 1st ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ERROR: name-error name ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: fully-qualified ( name -- name )
+ {
+ { [ dup empty? ] [ "." append ] }
+ { [ dup peek 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 newfx dns.util ;
+
+IN: dns.misc
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: resolv-conf-servers ( -- seq )
+ "/etc/resolv.conf" utf8 file-lines
+ [ " " split ] map
+ [ 1st "nameserver" = ] filter
+ [ 2nd ] 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
+ newfx 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 prefix-on ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! 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 ]
+ [ 1st swap clone over rdata>> >>name query->rrs prefix-on ]
+ [ 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 ] compare ] sort 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
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2008, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math sequences vectors classes classes.algebra
+combinators arrays words assocs parser namespaces make
+definitions prettyprint prettyprint.backend prettyprint.custom
+quotations generalizations debugger io compiler.units
+kernel.private effects accessors hashtables sorting shuffle
+math.order sets see effects.parser ;
+IN: multi-methods
+
+! PART I: Converting hook specializers
+: canonicalize-specializer-0 ( specializer -- specializer' )
+ [ \ f or ] map ;
+
+SYMBOL: args
+
+SYMBOL: hooks
+
+SYMBOL: total
+
+: canonicalize-specializer-1 ( specializer -- specializer' )
+ [
+ [ class? ] filter
+ [ length <reversed> [ 1+ neg ] map ] keep zip
+ [ length args [ max ] change ] keep
+ ]
+ [
+ [ pair? ] filter
+ [ keys [ hooks get adjoin ] each ] keep
+ ] bi append ;
+
+: canonicalize-specializer-2 ( specializer -- specializer' )
+ [
+ [
+ {
+ { [ dup integer? ] [ ] }
+ { [ dup word? ] [ hooks get index ] }
+ } cond args get +
+ ] dip
+ ] assoc-map ;
+
+: canonicalize-specializer-3 ( specializer -- specializer' )
+ [ total get object <array> dup <enum> ] dip update ;
+
+: canonicalize-specializers ( methods -- methods' hooks )
+ [
+ [ [ canonicalize-specializer-0 ] dip ] assoc-map
+
+ 0 args set
+ V{ } clone hooks set
+
+ [ [ canonicalize-specializer-1 ] dip ] assoc-map
+
+ hooks [ natural-sort ] change
+
+ [ [ canonicalize-specializer-2 ] dip ] assoc-map
+
+ args get hooks get length + total set
+
+ [ [ canonicalize-specializer-3 ] dip ] assoc-map
+
+ hooks get
+ ] with-scope ;
+
+: drop-n-quot ( n -- quot ) \ drop <repetition> >quotation ;
+
+: prepare-method ( method n -- quot )
+ [ 1quotation ] [ drop-n-quot ] bi* prepend ;
+
+: prepare-methods ( methods -- methods' prologue )
+ canonicalize-specializers
+ [ length [ prepare-method ] curry assoc-map ] keep
+ [ [ get ] curry ] map concat [ ] like ;
+
+! Part II: Topologically sorting specializers
+: maximal-element ( seq quot -- n elt )
+ dupd [
+ swapd [ call +lt+ = ] 2curry filter empty?
+ ] 2curry find [ "Topological sort failed" throw ] unless* ;
+ inline
+
+: topological-sort ( seq quot -- newseq )
+ [ >vector [ dup empty? not ] ] dip
+ [ dupd maximal-element [ over delete-nth ] dip ] curry
+ produce nip ; inline
+
+: classes< ( seq1 seq2 -- lt/eq/gt )
+ [
+ {
+ { [ 2dup eq? ] [ +eq+ ] }
+ { [ 2dup [ class<= ] [ swap class<= ] 2bi and ] [ +eq+ ] }
+ { [ 2dup class<= ] [ +lt+ ] }
+ { [ 2dup swap class<= ] [ +gt+ ] }
+ [ +eq+ ]
+ } cond 2nip
+ ] 2map [ +eq+ eq? not ] find nip +eq+ or ;
+
+: sort-methods ( alist -- alist' )
+ [ [ first ] bi@ classes< ] topological-sort ;
+
+! PART III: Creating dispatch quotation
+: picker ( n -- quot )
+ {
+ { 0 [ [ dup ] ] }
+ { 1 [ [ over ] ] }
+ { 2 [ [ pick ] ] }
+ [ 1- picker [ dip swap ] curry ]
+ } case ;
+
+: (multi-predicate) ( class picker -- quot )
+ swap "predicate" word-prop append ;
+
+: multi-predicate ( classes -- quot )
+ dup length <reversed>
+ [ picker 2array ] 2map
+ [ drop object eq? not ] assoc-filter
+ [ [ t ] ] [
+ [ (multi-predicate) ] { } assoc>map
+ unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
+ ] if-empty ;
+
+: argument-count ( methods -- n )
+ keys 0 [ length max ] reduce ;
+
+ERROR: no-method arguments generic ;
+
+: make-default-method ( methods generic -- quot )
+ [ argument-count ] dip [ [ narray ] dip no-method ] 2curry ;
+
+: multi-dispatch-quot ( methods generic -- quot )
+ [ make-default-method ]
+ [ drop [ [ multi-predicate ] dip ] assoc-map reverse ]
+ 2bi alist>quot ;
+
+! Generic words
+PREDICATE: generic < word
+ "multi-methods" word-prop >boolean ;
+
+: methods ( word -- alist )
+ "multi-methods" word-prop >alist ;
+
+: make-generic ( generic -- quot )
+ [
+ [ methods prepare-methods % sort-methods ] keep
+ multi-dispatch-quot %
+ ] [ ] make ;
+
+: update-generic ( word -- )
+ dup make-generic define ;
+
+! Methods
+PREDICATE: method-body < word
+ "multi-method-generic" word-prop >boolean ;
+
+M: method-body stack-effect
+ "multi-method-generic" word-prop stack-effect ;
+
+M: method-body crossref?
+ "forgotten" word-prop not ;
+
+: method-word-name ( specializer generic -- string )
+ [ name>> % "-" % unparse % ] "" make ;
+
+: method-word-props ( specializer generic -- assoc )
+ [
+ "multi-method-generic" set
+ "multi-method-specializer" set
+ ] H{ } make-assoc ;
+
+: <method> ( specializer generic -- word )
+ [ method-word-props ] 2keep
+ method-word-name f <word>
+ swap >>props ;
+
+: with-methods ( word quot -- )
+ over [
+ [ "multi-methods" word-prop ] dip call
+ ] dip update-generic ; inline
+
+: reveal-method ( method classes generic -- )
+ [ set-at ] with-methods ;
+
+: method ( classes word -- method )
+ "multi-methods" word-prop at ;
+
+: create-method ( classes generic -- method )
+ 2dup method dup [
+ 2nip
+ ] [
+ drop [ <method> dup ] 2keep reveal-method
+ ] if ;
+
+: niceify-method ( seq -- seq )
+ [ dup \ f eq? [ drop f ] when ] map ;
+
+M: no-method error.
+ "Type check error" print
+ nl
+ "Generic word " write dup generic>> pprint
+ " does not have a method applicable to inputs:" print
+ dup arguments>> short.
+ nl
+ "Inputs have signature:" print
+ dup arguments>> [ class ] map niceify-method .
+ nl
+ "Available methods: " print
+ generic>> methods canonicalize-specializers drop sort-methods
+ keys [ niceify-method ] map stack. ;
+
+: forget-method ( specializer generic -- )
+ [ delete-at ] with-methods ;
+
+: method>spec ( method -- spec )
+ [ "multi-method-specializer" word-prop ]
+ [ "multi-method-generic" word-prop ] bi prefix ;
+
+: define-generic ( word effect -- )
+ over set-stack-effect
+ dup "multi-methods" word-prop [ drop ] [
+ [ H{ } clone "multi-methods" set-word-prop ]
+ [ update-generic ]
+ bi
+ ] if ;
+
+! Syntax
+SYNTAX: GENERIC: CREATE-WORD complete-effect define-generic ;
+
+: parse-method ( -- quot classes generic )
+ parse-definition [ 2 tail ] [ second ] [ first ] tri ;
+
+: create-method-in ( specializer generic -- method )
+ create-method dup save-location f set-word ;
+
+: CREATE-METHOD ( -- method )
+ scan-word scan-object swap create-method-in ;
+
+: (METHOD:) ( -- method def ) CREATE-METHOD parse-definition ;
+
+SYNTAX: METHOD: (METHOD:) define ;
+
+! For compatibility
+SYNTAX: M:
+ scan-word 1array scan-word create-method-in
+ parse-definition
+ define ;
+
+! Definition protocol. We qualify core generics here
+QUALIFIED: syntax
+
+syntax:M: generic definer drop \ GENERIC: f ;
+
+syntax:M: generic definition drop f ;
+
+PREDICATE: method-spec < array
+ unclip generic? [ [ class? ] all? ] dip and ;
+
+syntax:M: method-spec where
+ dup unclip method [ ] [ first ] ?if where ;
+
+syntax:M: method-spec set-where
+ unclip method set-where ;
+
+syntax:M: method-spec definer
+ unclip method definer ;
+
+syntax:M: method-spec definition
+ unclip method definition ;
+
+syntax:M: method-spec synopsis*
+ unclip method synopsis* ;
+
+syntax:M: method-spec forget*
+ unclip method forget* ;
+
+syntax:M: method-body definer
+ drop \ METHOD: \ ; ;
+
+syntax:M: method-body synopsis*
+ dup definer.
+ [ "multi-method-generic" word-prop pprint-word ]
+ [ "multi-method-specializer" word-prop pprint* ] bi ;
--- /dev/null
+Experimental multiple dispatch implementation
--- /dev/null
+extensions
--- /dev/null
+IN: multi-methods.tests
+USING: multi-methods tools.test math sequences namespaces system
+kernel strings ;
+
+[ { POSTPONE: f integer } ] [ { f integer } canonicalize-specializer-0 ] unit-test
+
+: setup-canon-test ( -- )
+ 0 args set
+ V{ } clone hooks set ;
+
+: canon-test-1 ( -- seq )
+ { integer { cpu x86 } sequence } canonicalize-specializer-1 ;
+
+[ { { -2 integer } { -1 sequence } { cpu x86 } } ] [
+ [
+ setup-canon-test
+ canon-test-1
+ ] with-scope
+] unit-test
+
+[ { { 0 integer } { 1 sequence } { 2 x86 } } ] [
+ [
+ setup-canon-test
+ canon-test-1
+ canonicalize-specializer-2
+ ] with-scope
+] unit-test
+
+[ { integer sequence x86 } ] [
+ [
+ setup-canon-test
+ canon-test-1
+ canonicalize-specializer-2
+ args get hooks get length + total set
+ canonicalize-specializer-3
+ ] with-scope
+] unit-test
+
+CONSTANT: example-1
+ {
+ { { { cpu x86 } { os linux } } "a" }
+ { { { cpu ppc } } "b" }
+ { { string { os windows } } "c" }
+ }
+
+[
+ {
+ { { object x86 linux } "a" }
+ { { object ppc object } "b" }
+ { { string object windows } "c" }
+ }
+ { cpu os }
+] [
+ example-1 canonicalize-specializers
+] unit-test
+
+[
+ {
+ { { object x86 linux } [ drop drop "a" ] }
+ { { object ppc object } [ drop drop "b" ] }
+ { { string object windows } [ drop drop "c" ] }
+ }
+ [ \ cpu get \ os get ]
+] [
+ example-1 prepare-methods
+] unit-test
--- /dev/null
+IN: multi-methods.tests
+USING: multi-methods tools.test math sequences namespaces system
+kernel strings words compiler.units quotations ;
+
+DEFER: fake
+\ fake H{ } clone "multi-methods" set-word-prop
+
+[ "fake-{ }" ] [ { } \ fake method-word-name ] unit-test
+
+[ H{ { "multi-method-generic" fake } { "multi-method-specializer" { } } } ]
+[ { } \ fake method-word-props ] unit-test
+
+[ t ] [ { } \ fake <method> method-body? ] unit-test
+
+[
+ [ { } [ ] ] [ \ fake methods prepare-methods [ sort-methods ] dip ] unit-test
+
+ [ t ] [ { } \ fake multi-dispatch-quot callable? ] unit-test
+
+ [ t ] [ \ fake make-generic quotation? ] unit-test
+
+ [ ] [ \ fake update-generic ] unit-test
+
+ DEFER: testing
+
+ [ ] [ \ testing (( -- )) define-generic ] unit-test
+
+ [ t ] [ \ testing generic? ] unit-test
+] with-compilation-unit
--- /dev/null
+IN: multi-methods.tests
+USING: math strings sequences tools.test ;
+
+GENERIC: legacy-test ( a -- b )
+
+M: integer legacy-test sq ;
+M: string legacy-test " hey" append ;
+
+[ 25 ] [ 5 legacy-test ] unit-test
+[ "hello hey" ] [ "hello" legacy-test ] unit-test
--- /dev/null
+IN: multi-methods.tests
+USING: multi-methods tools.test math sequences namespaces system
+kernel strings definitions prettyprint debugger arrays
+hashtables continuations classes assocs accessors see ;
+
+GENERIC: first-test ( -- )
+
+[ t ] [ \ first-test generic? ] unit-test
+
+MIXIN: thing
+
+SINGLETON: paper INSTANCE: paper thing
+SINGLETON: scissors INSTANCE: scissors thing
+SINGLETON: rock INSTANCE: rock thing
+
+GENERIC: beats? ( obj1 obj2 -- ? )
+
+METHOD: beats? { paper scissors } t ;
+METHOD: beats? { scissors rock } t ;
+METHOD: beats? { rock paper } t ;
+METHOD: beats? { thing thing } f ;
+
+: play ( obj1 obj2 -- ? ) beats? 2nip ;
+
+[ { } 3 play ] must-fail
+[ t ] [ error get no-method? ] unit-test
+[ ] [ error get error. ] unit-test
+[ { { } 3 } ] [ error get arguments>> ] unit-test
+[ t ] [ paper scissors play ] unit-test
+[ f ] [ scissors paper play ] unit-test
+
+[ t ] [ { beats? paper scissors } method-spec? ] unit-test
+[ ] [ { beats? paper scissors } see ] unit-test
+
+SYMBOL: some-var
+
+GENERIC: hook-test ( -- obj )
+
+METHOD: hook-test { array { some-var array } } reverse ;
+METHOD: hook-test { { some-var array } } class ;
+METHOD: hook-test { hashtable { some-var number } } assoc-size ;
+
+{ 1 2 3 } some-var set
+[ { f t t } ] [ { t t f } hook-test ] unit-test
+[ fixnum ] [ 3 hook-test ] unit-test
+5.0 some-var set
+[ 0 ] [ H{ } hook-test ] unit-test
+
+"error" some-var set
+[ H{ } hook-test ] must-fail
+[ t ] [ error get no-method? ] unit-test
+[ { H{ } "error" } ] [ error get arguments>> ] unit-test
+
+MIXIN: busted
+
+TUPLE: busted-1 ;
+TUPLE: busted-2 ; INSTANCE: busted-2 busted
+TUPLE: busted-3 ;
+
+GENERIC: busted-sort ( obj1 obj2 -- obj1 obj2 )
+
+METHOD: busted-sort { busted-1 busted-2 } ;
+METHOD: busted-sort { busted-2 busted-3 } ;
+METHOD: busted-sort { busted busted } ;
--- /dev/null
+USING: kernel multi-methods tools.test math arrays sequences
+math.order ;
+IN: multi-methods.tests
+
+[ { 1 2 3 4 5 6 } ] [
+ { 6 4 5 1 3 2 } [ <=> ] topological-sort
+] unit-test
+
+[ +lt+ ] [
+ { fixnum array } { number sequence } classes<
+] unit-test
+
+[ +eq+ ] [
+ { number sequence } { number sequence } classes<
+] unit-test
+
+[ +gt+ ] [
+ { object object } { number sequence } classes<
+] unit-test
--- /dev/null
+
+USING: kernel arrays strings sequences sequences.deep accessors peg peg.ebnf
+ newfx ;
+
+IN: shell.parser
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: basic-expr command stdin stdout background ;
+TUPLE: pipeline-expr commands stdin stdout background ;
+TUPLE: single-quoted-expr expr ;
+TUPLE: double-quoted-expr expr ;
+TUPLE: back-quoted-expr expr ;
+TUPLE: glob-expr expr ;
+TUPLE: variable-expr expr ;
+TUPLE: factor-expr expr ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: ast>basic-expr ( ast -- obj ) first4 basic-expr boa ;
+
+: ast>pipeline-expr ( ast -- obj )
+ pipeline-expr new
+ over [ 1st ] [ 4th [ 1st ] map ] [ 5th ] tri suffix prefix-on >>commands
+ over 2nd >>stdin
+ over 6th >>stdout
+ swap 7th >>background ;
+
+: ast>single-quoted-expr ( ast -- obj )
+ 2nd >string single-quoted-expr boa ;
+
+: ast>double-quoted-expr ( ast -- obj )
+ 2nd >string double-quoted-expr boa ;
+
+: ast>back-quoted-expr ( ast -- obj )
+ 2nd >string back-quoted-expr boa ;
+
+: ast>glob-expr ( ast -- obj ) flatten concat glob-expr boa ;
+
+: ast>variable-expr ( ast -- obj ) 2nd variable-expr boa ;
+
+: ast>factor-expr ( ast -- obj ) 2nd >string factor-expr boa ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+EBNF: expr
+
+space = " "
+
+tab = "\t"
+
+white = (space | tab)
+
+_ = (white)* => [[ drop ignore ]]
+
+sq = "'"
+dq = '"'
+bq = "`"
+
+single-quoted = sq (!(sq) .)* sq => [[ ast>single-quoted-expr ]]
+double-quoted = dq (!(dq) .)* dq => [[ ast>double-quoted-expr ]]
+back-quoted = bq (!(bq) .)* bq => [[ ast>back-quoted-expr ]]
+
+factor = "$(" (!(")") .)* ")" => [[ ast>factor-expr ]]
+
+variable = "$" other => [[ ast>variable-expr ]]
+
+glob-char = ("*" | "?")
+
+non-glob-char = !(glob-char | white) .
+
+glob-beginning-string = (non-glob-char)* => [[ >string ]]
+
+glob-rest-string = (non-glob-char)+ => [[ >string ]]
+
+glob = glob-beginning-string glob-char (glob-rest-string | glob-char)* => [[ ast>glob-expr ]]
+
+other = (!(white | "&" | ">" | ">>" | "<" | "|") .)+ => [[ >string ]]
+
+element = (single-quoted | double-quoted | back-quoted | factor | variable | glob | other)
+
+command = (element _)+
+
+to-file = ">" _ other => [[ second ]]
+in-file = "<" _ other => [[ second ]]
+ap-file = ">>" _ other => [[ second ]]
+
+basic = _ command _ (in-file)? _ (to-file | ap-file)? _ ("&")? => [[ ast>basic-expr ]]
+
+pipeline = _ command _ (in-file)? _ "|" _ (command _ "|" _)* command _ (to-file | ap-file)? _ ("&")? => [[ ast>pipeline-expr ]]
+
+submission = (pipeline | basic)
+
+;EBNF
\ No newline at end of file
--- /dev/null
+USING: kernel parser words continuations namespaces debugger
+sequences combinators splitting prettyprint system io io.files
+io.pathnames io.launcher io.directories io.encodings.utf8 io.pipes
+sequences.deep accessors multi-methods newfx shell.parser
+combinators.short-circuit eval environment ;
+IN: shell
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: cd ( args -- )
+ dup empty?
+ [ drop home set-current-directory ]
+ [ first set-current-directory ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: pwd ( args -- )
+ drop
+ current-directory get
+ print ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: swords ( -- seq ) { "cd" "pwd" } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: expand ( expr -- expr )
+
+METHOD: expand { single-quoted-expr } expr>> ;
+
+METHOD: expand { double-quoted-expr } expr>> ;
+
+METHOD: expand { variable-expr } expr>> os-env ;
+
+METHOD: expand { glob-expr }
+ expr>>
+ dup "*" =
+ [ drop current-directory get directory-files ]
+ [ ]
+ if ;
+
+METHOD: expand { factor-expr } expr>> eval>string ;
+
+DEFER: expansion
+
+METHOD: expand { back-quoted-expr }
+ expr>>
+ expr
+ command>>
+ expansion
+ utf8 <process-stream>
+ contents
+ " \n" split
+ "" remove ;
+
+METHOD: expand { object } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: expansion ( command -- command ) [ expand ] map flatten ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: run-sword ( basic-expr -- )
+ command>> expansion unclip "shell" lookup execute( arguments -- ) ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: run-foreground ( process -- )
+ [ try-process ] [ print-error drop ] recover ;
+
+: run-background ( process -- ) run-detached drop ;
+
+: run-basic-expr ( basic-expr -- )
+ <process>
+ over command>> expansion >>command
+ over stdin>> >>stdin
+ over stdout>> >>stdout
+ swap background>>
+ [ run-background ]
+ [ run-foreground ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: basic-chant ( basic-expr -- )
+ dup command>> first swords member-of?
+ [ run-sword ]
+ [ run-basic-expr ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: pipeline-chant ( pipeline-chant -- ) commands>> run-pipeline drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: chant ( obj -- )
+ dup basic-expr?
+ [ basic-chant ]
+ [ pipeline-chant ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: prompt ( -- )
+ current-directory get write
+ " $ " write
+ flush ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+DEFER: shell
+
+: handle ( input -- )
+ {
+ { [ dup f = ] [ drop ] }
+ { [ dup "exit" = ] [ drop ] }
+ { [ dup "" = ] [ drop shell ] }
+ { [ dup expr ] [ expr chant shell ] }
+ { [ t ] [ drop "ix: ignoring input" print shell ] }
+ }
+ cond ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: shell ( -- )
+ prompt
+ readln
+ handle ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: ix ( -- ) shell ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+MAIN: ix
projects / factor.git / commitdiff