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

db4
Bruno Deferrari 2008-05-30 10:04:14 -03:00
commit 23adf1b166
40 changed files with 592 additions and 209 deletions

View File

@ -10,8 +10,10 @@ ARTICLE: "combinators-quot" "Quotation construction utilities"
{ $subsection alist>quot } ; { $subsection alist>quot } ;
ARTICLE: "combinators" "Additional combinators" ARTICLE: "combinators" "Additional combinators"
"The " { $vocab-link "combinators" } " vocabulary provides generalizations of certain combinators from the " { $vocab-link "kernel" } " vocabulary." "The " { $vocab-link "combinators" } " vocabulary provides a few useful combinators."
$nl $nl
"A looping combinator:"
{ $subsection while }
"Generalization of " { $link bi } " and " { $link tri } ":" "Generalization of " { $link bi } " and " { $link tri } ":"
{ $subsection cleave } { $subsection cleave }
"Generalization of " { $link bi* } " and " { $link tri* } ":" "Generalization of " { $link bi* } " and " { $link tri* } ":"

View File

@ -1,14 +1,10 @@
USING: help.syntax help.markup generator.fixup math kernel USING: help.syntax help.markup generator.fixup math kernel
words strings alien ; words strings alien byte-array ;
HELP: frame-required HELP: frame-required
{ $values { "n" "a non-negative integer" } } { $values { "n" "a non-negative integer" } }
{ $description "Notify the code generator that the currently compiling code block needs a stack frame with room for at least " { $snippet "n" } " parameters." } ; { $description "Notify the code generator that the currently compiling code block needs a stack frame with room for at least " { $snippet "n" } " parameters." } ;
HELP: (rel-fixup)
{ $values { "arg" integer } { "class" "a relocation class" } { "type" "a relocation type" } { "offset" integer } { "pair" "a pair of integers" } }
{ $description "Creates a relocation instruction for the VM's runtime compiled code linker." } ;
HELP: add-literal HELP: add-literal
{ $values { "obj" object } { "n" integer } } { $values { "obj" object } { "n" integer } }
{ $description "Adds a literal to the " { $link literal-table } ", if it is not already there, and outputs the index of the literal in the table. This literal can then be used as an argument for a " { $link rt-literal } " relocation with " { $link rel-fixup } "." } ; { $description "Adds a literal to the " { $link literal-table } ", if it is not already there, and outputs the index of the literal in the table. This literal can then be used as an argument for a " { $link rt-literal } " relocation with " { $link rel-fixup } "." } ;

View File

@ -1,9 +1,10 @@
! Copyright (C) 2007, 2008 Slava Pestov. ! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic assocs hashtables USING: arrays byte-arrays generic assocs hashtables io.binary
kernel kernel.private math namespaces sequences words kernel kernel.private math namespaces sequences words
quotations strings alien.strings layouts system combinators quotations strings alien.accessors alien.strings layouts system
math.bitfields words.private cpu.architecture math.order ; combinators math.bitfields words.private cpu.architecture
math.order accessors growable ;
IN: generator.fixup IN: generator.fixup
: no-stack-frame -1 ; inline : no-stack-frame -1 ; inline
@ -77,26 +78,23 @@ TUPLE: label-fixup label class ;
: label-fixup ( label class -- ) \ label-fixup boa , ; : label-fixup ( label class -- ) \ label-fixup boa , ;
M: label-fixup fixup* M: label-fixup fixup*
dup label-fixup-class rc-absolute? dup class>> rc-absolute?
[ "Absolute labels not supported" throw ] when [ "Absolute labels not supported" throw ] when
dup label-fixup-label swap label-fixup-class dup label>> swap class>> compiled-offset 4 - rot
compiled-offset 4 - rot 3array label-table get push ; 3array label-table get push ;
TUPLE: rel-fixup arg class type ; TUPLE: rel-fixup arg class type ;
: rel-fixup ( arg class type -- ) \ rel-fixup boa , ; : rel-fixup ( arg class type -- ) \ rel-fixup boa , ;
: (rel-fixup) ( arg class type offset -- pair ) : push-4 ( value vector -- )
pick rc-absolute-cell = cell 4 ? - [ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying ] tri
>r { 0 8 16 } bitfield r> swap set-alien-unsigned-4 ;
2array ;
M: rel-fixup fixup* M: rel-fixup fixup*
dup rel-fixup-arg [ [ arg>> ] [ class>> ] [ type>> ] tri { 0 8 16 } bitfield ]
over rel-fixup-class [ class>> rc-absolute-cell = cell 4 ? compiled-offset swap - ] bi
rot rel-fixup-type [ relocation-table get push-4 ] bi@ ;
compiled-offset (rel-fixup)
relocation-table get push-all ;
M: frame-required fixup* drop ; M: frame-required fixup* drop ;
@ -134,7 +132,7 @@ SYMBOL: literal-table
0 swap rt-here rel-fixup ; 0 swap rt-here rel-fixup ;
: init-fixup ( -- ) : init-fixup ( -- )
V{ } clone relocation-table set BV{ } clone relocation-table set
V{ } clone label-table set ; V{ } clone label-table set ;
: resolve-labels ( labels -- labels' ) : resolve-labels ( labels -- labels' )
@ -150,6 +148,6 @@ SYMBOL: literal-table
dup stack-frame-size swap [ fixup* ] each drop dup stack-frame-size swap [ fixup* ] each drop
literal-table get >array literal-table get >array
relocation-table get >array relocation-table get >byte-array
label-table get resolve-labels label-table get resolve-labels
] { } make ; ] { } make ;

View File

@ -1,8 +1,8 @@
USING: help.markup help.syntax io math ; USING: help.markup help.syntax io math byte-arrays ;
IN: io.binary IN: io.binary
ARTICLE: "stream-binary" "Working with binary data" ARTICLE: "stream-binary" "Working with binary data"
"The core stream words read and write strings. Packed binary integers can be read and written by converting to and from sequences of bytes. Floating point numbers can be read and written by converting them into a their bitwise integer representation (" { $link "floats" } ")." "Stream words on binary streams only read and write byte arrays. Packed binary integers can be read and written by converting to and from sequences of bytes. Floating point numbers can be read and written by converting them into a their bitwise integer representation (" { $link "floats" } ")."
$nl $nl
"There are two ways to order the bytes making up an integer; " { $emphasis "little endian" } " byte order outputs the least significant byte first, and the most significant byte last, whereas " { $emphasis "big endian" } " is the other way around." "There are two ways to order the bytes making up an integer; " { $emphasis "little endian" } " byte order outputs the least significant byte first, and the most significant byte last, whereas " { $emphasis "big endian" } " is the other way around."
$nl $nl
@ -42,11 +42,11 @@ HELP: nth-byte
{ $description "Outputs the " { $snippet "n" } "th least significant byte of the sign-extended 2's complement representation of " { $snippet "x" } "." } ; { $description "Outputs the " { $snippet "n" } "th least significant byte of the sign-extended 2's complement representation of " { $snippet "x" } "." } ;
HELP: >le HELP: >le
{ $values { "x" integer } { "n" "a non-negative integer" } { "str" "a string" } } { $values { "x" integer } { "n" "a non-negative integer" } { "byte-array" byte-array } }
{ $description "Converts an integer " { $snippet "x" } " into a string of " { $snippet "n" } " bytes in little endian order. Truncation will occur if the integer is not in the range " { $snippet "[-2^(8n),2^(8n))" } "." } ; { $description "Converts an integer " { $snippet "x" } " into a string of " { $snippet "n" } " bytes in little endian order. Truncation will occur if the integer is not in the range " { $snippet "[-2^(8n),2^(8n))" } "." } ;
HELP: >be HELP: >be
{ $values { "x" integer } { "n" "a non-negative integer" } { "str" "a string" } } { $values { "x" integer } { "n" "a non-negative integer" } { "byte-array" byte-array } }
{ $description "Converts an integer " { $snippet "x" } " into a string of " { $snippet "n" } " bytes in big endian order. Truncation will occur if the integer is not in the range " { $snippet "[-2^(8n),2^(8n))" } "." } ; { $description "Converts an integer " { $snippet "x" } " into a string of " { $snippet "n" } " bytes in big endian order. Truncation will occur if the integer is not in the range " { $snippet "[-2^(8n),2^(8n))" } "." } ;
HELP: mask-byte HELP: mask-byte

