Merge git://factorcode.org/git/factor

core/alien/compiler/compiler.factor

@@ -367,7 +367,7 @@ TUPLE: callback-context ;
     ] if ;
 
 : do-callback ( quot token -- )
-    init-error-handler
+    init-catchstack
     dup 2 setenv
     slip
     wait-to-return ; inline

core/bootstrap/stage1.factor

@@ -1,11 +1,11 @@
-! Copyright (C) 2004, 2007 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: bootstrap.stage1
 USING: arrays debugger generic hashtables io assocs
 kernel.private kernel math memory namespaces parser
 prettyprint sequences vectors words system splitting
 init io.files bootstrap.image bootstrap.image.private vocabs
-vocabs.loader system ;
+vocabs.loader system debugger continuations ;
 
 { "resource:core" } vocab-roots set
 
@@ -40,7 +40,14 @@ vocabs.loader system ;
     [
         "resource:core/bootstrap/stage2.factor"
         dup resource-exists? [
-            run-file
+            [ run-file ]
+            [
+                :c
+                dup print-error flush
+                "listener" vocab
+                [ restarts. vocab-main execute ]
+                [ die ] if*
+            ] recover
         ] [
             "Cannot find " write write "." print
             "Please move " write image write " to the same directory as the Factor sources," print

core/bootstrap/stage2.factor

@@ -51,66 +51,60 @@ SYMBOL: bootstrap-time
 ! Wrap everything in a catch which starts a listener so
 ! you can see what went wrong, instead of dealing with a
 ! fep
-[
-    ! We time bootstrap
-    millis >r
 
-    default-image-name "output-image" set-global
+! We time bootstrap
+millis >r
 
-    "math help handbook compiler tools ui ui.tools io" "include" set-global
+default-image-name "output-image" set-global
-    "" "exclude" set-global
 
-    parse-command-line
+"math help handbook compiler tools ui ui.tools io" "include" set-global
+"" "exclude" set-global
 
-    "-no-crossref" cli-args member? [ do-crossref ] unless
+parse-command-line
 
-    ! Set dll paths
+"-no-crossref" cli-args member? [ do-crossref ] unless
-    wince? [ "windows.ce" require ] when
-    winnt? [ "windows.nt" require ] when
 
-    "deploy-vocab" get [
+! Set dll paths
-        "stage2: deployment mode" print
+wince? [ "windows.ce" require ] when
-    ] [
+winnt? [ "windows.nt" require ] when
-        "listener" require
-        "none" require
-    ] if
 
-    [
+"deploy-vocab" get [
-        load-components
+    "stage2: deployment mode" print
-
-        run-bootstrap-init
-
-        "bootstrap.compiler" vocab [
-            compile-remaining
-        ] when
-    ] with-compiler-errors
-    :errors
-
-    f error set-global
-    f error-continuation set-global
-
-    "deploy-vocab" get [
-        "tools.deploy.shaker" run
-    ] [
-        [
-            boot
-            do-init-hooks
-            [
-                parse-command-line
-                run-user-init
-                "run" get run
-                stdio get [ stream-flush ] when*
-            ] [ print-error 1 exit ] recover
-        ] set-boot-quot
-
-        millis r> - dup bootstrap-time set-global
-        print-report
-
-        "output-image" get resource-path save-image-and-exit
-    ] if
 ] [
-    :c
+    "listener" require
-    print-error restarts.
+    "none" require
-    "listener" vocab-main execute
+] if
-    1 exit
+
-] recover
+[
+    load-components
+
+    run-bootstrap-init
+
+    "bootstrap.compiler" vocab [
+        compile-remaining
+    ] when
+] with-compiler-errors
+:errors
+
+f error set-global
+f error-continuation set-global
+
+"deploy-vocab" get [
+    "tools.deploy.shaker" run
+] [
+    [
+        boot
+        do-init-hooks
+        [
+            parse-command-line
+            run-user-init
+            "run" get run
+            stdio get [ stream-flush ] when*
+        ] [ print-error 1 exit ] recover
+    ] set-boot-quot
+
+    millis r> - dup bootstrap-time set-global
+    print-report
+
+    "output-image" get resource-path save-image-and-exit
+] if

core/continuations/continuations-docs.factor

@@ -193,6 +193,3 @@ HELP: save-error
 { $values { "error" "an error" } }
 { $description "Called by the error handler to set the " { $link error } " and " { $link restarts } " global variables after an error was thrown." }
 $low-level-note ;
-
-HELP: init-error-handler
-{ $description "Called on startup to initialize the catch stack and set a pair of hooks which allow the Factor VM to signal errors to library code." } ;

core/continuations/continuations.factor

@@ -6,6 +6,7 @@ IN: continuations
 
 SYMBOL: error
 SYMBOL: error-continuation
+SYMBOL: error-thread
 SYMBOL: restarts
 
 <PRIVATE
@@ -24,6 +25,8 @@ SYMBOL: restarts
     #! with a declaration.
     f { object } declare ;
 
+: init-catchstack V{ } clone 1 setenv ;
+
 PRIVATE>
 
 : catchstack ( -- catchstack ) catchstack* clone ; inline
@@ -169,17 +172,3 @@ M: condition compute-restarts
     condition-continuation
     [ <restart> ] curry { } assoc>map
     append ;
-
-<PRIVATE
-
-: init-error-handler ( -- )
-    V{ } clone set-catchstack
-    ! VM calls on error
-    [
-        continuation error-continuation set-global rethrow
-    ] 5 setenv
-    ! VM adds this to kernel errors, so that user-space
-    ! can identify them
-    "kernel-error" 6 setenv ;
-
-PRIVATE>

core/debugger/debugger-docs.factor

@@ -1,6 +1,6 @@
 USING: alien arrays generic generic.math help.markup help.syntax
 kernel math memory strings sbufs vectors io io.files classes
-help generic.standard continuations system ;
+help generic.standard continuations system debugger.private ;
 IN: debugger
 
 ARTICLE: "errors-assert" "Assertions"
@@ -80,9 +80,6 @@ HELP: print-error
 HELP: restarts.
 { $description "Print a list of restarts for the most recently thrown error to the " { $link stdio } " stream." } ;
 
-HELP: debug-help
-{ $description "Print a synopsis of useful debugger words." } ;
-
 HELP: error-hook
 { $var-description "A quotation with stack effect " { $snippet "( error -- )" } " which is used by " { $link try } " to report the error to the user." }
 { $examples "The default value prints the error with " { $link print-error } ", followed by a list of restarts and a help message. The graphical listener sets this variable to display a popup instead." } ;
@@ -169,3 +166,6 @@ HELP: depth
 HELP: assert-depth
 { $values { "quot" "a quotation" } }
 { $description "Runs a quotation. Throws an error if the total number of elements on the stack is not the same before and after the quotation runs." } ;
+
+HELP: init-debugger
+{ $description "Called on startup to set a pair of hooks which allow the " { $link throw } " word to function." } ;

core/debugger/debugger.factor

@@ -5,7 +5,8 @@ math namespaces prettyprint sequences assocs sequences.private
 strings io.styles vectors words system splitting math.parser
 tuples continuations continuations.private combinators
 generic.math io.streams.duplex classes compiler.units
-generic.standard vocabs ;
+generic.standard vocabs threads threads.private init
+kernel.private ;
 IN: debugger
 
 GENERIC: error. ( error -- )
@@ -57,27 +58,30 @@ M: string error. print ;
         dup length [ restart. ] 2each
     ] if ;
 
-: debug-help ( -- )
-    nl
-    "Debugger commands:" print
-    nl
-    ":help - documentation for this error" print
-    ":s    - data stack at exception time" print
-    ":r    - retain stack at exception time" print
-    ":c    - call stack at exception time" print
-    ":edit - jump to source location (parse errors only)" print
-
-    ":get  ( var -- value ) accesses variables at time of the error" print
-    flush ;
-
 : print-error ( error -- )
     [ error. flush ] curry
     [ global [ "Error in print-error!" print drop ] bind ]
     recover ;
 
+: error-in-thread. ( -- )
+    error-thread get-global
+    "Error in thread " write
+    [
+        dup thread-id #
+        " (" % dup thread-name %
+        ", " % dup thread-quot unparse-short % ")" %
+    ] "" make
+    swap write-object ":" print nl ;
+
 SYMBOL: error-hook
 
-[ print-error restarts. debug-help ] error-hook set-global
+[
+    error-in-thread.
+    print-error
+    restarts.
+    nl
+    "Type :help for debugging help." print flush
+] error-hook set-global
 
 : try ( quot -- )
     [ error-hook get call ] recover ;
@@ -260,3 +264,31 @@ M: no-compilation-unit error.
 
 M: no-vocab summary
     drop "Vocabulary does not exist" ;
+
+! Hooks
+M: thread error-in-thread ( error thread -- )
+    initial-thread get-global eq? [
+        die drop
+    ] [
+        global [
+            error-in-thread. print-error flush
+        ] bind
+    ] if ;
+
+<PRIVATE
+
+: init-debugger ( -- )
+    V{ } clone set-catchstack
+    ! VM calls on error
+    [
+        self error-thread set-global
+        continuation error-continuation set-global
+        rethrow
+    ] 5 setenv
+    ! VM adds this to kernel errors, so that user-space
+    ! can identify them
+    "kernel-error" 6 setenv ;
+
+PRIVATE>
+
+[ init-debugger ] "debugger" add-init-hook

core/init/init-tests.factor

@@ -0,0 +1,7 @@
+IN: temporary
+USING: init namespaces sequences math tools.test kernel ;
+
+[ t ] [
+    init-hooks get [ first "libc" = ] find drop
+    init-hooks get [ first "io.backend" = ] find drop <
+] unit-test

core/init/init.factor

@@ -15,7 +15,7 @@ init-hooks global [ drop V{ } clone ] cache drop
     dup init-hooks get at [ over call ] unless
     init-hooks get set-at ;
 
-: boot ( -- ) init-namespaces init-error-handler ;
+: boot ( -- ) init-namespaces init-catchstack ;
 
 : boot-quot ( -- quot ) 20 getenv ;
 

core/libc/libc.factor

@@ -46,7 +46,7 @@ M: realloc-error summary drop "Memory reallocation failed" ;
 
 <PRIVATE
 
-[ H{ } clone mallocs set-global ] "mallocs" add-init-hook
+[ H{ } clone mallocs set-global ] "libc" add-init-hook
 
 : add-malloc ( alien -- )
     dup mallocs get-global set-at ;

core/sequences/sequences-docs.factor

@@ -429,7 +429,7 @@ HELP: collect
 
 HELP: each
 { $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- )" } } }
-{ $description "Applies the quotation to each element of the sequence in turn." } ;
+{ $description "Applies the quotation to each element of the sequence in order." } ;
 
 HELP: reduce
 { $values { "seq" sequence } { "identity" object } { "quot" "a quotation with stack effect " { $snippet "( prev elt -- next )" } } { "result" "the final result" } }
@@ -447,7 +447,7 @@ HELP: accumulate
 
 HELP: map
 { $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( old -- new )" } } { "newseq" "a new sequence" } }
-{ $description "Applies the quotation to each element yielding a new element. The new elements are collected into a sequence of the same class as the input sequence." } ;
+{ $description "Applies the quotation to each element of the sequence in order. The new elements are collected into a sequence of the same class as the input sequence." } ;
 
 HELP: change-nth
 { $values { "i" "a non-negative integer" } { "seq" "a mutable sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- newelt )" } } }

core/threads/threads.factor

@@ -4,13 +4,12 @@
 IN: threads
 USING: arrays hashtables heaps kernel kernel.private math
 namespaces sequences vectors continuations continuations.private
-dlists assocs system combinators debugger prettyprint io init
+dlists assocs system combinators init boxes ;
-boxes ;
 
 SYMBOL: initial-thread
 
 TUPLE: thread
-name quot error-handler exit-handler
+name quot exit-handler
 id
 continuation state
 mailbox variables sleep-entry ;
@@ -60,11 +59,10 @@ threads global [ H{ } assoc-like ] change-at
 
 PRIVATE>
 
-: <thread> ( quot name error-handler -- thread )
+: <thread> ( quot name -- thread )
     \ thread counter <box> [ ] {
         set-thread-quot
         set-thread-name
-        set-thread-error-handler
         set-thread-id
         set-thread-continuation
         set-thread-exit-handler
@@ -179,20 +177,8 @@ M: real sleep
         ] 1 (throw)
     ] "spawn" suspend 2drop ;
 
