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