View File

@ -10,8 +10,8 @@ IN: io.binary
: nth-byte ( x n -- b ) -8 * shift mask-byte ; inline : nth-byte ( x n -- b ) -8 * shift mask-byte ; inline
: >le ( x n -- str ) [ nth-byte ] with B{ } map-as ; : >le ( x n -- byte-array ) [ nth-byte ] with B{ } map-as ;
: >be ( x n -- str ) >le dup reverse-here ; : >be ( x n -- byte-array ) >le dup reverse-here ;
: d>w/w ( d -- w1 w2 ) : d>w/w ( d -- w1 w2 )
dup HEX: ffffffff bitand dup HEX: ffffffff bitand

View File

@ -193,10 +193,7 @@ ARTICLE: "implementing-combinators" "Implementing combinators"
": keep ( x quot -- x )" ": keep ( x quot -- x )"
" over >r call r> ; inline" " over >r call r> ; inline"
} }
"Word inlining is documented in " { $link "declarations" } "." "Word inlining is documented in " { $link "declarations" } "." ;
$nl
"A looping combinator:"
{ $subsection while } ;
ARTICLE: "booleans" "Booleans" ARTICLE: "booleans" "Booleans"
"In Factor, any object that is not " { $link f } " has a true value, and " { $link f } " has a false value. The " { $link t } " object is the canonical true value." "In Factor, any object that is not " { $link f } " has a true value, and " { $link f } " has a false value. The " { $link t } " object is the canonical true value."

View File

@ -485,3 +485,5 @@ must-fail-with
[ t ] [ "staging-problem-test-1" "parser.tests" lookup >boolean ] unit-test [ t ] [ "staging-problem-test-1" "parser.tests" lookup >boolean ] unit-test
[ t ] [ "staging-problem-test-2" "parser.tests" lookup >boolean ] unit-test [ t ] [ "staging-problem-test-2" "parser.tests" lookup >boolean ] unit-test
[ "DEFER: blah" eval ] [ error>> no-current-vocab? ] must-fail-with

View File

@ -236,7 +236,7 @@ PREDICATE: unexpected-eof < unexpected
ERROR: no-current-vocab ; ERROR: no-current-vocab ;
M: no-current-vocab summary ( obj -- ) M: no-current-vocab summary ( obj -- )
drop "Current vocabulary is f, use IN:" ; drop "Not in a vocabulary; IN: form required" ;
: current-vocab ( -- str ) : current-vocab ( -- str )
in get [ no-current-vocab ] unless* ; in get [ no-current-vocab ] unless* ;

View File

