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

Last change on this file since 929 was 929, checked in by bryan, 15 years ago

add docstrings to the majority of common-lisp-user symbols starting
with a snapshot of those found in SBCL 0.8.18.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 5.1 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17
18
19
20
21
22(defun %kernel-restart (error-type &rest args)
23  (%kernel-restart-internal error-type args (%get-frame-ptr)))
24
25(defun %kernel-restart-internal (error-type args frame-ptr)
26  ;(declare (dynamic-extent args))
27  (dolist (f *kernel-restarts* (%err-disp-internal error-type args frame-ptr))
28    (when (eq (car f) error-type)
29      (return (apply (cdr f) frame-ptr args)))))
30
31; this is the def of %err-disp.
32; Yup.  That was my first guess.
33(defun %err-disp (err-num &rest errargs)
34  (%err-disp-internal err-num errargs (%get-frame-ptr)))
35
36(defun %errno-disp (errno &rest errargs)
37  (%errno-disp-internal errno errargs (%get-frame-ptr)))
38
39(defun %errno-disp-internal (errno errargs frame-ptr)
40  (declare (fixnum errno))
41  (let* ((err-type (max (ash errno -16) 0))
42         (errno (%word-to-int errno))
43         (error-string (%strerror errno))
44         (format-string (if errargs
45                          (format nil "~a : ~a" error-string "~s")
46                          error-string)))
47    (%err-disp-common nil err-type  format-string errargs frame-ptr)))
48
49
50(defun %err-disp-internal (err-num errargs frame-ptr)
51  (declare (fixnum err-num))
52  ; The compiler (finally !) won't tail-apply error.  But we kind of
53  ; expect it to ...
54  (let* ((err-typ (max (ash err-num -16) 0))
55         (err-num (%word-to-int err-num))
56         (format-string (%rsc-string err-num)))
57    (%err-disp-common err-num err-typ format-string errargs frame-ptr)))
58
59(defun %err-disp-common (err-num err-typ format-string errargs frame-ptr)
60  (let* ((condition-name (or (uvref *simple-error-types* err-typ)
61                             (%cdr (assq err-num *kernel-simple-error-classes*)))))
62    ;(dbg format-string)
63    (if condition-name     
64      (funcall '%error
65               (case condition-name
66                 (type-error (make-condition condition-name
67                                             :format-control format-string
68                                             :datum (car errargs)
69                                             :expected-type (%type-error-type (cadr errargs))))
70                 (improper-list (make-condition condition-name
71                                                :datum (car errargs)))
72                 (simple-file-error (make-condition condition-name
73                                             :pathname (car errargs)
74                                             :error-type format-string
75                                             :format-arguments (cdr errargs)))
76                 (undefined-function (make-condition condition-name
77                                                     :name (car errargs)))
78                 (call-special-operator-or-macro
79                  (make-condition condition-name
80                                  :name (car errargs)
81                                  :function-arguments (cadr errargs)))
82                 (sequence-index-type-error
83                  (make-sequence-index-type-error (car errargs) (cadr errargs)))
84                 (cant-construct-arglist
85                  (make-condition condition-name
86                                  :datum (car errargs)
87                                  :format-control format-string))
88                                 
89                 (t (make-condition condition-name 
90                                    :format-control format-string
91                                    :format-arguments errargs)))
92               nil
93               frame-ptr)
94      (funcall '%error format-string errargs frame-ptr))))
95
96(defun error (condition &rest args)
97  "Invoke the signal facility on a condition formed from DATUM and ARGUMENTS.
98  If the condition is not handled, the debugger is invoked."
99  #|
100  #+ppc-target
101  (with-pstrs ((pstr (if (stringp condition) condition "Error")))
102    (#_DebugStr pstr))
103  |#
104  (%error condition args (%get-frame-ptr)))
105
106(defun cerror (cont-string condition &rest args)
107  (let* ((fp (%get-frame-ptr)))
108    (restart-case (%error condition (if (condition-p condition) nil args) fp)
109      (continue ()
110                :report (lambda (stream) 
111                            (apply #'format stream cont-string args))
112                nil))))
113
114(defun %error (condition args error-pointer)
115  (setq condition (condition-arg condition args 'simple-error))
116  (signal condition)
117  (application-error *application* condition error-pointer)
118  (application-error
119   *application*
120   (condition-arg "~s returned. It shouldn't.~%If it returns again, I'll throw to toplevel."
121                  '(application-error) 'simple-error)
122   error-pointer)
123  (toplevel))
124
125(defun make-sequence-index-type-error (idx sequence)
126  (let* ((upper (length sequence)))
127    (make-condition 'sequence-index-type-error
128                    :datum idx
129                    :sequence sequence
130                    :expected-type `(integer 0 (,upper)))))
Note: See TracBrowser for help on using the repository browser.