source: trunk/source/level-1/l1-error-signal.lisp

Last change on this file was 16685, checked in by rme, 4 years ago

Update copyright/license headers in files.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 7.1 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;; Copyright 1994-2009 Clozure Associates
4;;;
5;;; Licensed under the Apache License, Version 2.0 (the "License");
6;;; you may not use this file except in compliance with the License.
7;;; You may obtain a copy of the License at
8;;;
9;;;     http://www.apache.org/licenses/LICENSE-2.0
10;;;
11;;; Unless required by applicable law or agreed to in writing, software
12;;; distributed under the License is distributed on an "AS IS" BASIS,
13;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
14;;; See the License for the specific language governing permissions and
15;;; limitations under the License.
16
17(in-package "CCL")
18
19(defun %kernel-restart (error-type &rest args)
20  (%kernel-restart-internal error-type args (%get-frame-ptr)))
21
22(defun %kernel-restart-internal (error-type args frame-ptr)
23  ;(declare (dynamic-extent args))
24  (dolist (f *kernel-restarts* (%err-disp-internal error-type args frame-ptr))
25    (when (eq (car f) error-type)
26      (return (apply (cdr f) frame-ptr args)))))
27
28;;; this is the def of %err-disp.
29;;; Yup.  That was my first guess.
30(defun %err-disp (err-num &rest errargs)
31  (%err-disp-internal err-num errargs (%get-frame-ptr)))
32
33(defun %errno-disp (errno &rest errargs)
34  (%errno-disp-internal errno errargs (%get-frame-ptr)))
35
36#+windows-target
37(defun %windows-error-disp (errno &rest errargs)
38  (%err-disp-common errno 0 (%windows-error-string errno) errargs (%get-frame-ptr)))
39 
40(defun %errno-disp-internal (errno errargs frame-ptr)
41  (declare (fixnum errno))
42  (let* ((err-type (max (ash errno -16) 0))
43         (errno (%word-to-int errno))
44         (error-string (%strerror errno))
45         (format-string (if errargs
46                          (format nil "~a : ~a" error-string "~s")
47                          error-string)))
48    (%err-disp-common nil err-type  format-string errargs frame-ptr)))
49
50
51(defun %err-disp-internal (err-num errargs frame-ptr)
52  (declare (fixnum err-num))
53  ;;; The compiler (finally !) won't tail-apply error.  But we kind of
54  ;;; expect it to ...
55  (if (eql err-num $XARRLIMIT)
56    (%error (make-condition 'vector-size-limitation
57                            :subtag (cadr errargs)
58                            :element-count (car errargs))
59            nil
60            frame-ptr)
61    (let* ((err-typ (max (ash err-num -16) 0))
62           (err-num (%word-to-int err-num))
63           (format-string (%rsc-string err-num)))
64      (%err-disp-common err-num err-typ format-string errargs frame-ptr))))
65
66(defparameter *foreign-error-condition-recognizers* ())
67
68
69(defun %err-disp-common (err-num err-typ format-string errargs frame-ptr)
70  (let* ((condition-name (or (uvref *simple-error-types* err-typ)
71                             (%cdr (assq err-num *kernel-simple-error-classes*)))))
72    ;;(dbg format-string)
73    (if condition-name     
74      (funcall '%error
75               (case condition-name
76                 (type-error
77                  (if (cdr errargs)
78                    (make-condition condition-name
79                                             :format-control format-string
80                                             :datum (car errargs)
81                                             :expected-type (%type-error-type (cadr errargs)))
82                    (make-condition condition-name
83                                             :format-control format-string
84                                             :datum (car errargs))))
85                 (improper-list (make-condition condition-name
86                                                :datum (car errargs)))
87                 (simple-file-error (make-condition condition-name
88                                             :pathname (car errargs)
89                                             :error-type format-string
90                                             :format-arguments (cdr errargs)))
91                 (undefined-function (make-condition condition-name
92                                                     :name (car errargs)))
93                 (call-special-operator-or-macro
94                  (make-condition condition-name
95                                  :name (car errargs)
96                                  :function-arguments (cadr errargs)))
97                 (sequence-index-type-error
98                  (make-sequence-index-type-error (car errargs) (cadr errargs)))
99                 (cant-construct-arglist
100                  (make-condition condition-name
101                                  :datum (car errargs)
102                                  :format-control format-string))
103                 (array-element-type-error
104                  (let* ((array (cadr errargs)))
105                    (make-condition condition-name
106                                    :format-control format-string
107                                    :datum (car errargs)
108                                    :expected-type (array-element-type array)
109                                    :array array)))
110                 (division-by-zero (make-condition condition-name
111                                                   :operation '/
112                                                   :operands (if errargs
113                                                               (list (car errargs)
114                                                                     0)
115                                                               (list 0))))
116                 (t (make-condition condition-name 
117                                    :format-control format-string
118                                    :format-arguments errargs)))
119               nil
120               frame-ptr)
121      (let* ((cond nil))
122        (if (and (eql err-num $XFOREIGNEXCEPTION)
123                 (dolist (recog *foreign-error-condition-recognizers*)
124                   (let* ((c (funcall recog (car errargs))))
125                     (when c (return (setq cond c))))))
126          (funcall '%error cond nil frame-ptr)
127          (funcall '%error format-string errargs frame-ptr))))))
128
129(defun error (condition &rest args)
130  "Invoke the signal facility on a condition formed from DATUM and ARGUMENTS.
131  If the condition is not handled, the debugger is invoked."
132  (%error condition args (%get-frame-ptr)))
133
134(defun cerror (cont-string condition &rest args)
135  (let* ((fp (%get-frame-ptr)))
136    (restart-case (%error condition (if (condition-p condition) nil args) fp)
137      (continue ()
138                :report (lambda (stream) 
139                            (apply #'format stream cont-string args))
140                nil))))
141
142(defun %error (condition args error-pointer)
143  (setq *error-reentry-count* 0)
144  (setq condition (condition-arg condition args 'simple-error))
145  (signal condition)
146  (unless *interactive-streams-initialized*
147    (bug (format nil "Error during early application initialization:~%
148~a" condition))
149    (#_exit #-windows-target #-android-target #$EX_SOFTWARE #+android-target 70 #+windows-target #$EXIT_FAILURE))
150  (application-error *application* condition error-pointer)
151  (application-error
152   *application*
153   (condition-arg "~s returned. It shouldn't.~%If it returns again, I'll throw to toplevel."
154                  '(application-error) 'simple-error)
155   error-pointer)
156  (toplevel))
157
158(defun make-sequence-index-type-error (idx sequence)
159  (let* ((upper (length sequence)))
160    (make-condition 'sequence-index-type-error
161                    :datum idx
162                    :sequence sequence
163                    :expected-type `(integer 0 (,upper)))))
Note: See TracBrowser for help on using the repository browser.