; .EnTete "Le-Lisp (c) version 15.2" " " "Les De'buggers"
; .EnPied "debug.ll" "L-%" " "
; .Annexe L "Utilitaire permettant d'explorer la pile"
; .nr % 1
;
; .Centre "*****************************************************************"
; .Centre " Ce fichier est en lecture seule hors du projet ALE de l'INRIA. "
; .Centre " Il est maintenu par ILOG SA, 2 Avenue Gallie'ni, 94250 Gentilly "
; .Centre " (c) Le-Lisp est une marque de'pose'e de l'INRIA "
; .Centre "*****************************************************************"
; .Centre "$Header: debug.ll,v 4.3 88/04/07 18:27:59 nuyens Exp $"
(unless (>= (version) 15.2)
(error 'load 'erricf 'debug))
(unless (featurep 'virtty)
(initty))
; Dans le package #:system:debug
(setq #:sys-package:colon '#:system:debug)
; .Section "Interface avec le monde"
; Globales re'glant le debug
; lignes maxi de pretty print
(defvar #:system:debug-line 5)
; niveaux maxi de pile
(defvar #:system:stack-depth 5)
; L'indicateur de debug
(defvar #:system:debug ())
; Impression du contenu de la pile
(defun printstack nl ; ((&opt n 32767) (&opt l (cstack))) ...
(let* ((l (if (and (consp nl) (consp (cdr nl))) (cadr nl) (cstack)))
(m (if (consp nl) ; nombre de blocs a imprimer
(min (car nl) (length l))
(length l)))
(n (length l)) ; nume'ros des blocs
frame)
(mapc (lambda (f) (when (:is-hidden-block f) (decr n)))
l)
(setq m (min m n))
(incr n)
(while (gt m 0)
(nextl l frame)
(unless (:is-hidden-block frame)
(decr n)
(decr m)
(prin " [stack ")
(when (< n 100) (princn #\sp))
(when (< n 10) (princn #\sp))
(prin n "] (")
(selectq (car frame)
; sur le type du bloc
(1 ; type lambda (1 llink fval lparam v1 .. vn)
(prin (or (:findfn (caddr frame))
'let)))
(2 ; type label (2 fct1 ofval1 oftyp1 ...)
(prin 'flet " " (cadr frame)))
(3 ; type e'chappement (3 tag-name)
(prin 'tag " "(cadr frame)))
(4 ; type itsoft (4 llink nom etat forme funct)
(prin 'itsoft " " (caddr frame)))
(5 ; type lock (5 fval)
(prin 'lock " " (or (symbolp (cadr frame))
(:findfn (cadr frame))
"(lambda ...)")))
(6 ; type protect (5 progn)
(prin 'protect))
(7 ; type sys-protect (6)
(prin 'sys-protect))
(8 ; type schedule (8 XXX)
(prin 'schedule))
(9 ; type tagbody (9 et1 corp1 ... etN corpN)
(prin 'tagbody))
(10 ; type bloc (10 slot)
(prin 'block))
(11)
(t ; type erronne
(prin
#- #:system:foreign-language "*** bloc inconnu :"
#+ #:system:foreign-language "*** unknown block:"
(car frame))))
(print " ...)")))))
(de :is-hidden-block (frame)
(or (eq (car frame) 7) ; sysprotect
(eq (car frame) 11) ; progn
(eq (car frame) 4)) ; itsoft
)
; Passage en/Sortie du mode debug
(df debug #:system:l
(cond ((atom #:system:l)
; retourne l'indicateur courant
#:system:debug)
((memq (car #:system:l) '(t ()))
; positionnement global
(setq #:system:debug (car #:system:l)))
(t ; positionnement temporaire
(let ((#:system:debug (car #:system:l)))
(eval (car #:system:l))))))
; Cre'ation d'une boucle d'inspection
(defun break ()
(if #:system:debug
(let ((#:system:debug t)
(#:sys-package:itsoft
(cons '#.#:sys-package:colon
(remq '#.#:sys-package:colon
#:sys-package:itsoft))))
(clockalarm 0)
(tag continue
(with ((inchan ())
(outchan ()))
(:break-loop (cstack)))
(err)))
(err)))
; Lancement d'une commande du de'buggeur
(defun debug-command (:char)
(eprogn (cdr (cassq :char :commands))))
; .Section "Implantation"
; Boucle d'inspection
(defvar :current-form)
(defvar :current-function)
(defvar :current-error-form)
(defvar :error-message)
(defvar :break-number 0)
(defvar :resetfn-alist)
(de :break-loop (:stack)
(let (:error-message
:current-function
:current-form
:current-error-form
(:resetfn-alist
(mapcoblist
(lambda (s)
(when (and (neq (valfn s) 0)
(getprop s 'resetfn))
(ncons (cons (cdr (getprop s 'resetfn)) s))))))
current-window
(:break-number (add1 :break-number)))
(protect
(progn
(when (and (featurep 'window) (current-window))
(setq current-window (current-window))
(current-window
(:create-break-window :break-number)))
(with ((prompt
(if (gt :break-number 1)
(catenate :break-number ">? ")
">? ")))
(:init-stack (:stack-in-error :stack))
(debug-command #/e)
(debug-command #/.)
(protect
(untilexit break
(itsoft 'toplevel ()))
(untilexit #:system:debug (:up-stack)))))
(when (and (featurep 'window)
(current-window))
(kill-window (current-window))
(current-window current-window)))))
; Interaction
; Le toplevel
(de :toplevel ()
(tag #:system:debug
(catcherror t
(print "= " (eval (read))))))
; De'codage des commandes
(defun :bol ()
(super-itsoft '#.#:sys-package:colon 'bol ())
(let* ((:inbuf (inbuf))
(:c (sref (inbuf) 0)))
(when (and (assq :c :commands) (eq 3 (inmax)))
(sset :inbuf 0 #\cr) (sset :inbuf 1 #\lf)
(debug-command :c))))
; Initialisations
; Initialisation de la fene↑tre
(de :create-break-window (n)
(create-window '#:window:tty
(div (bitxmax) 3)
(mul (mul n 2) (height-space))
(scale (bitxmax) 2 3)
(scale (bitymax) 2 3)
(catenate "Le←Lisp : Break Loop #" (string n))
1
1)))
; Initialisation de la pile
(de :find-syserror (stack)
(when stack
(if (and (eq 4 (caar stack))
(eq 'syserror (caddar stack)))
stack
(:find-syserror (cdr stack)))))
(de :find-break (stack)
(when stack
(if (and (eq 1 (caar stack))
(if (eq (typefn 'break) 'expr)
(eq (valfn 'break) (caddar stack))
(equal (valfn 'break) (loc (caddar stack)))))
stack
(:find-break (cdr stack)))))
(de :cut-to-toplevel (stack)
(if (:is-at-toplevel stack)
(displace stack '(()))
(let (frame)
(until (or (null (cdr stack))
(:is-at-toplevel (cdr stack)))
(nextl stack))
(when (consp stack) (rplacd stack ())))))
(de :is-at-toplevel (stack)
(or (and (eq 4 (caar stack)) (eq 'toplevel (caddar stack)))
(and
(eq 7 (caar stack)) ; sysprot
(nextl stack)
(or (eq 7 (caar stack)) (eq 5 (caar stack)))
(nextl stack)
(and (eq 3 (caar stack)) (eq '#:system:error-tag (cadar stack)))
(nextl stack)
(if (eq 11 (caar stack)) (nextl stack) t)
(and (eq 3 (caar stack)) (eq '#:system:toplevel-tag (cadar stack)))
(nextl stack)
(if (eq 1 (caar stack)) (nextl stack) t)
(and (eq 4 (caar stack)) (eq 'toplevel (caddar stack))))))
(de :stack-in-error (stack)
(:cut-to-toplevel stack)
(let ((stack (or (:find-syserror stack)
(:find-break stack))))
(cond ((and (eq 1 (caar stack))
(if (eq (typefn 'break) 'expr)
(eq (valfn 'break) (caddar stack))
(equal (valfn 'break) (loc (caddar stack)))))
; break au sommet
(setq :error-message '(break break ())
:current-error-form '(break)))
((eq 4 (caar stack))
; syserror au sommet
(setq :error-message (nth 10 (car stack)))
(setq :current-error-form ; break step: forme dans errmess
(if (eq 'step (car :error-message))
(caddr :error-message)
(nth 4 (car stack)))))
(t (setq :error-message '(debug errerr ()))))
(nextl stack)
(:remove-fn
'(cstep unstep step #:step:steploop #:step:stepeval)
stack)))
(de :remove-fn (lfn stack)
(setq stack (cons () stack)
lfn (mapcar 'valfn lfn))
(let ((bstack stack)
(fstack stack))
(while (setq fstack (:find-function (cdr fstack)))
(ifn (:is-in-lvalfn (caddr (car fstack)) lfn)
(setq stack fstack)
(rplacd stack (cdr fstack))))
(setq stack bstack)
(cdr bstack)))
(de :is-in-lvalfn (valfn lvalfn)
(any (lambda (vfn)
(or (eq vfn valfn)
(equal (loc valfn) vfn)))
lvalfn))
(defun :init-stack (stack)
(when (:is-a-struct-access (car stack)) ; hack #:system:structaccess
(nextl stack))
(setq :current-form (ncons stack))
(setq :current-function (ncons (:find-function stack))))
; Les commandes
(defvar :commands
'((#/v "show variables" (:print-current-variables))
(#/h "print top of stack" (:printstack #:system:stack-depth))
(#/H "print complete stack" (:printstack))
(#/e "show error message" (:print-error))
(#/. "show current stack frame" (:print-current-function))
(#/+ "down stack" (:down-stack) (:print-current-function))
(#/- "up stack" (:up-stack) (:print-current-function))
(#/t "back to toplevel" (exit #:system:toplevel-tag))
(#/q "exit inspection loop" (exit break))
(#/r "resume and correct error" (:continue))
(#/c "continue" (exit continue))
(#/z "step traced functions"
(setq #:trace:step-in-trace-flag t) (:continue))
(#/? "list commands" (:help))))
; Commandes d'impression
(de :printstack n
(if n (setq n (car n)) (setq n (length (car :current-form))))
(printstack n (car :current-form)))
(de :print-current-variables ()
(:print-variables (car :current-form)))
(defun :print-variables (:s)
(cond ((:has-function-definition (car :s))
(:print-arguments (nth 3 (car :s))))
((eq 1 (caar :s))
(:print-arguments (nth 3 (car :s)))
(:bind/unbind (car :s))
(:print-variables (cdr :s))
(:bind/unbind (car :s)))
(:s (:print-variables (cdr :s)))))
(defun :print-arguments (:larg)
(cond ((or (eq :larg '&nobind) (null :larg)))
((symbolp :larg) (print " " :larg "=" (symeval :larg)))
((consp :larg)
(:print-arguments (car :larg))
(:print-arguments (cdr :larg)))))
(de :print-error ()
(apply 'printerror :error-message)
(selectq (cadr :error-message)
((errwna ; "mauvais nombre d'arguments"
errbpa ; "mauvais parametre"
errilb) ; "liaison illegale"
(let ((d (:getdef (car :error-message))))
(:print-filtered
(list (car d) (cadr d) (:hilited:make (caddr d))))))
))
(defun :print-current-function ()
(let ((current-definition
(:getdef (:findfn (caddr (caar :current-function))))))
(when current-definition
(:print-filtered
(:hilite-expr
(:current-expr current-definition)
current-definition)))))
; Commandes de de'placement dans la pile
(defun :down-stack ()
(let* ((:next-form (cdr (car :current-function)))
(:next-function (:find-function :next-form)))
(ifn :next-function
(exit #:system:debug)
(newl :current-form :next-form)
(newl :current-function :next-function)
(let ((:previous-form (cadr :current-form)))
(while (neq :previous-form (car :current-form))
(:bind/unbind (nextl :previous-form)))))))
(de :up-stack ()
(ifn (cdr :current-function)
(exit #:system:debug)
(let ((:rebind-frames
(:up-frame-list (cadr :current-form) (car :current-form))))
(nextl :current-function)
(nextl :current-form)
(while :rebind-frames
(:bind/unbind (nextl :rebind-frames))))))
(de :up-frame-list (f1 f2)
(let ((res ()))
(until (eq (car f1) (car f2))
(newl res (nextl f1)))
res))
; Commandes diverses
(de :continue ()
(selectq (cadr :error-message)
(break (exit continue))
(errudv
(prinflush (prompt) "(setq " (caddr :error-message) " '")
(with ((prompt ""))
(let ((form
`(setq ,(caddr :error-message) ',(read))))
(exit continue (eval form)))))
(errudf
(prinflush "Function ")
(exit continue (read)))
(t
(print "This error can not be resumed"))))
(defun :help ()
(mapc (lambda ((c doc . rest)) (print "; " (ascii c) ": " doc))
:commands))
; De'pilage d'un block de pile
(defun :bind/unbind (:frame)
(when (eq 1 (car :frame)) ; bloc lambda
; type lambda (1 llink fval lparam vn ... v1)
(let ((:lval (nreverse (cddddr :frame))))
(:exchange-arguments (cadddr :frame) :lval)
(rplacd (cdddr :frame) (nreverse :lval)))))
(defun :exchange-arguments (:larg :lval)
(cond ((or (eq :larg '&nobind) (null :larg)))
((symbolp :larg)
(rplaca :lval
(prog1 (:cval :larg)
(:scval :larg (car :lval)))))
((consp :larg)
(:exchange-arguments (car :larg)
(if (consp (car :larg)) (car :lval) :lval))
(:exchange-arguments (cdr :larg) (cdr :lval)))))
(defvar :v)
(defun :scval (:s :v)
(if (boundp ':v) (set :s :v) (makunbound :s)))
(defun :cval (:s)
(if (boundp :s) (symeval :s) '←undef←))
(de :current-expr (definition)
(let ((:frame-list
(:up-frame-list (car :current-form) (car :current-function))))
(while :frame-list
(setq definition (:find-expr (nextl :frame-list) definition)))
(when (null (cdr :current-form))
(setq definition (:find-error definition)))
definition))
; Trouver l'expression ayant cre'e' le bloc frame dans sexpr
(de :find-expr (frame sexpr)
(or
(:find-tree
(or
(selectq (car frame)
; sur le type du bloc
(1 ; type lambda (1 llink fval lparam v1 ... vn)
(lambda (expr)
(and (consp (car expr))
(eq (cdar expr) (caddr frame)))))
; type label (2 fct1 ofval1 oftyp1 ... oftypn)
(3 ; type e'chappement (3 tag-name)
(lambda (expr)
(and (memq (car expr) '(tag untilexit))
(consp (cdr expr))
(eq (cadr expr) (cadr frame)))))
; type itsoft (4 llink nom etat forme funct)
(5 ; type lock (5 fval)
(lambda (expr)
(and (eq (car expr) 'lock)
(consp (cdr expr))
(eq (cadr expr) (cadr frame)))))
(6 ; type protect (6 progn)
(lambda (expr)
(and (eq (car expr) 'protect)
(consp (cdr expr))
(eq (cddr expr) (cadr frame)))))
; type sys-protect (7)
(8 ; type schedule (8 XXX)
(lambda (expr) (eq (car expr) 'schedule)))
(9 ; type tagbody (9 et1 corp1 ... etN corpN)
)
; type bloc (10 slot)
(11 ; type progn (11 progn)
(lambda (expr) (exit found (caadr frame)))))
(lambda (expr) (exit found ())))
sexpr)
sexpr))
; Trouver l'expression qui a provoque' l'erreur dans expr
(de :find-error (expr)
(or
(when (memq (cadr :error-message) '(errudf errbal errwna errilb break))
(:find-tree
(lambda (expr)
(eq expr :current-error-form))
expr))
(when (eq (cadr :error-message) 'errudv)
(:find-tree
(lambda (expr)
(when (eq (car expr) (caddr :error-message))
(exit found (car expr))))
expr))
(:find-tree
(lambda (expr)
(and (eq (car expr) (car :error-message))
(:find-tree
(lambda (expr)
(eq expr :current-error-form))
expr)))
expr)
expr))
; .SSection "Utilitaires"
; Recherche et substitution dans un arbre
(de :find-tree (:fn :tree)
(tag found (:find-tree1 :fn :tree)))
(de :find-tree1 (:fn :tree)
(when (consp :tree)
(when (funcall :fn :tree)
(exit found :tree))
(while (consp :tree)
(:find-tree1 :fn (nextl :tree)))))
; Substitution avec test EQ
(defun substq (n o s)
(cond ((atom s)
(if (eq s o) n s))
((consp s)
(cons
(if (eq (car s) o)
n
(substq n o (car s)))
(if (eq (cdr s) o)
n
(substq n o (cdr s)))))))
; Manipuler la pile sous forme de CSTACK
(de :find-function (stack)
(until (or (:has-function-definition (car stack))
(null stack))
(nextl stack))
stack)
(defun :has-function-definition (frame)
(and (eq (car frame) 1)
(:findfn (caddr frame))))
(de :is-a-struct-access (frame)
(and (eq (car frame) 1)
(let ((valfn (caddr frame)))
(and (consp valfn)
(eq (car valfn) '&nobind)
(consp (cdr valfn))
(consp (cadr valfn))
(eq (caadr valfn) '#:system:structaccess)))))
; Re'cupe'rer la de'finition d'une fonction
(de :getdef (f)
(cond ((memq f #:trace:trace)
(:get-plist-def f 'trace))
((getprop f 'resetfn)
(:get-plist-def f 'resetfn))
(t (getdef f))))
(de :findfn (valfn)
(or (findfn valfn)
(cassoc valfn :resetfn-alist)))
(de :get-plist-def (symbol prop)
(makedef symbol
(car (getprop symbol prop))
(cdr (getprop symbol prop))))
; .SSection "Gestion des objets mis en valeur"
(de :hilite-expr (expr1 expr2)
(ifn expr1
expr2
(substq (:hilited:make expr1) expr1 expr2)))
(defun :hilited:make (o)
(tcons ':hilited o))
(defun :hilited:prin (f)
(with ((tyattrib t))
(pprin (cdr f))))
(synonymq :hilited:pretty :hilited:prin)
; Limitation de l'impression hilite'e
(defvar :outlist)
(defvar :hibegin)
(defvar :hiend)
(defvar :nlines)
(defvar #:tty:system:hilited:tyattrib ())
(de #:tty:system:hilited:tyattrib (x)
(if x
(setq :hibegin (cons :nlines (outpos)))
(setq :hiend (cons :nlines (outpos)))))
(de :hilited:eol ()
(incr :nlines)
(newl :outlist (substring (outbuf) 0 (outpos)))
(fillstring (outbuf) 0 #\sp)
(outpos (lmargin)))
(de :print-filtered (x)
(let ((:nlines 0)
(:hibegin ())
(:hiend ())
(:outlist ()))
(let ((#:sys-package:itsoft ':hilited)
(#:sys-package:tty '#:tty:system:hilited))
(pprint x))
(ifn (and :hibegin :hiend)
(setq :hibegin (cons 0 0)
:hiend (cons 0 0)))
(:flush-hilited)))
(de :flush-hilited ()
(setq :outlist (nreverse :outlist))
(unless (le :nlines #:system:debug-line)
(let ((nscroll (min (sub1 (car :hibegin))
(sub (add1 (car :hiend))
#:system:debug-line))))
(when (gt nscroll 0)
(rplaca :hibegin (sub (car :hibegin) nscroll))
(rplaca :hiend (min (sub (car :hiend) nscroll)
(sub1 #:system:debug-line)))
(rplacd :outlist
(nthcdr (add1 nscroll) :outlist))
(rplaca :outlist (catenate (car :outlist) " ...")))
(when (gt (length :outlist) #:system:debug-line)
(let ((boutlist
(nthcdr (sub1 #:system:debug-line)
:outlist)))
(rplacd boutlist ())
(rplaca boutlist
(catenate (car boutlist) " ..."))
(when (gt (car :hiend) (sub1 #:system:debug-line))
(rplaca :hiend (sub1 #:system:debug-line))
(rplacd :hiend (slen (car boutlist))))))))
(let ((#:system:print-for-read ()))
(with ((outchan t))
(with ((rmargin 78))
(repeat (car :hibegin) (print (nextl :outlist)))
(prin (substring (car :outlist) 0 (cdr :hibegin)))
(tyattrib t)
(cond ((eq (car :hiend) (car :hibegin))
(prin (substring (car :outlist)
(cdr :hibegin)
(sub (cdr :hiend)
(cdr :hibegin)))))
(t
(print
(substring
(nextl :outlist)
(cdr :hibegin)))
(repeat (sub1 (sub (car :hiend) (car :hibegin)))
(tyattrib t) (print (nextl :outlist)))
(tyattrib t)
(prin
(substring (car :outlist) 0 (cdr :hiend)))))
(tyattrib ())
(print (substring (nextl :outlist) (cdr :hiend)))
(while :outlist (print (nextl :outlist)))))))