-: default-thread-error-handler ( error thread -- )
-    global [
-        "Error in thread " write
-        dup thread-id pprint
-        " (" write
-        dup thread-name pprint ")" print
-        "spawned to call " write
-        thread-quot short.
-        nl
-        print-error flush
-    ] bind ;
-
 : spawn ( quot name -- thread )
-    [ default-thread-error-handler ] <thread> [ (spawn) ] keep ;
+    <thread> [ (spawn) ] keep ;
 
 : spawn-server ( quot name -- thread )
     >r [ [ ] [ ] while ] curry r> spawn ;
@@ -202,6 +188,8 @@ M: real sleep
     [ >r set-namestack set-datastack r> call ] 3curry
     "Thread" spawn drop ;
 
+GENERIC: error-in-thread ( error thread -- )
+
 <PRIVATE
 
 : init-threads ( -- )
@@ -209,13 +197,13 @@ M: real sleep
     <dlist> 42 setenv
     <min-heap> 43 setenv
     initial-thread global
-    [ drop f "Initial" [ die ] <thread> ] cache
+    [ drop f "Initial" <thread> ] cache
     <box> over set-thread-continuation
     f over set-thread-state
     dup register-thread
     set-self ;
 
-[ self dup thread-error-handler call stop ]
+[ self error-in-thread stop ]
 thread-error-hook set-global
 
 PRIVATE>

