From 8bff6eba523455165baf6c5c0a696dc0646b319e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 28 May 2008 19:43:01 -0500 Subject: [PATCH 01/20] Fix silly DEFER: error --- core/parser/parser-tests.factor | 2 ++ core/parser/parser.factor | 2 +- core/syntax/syntax.factor | 2 +- 3 files changed, 4 insertions(+), 2 deletions(-) diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index 37eb5f148e..df6c9dadc5 100755 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -485,3 +485,5 @@ must-fail-with [ t ] [ "staging-problem-test-1" "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 diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 3f46d1dd30..46e93753b5 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -236,7 +236,7 @@ PREDICATE: unexpected-eof < unexpected ERROR: no-current-vocab ; M: no-current-vocab summary ( obj -- ) - drop "Current vocabulary is f, use IN:" ; + drop "Not in a vocabulary; IN: form required" ; : current-vocab ( -- str ) in get [ no-current-vocab ] unless* ; diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 7ed79f77f1..27c8609a99 100755 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -100,7 +100,7 @@ IN: bootstrap.syntax ] define-syntax "DEFER:" [ - scan in get create + scan current-vocab create dup old-definitions get [ delete-at ] with each set-word ] define-syntax From 73b0e07277b5b6f3f1d3d78dfea280bee8cd0a8a Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Wed, 28 May 2008 21:44:02 -0500 Subject: [PATCH 02/20] combinators.lib: Add || variants --- extra/combinators/lib/lib.factor | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/extra/combinators/lib/lib.factor b/extra/combinators/lib/lib.factor index 4c4a988935..2c7f2bbb03 100755 --- a/extra/combinators/lib/lib.factor +++ b/extra/combinators/lib/lib.factor @@ -77,8 +77,21 @@ MACRO: <--&& ( quots -- ) [ [ 2dup ] prepend [ not ] append [ f ] ] t short-circuit [ 2nip ] append ; +! or + 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 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From ce4f8871bf5464495d400440d585bc85d713fd82 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Wed, 28 May 2008 23:08:54 -0500 Subject: [PATCH 03/20] dns: Add support for AAAA records --- extra/dns/dns.factor | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/extra/dns/dns.factor b/extra/dns/dns.factor index 560db69bb2..f10bdea0bf 100644 --- a/extra/dns/dns.factor +++ b/extra/dns/dns.factor @@ -38,7 +38,7 @@ TUPLE: message ! 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 ) { @@ -58,6 +58,7 @@ SYMBOLS: A NS MD MF CNAME SOA MB MG MR NULL WKS PTR HINFO MINFO MX TXT ; { MINFO 14 } { MX 15 } { 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 ; +: ipv6->ba ( ip -- ba ) ":" split [ 16 base> ] map [ 2 >be ] map concat ; + : 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-ipv6 ( ba i -- ip ) + dup 16 + subseq 2 group [ be> 16 >base ] map ":" join ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + : get-rdata ( ba i type -- rdata ) { { CNAME [ get-name ] } @@ -338,6 +348,7 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED { MX [ get-mx ] } { SOA [ get-soa ] } { A [ get-ip ] } + { AAAA [ get-ipv6 ] } } case ; From e14a9ec0fb35bc16a51cba6de45de4dbb71377ad Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Wed, 28 May 2008 23:09:19 -0500 Subject: [PATCH 04/20] dns.cache: cache-get* word --- extra/dns/cache/cache.factor | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/extra/dns/cache/cache.factor b/extra/dns/cache/cache.factor index 75bbf9de9d..aeba35f29d 100644 --- a/extra/dns/cache/cache.factor +++ b/extra/dns/cache/cache.factor @@ -68,7 +68,7 @@ SYMBOL: NX : expired? ( entry -- ? ) time>> time->ttl 0 <= ; -: cache-get ( query -- result ) +: cache-get* ( query -- rrs/NX/f ) dup table-get ! query result { { [ 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 ) [ ttl>> ttl->time ] [ rdata>> {1} >vector ] bi entry boa ; From 5a2ff64c3f0768829920aaae1eced721e54557d6 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Wed, 28 May 2008 23:12:01 -0500 Subject: [PATCH 05/20] Add dns.recursive for recursive queries --- extra/dns/recursive/recursive.factor | 182 +++++++++++++++++++++++++++ 1 file changed, 182 insertions(+) create mode 100644 extra/dns/recursive/recursive.factor diff --git a/extra/dns/recursive/recursive.factor b/extra/dns/recursive/recursive.factor new file mode 100644 index 0000000000..6fe8ec96da --- /dev/null +++ b/extra/dns/recursive/recursive.factor @@ -0,0 +1,182 @@ + +USING: kernel continuations + combinators + sequences + 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" + } ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: cache-message ( message -- message ) + dup dup rcode>> NAME-ERROR = + [ + [ question-section>> 1st ] + [ authority-section>> [ type>> SOA = ] filter random ttl>> ] + bi + cache-nx + ] + [ + { + [ answer-section>> cache-add-rrs ] + [ authority-section>> cache-add-rrs ] + [ additional-section>> cache-add-rrs ] + } + cleave + ] + if ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: query->message ( query -- message ) ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: {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 ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: message-query ( message -- query ) question-section>> 1st ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: 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 ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: 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 ( 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 ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From cf587c054dd35e9ce41480cf39c7567745be0df4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 29 May 2008 02:40:32 -0500 Subject: [PATCH 06/20] Tweak font rendering to avoid roundoff error --- extra/opengl/opengl.factor | 4 +- extra/ui/freetype/freetype.factor | 126 +++++++++++++++++------------- 2 files changed, 74 insertions(+), 56 deletions(-) diff --git a/extra/opengl/opengl.factor b/extra/opengl/opengl.factor index a6e76cdc9e..79470131f3 100755 --- a/extra/opengl/opengl.factor +++ b/extra/opengl/opengl.factor @@ -203,9 +203,7 @@ TUPLE: sprite loc dim dim2 dlist texture ; dup sprite-loc gl-translate GL_TEXTURE_2D over sprite-texture glBindTexture init-texture - GL_QUADS [ dup sprite-dim2 four-sides ] do-state - dup sprite-dim { 1 0 } v* - swap sprite-loc v- gl-translate + GL_QUADS [ sprite-dim2 four-sides ] do-state GL_TEXTURE_2D 0 glBindTexture ; : rect-vertices ( lower-left upper-right -- ) diff --git a/extra/ui/freetype/freetype.factor b/extra/ui/freetype/freetype.factor index 1c83bc9713..be4f2ba8ae 100755 --- a/extra/ui/freetype/freetype.factor +++ b/extra/ui/freetype/freetype.factor @@ -3,7 +3,8 @@ USING: alien alien.accessors alien.c-types arrays io kernel libc math math.vectors namespaces opengl opengl.gl prettyprint assocs 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 @@ -41,8 +42,8 @@ M: font hashcode* drop font hashcode* ; ] bind ; M: freetype-renderer free-fonts ( world -- ) - dup world-handle select-gl-context - world-fonts [ nip second free-sprites ] assoc-each ; + [ handle>> select-gl-context ] + [ fonts>> [ nip second free-sprites ] assoc-each ] bi ; : ttf-name ( font style -- name ) 2array H{ @@ -67,7 +68,7 @@ M: freetype-renderer free-fonts ( world -- ) #! We use FT_New_Memory_Face, not FT_New_Face, since #! FT_New_Face only takes an ASCII path name and causes #! problems on localized versions of Windows - freetype -rot 0 f [ + [ freetype ] 2dip 0 f [ FT_New_Memory_Face freetype-error ] keep *void* ; @@ -85,29 +86,29 @@ SYMBOL: dpi : font-units>pixels ( n font -- n ) face-size face-size-y-scale FT_MulFix ; -: init-ascent ( font face -- ) - dup face-y-max swap font-units>pixels swap set-font-ascent ; +: init-ascent ( font face -- font ) + dup face-y-max swap font-units>pixels >>ascent ; inline -: init-descent ( font face -- ) - dup face-y-min swap font-units>pixels swap set-font-descent ; +: init-descent ( font face -- font ) + dup face-y-min swap font-units>pixels >>descent ; inline -: init-font ( font -- ) - dup font-handle 2dup init-ascent dupd init-descent - dup font-ascent over font-descent - ft-ceil - swap set-font-height ; +: init-font ( font -- font ) + dup handle>> init-ascent + dup handle>> init-descent + 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 ; : ( handle -- font ) - H{ } clone - { set-font-handle set-font-widths } font construct - dup init-font ; - -: (open-font) ( font -- open-font ) - first3 >r open-face dup 0 r> 6 shift - dpi get-global dpi get-global FT_Set_Char_Size - freetype-error ; + font new + H{ } clone >>widths + over first2 open-face >>handle + dup handle>> rot third set-char-size + init-font ; M: freetype-renderer open-font ( font -- open-font ) - freetype drop open-fonts get [ (open-font) ] cache ; + freetype drop open-fonts get [ ] cache ; : load-glyph ( font char -- glyph ) >r font-handle dup r> 0 FT_Load_Char @@ -132,30 +133,36 @@ M: freetype-renderer string-height ( open-font string -- h ) load-glyph dup FT_RENDER_MODE_NORMAL FT_Render_Glyph freetype-error ; -: copy-pixel ( bit tex -- bit tex ) - 255 f pick set-alien-unsigned-1 1+ - f pick alien-unsigned-1 - f pick set-alien-unsigned-1 >r 1+ r> 1+ ; +:: copy-pixel ( i j bitmap texture -- i j ) + 255 tex j set-alien-unsigned-1 + i bitmap alien-unsigned-1 j 1 + texture set-alien-unsigned-1 + i 1 + j 2 + ; inline -: (copy-row) ( bit tex bitend texend -- bitend texend ) - >r pick over >= [ - 2nip r> - ] [ - >r copy-pixel r> r> (copy-row) - ] if ; +: (copy-row) ( i j bitmap texture end -- ) + i end < [ + i j bitmap texture copy-pixel + i j bitmap texture end (copy-row) + ] when ; inline -: copy-row ( bit tex width width2 -- bitend texend width width2 ) - [ pick + >r pick + r> (copy-row) ] 2keep ; +: copy-row ( i j bitmap texture width width2 -- i j ) + i j bitmap texture i width + (copy-row) + i width + + j width2 + ; inline -: copy-bitmap ( glyph texture -- ) - over glyph-bitmap-rows >r - over glyph-bitmap-width dup next-power-of-2 2 * - >r >r >r glyph-bitmap-buffer alien-address r> r> r> r> - [ copy-row ] times 2drop 2drop ; +:: copy-bitmap ( glyph texture -- ) + [let* | texture [ texture alien-address ] + bitmap [ glyph glyph-bitmap-buffer alien-address ] + rows [ glyph glyph-bitmap-rows ] + width [ glyph glyph-bitmap-width ] + width2 [ width next-power-of-2 2 * ] | + 0 0 + rows [ bitmap texture width width2 copy-row ] times + 2drop + ] ; : bitmap>texture ( glyph sprite -- id ) tuck sprite-size2 * 2 * [ - alien-address [ copy-bitmap ] keep gray-texture + [ copy-bitmap ] keep gray-texture ] with-malloc ; : glyph-texture-loc ( glyph font -- loc ) @@ -163,34 +170,47 @@ M: freetype-renderer string-height ( open-font string -- h ) font-ascent swap glyph-hori-bearing-y - ft-floor 2array ; : glyph-texture-size ( glyph -- dim ) - dup glyph-bitmap-width next-power-of-2 - swap glyph-bitmap-rows next-power-of-2 2array ; + [ glyph-bitmap-width next-power-of-2 ] + [ glyph-bitmap-rows next-power-of-2 ] + bi 2array ; -: ( font char -- sprite ) +: ( open-font char -- sprite ) over >r render-glyph dup r> glyph-texture-loc over glyph-size pick glyph-texture-size [ bitmap>texture ] keep [ init-sprite ] keep ; -: draw-char ( open-font char sprites -- ) - [ dupd ] cache nip - sprite-dlist glCallList ; +:: char-sprite ( open-font sprites char -- sprite ) + char sprites [ open-font swap ] cache ; -: (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 [ - [ - [ >r 2dup r> swap draw-char ] each 2drop + loc [ + string open-font string char-widths scan-sums [ + [ open-font sprites ] 2dip draw-char + ] 2each ] with-translation ] do-enabled ; -: font-sprites ( open-font world -- pair ) - world-fonts [ open-font H{ } clone 2array ] cache ; +: font-sprites ( font world -- open-font sprites ) + world-fonts [ open-font H{ } clone 2array ] cache first2 ; 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 ) - [ char-width ] with { } map-as - dup 0 [ + ] accumulate nip swap 2 v/n v+ ; + char-widths [ scan-sums ] [ 2 v/n ] bi v+ ; M: freetype-renderer x>offset ( x open-font string -- n ) dup >r run-char-widths [ <= ] with find drop From d57c66690da5a85fc9a8b74235906b460f68622c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 29 May 2008 02:47:30 -0500 Subject: [PATCH 07/20] Fix errors reported by builder --- core/sets/sets-docs.factor | 2 +- extra/html/components/components-tests.factor | 2 +- extra/tangle/html/html-tests.factor | 2 +- extra/trees/splay/splay-tests.factor | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/core/sets/sets-docs.factor b/core/sets/sets-docs.factor index 97fbc973f0..205d4d34bf 100644 --- a/core/sets/sets-docs.factor +++ b/core/sets/sets-docs.factor @@ -28,7 +28,7 @@ HELP: adjoin { $description "Removes all elements equal to " { $snippet "elt" } ", and adds " { $snippet "elt" } " at the end of the sequence." } { $examples { $example - "USING: namespaces prettyprint sequences ;" + "USING: namespaces prettyprint sets ;" "V{ \"beans\" \"salsa\" \"cheese\" } \"v\" set" "\"nachos\" \"v\" get adjoin" "\"salsa\" \"v\" get adjoin" diff --git a/extra/html/components/components-tests.factor b/extra/html/components/components-tests.factor index f2b0049a8e..1a0f849a8f 100644 --- a/extra/html/components/components-tests.factor +++ b/extra/html/components/components-tests.factor @@ -1,7 +1,7 @@ IN: html.components.tests USING: tools.test kernel io.streams.string io.streams.null accessors inspector html.streams -html.components ; +html.components namespaces ; [ ] [ blank-values ] unit-test diff --git a/extra/tangle/html/html-tests.factor b/extra/tangle/html/html-tests.factor index 8e7d8c24e1..88ad748400 100644 --- a/extra/tangle/html/html-tests.factor +++ b/extra/tangle/html/html-tests.factor @@ -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 [ "test" ] [ "test" >html ] unit-test diff --git a/extra/trees/splay/splay-tests.factor b/extra/trees/splay/splay-tests.factor index 29bc153030..e54e3cd538 100644 --- a/extra/trees/splay/splay-tests.factor +++ b/extra/trees/splay/splay-tests.factor @@ -1,7 +1,7 @@ ! Copyright (c) 2005 Mackenzie Straight. ! See http://factorcode.org/license.txt for BSD license. USING: kernel tools.test trees.splay math namespaces assocs -sequences random ; +sequences random sets ; IN: trees.splay.tests : randomize-numeric-splay-tree ( splay-tree -- ) From 41c845cf738aef558821b7d4d4b94cd973d86da0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 29 May 2008 02:51:16 -0500 Subject: [PATCH 08/20] Encoding issue? --- extra/unicode/collation/collation-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/unicode/collation/collation-tests.factor b/extra/unicode/collation/collation-tests.factor index c9d6cb808f..b4a54bb11d 100755 --- a/extra/unicode/collation/collation-tests.factor +++ b/extra/unicode/collation/collation-tests.factor @@ -20,7 +20,7 @@ IN: unicode.collation.tests [ execute ] 2with each ; [ 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 t f ] [ "hello" "h e l l o." test-equality ] unit-test [ t t t t ] [ "hello" "\0hello\0" test-equality ] unit-test From 21fcc8a542a6a5574866684ab354fff7f32c0539 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 29 May 2008 03:17:36 -0500 Subject: [PATCH 09/20] Oops --- extra/ui/freetype/freetype.factor | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/extra/ui/freetype/freetype.factor b/extra/ui/freetype/freetype.factor index be4f2ba8ae..3512bbf670 100755 --- a/extra/ui/freetype/freetype.factor +++ b/extra/ui/freetype/freetype.factor @@ -134,24 +134,23 @@ M: freetype-renderer string-height ( open-font string -- h ) FT_RENDER_MODE_NORMAL FT_Render_Glyph freetype-error ; :: copy-pixel ( i j bitmap texture -- i j ) - 255 tex j set-alien-unsigned-1 - i bitmap alien-unsigned-1 j 1 + texture set-alien-unsigned-1 + 255 j texture set-char-nth + i bitmap char-nth j 1 + texture set-char-nth i 1 + j 2 + ; inline -: (copy-row) ( i j bitmap texture end -- ) +:: (copy-row) ( i j bitmap texture end -- ) i end < [ i j bitmap texture copy-pixel - i j bitmap texture end (copy-row) + bitmap texture end (copy-row) ] when ; inline -: copy-row ( i j bitmap texture width width2 -- i j ) +:: copy-row ( i j bitmap texture width width2 -- i j ) i j bitmap texture i width + (copy-row) i width + j width2 + ; inline :: copy-bitmap ( glyph texture -- ) - [let* | texture [ texture alien-address ] - bitmap [ glyph glyph-bitmap-buffer alien-address ] + [let* | bitmap [ glyph glyph-bitmap-buffer ] rows [ glyph glyph-bitmap-rows ] width [ glyph glyph-bitmap-width ] width2 [ width next-power-of-2 2 * ] | From 05c3c82e3c0bce204686a30c8c68a0e6dafe5f65 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 29 May 2008 05:17:13 -0500 Subject: [PATCH 10/20] newfx: index --- extra/newfx/newfx.factor | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/extra/newfx/newfx.factor b/extra/newfx/newfx.factor index abe0449d06..e017dc4b2b 100644 --- a/extra/newfx/newfx.factor +++ b/extra/newfx/newfx.factor @@ -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 ; : 2nd 1 at ; : 3rd 2 at ; From 188fab8f003cac11a5d0df17469e688ba2907552 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 29 May 2008 05:17:30 -0500 Subject: [PATCH 11/20] dns: move some words to dns --- extra/dns/cache/cache.factor | 28 ++++++++++++++++++++++++++++ extra/dns/dns.factor | 7 ++++++- 2 files changed, 34 insertions(+), 1 deletion(-) diff --git a/extra/dns/cache/cache.factor b/extra/dns/cache/cache.factor index aeba35f29d..4167c7b16e 100644 --- a/extra/dns/cache/cache.factor +++ b/extra/dns/cache/cache.factor @@ -119,3 +119,31 @@ ERROR: name-error name ; : cache-add-rr ( rr -- ) [ rr->query ] [ ] bi cache-add ; : 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 ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + diff --git a/extra/dns/dns.factor b/extra/dns/dns.factor index f10bdea0bf..9404ccdad1 100644 --- a/extra/dns/dns.factor +++ b/extra/dns/dns.factor @@ -470,4 +470,9 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED : ask ( message -- message ) dns-server ask-server ; -: ( query -- message ) swap {1} >>question-section ; \ No newline at end of file +: query->message ( query -- message ) swap {1} >>question-section ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: message-query ( message -- query ) question-section>> 1st ; + From a109d10b3df78961f596f9f1c68b199ffda473e0 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 29 May 2008 05:17:55 -0500 Subject: [PATCH 12/20] dns.recursive: Try out an optimized name->ip/server --- extra/dns/recursive/recursive.factor | 67 +++++++++++++++------------- 1 file changed, 35 insertions(+), 32 deletions(-) diff --git a/extra/dns/recursive/recursive.factor b/extra/dns/recursive/recursive.factor index 6fe8ec96da..3a74667845 100644 --- a/extra/dns/recursive/recursive.factor +++ b/extra/dns/recursive/recursive.factor @@ -2,6 +2,7 @@ USING: kernel continuations combinators sequences + math random unicode.case accessors symbols @@ -28,30 +29,6 @@ IN: dns.recursive ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: cache-message ( message -- message ) - dup dup rcode>> NAME-ERROR = - [ - [ question-section>> 1st ] - [ authority-section>> [ type>> SOA = ] filter random ttl>> ] - bi - cache-nx - ] - [ - { - [ answer-section>> cache-add-rrs ] - [ authority-section>> cache-add-rrs ] - [ additional-section>> cache-add-rrs ] - } - cleave - ] - if ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: query->message ( query -- message ) ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - : {name-type-class} ( obj -- seq ) [ name>> >lower ] [ type>> ] [ class>> ] tri {3} ; @@ -61,10 +38,6 @@ IN: dns.recursive ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: message-query ( message -- query ) question-section>> 1st ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - : answer-hits ( message -- rrs ) [ answer-section>> ] [ message-query ] bi rr-filter ; @@ -110,7 +83,7 @@ DEFER: name->ip ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: recursive-query ( query servers -- message ) +: (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 @@ -128,20 +101,39 @@ DEFER: name->ip remove ! message query servers dup empty? [ 2drop ] - [ rot drop recursive-query ] + [ rot drop (recursive-query) ] if ] } [ ! query servers server message sym drop nip nip ! query message extract-ns-ips ! query ips - recursive-query + (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 ; @@ -154,8 +146,19 @@ DEFER: name->ip : 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 root-dns-servers recursive-query ! message + A IN query boa recursive-query ! message { { [ name-hits? ] [ name-hits random rdata>> ] } { [ cname-hits? ] [ cname-hits random rdata>> name->ip ] } From 3bd5144f2030284c9e38e7f373880d765519d2f8 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 29 May 2008 10:11:12 -0500 Subject: [PATCH 13/20] dns.resolver: minor fix --- extra/dns/resolver/resolver.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/dns/resolver/resolver.factor b/extra/dns/resolver/resolver.factor index c8a9f22d08..7e0f6b4190 100644 --- a/extra/dns/resolver/resolver.factor +++ b/extra/dns/resolver/resolver.factor @@ -62,7 +62,7 @@ IN: dns.resolver ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : canonical/server ( name -- name ) - dup CNAME IN query boa ask* answer-section>> + dup CNAME IN query boa query->message ask* answer-section>> [ type>> CNAME = ] filter dup empty? not [ nip 1st rdata>> ] [ drop ] From a8cdb2226d7b78e12e02336f619fcef2f26440b3 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 29 May 2008 10:11:54 -0500 Subject: [PATCH 14/20] dns.resolver: another fix --- extra/dns/resolver/resolver.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/dns/resolver/resolver.factor b/extra/dns/resolver/resolver.factor index 7e0f6b4190..38fe59dc41 100644 --- a/extra/dns/resolver/resolver.factor +++ b/extra/dns/resolver/resolver.factor @@ -70,7 +70,7 @@ IN: dns.resolver : name->ip/server ( name -- ip ) canonical/server - dup A IN query boa ask* answer-section>> + dup A IN query boa query->message ask* answer-section>> [ type>> A = ] filter dup empty? not [ nip random rdata>> ] [ 2drop f ] From 5e9b59160845320c60f21e54d80e713fc5be30e0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 29 May 2008 17:32:59 -0500 Subject: [PATCH 15/20] Fix file-responder breakage --- extra/http/server/static/static.factor | 18 ++++++++---------- 1 file changed, 8 insertions(+), 10 deletions(-) diff --git a/extra/http/server/static/static.factor b/extra/http/server/static/static.factor index 0e799fd3ad..8814004589 100755 --- a/extra/http/server/static/static.factor +++ b/extra/http/server/static/static.factor @@ -4,7 +4,7 @@ USING: calendar io io.files kernel math math.order math.parser http http.server namespaces parser sequences strings assocs hashtables debugger http.mime sorting html.elements html.templates.fhtml logging calendar.format accessors -io.encodings.binary fry xml.entities ; +io.encodings.binary fry xml.entities destructors ; IN: http.server.static ! special maps mime types to quots with effect ( path -- ) @@ -29,16 +29,14 @@ TUPLE: file-responder root hook special allow-listings ; swap >>root H{ } clone >>special ; +: (serve-static) ( path mime-type -- response ) + [ [ binary &dispose ] dip ] + [ drop file-info [ size>> ] [ modified>> ] bi ] 2bi + [ "content-length" set-header ] + [ "last-modified" set-header ] bi* ; + : ( root -- responder ) - [ - - swap [ - file-info - [ size>> "content-length" set-header ] - [ modified>> "last-modified" set-header ] bi - ] - [ '[ , binary output-stream get stream-copy ] >>body ] bi - ] ; + [ (serve-static) ] ; : serve-static ( filename mime-type -- response ) over modified-since? From c525d0057d78cc3d23d146648e9293649790f851 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 29 May 2008 17:33:05 -0500 Subject: [PATCH 16/20] Help lint fix --- extra/ui/freetype/freetype-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/ui/freetype/freetype-docs.factor b/extra/ui/freetype/freetype-docs.factor index f463a7c0e7..855df9f564 100755 --- a/extra/ui/freetype/freetype-docs.factor +++ b/extra/ui/freetype/freetype-docs.factor @@ -38,7 +38,7 @@ HELP: render-glyph { $description "Renders a character and outputs a pointer to the bitmap." } ; HELP: -{ $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 } "." } ; HELP: (draw-string) From 4ef0ff1ca15a5b7db3807b3725bc09c247d457c6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 29 May 2008 17:33:11 -0500 Subject: [PATCH 17/20] Remove unnecessary padding --- vm/code_gc.h | 3 --- 1 file changed, 3 deletions(-) diff --git a/vm/code_gc.h b/vm/code_gc.h index 658dc990ae..ecc9f697f5 100644 --- a/vm/code_gc.h +++ b/vm/code_gc.h @@ -17,9 +17,6 @@ typedef struct _F_BLOCK /* Used during compaction */ struct _F_BLOCK *forwarding; - - /* Alignment padding */ - CELL padding[4]; } F_BLOCK; typedef struct { From 727cfcba433477b6b7c2cb34397115106e4899d9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 30 May 2008 01:31:05 -0500 Subject: [PATCH 18/20] Move relocation info out of the code heap and into the data heap --- core/combinators/combinators-docs.factor | 4 ++- core/generator/fixup/fixup-docs.factor | 4 +-- core/generator/fixup/fixup.factor | 32 ++++++++++------------ core/io/binary/binary-docs.factor | 8 +++--- core/io/binary/binary.factor | 4 +-- core/kernel/kernel-docs.factor | 5 +--- vm/callstack.c | 4 +-- vm/code_gc.c | 5 ++-- vm/code_gc.h | 8 ++---- vm/code_heap.c | 31 +++++++++------------ vm/code_heap.h | 5 ++-- vm/data_gc.c | 26 +++++++++--------- vm/debug.c | 7 ++--- vm/image.c | 10 +++---- vm/layouts.h | 2 +- vm/os-unix.c | 8 +++--- vm/os-windows-nt.c | 4 +-- vm/os-windows.c | 4 +-- vm/quotations.c | 35 ++++++++++-------------- vm/types.c | 35 +++++++++++++++++++++--- vm/types.h | 33 +++++++++++++++++----- 21 files changed, 150 insertions(+), 124 deletions(-) diff --git a/core/combinators/combinators-docs.factor b/core/combinators/combinators-docs.factor index 61752ac7d6..c65c01d2ab 100755 --- a/core/combinators/combinators-docs.factor +++ b/core/combinators/combinators-docs.factor @@ -10,8 +10,10 @@ ARTICLE: "combinators-quot" "Quotation construction utilities" { $subsection alist>quot } ; 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 +"A looping combinator:" +{ $subsection while } "Generalization of " { $link bi } " and " { $link tri } ":" { $subsection cleave } "Generalization of " { $link bi* } " and " { $link tri* } ":" diff --git a/core/generator/fixup/fixup-docs.factor b/core/generator/fixup/fixup-docs.factor index f5d530dccb..a0f067fb9e 100644 --- a/core/generator/fixup/fixup-docs.factor +++ b/core/generator/fixup/fixup-docs.factor @@ -1,12 +1,12 @@ USING: help.syntax help.markup generator.fixup math kernel -words strings alien ; +words strings alien byte-array ; HELP: frame-required { $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." } ; HELP: (rel-fixup) -{ $values { "arg" integer } { "class" "a relocation class" } { "type" "a relocation type" } { "offset" integer } { "pair" "a pair of integers" } } +{ $values { "arg" integer } { "class" "a relocation class" } { "type" "a relocation type" } { "offset" integer } { "byte-array" byte-array } } { $description "Creates a relocation instruction for the VM's runtime compiled code linker." } ; HELP: add-literal diff --git a/core/generator/fixup/fixup.factor b/core/generator/fixup/fixup.factor index b38d70fb80..a0961984ed 100755 --- a/core/generator/fixup/fixup.factor +++ b/core/generator/fixup/fixup.factor @@ -1,9 +1,10 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! 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 -quotations strings alien.strings layouts system combinators -math.bitfields words.private cpu.architecture math.order ; +quotations strings alien.accessors alien.strings layouts system +combinators math.bitfields words.private cpu.architecture +math.order accessors growable ; IN: generator.fixup : no-stack-frame -1 ; inline @@ -77,26 +78,23 @@ TUPLE: label-fixup label class ; : label-fixup ( label class -- ) \ label-fixup boa , ; M: label-fixup fixup* - dup label-fixup-class rc-absolute? + dup class>> rc-absolute? [ "Absolute labels not supported" throw ] when - dup label-fixup-label swap label-fixup-class - compiled-offset 4 - rot 3array label-table get push ; + dup label>> swap class>> compiled-offset 4 - rot + 3array label-table get push ; TUPLE: rel-fixup arg class type ; : rel-fixup ( arg class type -- ) \ rel-fixup boa , ; -: (rel-fixup) ( arg class type offset -- pair ) - pick rc-absolute-cell = cell 4 ? - - >r { 0 8 16 } bitfield r> - 2array ; +: push-4 ( value vector -- ) + [ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying ] tri + swap set-alien-unsigned-4 ; M: rel-fixup fixup* - dup rel-fixup-arg - over rel-fixup-class - rot rel-fixup-type - compiled-offset (rel-fixup) - relocation-table get push-all ; + [ [ arg>> ] [ class>> ] [ type>> ] tri { 0 8 16 } bitfield ] + [ class>> rc-absolute-cell = cell 4 ? compiled-offset swap - ] bi + [ relocation-table get push-4 ] bi@ ; M: frame-required fixup* drop ; @@ -134,7 +132,7 @@ SYMBOL: literal-table 0 swap rt-here rel-fixup ; : init-fixup ( -- ) - V{ } clone relocation-table set + BV{ } clone relocation-table set V{ } clone label-table set ; : resolve-labels ( labels -- labels' ) @@ -150,6 +148,6 @@ SYMBOL: literal-table dup stack-frame-size swap [ fixup* ] each drop literal-table get >array - relocation-table get >array + relocation-table get >byte-array label-table get resolve-labels ] { } make ; diff --git a/core/io/binary/binary-docs.factor b/core/io/binary/binary-docs.factor index 507571c044..ab82abe146 100644 --- a/core/io/binary/binary-docs.factor +++ b/core/io/binary/binary-docs.factor @@ -1,8 +1,8 @@ -USING: help.markup help.syntax io math ; +USING: help.markup help.syntax io math byte-arrays ; IN: io.binary 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 "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 @@ -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" } "." } ; 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))" } "." } ; 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))" } "." } ; HELP: mask-byte diff --git a/core/io/binary/binary.factor b/core/io/binary/binary.factor index f2ede93fd5..f3d236433f 100755 --- a/core/io/binary/binary.factor +++ b/core/io/binary/binary.factor @@ -10,8 +10,8 @@ IN: io.binary : nth-byte ( x n -- b ) -8 * shift mask-byte ; inline -: >le ( x n -- str ) [ nth-byte ] with B{ } map-as ; -: >be ( x n -- str ) >le dup reverse-here ; +: >le ( x n -- byte-array ) [ nth-byte ] with B{ } map-as ; +: >be ( x n -- byte-array ) >le dup reverse-here ; : d>w/w ( d -- w1 w2 ) dup HEX: ffffffff bitand diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 96c582a3e5..c39010f228 100755 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -193,10 +193,7 @@ ARTICLE: "implementing-combinators" "Implementing combinators" ": keep ( x quot -- x )" " over >r call r> ; inline" } -"Word inlining is documented in " { $link "declarations" } "." -$nl -"A looping combinator:" -{ $subsection while } ; +"Word inlining is documented in " { $link "declarations" } "." ; 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." diff --git a/vm/callstack.c b/vm/callstack.c index 25219d1569..df4063d149 100755 --- a/vm/callstack.c +++ b/vm/callstack.c @@ -109,9 +109,7 @@ CELL frame_executing(F_STACK_FRAME *frame) { F_COMPILED *compiled = frame_code(frame); CELL code_start = (CELL)(compiled + 1); - CELL literal_start = code_start - + compiled->code_length - + compiled->reloc_length; + CELL literal_start = code_start + compiled->code_length; return get(literal_start); } diff --git a/vm/code_gc.c b/vm/code_gc.c index 141f4abbfe..e0abdc5a61 100755 --- a/vm/code_gc.c +++ b/vm/code_gc.c @@ -257,12 +257,13 @@ void iterate_code_heap(CODE_HEAP_ITERATOR iter) } /* Copy all literals referenced from a code block to newspace */ -void collect_literals_step(F_COMPILED *compiled, CELL code_start, - CELL reloc_start, CELL literals_start) +void collect_literals_step(F_COMPILED *compiled, CELL code_start, CELL literals_start) { CELL scan; CELL literal_end = literals_start + compiled->literals_length; + copy_handle(&compiled->relocation); + for(scan = literals_start; scan < literal_end; scan += CELLS) copy_handle((CELL*)scan); } diff --git a/vm/code_gc.h b/vm/code_gc.h index ecc9f697f5..f93cba9c7a 100644 --- a/vm/code_gc.h +++ b/vm/code_gc.h @@ -44,16 +44,14 @@ INLINE F_BLOCK *next_block(F_HEAP *heap, F_BLOCK *block) /* compiled code */ F_HEAP code_heap; -typedef void (*CODE_HEAP_ITERATOR)(F_COMPILED *compiled, CELL code_start, - CELL reloc_start, CELL literals_start); +typedef void (*CODE_HEAP_ITERATOR)(F_COMPILED *compiled, CELL code_start, CELL literals_start); INLINE void iterate_code_heap_step(F_COMPILED *compiled, CODE_HEAP_ITERATOR iter) { CELL code_start = (CELL)(compiled + 1); - CELL reloc_start = code_start + compiled->code_length; - CELL literals_start = reloc_start + compiled->reloc_length; + CELL literals_start = code_start + compiled->code_length; - iter(compiled,code_start,reloc_start,literals_start); + iter(compiled,code_start,literals_start); } INLINE F_BLOCK *compiled_to_block(F_COMPILED *compiled) diff --git a/vm/code_heap.c b/vm/code_heap.c index 92915e49d1..69ffdeb2aa 100755 --- a/vm/code_heap.c +++ b/vm/code_heap.c @@ -139,13 +139,14 @@ void apply_relocation(CELL class, CELL offset, F_FIXNUM absolute_value) } /* Perform all fixups on a code block */ -void relocate_code_block(F_COMPILED *relocating, CELL code_start, - CELL reloc_start, CELL literals_start) +void relocate_code_block(F_COMPILED *compiled, CELL code_start, CELL literals_start) { - if(reloc_start != literals_start) + if(compiled->relocation != F) { - F_REL *rel = (F_REL *)reloc_start; - F_REL *rel_end = (F_REL *)literals_start; + F_BYTE_ARRAY *relocation = untag_object(compiled->relocation); + + F_REL *rel = (F_REL *)(relocation + 1); + F_REL *rel_end = (F_REL *)((char *)rel + byte_array_capacity(relocation)); 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 */ @@ -249,34 +250,32 @@ F_COMPILED *add_compiled_block( CELL type, F_ARRAY *code, F_ARRAY *labels, - F_ARRAY *relocation, + CELL relocation, F_ARRAY *literals) { CELL code_format = compiled_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; + REGISTER_ROOT(relocation); REGISTER_UNTAGGED(code); REGISTER_UNTAGGED(labels); - REGISTER_UNTAGGED(relocation); REGISTER_UNTAGGED(literals); - CELL here = allot_code_block(sizeof(F_COMPILED) + code_length - + rel_length + literals_length); + CELL here = allot_code_block(sizeof(F_COMPILED) + code_length + literals_length); UNREGISTER_UNTAGGED(literals); - UNREGISTER_UNTAGGED(relocation); UNREGISTER_UNTAGGED(labels); UNREGISTER_UNTAGGED(code); + UNREGISTER_ROOT(relocation); /* compiled header */ F_COMPILED *header = (void *)here; header->type = type; header->code_length = code_length; - header->reloc_length = rel_length; header->literals_length = literals_length; + header->relocation = relocation; here += sizeof(F_COMPILED); @@ -286,10 +285,6 @@ F_COMPILED *add_compiled_block( deposit_integers(here,code,code_format); here += code_length; - /* relation info */ - deposit_integers(here,relocation,sizeof(unsigned int)); - here += rel_length; - /* literals */ deposit_objects(here,literals); here += literals_length; @@ -353,7 +348,7 @@ DEFINE_PRIMITIVE(modify_code_heap) F_ARRAY *compiled_code = untag_array(data); 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 *code = untag_array(array_nth(compiled_code,3)); diff --git a/vm/code_heap.h b/vm/code_heap.h index 4e65313d3b..80605b1d28 100755 --- a/vm/code_heap.h +++ b/vm/code_heap.h @@ -53,8 +53,7 @@ typedef struct { unsigned int offset; } F_REL; -void relocate_code_block(F_COMPILED *relocating, CELL code_start, - CELL reloc_start, CELL literals_start); +void relocate_code_block(F_COMPILED *relocating, CELL code_start, CELL literals_start); void default_word_code(F_WORD *word, bool relocate); @@ -64,7 +63,7 @@ F_COMPILED *add_compiled_block( CELL type, F_ARRAY *code, F_ARRAY *labels, - F_ARRAY *rel, + CELL relocation, F_ARRAY *literals); CELL compiled_code_format(void); diff --git a/vm/data_gc.c b/vm/data_gc.c index a52f2490e9..54ad1168a0 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -930,22 +930,22 @@ DEFINE_PRIMITIVE(gc_stats) for(i = 0; i < MAX_GEN_COUNT; i++) { F_GC_STATS *s = &gc_stats[i]; - GROWABLE_ADD(stats,allot_cell(s->collections)); - GROWABLE_ADD(stats,allot_cell(s->gc_time)); - GROWABLE_ADD(stats,allot_cell(s->max_gc_time)); - GROWABLE_ADD(stats,allot_cell(s->collections == 0 ? 0 : s->gc_time / s->collections)); - GROWABLE_ADD(stats,allot_cell(s->object_count)); - GROWABLE_ADD(stats,tag_bignum(long_long_to_bignum(s->bytes_copied))); + GROWABLE_ARRAY_ADD(stats,allot_cell(s->collections)); + GROWABLE_ARRAY_ADD(stats,allot_cell(s->gc_time)); + GROWABLE_ARRAY_ADD(stats,allot_cell(s->max_gc_time)); + GROWABLE_ARRAY_ADD(stats,allot_cell(s->collections == 0 ? 0 : s->gc_time / s->collections)); + GROWABLE_ARRAY_ADD(stats,allot_cell(s->object_count)); + GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(s->bytes_copied))); total_gc_time += s->gc_time; } - GROWABLE_ADD(stats,allot_cell(total_gc_time)); - GROWABLE_ADD(stats,tag_bignum(long_long_to_bignum(cards_scanned))); - GROWABLE_ADD(stats,tag_bignum(long_long_to_bignum(decks_scanned))); - GROWABLE_ADD(stats,allot_cell(code_heap_scans)); + GROWABLE_ARRAY_ADD(stats,allot_cell(total_gc_time)); + GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(cards_scanned))); + GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(decks_scanned))); + GROWABLE_ARRAY_ADD(stats,allot_cell(code_heap_scans)); - GROWABLE_TRIM(stats); + GROWABLE_ARRAY_TRIM(stats); dpush(stats); } @@ -986,13 +986,13 @@ CELL find_all_words(void) while((obj = next_object()) != F) { if(type_of(obj) == WORD_TYPE) - GROWABLE_ADD(words,obj); + GROWABLE_ARRAY_ADD(words,obj); } /* End heap scan */ gc_off = false; - GROWABLE_TRIM(words); + GROWABLE_ARRAY_TRIM(words); return words; } diff --git a/vm/debug.c b/vm/debug.c index b86ec808bc..0278426895 100755 --- a/vm/debug.c +++ b/vm/debug.c @@ -296,8 +296,7 @@ void find_data_references(CELL look_for_) CELL look_for; -void find_code_references_step(F_COMPILED *compiled, CELL code_start, - CELL reloc_start, CELL literals_start) +void find_code_references_step(F_COMPILED *compiled, CELL code_start, CELL literals_start) { CELL scan; 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) { CELL code_start = (CELL)(compiled + 1); - CELL literal_start = code_start - + compiled->code_length - + compiled->reloc_length; + CELL literal_start = code_start + compiled->code_length; CELL obj = get(literal_start); diff --git a/vm/image.c b/vm/image.c index 653891fdfe..141594f01f 100755 --- a/vm/image.c +++ b/vm/image.c @@ -288,18 +288,18 @@ void relocate_data() } } -void fixup_code_block(F_COMPILED *relocating, CELL code_start, - CELL reloc_start, CELL literals_start) +void fixup_code_block(F_COMPILED *compiled, CELL code_start, CELL literals_start) { /* relocate literal table data */ 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) data_fixup((CELL*)scan); - if(reloc_start != literals_start) - relocate_code_block(relocating,code_start,reloc_start,literals_start); + relocate_code_block(compiled,code_start,literals_start); } void relocate_code() diff --git a/vm/layouts.h b/vm/layouts.h index 89af0a306c..1aee94357b 100755 --- a/vm/layouts.h +++ b/vm/layouts.h @@ -113,8 +113,8 @@ typedef struct { CELL type; /* this is WORD_TYPE or QUOTATION_TYPE */ CELL code_length; /* # bytes */ - CELL reloc_length; /* # bytes */ CELL literals_length; /* # bytes */ + CELL relocation; /* tagged pointer to byte-array or f */ } F_COMPILED; /* Assembly code makes assumptions about the layout of this struct */ diff --git a/vm/os-unix.c b/vm/os-unix.c index 6363ce68a9..1f63ea7ab1 100755 --- a/vm/os-unix.c +++ b/vm/os-unix.c @@ -73,14 +73,14 @@ DEFINE_PRIMITIVE(read_dir) while((file = readdir(dir)) != NULL) { CELL pair = parse_dir_entry(file); - GROWABLE_ADD(result,pair); + GROWABLE_ARRAY_ADD(result,pair); } closedir(dir); } UNREGISTER_ROOT(result); - GROWABLE_TRIM(result); + GROWABLE_ARRAY_TRIM(result); dpush(result); } @@ -104,12 +104,12 @@ DEFINE_PRIMITIVE(os_envs) while(*env) { CELL string = tag_object(from_char_string(*env)); - GROWABLE_ADD(result,string); + GROWABLE_ARRAY_ADD(result,string); env++; } UNREGISTER_ROOT(result); - GROWABLE_TRIM(result); + GROWABLE_ARRAY_TRIM(result); dpush(result); } diff --git a/vm/os-windows-nt.c b/vm/os-windows-nt.c index cc7b128941..4f5778d0c4 100755 --- a/vm/os-windows-nt.c +++ b/vm/os-windows-nt.c @@ -25,7 +25,7 @@ DEFINE_PRIMITIVE(os_envs) break; CELL string = tag_object(from_u16_string(finger)); - GROWABLE_ADD(result,string); + GROWABLE_ARRAY_ADD(result,string); finger = scan + 1; } @@ -33,7 +33,7 @@ DEFINE_PRIMITIVE(os_envs) FreeEnvironmentStrings(env); UNREGISTER_ROOT(result); - GROWABLE_TRIM(result); + GROWABLE_ARRAY_TRIM(result); dpush(result); } diff --git a/vm/os-windows.c b/vm/os-windows.c index 59c14d98f5..dc931d31c8 100755 --- a/vm/os-windows.c +++ b/vm/os-windows.c @@ -152,14 +152,14 @@ DEFINE_PRIMITIVE(read_dir) CELL name = tag_object(from_u16_string(find_data.cFileName)); CELL dirp = tag_boolean(find_data.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY); CELL pair = allot_array_2(name,dirp); - GROWABLE_ADD(result,pair); + GROWABLE_ARRAY_ADD(result,pair); } while (FindNextFile(dir, &find_data)); FindClose(dir); } UNREGISTER_ROOT(result); - GROWABLE_TRIM(result); + GROWABLE_ARRAY_TRIM(result); dpush(result); } diff --git a/vm/quotations.c b/vm/quotations.c index c3b50dbd47..e092aab4bf 100755 --- a/vm/quotations.c +++ b/vm/quotations.c @@ -60,14 +60,9 @@ F_REL rel_to_emit(CELL name, CELL code_format, CELL code_length, #define EMIT(name,rel_argument) { \ bool rel_p; \ - F_REL rel = rel_to_emit(name,code_format,code_count, \ - rel_argument,&rel_p); \ - if(rel_p) \ - { \ - GROWABLE_ADD(relocation,allot_cell(rel.type)); \ - GROWABLE_ADD(relocation,allot_cell(rel.offset)); \ - } \ - GROWABLE_APPEND(code,code_to_emit(name)); \ + F_REL rel = rel_to_emit(name,code_format,code_count,rel_argument,&rel_p); \ + if(rel_p) GROWABLE_BYTE_ARRAY_APPEND(relocation,&rel,sizeof(F_REL)); \ + GROWABLE_ARRAY_APPEND(code,code_to_emit(name)); \ } bool jit_stack_frame_p(F_ARRAY *array) @@ -110,13 +105,13 @@ void jit_compile(CELL quot, bool relocate) GROWABLE_ARRAY(code); REGISTER_ROOT(code); - GROWABLE_ARRAY(relocation); + GROWABLE_BYTE_ARRAY(relocation); REGISTER_ROOT(relocation); GROWABLE_ARRAY(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)); @@ -141,7 +136,7 @@ void jit_compile(CELL quot, bool relocate) current stack frame. */ 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) { @@ -157,7 +152,7 @@ void jit_compile(CELL quot, bool relocate) break; case WRAPPER_TYPE: wrapper = untag_object(obj); - GROWABLE_ADD(literals,wrapper->object); + GROWABLE_ARRAY_ADD(literals,wrapper->object); EMIT(JIT_PUSH_LITERAL,literals_count - 1); break; case FIXNUM_TYPE: @@ -176,8 +171,8 @@ void jit_compile(CELL quot, bool relocate) if(stack_frame) EMIT(JIT_EPILOG,0); - GROWABLE_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)); + GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i + 1)); EMIT(JIT_IF_JUMP,literals_count - 2); i += 2; @@ -191,7 +186,7 @@ void jit_compile(CELL quot, bool relocate) if(stack_frame) 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); i++; @@ -200,7 +195,7 @@ void jit_compile(CELL quot, bool relocate) break; } default: - GROWABLE_ADD(literals,obj); + GROWABLE_ARRAY_ADD(literals,obj); EMIT(JIT_PUSH_LITERAL,literals_count - 1); break; } @@ -214,15 +209,15 @@ void jit_compile(CELL quot, bool relocate) EMIT(JIT_RETURN,0); } - GROWABLE_TRIM(code); - GROWABLE_TRIM(relocation); - GROWABLE_TRIM(literals); + GROWABLE_ARRAY_TRIM(code); + GROWABLE_ARRAY_TRIM(literals); + GROWABLE_BYTE_ARRAY_TRIM(relocation); F_COMPILED *compiled = add_compiled_block( QUOTATION_TYPE, untag_object(code), NULL, - untag_object(relocation), + relocation, untag_object(literals)); set_quot_xt(untag_object(quot),compiled); diff --git a/vm/types.c b/vm/types.c index b4e5269f4e..adfdea41a5 100755 --- a/vm/types.c +++ b/vm/types.c @@ -197,7 +197,7 @@ DEFINE_PRIMITIVE(resize_array) 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); @@ -209,12 +209,12 @@ F_ARRAY *growable_add(F_ARRAY *result, CELL elt, CELL *result_count) UNREGISTER_ROOT(elt); set_array_nth(result,*result_count,elt); - *result_count = *result_count + 1; + (*result_count)++; 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); @@ -228,7 +228,7 @@ F_ARRAY *growable_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_count) 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; @@ -283,6 +283,33 @@ DEFINE_PRIMITIVE(resize_byte_array) 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 */ /* size is in bits */ diff --git a/vm/types.h b/vm/types.h index 3ce1838b8b..bbf7fb203d 100755 --- a/vm/types.h +++ b/vm/types.h @@ -146,6 +146,7 @@ DECLARE_PRIMITIVE(float_array); DECLARE_PRIMITIVE(clone); 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_byte_array); DECLARE_PRIMITIVE(resize_bit_array); @@ -193,15 +194,33 @@ DECLARE_PRIMITIVE(wrapper); CELL result##_count = 0; \ 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) \ - result = tag_object(growable_add(untag_object(result),elt,&result##_count)) +#define GROWABLE_ARRAY_ADD(result,elt) \ + 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) \ - result = tag_object(growable_append(untag_object(result),elts,&result##_count)) +#define GROWABLE_ARRAY_APPEND(result,elts) \ + 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)) + +/* 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)) From a0e71b0f86e6a6e0199ef390e7a80efa73bc2f03 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 30 May 2008 01:47:58 -0500 Subject: [PATCH 19/20] Doc fix --- core/generator/fixup/fixup-docs.factor | 4 ---- 1 file changed, 4 deletions(-) diff --git a/core/generator/fixup/fixup-docs.factor b/core/generator/fixup/fixup-docs.factor index a0f067fb9e..58bc32397f 100644 --- a/core/generator/fixup/fixup-docs.factor +++ b/core/generator/fixup/fixup-docs.factor @@ -5,10 +5,6 @@ HELP: frame-required { $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." } ; -HELP: (rel-fixup) -{ $values { "arg" integer } { "class" "a relocation class" } { "type" "a relocation type" } { "offset" integer } { "byte-array" byte-array } } -{ $description "Creates a relocation instruction for the VM's runtime compiled code linker." } ; - HELP: add-literal { $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 } "." } ; From 548c4d0b2c252f8c4c424c41983185fa3496d776 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 30 May 2008 07:31:20 -0500 Subject: [PATCH 20/20] Add dns.forwarding --- extra/dns/forwarding/forwarding.factor | 91 ++++++++++++++++++++++++++ 1 file changed, 91 insertions(+) create mode 100644 extra/dns/forwarding/forwarding.factor diff --git a/extra/dns/forwarding/forwarding.factor b/extra/dns/forwarding/forwarding.factor new file mode 100644 index 0000000000..5da04e25b6 --- /dev/null +++ b/extra/dns/forwarding/forwarding.factor @@ -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 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 ; \ No newline at end of file