@ -28,7 +28,7 @@ HELP: adjoin
{ $description "Removes all elements equal to " { $snippet "elt" } ", and adds " { $snippet "elt" } " at the end of the sequence." } { $description "Removes all elements equal to " { $snippet "elt" } ", and adds " { $snippet "elt" } " at the end of the sequence." }
{ $examples { $examples
{ $example { $example
"USING: namespaces prettyprint sequences ;" "USING: namespaces prettyprint sets ;"
"V{ \"beans\" \"salsa\" \"cheese\" } \"v\" set" "V{ \"beans\" \"salsa\" \"cheese\" } \"v\" set"
"\"nachos\" \"v\" get adjoin" "\"nachos\" \"v\" get adjoin"
"\"salsa\" \"v\" get adjoin" "\"salsa\" \"v\" get adjoin"

View File

@ -100,7 +100,7 @@ IN: bootstrap.syntax
] define-syntax ] define-syntax
"DEFER:" [ "DEFER:" [
scan in get create scan current-vocab create
dup old-definitions get [ delete-at ] with each dup old-definitions get [ delete-at ] with each
set-word set-word
] define-syntax ] define-syntax

View File

@ -77,8 +77,21 @@ MACRO: <--&& ( quots -- )
[ [ 2dup ] prepend [ not ] append [ f ] ] t short-circuit [ [ 2dup ] prepend [ not ] append [ f ] ] t short-circuit
[ 2nip ] append ; [ 2nip ] append ;
! or
MACRO: || ( quots -- ? ) [ [ t ] ] f short-circuit ; MACRO: || ( quots -- ? ) [ [ t ] ] f short-circuit ;
MACRO: 0|| ( quots -- ? ) [ [ t ] ] f short-circuit ;
MACRO: 1|| ( quots -- ? )
[ [ dup ] prepend [ t ] ] f short-circuit [ nip ] append ;
MACRO: 2|| ( quots -- ? )
[ [ 2dup ] prepend [ t ] ] f short-circuit [ 2nip ] append ;
MACRO: 3|| ( quots -- ? )
[ [ 2dup ] prepend [ t ] ] f short-circuit [ 2nip ] append ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! ifte ! ifte
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

View File

@ -68,7 +68,7 @@ SYMBOL: NX
: expired? ( entry -- ? ) time>> time->ttl 0 <= ; : expired? ( entry -- ? ) time>> time->ttl 0 <= ;
: cache-get ( query -- result ) : cache-get* ( query -- rrs/NX/f )
dup table-get ! query result dup table-get ! query result
{ {
{ [ dup f = ] [ 2drop f ] } ! not in the cache { [ dup f = ] [ 2drop f ] } ! not in the cache
@ -80,6 +80,15 @@ SYMBOL: NX
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
ERROR: name-error name ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: cache-get ( query -- rrs/f )
dup cache-get* dup NX = [ drop name>> name-error ] [ nip ] if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: rr->entry ( rr -- entry ) : rr->entry ( rr -- entry )
[ ttl>> ttl->time ] [ rdata>> {1} >vector ] bi entry boa ; [ ttl>> ttl->time ] [ rdata>> {1} >vector ] bi entry boa ;
@ -110,3 +119,31 @@ SYMBOL: NX
: cache-add-rr ( rr -- ) [ rr->query ] [ ] bi cache-add ; : cache-add-rr ( rr -- ) [ rr->query ] [ ] bi cache-add ;
: cache-add-rrs ( rrs -- ) [ cache-add-rr ] each ; : cache-add-rrs ( rrs -- ) [ cache-add-rr ] each ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! cache-name-error
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: message-soa ( message -- rr/soa )
authority-section>> [ type>> SOA = ] filter 1st ;
: cache-name-error ( message -- message )
dup
[ message-query ] [ message-soa ttl>> ] bi
cache-nx ;
: cache-message-records ( message -- message )
dup
{
[ answer-section>> cache-add-rrs ]
[ authority-section>> cache-add-rrs ]
[ additional-section>> cache-add-rrs ]
}
cleave ;
: cache-message ( message -- message )
dup rcode>> NAME-ERROR = [ cache-name-error ] when
cache-message-records ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

View File

@ -38,7 +38,7 @@ TUPLE: message
! TYPE ! TYPE
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOLS: A NS MD MF CNAME SOA MB MG MR NULL WKS PTR HINFO MINFO MX TXT ; SYMBOLS: A NS MD MF CNAME SOA MB MG MR NULL WKS PTR HINFO MINFO MX TXT AAAA ;
: type-table ( -- table ) : type-table ( -- table )
{ {
@ -58,6 +58,7 @@ SYMBOLS: A NS MD MF CNAME SOA MB MG MR NULL WKS PTR HINFO MINFO MX TXT ;
{ MINFO 14 } { MINFO 14 }
{ MX 15 } { MX 15 }
{ TXT 16 } { TXT 16 }
{ AAAA 28 }
} ; } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -126,6 +127,8 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
: ip->ba ( ip -- ba ) "." split [ string>number ] map >byte-array ; : 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 ; : label->ba ( label -- ba ) [ >byte-array ] [ length ] bi prefix ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -330,6 +333,13 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
: get-ip ( ba i -- ip ) dup 4 + subseq >array [ number>string ] map "." join ; : 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 ) : get-rdata ( ba i type -- rdata )
{ {
{ CNAME [ get-name ] } { CNAME [ get-name ] }
@ -338,6 +348,7 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
{ MX [ get-mx ] } { MX [ get-mx ] }
{ SOA [ get-soa ] } { SOA [ get-soa ] }
{ A [ get-ip ] } { A [ get-ip ] }
{ AAAA [ get-ipv6 ] }
} }
case ; case ;
@ -459,4 +470,9 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
: ask ( message -- message ) dns-server ask-server ; : ask ( message -- message ) dns-server ask-server ;
: <query-message> ( query -- message ) <message> swap {1} >>question-section ; : query->message ( query -- message ) <message> swap {1} >>question-section ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: message-query ( message -- query ) question-section>> 1st ;

View File

@ -0,0 +1,91 @@
USING: kernel
combinators
vectors
io.sockets
accessors
newfx
dns dns.cache ;
IN: dns.forwarding
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! DNS server - caching, forwarding
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: (socket) ( -- vec ) V{ f } ;
: socket ( -- socket ) (socket) 1st ;
: init-socket ( -- ) f 5353 <inet4> <datagram> 0 (socket) as-mutate ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: (upstream-server) ( -- vec ) V{ f } ;
: upstream-server ( -- ip ) (upstream-server) 1st ;
: set-upstream-server ( ip -- ) 0 (upstream-server) as-mutate ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: query->answer/cache ( query -- rrs/NX/f )
{
{ [ dup type>> CNAME = ] [ cache-get* ] }
{
[ dup clone CNAME >>type cache-get* vector? ]
[
dup clone CNAME >>type cache-get* 1st ! query rr/cname
dup rdata>> ! query rr/cname cname
>r swap clone r> ! rr/cname query cname
>>name ! rr/cname query
query->answer/cache ! rr/cname rrs/NX/f
{
{ [ dup vector? ] [ clone push-on ] }
{ [ dup NX = ] [ nip ] }
{ [ dup f = ] [ nip ] }
}
cond
]
}
{ [ t ] [ cache-get* ] }
}
cond ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: answer-from-cache ( message -- message/f )
dup message-query ! message query
dup query->answer/cache ! message query rrs/NX/f
{
{ [ dup f = ] [ 3drop f ] }
{ [ dup NX = ] [ 2drop NAME-ERROR >>rcode ] }
{ [ t ] [ nip >>answer-section ] }
}
cond ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: answer-from-server ( message -- message )
upstream-server ask-server
cache-message ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: find-answer ( message -- message )
dup answer-from-cache dup
[ nip ]
[ drop answer-from-server ]
if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: loop ( -- )
socket receive ! byte-array addr-spec
swap ! addr-spec byte-array
parse-message ! addr-spec message
find-answer ! addr-spec message
message->ba ! addr-spec byte-array
swap ! byte-array addr-spec
socket send
loop ;

View File

@ -0,0 +1,185 @@
USING: kernel continuations
combinators
sequences
math
random
unicode.case
accessors symbols
combinators.lib combinators.cleave
newfx
dns dns.cache ;
IN: dns.recursive
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: root-dns-servers ( -- servers )
{
"192.5.5.241"
"192.112.36.4"
"128.63.2.53"
"192.36.148.17"
"192.58.128.30"
"193.0.14.129"
"199.7.83.42"
"202.12.27.33"
"198.41.0.4"
} ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: {name-type-class} ( obj -- seq )
[ name>> >lower ] [ type>> ] [ class>> ] tri {3} ;
: rr=query? ( rr query -- ? ) [ {name-type-class} ] bi@ = ;
: rr-filter ( rrs query -- rrs ) [ rr=query? ] curry filter ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: answer-hits ( message -- rrs )
[ answer-section>> ] [ message-query ] bi rr-filter ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: name-hits ( message -- rrs )
[ answer-section>> ] [ message-query clone A >>type ] bi rr-filter ;
: cname-hits ( message -- rrs )
[ answer-section>> ] [ message-query clone CNAME >>type ] bi rr-filter ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: authority-hits ( message -- rrs )
authority-section>> [ type>> NS = ] filter ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOLS: ANSWERED NO-NAME-SERVERS UNCLASSIFIED ;
: classify-message ( message -- symbol )
{
{ [ dup rcode>> NAME-ERROR = ] [ drop NAME-ERROR ] }
{ [ dup rcode>> SERVER-FAILURE = ] [ drop SERVER-FAILURE ] }
{ [ dup answer-hits empty? not ] [ drop ANSWERED ] }
{ [ dup cname-hits empty? not ] [ drop CNAME ] }
{ [ dup authority-hits empty? ] [ drop NO-NAME-SERVERS ] }
{ [ t ] [ drop UNCLASSIFIED ] }
}
cond ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
DEFER: name->ip
! : name->ip/f ( name -- ip/f ) [ name->ip ] [ drop f ] recover ;
! : extract-ns-ips ( message -- ips )
! authority-hits [ rdata>> name->ip/f ] map [ ] filter ;
: extract-ns-ips ( message -- ips )
authority-hits [ rdata>> name->ip ] map [ ] filter ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: (recursive-query) ( query servers -- message )
dup random ! query servers server
pick query->message 0 >>rd ! query servers server message
over ask-server ! query servers server message
cache-message ! query servers server message
dup classify-message ! query servers server message sym
{
{ NAME-ERROR [ -roll 3drop ] }
{ ANSWERED [ -roll 3drop ] }
{ CNAME [ -roll 3drop ] }
{ NO-NAME-SERVERS [ -roll 3drop ] }
{
SERVER-FAILURE
[
-roll ! message query servers server
remove ! message query servers
dup empty?
[ 2drop ]
[ rot drop (recursive-query) ]
if
]
}
[ ! query servers server message sym
drop nip nip ! query message
extract-ns-ips ! query ips
(recursive-query)
]
}
case ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: cdr-name ( name -- name ) dup CHAR: . index 1+ tail ;
: cache-get-ns ( name -- seq/f ) NS IN query boa cache-get ;
: name->servers ( name -- servers )
{
{ [ dup "" = ] [ drop root-dns-servers ] }
{ [ dup cache-get-ns ] [ cache-get-ns [ rdata>> name->ip ] map ] }
{ [ t ] [ cdr-name name->servers ] }
}
cond ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: recursive-query ( query -- message )
dup name>> name->servers (recursive-query) ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: canonical/cache ( name -- name )
dup CNAME IN query boa cache-get dup [ nip 1st rdata>> ] [ drop ] if ;
: name->ip/cache ( name -- ip/f )
canonical/cache
A IN query boa cache-get dup [ random rdata>> ] [ ] if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: name-hits? ( message -- message ? ) dup name-hits empty? not ;
: cname-hits? ( message -- message ? ) dup cname-hits empty? not ;
! : name->ip/server ( name -- ip-or-f )
! A IN query boa root-dns-servers recursive-query ! message
! {
! { [ name-hits? ] [ name-hits random rdata>> ] }
! { [ cname-hits? ] [ cname-hits random rdata>> name->ip ] }
! { [ t ] [ drop f ] }
! }
! cond ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: name->ip/server ( name -- ip-or-f )
A IN query boa recursive-query ! message
{
{ [ name-hits? ] [ name-hits random rdata>> ] }
{ [ cname-hits? ] [ cname-hits random rdata>> name->ip ] }
{ [ t ] [ drop f ] }
}
cond ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! : name->ip ( name -- ip )
! { [ name->ip/cache ] [ name->ip/server ] [ name-error ] } 1|| ;
: name->ip ( name -- ip )
dup name->ip/cache dup
[ nip ]
[
drop dup name->ip/server dup
[ nip ]
[ drop name-error ]
if
]
if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

View File

@ -62,7 +62,7 @@ IN: dns.resolver
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: canonical/server ( name -- name ) : canonical/server ( name -- name )
dup CNAME IN query boa <query-message> ask* answer-section>> dup CNAME IN query boa query->message ask* answer-section>>
[ type>> CNAME = ] filter dup empty? not [ type>> CNAME = ] filter dup empty? not
[ nip 1st rdata>> ] [ nip 1st rdata>> ]
[ drop ] [ drop ]
@ -70,7 +70,7 @@ IN: dns.resolver
: name->ip/server ( name -- ip ) : name->ip/server ( name -- ip )
canonical/server canonical/server
dup A IN query boa <query-message> ask* answer-section>> dup A IN query boa query->message ask* answer-section>>
[ type>> A = ] filter dup empty? not [ type>> A = ] filter dup empty? not
[ nip random rdata>> ] [ nip random rdata>> ]
[ 2drop f ] [ 2drop f ]

View File

@ -1,7 +1,7 @@
IN: html.components.tests IN: html.components.tests
USING: tools.test kernel io.streams.string USING: tools.test kernel io.streams.string
io.streams.null accessors inspector html.streams io.streams.null accessors inspector html.streams
html.components ; html.components namespaces ;
[ ] [ blank-values ] unit-test [ ] [ blank-values ] unit-test

View File

@ -4,7 +4,7 @@ USING: calendar io io.files kernel math math.order
math.parser http http.server namespaces parser sequences strings math.parser http http.server namespaces parser sequences strings
assocs hashtables debugger http.mime sorting html.elements assocs hashtables debugger http.mime sorting html.elements
html.templates.fhtml logging calendar.format accessors html.templates.fhtml logging calendar.format accessors
io.encodings.binary fry xml.entities ; io.encodings.binary fry xml.entities destructors ;
IN: http.server.static IN: http.server.static
! special maps mime types to quots with effect ( path -- ) ! special maps mime types to quots with effect ( path -- )
@ -29,16 +29,14 @@ TUPLE: file-responder root hook special allow-listings ;
swap >>root swap >>root
H{ } clone >>special ; H{ } clone >>special ;
: (serve-static) ( path mime-type -- response )
[ [ binary <file-reader> &dispose ] dip <content> ]
[ drop file-info [ size>> ] [ modified>> ] bi ] 2bi
[ "content-length" set-header ]
[ "last-modified" set-header ] bi* ;
: <static> ( root -- responder ) : <static> ( root -- responder )
[ [ (serve-static) ] <file-responder> ;
<content>
swap [
file-info
[ size>> "content-length" set-header ]
[ modified>> "last-modified" set-header ] bi
]
[ '[ , binary <file-reader> output-stream get stream-copy ] >>body ] bi
] <file-responder> ;
: serve-static ( filename mime-type -- response ) : serve-static ( filename mime-type -- response )
over modified-since? over modified-since?

View File

@ -170,6 +170,11 @@ METHOD: as-mutate { object object assoc } set-at ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: index ( seq obj -- i ) swap sequences:index ;
: index-of ( obj seq -- i ) sequences:index ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: 1st 0 at ; : 1st 0 at ;
: 2nd 1 at ; : 2nd 1 at ;
: 3rd 2 at ; : 3rd 2 at ;

View File

@ -203,9 +203,7 @@ TUPLE: sprite loc dim dim2 dlist texture ;
dup sprite-loc gl-translate dup sprite-loc gl-translate
GL_TEXTURE_2D over sprite-texture glBindTexture GL_TEXTURE_2D over sprite-texture glBindTexture
init-texture init-texture
GL_QUADS [ dup sprite-dim2 four-sides ] do-state GL_QUADS [ sprite-dim2 four-sides ] do-state
dup sprite-dim { 1 0 } v*
swap sprite-loc v- gl-translate
GL_TEXTURE_2D 0 glBindTexture ; GL_TEXTURE_2D 0 glBindTexture ;
: rect-vertices ( lower-left upper-right -- ) : rect-vertices ( lower-left upper-right -- )

View File

@ -1,4 +1,4 @@
USING: html kernel semantic-db tangle.html tools.test ; USING: kernel semantic-db tangle.html tools.test ;
IN: tangle.html.tests IN: tangle.html.tests
[ "test" ] [ "test" >html ] unit-test [ "test" ] [ "test" >html ] unit-test

View File

@ -1,7 +1,7 @@
! Copyright (c) 2005 Mackenzie Straight. ! Copyright (c) 2005 Mackenzie Straight.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel tools.test trees.splay math namespaces assocs USING: kernel tools.test trees.splay math namespaces assocs
sequences random ; sequences random sets ;
IN: trees.splay.tests IN: trees.splay.tests
: randomize-numeric-splay-tree ( splay-tree -- ) : randomize-numeric-splay-tree ( splay-tree -- )

View File

@ -38,7 +38,7 @@ HELP: render-glyph
{ $description "Renders a character and outputs a pointer to the bitmap." } ; { $description "Renders a character and outputs a pointer to the bitmap." } ;
HELP: <char-sprite> HELP: <char-sprite>
{ $values { "font" font } { "char" "a non-negative integer" } { "sprite" sprite } } { $values { "open-font" font } { "char" "a non-negative integer" } { "sprite" sprite } }
{ $description "Renders a character to an OpenGL texture and records a display list which draws a quad with this texture. This word allocates native resources which must be freed by " { $link free-sprites } "." } ; { $description "Renders a character to an OpenGL texture and records a display list which draws a quad with this texture. This word allocates native resources which must be freed by " { $link free-sprites } "." } ;
HELP: (draw-string) HELP: (draw-string)

View File

@ -3,7 +3,8 @@
USING: alien alien.accessors alien.c-types arrays io kernel libc USING: alien alien.accessors alien.c-types arrays io kernel libc
math math.vectors namespaces opengl opengl.gl prettyprint assocs math math.vectors namespaces opengl opengl.gl prettyprint assocs
sequences io.files io.styles continuations freetype sequences io.files io.styles continuations freetype
ui.gadgets.worlds ui.render ui.backend byte-arrays ; ui.gadgets.worlds ui.render ui.backend byte-arrays accessors
locals ;
IN: ui.freetype IN: ui.freetype
@ -41,8 +42,8 @@ M: font hashcode* drop font hashcode* ;
] bind ; ] bind ;
M: freetype-renderer free-fonts ( world -- ) M: freetype-renderer free-fonts ( world -- )
dup world-handle select-gl-context [ handle>> select-gl-context ]
world-fonts [ nip second free-sprites ] assoc-each ; [ fonts>> [ nip second free-sprites ] assoc-each ] bi ;
: ttf-name ( font style -- name ) : ttf-name ( font style -- name )
2array H{ 2array H{
@ -67,7 +68,7 @@ M: freetype-renderer free-fonts ( world -- )
#! We use FT_New_Memory_Face, not FT_New_Face, since #! We use FT_New_Memory_Face, not FT_New_Face, since
#! FT_New_Face only takes an ASCII path name and causes #! FT_New_Face only takes an ASCII path name and causes
#! problems on localized versions of Windows #! problems on localized versions of Windows
freetype -rot 0 f <void*> [ [ freetype ] 2dip 0 f <void*> [
FT_New_Memory_Face freetype-error FT_New_Memory_Face freetype-error
] keep *void* ; ] keep *void* ;
@ -85,29 +86,29 @@ SYMBOL: dpi
: font-units>pixels ( n font -- n ) : font-units>pixels ( n font -- n )
face-size face-size-y-scale FT_MulFix ; face-size face-size-y-scale FT_MulFix ;
: init-ascent ( font face -- ) : init-ascent ( font face -- font )
dup face-y-max swap font-units>pixels swap set-font-ascent ; dup face-y-max swap font-units>pixels >>ascent ; inline
: init-descent ( font face -- ) : init-descent ( font face -- font )
dup face-y-min swap font-units>pixels swap set-font-descent ; dup face-y-min swap font-units>pixels >>descent ; inline
: init-font ( font -- ) : init-font ( font -- font )
dup font-handle 2dup init-ascent dupd init-descent dup handle>> init-ascent
dup font-ascent over font-descent - ft-ceil dup handle>> init-descent
swap set-font-height ; dup [ ascent>> ] [ descent>> ] bi - ft-ceil >>height ; inline
: set-char-size ( handle size -- )
0 swap 6 shift dpi get-global dup FT_Set_Char_Size freetype-error ;
: <font> ( handle -- font ) : <font> ( handle -- font )
H{ } clone font new
{ set-font-handle set-font-widths } font construct H{ } clone >>widths
dup init-font ; over first2 open-face >>handle
dup handle>> rot third set-char-size
: (open-font) ( font -- open-font ) init-font ;
first3 >r open-face dup 0 r> 6 shift
dpi get-global dpi get-global FT_Set_Char_Size
freetype-error <font> ;
M: freetype-renderer open-font ( font -- open-font ) M: freetype-renderer open-font ( font -- open-font )
freetype drop open-fonts get [ (open-font) ] cache ; freetype drop open-fonts get [ <font> ] cache ;
: load-glyph ( font char -- glyph ) : load-glyph ( font char -- glyph )
>r font-handle dup r> 0 FT_Load_Char >r font-handle dup r> 0 FT_Load_Char
@ -132,30 +133,35 @@ M: freetype-renderer string-height ( open-font string -- h )
load-glyph dup load-glyph dup
FT_RENDER_MODE_NORMAL FT_Render_Glyph freetype-error ; FT_RENDER_MODE_NORMAL FT_Render_Glyph freetype-error ;
: copy-pixel ( bit tex -- bit tex ) :: copy-pixel ( i j bitmap texture -- i j )
255 f pick set-alien-unsigned-1 1+ 255 j texture set-char-nth
f pick alien-unsigned-1 i bitmap char-nth j 1 + texture set-char-nth
f pick set-alien-unsigned-1 >r 1+ r> 1+ ; i 1 + j 2 + ; inline
: (copy-row) ( bit tex bitend texend -- bitend texend ) :: (copy-row) ( i j bitmap texture end -- )
>r pick over >= [ i end < [
2nip r> i j bitmap texture copy-pixel
] [ bitmap texture end (copy-row)
>r copy-pixel r> r> (copy-row) ] when ; inline
] if ;
: copy-row ( bit tex width width2 -- bitend texend width width2 ) :: copy-row ( i j bitmap texture width width2 -- i j )
[ pick + >r pick + r> (copy-row) ] 2keep ; i j bitmap texture i width + (copy-row)
i width +
j width2 + ; inline
: copy-bitmap ( glyph texture -- ) :: copy-bitmap ( glyph texture -- )
over glyph-bitmap-rows >r [let* | bitmap [ glyph glyph-bitmap-buffer ]
over glyph-bitmap-width dup next-power-of-2 2 * rows [ glyph glyph-bitmap-rows ]
>r >r >r glyph-bitmap-buffer alien-address r> r> r> r> width [ glyph glyph-bitmap-width ]
[ copy-row ] times 2drop 2drop ; width2 [ width next-power-of-2 2 * ] |
0 0
rows [ bitmap texture width width2 copy-row ] times
2drop
] ;
: bitmap>texture ( glyph sprite -- id ) : bitmap>texture ( glyph sprite -- id )
tuck sprite-size2 * 2 * [ tuck sprite-size2 * 2 * [
alien-address [ copy-bitmap ] keep <alien> gray-texture [ copy-bitmap ] keep gray-texture
] with-malloc ; ] with-malloc ;
: glyph-texture-loc ( glyph font -- loc ) : glyph-texture-loc ( glyph font -- loc )
@ -163,34 +169,47 @@ M: freetype-renderer string-height ( open-font string -- h )
font-ascent swap glyph-hori-bearing-y - ft-floor 2array ; font-ascent swap glyph-hori-bearing-y - ft-floor 2array ;
: glyph-texture-size ( glyph -- dim ) : glyph-texture-size ( glyph -- dim )
dup glyph-bitmap-width next-power-of-2 [ glyph-bitmap-width next-power-of-2 ]
swap glyph-bitmap-rows next-power-of-2 2array ; [ glyph-bitmap-rows next-power-of-2 ]
bi 2array ;
: <char-sprite> ( font char -- sprite ) : <char-sprite> ( open-font char -- sprite )
over >r render-glyph dup r> glyph-texture-loc over >r render-glyph dup r> glyph-texture-loc
over glyph-size pick glyph-texture-size <sprite> over glyph-size pick glyph-texture-size <sprite>
[ bitmap>texture ] keep [ init-sprite ] keep ; [ bitmap>texture ] keep [ init-sprite ] keep ;
: draw-char ( open-font char sprites -- ) :: char-sprite ( open-font sprites char -- sprite )
[ dupd <char-sprite> ] cache nip char sprites [ open-font swap <char-sprite> ] cache ;
sprite-dlist glCallList ;
: (draw-string) ( open-font sprites string loc -- ) : draw-char ( open-font sprites char loc -- )
GL_MODELVIEW [
0 0 glTranslated
char-sprite sprite-dlist glCallList
] do-matrix ;
: char-widths ( open-font string -- widths )
[ char-width ] with { } map-as ;
: scan-sums ( seq -- seq' )
0 [ + ] accumulate nip ;
:: (draw-string) ( open-font sprites string loc -- )
GL_TEXTURE_2D [ GL_TEXTURE_2D [
[ loc [
[ >r 2dup r> swap draw-char ] each 2drop string open-font string char-widths scan-sums [
[ open-font sprites ] 2dip draw-char
] 2each
] with-translation ] with-translation
] do-enabled ; ] do-enabled ;
: font-sprites ( open-font world -- pair ) : font-sprites ( font world -- open-font sprites )
world-fonts [ open-font H{ } clone 2array ] cache ; world-fonts [ open-font H{ } clone 2array ] cache first2 ;
M: freetype-renderer draw-string ( font string loc -- ) M: freetype-renderer draw-string ( font string loc -- )
>r >r world get font-sprites first2 r> r> (draw-string) ; >r >r world get font-sprites r> r> (draw-string) ;
: run-char-widths ( open-font string -- widths ) : run-char-widths ( open-font string -- widths )
[ char-width ] with { } map-as char-widths [ scan-sums ] [ 2 v/n ] bi v+ ;
dup 0 [ + ] accumulate nip swap 2 v/n v+ ;
M: freetype-renderer x>offset ( x open-font string -- n ) M: freetype-renderer x>offset ( x open-font string -- n )
dup >r run-char-widths [ <= ] with find drop dup >r run-char-widths [ <= ] with find drop

View File

@ -20,7 +20,7 @@ IN: unicode.collation.tests
[ execute ] 2with each ; [ execute ] 2with each ;
[ f f f f ] [ "hello" "hi" test-equality ] unit-test [ f f f f ] [ "hello" "hi" test-equality ] unit-test
[ t f f f ] [ "hello" "hŽllo" test-equality ] unit-test [ t f f f ] [ "hello" "h\u0000e9llo" test-equality ] unit-test
[ t t f f ] [ "hello" "HELLO" test-equality ] unit-test [ t t f f ] [ "hello" "HELLO" test-equality ] unit-test
[ t t t f ] [ "hello" "h e l l o." test-equality ] unit-test [ t t t f ] [ "hello" "h e l l o." test-equality ] unit-test
[ t t t t ] [ "hello" "\0hello\0" test-equality ] unit-test [ t t t t ] [ "hello" "\0hello\0" test-equality ] unit-test

View File

@ -109,9 +109,7 @@ CELL frame_executing(F_STACK_FRAME *frame)
{ {
F_COMPILED *compiled = frame_code(frame); F_COMPILED *compiled = frame_code(frame);
CELL code_start = (CELL)(compiled + 1); CELL code_start = (CELL)(compiled + 1);
CELL literal_start = code_start CELL literal_start = code_start + compiled->code_length;
+ compiled->code_length
+ compiled->reloc_length;
return get(literal_start); return get(literal_start);
} }

View File

@ -257,12 +257,13 @@ void iterate_code_heap(CODE_HEAP_ITERATOR iter)
} }
/* Copy all literals referenced from a code block to newspace */ /* Copy all literals referenced from a code block to newspace */
void collect_literals_step(F_COMPILED *compiled, CELL code_start, void collect_literals_step(F_COMPILED *compiled, CELL code_start, CELL literals_start)
CELL reloc_start, CELL literals_start)
{ {
CELL scan; CELL scan;
CELL literal_end = literals_start + compiled->literals_length; CELL literal_end = literals_start + compiled->literals_length;
copy_handle(&compiled->relocation);
for(scan = literals_start; scan < literal_end; scan += CELLS) for(scan = literals_start; scan < literal_end; scan += CELLS)
copy_handle((CELL*)scan); copy_handle((CELL*)scan);
} }

View File

@ -17,9 +17,6 @@ typedef struct _F_BLOCK
/* Used during compaction */ /* Used during compaction */
struct _F_BLOCK *forwarding; struct _F_BLOCK *forwarding;
/* Alignment padding */
CELL padding[4];
} F_BLOCK; } F_BLOCK;
typedef struct { typedef struct {
@ -47,16 +44,14 @@ INLINE F_BLOCK *next_block(F_HEAP *heap, F_BLOCK *block)
/* compiled code */ /* compiled code */
F_HEAP code_heap; F_HEAP code_heap;
typedef void (*CODE_HEAP_ITERATOR)(F_COMPILED *compiled, CELL code_start, typedef void (*CODE_HEAP_ITERATOR)(F_COMPILED *compiled, CELL code_start, CELL literals_start);
CELL reloc_start, CELL literals_start);
INLINE void iterate_code_heap_step(F_COMPILED *compiled, CODE_HEAP_ITERATOR iter) INLINE void iterate_code_heap_step(F_COMPILED *compiled, CODE_HEAP_ITERATOR iter)
{ {
CELL code_start = (CELL)(compiled + 1); CELL code_start = (CELL)(compiled + 1);
CELL reloc_start = code_start + compiled->code_length; CELL literals_start = code_start + compiled->code_length;
CELL literals_start = reloc_start + compiled->reloc_length;
iter(compiled,code_start,reloc_start,literals_start); iter(compiled,code_start,literals_start);
} }
INLINE F_BLOCK *compiled_to_block(F_COMPILED *compiled) INLINE F_BLOCK *compiled_to_block(F_COMPILED *compiled)

View File

@ -139,13 +139,14 @@ void apply_relocation(CELL class, CELL offset, F_FIXNUM absolute_value)
} }
/* Perform all fixups on a code block */ /* Perform all fixups on a code block */
void relocate_code_block(F_COMPILED *relocating, CELL code_start, void relocate_code_block(F_COMPILED *compiled, CELL code_start, CELL literals_start)
CELL reloc_start, CELL literals_start)
{ {
if(reloc_start != literals_start) if(compiled->relocation != F)
{ {
F_REL *rel = (F_REL *)reloc_start; F_BYTE_ARRAY *relocation = untag_object(compiled->relocation);
F_REL *rel_end = (F_REL *)literals_start;
F_REL *rel = (F_REL *)(relocation + 1);
F_REL *rel_end = (F_REL *)((char *)rel + byte_array_capacity(relocation));
while(rel < rel_end) while(rel < rel_end)
{ {
@ -160,7 +161,7 @@ void relocate_code_block(F_COMPILED *relocating, CELL code_start,
} }
} }
flush_icache(code_start,reloc_start - code_start); flush_icache(code_start,literals_start - code_start);
} }
/* Fixup labels. This is done at compile time, not image load time */ /* Fixup labels. This is done at compile time, not image load time */
@ -249,34 +250,32 @@ F_COMPILED *add_compiled_block(
CELL type, CELL type,
F_ARRAY *code, F_ARRAY *code,
F_ARRAY *labels, F_ARRAY *labels,
F_ARRAY *relocation, CELL relocation,
F_ARRAY *literals) F_ARRAY *literals)
{ {
CELL code_format = compiled_code_format(); CELL code_format = compiled_code_format();
CELL code_length = align8(array_capacity(code) * code_format); CELL code_length = align8(array_capacity(code) * code_format);
CELL rel_length = array_capacity(relocation) * sizeof(unsigned int);
CELL literals_length = array_capacity(literals) * CELLS; CELL literals_length = array_capacity(literals) * CELLS;
REGISTER_ROOT(relocation);
REGISTER_UNTAGGED(code); REGISTER_UNTAGGED(code);
REGISTER_UNTAGGED(labels); REGISTER_UNTAGGED(labels);
REGISTER_UNTAGGED(relocation);
REGISTER_UNTAGGED(literals); REGISTER_UNTAGGED(literals);
CELL here = allot_code_block(sizeof(F_COMPILED) + code_length CELL here = allot_code_block(sizeof(F_COMPILED) + code_length + literals_length);
+ rel_length + literals_length);
UNREGISTER_UNTAGGED(literals); UNREGISTER_UNTAGGED(literals);
UNREGISTER_UNTAGGED(relocation);
UNREGISTER_UNTAGGED(labels); UNREGISTER_UNTAGGED(labels);
UNREGISTER_UNTAGGED(code); UNREGISTER_UNTAGGED(code);
UNREGISTER_ROOT(relocation);
/* compiled header */ /* compiled header */
F_COMPILED *header = (void *)here; F_COMPILED *header = (void *)here;
header->type = type; header->type = type;
header->code_length = code_length; header->code_length = code_length;
header->reloc_length = rel_length;
header->literals_length = literals_length; header->literals_length = literals_length;
header->relocation = relocation;
here += sizeof(F_COMPILED); here += sizeof(F_COMPILED);
@ -286,10 +285,6 @@ F_COMPILED *add_compiled_block(
deposit_integers(here,code,code_format); deposit_integers(here,code,code_format);
here += code_length; here += code_length;
/* relation info */
deposit_integers(here,relocation,sizeof(unsigned int));
here += rel_length;
/* literals */ /* literals */
deposit_objects(here,literals); deposit_objects(here,literals);
here += literals_length; here += literals_length;
@ -353,7 +348,7 @@ DEFINE_PRIMITIVE(modify_code_heap)
F_ARRAY *compiled_code = untag_array(data); F_ARRAY *compiled_code = untag_array(data);
F_ARRAY *literals = untag_array(array_nth(compiled_code,0)); F_ARRAY *literals = untag_array(array_nth(compiled_code,0));
F_ARRAY *relocation = untag_array(array_nth(compiled_code,1)); CELL relocation = array_nth(compiled_code,1);
F_ARRAY *labels = untag_array(array_nth(compiled_code,2)); F_ARRAY *labels = untag_array(array_nth(compiled_code,2));
F_ARRAY *code = untag_array(array_nth(compiled_code,3)); F_ARRAY *code = untag_array(array_nth(compiled_code,3));

View File

@ -53,8 +53,7 @@ typedef struct {
unsigned int offset; unsigned int offset;
} F_REL; } F_REL;
void relocate_code_block(F_COMPILED *relocating, CELL code_start, void relocate_code_block(F_COMPILED *relocating, CELL code_start, CELL literals_start);
CELL reloc_start, CELL literals_start);
void default_word_code(F_WORD *word, bool relocate); void default_word_code(F_WORD *word, bool relocate);
@ -64,7 +63,7 @@ F_COMPILED *add_compiled_block(
CELL type, CELL type,
F_ARRAY *code, F_ARRAY *code,
F_ARRAY *labels, F_ARRAY *labels,
F_ARRAY *rel, CELL relocation,
F_ARRAY *literals); F_ARRAY *literals);
CELL compiled_code_format(void); CELL compiled_code_format(void);

View File

@ -930,22 +930,22 @@ DEFINE_PRIMITIVE(gc_stats)
for(i = 0; i < MAX_GEN_COUNT; i++) for(i = 0; i < MAX_GEN_COUNT; i++)
{ {
F_GC_STATS *s = &gc_stats[i]; F_GC_STATS *s = &gc_stats[i];
GROWABLE_ADD(stats,allot_cell(s->collections)); GROWABLE_ARRAY_ADD(stats,allot_cell(s->collections));
GROWABLE_ADD(stats,allot_cell(s->gc_time)); GROWABLE_ARRAY_ADD(stats,allot_cell(s->gc_time));
GROWABLE_ADD(stats,allot_cell(s->max_gc_time)); GROWABLE_ARRAY_ADD(stats,allot_cell(s->max_gc_time));
GROWABLE_ADD(stats,allot_cell(s->collections == 0 ? 0 : s->gc_time / s->collections)); GROWABLE_ARRAY_ADD(stats,allot_cell(s->collections == 0 ? 0 : s->gc_time / s->collections));
GROWABLE_ADD(stats,allot_cell(s->object_count)); GROWABLE_ARRAY_ADD(stats,allot_cell(s->object_count));
GROWABLE_ADD(stats,tag_bignum(long_long_to_bignum(s->bytes_copied))); GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(s->bytes_copied)));
total_gc_time += s->gc_time; total_gc_time += s->gc_time;
} }
GROWABLE_ADD(stats,allot_cell(total_gc_time)); GROWABLE_ARRAY_ADD(stats,allot_cell(total_gc_time));
GROWABLE_ADD(stats,tag_bignum(long_long_to_bignum(cards_scanned))); GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(cards_scanned)));
GROWABLE_ADD(stats,tag_bignum(long_long_to_bignum(decks_scanned))); GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(decks_scanned)));
GROWABLE_ADD(stats,allot_cell(code_heap_scans)); GROWABLE_ARRAY_ADD(stats,allot_cell(code_heap_scans));
GROWABLE_TRIM(stats); GROWABLE_ARRAY_TRIM(stats);
dpush(stats); dpush(stats);
} }
@ -986,13 +986,13 @@ CELL find_all_words(void)
while((obj = next_object()) != F) while((obj = next_object()) != F)
{ {
if(type_of(obj) == WORD_TYPE) if(type_of(obj) == WORD_TYPE)
GROWABLE_ADD(words,obj); GROWABLE_ARRAY_ADD(words,obj);
} }
/* End heap scan */ /* End heap scan */
gc_off = false; gc_off = false;
GROWABLE_TRIM(words); GROWABLE_ARRAY_TRIM(words);
return words; return words;
} }