extra/benchmark/crc32/crc32.factor

@@ -0,0 +1,10 @@
+USING: io.crc32 io.files kernel math ;
+IN: benchmark.crc32
+
+: crc32-primes-list ( -- )
+    10 [
+        "extra/math/primes/list/list.factor" resource-path
+        file-contents crc32 drop
+    ] times ;
+
+MAIN: crc32-primes-list

extra/benchmark/md5/md5.factor

@@ -0,0 +1,7 @@
+USING: crypto.md5 io.files kernel ;
+IN: benchmark.md5
+
+: md5-primes-list ( -- )
+    "extra/math/primes/list/list.factor" resource-path file>md5 drop ;
+
+MAIN: md5-primes-list

extra/benchmark/random/random.factor

@@ -0,0 +1,14 @@
+USING: io.files random math.parser io math ;
+IN: benchmark.random
+
+: random-numbers-path "random-numbers.txt" temp-file ;
+
+: write-random-numbers ( n -- )
+    random-numbers-path [
+        [ 200 random 100 - number>string print ] times
+    ] with-file-writer ;
+
+: random-main ( -- )
+    1000000 write-random-numbers ;
+
+MAIN: random-main

extra/benchmark/sort/sort.factor

@@ -1,7 +1,8 @@
-USING: kernel sequences sorting random ;
+USING: kernel sequences sorting benchmark.random math.parser
+io.files ;
 IN: benchmark.sort
 
 : sort-benchmark
-    100000 [ drop 100000 random ] map natural-sort drop ;
+    random-numbers-path file-lines [ string>number ] map natural-sort drop ;
 
 MAIN: sort-benchmark

extra/benchmark/sum-file/sum-file.factor

@@ -1,4 +1,5 @@
-USING: io io.files math math.parser kernel prettyprint ;
+USING: io io.files math math.parser kernel prettyprint
+benchmark.random ;
 IN: benchmark.sum-file
 
 : sum-file-loop ( n -- n' )
@@ -8,6 +9,6 @@ IN: benchmark.sum-file
     [ 0 sum-file-loop ] with-file-reader . ;
 
 : sum-file-main ( -- )
-    home "sum-file-in.txt" path+ sum-file ;
+    random-numbers-path sum-file ;
 
 MAIN: sum-file-main

extra/concurrency/combinators/combinators-tests.factor

@@ -11,7 +11,7 @@ concurrency.mailboxes threads sequences ;
 [ { 1 4 9 } ] [ { 1 2 3 } [ 1000 random sleep sq ] parallel-map ] unit-test
 
 [ { 1 2 3 } [ dup 2 mod 0 = [ "Even" throw ] when ] parallel-map ]
-[ linked-error "Even" = ] must-fail-with
+[ delegate "Even" = ] must-fail-with
 
 [ V{ 0 3 6 9 } ]
 [ 10 [ 3 mod zero? ] parallel-subset ] unit-test

extra/concurrency/flags/flags-docs.factor

@@ -14,6 +14,10 @@ HELP: raise-flag
 { $values { "flag" flag } }
 { $description "Raises a flag, notifying any threads waiting on it. Does nothing if the flag has already been raised." } ;
 
+HELP: wait-for-flag
+{ $values { "flag" flag } }
+{ $description "Waits for a flag to be raised. If the flag has already been raised, returns immediately." } ;
+
 HELP: lower-flag
 { $values { "flag" flag } }
 { $description "Attempts to lower a flag. If the flag has been raised previously, returns immediately, otherwise waits for it to be raised first." } ;
@@ -26,8 +30,9 @@ $nl
 "Essentially, a flag can be thought of as a counting semaphore where the count never goes above one."
 { $subsection flag }
 { $subsection flag? }
-"Raising and lowering flags:"
+"Waiting for a flag to be raised:"
 { $subsection raise-flag }
+{ $subsection wait-for-flag }
 { $subsection lower-flag } ;
 
 ABOUT: "concurrency.flags"

extra/concurrency/flags/flags.factor

@@ -13,9 +13,14 @@ TUPLE: flag value? thread ;
         [ resume ] [ drop t over set-flag-value? ] if
     ] unless drop ;
 
