(DEFINE-FILE-INFO §READTABLE "XCL" §PACKAGE "INTERLISP")

(filecreated "16-Oct-86 18:15:48" {eris}<lispcore>sources>aerror.\;4
 7011   

      |previous| |date:| "15-Sep-86 18:17:03" {eris}<lispcore>sources>aerror.\;3)


; Copyright (c) 1982, 1983, 1986 by Xerox Corporation.  All rights reserved.

(prettycomprint aerrorcoms)

(rpaqq aerrorcoms
 ((fns errorm errorn errorstring seterrorn lisperror \\lisperror \\illegal.arg 
                        \\arg.not.litatom)
                   (export (declare\: eval@compile (vars \\errormessagelist)
                                  dontcopy
                                  (optimizers lisperror)))
                   (variables *last-condition*)
                   (globalvars \\errormessagelist)
                   (functions condition-to-errn errm-to-condition)
                   (prop filetype aerror)
                   (localvars . t)))
(defineq

(errorm

  (lambda (x)
                                                (* |amd| "30-Jul-86 15:31")

    (cl:unless (or (condition-typep x 'condition)
                   (cl:listp x))
           (cl:setq x (list 17 x)))
    (cond
       ((condition-typep x 'condition)
        (cl:terpri t)
        (report-condition x t)
        (cl:terpri t))
       (t (prog nil
                (terpri t)
                (prin1 (or (car (nth \\errormessagelist (add1 (or (numberp (car x))
                                                                  17))))
                           '"ERROR")
                       t t)
                (terpri t)
                (return (print (car (or (listp (cdr x))
                                        (return)))
                               t t)))))))

(errorn

  (lambda nil
                                                (* |amd| "30-Jul-86 17:58")

                                                             (* |lmm:| 26 jun 75 655)

    (cond
       ((null *last-condition*)
        nil)
       ((condition-typep *last-condition* 'old-interlisp-error)
        (cons (old-interlisp-error-number *last-condition*)
              (cond
                 ((old-interlisp-error-message *last-condition*)
                  (list (old-interlisp-error-message *last-condition*)))
                 (t nil))))
       (t *last-condition*))))

(errorstring

  (lambda (x)
                                                (* |lmm| "21-APR-80 15:46")

    (car (nth \\errormessagelist (add1 (or (numberp x)
                                           17))))))

(seterrorn

  (lambda (num mess)
                                         (* |amd| "30-Jul-86 17:00")

    (cl:setq *last-condition* (errm-to-condition num mess))))

(lisperror

  (lambda (n x continueokflg)
                                (* |lmm| " 6-MAY-80 21:30")

                                                             (* |compiles| |open| |as| |call| |to| 

                                                             \\lisperror)

    (\\lisperror
 x n continueokflg)))

(\\lisperror

  (lambda (x n continueokflg)
                                (* |hdj| "15-Sep-86 17:39")

    (declare (usedfree \\interruptable))
    (prog nil
          (selectq n
              ((5 22) 
          
          (* |File| |errors| |that| |can| |happen| |to| |files| |open| |for| |output|)


                   
          
          (* * (\\stop.dribble? x))

)
              nil)
          (or \\interruptable (\\mp.error \\mp.uninterruptable 
                          "Error in uninterruptable system code -- ^N to continue into error handler" 
                                     x))
      ret (return (prog1 (cond
                            ((smallp n)
                             (errorx (list n x)))
                            (t (error n x)))
                         (or continueokflg (go ret)))))))

(\\illegal.arg

  (lambda (x)
                                                (* |lmm| "25-APR-80 18:02")

    (lisperror
 "ILLEGAL ARG" x)))

(\\arg.not.litatom

  (lambda (x)
                                                (* |lmm| "25-APR-80 18:02")

    (lisperror
 "ARG NOT LITATOM" x)))
)
(* FOLLOWING DEFINITIONS EXPORTED)


(declare\: eval@compile 

(rpaqq \\errormessagelist
 
       ("SYSTEM ERROR" " " "STACK OVERFLOW" "ILLEGAL RETURN" "ARG NOT LIST" "HARD DISK ERROR" 
              "ATTEMPT TO SET NIL OR T" "ATTEMPT TO RPLAC NIL" "UNDEFINED OR ILLEGAL GO" 
              "FILE WON'T OPEN" "NON-NUMERIC ARG" "ATOM TOO LONG" "ATOM HASH TABLE FULL" 
              "FILE NOT OPEN" "ARG NOT LITATOM" "! too many files open" "END OF FILE" "ERROR" "BREAK" 
              "ILLEGAL STACK ARG" "FAULT IN EVAL" "ARRAYS FULL" "FILE SYSTEM RESOURCES EXCEEDED" 
              "FILE NOT FOUND" "BAD SYSOUT FILE" "UNUSUAL CDR ARG LIST" "HASH TABLE FULL" 
              "ILLEGAL ARG" "ARG NOT ARRAY" "ILLEGAL OR IMPOSSIBLE BLOCK" 
              "STACK PTR HAS BEEN RELEASED" "STORAGE FULL" "ATTEMPT TO USE ITEM OF INCORRECT TYPE" 
              "ILLEGAL DATA TYPE NUMBER" "DATA TYPES FULL" "ATTEMPT TO BIND NIL OR T" 
              "! too many user interrupt characters" "! read-macro context error" "ILLEGAL READTABLE" 
              "ILLEGAL TERMINAL TABLE" "! swapblock too big for buffer" "PROTECTION VIOLATION" 
              "BAD FILE NAME" "USER BREAK" "UNBOUND ATOM" "UNDEFINED CAR OF FORM" 
              "UNDEFINED FUNCTION" "CONTROL-E" "FLOATING UNDERFLOW" "FLOATING OVERFLOW" "OVERFLOW" 
              "ARG NOT HARRAY" "TOO MANY ARGUMENTS"))
dontcopy 
(defoptimizer lisperror
 (message arg)
   `(\\lisperror ,arg ,(cl:if (cl:stringp message)
                              (for x in \\errormessagelist as i from 0 when (cl:equal x message)
                                   do
                                   (return i)
                                   finally
                                   (return (help "Unknown error message" (list message arg))))
                              message)))

)


(* END EXPORTED DEFINITIONS)

(cl:defvar *last-condition*
 nil 
                             "Last condition signalled. This gets rebound to itself in nested execs.")

(declare\: doeval@compile dontcopy

(globalvars \\errormessagelist)
)
(cl:defun condition-to-errn
 (condition) (cl:if (condition-typep condition 'old-interlisp-error)
                                               (old-interlisp-error-number condition)
                                               nil))

(cl:defun errm-to-condition
 (num message) (cl:if (condition-typep num 'condition)
                                                 num
                                                 (make-condition 'old-interlisp-error :number num 
                                                        :message message)))


(putprops aerror filetype
 cl:compile-file)
(declare\: doeval@compile dontcopy

(localvars . t)
)
(putprops aerror copyright ("Xerox Corporation" 1982 1983 1986))
(declare\: dontcopy
  (filemap (nil (900 4198 (errorm 910 . 1707) (errorn 1709 . 2303) (errorstring 2305 . 2525) (seterrorn 
2527 . 2700) (lisperror 2702 . 3037) (\\lisperror 3039 . 3878) (\\illegal.arg 3880 . 4033) (
\\arg.not.litatom 4035 . 4196)))))
stop