! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays definitions generic hashtables inspector io kernel
-math namespaces prettyprint sequences assocs sequences.private
-strings io.styles vectors words system splitting math.parser
-classes.tuple continuations continuations.private combinators
-generic.math io.streams.duplex classes.builtin classes
-compiler.units generic.standard vocabs threads threads.private
-init kernel.private libc io.encodings mirrors accessors ;
+math namespaces prettyprint prettyprint.config sequences assocs
+sequences.private strings io.styles vectors words system
+splitting math.parser classes.tuple continuations
+continuations.private combinators generic.math
+classes.builtin classes compiler.units generic.standard vocabs
+threads threads.private init kernel.private libc io.encodings
+mirrors accessors math.order ;
IN: debugger
GENERIC: error. ( error -- )
[ global [ "Error in print-error!" print drop ] bind ]
recover ;
-SYMBOL: error-hook
-
-[
++: print-error-and-restarts ( error -- )
+ print-error
+ restarts.
+ nl
- "Type :help for debugging help." print flush
-] error-hook set-global
++ "Type :help for debugging help." print flush ;
+
: try ( quot -- )
- [
- print-error
- restarts.
- nl
- "Type :help for debugging help." print flush
- ] recover ;
- [ error-hook get call ] recover ;
++ [ print-error-and-restarts ] recover ;
ERROR: assert got expect ;
: assert-depth ( quot -- )
>r datastack r> swap slip >r datastack r>
- 2dup [ length ] compare sgn {
- { -1 [ trim-datastacks nip relative-underflow ] }
- { 0 [ 2drop ] }
- { 1 [ trim-datastacks drop relative-overflow ] }
+ 2dup [ length ] compare {
+ { +lt+ [ trim-datastacks nip relative-underflow ] }
+ { +eq+ [ 2drop ] }
+ { +gt+ [ trim-datastacks drop relative-overflow ] }
} case ; inline
: expired-error. ( obj -- )
M: inconsistent-next-method summary
drop "Executing call-next-method with inconsistent parameters" ;
-M: stream-closed-twice summary
- drop "Attempt to perform I/O on closed stream" ;
-
M: check-method summary
drop "Invalid parameters for create-method" ;
M: assert summary drop "Assertion failed" ;
+M: assert error.
+ "Assertion failed" print
+ standard-table-style [
+ 15 length-limit set
+ 5 line-limit set
+ [ expect>> [ [ "Expect:" write ] with-cell pprint-cell ] with-row ]
+ [ got>> [ [ "Got:" write ] with-cell pprint-cell ] with-row ] bi
+ ] tabular-output ;
+
M: immutable summary drop "Sequence is immutable" ;
M: redefine-error error.
M: realloc-error summary
drop "Memory reallocation failed" ;
-: error-in-thread. ( -- )
- error-thread get-global
+: error-in-thread. ( thread -- )
"Error in thread " write
[
dup thread-id #
die drop
] [
global [
- error-in-thread. print-error flush
+ error-thread get-global error-in-thread. print-error flush
] bind
] if ;
! See http://factorcode.org/license.txt for BSD license.
USING: arrays hashtables io kernel math math.parser memory
namespaces parser sequences strings io.styles
-io.streams.duplex vectors words generic system combinators
-continuations debugger definitions compiler.units accessors ;
+vectors words generic system combinators continuations debugger
+definitions compiler.units accessors ;
IN: listener
SYMBOL: quit-flag
M: object stream-read-quot
V{ } clone read-quot-loop ;
-M: duplex-stream stream-read-quot
- duplex-stream-in stream-read-quot ;
-
-: read-quot ( -- quot/f ) stdio get stream-read-quot ;
+: read-quot ( -- quot/f ) input-stream get stream-read-quot ;
: bye ( -- ) quit-flag on ;
"( " in get " )" 3append
H{ { background { 1 0.7 0.7 1 } } } format bl flush ;
+SYMBOL: error-hook
+
++[ print-error-and-restarts ] error-hook set-global
++
: listen ( -- )
listener-hook get call prompt.
- [ read-quot [ try ] [ bye ] if* ]
+ [ read-quot [ [ error-hook get call ] recover ] [ bye ] if* ]
[
dup parse-error? [
error-hook get call
! Copyright (C) 2004, 2008 Slava Pestov.
! Copyright (C) 2005 Mackenzie Straight.
! See http://factorcode.org/license.txt for BSD license.
-IN: threads
USING: arrays hashtables heaps kernel kernel.private math
namespaces sequences vectors continuations continuations.private
-dlists assocs system combinators init boxes accessors ;
+dlists assocs system combinators init boxes accessors
+math.order ;
+IN: threads
SYMBOL: initial-thread
[ sleep-queue heap-peek nip millis [-] ]
} cond ;
+ DEFER: stop
+
<PRIVATE
-: schedule-sleep ( thread ms -- )
+: schedule-sleep ( thread dt -- )
>r check-registered dup r> sleep-queue heap-push*
>>sleep-entry drop ;
[ ] while
drop ;
+ : start ( namestack thread -- )
+ [
+ set-self
+ set-namestack
+ V{ } set-catchstack
+ { } set-retainstack
+ { } set-datastack
+ self quot>> [ call stop ] call-clear
+ ] 2 (throw) ;
+
+ DEFER: next
+
+ : no-runnable-threads ( -- * )
+ ! We should never be in a state where the only threads
+ ! are sleeping; the I/O wait thread is always runnable.
+ ! However, if it dies, we handle this case
+ ! semi-gracefully.
+ !
+ ! And if sleep-time outputs f, there are no sleeping
+ ! threads either... so WTF.
+ sleep-time [ die 0 ] unless* (sleep) next ;
+
+ : (next) ( arg thread -- * )
+ f >>state
+ dup set-self
+ dup continuation>> ?box
+ [ nip continue-with ] [ drop start ] if ;
+
: next ( -- * )
expire-sleep-loop
run-queue dup dlist-empty? [
- ! We should never be in a state where the only threads
- ! are sleeping; the I/O wait thread is always runnable.
- ! However, if it dies, we handle this case
- ! semi-gracefully.
- !
- ! And if sleep-time outputs f, there are no sleeping
- ! threads either... so WTF.
- drop sleep-time [ die 0 ] unless* (sleep) next
+ drop no-runnable-threads
] [
- pop-back
- dup array? [ first2 ] [ f swap ] if dup set-self
- f >>state
- continuation>> box>
- continue-with
+ pop-back dup array? [ first2 ] [ f swap ] if (next)
] if ;
PRIVATE>
: stop ( -- )
- self dup exit-handler>> call
- unregister-thread next ;
+ self [ exit-handler>> call ] [ unregister-thread ] bi next ;
: suspend ( quot state -- obj )
[
- self continuation>> >box
- self (>>state)
- self swap call next
+ >r
+ >r self swap call
+ r> self (>>state)
+ r> self continuation>> >box
+ next
] callcc1 2nip ; inline
: yield ( -- ) [ resume ] f suspend drop ;
M: f sleep-until
drop [ drop ] "interrupt" suspend drop ;
-GENERIC: sleep ( ms -- )
+GENERIC: sleep ( dt -- )
M: real sleep
millis + >integer sleep-until ;
] when drop ;
: (spawn) ( thread -- )
- [
- resume-now [
- dup set-self
- dup register-thread
- V{ } set-catchstack
- { } set-retainstack
- >r { } set-datastack r>
- quot>> [ call stop ] call-clear
- ] 1 (throw)
- ] "spawn" suspend 2drop ;
+ [ register-thread ] [ namestack swap resume-with ] bi ;
: spawn ( quot name -- thread )
<thread> [ (spawn) ] keep ;
>r [ [ ] [ ] while ] curry r> spawn ;
: in-thread ( quot -- )
- >r datastack namestack r>
- [ >r set-namestack set-datastack r> call ] 3curry
+ >r datastack r>
+ [ >r set-datastack r> call ] 2curry
"Thread" spawn drop ;
GENERIC: error-in-thread ( error thread -- )
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs combinators continuations documents
- hashtables io io.styles kernel math
- math.vectors models namespaces parser prettyprint quotations
- sequences strings threads listener
- classes.tuple ui.commands ui.gadgets ui.gadgets.editors
- ui.gadgets.presentations ui.gadgets.worlds ui.gestures
- definitions boxes calendar concurrency.flags ui.tools.workspace
- accessors math.order ;
-hashtables io io.styles kernel math math.vectors models
-namespaces parser prettyprint quotations sequences strings
-threads listener classes.tuple ui.commands ui.gadgets
++hashtables io io.styles kernel math math.order math.vectors
++models namespaces parser prettyprint quotations sequences
++strings threads listener classes.tuple ui.commands ui.gadgets
+ ui.gadgets.editors ui.gadgets.presentations ui.gadgets.worlds
+ ui.gestures definitions calendar concurrency.flags
+ ui.tools.workspace accessors ;
IN: ui.tools.interactor
- TUPLE: interactor history output flag thread help ;
+ ! If waiting is t, we're waiting for user input, and invoking
+ ! evaluate-input resumes the thread.
+ TUPLE: interactor output history flag thread waiting help ;
+
+ : register-self ( interactor -- )
+ self >>thread drop ;
: interactor-continuation ( interactor -- continuation )
- interactor-thread box-value
- thread-continuation box-value ;
+ thread>> continuation>> value>> ;
: interactor-busy? ( interactor -- ? )
- interactor-thread box-full? not ;
+ #! We're busy if there's no thread to resume.
+ [ waiting>> ]
+ [ thread>> dup [ thread-registered? ] when ]
+ bi and not ;
: interactor-use ( interactor -- seq )
dup interactor-busy? [ drop f ] [
use swap
- interactor-continuation continuation-name
+ interactor-continuation name>>
assoc-stack
] if ;
- : init-caret-help ( interactor -- )
- dup editor-caret 1/3 seconds <delay>
- swap set-interactor-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 ;
+ : <help-model> ( interactor -- model )
+ editor-caret 1/3 seconds <delay> ;
: <interactor> ( output -- gadget )
<source-editor>
interactor construct-editor
- tuck set-interactor-output
- dup init-interactor-history
- dup init-interactor-state
- dup init-caret-help ;
+ V{ } clone >>history
+ <flag> >>flag
+ dup <help-model> >>help
+ swap >>output ;
M: interactor graft*
- dup delegate graft*
- dup interactor-help add-connection ;
+ [ delegate graft* ] [ dup help>> add-connection ] bi ;
+
+ M: interactor ungraft*
+ [ dup help>> remove-connection ] [ delegate ungraft ] bi ;
: word-at-loc ( loc interactor -- word )
over [
] if ;
M: interactor model-changed
- 2dup interactor-help eq? [
+ 2dup help>> eq? [
swap model-value over word-at-loc swap show-summary
] [
delegate model-changed
[ H{ { font-style bold } } format ] with-nesting ;
: interactor-input. ( string interactor -- )
- interactor-output [
+ output>> [
dup string? [ dup write-input nl ] [ short. ] if
- ] with-stream* ;
+ ] with-output-stream* ;
: add-interactor-history ( str interactor -- )
over empty? [ 2drop ] [ interactor-history push-new ] if ;
: interactor-continue ( obj interactor -- )
- interactor-thread box> resume-with ;
+ thread>> resume-with ;
: clear-input ( interactor -- ) gadget-model clear-doc ;
] unless drop ;
: interactor-yield ( interactor -- obj )
- [
- [ interactor-thread >box ] keep
- interactor-flag raise-flag
- ] curry "input" suspend ;
+ dup thread>> self eq? [
+ t >>waiting
+ [ [ flag>> raise-flag ] curry "input" suspend ] keep
+ f >>waiting
+ drop
+ ] [ drop f ] if ;
M: interactor stream-readln
[ interactor-yield ] keep interactor-finish
} cond ;
M: interactor pref-dim*
- 0 over line-height 4 * 2array swap delegate pref-dim* vmax ;
+ [ line-height 4 * 0 swap 2array ] [ delegate pref-dim* ] bi
+ vmax ;
interactor "interactor" f {
{ T{ key-down f f "RET" } evaluate-input }
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: inspector ui.tools.interactor ui.tools.inspector
-ui.tools.workspace help.markup io io.streams.duplex io.styles
+ui.tools.workspace help.markup io io.styles
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
<scrolling-pane> g-> set-listener-gadget-output
<scroller> "Output" <labelled-gadget> 1 track, ;
-: <listener-stream> ( listener -- stream )
- [ input>> ] [ output>> <pane-stream> ] bi <duplex-stream> ;
+: listener-streams ( listener -- input output )
+ [ input>> ] [ output>> <pane-stream> ] bi ;
: <listener-input> ( listener -- gadget )
-
listener-gadget-output <pane-stream> <interactor> ;
+
output>> <pane-stream> <interactor> ;
: listener-input, ( -- )
g <listener-input> g-> set-listener-gadget-input
"cookbook" ($link) "." print nl ;
M: listener-gadget focusable-child*
- listener-gadget-input ;
+ input>> ;
M: listener-gadget call-tool* ( input listener -- )
- >r input-string r> listener-gadget-input set-editor-string ;
+ >r string>> r> input>> set-editor-string ;
M: listener-gadget tool-scroller
- listener-gadget-output find-scroller ;
+ output>> find-scroller ;
: wait-for-listener ( listener -- )
#! Wait for the listener to start.
- listener-gadget-input interactor-flag wait-for-flag ;
+ input>> flag>> wait-for-flag ;
: workspace-busy? ( workspace -- ? )
- workspace-listener listener-gadget-input interactor-busy? ;
+ listener>> input>> interactor-busy? ;
: listener-input ( string -- )
- get-workspace
- workspace-listener
- listener-gadget-input set-editor-string ;
+ get-workspace listener>> input>> set-editor-string ;
: (call-listener) ( quot listener -- )
- listener-gadget-input interactor-call ;
+ input>> interactor-call ;
: call-listener ( quot -- )
- [ workspace-busy? not ] get-workspace* workspace-listener
+ [ workspace-busy? not ] get-workspace* listener>>
[ dup wait-for-listener (call-listener) ] 2curry
"Listener call" spawn drop ;
: eval-listener ( string -- )
get-workspace
- workspace-listener
- listener-gadget-input [ set-editor-string ] keep
+ listener>> input>> [ set-editor-string ] keep
evaluate-input ;
: listener-run-files ( seq -- )
] if ;
: com-end ( listener -- )
- listener-gadget-input interactor-eof ;
+ input>> interactor-eof ;
: clear-output ( listener -- )
- listener-gadget-output pane-clear ;
+ output>> pane-clear ;
\ clear-output H{ { +listener+ t } } define-command
stack-display new
g workspace-listener swap [
dup <toolbar> f track,
- listener-gadget-stack [ stack. ]
+ stack>> [ [ stack. ] curry try ]
t "Data stack" <labelled-pane> 1 track,
] { 0 1 } build-track ;
swap show-tool inspect-object ;
: listener-thread ( listener -- )
- dup <listener-stream> [
- [ [ ui-listener-hook ] curry listener-hook set ]
- [ [ ui-error-hook ] curry error-hook set ]
+ dup listener-streams [
- [
- [ [ ui-listener-hook ] curry listener-hook set ]
- [ [ ui-error-hook ] curry error-hook set ]
- [ [ ui-inspector-hook ] curry inspector-hook set ] tri
- welcome.
- listener
- ] with-input-stream*
- ] with-output-stream* ;
++ [ [ ui-listener-hook ] curry listener-hook set ]
++ [ [ ui-error-hook ] curry error-hook set ]
+ [ [ ui-inspector-hook ] curry inspector-hook set ] tri
+ welcome.
+ listener
- ] with-stream* ;
++ ] with-streams* ;
: start-listener-thread ( listener -- )
- [ listener-thread ] curry "Listener" spawn drop ;
+ [
+ [ input>> register-self ] [ listener-thread ] bi
+ ] curry "Listener" spawn drop ;
: restart-listener ( listener -- )
#! Returns when listener is ready to receive input.
- dup com-end dup clear-output
- dup start-listener-thread
- wait-for-listener ;
+ {
+ [ com-end ]
+ [ clear-output ]
+ [ start-listener-thread ]
+ [ wait-for-listener ]
+ } cleave ;
: init-listener ( listener -- )
f <model> swap set-listener-gadget-stack ;
[ default-gesture-handler ] [ 3drop f ] if ;
M: listener-gadget graft*
- dup delegate graft*
- dup listener-gadget-input interactor-thread ?box 2drop
- restart-listener ;
+ [ delegate graft* ] [ restart-listener ] bi ;
M: listener-gadget ungraft*
- dup com-end
- delegate ungraft* ;
+ [ com-end ] [ delegate ungraft* ] bi ;
projects / factor.git / commitdiff