+: wait-for-flag ( flag -- )
+    dup flag-value? [ drop ] [
+        [ flag-thread >box ] curry "flag" suspend drop
+    ] if ;
+
 : lower-flag ( flag -- )
     dup flag-value? [
         f swap set-flag-value?
     ] [
-        [ flag-thread >box ] curry "flag" suspend drop
+        wait-for-flag
     ] if ;

extra/concurrency/locks/locks-tests.factor

@@ -174,5 +174,5 @@ threads sequences calendar ;
     ] ;
 
 [ lock-timeout-test ] [
-    linked-thread thread-name "Lock timeout-er" =
+    linked-error-thread thread-name "Lock timeout-er" =
 ] must-fail-with

extra/concurrency/mailboxes/mailboxes.factor

@@ -65,12 +65,23 @@ TUPLE: mailbox threads data ;
 : mailbox-get? ( pred mailbox -- obj )
     f mailbox-get-timeout? ; inline
 
-TUPLE: linked error thread ;
+TUPLE: linked-error thread ;
 
-C: <linked> linked
+: <linked-error> ( error thread -- linked )
+    { set-delegate set-linked-error-thread }
+    linked-error construct ;
 
-: ?linked dup linked? [ rethrow ] when ;
+: ?linked dup linked-error? [ rethrow ] when ;
+
+TUPLE: linked-thread supervisor ;
+
+M: linked-thread error-in-thread
+    [ <linked-error> ] keep
+    linked-thread-supervisor mailbox-put ;
+
+: <linked-thread> ( quot name mailbox -- thread' )
+    >r <thread> linked-thread construct-delegate r>
+    over set-linked-thread-supervisor ;
 
 : spawn-linked-to ( quot name mailbox -- thread )
-    [ >r <linked> r> mailbox-put ] curry <thread>
+    <linked-thread> [ (spawn) ] keep ;
-    [ (spawn) ] keep ;

extra/concurrency/messaging/messaging-tests.factor

@@ -29,7 +29,7 @@ IN: temporary
         "crash" throw
     ] "Linked test" spawn-linked drop
     receive
-] [ linked-error "crash" = ] must-fail-with
+] [ delegate "crash" = ] must-fail-with
 
 MATCH-VARS: ?from ?to ?value ;
 SYMBOL: increment

extra/concurrency/messaging/messaging.factor

@@ -32,7 +32,7 @@ M: thread send ( message thread -- )
     my-mailbox swap mailbox-get-timeout? ?linked ; inline
 
 : rethrow-linked ( error process supervisor -- )
-    >r <linked> r> send ;
+    >r <linked-error> r> send ;
 
 : spawn-linked ( quot name -- thread )
     my-mailbox spawn-linked-to ;

extra/db/db.factor

@@ -5,29 +5,36 @@ namespaces sequences sequences.lib tuples words strings
 tools.walker ;
 IN: db
 
-TUPLE: db handle ;
+TUPLE: db
-! TUPLE: db handle insert-statements update-statements delete-statements ;
+    handle
+    insert-statements
+    update-statements
+    delete-statements ;
+
 : <db> ( handle -- obj )
-    ! H{ } clone H{ } clone H{ } clone
+    H{ } clone H{ } clone H{ } clone
     db construct-boa ;
 
 GENERIC: make-db* ( seq class -- db )
-: make-db ( seq class -- db ) construct-empty make-db* ;
 GENERIC: db-open ( db -- )
 HOOK: db-close db ( handle -- )
+: make-db ( seq class -- db ) construct-empty make-db* ;
 
 : dispose-statements ( seq -- )
     [ dispose drop ] assoc-each ;
 
 : dispose-db ( db -- ) 
     dup db [
-        ! dup db-insert-statements dispose-statements
+        dup db-insert-statements dispose-statements
-        ! dup db-update-statements dispose-statements
+        dup db-update-statements dispose-statements
-        ! dup db-delete-statements dispose-statements
+        dup db-delete-statements dispose-statements
         db-handle db-close
     ] with-variable ;
 
 TUPLE: statement handle sql in-params out-params bind-params bound? ;
+TUPLE: simple-statement ;
+TUPLE: prepared-statement ;
+TUPLE: result-set sql params handle n max ;
 : <statement> ( sql in out -- statement )
     {
         set-statement-sql
@@ -35,17 +42,11 @@ TUPLE: statement handle sql in-params out-params bind-params bound? ;
         set-statement-out-params
     } statement construct ;
 
-TUPLE: simple-statement ;
-TUPLE: prepared-statement ;
-
 HOOK: <simple-statement> db ( str in out -- statement )
 HOOK: <prepared-statement> db ( str in out -- statement )
 GENERIC: prepare-statement ( statement -- )
-GENERIC: bind-statement* ( obj statement -- )
+GENERIC: bind-statement* ( statement -- )
-GENERIC: reset-statement ( statement -- )
 GENERIC: bind-tuple ( tuple statement -- )
-
-TUPLE: result-set sql params handle n max ;
 GENERIC: query-results ( query -- result-set )
 GENERIC: #rows ( result-set -- n )
 GENERIC: #columns ( result-set -- n )
@@ -61,9 +62,8 @@ GENERIC: more-rows? ( result-set -- ? )
     ] if ;
 
 : bind-statement ( obj statement -- )
-    dup statement-bound? [ dup reset-statement ] when
-    [ bind-statement* ] 2keep
     [ set-statement-bind-params ] keep
+    [ bind-statement* ] keep
     t swap set-statement-bound? ;
 
 : init-result-set ( result-set -- )
@@ -104,7 +104,6 @@ GENERIC: more-rows? ( result-set -- ? )
 : do-bound-command ( obj query -- )
     [ bind-statement ] keep execute-statement ;
 
-
 SYMBOL: in-transaction
 HOOK: begin-transaction db ( -- )
 HOOK: commit-transaction db ( -- )

extra/db/postgresql/postgresql.factor

@@ -38,10 +38,7 @@ M: postgresql-db db-open ( db -- )
 M: postgresql-db dispose ( db -- )
     db-handle PQfinish ;
 
