1 files changed, 81 insertions, 0 deletions
diff --git a/parser/parser-debugger.scm b/parser/parser-debugger.scm
new file mode 100644
index 0000000..40d9382
--- /dev/null
+++ b/parser/parser-debugger.scm
@@ -0,0 +1,81 @@
+;;; These routines are strictly for debugging the parser.  They could
+;;; be removed from the system later.
+
+;;; define some debugging stuff
+;;;  Here's the debugging control:
+;;;  Capabilities:
+;;;      record start (line,token,production,k)
+;;;      record end (line,token,prodection,k)
+;;;      print end (line,token,prodection,k,value)
+;;;      break start
+;;;      break end
+
+(define *parser-debug-options* '())
+(define *parser-debug-lines* '())
+(define *parser-debug-id* 0)
+
+(define (watch-lines . lines)
+  (setf *parser-debug-lines* lines))
+
+(define (watching-this-line?)
+ (and (not (eq? *parser-debug-lines* 'none))
+  (or (null? *parser-debug-lines*)
+      (and (>= *current-line* (car *parser-debug-lines*))
+	   (or (null? (cdr *parser-debug-lines*))
+	       (<= *current-line* (cadr *parser-debug-lines*)))))))
+
+(define (ptrace-print-obj x)
+  (pprint x))
+
+(define (ptrace-breakpoint)
+  (error "Breakpoint~%"))
+
+(define (parser-show-context id tag msg)
+  (format '#t "~A parse of ~A(~A)  Line: ~A  Token: ~A"
+	  msg tag id *current-line* *token*)
+  (when (not (null? *token-args*))
+     (format '#t " ~A" *token-args*))
+  (format '#t "~%"))
+
+(define (ptrace-clear)
+  (setf *parser-debug-options* '()))
+
+(define (ptrace-pop)
+  (pop *parser-debug-options*))
+
+(define (ptrace-watch . things)
+  (dolist (x things)
+     (push (cons x 'watch) *parser-debug-options*)))
+
+(define (ptrace-show . things)
+  (dolist (x things)
+     (push (cons x 'show) *parser-debug-options*)))
+
+(define (ptrace-break . things)
+  (dolist (x things)
+     (push (cons x 'break) *parser-debug-options*)))
+
+;;; Routines called by the trace-parser macro
+
+(define (tracing-parse/entry tag)
+  (let ((all? (assq 'all *parser-debug-options*))
+	(this? (assq tag *parser-debug-options*)))
+    (cond ((or all? this?)
+	   (incf *parser-debug-id*)
+	   (parser-show-context *parser-debug-id* tag "Entering")
+	   (when (and this? (eq? (cdr this?) 'break))
+		 (ptrace-breakpoint))
+	   *parser-debug-id*)
+	  (else 0))))
+
+(define (tracing-parse/exit tag id res)
+  (let ((all? (assq 'all *parser-debug-options*))
+	(this? (assq tag *parser-debug-options*)))
+    (when (and (or all? this?) (not (eq? tag 0)))
+      (setf (dynamic *returned-obj*) res)
+      (parser-show-context id tag "Exiting")
+      (when (and this? (eq? (cdr this?) 'show))
+	    (ptrace-print-obj res))
+      (when (and this? (eq? (cdr this?) 'break))
+	    (ptrace-breakpoint)))))
+