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

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

APPLICATION-UI-OBJECT stuff.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 28.4 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     (ui-object :initform nil :initarg :ui-object :accessor application-ui-object)))
249       
250(defclass ui-object ()
251    ())
252
253;;; It's intended that this be specialized ...
254(defmethod ui-object-do-operation ((u ui-object) operation &rest args)
255  (declare (ignore operation args)))
256
257
258(defun %usage-exit (banner exit-status other-args)
259  (with-cstrs ((banner banner)
260               (other-args other-args))
261    (ff-call (%kernel-import ppc32::kernel-import-usage-exit)
262             :address banner
263             :signed-fullword exit-status
264             :address other-args
265             :void)))
266
267;;; Returns three values: error-flag, options-alist, non-option-arguments
268(defmethod parse-application-arguments ((a application))
269  (let* ((cla (slot-value a 'command-line-arguments))
270         (vals (cdr *command-line-argument-list*))
271         (options ())
272         (non-options ()))
273    (do* ()
274         ((null vals)
275          (values nil (nreverse options) (nreverse non-options)))
276      (let* ((val (pop vals))
277             (val-len (length val))
278             (short-p nil)
279             (option
280              (if (and (>= val-len 2)
281                       (eql (schar val 0) #\-))
282                (if (eql (schar val 1) #\-)
283                  (find val cla
284                        :key #'command-line-argument-long-name
285                        :test #'(lambda (k v) (string= k v :start1 2)))
286                  (progn
287                    (setq short-p t)
288                    (find (schar val 1) cla
289                          :key #'command-line-argument-option-char))))))
290        (if (null option)
291          (if (and (>= val-len 1)
292                   (eql (schar val 0) #\-))
293            (return (values :unknown-option val nil))
294            (push val non-options))     ;non-option argument
295          ;; We recognized the option.  Is it a duplicate of
296          ;; something already seen?
297          (let* ((key (command-line-argument-keyword option))
298                 (operand nil))
299            (when (and (assoc key options)
300                       (not (command-line-argument-allow-multiple option)))
301              (return (values :duplicate-option val nil)))
302            (when (command-line-argument-may-take-operand option)
303              ;; A short option name can be followed by the operand,
304              ;; without intervening whitespace.
305              (if (and short-p (> val-len 2))
306                (setq operand (subseq val 2))
307                (if vals
308                  (setq operand (pop vals))
309                  (return (values :missing-operand val nil)))))
310            (push (cons key operand) options)))))))
311
312(defmethod summarize-option-syntax ((a application))
313  (flet ((summarize-option (o)
314           (format nil "~8t-~a, --~a : ~a~%"
315                   (command-line-argument-option-char o)
316                   (command-line-argument-long-name o)
317                   (command-line-argument-help-string o))))
318    (format nil "~{~a~}" (mapcar #'summarize-option
319                                 (slot-value a 'command-line-arguments)))))
320
321 
322;;; Process the "help" and "version" options, report parsing errors.
323(defmethod process-application-arguments ((a application) error-flag opts args)
324  (declare (ignore args))
325  (if (null error-flag)
326    (if (assoc :help opts)
327      (%usage-exit "" 0 (summarize-option-syntax a))
328      (if (assoc :version opts)
329        (progn
330          (format t "~&~a~&" (application-version-string a))
331          (force-output t)
332          (#_exit 0))))
333    (%usage-exit
334     (format nil
335             (case error-flag
336               (:missing-argument "Missing argument to ~a option")
337               (:duplicate-argument "Duplicate ~a option")
338               (:unknown-option "Unknown option: ~a")
339               (t "~a"))
340             opts)
341     #$EX_USAGE
342     (summarize-option-syntax a))))
343               
344
345;;; an example method to base a specialization on
346(defmethod toplevel-function ((a application) init-file)
347  (declare (ignore init-file))
348  (multiple-value-bind (error-flag options args)
349      (parse-application-arguments a)
350    (process-application-arguments a error-flag options args)))
351
352(defmethod application-version-string ((a application))
353  "Return a string which (arbitrarily) represents the application version.
354Default version returns OpenMCL version info."
355  (format nil "~&~d.~d~@[.~d~]~@[-~a~]~&"
356          *openmcl-major-version*
357          *openmcl-minor-version*
358          (unless (zerop *openmcl-revision*)
359            *openmcl-revision*)
360          *openmcl-suffix*))
361
362(defmethod application-ui-operation ((a application) operation &rest args)
363  (let* ((ui-object (application-ui-object a)))
364    (when ui-object
365      (apply #'ui-object-do-operation ui-object operation args))))
366
367
368
369
370
371(defun find-restart-in-process (name p)
372  (without-interrupts
373   (let ((restarts (symbol-value-in-process '%restarts% p)))
374     (dolist (cluster restarts)
375       (dolist (restart cluster)
376         (when (and (or (eq restart name) (eq (restart-name restart) name)))
377           (return-from find-restart-in-process restart)))))))
378
379
380
381; specialize this for your application
382(defmethod open-application ((self application) startup)
383  (declare (ignore startup))
384  nil)
385 
386; specialize this for your application
387(defmethod open-application-document ((a application) path &optional startup)
388  (declare (ignore path startup)))
389
390(defmethod application-name          ((app application)) nil)
391(defmethod application-init-file     ((app application)) nil)
392
393
394(defclass lisp-development-system (application) 
395  ((command-line-arguments
396    :initform
397    (list *standard-help-argument*
398          *standard-version-argument*
399          (make-command-line-argument
400           :option-char #\n
401           :long-name "no-init"
402           :keyword :noinit
403           :help-string "suppress loading of init file")
404          (make-command-line-argument
405           :option-char #\e
406           :long-name "eval"
407           :keyword :eval
408           :help-string "evaluate <form> (may need to quote <form> in shell)"
409           :may-take-operand t
410           :allow-multiple t)
411          (make-command-line-argument
412           :option-char #\l
413           :long-name "load"
414           :keyword :load
415           :help-string "load <file>"
416           :may-take-operand t
417           :allow-multiple t)
418          (make-command-line-argument
419           :option-char #\T
420           :long-name "set-lisp-heap-gc-threshold"
421           :help-string "set lisp-heap-gc-threshold to <n>"
422           :keyword :gc-threshold
423           :may-take-operand t
424           :allow-multiple nil)))))
425
426(defparameter *application*
427  (make-instance 'lisp-development-system))
428
429(defvar *load-lisp-init-file* t)
430(defvar *lisp-startup-parameters* ())
431
432(defmethod process-application-arguments ((a lisp-development-system)
433                                          error-flag options args)
434  (declare (ignorable error-flag))
435  (call-next-method)                    ; handle help, errors
436  (if args
437    (%usage-exit (format nil "Unrecognized non-option arguments: ~a" args)
438                 #$EX_USAGE
439                 (summarize-option-syntax a))
440    (setq *load-lisp-init-file* (not (assoc :noinit options))
441          *lisp-startup-parameters*
442          (mapcan #'(lambda (x)
443                      (and (member (car x) '(:load :eval :gc-threshold)) (list x)))
444                  options))))
445       
446
447(defmethod toplevel-function ((a lisp-development-system) init-file)
448  (call-next-method)
449  (let* ((sr (input-stream-shared-resource *terminal-input*)))
450    (make-mcl-listener-process
451     "listener"
452     *terminal-input*
453     *terminal-output*
454     #'(lambda () (when sr (setf (shared-resource-primary-owner sr)
455                                 *initial-process*)))
456     #'(lambda ()
457         (startup-ccl (and *load-lisp-init-file* init-file))
458         (listener-function)
459         nil)
460     nil))
461  (%set-toplevel #'(lambda ()
462                     (with-standard-abort-handling nil 
463                       (loop
464                         (%nanosleep *periodic-task-seconds* *periodic-task-nanoseconds*)
465                         (housekeeping)))))
466  (toplevel))
467
468
469
470(defmethod application-init-file ((app lisp-development-system))
471  "home:openmcl-init")
472
473
474; redefined by hide-listener-support
475(defmethod application-error ((a application) condition error-pointer)
476  (declare (ignore condition error-pointer))
477  (quit))
478
479(defun error-header (kind)
480  (let ((pname (process-name *current-process*)))
481    (if (and pname (not (string-equal pname *main-listener-process-name*)))
482      (format nil "~A in process ~A(~d)" kind pname
483              (process-serial-number *current-process*))
484      (format nil "~A" kind))))
485
486(defun signal (condition &rest args)
487  (setq condition (condition-arg condition args 'simple-condition))
488  (lds
489   (let* ((*break-on-signals* *break-on-signals*))
490     (let* ((old-bos *break-on-signals*))
491       (when (unknown-ctype-p (let* ((*break-on-signals* nil)) (specifier-type old-bos)))
492         (setq *break-on-signals* nil)
493         (warn "~S : Ignoring invalid type specifier ~s." '*break-on-signals old-bos)))
494         
495   (when (typep condition *break-on-signals*)
496     (let ((*break-on-signals* nil))
497       (cbreak-loop "Signal" "Signal the condition." condition (%get-frame-ptr))))))
498  (let ((%handlers% %handlers%))
499    (while %handlers%
500      (do* ((tag (pop %handlers%)) (handlers tag (cddr handlers)))
501           ((null handlers))
502        (when (typep condition (car handlers))
503          (let ((fn (cadr handlers)))
504            (cond ((null fn) (throw tag condition))
505                  ((fixnump fn) (throw tag (cons fn condition)))
506                  (t (funcall fn condition)))))))))
507
508(defvar *error-print-circle* nil)   ; reset to T when we actually can print-circle
509
510
511
512;;;***********************************
513;;;Mini-evaluator
514;;;***********************************
515
516(defun new-lexical-environment (&optional parent)
517  (%istruct 'lexical-environment parent nil nil nil nil nil nil))
518
519(defmethod make-load-form ((e lexical-environment) &optional env)
520  (declare (ignore env))
521  nil)
522
523(defun new-definition-environment (&optional (type 'compile-file))
524  (%istruct 'definition-environment (list type)  nil nil nil nil nil nil nil nil nil nil nil nil ))
525
526(defun definition-environment (env &optional clean-only &aux parent)
527  (if (and env (not (istruct-typep env 'lexical-environment))) (report-bad-arg env 'lexical-environment))
528  (do* () 
529       ((or (null env) 
530            (listp (setq parent (lexenv.parent-env env)))
531            (and clean-only (or (lexenv.variables env) (lexenv.functions env)))))
532    (setq env parent))
533  (if (consp parent)
534    env))
535
536(defvar *symbol-macros* (make-hash-table :test #'eq))
537
538(defun %define-symbol-macro (name expansion)
539  (if (or (constant-symbol-p name)
540          (proclaimed-special-p name))
541      (signal-program-error "Symbol ~s already globally defined as a ~A"
542                            name (if (constant-symbol-p name)
543                                     'constant
544                                     'variable)))
545  (setf (gethash name *symbol-macros*) expansion)
546  name)
547
548(defvar *macroexpand-hook* 'funcall) ; Should be #'funcall.
549;(queue-fixup (setq *macroexpand-hook* #'funcall)) ;  No it shouldn't.
550
551(defun %symbol-macroexpand-1 (sym env)
552  (if (and env (not (istruct-typep env 'lexical-environment)))
553      (report-bad-arg env 'lexical-environment))
554  (do* ((env env (lexenv.parent-env env)))
555       ((null env))
556    (if (eq (%svref env 0) 'definition-environment)
557        (let* ((info (assq sym (defenv.symbol-macros env))))
558          (if info
559            (return-from %symbol-macroexpand-1 (values (cdr info) t))
560            (return)))
561        (let* ((vars (lexenv.variables env)))
562          (when (consp vars)
563            (let* ((info (dolist (var vars)
564                           (if (eq (var-name var) sym)
565                               (return var)))))           
566              (when info
567                (if (and (consp (setq info (var-expansion info)))
568                         (eq (%car info) :symbol-macro))
569                    (return-from %symbol-macroexpand-1 (values (%cdr info) t))
570                    (return-from %symbol-macroexpand-1 (values sym nil)))))))))
571  ;; Look it up globally.
572  (multiple-value-bind (expansion win) (gethash sym *symbol-macros*)
573    (if win (values expansion t) (values sym nil))))
574
575(defun macroexpand-1 (form &optional env &aux fn)
576  (declare (resident))
577  (if (and (consp form)
578           (symbolp (%car form)))
579    (if (setq fn (macro-function (%car form) env))
580      (values (funcall *macroexpand-hook* fn form env) t)
581      (values form nil))
582    (if (and form (symbolp form))
583      (%symbol-macroexpand-1 form env)
584      (values form nil))))
585
586(defun macroexpand (form &optional env)
587  (declare (resident))
588  (multiple-value-bind (new win) (macroexpand-1 form env)
589    (do* ((won-at-least-once win))
590         ((null win) (values new won-at-least-once))
591      (multiple-value-setq (new win) (macroexpand-1 new env)))))
592
593(defun %symbol-macroexpand (form env &aux win won)
594  ; Keep expanding until no longer a symbol-macro or no longer a symbol.
595  (loop
596    (unless (and form (symbolp form)) (return))
597    (multiple-value-setq (form win) (macroexpand-1 form env))
598    (if win (setq won t) (return)))
599  (values form won))
600
601(defun retain-lambda-expression (name lambda-expression env)
602  (if (and (let* ((lambda-list (cadr lambda-expression)))
603             (and (not (memq '&lap lambda-list))
604                  (not (memq '&method lambda-list))
605                  (not (memq '&lexpr lambda-list))))
606           (nx-declared-inline-p name env)
607           (not (gethash name *nx1-alphatizers*))
608           ; A toplevel definition defined inside a (symbol-)macrolet should
609           ; be inlineable.  It isn't; call DEFINITION-ENVIRONMENT with a
610           ; "clean-only" argument to ensure that there are no lexically
611           ; bound macros or symbol-macros.
612           (definition-environment env t))
613    lambda-expression))
614
615; This is different from AUGMENT-ENVIRONMENT.
616; If "info" is a lambda expression, then
617;  record a cons whose CAR is (encoded-lfun-bits . keyvect) and whose cdr
618;  is the lambda expression iff the function named by "name" is
619;  declared/proclaimed INLINE in env
620(defun note-function-info (name lambda-expression env)
621  (let ((definition-env (definition-environment env)))
622    (if definition-env
623      (let* ((already (assq (setq name (maybe-setf-function-name name))
624                            (defenv.defined definition-env)))
625             (info nil))
626        (when (lambda-expression-p lambda-expression)
627          (multiple-value-bind (lfbits keyvect) (encode-lambda-list lambda-expression t)
628            (setq info (cons (cons lfbits keyvect) 
629                             (retain-lambda-expression name lambda-expression env)))))
630          (if already
631            (if info (%rplacd already info))
632            (push (cons name info) (defenv.defined definition-env)))))
633    name))
634
635; And this is different from FUNCTION-INFORMATION.
636(defun retrieve-environment-function-info (name env)
637 (let ((defenv (definition-environment env)))
638   (if defenv (assq (maybe-setf-function-name name) (defenv.defined defenv)))))
639
640(defun maybe-setf-function-name (name)
641  (if (and (consp name) (eq (car name) 'setf))
642    (setf-function-name (cadr name))
643    name))
644
645; Must differ from -something-, but not sure what ...
646(defun note-variable-info (name info env)
647  (let ((definition-env (definition-environment env)))
648    (if definition-env (push (cons name info) (defenv.specials definition-env)))
649    name))
650
651(defun compile-file-environment-p (env)
652  (let ((defenv (definition-environment env)))
653    (and defenv (eq 'compile-file (car (defenv.type defenv))))))
654
655(defun cheap-eval (form)
656  (cheap-eval-in-environment form nil))
657
658; used by nfcomp too
659; Should preserve order of decl-specs; it sometimes matters.
660(defun decl-specs-from-declarations (declarations)
661  (let ((decl-specs nil))
662    (dolist (declaration declarations decl-specs)
663      ;(unless (eq (car declaration) 'declare) (say "what"))
664      (dolist (decl-spec (cdr declaration))
665        (setq decl-specs (nconc decl-specs (list decl-spec)))))))
666
667(defun cheap-eval-in-environment (form env &aux sym)
668  (declare (resident))
669  (flet ((progn-in-env (body&decls parse-env base-env)
670           (multiple-value-bind (body decls) (parse-body body&decls parse-env)
671             (setq base-env (augment-environment base-env :declare (decl-specs-from-declarations decls)))
672             (while (cdr body)
673               (cheap-eval-in-environment (pop body) base-env))
674             (cheap-eval-in-environment (car body) base-env))))
675    (if form
676      (cond ((symbolp form) 
677             (multiple-value-bind (expansion win) (macroexpand-1 form env)
678               (if win 
679                 (cheap-eval-in-environment expansion env) 
680                 (let* ((defenv (definition-environment env))
681                        (constant (if defenv (assq form (defenv.constants defenv))))
682                        (constval (%cdr constant)))
683                   (if constant
684                     (if (neq (%unbound-marker-8) constval)
685                       constval
686                       (error "Can't determine value of constant symbol ~s" form))
687                     (if (constant-symbol-p form)
688                       (%sym-global-value form)
689                       (symbol-value form)))))))
690            ((atom form) form)
691            ((eq (setq sym (%car form)) 'quote)
692             (verify-arg-count form 1 1)
693             (%cadr form))
694            ((eq sym 'function)
695             (verify-arg-count form 1 1)
696             (cond ((symbolp (setq sym (%cadr form)))
697                    (%function sym))
698                   ((and (consp sym) (eq (%car sym) 'setf) (consp (%cdr sym)) (null (%cddr sym)))
699                    (%function (setf-function-name (%cadr sym))))
700                   (t (%make-function nil sym env))))
701            ((eq sym 'nfunction)
702             (verify-arg-count form 2 2)
703             (%make-function (%cadr form) (%caddr form) env))
704            ((eq sym 'progn) (progn-in-env (%cdr form) env env))
705            ((eq sym 'setq)
706             (if (not (%ilogbitp 0 (list-length form)))
707               (verify-arg-count form 0 0)) ;Invoke a "Too many args" error.
708             (let* ((sym nil)
709                    (val nil))
710               (while (setq form (%cdr form))
711                 (setq sym (require-type (pop form) 'symbol))
712                 (multiple-value-bind (expansion expanded)
713                                      (macroexpand-1 sym env)
714                   (if expanded
715                     (setq val (cheap-eval-in-environment `(setf ,expansion ,(%car form)) env))
716                     (set sym (setq val (cheap-eval-in-environment (%car form) env))))))
717               val))
718            ((eq sym 'eval-when)
719             (destructuring-bind (when . body) (%cdr form)
720               (when (or (memq 'eval when) (memq :execute when)) (progn-in-env body env env))))
721            ((eq sym 'if)
722             (destructuring-bind (test true &optional false) (%cdr form)
723               (cheap-eval-in-environment (if (cheap-eval-in-environment test env) true false) env)))
724            ((eq sym 'locally) (progn-in-env (%cdr form) env env))
725            ((eq sym 'symbol-macrolet)
726             (multiple-value-bind (body decls) (parse-body (cddr form) env)
727               (progn-in-env body env (augment-environment env :symbol-macro (cadr form) :declare (decl-specs-from-declarations decls)))))
728            ((eq sym 'macrolet)
729             (let ((temp-env (augment-environment env
730                                                  :macro 
731                                                  (mapcar #'(lambda (m)
732                                                              (destructuring-bind (name arglist &body body) m
733                                                                (list name (enclose (parse-macro name arglist body env)
734                                                                                    env))))
735                                                          (cadr form)))))
736               (progn-in-env (cddr form) temp-env temp-env)))
737            ((and (symbolp sym) 
738                  (compiler-special-form-p sym)
739                  (not (functionp (fboundp sym))))
740             (if (eq sym 'unwind-protect)
741               (destructuring-bind (protected-form . cleanup-forms) (cdr form)
742                 (unwind-protect
743                   (cheap-eval-in-environment protected-form env)
744                   (progn-in-env cleanup-forms env env)))
745               (funcall (%make-function nil `(lambda () (progn ,form)) env))))
746            ((and (symbolp sym) (macro-function sym env))
747             (if (eq sym 'step)
748               (let ((*compile-definitions* nil))
749                     (cheap-eval-in-environment (macroexpand-1 form env) env))
750               (cheap-eval-in-environment (macroexpand-1 form env) env)))
751            ((or (symbolp sym)
752                 (and (consp sym) (eq (%car sym) 'lambda)))
753             (let ((args nil))
754               (dolist (elt (%cdr form)) (push (cheap-eval-in-environment elt env) args))
755               (apply #'call-check-regs (if (symbolp sym) sym (%make-function nil sym env))
756                      (nreverse args))))
757            (t (signal-simple-condition 'simple-program-error "Car of ~S is not a function name or lambda-expression." form))))))
758
759
760(%fhave 'eval #'cheap-eval)
761
762
763
764 
765(defun call-check-regs (fn &rest args)
766  (declare (dynamic-extent args)
767           (optimize (debug 3)))        ; don't use any saved registers
768  (let ((old-regs (multiple-value-list (get-saved-register-values))))
769    (declare (dynamic-extent old-regs))
770    (multiple-value-prog1 (apply fn args)
771      (let* ((new-regs (multiple-value-list (get-saved-register-values)))
772             (new-regs-tail new-regs))
773        (declare (dynamic-extent new-regs))
774        (unless (dolist (old-reg old-regs t)
775                  (unless (eq old-reg (car new-regs-tail))
776                    (return nil))
777                  (pop new-regs-tail))
778          (apply 'error "Registers clobbered applying ~s to ~s~%~@{~a sb: ~s, Was: ~s~%~}"
779                 fn args
780                 (mapcan 'list
781                         (let ((res nil))
782                           (dotimes (i (length old-regs))
783                             (push (format nil "save~d" i) res))
784                           (nreverse res))
785                         old-regs
786                         new-regs)))))))
787
788
789
790
791
792;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
793;; Stack frame accessors.
794
795; Kinda scant, wouldn't you say ?
796
797
798;end of L1-readloop.lisp
799
Note: See TracBrowser for help on using the repository browser.