-M: postgresql-statement bind-statement* ( seq statement -- )
+M: postgresql-statement bind-statement* ( statement -- )
-    set-statement-bind-params ;
-
-M: postgresql-statement reset-statement ( statement -- )
     drop ;
 
 M: postgresql-statement bind-tuple ( tuple statement -- )

extra/db/sqlite/sqlite.factor

@@ -4,7 +4,8 @@ USING: alien arrays assocs classes compiler db
 hashtables io.files kernel math math.parser namespaces
 prettyprint sequences strings tuples alien.c-types
 continuations db.sqlite.lib db.sqlite.ffi db.tuples
-words combinators.lib db.types combinators tools.walker ;
+words combinators.lib db.types combinators tools.walker
+combinators.cleave ;
 IN: db.sqlite
 
 TUPLE: sqlite-db path ;
@@ -29,14 +30,13 @@ M: sqlite-db <simple-statement> ( str -- obj )
     <prepared-statement> ;
 
 M: sqlite-db <prepared-statement> ( str -- obj )
-    db get db-handle 
     {
         set-statement-sql
         set-statement-in-params
         set-statement-out-params
-        set-statement-handle
     } statement construct
-    dup statement-handle over statement-sql sqlite-prepare
+    db get db-handle over statement-sql sqlite-prepare
+    over set-statement-handle
     sqlite-statement construct-delegate ;
 
 M: sqlite-statement dispose ( statement -- )
@@ -45,20 +45,32 @@ M: sqlite-statement dispose ( statement -- )
 M: sqlite-result-set dispose ( result-set -- )
     f swap set-result-set-handle ;
 
-: sqlite-bind ( specs handle -- )
+: sqlite-bind ( triples handle -- )
-    swap [ sqlite-bind-type ] with each ;
+    swap [ first3 sqlite-bind-type ] with each ;
 
-M: sqlite-statement bind-statement* ( obj statement -- )
+: reset-statement ( statement -- )
-    statement-handle sqlite-bind ;
-
-M: sqlite-statement reset-statement ( statement -- )
     statement-handle sqlite-reset ;
 
+M: sqlite-statement bind-statement* ( statement -- )
+    dup statement-bound? [ dup reset-statement ] when
+    [ statement-bind-params ] [ statement-handle ] bi sqlite-bind ;
+
+M: sqlite-statement bind-tuple ( tuple statement -- )
+    [
+        statement-in-params
+        [
+            [ sql-spec-column-name ":" swap append ]
+            [ sql-spec-slot-name rot get-slot-named ]
+            [ sql-spec-type ] tri 3array
+        ] with map
+    ] keep
+    [ set-statement-bind-params ] keep bind-statement* ;
+
 : last-insert-id ( -- id )
     db get db-handle sqlite3_last_insert_rowid
     dup zero? [ "last-id failed" throw ] when ;
 
-M: sqlite-statement insert-tuple* ( tuple statement -- )
+M: sqlite-db insert-tuple* ( tuple statement -- )
     execute-statement last-insert-id swap set-primary-key ;
 
 M: sqlite-result-set #columns ( result-set -- n )
@@ -78,7 +90,6 @@ M: sqlite-result-set more-rows? ( result-set -- ? )
     sqlite-result-set-has-more? ;
 
 M: sqlite-statement query-results ( query -- result-set )
-break
     dup statement-handle sqlite-result-set <result-set>
     dup advance-row ;
 
@@ -127,7 +138,7 @@ M: sqlite-db <insert-assigned-statement> ( tuple -- statement )
 
 : where-primary-key% ( specs -- )
     " where " 0%
-    find-primary-key sql-spec-column-name dup 0% " = " 0% bind% ;
+    find-primary-key dup sql-spec-column-name 0% " = " 0% bind% ;
 
 M: sqlite-db <update-tuple-statement> ( class -- statement )
     [
@@ -135,7 +146,7 @@ M: sqlite-db <update-tuple-statement> ( class -- statement )
         0%
         " set " 0%
         dup remove-id
-        [ ", " 0% ] [ sql-spec-column-name dup 0% " = " 0% bind% ] interleave
+        [ ", " 0% ] [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave
         where-primary-key%
     ] sqlite-make ;
 
@@ -144,7 +155,7 @@ M: sqlite-db <delete-tuple-statement> ( specs table -- sql )
         "delete from " 0% 0%
         " where " 0%
         find-primary-key
-        sql-spec-column-name dup 0% " = " 0% bind%
+        dup sql-spec-column-name 0% " = " 0% bind%
     ] sqlite-make ;
 
 ! : select-interval ( interval name -- ) ;
@@ -152,8 +163,6 @@ M: sqlite-db <delete-tuple-statement> ( specs table -- sql )
 
 M: sqlite-db bind% ( spec -- )
     dup 1, sql-spec-column-name ":" swap append 0% ;