View File

@ -296,8 +296,7 @@ void find_data_references(CELL look_for_)
CELL look_for; CELL look_for;
void find_code_references_step(F_COMPILED *compiled, CELL code_start, void find_code_references_step(F_COMPILED *compiled, CELL code_start, CELL literals_start)
CELL reloc_start, CELL literals_start)
{ {
CELL scan; CELL scan;
CELL literal_end = literals_start + compiled->literals_length; CELL literal_end = literals_start + compiled->literals_length;
@ -305,9 +304,7 @@ void find_code_references_step(F_COMPILED *compiled, CELL code_start,
for(scan = literals_start; scan < literal_end; scan += CELLS) for(scan = literals_start; scan < literal_end; scan += CELLS)
{ {
CELL code_start = (CELL)(compiled + 1); CELL code_start = (CELL)(compiled + 1);
CELL literal_start = code_start CELL literal_start = code_start + compiled->code_length;
+ compiled->code_length
+ compiled->reloc_length;
CELL obj = get(literal_start); CELL obj = get(literal_start);

View File

@ -288,18 +288,18 @@ void relocate_data()
} }
} }
void fixup_code_block(F_COMPILED *relocating, CELL code_start, void fixup_code_block(F_COMPILED *compiled, CELL code_start, CELL literals_start)
CELL reloc_start, CELL literals_start)
{ {
/* relocate literal table data */ /* relocate literal table data */
CELL scan; CELL scan;
CELL literal_end = literals_start + relocating->literals_length; CELL literal_end = literals_start + compiled->literals_length;
data_fixup(&compiled->relocation);
for(scan = literals_start; scan < literal_end; scan += CELLS) for(scan = literals_start; scan < literal_end; scan += CELLS)
data_fixup((CELL*)scan); data_fixup((CELL*)scan);
if(reloc_start != literals_start) relocate_code_block(compiled,code_start,literals_start);
relocate_code_block(relocating,code_start,reloc_start,literals_start);
} }
void relocate_code() void relocate_code()

View File

@ -113,8 +113,8 @@ typedef struct
{ {
CELL type; /* this is WORD_TYPE or QUOTATION_TYPE */ CELL type; /* this is WORD_TYPE or QUOTATION_TYPE */
CELL code_length; /* # bytes */ CELL code_length; /* # bytes */
CELL reloc_length; /* # bytes */
CELL literals_length; /* # bytes */ CELL literals_length; /* # bytes */
CELL relocation; /* tagged pointer to byte-array or f */
} F_COMPILED; } F_COMPILED;
/* Assembly code makes assumptions about the layout of this struct */ /* Assembly code makes assumptions about the layout of this struct */

View File

@ -73,14 +73,14 @@ DEFINE_PRIMITIVE(read_dir)
while((file = readdir(dir)) != NULL) while((file = readdir(dir)) != NULL)
{ {
CELL pair = parse_dir_entry(file); CELL pair = parse_dir_entry(file);
GROWABLE_ADD(result,pair); GROWABLE_ARRAY_ADD(result,pair);
} }
closedir(dir); closedir(dir);
} }
UNREGISTER_ROOT(result); UNREGISTER_ROOT(result);
GROWABLE_TRIM(result); GROWABLE_ARRAY_TRIM(result);
dpush(result); dpush(result);
} }
@ -104,12 +104,12 @@ DEFINE_PRIMITIVE(os_envs)
while(*env) while(*env)
{ {
CELL string = tag_object(from_char_string(*env)); CELL string = tag_object(from_char_string(*env));
GROWABLE_ADD(result,string); GROWABLE_ARRAY_ADD(result,string);
env++; env++;
} }
UNREGISTER_ROOT(result); UNREGISTER_ROOT(result);
GROWABLE_TRIM(result); GROWABLE_ARRAY_TRIM(result);
dpush(result); dpush(result);
} }

