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

core/alien/compiler/compiler.factor

@@ -7,7 +7,7 @@ math.parser classes alien.arrays alien.c-types alien.strings
 alien.structs alien.syntax cpu.architecture alien inspector
 quotations assocs kernel.private threads continuations.private
 libc combinators compiler.errors continuations layouts accessors
-;
+init ;
 IN: alien.compiler
 
 TUPLE: #alien-node < node return parameters abi ;
@@ -336,7 +336,7 @@ M: #alien-indirect generate-node
 ! this hashtable, they will all be blown away by code GC, beware
 SYMBOL: callbacks
 
-callbacks global [ H{ } assoc-like ] change-at
+[ H{ } clone callbacks set-global ] "alien.compiler" add-init-hook
 
 : register-callback ( word -- ) dup callbacks get set-at ;
 
@@ -344,7 +344,7 @@ M: alien-callback-error summary
     drop "Words calling ``alien-callback'' must be compiled with the optimizing compiler." ;
 
 : callback-bottom ( node -- )
-    xt>> [ word-xt drop <alien> ] curry
+    xt>> [ [ register-callback ] [ word-xt drop <alien> ] bi ] curry
     recursive-state get infer-quot ;
 
 \ alien-callback [
@@ -354,7 +354,7 @@ M: alien-callback-error summary
     pop-literal nip >>abi
     pop-parameters >>parameters
     pop-literal nip >>return
-    gensym dup register-callback >>xt
+    gensym >>xt
     callback-bottom
 ] "infer" set-word-prop
 

core/alien/structs/structs-docs.factor

@@ -91,6 +91,6 @@ $nl
 ARTICLE: "c-unions" "C unions"
 "A " { $snippet "union" } " in C defines a type large enough to hold its largest member. This is usually used to allocate a block of memory which can hold one of several types of values."
 { $subsection POSTPONE: C-UNION: }
-"C structure objects can be allocated by calling " { $link <c-object> } " or " { $link malloc-object } "."
+"C union objects can be allocated by calling " { $link <c-object> } " or " { $link malloc-object } "."
 $nl
 "Arrays of C unions can be created by calling " { $link <c-array> } " or " { $link malloc-array } ". Elements can be read and written using words named " { $snippet { $emphasis "type" } "-nth" } " and " { $snippet "set-" { $emphasis "type" } "-nth" } "; these words are automatically generated by " { $link POSTPONE: C-UNION: } "." ;

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* } ":"

core/generator/fixup/fixup-docs.factor

@@ -1,14 +1,11 @@
-USING: help.syntax help.markup generator.fixup math kernel
+USING: help.syntax help.markup math kernel
 words strings alien ;
+IN: generator.fixup
 
 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" } }
-{ $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 } "." } ;

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
+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
 
 : 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
+    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 ;
 
 : 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*
-    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 ;
 
@@ -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 ;

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

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 ;
+: >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 )
     dup HEX: ffffffff bitand

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" } "."
+"Word inlining is documented in " { $link "declarations" } "." ;
-$nl
-"A looping combinator:"
-{ $subsection while } ;
 
 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."

extra/bunny/model/model.factor

@@ -35,10 +35,8 @@ IN: bunny.model
     [ normalize ] map ;
 
 : read-model ( stream -- model )
-    "Reading model" print flush [
     ascii [ parse-model ] with-file-reader
-        [ normals ] 2keep 3array
+    [ normals ] 2keep 3array ;
-    ] time ;
 
 : model-path "bun_zipper.ply" temp-file ;
 

extra/cairo/gadgets/gadgets.factor

@@ -1,73 +1,39 @@
 ! Copyright (C) 2008 Matthew Willis.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: cairo cairo.ffi ui.render kernel opengl.gl opengl
+USING: sequences math opengl.gadgets kernel
-math byte-arrays ui.gadgets accessors arrays 
+byte-arrays cairo.ffi cairo io.backend
-namespaces io.backend ;
+opengl.gl arrays ;
 
 IN: cairo.gadgets
 
-! We need two kinds of gadgets:
-! one performs the cairo ops once and caches the bytes, the other
-! performs cairo ops every refresh
-
-TUPLE: cairo-gadget width height quot cache? bytes ;
-PREDICATE: cached-cairo < cairo-gadget cache?>> ;
-: <cairo-gadget> ( width height quot -- cairo-gadget )
-    cairo-gadget construct-gadget 
-    swap >>quot
-    swap >>height
-    swap >>width ;
-
-: <cached-cairo> ( width height quot -- cairo-gadget )
-    <cairo-gadget> t >>cache? ;
-
 : width>stride ( width -- stride ) 4 * ;
     
-: copy-cairo ( width height quot -- byte-array )
+: copy-cairo ( dim quot -- byte-array )
-    >r over width>stride
+    >r first2 over width>stride
     [ * nip <byte-array> dup CAIRO_FORMAT_ARGB32 ]
     [ cairo_image_surface_create_for_data ] 3bi
     r> with-cairo-from-surface ;
 
-: (cairo>bytes) ( gadget -- byte-array )
+: <cairo-gadget> ( dim quot -- )
-    [ width>> ] [ height>> ] [ quot>> ] tri copy-cairo ;
+    over 2^-bounds swap copy-cairo
+    GL_BGRA rot <texture-gadget> ;
 
-GENERIC: cairo>bytes
+! maybe also texture>png
-M: cairo-gadget cairo>bytes ( gadget -- byte-array )
+! : cairo>png ( gadget path -- )
-    (cairo>bytes) ;
+!    >r [ cairo>bytes CAIRO_FORMAT_ARGB32 ] [ width>> ]
-
+!    [ height>> ] tri over width>stride
-M: cached-cairo cairo>bytes ( gadget -- byte-array )
+!    cairo_image_surface_create_for_data
-    dup bytes>> [ ] [
+!    r> [ cairo_surface_write_to_png check-cairo ] curry with-surface ;
-        dup (cairo>bytes) [ >>bytes drop ] keep
-    ] ?if ;
-
-: cairo>png ( gadget path -- )
-    >r [ cairo>bytes CAIRO_FORMAT_ARGB32 ] [ width>> ]
-    [ height>> ] tri over width>stride
-    cairo_image_surface_create_for_data
-    r> [ cairo_surface_write_to_png check-cairo ] curry with-surface ;
-
-M: cairo-gadget draw-gadget* ( gadget -- )
-    origin get [
-        0 0 glRasterPos2i
-        1.0 -1.0 glPixelZoom
-        [ width>> ] [ height>> GL_BGRA GL_UNSIGNED_BYTE ]
-        [ cairo>bytes ] tri glDrawPixels
-    ] with-translation ;
-    
-M: cairo-gadget pref-dim* ( gadget -- rect )
-    [ width>> ] [ height>> ] bi 2array ;
 
 : copy-surface ( surface -- )
     cr swap 0 0 cairo_set_source_surface
     cr cairo_paint ;
 
-: <bytes-gadget> ( width height bytes -- cairo-gadget )
-    >r [ ] <cached-cairo> r> >>bytes ;
-
 : <png-gadget> ( path -- gadget )
     normalize-path cairo_image_surface_create_from_png
     [ cairo_image_surface_get_width ]
-    [ cairo_image_surface_get_height 2dup ]
+    [ cairo_image_surface_get_height 2array dup 2^-bounds ]
     [ [ copy-surface ] curry copy-cairo ] tri
-    <bytes-gadget> ;
+    GL_BGRA rot <texture-gadget> ;
+
+

extra/cairo/pango/gadgets/gadgets.factor

@@ -1,20 +0,0 @@
-USING: cairo.pango cairo cairo.ffi cairo.gadgets
-alien.c-types kernel math ;
-IN: cairo.pango.gadgets
-
-: (pango-gadget) ( setup show -- gadget )
-    [ drop layout-size ]
-    [ compose [ with-pango ] curry <cached-cairo> ] 2bi ;
-
-: <pango-gadget> ( quot -- gadget )
-    [ cr layout pango_cairo_show_layout ] (pango-gadget) ;
-
-USING: prettyprint sequences ui.gadgets.panes ;
-: hello-pango ( -- )
-    50 [ 6 + ] map [
-        "Sans Bold " swap unparse append
-        [ layout-font "Hello, Pango!" layout-text ] curry
-        <pango-gadget> gadget.
-    ] each ;
-
-MAIN: hello-pango

extra/cairo/samples/samples.factor

@@ -142,6 +142,6 @@ IN: cairo.samples
  USING: quotations cairo.gadgets ui.gadgets.panes sequences ;
  : samples ( -- )
     { arc clip clip-image dash gradient text utf8 }
-    [ 256 256 rot 1quotation <cached-cairo> gadget. ] each ;
+    [ { 256 256 } swap 1quotation <cairo-gadget> gadget. ] each ;
  
  MAIN: samples

extra/db/db.factor

@@ -39,31 +39,13 @@ TUPLE: statement handle sql in-params out-params bind-params bound? type ;
 TUPLE: simple-statement < statement ;
 TUPLE: prepared-statement < statement ;
 