-    ! dup 1, sql-spec-column-name
-    ! dup 0% " = " 0% ":" swap append 0% ;
 
 M: sqlite-db <select-by-slots-statement> ( tuple class -- statement )
     [
@@ -201,7 +210,3 @@ M: sqlite-db type-table ( -- assoc )
 
 M: sqlite-db create-type-table
     type-table ;
-
-! HOOK: get-column-value ( n result-set type -- )
-! M: sqlite get-column-value { { "TEXT" get-text-column } { 
-! "INTEGER" get-integer-column } ... } case ;

extra/db/tuples/tuples-tests.factor

@@ -22,8 +22,9 @@ SYMBOL: the-person2
 : test-tuples ( -- )
     [ person drop-table ] [ drop ] recover
     [ ] [ person create-table ] unit-test
+    [ person create-table ] must-fail
     
-    [  ] [ the-person1 get insert-tuple ] unit-test
+    [ ] [ the-person1 get insert-tuple ] unit-test
 
     [ 1 ] [ the-person1 get person-the-id ] unit-test
 
@@ -66,8 +67,8 @@ person "PERSON"
 "billy" 10 3.14 <person> the-person1 set
 "johnny" 10 3.14 <person> the-person2 set
 
-! test-sqlite
+test-sqlite
-test-postgresql
+! test-postgresql
 
 person "PERSON"
 {
@@ -80,8 +81,8 @@ person "PERSON"
 1 "billy" 10 3.14 <assigned-person> the-person1 set
 2 "johnny" 10 3.14 <assigned-person> the-person2 set
 
-! test-sqlite
+test-sqlite
-test-postgresql
+! test-postgresql
 
 TUPLE: paste n summary author channel mode contents timestamp annotations ;
 TUPLE: annotation n paste-id summary author mode contents ;
@@ -108,11 +109,11 @@ annotation "ANNOTATION"
     { "contents" "CONTENTS" TEXT }
 } define-persistent
 
-{ "localhost" "postgres" "" "factor-test" } postgresql-db [
+! { "localhost" "postgres" "" "factor-test" } postgresql-db [
-    [ paste drop-table ] [ drop ] recover
+    ! [ paste drop-table ] [ drop ] recover
-    [ annotation drop-table ] [ drop ] recover
+    ! [ annotation drop-table ] [ drop ] recover
-    [ paste drop-table ] [ drop ] recover
+    ! [ paste drop-table ] [ drop ] recover
-    [ annotation drop-table ] [ drop ] recover
+    ! [ annotation drop-table ] [ drop ] recover
-    [ ] [ paste create-table ] unit-test
+    ! [ ] [ paste create-table ] unit-test
-    [ ] [ annotation create-table ] unit-test
+    ! [ ] [ annotation create-table ] unit-test
-] with-db
+! ] with-db

extra/db/tuples/tuples.factor

@@ -26,14 +26,14 @@ IN: db.tuples
 HOOK: create-sql-statement db ( class -- obj )
 HOOK: drop-sql-statement db ( class -- obj )
 
-HOOK: <insert-native-statement> db ( tuple -- obj )
+HOOK: <insert-native-statement> db ( class -- obj )
-HOOK: <insert-assigned-statement> db ( tuple -- obj )
+HOOK: <insert-assigned-statement> db ( class -- obj )
 
-HOOK: <update-tuple-statement> db ( tuple -- obj )
+HOOK: <update-tuple-statement> db ( class -- obj )
-HOOK: <update-tuples-statement> db ( tuple -- obj )
+HOOK: <update-tuples-statement> db ( class -- obj )
 
-HOOK: <delete-tuple-statement> db ( tuple -- obj )
+HOOK: <delete-tuple-statement> db ( class -- obj )
-HOOK: <delete-tuples-statement> db ( tuple -- obj )
+HOOK: <delete-tuples-statement> db ( class -- obj )
 
 HOOK: <select-by-slots-statement> db ( tuple -- tuple )
 
@@ -63,15 +63,27 @@ HOOK: insert-tuple* db ( tuple statement -- )
 : sql-props ( class -- columns table )
     dup db-columns swap db-table ;
 
-: create-table ( class -- ) create-sql-statement execute-statement ;
+: with-disposals ( seq quot -- )
-: drop-table ( class -- ) drop-sql-statement execute-statement ;
+    over sequence? [
+        [ with-disposal ] curry each
+    ] [
+        with-disposal
+    ] if ;
+
+: create-table ( class -- )
+    create-sql-statement [ execute-statement ] with-disposals ;
+
+: drop-table ( class -- )
+    drop-sql-statement [ execute-statement ] with-disposals ;
 
 : insert-native ( tuple -- )
-    dup class <insert-native-statement>
+    dup class
+    db get db-insert-statements [ <insert-native-statement> ] cache
     [ bind-tuple ] 2keep insert-tuple* ;
 
 : insert-assigned ( tuple -- )
-    dup class <insert-assigned-statement>
+    dup class
+    db get db-insert-statements [ <insert-assigned-statement> ] cache
     [ bind-tuple ] keep execute-statement ;
 
 : insert-tuple ( tuple -- )
@@ -82,19 +94,18 @@ HOOK: insert-tuple* db ( tuple statement -- )
     ] if ;
 
 : update-tuple ( tuple -- )
-    dup class <update-tuple-statement>
+    dup class
+    db get db-update-statements [ <update-tuple-statement> ] cache
     [ bind-tuple ] keep execute-statement ;
 
-: update-tuples ( seq -- )
-    <update-tuples-statement> execute-statement ;
-
 : delete-tuple ( tuple -- )
-    dup class <delete-tuple-statement>
+    dup class
+    db get db-delete-statements [ <delete-tuple-statement> ] cache
     [ bind-tuple ] keep execute-statement ;
 
-: setup-select ( tuple -- statement )
+: select-tuples ( tuple -- tuple )
-    dup dup class <select-by-slots-statement>
+    dup dup class <select-by-slots-statement> [
-    [ bind-tuple ] keep ;
+        [ bind-tuple ] keep query-tuples
+    ] with-disposal ;
 
-: select-tuples ( tuple -- tuple ) setup-select query-tuples ;
 : select-tuple ( tuple -- tuple/f ) select-tuples ?first ;

extra/help/handbook/handbook.factor

@@ -199,6 +199,7 @@ ARTICLE: "tools" "Developer tools"
 "Debugging tools:"
 { $subsection "tools.annotations" }
 { $subsection "tools.test" }
+{ $subsection "tools.threads" }
 "Performance tools:"
 { $subsection "tools.memory" }
 { $subsection "profiling" }

extra/help/help.factor

@@ -122,18 +122,31 @@ M: word set-article-parent swap "help-parent" set-word-prop ;
 
 : (:help-multi)
     "This error has multiple delegates:" print
-    ($index) nl ;
+    ($index) nl
+    "Use \\ ... help to get help about a specific delegate." print ;
 
 : (:help-none)
     drop "No help for this error. " print ;
 