View File

@ -25,7 +25,7 @@ DEFINE_PRIMITIVE(os_envs)
break; break;
CELL string = tag_object(from_u16_string(finger)); CELL string = tag_object(from_u16_string(finger));
GROWABLE_ADD(result,string); GROWABLE_ARRAY_ADD(result,string);
finger = scan + 1; finger = scan + 1;
} }
@ -33,7 +33,7 @@ DEFINE_PRIMITIVE(os_envs)
FreeEnvironmentStrings(env); FreeEnvironmentStrings(env);
UNREGISTER_ROOT(result); UNREGISTER_ROOT(result);
GROWABLE_TRIM(result); GROWABLE_ARRAY_TRIM(result);
dpush(result); dpush(result);
} }

View File

@ -152,14 +152,14 @@ DEFINE_PRIMITIVE(read_dir)
CELL name = tag_object(from_u16_string(find_data.cFileName)); CELL name = tag_object(from_u16_string(find_data.cFileName));
CELL dirp = tag_boolean(find_data.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY); CELL dirp = tag_boolean(find_data.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY);
CELL pair = allot_array_2(name,dirp); CELL pair = allot_array_2(name,dirp);
GROWABLE_ADD(result,pair); GROWABLE_ARRAY_ADD(result,pair);
} }
while (FindNextFile(dir, &find_data)); while (FindNextFile(dir, &find_data));
FindClose(dir); FindClose(dir);
} }
UNREGISTER_ROOT(result); UNREGISTER_ROOT(result);
GROWABLE_TRIM(result); GROWABLE_ARRAY_TRIM(result);
dpush(result); dpush(result);
} }