-SINGLETON: throwable
-SINGLETON: nonthrowable
-
-: make-throwable ( obj -- obj' )
-    dup sequence? [
-        [ make-throwable ] map
-    ] [
-        throwable >>type
-    ] if ;
-
-: make-nonthrowable ( obj -- obj' )
-    dup sequence? [
-        [ make-nonthrowable ] map
-    ] [
-        nonthrowable >>type
-    ] if ;
-
 TUPLE: result-set sql in-params out-params handle n max ;
 
 : construct-statement ( sql in out class -- statement )
     new
         swap >>out-params
         swap >>in-params
-        swap >>sql
+        swap >>sql ;
-        throwable >>type ;
 
 HOOK: <simple-statement> db ( str in out -- statement )
 HOOK: <prepared-statement> db ( str in out -- statement )
@@ -81,12 +63,9 @@ GENERIC: more-rows? ( result-set -- ? )
 
 GENERIC: execute-statement* ( statement type -- )
 
-M: throwable execute-statement* ( statement type -- )
+M: object execute-statement* ( statement type -- )
     drop query-results dispose ;
 
-M: nonthrowable execute-statement* ( statement type -- )
-    drop [ query-results dispose ] [ 2drop ] recover ;
-
 : execute-statement ( statement -- )
     dup sequence? [
         [ execute-statement ] each

extra/db/errors/errors.factor

@@ -0,0 +1,11 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel ;
+IN: db.errors
+
+ERROR: db-error ;
+ERROR: sql-error ;
+
+
+ERROR: table-exists ;
+ERROR: bad-schema ;

extra/db/postgresql/postgresql.factor

@@ -175,7 +175,7 @@ M: postgresql-db create-sql-statement ( class -- seq )
 
 : drop-table-sql ( table -- statement )
     [
-        "drop table " 0% 0% ";" 0% drop
+        "drop table " 0% 0% drop
     ] query-make ;
 
 M: postgresql-db drop-sql-statement ( class -- seq )

extra/db/queries/queries.factor

@@ -1,21 +1,19 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel math namespaces sequences random
-strings
+strings math.parser math.intervals combinators
-math.bitfields.lib namespaces.lib db db.tuples db.types
+math.bitfields.lib namespaces.lib db db.tuples db.types ;
-math.intervals ;
 IN: db.queries
 
 GENERIC: where ( specs obj -- )
 
 : maybe-make-retryable ( statement -- statement )
-    dup in-params>> [ generator-bind? ] contains? [
+    dup in-params>> [ generator-bind? ] contains?
-        make-retryable
+    [ make-retryable ] when ;
-    ] when ;
 
 : query-make ( class quot -- )
     >r sql-props r>
-    [ 0 sql-counter rot with-variable ";" 0% ] { "" { } { } } nmake
+    [ 0 sql-counter rot with-variable ] { "" { } { } } nmake
     <simple-statement> maybe-make-retryable ; inline
 
 M: db begin-transaction ( -- ) "BEGIN" sql-command ;
@@ -127,3 +125,36 @@ M: db <select-by-slots-statement> ( tuple class -- statement )
         " from " 0% 0%
         where-clause
     ] query-make ;
+
+: do-group ( tuple groups -- )
+    [
+        ", " join " group by " prepend append
+    ] curry change-sql drop ;
+
+: do-order ( tuple order -- )
+    [
+        ", " join " order by " prepend append
+    ] curry change-sql drop ;
+
+: do-offset ( tuple n -- )
+    [
+        number>string " offset " prepend append
+    ] curry change-sql drop ;
+
+: do-limit ( tuple n -- )
+    [
+        number>string " limit " prepend append
+    ] curry change-sql drop ;
+
+: make-advanced-statement ( tuple advanced -- tuple' )
+    dupd
+    {
+        [ group>> [ do-group ] [ drop ] if* ]
+        [ order>> [ do-order ] [ drop ] if* ]
+        [ limit>> [ do-limit ] [ drop ] if* ]
+        [ offset>> [ do-offset ] [ drop ] if* ]
+    } 2cleave ;
+
+M: db <advanced-select-statement> ( tuple class group order limit offset -- tuple )
+    advanced-statement boa
+    [ <select-by-slots-statement> ] dip make-advanced-statement ;

extra/db/sql/sql-tests.factor

@@ -4,9 +4,11 @@ IN: db.sql.tests
 ! TUPLE: person name age ;
 : insert-1
     { insert
+        {
             { table "person" }
             { columns "name" "age" }
             { values "erg" 26 }
+        }
     } ;
 
 : update-1

extra/db/sqlite/lib/lib.factor

@@ -4,24 +4,25 @@ USING: alien.c-types arrays assocs kernel math math.parser
 namespaces sequences db.sqlite.ffi db combinators
 continuations db.types calendar.format serialize
 io.streams.byte-array byte-arrays io.encodings.binary
-io.backend ;
+io.backend db.errors ;
 IN: db.sqlite.lib
 
-: sqlite-error ( n -- * )
+ERROR: sqlite-error < db-error n string ;
-    sqlite-error-messages nth throw ;
+ERROR: sqlite-sql-error < sql-error n string ;
 
-: sqlite-statement-error-string ( -- str )
+: throw-sqlite-error ( n -- * )
-    db get db-handle sqlite3_errmsg ;
+    dup sqlite-error-messages nth sqlite-error ;
 
 : sqlite-statement-error ( -- * )
-    sqlite-statement-error-string throw ;
+    SQLITE_ERROR
+    db get db-handle sqlite3_errmsg sqlite-sql-error ;
 
 : sqlite-check-result ( n -- )
     {
-        { [ dup SQLITE_OK = ] [ drop ] }
+        { SQLITE_OK [ ] }
-        { [ dup SQLITE_ERROR = ] [ sqlite-statement-error ] }
+        { SQLITE_ERROR [ sqlite-statement-error ] }
-        [ sqlite-error ]
+        [ throw-sqlite-error ]
-    } cond ;
+    } case ;
 
 : sqlite-open ( path -- db )
     normalize-path
@@ -158,12 +159,11 @@ IN: db.sqlite.lib
     dup sqlite-#columns [ sqlite-column ] with map ;
 
 : sqlite-step-has-more-rows? ( prepared -- bool )
-    dup SQLITE_ROW =  [
+    {
-        drop t
+        { SQLITE_ROW [ t ] }
-    ] [
+        { SQLITE_DONE [ f ] }
-        dup SQLITE_DONE =
+        [ sqlite-check-result f ]
-        [ drop ] [ sqlite-check-result ] if f
+    } case ;
-    ] if ;
 
 : sqlite-next ( prepared -- ? )
     sqlite3_step sqlite-step-has-more-rows? ;

extra/db/sqlite/sqlite.factor

@@ -16,7 +16,7 @@ M: sqlite-db make-db* ( path db -- db )
     swap >>path ;
 
 M: sqlite-db db-open ( db -- db )
-    [ path>> sqlite-open ] [ swap >>handle ] bi ;
+    dup path>> sqlite-open >>handle ;
 
 M: sqlite-db db-close ( handle -- ) sqlite-close ;
 M: sqlite-db dispose ( db -- ) dispose-db ;
@@ -197,4 +197,3 @@ M: sqlite-db compound ( str seq -- str' )
         { "default" [ first number>string join-space ] }
         [ 2drop ] 
     } case ;
-

extra/db/tuples/tuples-tests.factor

@@ -3,7 +3,8 @@
 USING: io.files kernel tools.test db db.tuples classes
 db.types continuations namespaces math math.ranges
 prettyprint calendar sequences db.sqlite math.intervals
-db.postgresql accessors random math.bitfields.lib ;
+db.postgresql accessors random math.bitfields.lib
+math.ranges strings sequences.lib ;
 IN: db.tuples.tests
 
 TUPLE: person the-id the-name the-number the-real
@@ -198,7 +199,7 @@ TUPLE: annotation n paste-id summary author mode contents ;
 : test-sqlite ( quot -- )
     >r "tuples-test.db" temp-file sqlite-db r> with-db ;
 
-: test-postgresql ( -- )
+: test-postgresql ( quot -- )
     >r { "localhost" "postgres" "foob" "factor-test" } postgresql-db r> with-db ;
 
 : test-repeated-insert
@@ -224,6 +225,12 @@ TUPLE: serialize-me id data ;
 
 TUPLE: exam id name score ; 
 
+: random-exam ( -- exam )
+        f
+        6 [ CHAR: a CHAR: b [a,b] random ] replicate >string
+        100 random
+    exam boa ;
+
 : test-intervals ( -- )
     exam "EXAM"
     {
@@ -415,7 +422,7 @@ TUPLE: does-not-persist ;
 ] test-postgresql
 
 
-TUPLE: suparclass a ;
+TUPLE: suparclass id a ;
 
 suparclass f {
     { "id" "ID" +db-assigned-id+ }
@@ -428,8 +435,26 @@ subbclass "SUBCLASS" {
     { "b" "B" TEXT }
 } define-persistent
 
+TUPLE: fubbclass < subbclass ;
+
+fubbclass "FUBCLASS" { } define-persistent
+
 : test-db-inheritance ( -- )
-    [ ] [ subbclass ensure-table ] unit-test ;
+    [ ] [ subbclass ensure-table ] unit-test
+    [ ] [ fubbclass ensure-table ] unit-test
+    
+    [ ] [
+        subbclass new 5 >>a "hi" >>b dup insert-tuple id>> "id" set
+    ] unit-test
+    
+    [ t "hi" 5 ] [
+        subbclass new "id" get >>id select-tuple
+        [ subbclass? ] [ b>> ] [ a>> ] tri
+    ] unit-test
+    
+    [ ] [ fubbclass new 0 >>a "hi" >>b insert-tuple ] unit-test
+    
+    [ t ] [ fubbclass new select-tuples [ fubbclass? ] all? ] unit-test ;
 
 [ test-db-inheritance ] test-sqlite
 

extra/db/tuples/tuples.factor

@@ -13,10 +13,10 @@ IN: db.tuples
     "db-columns" set-word-prop
     "db-relations" set-word-prop ;
 
-ERROR: not-persistent ;
+ERROR: not-persistent class ;
 
 : db-table ( class -- obj )
-    "db-table" word-prop [ not-persistent ] unless* ;
+    dup "db-table" word-prop [ ] [ not-persistent ] ?if ;
 
 : db-columns ( class -- obj )
     superclasses [ "db-columns" word-prop ] map concat ;
@@ -42,6 +42,8 @@ HOOK: <insert-user-assigned-statement> db ( class -- obj )
 HOOK: <update-tuple-statement> db ( class -- obj )
 HOOK: <delete-tuples-statement> db ( tuple class -- obj )
 HOOK: <select-by-slots-statement> db ( tuple class -- tuple )
+TUPLE: advanced-statement group order offset limit ;
+HOOK: <advanced-select-statement> db ( tuple class group order offset limit -- tuple )
 
 HOOK: insert-tuple* db ( tuple statement -- )
 
@@ -74,16 +76,16 @@ M: retryable execute-statement* ( statement type -- )
         [ regenerate-params bind-statement* f ] cleanup
     ] curry 10 retry drop ;
 
-: resulting-tuple ( row out-params -- tuple )
+: resulting-tuple ( class row out-params -- tuple )
-    dup first class>> new [
+    rot class new [
         [
             >r slot-name>> r> set-slot-named
         ] curry 2each
     ] keep ;
 
-: query-tuples ( statement -- seq )
+: query-tuples ( exemplar-tuple statement -- seq )
     [ out-params>> ] keep query-results [
-        [ sql-row-typed swap resulting-tuple ] with query-map
+        [ sql-row-typed swap resulting-tuple ] with with query-map
     ] with-disposal ;
  
 : query-modify-tuple ( tuple statement -- )
@@ -110,8 +112,8 @@ M: retryable execute-statement* ( statement type -- )
 
 : recreate-table ( class -- )
     [
-        drop-sql-statement make-nonthrowable
+        [ drop-sql-statement [ execute-statement ] with-disposals
-        [ execute-statement ] with-disposals
+        ] curry ignore-errors
     ] [ create-table ] bi ;
 
 : ensure-table ( class -- )
@@ -141,9 +143,12 @@ M: retryable execute-statement* ( statement type -- )
         [ bind-tuple ] keep execute-statement
     ] with-disposal ;
 
-: select-tuples ( tuple -- tuples )
+: do-select ( exemplar-tuple statement -- tuples )
-    dup dup class <select-by-slots-statement> [
+    [ [ bind-tuple ] [ query-tuples ] 2bi ] with-disposal ;
-        [ bind-tuple ] keep query-tuples
-    ] with-disposal ;
 
-: select-tuple ( tuple -- tuple/f ) select-tuples ?first ;
+: select-tuples ( tuple -- tuples )
+    dup dup class <select-by-slots-statement> do-select ;
+
+: select-tuple ( tuple -- tuple/f )
+    dup dup class f f f 1 <advanced-select-statement>
+    do-select ?first ;

extra/db/types/types.factor

@@ -142,7 +142,8 @@ HOOK: bind% db ( spec -- )
 HOOK: bind# db ( spec obj -- )
 
 : offset-of-slot ( str obj -- n )
-    class "slots" word-prop slot-named slot-spec-offset ;
+    class superclasses [ "slots" word-prop ] map concat
+    slot-named slot-spec-offset ;
 
 : get-slot-named ( name obj -- value )
     tuck offset-of-slot slot ;

extra/dns/cache/cache.factor

@@ -80,7 +80,7 @@ SYMBOL: NX
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-ERROR: name-error name ;
+! ERROR: name-error name ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 

extra/dns/dns.factor

@@ -476,3 +476,16 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
 
 : message-query ( message -- query ) question-section>> 1st ;
 
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ERROR: name-error name ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: fully-qualified ( name -- name )
+    {
+      { [ dup empty?         ] [ "." append ] }
+      { [ dup peek CHAR: . = ] [            ] }
+      { [ t                  ] [ "." append ] }
+    }
+  cond ;

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 <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 ;

extra/dns/resolver/resolver.factor

@@ -6,34 +6,6 @@ IN: dns.resolver
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-! Need to cache records even in the case of name error
-
-: 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 ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! Ask and cache the records
-
-: ask* ( message -- message ) ask cache-message ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
 : canonical/cache ( name -- name )
   dup CNAME IN query boa cache-get dup vector? ! name result ?
     [ nip 1st rdata>> ]
@@ -44,25 +16,16 @@ IN: dns.resolver
   canonical/cache
   dup A IN query boa cache-get ! name result
     {
-    {
+      { [ dup NX = ] [ 2drop f ] }
-      [ dup NX = ]
+      { [ dup f = ]  [ 2drop f ] }
-      [ 2drop f ]
+      { [ t ]        [ nip random rdata>> ] }
-    }
-    {
-      [ dup f = ]
-      [ 2drop f ]
-    }
-    {
-      [ t ]
-      [ nip random rdata>> ]
-    }
     }
   cond ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 : canonical/server ( name -- name )
-  dup CNAME IN query boa query->message ask* answer-section>>
+  dup CNAME IN query boa query->message ask cache-message answer-section>>
   [ type>> CNAME = ] filter dup empty? not
     [ nip 1st rdata>> ]
     [ drop ]
@@ -70,7 +33,7 @@ IN: dns.resolver
 
 : name->ip/server ( name -- ip )
   canonical/server
-  dup A IN query boa query->message ask* answer-section>>
+  dup A IN query boa query->message ask cache-message answer-section>>
   [ type>> A = ] filter dup empty? not
     [ nip random rdata>> ]
     [ 2drop f ]
@@ -78,16 +41,6 @@ IN: dns.resolver
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: fully-qualified ( name -- name )
-    {
-      { [ dup empty?         ] [ "." append ] }
-      { [ dup peek CHAR: . = ] [            ] }
-      { [ t                  ] [ "." append ] }
-    }
-  cond ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
 : name->ip ( name -- ip )
   fully-qualified
   dup name->ip/cache dup

extra/dns/stub/stub.factor

@@ -0,0 +1,20 @@
+
+USING: kernel sequences random accessors dns ;
+
+IN: dns.stub
+
+! Stub resolver
+! 
+! Generally useful, but particularly when running a forwarding,
+! caching, nameserver on localhost with multiple Factor instances
+! querying it.
+
+: name->ip ( name -- ip )
+  A IN query boa
+  query->message
+  ask
+  dup rcode>> NAME-ERROR =
+    [ message-query name>> name-error ]
+    [ answer-section>> [ type>> A = ] filter random rdata>> ]
+  if ;
+

extra/io/windows/nt/backend/backend.factor

@@ -64,9 +64,11 @@ M: winnt add-completion ( win32-handle -- )
 
 : handle-overlapped ( timeout -- ? )
     wait-for-overlapped [
-        >r drop GetLastError
+        dup [
-        [ 1array ] [ expected-io-error? ] bi
+            >r drop GetLastError 1array r> resume-callback t
-        [ r> 2drop f ] [ r> resume-callback t ] if
+        ] [
+            2drop f
+        ] if
     ] [
         resume-callback t
     ] if ;

extra/json/reader/reader-tests.factor

@@ -0,0 +1,43 @@
+USING: arrays json.reader kernel multiline strings tools.test ;
+IN: json.reader.tests
+
+{ f } [ "false" json> ] unit-test
+{ t } [ "true" json> ] unit-test
+{ json-null } [ "null" json> ] unit-test
+{ 0 } [ "0" json> ] unit-test
+{ 102 } [ "102" json> ] unit-test
+{ -102 } [ "-102" json> ] unit-test
+{ 102 } [ "+102" json> ] unit-test
+{ 102.0 } [ "102.0" json> ] unit-test
+{ 102.5 } [ "102.5" json> ] unit-test
+{ 102.5 } [ "102.50" json> ] unit-test
+{ -10250 } [ "-102.5e2" json> ] unit-test
+{ -10250 } [ "-102.5E+2" json> ] unit-test
+{ 10.25 } [ "1025e-2" json> ] unit-test
+{ 0.125 } [ "0.125" json> ] unit-test
+{ -0.125 } [ "-0.125" json> ] unit-test
+
+{ " fuzzy  pickles " } [ <" " fuzzy  pickles " "> json> ] unit-test
+{ "while 1:\n\tpass" } [ <" "while 1:\n\tpass" "> json> ] unit-test
+{ 8 9 10 12 13 34 47 92 } >string 1array [ <" "\b\t\n\f\r\"\/\\" "> json> ] unit-test
+{ HEX: abcd } >string 1array [ <" "\uaBCd" "> json> ] unit-test
+
+{ { 1 "two" 3.0 } } [ <" [1, "two", 3.0] "> json> ] unit-test
+{ H{ { "US$" 1.0 } { "EU€" 1.5 } } } [ <" { "US$":1.00, "EU\u20AC":1.50 } "> json> ] unit-test
+{ H{
+    { "fib" { 1 1 2 3 5 8 H{ { "etc" "etc" } } } }
+    { "prime" { 2 3 5 7 11 13 } }
+} } [ <" {
+    "fib": [1, 1,  2,   3,     5,         8,
+        { "etc":"etc" } ],
+    "prime":
+    [ 2,3,     5,7,
+11,
+13
+]      }
+"> json> ] unit-test
+
+{ 0 } [ "      0" json> ] unit-test
+{ 0 } [ "0      " json> ] unit-test
+{ 0 } [ "   0   " json> ] unit-test
+

extra/json/reader/reader.factor

@@ -7,6 +7,8 @@ IN: json.reader
 
 ! Grammar for JSON from RFC 4627
 
+SYMBOL: json-null
+
 : [<&>] ( quot -- quot )
   { } make unclip [ <&> ] reduce ;
 
@@ -17,8 +19,7 @@ LAZY: 'ws' ( -- parser )
   " " token 
   "\n" token <|>
   "\r" token <|>
-  "\t" token <|> 
+  "\t" token <|> <*> ;
-  "" token <|> ;
 
 LAZY: spaced ( parser -- parser )
   'ws' swap &> 'ws' <& ;
@@ -42,24 +43,39 @@ LAZY: 'value-separator' ( -- parser )
   "," token spaced ;
 
 LAZY: 'false' ( -- parser )
-  "false" token ;
+  "false" token [ drop f ] <@ ;
 
 LAZY: 'null' ( -- parser )
-  "null" token ;
+  "null" token [ drop json-null ] <@ ;
 
 LAZY: 'true' ( -- parser )
-  "true" token ;
+  "true" token [ drop t ] <@ ;
 
 LAZY: 'quot' ( -- parser )
   "\"" token ;
 
+LAZY: 'hex-digit' ( -- parser )
+  [ digit> ] satisfy [ digit> ] <@ ;
+
+: hex-digits>ch ( digits -- ch )
+    0 [ swap 16 * + ] reduce ;
+
+LAZY: 'string-char' ( -- parser )
+  [ quotable? ] satisfy
+  "\\b" token [ drop 8 ] <@ <|>
+  "\\t" token [ drop CHAR: \t ] <@ <|>
+  "\\n" token [ drop CHAR: \n ] <@ <|>
+  "\\f" token [ drop 12 ] <@ <|>
+  "\\r" token [ drop CHAR: \r ] <@ <|>
+  "\\\"" token [ drop CHAR: " ] <@ <|>
+  "\\/" token [ drop CHAR: / ] <@ <|>
+  "\\\\" token [ drop CHAR: \\ ] <@ <|>
+  "\\u" token 'hex-digit' 4 exactly-n &>
+  [ hex-digits>ch ] <@ <|> ;
+
 LAZY: 'string' ( -- parser )
   'quot' 
-  [ 
+  'string-char' <*> &> 
-    [ quotable? ] keep
-    [ CHAR: \\ = or ] keep 
-    CHAR: " = not and 
-  ] satisfy <*> &> 
   'quot' <& [ >string ] <@  ;
 
 DEFER: 'value'
@@ -86,6 +102,9 @@ LAZY: 'minus' ( -- parser )
 LAZY: 'plus' ( -- parser )
   "+" token ;
 
+LAZY: 'sign' ( -- parser )
+  'minus' 'plus' <|> ;
+
 LAZY: 'zero' ( -- parser )
   "0" token [ drop 0 ] <@ ;
 
@@ -116,11 +135,11 @@ LAZY: 'e' ( -- parser )
 : sign-number ( pair -- number )
   #! Pair is { minus? num }
   #! Convert the json number value to a factor number
-  dup second swap first [ -1 * ] when ;
+  dup second swap first [ first "-" = [ -1 * ] when ] when* ;
 
 LAZY: 'exp' ( -- parser )
     'e' 
-    'minus' 'plus' <|> <?> &>
+    'sign' <?> &>
     'digit0-9' <+> [ decimal>integer ] <@ <&> [ sign-number ] <@ ;
 
 : sequence>frac ( seq -- num ) 
@@ -136,7 +155,7 @@ LAZY: 'frac' ( -- parser )
   dup second dup [ 10 swap first ^ swap first * ] [ drop first ] if ;
 
 LAZY: 'number' ( -- parser )
-  'minus' <?>
+  'sign' <?>
   [ 'int' , 'frac' 0 succeed <|> , ] [<&>] [ sum ] <@ 
   'exp' <?> <&> [ raise-to-power ] <@ <&> [ sign-number ] <@ ;
 
@@ -149,7 +168,7 @@ LAZY: 'value' ( -- parser )
     'object' ,
     'array' ,
     'number' ,
-  ] [<|>] ;
+  ] [<|>] spaced ;
 
 : json> ( string -- object )
   #! Parse a json formatted string to a factor object

extra/logging/logging-tests.factor

@@ -0,0 +1,24 @@
+IN: logging.tests
+USING: tools.test logging math ;
+
+: input-logging-test ( a b -- c ) + ;
+
+\ input-logging-test NOTICE add-input-logging
+
+: output-logging-test ( a b -- c ) + ;
+
+\ output-logging-test DEBUG add-output-logging
+
+: error-logging-test ( a b -- c ) / ;
+
+\ error-logging-test ERROR add-error-logging
+
+"logging-test" [
+    [ 4 ] [ 1 3 input-logging-test ] unit-test
+    
+    [ 4 ] [ 1 3 output-logging-test ] unit-test
+    
+    [ 4/3 ] [ 4 3 error-logging-test ] unit-test
+    
+    [ f ] [ 1 0 error-logging-test ] unit-test
+] with-logging

extra/logging/logging.factor

@@ -4,33 +4,26 @@ USING: logging.server sequences namespaces concurrency.messaging
 words kernel arrays shuffle tools.annotations
 prettyprint.config prettyprint debugger io.streams.string
 splitting continuations effects arrays.lib parser strings
-combinators.lib quotations ;
+combinators.lib quotations fry symbols accessors ;
 IN: logging
 
-SYMBOL: DEBUG
+SYMBOLS: DEBUG NOTICE WARNING ERROR CRITICAL ;
-SYMBOL: NOTICE
-SYMBOL: WARNING
-SYMBOL: ERROR
-SYMBOL: CRITICAL
 
-: log-levels
+: log-levels { DEBUG NOTICE NOTICE WARNING ERROR CRITICAL } ;
-    { DEBUG NOTICE NOTICE WARNING ERROR CRITICAL } ;
 
 : send-to-log-server ( array string -- )
     prefix "log-server" get send ;
 
 SYMBOL: log-service
 
-: check-log-message
+: check-log-message ( msg word level -- msg word level )
-    pick string?
+    3dup [ string? ] [ word? ] [ word? ] tri* and and
-    pick word?
+    [ "Bad parameters to log-message" throw ] unless ; inline
-    pick word? and and
-    [ "Bad parameters to log-message" throw ] unless ;
 
 : log-message ( msg word level -- )
     check-log-message
     log-service get dup [
-        >r >r >r string-lines r> word-name r> word-name r>
+        [ [ string-lines ] [ word-name ] [ word-name ] tri* ] dip
         4array "log-message" send-to-log-server
     ] [
         4drop
@@ -69,7 +62,7 @@ SYMBOL: log-service
 PRIVATE>
 
 : (define-logging) ( word level quot -- )
-    >r >r dup r> r> 2curry annotate ;
+    [ dup ] 2dip 2curry annotate ;
 
 : call-logging-quot ( quot word level -- quot' )
     "called" -rot [ log-message ] 3curry prepose ;
@@ -79,31 +72,30 @@ PRIVATE>
 
 : log-stack ( n word level -- )
     log-service get [
-        >r >r [ ndup ] keep narray stack>message
+        [ [ ndup ] keep narray stack>message ] 2dip log-message
-        r> r> log-message
     ] [
         3drop
     ] if ; inline
 
-: input# stack-effect effect-in length ;
+: input# stack-effect in>> length ;
 
 : input-logging-quot ( quot word level -- quot' )
-    over input# -rot [ log-stack ] 3curry prepose ;
+    rot [ [ input# ] keep ] 2dip '[ , , , log-stack @ ] ;
 
 : add-input-logging ( word level -- )
     [ input-logging-quot ] (define-logging) ;
 
-: output# stack-effect effect-out length ;
+: output# stack-effect out>> length ;
 
 : output-logging-quot ( quot word level -- quot' )
-    over output# -rot [ log-stack ] 3curry compose ;
+    [ [ output# ] keep ] dip '[ @ , , , log-stack ] ;
 
 : add-output-logging ( word level -- )
     [ output-logging-quot ] (define-logging) ;
 
 : (log-error) ( object word level -- )
     log-service get [
-        >r >r [ print-error ] with-string-writer r> r> log-message
+        [ [ print-error ] with-string-writer ] 2dip log-message
     ] [
         2drop rethrow
     ] if ;
@@ -112,22 +104,21 @@ PRIVATE>
 
 : log-critical ( error word -- ) CRITICAL (log-error) ;
 
-: stack-balancer ( effect word -- quot )
+: stack-balancer ( effect -- quot )
-    >r dup effect-in length r> [ over >r ERROR log-stack r> ndrop ] 2curry
+    [ in>> length [ ndrop ] curry ]
-    swap effect-out length f <repetition> append >quotation ;
+    [ out>> length f <repetition> >quotation ]
+    bi append ;
 
 : error-logging-quot ( quot word -- quot' )
-    [ [ log-error ] curry ] keep
+    dup stack-effect stack-balancer
-    [ stack-effect ] keep stack-balancer compose
+    '[ , [ , log-error @ ] recover ] ;
-    [ recover ] 2curry ;
 
 : add-error-logging ( word level -- )
-    [ over >r input-logging-quot r> error-logging-quot ]
+    [ [ input-logging-quot ] 2keep drop error-logging-quot ]
     (define-logging) ;
 
 : LOG:
     #! Syntax: name level
-    CREATE-WORD
+    CREATE-WORD dup scan-word
-    dup scan-word
+    '[ 1array stack>message , , log-message ]
-    [ >r >r 1array stack>message r> r> log-message ] 2curry
     define ; parsing

extra/memoize/memoize.factor

@@ -58,3 +58,6 @@ M: memoized reset-word
 
 : reset-memoized ( word -- )
     "memoize" word-prop clear-assoc ;
+
+: invalidate-memoized ! ( inputs... word )
+    [ #in packer call ] [ "memoize" word-prop delete-at ] bi ;

extra/namespaces/lib/lib.factor

@@ -2,7 +2,7 @@
 ! USING: kernel quotations namespaces sequences assocs.lib ;
 
 USING: kernel namespaces namespaces.private quotations sequences
-       assocs.lib math.parser math sequences.lib locals ;
+       assocs.lib math.parser math sequences.lib locals mirrors ;
 
 IN: namespaces.lib
 
@@ -58,3 +58,9 @@ MACRO:: nmake ( quot exemplars -- )
             ] with-scope
         ]
     ] ;
+
+: make-object ( quot class -- object )
+    new [ <mirror> swap bind ] keep ; inline
+
+: with-object ( object quot -- )
+    [ <mirror> ] dip bind ; inline

extra/opengl/gadgets/gadgets.factor

@@ -0,0 +1,72 @@
+! Copyright (C) 2008 Matthew Willis.
+! See http://factorcode.org/license.txt for BSD license.
+USING: locals math.functions math namespaces
+opengl.gl accessors kernel opengl ui.gadgets
+destructors sequences ui.render colors ;
+IN: opengl.gadgets
+
+TUPLE: texture-gadget bytes format dim tex ;
+
+: 2^-ceil ( x -- y )
+    dup 2 < [ 2 * ] [ 1- log2 1+ 2^ ] if ; foldable flushable
+
+: 2^-bounds ( dim -- dim' )
+    [ 2^-ceil ] map ; foldable flushable
+
+: <texture-gadget> ( bytes format dim -- gadget )
+    texture-gadget construct-gadget
+        swap >>dim
+        swap >>format
+        swap >>bytes ;
+
+:: render ( gadget -- )
+    GL_ENABLE_BIT [
+        GL_TEXTURE_2D glEnable
+        GL_TEXTURE_2D gadget tex>> glBindTexture
+        GL_TEXTURE_2D
+        0
+        GL_RGBA
+        gadget dim>> 2^-bounds first2
+        0
+        gadget format>>
+        GL_UNSIGNED_BYTE
+        gadget bytes>>
+        glTexImage2D
+        init-texture
+        GL_TEXTURE_2D 0 glBindTexture
+    ] do-attribs ;
+
+:: four-corners ( dim -- )
+    [let* | w [ dim first ]
+            h [ dim second ]
+            dim' [ dim dup 2^-bounds [ /f ] 2map ]
+            w' [ dim' first ]
+            h' [ dim' second ] |
+        0  0  glTexCoord2d 0 0 glVertex2d
+        0  h' glTexCoord2d 0 h glVertex2d
+        w' h' glTexCoord2d w h glVertex2d
+        w' 0  glTexCoord2d w 0 glVertex2d
+    ] ;
+
+M: texture-gadget draw-gadget* ( gadget -- )
+    origin get [
+        GL_ENABLE_BIT [
+            white gl-color
+            1.0 -1.0 glPixelZoom
+            GL_TEXTURE_2D glEnable
+            GL_TEXTURE_2D over tex>> glBindTexture
+            GL_QUADS [
+                dim>> four-corners
+            ] do-state
+            GL_TEXTURE_2D 0 glBindTexture
+        ] do-attribs
+    ] with-translation ;
+
+M: texture-gadget graft* ( gadget -- )
+    gen-texture >>tex [ render ]
+    [ f >>bytes f >>format drop ] bi ;
+
+M: texture-gadget ungraft* ( gadget -- )
+    tex>> delete-texture ;
+
+M: texture-gadget pref-dim* ( gadget -- dim ) dim>> ;

extra/openssl/openssl.factor

@@ -38,15 +38,15 @@ M: TLSv1  ssl-method drop TLSv1_method ;
     OpenSSL_add_all_digests
     OpenSSL_add_all_ciphers ;
 
-SYMBOL: ssl-initiazed?
+SYMBOL: ssl-initialized?
 
 : maybe-init-ssl ( -- )
-    ssl-initiazed? get-global [
+    ssl-initialized? get-global [
         init-ssl
-        t ssl-initiazed? set-global
+        t ssl-initialized? set-global
     ] unless ;
 
-[ f ssl-initiazed? set-global ] "openssl" add-init-hook
+[ f ssl-initialized? set-global ] "openssl" add-init-hook
 
 TUPLE: openssl-context < secure-context aliens ;
 

extra/pango/cairo/cairo.factor

@@ -2,10 +2,10 @@
 ! See http://factorcode.org/license.txt for BSD license.
 !
 ! pangocairo bindings, from pango/pangocairo.h
-
 USING: cairo.ffi alien.c-types math
-alien.syntax system combinators alien ;
+alien.syntax system combinators alien
-IN: cairo.pango
+arrays pango pango.fonts ;
+IN: pango.cairo
 
 << "pangocairo" {
 !    { [ os winnt? ] [ "libpangocairo-1.dll" ] }
@@ -15,10 +15,6 @@ IN: cairo.pango
 
 LIBRARY: pangocairo
 
-TYPEDEF: void* PangoCairoFont
-TYPEDEF: void* PangoCairoFontMap
-TYPEDEF: void* PangoFontMap
-
 FUNCTION: PangoFontMap*
 pango_cairo_font_map_new  ( ) ;
 
@@ -92,49 +88,6 @@ pango_cairo_layout_path ( cairo_t* cr, PangoLayout* layout ) ;
 FUNCTION: void
 pango_cairo_error_underline_path ( cairo_t* cr, double x, double y, double width, double height ) ;
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Helpful functions from other parts of pango
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: PANGO_SCALE 1024 ;
-
-FUNCTION: void
-pango_layout_set_text ( PangoLayout* layout, char* text, int length ) ;
-
-FUNCTION: char*
-pango_layout_get_text ( PangoLayout* layout ) ;
-
-FUNCTION: void
-pango_layout_get_size ( PangoLayout* layout, int* width, int* height ) ;
-
-TYPEDEF: void* PangoFontDescription
-
-FUNCTION: PangoFontDescription*
-pango_font_description_from_string ( char* str ) ;
-
-FUNCTION: char*
-pango_font_description_to_string ( PangoFontDescription* desc ) ;
-
-FUNCTION: char*
-pango_font_description_to_filename ( PangoFontDescription* desc ) ;
-
-FUNCTION: void
-pango_layout_set_font_description ( PangoLayout* layout, PangoFontDescription* desc ) ;
-
-FUNCTION: PangoFontDescription*
-pango_layout_get_font_description ( PangoLayout* layout ) ;
-
-FUNCTION: void
-pango_layout_get_pixel_size ( PangoLayout* layout, int* width, int* height ) ;
-
-FUNCTION: void
-pango_font_description_free ( PangoFontDescription* desc ) ;
-
-TYPEDEF: void* gpointer
-
-FUNCTION: void
-g_object_unref ( gpointer object ) ;
-
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 ! Higher level words and combinators
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -162,8 +115,8 @@ M: pango-layout dispose ( alien -- ) alien>> g_object_unref ;
     >r CAIRO_FORMAT_ARGB32 0 0 cairo_image_surface_create
     r> [ with-pango ] curry with-cairo-from-surface ; inline
 
-: layout-size ( quot -- width height )
+: layout-size ( quot -- dim )
-    [ layout pango-layout-get-pixel-size ] compose dummy-pango ; inline
+    [ layout pango-layout-get-pixel-size 2array ] compose dummy-pango ; inline
 
 : layout-font ( str -- )
     pango_font_description_from_string
@@ -173,3 +126,6 @@ M: pango-layout dispose ( alien -- ) alien>> g_object_unref ;
 
 : layout-text ( str -- )
     layout swap -1 pango_layout_set_text ;
+
+: families ( -- families )
+    pango_cairo_font_map_get_default list-families ;

extra/pango/cairo/gadgets/gadgets.factor

@@ -0,0 +1,30 @@
+! Copyright (C) 2008 Matthew Willis.
+! See http://factorcode.org/license.txt for BSD license.
+USING: pango.cairo cairo cairo.ffi cairo.gadgets
+alien.c-types kernel math ;
+IN: pango.cairo.gadgets
+
+: (pango-gadget) ( setup show -- gadget )
+    [ drop layout-size ]
+    [ compose [ with-pango ] curry <cairo-gadget> ] 2bi ;
+
+: <pango-gadget> ( quot -- gadget )
+    [ cr layout pango_cairo_show_layout ] (pango-gadget) ;
+
+USING: prettyprint sequences ui.gadgets.panes
+threads io.backend io.encodings.utf8 io.files ;
+: hello-pango ( -- )
+    50 [ 6 + ] map [
+        "Sans " swap unparse append
+        [ 
+            cr 0 1 0.2 0.6 cairo_set_source_rgba
+            layout-font "今日は、 Pango!" layout-text
+        ] curry
+        <pango-gadget> gadget. yield
+    ] each
+    [ 
+        "resource:extra/pango/cairo/gadgets/gadgets.factor"
+        normalize-path utf8 file-contents layout-text
+    ] <pango-gadget> gadget. ;
+
+MAIN: hello-pango

extra/pango/fonts/fonts.factor

@@ -0,0 +1,40 @@
+! Copyright (C) 2008 Matthew Willis.
+! See http://factorcode.org/license.txt for BSD license
+USING: pango alien.syntax alien.c-types
+kernel ;
+IN: pango.fonts
+
+LIBRARY: pango
+
+FUNCTION: void
+pango_font_map_list_families ( PangoFontMap* fontmap, PangoFontFamily*** families, int* n_families ) ;
+
+FUNCTION: char*
+pango_font_family_get_name ( PangoFontFamily* family ) ;
+
+FUNCTION: int
+pango_font_family_is_monospace ( PangoFontFamily* family ) ;
+
+FUNCTION: void
+pango_font_family_list_faces ( PangoFontFamily* family, PangoFontFace*** faces, int* n_faces ) ;
+
+FUNCTION: char*
+pango_font_face_get_face_name ( PangoFontFace* face ) ;
+
+FUNCTION: void
+pango_font_face_list_sizes ( PangoFontFace* face, int** sizes, int* n_sizes ) ;
+
+: list-families ( PangoFontMap* -- PangoFontFamily*-seq )
+    0 <int> 0 <int> [ pango_font_map_list_families ] 2keep
+    *int swap *void* [ swap c-void*-array> ] [ g_free ] bi ;
+
+: list-faces ( PangoFontFamily* -- PangoFontFace*-seq )
+    0 <int> 0 <int> [ pango_font_family_list_faces ] 2keep
+    *int swap *void* [ swap c-void*-array> ] [ g_free ] bi ;
+
+: list-sizes ( PangoFontFace* -- ints )
+    0 <int> 0 <int> [ pango_font_face_list_sizes ] 2keep
+    *int swap *void* [ swap c-int-array> ] [ g_free ] bi ;
+
+: monospace? ( PangoFontFamily* -- ? )
+    pango_font_family_is_monospace 1 = ;

extra/pango/pango.factor

@@ -0,0 +1,59 @@
+! Copyright (C) 2008 Matthew Willis.
+! See http://factorcode.org/license.txt for BSD license
+USING: system
+alien.c-types alien.syntax alien combinators ;
+IN: pango
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Helpful functions from other parts of pango
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+<< "pango" {
+!    { [ os winnt? ] [ "libpango-1.dll" ] }
+!    { [ os macosx? ] [ "libpango.dylib" ] }
+    { [ os unix? ] [ "libpango-1.0.so" ] }
+} cond "cdecl" add-library >>
+
+LIBRARY: pango
+
+: PANGO_SCALE 1024 ;
+
+FUNCTION: void
+pango_layout_set_text ( PangoLayout* layout, char* text, int length ) ;
+
+FUNCTION: char*
+pango_layout_get_text ( PangoLayout* layout ) ;
+
+FUNCTION: void
+pango_layout_get_size ( PangoLayout* layout, int* width, int* height ) ;
+
+FUNCTION: PangoFontDescription*
+pango_font_description_from_string ( char* str ) ;
+
+FUNCTION: char*
+pango_font_description_to_string ( PangoFontDescription* desc ) ;
+
+FUNCTION: char*
+pango_font_description_to_filename ( PangoFontDescription* desc ) ;
+
+FUNCTION: void
+pango_layout_set_font_description ( PangoLayout* layout, PangoFontDescription* desc ) ;
+
+FUNCTION: PangoFontDescription*
+pango_layout_get_font_description ( PangoLayout* layout ) ;
+
+FUNCTION: void
+pango_layout_get_pixel_size ( PangoLayout* layout, int* width, int* height ) ;
+
+FUNCTION: void
+pango_font_description_free ( PangoFontDescription* desc ) ;
+
+! glib functions
+
+TYPEDEF: void* gpointer
+
+FUNCTION: void
+g_object_unref ( gpointer object ) ;
+
+FUNCTION: void
+g_free ( gpointer mem ) ;

extra/tools/deploy/deploy-tests.factor

@@ -23,7 +23,7 @@ namespaces continuations layouts accessors ;
 [ ] [ "sudoku" shake-and-bake ] unit-test
 
 [ t ] [
-    cell 8 = 30 15 ? 100000 * small-enough?
+    cell 8 = 20 10 ? 100000 * small-enough?
 ] unit-test
 
 [ ] [ "hello-ui" shake-and-bake ] unit-test
@@ -37,6 +37,12 @@ namespaces continuations layouts accessors ;
     cell 8 = 40 20 ? 100000 * small-enough?
 ] unit-test
 
+[ ] [ "maze" shake-and-bake ] unit-test
+
+[ t ] [
+    cell 8 = 30 15 ? 100000 * small-enough?
+] unit-test
+
 [ ] [ "bunny" shake-and-bake ] unit-test
 
 [ t ] [

extra/tools/deploy/shaker/shaker.factor

@@ -108,6 +108,8 @@ IN: tools.deploy.shaker
 
 : stripped-globals ( -- seq )
     [
+        "callbacks" "alien.compiler" lookup ,
+
         {
             bootstrap.stage2:bootstrap-time
             continuations:error
@@ -142,6 +144,7 @@ IN: tools.deploy.shaker
 
             {
                 gensym
+                name>char-hook
                 classes:class-and-cache
                 classes:class-not-cache
                 classes:class-or-cache
@@ -167,6 +170,8 @@ IN: tools.deploy.shaker
                 vocabs:load-vocab-hook
                 word
             } %
+
+            { } { "optimizer.math.partial" } strip-vocab-globals %
         ] when
 
         strip-prettyprint? [

extra/tools/walker/walker.factor

@@ -4,7 +4,7 @@ USING: threads kernel namespaces continuations combinators
 sequences math namespaces.private continuations.private
 concurrency.messaging quotations kernel.private words
 sequences.private assocs models arrays accessors
-generic generic.standard ;
+generic generic.standard definitions ;
 IN: tools.walker
 
 SYMBOL: show-walker-hook ! ( status continuation thread -- )
@@ -73,6 +73,7 @@ M: object add-breakpoint ;
         { [ dup "step-into" word-prop ] [ "step-into" word-prop call ] }
         { [ dup standard-generic? ] [ effective-method (step-into-execute) ] }
         { [ dup hook-generic? ] [ effective-method (step-into-execute) ] }
+        { [ dup uses \ suspend swap member? ] [ execute break ] }
         { [ dup primitive? ] [ execute break ] }
         [ word-def (step-into-quot) ]
     } cond ;
@@ -89,7 +90,6 @@ SYMBOL: step-into
 SYMBOL: step-all
 SYMBOL: step-into-all
 SYMBOL: step-back
-SYMBOL: detach
 SYMBOL: abandon
 SYMBOL: call-in
 
@@ -137,7 +137,7 @@ SYMBOL: +stopped+
 {
     >n ndrop >c c>
     continue continue-with
-    stop yield suspend sleep (spawn)
+    stop suspend (spawn)
 } [
     dup [ execute break ] curry
     "step-into" set-word-prop
@@ -168,10 +168,7 @@ SYMBOL: +stopped+
     +running+ set-status ;
 
 : walker-stopped ( -- )
-    +stopped+ set-status
+    +stopped+ set-status ;
-    [ status +stopped+ eq? ]
-    [ [ drop f ] handle-synchronous ]
-    [ ] while ;
 
 : step-into-all-loop ( -- )
     +running+ set-status

extra/urls/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

extra/urls/summary.txt

@@ -0,0 +1 @@
+Tools for working with URLs (uniform resource locators)

extra/urls/tags.txt

@@ -0,0 +1,2 @@
+web
+network

extra/urls/urls-tests.factor

@@ -0,0 +1,194 @@
+IN: urls.tests
+USING: urls tools.test tuple-syntax arrays kernel assocs ;
+
+[ "hello%20world" ] [ "hello world" url-encode ] unit-test
+[ "hello world" ] [ "hello%20world" url-decode ] unit-test
+[ "~hello world" ] [ "%7ehello+world" url-decode ] unit-test
+[ f ] [ "%XX%XX%XX" url-decode ] unit-test
+[ f ] [ "%XX%XX%X" url-decode ] unit-test
+
+[ "hello world"   ] [ "hello+world"    url-decode ] unit-test
+[ "hello world"   ] [ "hello%20world"  url-decode ] unit-test
+[ " ! "           ] [ "%20%21%20"      url-decode ] unit-test
+[ "hello world"   ] [ "hello world%"   url-decode ] unit-test
+[ "hello world"   ] [ "hello world%x"  url-decode ] unit-test
+[ "hello%20world" ] [ "hello world"    url-encode ] unit-test
+[ "%20%21%20"     ] [ " ! "            url-encode ] unit-test
+
+[ "\u001234hi\u002045" ] [ "\u001234hi\u002045" url-encode url-decode ] unit-test
+
+[ "a=b&a=c" ] [ { { "a" { "b" "c" } } } assoc>query ] unit-test
+
+[ H{ { "a" "b" } } ] [ "a=b" query>assoc ] unit-test
+
+[ H{ { "a" { "b" "c" } } } ] [ "a=b&a=c" query>assoc ] unit-test
+
+[ "a=3" ] [ { { "a" 3 } } assoc>query ] unit-test
+
+: urls
+    {
+        {
+            TUPLE{ url
+                protocol: "http"
+                host: "www.apple.com"
+                port: 1234
+                path: "/a/path"
+                query: H{ { "a" "b" } }
+                anchor: "foo"
+            }
+            "http://www.apple.com:1234/a/path?a=b#foo"
+        }
+        {
+            TUPLE{ url
+                protocol: "http"
+                host: "www.apple.com"
+                path: "/a/path"
+                query: H{ { "a" "b" } }
+                anchor: "foo"
+            }
+            "http://www.apple.com/a/path?a=b#foo"
+        }
+        {
+            TUPLE{ url
+                protocol: "http"
+                host: "www.apple.com"
+                port: 1234
+                path: "/another/fine/path"
+                anchor: "foo"
+            }
+            "http://www.apple.com:1234/another/fine/path#foo"
+        }
+        {
+            TUPLE{ url
+                path: "/a/relative/path"
+                anchor: "foo"
+            }
+            "/a/relative/path#foo"
+        }
+        {
+            TUPLE{ url
+                path: "/a/relative/path"
+            }
+            "/a/relative/path"
+        }
+        {
+            TUPLE{ url
+                path: "a/relative/path"
+            }
+            "a/relative/path"
+        }
+    } ;
+
+urls [
+    [ 1array ] [ [ string>url ] curry ] bi* unit-test
+] assoc-each
+
+urls [
+    swap [ 1array ] [ [ url>string ] curry ] bi* unit-test
+] assoc-each
+
+[ "b" ] [ "a" "b" url-append-path ] unit-test
+
+[ "a/b" ] [ "a/c" "b" url-append-path ] unit-test
+
+[ "a/b" ] [ "a/" "b" url-append-path ] unit-test
+
+[ "/b" ] [ "a" "/b" url-append-path ] unit-test
+
+[ "/b" ] [ "a/b/" "/b" url-append-path ] unit-test
+
+[ "/xxx/bar" ] [ "/xxx/baz" "bar" url-append-path ] unit-test
+
+[
+    TUPLE{ url
+        protocol: "http"
+        host: "www.apple.com"
+        port: 1234
+        path: "/a/path"
+    }
+] [
+    TUPLE{ url
+        protocol: "http"
+        host: "www.apple.com"
+        port: 1234
+        path: "/foo"
+    }
+
+    TUPLE{ url
+        path: "/a/path"
+    }
+
+    derive-url
+] unit-test
+
+[
+    TUPLE{ url
+        protocol: "http"
+        host: "www.apple.com"
+        port: 1234
+        path: "/a/path/relative/path"
+        query: H{ { "a" "b" } }
+        anchor: "foo"
+    }
+] [
+    TUPLE{ url
+        protocol: "http"
+        host: "www.apple.com"
+        port: 1234
+        path: "/a/path/"
+    }
+
+    TUPLE{ url
+        path: "relative/path"
+        query: H{ { "a" "b" } }
+        anchor: "foo"
+    }
+
+    derive-url
+] unit-test
+
+[
+    TUPLE{ url
+        protocol: "http"
+        host: "www.apple.com"
+        port: 1234
+        path: "/a/path/relative/path"
+        query: H{ { "a" "b" } }
+        anchor: "foo"
+    }
+] [
+    TUPLE{ url
+        protocol: "http"
+        host: "www.apple.com"
+        port: 1234
+        path: "/a/path/"
+    }
+
+    TUPLE{ url
+        path: "relative/path"
+        query: H{ { "a" "b" } }
+        anchor: "foo"
+    }
+
+    derive-url
+] unit-test
+
+[
+    TUPLE{ url
+        protocol: "http"
+        host: "www.apple.com"
+        path: "/xxx/baz"
+    }
+] [
+    TUPLE{ url
+        protocol: "http"
+        host: "www.apple.com"
+        path: "/xxx/bar"
+    }
+
+    TUPLE{ url
+        path: "baz"
+    }
+
+    derive-url
+] unit-test

extra/urls/urls.factor

@@ -0,0 +1,160 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel unicode.categories combinators sequences splitting
+fry namespaces assocs arrays strings mirrors
+io.encodings.string io.encodings.utf8
+math math.parser accessors namespaces.lib ;
+IN: urls
+
+: url-quotable? ( ch -- ? )
+    #! In a URL, can this character be used without
+    #! URL-encoding?
+    {
+        { [ dup letter? ] [ t ] }
+        { [ dup LETTER? ] [ t ] }
+        { [ dup digit? ] [ t ] }
+        { [ dup "/_-.:" member? ] [ t ] }
+        [ f ]
+    } cond nip ; foldable
+
+: push-utf8 ( ch -- )
+    1string utf8 encode
+    [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ;
+
+: url-encode ( str -- str )
+    [
+        [ dup url-quotable? [ , ] [ push-utf8 ] if ] each
+    ] "" make ;
+
+: url-decode-hex ( index str -- )
+    2dup length 2 - >= [
+        2drop
+    ] [
+        [ 1+ dup 2 + ] dip subseq  hex> [ , ] when*
+    ] if ;
+
+: url-decode-% ( index str -- index str )
+    2dup url-decode-hex [ 3 + ] dip ;
+
+: url-decode-+-or-other ( index str ch -- index str )
+    dup CHAR: + = [ drop CHAR: \s ] when , [ 1+ ] dip ;
+
+: url-decode-iter ( index str -- )
+    2dup length >= [
+        2drop
+    ] [
+        2dup nth dup CHAR: % = [
+            drop url-decode-%
+        ] [
+            url-decode-+-or-other
+        ] if url-decode-iter
+    ] if ;
+
+: url-decode ( str -- str )
+    [ 0 swap url-decode-iter ] "" make utf8 decode ;
+
+: add-query-param ( value key assoc -- )
+    [
+        at [
+            {
+                { [ dup string? ] [ swap 2array ] }
+                { [ dup array? ] [ swap suffix ] }
+                { [ dup not ] [ drop ] }
+            } cond
+        ] when*
+    ] 2keep set-at ;
+
+: query>assoc ( query -- assoc )
+    dup [
+        "&" split H{ } clone [
+            [
+                [ "=" split1 [ dup [ url-decode ] when ] bi@ swap ] dip
+                add-query-param
+            ] curry each
+        ] keep
+    ] when ;
+
+: assoc>query ( hash -- str )
+    [
+        {
+            { [ dup number? ] [ number>string 1array ] }
+            { [ dup string? ] [ 1array ] }
+            { [ dup sequence? ] [ ] }
+        } cond
+    ] assoc-map
+    [
+        [
+            [ url-encode ] dip
+            [ url-encode "=" swap 3append , ] with each
+        ] assoc-each
+    ] { } make "&" join ;
+
+TUPLE: url protocol host port path query anchor ;
+
+: query-param ( request key -- value )
+    swap query>> at ;
+
+: set-query-param ( request value key -- request )
+    pick query>> set-at ;
+
+: parse-host ( string -- host port )
+    ":" split1 [ url-decode ] [
+        dup [
+            string>number
+            dup [ "Invalid port" throw ] unless
+        ] when
+    ] bi* ;
+
+: parse-host-part ( protocol rest -- string' )
+    [ "protocol" set ] [
+        "//" ?head [ "Invalid URL" throw ] unless
+        "/" split1 [
+            parse-host [ "host" set ] [ "port" set ] bi*
+        ] [ "/" prepend ] bi*
+    ] bi* ;
+
+: string>url ( string -- url )
+    [
+        ":" split1 [ parse-host-part ] when*
+        "#" split1 [
+            "?" split1 [ query>assoc "query" set ] when*
+            url-decode "path" set
+        ] [
+            url-decode "anchor" set
+        ] bi*
+    ] url make-object ;
+
+: unparse-host-part ( protocol -- )
+    %
+    "://" %
+    "host" get url-encode %
+    "port" get [ ":" % # ] when*
+    "path" get "/" head? [ "Invalid URL" throw ] unless ;
+
+: url>string ( url -- string )
+    [
+        <mirror> [
+            "protocol" get [ unparse-host-part ] when*
+            "path" get url-encode %
+            "query" get [ "?" % assoc>query % ] when*
+            "anchor" get [ "#" % url-encode % ] when*
+        ] bind
+    ] "" make ;
+
+: url-append-path ( path1 path2 -- path )
+    {
+        { [ dup "/" head? ] [ nip ] }
+        { [ dup empty? ] [ drop ] }
+        { [ over "/" tail? ] [ append ] }
+        { [ "/" pick start not ] [ nip ] }
+        [ [ "/" last-split1 drop "/" ] dip 3append ]
+    } cond ;
+
+: derive-url ( base url -- url' )
+    [ clone dup ] dip
+    2dup [ path>> ] bi@ url-append-path
+    [ [ <mirror> ] bi@ [ nip ] assoc-filter update ] dip
+    >>path ;
+
+: relative-url ( url -- url' )
+    clone f >>protocol f >>host f >>port ;

extra/webapps/pastebin/pastebin.factor

@@ -15,18 +15,22 @@ IN: webapps.pastebin
 ! DOMAIN MODEL
 ! ! !
 
-TUPLE: paste id summary author mode date contents annotations ;
+TUPLE: entity id summary author mode date contents ;
 
-\ paste "PASTE"
+entity f
 {
     { "id" "ID" INTEGER +db-assigned-id+ }
     { "summary" "SUMMARY" { VARCHAR 256 } +not-null+ }
     { "author" "AUTHOR" { VARCHAR 256 } +not-null+ }
     { "mode" "MODE" { VARCHAR 256 } +not-null+ }
-    { "date" "DATE" DATETIME +not-null+ , }
+    { "date" "DATE" DATETIME +not-null+ }
     { "contents" "CONTENTS" TEXT +not-null+ }
 } define-persistent
 
+TUPLE: paste < entity annotations ;
+
+\ paste "PASTES" { } define-persistent
+
 : <paste> ( id -- paste )
     \ paste new
         swap >>id ;
@@ -34,23 +38,17 @@ TUPLE: paste id summary author mode date contents annotations ;
 : pastes ( -- pastes )
     f <paste> select-tuples ;
 
-TUPLE: annotation aid id summary author mode contents date ;
+TUPLE: annotation < entity parent ;
 
-annotation "ANNOTATION"
+annotation "ANNOTATIONS"
 {
-    { "aid" "AID" INTEGER +db-assigned-id+ }
+    { "parent" "PARENT" INTEGER +not-null+ }
-    { "id" "ID" INTEGER +not-null+ }
-    { "summary" "SUMMARY" { VARCHAR 256 } +not-null+ }
-    { "author" "AUTHOR" { VARCHAR 256 } +not-null+ }
-    { "mode" "MODE" { VARCHAR 256 } +not-null+ }
-    { "date" "DATE" DATETIME +not-null+ }
-    { "contents" "CONTENTS" TEXT +not-null+ }
 } define-persistent
 
-: <annotation> ( id aid -- annotation )
+: <annotation> ( parent id -- annotation )
     annotation new
-        swap >>aid
+        swap >>id
-        swap >>id ;
+        swap >>parent ;
 
 : fetch-annotations ( paste -- paste )
     dup annotations>> [
@@ -76,8 +74,8 @@ M: paste entity-link
     id>> "id" associate "$pastebin/paste" swap link>string ;
 
 M: annotation entity-link
-    [ id>> "id" associate "$pastebin/paste" swap link>string ]
+    [ parent>> "parent" associate "$pastebin/paste" swap link>string ]
-    [ aid>> number>string "#" prepend ] bi
+    [ id>> number>string "#" prepend ] bi
     append ;
 
 : pastebin-template ( name -- template )
@@ -147,7 +145,7 @@ M: annotation entity-link
         [ validate-integer-id ] >>init
         [ "id" value paste annotations>> paste-feed ] >>feed ;
 
-: validate-paste ( -- )
+: validate-entity ( -- )
     {
         { "summary" [ v-one-line ] }
         { "author" [ v-one-line ] }
@@ -156,7 +154,7 @@ M: annotation entity-link
         { "captcha" [ v-captcha ] }
     } validate-params ;
 
-: deposit-paste-slots ( tuple -- )
+: deposit-entity-slots ( tuple -- )
     now >>date
     { "summary" "author" "mode" "contents" } deposit-slots ;
 
@@ -170,10 +168,10 @@ M: annotation entity-link
         "new-paste" pastebin-template >>template
 
         [
-            validate-paste
+            validate-entity
 
             f <paste>
-            [ deposit-paste-slots ]
+            [ deposit-entity-slots ]
             [ insert-tuple ]
             [ id>> "$pastebin/paste" <id-redirect> ]
             tri
@@ -195,31 +193,35 @@ M: annotation entity-link
 
 : <new-annotation-action> ( -- action )
     <page-action>
-        [ validate-paste ] >>validate
+        [
-
+            { { "id" [ v-integer ] } } validate-params
-        [ "id" param "$pastebin/paste" <id-redirect> ] >>display
+            "id" value "$pastebin/paste" <id-redirect>
+        ] >>display
 
         [
-            f f <annotation>
+            { { "id" [ v-integer ] } } validate-params
-            {
+            validate-entity
-                [ deposit-paste-slots ]
+        ] >>validate
-                [ { "id" } deposit-slots ]
+
+        [
+            "id" value f <annotation>
+            [ deposit-entity-slots ]
             [ insert-tuple ]
             [
                 ! Add anchor here
-                    id>> "$pastebin/paste" <id-redirect>
+                parent>> "$pastebin/paste" <id-redirect>
             ]
-            } cleave
+            tri
         ] >>submit ;
 
 : <delete-annotation-action> ( -- action )
     <action>
-        [ { { "aid" [ v-number ] } } validate-params ] >>validate
+        [ { { "id" [ v-number ] } } validate-params ] >>validate
 
         [
-            f "aid" value <annotation> select-tuple
+            f "id" value <annotation> select-tuple
             [ delete-tuples ]
-            [ id>> "$pastebin/paste" <id-redirect> ]
+            [ parent>> "$pastebin/paste" <id-redirect> ]
             bi
         ] >>submit ;
 

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
+	CELL literal_start = code_start + compiled->code_length;
-		+ compiled->code_length
-		+ compiled->reloc_length;
 
 	return get(literal_start);
 }

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,
+void collect_literals_step(F_COMPILED *compiled, CELL code_start, CELL literals_start)
-	CELL reloc_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);
 }

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,
+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)
 {
 	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)

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,
+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)
 		{
@@ -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
+	CELL here = allot_code_block(sizeof(F_COMPILED) + code_length + literals_length);
-		+ rel_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));
 

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,
+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);
 
@@ -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);

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_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;
 	}
 
-	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);
 }
 
@@ -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;
 }

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,
+void find_code_references_step(F_COMPILED *compiled, CELL code_start, CELL literals_start)
-		CELL reloc_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
+		CELL literal_start = code_start + compiled->code_length;
-			+ compiled->code_length
-			+ compiled->reloc_length;
 
 		CELL obj = get(literal_start);
 

vm/image.c

@@ -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 */
 	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(compiled,code_start,literals_start);
-		relocate_code_block(relocating,code_start,reloc_start,literals_start);
 }
 
 void relocate_code()

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 */

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);
 }
 

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);
 }
 

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);
 }

