[uim-commit] r813 - trunk/scm
yamaken at freedesktop.org
yamaken at freedesktop.org
Sat Apr 2 16:24:51 PST 2005
Author: yamaken
Date: 2005-04-02 16:24:47 -0800 (Sat, 02 Apr 2005)
New Revision: 813
Modified:
trunk/scm/uim-db.scm
Log:
* This commit improves the interactive debugger for the uim Scheme
interpreter. All changes had been contributed by Jun Inoue
in [Anthy-dev 1961] and [Anthy-dev 1963]. Thank you for the help.
* scm/uim-db.scm
- (uim-db-every, uim-db-do-display, uim-db-add-hook!,
uim-db-del-hook!): New procedure
- (record uim-db-breakpoint): New record
- (uim-db-insert-code!): Modify a message
- (uim-db-set-break!, uim-db-del-break!, uim-db-break):
* Ditto
* Simplify with uim-db-breakpoint
- (uim-db-shell):
* Split help message off
* Simplify with uim-db-breakpoint
- (uim-db-help):
* Split help message off
- (uim-db-help-database): New variable
Modified: trunk/scm/uim-db.scm
===================================================================
--- trunk/scm/uim-db.scm 2005-03-30 14:06:54 UTC (rev 812)
+++ trunk/scm/uim-db.scm 2005-04-03 00:24:47 UTC (rev 813)
@@ -63,6 +63,10 @@
(lambda (f l)
(pair-fold (lambda (lis e) (f (car lis))) () l)))
+(define uim-db-every
+ (lambda (f l)
+ (pair-fold (lambda (lis e) (and e (f (car lis)))) #t l)))
+
(define uim-db-walk-tree
(lambda (f x)
(if (not (uim-db-molecular? x))
@@ -80,6 +84,17 @@
(set! uim-db-next-display-id
(+ 1 uim-db-next-display-id))))
+(define uim-db-do-display
+ (lambda dummy
+ (uim-db-for-each
+ (lambda (l)
+ (uim-db-puts "Display " (car l) ": ")
+ (print (cdr l))
+ (puts " ==> ")
+ (*catch 'all (print (eval (cdr l) env))))
+ uim-db-display)
+ #t))
+
(define uim-db-del-display!
(lambda (id)
(set! uim-db-display
@@ -124,12 +139,62 @@
(dbg-copy-info! (cdr code) '()) ; invalidate
(dbg-copy-info! (cddr code) pos)
(set-car! pos code))
- (print "Invalid argument to uim-db-insert-code!"))))
+ (print "Invalid argument to uim-db-insert-code!\n"))))
(define uim-db-restore-code!
(lambda (pos)
(set-car! pos (cadr (cdar pos)))))
+; breakpoint descriptor
+(define-record
+ 'uim-db-breakpoint
+ (list
+ (list 'id #f)
+ (list 'pos ()) ; the position that uim-db-find found
+ (list 'expr ()) ; the expression that this is set on
+ (list 'next-hook-id 1)
+ (list 'hook-alist (list
+ (cons -1 uim-db-do-display)))))
+
+(define uim-db-add-hook!
+ (lambda (break-id f)
+ (if (procedure? f)
+ (let ((bp (srfi-assoc break-id uim-db-breakpoint-alist =)))
+ (uim-db-breakpoint-set-hook-alist!
+ bp
+ (cons (cons (uim-db-breakpoint-next-hook-id bp) f)
+ (uim-db-breakpoint-hook-alist bp)))
+ (uim-db-puts "Set hook "
+ (uim-db-breakpoint-next-hook-id bp)
+ " on breakpoint "
+ break-id
+ "\n")
+ (uim-db-breakpoint-set-next-hook-id!
+ bp
+ (+ 1 (uim-db-breakpoint-next-hook-id bp))))
+ (puts "Invalid argument to uim-db-add-hook!\n"))))
+
+(define uim-db-del-hook!
+ (lambda (break-id hook-id)
+ (let ((bp (srfi-assoc break-id uim-db-breakpoint-alist =)))
+ (if bp
+ (if (srfi-assoc hook-id
+ (uim-db-breakpoint-hook-alist bp)
+ =)
+ (begin
+ (uim-db-breakpoint-set-hook-alist!
+ bp
+ (uim-db-alist-delete! hook-id
+ (uim-db-breakpoint-hook-alist bp)
+ =))
+ (uim-db-puts "Deleted hook "
+ hook-id
+ " of breakpoint "
+ break-id
+ "\n"))
+ (puts "Invalid hook ID.\n"))
+ (puts "Invalid breakpoint ID.\n")))))
+
(define uim-db-set-break!
(lambda criteria
(cond
@@ -152,13 +217,13 @@
", on expression\n")
(print code)
(set! uim-db-breakpoint-alist
- (cons (list uim-db-next-id pos code)
+ (cons (uim-db-breakpoint-new uim-db-next-id pos code)
uim-db-breakpoint-alist))
(set! uim-db-next-id (+ uim-db-next-id 1))
(set! uim-db-current-file (car criteria)))
(puts "Error: specified code not found\n"))))
(else
- (puts "Usage: (uim-db-set-break! file-name line-number)")))))
+ (puts "Usage: (uim-db-set-break! file-name line-number)\n")))))
(define uim-db-del-break!
(lambda (id)
@@ -169,92 +234,87 @@
(uim-db-alist-delete! id
uim-db-breakpoint-alist
=))
- (uim-db-restore-code! (cadr bp))
+ (uim-db-restore-code! (uim-db-breakpoint-pos bp))
(uim-db-puts "Deleted breakpoint "
id
" at "
- (dbg-get-file (cadr bp))
+ (dbg-get-file (uim-db-breakpoint-pos bp))
":"
- (dbg-get-line (cadr bp))
+ (dbg-get-line (uim-db-breakpoint-pos bp))
"\n"))
(puts "Invalid breakpoint ID.\n")))))
(define uim-db-break
(lambda (env id)
(let ((bp (srfi-assoc id uim-db-breakpoint-alist =)))
- (uim-db-puts "Breakpoint "
- (car bp)
- " hit at "
- (dbg-get-file (cadr bp))
- ":"
- (dbg-get-line (cadr bp))
- "\n"
- "Type @help if you "
- "don't know what to do.\n")
- (uim-db-for-each
- (lambda (l)
- (uim-db-puts "Display " (car l) ": ")
- (print (cdr l))
- (puts " ==> ")
- (*catch 'all (print (eval (cdr l) env))))
- uim-db-display)
- (puts uim-db-prompt)
- (let interact ((expr (read)))
- (if (and (not (eq? (eof-val) expr))
- (not (memq expr '(@c @cont @continue))))
+ (if (uim-db-every
+ (lambda (x) ((cdr x) env bp))
+ (uim-db-breakpoint-hook-alist bp))
+ (begin
+ (uim-db-puts "Breakpoint "
+ (uim-db-breakpoint-id bp)
+ " hit at "
+ (dbg-get-file (uim-db-breakpoint-pos bp))
+ ":"
+ (dbg-get-line (uim-db-breakpoint-pos bp))
+ "\n"
+ "Type (uim-db-help 'shell) if you don't "
+ "know what to do.\n")
+ (uim-db-shell env bp)
+ (puts "Continuing execution.\n"))))))
+
+(define uim-db-shell
+ (lambda args
+ (puts uim-db-prompt)
+ (let ((env (if (>= (length args) 1) (car args) ()))
+ (bp (if (>= (length args) 2) (cadr args) #f))
+ (expr (*catch 'all (read))))
+ (if (or (eq? (eof-val) expr)
+ (memq expr '(@c @cont @continue)))
+ #f
(begin
- (case expr
- ((@break @b)
- (let ((arg (read)))
- (if (string? arg)
- (begin
- (set! uim-db-current-file arg)
- (set! arg (read))))
- (uim-db-set-break! uim-db-current-file arg)))
- ((@del @d)
- (uim-db-del-break! (read)))
- ((@expression @expr @exp @e)
- (uim-db-puts "This breakpoint is set on the expression:\n"
- (car (cddr bp))
- "Breakpoint "
- (car bp)
- " at "
- (dbg-get-file (cadr bp))
- ":"
- (dbg-get-line (cadr bp))
- "\n"))
- ((@help)
- (uim-db-puts "Basically this is uim-sh in the environment "
- "surrounding the breakpoint. You can inspect "
- "and/or mutate global and local variables as "
- "you wish.\n"
- "In addition to that, a few special commands "
- "beginning with `@' are available:\n"
- "@continue/@cont/@c\n"
- "\tContinues execution of the program.\n"
- "@break/@b [<f>] <l>\n"
- "\tA shorthand for (uim-db-set-break! <f> "
- "<l>).\n"
- "@del/@d <n>\n"
- "\tSame as (uim-db-del-break! <n>)\n"
- "@expression/@expr/@exp/@e\n"
- "\tPrints the next expression to be "
- "evaluated.\n"
- "@display/@disp/@di <expr>\n"
- "\tEquivalent to (uim-db-add-display! <expr>)\n"
- "@undisplay/@undisp/@u <i>\n"
- "\tShorthand for (uim-db-del-display! <i>)\n"))
- ((@display @disp @di)
- (uim-db-add-display! (read)))
- ((@undisplay @undisp @u)
- (uim-db-del-display! (read)))
- (else
- (*catch 'all
- (print (eval expr env)))))
- (puts uim-db-prompt)
- (interact (read)))
- ; @continue @cont @c
- (puts "Continuing execution.\n"))))))
+ (*catch
+ 'all
+ (case expr
+ ((@break @b)
+ (let ((arg (eval (read))))
+ (if (string? arg)
+ (begin
+ (set! uim-db-current-file arg)
+ (set! arg (eval (read)))))
+ (uim-db-set-break! uim-db-current-file arg)))
+ ((@del @d)
+ (uim-db-del-break! (eval (read))))
+ ((@expression @expr @exp @e)
+ (if (null? bp)
+ (puts "You can't do that in a manually-invoked shell.\n")
+ (uim-db-puts
+ "This breakpoint is set on the expression:\n"
+ (uim-db-breakpoint-expr bp)
+ "Breakpoint "
+ (uim-db-breakpoint-id bp)
+ " at "
+ (dbg-get-file (uim-db-breakpoint-pos bp))
+ ":"
+ (dbg-get-line (uim-db-breakpoint-pos bp))
+ "\n")))
+ ((@display @disp @di)
+ (uim-db-add-display! (read))) ; don't eval
+ ((@undisplay @undisp @u)
+ (uim-db-del-display! (eval (read))))
+ ((@hook)
+ (if (null? bp)
+ (puts "You can't do that in a manually-invoked shell.\n")
+ (uim-db-add-hook! (uim-db-breakpoint-id bp)
+ (eval (read)))))
+ ((@unhook @delhook)
+ (if (null? bp)
+ (puts "You can't do that in a manually-invoked shell.\n")
+ (uim-db-del-hook! (uim-db-breakpoint-id bp)
+ (eval (read)))))
+ (else
+ (print (eval expr env)))))
+ (uim-db-shell env bp))))))
; You MUST NOT set breakpoints in the following functions,
; as uim-db-break calls them.
@@ -302,21 +362,124 @@
(define uim-db-help
- (lambda ()
- (puts
-"(uim-db-set-break! file line) or
-(uim-db-set-break! line)
-Sets a breakpoint at the innermost list containing code at file:line. The code must be enclosed in a toplevel closure. If file is omitted, it's substituted with the one from the previous call.
+ (lambda args
+ (let help ((topics args)
+ (database uim-db-help-database))
+ (cond
+ ((not database)
+ (puts "Sorry, that topic isn't available."))
+ ((null? topics)
+ (apply uim-db-puts (cadr database))
+ (if (pair? (cddr database))
+ (begin
+ (puts "\nSubtopics:\n")
+ (uim-db-for-each
+ (lambda (db)
+ (print (car db)))
+ (cddr database)))))
+ (else
+ (help (cdr topics) (srfi-assoc (car topics)
+ (cdr database))))))))
-(uim-db-del-break! id)
-Deletes a breakpoint.
-
-(uim-db-add-display! expr)
-expr is evaluated and displayed every time a breakpoint is hit.
-
-(uim-db-del-display! id)
-Deletes a display.
-
-uim-db-break-at-molecule (variable)
-Set breakpoints at the code at file:line rather than around it.\n")))
-
+(define uim-db-help-database
+ ; <database> --> (<entry>+)
+ ; <entry> --> (<topic> (<string>+) <entry>*)
+ '(()
+ ("(uim-db-help <topic> [<subtopic> <subsubtopic>...])\n"
+ "This is the manual for uim-db. <topic>s should be passed as symbols.\n")
+ (breakpoint
+ ("(uim-db-set-break! file line) or (uim-db-set-break! line) sets "
+ "a breakpoint. (uim-db-del-break! id) deletes it.\n")
+ (uim-db-set-break!
+ ("(uim-db-set-break! file line) or \n"
+ "(uim-db-set-break! line)\n"
+ "Sets a breakpoint at the innermost list containing code at "
+ "file:line. The code must be enclosed in a toplevel closure. "
+ "If file is omitted, it's substituted with the one from the "
+ "previous call.\n"
+ "If uim-db-break-at-molecule is set to true (#f by default), "
+ "The breakpoint is set *on* a code at file:line rather than "
+ "around it.\n"))
+ (uim-db-del-break!
+ ("(uim-db-del-break! id)\n"
+ "Deletes a breakpoint. The ID should have been shown when "
+ "you set it.\n"))
+ (descriptor
+ ("A breakpoint is described by a list whose field can be retreived "
+ "with uim-db-breakpoint-<field> and mutated with "
+ "uim-db-breakpoint-set-<field>! where <field> is any of:\n"
+ "id\n"
+ "\tThe breakpoint's ID.\n"
+ "pos\n"
+ "\tThe position at which the breakpoint is set. Pass it to "
+ "dbg-get-info to obtain the file and line.\n"
+ "expr\n"
+ "\tThe expression on which the breakpoint is set.\n\n"
+ "See also: hook\n")))
+ (display
+ ("Displays are expressions evaluated and printed every time "
+ "execution stops at a breakpoint. (uim-db-add-display! expr) "
+ "adds one, (uim-db-del-display! id) deletes one. "
+ "(uim-db-do-display) does the actual displaying.\n"
+ "See also: hook\n"))
+ (hook
+ ("Each breakpoint can have hook functions assigned. "
+ "If any of the hooks returns #f, "
+ "the breakpoint is skipped. ALL SUBSEQUENT HOOKS AND DISPLAYS "
+ "ARE SKIPPED as well. If you want the display, explicitly call "
+ "uim-db-do-display before returning #f.\n"
+ "Hooks are executed in LIFO order, so you can entirely disable a "
+ "breakpoint by adding (lambda dummy #f) to its hooks.\n"
+ "See also: display\n")
+ (uim-db-add-hook!
+ ("(uim-db-add-hook! id hook)\n"
+ "Adds the hook to the breakpoint specified by id.\n"))
+ (uim-db-del-hook!
+ ("(uim-db-del-hook! breakpoint-id hook-id)\n"
+ "Deletes a hook. Hook IDs are local to each breakpoint.\n"))
+ (hook-spec
+ ("A hook is a function "
+ "that looks like (lambda (env bp . extra)...). Env will be "
+ "bound to the "
+ "environment that was active right before hitting the breakpoint, "
+ "bp will be the breakpoint's descriptor, and extra is reserved for "
+ "future use. Return #f if "
+ "you want the breakpoint to be skipped. All subsequent hooks "
+ "and displays are skipped, too, so be careful.\n")))
+ (shell
+ ("When a breakpoint is hit, the debugger shell, identified by the "
+ "prompt uim-db>, will be invoked. This is identical to uim-sh "
+ "except that the environment in effect will be the one that was "
+ "active on encountering the breakpoint. Hence you can examine "
+ "and/or manipulate local variables.\n"
+ "In addition, a few special commands (mainly shorthands) "
+ "beginning with `@' are supplied. You can also invoke the shell "
+ "manually.\n")
+ (uim-db-shell
+ ("(uim-db-shell) or\n"
+ "(uim-db-shell env)\n"
+ "Invokes the debugger shell. The shell will be executed in the "
+ "specified environment or toplevel if omitted."))
+ (commands
+ ("Note: the ones marked with *** aren't available when the debugger "
+ "shell is invoked manually.\n"
+ "@continue/@cont/@c\n"
+ "\tExit the shell and continue execution of the program.\n"
+ "@break/@b [<f>] <l>\n"
+ "\tA shorthand for (uim-db-set-break! <f> "
+ "<l>).\n"
+ "@del/@d <n>\n"
+ "\tSame as (uim-db-del-break! <n>)\n"
+ "@expression/@expr/@exp/@e ***\n"
+ "\tPrints the next expression to be "
+ "evaluated.\n"
+ "@display/@disp/@di <expr>\n"
+ "\tEquivalent to (uim-db-add-display! '<expr>) (notice the quote).\n"
+ "@help <topic>\n"
+ "\tExecutes (uim-db-help).\n"
+ "@undisplay/@undisp/@u <i>\n"
+ "\tShorthand for (uim-db-del-display! <i>)\n"
+ "@hook <proc> ***\n"
+ "\tAdds <proc> to the hooks list of the current breakpoint.\n"
+ "@unhook/@delhook <hook-id> ***\n"
+ "\tRemoves a hook.\n")))))
More information about the Uim-commit
mailing list