Merge branch 'master' of 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
-words strings alien byte-array ;
+USING: help.syntax help.markup math kernel
+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
-    ] time ;
+    ascii [ parse-model ] with-file-reader
+    [ normals ] 2keep 3array ;
 
 : model-path "bun_zipper.ply" temp-file ;
 

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,9 +1,8 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel math namespaces sequences random
-strings
-math.bitfields.lib namespaces.lib db db.tuples db.types
-math.intervals ;
+strings math.parser math.intervals combinators
+math.bitfields.lib namespaces.lib db db.tuples db.types ;
 IN: db.queries
 
 GENERIC: where ( specs obj -- )
@@ -15,7 +14,7 @@ GENERIC: where ( specs obj -- )
 
 : 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 +126,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 }
+        {
+            { 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 -- * )
-    sqlite-error-messages nth throw ;
+ERROR: sqlite-error < db-error n string ;
+ERROR: sqlite-sql-error < sql-error n string ;
 
-: sqlite-statement-error-string ( -- str )
-    db get db-handle sqlite3_errmsg ;
+: throw-sqlite-error ( n -- * )
+    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 ] }
-        { [ dup SQLITE_ERROR = ] [ sqlite-statement-error ] }
-        [ sqlite-error ]
-    } cond ;
+        { SQLITE_OK [ ] }
+        { SQLITE_ERROR [ sqlite-statement-error ] }
+        [ throw-sqlite-error ]
+    } 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
-    ] [
-        dup SQLITE_DONE =
-        [ drop ] [ sqlite-check-result ] if f
-    ] if ;
+    {
+        { SQLITE_ROW [ t ] }
+        { SQLITE_DONE [ f ] }
+        [ sqlite-check-result f ]
+    } case ;
 
 : 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,9 +199,10 @@ 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 ( -- )
->r { "localhost" "postgres" "foob" "factor-test" } postgresql-db r> with-db ;
+! : test-postgresql ( quot -- )
+!     >r { "localhost" "postgres" "foob" "factor-test" } postgresql-db r> with-db ;
 
+: test-postgresql drop ;
 : test-repeated-insert
     [ ] [ person ensure-table ] unit-test
     [ ] [ person1 get insert-tuple ] unit-test
@@ -224,6 +226,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 +423,7 @@ TUPLE: does-not-persist ;
 ] test-postgresql
 
 
-TUPLE: suparclass a ;
+TUPLE: suparclass id a ;
 
 suparclass f {
     { "id" "ID" +db-assigned-id+ }
@@ -428,8 +436,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 )
-    dup first class>> new [
+: resulting-tuple ( class row out-params -- tuple )
+    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 -- )
@@ -141,9 +143,12 @@ M: retryable execute-statement* ( statement type -- )
         [ bind-tuple ] keep execute-statement
     ] with-disposal ;
 
-: select-tuples ( tuple -- tuples )
-    dup dup class <select-by-slots-statement> [
-        [ bind-tuple ] keep query-tuples
-    ] with-disposal ;
+: do-select ( exemplar-tuple statement -- tuples )
+    [ [ bind-tuple ] [ query-tuples ] 2bi ] 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/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
-        [ 1array ] [ expected-io-error? ] bi
-        [ r> 2drop f ] [ r> resume-callback t ] if
+        dup [
+            >r drop GetLastError 1array r> resume-callback t
+        ] [
+            2drop f
+        ] if
     ] [
         resume-callback t
     ] if ;

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
-SYMBOL: NOTICE
-SYMBOL: WARNING
-SYMBOL: ERROR
-SYMBOL: CRITICAL
+SYMBOLS: DEBUG NOTICE WARNING ERROR CRITICAL ;
 
-: log-levels
-    { DEBUG NOTICE NOTICE WARNING ERROR CRITICAL } ;
+: log-levels { DEBUG NOTICE NOTICE WARNING ERROR CRITICAL } ;
 
 : send-to-log-server ( array string -- )
     prefix "log-server" get send ;
 
 SYMBOL: log-service
 
-: check-log-message
-    pick string?
-    pick word?
-    pick word? and and
-    [ "Bad parameters to log-message" throw ] unless ;
+: check-log-message ( msg word level -- msg word level )
+    3dup [ string? ] [ word? ] [ word? ] tri* and and
+    [ "Bad parameters to log-message" throw ] unless ; inline
 
 : 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
-        r> r> log-message
+        [ [ ndup ] keep narray stack>message ] 2dip 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 )
-    >r dup effect-in length r> [ over >r ERROR log-stack r> ndrop ] 2curry
-    swap effect-out length f <repetition> append >quotation ;
+: stack-balancer ( effect -- quot )
+    [ in>> length [ ndrop ] curry ]
+    [ out>> length f <repetition> >quotation ]
+    bi append ;
 
 : error-logging-quot ( quot word -- quot' )
-    [ [ log-error ] curry ] keep
-    [ stack-effect ] keep stack-balancer compose
-    [ recover ] 2curry ;
+    dup stack-effect stack-balancer
+    '[ , [ , log-error @ ] recover ] ;
 
 : 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
-    dup scan-word
-    [ >r >r 1array stack>message r> r> log-message ] 2curry
+    CREATE-WORD dup scan-word
+    '[ 1array stack>message , , log-message ]
     define ; parsing

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
-    [ status +stopped+ eq? ]
-    [ [ drop f ] handle-synchronous ]
-    [ ] while ;
+    +stopped+ set-status ;
 
 : step-into-all-loop ( -- )
     +running+ set-status

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+ }
-    { "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+ }
+    { "parent" "PARENT" INTEGER +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 ]
-    [ aid>> number>string "#" prepend ] bi
+    [ parent>> "parent" associate "$pastebin/paste" swap link>string ]
+    [ 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" param "$pastebin/paste" <id-redirect> ] >>display
+        [
+            { { "id" [ v-integer ] } } validate-params
+            "id" value "$pastebin/paste" <id-redirect>
+        ] >>display
 
         [
-            f f <annotation>
-            {
-                [ deposit-paste-slots ]
-                [ { "id" } deposit-slots ]
-                [ insert-tuple ]
-                [
-                    ! Add anchor here
-                    id>> "$pastebin/paste" <id-redirect>
-                ]
-            } cleave
+            { { "id" [ v-integer ] } } validate-params
+            validate-entity
+        ] >>validate
+
+        [
+            "id" value f <annotation>
+            [ deposit-entity-slots ]
+            [ insert-tuple ]
+            [
+                ! Add anchor here
+                parent>> "$pastebin/paste" <id-redirect>
+            ]
+            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))
-		| (to_fixnum(array_nth(quadruple,1)) << 8));
-	CELL rel_offset = array_nth(quadruple,3) * compiled_code_format();
+	F_REL rel;
+	rel.type = to_fixnum(array_nth(quadruple,2)) | (to_fixnum(array_nth(quadruple,1)) << 8);
+	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));
 }