; .EnTete "Le-Lisp (c) version 15.2" " " "Le nouveau toplevel"
; .EnPied "toplevel.ll" "C-%" " "
; .Annexe C "Le Nouveau Toplevel"
; .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: toplevel.ll,v 4.2 88/11/17 17:14:39 nuyens Exp $"
(unless (>= (version) 15.2)
(error 'load 'erricf 'toplevel))
; .Section "Le nouveau toplevel et le gestionnaire d'erreur"
; La me'canique des interruptions programmables
(defvar #:sys-package:itsoft ()) ; le package des interruptions
; La me'canique de traitement des erreurs
(defvar #:system:debug ()) ; On debugge
(defvar #:trace:trace ()) ; les fonctions tracees
(defvar #:system:print-msgs 1) ; l'OS imprime ses messages
(defvar #:system:error-flag ()) ; Impression des messages
(df catcherror (#:system:error-flag . #:system:l)
; le re'cupe'rateur d'erreur "a` la Le←Lisp"
(let ((#:system:error-flag (eval #:system:error-flag)))
(let ((#:system:print-msgs
(if #:system:error-flag #:system:print-msgs 0))
(#:system:debug
(if #:system:error-flag #:system:debug ())))
(tag #:system:error-tag
(ncons (eprogn #:system:l))))))
(dmd errset (#:system:e #:system:i)
; le re'cupe'rateur d'erreur "a` la Maclisp"
(list 'catcherror #:system:i #:system:e))
(dmd err #:system:l
; l'argument est un PROGN a` e'valuer
(mcons 'exit '#:system:error-tag #:system:l))
; La fonction BREAK : elle sera rede'finie dans le debugger
(de break () (err))
; L'interruption SYSERROR
(defvar #:system:f ())
(defvar #:system:m ())
(defvar #:system:b ())
(de syserror (#:system:f #:system:m #:system:b)
; 1 - vide le tampon d'entre'e
(teread)
(tyflush)
; 2 - imprime le message sur TTY
(when (and #:system:error-flag (null #:system:debug))
(let ((outchan (outchan)))
(outchan ())
(protect
(printerror #:system:f #:system:m #:system:b)
(outchan outchan))))
(break))
; .Section "le toplevel proprement dit"
(defvar #:toplevel:status t) ; toplevel interactif
(defvar #:toplevel:read ()) ; dernier objet lu
(defvar #:toplevel:cread ()) ; objet courant
(defvar #:toplevel:print ()) ; dernie`re forme imprime'e
(defvar #:toplevel:eval ()) ; dernie`re valeur retourne'e
(dmd #:toplevel:topeval (e)
; e'value une expression au toplevel
(list 'tag '#:system:error-tag
(list 'lock '(lambda (tag val)
(cond ((null tag)
(ncons val))
((eq tag '#:system:error-tag) ())
((eq tag '#:system:toplevel-tag)
(exit #:system:toplevel-tag))
(t (error 'toplevel
'errudt
tag))))
e)))
(de toplevel ()
(tag #:system:toplevel-tag
(setq ; quelques re'glages :
#:system:error-flag t
; l'ancienne forme lue
#:toplevel:read #:toplevel:cread
; la nouvelle forme lue (en liste par TOPEVAL)
#:toplevel:cread (#:toplevel:topeval (read))
#:toplevel:cread
(when (consp #:toplevel:cread) (car #:toplevel:cread))
; la valeur de l'e'valuation
#:toplevel:eval (#:toplevel:topeval (eval #:toplevel:cread)))
(when (and (consp #:toplevel:eval)
#:toplevel:status)
(tyflush) ; pour ne pas me'langer les TYO e'ventuels
(princn #/=)
(princn #\sp)
(#:toplevel:topeval (print (car #:toplevel:eval))))
(setq #:toplevel:eval (car #:toplevel:eval))))
; petit re'glage du print
(printline 5000)
; .Section "Les libelle's des erreurs standard"
; .SSection "Les erreurs fatales"
#- #:system:foreign-language
(progn
(defvar ERRFSTK "***** Erreur fatale : pile pleine.")
(defvar ERRFSGC "***** Erreur fatale : pile pleine durant un GC.")
(defvar ERRFPGC "***** Erreur fatale : pile pleine durant un PRINT.")
(defvar ERRFSUD "***** Erreur fatale : pile vide.")
(defvar ERRFSTR "***** Erreur fatale : zone des chaines pleine.")
(defvar ERRFVEC "***** Erreur fatale : zone des vecteurs pleine.")
(defvar ERRFSYM "***** Erreur fatale : zone des symboles pleine.")
(defvar ERRFCNS "***** Erreur fatale : zone des listes pleine.")
(defvar ERRFFLT "***** Erreur fatale : zone des flottants pleine.")
(defvar ERRFFIX "***** Erreur fatale : zone des entiers pleine.")
(defvar ERRFHEP "***** Erreur fatale : zone du tas pleine.")
(defvar ERRFCOD "***** Erreur fatale : zone du code pleine.")
)
#+ #:system:foreign-language
(progn
(defvar ERRFSTK "***** Fatal error : stack overflow.")
(defvar ERRFSGC "***** Fatal error : stack overflow during GC.")
(defvar ERRFPGC "***** Fatal error : stack overflow during PRINT.")
(defvar ERRFSUD "***** Fatal error : stack underflow.")
(defvar ERRFSTR "***** Fatal error : no room for strings.")
(defvar ERRFVEC "***** Fatal error : no room for vectors.")
(defvar ERRFSYM "***** Fatal error : no room for symbols.")
(defvar ERRFCNS "***** Fatal error : no room for lists.")
(defvar ERRFFLT "***** Fatal error : no room for floats.")
(defvar ERRFFIX "***** Fatal error : no room for fixnums.")
(defvar ERRFHEP "***** Fatal error : heap overflow.")
(defvar ERRFCOD "***** Fatal error : no room for code.")
)
; .SSection "Les erreurs non fatales"
#- #:system:foreign-language
(progn
(defvar ERRMAC "erreur de la machine")
(defvar ERRUDV "variable indefinie")
(defvar ERRUDF "fonction indefinie")
(defvar ERRUDM "methode indefinie")
(defvar ERRUDT "echappement indefini")
(defvar ERRBDF "mauvaise definition")
(defvar ERRWNA "mauvais nombre d'arguments")
(defvar ERRBPA "mauvais parametre")
(defvar ERRILB "liaison illegale")
(defvar ERRBAL "mauvaise liste d'arguments")
(defvar ERRNAB "pas de portee lexicale")
(defvar ERRXIA "bloc lexical perime")
(defvar ERRSXT "erreur de syntaxe")
(defvar ERRIOS "erreur d'entree/sortie")
(defvar ERR0DV "division par 0")
(defvar ERRNNA "l'argument n'est pas un nombre")
(defvar ERRNIA "l'argument n'est pas un entier")
(defvar ERRNFA "l'argument n'est pas un flottant")
(defvar ERRNSA "l'argument n'est pas une chaine")
(defvar ERRNAA "l'argument n'est pas un atome")
(defvar ERRNLA "l'argument n'est pas une liste")
(defvar ERRNVA "l'argument n'est pas une variable")
(defvar ERRVEC "l'argument n'est pas un vecteur")
(defvar ERRSYM "l'argument n'est pas un symbole")
(defvar ERRNDA "l'argument n'est pas une adresse")
(defvar ERRSTC "l'argument n'est pas une structure")
(defvar ERROOB "argument hors limite")
(defvar ERRSTL "chaine trop longue")
(defvar ERRGEN "ne sait pas calculer")
(defvar ERRVIRTTY "terminal inconnu")
(defvar ERRFILE "fichier inconnu")
(defvar ERRICF "fichier incompatible")
(defvar ERRTNB "Je ne sais pas tracer une fonction &NOBIND")
(defvar ERRCNT "Je ne peux pas tracer")
(defvar ERRKNT "Je ne sais pas tracer une fonction de ce type")
(defvar ERRNTF "cette fonction n'etait pas tracee")
(defvar ERRUNK "je ne connais pas")
)
#+ #:system:foreign-language
(progn
(defvar ERRMAC "machine error")
(defvar ERRUDV "undefined variable")
(defvar ERRUDF "undefined function")
(defvar ERRUDM "undefined method")
(defvar ERRUDT "undefined escape")
(defvar ERRBDF "bad definition")
(defvar ERRWNA "wrong number of arguments")
(defvar ERRBPA "bad parameter")
(defvar ERRILB "illegal binding")
(defvar ERRBAL "bad argument list")
(defvar ERRNAB "no lexical scope")
(defvar ERRXIA "inactive lexical scope")
(defvar ERRSXT "syntax error")
(defvar ERRIOS "I/O error")
(defvar ERR0DV "division by zero")
(defvar ERRNNA "not a number")
(defvar ERRNIA "not a fixnum")
(defvar ERRNFA "non float argument")
(defvar ERRNSA "non string argument")
(defvar ERRNAA "not an atom")
(defvar ERRNLA "not a list")
(defvar ERRNVA "not a variable")
(defvar ERRVEC "not a vector")
(defvar ERRSYM "not a symbol")
(defvar ERRNDA "not an address")
(defvar ERRSTC "not a structure")
(defvar ERROOB "argument out of bounds")
(defvar ERRSTL "string too long")
(defvar ERRGEN "can't compute")
(defvar ERRVIRTTY "unknown terminal type")
(defvar ERRFILE "unknown file")
(defvar ERRICF "incompatible file")
(defvar ERRTNB "I don't know how to trace an &NOBIND function")
(defvar ERRCNT "I can't trace")
(defvar ERRKNT "I don't know trace a function of this type")
(defvar ERRNTF "this function wasn't traced")
(defvar ERRUNK "I don't know")
)
; .Section "Les impressions du gestionnaire d'erreur"
(de printerror (#:system:f #:system:m #:system:b)
; imprime un message d'erreur
; - pour la fonction <f>
; - le type d'erreur <m>
; - l'argument de'fectueux <b>
(print "** " #:system:f " : "
;; determiner le message
(if (and (symbolp #:system:m) (boundp #:system:m))
;; les erreurs standard sont signalle's quote' pour permettre
;; de tester le nom de l'erreur, au lieu de son message.
(symeval #:system:m)
#:system:m)
" : "
(cond
((and (eq #:system:m 'errsxt)
(numberp #:system:b)
(> #:system:b 0) (< #:system:b 13))
(selectq #:system:b
(1 #- #:system:foreign-language "liste trop courte"
#+ #:system:foreign-language "list too short")
(2 #- #:system:foreign-language "chaine trop longue"
#+ #:system:foreign-language "string too long")
(3 #- #:system:foreign-language "symbole trop long"
#+ #:system:foreign-language "symbol too long")
(4 #- #:system:foreign-language "mauvais debut d'expression"
#+ #:system:foreign-language "bad beginning of expression")
(5 #- #:system:foreign-language "symbole special trop long"
#+ #:system:foreign-language "special symbol too long")
(6 #- #:system:foreign-language "mauvais package"
#+ #:system:foreign-language "bad package")
(7 #- #:system:foreign-language "mauvaise construction pointee"
#+ #:system:foreign-language "bad dotted pair construction")
(9 #- #:system:foreign-language "mauvaise liste arguments"
#+ #:system:foreign-language "bad arguments list")
(10 #- #:system:foreign-language "mauvaise valeur de splice-macro"
#+ #:system:foreign-language "bad splice-macro")
(11 #- #:system:foreign-language "EOF durant un READ"
#+ #:system:foreign-language "EOF during READ")
(12 #- #:system:foreign-language "mauvaise utilisation du BACKQUOTE"
#+ #:system:foreign-language "bad use of BACKQUOTE")
(t #:system:b)))
((and #:system:unixp
(eq #:system:m 'errmac)
(numberp #:system:b))
(selectq #:system:b
(4 #- #:system:foreign-language "instruction illegale"
#+ #:system:foreign-language "illegal instruction")
(8 #- #:system:foreign-language "exception flottante"
#+ #:system:foreign-language "floating point exception")
(10 #- #:system:foreign-language "erreur de bus"
#+ #:system:foreign-language "bus error")
(11 #- #:system:foreign-language "violation de segment"
#+ #:system:foreign-language "segmentation fault")
(t #:system:b)))
(t #:system:b))))