steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor

db4
Doug Coleman 2008-05-23 16:30:47 -05:00
parent 6386de6c2a 92ce3b9c3d
commit 61d3e6246c
18 changed files with 719 additions and 48 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
core/debugger/debugger.factor
View File

@ -93,7 +93,7 @@ M: relative-overflow summary
drop "Superfluous items pushed to data stack" ; drop "Superfluous items pushed to data stack" ;
: assert-depth ( quot -- ) : assert-depth ( quot -- )
>r datastack r> swap slip >r datastack r> >r datastack r> dip >r datastack r>
2dup [ length ] compare { 2dup [ length ] compare {
{ +lt+ [ trim-datastacks nip relative-underflow ] } { +lt+ [ trim-datastacks nip relative-underflow ] }
{ +eq+ [ 2drop ] } { +eq+ [ 2drop ] }

6
core/kernel/kernel.factor
View File

@ -57,6 +57,8 @@ DEFER: if
: dip ( obj quot -- obj ) swap slip ; inline : dip ( obj quot -- obj ) swap slip ; inline
: 2dip ( obj1 obj2 quot -- obj1 obj2 ) -rot 2slip ; inline
! Keepers ! Keepers
: keep ( x quot -- x ) over slip ; inline : keep ( x quot -- x ) over slip ; inline
@ -88,14 +90,14 @@ DEFER: if
! Spreaders ! Spreaders
: bi* ( x y p q -- ) : bi* ( x y p q -- )
>r swap slip r> call ; inline >r dip r> call ; inline
: tri* ( x y z p q r -- ) : tri* ( x y z p q r -- )
>r rot >r bi* r> r> call ; inline >r rot >r bi* r> r> call ; inline
! Double spreaders ! Double spreaders
: 2bi* ( w x y z p q -- ) : 2bi* ( w x y z p q -- )
>r -rot 2slip r> call ; inline >r 2dip r> call ; inline
! Appliers ! Appliers
: bi@ ( x y quot -- ) : bi@ ( x y quot -- )

2
extra/concurrency/mailboxes/mailboxes.factor
View File

@ -58,7 +58,7 @@ M: mailbox dispose* threads>> notify-all ;
: while-mailbox-empty ( mailbox quot -- ) : while-mailbox-empty ( mailbox quot -- )
over mailbox-empty? [ over mailbox-empty? [
dup >r swap slip r> while-mailbox-empty dup >r dip r> while-mailbox-empty
] [ ] [
2drop 2drop
] if ; inline ] if ; inline

142
extra/dns/cache/cache.factor vendored Normal file
View File

@ -0,0 +1,142 @@
USING: kernel system
combinators
vectors sequences assocs
math math.functions
prettyprint unicode.case
accessors
combinators.cleave
newfx
dns ;
IN: dns.cache
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: cache ( -- table ) H{ } ;
! key: 'name type class' (as string)
! val: entry
TUPLE: entry time data ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: query->key ( query -- key )
{ [ name>> >lower ] [ type>> unparse ] [ class>> unparse ] } <arr> " " join ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: table-get ( query -- result ) query->key cache of ;
: table-check ( query -- ? ) query->key cache key? ;
: table-add ( query value -- ) [ query->key ] [ ] bi* cache at-mutate ;
: table-rem ( query -- ) query->key cache delete-key-of drop ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: now ( -- seconds ) millis 1000.0 / round >integer ;
: ttl->time ( ttl -- seconds ) now + ;
: time->ttl ( time -- ttl ) now - ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: NX
: cache-nx ( query ttl -- )
ttl->time NX entry boa
table-add ;
: nx? ( obj -- ? )
dup entry?
[ data>> NX = ]
[ drop f ]
if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: query->rr ( query -- rr ) [ name>> ] [ type>> ] [ class>> ] tri f f rr boa ;
: query+entry->rrs ( query entry -- rrs )
swap ! entry query
query->rr ! entry rr
over ! entry rr entry
time>> time->ttl >>ttl ! entry rr
swap ! rr entry
data>> [ >r dup clone r> >>rdata ] map
nip ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: entry-expired? ( entry -- ? ) time>> time->ttl 0 <= ;
: cache-get ( query -- result )
dup table-get ! query result
{
{
[ dup f = ] ! not in the cache
[ 2drop f ]
}
{
[ dup entry-expired? ] ! here but expired
[ drop table-rem f ]
}
{
[ dup nx? ] ! negative result has been cached
[ 2drop NX ]
}
{
[ t ]
[ query+entry->rrs ]
}
}
cond ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: rr->entry ( rr -- entry )
[ ttl>> ttl->time ] [ rdata>> {1} >vector ] bi entry boa ;
: maybe-pushed-on ( obj seq -- )
2dup member-of?
[ 2drop ]
[ pushed-on ]
if ;
: add-rr-to-entry ( rr entry -- )
over ttl>> ttl->time >>time
[ rdata>> ] [ data>> ] bi* maybe-pushed-on ;
: cache-add ( query rr -- )
over table-get ! query rr entry
{
{
[ dup f = ] ! not in the cache
[ drop rr->entry table-add ]
}
{
[ dup nx? ]
[ drop over table-rem rr->entry table-add ]
}
{
[ dup entry-expired? ]
[ drop rr->entry table-add ]
}
{
[ t ]
[ rot drop add-rr-to-entry ]
}
}
cond ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: rr->query ( rr -- query ) [ name>> ] [ type>> ] [ class>> ] tri query boa ;
: cache-add-rr ( rr -- ) [ rr->query ] [ ] bi cache-add ;
: cache-add-rrs ( rrs -- ) [ cache-add-rr ] each ;

462
extra/dns/dns.factor Normal file
View File

@ -0,0 +1,462 @@
USING: kernel byte-arrays combinators strings arrays sequences splitting
math math.functions math.parser random
destructors
io io.binary io.sockets io.encodings.binary
accessors
combinators.cleave
newfx
symbols
;
IN: dns
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TUPLE: query name type class ;
TUPLE: rr name type class ttl rdata ;
TUPLE: hinfo cpu os ;
TUPLE: mx preference exchange ;
TUPLE: soa mname rname serial refresh retry expire minimum ;
TUPLE: message
id qr opcode aa tc rd ra z rcode
question-section
answer-section
authority-section
additional-section ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: random-id ( -- id ) 2 16 ^ random ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! TYPE
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOLS: A NS MD MF CNAME SOA MB MG MR NULL WKS PTR HINFO MINFO MX TXT ;
: type-table ( -- table )
{
{ A 1 }
{ NS 2 }
{ MD 3 }
{ MF 4 }
{ CNAME 5 }
{ SOA 6 }
{ MB 7 }
{ MG 8 }
{ MR 9 }
{ NULL 10 }
{ WKS 11 }
{ PTR 12 }
{ HINFO 13 }
{ MINFO 14 }
{ MX 15 }
{ TXT 16 }
} ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! CLASS
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOLS: IN CS CH HS ;
: class-table ( -- table )
{
{ IN 1 }
{ CS 2 }
{ CH 3 }
{ HS 4 }
} ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! OPCODE
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOLS: QUERY IQUERY STATUS ;
: opcode-table ( -- table )
{
{ QUERY 0 }
{ IQUERY 1 }
{ STATUS 2 }
} ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! RCODE
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
REFUSED ;
: rcode-table ( -- table )
{
{ NO-ERROR 0 }
{ FORMAT-ERROR 1 }
{ SERVER-FAILURE 2 }
{ NAME-ERROR 3 }
{ NOT-IMPLEMENTED 4 }
{ REFUSED 5 }
} ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: <message> ( -- message )
message new
random-id >>id
0 >>qr
QUERY >>opcode
0 >>aa
0 >>tc
1 >>rd
0 >>ra
0 >>z
NO-ERROR >>rcode
{ } >>question-section
{ } >>answer-section
{ } >>authority-section
{ } >>additional-section ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: ip->ba ( ip -- ba ) "." split [ string>number ] map >byte-array ;
: label->ba ( label -- ba ) [ >byte-array ] [ length ] bi prefix ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: uint8->ba ( n -- ba ) 1 >be ;
: uint16->ba ( n -- ba ) 2 >be ;
: uint32->ba ( n -- ba ) 4 >be ;
: uint64->ba ( n -- ba ) 8 >be ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: dn->ba ( dn -- ba ) "." split [ label->ba ] map concat ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: query->ba ( query -- ba )
{
[ name>> dn->ba ]
[ type>> type-table of uint16->ba ]
[ class>> class-table of uint16->ba ]
}
<arr> 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 ]
}
<arr> 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
]
}
<arr> 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 ]
}
<arr> sum uint16->ba ;
: message->ba ( message -- ba )
{
[ id>> uint16->ba ]
[ header-bits-ba ]
[ question-section>> length uint16->ba ]
[ answer-section>> length uint16->ba ]
[ authority-section>> length uint16->ba ]
[ additional-section>> length uint16->ba ]
[ question-section>> [ query->ba ] map concat ]
[ answer-section>> [ rr->ba ] map concat ]
[ authority-section>> [ rr->ba ] map concat ]
[ additional-section>> [ rr->ba ] map concat ]
}
<arr> concat ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: get-single ( ba i -- n ) at ;
: get-double ( ba i -- n ) dup 2 + subseq be> ;
: get-quad ( ba i -- n ) dup 4 + subseq be> ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: label-length ( ba i -- length ) get-single ;
: skip-label ( ba i -- ba i ) 2dup label-length + 1 + ;
: null-label? ( ba i -- ? ) get-single 0 = ;
: get-label ( ba i -- label ) [ 1 + ] [ skip-label nip ] 2bi subseq >string ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: bit-test ( a b -- ? ) bitand 0 = not ;
: pointer? ( ba i -- ? ) get-single BIN: 11000000 bit-test ;
: pointer ( ba i -- val ) get-double BIN: 0011111111111111 bitand ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: skip-name ( ba i -- ba i )
{
{ [ 2dup null-label? ] [ 1 + ] }
{ [ 2dup pointer? ] [ 2 + ] }
{ [ t ] [ skip-label skip-name ] }
}
cond ;
: get-name ( ba i -- name )
{
{ [ 2dup null-label? ] [ 2drop "" ] }
{ [ 2dup pointer? ] [ dupd pointer get-name ] }
{
[ t ]
[
[ get-label ]
[ skip-label get-name ]
2bi
"." swap 3append
]
}
}
cond ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: get-query ( ba i -- query )
[ get-name ]
[
skip-name
[ 0 + get-double type-table key-of ]
[ 2 + get-double class-table key-of ]
2bi
]
2bi query boa ;
: skip-query ( ba i -- ba i ) skip-name 4 + ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: get-mx ( ba i -- mx ) [ get-double ] [ 2 + get-double ] 2bi mx boa ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: get-soa ( ba i -- soa )
{
[ get-name ]
[ skip-name get-name ]
[
skip-name
skip-name
{
[ 0 + get-quad ]
[ 4 + get-quad ]
[ 8 + get-quad ]
[ 12 + get-quad ]
[ 16 + get-quad ]
}
2cleave
]
}
2cleave soa boa ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: get-ip ( ba i -- ip ) dup 4 + subseq >array [ number>string ] map "." join ;
: get-rdata ( ba i type -- rdata )
{
{ CNAME [ get-name ] }
{ NS [ get-name ] }
{ PTR [ get-name ] }
{ MX [ get-mx ] }
{ SOA [ get-soa ] }
{ A [ get-ip ] }
}
case ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: get-rr ( ba i -- rr )
[ get-name ]
[
skip-name
{
[ 0 + get-double type-table key-of ]
[ 2 + get-double class-table key-of ]
[ 4 + get-quad ]
[ [ 10 + ] [ get-double type-table key-of ] 2bi get-rdata ]
}
2cleave
]
2bi rr boa ;
: skip-rr ( ba i -- ba i ) skip-name 8 + 2dup get-double + 2 + ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: get-question-section ( ba i count -- seq ba i )
[ drop [ skip-query ] [ get-query ] 2bi ] map -rot ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: get-rr-section ( ba i count -- seq ba i )
[ drop [ skip-rr ] [ get-rr ] 2bi ] map -rot ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: >> neg shift ;
: get-header-bits ( ba i -- qr opcode aa tc rd ra z rcode )
get-double
{
[ 15 >> BIN: 1 bitand ]
[ 11 >> BIN: 111 bitand opcode-table key-of ]
[ 10 >> BIN: 1 bitand ]
[ 9 >> BIN: 1 bitand ]
[ 8 >> BIN: 1 bitand ]
[ 7 >> BIN: 1 bitand ]
[ 4 >> BIN: 111 bitand ]
[ BIN: 1111 bitand rcode-table key-of ]
}
cleave ;
: parse-message ( ba -- message )
0
{
[ get-double ]
[ 2 + get-header-bits ]
[
4 +
{
[ 8 + ]
[ 0 + get-double ]
[ 2 + get-double ]
[ 4 + get-double ]
[ 6 + get-double ]
}
2cleave
>r >r >r
get-question-section r>
get-rr-section r>
get-rr-section r>
get-rr-section
2drop
]
}
2cleave message boa ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: send-receive-udp ( ba server -- ba )
f 0 <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 {1} >>question-section ;

