source: branches/working-0711/ccl/level-1/l1-readloop.lisp @ 11832

Last change on this file since 11832 was 11786, checked in by gz, 11 years ago

fix typo

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 29.9 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(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 0))
111  "exit must be either a (signed-byte 32) exit status or a function to call to exit lisp"
112  (if (or (null exit) (typep exit '(signed-byte 32)))
113    (setq exit (let ((exit-status (or exit 0)))
114                 #'(lambda () (#__exit exit-status))))
115    (unless (typep exit 'function)
116      (report-bad-arg exit '(or (signed-byte 32) function))))
117  (let* ((ip *initial-process*)
118         (cp *current-process*))
119    (when (process-verify-quit ip)
120      (process-interrupt ip
121                         #'(lambda ()
122                             (process-exit-application *current-process*
123                                                       #'(lambda ()
124                                                           (%set-toplevel nil)
125                                                           (funcall exit) ;; must exit
126                                                           (bug "Exit function didn't exit")))))
127      (unless (eq cp ip)
128        (process-kill cp)))))
129
130
131(defloadvar *quitting* nil)
132
133
134(defun prepare-to-quit (&optional part)
135  (let-globally ((*quitting* t))
136    (when (or (null part) (eql 0 part))
137      (dolist (f *lisp-cleanup-functions*)
138        (funcall f)))
139    (let* ((stragglers ()))
140      (dolist (p (all-processes))
141        (unless (or (eq p *initial-process*)
142                    (not (process-active-p p)))
143          (if (process-persistent p)
144            (process-reset p :shutdown)
145            (process-kill p))))
146      (dolist (p (all-processes))
147        (let* ((semaphore (process-termination-semaphore p)))
148          (when semaphore
149            (unless (eq p *initial-process*)
150              (unless (timed-wait-on-semaphore semaphore 0.05)
151                (push p stragglers))))))
152      (dolist (p stragglers)
153        (let* ((semaphore (process-termination-semaphore p)))
154          (maybe-finish-process-kill p :kill)
155          (when semaphore
156            (timed-wait-on-semaphore semaphore 0.10)))))
157    (shutdown-lisp-threads)
158    (loop
159      (let* ((streams (open-file-streams)))
160        (when (null streams) (return))
161        (let* ((ioblock (stream-ioblock (car streams) nil)))
162          (when ioblock
163            (setf (ioblock-inbuf-lock ioblock) nil
164                  (ioblock-outbuf-lock ioblock) nil
165                  (ioblock-owner ioblock) nil)))
166        (close (car streams))))
167    (setf (interrupt-level) -1)         ; can't abort after this
168    )
169  ;; Didn't abort, so really quitting.
170  (setq *quitting* t))
171
172
173(defun signal (condition &rest args)
174  "Invokes the signal facility on a condition formed from DATUM and
175   ARGUMENTS. If the condition is not handled, NIL is returned. If
176   (TYPEP condition *BREAK-ON-SIGNALS*) is true, the debugger is invoked
177   before any signalling is done."
178  (setq condition (condition-arg condition args 'simple-condition))
179  (let* ((*break-on-signals* *break-on-signals*))
180     (let* ((old-bos *break-on-signals*))
181       (when (unknown-ctype-p (let* ((*break-on-signals* nil)) (specifier-type old-bos)))
182         (setq *break-on-signals* nil)
183         (warn "~S : Ignoring invalid type specifier ~s." '*break-on-signals* old-bos)))
184         
185   (when (typep condition *break-on-signals*)
186     (let ((*break-on-signals* nil))
187       (cbreak-loop "Signal" "Signal the condition." condition (%get-frame-ptr)))))
188  (let ((%handlers% %handlers%))
189    (while %handlers%
190      (do* ((tag (pop %handlers%)) (handlers tag (cddr handlers)))
191           ((null handlers))
192        (when (typep condition (car handlers))
193          (let ((fn (cadr handlers)))
194            (cond ((null fn) (throw tag condition))
195                  ((fixnump fn) (throw tag (cons fn condition)))
196                  (t (funcall fn condition)))))))))
197
198(defvar *error-print-circle* nil)   ; reset to T when we actually can print-circle
199
200
201
202;;;***********************************
203;;;Mini-evaluator
204;;;***********************************
205
206(defun new-lexical-environment (&optional parent)
207  (%istruct 'lexical-environment parent nil nil nil nil nil nil))
208
209(defmethod make-load-form ((e lexical-environment) &optional env)
210  (declare (ignore env))
211  nil)
212
213(defun new-definition-environment (&optional (type 'compile-file))
214  (%istruct 'definition-environment (list type)  nil nil nil nil nil nil nil nil nil nil nil nil ))
215
216(defun definition-environment (env &optional clean-only &aux parent)
217  (if (and env (not (istruct-typep env 'lexical-environment))) (report-bad-arg env 'lexical-environment))
218  (do* () 
219       ((or (null env) 
220            (listp (setq parent (lexenv.parent-env env)))
221            (and clean-only (or (lexenv.variables env) (lexenv.functions env)))))
222    (setq env parent))
223  (if (consp parent)
224    env))
225
226(defvar *symbol-macros* (make-hash-table :test #'eq))
227
228(defun %define-symbol-macro (name expansion)
229  (if (or (constant-symbol-p name)
230          (proclaimed-special-p name))
231      (signal-program-error "Symbol ~s already globally defined as a ~A"
232                            name (if (constant-symbol-p name)
233                                     'constant
234                                     'variable)))
235  (setf (gethash name *symbol-macros*) expansion)
236  name)
237
238(defvar *macroexpand-hook* 'funcall
239  "The value of this variable must be a designator for a function that can
240  take three arguments, a macro expander function, the macro form to be
241  expanded, and the lexical environment to expand in. The function should
242  return the expanded form. This function is called by MACROEXPAND-1
243  whenever a runtime expansion is needed. Initially this is set to
244  FUNCALL.") ; Should be #'funcall.
245;(queue-fixup (setq *macroexpand-hook* #'funcall)) ;  No it shouldn't.
246
247(defun %symbol-macroexpand-1 (sym env)
248  (flet ((expand-it (expansion)
249           (funcall *macroexpand-hook*
250                    (constantly expansion)
251                    sym
252                    env)))
253    (if (and env (not (istruct-typep env 'lexical-environment)))
254      (report-bad-arg env 'lexical-environment))
255    (do* ((env env (lexenv.parent-env env)))
256         ((null env))
257      (if (istruct-typep env 'definition-environment)
258        (let* ((info (assq sym (defenv.symbol-macros env))))
259          (if info
260            (return-from %symbol-macroexpand-1 (values (expand-it (cdr info)) t))
261            (return)))
262        (let* ((vars (lexenv.variables env)))
263          (when (consp vars)
264            (let* ((info (dolist (var vars)
265                           (if (eq (var-name var) sym)
266                             (return var)))))           
267              (when info
268                (if (and (consp (setq info (var-expansion info)))
269                         (eq (%car info) :symbol-macro))
270                  (return-from %symbol-macroexpand-1 (values (expand-it (%cdr info)) t))
271                  (return-from %symbol-macroexpand-1 (values sym nil)))))))))
272    ;; Look it up globally.
273    (multiple-value-bind (expansion win) (gethash sym *symbol-macros*)
274      (if win (values (expand-it expansion) t) (values sym nil)))))
275
276(defun macroexpand-all (form &optional (env (new-lexical-environment)))
277  "Recursivly expand all macros in FORM."
278  (flet ((mexpand (forms env)
279           (mapcar (lambda (form) (macroexpand-all form env)) forms)))
280    (macrolet ((destructuring-bind-body (binds form &body body)
281                 (if (eql '&body (first (last binds)))
282                   (let ((&body (gensym "&BODY")))
283                     `(destructuring-bind ,(append (butlast binds) (list '&body &body))
284                          ,form
285                        (multiple-value-bind (body decls)
286                            (parse-body ,&body env nil)
287                          ,@body)))
288                   `(destructuring-bind ,binds ,form ,@body))))
289      (multiple-value-bind (expansion win)
290          (macroexpand-1 form env)
291        (if win
292          (macroexpand-all expansion env)
293          (if (atom form)
294            form
295            (case (first form)
296              (macrolet
297               (destructuring-bind-body (macros &body) (rest form)
298                (setf env (augment-environment env
299                                               :macro (mapcar (lambda (macro)
300                                                                (destructuring-bind
301                                                                      (name arglist &body body)
302                                                                    macro
303                                                                  (list name (enclose (parse-macro name arglist body env)))))
304                                                              macros)
305                                               :declare (decl-specs-from-declarations decls)))
306                (let ((body (mexpand body env)))
307                  (if decls
308                    `(locally ,@decls ,@body)
309                    `(progn ,@body)))))
310              (symbol-macrolet
311               (destructuring-bind-body (symbol-macros &body) (rest form)
312                (setf env (augment-environment env :symbol-macro symbol-macros :declare (decl-specs-from-declarations decls)))
313                (let ((body (mexpand body env)))
314                  (if decls
315                    `(locally ,@decls ,@body)
316                    `(progn ,@body)))))
317              ((let let* compiler-let)
318               (destructuring-bind-body (bindings &body) (rest form)
319                `(,(first form)
320                   ,(mapcar (lambda (binding)
321                             
322                              (if (listp binding)
323                                (list (first binding) (macroexpand-all (second binding) env))
324                                binding))
325                            bindings)
326                   ,@decls
327                   ,@(mexpand body env))))
328              ((flet labels)
329               (destructuring-bind-body (bindings &body) (rest form)
330                `(,(first form)
331                   ,(mapcar (lambda (binding)
332                              (list* (first binding) (cdr (macroexpand-all `(lambda ,@(rest binding)) env))))
333                            bindings)
334                   ,@decls
335                   ,@(mexpand body env))))
336              (nfunction (list* 'nfunction (second form) (macroexpand-all (third form) env)))
337              (function
338                 (if (and (consp (second form))
339                          (eql 'lambda (first (second form))))
340                   (destructuring-bind (lambda arglist &body body&decls)
341                       (second form)
342                     (declare (ignore lambda))
343                     (multiple-value-bind (body decls)
344                         (parse-body body&decls env)
345                       `(lambda ,arglist ,@decls ,@(mexpand body env))))
346                   form))
347              ((eval-when the locally block return-from)
348                 (list* (first form) (second form) (mexpand (cddr form) env)))
349              (setq
350                 `(setq ,@(loop for (name value) on (rest form) by #'cddr
351                                collect name
352                                collect (macroexpand-all value env))))
353              ((go quote) form)
354              ((fbind with-c-frame with-variable-c-frame ppc-lap-function)
355               (error "Unable to macroexpand ~S." form))
356              ((catch if load-time-value multiple-value-call multiple-value-prog1 progn
357                progv tagbody throw unwind-protect)
358               (cons (first form) (mexpand (rest form) env)))
359              (t
360               ;; need to check that (first form) is either fboundp or a local function...
361               (cons (first form) (mexpand (rest form) env))))))))))
362
363(defun macroexpand-1 (form &optional env &aux fn)
364  "If form is a macro (or symbol macro), expand it once. Return two values,
365   the expanded form and a T-or-NIL flag indicating whether the form was, in
366   fact, a macro. ENV is the lexical environment to expand in, which defaults
367   to the null environment."
368  (declare (resident))
369  (if (and (consp form)
370           (symbolp (%car form)))
371    (if (setq fn (macro-function (%car form) env))
372      (values (funcall *macroexpand-hook* fn form env) t)
373      (values form nil))
374    (if (and form (symbolp form))
375      (%symbol-macroexpand-1 form env)
376      (values form nil))))
377
378(defun macroexpand (form &optional env)
379  "Repetitively call MACROEXPAND-1 until the form can no longer be expanded.
380   Returns the final resultant form, and T if it was expanded. ENV is the
381   lexical environment to expand in, or NIL (the default) for the null
382   environment."
383  (declare (resident))
384  (multiple-value-bind (new win) (macroexpand-1 form env)
385    (do* ((won-at-least-once win))
386         ((null win) (values new won-at-least-once))
387      (multiple-value-setq (new win) (macroexpand-1 new env)))))
388
389(defun %symbol-macroexpand (form env &aux win won)
390  ; Keep expanding until no longer a symbol-macro or no longer a symbol.
391  (loop
392    (unless (and form (symbolp form)) (return))
393    (multiple-value-setq (form win) (macroexpand-1 form env))
394    (if win (setq won t) (return)))
395  (values form won))
396
397(defun retain-lambda-expression (name lambda-expression env)
398  (if (and (let* ((lambda-list (cadr lambda-expression)))
399             (and (not (memq '&lap lambda-list))
400                  (not (memq '&method lambda-list))
401                  (not (memq '&lexpr lambda-list))))
402           (nx-declared-inline-p name env)
403           (not (gethash name *nx1-alphatizers*))
404           ; A toplevel definition defined inside a (symbol-)macrolet should
405           ; be inlineable.  It isn't; call DEFINITION-ENVIRONMENT with a
406           ; "clean-only" argument to ensure that there are no lexically
407           ; bound macros or symbol-macros.
408           (definition-environment env t))
409    lambda-expression))
410
411
412(defun %cons-def-info (type &optional lfbits keyvect lambda specializers qualifiers)
413  (ecase type
414    (defun nil)
415    (defmacro (setq lambda '(macro) lfbits nil)) ;; some code assumes lfbits=nil
416    (defgeneric (setq lambda (list :methods)))
417    (defmethod (setq lambda (list :methods (cons qualifiers specializers)))))
418  (vector lfbits keyvect *loading-file-source-file* lambda))
419
420(defun def-info.lfbits (def-info)
421  (and def-info (svref def-info 0)))
422
423(defun def-info.keyvect (def-info)
424  (and def-info (svref def-info 1)))
425
426(defun def-info.file (def-info)
427  (and def-info (svref def-info 2)))
428
429(defun def-info.lambda (def-info)
430  (let ((data (and def-info (svref def-info 3))))
431    (and (eq (car data) 'lambda) data)))
432
433(defun def-info.methods (def-info)
434  (let ((data (and def-info (svref def-info 3))))
435    (and (eq (car data) :methods) (%cdr data))))
436
437(defun def-info-with-new-methods (def-info new-methods)
438  (unless (eq (def-info.type def-info) 'defgeneric) (error "Bug: not method info: ~s" def-info))
439  (if (eq new-methods (def-info.methods def-info))
440    def-info
441    (let ((new (copy-seq def-info)))
442      (setf (svref new 3) (cons :methods new-methods))
443      new)))
444
445(defun def-info.macro-p (def-info)
446  (let ((data (and def-info (svref def-info 3))))
447    (eq (car data) 'macro)))
448
449(defun def-info.type (def-info)
450  (if (null def-info) nil  ;; means FTYPE decl or lap function
451    (let ((data (svref def-info 3)))
452      (ecase (car data)
453        ((nil lambda) 'defun)
454        (:methods 'defgeneric)
455        (macro 'defmacro)))))
456
457(defparameter *one-arg-defun-def-info* (%cons-def-info 'defun (encode-lambda-list '(x))))
458
459(defvar *compiler-warn-on-duplicate-definitions* t)
460
461(defun combine-function-infos (name old-info new-info)
462  (let ((old-type (def-info.type old-info))
463        (new-type (def-info.type new-info)))
464    (cond ((and (eq old-type 'defgeneric) (eq new-type 'defgeneric))
465           ;; TODO: Check compatibility of lfbits...
466           ;; TODO: check that all methods implement defgeneric keys
467           (let ((old-methods (def-info.methods old-info))
468                 (new-methods (def-info.methods new-info)))
469             (loop for new-method in new-methods
470                   do (if (member new-method old-methods :test #'equal)
471                        (when *compiler-warn-on-duplicate-definitions*
472                          (nx1-whine :duplicate-definition
473                                     `(method ,@(car new-method) ,name ,(cdr new-method))
474                                     (def-info.file old-info)
475                                     (def-info.file new-info)))
476                        (push new-method old-methods)))
477             (def-info-with-new-methods old-info old-methods)))
478          ((or (eq (or old-type 'defun) (or new-type 'defun))
479               (eq (or old-type 'defgeneric) (or new-type 'defgeneric)))
480           (when (and old-type new-type *compiler-warn-on-duplicate-definitions*)
481             (nx1-whine :duplicate-definition name (def-info.file old-info) (def-info.file new-info)))
482           (or new-info old-info))
483          (t
484           (when *compiler-warn-on-duplicate-definitions*
485             (apply #'nx1-whine :duplicate-definition
486                    name
487                    (def-info.file old-info)
488                    (def-info.file new-info)
489                    (cond ((eq old-type 'defmacro) '("macro" "function"))
490                          ((eq new-type 'defmacro) '("function" "macro"))
491                          ((eq old-type 'defgeneric) '("generic function" "function"))
492                          (t '("function" "generic function")))))
493           new-info))))
494
495(defun record-function-info (name info env)
496  (let* ((definition-env (definition-environment env)))
497    (if definition-env
498      (let* ((defs (defenv.defined definition-env))
499             (already (if (listp defs) (assq name defs) (gethash name defs))))
500        (if already
501          (setf (%cdr already) (combine-function-infos name (%cdr already) info))
502          (let ((outer (loop for defer = (cdr (defenv.type definition-env))
503                               then (deferred-warnings.parent defer)
504                             while (typep defer 'deferred-warnings)
505                             thereis (gethash name (deferred-warnings.defs defer)))))
506            (when outer
507              (setq info (combine-function-infos name (%cdr outer) info)))
508            (let ((new (cons name info)))
509              (if (listp defs)
510                (setf (defenv.defined definition-env) (cons new defs))
511                (setf (gethash name defs) new)))))
512        info))))
513
514
515;;; This is different from AUGMENT-ENVIRONMENT.
516(defun note-function-info (name lambda-expression env)
517  (let* ((info nil)
518         (name (maybe-setf-function-name name)))
519    (when (lambda-expression-p lambda-expression)
520      (multiple-value-bind (lfbits keyvect) (encode-lambda-list (cadr lambda-expression) t)
521        (setq info (%cons-def-info 'defun lfbits keyvect
522                                   (retain-lambda-expression name lambda-expression env)))))
523    (record-function-info name info env))
524  name)
525
526; And this is different from FUNCTION-INFORMATION.
527(defun retrieve-environment-function-info (name env)
528 (let ((defenv (definition-environment env)))
529   (when defenv
530     (let ((defs (defenv.defined defenv))
531           (sym (maybe-setf-function-name name)))
532       (if (listp defs) (assq sym defs) (gethash sym defs))))))
533
534(defun maybe-setf-function-name (name)
535  (if (and (consp name) (eq (car name) 'setf))
536    (setf-function-name (cadr name))
537    name))
538
539;;; Must differ from -something-, but not sure what ...
540(defun note-variable-info (name info env)
541  (let ((definition-env (definition-environment env)))
542    (if definition-env (push (cons name info) (defenv.specials definition-env)))
543    name))
544
545(defun compile-file-environment-p (env)
546  (let ((defenv (definition-environment env)))
547    (and defenv (eq 'compile-file (car (defenv.type defenv))))))
548
549(defun cheap-eval (form)
550  (cheap-eval-in-environment form nil))
551
552; used by nfcomp too
553; Should preserve order of decl-specs; it sometimes matters.
554(defun decl-specs-from-declarations (declarations)
555  (let ((decl-specs nil))
556    (dolist (declaration declarations decl-specs)
557      ;(unless (eq (car declaration) 'declare) (say "what"))
558      (dolist (decl-spec (cdr declaration))
559        (setq decl-specs (nconc decl-specs (list decl-spec)))))))
560
561(defun cheap-eval-in-environment (form env &aux sym)
562  (declare (resident))
563  (flet ((progn-in-env (body&decls parse-env base-env)
564           (multiple-value-bind (body decls) (parse-body body&decls parse-env)
565             (setq base-env (augment-environment base-env :declare (decl-specs-from-declarations decls)))
566             (while (cdr body)
567               (cheap-eval-in-environment (pop body) base-env))
568             (cheap-eval-in-environment (car body) base-env))))
569    (if form
570      (cond ((symbolp form) 
571             (multiple-value-bind (expansion win) (macroexpand-1 form env)
572               (if win 
573                 (cheap-eval-in-environment expansion env) 
574                 (let* ((defenv (definition-environment env))
575                        (constant (if defenv (assq form (defenv.constants defenv))))
576                        (constval (%cdr constant)))
577                   (if constant
578                     (if (neq (%unbound-marker-8) constval)
579                       constval
580                       (error "Can't determine value of constant symbol ~s" form))
581                     (if (constant-symbol-p form)
582                       (%sym-global-value form)
583                       (symbol-value form)))))))
584            ((atom form) form)
585            ((eq (setq sym (%car form)) 'quote)
586             (verify-arg-count form 1 1)
587             (%cadr form))
588            ((eq sym 'function)
589             (verify-arg-count form 1 1)
590             (cond ((symbolp (setq sym (%cadr form)))
591                    (multiple-value-bind (kind local-p)
592                        (function-information sym env)
593                      (if (and local-p (eq kind :macro))
594                        (error "~s can't be used to reference lexically defined macro ~S" 'function sym)))
595                    (%function sym))
596                   ((and (consp sym) (eq (%car sym) 'setf) (consp (%cdr sym)) (null (%cddr sym)))
597                    (multiple-value-bind (kind local-p)
598                        (function-information sym env)
599                      (if (and local-p (eq kind :macro))
600                        (error "~s can't be used to reference lexically defined macro ~S" 'function sym)))
601                    (%function (setf-function-name (%cadr sym))))
602                   (t (%make-function nil sym env))))
603            ((eq sym 'nfunction)
604             (verify-arg-count form 2 2)
605             (%make-function (%cadr form) (%caddr form) env))
606            ((eq sym 'progn) (progn-in-env (%cdr form) env env))
607            ((eq sym 'setq)
608             (if (not (%ilogbitp 0 (list-length form)))
609               (verify-arg-count form 0 0)) ;Invoke a "Too many args" error.
610             (let* ((sym nil)
611                    (val nil))
612               (while (setq form (%cdr form))
613                 (setq sym (require-type (pop form) 'symbol))
614                 (multiple-value-bind (expansion expanded)
615                                      (macroexpand-1 sym env)
616                   (if expanded
617                     (setq val (cheap-eval-in-environment `(setf ,expansion ,(%car form)) env))
618                     (set sym (setq val (cheap-eval-in-environment (%car form) env))))))
619               val))
620            ((eq sym 'eval-when)
621             (destructuring-bind (when . body) (%cdr form)
622               (when (or (memq 'eval when) (memq :execute when)) (progn-in-env body env env))))
623            ((eq sym 'if)
624             (destructuring-bind (test true &optional false) (%cdr form)
625               (cheap-eval-in-environment (if (cheap-eval-in-environment test env) true false) env)))
626            ((eq sym 'locally) (progn-in-env (%cdr form) env env))
627            ((eq sym 'symbol-macrolet)
628             (multiple-value-bind (body decls) (parse-body (cddr form) env)
629               (progn-in-env body env (augment-environment env :symbol-macro (cadr form) :declare (decl-specs-from-declarations decls)))))
630            ((eq sym 'macrolet)
631             (let ((temp-env (augment-environment env
632                                                  :macro 
633                                                  (mapcar #'(lambda (m)
634                                                              (destructuring-bind (name arglist &body body) m
635                                                                (list name (enclose (parse-macro name arglist body env)
636                                                                                    env))))
637                                                          (cadr form)))))
638               (progn-in-env (cddr form) temp-env temp-env)))
639            ((and (symbolp sym) 
640                  (compiler-special-form-p sym)
641                  (not (functionp (fboundp sym))))
642             (if (eq sym 'unwind-protect)
643               (destructuring-bind (protected-form . cleanup-forms) (cdr form)
644                 (unwind-protect
645                   (cheap-eval-in-environment protected-form env)
646                   (progn-in-env cleanup-forms env env)))
647               (funcall (%make-function nil `(lambda () (progn ,form)) env))))
648            ((and (symbolp sym) (macro-function sym env))
649             (if (eq sym 'step)
650               (let ((*compile-definitions* nil))
651                     (cheap-eval-in-environment (macroexpand-1 form env) env))
652               (cheap-eval-in-environment (macroexpand-1 form env) env)))
653            ((or (symbolp sym)
654                 (and (consp sym) (eq (%car sym) 'lambda)))
655             (let ((args nil))
656               (dolist (elt (%cdr form)) (push (cheap-eval-in-environment elt env) args))
657               (apply #'call-check-regs (if (symbolp sym) sym (%make-function nil sym env))
658                      (nreverse args))))
659            (t (signal-simple-condition 'simple-program-error "Car of ~S is not a function name or lambda-expression." form))))))
660
661
662(%fhave 'eval #'cheap-eval)
663
664
665
666 
667(defun call-check-regs (fn &rest args)
668  (declare (dynamic-extent args)
669           (optimize (debug 3)))        ; don't use any saved registers
670  (let ((old-regs (multiple-value-list (get-saved-register-values))))
671    (declare (dynamic-extent old-regs))
672    (multiple-value-prog1 (apply fn args)
673      (let* ((new-regs (multiple-value-list (get-saved-register-values)))
674             (new-regs-tail new-regs))
675        (declare (dynamic-extent new-regs))
676        (unless (dolist (old-reg old-regs t)
677                  (unless (eq old-reg (car new-regs-tail))
678                    (return nil))
679                  (pop new-regs-tail))
680          (apply 'error "Registers clobbered applying ~s to ~s~%~@{~a sb: ~s, Was: ~s~%~}"
681                 fn args
682                 (mapcan 'list
683                         (let ((res nil))
684                           (dotimes (i (length old-regs))
685                             (push (format nil "save~d" i) res))
686                           (nreverse res))
687                         old-regs
688                         new-regs)))))))
689
690
691
692
693
694;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
695;; Stack frame accessors.
696
697; Kinda scant, wouldn't you say ?
698
699
700;end of L1-readloop.lisp
701
Note: See TracBrowser for help on using the repository browser.