; .EnTete "Le-Lisp (c) version 15.2" " " "Pisteur et pas a` pas"
; .EnPied "trace.ll" "K-%" " "
; .Annexe K "Le Pisteur et le Mode Pas-a`-pas"
; .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: trace.ll,v 4.11 88/11/23 09:53:27 nuyens Exp $"

(unless (>= (version) 15.2)
        (error 'load 'erricf 'trace))

; Tous les symboles pre'ce'de's de : seront cre'e's dans le package TRACE.

(defvar #:sys-package:colon 'trace)

(add-feature 'debug)

; .Section "Les variables globales"

(defvar #:system:debug ())
(defvar *trace-input* ())       ; le canal ou lire les commandes
(defvar *trace-output* ())	; le canal de sortie des messages du traceur.
(defvar #:step:auto-step ())    ; pour stepper automatiquement.

(defmacro :output body
  `(with ((outchan *trace-output*))
	 ,@body)))

; la liste des fonctions trace'es
(defvar :trace ())

; la liste des dernie`res fonctions de'trace'es
(defvar :last-untraced ())

; la liste des fonctions intracables
(defvar :untracable '(cstep step unstep quote arg =))

; .Section "Les fonctions auxiliaires"
 
(de :flat (l)
    (let ((r)) (:flat-aux l) (reverse r)))
 
(de :flat-aux (l)
    (cond ((null l) ())
          ((atom l) (newl r l))
          (t (:flat-aux (car l)) (:flat-aux (cdr l)))))
 
; .Section "Les fonctions de tracage"

(defvar tracewindow ())

(df trace l
    ; trace la liste de fonctions "l"
    (mapc ':trace-one l)
    (when (and :trace (featurep 'window) (null tracewindow))
          (setq tracewindow
                (create-window '#:window:tty 
                       (div (bitxmax) 2) (mul (height-space) 3)
                       (div (bitxmax) 2) (bitymax) "Le_Lisp : Trace" 0 1)))
    l)

(df untrace l
    ; enle`ve la trace de toutes les fonctions
    ; de la liste 'l' ou de toutes les fonctions
    ; trace'es si 'l' = ()
    (mapc ':untrace-one (setq :last-untraced (or l (setq l :trace))))
    (when (and (null :trace) (featurep 'window) tracewindow)
          (kill-window tracewindow)
          (setq tracewindow ()))
    l)

; Pour l'avenir...
;(de retrace ()
;    ;; retrace les dernie`res fonctions untrace'es
;    (prog1
;	(mapc ':trace-one :last-untraced)
;        (setq :last-untraced nil)))

(de :untrace-one (f)
    (let ((val (getprop f 'trace)))
         (if (atom val)
             (printerror 'untrace 'ERRNTF f)
	   (cond
	    ((getprop f 'resetfn&trace)     ; Il y avait un resetfn avant
	     (resetfn f (car val)(cdr val)) ;  la trace
	     (remprop f 'resetfn&trace))
	    ((getprop f 'resetfn)       ; C'est la trace qui a mis le
	     (remprop f 'resetfn)       ;  resetfn
	     (setfn f (car val) (cdr val)))
	    (t                          ; Sinon, cas simple
	     (setfn f (car val) (cdr val))))
	   (remprop f 'trace)
	   (setq :trace (delq f :trace)))))

; Un spe'cification de trace (argument de trace-one) a le format suivant
;   trace ::= fct
;          |  (fct [trace-spec]*)
;          |  ((fct*) [trace-spec]*)  ;  pas encore
; trace-spec ::= (wherein fct) | (wherein (fct*)) ;  pas encore
;             |  (entry expr*)
;             |  (exit  expr*)
;             |  (when  expr)   ; trace conditionnelle
;             |  (break expr)   ; break conditionnel
;             |  (step expr)    ; pas a` pas conditionnel
; 
; La spe'cif par defaut (correspondant a` (trace foo)) est
;    (foo (entry (prin 'foo "--->") (print-parameters 'foo))
;         (exit  (prin 'foo "<---") (print #:trace:value))
;         (when t)
;         (break ())
;         (step ())
;    )

(defun default-specif (item)
  (selectq item
	   (entry
	    `((:output
	       (print
		',:fct " ---> "
		,@(if (index "subr" :ftype)
		      ; pas de ` a cause des mapcan!
		      (mapcan (lambda (u) (list u " ")) (:flat :larg))
		    (mapcan (lambda (u) (list (kwote u) "=" u " "))
			    (:flat :larg)))))))
	   (exit
	    `((:output (print ',:fct " <--- " :value))))
	   (when
	    '(t))			; pas de when (when t)
	   (break
	    ())				; pas de break
	   (step
	    ())				; pas de step
	   ))          

(defun parse-specif (specif)
    (mapcar (lambda (item) (or (assq item specif)
                               (cons item (default-specif item))))
            '(entry exit when break step)))

(defvar :not-in-trace-flag t)
(defvar :step-in-trace-flag ())

; Les fonctions utilise'es par la trace interne

(synonymq :if if)
(synonymq :let let)
(synonymq :when when)
(synonymq :with with)
(synonymq :progn progn)
(synonymq :itsoft itsoft)
(synonymq :and and)
(synonymq :or or)
(synonymq :call call)
(synonymq :calln calln)
(synonymq :boundp boundp)
(synonymq :eval eval)
(synonymq :traceval traceval)
(synonymq :eprogn eprogn)

(defun build-tracing-fval (specif)
  `(,:larg
    (unstep
     (:if :not-in-trace-flag
	  (:let ((:not-in-trace-flag ()))
		(setq :step-in-trace-flag ())
		(:when ,(car (cassq 'when specif))
		       ,(if (featurep 'window)
			    `(:with (,(list 'current-window 'tracewindow))
				    ,@(cassq 'entry specif))
                          `(:progn ,@(cassq 'entry specif)))
		       (:when ,(car (cassq 'break specif))
			      (let ((:not-in-trace-flag t) 
				    (#:system:debug t))
				(:itsoft 'syserror
					 '(,:fct break tracebreak)))))
		(:let ((:value 
			(:if (:and ,(car (cassq 'when specif))
				   (:or :step-in-trace-flag
					,(car (cassq 'step specif))))
			     (:let ((:not-in-trace-flag t))
				   (step ,:call))
			     (:let ((:not-in-trace-flag t))
				   (cstep ,:call)))))
		      (:when ,(car (cassq 'when specif))
			     ,(if (featurep 'window)
				  `(:with (,(list 'current-window
						  'tracewindow))
					  ,@(cassq 'exit specif))
				`(:progn
				  ,@(cassq 'exit specif))))
		      :value))
	  (cstep ,:call)))))

(defvar :fct)                   ; la fonction tracee
(defvar :ftype)                 ; son ftype
(defvar :larg)                  ; ses arguments, (pseudos pour subr)
(defvar :call)                  ; la forme pour lancer la fct

(de :trace-one (:fct)
    (let ((specif)
	  (props))	; les indicateurs a positionner apres le setfn
      (when (consp :fct)
	    (setq specif (cdr :fct) :fct (car :fct)))
      (when (memq :fct :untracable)
	    (error 'trace 'errcnt :fct))
      (when (and (consp (valfn :fct))
		 (eq '&nobind (car (valfn :fct))))
	    (error 'trace 'errtnb :fct))
      (when (memq :fct :trace) (:untrace-one :fct))
      ; liaison des spe'ciales
      (let ((:ftype (or (car (getprop :fct 'resetfn)) (typefn :fct)))
	    :larg :call
	    (fval (or (cdr (getprop :fct 'resetfn)) (valfn :fct))))
	(when (getprop :fct 'resetfn)
	      ;; on n'a plus besoin d'enlever l'indicateur resetfn, parce
	      ;; que setfn le fait.
	      (newl props '(t resetfn&trace)))
	(selectq :ftype
		 ((expr fexpr macro dmacro)
		  (setq :larg  (car fval)
			:call `(:progn ,@(cdr fval))))
		 (subr0
		  (setq :larg  ()
			:call `(:call ',fval () () ())))
		 ((subr1)
		  (setq :larg '(:arg1)
			:call `(:call ',fval :arg1 () ())))
		 (subr2
		  (setq :larg '(:arg1 :arg2)
			:call `(:call ',fval :arg1 :arg2 ())))
		 (subr3
		  (setq :larg '(:arg1 :arg2 :arg3)
			:call `(:call ',fval :arg1 :arg2 :arg3)))
		 ((fsubr msubr dmsubr)
		  (setq :larg ':arg1
			:call `(:call ',fval :arg1 () ())))
		 (nsubr
		  (setq :larg ':arg1
                                :call `(:calln ',fval :arg1))))
	(cond ((null :ftype)
	       (printerror 'trace 'ERRUNK :fct))  
	      ((not (memq :ftype '(expr fexpr macro dmacro
					msubr dmsubr subr0 subr1 subr2
					subr3 fsubr nsubr)))
	       (printerror 'trace 'ERRKNT (list :fct :ftype)))
	      (t
	       (newl props (list (cons :ftype fval) 'trace))
	       (resetfn :fct
			(or (car (memq :ftype '(expr fexpr macro dmacro)))
			    (cassq :ftype
				   '((subr1 . expr) (subr2 . expr)
				     (subr3 . expr) (subr0 . expr)
				     (fsubr . fexpr) (nsubr . expr)
				     (msubr . macro) (dmsubr . dmacro))))
			(build-tracing-fval (parse-specif specif)))
	       ;; maintenant on peut positionner les indicateurs
	       (newl :trace :fct)
	       (mapc (lambda ((value prop))
		       (putprop :fct value prop))
		     props))))))


(de tracend ()
    (untrace)
    (mapc 'remob (oblist 'trace))
    (libautoload trace trace untrace)
    'tracend)

; .Section "Le mode pas-a`-pas"

; Le STEPPER : permet d'exe'cuter une expression en PAS A PAS
;  ex : (step (fib 10)).
; Le signal d'invite du pas a` pas est   "step>"


(setq #:sys-package:colon 'step)

; TEMPORAIRE: le temps de pouvoir les declarer &DYNAMIC.

(defvar :depth 0)
(defvar :value ())
(defvar :speak t)
(defvar :history ())
(defvar :exp)
(makunbound ':speak)

(defvar :ERRNBD
  #- #:system:foreign-language "je ne peux pas suivre une fonction &NOBIND"
  #+ #:system:foreign-language "I can't step an &NOBIND function")

(df step (:exp)
  (#:trace:let ((#:sys-package:itsoft
         (cons '#.#:sys-package:colon #:sys-package:itsoft))
        (:depth 0)                         ; la profondeur
        (:value)                           ; la valeur retourne'e
        (:speak t)                         ; la trace parle.
        (:history))                        ; l'histoire
        (tag step
	     (#:trace:traceval
	         `(progn ,:exp)); avec PROGN car sinon le toplevel STEP anihile
	     )))                ; plusieurs cas -&nobind; unstep-.

(de :nobind? (:form)
   (and (consp :form)
     (cond
      ((symbolp (car :form))
       (cond
	((and (consp (valfn (car :form)))
	      (eq '&nobind (car (valfn (car :form))))))
	((and (eq (car :form) 'send)
	      (eq (typefn 'send) 'nsubr))) ))
      ((and (consp (car :form))
	    (eq 'lambda (caar :form))
	    (eq '&nobind (cadar :form)))))
    ))
  
(de :stepeval (:forme :env)
  ; lance' par IT SOFT    
  (let ((:depth (1+ :depth)) 
        (:history (cons :forme :history)))
       (cond ((and (consp :forme)
                   (eq (car :forme) 'unstep))
              (eval :forme :env))
             ((null :speak) (stepeval :forme :env))
             (t (:steploop #/.)))))

(df unstep :exp
    (#:trace:eprogn :exp))

; to compile traced functions with complice
(putprop 'unstep 'parano '#:complice:fvar)

(df cstep (:exp)
    (#:trace:if (#:trace:and (#:trace:boundp ':speak) :speak)
        (#:trace:traceval :exp)
        (#:trace:eval :exp)))

(de :stepmargin (:n)
    (repeat (if (< :n 20) :n 21) (princn #\sp)))

(de :steploop (:cmd)
    (when :auto-step (setq :cmd t))
    (selectq :cmd
        (#/. 
	 (#:trace:output
	  (with ((printlevel 3) (printline 1))
		(:stepmargin :depth)
		(prinflush :depth " -> " :forme " step>")))
	 (let ((response
		(with ((inchan *trace-input*))
		      (teread)
		      (car (readline)))))
	   (:steploop response)))
	(#/=
	 (let ((#:system:debug t))
	   (itsoft 'syserror (list 'step 'break :forme)))
	 (:steploop #/.))
	(#/< (setq :value (let ((:speak ()))
			    (eval :forme :env)))
	     (#:trace:output
	      (:stepmargin :depth) 
	      (print :depth " <- " :value)))
	(#/q (exit #:system:toplevel-tag))
	(#/h (let ((:n 0) 
		   (:history (reverse :history)))
	       (#:trace:output
		(while :history
		  (:stepmargin :n)
		  (print (incr :n) " " (nextl :history)))))
	     (:steploop #/.))
	(#/?
	 (#:trace:output
	  #- #:system:foreign-language
	  (progn
	    (print ";Les commandes de pas a pas sont : ")
	    (print ";   CR  pour passer a l'expression suivante")
	    (print ";   .   pour voir l'expression courante")
	    (print ";   <   pour evaluer sans pas a pas et y revenir")
	    (print ";   q   retour au toplevel")
	    (print ";   h   pour avoir l'historique du pas a pas")
	    (print ";   ?   pour avoir ce texte ...."))
	  #+ #:system:foreign-language
	  (progn
	    (print ";Commands for step are : ")
	    (print ";   CR  go to next expression")
	    (print ";   .   see current expression")
	    (print ";   <   evaluate without step and come back")
	    (print ";   q   return to toplevel")
	    (print ";   h   view history")
	    (print ";   ?   this message ..."))
	  )
	 (:steploop #/.))
	(t 
	 (#:trace:output
	       (setq :value 
		     (if (not (:nobind? :forme)) ; On exclue le cas des &nobind
			 (traceval :forme :env)
		       (:stepmargin :depth)
		       (printerror 'step
				   :ERRNBD
				   :forme)
		       (eval :forme :env)))
	       (:stepmargin :depth) 
	       (print :depth " <- " :value)))))

#|
	 (#:trace:output
	  (setq :value 
		(if (not (:nobind? :forme)) ; On exclue le cas des &nobind
		    (traceval :forme :env)
		  (:stepmargin :depth)
		  (printerror 'step :ERRNBD :forme)
		  (eval :forme :env)))
	  (:stepmargin :depth) 
	  (print :depth " <- " :value)))))
|#
(de stepend ()
    (mapc 'remob (oblist 'step))
    (libautoload trace step unstep cstep)
    'stepend)

; .Section "Re'cupe'ration de l'espace"

(de debugend ()
    ; re'cupe`re la place des fonctions de mise au point
    (tracend)
    (stepend)
    (rem-feature 'debug)
    'debugend)