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/generator/fixup/fixup-docs.factor

@@ -1,5 +1,6 @@
-USING: help.syntax help.markup generator.fixup math kernel
+USING: help.syntax help.markup math kernel
-words strings alien byte-array ;
+words strings alien ;
+IN: generator.fixup
 
 HELP: frame-required
 { $values { "n" "a non-negative integer" } }

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/combinators/lib/lib.factor

@@ -90,7 +90,7 @@ MACRO: 2|| ( quots -- ? )
   [ [ 2dup ] prepend [ t ] ] f short-circuit [ 2nip ] append ;
 
 MACRO: 3|| ( quots -- ? )
-  [ [ 2dup ] prepend [ t ] ] f short-circuit [ 2nip ] append ;
+  [ [ 3dup ] prepend [ t ] ] f short-circuit [ 3nip ] append ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 ! ifte

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,8 +199,8 @@ 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 ;
+    >r { "localhost" "postgres" "foob" "factor-test" } postgresql-db r> with-db ;
 
 : test-repeated-insert
     [ ] [ person ensure-table ] unit-test
@@ -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,10 +80,6 @@ SYMBOL: NX
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-ERROR: name-error name ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
 : cache-get ( query -- rrs/f )
   dup cache-get* dup NX = [ drop name>> name-error ] [ nip ] if ;
 

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

@@ -2,10 +2,12 @@
 USING: kernel
        combinators
        vectors
+       sequences
        io.sockets
        accessors
+       combinators.lib
        newfx
-       dns dns.cache ;
+       dns dns.cache dns.misc ;
 
 IN: dns.forwarding
 
@@ -17,7 +19,10 @@ IN: dns.forwarding
 
 : socket ( -- socket ) (socket) 1st ;
 
-: init-socket ( -- ) f 5353 <inet4> <datagram> 0 (socket) as-mutate ;
+: init-socket-on-port ( port -- )
+  f swap <inet4> <datagram> 0 (socket) as-mutate ;
+
+: init-socket ( -- ) 53 init-socket-on-port ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
@@ -27,30 +32,37 @@ IN: dns.forwarding
 
 : set-upstream-server ( ip -- ) 0 (upstream-server) as-mutate ;
 
+: init-upstream-server ( -- )
+  upstream-server not
+    [ resolv-conf-server set-upstream-server ]
+  when ;
+
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
+: 1&& <-&& ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: rrs? ( obj -- ? ) { [ NX = not ] [ f = not ] } 1&& ;
+
 : query->answer/cache ( query -- rrs/NX/f )
-    {
+  dup cache-get* dup { [ rrs? ] [ NX = ] } 1||
-      { [ dup type>> CNAME = ] [ cache-get* ] }
+    [ nip ]
-      {
-        [ dup clone CNAME >>type cache-get* vector? ]
     [
-          dup clone CNAME >>type cache-get* 1st       ! query rr/cname
+      drop
-          dup rdata>>                                 ! query rr/cname cname
+      dup clone CNAME >>type cache-get* dup { [ NX = ] [ f = ] } 1||
-          >r swap clone r>                            ! rr/cname query cname
+        [ nip ]
-          >>name                                      ! rr/cname query
+        [                                       ! query rrs
-          query->answer/cache                         ! rr/cname rrs/NX/f
+          tuck                                  ! rrs query rrs
-            {
+          1st                                   ! rrs query rr/cname
-              { [ dup vector? ] [ clone push-on ] }
+          rdata>>                               ! rrs query name
-              { [ dup NX = ]    [ nip ] }
+          >r clone r> >>name                    ! rrs query
-              { [ dup f = ]     [ nip ] }
+          query->answer/cache                   ! rrs rrs/NX/f
-            }
+          dup rrs? [ append ] [ nip ] if
-          cond
         ]
-      }
+      if
-      { [ t ] [ cache-get* ] }
+    ]
-    }
+  if ;
-  cond ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
@@ -89,3 +101,9 @@ IN: dns.forwarding
   swap                                        ! byte-array addr-spec
   socket send
   loop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: start ( -- ) init-socket init-upstream-server loop ;
+
+MAIN: start

extra/dns/misc/misc.factor

@@ -0,0 +1,12 @@
+
+USING: kernel sequences splitting io.files io.encodings.utf8 random newfx ;
+
+IN: dns.misc
+
+: resolv-conf-servers ( -- seq )
+  "/etc/resolv.conf" utf8 file-lines
+  [ " " split ] map
+  [ 1st "nameserver" = ] filter
+  [ 2nd ] map ;
+
+: resolv-conf-server ( -- ip ) resolv-conf-servers random ;

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