Code cleanup, fix stack assertion error

slava 2006-11-23 07:17:54 +00:00
parent 12db389fc2
commit 169b07e0b3
7 changed files with 20 additions and 16 deletions

View File

@ -7,6 +7,8 @@
- variable width word wrap - variable width word wrap
- graphical crossref tool - graphical crossref tool
- http://paste.lisp.org/display/30426 - http://paste.lisp.org/display/30426
- C+p: shows newlines as a box
- use mach exception handling to trap div by zero on os x
- menu Command: quots look dumb - menu Command: quots look dumb
- top level window positioning on ms windows - top level window positioning on ms windows

View File

@ -80,19 +80,19 @@ M: listener-gadget tool-help
listener-gadget swap find-tool nip tool-gadget listener-gadget swap find-tool nip tool-gadget
listener-gadget-input interactor-busy? ; listener-gadget-input interactor-busy? ;
: find-listener ( -- listener ) : get-listener ( -- listener )
listener-gadget listener-gadget
[ workspace-busy? not ] find-workspace* [ workspace-busy? not ] get-workspace*
show-tool tool-gadget ; show-tool tool-gadget ;
: (call-listener) ( quot listener -- ) : (call-listener) ( quot listener -- )
listener-gadget-input interactor-call ; listener-gadget-input interactor-call ;
: call-listener ( quot -- ) : call-listener ( quot -- )
find-listener (call-listener) ; get-listener (call-listener) ;
: eval-listener ( string -- ) : eval-listener ( string -- )
find-listener get-listener
listener-gadget-input [ set-editor-text ] keep listener-gadget-input [ set-editor-text ] keep
interactor-commit ; interactor-commit ;

View File

@ -33,7 +33,7 @@ M: messages compile-error
: <messages-button> ( -- gadget ) : <messages-button> ( -- gadget )
"Compiler messages" "Compiler messages"
[ drop find-workspace messages select-tool ] [ find-workspace messages select-tool ]
<bevel-button> ; <bevel-button> ;
M: messages batch-ends M: messages batch-ends

View File

@ -80,7 +80,7 @@ M: operation invoke-command ( target operation -- )
[ drop ] [ [ "USE: " % % " " % % ] "" make ] if ; [ drop ] [ [ "USE: " % % " " % % ] "" make ] if ;
: insert-word ( word -- ) : insert-word ( word -- )
find-listener [ word-completion-string ] keep get-listener [ word-completion-string ] keep
listener-gadget-input user-input ; listener-gadget-input user-input ;
[ word? ] H{ [ word? ] H{
@ -147,7 +147,7 @@ M: operation invoke-command ( target operation -- )
{ +primary+ t } { +primary+ t }
{ +name+ "Browse" } { +name+ "Browse" }
{ +keyboard+ T{ key-down f { A+ } "b" } } { +keyboard+ T{ key-down f { A+ } "b" } }
{ +quot+ [ vocab-link-name find-workspace swap show-vocab-words ] } { +quot+ [ vocab-link-name get-workspace swap show-vocab-words ] }
} define-operation } define-operation
[ vocab-link? ] H{ [ vocab-link? ] H{
@ -199,7 +199,7 @@ M: operation invoke-command ( target operation -- )
{ +primary+ t } { +primary+ t }
{ +name+ "Browse" } { +name+ "Browse" }
{ +keyboard+ T{ key-down f { A+ } "b" } } { +keyboard+ T{ key-down f { A+ } "b" } }
{ +quot+ [ find-workspace swap show-module-files ] } { +quot+ [ get-workspace swap show-module-files ] }
} define-operation } define-operation
[ module? ] H{ [ module? ] H{

View File

@ -34,7 +34,7 @@ search-field H{
: <search-list> ( seq producer presenter -- gadget ) : <search-list> ( seq producer presenter -- gadget )
-rot curry <search-model> -rot curry <search-model>
[ [ workspace? ] find-parent hide-popup ] -rot [ find-workspace hide-popup ] -rot
<list> ; <list> ;
C: live-search ( string seq producer presenter -- gadget ) C: live-search ( string seq producer presenter -- gadget )
@ -126,7 +126,7 @@ C: history-search ( string seq -- gadget )
[ delegate>live-search ] keep ; [ delegate>live-search ] keep ;
: search-action ( search -- obj ) : search-action ( search -- obj )
dup [ workspace? ] find-parent hide-popup dup find-workspace hide-popup
live-search-list list-value ; live-search-list list-value ;
: show-titled-popup ( workspace gadget title -- ) : show-titled-popup ( workspace gadget title -- )

View File

@ -22,6 +22,8 @@ M: gadget tool-help drop f ;
TUPLE: workspace book popup ; TUPLE: workspace book popup ;
: find-workspace [ workspace? ] find-parent ;
TUPLE: tool gadget ; TUPLE: tool gadget ;
: find-tool ( class workspace -- index tool ) : find-tool ( class workspace -- index tool )
@ -34,17 +36,17 @@ TUPLE: tool gadget ;
: select-tool ( workspace class -- ) swap show-tool drop ; : select-tool ( workspace class -- ) swap show-tool drop ;
: find-workspace* ( quot -- workspace ) : get-workspace* ( quot -- workspace )
[ dup workspace? [ over call ] [ drop f ] if ] find-window [ dup workspace? [ over call ] [ drop f ] if ] find-window
[ nip dup raise-window world-gadget ] [ nip dup raise-window world-gadget ]
[ workspace-window drop find-workspace* ] if* ; inline [ workspace-window drop get-workspace* ] if* ; inline
: find-workspace ( -- workspace ) [ drop t ] find-workspace* ; : get-workspace ( -- workspace ) [ drop t ] get-workspace* ;
: call-tool ( arg class -- ) : call-tool ( arg class -- )
find-workspace show-tool call-tool* ; get-workspace show-tool call-tool* ;
: get-tool ( class -- gadget ) : get-tool ( class -- gadget )
find-workspace find-tool nip tool-gadget ; get-workspace find-tool nip tool-gadget ;
: find-messages ( -- gadget ) messages get-tool ; : find-messages ( -- gadget ) messages get-tool ;

View File

@ -75,7 +75,7 @@ M: walker-gadget tool-help drop "ui-walker" ;
: walker-step-all ( walker -- ) : walker-step-all ( walker -- )
dup [ step-all ] walker-command reset-walker dup [ step-all ] walker-command reset-walker
find-workspace listener-gadget select-tool ; get-workspace listener-gadget select-tool ;
walker-gadget "toolbar" { walker-gadget "toolbar" {
{ "Step" T{ key-down f f "s" } [ walker-step ] } { "Step" T{ key-down f f "s" } [ walker-step ] }