vm/profiler.c

@@ -11,11 +11,12 @@ F_COMPILED *compile_profiling_stub(F_WORD *word)
 	CELL code = array_nth(quadruple,0);
 	REGISTER_ROOT(code);
 
-	CELL rel_type = allot_cell(to_fixnum(array_nth(quadruple,2))
+	F_REL rel;
-		| (to_fixnum(array_nth(quadruple,1)) << 8));
+	rel.type = to_fixnum(array_nth(quadruple,2)) | (to_fixnum(array_nth(quadruple,1)) << 8);
-	CELL rel_offset = array_nth(quadruple,3) * compiled_code_format();
+	rel.offset = to_fixnum(array_nth(quadruple,3)) * compiled_code_format();
 
-	CELL relocation = allot_array_2(rel_type,rel_offset);
+	F_BYTE_ARRAY *relocation = allot_byte_array(sizeof(F_REL));
+	memcpy((void *)BREF(relocation,0),&rel,sizeof(F_REL));
 
 	UNREGISTER_ROOT(code);
 	UNREGISTER_ROOT(literals);
@@ -24,7 +25,7 @@ F_COMPILED *compile_profiling_stub(F_WORD *word)
 		WORD_TYPE,
 		untag_object(code),
 		NULL, /* no labels */
-		untag_object(relocation),
+		tag_object(relocation),
 		untag_object(literals));
 }
 

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, \
+		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)
@@ -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_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);
 
 				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_ARRAY_TRIM(code);
-	GROWABLE_TRIM(relocation);
+	GROWABLE_ARRAY_TRIM(literals);
-	GROWABLE_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);

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);
 
@@ -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 */

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) \
+#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))
+
+/* 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))