View File

@ -60,14 +60,9 @@ F_REL rel_to_emit(CELL name, CELL code_format, CELL code_length,
#define EMIT(name,rel_argument) { \ #define EMIT(name,rel_argument) { \
bool rel_p; \ bool rel_p; \
F_REL rel = rel_to_emit(name,code_format,code_count, \ F_REL rel = rel_to_emit(name,code_format,code_count,rel_argument,&rel_p); \
rel_argument,&rel_p); \ if(rel_p) GROWABLE_BYTE_ARRAY_APPEND(relocation,&rel,sizeof(F_REL)); \
if(rel_p) \ GROWABLE_ARRAY_APPEND(code,code_to_emit(name)); \
{ \
GROWABLE_ADD(relocation,allot_cell(rel.type)); \
GROWABLE_ADD(relocation,allot_cell(rel.offset)); \
} \
GROWABLE_APPEND(code,code_to_emit(name)); \
} }
bool jit_stack_frame_p(F_ARRAY *array) bool jit_stack_frame_p(F_ARRAY *array)
@ -110,13 +105,13 @@ void jit_compile(CELL quot, bool relocate)
GROWABLE_ARRAY(code); GROWABLE_ARRAY(code);
REGISTER_ROOT(code); REGISTER_ROOT(code);
GROWABLE_ARRAY(relocation); GROWABLE_BYTE_ARRAY(relocation);
REGISTER_ROOT(relocation); REGISTER_ROOT(relocation);
GROWABLE_ARRAY(literals); GROWABLE_ARRAY(literals);
REGISTER_ROOT(literals); REGISTER_ROOT(literals);
GROWABLE_ADD(literals,stack_traces_p() ? quot : F); GROWABLE_ARRAY_ADD(literals,stack_traces_p() ? quot : F);
bool stack_frame = jit_stack_frame_p(untag_object(array)); bool stack_frame = jit_stack_frame_p(untag_object(array));
@ -141,7 +136,7 @@ void jit_compile(CELL quot, bool relocate)
current stack frame. */ current stack frame. */
word = untag_object(obj); word = untag_object(obj);
GROWABLE_ADD(literals,array_nth(untag_object(array),i)); GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
if(i == length - 1) if(i == length - 1)
{ {
@ -157,7 +152,7 @@ void jit_compile(CELL quot, bool relocate)
break; break;
case WRAPPER_TYPE: case WRAPPER_TYPE:
wrapper = untag_object(obj); wrapper = untag_object(obj);
GROWABLE_ADD(literals,wrapper->object); GROWABLE_ARRAY_ADD(literals,wrapper->object);
EMIT(JIT_PUSH_LITERAL,literals_count - 1); EMIT(JIT_PUSH_LITERAL,literals_count - 1);
break; break;
case FIXNUM_TYPE: case FIXNUM_TYPE:
@ -176,8 +171,8 @@ void jit_compile(CELL quot, bool relocate)
if(stack_frame) if(stack_frame)
EMIT(JIT_EPILOG,0); EMIT(JIT_EPILOG,0);
GROWABLE_ADD(literals,array_nth(untag_object(array),i)); GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
GROWABLE_ADD(literals,array_nth(untag_object(array),i + 1)); GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i + 1));
EMIT(JIT_IF_JUMP,literals_count - 2); EMIT(JIT_IF_JUMP,literals_count - 2);
i += 2; i += 2;
@ -191,7 +186,7 @@ void jit_compile(CELL quot, bool relocate)
if(stack_frame) if(stack_frame)
EMIT(JIT_EPILOG,0); EMIT(JIT_EPILOG,0);
GROWABLE_ADD(literals,array_nth(untag_object(array),i)); GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
EMIT(JIT_DISPATCH,literals_count - 1); EMIT(JIT_DISPATCH,literals_count - 1);
i++; i++;
@ -200,7 +195,7 @@ void jit_compile(CELL quot, bool relocate)
break; break;
} }
default: default:
GROWABLE_ADD(literals,obj); GROWABLE_ARRAY_ADD(literals,obj);
EMIT(JIT_PUSH_LITERAL,literals_count - 1); EMIT(JIT_PUSH_LITERAL,literals_count - 1);
break; break;
} }
@ -214,15 +209,15 @@ void jit_compile(CELL quot, bool relocate)
EMIT(JIT_RETURN,0); EMIT(JIT_RETURN,0);
} }
GROWABLE_TRIM(code); GROWABLE_ARRAY_TRIM(code);
GROWABLE_TRIM(relocation); GROWABLE_ARRAY_TRIM(literals);
GROWABLE_TRIM(literals); GROWABLE_BYTE_ARRAY_TRIM(relocation);
F_COMPILED *compiled = add_compiled_block( F_COMPILED *compiled = add_compiled_block(
QUOTATION_TYPE, QUOTATION_TYPE,
untag_object(code), untag_object(code),
NULL, NULL,
untag_object(relocation), relocation,
untag_object(literals)); untag_object(literals));
set_quot_xt(untag_object(quot),compiled); set_quot_xt(untag_object(quot),compiled);

