source: trunk/ccl/level-1/l1-readloop.lisp @ 569

Last change on this file since 569 was 569, checked in by gb, 16 years ago

QUIT typechecks arg before it's too late to do so.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 27.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(defvar *break-on-warnings* nil)
24(defvar *break-on-errors* t "Not CL.")
25(defvar *debugger-hook* nil)
26(defvar *backtrace-on-break* nil)
27(defvar *** nil)
28(defvar ** nil)
29(defvar * nil)
30(defvar /// nil)
31(defvar // nil)
32(defvar / nil)
33(defvar +++ nil)
34(defvar ++ nil)
35(defvar + nil)
36(defvar - nil)
37
38(defvar *continuablep* nil)
39(defvar *in-read-loop* nil 
40 "Not CL. Is T if waiting for input in the read loop")
41(defvar *listener-p* nil
42  "Bound true by READ-LOOP. This is how we tell if a process is a Listener")
43
44(defparameter *inhibit-error* nil "If non-nil, ERROR just throws")
45(defvar *did-startup* nil)
46
47
48(defun process-is-listener-p (process)
49  (symbol-value-in-process '*listener-p* process))
50
51(defun process-is-toplevel-listener-p (process)
52  (and (symbol-value-in-process '*in-read-loop* process)
53       (eql 0 (symbol-value-in-process '*break-level* process))))
54
55
56(defmacro catch-cancel (&body body)
57  `(catch :cancel ,@body))
58
59(defmacro throw-cancel (&optional value)
60  `(throw :cancel ,value))
61
62(defun toplevel ()
63  (throw :toplevel nil))
64
65; This is the old way we did this.
66; It has the drawback that it doesn't throw out,
67; just restarts the process without cleaning up.
68#|
69      (progn
70        (process-interrupt *initial-process*
71                           #'(lambda (p)
72                               (let ((function.args (process.initial-form p)))
73                                 (apply #'process-preset
74                                        p
75                                        (car function.args)
76                                        (cdr function.args))))
77                           p)
78        (loop
79          (suspend-current-process))))))
80|#
81
82(defun cancel ()
83 (throw :cancel :cancel))
84
85; It's not clear that this is the right behavior, but aborting CURRENT-PROCESS -
86; when no one's sure just what CURRENT-PROCESS is - doesn't seem right either.
87(defun interactive-abort ()
88  (interactive-abort-in-process *current-process*))
89
90(defun interactive-abort-in-process (p)
91  (if p (process-interrupt p 
92                           #'(lambda ()
93                               (unless *inhibit-abort*
94                                 (lds (if *in-read-loop* 
95                                        (abort-break)
96                                        (abort))
97                                      (abort))
98                                 )))))
99
100
101; What process-to-abort does now (5/5/95):
102; - all processes idling: cmd-. & opt-cmd-. abort event-processor
103; - one process busy: cmd-. aborts the busy process; opt-cmd-. gives dialog
104; - two or more processes busy: cmd-. & opt-cmd-. gives dialog
105; (a busy process is a non-idling listener, or any other that's not event-processor)
106
107#+notyet
108(defun process-to-abort (what)
109  (let ((l (mapcan #'(lambda (x)
110                       (unless (or (process-exhausted-p x)
111                                   (not (find-restart-in-process 'abort x))
112                                   ; idling listeners:
113                                   #|
114                                   (and (symbol-value-in-process '*in-read-loop* x)
115                                        (eq 0 (symbol-value-in-process '*break-level* x)))|#
116                                   )
117                         (list x)))
118                   (reverse *active-processes*))))
119    (cond
120      ((null (cdr l)) (car l)) ; *current-process*
121      ((and (null (cddr l))
122            (not (option-key-p)))
123       (if (eq (car l) *event-processor*) (cadr l) (car l)))
124      (t (let ((p (catch-cancel
125                    (select-item-from-list l
126                                           :window-title what
127                                           :help-spec 15010
128                                           :list-spec 15011
129                                           :button-spec 15013))))
130           (if (neq p :cancel) (car p)))))))
131
132(defun abort (&optional condition)
133  (invoke-restart-no-return (find-restart 'abort condition)))
134
135(defun continue (&optional condition)
136  (let ((r (find-restart 'continue condition)))
137    (if r (invoke-restart r))))
138
139(defun muffle-warning (&optional condition)
140  (invoke-restart-no-return (find-restart 'muffle-warning condition)))
141
142(defun abort-break ()
143  (invoke-restart-no-return 'abort-break))
144
145#| Doing it this way prevents abort from clearing input in the listener
146(defun abort-break ()
147  (let ((res (find-restart-2 'abort)))
148    (if  res (invoke-restart-no-return res) (abort))))
149
150; find second restart
151(defun find-restart-2 (name &aux res)
152  (dolist (cluster %restarts% res)
153    (dolist (restart cluster)
154      (when (eq (restart-name restart) name)                 
155        (if res (return-from find-restart-2 restart)(setq res restart))))))
156|#
157
158
159(defun quit (&optional (exit-status 0))
160  (unless (typep exit-status '(signed-byte 32))
161    (report-bad-arg exit-status '(signed-byte 32)))
162  (let* ((ip *initial-process*)
163         (cp *current-process*))
164    (when (process-verify-quit ip)
165      (process-interrupt ip
166                         #'(lambda ()
167                             (process-exit-application *current-process*
168                                   #'(lambda ()
169                                       (#_exit exit-status)))))
170      (unless (eq cp ip)
171        (process-kill cp)))))
172
173
174
175
176(defglobal *quitting* nil)
177
178
179
180
181(defun prepare-to-quit (&optional part)
182  (let-globally ((*quitting* t))
183    (when (or (null part) (eql 0 part))
184      (dolist (f *lisp-cleanup-functions*)
185        (funcall f)))
186    (let* ((stragglers ()))
187      (dolist (p (all-processes))
188        (unless (or (eq p *initial-process*)
189                    (not (process-active-p p)))
190          (if (process-persistent p)
191            (process-reset p :shutdown)
192            (process-kill p))))
193      (dolist (p (all-processes))
194        (unless (eq p *initial-process*)
195          (unless (process-wait-with-timeout
196                   "Shutdown wait"
197                   5
198                   #'process-exhausted-p
199                   p)
200            (push p stragglers))))
201      (dolist (p stragglers)
202        (unless (process-wait-with-timeout
203                 "deathwatch"
204                 (* 5 *ticks-per-second*)
205                 #'(lambda () (process-exhausted-p p)))
206          (maybe-finish-process-kill p :kill))))
207    (shutdown-lisp-threads)
208    (while *open-file-streams*
209      (close (car *open-file-streams*)))
210    (setf (interrupt-level) -1)       ; can't abort after this
211    ))
212
213
214
215
216
217
218
219;; Application classes
220
221(defstruct command-line-argument
222  keyword
223  help-string
224  option-char
225  long-name
226  may-take-operand
227  allow-multiple                        ; option can appear multiple times
228)
229
230(defvar *standard-help-argument*
231  (make-command-line-argument
232   :keyword :help
233   :help-string "this text"
234   :option-char #\h
235   :long-name "help"))
236
237(defvar *standard-version-argument*
238  (make-command-line-argument
239   :keyword :version
240   :help-string "print (LISP-APPLICATION-VERSION) and exit"
241   :option-char #\V
242   :long-name "version"))
243
244(defclass application ()
245    ((command-line-arguments
246      :initform
247      (list *standard-help-argument* *standard-version-argument*))))
248       
249                             
250(defun %usage-exit (banner exit-status other-args)
251  (with-cstrs ((banner banner)
252               (other-args other-args))
253    (ff-call (%kernel-import ppc32::kernel-import-usage-exit)
254             :address banner
255             :signed-fullword exit-status
256             :address other-args
257             :void)))
258
259;;; Returns three values: error-flag, options-alist, non-option-arguments
260(defmethod parse-application-arguments ((a application))
261  (let* ((cla (slot-value a 'command-line-arguments))
262         (vals (cdr *command-line-argument-list*))
263         (options ())
264         (non-options ()))
265    (do* ()
266         ((null vals)
267          (values nil (nreverse options) (nreverse non-options)))
268      (let* ((val (pop vals))
269             (val-len (length val))
270             (short-p nil)
271             (option
272              (if (and (>= val-len 2)
273                       (eql (schar val 0) #\-))
274                (if (eql (schar val 1) #\-)
275                  (find val cla
276                        :key #'command-line-argument-long-name
277                        :test #'(lambda (k v) (string= k v :start1 2)))
278                  (progn
279                    (setq short-p t)
280                    (find (schar val 1) cla
281                          :key #'command-line-argument-option-char))))))
282        (if (null option)
283          (if (and (>= val-len 1)
284                   (eql (schar val 0) #\-))
285            (return (values :unknown-option val nil))
286            (push val non-options))     ;non-option argument
287          ;; We recognized the option.  Is it a duplicate of
288          ;; something already seen?
289          (let* ((key (command-line-argument-keyword option))
290                 (operand nil))
291            (when (and (assoc key options)
292                       (not (command-line-argument-allow-multiple option)))
293              (return (values :duplicate-option val nil)))
294            (when (command-line-argument-may-take-operand option)
295              ;; A short option name can be followed by the operand,
296              ;; without intervening whitespace.
297              (if (and short-p (> val-len 2))
298                (setq operand (subseq val 2))
299                (if vals
300                  (setq operand (pop vals))
301                  (return (values :missing-operand val nil)))))
302            (push (cons key operand) options)))))))
303
304(defmethod summarize-option-syntax ((a application))
305  (flet ((summarize-option (o)
306           (format nil "~8t-~a, --~a : ~a~%"
307                   (command-line-argument-option-char o)
308                   (command-line-argument-long-name o)
309                   (command-line-argument-help-string o))))
310    (format nil "~{~a~}" (mapcar #'summarize-option
311                                 (slot-value a 'command-line-arguments)))))
312
313 
314;;; Process the "help" and "version" options, report parsing errors.
315(defmethod process-application-arguments ((a application) error-flag opts args)
316  (declare (ignore args))
317  (if (null error-flag)
318    (if (assoc :help opts)
319      (%usage-exit "" 0 (summarize-option-syntax a))
320      (if (assoc :version opts)
321        (progn
322          (format t "~&~a~&" (application-version-string a))
323          (force-output t)
324          (#_exit 0))))
325    (%usage-exit
326     (format nil
327             (case error-flag
328               (:missing-argument "Missing argument to ~a option")
329               (:duplicate-argument "Duplicate ~a option")
330               (:unknown-option "Unknown option: ~a")
331               (t "~a"))
332             opts)
333     #$EX_USAGE
334     (summarize-option-syntax a))))
335               
336
337;;; an example method to base a specialization on
338(defmethod toplevel-function ((a application) init-file)
339  (declare (ignore init-file))
340  (multiple-value-bind (error-flag options args)
341      (parse-application-arguments a)
342    (process-application-arguments a error-flag options args)))
343
344(defmethod application-version-string ((a application))
345  "Return a string which (arbitrarily) represents the application version.
346Default version returns OpenMCL version info."
347  (format nil "~&~d.~d~@[.~d~]~@[-~a~]~&"
348          *openmcl-major-version*
349          *openmcl-minor-version*
350          (unless (zerop *openmcl-revision*)
351            *openmcl-revision*)
352          *openmcl-suffix*))
353
354
355(defun find-restart-in-process (name p)
356  (without-interrupts
357   (let ((restarts (symbol-value-in-process '%restarts% p)))
358     (dolist (cluster restarts)
359       (dolist (restart cluster)
360         (when (and (or (eq restart name) (eq (restart-name restart) name)))
361           (return-from find-restart-in-process restart)))))))
362
363
364
365; specialize this for your application
366(defmethod open-application ((self application) startup)
367  (declare (ignore startup))
368  nil)
369 
370; specialize this for your application
371(defmethod open-application-document ((a application) path &optional startup)
372  (declare (ignore path startup)))
373
374(defmethod application-name          ((app application)) nil)
375(defmethod application-init-file     ((app application)) nil)
376
377
378(defclass lisp-development-system (application) 
379  ((command-line-arguments
380    :initform
381    (list *standard-help-argument*
382          *standard-version-argument*
383          (make-command-line-argument
384           :option-char #\n
385           :long-name "no-init"
386           :keyword :noinit
387           :help-string "suppress loading of init file")
388          (make-command-line-argument
389           :option-char #\e
390           :long-name "eval"
391           :keyword :eval
392           :help-string "evaluate <form> (may need to quote <form> in shell)"
393           :may-take-operand t
394           :allow-multiple t)
395          (make-command-line-argument
396           :option-char #\l
397           :long-name "load"
398           :keyword :load
399           :help-string "load <file>"
400           :may-take-operand t
401           :allow-multiple t)
402          (make-command-line-argument
403           :option-char #\T
404           :long-name "set-lisp-heap-gc-threshold"
405           :help-string "set lisp-heap-gc-threshold to <n>"
406           :keyword :gc-threshold
407           :may-take-operand t
408           :allow-multiple nil)))))
409
410(defparameter *application*
411  (make-instance 'lisp-development-system))
412
413(defvar *load-lisp-init-file* t)
414(defvar *lisp-startup-parameters* ())
415
416(defmethod process-application-arguments ((a lisp-development-system)
417                                          error-flag options args)
418  (declare (ignorable error-flag))
419  (call-next-method)                    ; handle help, errors
420  (if args
421    (%usage-exit (format nil "Unrecognized non-option arguments: ~a" args)
422                 #$EX_USAGE
423                 (summarize-option-syntax a))
424    (setq *load-lisp-init-file* (not (assoc :noinit options))
425          *lisp-startup-parameters*
426          (mapcan #'(lambda (x)
427                      (and (member (car x) '(:load :eval :gc-threshold)) (list x)))
428                  options))))
429       
430
431(defmethod toplevel-function ((a lisp-development-system) init-file)
432  (call-next-method)
433  (let* ((sr (input-stream-shared-resource *terminal-input*)))
434    (make-mcl-listener-process
435     "listener"
436     *terminal-input*
437     *terminal-output*
438     #'(lambda () (when sr (setf (shared-resource-primary-owner sr)
439                                 *initial-process*)))
440     #'(lambda ()
441         (startup-ccl (and *load-lisp-init-file* init-file))
442         (listener-function)
443         nil)
444     nil))
445  (%set-toplevel #'(lambda ()
446                     (with-standard-abort-handling nil 
447                       (loop
448                         (%nanosleep *periodic-task-seconds* *periodic-task-nanoseconds*)
449                         (housekeeping)))))
450  (toplevel))
451
452
453
454(defmethod application-init-file ((app lisp-development-system))
455  "home:openmcl-init")
456
457
458; redefined by hide-listener-support
459(defmethod application-error ((a application) condition error-pointer)
460  (declare (ignore condition error-pointer))
461  (quit))
462
463(defun error-header (kind)
464  (let ((pname (process-name *current-process*)))
465    (if (and pname (not (string-equal pname *main-listener-process-name*)))
466      (format nil "~A in process ~A(~d)" kind pname
467              (process-serial-number *current-process*))
468      (format nil "~A" kind))))
469
470(defun signal (condition &rest args)
471  (setq condition (condition-arg condition args 'simple-condition))
472  (lds
473   (let* ((*break-on-signals* *break-on-signals*))
474     (let* ((old-bos *break-on-signals*))
475       (when (unknown-ctype-p (let* ((*break-on-signals* nil)) (specifier-type old-bos)))
476         (setq *break-on-signals* nil)
477         (warn "~S : Ignoring invalid type specifier ~s." '*break-on-signals old-bos)))
478         
479   (when (typep condition *break-on-signals*)
480     (let ((*break-on-signals* nil))
481       (cbreak-loop "Signal" "Signal the condition." condition (%get-frame-ptr))))))
482  (let ((%handlers% %handlers%))
483    (while %handlers%
484      (do* ((tag (pop %handlers%)) (handlers tag (cddr handlers)))
485           ((null handlers))
486        (when (typep condition (car handlers))
487          (let ((fn (cadr handlers)))
488            (cond ((null fn) (throw tag condition))
489                  ((fixnump fn) (throw tag (cons fn condition)))
490                  (t (funcall fn condition)))))))))
491
492(defvar *error-print-circle* nil)   ; reset to T when we actually can print-circle
493
494
495
496;;;***********************************
497;;;Mini-evaluator
498;;;***********************************
499
500(defun new-lexical-environment (&optional parent)
501  (%istruct 'lexical-environment parent nil nil nil nil nil nil))
502
503(defmethod make-load-form ((e lexical-environment) &optional env)
504  (declare (ignore env))
505  nil)
506
507(defun new-definition-environment (&optional (type 'compile-file))
508  (%istruct 'definition-environment (list type)  nil nil nil nil nil nil nil nil nil nil nil nil ))
509
510(defun definition-environment (env &optional clean-only &aux parent)
511  (if (and env (not (istruct-typep env 'lexical-environment))) (report-bad-arg env 'lexical-environment))
512  (do* () 
513       ((or (null env) 
514            (listp (setq parent (lexenv.parent-env env)))
515            (and clean-only (or (lexenv.variables env) (lexenv.functions env)))))
516    (setq env parent))
517  (if (consp parent)
518    env))
519
520(defvar *symbol-macros* (make-hash-table :test #'eq))
521
522(defun %define-symbol-macro (name expansion)
523  (if (or (constant-symbol-p name)
524          (proclaimed-special-p name))
525      (signal-program-error "Symbol ~s already globally defined as a ~A"
526                            name (if (constant-symbol-p name)
527                                     'constant
528                                     'variable)))
529  (setf (gethash name *symbol-macros*) expansion)
530  name)
531
532(defvar *macroexpand-hook* 'funcall) ; Should be #'funcall.
533;(queue-fixup (setq *macroexpand-hook* #'funcall)) ;  No it shouldn't.
534
535(defun %symbol-macroexpand-1 (sym env)
536  (if (and env (not (istruct-typep env 'lexical-environment)))
537      (report-bad-arg env 'lexical-environment))
538  (do* ((env env (lexenv.parent-env env)))
539       ((null env))
540    (if (eq (%svref env 0) 'definition-environment)
541        (let* ((info (assq sym (defenv.symbol-macros env))))
542          (if info
543            (return-from %symbol-macroexpand-1 (values (cdr info) t))
544            (return)))
545        (let* ((vars (lexenv.variables env)))
546          (when (consp vars)
547            (let* ((info (dolist (var vars)
548                           (if (eq (var-name var) sym)
549                               (return var)))))           
550              (when info
551                (if (and (consp (setq info (var-expansion info)))
552                         (eq (%car info) :symbol-macro))
553                    (return-from %symbol-macroexpand-1 (values (%cdr info) t))
554                    (return-from %symbol-macroexpand-1 (values sym nil)))))))))
555  ;; Look it up globally.
556  (multiple-value-bind (expansion win) (gethash sym *symbol-macros*)
557    (if win (values expansion t) (values sym nil))))
558
559(defun macroexpand-1 (form &optional env &aux fn)
560  (declare (resident))
561  (if (and (consp form)
562           (symbolp (%car form)))
563    (if (setq fn (macro-function (%car form) env))
564      (values (funcall *macroexpand-hook* fn form env) t)
565      (values form nil))
566    (if (and form (symbolp form))
567      (%symbol-macroexpand-1 form env)
568      (values form nil))))
569
570(defun macroexpand (form &optional env)
571  (declare (resident))
572  (multiple-value-bind (new win) (macroexpand-1 form env)
573    (do* ((won-at-least-once win))
574         ((null win) (values new won-at-least-once))
575      (multiple-value-setq (new win) (macroexpand-1 new env)))))
576
577(defun %symbol-macroexpand (form env &aux win won)
578  ; Keep expanding until no longer a symbol-macro or no longer a symbol.
579  (loop
580    (unless (and form (symbolp form)) (return))
581    (multiple-value-setq (form win) (macroexpand-1 form env))
582    (if win (setq won t) (return)))
583  (values form won))
584
585(defun retain-lambda-expression (name lambda-expression env)
586  (if (and (let* ((lambda-list (cadr lambda-expression)))
587             (and (not (memq '&lap lambda-list))
588                  (not (memq '&method lambda-list))
589                  (not (memq '&lexpr lambda-list))))
590           (nx-declared-inline-p name env)
591           (not (gethash name *nx1-alphatizers*))
592           ; A toplevel definition defined inside a (symbol-)macrolet should
593           ; be inlineable.  It isn't; call DEFINITION-ENVIRONMENT with a
594           ; "clean-only" argument to ensure that there are no lexically
595           ; bound macros or symbol-macros.
596           (definition-environment env t))
597    lambda-expression))
598
599; This is different from AUGMENT-ENVIRONMENT.
600; If "info" is a lambda expression, then
601;  record a cons whose CAR is (encoded-lfun-bits . keyvect) and whose cdr
602;  is the lambda expression iff the function named by "name" is
603;  declared/proclaimed INLINE in env
604(defun note-function-info (name lambda-expression env)
605  (let ((definition-env (definition-environment env)))
606    (if definition-env
607      (let* ((already (assq (setq name (maybe-setf-function-name name))
608                            (defenv.defined definition-env)))
609             (info nil))
610        (when (lambda-expression-p lambda-expression)
611          (multiple-value-bind (lfbits keyvect) (encode-lambda-list lambda-expression t)
612            (setq info (cons (cons lfbits keyvect) 
613                             (retain-lambda-expression name lambda-expression env)))))
614          (if already
615            (if info (%rplacd already info))
616            (push (cons name info) (defenv.defined definition-env)))))
617    name))
618
619; And this is different from FUNCTION-INFORMATION.
620(defun retrieve-environment-function-info (name env)
621 (let ((defenv (definition-environment env)))
622   (if defenv (assq (maybe-setf-function-name name) (defenv.defined defenv)))))
623
624(defun maybe-setf-function-name (name)
625  (if (and (consp name) (eq (car name) 'setf))
626    (setf-function-name (cadr name))
627    name))
628
629; Must differ from -something-, but not sure what ...
630(defun note-variable-info (name info env)
631  (let ((definition-env (definition-environment env)))
632    (if definition-env (push (cons name info) (defenv.specials definition-env)))
633    name))
634
635(defun compile-file-environment-p (env)
636  (let ((defenv (definition-environment env)))
637    (and defenv (eq 'compile-file (car (defenv.type defenv))))))
638
639(defun cheap-eval (form)
640  (cheap-eval-in-environment form nil))
641
642; used by nfcomp too
643; Should preserve order of decl-specs; it sometimes matters.
644(defun decl-specs-from-declarations (declarations)
645  (let ((decl-specs nil))
646    (dolist (declaration declarations decl-specs)
647      ;(unless (eq (car declaration) 'declare) (say "what"))
648      (dolist (decl-spec (cdr declaration))
649        (setq decl-specs (nconc decl-specs (list decl-spec)))))))
650
651(defun cheap-eval-in-environment (form env &aux sym)
652  (declare (resident))
653  (flet ((progn-in-env (body&decls parse-env base-env)
654           (multiple-value-bind (body decls) (parse-body body&decls parse-env)
655             (setq base-env (augment-environment base-env :declare (decl-specs-from-declarations decls)))
656             (while (cdr body)
657               (cheap-eval-in-environment (pop body) base-env))
658             (cheap-eval-in-environment (car body) base-env))))
659    (if form
660      (cond ((symbolp form) 
661             (multiple-value-bind (expansion win) (macroexpand-1 form env)
662               (if win 
663                 (cheap-eval-in-environment expansion env) 
664                 (let* ((defenv (definition-environment env))
665                        (constant (if defenv (assq form (defenv.constants defenv))))
666                        (constval (%cdr constant)))
667                   (if constant
668                     (if (neq (%unbound-marker-8) constval)
669                       constval
670                       (error "Can't determine value of constant symbol ~s" form))
671                     (if (constant-symbol-p form)
672                       (%sym-global-value form)
673                       (symbol-value form)))))))
674            ((atom form) form)
675            ((eq (setq sym (%car form)) 'quote)
676             (verify-arg-count form 1 1)
677             (%cadr form))
678            ((eq sym 'function)
679             (verify-arg-count form 1 1)
680             (cond ((symbolp (setq sym (%cadr form)))
681                    (%function sym))
682                   ((and (consp sym) (eq (%car sym) 'setf) (consp (%cdr sym)) (null (%cddr sym)))
683                    (%function (setf-function-name (%cadr sym))))
684                   (t (%make-function nil sym env))))
685            ((eq sym 'nfunction)
686             (verify-arg-count form 2 2)
687             (%make-function (%cadr form) (%caddr form) env))
688            ((eq sym 'progn) (progn-in-env (%cdr form) env env))
689            ((eq sym 'setq)
690             (if (not (%ilogbitp 0 (list-length form)))
691               (verify-arg-count form 0 0)) ;Invoke a "Too many args" error.
692             (let* ((sym nil)
693                    (val nil))
694               (while (setq form (%cdr form))
695                 (setq sym (require-type (pop form) 'symbol))
696                 (multiple-value-bind (expansion expanded)
697                                      (macroexpand-1 sym env)
698                   (if expanded
699                     (setq val (cheap-eval-in-environment `(setf ,expansion ,(%car form)) env))
700                     (set sym (setq val (cheap-eval-in-environment (%car form) env))))))
701               val))
702            ((eq sym 'eval-when)
703             (destructuring-bind (when . body) (%cdr form)
704               (when (or (memq 'eval when) (memq :execute when)) (progn-in-env body env env))))
705            ((eq sym 'if)
706             (destructuring-bind (test true &optional false) (%cdr form)
707               (cheap-eval-in-environment (if (cheap-eval-in-environment test env) true false) env)))
708            ((eq sym 'locally) (progn-in-env (%cdr form) env env))
709            ((eq sym 'symbol-macrolet)
710             (multiple-value-bind (body decls) (parse-body (cddr form) env)
711               (progn-in-env body env (augment-environment env :symbol-macro (cadr form) :declare (decl-specs-from-declarations decls)))))
712            ((eq sym 'macrolet)
713             (let ((temp-env (augment-environment env
714                                                  :macro 
715                                                  (mapcar #'(lambda (m)
716                                                              (destructuring-bind (name arglist &body body) m
717                                                                (list name (enclose (parse-macro name arglist body env)
718                                                                                    env))))
719                                                          (cadr form)))))
720               (progn-in-env (cddr form) temp-env temp-env)))
721            ((and (symbolp sym) 
722                  (compiler-special-form-p sym)
723                  (not (functionp (fboundp sym))))
724             (if (eq sym 'unwind-protect)
725               (destructuring-bind (protected-form . cleanup-forms) (cdr form)
726                 (unwind-protect
727                   (cheap-eval-in-environment protected-form env)
728                   (progn-in-env cleanup-forms env env)))
729               (funcall (%make-function nil `(lambda () (progn ,form)) env))))
730            ((and (symbolp sym) (macro-function sym env))
731             (if (eq sym 'step)
732               (let ((*compile-definitions* nil))
733                     (cheap-eval-in-environment (macroexpand-1 form env) env))
734               (cheap-eval-in-environment (macroexpand-1 form env) env)))
735            ((or (symbolp sym)
736                 (and (consp sym) (eq (%car sym) 'lambda)))
737             (let ((args nil))
738               (dolist (elt (%cdr form)) (push (cheap-eval-in-environment elt env) args))
739               (apply #'call-check-regs (if (symbolp sym) sym (%make-function nil sym env))
740                      (nreverse args))))
741            (t (signal-simple-condition 'simple-program-error "Car of ~S is not a function name or lambda-expression." form))))))
742
743
744(%fhave 'eval #'cheap-eval)
745
746
747
748 
749(defun call-check-regs (fn &rest args)
750  (declare (dynamic-extent args)
751           (optimize (debug 3)))        ; don't use any saved registers
752  (let ((old-regs (multiple-value-list (get-saved-register-values))))
753    (declare (dynamic-extent old-regs))
754    (multiple-value-prog1 (apply fn args)
755      (let* ((new-regs (multiple-value-list (get-saved-register-values)))
756             (new-regs-tail new-regs))
757        (declare (dynamic-extent new-regs))
758        (unless (dolist (old-reg old-regs t)
759                  (unless (eq old-reg (car new-regs-tail))
760                    (return nil))
761                  (pop new-regs-tail))
762          (apply 'error "Registers clobbered applying ~s to ~s~%~@{~a sb: ~s, Was: ~s~%~}"
763                 fn args
764                 (mapcan 'list
765                         (let ((res nil))
766                           (dotimes (i (length old-regs))
767                             (push (format nil "save~d" i) res))
768                           (nreverse res))
769                         old-regs
770                         new-regs)))))))
771
772
773
774
775
776;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
777;; Stack frame accessors.
778
779; Kinda scant, wouldn't you say ?
780
781
782;end of L1-readloop.lisp
783
Note: See TracBrowser for help on using the repository browser.