diff --git a/TODO.txt b/TODO.txt index 064ba7cf40..ad1df4b360 100644 --- a/TODO.txt +++ b/TODO.txt @@ -1,22 +1,24 @@ + 0.87: - parse errors should be shown in a popup -- growable data heap + - menu Command: quots look dumb + - no need for modify-listener-operation! + - command buttons: indicate shortcuts +- http://paste.lisp.org/display/30426 +- update ui docs ++ 0.88: + +- growable data heap - variable width word wrap - graphical crossref tool -- http://paste.lisp.org/display/30426 - compiled call traces: - should be independent of whenever the runtime was built with -fomit-frame-pointer or not - doesn't show #labels - we don't know if signal handlers run with the same stack or not - -+ 0.88: - - use crc32 instead of modification date in reload-modules - models: don't do redundant work -- menu Command: quots look dumb - top level window positioning on ms windows - crashes: - callback scheduling issue @@ -31,6 +33,7 @@ - available-modules - :trace - string-lines + - md5, crc32 - auto-update browser and help when sources reload - mac intel: struct returns from objc methods - new windows don't always have focus, eg focus follows mouse diff --git a/core/errors.factor b/core/errors.factor index 6062f749a1..01660b4a69 100644 --- a/core/errors.factor +++ b/core/errors.factor @@ -30,16 +30,21 @@ SYMBOL: restarts [ >c drop call c> drop ] [ rot drop swap call ] ifcc ; inline -TUPLE: condition restarts cc ; +TUPLE: condition restarts continuation ; C: condition ( error restarts cc -- condition ) - [ set-condition-cc ] keep + [ set-condition-continuation ] keep [ set-condition-restarts ] keep [ set-delegate ] keep ; : condition ( error restarts -- restart ) [ throw ] callcc1 2nip ; +TUPLE: restart name obj continuation ; + +: restart ( restart -- ) + dup restart-obj swap restart-continuation continue-with ; + GENERIC: compute-restarts ( error -- seq ) M: object compute-restarts drop { } ; @@ -48,8 +53,9 @@ M: tuple compute-restarts delegate compute-restarts ; M: condition compute-restarts [ delegate compute-restarts ] keep - [ condition-cc ] keep - condition-restarts [ swap add ] map-with append ; + [ condition-continuation ] keep + condition-restarts [ first2 rot ] map-with + append ; PREDICATE: array kernel-error ( obj -- ? ) dup first \ kernel-error eq? swap second 0 18 between? and ; diff --git a/core/io/stdio.factor b/core/io/stdio.factor index 0a6b1aa459..bc0ec9a5ca 100644 --- a/core/io/stdio.factor +++ b/core/io/stdio.factor @@ -46,12 +46,7 @@ SYMBOL: stdio : write-outliner ( str obj content -- ) outline associate [ write-object ] with-nesting ; -: (print-input/quot) - associate [ H{ { font-style bold } } format ] with-nesting - terpri ; - : print-input ( string input -- ) - presented (print-input/quot) ; - -: print-quot ( string quot -- ) - quotation (print-input/quot) ; + presented associate + [ H{ { font-style bold } } format ] with-nesting + terpri ; diff --git a/core/tools/debugger.factor b/core/tools/debugger.factor index 82bee5bdb5..c7db949d41 100644 --- a/core/tools/debugger.factor +++ b/core/tools/debugger.factor @@ -64,7 +64,7 @@ M: string error. print ; "(offset " write word-xt - >hex write ")" write ; : bare-xt. ( xt -- ) - "C code: " write xt. ; + "C code: " write xt. ; : :trace error-stack-trace get symbolic-stack-trace [ @@ -78,12 +78,10 @@ M: string error. print ; error-continuation get continuation-name hash-stack ; : :res ( n -- ) - restarts get-global nth - f restarts set-global - first3 continue-with ; + restarts get-global nth f restarts set-global restart ; : :edit ( -- ) - error get delegates [ parse-error-file ] find nip [ + error get delegates [ parse-error? ] find-last nip [ dup parse-error-file ?resource-path swap parse-error-line edit-location ] when* ; @@ -104,8 +102,7 @@ M: string error. print ; } cond ; : restart. ( restart n -- ) - [ [ # " :res " % first % ] "" make ] keep - [ :res ] curry print-quot ; + [ # " :res " % restart-name % ] "" make print ; : restarts. ( -- ) restarts get dup empty? [ @@ -121,13 +118,13 @@ M: string error. print ; terpri "Debugger commands:" print terpri - ":help - documentation for this error" [ :help ] print-quot - ":s - data stack at exception time" [ :s ] print-quot - ":r - retain stack at exception time" [ :r ] print-quot - ":c - call stack at exception time" [ :c ] print-quot + ":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 error get [ parse-error? ] is? [ - ":edit - jump to source location" [ :edit ] print-quot + ":edit - jump to source location" print ] when ":get ( var -- value ) accesses variables at time of the error" print @@ -142,4 +139,7 @@ M: string error. print ; "Error in print-error!" print ] recover drop ; -: try ( quot -- ) [ print-error ] recover ; +SYMBOL: error-hook + +: try ( quot -- ) + [ error-hook get [ call ] [ print-error ] ?if ] recover ; diff --git a/core/tools/inspector.factor b/core/tools/inspector.factor index 64a25f9424..9a32dd6827 100644 --- a/core/tools/inspector.factor +++ b/core/tools/inspector.factor @@ -25,8 +25,8 @@ SYMBOL: inspector-stack : inspector-help ( -- ) "Object inspector." print - "up -- return to previous object" [ up ] print-quot - "me ( -- obj ) push this object" [ me ] print-quot + "up -- return to previous object" print + "me ( -- obj ) push this object" print "go ( n -- ) inspect nth slot" print terpri ; diff --git a/core/ui/gadgets/presentations.factor b/core/ui/gadgets/presentations.factor index f4b87793bf..9c9c5409e5 100644 --- a/core/ui/gadgets/presentations.factor +++ b/core/ui/gadgets/presentations.factor @@ -81,9 +81,6 @@ presentation H{ [ presentation-object summary ] [ "" ] if* ] dup reverse-video-theme ; -: ( gadget quot -- button ) - [ call-listener drop ] curry ; - ! Character styles : apply-style ( style gadget key quot -- style gadget ) @@ -106,16 +103,12 @@ presentation H{ : apply-presentation-style ( style gadget -- style gadget ) presented [ ] apply-style ; -: apply-quotation-style ( style gadget -- style gadget ) - quotation [ ] apply-style ; - : ( style text -- gadget )