(FILECREATED "15-Sep-86 18:17:03" {ERIS}<LISPCORE>SOURCES>AERROR.;3 6940
changes to: (FNS \LISPERROR)
previous date: " 9-Sep-86 13:51:45" {ERIS}<LISPCORE>SOURCES>AERROR.;2)
(* 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 (QUOTE CONDITION))
(CL:LISTP X))
(CL:SETQ X (LIST 17 X)))
(COND
((CONDITION-TYPEP X (QUOTE 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))))
(QUOTE "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* (QUOTE 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)
(BQUOTE (\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)
(DEFVAR *LAST-CONDITION* NIL "Last condition signalled. This gets rebound to itself in nested execs.")
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \ERRORMESSAGELIST)
)
(DEFUN CONDITION-TO-ERRN (CONDITION) (CL:IF (CONDITION-TYPEP CONDITION (QUOTE OLD-INTERLISP-ERROR))
(OLD-INTERLISP-ERROR-NUMBER CONDITION)
NIL))
(DEFUN ERRM-TO-CONDITION (NUM MESSAGE) (CL:IF (CONDITION-TYPEP NUM (QUOTE CONDITION))
NUM
(MAKE-CONDITION (QUOTE OLD-INTERLISP-ERROR)
:NUMBER NUM :MESSAGE MESSAGE)))
(PUTPROPS AERROR FILETYPE COMPILE-FILE)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
(PUTPROPS AERROR COPYRIGHT ("Xerox Corporation" 1982 1983 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (869 4152 (ERRORM 879 . 1693) (ERRORN 1695 . 2292) (ERRORSTRING 2294 . 2510) (SETERRORN
2512 . 2683) (LISPERROR 2685 . 2940) (\LISPERROR 2942 . 3838) (\ILLEGAL.ARG 3840 . 3990) (
\ARG.NOT.LITATOM 3992 . 4150)))))
STOP