15
extra/lisp/lisp-docs.factor Normal file
View File

@ -0,0 +1,15 @@
IN: lisp
USING: help.markup help.syntax ;
ARTICLE: "lisp" "Lisp in Factor"
"This is a simple implementation of a Lisp dialect, which somewhat resembles Scheme." $nl
"It works in two main stages: "
{ $list
{ "Parse (via " { $vocab-link "lisp.parser" } " the Lisp code into a "
{ $snippet "s-exp" } " tuple." }
{ "Transform the " { $snippet "s-exp" } " into a Factor quotation, via " { $link convert-form } }
}
{ $subsection "lisp.parser" } ;
ABOUT: "lisp"

54
extra/lisp/lisp-tests.factor
View File

@ -4,16 +4,44 @@ USING: lisp lisp.parser tools.test sequences math kernel parser ;
IN: lisp.test IN: lisp.test
init-env [
init-env
"+" [ first2 + ] lisp-define
"#f" [ f ] lisp-define
{ [ first2 + ] } [ "#t" [ t ] lisp-define
"+" lisp-get
] unit-test "+" "math" "+" define-primitve
"-" "math" "-" define-primitve
{ 3 } [
[ { 5 } [
"((lambda (x y) (+ x y)) 1 2)" lisp-string>factor call [ 2 3 ] "+" <lisp-symbol> funcall
] with-interactive-vocabs ] unit-test
] unit-test
{ 8.3 } [
[ 10.4 2.1 ] "-" <lisp-symbol> funcall
] unit-test
{ 3 } [
"((lambda (x y) (+ x y)) 1 2)" lisp-string>factor call
] unit-test
{ 42 } [
"((lambda (x y z) (+ x (- y z))) 40 3 1)" lisp-string>factor call
] unit-test
{ 1 } [
"(if #t 1 2)" lisp-string>factor call
] unit-test
{ "b" } [
"(cond (#f \"a\") (#t \"b\"))" lisp-string>factor call
] unit-test
{ 5 } [
"(begin (+ 1 4))" lisp-string>factor call
] unit-test
{ 3 } [
"((lambda (x) (if x (begin (+ 1 2)) (- 3 5))) #t)" lisp-string>factor call
] unit-test
] with-interactive-vocabs