View File

@ -197,7 +197,7 @@ DEFINE_PRIMITIVE(resize_array)
dpush(tag_object(reallot_array(array,capacity,F))); dpush(tag_object(reallot_array(array,capacity,F)));
} }
F_ARRAY *growable_add(F_ARRAY *result, CELL elt, CELL *result_count) F_ARRAY *growable_array_add(F_ARRAY *result, CELL elt, CELL *result_count)
{ {
REGISTER_ROOT(elt); REGISTER_ROOT(elt);
@ -209,12 +209,12 @@ F_ARRAY *growable_add(F_ARRAY *result, CELL elt, CELL *result_count)
UNREGISTER_ROOT(elt); UNREGISTER_ROOT(elt);
set_array_nth(result,*result_count,elt); set_array_nth(result,*result_count,elt);
*result_count = *result_count + 1; (*result_count)++;
return result; return result;
} }
F_ARRAY *growable_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_count) F_ARRAY *growable_array_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_count)
{ {
REGISTER_UNTAGGED(elts); REGISTER_UNTAGGED(elts);
@ -228,7 +228,7 @@ F_ARRAY *growable_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_count)
write_barrier((CELL)result); write_barrier((CELL)result);
memcpy((void*)AREF(result,*result_count),(void*)AREF(elts,0),elts_size * CELLS); memcpy((void *)AREF(result,*result_count),(void *)AREF(elts,0),elts_size * CELLS);
*result_count += elts_size; *result_count += elts_size;
@ -283,6 +283,33 @@ DEFINE_PRIMITIVE(resize_byte_array)
dpush(tag_object(reallot_byte_array(array,capacity))); dpush(tag_object(reallot_byte_array(array,capacity)));
} }
F_BYTE_ARRAY *growable_byte_array_add(F_BYTE_ARRAY *result, CELL elt, CELL *result_count)
{
if(*result_count == byte_array_capacity(result))
{
result = reallot_byte_array(result,*result_count * 2);
}
bput(BREF(result,*result_count),elt);
*result_count++;
return result;
}
F_BYTE_ARRAY *growable_byte_array_append(F_BYTE_ARRAY *result, void *elts, CELL len, CELL *result_count)
{
CELL new_size = *result_count + len;
if(new_size >= byte_array_capacity(result))
result = reallot_byte_array(result,new_size * 2);
memcpy((void *)BREF(result,*result_count),elts,len);
*result_count = new_size;
return result;
}
/* Bit arrays */ /* Bit arrays */
/* size is in bits */ /* size is in bits */

