mirror of
https://github.com/PDP-10/its.git
synced 2026-03-02 01:50:24 +00:00
275 lines
9.6 KiB
Common Lisp
275 lines
9.6 KiB
Common Lisp
;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
|
||
;;; (c) Copyright 1976, 1983 Massachusetts Institute of Technology ;;;
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
||
(macsyma-module merror)
|
||
|
||
;;; Macsyma error signalling.
|
||
;;; 2:08pm Tuesday, 30 June 1981 George Carrette.
|
||
|
||
(DEFMVAR $ERROR '((MLIST SIMP) |&No error.|)
|
||
"This is set to a list of the arguments to the call to ERROR,
|
||
with the message text in a compact format.")
|
||
|
||
(DEFMVAR $ERRORMSG 'T
|
||
"If FALSE then NO error message is printed!")
|
||
|
||
(DEFMFUN $ERROR (&REST L)
|
||
"Signals a Macsyma user error."
|
||
(apply #'merror (fstringc L)))
|
||
|
||
(DEFMVAR $ERROR_SIZE 10.
|
||
"Expressions greater in some size measure over this value
|
||
are replaced by symbols {ERREXP1, ERREXP2,...} in the error
|
||
display, the symbols being set to the expressions, so that one can
|
||
look at them with expression editing tools. The default value of
|
||
this variable may be determined by factors of terminal speed and type.")
|
||
|
||
(DECLARE (FIXNUM (ERROR-SIZE NIL)))
|
||
|
||
(DEFUN ERROR-SIZE (EXP)
|
||
(IF (ATOM EXP) 0
|
||
(DO ((L (CDR EXP) (CDR L))
|
||
(N 1 (1+ (+ N (ERROR-SIZE (CAR L))))))
|
||
((OR (NULL L)
|
||
;; no need to go any further, and this will save us
|
||
;; from circular structures. (Which they display
|
||
;; package would have a hell of a time with too.)
|
||
(> N $ERROR_SIZE))
|
||
N)
|
||
(DECLARE (FIXNUM N)))))
|
||
|
||
;;; Problem: Most macsyma users do not take advantage of break-points
|
||
;;; for debugging. Therefore they need to have the error variables
|
||
;;; SET (as the old ERREXP was), and not PROGV bound. The problem with
|
||
;;; this is that recursive errors will bash the old value of the error
|
||
;;; variables. It would be better to bind these variables, for, among
|
||
;;; other things, then the values could get garbage collected.
|
||
|
||
;; Define the MACSYMA-ERROR condition.
|
||
#+LISPM (PROGN 'COMPILE
|
||
|
||
(DEFFLAVOR MACSYMA-ERROR (MFORMAT-STRING) (ERROR)
|
||
:INITABLE-INSTANCE-VARIABLES)
|
||
(DEFMETHOD (MACSYMA-ERROR :REPORT) (STREAM) (SEND STREAM ':STRING-OUT MFORMAT-STRING))
|
||
(COMPILE-FLAVOR-METHODS MACSYMA-ERROR)
|
||
|
||
;;; I'm not sure that this is the right way to do this. We can always flush this when
|
||
;;; enter-macsyma-debugger does the right thing.
|
||
|
||
(DEFFLAVOR MACSYMA-DEBUGGER (MFORMAT-STRING) (ERROR)
|
||
:INITABLE-INSTANCE-VARIABLES)
|
||
(DEFMETHOD (MACSYMA-DEBUGGER :REPORT) (STREAM) (SEND STREAM ':STRING-OUT MFORMAT-STRING))
|
||
(COMPILE-FLAVOR-METHODS MACSYMA-DEBUGGER)
|
||
|
||
(DEFUN ENTER-MACSYMA-DEBUGGER ()
|
||
(ERROR 'MACSYMA-DEBUGGER ':MFORMAT-STRING "Entering Lisp Debugger"))
|
||
(DEFPROP ENTER-MACSYMA-DEBUGGER T :ERROR-REPORTER)
|
||
|
||
) ;#+LISPM
|
||
|
||
(DEFMFUN MERROR (STRING &REST L)
|
||
(SETQ STRING (CHECK-OUT-OF-CORE-STRING STRING))
|
||
(SETQ $ERROR `((MLIST) ,STRING ,@L))
|
||
(AND $ERRORMSG ($ERRORMSG))
|
||
#+LISPM (IF DEBUG
|
||
(ENTER-MACSYMA-DEBUGGER)
|
||
(ERROR 'MACSYMA-ERROR ':MFORMAT-STRING STRING))
|
||
#+NIL (ERROR STRING)
|
||
#-(OR LISPM NIL) (ERROR))
|
||
|
||
#+LISPM
|
||
;; This tells the error handler to report the context of
|
||
;; the error as the function that called MERROR, instead of
|
||
;; saying that the error was in MERROR.
|
||
(DEFPROP MERROR T :ERROR-REPORTER)
|
||
|
||
(DEFMVAR $ERROR_SYMS '((MLIST) $ERREXP1 $ERREXP2 $ERREXP3)
|
||
"Symbols to bind the too-large error expresssions to")
|
||
|
||
(DEFUN ($ERROR_SYMS ASSIGN) (VAR VAL)
|
||
(IF (NOT (AND ($LISTP VAL)
|
||
(DO ((L (CDR VAL) (CDR L)))
|
||
((NULL L) (RETURN T))
|
||
(IF (NOT (SYMBOLP (CAR L))) (RETURN NIL)))))
|
||
(MERROR "The variable ~M being set to ~M which is not a list of symbols."
|
||
VAR VAL)))
|
||
|
||
(DEFUN PROCESS-ERROR-ARGL (L)
|
||
;; This returns things so that we could set or bind.
|
||
(DO ((ERROR-SYMBOLS NIL)
|
||
(ERROR-VALUES NIL)
|
||
(NEW-ARGL NIL)
|
||
(SYMBOL-NUMBER 0))
|
||
((NULL L)
|
||
(LIST (NREVERSE ERROR-SYMBOLS)
|
||
(NREVERSE ERROR-VALUES)
|
||
(NREVERSE NEW-ARGL)))
|
||
(LET ((FORM (POP L)))
|
||
(COND ((> (ERROR-SIZE FORM) $ERROR_SIZE)
|
||
(SETQ SYMBOL-NUMBER (1+ SYMBOL-NUMBER))
|
||
(LET ((SYM (NTHCDR SYMBOL-NUMBER $ERROR_SYMS)))
|
||
(COND (SYM
|
||
(SETQ SYM (CAR SYM)))
|
||
('ELSE
|
||
(SETQ SYM (CONCAT '$ERREXP SYMBOL-NUMBER))
|
||
(SETQ $ERROR_SYMS (APPEND $ERROR_SYMS (LIST SYM)))))
|
||
(PUSH SYM ERROR-SYMBOLS)
|
||
(PUSH FORM ERROR-VALUES)
|
||
(PUSH SYM NEW-ARGL)))
|
||
('ELSE
|
||
(PUSH FORM NEW-ARGL))))))
|
||
|
||
(DEFMFUN $ERRORMSG ()
|
||
"ERRORMSG() redisplays the error message."
|
||
;; Don't optimize out call to PROCESS-ERROR-ARGL in case of
|
||
;; multiple calls to $ERRORMSG, because the user may have changed
|
||
;; the values of the special variables controlling its behavior.
|
||
;; The real expense here is when MFORMAT calls the DISPLA package.
|
||
(LET ((THE-JIG (PROCESS-ERROR-ARGL (CDDR $ERROR))))
|
||
(MAPC #'SET (CAR THE-JIG) (CADR THE-JIG))
|
||
(CURSORPOS 'A #-(OR LISPM NIL) NIL)
|
||
(LET ((ERRSET NIL))
|
||
(IF (NULL (ERRSET
|
||
(LEXPR-FUNCALL #'MFORMAT NIL (CADR $ERROR) (CADDR THE-JIG))))
|
||
(MTELL "~%** Error while printing error message **~%~A~%"
|
||
(CADR $ERROR)
|
||
)))
|
||
(IF (NOT (ZEROP (CHARPOS T))) (MTERPRI)))
|
||
'$DONE)
|
||
|
||
(DEFMFUN READ-ONLY-ASSIGN (VAR VAL)
|
||
(IF MUNBINDP
|
||
'MUNBINDP
|
||
(MERROR "Attempting to assign read-only variable ~:M the value:~%~M"
|
||
VAR VAL)))
|
||
|
||
(DEFPROP $ERROR READ-ONLY-ASSIGN ASSIGN)
|
||
|
||
;; THIS THROWS TO (*CATCH 'RATERR ...), WHEN A PROGRAM ANTICIPATES
|
||
;; AN ERROR (E.G. ZERO-DIVIDE) BY SETTING UP A CATCH AND SETTING
|
||
;; ERRRJFFLAG TO T. Someday this will be replaced with SIGNAL.
|
||
;; Such skill with procedure names! I'd love to see how he'd do with
|
||
;; city streets.
|
||
|
||
;;; N.B. I think the above comment is by CWH, this function used
|
||
;;; to be in RAT;RAT3A. Its not a bad try really, one of the better
|
||
;;; in macsyma. Once all functions of this type are rounded up
|
||
;;; I'll see about implementing signaling. -GJC
|
||
|
||
(DEFMFUN ERRRJF N
|
||
(IF ERRRJFFLAG (*THROW 'RATERR NIL) (APPLY #'MERROR (LISTIFY N))))
|
||
|
||
;;; The user-error function is called on |&foo| "strings" and expressions.
|
||
;;; Cons up a format string so that $ERROR can be bound.
|
||
;;; This might also be done at code translation time.
|
||
;;; This is a bit crude.
|
||
|
||
(defmfun fstringc (L)
|
||
(do ((sl nil) (s) (sb)
|
||
(se nil))
|
||
((null l)
|
||
(setq sl (maknam sl))
|
||
#+PDP10
|
||
(putprop sl t '+INTERNAL-STRING-MARKER)
|
||
(cons sl (nreverse se)))
|
||
(setq s (pop l))
|
||
(cond ((and (symbolp s) (= (getcharn s 1) #/&))
|
||
(setq sb (mapcan #'(lambda (x)
|
||
(if (= x #/~)
|
||
(list x x)
|
||
(list x)))
|
||
(cdr (exploden s)))))
|
||
(t
|
||
(push s se)
|
||
(setq sb (list #/~ #/M))))
|
||
(setq sl (nconc sl sb (if (null l) nil (list #\SP))))))
|
||
|
||
#+PDP10
|
||
(PROGN 'COMPILE
|
||
;; Fun and games with the pdp-10. The calling sequence for
|
||
;; subr, (arguments passed through registers), is much smaller
|
||
;; than that for lsubrs. If we really were going to do a lot
|
||
;; of this hackery then we would define some kind of macro
|
||
;; for it.
|
||
(LET ((X (GETL 'MERROR '(EXPR LSUBR))))
|
||
(REMPROP '*MERROR (CAR X))
|
||
(PUTPROP '*MERROR (CADR X) (CAR X)))
|
||
(DECLARE (*LEXPR *MERROR))
|
||
(DEFMFUN *MERROR-1 (A) (*MERROR A))
|
||
(DEFMFUN *MERROR-2 (A B) (*MERROR A B))
|
||
(DEFMFUN *MERROR-3 (A B C) (*MERROR A B C))
|
||
(DEFMFUN *MERROR-4 (A B C D) (*MERROR A B C D))
|
||
(DEFMFUN *MERROR-5 (A B C D E) (*MERROR A B C D E))
|
||
|
||
|
||
(LET ((X (GETL 'ERRRJF '(EXPR LSUBR))))
|
||
(REMPROP '*ERRRJF (CAR X))
|
||
(PUTPROP '*ERRRJF (CADR X) (CAR X)))
|
||
(DECLARE (*LEXPR *ERRRJF))
|
||
(DEFMFUN *ERRRJF-1 (A) (*ERRRJF A))
|
||
|
||
)
|
||
#+Maclisp
|
||
(progn 'compile
|
||
(defun m-wna-eh (((f . actual-args) args-info))
|
||
;; generate a nice user-readable message about this lisp error.
|
||
;; F may be a symbol or a lambda expression.
|
||
;; args-info may be nil, an args-info form, or a formal argument list.
|
||
(merror "~M ~A to function ~A"
|
||
`((mlist) ,@actual-args)
|
||
;; get the error messages passed as first arg to lisp ERROR.
|
||
(caaddr (errframe ()))
|
||
(if (symbolp f)
|
||
(if (or (equal (args f) args-info)
|
||
(symbolp args-info))
|
||
f
|
||
`((,f),@args-info))
|
||
`((lambda)((mlist),@(cadr f))))))
|
||
|
||
(defun m-wta-eh ((object))
|
||
(merror "~A: ~A" (caaddr (errframe ())) object))
|
||
|
||
(defun m-ubv-eh ((variable))
|
||
(merror "Unbound variable: ~A" variable))
|
||
|
||
;; TRANSL generates regular LISP function calls for functions which
|
||
;; are lisp defined at translation time, and in compiled code.
|
||
;; MEXPRs can be handled by the UUF (Undefined User Function) handler.
|
||
|
||
(DEFVAR UUF-FEXPR-ALIST ())
|
||
|
||
(DEFUN UUF-HANDLER (X)
|
||
(LET ((FUNP (OR (MGETL (CAR X) '(MEXPR MMACRO))
|
||
(GETL (CAR X) '(TRANSLATED-MMACRO MFEXPR* MFEXPR*S)))))
|
||
(CASEQ (CAR FUNP)
|
||
((MEXPR)
|
||
;; The return value of the UUF-HANDLER is put back into
|
||
;; the "CAR EVALUATION LOOP" of the S-EXP. It is evaluated,
|
||
;; checked for "functionality" and applied if a function,
|
||
;; otherwise it is evaluated again, unless it's atomic,
|
||
;; in which case it will call the UNDF-FNCTN handler again,
|
||
;; unless (STATUS PUNT) is NIL in which case it is
|
||
;; evaluated (I think). One might honestly ask
|
||
;; why the maclisp evaluator behaves like this. -GJC
|
||
`((QUOTE (LAMBDA *N*
|
||
(MAPPLY ',(CAR X) (LISTIFY *N*) ',(CAR X))))))
|
||
((MMACRO TRANSLATED-MMACRO)
|
||
(MERROR
|
||
"Call to a macro '~:@M' which was undefined during translation."
|
||
(CAR X)))
|
||
((MFEXPR* MFEXPR*S)
|
||
;; An call in old translated code to what was a FEXPR.
|
||
(LET ((CELL (ASSQ (CAR X) UUF-FEXPR-ALIST)))
|
||
(OR CELL
|
||
(LET ((NAME (GENSYM)))
|
||
(PUTPROP NAME
|
||
`(LAMBDA (,NAME) (MEVAL (CONS '(,(CAR X)) ,NAME)))
|
||
'FEXPR)
|
||
(SETQ CELL (LIST (CAR X) NAME))
|
||
(PUSH CELL UUF-FEXPR-ALIST)))
|
||
(CDR CELL)))
|
||
(T
|
||
(MERROR "Call to an undefined function '~A' at Lisp level."
|
||
(CAR X))))))
|
||
) |