/[cmucl]/src/code/lispinit.lisp
ViewVC logotype

Diff of /src/code/lispinit.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.38 by ram, Thu Aug 19 12:46:05 1993 UTC revision 1.39 by ram, Thu Aug 19 17:15:40 1993 UTC
# Line 72  Line 72 
72  ); #-gengc progn  ); #-gengc progn
73    
74    
75    ;;;; Random stuff that needs to be in the cold load which would otherwise be
76    ;;;; byte-compiled.
77    ;;;;
78    (defvar hi::*in-the-editor* nil)
79    
80    ;;;; Called by defmacro expanders...
81    
82    ;;; VERIFY-KEYWORDS -- internal
83    ;;;
84    ;;; Determine if key-list is a valid list of keyword/value pairs.  Do not
85    ;;; signal the error directly, 'cause we don't know how it should be signaled.
86    ;;;
87    (defun verify-keywords (key-list valid-keys allow-other-keys)
88      (do ((already-processed nil)
89           (unknown-keyword nil)
90           (remaining key-list (cddr remaining)))
91          ((null remaining)
92           (if (and unknown-keyword
93                    (not allow-other-keys)
94                    (not (lookup-keyword :allow-other-keys key-list)))
95               (values :unknown-keyword (list unknown-keyword valid-keys))
96               (values nil nil)))
97        (cond ((not (and (consp remaining) (listp (cdr remaining))))
98               (return (values :dotted-list key-list)))
99              ((null (cdr remaining))
100               (return (values :odd-length key-list)))
101              ((member (car remaining) already-processed)
102               (return (values :duplicate (car remaining))))
103              ((or (eq (car remaining) :allow-other-keys)
104                   (member (car remaining) valid-keys))
105               (push (car remaining) already-processed))
106              (t
107               (setf unknown-keyword (car remaining))))))
108    
109    (defun lookup-keyword (keyword key-list)
110      (do ((remaining key-list (cddr remaining)))
111          ((endp remaining))
112        (when (eq keyword (car remaining))
113          (return (cadr remaining)))))
114    ;;;
115    (defun keyword-supplied-p (keyword key-list)
116      (do ((remaining key-list (cddr remaining)))
117          ((endp remaining))
118        (when (eq keyword (car remaining))
119          (return t))))
120    
121    (in-package "CONDTIIONS")
122    
123    (defvar *break-on-signals* nil
124      "When (typep condition *break-on-signals*) is true, then calls to SIGNAL will
125       enter the debugger prior to signalling that condition.")
126    
127    (defun signal (datum &rest arguments)
128      "Invokes the signal facility on a condition formed from datum and arguments.
129       If the condition is not handled, nil is returned.  If
130       (TYPEP condition *BREAK-ON-SIGNALS*) is true, the debugger is invoked before
131       any signalling is done."
132      (let ((condition (coerce-to-condition datum arguments
133                                            'simple-condition 'signal))
134            (*handler-clusters* *handler-clusters*))
135        (when (typep condition *break-on-signals*)
136          (let ((*break-on-signals* nil))
137            (break "~A~%Break entered because of *break-on-signals* (now NIL.)"
138                   condition)))
139        (loop
140          (unless *handler-clusters* (return))
141          (let ((cluster (pop *handler-clusters*)))
142            (dolist (handler cluster)
143              (when (typep condition (car handler))
144                (funcall (cdr handler) condition)))))
145        nil))
146    
147    ;;; COERCE-TO-CONDITION is used in SIGNAL, ERROR, CERROR, WARN, and
148    ;;; INVOKE-DEBUGGER for parsing the hairy argument conventions into a single
149    ;;; argument that's directly usable by all the other routines.
150    ;;;
151    (defun coerce-to-condition (datum arguments default-type function-name)
152      (cond ((typep datum 'condition)
153             (if arguments
154                 (cerror "Ignore the additional arguments."
155                         'simple-type-error
156                         :datum arguments
157                         :expected-type 'null
158                         :format-control "You may not supply additional arguments ~
159                                         when giving ~S to ~S."
160                         :format-arguments (list datum function-name)))
161             datum)
162            ((symbolp datum) ;Roughly, (subtypep datum 'condition).
163             (apply #'make-condition datum arguments))
164            ((or (stringp datum) (functionp datum))
165             (make-condition default-type
166                             :format-control datum
167                             :format-arguments arguments))
168            (t
169             (error 'simple-type-error
170                    :datum datum
171                    :expected-type '(or symbol string)
172                    :format-control "Bad argument to ~S: ~S"
173                    :format-arguments (list function-name datum)))))
174    
175    (defun error (datum &rest arguments)
176      "Invokes the signal facility on a condition formed from datum and arguments.
177       If the condition is not handled, the debugger is invoked."
178      (kernel:infinite-error-protect
179        (let ((condition (coerce-to-condition datum arguments
180                                              'simple-error 'error))
181              (debug:*stack-top-hint* debug:*stack-top-hint*))
182          (unless (and (error-function-name condition) debug:*stack-top-hint*)
183            (multiple-value-bind
184                (name frame)
185                (kernel:find-caller-name)
186              (unless (error-function-name condition)
187                (setf (error-function-name condition) name))
188              (unless debug:*stack-top-hint*
189                (setf debug:*stack-top-hint* frame))))
190          (let ((debug:*stack-top-hint* nil))
191            (signal condition))
192          (invoke-debugger condition))))
193    
194    ;;; CERROR must take care to not use arguments when datum is already a
195    ;;; condition object.
196    ;;;
197    (defun cerror (continue-string datum &rest arguments)
198      (kernel:infinite-error-protect
199        (with-simple-restart
200            (continue "~A" (apply #'format nil continue-string arguments))
201          (let ((condition (if (typep datum 'condition)
202                               datum
203                               (coerce-to-condition datum arguments
204                                                    'simple-error 'error)))
205                (debug:*stack-top-hint* debug:*stack-top-hint*))
206            (unless (and (error-function-name condition) debug:*stack-top-hint*)
207              (multiple-value-bind
208                  (name frame)
209                  (kernel:find-caller-name)
210                (unless (error-function-name condition)
211                  (setf (error-function-name condition) name))
212                (unless debug:*stack-top-hint*
213                  (setf debug:*stack-top-hint* frame))))
214            (with-condition-restarts condition (list (find-restart 'continue))
215              (let ((debug:*stack-top-hint* nil))
216                (signal condition))
217              (invoke-debugger condition)))))
218      nil)
219    
220    (defun break (&optional (datum "Break") &rest arguments)
221      "Prints a message and invokes the debugger without allowing any possibility
222       of condition handling occurring."
223      (kernel:infinite-error-protect
224        (with-simple-restart (continue "Return from BREAK.")
225          (let ((debug:*stack-top-hint*
226                 (or debug:*stack-top-hint*
227                     (nth-value 1 (kernel:find-caller-name)))))
228            (invoke-debugger
229             (coerce-to-condition datum arguments 'simple-condition 'break)))))
230      nil)
231    
232    (defun warn (datum &rest arguments)
233      "Warns about a situation by signalling a condition formed by datum and
234       arguments.  While the condition is being signaled, a muffle-warning restart
235       exists that causes WARN to immediately return nil."
236      (kernel:infinite-error-protect
237        (let ((condition (coerce-to-condition datum arguments
238                                              'simple-warning 'warn)))
239          (check-type condition warning "a warning condition")
240          (restart-case (signal condition)
241            (muffle-warning ()
242              :report "Skip warning."
243              (return-from warn nil)))
244          (format *error-output* "~&~@<Warning:  ~3i~:_~A~:>~%" condition)))
245      nil)
246    
247    (in-package "LISP")
248    
249    
250  ;;; %Initial-Function is called when a cold system starts up.  First we zoom  ;;; %Initial-Function is called when a cold system starts up.  First we zoom
251  ;;; down the *Lisp-Initialization-Functions* doing things that wanted to happen  ;;; down the *Lisp-Initialization-Functions* doing things that wanted to happen
252  ;;; at "load time."  Then we initialize the various subsystems and call the  ;;; at "load time."  Then we initialize the various subsystems and call the
# Line 89  Line 264 
264         (%primitive print ,(symbol-name name))         (%primitive print ,(symbol-name name))
265         (,name))))         (,name))))
266    
 (defvar hi::*in-the-editor* nil)  
   
267  (defun %initial-function ()  (defun %initial-function ()
268    "Gives the world a shove and hopes it spins."    "Gives the world a shove and hopes it spins."
269    (%primitive print "In initial-function, and running.")    (%primitive print "In initial-function, and running.")

Legend:
Removed from v.1.38  
changed lines
  Added in v.1.39

  ViewVC Help
Powered by ViewVC 1.1.5