[uim-commit] r777 - in trunk: scm test uim
yamaken at freedesktop.org
yamaken at freedesktop.org
Wed Mar 9 03:18:31 PST 2005
Author: yamaken
Date: 2005-03-09 03:18:29 -0800 (Wed, 09 Mar 2005)
New Revision: 777
Added:
trunk/scm/uim-db.scm
trunk/test/test-db.scm
Modified:
trunk/scm/Makefile.am
trunk/uim/slib.c
Log:
* This commit add a interactive debugger for the uim Scheme
interpreter. All of implementation has been contributed by Jun Inoue
in [Anthy-dev 1806] and [Anthy-dev 1812]. Thank you for the great
help
* uim/slib.c
- (_NEWCELL): Removed
- (NEWCELL): Remove obsolete debugger handlings
- (dbg_mod): New static variable
- (lreadr, lreadparen, closure, leval_lambda, letstar_macro,
named_let_macro, normal_let_macro, letrec_macro): Add debugger
handlings
- (readtl): Remove debugger handlings and merge orig_readtl()
- (orig_readtl): Removed
- (dbg_lineinc, dbg_linedec): Modify debugger handlings about line
number information
- (dbg_readini, dbg_readend): Modify debugger handlings
- (dbg_register_closure, dbg_expand_file_name, dbg_get_info,
dbg_get_line, dbg_get_file, dbg_copy_info): New procedure
- (integer2string): New procedure
- (init_dbg): Add initialization of dbg-get-info, dbg-get-line,
dbg-copy-info!, dbg-expand-file-name, dbg-closures and
number->string
* scm/uim-db.scm
- New file
- (uim-db-prompt, uim-db-break-at-molecule, uim-db-current-file,
uim-db-next-id, uim-db-next-display-id, uim-db-breakpoint-alist,
uim-db-display): New variable
- (uim-db-print, uim-db-molecular?, uim-db-for-each,
uim-db-walk-tree, uim-db-add-display!, uim-db-del-display!,
uim-db-find, uim-db-insert-code!, uim-db-restore-code!,
uim-db-set-break!, uim-db-del-break!, uim-db-break, uim-db-puts,
uim-db-alist-delete!, uim-db-help): New procedure
- (pair-fold, srfi-assoc): New procedure
* test/test-db.scm
- New file
- (test-db-find, test-db-dep): New procedure
- (testcase debugger): New testcase
- (test uim-db-find, test for external dependency): New test
* scm/Makefile.am
- (SCM_FILES): Add uim-db.scm
Modified: trunk/scm/Makefile.am
===================================================================
--- trunk/scm/Makefile.am 2005-03-08 19:45:27 UTC (rev 776)
+++ trunk/scm/Makefile.am 2005-03-09 11:18:29 UTC (rev 777)
@@ -7,7 +7,7 @@
SCM_FILES = plugin.scm im.scm im-custom.scm lazy-load.scm init.scm \
default.scm \
util.scm key.scm ustr.scm action.scm load-action.scm i18n.scm \
- uim-sh.scm custom.scm custom-rt.scm \
+ uim-sh.scm uim-db.scm custom.scm custom-rt.scm \
manage-modules.scm \
direct.scm \
rk.scm \
Added: trunk/scm/uim-db.scm
===================================================================
--- trunk/scm/uim-db.scm 2005-03-08 19:45:27 UTC (rev 776)
+++ trunk/scm/uim-db.scm 2005-03-09 11:18:29 UTC (rev 777)
@@ -0,0 +1,322 @@
+;;; uim-db.scm: uim interactive debugger
+;;;
+;;; Copyright (c) 2005 uim Project http://uim.freedesktop.org/
+;;;
+;;; All rights reserved.
+;;;
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+;;; 1. Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+;;; 2. Redistributions in binary form must reproduce the above copyright
+;;; notice, this list of conditions and the following disclaimer in the
+;;; documentation and/or other materials provided with the distribution.
+;;; 3. Neither the name of authors nor the names of its contributors
+;;; may be used to endorse or promote products derived from this software
+;;; without specific prior written permission.
+;;;
+;;; THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
+;;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
+;;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+;;; OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+;;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+;;; SUCH DAMAGE.
+;;;;
+
+(define uim-db-prompt "uim-db> ")
+(define uim-db-break-at-molecule #f)
+
+(define uim-db-current-file "")
+(define uim-db-next-id 1)
+(define uim-db-next-display-id 1)
+(define uim-db-breakpoint-alist '())
+(define uim-db-display '())
+
+(define uim-db-print
+ (lambda (x)
+ (puts "\n>>> ")
+ (print (dbg-get-info x))
+ (print x)))
+
+; can we set breakpoints within x?
+; FIXME: is there a better-known term for this?
+(define uim-db-molecular?
+ (lambda (x)
+ (or (not (pair? x))
+ (memq (car x) '(quote +internal-backquote)))))
+
+; partial implementation
+(define pair-fold
+ (lambda (f e lis)
+ (if (null? lis)
+ e
+ (let ((nextls (cdr lis))) ; be set-cdr! safe
+ (pair-fold f (f lis e) nextls)))))
+
+(define uim-db-for-each
+ (lambda (f l)
+ (pair-fold (lambda (lis e) (f (car lis))) () l)))
+
+(define uim-db-walk-tree
+ (lambda (f x)
+ (if (not (uim-db-molecular? x))
+ (begin
+ (f x)
+ (uim-db-walk-tree f (car x))
+ (uim-db-walk-tree f (cdr x))))))
+
+(define uim-db-add-display!
+ (lambda (expr)
+ (set! uim-db-display
+ (cons (cons uim-db-next-display-id
+ expr)
+ uim-db-display))
+ (set! uim-db-next-display-id
+ (+ 1 uim-db-next-display-id))))
+
+(define uim-db-del-display!
+ (lambda (id)
+ (set! uim-db-display
+ (uim-db-alist-delete! id
+ uim-db-display
+ =))))
+
+(define uim-db-find
+ (lambda (file line)
+ (let* ((closer
+ (lambda (l cand)
+ (if (and (<= (dbg-get-line cand)
+ (dbg-get-line l))
+ (<= (dbg-get-line l)
+ line)
+ (< (dbg-get-line cand)
+ line))
+ l
+ cand)))
+ (descend (lambda (x) (pair-fold closer '() x)))
+ (mod (srfi-assoc (dbg-expand-file-name file)
+ dbg-closures
+ string=?))
+ (proc (and mod
+ (pair-fold (lambda (l x) (closer (car l) x))
+ '()
+ (cdr mod)))))
+ (if proc
+ (let probe ((prev (cddr (%%closure-code proc)))
+ (code (descend (cddr (%%closure-code proc)))))
+ (if (uim-db-molecular? (car code))
+ (if uim-db-break-at-molecule
+ code
+ prev)
+ (probe code (descend (car code)))))
+ #f))))
+
+(define uim-db-insert-code!
+ (lambda (pos c)
+ (if (pair? pos)
+ (let ((code (list 'begin c (car pos))))
+ (dbg-copy-info! (cdr code) '()) ; invalidate
+ (dbg-copy-info! (cddr code) pos)
+ (set-car! pos code))
+ (print "Invalid argument to uim-db-insert-code!"))))
+
+(define uim-db-restore-code!
+ (lambda (pos)
+ (set-car! pos (cadr (cdar pos)))))
+
+(define uim-db-set-break!
+ (lambda criteria
+ (cond
+ ((number? (car criteria))
+ (uim-db-set-break! uim-db-current-file (car criteria)))
+ ((and (string? (car criteria))
+ (number? (cadr criteria)))
+ (let ((pos (uim-db-find (car criteria) (cadr criteria))))
+ (if (pair? pos)
+ (let ((code (car pos)))
+ (uim-db-insert-code! pos (list 'uim-db-break
+ '(the-environment)
+ uim-db-next-id))
+ (uim-db-puts "Breakpoint "
+ uim-db-next-id
+ " set at "
+ (dbg-get-file pos)
+ ":"
+ (dbg-get-line pos)
+ ", on expression\n")
+ (print code)
+ (set! uim-db-breakpoint-alist
+ (cons (list 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)")))))
+
+(define uim-db-del-break!
+ (lambda (id)
+ (let ((bp (srfi-assoc id uim-db-breakpoint-alist =)))
+ (if bp
+ (begin
+ (set! uim-db-breakpoint-alist
+ (uim-db-alist-delete! id
+ uim-db-breakpoint-alist
+ =))
+ (uim-db-restore-code! (cadr bp))
+ (uim-db-puts "Deleted breakpoint "
+ id
+ " at "
+ (dbg-get-file (cadr bp))
+ ":"
+ (dbg-get-line (cadr 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))))
+ (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"))))))
+
+; You MUST NOT set breakpoints in the following functions,
+; as uim-db-break calls them.
+(define uim-db-puts
+ (lambda args
+ (uim-db-for-each
+ (lambda (x)
+ (case (typeof x)
+ ((tc_string tc_symbol) (puts x))
+ ((tc_intnum) (puts (number->string x)))
+ (else (print x))))
+ args)))
+
+(define srfi-assoc
+ (lambda args
+ (let loop ((key (car args))
+ (alist (cadr args))
+ (key=? (if (pair? (cddr args))
+ (car (cddr args))
+ equal?)))
+ (cond ((null? alist)
+ #f)
+ ((key=? (caar alist) key)
+ (car alist))
+ (else
+ (loop key (cdr alist) key=?))))))
+
+(define uim-db-alist-delete!
+ (lambda args
+ (let ((key (car args))
+ (pred (if (pair? (cddr args))
+ (car (cddr args))
+ equal?))
+ (result (cons 0 (cadr args))))
+ (pair-fold (lambda (lis ans)
+ (if (pred key (caar lis))
+ (begin
+ (set-cdr! ans (cdr lis))
+ ans)
+ (cdr ans)))
+ result
+ (cadr args))
+ (cdr result))))
+
+
+
+(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.
+
+(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")))
+
Added: trunk/test/test-db.scm
===================================================================
--- trunk/test/test-db.scm 2005-03-08 19:45:27 UTC (rev 776)
+++ trunk/test/test-db.scm 2005-03-09 11:18:29 UTC (rev 777)
@@ -0,0 +1,105 @@
+#!/usr/bin/env gosh
+
+;;; Copyright (c) 2005 uim Project http://uim.freedesktop.org/
+;;;
+;;; All rights reserved.
+;;;
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+;;; 1. Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+;;; 2. Redistributions in binary form must reproduce the above copyright
+;;; notice, this list of conditions and the following disclaimer in the
+;;; documentation and/or other materials provided with the distribution.
+;;; 3. Neither the name of authors nor the names of its contributors
+;;; may be used to endorse or promote products derived from this software
+;;; without specific prior written permission.
+;;;
+;;; THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
+;;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
+;;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+;;; OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+;;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+;;; SUCH DAMAGE.
+;;;;
+
+
+
+; Tests for uim-db requires debugging information, so we have to let
+; libuim load this file and give it a toplevel procedure.
+
+(define test-db-find
+ (lambda ()
+ (if (feature? 'debug)
+ (begin
+ (let ((check
+ (lambda (code)
+ (eq? (cdr code)
+ (uim-db-find
+ (dbg-get-file code)
+ (+ 1 (dbg-get-line code)))))))
+ (let* ((q quote))
+ (let name ((code (q (place-holder
+ (target)))))
+ (uim-db-set-break! (dbg-get-file check)
+ (dbg-get-line check))
+ (check code)))))
+ #t)))
+
+; Certain functions in uim-db.scm are not allowed to call scheme
+; functions in other files. Otherwise setting a breakpoint to the
+; function being used may cause an infinite recursion.
+(define test-db-dep
+ (lambda ()
+ (letrec ((exclude
+ '(dbg-closures)) ; don't follow these symbols
+ (dependent?
+ (lambda (datum)
+ (case (typeof datum)
+ ((tc_closure)
+ (or (if (or (null? (dbg-get-info datum))
+ (string=? (dbg-get-file datum)
+ (dbg-expand-file-name "uim-db.scm")))
+ #f
+ ; gosh doesn't recognize "#<CLOSURE arg...>"
+ (%%closure-code datum))
+ (dependent? (cddr (%%closure-code datum)))))
+ ((tc_symbol)
+ (and (symbol-bound? datum)
+ (not (memq datum exclude))
+ (begin
+ (set! exclude (cons datum exclude))
+ (dependent? (eval datum)))))
+ ((tc_cons)
+ (or (dependent? (car datum))
+ (dependent? (cdr datum))))
+ (else #f)))))
+ (if (feature? 'debug)
+ (any dependent?
+ (cdr (srfi-assoc (dbg-expand-file-name "uim-db.scm")
+ dbg-closures
+ string=?)))
+ #f))))
+
+; shadow this part from libuim
+(if (not (symbol-bound? 'feature?))
+ (begin
+ (use test.unit)
+
+ (require "test/uim-test-utils")
+
+ (define-uim-test-case "testcase debugger"
+ (setup
+ (lambda ()
+ (uim '(begin (load "test/test-db.scm")
+ (load "uim-db.scm")))))
+ ("test uim-db-find"
+ (assert-true (uim-bool '(test-db-find))))
+ ("test for external dependency"
+ (assert-false (uim-bool '(test-db-dep)))))))
Modified: trunk/uim/slib.c
===================================================================
--- trunk/uim/slib.c 2005-03-08 19:45:27 UTC (rev 776)
+++ trunk/uim/slib.c 2005-03-09 11:18:29 UTC (rev 777)
@@ -81,6 +81,7 @@
removed non-standard _"str" syntax for i18n (Sep-30-2004) YamaKen
added NESTED_REPL_C_STRING feature (Dec-31-2004) YamaKen
added heap_alloc_threshold and make configurable (Jan-07-2005) YamaKen
+ added support for interactive debugging (Feb-09-2005) Jun Inoue
*/
#include "config.h"
@@ -94,6 +95,7 @@
#include <stdlib.h>
#include <time.h>
#include <errno.h>
+#include <limits.h>
#include <sys/types.h>
#if HAVE_SYS_TIMES_H
#include <sys/times.h>
@@ -181,6 +183,7 @@
static LISP closure (LISP env, LISP code);
static LISP ptrcons (void *ptr);
static LISP funcptrcons (C_FUNC ptr);
+static LISP assoc (LISP x, LISP alist);
static void init_subr (char *name, long type, SUBR_FUNC fcn);
static void init_subr_0 (char *name, LISP (*fcn) (void));
@@ -251,7 +254,7 @@
#define STACK_CHECK(_ptr) \
if (((char *) (_ptr)) < stack_limit_ptr) err_stack((char *) _ptr);
-#define _NEWCELL(_into, _type) \
+#define NEWCELL(_into, _type) \
{ if NULLP(freelist) \
gc_for_newcell(); \
_into = freelist; \
@@ -260,15 +263,11 @@
(*_into).gc_mark = 0; \
(*_into).type = (short) _type;}
-#if DEBUG_SCM
-#define NEWCELL(_into,_type) \
-{ _NEWCELL (_into, _type); \
- (*_into).dbg_info = car (dbg_pos);}
-#else /* not DEBUG_SCM */
-#define NEWCELL(_into, _type) _NEWCELL (_into, _type)
+#if ! DEBUG_SCM
#define dbg_readini(f)
#define dbg_readend()
#define dbg_readabrt()
+#define dbg_register_closure(x)
#endif /* DEBUG_SCM */
/* exported global symbol */
@@ -337,6 +336,7 @@
#if DEBUG_SCM
static LISP dbg_pos = NIL;
+static LISP dbg_mod = NIL;
static LISP orig_readtl (struct gen_readio * f);
static int dbg_getc (struct gen_readio * f);
@@ -345,9 +345,6 @@
static void dbg_readend (void);
static void dbg_lineinc (void);
static void dbg_linedec (void);
-#if 0
-static LISP dbg_curpos (void);
-#endif
static void init_dbg (void);
#endif /* DEBUG_SCM */
@@ -799,7 +796,7 @@
if (c == '\n')
{
c = getc (f);
-#ifdef DEBUG_SCM
+#if DEBUG_SCM
dbg_lineinc ();
#endif
}
@@ -1111,9 +1108,26 @@
{
int c, j;
char *p, *buffer = tkbuffer;
+#if DEBUG_SCM
+ LISP dbg_start_pos, dbg_ret;
+#define return(val) \
+ do \
+ { \
+ dbg_ret = (val); \
+ if NNULLP \
+ (dbg_ret) \
+ dbg_ret->dbg_info = dbg_start_pos; \
+ return (dbg_ret); \
+ } \
+ while (0)
+#endif /* DEBUG_SCM */
+
STACK_CHECK (&f);
p = buffer;
c = flush_ws (f, "end of file inside read");
+#if DEBUG_SCM
+ dbg_start_pos = car (dbg_pos);
+#endif
switch (c)
{
case '(':
@@ -1176,6 +1190,7 @@
*p++ = c;
}
return (my_err ("token larger than TKBUFFERN", NIL));
+#undef return
}
/* Iterative version */
@@ -1188,6 +1203,10 @@
while ((c = flush_ws(f, "end of file inside list")) != ')')
{
+#if DEBUG_SCM
+ LISP dbg_start_pos;
+ dbg_start_pos = car (dbg_pos);
+#endif
UNGETC_FCN (c,f);
tmp = lreadr (f);
if EQ
@@ -1212,15 +1231,18 @@
CDR (last) = cons (tmp, NIL);
last = cdr (last);
}
+#if DEBUG_SCM
+ last->dbg_info = dbg_start_pos;
+#endif
}
return l;
}
static LISP
readtl (struct gen_readio * f)
+{
+ int c;
#if DEBUG_SCM
-{
- /* wrapper that prepares debugging information */
if NNULLP
(dbg_pos)
{
@@ -1231,9 +1253,17 @@
s.cb_argument = (void *) f;
f = &s;
}
- return orig_readtl (f);
+#endif
+
+ c = flush_ws (f, (char *) NULL);
+ if (c == EOF)
+ return (eof_val);
+ UNGETC_FCN (c, f);
+ return (lreadr (f));
}
+#if DEBUG_SCM
+
static int
dbg_getc (struct gen_readio * f)
{
@@ -1261,9 +1291,8 @@
{
file = CAR (CAR (dbg_pos));
line = CDR (CAR (dbg_pos));
- line = intcons (INTNM (line) + 1);
- CAR (dbg_pos) = cons (file, line);
- line->dbg_info = CAR (dbg_pos)->dbg_info = NIL;
+ CAR (dbg_pos) = cons (file, intcons (INTNM (line) + 1));
+ CAR (dbg_pos)->dbg_info = NIL;
}
/* else: we have given up debugging information */
}
@@ -1277,9 +1306,8 @@
{
file = CAR (CAR (dbg_pos));
line = CDR (CAR (dbg_pos));
- line = intcons (INTNM (line) - 1);
- CAR (dbg_pos) = cons (file, line);
- line->dbg_info = CAR (dbg_pos)->dbg_info = NIL;
+ CAR (dbg_pos) = cons (file, intcons (INTNM (line) - 1));
+ CAR (dbg_pos)->dbg_info = NIL;
}
/* else: we have given up debugging information */
}
@@ -1287,38 +1315,166 @@
static void
dbg_readini (char *filename)
{
- LISP tmp;
- tmp = cons (strcons (-1, filename), intcons (1));
- tmp->dbg_info = CAR(tmp)->dbg_info = CDR(tmp)->dbg_info = NIL;
- dbg_pos = cons (tmp, dbg_pos);
- dbg_pos->dbg_info = NIL;
+ LISP f, dbg_pos_save, dbg_closures;
+
+ /* no debug info needed for now */
+ dbg_pos_save = dbg_pos;
+ dbg_pos = NIL;
+
+ /* maintain a list of toplevel closures */
+ f = strcons (-1, filename);
+ dbg_closures = rintern ("dbg-closures");
+ dbg_mod = assoc (f, VCELL (dbg_closures));
+ if NNULLP
+ (dbg_mod)
+ CDR (dbg_mod) = NIL;
+ else
+ {
+ dbg_mod = cons (cons (f, NIL), VCELL (dbg_closures));
+ setvar (dbg_closures, dbg_mod, NIL);
+ dbg_mod = CAR (dbg_mod);
+ }
+
+ dbg_pos = cons (cons (f, intcons (1)), dbg_pos_save);
}
static void
dbg_readend (void)
{
dbg_pos = cdr (dbg_pos);
+ if CONSP
+ (dbg_pos)
+ {
+ dbg_mod = assoc (CAR (CAR (dbg_pos)), VCELL (rintern ("dbg-closures")));
+ if NULLP
+ (dbg_mod)
+ abort ();
+ }
}
static void
+dbg_register_closure (LISP x)
+{
+ /* maintain a list of toplevel closures */
+ if CONSP
+ (dbg_pos)
+ {
+ CDR (dbg_mod) = cons (x, CDR (dbg_mod));
+ /* toplevel closures should know where their definitions begin */
+ if NNULLP
+ (cddr (x->storage_as.closure.code))
+ x->dbg_info = CDR (CDR (x->storage_as.closure.code))->dbg_info;
+ }
+}
+
+static LISP
+dbg_expand_file_name (LISP fl)
+{
+ char *fname, *fnbuf;
+ FILE *f;
+ size_t len;
+
+ if NTYPEP
+ (fl, tc_string)
+ my_err ("wta to dbg_expand_file_name ()", fl);
+ fname = fl->storage_as.string.data;
+ if ((fname[0] != '/'))
+ {
+ len = strlen (siod_lib) + strlen (fname) + 2;
+ fnbuf = must_malloc (len);
+ strcpy (fnbuf, siod_lib);
+ strcat (fnbuf, "/");
+ strcat (fnbuf, fname);
+ if ((f = fopen (fnbuf, "r")))
+ {
+ fclose (f);
+ fl = cons (NIL, NIL);
+ fl->type = tc_string;
+ fl->storage_as.string.data = fnbuf;
+ fl->storage_as.string.dim = len-1;
+ return (fl);
+ }
+ free (fnbuf);
+ }
+ return (fl);
+}
+
+static LISP
+dbg_get_info (LISP x)
+{
+ return NNULLP (x) ? x->dbg_info : NIL;
+}
+
+static LISP
+dbg_get_line (LISP x)
+{
+ x = dbg_get_info (x);
+#if DEBUG_SCM
+ return NNULLP (x) ? CDR (x) : intcons (-1);
+#endif
+}
+
+static LISP
+dbg_get_file (LISP x)
+{
+ x = dbg_get_info (x);
+ return NNULLP (x) ? CAR (x) : strcons (-1, "(No file info)");
+}
+
+static LISP
+dbg_copy_info (LISP x, LISP y)
+{
+ return (x->dbg_info = dbg_get_info (y));
+}
+
+static LISP
+integer2string (LISP args)
+{
+ char buf[sizeof (long)*CHAR_BIT];
+ char *p = buf + sizeof (buf);
+ unsigned long n, r;
+ LISP x, radix;
+ x = car (args);
+ radix = NNULLP (cdr (args)) ? CAR (CDR (args)) : intcons (10);
+ if NINTNUMP
+ (x)
+ my_err ("wta to integer2string", x);
+ if NINTNUMP
+ (radix)
+ my_err ("wta to integer2string", radix);
+ r = INTNM (radix);
+ if (r < 2 || 16 < r)
+ my_err ("invalid radix to integer2string", radix);
+ n = (r == 10) ? labs (INTNM (x)) : INTNM (x);
+ do
+ {
+ if (n % r > 9)
+ *--p = 'A' + n % r - 10;
+ else
+ *--p = '0' + n % r;
+ }
+ while (n /= r);
+ if (r == 10 && INTNM (x) < 0)
+ *--p = '-';
+ return strcons (sizeof(buf)-(p-buf), p);
+}
+
+static void
init_dbg (void)
{
dbg_pos = NIL;
gc_protect (&dbg_pos);
+ init_subr_1 ("dbg-get-info", dbg_get_info);
+ init_subr_1 ("dbg-get-line", dbg_get_line);
+ init_subr_1 ("dbg-get-file", dbg_get_file);
+ init_subr_2 ("dbg-copy-info!", dbg_copy_info);
+ init_subr_1 ("dbg-expand-file-name", dbg_expand_file_name);
+ init_lsubr ("number->string", integer2string);
+ setvar (rintern ("dbg-closures"), NIL, NIL);
provide (rintern ("debug"));
}
-static LISP
-orig_readtl (struct gen_readio * f)
#endif /* DEBUG_SCM */
-{
- int c;
- c = flush_ws (f, (char *) NULL);
- if (c == EOF)
- return (eof_val);
- UNGETC_FCN (c, f);
- return (lreadr (f));
-}
static LISP
read_from_string (LISP x)
@@ -2100,6 +2256,7 @@
NEWCELL (z, tc_closure);
(*z).storage_as.closure.env = env;
(*z).storage_as.closure.code = code;
+ dbg_register_closure (z);
return (z);
}
@@ -3304,10 +3461,13 @@
leval_lambda (LISP args, LISP env)
{
LISP body;
+#if ! DEBUG_SCM
+ /* the debugger needs the body to be a list */
if NULLP
(cdr (cdr (args)))
body = car (cdr (args));
else
+#endif
body = cons (sym_progn, cdr (args));
return (closure (env, cons (arglchk (car (args)), body)));
}
@@ -3441,11 +3601,22 @@
{
LISP bindings = cadr (form);
if (NNULLP (bindings) && NNULLP (cdr (bindings)))
- setcdr (form, cons (cons (car (bindings), NIL),
- cons (cons (rintern ("let*"),
- cons (cdr (bindings),
- cddr (form))),
- NIL)));
+ {
+ setcdr (form, cons (cons (car (bindings), NIL),
+ cons (cons (rintern ("let*"),
+ cons (cdr (bindings),
+ cddr (form))),
+ NIL)));
+#if DEBUG_SCM
+ /* (let (bind1) (let* (bind2+) body)) */
+ CDR (form)->dbg_info = bindings->dbg_info;
+ CAR (CDR (form))->dbg_info = bindings->dbg_info;
+ CDR (CDR (form))->dbg_info = CDR (bindings)->dbg_info;
+ CAR (CDR (CDR (form)))->dbg_info = CDR (bindings)->dbg_info;
+ CDR (CAR (CDR (CDR (form))))->dbg_info = CDR (bindings)->dbg_info;
+ CAR (CDR (CAR (CDR (CDR (form)))))->dbg_info = CDR (bindings)->dbg_info;
+#endif
+ }
setcar (form, rintern ("let"));
return (form);
}
@@ -3488,6 +3659,9 @@
named_let_macro (LISP form)
{
LISP name, fl, al, bindings, body;
+#if DEBUG_SCM
+ LISP orgbind = car (cddr (form));
+#endif
bindings = split_to_name_and_value (car (cddr (form)));
fl = car (bindings);
@@ -3505,6 +3679,27 @@
cons (sym_lambda, cons (reverse (fl), body)))),
name));
setcdr (form, reverse (al));
+#if DEBUG_SCM
+ /* (let name (orgbind) body) */
+ /* ((letrec ((name (lambda vars body))) name) inits) */
+ if NNULLP
+ (orgbind)
+ {
+ al = CDR (form);
+ fl = orgbind;
+ for (; NNULLP (al); al = CDR (al), fl = CDR (fl))
+ {
+ if NNULLP
+ (cdar (fl))
+ al->dbg_info = CDR (CAR (fl))->dbg_info;
+ }
+ }
+ al = dbg_get_info (body);
+ form->dbg_info = al;
+ CDR (CAR (form))->dbg_info = al;
+ CDR (CAR (CAR (CDR (CAR (form)))))->dbg_info = al;
+ CDR (CDR (CAR (CDR (CAR (CAR (CDR (CAR (form))))))))->dbg_info = al;
+#endif
return (form);
}
@@ -3512,18 +3707,39 @@
normal_let_macro (LISP form)
{
LISP fl, al, bindings, body;
+#if DEBUG_SCM
+ LISP orgbind = cadr (form);
+#endif
bindings = split_to_name_and_value (cadr (form));
fl = car (bindings);
al = cdr (bindings);
body = cddr (form);
+#if ! DEBUG_SCM
if NULLP
(cdr (body)) body = car (body);
else
+#endif
body = cons (sym_progn, body);
setcdr (form, cons (reverse (fl), cons (reverse (al), cons (body, NIL))));
setcar (form, rintern ("let-internal"));
+#if DEBUG_SCM
+ if NNULLP
+ (orgbind)
+ {
+ CDR (CDR (form))->dbg_info = orgbind->dbg_info;
+ al = CAR (CDR (CDR (form)));
+ fl = orgbind;
+ for (; NNULLP (al); al = CDR (al), fl = CDR (fl))
+ {
+ if NNULLP
+ (cdar (fl))
+ al->dbg_info = CDR (CAR (fl))->dbg_info;
+ }
+ }
+ CDR (CDR (CDR (form)))->dbg_info = dbg_get_info (CDR (body));
+#endif
return (form);
}
@@ -4133,9 +4349,16 @@
{
letb = cons (cons (caar (l), NIL), letb);
setb = cons (listn (3, rintern ("set!"), caar (l), car(cdar (l))), setb);
+#if DEBUG_SCM
+ setb->dbg_info = dbg_get_info (cdar (l));
+ CDR (CDR (CAR (setb)))->dbg_info = dbg_get_info (cdar (l));
+#endif
}
setcdr (form, cons (letb, setb));
setcar (form, rintern ("let"));
+#if DEBUG_SCM
+ CDR (form)->dbg_info = dbg_get_info (setb);
+#endif
return (form);
}
More information about the Uim-commit
mailing list