30
extra/lisp/lisp.factor
View File

@ -2,11 +2,12 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel peg sequences arrays strings combinators.lib USING: kernel peg sequences arrays strings combinators.lib
namespaces combinators math bake locals locals.private accessors namespaces combinators math bake locals locals.private accessors
vectors syntax lisp.parser assocs parser sequences.lib ; vectors syntax lisp.parser assocs parser sequences.lib words quotations ;
IN: lisp IN: lisp
DEFER: convert-form DEFER: convert-form
DEFER: funcall DEFER: funcall
DEFER: lookup-var
! Functions to convert s-exps to quotations ! Functions to convert s-exps to quotations
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -17,14 +18,16 @@ DEFER: funcall
rest [ convert-form ] map reverse first3 [ % , , if ] bake ; rest [ convert-form ] map reverse first3 [ % , , if ] bake ;
: convert-begin ( s-exp -- quot ) : convert-begin ( s-exp -- quot )
rest convert-form ; rest [ convert-form ] map >quotation [ , [ funcall ] each ] bake ;
: convert-cond ( s-exp -- quot ) : convert-cond ( s-exp -- quot )
rest [ [ convert-form map ] map ] [ % cond ] bake ; rest [ body>> >array [ convert-form ] map first2 swap `{ [ % funcall ] , } bake ]
map >array [ , cond ] bake ;
: convert-general-form ( s-exp -- quot ) : convert-general-form ( s-exp -- quot )
unclip convert-form swap convert-body [ , % funcall ] bake ; unclip convert-form swap convert-body [ , % funcall ] bake ;
! words for convert-lambda
<PRIVATE <PRIVATE
: localize-body ( assoc body -- assoc newbody ) : localize-body ( assoc body -- assoc newbody )
[ dup lisp-symbol? [ over dupd [ name>> ] dip at swap or ] [ dup lisp-symbol? [ over dupd [ name>> ] dip at swap or ]
@ -34,8 +37,6 @@ DEFER: funcall
: localize-lambda ( body vars -- newbody newvars ) : localize-lambda ( body vars -- newbody newvars )
make-locals dup push-locals swap make-locals dup push-locals swap
[ swap localize-body <s-exp> convert-form swap pop-locals ] dip swap ; [ swap localize-body <s-exp> convert-form swap pop-locals ] dip swap ;
PRIVATE>
: split-lambda ( s-exp -- body vars ) : split-lambda ( s-exp -- body vars )
first3 -rot nip [ body>> ] bi@ [ name>> ] map ; inline first3 -rot nip [ body>> ] bi@ [ name>> ] map ; inline
@ -47,6 +48,7 @@ PRIVATE>
: normal-lambda ( body vars -- quot ) : normal-lambda ( body vars -- quot )
localize-lambda <lambda> [ , compose ] bake ; localize-lambda <lambda> [ , compose ] bake ;
PRIVATE>
: convert-lambda ( s-exp -- quot ) : convert-lambda ( s-exp -- quot )
split-lambda dup "&rest" swap member? [ rest-lambda ] [ normal-lambda ] if ; split-lambda dup "&rest" swap member? [ rest-lambda ] [ normal-lambda ] if ;
@ -67,8 +69,10 @@ PRIVATE>
[ drop convert-general-form ] if ; [ drop convert-general-form ] if ;
: convert-form ( lisp-form -- quot ) : convert-form ( lisp-form -- quot )
dup s-exp? [ body>> convert-list-form ] { { [ dup s-exp? ] [ body>> convert-list-form ] }
[ [ , ] [ ] make ] if ; { [ dup lisp-symbol? ] [ [ , lookup-var ] bake ] }
[ [ , ] bake ]
} cond ;
: lisp-string>factor ( str -- quot ) : lisp-string>factor ( str -- quot )
lisp-expr parse-result-ast convert-form lambda-rewrite call ; lisp-expr parse-result-ast convert-form lambda-rewrite call ;
@ -85,7 +89,13 @@ ERROR: no-such-var var ;
swap lisp-env get set-at ; swap lisp-env get set-at ;
: lisp-get ( name -- word ) : lisp-get ( name -- word )
dup lisp-env get at [ ] [ no-such-var ] ?if ; dup lisp-env get at [ ] [ no-such-var throw ] ?if ;
: lookup-var ( lisp-symbol -- quot )
name>> lisp-get ;
: funcall ( quot sym -- * ) : funcall ( quot sym -- * )
dup lisp-symbol? [ name>> lisp-get ] when call ; inline dup lisp-symbol? [ lookup-var ] when call ; inline
: define-primitve ( name vocab word -- )
swap lookup [ [ , ] compose call ] bake lisp-define ;

6
extra/lisp/parser/parser-docs.factor Normal file
View File

@ -0,0 +1,6 @@
IN: lisp.parser
USING: help.markup help.syntax ;
ARTICLE: "lisp.parser" "Parsing strings of Lisp"
"This vocab uses " { $vocab-link "peg.ebnf" } " to turn strings of Lisp into " { $snippet "s-exp" } "s, which are then used by"
{ $vocab-link "lisp" } " to produce Factor quotations." ;

2
extra/lisp/parser/parser.factor
View File

@ -24,7 +24,7 @@ rational = integer "/" (digit)+ => [[ first3 nip string
number = float number = float
| rational | rational
| integer | integer
id-specials = "!" | "$" | "%" | "&" | "*" | "/" | ":" | "<" id-specials = "!" | "$" | "%" | "&" | "*" | "/" | ":" | "<" | "#"
| " =" | ">" | "?" | "^" | "_" | "~" | "+" | "-" | "." | "@" | " =" | ">" | "?" | "^" | "_" | "~" | "+" | "-" | "." | "@"
letters = [a-zA-Z] => [[ 1array >string ]] letters = [a-zA-Z] => [[ 1array >string ]]
initials = letters | id-specials initials = letters | id-specials

2
extra/lisp/summary.txt
View File

@ -1 +1 @@
A Lisp interpreter in Factor A Lisp interpreter/compiler in Factor

10
extra/newfx/newfx.factor
View File

@ -160,6 +160,16 @@ METHOD: as-mutate { object object assoc } set-at ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: subseq ( seq from to -- subseq ) rot sequences:subseq ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: key ( table val -- key ) swap assocs:value-at ;
: key-of ( val table -- key ) assocs:value-at ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: 1st 0 at ; : 1st 0 at ;
: 2nd 1 at ; : 2nd 1 at ;
: 3rd 2 at ; : 3rd 2 at ;

2
extra/shuffle/shuffle.factor
View File

@ -5,8 +5,6 @@ USING: kernel sequences namespaces math inference.transforms
IN: shuffle IN: shuffle
: 2dip -rot 2slip ; inline
MACRO: npick ( n -- ) 1- dup saver [ dup ] rot [ r> swap ] n*quot 3append ; MACRO: npick ( n -- ) 1- dup saver [ dup ] rot [ r> swap ] n*quot 3append ;
MACRO: ndup ( n -- ) dup [ npick ] curry n*quot ; MACRO: ndup ( n -- ) dup [ npick ] curry n*quot ;

17
extra/strings/lib/lib.factor
View File

@ -1,26 +1,21 @@
USING: math arrays sequences kernel random splitting strings unicode.case ; USING: math math.ranges arrays sequences kernel random splitting
strings unicode.case ;
IN: strings.lib IN: strings.lib
: char>digit ( c -- i ) 48 - ;
: string>digits ( s -- seq ) [ char>digit ] { } map-as ;
: >Upper ( str -- str ) : >Upper ( str -- str )
dup empty? [ dup empty? [ unclip ch>upper prefix ] unless ;
unclip ch>upper 1string prepend
] unless ;
: >Upper-dashes ( str -- str ) : >Upper-dashes ( str -- str )
"-" split [ >Upper ] map "-" join ; "-" split [ >Upper ] map "-" join ;
: lower-alpha-chars ( -- seq ) : lower-alpha-chars ( -- seq )
26 [ CHAR: a + ] map ; CHAR: a CHAR: z [a,b] ;
: upper-alpha-chars ( -- seq ) : upper-alpha-chars ( -- seq )
26 [ CHAR: A + ] map ; CHAR: A CHAR: Z [a,b] ;
: numeric-chars ( -- seq ) : numeric-chars ( -- seq )
10 [ CHAR: 0 + ] map ; CHAR: 0 CHAR: 9 [a,b] ;
: alpha-chars ( -- seq ) : alpha-chars ( -- seq )
lower-alpha-chars upper-alpha-chars append ; lower-alpha-chars upper-alpha-chars append ;

2
extra/tools/test/ui/ui.factor
View File

@ -10,7 +10,7 @@ IN: tools.test.ui
<dlist> \ graft-queue [ <dlist> \ graft-queue [
over over
graft notify-queued graft notify-queued
swap slip dip
ungraft notify-queued ungraft notify-queued
] with-variable ] with-variable
] with-string-writer print ; ] with-string-writer print ;

6
extra/webapps/pastebin/pastebin.factor
View File

@ -64,14 +64,14 @@ annotation "ANNOTATION"
] unless ; ] unless ;
: <annotation-form> ( -- form ) : <annotation-form> ( -- form )
"paste" <form> "annotation" <form>
"annotation" pastebin-template >>view-template
"id" <integer> "id" <integer>
hidden >>renderer hidden >>renderer
add-field add-field
"aid" <integer> "aid" <integer>
hidden >>renderer hidden >>renderer
add-field add-field
"annotation" pastebin-template >>view-template
"summary" <string> add-field "summary" <string> add-field
"author" <string> add-field "author" <string> add-field
"mode" <mode> add-field "mode" <mode> add-field
@ -79,7 +79,7 @@ annotation "ANNOTATION"
"date" <date> add-field ; "date" <date> add-field ;
: <new-annotation-form> ( -- form ) : <new-annotation-form> ( -- form )
"paste" <form> "annotation" <form>
"new-annotation" pastebin-template >>edit-template "new-annotation" pastebin-template >>edit-template
"id" <integer> "id" <integer>
hidden >>renderer hidden >>renderer

2
extra/windows/com/wrapper/wrapper.factor
View File

@ -29,7 +29,7 @@ unless
>r find-com-interface-definition family-tree >r find-com-interface-definition family-tree
r> 1quotation [ >r iid>> r> 2array ] curry map r> 1quotation [ >r iid>> r> 2array ] curry map
] map-index concat ] map-index concat
[ f ] prefix , [ f ] suffix ,
\ case , \ case ,
"void*" heap-size "void*" heap-size
[ * rot <displaced-alien> com-add-ref 0 rot set-void*-nth S_OK ] [ * rot <displaced-alien> com-add-ref 0 rot set-void*-nth S_OK ]

5
misc/factor.el
View File

@ -82,6 +82,7 @@
("^!.*$" . font-lock-comment-face) ("^!.*$" . font-lock-comment-face)
(" !.*$" . font-lock-comment-face) (" !.*$" . font-lock-comment-face)
("( .* )" . font-lock-comment-face) ("( .* )" . font-lock-comment-face)
"BIN:"
"MAIN:" "MAIN:"
"IN:" "USING:" "TUPLE:" "^C:" "^M:" "IN:" "USING:" "TUPLE:" "^C:" "^M:"
"METHOD:" "METHOD:"
@ -89,7 +90,9 @@
"REQUIRES:" "REQUIRES:"
"GENERIC:" "GENERIC#" "SYMBOL:" "PREDICATE:" "VAR:" "VARS:" "GENERIC:" "GENERIC#" "SYMBOL:" "PREDICATE:" "VAR:" "VARS:"
"C-STRUCT:" "C-STRUCT:"
"C-UNION:" "<PRIVATE" "PRIVATE>" "MACRO:" "MACRO::" "DEFER:" "TYPEDEF:")) "C-UNION:" "<PRIVATE" "PRIVATE>" "MACRO:" "MACRO::" "DEFER:" "TYPEDEF:"
"SYMBOLS:"
))
(defun factor-mode () (defun factor-mode ()
"A mode for editing programs written in the Factor programming language." "A mode for editing programs written in the Factor programming language."