+: (:help-debugger)
+    nl
+    "Debugger commands:" print
+    nl
+    ":help - documentation for this error" print
+    ":s    - data stack at exception time" print
+    ":r    - retain stack at exception time" print
+    ":c    - call stack at exception time" print
+    ":edit - jump to source location (parse errors only)" print
+
+    ":get  ( var -- value ) accesses variables at time of the error" print ;
+
 : :help ( -- )
     error get delegates [ error-help ] map [ ] subset
     {
         { [ dup empty? ] [ (:help-none) ] }
         { [ dup length 1 = ] [ first help ] }
         { [ t ] [ (:help-multi) ] }
-    } cond ;
+    } cond (:help-debugger) ;
 
 : remove-article ( name -- )
     dup articles get key? [

extra/math/primes/primes.factor

@@ -47,3 +47,5 @@ PRIVATE>
   primes-upto
   >r 1- next-prime r>
   [ [ <=> ] binsearch ] keep [ length ] keep <slice> ; foldable
+
+: coprime? ( a b -- ? ) gcd nip 1 = ; foldable

extra/opengl/gl/extensions/extensions.factor

@@ -17,7 +17,7 @@ SYMBOL: +gl-function-pointers+
 : reset-gl-function-pointers ( -- )
     100 <hashtable> +gl-function-pointers+ set-global ;
     
-[ reset-gl-function-pointers ] "opengl.gl init hook" add-init-hook
+[ reset-gl-function-pointers ] "opengl.gl" add-init-hook
 reset-gl-function-pointers
 reset-gl-function-number-counter
 

extra/tools/threads/threads-docs.factor

@@ -0,0 +1,17 @@
+IN: tools.threads
+USING: help.markup help.syntax threads ;
+
+HELP: threads.
+{ $description "Prints a list of running threads and their state. The ``Waiting on'' column displays one of the following:"
+    { $list
+        "``running'' if the thread is the current thread"
+        "``yield'' if the thread is waiting to run"
+        { "the string given to " { $link suspend } " if the thread is suspended" }
+    }
+} ;
+
+ARTICLE: "tools.threads" "Listing threads"
+"Printing a list of running threads:"
+{ $subsection threads. } ;
+
+ABOUT: "tools.threads"

extra/ui/gadgets/buttons/buttons.factor

@@ -88,7 +88,6 @@ TUPLE: repeat-button ;
 
 repeat-button H{
     { T{ drag } [ button-clicked ] }
-    { T{ button-down } [ button-clicked ] }
 } set-gestures
 
 : <repeat-button> ( label quot -- button )

extra/ui/tools/interactor/interactor.factor

@@ -1,18 +1,15 @@
 ! Copyright (C) 2006, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays assocs combinators continuations documents
-ui.tools.workspace hashtables io io.styles kernel math
+ hashtables io io.styles kernel math
 math.vectors models namespaces parser prettyprint quotations
 sequences sequences.lib strings threads listener
 tuples ui.commands ui.gadgets ui.gadgets.editors
 ui.gadgets.presentations ui.gadgets.worlds ui.gestures
-definitions boxes calendar ;
+definitions boxes calendar concurrency.flags ui.tools.workspace ;
 IN: ui.tools.interactor
 
-TUPLE: interactor
+TUPLE: interactor history output flag thread help ;
-history output
-thread quot
-help ;
 
 : interactor-continuation ( interactor -- continuation )
     interactor-thread box-value
@@ -35,12 +32,16 @@ help ;
 : init-interactor-history ( interactor -- )
     V{ } clone swap set-interactor-history ;
 
+: init-interactor-state ( interactor -- )
+    <flag> over set-interactor-flag
+    <box> swap set-interactor-thread ;
+
 : <interactor> ( output -- gadget )
     <source-editor>
     interactor construct-editor
     tuck set-interactor-output
-    <box> over set-interactor-thread
     dup init-interactor-history
+    dup init-interactor-state
     dup init-caret-help ;
 
 M: interactor graft*
@@ -97,7 +98,10 @@ M: interactor model-changed
     ] unless drop ;
 
 : interactor-yield ( interactor -- obj )
-    [ interactor-thread >box ] curry "input" suspend ;
+    [
+        [ interactor-thread >box ] keep
+        interactor-flag raise-flag
+    ] curry "input" suspend ;
 
 M: interactor stream-readln
     [ interactor-yield ] keep interactor-finish ?first ;

extra/ui/tools/listener/listener.factor

@@ -6,7 +6,7 @@ kernel models namespaces parser quotations sequences ui.commands
 ui.gadgets ui.gadgets.editors ui.gadgets.labelled
 ui.gadgets.panes ui.gadgets.buttons ui.gadgets.scrollers
 ui.gadgets.tracks ui.gestures ui.operations vocabs words
-prettyprint listener debugger threads boxes ;
+prettyprint listener debugger threads boxes concurrency.flags ;
 IN: ui.tools.listener
 
 TUPLE: listener-gadget input output stack ;
@@ -40,9 +40,14 @@ M: listener-gadget call-tool* ( input listener -- )
 M: listener-gadget tool-scroller
     listener-gadget-output find-scroller ;
 
+: wait-for-listener ( listener -- )
+    #! Wait for the listener to start.
+    listener-gadget-input interactor-flag wait-for-flag ;
+
 : workspace-busy? ( workspace -- ? )
-    workspace-listener listener-gadget-input
+    workspace-listener
-    interactor-busy? ;
+    dup wait-for-listener
+    listener-gadget-input interactor-busy? ;
 
 : get-listener ( -- listener )
     [ workspace-busy? not ] get-workspace* workspace-listener ;
@@ -131,10 +136,14 @@ M: stack-display tool-scroller
         listener
     ] with-stream* ;
 
+: start-listener-thread ( listener -- )
+    [ listener-thread ] curry "Listener" spawn drop ;
+
 : restart-listener ( listener -- )
+    #! Returns when listener is ready to receive input.
     dup com-end dup clear-output
-    [ listener-thread ] curry
+    dup start-listener-thread
-    "Listener" spawn drop ;
+    wait-for-listener ;
 
 : init-listener ( listener -- )
     f <model> swap set-listener-gadget-stack ;

extra/ui/tools/tools.factor

@@ -1,15 +1,14 @@
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays assocs debugger ui.tools.workspace
-ui.tools.operations ui.tools.browser ui.tools.inspector
+ui.tools.operations ui.tools.traceback ui.tools.browser
-ui.tools.listener ui.tools.profiler
+ui.tools.inspector ui.tools.listener ui.tools.profiler
 ui.tools.operations inspector io kernel math models namespaces
 prettyprint quotations sequences ui ui.commands ui.gadgets
