[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