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 | (in-package "CCL") |
---|
18 | |
---|
19 | ;L1-readloop.lisp |
---|
20 | |
---|
21 | |
---|
22 | (defvar *break-on-signals* nil |
---|
23 | "When (TYPEP condition *BREAK-ON-SIGNALS*) is true, then calls to SIGNAL will |
---|
24 | enter the debugger prior to signalling that condition.") |
---|
25 | (defvar *break-on-warnings* nil) |
---|
26 | (defvar *break-on-errors* t "Not CL.") |
---|
27 | (defvar *debugger-hook* nil |
---|
28 | "This is either NIL or a function of two arguments, a condition and the value |
---|
29 | of *DEBUGGER-HOOK*. This function can either handle the condition or return |
---|
30 | which causes the standard debugger to execute. The system passes the value |
---|
31 | of this variable to the function because it binds *DEBUGGER-HOOK* to NIL |
---|
32 | around the invocation.") |
---|
33 | (defvar *backtrace-on-break* nil) |
---|
34 | (defvar *** nil |
---|
35 | "the previous value of **") |
---|
36 | (defvar ** nil |
---|
37 | "the previous value of *") |
---|
38 | (defvar * nil |
---|
39 | "the value of the most recent top level EVAL") |
---|
40 | (defvar /// nil |
---|
41 | "the previous value of //") |
---|
42 | (defvar // nil |
---|
43 | "the previous value of /") |
---|
44 | (defvar / nil |
---|
45 | "a list of all the values returned by the most recent top level EVAL") |
---|
46 | (defvar +++ nil |
---|
47 | "the previous value of ++") |
---|
48 | (defvar ++ nil |
---|
49 | "the previous value of +") |
---|
50 | (defvar + nil |
---|
51 | "the value of the most recent top level READ") |
---|
52 | (defvar - nil |
---|
53 | "the form currently being evaluated") |
---|
54 | |
---|
55 | (defvar *continuablep* nil) |
---|
56 | (defvar *in-read-loop* nil |
---|
57 | "Is T if waiting for input in the read loop") |
---|
58 | |
---|
59 | |
---|
60 | (defvar *did-startup* nil) |
---|
61 | |
---|
62 | |
---|
63 | |
---|
64 | (defmacro catch-cancel (&body body) |
---|
65 | `(catch :cancel ,@body)) |
---|
66 | |
---|
67 | (defmacro throw-cancel (&optional value) |
---|
68 | `(throw :cancel ,value)) |
---|
69 | |
---|
70 | ;;; Throwing like this works in listeners and in the initial process. |
---|
71 | ;;; Can't easily tell if a process is a listener. Should be able to. |
---|
72 | (defun toplevel () |
---|
73 | (throw :toplevel nil)) |
---|
74 | |
---|
75 | |
---|
76 | ;;; It's not clear that this is the right behavior, but aborting CURRENT-PROCESS - |
---|
77 | ;;; when no one's sure just what CURRENT-PROCESS is - doesn't seem right either. |
---|
78 | (defun interactive-abort () |
---|
79 | (interactive-abort-in-process *current-process*)) |
---|
80 | |
---|
81 | (defun interactive-abort-in-process (p) |
---|
82 | (if p (process-interrupt p |
---|
83 | #'(lambda () |
---|
84 | (unless *inhibit-abort* |
---|
85 | (if *in-read-loop* |
---|
86 | (abort-break) |
---|
87 | (abort)) |
---|
88 | ))))) |
---|
89 | |
---|
90 | |
---|
91 | (defun abort (&optional condition) |
---|
92 | "Transfer control to a restart named ABORT, signalling a CONTROL-ERROR if |
---|
93 | none exists." |
---|
94 | (invoke-restart-no-return (find-restart 'abort condition))) |
---|
95 | |
---|
96 | (defun continue (&optional condition) |
---|
97 | "Transfer control to a restart named CONTINUE, or return NIL if none exists." |
---|
98 | (let ((r (find-restart 'continue condition))) |
---|
99 | (if r (invoke-restart r)))) |
---|
100 | |
---|
101 | (defun muffle-warning (&optional condition) |
---|
102 | "Transfer control to a restart named MUFFLE-WARNING, signalling a |
---|
103 | CONTROL-ERROR if none exists." |
---|
104 | (invoke-restart-no-return (find-restart 'muffle-warning condition))) |
---|
105 | |
---|
106 | (defun abort-break () |
---|
107 | (invoke-restart-no-return 'abort-break)) |
---|
108 | |
---|
109 | |
---|
110 | (defun quit (&optional (exit-status 0)) |
---|
111 | (unless (typep exit-status '(signed-byte 32)) |
---|
112 | (report-bad-arg exit-status '(signed-byte 32))) |
---|
113 | (let* ((ip *initial-process*) |
---|
114 | (cp *current-process*)) |
---|
115 | (when (process-verify-quit ip) |
---|
116 | (process-interrupt ip |
---|
117 | #'(lambda () |
---|
118 | (process-exit-application *current-process* |
---|
119 | #'(lambda () |
---|
120 | (%set-toplevel nil) |
---|
121 | (#__exit exit-status))))) |
---|
122 | (unless (eq cp ip) |
---|
123 | (process-kill cp))))) |
---|
124 | |
---|
125 | |
---|
126 | (defglobal *quitting* nil) |
---|
127 | |
---|
128 | |
---|
129 | (defun prepare-to-quit (&optional part) |
---|
130 | (let-globally ((*quitting* t)) |
---|
131 | (when (or (null part) (eql 0 part)) |
---|
132 | (dolist (f *lisp-cleanup-functions*) |
---|
133 | (funcall f))) |
---|
134 | (let* ((stragglers ())) |
---|
135 | (dolist (p (all-processes)) |
---|
136 | (unless (or (eq p *initial-process*) |
---|
137 | (not (process-active-p p))) |
---|
138 | (if (process-persistent p) |
---|
139 | (process-reset p :shutdown) |
---|
140 | (process-kill p)))) |
---|
141 | (dolist (p (all-processes)) |
---|
142 | (let* ((semaphore (process-termination-semaphore p))) |
---|
143 | (when semaphore |
---|
144 | (unless (eq p *initial-process*) |
---|
145 | (unless (timed-wait-on-semaphore semaphore 0.05) |
---|
146 | (push p stragglers)))))) |
---|
147 | (dolist (p stragglers) |
---|
148 | (let* ((semaphore (process-termination-semaphore p))) |
---|
149 | (maybe-finish-process-kill p :kill) |
---|
150 | (when semaphore |
---|
151 | (timed-wait-on-semaphore semaphore 0.10))))) |
---|
152 | (shutdown-lisp-threads) |
---|
153 | (loop |
---|
154 | (let* ((streams (open-file-streams))) |
---|
155 | (when (null streams) (return)) |
---|
156 | (let* ((ioblock (stream-ioblock (car streams) nil))) |
---|
157 | (when ioblock |
---|
158 | (setf (ioblock-inbuf-lock ioblock) nil |
---|
159 | (ioblock-outbuf-lock ioblock) nil |
---|
160 | (ioblock-owner ioblock) nil))) |
---|
161 | (close (car streams)))) |
---|
162 | (setf (interrupt-level) -1) ; can't abort after this |
---|
163 | ) |
---|
164 | ;; Didn't abort, so really quitting. |
---|
165 | (setq *quitting* t)) |
---|
166 | |
---|
167 | |
---|
168 | (defun signal (condition &rest args) |
---|
169 | "Invokes the signal facility on a condition formed from DATUM and |
---|
170 | ARGUMENTS. If the condition is not handled, NIL is returned. If |
---|
171 | (TYPEP condition *BREAK-ON-SIGNALS*) is true, the debugger is invoked |
---|
172 | before any signalling is done." |
---|
173 | (setq condition (condition-arg condition args 'simple-condition)) |
---|
174 | (let* ((*break-on-signals* *break-on-signals*)) |
---|
175 | (let* ((old-bos *break-on-signals*)) |
---|
176 | (when (unknown-ctype-p (let* ((*break-on-signals* nil)) (specifier-type old-bos))) |
---|
177 | (setq *break-on-signals* nil) |
---|
178 | (warn "~S : Ignoring invalid type specifier ~s." '*break-on-signals old-bos))) |
---|
179 | |
---|
180 | (when (typep condition *break-on-signals*) |
---|
181 | (let ((*break-on-signals* nil)) |
---|
182 | (cbreak-loop "Signal" "Signal the condition." condition (%get-frame-ptr))))) |
---|
183 | (let ((%handlers% %handlers%)) |
---|
184 | (while %handlers% |
---|
185 | (do* ((tag (pop %handlers%)) (handlers tag (cddr handlers))) |
---|
186 | ((null handlers)) |
---|
187 | (when (typep condition (car handlers)) |
---|
188 | (let ((fn (cadr handlers))) |
---|
189 | (cond ((null fn) (throw tag condition)) |
---|
190 | ((fixnump fn) (throw tag (cons fn condition))) |
---|
191 | (t (funcall fn condition))))))))) |
---|
192 | |
---|
193 | (defvar *error-print-circle* nil) ; reset to T when we actually can print-circle |
---|
194 | |
---|
195 | |
---|
196 | |
---|
197 | ;;;*********************************** |
---|
198 | ;;;Mini-evaluator |
---|
199 | ;;;*********************************** |
---|
200 | |
---|
201 | (defun new-lexical-environment (&optional parent) |
---|
202 | (%istruct 'lexical-environment parent nil nil nil nil nil nil)) |
---|
203 | |
---|
204 | (defmethod make-load-form ((e lexical-environment) &optional env) |
---|
205 | (declare (ignore env)) |
---|
206 | nil) |
---|
207 | |
---|
208 | (defun new-definition-environment (&optional (type 'compile-file)) |
---|
209 | (%istruct 'definition-environment (list type) nil nil nil nil nil nil nil nil nil nil nil nil )) |
---|
210 | |
---|
211 | (defun definition-environment (env &optional clean-only &aux parent) |
---|
212 | (if (and env (not (istruct-typep env 'lexical-environment))) (report-bad-arg env 'lexical-environment)) |
---|
213 | (do* () |
---|
214 | ((or (null env) |
---|
215 | (listp (setq parent (lexenv.parent-env env))) |
---|
216 | (and clean-only (or (lexenv.variables env) (lexenv.functions env))))) |
---|
217 | (setq env parent)) |
---|
218 | (if (consp parent) |
---|
219 | env)) |
---|
220 | |
---|
221 | (defvar *symbol-macros* (make-hash-table :test #'eq)) |
---|
222 | |
---|
223 | (defun %define-symbol-macro (name expansion) |
---|
224 | (if (or (constant-symbol-p name) |
---|
225 | (proclaimed-special-p name)) |
---|
226 | (signal-program-error "Symbol ~s already globally defined as a ~A" |
---|
227 | name (if (constant-symbol-p name) |
---|
228 | 'constant |
---|
229 | 'variable))) |
---|
230 | (setf (gethash name *symbol-macros*) expansion) |
---|
231 | name) |
---|
232 | |
---|
233 | (defvar *macroexpand-hook* 'funcall |
---|
234 | "The value of this variable must be a designator for a function that can |
---|
235 | take three arguments, a macro expander function, the macro form to be |
---|
236 | expanded, and the lexical environment to expand in. The function should |
---|
237 | return the expanded form. This function is called by MACROEXPAND-1 |
---|
238 | whenever a runtime expansion is needed. Initially this is set to |
---|
239 | FUNCALL.") ; Should be #'funcall. |
---|
240 | ;(queue-fixup (setq *macroexpand-hook* #'funcall)) ; No it shouldn't. |
---|
241 | |
---|
242 | (defun %symbol-macroexpand-1 (sym env) |
---|
243 | (flet ((expand-it (expansion) |
---|
244 | (funcall *macroexpand-hook* |
---|
245 | (constantly expansion) |
---|
246 | sym |
---|
247 | env))) |
---|
248 | (if (and env (not (istruct-typep env 'lexical-environment))) |
---|
249 | (report-bad-arg env 'lexical-environment)) |
---|
250 | (do* ((env env (lexenv.parent-env env))) |
---|
251 | ((null env)) |
---|
252 | (if (eq (%svref env 0) 'definition-environment) |
---|
253 | (let* ((info (assq sym (defenv.symbol-macros env)))) |
---|
254 | (if info |
---|
255 | (return-from %symbol-macroexpand-1 (values (expand-it (cdr info)) t)) |
---|
256 | (return))) |
---|
257 | (let* ((vars (lexenv.variables env))) |
---|
258 | (when (consp vars) |
---|
259 | (let* ((info (dolist (var vars) |
---|
260 | (if (eq (var-name var) sym) |
---|
261 | (return var))))) |
---|
262 | (when info |
---|
263 | (if (and (consp (setq info (var-expansion info))) |
---|
264 | (eq (%car info) :symbol-macro)) |
---|
265 | (return-from %symbol-macroexpand-1 (values (expand-it (%cdr info)) t)) |
---|
266 | (return-from %symbol-macroexpand-1 (values sym nil))))))))) |
---|
267 | ;; Look it up globally. |
---|
268 | (multiple-value-bind (expansion win) (gethash sym *symbol-macros*) |
---|
269 | (if win (values (expand-it expansion) t) (values sym nil))))) |
---|
270 | |
---|
271 | (defun macroexpand-1 (form &optional env &aux fn) |
---|
272 | "If form is a macro (or symbol macro), expand it once. Return two values, |
---|
273 | the expanded form and a T-or-NIL flag indicating whether the form was, in |
---|
274 | fact, a macro. ENV is the lexical environment to expand in, which defaults |
---|
275 | to the null environment." |
---|
276 | (declare (resident)) |
---|
277 | (if (and (consp form) |
---|
278 | (symbolp (%car form))) |
---|
279 | (if (setq fn (macro-function (%car form) env)) |
---|
280 | (values (funcall *macroexpand-hook* fn form env) t) |
---|
281 | (values form nil)) |
---|
282 | (if (and form (symbolp form)) |
---|
283 | (%symbol-macroexpand-1 form env) |
---|
284 | (values form nil)))) |
---|
285 | |
---|
286 | (defun macroexpand (form &optional env) |
---|
287 | "Repetitively call MACROEXPAND-1 until the form can no longer be expanded. |
---|
288 | Returns the final resultant form, and T if it was expanded. ENV is the |
---|
289 | lexical environment to expand in, or NIL (the default) for the null |
---|
290 | environment." |
---|
291 | (declare (resident)) |
---|
292 | (multiple-value-bind (new win) (macroexpand-1 form env) |
---|
293 | (do* ((won-at-least-once win)) |
---|
294 | ((null win) (values new won-at-least-once)) |
---|
295 | (multiple-value-setq (new win) (macroexpand-1 new env))))) |
---|
296 | |
---|
297 | (defun %symbol-macroexpand (form env &aux win won) |
---|
298 | ; Keep expanding until no longer a symbol-macro or no longer a symbol. |
---|
299 | (loop |
---|
300 | (unless (and form (symbolp form)) (return)) |
---|
301 | (multiple-value-setq (form win) (macroexpand-1 form env)) |
---|
302 | (if win (setq won t) (return))) |
---|
303 | (values form won)) |
---|
304 | |
---|
305 | (defun retain-lambda-expression (name lambda-expression env) |
---|
306 | (if (and (let* ((lambda-list (cadr lambda-expression))) |
---|
307 | (and (not (memq '&lap lambda-list)) |
---|
308 | (not (memq '&method lambda-list)) |
---|
309 | (not (memq '&lexpr lambda-list)))) |
---|
310 | (nx-declared-inline-p name env) |
---|
311 | (not (gethash name *nx1-alphatizers*)) |
---|
312 | ; A toplevel definition defined inside a (symbol-)macrolet should |
---|
313 | ; be inlineable. It isn't; call DEFINITION-ENVIRONMENT with a |
---|
314 | ; "clean-only" argument to ensure that there are no lexically |
---|
315 | ; bound macros or symbol-macros. |
---|
316 | (definition-environment env t)) |
---|
317 | lambda-expression)) |
---|
318 | |
---|
319 | ; This is different from AUGMENT-ENVIRONMENT. |
---|
320 | ; If "info" is a lambda expression, then |
---|
321 | ; record a cons whose CAR is (encoded-lfun-bits . keyvect) and whose cdr |
---|
322 | ; is the lambda expression iff the function named by "name" is |
---|
323 | ; declared/proclaimed INLINE in env |
---|
324 | (defun note-function-info (name lambda-expression env) |
---|
325 | (let ((definition-env (definition-environment env))) |
---|
326 | (if definition-env |
---|
327 | (let* ((already (assq (setq name (maybe-setf-function-name name)) |
---|
328 | (defenv.defined definition-env))) |
---|
329 | (info nil)) |
---|
330 | (when (lambda-expression-p lambda-expression) |
---|
331 | (multiple-value-bind (lfbits keyvect) (encode-lambda-list lambda-expression t) |
---|
332 | (setq info (cons (cons lfbits keyvect) |
---|
333 | (retain-lambda-expression name lambda-expression env))))) |
---|
334 | (if already |
---|
335 | (if info (%rplacd already info)) |
---|
336 | (push (cons name info) (defenv.defined definition-env))))) |
---|
337 | name)) |
---|
338 | |
---|
339 | ; And this is different from FUNCTION-INFORMATION. |
---|
340 | (defun retrieve-environment-function-info (name env) |
---|
341 | (let ((defenv (definition-environment env))) |
---|
342 | (if defenv (assq (maybe-setf-function-name name) (defenv.defined defenv))))) |
---|
343 | |
---|
344 | (defun maybe-setf-function-name (name) |
---|
345 | (if (and (consp name) (eq (car name) 'setf)) |
---|
346 | (setf-function-name (cadr name)) |
---|
347 | name)) |
---|
348 | |
---|
349 | ; Must differ from -something-, but not sure what ... |
---|
350 | (defun note-variable-info (name info env) |
---|
351 | (let ((definition-env (definition-environment env))) |
---|
352 | (if definition-env (push (cons name info) (defenv.specials definition-env))) |
---|
353 | name)) |
---|
354 | |
---|
355 | (defun compile-file-environment-p (env) |
---|
356 | (let ((defenv (definition-environment env))) |
---|
357 | (and defenv (eq 'compile-file (car (defenv.type defenv)))))) |
---|
358 | |
---|
359 | (defun cheap-eval (form) |
---|
360 | (cheap-eval-in-environment form nil)) |
---|
361 | |
---|
362 | ; used by nfcomp too |
---|
363 | ; Should preserve order of decl-specs; it sometimes matters. |
---|
364 | (defun decl-specs-from-declarations (declarations) |
---|
365 | (let ((decl-specs nil)) |
---|
366 | (dolist (declaration declarations decl-specs) |
---|
367 | ;(unless (eq (car declaration) 'declare) (say "what")) |
---|
368 | (dolist (decl-spec (cdr declaration)) |
---|
369 | (setq decl-specs (nconc decl-specs (list decl-spec))))))) |
---|
370 | |
---|
371 | (defun cheap-eval-in-environment (form env &aux sym) |
---|
372 | (declare (resident)) |
---|
373 | (flet ((progn-in-env (body&decls parse-env base-env) |
---|
374 | (multiple-value-bind (body decls) (parse-body body&decls parse-env) |
---|
375 | (setq base-env (augment-environment base-env :declare (decl-specs-from-declarations decls))) |
---|
376 | (while (cdr body) |
---|
377 | (cheap-eval-in-environment (pop body) base-env)) |
---|
378 | (cheap-eval-in-environment (car body) base-env)))) |
---|
379 | (if form |
---|
380 | (cond ((symbolp form) |
---|
381 | (multiple-value-bind (expansion win) (macroexpand-1 form env) |
---|
382 | (if win |
---|
383 | (cheap-eval-in-environment expansion env) |
---|
384 | (let* ((defenv (definition-environment env)) |
---|
385 | (constant (if defenv (assq form (defenv.constants defenv)))) |
---|
386 | (constval (%cdr constant))) |
---|
387 | (if constant |
---|
388 | (if (neq (%unbound-marker-8) constval) |
---|
389 | constval |
---|
390 | (error "Can't determine value of constant symbol ~s" form)) |
---|
391 | (if (constant-symbol-p form) |
---|
392 | (%sym-global-value form) |
---|
393 | (symbol-value form))))))) |
---|
394 | ((atom form) form) |
---|
395 | ((eq (setq sym (%car form)) 'quote) |
---|
396 | (verify-arg-count form 1 1) |
---|
397 | (%cadr form)) |
---|
398 | ((eq sym 'function) |
---|
399 | (verify-arg-count form 1 1) |
---|
400 | (cond ((symbolp (setq sym (%cadr form))) |
---|
401 | (multiple-value-bind (kind local-p) |
---|
402 | (function-information sym env) |
---|
403 | (if (and local-p (eq kind :macro)) |
---|
404 | (error "~s can't be used to reference lexically defined macro ~S" 'function sym))) |
---|
405 | (%function sym)) |
---|
406 | ((and (consp sym) (eq (%car sym) 'setf) (consp (%cdr sym)) (null (%cddr sym))) |
---|
407 | (multiple-value-bind (kind local-p) |
---|
408 | (function-information sym env) |
---|
409 | (if (and local-p (eq kind :macro)) |
---|
410 | (error "~s can't be used to reference lexically defined macro ~S" 'function sym))) |
---|
411 | (%function (setf-function-name (%cadr sym)))) |
---|
412 | (t (%make-function nil sym env)))) |
---|
413 | ((eq sym 'nfunction) |
---|
414 | (verify-arg-count form 2 2) |
---|
415 | (%make-function (%cadr form) (%caddr form) env)) |
---|
416 | ((eq sym 'progn) (progn-in-env (%cdr form) env env)) |
---|
417 | ((eq sym 'setq) |
---|
418 | (if (not (%ilogbitp 0 (list-length form))) |
---|
419 | (verify-arg-count form 0 0)) ;Invoke a "Too many args" error. |
---|
420 | (let* ((sym nil) |
---|
421 | (val nil)) |
---|
422 | (while (setq form (%cdr form)) |
---|
423 | (setq sym (require-type (pop form) 'symbol)) |
---|
424 | (multiple-value-bind (expansion expanded) |
---|
425 | (macroexpand-1 sym env) |
---|
426 | (if expanded |
---|
427 | (setq val (cheap-eval-in-environment `(setf ,expansion ,(%car form)) env)) |
---|
428 | (set sym (setq val (cheap-eval-in-environment (%car form) env)))))) |
---|
429 | val)) |
---|
430 | ((eq sym 'eval-when) |
---|
431 | (destructuring-bind (when . body) (%cdr form) |
---|
432 | (when (or (memq 'eval when) (memq :execute when)) (progn-in-env body env env)))) |
---|
433 | ((eq sym 'if) |
---|
434 | (destructuring-bind (test true &optional false) (%cdr form) |
---|
435 | (cheap-eval-in-environment (if (cheap-eval-in-environment test env) true false) env))) |
---|
436 | ((eq sym 'locally) (progn-in-env (%cdr form) env env)) |
---|
437 | ((eq sym 'symbol-macrolet) |
---|
438 | (multiple-value-bind (body decls) (parse-body (cddr form) env) |
---|
439 | (progn-in-env body env (augment-environment env :symbol-macro (cadr form) :declare (decl-specs-from-declarations decls))))) |
---|
440 | ((eq sym 'macrolet) |
---|
441 | (let ((temp-env (augment-environment env |
---|
442 | :macro |
---|
443 | (mapcar #'(lambda (m) |
---|
444 | (destructuring-bind (name arglist &body body) m |
---|
445 | (list name (enclose (parse-macro name arglist body env) |
---|
446 | env)))) |
---|
447 | (cadr form))))) |
---|
448 | (progn-in-env (cddr form) temp-env temp-env))) |
---|
449 | ((and (symbolp sym) |
---|
450 | (compiler-special-form-p sym) |
---|
451 | (not (functionp (fboundp sym)))) |
---|
452 | (if (eq sym 'unwind-protect) |
---|
453 | (destructuring-bind (protected-form . cleanup-forms) (cdr form) |
---|
454 | (unwind-protect |
---|
455 | (cheap-eval-in-environment protected-form env) |
---|
456 | (progn-in-env cleanup-forms env env))) |
---|
457 | (funcall (%make-function nil `(lambda () (progn ,form)) env)))) |
---|
458 | ((and (symbolp sym) (macro-function sym env)) |
---|
459 | (if (eq sym 'step) |
---|
460 | (let ((*compile-definitions* nil)) |
---|
461 | (cheap-eval-in-environment (macroexpand-1 form env) env)) |
---|
462 | (cheap-eval-in-environment (macroexpand-1 form env) env))) |
---|
463 | ((or (symbolp sym) |
---|
464 | (and (consp sym) (eq (%car sym) 'lambda))) |
---|
465 | (let ((args nil)) |
---|
466 | (dolist (elt (%cdr form)) (push (cheap-eval-in-environment elt env) args)) |
---|
467 | (apply #'call-check-regs (if (symbolp sym) sym (%make-function nil sym env)) |
---|
468 | (nreverse args)))) |
---|
469 | (t (signal-simple-condition 'simple-program-error "Car of ~S is not a function name or lambda-expression." form)))))) |
---|
470 | |
---|
471 | |
---|
472 | (%fhave 'eval #'cheap-eval) |
---|
473 | |
---|
474 | |
---|
475 | |
---|
476 | |
---|
477 | (defun call-check-regs (fn &rest args) |
---|
478 | (declare (dynamic-extent args) |
---|
479 | (optimize (debug 3))) ; don't use any saved registers |
---|
480 | (let ((old-regs (multiple-value-list (get-saved-register-values)))) |
---|
481 | (declare (dynamic-extent old-regs)) |
---|
482 | (multiple-value-prog1 (apply fn args) |
---|
483 | (let* ((new-regs (multiple-value-list (get-saved-register-values))) |
---|
484 | (new-regs-tail new-regs)) |
---|
485 | (declare (dynamic-extent new-regs)) |
---|
486 | (unless (dolist (old-reg old-regs t) |
---|
487 | (unless (eq old-reg (car new-regs-tail)) |
---|
488 | (return nil)) |
---|
489 | (pop new-regs-tail)) |
---|
490 | (apply 'error "Registers clobbered applying ~s to ~s~%~@{~a sb: ~s, Was: ~s~%~}" |
---|
491 | fn args |
---|
492 | (mapcan 'list |
---|
493 | (let ((res nil)) |
---|
494 | (dotimes (i (length old-regs)) |
---|
495 | (push (format nil "save~d" i) res)) |
---|
496 | (nreverse res)) |
---|
497 | old-regs |
---|
498 | new-regs))))))) |
---|
499 | |
---|
500 | |
---|
501 | |
---|
502 | |
---|
503 | |
---|
504 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
---|
505 | ;; Stack frame accessors. |
---|
506 | |
---|
507 | ; Kinda scant, wouldn't you say ? |
---|
508 | |
---|
509 | |
---|
510 | ;end of L1-readloop.lisp |
---|
511 | |
---|