-ui.gadgets.books ui.gadgets.buttons
+ui.gadgets.books ui.gadgets.buttons ui.gadgets.labelled
-ui.gadgets.labelled ui.gadgets.scrollers ui.gadgets.tracks
+ui.gadgets.scrollers ui.gadgets.tracks ui.gadgets.worlds
-ui.gadgets.worlds ui.gadgets.presentations ui.gestures words
+ui.gadgets.presentations ui.gestures words vocabs.loader
-vocabs.loader tools.test ui.gadgets.buttons
+tools.test ui.gadgets.buttons ui.gadgets.status-bar mirrors ;
-ui.gadgets.status-bar mirrors ;
 IN: ui.tools
 
 : <workspace-tabs> ( -- tabs )
@@ -85,3 +84,11 @@ workspace "workflow" f {
 [
     <workspace> "Factor workspace" open-status-window
 ] workspace-window-hook set-global
+
+: inspect-continuation ( traceback -- )
+    control-value [ inspect ] curry call-listener ;
+
+traceback-gadget "toolbar" f {
+    { T{ key-down f f "v" } variables }
+    { T{ key-down f f "n" } inspect-continuation }
+} define-command-map

extra/ui/tools/traceback/traceback.factor

@@ -1,8 +1,10 @@
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: continuations kernel models namespaces prettyprint ui
 ui.commands ui.gadgets ui.gadgets.labelled assocs
-ui.gadgets.tracks ui.gestures sequences hashtables inspector ;
+ui.gadgets.tracks ui.gadgets.buttons ui.gadgets.panes
+ui.gadgets.status-bar ui.gadgets.scrollers
+ui.gestures sequences hashtables inspector ;
 IN: ui.tools.traceback
 
 : <callstack-display> ( model -- gadget )
@@ -17,10 +19,6 @@ IN: ui.tools.traceback
     [ [ continuation-retain stack. ] when* ]
     t "Retain stack" <labelled-pane> ;
 
-: <namestack-display> ( model -- gadget )
-    [ [ continuation-name namestack. ] when* ]
-    f "Dynamic variables" <labelled-pane> ;
-
 TUPLE: traceback-gadget ;
 
 M: traceback-gadget pref-dim* drop { 550 600 } ;
@@ -31,11 +29,28 @@ M: traceback-gadget pref-dim* drop { 550 600 } ;
             [
                 g gadget-model <datastack-display> 1/2 track,
                 g gadget-model <retainstack-display> 1/2 track,
-            ] { 1 0 } make-track 1/5 track,
+            ] { 1 0 } make-track 1/3 track,
-            g gadget-model <callstack-display> 2/5 track,
+            g gadget-model <callstack-display> 2/3 track,
-            g gadget-model <namestack-display> 2/5 track,
+            toolbar,
         ] with-gadget
     ] keep ;
 
+: <namestack-display> ( model -- gadget )
+    [ [ continuation-name namestack. ] when* ]
+    <pane-control> ;
+
+TUPLE: variables-gadget ;
+
+: <variables-gadget> ( model -- gadget )
+    <namestack-display> <scroller>
+    variables-gadget construct-empty
+    [ set-gadget-delegate ] keep ;
+
+M: variables-gadget pref-dim* drop { 400 400 } ;
+
+: variables ( traceback -- )
+    gadget-model <variables-gadget>
+    "Dynamic variables" open-status-window ;
+
 : traceback-window ( continuation -- )
     <model> <traceback-gadget> "Traceback" open-window ;

extra/ui/tools/walker/walker-docs.factor

@@ -7,5 +7,4 @@ ARTICLE: "ui-walker" "UI walker"
 $nl
 "The walker can travel backwards through time, and restore stacks. This does not undo side effects and therefore can only be used reliably on referentially transparent code."
 { $command-map walker-gadget "toolbar" }
-{ $command-map walker-gadget "other" }
 "Walkers are instances of " { $link walker-gadget } "." ;

extra/ui/tools/walker/walker.factor

@@ -7,7 +7,7 @@ ui.tools.workspace ui.gestures ui.gadgets.labels ui threads
 namespaces tools.walker assocs ;
 IN: ui.tools.walker
 
-TUPLE: walker-gadget status continuation thread ;
+TUPLE: walker-gadget status continuation thread traceback ;
 
 : walker-command ( walker msg -- )
     over walker-gadget-thread thread-registered?
@@ -26,13 +26,12 @@ TUPLE: walker-gadget status continuation thread ;
 
 : com-abandon ( walker -- ) abandon walker-command ;
 
-: com-inspect ( walker -- )
-    walker-continuation model-value
-    [ inspect ] curry call-listener ;
-
 M: walker-gadget ungraft*
     dup delegate ungraft* detach walker-command ;
 
+M: walker-gadget focusable-child*
+    walker-gadget-traceback ;
+
 : walker-state-string ( status thread -- string )
     [
         "Thread: " %
@@ -52,10 +51,10 @@ M: walker-gadget ungraft*
     [ walker-state-string ] curry <filter> <label-control> ;
 
 : <walker-gadget> ( status continuation thread -- gadget )
-    walker-gadget construct-boa [
+    over <traceback-gadget> walker-gadget construct-boa [
         toolbar,
         g walker-gadget-status self <thread-status> f track,
-        g walker-gadget-continuation <traceback-gadget> 1 track,
+        g walker-gadget-traceback 1 track,
     ] { 0 1 } build-track ;
 
 : walker-help "ui-walker" help-window ;
@@ -69,12 +68,8 @@ walker-gadget "toolbar" f {
     { T{ key-down f f "b" } com-back }
     { T{ key-down f f "c" } com-continue }
     { T{ key-down f f "a" } com-abandon }
-    { T{ key-down f f "F1" } walker-help }
-} define-command-map
-
-walker-gadget "other" f {
-    { T{ key-down f f "n" } com-inspect }
     { T{ key-down f f "d" } close-window }
+    { T{ key-down f f "F1" } walker-help }
 } define-command-map
 
 : walker-window ( -- )