(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED "16-May-90 18:18:52" |{DSK}local>lde>lispcore>sources>IL-ERROR-STUFF.;2| 12984 |changes| |to:| (VARS IL-ERROR-STUFFCOMS) |previous| |date:| " 2-Mar-88 16:39:33" |{DSK}local>lde>lispcore>sources>IL-ERROR-STUFF.;1| ) ; Copyright (c) 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. (PRETTYCOMPRINT IL-ERROR-STUFFCOMS) (RPAQQ IL-ERROR-STUFFCOMS ((FNS HELP SHOULDNT ERROR ERRORX INTERRUPT FAULTEVAL FAULTAPPLY OLDFAULT1 ERRORMESS ERRORMESS1 SMARTARGLIST \\SIMPLIFY.CL.ARGLIST) (INITVARS (HELPDEPTH 7) (BREAKDELIMITER " ") (HELPTIME 1000) (HELPCLOCK) (NLSETQGAG T) (*MACROEXPAND-HOOK* 'CL:FUNCALL) (COMPILERMACROPROPS '(DMACRO ALTOMACRO BYTEMACRO MACRO))) (* |;;| "for backward compatibility. Used currently by window mouse handler") (VARS (NBREAKS 0)) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA ERRORX))))) (DEFINEQ (help (lambda (mess1 mess2) (* \; "Edited 5-Feb-88 14:38 by amd") "Used to signify 'I don't know what I should do'" (conditions:invoke-debugger (make-condition 'simple-condition :format-string "Help!~@{~@[ ~A~]~}" :format-arguments (list mess1 mess2))))) (shouldnt (lambda (mess) (* \; "Edited 9-Mar-87 11:41 by jrb:") (help "Shouldn't happen:" mess))) (error (lambda (mess1 mess2 nobreak) (* \; "Edited 18-Jan-88 19:05 by amd") (declare (globalvars nlsetqgag)) (cond ((and nobreak (neq helpflag 'break!)) (* \; "An ERROR! cum message.") (signal (errm-to-condition 17 (cons mess1 mess2))) (errormess1 mess1 mess2) (error!)) (t (seterrorn 17 (cons mess1 mess2)) (errorx *last-condition*))))) (errorx (cl:lambda (&optional erxm) (* \; "Edited 7-Apr-87 18:12 by amd") (and erxm (not (typep erxm (quote condition))) (seterrorn (car erxm) (cadr erxm))) (resetlst (let ((errorpos (find-debugger-entry-frame (quote errorx) t))) (declare (cl:special errorpos)) (resetsave nil (list (quote relstk) errorpos)) (proceed-case (cl:error *last-condition*) (proceed (condition) :report "Retry execution" (envapply (stkname errorpos) (stkargs errorpos) (stknth 1 errorpos errorpos) errorpos t t)))))) ) (interrupt (lambda (intfn) (* \; "Edited 24-Nov-86 19:16 by amd") (debugger :condition (make-condition (quote si::interrupt) :function intfn))) ) (faulteval (lambda (faultx) (declare (localvars . t)) (* \; "Edited 12-Mar-87 09:56 by jds") (prog (tem tem2) (cond ((listp faultx) (cond ((litatom (setq tem (car faultx))) (cond ((and (setq tem2 (getmacroprop tem compilermacroprops)) (not (equal faultx (setq tem2 (macroexpansion faultx tem2))))) (cond (clisparray (puthash faultx (or (listp tem2) (list (quote progn) tem2)) clisparray))) (return (\\eval tem2))) ((setq tem2 (get tem (quote macro-fn))) (return (\\eval (cl:funcall *macroexpand-hook* tem2 faultx nil)))) (t (setq tem (getd (car faultx))))))) (cond ((and (listp tem) (fmemb (car tem) lambdasplst)) (return (\\evalformaslambda faultx)))))) (return (cond ((and dwimflg (getd (quote newfault1))) (newfault1 faultx)) (t (oldfault1 faultx)))))) ) (faultapply (lambda (faultfn faultargs) (* \; "Edited 24-Feb-87 14:26 by amd") (cond ((ccodep faultfn) (* |;;| " hack to handle case where microcode doesn't know how to FUNCALL a CCODEP") (spreadapply (quote \\interpreter-dummy) (uninterruptably (putd (quote \\interpreter-dummy) faultfn t) faultargs))) (t (prog ((def (cond ((cl:symbolp faultfn) (getd faultfn)) (t faultfn))) %lexical-environment%) retry (cond ((typep def (quote closure)) (* \; "an interpreted closure ") (setq %lexical-environment% (closure-environment def)) (setq def (closure-function def)) (go retry))) (return (prog (tran tranfn) (or (and (listp def) (fmemb (car def) lambdasplst)) (go out)) (cond ((or (setq tran (gethash def clisparray)) (and (setq tranfn (car (cdr (assoc (car def) lambdatranfns)))) (listp (setq tran (cl:funcall tranfn def))) (progn (and clisparray (puthash def tran clisparray)) t))) (* |;;| "either in CLISPARRAY or translated by lambda-tran") (setq def tran)) (%lexical-environment% (* |;;| "found the environment")) (t (go out))) (return (apply def faultargs)) out (return (cond ((and dwimflg (getd (quote newfault1))) (newfault1 faultfn faultargs t)) (t (oldfault1 faultfn faultargs t)))))))))) ) (oldfault1 (lambda (faultx faultargs faultapplyflg) (* |lmm| " 6-Nov-86 02:10") (cl:cerror "Re-execute" (cond (faultapplyflg (make-condition (quote undefined-function-in-apply) :name faultx :arguments faultargs)) ((nlistp faultx) (make-condition (quote unbound-variable) :name faultx)) (t (make-condition (quote undefined-function) :name (car faultx))))) (cond (faultapplyflg (cl:apply faultx faultargs)) (t (eval faultx)))) ) (errormess (lambda (u) (* \; "Edited 24-Nov-86 13:46 by amd") (* |;;| "Replaces ERRORM.") (* |;;| "merged FAULT2 printing in, driven off of extra information on ERRORN - rrb 7/83") (let ((condition (cond ((null u) *last-condition*) ((typep u (quote condition)) u) (t (errm-to-condition (car u) (cadr u)))))) (cond ((and lispxhistory (not (typep condition (quote storage-condition)))) (lispxput (quote *error*) (cl:type-of condition)))) (* "Used to be:" (cond (lispxprintflg (prog ((extrames (caddr u))) (lispxterpri t) (lispxprin1 (errorstring (car u)) t) (lispxterpri t) (lispxprin2 (cadr u) t) (cond ((listp extrames) (* |;;| "in top level unbound atoms this is the litatom NORMAL for which nothing should print.") (lispxprin1 (quote " {in ") t) (lispxprin2 (car extrames) t t) (lispxprin1 (quote "}") t) (cond ((cdr extrames) (lispxprin1 (quote " in ") t) (lispxprin2 (cdr extrames) t t))))) (lispxterpri t))) (t (errorm u)))) (cl:princ condition *error-output*))) ) (errormess1 (lambda (mess1 mess2 mess3) (* \; "Edited 2-Mar-88 16:36 by amd") (* |;;| "Prints messages for help and error") (prog (badguy message) (cond ((and (null mess1) (null mess2)) (print mess3 *standard-output* t) (return))) (prin1 mess1 *standard-output*) (cond ((or (atom mess1) (stringp mess2)) (spaces 1 *standard-output*)) (t (terpri *standard-output*))) (cond ((stringp mess2) (prin1 mess2 *standard-output*) (terpri *standard-output*)) (t (print mess2 *standard-output* t)))))) (smartarglist (lambda (fn explainflg tail) (* \; "Edited 15-Jan-88 18:34 by bvm:") (* |;;| "Provide the argument list for the function named FN. FN may also be a macro, in which case its arg list is fake, but returned anyhow.") (* |;;| "FN can also be the actual (LAMBDA --) form.") (prog (tem def otherdef) (cond ((not (litatom fn)) (* \; "Got a lambda form to return the arglist for") (return (cond ((and explainflg (listp fn) (eq (car fn) (quote cl:lambda))) (* \; "We're in EXPLAIN mode, and it was a common lisp function, so hack up the CL arg list") (\\simplify.cl.arglist (cadr fn))) (t (* \; "Otherwise, just return the conventional arg list") (arglist fn)))))) retry (cond ((setq tem (get fn (quote broken))) (* |;;| "It's a broken function, so get the REAL function's arg list & return it:") (return (smartarglist tem explainflg))) ((setq tem (getlis fn (quote (argnames)))) (* |;;| "gives user an override. Also provides a way of supplying args for nospread fns, whose Interlisp \"arglist\" is uninteresting, or whose Common Lisp arglist would otherwise vanish upon being compiled by the Interlisp compiler. We use GETLIS rather than GET, so that user can force the arglist to appear to be NIL, even if it isn't really.") (* |;;| "Arg names are used for two purposes: explaining, as with ?=, and breaking/advising. For nospread functions, want the latter to be a legitimate arglist. The format used for this is (NIL explainForm . validForm). Note that this alternative form is unambiguous, since NIL can never be an argument name") (return (cond ((or (nlistp (setq tem (cadr tem))) (not (null (car tem)))) tem) (explainflg (cadr tem)) (t (cddr tem))))) ((exprp (setq def (or (get fn (quote advised)) (getd fn) (get fn (quote expr))))) (* \; "Have an interpreted def lying around") (selectq (car (listp def)) ((nlambda lambda) (* \; "Nice Interlisp forms--return args directly") (return (cadr def))) (cl:lambda (* \; "Can handle these if explaining, but first simplify") (cl:when explainflg (return (\\simplify.cl.arglist (cadr def))))) nil)) ((and explainflg (setq otherdef (getdef fn (quote functions) (quote current) (quote (noerror nocopy)))) (selectq (car otherdef) ((defmacro cl:defun) t) ((defdefiner defcommand) (|pop| otherdef)) nil)) (* |;;| "The FN (or macro) has an in-core source definition. Gather the arg list from that, as most authoritative:") (return (\\simplify.cl.arglist (cl:third (remove-comments otherdef)))))) (cond ((and (or def (setq def (get fn (quote code)))) (or (exprp def) (ccodep def))) (* |;;| "The function has a definition in force, or there's a back-up compiled or source definition that's worth consulting.") (cond ((or (not explainflg) (neq (argtype def) 3)) (* \; "If EXPLAINFLG is true and we have an NLAMBDA*, then there might be a macro with a more interesting arg list--hold off.") (return (arglist def explainflg))) ((and (ccodep def) (listp (setq tem (arglist def explainflg)))) (* \; "Had an interesting stored arglist.") (return tem))))) (return (cond ((and explainflg (setq tem (getmacroprop fn compilermacroprops))) (* \; "If we're explaining, then we might be able to get an interesting arg list out of a macro") (selectq (car (listp tem)) ((lambda nlambda openlambda) (* \; "These have conventional args in second position") (cadr tem)) (= (* \; "Get args for synonym") (smartarglist (cdr tem) explainflg)) (cond ((listp (setq tem (car tem))) (* \; "Substitution macro--TEM is now the arg list") (cond ((cdr (last tem)) (* \; "Last element is a tail. Turn (A B . C) into (A B ... C). Following depends on APPEND working this way on improper lists") (append tem (list (quote |...|) (cdr (last tem))))) (t tem))) (def (* \; "No args, or computed macro (either of the form CompilerFN or (args . expansionFn)). Fall back on the definition above") (arglist def explainflg))))) ((and (not def) (setq tem (fncheck fn t nil t tail)) (neq tem fn)) (setq fn tem) (go retry)) (t (arglist fn explainflg)))))) ) (\\simplify.cl.arglist (lambda (lst) (* |lmm| "28-Sep-86 12:07") (|bind| section |for| x |in| lst |collect| (cl:if (listp x) (case section (&optional (car x)) (&key (cond ((listp (car x)) (caar x)) (t (car x)))) (t (* \; " assume destructuring") x)) (case x (&aux (go $$out)) ((&aux &optional &key &body &rest &environment) (setq section x)) (t x))))) ) ) (RPAQ? HELPDEPTH 7) (RPAQ? BREAKDELIMITER " ") (RPAQ? HELPTIME 1000) (RPAQ? HELPCLOCK ) (RPAQ? NLSETQGAG T) (RPAQ? *MACROEXPAND-HOOK* 'CL:FUNCALL) (RPAQ? COMPILERMACROPROPS '(DMACRO ALTOMACRO BYTEMACRO MACRO)) (* |;;| "for backward compatibility. Used currently by window mouse handler") (RPAQQ NBREAKS 0) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ERRORX) ) (PRETTYCOMPRINT IL-ERROR-STUFFCOMS) (RPAQQ IL-ERROR-STUFFCOMS ((FNS HELP SHOULDNT ERROR ERRORX INTERRUPT FAULTEVAL FAULTAPPLY OLDFAULT1 ERRORMESS ERRORMESS1 SMARTARGLIST \\SIMPLIFY.CL.ARGLIST) (INITVARS (HELPDEPTH 7) (BREAKDELIMITER " ") (HELPTIME 1000) (HELPCLOCK) (NLSETQGAG T) (*MACROEXPAND-HOOK* 'CL:FUNCALL) (COMPILERMACROPROPS '(DMACRO ALTOMACRO BYTEMACRO MACRO))) (* |;;| "for backward compatibility. Used currently by window mouse handler") (VARS (NBREAKS 0)) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA))))) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS IL-ERROR-STUFF COPYRIGHT ("Venue & Xerox Corporation" 1987 1988 1990)) (DECLARE\: DONTCOPY (FILEMAP (NIL (1303 11373 (HELP 1313 . 1664) (SHOULDNT 1666 . 1768) (ERROR 1770 . 2236) (ERRORX 2238 . 2738) (INTERRUPT 2740 . 2889) (FAULTEVAL 2891 . 3652) (FAULTAPPLY 3654 . 4854) (OLDFAULT1 4856 . 5286) (ERRORMESS 5288 . 6261) (ERRORMESS1 6263 . 7037) (SMARTARGLIST 7039 . 11012) ( \\SIMPLIFY.CL.ARGLIST 11014 . 11371))))) STOP