src/merror.lisp

   1 ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
   2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   3 ;;;     The data in this file contains enhancments.                    ;;;;;
   4 ;;;                                                                    ;;;;;
   5 ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
   6 ;;;     All rights reserved                                            ;;;;;
   7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   8 ;;;     (c) Copyright 1982 Massachusetts Institute of Technology         ;;;
   9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10
  11 (in-package :maxima)
  12
  13 (macsyma-module merror)
  14
  15 ;;; Macsyma error signalling.
  16 ;;; 2:08pm  Tuesday, 30 June 1981 George Carrette.
  17
  18 (defmvar $error `((mlist simp) "No error.")
  19   "During an MAXIMA-ERROR break this is bound to a list
  20   of the arguments to the call to MAXIMA-ERROR, with the message
  21   text in a compact format.")
  22
  23 (defmvar $errormsg 't
  24   "If `false' then no maxima-error message is printed!")
  25
  26 (defmfun $error (&rest l)
  27   "Signals a Maxima user error."
  28   (apply #'merror (fstringc l)))
  29
  30 (defmfun $warning (&rest l)
  31   "Signals a Maxima warning."
  32   (apply #'mwarning l))
  33
  34 (defmvar $error_size 60.
  35   "Expressions greater in SOME size measure over this value
  36   are replaced by symbols {ERREXP1, ERREXP2,...} in the MAXIMA-ERROR
  37   display, the symbols being set to the expressions, so that one can
  38   look at them with expression editing tools. The default value of
  39   this variable may be determined by factors of terminal speed and type.")
  40
  41 (defun error-size (exp)
  42   ; Call SPECREPCHECK on the argument in case it's a specrep. Ugh.
  43   ; But this simplifies its argument, which is a no-no if we got here
  44   ; because some simplification code is complaining, so inhibit simplification. Double ugh.
  45   (let (($simp nil))
  46     (declare (special $simp))
  47     (setq exp (specrepcheck exp)))
  48
  49   (if (atom exp)
  50       0
  51       (do ((l (cdr exp) (cdr l))
  52            (n 1 (1+ (+ n (error-size (car l))))))
  53           ((or (atom l)
  54                ;; no need to go any further, and this will save us
  55                ;; from circular structures. (Which the display
  56                ;; package would have a hell of a time with too.)
  57                (> n $error_size))
  58            n))))
  59
  60 ;;; Problem: Most macsyma users do not take advantage of break-points
  61 ;;; for debugging. Therefore they need to have the error variables
  62 ;;; SET (as the old ERREXP was), and not PROGV bound. The problem with
  63 ;;; this is that recursive errors will bash the old value of the
  64 ;;; error variables. However, since we do bind the value of the
  65 ;;; variable $ERROR, calling the function $ERRORMSG will always
  66 ;;; set things back. It would be better to bind these variables,
  67 ;;; for, among other things, then the values could get garbage
  68 ;;; collected.
  69
  70 (define-condition maxima-$error (error)
  71   ((message :initform $error :reader the-$error))
  72   (:documentation "Muser error, to be signalled by MERROR, usually.")
  73   (:report (lambda (c stream)
  74              (declare (ignore c))
  75              (let ((*standard-output* stream))
  76                ($errormsg)))))
  77
  78 (defvar *merror-signals-$error-p* nil
  79   "When T, MERROR will signal a MAXIMA-$ERROR condition.")
  80
  81 ;; Sample:
  82 ;; (defun h (he)
  83 ;;   (merror "hi there ~:M and ~:M" he he))
  84 ;; This will signal a MAXIMA-$ERROR condition:
  85 ;; (with-$error (h '$you))
  86
  87 (defmacro with-$error (&body body)
  88   "Let MERROR signal a MAXIMA-$ERROR condition."
  89   `(let ((*merror-signals-$error-p* t))
  90      (declare (special *merror-signals-$error-p*))
  91      ,@body))
  92
  93 (defun merror (sstring &rest l)
  94   (declare (special errcatch *mdebug*))
  95   (setq $error `((mlist simp) ,sstring ,@ l))
  96   (cond (*merror-signals-$error-p*
  97          (error 'maxima-$error))
  98         ((eq *mdebug* '$lisp)
  99          ; Go immediately into the lisp debugger
 100          (let ((*debugger-hook* nil))
 101            (invoke-debugger (make-condition 'maxima-$error))))
 102         (*mdebug*
 103          (let ((dispflag t) ret)
 104            (declare (special dispflag))
 105            (when $errormsg
 106              ($errormsg))
 107            (format t (intl:gettext " -- an error.  Entering the Maxima debugger.~%~
 108                        Enter ':h' for help.~%"))
 109            (progn
 110              (setq ret (break-dbm-loop nil))
 111              (cond ((eql ret :resume)
 112                     (break-quit))))))
 113         (errcatch
 114          (when $errormsg
 115            ($errormsg))
 116          (error 'maxima-$error))
 117         (t
 118          (when $errormsg
 119            ($errormsg))
 120          (fresh-line *standard-output*)
 121          ($backtrace 3)
 122          (format t (intl:gettext "~& -- an error. To debug this try: debugmode(true);~%"))
 123          (finish-output)
 124          (throw 'macsyma-quit 'maxima-error))))
 125
 126 (defun mwarning (&rest l)
 127   (format t "Warning: ~{~a~^ ~}~%" (mapcar #'$sconcat l)))
 128
 129 (defmvar $error_syms '((mlist) $errexp1 $errexp2 $errexp3)
 130   "Symbols to bind the too-large `maxima-error' expresssions to")
 131
 132 (putprop '$error_syms 'assign-symbols 'assign)
 133
 134 (defun assign-symbols (var val)
 135   (if (not (and ($listp val)
 136                 (do ((l (cdr val) (cdr l)))
 137                     ((null l) (return t))
 138                   (if (not (symbolp (car l))) (return nil)))))
 139       (merror (intl:gettext "assignment: assignment to ~M must be a list of symbols; found: ~M")
 140               var val)))
 141
 142 (defun process-error-argl (l)
 143   ;; This returns things so that we could set or bind.
 144   (do ((error-symbols nil)
 145        (error-values nil)
 146        (new-argl nil)
 147        (symbol-number 0))
 148       ((null l)
 149        (list (nreverse error-symbols)
 150              (nreverse error-values)
 151              (nreverse new-argl)))
 152     (let ((form (pop l)))
 153       (cond ((> (error-size form) $error_size)
 154              (incf symbol-number)
 155              (let ((sym (nthcdr symbol-number $error_syms)))
 156                (cond (sym
 157                       (setq sym (car sym)))
 158                      (t
 159                       (setq sym (intern (format nil "~A~D" '$errexp
 160                                                 symbol-number)))
 161                       (tuchus $error_syms sym)))
 162                (push sym error-symbols)
 163                (push form error-values)
 164                (push sym new-argl)))
 165             (t
 166              (push form new-argl))))))
 167
 168 (defmfun $errormsg ()
 169   "errormsg() redisplays the maxima-error message while in a `maxima-error' break."
 170   ;; Don't optimize out call to PROCESS-ERROR-ARGL in case of
 171   ;; multiple calls to $ERRORMSG, because the user may have changed
 172   ;; the values of the special variables controlling its behavior.
 173   ;; The real expense here is when MFORMAT calls the DISPLA package.
 174   (let ((the-jig (process-error-argl (cddr $error))))
 175     (mapc #'(lambda (v x) (setf (symbol-value v) x)) (car the-jig) (cadr the-jig))
 176     (fresh-line)
 177     (let ((errset nil))
 178       (if (null (errset
 179                  (apply #'mformat nil
 180                         (cadr $error) (caddr the-jig))))
 181           (mtell (intl:gettext "~%** error while printing error message **~%~A~%")
 182                  (cadr $error)
 183                  )))
 184     (fresh-line))
 185   '$done)
 186
 187 (defun read-only-assign (var val)
 188   (if munbindp
 189       'munbindp
 190       (merror (intl:gettext "assignment: attempting to assign read-only variable ~:M the value ~M") var val)))
 191
 192
 193 (defprop $error read-only-assign  assign)
 194
 195 ;; RAT-ERROR (function)
 196 ;;
 197 ;; Throw to the nearest enclosing RAT-ERR tag (set by IGNORE-RAT-ERROR or
 198 ;; RAT-ERROR-TO-MERROR). If ERROR-ARGS is nonzero, they are thrown. The
 199 ;; RAT-ERROR-TO-MERROR form applies the MERROR function to them.
 200 ;;
 201 ;; The obvious way to make RAT-ERROR work is to raise a condition. On the lisp
 202 ;; implementations we support other than CMUCL, this runs perfectly
 203 ;; fast. Unfortunately, on CMUCL there's a performance bug which turns out to be
 204 ;; very costly when you raise lots of the condition. There are lots and lots of
 205 ;; rat-error calls running the test suite (10s of thousands), and this turns out
 206 ;; to be hilariously slow.
 207 ;;
 208 ;; Thus we do the (catch .... (throw .... )) thing instead. Other error handling
 209 ;; should be able to use conditions with impunity: the only reason that the
 210 ;; performance was so critical with rat error is the sheer number of them that
 211 ;; are thrown.
 212 (defun rat-error (&rest error-args)
 213   (throw 'rat-err error-args))
 214
 215 ;; IGNORE-RAT-ERR
 216 ;;
 217 ;; Evaluate BODY with the RAT-ERR tag set. If something in BODY throws to
 218 ;; RAT-ERR (happens upon calling the RAT-ERROR function), this form evaluates to
 219 ;; NIL.
 220 (defmacro ignore-rat-err (&body body)
 221   (let ((result (gensym)) (error-p (gensym)))
 222     `(let ((,result) (,error-p t))
 223        (catch 'rat-err
 224          (setf ,result (progn ,@body))
 225          (setf ,error-p nil))
 226        (unless ,error-p ,result))))
 227
 228 (defmacro rat-error-to-merror (&body body)
 229   (let ((result (gensym)) (error-args (gensym)) (error-p (gensym)))
 230     `(let ((,result) (,error-p t))
 231        (let ((,error-args
 232               (catch 'rat-err
 233                 (setf ,result (progn ,@body))
 234                 (setf ,error-p nil))))
 235          (when ,error-p
 236            (apply #'merror ,error-args)))
 237        ,result)))
 238
 239 ;;; The user-error function is called on "strings" and expressions.
 240 ;;; Cons up a format string so that $ERROR can be bound.
 241 ;;; This might also be done at code translation time.
 242 ;;; This is a bit crude.
 243
 244 (defun fstringc (l)
 245   (do ((sl nil) (s) (sb)
 246        (se nil))
 247       ((null l)
 248        (setq sl (maknam sl))
 249        (cons sl (nreverse se)))
 250     (setq s (pop l))
 251     (cond ((stringp s)
 252            (setq sb (mapcan #'(lambda (x)
 253                                 (if (char= x #\~)
 254                                     (list x x)
 255                                     (list x)))
 256                             (coerce s 'list))))
 257           (t
 258            (push s se)
 259            (setq sb (list #\~ #\M))))
 260     (setq sl (nconc sl sb (if (null l) nil (list #\space))))))