; .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)))))))