View File

@ -146,6 +146,7 @@ DECLARE_PRIMITIVE(float_array);
DECLARE_PRIMITIVE(clone); DECLARE_PRIMITIVE(clone);
F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity, CELL fill); F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity, CELL fill);
F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity);
DECLARE_PRIMITIVE(resize_array); DECLARE_PRIMITIVE(resize_array);
DECLARE_PRIMITIVE(resize_byte_array); DECLARE_PRIMITIVE(resize_byte_array);
DECLARE_PRIMITIVE(resize_bit_array); DECLARE_PRIMITIVE(resize_bit_array);
@ -193,15 +194,33 @@ DECLARE_PRIMITIVE(wrapper);
CELL result##_count = 0; \ CELL result##_count = 0; \
CELL result = tag_object(allot_array(ARRAY_TYPE,100,F)) CELL result = tag_object(allot_array(ARRAY_TYPE,100,F))
F_ARRAY *growable_add(F_ARRAY *result, CELL elt, CELL *result_count); F_ARRAY *growable_array_add(F_ARRAY *result, CELL elt, CELL *result_count);
#define GROWABLE_ADD(result,elt) \ #define GROWABLE_ARRAY_ADD(result,elt) \
result = tag_object(growable_add(untag_object(result),elt,&result##_count)) result = tag_object(growable_array_add(untag_object(result),elt,&result##_count))
F_ARRAY *growable_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_count); F_ARRAY *growable_array_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_count);
#define GROWABLE_APPEND(result,elts) \ #define GROWABLE_ARRAY_APPEND(result,elts) \
result = tag_object(growable_append(untag_object(result),elts,&result##_count)) result = tag_object(growable_array_append(untag_object(result),elts,&result##_count))
#define GROWABLE_TRIM(result) \ #define GROWABLE_ARRAY_TRIM(result) \
result = tag_object(reallot_array(untag_object(result),result##_count,F)) result = tag_object(reallot_array(untag_object(result),result##_count,F))
/* Macros to simulate a byte vector in C */
#define GROWABLE_BYTE_ARRAY(result) \
CELL result##_count = 0; \
CELL result = tag_object(allot_byte_array(100))
F_ARRAY *growable_byte_array_add(F_BYTE_ARRAY *result, CELL elt, CELL *result_count);
#define GROWABLE_BYTE_ARRAY_ADD(result,elt) \
result = tag_object(growable_byte_array_add(untag_object(result),elt,&result##_count))
F_ARRAY *growable_byte_array_append(F_BYTE_ARRAY *result, void *elts, CELL len, CELL *result_count);
#define GROWABLE_BYTE_ARRAY_APPEND(result,elts,len) \
result = tag_object(growable_byte_array_append(untag_object(result),elts,len,&result##_count))
#define GROWABLE_BYTE_ARRAY_TRIM(result) \
result = tag_object(reallot_byte_array(untag_object(result),result##_count))