;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*- (in-package "CONDITIONS") (defvar *internal-error-table* (make-hash-table :test 'equal)) (defmacro find-internal-error-data (error-name error-format-string) `(gethash (list ,error-name ,error-format-string) *internal-error-table*)) (defun clcs-universal-error-handler (error-name correctable function-name continue-format-string error-format-string &rest args) (if correctable (with-simple-restart (continue "~a" (apply #'format nil continue-format-string args)) (error 'internal-simple-error :function-name function-name :format-string error-format-string :format-arguments args)) (let ((e-d (find-internal-error-data error-name error-format-string))) (print e-d) (if e-d (let ((condition-name (car e-d))) (apply #'error condition-name :function-name function-name (let ((k-a (mapcan #'list (cdr e-d) args))) (if (simple-condition-class-p condition-name) (list* :format-string error-format-string :format-arguments args k-a) k-a)))) (error 'internal-simple-error :function-name function-name :format-string error-format-string :format-arguments args))))) (defun set-internal-error (error-keyword error-format condition-name &rest keyword-list) (setf (find-internal-error-data error-keyword error-format) (cons condition-name keyword-list))) (defun initialize-internal-error-table () (declare (special *internal-error-list*)) (clrhash *internal-error-table*) (dolist (error-data *internal-error-list*) (apply #'set-internal-error (cdr error-data)))) (defparameter *internal-error-list* '(("FEwrong_type_argument" :wrong-type-argument "~S is not of type ~S." internal-type-error :datum :expected-type) ("FEtoo_few_arguments" :too-few-arguments "~S [or a callee] requires more than ~R argument~:p." internal-simple-control-error) ; || |top - base| ("FEtoo_few_argumentsF" :too-few-arguments "Too few arguments." internal-simple-control-error) ; || |args| ("FEtoo_many_arguments" :too-many-arguments "~S [or a callee] requires less than ~R argument~:p." internal-simple-control-error) ; || |top - base| ("FEtoo_many_argumentsF" :too-many-arguments "Too many arguments." internal-simple-control-error) ; || |args| ("FEinvalid_macro_call" :invalid-form "Invalid macro call to ~S." internal-simple-program-error) ; || ("FEunexpected_keyword" :unexpected-keyword "~S does not allow the keyword ~S." internal-simple-control-error) ; || |key| ("FEunbound_variable" :unbound-variable "The variable ~S is unbound." internal-unbound-variable :name) ; |sym| ("FEundefined_function" :undefined-function "The function ~S is undefined." internal-undefined-function :name) ("FEinvalid_function" :invalid-function "~S is invalid as a function." internal-simple-program-error) ; |obj| ("check_arg_failed" :too-few-arguments "~S [or a callee] requires ~R argument~:p,~%\ but only ~R ~:*~[were~;was~:;were~] supplied." internal-simple-control-error) ; || |n| |top - base| ("check_arg_failed" :too-many-arguments "~S [or a callee] requires only ~R argument~:p,~%\ but ~R ~:*~[were~;was~:;were~] supplied." internal-simple-control-error) ; || |n| |top - base| ("ck_larg_at_least" :error "APPLY sended too few arguments to LAMBDA." internal-simple-control-error) ("ck_larg_exactly" :error "APPLY sended too few arguments to LAMBDA." internal-simple-control-error) ("keyword_value_mismatch" :error "Keywords and values do not match." internal-simple-error) ;?? ("not_a_keyword" :error "~S is not a keyword." internal-simple-error) ;?? ("illegal_declare" :invalid-form "~S is an illegal declaration form." internal-simple-program-error) ("not_a_symbol" :invalid-variable "~S is not a symbol." internal-simple-error) ;?? ("not_a_variable" :invalid-variable "~S is not a variable." internal-simple-program-error) ("illegal_index" :error "~S is an illegal index to ~S." internal-simple-error) ("vfun_wrong_number_of_args" :error "Expected ~S args but received ~S args" internal-simple-control-error) ("end_of_stream" :error "Unexpected end of ~S." internal-end-of-file :stream) ("open_stream" :error "~S is an illegal IF-DOES-NOT-EXIST option." internal-simple-control-error) ("open_stream" :error "The file ~A already exists." internal-simple-file-error :pathname) ("open_stream" :error "Cannot append to the file ~A." internal-simple-file-error :pathname) ("open_stream" :error "~S is an illegal IF-EXISTS option." internal-simple-control-error) ("close_stream" :error "Cannot close the standard output." internal-simple-stream-error) ; no stream here!! ("close_stream" :error "Cannot close the standard input." internal-simple-stream-error) ; no stream here!! ("too_long_file_name" :error "~S is a too long file name." internal-simple-file-error :pathname) ("cannot_open" :error "Cannot open the file ~A." internal-simple-file-error :pathname) ("cannot_create" :error "Cannot create the file ~A." internal-simple-file-error :pathname) ("cannot_read" :error "Cannot read the stream ~S." internal-simple-stream-error :stream) ("cannot_write" :error "Cannot write to the stream ~S." internal-simple-stream-error :stream) )) (initialize-internal-error-table) (defun condition-backtrace (condition) (let* ((*debug-io* *error-output*) (si::*ihs-base* (1+ si::*ihs-top*)) (si::*ihs-top* (1- (si::ihs-top))) (si::*current-ihs* si::*ihs-top*) (si::*frs-base* (or (si::sch-frs-base si::*frs-top* si::*ihs-base*) (1+ (si::frs-top)))) (si::*frs-top* (si::frs-top)) (si::*break-env* nil)) (format *error-output* "~%~A~%" condition) (si::simple-backtrace))) (defvar *error-set-break-p* nil) (defun clcs-error-set (form) (let ((cond nil)) (restart-case (handler-bind ((error #'(lambda (condition) (unless (or si::*break-enable* *error-set-break-p*) (condition-backtrace condition) (return-from clcs-error-set condition)) (setq cond condition) nil))) (values-list (cons nil (multiple-value-list (eval form))))) (si::error-set () :report (lambda (stream) (format stream "~S" `(si::error-set ',form))) cond)))) (eval-when (compile load eval) (defun reset-function (symbol) ; invoke compiler::compiler-clear-compiler-properties (setf (symbol-function symbol) (symbol-function symbol))) (reset-function 'si::error-set) (reset-function 'load) (reset-function 'open) ) (setq compiler::*compiler-break-enable* t) (defun compiler::cmp-toplevel-eval (form) (let* (;;(si::*ihs-base* si::*ihs-top*) ; show the whole stack (si::*ihs-top* (1- (si::ihs-top))) (*break-enable* compiler::*compiler-break-enable*) (si::*break-hidden-packages* (cons (find-package 'compiler) si::*break-hidden-packages*))) (si:error-set form)))