source: release/1.9/source/level-1/l1-error-signal.lisp @ 15706

Last change on this file since 15706 was 15706, checked in by gb, 6 years ago

Propagate recent trunk changes.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 7.2 KB
RevLine 
[6]1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
[13067]3;;;   Copyright (C) 2009 Clozure Associates
[6]4;;;   Copyright (C) 1994-2001 Digitool, Inc
[13066]5;;;   This file is part of Clozure CL. 
[6]6;;;
[13066]7;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
8;;;   License , known as the LLGPL and distributed with Clozure CL as the
[6]9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
[13066]10;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
[6]11;;;   conflict, the preamble takes precedence. 
12;;;
[13066]13;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
[6]14;;;
15;;;   The LLGPL is also available online at
16;;;   http://opensource.franz.com/preamble.html
17
[2326]18(in-package "CCL")
[6]19
20(defun %kernel-restart (error-type &rest args)
21  (%kernel-restart-internal error-type args (%get-frame-ptr)))
22
23(defun %kernel-restart-internal (error-type args frame-ptr)
24  ;(declare (dynamic-extent args))
25  (dolist (f *kernel-restarts* (%err-disp-internal error-type args frame-ptr))
26    (when (eq (car f) error-type)
27      (return (apply (cdr f) frame-ptr args)))))
28
[1971]29;;; this is the def of %err-disp.
30;;; Yup.  That was my first guess.
[6]31(defun %err-disp (err-num &rest errargs)
32  (%err-disp-internal err-num errargs (%get-frame-ptr)))
33
34(defun %errno-disp (errno &rest errargs)
35  (%errno-disp-internal errno errargs (%get-frame-ptr)))
36
[10875]37#+windows-target
38(defun %windows-error-disp (errno &rest errargs)
39  (%err-disp-common errno 0 (%windows-error-string errno) errargs (%get-frame-ptr)))
40 
[6]41(defun %errno-disp-internal (errno errargs frame-ptr)
42  (declare (fixnum errno))
43  (let* ((err-type (max (ash errno -16) 0))
44         (errno (%word-to-int errno))
45         (error-string (%strerror errno))
46         (format-string (if errargs
47                          (format nil "~a : ~a" error-string "~s")
48                          error-string)))
49    (%err-disp-common nil err-type  format-string errargs frame-ptr)))
50
51
52(defun %err-disp-internal (err-num errargs frame-ptr)
53  (declare (fixnum err-num))
[4183]54  ;;; The compiler (finally !) won't tail-apply error.  But we kind of
55  ;;; expect it to ...
[15706]56  (if (eql err-num $XARRLIMIT)
57    (%error (make-condition 'vector-size-limitation
58                            :subtag (cadr errargs)
59                            :element-count (car errargs))
60            nil
61            frame-ptr)
62    (let* ((err-typ (max (ash err-num -16) 0))
63           (err-num (%word-to-int err-num))
64           (format-string (%rsc-string err-num)))
65      (%err-disp-common err-num err-typ format-string errargs frame-ptr))))
[6]66
[6936]67(defparameter *foreign-error-condition-recognizers* ())
68
69
[6]70(defun %err-disp-common (err-num err-typ format-string errargs frame-ptr)
71  (let* ((condition-name (or (uvref *simple-error-types* err-typ)
72                             (%cdr (assq err-num *kernel-simple-error-classes*)))))
[4183]73    ;;(dbg format-string)
[6]74    (if condition-name     
75      (funcall '%error
76               (case condition-name
[1890]77                 (type-error
78                  (if (cdr errargs)
79                    (make-condition condition-name
[6]80                                             :format-control format-string
81                                             :datum (car errargs)
[1890]82                                             :expected-type (%type-error-type (cadr errargs)))
83                    (make-condition condition-name
84                                             :format-control format-string
85                                             :datum (car errargs))))
[243]86                 (improper-list (make-condition condition-name
87                                                :datum (car errargs)))
[6]88                 (simple-file-error (make-condition condition-name
89                                             :pathname (car errargs)
90                                             :error-type format-string
91                                             :format-arguments (cdr errargs)))
92                 (undefined-function (make-condition condition-name
93                                                     :name (car errargs)))
94                 (call-special-operator-or-macro
95                  (make-condition condition-name
[282]96                                  :name (car errargs)
[6]97                                  :function-arguments (cadr errargs)))
98                 (sequence-index-type-error
99                  (make-sequence-index-type-error (car errargs) (cadr errargs)))
[332]100                 (cant-construct-arglist
101                  (make-condition condition-name
102                                  :datum (car errargs)
103                                  :format-control format-string))
[11491]104                 (array-element-type-error
105                  (let* ((array (cadr errargs)))
106                    (make-condition condition-name
107                                    :format-control format-string
108                                    :datum (car errargs)
109                                    :expected-type (array-element-type array)
110                                    :array array)))
[14844]111                 (division-by-zero (make-condition condition-name
112                                                   :operation '/
113                                                   :operands (if errargs
114                                                               (list (car errargs)
115                                                                     0)
116                                                               (list 0))))
[6]117                 (t (make-condition condition-name 
118                                    :format-control format-string
119                                    :format-arguments errargs)))
120               nil
121               frame-ptr)
[6936]122      (let* ((cond nil))
123        (if (and (eql err-num $XFOREIGNEXCEPTION)
124                 (dolist (recog *foreign-error-condition-recognizers*)
125                   (let* ((c (funcall recog (car errargs))))
126                     (when c (return (setq cond c))))))
127          (funcall '%error cond nil frame-ptr)
128          (funcall '%error format-string errargs frame-ptr))))))
[6]129
130(defun error (condition &rest args)
[929]131  "Invoke the signal facility on a condition formed from DATUM and ARGUMENTS.
132  If the condition is not handled, the debugger is invoked."
[6]133  (%error condition args (%get-frame-ptr)))
134
135(defun cerror (cont-string condition &rest args)
136  (let* ((fp (%get-frame-ptr)))
137    (restart-case (%error condition (if (condition-p condition) nil args) fp)
138      (continue ()
139                :report (lambda (stream) 
140                            (apply #'format stream cont-string args))
141                nil))))
142
143(defun %error (condition args error-pointer)
[8384]144  (setq *error-reentry-count* 0)
[6]145  (setq condition (condition-arg condition args 'simple-error))
146  (signal condition)
[5315]147  (unless *interactive-streams-initialized*
148    (bug (format nil "Error during early application initialization:~%
149~a" condition))
[14510]150    (#_exit #-windows-target #-android-target #$EX_SOFTWARE #+android-target 70 #+windows-target #$EXIT_FAILURE))
[6]151  (application-error *application* condition error-pointer)
152  (application-error
153   *application*
154   (condition-arg "~s returned. It shouldn't.~%If it returns again, I'll throw to toplevel."
155                  '(application-error) 'simple-error)
156   error-pointer)
157  (toplevel))
158
159(defun make-sequence-index-type-error (idx sequence)
160  (let* ((upper (length sequence)))
161    (make-condition 'sequence-index-type-error
162                    :datum idx
163                    :sequence sequence
164                    :expected-type `(integer 0 (,upper)))))
Note: See TracBrowser for help on using the repository browser.