From a5503782d775f2c296c065c43dfe95d8deb81b39 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 27 Feb 2008 17:15:52 -0600 Subject: [PATCH 01/10] Fix hang when clicking presentations in the walker; improve traceback widget --- extra/concurrency/flags/flags-docs.factor | 7 +++- extra/concurrency/flags/flags.factor | 7 +++- extra/ui/tools/interactor/interactor.factor | 20 ++++++----- extra/ui/tools/listener/listener.factor | 14 ++++++-- extra/ui/tools/tools.factor | 4 ++- extra/ui/tools/traceback/traceback.factor | 37 ++++++++++++++++----- extra/ui/tools/walker/walker-docs.factor | 1 - extra/ui/tools/walker/walker.factor | 10 +----- 8 files changed, 67 insertions(+), 33 deletions(-) diff --git a/extra/concurrency/flags/flags-docs.factor b/extra/concurrency/flags/flags-docs.factor index 11c85240b9..1b2c1b754e 100644 --- a/extra/concurrency/flags/flags-docs.factor +++ b/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" diff --git a/extra/concurrency/flags/flags.factor b/extra/concurrency/flags/flags.factor index d4e60d63ee..888b617b85 100644 --- a/extra/concurrency/flags/flags.factor +++ b/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 ; diff --git a/extra/ui/tools/interactor/interactor.factor b/extra/ui/tools/interactor/interactor.factor index 3c9809f343..9e43460aa9 100755 --- a/extra/ui/tools/interactor/interactor.factor +++ b/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 -history output -thread quot -help ; +TUPLE: interactor history output flag thread 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 -- ) + over set-interactor-flag + swap set-interactor-thread ; + : ( output -- gadget ) interactor construct-editor tuck set-interactor-output - 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 ; diff --git a/extra/ui/tools/listener/listener.factor b/extra/ui/tools/listener/listener.factor index 7617b0f32d..0577ae38bd 100755 --- a/extra/ui/tools/listener/listener.factor +++ b/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 ; @@ -131,10 +131,18 @@ M: stack-display tool-scroller listener ] with-stream* ; +: start-listener-thread ( listener -- ) + [ listener-thread ] curry "Listener" spawn drop ; + +: wait-for-listener ( listener -- ) + #! Wait for the listener to start. + listener-gadget-input interactor-flag wait-for-flag ; + : restart-listener ( listener -- ) + #! Returns when listener is ready to receive input. dup com-end dup clear-output - [ listener-thread ] curry - "Listener" spawn drop ; + dup start-listener-thread + wait-for-listener ; : init-listener ( listener -- ) f swap set-listener-gadget-stack ; diff --git a/extra/ui/tools/tools.factor b/extra/ui/tools/tools.factor index 2b3c652352..0156fe80ea 100755 --- a/extra/ui/tools/tools.factor +++ b/extra/ui/tools/tools.factor @@ -83,5 +83,7 @@ workspace "workflow" f { } define-command-map [ - "Factor workspace" open-status-window + + dup "Factor workspace" open-status-window + workspace-listener wait-for-listener ] workspace-window-hook set-global diff --git a/extra/ui/tools/traceback/traceback.factor b/extra/ui/tools/traceback/traceback.factor index a3aa182683..d4a0544f0a 100755 --- a/extra/ui/tools/traceback/traceback.factor +++ b/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 : ( model -- gadget ) @@ -17,10 +19,6 @@ IN: ui.tools.traceback [ [ continuation-retain stack. ] when* ] t "Retain stack" ; -: ( model -- gadget ) - [ [ continuation-name namestack. ] when* ] - f "Dynamic variables" ; - TUPLE: traceback-gadget ; M: traceback-gadget pref-dim* drop { 550 600 } ; @@ -31,11 +29,32 @@ M: traceback-gadget pref-dim* drop { 550 600 } ; [ g gadget-model 1/2 track, g gadget-model 1/2 track, - ] { 1 0 } make-track 1/5 track, - g gadget-model 2/5 track, - g gadget-model 2/5 track, + ] { 1 0 } make-track 1/3 track, + g gadget-model 2/3 track, + toolbar, ] with-gadget ] keep ; +: ( model -- gadget ) + [ [ continuation-name namestack. ] when* ] + ; + +TUPLE: variables-gadget ; + +: ( model -- gadget ) + + variables-gadget construct-empty + [ set-gadget-delegate ] keep ; + +M: variables-gadget pref-dim* drop { 400 400 } ; + +: variables ( traceback -- ) + gadget-model + "Dynamic variables" open-status-window ; + : traceback-window ( continuation -- ) "Traceback" open-window ; + +traceback-gadget "toolbar" f { + { T{ key-down f f "v" } variables } +} define-command-map diff --git a/extra/ui/tools/walker/walker-docs.factor b/extra/ui/tools/walker/walker-docs.factor index 38b4e2a837..54caf8be12 100755 --- a/extra/ui/tools/walker/walker-docs.factor +++ b/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 } "." ; diff --git a/extra/ui/tools/walker/walker.factor b/extra/ui/tools/walker/walker.factor index 17ca7552ce..ea38b9c8db 100755 --- a/extra/ui/tools/walker/walker.factor +++ b/extra/ui/tools/walker/walker.factor @@ -26,10 +26,6 @@ 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 ; @@ -69,12 +65,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 ( -- ) From 8cdec0202b9a40f2213b2a8221c582db53329bd7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 27 Feb 2008 18:28:32 -0600 Subject: [PATCH 02/10] fix sqlite remove reset-statement from db vocab --- extra/db/db.factor | 17 ++++------ extra/db/postgresql/postgresql.factor | 5 +-- extra/db/sqlite/sqlite.factor | 47 +++++++++++++++------------ extra/db/tuples/tuples-tests.factor | 27 +++++++-------- extra/db/tuples/tuples.factor | 38 +++++++++++++--------- 5 files changed, 70 insertions(+), 64 deletions(-) diff --git a/extra/db/db.factor b/extra/db/db.factor index d5242659ae..f6596af101 100755 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -12,9 +12,9 @@ TUPLE: db handle ; 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 ; @@ -28,6 +28,9 @@ HOOK: db-close db ( handle -- ) ] 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 ; : ( sql in out -- statement ) { set-statement-sql @@ -35,17 +38,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: db ( str in out -- statement ) HOOK: db ( str in out -- statement ) GENERIC: prepare-statement ( statement -- ) -GENERIC: bind-statement* ( obj statement -- ) -GENERIC: reset-statement ( statement -- ) +GENERIC: bind-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 ) @@ -53,6 +50,7 @@ GENERIC# row-column 1 ( result-set n -- obj ) GENERIC: advance-row ( result-set -- ) GENERIC: more-rows? ( result-set -- ? ) +! must be called from within with-disposal : execute-statement ( statement -- ) dup sequence? [ [ execute-statement ] each @@ -61,9 +59,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 -- ) diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor index 154a330913..9383a9290c 100755 --- a/extra/db/postgresql/postgresql.factor +++ b/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 -- ) - set-statement-bind-params ; - -M: postgresql-statement reset-statement ( statement -- ) +M: postgresql-statement bind-statement* ( statement -- ) drop ; M: postgresql-statement bind-tuple ( tuple statement -- ) diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index 8aba932490..b980e99718 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/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 ( str -- obj ) ; M: sqlite-db ( 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 -- ) - swap [ sqlite-bind-type ] with each ; +: sqlite-bind ( triples handle -- ) + swap [ first3 sqlite-bind-type ] with each ; -M: sqlite-statement bind-statement* ( obj statement -- ) - statement-handle sqlite-bind ; - -M: sqlite-statement reset-statement ( 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 dup advance-row ; @@ -127,7 +138,7 @@ M: sqlite-db ( 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 ( class -- statement ) [ @@ -135,7 +146,7 @@ M: sqlite-db ( 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 ( 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 ( 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 ( 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 ; diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index 6a0d0378b2..c9e6d302e0 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/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 the-person1 set "johnny" 10 3.14 the-person2 set -! test-sqlite -test-postgresql +test-sqlite +! test-postgresql person "PERSON" { @@ -80,8 +81,8 @@ person "PERSON" 1 "billy" 10 3.14 the-person1 set 2 "johnny" 10 3.14 the-person2 set -! test-sqlite -test-postgresql +test-sqlite +! 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 [ - [ paste drop-table ] [ drop ] recover - [ annotation drop-table ] [ drop ] recover - [ paste drop-table ] [ drop ] recover - [ annotation drop-table ] [ drop ] recover - [ ] [ paste create-table ] unit-test - [ ] [ annotation create-table ] unit-test -] with-db +! { "localhost" "postgres" "" "factor-test" } postgresql-db [ + ! [ paste drop-table ] [ drop ] recover + ! [ annotation drop-table ] [ drop ] recover + ! [ paste drop-table ] [ drop ] recover + ! [ annotation drop-table ] [ drop ] recover + ! [ ] [ paste create-table ] unit-test + ! [ ] [ annotation create-table ] unit-test +! ] with-db diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index 4e8b8ec9d0..28556a13fa 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -63,16 +63,20 @@ 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 ; -: drop-table ( class -- ) drop-sql-statement execute-statement ; +: create-table ( class -- ) + create-sql-statement [ execute-statement ] with-disposal ; +: drop-table ( class -- ) + drop-sql-statement [ execute-statement ] with-disposal ; : insert-native ( tuple -- ) - dup class - [ bind-tuple ] 2keep insert-tuple* ; + dup class [ + [ bind-tuple ] 2keep dup . insert-tuple* + ] with-disposal ; : insert-assigned ( tuple -- ) - dup class - [ bind-tuple ] keep execute-statement ; + dup class [ + [ bind-tuple ] keep execute-statement + ] with-disposal ; : insert-tuple ( tuple -- ) dup class db-columns find-primary-key assigned-id? [ @@ -82,19 +86,21 @@ HOOK: insert-tuple* db ( tuple statement -- ) ] if ; : update-tuple ( tuple -- ) - dup class - [ bind-tuple ] keep execute-statement ; + dup class [ + [ bind-tuple ] keep execute-statement + ] with-disposal ; -: update-tuples ( seq -- ) - execute-statement ; +! : update-tuples ( seq -- ) + ! execute-statement ; : delete-tuple ( tuple -- ) - dup class - [ bind-tuple ] keep execute-statement ; + dup class [ + [ bind-tuple ] keep execute-statement + ] with-disposal ; -: setup-select ( tuple -- statement ) - dup dup class - [ bind-tuple ] keep ; +: select-tuples ( tuple -- tuple ) + dup dup class [ + [ bind-tuple ] keep query-tuples + ] with-disposal ; -: select-tuples ( tuple -- tuple ) setup-select query-tuples ; : select-tuple ( tuple -- tuple/f ) select-tuples ?first ; From 3fcac9bd3d78e4acb2a2d305e92ba28800669443 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 27 Feb 2008 18:47:14 -0600 Subject: [PATCH 03/10] make postgresql pass unit tests --- extra/db/tuples/tuples-tests.factor | 8 ++++---- extra/db/tuples/tuples.factor | 8 ++++++-- 2 files changed, 10 insertions(+), 6 deletions(-) diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index c9e6d302e0..83b814378b 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -67,8 +67,8 @@ person "PERSON" "billy" 10 3.14 the-person1 set "johnny" 10 3.14 the-person2 set -test-sqlite -! test-postgresql +! test-sqlite +test-postgresql person "PERSON" { @@ -81,8 +81,8 @@ person "PERSON" 1 "billy" 10 3.14 the-person1 set 2 "johnny" 10 3.14 the-person2 set -test-sqlite -! test-postgresql +! test-sqlite +test-postgresql TUPLE: paste n summary author channel mode contents timestamp annotations ; TUPLE: annotation n paste-id summary author mode contents ; diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index 28556a13fa..96c171c96f 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -63,10 +63,14 @@ HOOK: insert-tuple* db ( tuple statement -- ) : sql-props ( class -- columns table ) dup db-columns swap db-table ; +: with-disposals ( seq quot -- ) + [ with-disposal ] curry each ; + : create-table ( class -- ) - create-sql-statement [ execute-statement ] with-disposal ; + create-sql-statement [ execute-statement ] with-disposals ; + : drop-table ( class -- ) - drop-sql-statement [ execute-statement ] with-disposal ; + drop-sql-statement [ execute-statement ] with-disposals ; : insert-native ( tuple -- ) dup class [ From ed4506c0b04d7a878ddb9b09fe1fc553b7e15360 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 27 Feb 2008 19:23:22 -0600 Subject: [PATCH 04/10] Errors remember the original thread --- core/alien/compiler/compiler.factor | 2 +- core/bootstrap/stage1.factor | 13 ++- core/bootstrap/stage2.factor | 104 +++++++++---------- core/continuations/continuations-docs.factor | 3 - core/continuations/continuations.factor | 17 +-- core/debugger/debugger-docs.factor | 8 +- core/debugger/debugger.factor | 62 ++++++++--- core/init/init-tests.factor | 7 ++ core/init/init.factor | 2 +- core/libc/libc.factor | 2 +- core/sequences/sequences-docs.factor | 4 +- core/threads/threads.factor | 28 ++--- 12 files changed, 133 insertions(+), 119 deletions(-) create mode 100644 core/init/init-tests.factor diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor index 48e8d7e307..baab72036d 100755 --- a/core/alien/compiler/compiler.factor +++ b/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 diff --git a/core/bootstrap/stage1.factor b/core/bootstrap/stage1.factor index 7c7a03f575..0e038d0a10 100755 --- a/core/bootstrap/stage1.factor +++ b/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 diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index 3b5918a4f8..63b5726ad7 100755 --- a/core/bootstrap/stage2.factor +++ b/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 - "" "exclude" set-global +default-image-name "output-image" 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 - wince? [ "windows.ce" require ] when - winnt? [ "windows.nt" require ] when +"-no-crossref" cli-args member? [ do-crossref ] unless - "deploy-vocab" get [ - "stage2: deployment mode" print - ] [ - "listener" require - "none" require - ] if +! Set dll paths +wince? [ "windows.ce" require ] when +winnt? [ "windows.nt" require ] when - [ - 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 +"deploy-vocab" get [ + "stage2: deployment mode" print ] [ - :c - print-error restarts. - "listener" vocab-main execute - 1 exit -] recover + "listener" require + "none" require +] if + +[ + 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 diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index 5fc86e25d4..9a26dbc67e 100755 --- a/core/continuations/continuations-docs.factor +++ b/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." } ; diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index d68b5b2433..13b31cfde6 100755 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -6,6 +6,7 @@ IN: continuations SYMBOL: error SYMBOL: error-continuation +SYMBOL: error-thread SYMBOL: restarts : catchstack ( -- catchstack ) catchstack* clone ; inline @@ -169,17 +172,3 @@ M: condition compute-restarts condition-continuation [ ] curry { } assoc>map append ; - - diff --git a/core/debugger/debugger-docs.factor b/core/debugger/debugger-docs.factor index b754856ee4..5e8b6df34a 100755 --- a/core/debugger/debugger-docs.factor +++ b/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." } ; diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor index 95470dcbcd..378491e141 100755 --- a/core/debugger/debugger.factor +++ b/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 ; + + + +[ init-debugger ] "debugger" add-init-hook diff --git a/core/init/init-tests.factor b/core/init/init-tests.factor new file mode 100644 index 0000000000..aa7cd0ea58 --- /dev/null +++ b/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 diff --git a/core/init/init.factor b/core/init/init.factor index 770655d990..6ee11c76fc 100755 --- a/core/init/init.factor +++ b/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 ; diff --git a/core/libc/libc.factor b/core/libc/libc.factor index 2006850839..a28c5c0a98 100644 --- a/core/libc/libc.factor +++ b/core/libc/libc.factor @@ -46,7 +46,7 @@ M: realloc-error summary drop "Memory reallocation failed" ; -: ( quot name error-handler -- thread ) +: ( quot name -- thread ) \ thread counter [ ] { 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 ] [ (spawn) ] keep ; + [ (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 -- ) + 42 setenv 43 setenv initial-thread global - [ drop f "Initial" [ die ] ] cache + [ drop f "Initial" ] cache 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> From cfa7c3771cca1c9305c8e11598c4acd1b4fd9273 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 27 Feb 2008 19:24:24 -0600 Subject: [PATCH 05/10] Fixes for linked error change --- .../combinators/combinators-tests.factor | 2 +- extra/concurrency/locks/locks-tests.factor | 2 +- extra/concurrency/mailboxes/mailboxes.factor | 21 ++++++++++++++----- .../messaging/messaging-tests.factor | 2 +- 4 files changed, 19 insertions(+), 8 deletions(-) diff --git a/extra/concurrency/combinators/combinators-tests.factor b/extra/concurrency/combinators/combinators-tests.factor index 831dad6b56..e06b97489b 100755 --- a/extra/concurrency/combinators/combinators-tests.factor +++ b/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 diff --git a/extra/concurrency/locks/locks-tests.factor b/extra/concurrency/locks/locks-tests.factor index 1280339231..92f1a9f103 100755 --- a/extra/concurrency/locks/locks-tests.factor +++ b/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 diff --git a/extra/concurrency/mailboxes/mailboxes.factor b/extra/concurrency/mailboxes/mailboxes.factor index adfb5bac0a..28b2fb7221 100755 --- a/extra/concurrency/mailboxes/mailboxes.factor +++ b/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 +: ( 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 + [ ] keep + linked-thread-supervisor mailbox-put ; + +: ( quot name mailbox -- thread' ) + >r linked-thread construct-delegate r> + over set-linked-thread-supervisor ; : spawn-linked-to ( quot name mailbox -- thread ) - [ >r r> mailbox-put ] curry - [ (spawn) ] keep ; + [ (spawn) ] keep ; diff --git a/extra/concurrency/messaging/messaging-tests.factor b/extra/concurrency/messaging/messaging-tests.factor index 5f241b77e3..3f6e4e3ed8 100755 --- a/extra/concurrency/messaging/messaging-tests.factor +++ b/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 From 27c9b31288f42363d19445feec21db2d6246aa41 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 27 Feb 2008 19:24:50 -0600 Subject: [PATCH 06/10] New benchmarks and UI improvements --- extra/benchmark/crc32/crc32.factor | 10 ++++++++ extra/benchmark/md5/md5.factor | 7 +++++ extra/benchmark/random/random.factor | 14 ++++++++++ extra/benchmark/sort/sort.factor | 5 ++-- extra/benchmark/sum-file/sum-file.factor | 5 ++-- extra/help/handbook/handbook.factor | 1 + extra/help/help.factor | 17 ++++++++++-- extra/opengl/gl/extensions/extensions.factor | 2 +- extra/tools/threads/threads-docs.factor | 17 ++++++++++++ extra/ui/gadgets/buttons/buttons.factor | 1 - extra/ui/tools/listener/listener.factor | 13 +++++----- extra/ui/tools/tools.factor | 27 ++++++++++++-------- extra/ui/tools/traceback/traceback.factor | 4 --- extra/ui/tools/walker/walker.factor | 9 ++++--- 14 files changed, 100 insertions(+), 32 deletions(-) create mode 100644 extra/benchmark/crc32/crc32.factor create mode 100644 extra/benchmark/md5/md5.factor create mode 100644 extra/benchmark/random/random.factor create mode 100644 extra/tools/threads/threads-docs.factor diff --git a/extra/benchmark/crc32/crc32.factor b/extra/benchmark/crc32/crc32.factor new file mode 100644 index 0000000000..7dad272296 --- /dev/null +++ b/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 diff --git a/extra/benchmark/md5/md5.factor b/extra/benchmark/md5/md5.factor new file mode 100644 index 0000000000..3043725acd --- /dev/null +++ b/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 diff --git a/extra/benchmark/random/random.factor b/extra/benchmark/random/random.factor new file mode 100644 index 0000000000..95c797cddd --- /dev/null +++ b/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 diff --git a/extra/benchmark/sort/sort.factor b/extra/benchmark/sort/sort.factor index 0a31bf0ca4..a54480692a 100644 --- a/extra/benchmark/sort/sort.factor +++ b/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 diff --git a/extra/benchmark/sum-file/sum-file.factor b/extra/benchmark/sum-file/sum-file.factor index e17765d542..1d52beebfc 100644 --- a/extra/benchmark/sum-file/sum-file.factor +++ b/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 diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index 6660ddf218..178b7a5d35 100755 --- a/extra/help/handbook/handbook.factor +++ b/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" } diff --git a/extra/help/help.factor b/extra/help/help.factor index 77b9f699aa..490374a384 100755 --- a/extra/help/help.factor +++ b/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? [ diff --git a/extra/opengl/gl/extensions/extensions.factor b/extra/opengl/gl/extensions/extensions.factor index e05e3a1af5..01725ee9a9 100644 --- a/extra/opengl/gl/extensions/extensions.factor +++ b/extra/opengl/gl/extensions/extensions.factor @@ -17,7 +17,7 @@ SYMBOL: +gl-function-pointers+ : reset-gl-function-pointers ( -- ) 100 +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 diff --git a/extra/tools/threads/threads-docs.factor b/extra/tools/threads/threads-docs.factor new file mode 100644 index 0000000000..d4c5be9c17 --- /dev/null +++ b/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" diff --git a/extra/ui/gadgets/buttons/buttons.factor b/extra/ui/gadgets/buttons/buttons.factor index cf6d1a9ed9..defd5aa38a 100755 --- a/extra/ui/gadgets/buttons/buttons.factor +++ b/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 : ( label quot -- button ) diff --git a/extra/ui/tools/listener/listener.factor b/extra/ui/tools/listener/listener.factor index 0577ae38bd..c4c366bb7d 100755 --- a/extra/ui/tools/listener/listener.factor +++ b/extra/ui/tools/listener/listener.factor @@ -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 - interactor-busy? ; + workspace-listener + dup wait-for-listener + listener-gadget-input interactor-busy? ; : get-listener ( -- listener ) [ workspace-busy? not ] get-workspace* workspace-listener ; @@ -134,10 +139,6 @@ M: stack-display tool-scroller : start-listener-thread ( listener -- ) [ listener-thread ] curry "Listener" spawn drop ; -: wait-for-listener ( listener -- ) - #! Wait for the listener to start. - listener-gadget-input interactor-flag wait-for-flag ; - : restart-listener ( listener -- ) #! Returns when listener is ready to receive input. dup com-end dup clear-output diff --git a/extra/ui/tools/tools.factor b/extra/ui/tools/tools.factor index 0156fe80ea..b3b24cf749 100755 --- a/extra/ui/tools/tools.factor +++ b/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.listener ui.tools.profiler +ui.tools.operations ui.tools.traceback ui.tools.browser +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.labelled ui.gadgets.scrollers ui.gadgets.tracks -ui.gadgets.worlds ui.gadgets.presentations ui.gestures words -vocabs.loader tools.test ui.gadgets.buttons -ui.gadgets.status-bar mirrors ; +ui.gadgets.books ui.gadgets.buttons ui.gadgets.labelled +ui.gadgets.scrollers ui.gadgets.tracks ui.gadgets.worlds +ui.gadgets.presentations ui.gestures words vocabs.loader +tools.test ui.gadgets.buttons ui.gadgets.status-bar mirrors ; IN: ui.tools : ( -- tabs ) @@ -83,7 +82,13 @@ workspace "workflow" f { } define-command-map [ - - dup "Factor workspace" open-status-window - workspace-listener wait-for-listener + "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 diff --git a/extra/ui/tools/traceback/traceback.factor b/extra/ui/tools/traceback/traceback.factor index d4a0544f0a..3c3ff9da44 100755 --- a/extra/ui/tools/traceback/traceback.factor +++ b/extra/ui/tools/traceback/traceback.factor @@ -54,7 +54,3 @@ M: variables-gadget pref-dim* drop { 400 400 } ; : traceback-window ( continuation -- ) "Traceback" open-window ; - -traceback-gadget "toolbar" f { - { T{ key-down f f "v" } variables } -} define-command-map diff --git a/extra/ui/tools/walker/walker.factor b/extra/ui/tools/walker/walker.factor index ea38b9c8db..bc038cd244 100755 --- a/extra/ui/tools/walker/walker.factor +++ b/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? @@ -29,6 +29,9 @@ TUPLE: walker-gadget status continuation thread ; 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: " % @@ -48,10 +51,10 @@ M: walker-gadget ungraft* [ walker-state-string ] curry ; : ( status continuation thread -- gadget ) - walker-gadget construct-boa [ + over walker-gadget construct-boa [ toolbar, g walker-gadget-status self f track, - g walker-gadget-continuation 1 track, + g walker-gadget-traceback 1 track, ] { 0 1 } build-track ; : walker-help "ui-walker" help-window ; From 78266a3fc8ad6a6c3ebefab661cc4f77efc52fd1 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 27 Feb 2008 19:30:31 -0600 Subject: [PATCH 07/10] cache statements in db --- extra/db/db.factor | 18 +++++++++------- extra/db/tuples/tuples.factor | 39 ++++++++++++++++------------------- 2 files changed, 28 insertions(+), 29 deletions(-) diff --git a/extra/db/db.factor b/extra/db/db.factor index f6596af101..a577ff5fc5 100755 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -5,10 +5,14 @@ namespaces sequences sequences.lib tuples words strings tools.walker ; IN: db -TUPLE: db handle ; -! TUPLE: db handle insert-statements update-statements delete-statements ; +TUPLE: db + handle + insert-statements + update-statements + delete-statements ; + : ( handle -- obj ) - ! H{ } clone H{ } clone H{ } clone + H{ } clone H{ } clone H{ } clone db construct-boa ; GENERIC: make-db* ( seq class -- db ) @@ -21,9 +25,9 @@ HOOK: db-close db ( handle -- ) : dispose-db ( db -- ) dup db [ - ! dup db-insert-statements dispose-statements - ! dup db-update-statements dispose-statements - ! dup db-delete-statements dispose-statements + dup db-insert-statements dispose-statements + dup db-update-statements dispose-statements + dup db-delete-statements dispose-statements db-handle db-close ] with-variable ; @@ -50,7 +54,6 @@ GENERIC# row-column 1 ( result-set n -- obj ) GENERIC: advance-row ( result-set -- ) GENERIC: more-rows? ( result-set -- ? ) -! must be called from within with-disposal : execute-statement ( statement -- ) dup sequence? [ [ execute-statement ] each @@ -101,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 ( -- ) diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index 96c171c96f..f384ea08db 100755 --- a/extra/db/tuples/tuples.factor +++ b/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: db ( tuple -- obj ) -HOOK: db ( tuple -- obj ) +HOOK: db ( class -- obj ) +HOOK: db ( class -- obj ) -HOOK: db ( tuple -- obj ) -HOOK: db ( tuple -- obj ) +HOOK: db ( class -- obj ) +HOOK: db ( class -- obj ) -HOOK: db ( tuple -- obj ) -HOOK: db ( tuple -- obj ) +HOOK: db ( class -- obj ) +HOOK: db ( class -- obj ) HOOK: db ( tuple -- tuple ) @@ -73,14 +73,14 @@ HOOK: insert-tuple* db ( tuple statement -- ) drop-sql-statement [ execute-statement ] with-disposals ; : insert-native ( tuple -- ) - dup class [ - [ bind-tuple ] 2keep dup . insert-tuple* - ] with-disposal ; + dup class + db get db-insert-statements [ ] cache + [ bind-tuple ] 2keep insert-tuple* ; : insert-assigned ( tuple -- ) - dup class [ - [ bind-tuple ] keep execute-statement - ] with-disposal ; + dup class + db get db-insert-statements [ ] cache + [ bind-tuple ] keep execute-statement ; : insert-tuple ( tuple -- ) dup class db-columns find-primary-key assigned-id? [ @@ -90,17 +90,14 @@ HOOK: insert-tuple* db ( tuple statement -- ) ] if ; : update-tuple ( tuple -- ) - dup class [ - [ bind-tuple ] keep execute-statement - ] with-disposal ; - -! : update-tuples ( seq -- ) - ! execute-statement ; + dup class + db get db-update-statements [ ] cache + [ bind-tuple ] keep execute-statement ; : delete-tuple ( tuple -- ) - dup class [ - [ bind-tuple ] keep execute-statement - ] with-disposal ; + dup class + db get db-delete-statements [ ] cache + [ bind-tuple ] keep execute-statement ; : select-tuples ( tuple -- tuple ) dup dup class [ From eb8207a784ba231e6b3b5f44e6828acba610edba Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 27 Feb 2008 19:36:32 -0600 Subject: [PATCH 08/10] fix with-disposals to work on seq or obj --- extra/db/tuples/tuples-tests.factor | 8 ++++---- extra/db/tuples/tuples.factor | 6 +++++- 2 files changed, 9 insertions(+), 5 deletions(-) diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index 83b814378b..c9e6d302e0 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -67,8 +67,8 @@ person "PERSON" "billy" 10 3.14 the-person1 set "johnny" 10 3.14 the-person2 set -! test-sqlite -test-postgresql +test-sqlite +! test-postgresql person "PERSON" { @@ -81,8 +81,8 @@ person "PERSON" 1 "billy" 10 3.14 the-person1 set 2 "johnny" 10 3.14 the-person2 set -! test-sqlite -test-postgresql +test-sqlite +! test-postgresql TUPLE: paste n summary author channel mode contents timestamp annotations ; TUPLE: annotation n paste-id summary author mode contents ; diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index f384ea08db..e7fe7e49c2 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -64,7 +64,11 @@ HOOK: insert-tuple* db ( tuple statement -- ) dup db-columns swap db-table ; : with-disposals ( seq quot -- ) - [ with-disposal ] curry each ; + over sequence? [ + [ with-disposal ] curry each + ] [ + with-disposal + ] if ; : create-table ( class -- ) create-sql-statement [ execute-statement ] with-disposals ; From 13290fcd827c1c9f0a6ac9eaac8a5917bf691bff Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 27 Feb 2008 22:23:01 -0600 Subject: [PATCH 09/10] Fix load --- extra/concurrency/messaging/messaging.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/concurrency/messaging/messaging.factor b/extra/concurrency/messaging/messaging.factor index 97cd45190f..6915653eb4 100755 --- a/extra/concurrency/messaging/messaging.factor +++ b/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 r> send ; + >r r> send ; : spawn-linked ( quot name -- thread ) my-mailbox spawn-linked-to ; From 260acff9523601dcf3e4345d175eefe650cde811 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 27 Feb 2008 23:09:29 -0600 Subject: [PATCH 10/10] add coprime? to math.primes --- extra/math/primes/primes.factor | 2 ++ 1 file changed, 2 insertions(+) diff --git a/extra/math/primes/primes.factor b/extra/math/primes/primes.factor index 68ab5b3221..685124e4e9 100644 --- a/extra/math/primes/primes.factor +++ b/extra/math/primes/primes.factor @@ -47,3 +47,5 @@ PRIVATE> primes-upto >r 1- next-prime r> [ [ <=> ] binsearch ] keep [ length ] keep ; foldable + +: coprime? ( a b -- ? ) gcd nip 1 = ; foldable