source: trunk/source/lib/macros.lisp @ 11285

Last change on this file since 11285 was 11285, checked in by gb, 11 years ago

(SETF (THE TYPE PLACE) VALUE) => (SETF PLACE (THE TYPE VALUE)).

Whether the SETF expander on THE needs to exist or not probably has
to do with whether or not INCF, DECF, and things defined with
DEFINE-MODIFY-MACRO need it to. If it does "need to", it should
probably be fixed.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 148.2 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;;; Macros (and functions/constants used at macroexpand-time) ONLY.
18
19(in-package "CCL")
20
21(eval-when (eval compile)
22  (require "LEVEL-2")
23  (require "BACKQUOTE")
24  (require "DEFSTRUCT-MACROS"))
25
26;; Constants
27
28(defmacro defconstant (sym val &optional (doc () doc-p) &environment env)
29  "Define a global constant, saying that the value is constant and may be
30  compiled into code. If the variable already has a value, and this is not
31  EQL to the new value, the code is not portable (undefined behavior). The
32  third argument is an optional documentation string for the variable."
33  (setq sym (require-type sym 'symbol)
34        doc (if doc-p (require-type doc 'string)))
35  `(progn
36     (eval-when (:compile-toplevel)
37       (define-compile-time-constant ',sym ',val ,env))
38     (eval-when (:load-toplevel :execute)
39       (%defconstant ',sym ,val ,@(if doc-p (list doc))))))
40
41;; Lists
42
43(defmacro %car (x)
44  `(car (the list ,x)))
45
46(defmacro set-%car (x y)
47  `(setf (car (the cons ,x)) ,y))
48
49(defmacro %cdr (x)
50  `(cdr (the list ,x)))
51
52(defmacro set-%cdr (x y)
53  `(setf (cdr (the cons ,x)) ,y))
54
55(defmacro %caar (x)
56 `(%car (%car ,x)))
57
58(defmacro %cadr (x)
59 `(%car (%cdr ,x)))
60
61(defmacro %cdar (x)
62 `(%cdr (%car ,x)))
63
64(defmacro %cddr (x)
65 `(%cdr (%cdr ,x)))
66
67(defmacro %caaar (x)
68 `(%car (%car (%car ,x))))
69
70(defmacro %caadr (x)
71 `(%car (%car (%cdr ,x))))
72
73(defmacro %cadar (x)
74 `(%car (%cdr (%car ,x))))
75
76(defmacro %caddr (x)
77 `(%car (%cdr (%cdr ,x))))
78
79(defmacro %cdaar (x)
80 `(%cdr (%car (%car ,x))))
81
82(defmacro %cdadr (x)
83 `(%cdr (%car (%cdr ,x))))
84
85(defmacro %cddar (x)
86 `(%cdr (%cdr (%car ,x))))
87
88(defmacro %cdddr (x)
89 `(%cdr (%cdr (%cdr ,x))))
90
91(defmacro %rplaca (x y)
92  `(rplaca (the cons ,x) ,y))
93
94(defmacro %rplacd (x y)
95  `(rplacd (the cons ,x) ,y))
96
97; These are open-coded by the compiler to isolate platform
98; dependencies.
99
100(defmacro %unbound-marker-8 ()
101  `(%unbound-marker))
102
103(defmacro %slot-missing-marker ()
104  `(%illegal-marker))
105
106
107
108
109(defmacro %null-ptr () '(%int-to-ptr 0))
110
111;;;Assorted useful macro definitions
112
113(defmacro def-accessors (ref &rest names)
114  (define-accessors ref names))
115
116(defmacro def-accessor-macros (ref &rest names)
117  (define-accessors ref names t))
118
119(defun define-accessors (ref names &optional no-constants
120                             &aux (arg (gensym)) (index 0) progn types)
121  (when (listp ref)
122    (setq types ref
123          ref (pop names)))
124  (dolist (name names)
125    (when name
126      (unless (listp name) (setq name (list name)))
127      (dolist (sym name)
128        (when sym
129          (push `(defmacro ,sym (,arg) (list ',ref ,arg ,index)) progn)
130          (unless no-constants
131            (push `(defconstant ,sym ,index) progn)))))
132    (setq index (1+ index)))
133 `(progn
134    ,.(nreverse progn)
135    ,@(if types `((add-accessor-types ',types ',names)))
136    ,index))
137
138(defmacro specialv (var)
139  `(locally (declare (special ,var)) ,var))
140
141
142(defmacro prog1 (valform &rest otherforms)
143 (let ((val (gensym)))
144 `(let ((,val ,valform))
145   ,@otherforms
146   ,val)))
147
148(defmacro prog2 (first second &rest others)
149 `(progn ,first (prog1 ,second ,@others)))
150
151(defmacro prog (inits &body body &environment env)
152  (multiple-value-bind (forms decls) (parse-body body env nil)
153    `(block nil
154       (let ,inits
155         ,@decls
156         (tagbody ,@forms)))))
157
158(defmacro prog* (inits &body body &environment env)
159  (multiple-value-bind (forms decls) (parse-body body env nil)
160    `(block nil
161       (let* ,inits
162         ,@decls
163         (tagbody ,@forms)))))
164
165
166(defmacro %stack-block ((&rest specs) &body forms &aux vars lets)
167  (dolist (spec specs)
168    (destructuring-bind (var ptr &key clear) spec
169      (push var vars)
170      (push `(,var (%new-ptr ,ptr ,clear)) lets)))
171  `(let* ,(nreverse lets)
172     (declare (dynamic-extent ,@vars))
173     (declare (type macptr ,@vars))
174     (declare (unsettable ,@vars))
175     ,@forms))
176
177(defmacro %vstack-block (spec &body forms)
178  `(%stack-block (,spec) ,@forms))
179
180(defmacro dolist ((varsym list &optional ret) &body body &environment env)
181  (if (not (symbolp varsym)) (signal-program-error $XNotSym varsym))
182  (let* ((toplab (gensym))
183         (tstlab (gensym))
184         (lstsym (gensym)))
185    (multiple-value-bind (forms decls) (parse-body body env nil)
186     `(block nil
187       (let* ((,lstsym ,list) ,varsym)
188        ,@decls
189          (tagbody
190            (go ,tstlab)
191            ,toplab
192            (setq ,lstsym (cdr (the list ,lstsym)))
193            ,@forms
194            ,tstlab
195            (setq ,varsym (car ,lstsym))
196            (if ,lstsym (go ,toplab)))
197          ,@(if ret `((progn  ,ret))))))))
198
199
200(defmacro dovector ((varsym vector &optional ret) &body body &environment env)
201  (if (not (symbolp varsym))(signal-program-error $XNotSym varsym))
202  (let* ((toplab (gensym))
203         (tstlab (gensym))
204         (lengthsym (gensym))
205         (indexsym (gensym))
206         (vecsym (gensym)))
207    (multiple-value-bind (forms decls) (parse-body body env nil)
208     `(let* ((,vecsym ,vector)
209             (,lengthsym (length ,vecsym))
210             (,indexsym 0)
211             ,varsym)
212        ,@decls
213        ,@(let ((type (nx-form-type vector env)))
214            (unless (eq type t)
215              `((declare (type ,type ,vecsym)))))
216        (block nil
217          (tagbody
218            (go ,tstlab)
219            ,toplab
220            (setq ,varsym (locally (declare (optimize (speed 3) (safety 0)))
221                            (aref ,vecsym ,indexsym))
222                  ,indexsym (%i+ ,indexsym 1))
223            ,@forms
224            ,tstlab
225            (if (%i< ,indexsym ,lengthsym) (go ,toplab)))
226          ,@(if ret `((progn (setq ,varsym nil) ,ret))))))))
227
228(defmacro report-bad-arg (&rest args)
229  `(values (%badarg ,@args)))
230
231(defmacro %cons-restart (name action report interactive test)
232 `(%istruct 'restart ,name ,action ,report ,interactive ,test))
233
234(defmacro restart-bind (clauses &body body)
235  "Executes forms in a dynamic context where the given restart bindings are
236   in effect. Users probably want to use RESTART-CASE. When clauses contain
237   the same restart name, FIND-RESTART will find the first such clause."
238  (let* ((restarts (mapcar #'(lambda (clause) 
239                               (list (make-symbol (symbol-name (require-type (car clause) 'symbol)))
240                                     `(%cons-restart nil nil nil nil nil)))
241                           clauses))
242         (bindings (mapcar #'(lambda (clause name)
243                              `(make-restart ,(car name) ',(car clause)
244                                             ,@(cdr clause)))
245                           clauses restarts))
246        (cluster (gensym)))
247    `(let* (,@restarts)
248       (declare (dynamic-extent ,@(mapcar #'car restarts)))
249       (let* ((,cluster (list ,@bindings))
250              (%restarts% (cons ,cluster %restarts%)))
251         (declare (dynamic-extent ,cluster %restarts%))
252         (progn
253           ,@body)))))
254
255(defmacro handler-bind (clauses &body body)
256  "(HANDLER-BIND ( {(type handler)}* )  body)
257   Executes body in a dynamic context where the given handler bindings are
258   in effect. Each handler must take the condition being signalled as an
259   argument. The bindings are searched first to last in the event of a
260   signalled condition."
261  (let* ((fns)
262         (decls)         
263         (bindings (mapcan #'(lambda (clause)
264                               (destructuring-bind (condition handler) clause
265                                 (if (and (consp handler)(eq (car handler) 'function)
266                                          (consp (cadr handler))(eq (car (cadr handler)) 'lambda))
267                                   (let ((fn (gensym)))
268                                     (push `(,fn ,handler) fns)
269                                     (push `(declare (dynamic-extent ,fn)) decls)
270                                     `(',condition ,fn))
271                                   (list `',condition
272                                         `,handler))))
273                           clauses))
274        (cluster (gensym)))   
275    (if (null bindings)
276      `(progn ,@body)
277      `(let* (,@fns
278              (,cluster (list ,@bindings))
279              (%handlers% (cons ,cluster %handlers%)))
280         (declare (dynamic-extent ,cluster %handlers%))
281         ,@decls
282         ,@body))))
283
284(defmacro restart-case (&environment env form &rest clauses)
285  "(RESTART-CASE form
286   {(case-name arg-list {keyword value}* body)}*)
287   The form is evaluated in a dynamic context where the clauses have special
288   meanings as points to which control may be transferred (see INVOKE-RESTART).
289   When clauses contain the same case-name, FIND-RESTART will find the first
290   such clause. If Expression is a call to SIGNAL, ERROR, CERROR or WARN (or
291   macroexpands into such) then the signalled condition will be associated with
292   the new restarts."
293  (let ((cluster nil))
294    (when clauses (setq cluster (gensym) form (restart-case-form form env cluster)))
295    (flet ((restart-case-1 (name arglist &rest forms)
296             (let (interactive report test)
297               (loop
298                 (case (car forms)
299                   (:interactive (setq interactive (cadr forms)))
300                   (:report (setq report (cadr forms)))
301                   (:test (setq test (cadr forms)))
302                   (t (return nil)))
303                 (setq forms (cddr forms)))
304               (when (and report (not (stringp report)))
305                 (setq report `#',report))
306               (when interactive
307                 (setq interactive `#',interactive))
308               (when test
309                 (setq test `#',test))
310               (values (require-type name 'symbol) arglist report interactive test forms))))
311      (cond ((null clauses) form)
312            ((and (null (cdr clauses)) (null (cadr (car clauses))))
313             (let ((block (gensym)) 
314                   (restart-name (gensym)))
315               (multiple-value-bind (name arglist report interactive test body)
316                                    (apply #'restart-case-1 (car clauses))
317                 (declare (ignore arglist))
318                 `(block ,block
319                    (let* ((,restart-name (%cons-restart ',name () ,report ,interactive ,test))
320                           (,cluster (list ,restart-name)))
321                      (declare (dynamic-extent ,restart-name ,cluster))
322                      (catch ,cluster
323                        (let ((%restarts% (cons ,cluster %restarts%)))
324                          (declare (dynamic-extent %restarts%))
325                          (return-from ,block ,form))))
326                    ,@body))))
327            (t
328             (let ((block (gensym)) (val (gensym))
329                   (index -1) restarts restart-names restart-name cases)
330               (while clauses
331                 (setq index (1+ index))
332                 (multiple-value-bind (name arglist report interactive test body)
333                                      (apply #'restart-case-1 (pop clauses))
334                   (push (setq restart-name (make-symbol (symbol-name name))) restart-names)
335                   (push (list restart-name `(%cons-restart ',name ,index ,report ,interactive ,test))
336                         restarts)
337                   (when (null clauses) (setq index t))
338                   (push `(,index (apply #'(lambda ,arglist ,@body) ,val))
339                         cases)))
340               `(block ,block
341                  (let ((,val (let* (,@restarts
342                                     (,cluster (list ,@(reverse restart-names))))
343                                (declare (dynamic-extent ,@restart-names ,cluster))
344                                (catch ,cluster
345                                  (let ((%restarts% (cons ,cluster %restarts%)))
346                                    (declare (dynamic-extent %restarts%))
347                                    (return-from ,block ,form))))))
348                    (case (pop ,val)
349                      ,@(nreverse cases))))))))))
350
351
352; Anything this hairy should die a slow and painful death.
353; Unless, of course, I grossly misunderstand...
354(defun restart-case-form (form env clustername)
355  (let ((expansion (macroexpand form env))
356        (head nil))
357    (if (and (listp expansion)          ; already an ugly hack, made uglier by %error case ...
358             (memq (setq head (pop expansion)) '(signal error cerror warn %error)))
359      (let ((condform nil)
360            (signalform nil)
361            (cname (gensym)))
362        (case head
363          (cerror
364           (destructuring-bind 
365             (continue cond &rest args) expansion
366             (setq condform `(condition-arg ,cond (list ,@args) 'simple-error)
367                   signalform `(cerror ,continue ,cname))))
368          ((signal error warn)
369           (destructuring-bind
370             (cond &rest args) expansion
371             (setq condform `(condition-arg ,cond (list ,@args) ,(if (eq head 'warning)
372                                                                   ''simple-warning
373                                                                   (if (eq head 'error)
374                                                                     ''simple-error
375                                                                     ''simple-condition)))
376                   signalform `(,head ,cname))))
377          (t ;%error
378           (destructuring-bind (cond args fp) expansion
379             (setq condform `(condition-arg ,cond ,args 'simple-error)
380                   signalform `(%error ,cname nil ,fp)))))
381        `(let ((,cname ,condform))
382           (with-condition-restarts ,cname ,clustername
383             ,signalform)))
384      form)))
385     
386
387(defmacro handler-case (form &rest clauses)
388  "(HANDLER-CASE form
389   { (type ([var]) body) }* )
390   Execute FORM in a context with handlers established for the condition
391   types. A peculiar property allows type to be :NO-ERROR. If such a clause
392   occurs, and form returns normally, all its values are passed to this clause
393   as if by MULTIPLE-VALUE-CALL.  The :NO-ERROR clause accepts more than one
394   var specification."
395  (let* ((no-error-clause (assoc :no-error clauses)))
396    (if no-error-clause
397      (let* ((normal-return (gensym))
398             (error-return (gensym)))
399        `(block ,error-return
400          (multiple-value-call #'(lambda ,@(cdr no-error-clause))
401            (block ,normal-return
402              (return-from ,error-return
403                (handler-case (return-from ,normal-return ,form)
404                  ,@(remove no-error-clause clauses)))))))
405      (flet ((handler-case (type var &rest body)
406               (when (eq type :no-error)
407                 (signal-program-error "Duplicate :no-error clause. "))
408           (values type var body)))
409        (cond ((null clauses) form)
410          ((null (cdr clauses))
411           (let ((block   (gensym))
412                 (cluster (gensym)))
413             (multiple-value-bind (type var body)
414                                  (apply #'handler-case (car clauses))
415               (if var
416                 `(block ,block
417                    ((lambda ,var ,@body)
418                      (let* ((,cluster (list ',type)))
419                        (declare (dynamic-extent ,cluster))
420                        (catch ,cluster
421                          (let ((%handlers% (cons ,cluster %handlers%)))
422                            (declare (dynamic-extent %handlers%))
423                            (return-from ,block ,form))))))
424                 `(block ,block
425                    (let* ((,cluster (list ',type)))
426                      (declare (dynamic-extent ,cluster))
427                      (catch ,cluster
428                        (let ((%handlers% (cons ,cluster %handlers%)))
429                          (declare (dynamic-extent %handlers%))
430                          (return-from ,block ,form)))
431                      (locally ,@body)))))))
432          (t (let ((block (gensym)) (cluster (gensym)) (val (gensym))
433                   (index -1) handlers cases)
434               (while clauses
435                 (setq index (1+ index))
436                 (multiple-value-bind (type var body)
437                                      (apply #'handler-case (pop clauses))                   
438                   (push `',type handlers)
439                   (push index handlers)
440                   (when (null clauses) (setq index t))
441                   (push (if var
442                           `(,index ((lambda ,var ,@body) ,val))
443                           `(,index (locally ,@body))) cases)))
444               `(block ,block
445                  (let ((,val (let* ((,cluster (list ,@(nreverse handlers))))
446                                (declare (dynamic-extent ,cluster))
447                                (catch ,cluster
448                                  (let ((%handlers% (cons ,cluster %handlers%)))
449                                    (declare (dynamic-extent %handlers%))
450                                    (return-from ,block ,form))))))
451                    (case (pop ,val)
452                      ,@(nreverse cases)))))))))))
453
454(defmacro with-simple-restart ((restart-name format-string &rest format-args)
455                               &body body
456                               &aux (cluster (gensym)) (temp (make-symbol (symbol-name restart-name))))
457  "(WITH-SIMPLE-RESTART (restart-name format-string format-arguments)
458   body)
459   If restart-name is not invoked, then all values returned by forms are
460   returned. If control is transferred to this restart, it immediately
461   returns the values NIL and T."
462  (unless (and (stringp format-string)
463               (null format-args)
464               (not (%str-member #\~ (ensure-simple-string format-string))))
465    (let ((stream (gensym)))
466      (setq format-string `#'(lambda (,stream) (format ,stream ,format-string ,@format-args)))))
467  `(let* ((,temp (%cons-restart ',restart-name
468                                'simple-restart
469                                ,format-string
470                                nil
471                                nil))
472          (,cluster (list ,temp)))
473     (declare (dynamic-extent ,temp ,cluster))
474     (catch ,cluster
475       (let ((%restarts% (cons ,cluster %restarts%)))
476         (declare (dynamic-extent %restarts%))
477         ,@body))))
478
479;Like with-simple-restart but takes a pre-consed restart.  Not CL.
480(defmacro with-restart (restart &body body &aux (cluster (gensym)))
481  `(let* ((,cluster (list ,restart)))
482     (declare (dynamic-extent ,cluster))
483     (catch ,cluster
484       (let ((%restarts% (cons ,cluster %restarts%)))
485         (declare (dynamic-extent %restarts%))
486         ,@body))))
487
488(defmacro ignore-errors (&rest forms)
489  "Execute FORMS handling ERROR conditions, returning the result of the last
490  form, or (VALUES NIL the-ERROR-that-was-caught) if an ERROR was handled."
491  `(handler-case (progn ,@forms)
492     (error (condition) (values nil condition))))
493
494(defmacro def-kernel-restart (&environment env errno name arglist &body body)
495  (multiple-value-bind (body decls)
496                       (parse-body body env)
497    `(let* ((fn (nfunction ,name (lambda ,arglist ,@decls (block ,name ,@body))))
498            (pair (assq ,errno ccl::*kernel-restarts*)))
499       (if pair
500         (rplacd pair fn)
501         (push (cons ,errno fn) ccl::*kernel-restarts*))
502       fn)))
503
504
505;;; Setf.
506
507;  If you change anything here, be sure to make the corresponding change
508;  in get-setf-method.
509(defmacro setf (&rest args &environment env)
510  "Takes pairs of arguments like SETQ. The first is a place and the second
511  is the value that is supposed to go into that place. Returns the last
512  value. The place argument may be any of the access forms for which SETF
513  knows a corresponding setting form."
514  (let ((temp (length args))
515        (accessor nil))
516    (cond ((eq temp 2)
517           (let* ((form (car args)) 
518                  (value (cadr args)))
519             ;This must match get-setf-method .
520             (cond ((atom form)
521                    (progn
522                      (unless (symbolp form)(signal-program-error $XNotSym form))
523                      `(setq ,form ,value)))
524                   ((eq (car form) 'the)
525                    (unless (eql (length form) 3)
526                      (error "Bad THE place form in (SETF ~S ~S)" form value))
527                    (destructuring-bind (type place) (cdr form)
528                      `(setf ,place (the ,type ,value))))
529                   (t
530                    (multiple-value-bind (ftype local-p)
531                        (function-information (setq accessor (car form)) ENV)
532                      (if local-p
533                        (if (eq ftype :function)
534                                        ;Local function, so don't use global setf definitions.
535                          (default-setf form value env)
536                          `(setf ,(macroexpand-1 form env) ,value))
537                        (cond
538                          ((setq temp (%setf-method accessor))
539                           (if (symbolp temp)
540                             `(,temp ,@(cdar args) ,value)
541                             (multiple-value-bind (dummies vals storevars setter #|getter|#)
542                                 (funcall temp form env)
543                               (do* ((d dummies (cdr d))
544                                     (v vals (cdr v))
545                                     (let-list nil))
546                                    ((null d)
547                                     (setq let-list (nreverse let-list))
548                                     `(let* ,let-list
549                                       (declare (ignorable ,@dummies))
550                                       (multiple-value-bind ,storevars ,value
551                                         #|,getter|#
552                                         ,setter)))
553                                 (push (list (car d) (car v)) let-list)))))
554                          ((and (type-and-refinfo-p (setq temp (or (environment-structref-info accessor env)
555                                                                   (and #-bccl (boundp '%structure-refs%)
556                                                                        (gethash accessor %structure-refs%)))))
557                                (not (refinfo-r/o (if (consp temp) (%cdr temp) temp))))
558                           (if (consp temp)
559                             ;; strip off type, but add in a require-type
560                             (let ((type (%car temp)))
561                               `(the ,type (setf ,(defstruct-ref-transform (%cdr temp) (%cdar args))
562                                            (require-type ,value ',type))))
563                             `(setf ,(defstruct-ref-transform temp (%cdar args))
564                               ,value)))
565                          (t
566                           (multiple-value-bind (res win)
567                               (macroexpand-1 form env)
568                             (if win
569                               `(setf ,res ,value)
570                               (default-setf form value env)))))))))))
571          ((oddp temp)
572           (signal-program-error "Odd number of args to SETF : ~s." args))
573          (t (do* ((a args (cddr a)) (l nil))
574                  ((null a) `(progn ,@(nreverse l)))
575               (push `(setf ,(car a) ,(cadr a)) l))))))
576
577
578(defun default-setf (setter value &optional env)
579  (let* ((reader (car setter))
580         (args (cdr setter))
581         (gensyms (mapcar #'(lambda (sym) (declare (ignore sym)) (gensym)) args))
582         types declares)
583    (flet ((form-type (form)
584             (nx-form-type form env)))
585      (declare (dynamic-extent #'form-type))
586      (setq types (mapcar #'form-type args)))
587    (dolist (sym gensyms)
588      (let ((sym-type (pop types)))
589        (unless (eq sym-type t)
590          (push `(type ,sym-type ,sym) declares))))
591    `(let ,(mapcar #'list gensyms args)
592       ,@(and declares (list `(declare ,@(nreverse declares))))
593       (funcall #'(setf ,reader) ,value ,@gensyms))))
594
595;; Establishing these setf-inverses is something that should
596;; happen at compile-time
597(defsetf elt set-elt)
598(defsetf car set-car)
599(defsetf %car set-%car)
600(defsetf first set-car)
601(defsetf cdr set-cdr)
602(defsetf %cdr set-%cdr)
603(defsetf rest set-cdr)
604(defsetf uvref uvset)
605(defsetf aref aset)
606(defsetf svref svset)
607(defsetf %svref %svset)
608(defsetf char set-char)
609(defsetf schar set-schar)
610(defsetf %scharcode %set-scharcode)
611(defsetf symbol-value set)
612(defsetf symbol-plist set-symbol-plist)
613(defsetf fill-pointer set-fill-pointer)
614
615; This sux; it calls the compiler twice (once to shove the macro in the
616; environment, once to dump it into the file.)
617(defmacro defmacro  (name arglist &body body &environment env)
618  (unless (symbolp name)(signal-program-error $XNotSym name))
619  (unless (listp arglist) (signal-program-error "~S is not a list." arglist))
620  (multiple-value-bind (lambda-form doc)
621                       (parse-macro-1 name arglist body env)
622    (let* ((normalized (normalize-lambda-list arglist t t))
623           (body-pos (position '&body normalized))
624           (argstring (let ((temp nil))
625                        (dolist (arg normalized)
626                          (if (eq arg '&aux)
627                            (return)
628                            (push arg temp)))
629                        (format nil "~:a" (nreverse temp)))))
630      (if (and body-pos (memq '&optional normalized)) (decf body-pos))
631      `(progn
632         (eval-when (:compile-toplevel)
633           (define-compile-time-macro ',name ',lambda-form ',env))
634         (eval-when (:load-toplevel :execute)
635           (%macro 
636            (nfunction ,name ,lambda-form)
637            '(,doc ,body-pos . ,argstring))
638           ',name)))))
639
640(defmacro define-symbol-macro (name expansion &environment env)
641  (unless (symbolp name)(signal-program-error $XNotSym name))
642  `(progn
643    (eval-when (:compile-toplevel)
644      (define-compile-time-symbol-macro ',name ',expansion ',env))
645    (eval-when (:load-toplevel :execute)
646      (%define-symbol-macro ',name ',expansion))))
647
648;; ---- allow inlining setf functions
649(defmacro defun (spec args &body body &environment env &aux global-name inline-spec)
650  "Define a function at top level."
651  (validate-function-name spec)
652  (setq args (require-type args 'list))
653  (setq body (require-type body 'list))
654  (multiple-value-bind (forms decls doc) (parse-body body env t)
655    (cond ((symbolp spec)
656           (setq global-name spec)
657           (setq inline-spec spec)
658           (setq body `(block ,spec ,@forms)))
659          ((and (consp spec) (eq 'setf (%car spec)))
660           (setq inline-spec spec)
661           (setq body `(block ,(cadr spec) ,@forms)))
662          (t (setq body `(progn ,@forms))))
663    (let* ((lambda-expression `(lambda ,args 
664                                ,@(if global-name
665                                    `((declare (global-function-name ,global-name))))
666                                ,@decls ,body))
667           (info (if (and inline-spec
668                          (or (null env)
669                              (definition-environment env t))
670                          (nx-declared-inline-p inline-spec env)
671                          (not (and (symbolp inline-spec)
672                                    (gethash inline-spec *NX1-ALPHATIZERS*))))
673                   (cons doc lambda-expression)
674                   doc)))
675      `(progn
676         (%defun (nfunction ,spec ,lambda-expression) ',info)
677         ',spec))))
678
679(defmacro %defvar-init (var initform doc)
680  `(unless (%defvar ',var ,doc)
681    (set ',var ,initform)))
682
683(defmacro defvar (&environment env var &optional (value () value-p) doc)
684  "Define a global variable at top level. Declare the variable
685  SPECIAL and, optionally, initialize it. If the variable already has a
686  value, the old value is not clobbered. The third argument is an optional
687  documentation string for the variable."
688  (if (and doc (not (stringp doc))) (report-bad-arg doc 'string))
689  (if (and (compile-file-environment-p env) (not *fasl-save-doc-strings*))
690    (setq doc nil))
691 `(progn
692    (eval-when (:compile-toplevel)
693      (note-variable-info ',var ,value-p ,env))
694    ,(if value-p
695       `(%defvar-init ,var ,value ,doc)
696       `(%defvar ',var))
697    ',var))
698         
699(defmacro def-standard-initial-binding (name &optional (form name) (doc nil doc-p) &environment env)
700  `(progn
701    (eval-when (:compile-toplevel)
702      (note-variable-info ',name t ,env))   
703    (define-standard-initial-binding ',name #'(lambda () ,form))
704    ,@(when doc-p
705           `((set-documentation ',name 'variable ,doc)))
706    ',name))
707
708(defmacro defparameter (&environment env var value &optional doc)
709  "Define a parameter that is not normally changed by the program,
710  but that may be changed without causing an error. Declare the
711  variable special and sets its value to VAL, overwriting any
712  previous value. The third argument is an optional documentation
713  string for the parameter."
714  (if (and doc (not (stringp doc))) (signal-program-error "~S is not a string." doc))
715  (if (and (compile-file-environment-p env) (not *fasl-save-doc-strings*))
716    (setq doc nil))
717  `(progn
718     (eval-when (:compile-toplevel)
719       (note-variable-info ',var t ,env))
720     (%defparameter ',var ,value ,doc)))
721
722
723(defmacro defstatic (&environment env var value &optional doc)
724  "Syntax is like DEFPARAMETER.  Proclaims the symbol to be special,
725but also asserts that it will never be given a per-thread dynamic
726binding.  The value of the variable can be changed (via SETQ, etc.),
727but since all threads access the same static binding of the variable,
728such changes should be made with care."
729  (if (and doc (not (stringp doc))) (signal-program-error "~S is not a string." doc))
730  (if (and (compile-file-environment-p env) (not *fasl-save-doc-strings*))
731    (setq doc nil))
732  `(progn
733     (eval-when (:compile-toplevel)
734       (note-variable-info ',var :global ,env))
735     (%defglobal ',var ,value ,doc)))
736
737
738(defmacro defglobal (&rest args)
739  "Synonym for DEFSTATIC."
740  `(defstatic ,@args))
741
742
743(defmacro defloadvar (&environment env var value &optional doc)
744  `(progn
745     (defstatic ,var ,nil ,@(if doc `(,doc)))
746     (def-ccl-pointers ,var ()
747       (setq ,var ,value))
748     ',var))
749
750
751
752
753(defmacro qlfun (name args &body body)
754  `(nfunction ,name (lambda ,args ,@body)))
755
756(defmacro lfun-bits-known-function (f)
757  (let* ((temp (gensym)))
758    `(let* ((,temp (function-to-function-vector ,f)))
759      (%svref ,temp (the fixnum (1- (the fixnum (uvsize ,temp))))))))
760
761(defmacro lfunloop (for var in function &body loop-body)
762  "Loop over immediates in function"
763  (assert (and (or (equal (symbol-name for) "FOR") (equal (symbol-name for) "AS"))
764               (equal (symbol-name in) "IN")))
765  (let ((fn (gensym))
766        (lfv (gensym))
767        (i (gensym)))
768    `(loop with ,fn = ,function
769           with ,lfv = (function-to-function-vector ,fn)
770           for ,i from #+ppc-target 1 #+x86-target (%function-code-words ,fn) below (%i- (uvsize  ,lfv) 1)
771           as ,var = (%svref ,lfv ,i)
772           ,@loop-body)))
773
774(defmacro cond (&rest args &aux clause)
775  (when args
776     (setq clause (car args))
777     (if (cdr clause)         
778         `(if ,(car clause) (progn ,@(cdr clause)) (cond ,@(cdr args)))
779       (if (cdr args) `(or ,(car clause) (cond ,@(cdr args)))
780                      `(values ,(car clause))))))
781
782(defmacro and (&rest args)
783  "And Form*
784AND evaluates each form in sequence, from left to right.  If any form
785returns NIL, AND returns NIL; otherwise, AND returns the values(s) returned
786by the last form.  If there are no forms, AND returns T."
787  (if (null args) t
788    (if (null (cdr args)) (car args)
789      `(if ,(car args) (and ,@(cdr args))))))
790
791(defmacro or (&rest args)
792  "Or Form*
793OR evaluates each Form, in sequence, from left to right.
794If any Form but the last returns a non-NIL value, OR returns that
795single value (without evaluating any subsequent Forms.)  If OR evaluates
796the last Form, it returns all values returned by that Form.  If there
797are no Forms, OR returns NIL."
798  (if args
799    (if (cdr args)
800      (do* ((temp (gensym))
801            (handle (list nil))
802            (forms `(let ((,temp ,(pop args)))
803                     (if ,temp ,temp ,@handle))))
804           ((null (cdr args))
805            (%rplaca handle (%car args))
806            forms)
807        (%rplaca handle `(if (setq ,temp ,(%car args)) 
808                          ,temp 
809                          ,@(setq handle (list nil))))
810        (setq args (%cdr args)))
811      (%car args))))
812
813(defmacro case (key &body forms)
814  "CASE Keyform {({(Key*) | Key} Form*)}*
815  Evaluates the Forms in the first clause with a Key EQL to the value of
816  Keyform. If a singleton key is T then the clause is a default clause."
817   (let ((key-var (gensym)))
818     `(let ((,key-var ,key))
819        (declare (ignorable ,key-var))
820        (cond ,@(case-aux forms key-var nil nil)))))
821
822(defmacro ccase (keyplace &body forms)
823  "CCASE Keyform {({(Key*) | Key} Form*)}*
824  Evaluates the Forms in the first clause with a Key EQL to the value of
825  Keyform. If none of the keys matches then a correctable error is
826  signalled."
827  (let* ((key-var (gensym))
828         (tag (gensym)))
829    `(prog (,key-var)
830       ,tag
831       (setq ,key-var ,keyplace)
832       (return (cond ,@(case-aux forms key-var tag keyplace))))))
833
834(defmacro ecase (key &body forms)
835  "ECASE Keyform {({(Key*) | Key} Form*)}*
836  Evaluates the Forms in the first clause with a Key EQL to the value of
837  Keyform. If none of the keys matches then an error is signalled."
838  (let* ((key-var (gensym)))
839    `(let ((,key-var ,key))
840       (declare (ignorable ,key-var))
841       (cond ,@(case-aux forms key-var 'ecase nil)))))
842       
843(defun case-aux (clauses key-var e-c-p placename &optional (used-keys (list (list '%case-core))))
844  (if clauses
845    (let* ((key-list (caar clauses))
846           (stype (if e-c-p (if (eq e-c-p 'ecase) e-c-p 'ccase) 'case))
847           (test (cond ((and (not e-c-p)
848                             (or (eq key-list 't)
849                                 (eq key-list 'otherwise)))
850                        t)
851                       (key-list
852                        (cons 'or
853                              (case-key-testers key-var used-keys key-list stype)))))
854           (consequent-list (or (%cdar clauses) '(nil))))
855      (if (eq test t)
856        (progn
857          (when (%cdr clauses) (warn "~s or ~s clause in the middle of a ~s statement.  Subsequent clauses ignored."
858                                     't 'otherwise 'case))
859          (cons (cons t consequent-list) nil))
860        (cons (cons test consequent-list)
861              (case-aux (%cdr clauses) key-var e-c-p placename used-keys))))
862    (when e-c-p
863      (setq used-keys `(member ,@(mapcar #'car (cdr used-keys))))
864      (if (eq e-c-p 'ecase)
865        `((t (values (%err-disp #.$XWRONGTYPE ,key-var ',used-keys))))
866        `((t (setf ,placename (ensure-value-of-type ,key-var ',used-keys ',placename))
867           (go ,e-c-p)))))))
868
869
870;;; We don't want to descend list structure more than once (like this has
871;;; been doing for the last 18 years or so.)
872(defun case-key-testers (symbol used-keys atom-or-list statement-type &optional recursive)
873  (if (or recursive (atom atom-or-list))
874    (progn
875      (if (assoc atom-or-list used-keys)
876        (warn "Duplicate keyform ~s in ~s statement." atom-or-list statement-type)
877        (setq used-keys (nconc used-keys (list (cons atom-or-list t)))))
878      `((,(if (typep atom-or-list '(and number (not fixnum)))
879              'eql
880              'eq)
881         ,symbol ',atom-or-list)))
882    (nconc (case-key-testers symbol used-keys (car atom-or-list) statement-type t)
883           (when (cdr atom-or-list)
884             (case-key-testers symbol used-keys (%cdr atom-or-list) statement-type nil)))))
885
886
887; generate the COND body of a {C,E}TYPECASE form
888(defun typecase-aux (key-var clauses &optional e-c-p keyform)
889  (let* ((construct (if e-c-p (if (eq e-c-p 'etypecase) e-c-p 'ctypecase) 'typecase))
890         (types ())
891         (body ())
892         otherwise-seen-p)
893    (flet ((bad-clause (c) 
894             (signal-program-error "Invalid clause ~S in ~S form." c construct)))
895      (dolist (clause clauses)
896        (if (atom clause)
897            (bad-clause clause))
898        (if otherwise-seen-p
899            (signal-program-error "OTHERWISE must be final clause in ~S form." construct))
900        (destructuring-bind (typespec &body consequents) clause
901          (when (eq construct 'typecase)
902            (if (eq typespec 'otherwise)
903                (progn (setq typespec t)
904                       (setq otherwise-seen-p t))))
905          (unless
906              (dolist (already types nil)
907                (when (subtypep typespec already)
908                  (warn "Clause ~S ignored in ~S form - shadowed by ~S ." clause construct (assq already clauses))
909                  (return t)))
910            (push typespec types)
911            (setq typespec `(typep ,key-var ',typespec))
912            (push `(,typespec nil ,@consequents) body))))
913      (when e-c-p
914        (setq types `(or ,@(nreverse types)))
915        (if (eq construct 'etypecase)
916            (push `(t (values (%err-disp #.$XWRONGTYPE ,key-var ',types))) body)
917            (push `(t (setf ,keyform (ensure-value-of-type  ,key-var ',types ',keyform))
918                      (go ,e-c-p)) body))))
919    `(cond ,@(nreverse body))))
920
921(defmacro typecase (keyform &body clauses)
922  "TYPECASE Keyform {(Type Form*)}*
923  Evaluates the Forms in the first clause for which TYPEP of Keyform and Type
924  is true."
925  (let ((key-var (gensym)))
926    `(let ((,key-var ,keyform))
927       (declare (ignorable ,key-var))
928       ,(typecase-aux key-var clauses))))
929
930(defmacro etypecase (keyform &body clauses)
931  "ETYPECASE Keyform {(Type Form*)}*
932  Evaluates the Forms in the first clause for which TYPEP of Keyform and Type
933  is true. If no form is satisfied then an error is signalled."
934  (let ((key-var (gensym)))
935    `(let ((,key-var ,keyform))
936       (declare (ignorable ,key-var))
937       ,(typecase-aux key-var clauses 'etypecase))))
938
939(defmacro ctypecase (keyplace &body clauses)
940  "CTYPECASE Key {(Type Form*)}*
941  Evaluates the Forms in the first clause for which TYPEP of Keyform and Type
942  is true. If no form is satisfied then a correctable error is signalled."
943  (let ((key-var (gensym))
944        (tag (gensym)))
945    `(prog (,key-var)
946       ,tag
947       (setq ,key-var ,keyplace)
948       (return ,(typecase-aux key-var clauses tag keyplace)))))
949
950(defmacro destructuring-bind (lambda-list expression &body body)
951  "Bind the variables in LAMBDA-LIST to the contents of ARG-LIST."
952  (multiple-value-bind (bindings decls)
953      (%destructure-lambda-list  lambda-list expression nil nil)
954    `(let* ,(nreverse bindings)
955      ,@(when decls `((declare ,@decls)))
956      ,@body)))
957
958(defmacro make-destructure-state (tail whole lambda)
959  `(%istruct 'destructure-state ,tail ,whole ,lambda))
960
961
962; This is supposedly ANSI CL.
963(defmacro lambda (&whole lambda-expression (&rest paramlist) &body body)
964  (unless (lambda-expression-p lambda-expression)
965    (warn "Invalid lambda expression: ~s" lambda-expression))
966  `(function (lambda ,paramlist ,@body)))
967
968; This isn't
969(defmacro nlambda (name (&rest arglist) &body body)
970  `(nfunction ,name (lambda ,arglist ,@body)))
971
972(defmacro when (test &body body)
973  "If the first argument is true, the rest of the forms are
974  evaluated as a PROGN."
975 `(if ,test
976   (progn ,@body)))
977
978(defmacro unless (test &body body)
979  "If the first argument is not true, the rest of the forms are
980  evaluated as a PROGN."
981 `(if (not ,test)
982   (progn ,@body)))
983
984(defmacro return (&optional (form nil form-p))
985  `(return-from nil ,@(if form-p `(,form))))
986
987; since they use tagbody, while & until BOTH return NIL
988(defmacro while (test &body body)
989  (let ((testlab (gensym))
990        (toplab (gensym)))
991    `(tagbody
992       (go ,testlab)
993      ,toplab
994      (progn ,@body)
995      ,testlab
996      (when ,test (go ,toplab)))))
997
998(defmacro until (test &body body)
999  (let ((testlab (gensym))
1000        (toplab (gensym)))
1001    `(tagbody
1002       (go ,testlab)
1003      ,toplab
1004      (progn ,@body)
1005      ,testlab
1006      (if (not ,test)
1007        (go ,toplab)))))
1008
1009(defmacro psetq (&whole call &body pairs &environment env)
1010  "PSETQ {var value}*
1011   Set the variables to the values, like SETQ, except that assignments
1012   happen in parallel, i.e. no assignments take place until all the
1013   forms have been evaluated."
1014  (when pairs
1015   (if (evenp (length pairs))
1016     (do* ((l pairs (%cddr l))
1017           (sym (%car l) (%car l)))
1018          ((null l) (%pset pairs))
1019       (unless (symbolp sym) (report-bad-arg sym 'symbol))
1020       (when (nth-value 1 (macroexpand-1 sym env))
1021         (return `(psetf ,@pairs))))
1022     (signal-program-error "Uneven number of args in the call ~S" call))))
1023
1024; generates body for psetq.
1025; "pairs" is a proper list whose length is not odd.
1026(defun %pset (pairs)
1027 (when pairs
1028   (let (vars vals gensyms let-list var val sets)
1029      (loop
1030        (setq var (pop pairs)
1031              val (pop pairs))
1032        (if (null pairs) (return))
1033        (push var vars)
1034        (push val vals)
1035        (push (gensym) gensyms))
1036      (dolist (g gensyms)
1037        (push g sets)
1038        (push (pop vars) sets)
1039        (push (list g (pop vals)) let-list))
1040      (push val sets)
1041      (push var sets)
1042      `(progn
1043         (let ,let-list
1044           (setq ,@sets))
1045         nil))))
1046
1047
1048(eval-when (:compile-toplevel :load-toplevel :execute)
1049(defun do-loop (binder setter env var-init-steps end-test result body)
1050  (let ((toptag (gensym))
1051        (testtag (gensym)))
1052    (multiple-value-bind (forms decls) (parse-body body env nil)
1053      `(block nil
1054         (,binder ,(do-let-vars var-init-steps)
1055                  ,@decls
1056                  (tagbody ; crocks-r-us.
1057                    (go ,testtag)
1058                    ,toptag
1059                    (tagbody
1060                      ,@forms)
1061                    (,setter ,@(do-step-vars var-init-steps))
1062                    ,testtag
1063                    (unless ,end-test
1064                      (go ,toptag)))
1065                  ,@result)))))
1066)
1067
1068(defmacro do (&environment env var-init-steps (&optional end-test &rest result) &body body)
1069  "DO ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form*
1070  Iteration construct. Each Var is initialized in parallel to the value of the
1071  specified Init form. On subsequent iterations, the Vars are assigned the
1072  value of the Step form (if any) in parallel. The Test is evaluated before
1073  each evaluation of the body Forms. When the Test is true, the Exit-Forms
1074  are evaluated as a PROGN, with the result being the value of the DO. A block
1075  named NIL is established around the entire expansion, allowing RETURN to be
1076  used as an alternate exit mechanism."
1077  (do-loop 'let 'psetq env var-init-steps end-test result body))
1078
1079(defmacro do* (&environment env var-init-steps (&optional end-test &rest result) &body body)
1080  "DO* ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form*
1081  Iteration construct. Each Var is initialized sequentially (like LET*) to the
1082  value of the specified Init form. On subsequent iterations, the Vars are
1083  sequentially assigned the value of the Step form (if any). The Test is
1084  evaluated before each evaluation of the body Forms. When the Test is true,
1085  the Exit-Forms are evaluated as a PROGN, with the result being the value
1086  of the DO. A block named NIL is established around the entire expansion,
1087  allowing RETURN to be used as an laternate exit mechanism."
1088  (do-loop 'let* 'setq env var-init-steps end-test result body))
1089
1090
1091(defun do-let-vars (var-init-steps)
1092  (if var-init-steps
1093      (cons (list (do-let-vars-var (car var-init-steps))
1094                  (do-let-vars-init (car var-init-steps)))
1095             (do-let-vars (cdr var-init-steps)))))
1096
1097(defun do-let-vars-var (var-init-step)
1098  (if (consp var-init-step)
1099       (car var-init-step)
1100       var-init-step))
1101
1102(defun do-let-vars-init (var-init-step)
1103   (if (consp var-init-step)
1104        (cadr var-init-step)
1105        nil))
1106
1107(defun do-step-vars (var-init-steps)
1108    (if var-init-steps
1109        (if (do-step-vars-step? (car var-init-steps))
1110             (append (list (do-let-vars-var (car var-init-steps))
1111                           (do-step-vars-step (car var-init-steps)))
1112                     (do-step-vars (cdr var-init-steps)))
1113             (do-step-vars (cdr var-init-steps)))))
1114
1115(defun do-step-vars-step? (var-init-step)
1116  (if (consp var-init-step)
1117       (cddr var-init-step)))
1118
1119(defun do-step-vars-step (var-init-step)
1120  (if (consp var-init-step)
1121       (caddr var-init-step)))
1122
1123
1124(defmacro dotimes ((i n &optional result) &body body &environment env)
1125  (multiple-value-bind (forms decls)
1126                       (parse-body body env)
1127    (if (not (symbolp i))(signal-program-error $Xnotsym i))
1128    (let* ((toptag (gensym))
1129           (limit (gensym)))
1130      `(block nil
1131        (let ((,limit ,n) (,i 0))
1132         ,@decls
1133         (declare (unsettable ,i))
1134           (if (int>0-p ,limit)
1135             (tagbody
1136               ,toptag
1137               ,@forms
1138               (locally
1139                (declare (settable ,i))
1140                (setq ,i (1+ ,i)))
1141               (unless (eql ,i ,limit) (go ,toptag))))
1142           ,result)))))
1143 
1144(defun do-syms-result (var resultform)
1145  (unless (eq var resultform)
1146    (if (and (consp resultform) (not (quoted-form-p resultform)))
1147      `(progn (setq ,var nil) ,resultform)
1148      resultform)))
1149
1150(defun expand-package-iteration-macro (iteration-function var pkg-spec resultform body env)
1151  (multiple-value-bind (body decls) (parse-body body env nil)
1152    (let* ((ftemp (gensym))
1153           (vtemp (gensym))
1154           (ptemp (gensym))
1155           (result (do-syms-result var resultform)))
1156      `(block nil
1157        (let* ((,var nil)
1158               (,ptemp ,pkg-spec))
1159          ,@decls
1160           (flet ((,ftemp (,vtemp) (declare (debugging-function-name nil)) (setq ,var ,vtemp) (tagbody ,@body)))
1161             (declare (dynamic-extent #',ftemp))
1162             (,iteration-function ,ptemp #',ftemp))
1163           ,@(when result `(,result)))))))
1164
1165(defmacro do-symbols ((var &optional pkg result) &body body &environment env)
1166  "DO-SYMBOLS (VAR [PACKAGE [RESULT-FORM]]) {DECLARATION}* {TAG | FORM}*
1167   Executes the FORMs at least once for each symbol accessible in the given
1168   PACKAGE with VAR bound to the current symbol."
1169  (expand-package-iteration-macro 'iterate-over-accessable-symbols var pkg result body env))
1170
1171(defmacro do-present-symbols ((var &optional pkg result) &body body &environment env)
1172  (expand-package-iteration-macro 'iterate-over-present-symbols var pkg result body env))
1173
1174(defmacro do-external-symbols ((var &optional pkg result) &body body &environment env)
1175  "DO-EXTERNAL-SYMBOLS (VAR [PACKAGE [RESULT-FORM]]) {DECL}* {TAG | FORM}*
1176   Executes the FORMs once for each external symbol in the given PACKAGE with
1177   VAR bound to the current symbol."
1178  (expand-package-iteration-macro 'iterate-over-external-symbols var pkg result body env))
1179
1180(defmacro do-all-symbols ((var &optional resultform)
1181                          &body body &environment env)
1182  "DO-ALL-SYMBOLS (VAR [RESULT-FORM]) {DECLARATION}* {TAG | FORM}*
1183   Executes the FORMs once for each symbol in every package with VAR bound
1184   to the current symbol."
1185  (multiple-value-bind (body decls) (parse-body body env nil)
1186    (let* ((ftemp (gensym))
1187           (vtemp (gensym))
1188           (result (do-syms-result var resultform)))
1189      `(block nil
1190        (let* ((,var nil))
1191         ,@decls
1192           (flet ((,ftemp (,vtemp) (declare (debugging-function-name nil)) (setq ,var ,vtemp) (tagbody ,@body)))
1193             (declare (dynamic-extent #',ftemp))
1194             (iterate-over-all-symbols #',ftemp))
1195           ,@(when result `(,result)))))))
1196
1197(defmacro multiple-value-list (form)
1198  `(multiple-value-call #'list ,form))
1199
1200
1201
1202
1203(defmacro %i> (x y)
1204  `(> (the fixnum ,x) (the fixnum ,y)))
1205
1206(defmacro %i< (x y)
1207  `(< (the fixnum ,x) (the fixnum ,y)))
1208
1209(defmacro %i<= (x y)
1210 `(not (%i> ,x ,y)))
1211
1212(defmacro %i>= (x y)
1213 `(not (%i< ,x ,y)))
1214
1215(defmacro bitset (bit number)
1216  `(logior (ash 1 ,bit) ,number))
1217
1218(defmacro bitclr (bit number)
1219  `(logand (lognot (ash 1 ,bit)) ,number))
1220
1221(defmacro bitopf ((op bit place) &environment env)
1222  (multiple-value-bind (vars vals stores store-form access-form)
1223                       (get-setf-method place env)
1224    (let* ((constant-bit-p (constantp bit))
1225           (bitvar (if constant-bit-p bit (gensym))))
1226      `(let ,(unless constant-bit-p `((,bitvar ,bit)))          ; compiler isn't smart enough
1227         (let* ,(mapcar #'list `(,@vars ,@stores) `(,@vals (,op ,bitvar ,access-form)))
1228           ,store-form)))))
1229
1230(defmacro bitsetf (bit place)
1231  `(bitopf (bitset ,bit ,place)))
1232
1233(defmacro bitclrf (bit place)
1234  `(bitopf (bitclr ,bit ,place)))
1235
1236(defmacro %svref (v i)
1237  (let* ((vtemp (make-symbol "VECTOR"))
1238           (itemp (make-symbol "INDEX")))
1239      `(let* ((,vtemp ,v)
1240              (,itemp ,i))
1241         (locally (declare (optimize (speed 3) (safety 0)))
1242           (svref ,vtemp ,itemp)))))
1243
1244(defmacro %svset (v i new &environment env)
1245  (let* ((vtemp (make-symbol "VECTOR"))
1246         (itemp (make-symbol "INDEX"))
1247         (ntemp (make-symbol "NEW")))
1248    `(let* ((,vtemp ,v)
1249            (,itemp ,i)
1250            (,ntemp ,new))
1251      (locally (declare (optimize (speed 3) (safety 0)))
1252        (setf (svref ,vtemp ,itemp) ,ntemp)))))
1253
1254
1255(defmacro %schar (v i)
1256  (let* ((vtemp (make-symbol "STRING"))
1257         (itemp (make-symbol "INDEX")))
1258    `(let* ((,vtemp ,v)
1259            (,itemp ,i))
1260       (locally (declare (optimize (speed 3) (safety 0)))
1261         (schar ,vtemp ,itemp)))))
1262
1263(defmacro %set-schar (v i new)
1264  (let* ((vtemp (make-symbol "STRING"))
1265         (itemp (make-symbol "INDEX"))
1266         (ntemp (make-symbol "NEW")))
1267      `(let* ((,vtemp ,v)
1268              (,itemp ,i)
1269              (,ntemp ,new))
1270         (locally (declare (optimize (speed 3) (safety 0)))
1271           (setf (schar ,vtemp ,itemp) ,ntemp)))))
1272
1273
1274
1275(defmacro %char-code (c) `(char-code (the character ,c)))
1276(defmacro %code-char (i) `(code-char (the (mod 256) ,i)))
1277
1278(defmacro %izerop (x) `(eq ,x 0))
1279(defmacro %iminusp (x) `(< (the fixnum ,x) 0))
1280(defmacro %i+ (&rest (&optional (n0 0) &rest others))
1281  (if others
1282    `(the fixnum (+ (the fixnum ,n0) (%i+ ,@others)))
1283    `(the fixnum ,n0)))
1284(defmacro %i- (x y &rest others) 
1285  (if (not others)
1286    `(the fixnum (- (the fixnum ,x) (the fixnum ,y)))
1287    `(the fixnum (- (the fixnum ,x) (the fixnum (%i+ ,y ,@others))))))
1288
1289
1290(defmacro %i* (x y) `(the fixnum (* (the fixnum ,x) (the fixnum ,y))))
1291
1292(defmacro %ilogbitp (b i)
1293  (target-word-size-case
1294   (32
1295    `(logbitp (the (integer 0 29) ,b) (the fixnum ,i)))
1296   (64
1297    `(logbitp (the (integer 0 60) ,b) (the fixnum ,i)))))
1298
1299;;; Seq-Dispatch does an efficient type-dispatch on the given Sequence.
1300
1301(defmacro seq-dispatch (sequence list-form array-form)
1302  `(if (sequence-type ,sequence)
1303       ,list-form
1304       ,array-form))
1305
1306
1307(defsetf %get-byte %set-byte)
1308(defsetf %get-unsigned-byte %set-unsigned-byte)
1309(defsetf %get-signed-byte %set-byte)
1310(defsetf %get-word %set-word)
1311(defsetf %get-signed-word %set-word)
1312(defsetf %get-unsigned-word %set-unsigned-word)
1313(defsetf %get-long %set-long)
1314(defsetf %get-signed-long %set-long)
1315(defsetf %get-unsigned-long %set-unsigned-long)
1316(defsetf %get-full-long %set-long)
1317(defsetf %get-point %set-long)
1318(defsetf %get-ptr %set-ptr)
1319(defsetf %get-double-float %set-double-float)
1320(defsetf %get-single-float %set-single-float)
1321(defsetf %get-bit %set-bit)
1322(defsetf %get-unsigned-long-long %set-unsigned-long-long)
1323(defsetf %%get-unsigned-longlong %%set-unsigned-longlong)
1324(defsetf %get-signed-long-long %set-signed-long-long)
1325(defsetf %%get-signed-longlong %%set-signed-longlong)
1326(defsetf %get-bitfield %set-bitfield)
1327
1328(defmacro %ilognot (int) `(%i- -1 ,int))
1329
1330(defmacro %ilogior2 (x y) 
1331  `(logior (the fixnum ,x) (the fixnum ,y)))
1332
1333(defmacro %ilogior (body &body args)
1334   (while args
1335     (setq body (list '%ilogior2 body (pop args))))
1336   body)
1337
1338(defmacro %ilogand2 (x y)
1339  `(logand (the fixnum ,x) (the fixnum ,y)))
1340
1341(defmacro %ilogand (body &body args)
1342   (while args
1343     (setq body (list '%ilogand2 body (pop args))))
1344   body)
1345
1346(defmacro %ilogxor2 (x y)
1347  `(logxor (the fixnum ,x) (the fixnum ,y)))
1348
1349(defmacro %ilogxor (body &body args)
1350   (while args
1351     (setq body (list '%ilogxor2 body (pop args))))
1352   body)
1353
1354(defmacro with-macptrs (varlist &rest body &environment env)
1355  (multiple-value-bind (body other-decls) (parse-body body env)
1356    (collect ((temp-bindings)
1357              (temp-decls)
1358              (bindings)
1359              (our-decls)
1360              (inits))
1361      (dolist (var varlist)
1362        (let* ((temp (gensym)))
1363          (temp-decls temp)
1364        (if (consp var)
1365          (progn
1366            (our-decls (car var))
1367            (temp-bindings `(,temp (%null-ptr)))
1368            (bindings `(,(car var) ,temp))
1369            (if (cdr var)
1370              (inits `(%setf-macptr ,temp ,@(cdr var)))))
1371          (progn
1372            (our-decls var)
1373            (temp-bindings  `(,temp  (%null-ptr)))
1374            (bindings `(,var ,temp))))))
1375  `(let* ,(temp-bindings)
1376    (declare (dynamic-extent ,@(temp-decls)))
1377    (declare (type macptr ,@(temp-decls)))
1378    ,@(inits)
1379    (let* ,(bindings)
1380      (declare (type macptr ,@(our-decls)))
1381      ,@other-decls
1382      ,@body)))))
1383
1384
1385(defmacro with-loading-file (filename &rest body)
1386   `(let ((*loading-files* (cons ,filename (locally (declare (special *loading-files*))
1387                                                    *loading-files*))))
1388      (declare (special *loading-files*))
1389      ,@body))
1390
1391(defmacro with-input-from-string ((var string &key index start end) &body forms &environment env)
1392  "Create an input string stream, provide an opportunity to perform
1393operations on the stream (returning zero or more values), and then close
1394the string stream.
1395
1396STRING is evaluated first, and VAR is bound to a character input string
1397stream that supplies characters from the subsequence of the resulting
1398string bounded by start and end. BODY is executed as an implicit progn."
1399  (multiple-value-bind (forms decls) (parse-body forms env nil)
1400    `(let ((,var
1401            ,(cond ((null end)
1402                    `(make-string-input-stream ,string ,(or start 0)))
1403                   ((symbolp end)
1404                    `(if ,end
1405                      (make-string-input-stream ,string ,(or start 0) ,end)
1406                      (make-string-input-stream ,string ,(or start 0))))
1407                   (t
1408                    `(make-string-input-stream ,string ,(or start 0) ,end)))))
1409      ,@decls
1410      (unwind-protect
1411           (multiple-value-prog1
1412               (progn ,@forms)
1413             ,@(if index `((setf ,index (string-input-stream-index ,var)))))
1414        (close ,var)))))
1415
1416(defmacro with-output-to-string ((var &optional string &key (element-type 'base-char element-type-p))
1417                                 &body body 
1418                                 &environment env)
1419  "Create a character output stream, perform a series of operations that
1420may send results to this stream, and then close the stream.  BODY is
1421executed as an implicit progn with VAR bound to an output string stream.
1422All output to that string stream is saved in a string."
1423  (let ((string-var (gensym "string")))
1424    (multiple-value-bind (forms decls) (parse-body body env nil)
1425      `(let* ((,string-var ,string)
1426              (,var (if ,string-var
1427                      ,@(if element-type-p
1428                            `((progn
1429                                ,element-type
1430                                (%make-string-output-stream ,string-var)))
1431                            `((%make-string-output-stream ,string-var)))
1432                      ,@(if element-type-p
1433                            `((make-string-output-stream :element-type ,element-type))
1434                            `((make-string-output-stream))))))
1435         ,@decls
1436         (unwind-protect
1437              (progn
1438                ,@forms
1439                ,@(if string () `((get-output-stream-string ,var))))
1440           (close ,var))))))
1441
1442(defmacro with-output-to-truncating-string-stream ((var len) &body body
1443                                                   &environment env)
1444  (multiple-value-bind (forms decls) (parse-body body env nil)
1445    `(let* ((,var (make-truncating-string-stream ,len)))
1446      ,@decls
1447      (unwind-protect
1448           (progn
1449             ,@forms
1450             (values (get-output-stream-string ,var)
1451                     (slot-value ,var 'truncated)))
1452        (close ,var)))))
1453
1454(defmacro with-open-file ((var . args) &body body &aux (stream (gensym))(done (gensym)))
1455  "Use open to create a file stream to file named by filespec. Filespec is
1456the name of the file to be opened. Options are used as keyword arguments
1457to open."
1458  `(let (,stream ,done)
1459     (unwind-protect
1460       (multiple-value-prog1
1461         (let ((,var (setq ,stream (open ,@args))))
1462           ,@body)
1463         (setq ,done t))
1464       (when ,stream (close ,stream :abort (null ,done))))))
1465
1466(defmacro with-compilation-unit ((&key override) &body body)
1467  "WITH-COMPILATION-UNIT ({Key Value}*) Form*
1468  This form affects compilations that take place within its dynamic extent. It
1469  is intended to be wrapped around the compilation of all files in the same
1470  system. These keywords are defined:
1471    :OVERRIDE Boolean-Form
1472        One of the effects of this form is to delay undefined warnings
1473        until the end of the form, instead of giving them at the end of each
1474        compilation. If OVERRIDE is NIL (the default), then the outermost
1475        WITH-COMPILATION-UNIT form grabs the undefined warnings. Specifying
1476        OVERRIDE true causes that form to grab any enclosed warnings, even if
1477        it is enclosed by another WITH-COMPILATION-UNIT."
1478  `(flet ((with-compilation-unit-body ()
1479            ,@body))
1480     (declare (dynamic-extent #'with-compilation-unit-body))
1481     (call-with-compilation-unit #'with-compilation-unit-body :override ,override)))
1482
1483; Yow! Another Done Fun.
1484(defmacro with-standard-io-syntax (&body body &environment env)
1485  "Bind the reader and printer control variables to values that enable READ
1486   to reliably read the results of PRINT. These values are:
1487       *PACKAGE*                        the COMMON-LISP-USER package
1488       *PRINT-ARRAY*                    T
1489       *PRINT-BASE*                     10
1490       *PRINT-CASE*                     :UPCASE
1491       *PRINT-CIRCLE*                   NIL
1492       *PRINT-ESCAPE*                   T
1493       *PRINT-GENSYM*                   T
1494       *PRINT-LENGTH*                   NIL
1495       *PRINT-LEVEL*                    NIL
1496       *PRINT-LINES*                    NIL
1497       *PRINT-MISER-WIDTH*              NIL
1498       *PRINT-PRETTY*                   NIL
1499       *PRINT-RADIX*                    NIL
1500       *PRINT-READABLY*                 T
1501       *PRINT-RIGHT-MARGIN*             NIL
1502       *READ-BASE*                      10
1503       *READ-DEFAULT-FLOAT-FORMAT*      SINGLE-FLOAT
1504       *READ-EVAL*                      T
1505       *READ-SUPPRESS*                  NIL
1506       *READTABLE*                      the standard readtable"
1507  (multiple-value-bind (decls body) (parse-body body env)
1508    `(let ((*package* (pkg-arg "COMMON-LISP-USER"))
1509           (*print-array* t)
1510           (*print-base* 10.)
1511           (*print-case* :upcase)
1512           (*print-circle* nil)
1513           (*print-escape* t)
1514           (*print-gensym* t)
1515           (*print-length* nil)
1516           (*print-level* nil)
1517           (*print-lines* nil) ; This doesn't exist as of 5/15/90 - does now
1518           (*print-miser-width* nil)
1519           (*print-pprint-dispatch* nil)
1520           (*print-pretty* nil)
1521           (*print-radix* nil)
1522           (*print-readably* t)
1523           (*print-right-margin* nil)
1524           (*read-base* 10.)
1525           (*read-default-float-format* 'single-float)
1526           (*read-eval* t) ; Also MIA as of 5/15/90
1527           (*read-suppress* nil)
1528           (*readtable* %initial-readtable%))
1529       ,@decls
1530       ,@body)))
1531
1532(defmacro with-self-bound-io-control-vars (&body body)
1533  `(let (
1534         (*print-array* *print-array*)
1535         (*print-base* *print-base*)
1536         (*print-case* *print-case*)
1537         (*print-circle* *print-circle*)
1538         (*print-escape* *print-escape*)
1539         (*print-gensym* *print-gensym*)
1540         (*print-length* *print-length*)
1541         (*print-level* *print-level*)
1542         (*print-lines* *print-lines*)
1543         (*print-miser-width* *print-miser-width*)
1544         (*print-pprint-dispatch* *print-pprint-dispatch*)
1545         (*print-pretty* *print-pretty*)
1546         (*print-radix* *print-radix*)
1547         (*print-readably* *print-readably*)
1548         (*print-right-margin* *print-right-margin*)
1549         (*read-base* *read-base*)
1550         (*read-default-float-format* *read-default-float-format*)
1551         (*read-eval* *read-eval*)
1552         (*read-suppress* *read-suppress*)
1553         (*readtable* *readtable*))
1554     ,@body))
1555
1556(defmacro print-unreadable-object (&environment env (object stream &key type identity) &body forms)
1557  "Output OBJECT to STREAM with \"#<\" prefix, \">\" suffix, optionally
1558  with object-type prefix and object-identity suffix, and executing the
1559  code in BODY to provide possible further output."
1560  (multiple-value-bind (body decls) (parse-body forms env)
1561    (if body
1562      (let ((thunk (gensym)))
1563        `(let ((,thunk #'(lambda () ,@decls ,@body)))
1564           (declare (dynamic-extent ,thunk))
1565          (%print-unreadable-object ,object ,stream ,type ,identity ,thunk)))
1566      `(%print-unreadable-object ,object ,stream ,type ,identity nil))))
1567;; Pointers and Handles
1568
1569;;Add function to lisp system pointer functions, and run it if it's not already
1570;; there.
1571(defmacro def-ccl-pointers (name arglist &body body &aux (old (gensym)))
1572  `(flet ((,name ,arglist ,@body))
1573     (let ((,old (member ',name *lisp-system-pointer-functions* :key #'function-name)))
1574       (if ,old
1575         (rplaca ,old #',name)
1576         (progn
1577           (push #',name *lisp-system-pointer-functions*)
1578           (,name))))))
1579
1580(defmacro def-load-pointers (name arglist &body body &aux (old (gensym)))
1581  `(flet ((,name ,arglist ,@body))
1582     (let ((,old (member ',name *lisp-user-pointer-functions* :key #'function-name)))
1583       (if ,old
1584         (rplaca ,old #',name)
1585         (progn
1586           (push #',name *lisp-user-pointer-functions*)
1587           (,name))))))
1588
1589;Queue up some code to run after ccl all loaded up, or, if ccl is already
1590;loaded up, just run it right now.
1591(defmacro queue-fixup (&rest body &aux (fn (gensym)))
1592  `(let ((,fn #'(lambda () ,@body)))
1593     (if (eq %lisp-system-fixups% T)
1594       (funcall ,fn)
1595       (push (cons ,fn *loading-file-source-file*) %lisp-system-fixups%))))
1596
1597(defmacro %incf-ptr (p &optional (by 1))
1598  (if (symbolp p)  ;once-only
1599    `(%setf-macptr (the macptr ,p) (%inc-ptr ,p ,by))
1600    (let ((var (gensym)))
1601      `(let ((,var ,p)) (%setf-macptr (the macptr ,var) (%inc-ptr ,var ,by))))))
1602
1603(defmacro with-string-from-cstring ((s ptr) &body body)
1604  (let* ((len (gensym))
1605         (p (gensym)))
1606    `(let* ((,p ,ptr)
1607            (,len (%cstrlen ,p))
1608            (,s (make-string ,len)))
1609      (declare (fixnum ,len))
1610      (%copy-ptr-to-ivector ,p 0 ,s 0 ,len)
1611      (locally
1612          ,@body))))
1613
1614
1615(defmacro with-cstr ((sym str &optional start end) &rest body &environment env)
1616  (multiple-value-bind (body decls) (parse-body body env nil)
1617    (if (and (base-string-p str) (null start) (null end))
1618      (let ((strlen (%i+ (length str) 1)))
1619        `(%stack-block ((,sym ,strlen))
1620           ,@decls
1621           (%cstr-pointer ,str ,sym)
1622           ,@body))
1623      (let ((strname (gensym))
1624            (start-name (gensym))
1625            (end-name (gensym)))
1626        `(let ((,strname ,str)
1627               ,@(if (or start end)
1628                   `((,start-name ,(or start 0))
1629                     (,end-name ,(or end `(length ,strname))))))
1630           (%vstack-block (,sym
1631                           (the fixnum
1632                             (1+
1633                              (the fixnum
1634                                ,(if (or start end)
1635                                     `(byte-length
1636                                       ,strname ,start-name ,end-name)
1637                                     `(length ,strname))))))
1638             ,@decls
1639             ,(if (or start end)
1640                `(%cstr-segment-pointer ,strname ,sym ,start-name ,end-name)
1641                `(%cstr-pointer ,strname ,sym))
1642             ,@body))))))
1643
1644(defmacro with-utf-8-cstr ((sym str) &body body)
1645  (let* ((data (gensym))
1646         (offset (gensym))
1647         (string (gensym))
1648         (len (gensym))
1649         (noctets (gensym))
1650         (end (gensym)))
1651    `(let* ((,string ,str)
1652            (,len (length ,string)))
1653      (multiple-value-bind (,data ,offset) (array-data-and-offset ,string)
1654        (let* ((,end (+ ,offset ,len))
1655               (,noctets (utf-8-octets-in-string ,data ,offset ,end)))
1656          (%stack-block ((,sym (1+ ,noctets)))
1657            (utf-8-memory-encode ,data ,sym 0 ,offset ,end)
1658            (setf (%get-unsigned-byte ,sym ,noctets) 0)
1659            ,@body))))))
1660
1661
1662
1663(defmacro with-native-utf-16-cstr ((sym str) &body body)
1664  (let* ((data (gensym))
1665         (offset (gensym))
1666         (string (gensym))
1667         (len (gensym))
1668         (noctets (gensym))
1669         (end (gensym)))
1670    `(let* ((,string ,str)
1671            (,len (length ,string)))
1672      (multiple-value-bind (,data ,offset) (array-data-and-offset ,string)
1673        (let* ((,end (+ ,offset ,len))
1674               (,noctets (utf-16-octets-in-string ,data ,offset ,end)))
1675          (%stack-block ((,sym (1+ ,noctets)))
1676            (native-utf-16-memory-encode ,data ,sym 0 ,offset ,end)
1677            (setf (%get-unsigned-word ,sym ,noctets) 0)
1678            ,@body))))))
1679
1680(defmacro with-pointers (speclist &body body)
1681   (with-specs-aux 'with-pointer speclist body))
1682
1683
1684
1685(defmacro with-cstrs (speclist &body body)
1686   (with-specs-aux 'with-cstr speclist body))
1687
1688(defmacro with-utf-8-cstrs (speclist &body body)
1689   (with-specs-aux 'with-utf-8-cstr speclist body))
1690
1691(defmacro with-native-utf-16-cstrs (speclist &body body)
1692  (with-specs-aux 'with-native-utf-16-cstr speclist body))
1693
1694(defmacro with-encoded-cstr ((encoding-name (sym string &optional start end))
1695                             &rest body &environment env)
1696  (let* ((encoding (gensym))
1697         (str (gensym)))
1698      (multiple-value-bind (body decls) (parse-body body env nil)
1699        `(let* ((,str ,string)
1700                (,encoding (get-character-encoding ,encoding-name)))
1701          (%stack-block ((,sym (cstring-encoded-length-in-bytes ,encoding ,str ,start ,end) :clear t))
1702            ,@decls
1703            (encode-string-to-memory ,encoding ,sym 0 ,str ,start ,end)
1704            ,@body)))))
1705
1706(defmacro with-encoded-cstrs (encoding-name bindings &body body)
1707  (with-specs-aux 'with-encoded-cstr (mapcar #'(lambda (b)
1708                                                 `(,encoding-name ,b))
1709                                             bindings) body))
1710
1711(defmacro with-filename-cstrs (&rest rest)
1712  (case (target-os-name)
1713    (:darwin `(with-utf-8-cstrs ,@rest))
1714    (:windows `(with-native-utf-16-cstrs ,@rest))
1715    (t `(with-encoded-cstrs (pathname-encoding-name) ,@rest))))
1716
1717
1718(defun with-specs-aux (name spec-list original-body)
1719  (multiple-value-bind (body decls) (parse-body original-body nil)
1720    (when decls (signal-program-error "declarations not allowed in ~s" original-body))
1721    (setq body (cons 'progn body))
1722    (dolist (spec (reverse spec-list))
1723      (setq body (list name spec body)))
1724    body))
1725
1726
1727(defmacro type-predicate (type)
1728  `(get-type-predicate ,type))
1729
1730(defsetf type-predicate set-type-predicate)
1731
1732(defun adjust-defmethod-lambda-list (ll)
1733  ;; If the lambda list contains &key, ensure that it also contains
1734  ;; &allow-other-keys
1735  (if (or (not (memq '&key ll))
1736          (memq '&allow-other-keys ll))
1737    ll
1738    (if (memq '&aux ll)
1739      (let* ((ll (copy-list ll))
1740             (aux (memq '&aux ll)))
1741        (setf (car aux) '&allow-other-keys
1742              (cdr aux) (cons '&aux (cdr aux)))
1743        ll)
1744      (append ll '(&allow-other-keys)))))
1745
1746(defun encode-gf-lambda-list (lambda-list)
1747  (let* ((bits (encode-lambda-list lambda-list)))
1748    (declare (fixnum bits))
1749    (if (logbitp $lfbits-keys-bit bits)
1750      (logior bits (ash 1 $lfbits-aok-bit))
1751      bits)))
1752
1753(defmacro defmethod (name &rest args &environment env)
1754  (multiple-value-bind (function-form specializers-form qualifiers lambda-list documentation specializers)
1755      (parse-defmethod name args env)
1756    `(progn
1757       (eval-when (:compile-toplevel)
1758         (record-function-info ',(maybe-setf-function-name name)
1759                               ',(%cons-def-info 'defmethod (encode-gf-lambda-list lambda-list) nil nil
1760                                                 specializers qualifiers)
1761                               ,env))
1762       (compiler-let ((*nx-method-warning-name* '(,name ,@qualifiers ,specializers)))
1763         (ensure-method ',name ,specializers-form
1764                        :function ,function-form
1765                        :qualifiers ',qualifiers
1766                        :lambda-list ',lambda-list
1767                        ,@(if documentation `(:documentation ,documentation)))))))
1768
1769
1770(defun seperate-defmethod-decls (decls)
1771  (let (outer inner)
1772    (dolist (decl decls)
1773      (if (neq (car decl) 'declare)
1774        (push decl outer)
1775        (let (outer-list inner-list)
1776          (dolist (d (cdr decl))
1777            (if (and (listp d) (eq (car d) 'dynamic-extent))
1778              (let (in out)
1779                (dolist (fspec (cdr d))
1780                  (if (and (listp fspec)
1781                           (eq (car fspec) 'function)
1782                           (listp (cdr fspec))
1783                           (null (cddr fspec))
1784                           (memq (cadr fspec) '(call-next-method next-method-p)))
1785                    (push fspec in)
1786                    (push fspec out)))
1787                (when out
1788                  (push `(dynamic-extent ,@(nreverse out)) outer-list))
1789                (when in
1790                  (push `(dynamic-extent ,@(nreverse in)) inner-list)))
1791              (push d outer-list)))
1792          (when outer-list
1793            (push `(declare ,@(nreverse outer-list)) outer))
1794          (when inner-list
1795            (push `(declare ,@(nreverse inner-list)) inner)))))
1796    (values (nreverse outer) (nreverse inner))))
1797                   
1798
1799(defvar *warn-about-unreferenced-required-args-in-methods* #+ccl-0711 nil #-ccl-0711 T)
1800
1801(defun parse-defmethod (name args env)
1802  (validate-function-name name)
1803  (let (qualifiers lambda-list parameters specializers specializers-form refs types temp)
1804    (until (listp (car args))
1805      (push (pop args) qualifiers))
1806    (setq lambda-list (pop args))
1807    (while (and lambda-list (not (memq (car lambda-list) lambda-list-keywords)))
1808      (let ((p (pop lambda-list)))
1809        (cond ((consp p)
1810               (unless (and (consp (%cdr p)) (null (%cddr p)))
1811                 (signal-program-error "Illegal arg ~S" p))
1812               (push (%car p) parameters)
1813               (push (%car p) refs)
1814               (setq p (%cadr p))
1815               (cond ((and (consp p) (eq (%car p) 'eql)
1816                           (consp (%cdr p)) (null (%cddr p)))
1817                      (push `(list 'eql ,(%cadr p)) specializers-form)
1818                      (push p specializers))
1819                     ((or (setq temp (non-nil-symbol-p p))
1820                          (specializer-p p))
1821                      (push `',p specializers-form)
1822                      (push p specializers)
1823                      (unless (or (eq p t) (not temp))
1824                        ;Should be `(guaranteed-type ...).
1825                        (push `(type ,p ,(%car parameters)) types)))
1826                     (t (signal-program-error "Illegal arg ~S" p))))
1827              (t
1828               (push p parameters)
1829               (unless *warn-about-unreferenced-required-args-in-methods*
1830                 (push p refs))
1831               (push t specializers-form)
1832               (push t specializers)))))
1833    (setq lambda-list (nreconc parameters lambda-list))
1834    (multiple-value-bind (body decls doc) (parse-body args env t)
1835      (multiple-value-bind (outer-decls inner-decls) 
1836                           (seperate-defmethod-decls decls)
1837        (let* ((methvar (make-symbol "NEXT-METHOD-CONTEXT"))
1838               (cnm-args (gensym))
1839               (lambda-form `(lambda ,(list* '&method methvar lambda-list)
1840                               (declare ;,@types
1841                                (ignorable ,@refs))
1842                               ,@outer-decls
1843                               (block ,(if (consp name) (cadr name) name)
1844                                 (flet ((call-next-method (&rest ,cnm-args)
1845                                          (declare (dynamic-extent ,cnm-args))
1846                                          (if ,cnm-args
1847                                            (apply #'%call-next-method-with-args ,methvar ,cnm-args)
1848                                            (%call-next-method ,methvar)))
1849                                        (next-method-p () (%next-method-p ,methvar)))
1850                                   (declare (inline call-next-method next-method-p))
1851                                   ,@inner-decls
1852                                   ,@body)))))
1853          (values
1854           (if name `(nfunction ,name ,lambda-form) `(function ,lambda-form))
1855           `(list ,@(nreverse specializers-form))
1856           (nreverse qualifiers)
1857           lambda-list
1858           doc
1859           (nreverse specializers)))))))
1860
1861(defmacro anonymous-method (name &rest args &environment env)
1862  (multiple-value-bind (function-form specializers-form qualifiers method-class documentation)
1863                       (parse-defmethod name args env)
1864   
1865    `(%anonymous-method
1866      ,function-form
1867      ,specializers-form
1868      ',qualifiers
1869      ,@(if (or method-class documentation) `(',method-class))
1870      ,@(if documentation `(,documentation)))))
1871
1872
1873
1874(defmacro defclass (class-name superclasses slots &rest class-options &environment env)
1875  (flet ((duplicate-options (where) (signal-program-error "Duplicate options in ~S" where))
1876         (illegal-option (option) (signal-program-error "Illegal option ~s" option))
1877         (make-initfunction (form)
1878           (cond ((or (eq form 't)
1879                      (equal form ''t))
1880                  '(function true))
1881                 ((or (eq form 'nil)
1882                      (equal form ''nil))
1883                  '(function false))
1884                 (t
1885                  `(function (lambda () ,form))))))
1886    (setq class-name (require-type class-name '(and symbol (not null))))
1887    (setq superclasses (mapcar #'(lambda (s) (require-type s 'symbol)) superclasses))
1888    (let* ((options-seen ())
1889           (signatures ())
1890           (slot-names))
1891      (flet ((canonicalize-defclass-option (option)
1892               (let* ((option-name (car option)))
1893                 (if (member option-name options-seen :test #'eq)
1894                   (duplicate-options class-options)
1895                   (push option-name options-seen))
1896                 (case option-name
1897                   (:default-initargs
1898                       (let ((canonical ())
1899                             (initargs-seen ()))
1900                         (let (key val (tail (cdr option)))
1901                           (loop (when (null tail) (return nil))
1902                              (setq key (pop tail)
1903                                    val (pop tail))
1904                              (when (memq key initargs-seen)
1905                                (SIGNAL-PROGRAM-error "Duplicate initialization argument name ~S in :DEFAULT-INITARGS of DEFCLASS ~S" key class-name))
1906                              (push key initargs-seen)
1907                              (push ``(,',key ,',val  ,,(make-initfunction val)) canonical))
1908                           `(':direct-default-initargs (list ,@(nreverse canonical))))))
1909                   (:metaclass
1910                    (unless (and (cadr option)
1911                                 (typep (cadr option) 'symbol))
1912                      (illegal-option option))
1913                    `(:metaclass  ',(cadr option)))
1914                   (:documentation
1915                    `(:documentation ',(cadr option)))
1916                   (t
1917                     (list `',option-name `',(cdr option))))))
1918             (canonicalize-slot-spec (slot)
1919               (if (null slot) (signal-program-error "Illegal slot NIL"))
1920               (if (not (listp slot)) (setq slot (list slot)))
1921               (let* ((slot-name (require-type (car slot) 'symbol))
1922                      (initargs nil)
1923                      (other-options ())
1924                      (initform nil)
1925                      (initform-p nil)
1926                      (initfunction nil)
1927                      (type nil)
1928                      (type-p nil)
1929                      (allocation nil)
1930                      (allocation-p nil)
1931                      (documentation nil)
1932                      (documentation-p nil)
1933                      (readers nil)
1934                      (writers nil)
1935                      (reader-info (%cons-def-info 'defmethod (dpb 1 $lfbits-numreq 0) nil nil (list class-name)))
1936                      (writer-info (%cons-def-info 'defmethod (dpb 2 $lfbits-numreq 0) nil nil (list t class-name))))
1937                 (when (memq slot-name slot-names)
1938                   (SIGNAL-PROGRAM-error "Multiple slots named ~S in DEFCLASS ~S" slot-name class-name))
1939                 (push slot-name slot-names)
1940                 (do ((options (cdr slot) (cddr options))
1941                      name)
1942                     ((null options))
1943                   (when (null (cdr options)) (signal-program-error "Illegal slot spec ~S" slot))
1944                   (case (car options)
1945                     (:reader
1946                      (setq name (cadr options))
1947                      (unless (memq name readers)
1948                        (push (cons name reader-info) signatures)
1949                        (push name readers)))
1950                     (:writer                     
1951                      (setq name (cadr options))
1952                      (unless (member name writers :test 'equal)
1953                        (push (cons name writer-info) signatures)
1954                        (push name writers)))
1955                     (:accessor
1956                      (setq name (cadr options))
1957                      (unless (memq name readers)
1958                        (push (cons name reader-info) signatures)
1959                        (push name readers))
1960                      (let ((setf-name `(setf ,name)))
1961                        (unless (member setf-name writers :test 'equal)
1962                          (push (cons (setf-function-name name) writer-info) signatures)
1963                          (push setf-name writers))))
1964                     (:initarg
1965                      (push (require-type (cadr options) 'symbol) initargs))
1966                     (:type
1967                      (if type-p
1968                        (duplicate-options slot)
1969                        (setq type-p t))
1970                      ;(when (null (cadr options)) (signal-program-error "Illegal options ~S" options))
1971                      (setq type (cadr options)))
1972                     (:initform
1973                      (if initform-p
1974                        (duplicate-options slot)
1975                        (setq initform-p t))
1976                      (let ((option (cadr options)))
1977                        (setq initform `',option
1978                              initfunction
1979                              (if (constantp option)
1980                                `(constantly ,option)
1981                                `#'(lambda () ,option)))))
1982                     (:allocation
1983                      (if allocation-p
1984                        (duplicate-options slot)
1985                        (setq allocation-p t))
1986                      (setq allocation (cadr options)))
1987                     (:documentation
1988                      (if documentation-p
1989                        (duplicate-options slot)
1990                        (setq documentation-p t))
1991                      (setq documentation (cadr options)))
1992                     (t
1993                      (let* ((pair (or (assq (car options) other-options)
1994                                       (car (push (list (car options)) other-options)))))
1995                        (push (cadr options) (cdr pair))))))
1996                 `(list :name ',slot-name
1997                   ,@(when allocation `(:allocation ',allocation))
1998                   ,@(when initform-p `(:initform ,initform
1999                                        :initfunction ,initfunction))
2000                   ,@(when initargs `(:initargs ',initargs))
2001                   ,@(when readers `(:readers ',readers))
2002                   ,@(when writers `(:writers ',writers))
2003                   ,@(when type-p `(:type ',type))
2004                   ,@(when documentation-p `(:documentation ,documentation))
2005                   ,@(mapcan #'(lambda (opt)
2006                                 `(',(car opt) ',(if (null (cddr opt))
2007                                                     (cadr opt)
2008                                                     (cdr opt)))) other-options)))))
2009        (let* ((direct-superclasses superclasses)
2010               (direct-slot-specs (mapcar #'canonicalize-slot-spec slots))
2011               (other-options (apply #'append (mapcar #'canonicalize-defclass-option class-options )))
2012               (keyvect (class-keyvect class-name other-options)))
2013          (when (vectorp keyvect)
2014            (let ((illegal (loop for arg in other-options by #'cddr
2015                              as key = (if (quoted-form-p arg) (%cadr arg) arg)
2016                              unless (or (eq key :metaclass) (find key keyvect)) collect key)))
2017              (when illegal
2018                (signal-program-error "Class option~p~{ ~s~} is not one of ~s"
2019                                      (length illegal) illegal keyvect))))
2020          `(progn
2021            (eval-when (:compile-toplevel)
2022              (%compile-time-defclass ',class-name ,env)
2023              (progn
2024                ,@(mapcar #'(lambda (sig) `(record-function-info ',(car sig) ',(cdr sig) ,env))
2025                          signatures)))
2026              (ensure-class-for-defclass ',class-name
2027                            :direct-superclasses ',direct-superclasses
2028                            :direct-slots ,`(list ,@direct-slot-specs)
2029                            ,@other-options)))))))
2030
2031(defmacro define-method-combination (name &rest rest &environment env)
2032  (setq name (require-type name 'symbol))
2033  (cond ((or (null rest) (and (car rest) (symbolp (car rest))))
2034         `(short-form-define-method-combination ',name ',rest))
2035        ((listp (car rest))
2036         (destructuring-bind (lambda-list method-group-specifiers . forms) rest
2037           (long-form-define-method-combination 
2038            name lambda-list method-group-specifiers forms env)))
2039        (t (%badarg (car rest) '(or (and null symbol) list)))))
2040
2041(defmacro defgeneric (function-name lambda-list &rest options-and-methods &environment env)
2042  (fboundp function-name)             ; type-check
2043  (multiple-value-bind (method-combination generic-function-class options methods)
2044      (parse-defgeneric function-name t lambda-list options-and-methods)
2045    (let ((gf (gensym)))
2046      `(progn
2047         (eval-when (:compile-toplevel)
2048           (record-function-info ',(maybe-setf-function-name function-name)
2049                                 ',(%cons-def-info 'defgeneric (encode-gf-lambda-list lambda-list))
2050                                 ,env))
2051         (let ((,gf (%defgeneric
2052                     ',function-name ',lambda-list ',method-combination ',generic-function-class 
2053                     ',(apply #'append options))))
2054           (%set-defgeneric-methods ,gf ,@methods)
2055           ,gf)))))
2056
2057
2058
2059(defun parse-defgeneric (function-name global-p lambda-list options-and-methods)
2060  (check-generic-function-lambda-list lambda-list)
2061  (let ((method-combination '(standard))
2062        (generic-function-class 'standard-generic-function)
2063        options declarations methods option-keywords method-class)
2064    (flet ((bad-option (o)
2065             (signal-program-error "Bad option: ~s to ~s." o 'defgeneric)))
2066      (dolist (o options-and-methods)
2067        (let ((keyword (car o))
2068              (defmethod (if global-p 'defmethod 'anonymous-method)))
2069          (if (eq keyword :method)
2070            (let ((defn `(,defmethod ,function-name ,@(%cdr o))))
2071              (push defn methods))
2072            (cond ((and (not (eq keyword 'declare))
2073                        (memq keyword (prog1 option-keywords (push keyword option-keywords))))             
2074                   (signal-program-error "Duplicate option: ~s to ~s" keyword 'defgeneric))
2075                  ((eq keyword :method-combination)
2076                   (unless (symbolp (cadr o))
2077                     (bad-option o))
2078                   (setq method-combination (cdr o)))
2079                  ((eq keyword :generic-function-class)
2080                   (unless (and (cdr o) (symbolp (cadr o)) (null (%cddr o)))
2081                     (bad-option o))
2082                   (setq generic-function-class (%cadr o)))
2083                  ((eq keyword 'declare)
2084                   (push (cadr o) declarations))
2085                  ((eq keyword :argument-precedence-order)
2086                   (dolist (arg (cdr o))
2087                     (unless (and (symbolp arg) (memq arg lambda-list))
2088                       (bad-option o)))
2089                   (push (list keyword (cdr o)) options))
2090                  ((eq keyword :method-class)
2091                   (push o options)
2092                   (when (or (cddr o) (not (symbolp (setq method-class (%cadr o)))))
2093                     (bad-option o)))
2094                  ((eq keyword :documentation)
2095                   (push o options)
2096                   (when (or (cddr o) (not (stringp (%cadr o))))
2097                     (bad-option o)))
2098                  (t (bad-option o)))))))
2099    (when method-class
2100      (dolist (m methods)
2101        (push `(:method-class ,method-class) (cddr m))))
2102    (when declarations
2103      (setq options `((:declarations ,declarations) ,@options)))
2104    (values method-combination generic-function-class options methods)))
2105
2106                 
2107(defmacro def-aux-init-functions (class &rest functions)
2108  `(set-aux-init-functions ',class (list ,@functions)))
2109
2110
2111
2112
2113
2114
2115;;; A powerful way of defining REPORT-CONDITION...
2116;;; Do they really expect that each condition type has a unique method on PRINT-OBJECT
2117;;; which tests *print-escape* ?  Scary if so ...
2118
2119(defmacro define-condition (name (&rest supers) (&rest slots) &body options)
2120  "DEFINE-CONDITION Name (Parent-Type*) (Slot-Spec*) Option*
2121   Define NAME as a condition type. This new type inherits slots and its
2122   report function from the specified PARENT-TYPEs. A slot spec is a list of:
2123     (slot-name :reader <rname> :initarg <iname> {Option Value}*
2124
2125   The DEFINE-CLASS slot options :ALLOCATION, :INITFORM, [slot] :DOCUMENTATION
2126   and :TYPE and the overall options :DEFAULT-INITARGS and
2127   [type] :DOCUMENTATION are also allowed.
2128
2129   The :REPORT option is peculiar to DEFINE-CONDITION. Its argument is either
2130   a string or a two-argument lambda or function name. If a function, the
2131   function is called with the condition and stream to report the condition.
2132   If a string, the string is printed.
2133
2134   Condition types are classes, but (as allowed by ANSI and not as described in
2135   CLtL2) are neither STANDARD-OBJECTs nor STRUCTURE-OBJECTs. WITH-SLOTS and
2136   SLOT-VALUE may not be used on condition objects."
2137  ; If we could tell what environment we're being expanded in, we'd
2138  ; probably want to check to ensure that all supers name conditions
2139  ; in that environment.
2140  (let ((classopts nil)
2141        (duplicate nil)
2142        (docp nil)
2143        (default-initargs-p nil)
2144        (reporter nil))
2145    (dolist (option options)
2146      (unless (and (consp option)
2147                   (consp (%cdr option)))
2148        (signal-program-error "Invalid option ~s ." option))
2149      (ecase (%car option)
2150        (:default-initargs 
2151            (unless (plistp (cdr option)) 
2152              (signal-program-error "~S is not a plist." (%cdr option))) 
2153            (if default-initargs-p 
2154              (setq duplicate t) 
2155              (push (setq default-initargs-p option) classopts))) 
2156        (:documentation 
2157         (unless (null (%cddr option)) 
2158           (signal-program-error "Invalid option ~s ." option)) 
2159         (if docp
2160           (setq duplicate t)
2161           (push (setq docp option) classopts)))
2162        (:report 
2163         (unless (null (%cddr option)) 
2164           (signal-program-error "Invalid option ~s ." option)) 
2165         (if reporter
2166           (setq duplicate t)
2167           (progn
2168             (if (or (lambda-expression-p (setq reporter (%cadr option)))
2169                     (symbolp reporter))
2170               (setq reporter `(function ,reporter))
2171               (if (stringp reporter)
2172                 (setq reporter `(function (lambda (c s) (declare (ignore c)) (write-string ,reporter s))))
2173                 (signal-program-error "~a expression is not a string, symbol, or lambda expression ." (%car option))))
2174             (setq reporter `((defmethod report-condition ((c ,name) s)
2175                                (funcall ,reporter c s))))))))
2176      (if duplicate (signal-program-error "Duplicate option ~s ." option)))
2177    `(progn
2178       (defclass ,name ,(or supers '(condition)) ,slots ,@classopts)
2179       ,@reporter
2180       ',name)))
2181
2182(defmacro with-condition-restarts (&environment env condition restarts &body body)
2183  "Evaluates the BODY in a dynamic environment where the restarts in the list
2184   RESTARTS-FORM are associated with the condition returned by CONDITION-FORM.
2185   This allows FIND-RESTART, etc., to recognize restarts that are not related
2186   to the error currently being debugged. See also RESTART-CASE."
2187  (multiple-value-bind (body decls)
2188                       (parse-body body env)
2189    (let ((cond (gensym))
2190          (r (gensym)))
2191          `(let* ((*condition-restarts* *condition-restarts*))
2192             ,@decls
2193             (let ((,cond ,condition))
2194               (dolist (,r ,restarts) (push (cons ,r ,cond) *condition-restarts*))
2195               ,@body)))))
2196 
2197(defmacro setf-find-class (name arg1 &optional (arg2 () 2-p) (arg3 () 3-p))
2198  (cond (3-p ;might want to pass env (arg2) to find-class someday?
2199         `(set-find-class ,name (progn ,arg1 ,arg2 ,arg3)))
2200        (2-p
2201         `(set-find-class ,name (progn ,arg1 ,arg2)))
2202        (t `(set-find-class ,name ,arg1))))
2203
2204(defsetf find-class setf-find-class)
2205
2206(defmacro restoring-interrupt-level (var &body body)
2207  `(unwind-protect
2208    (progn ,@body)
2209    (restore-interrupt-level ,var)
2210    (%interrupt-poll)))
2211
2212(defmacro without-interrupts (&body body)
2213  "Evaluate its body in an environment in which process-interrupt
2214requests are deferred."
2215  `(let* ((*interrupt-level* -1))
2216    ,@body))
2217
2218(defmacro with-interrupts-enabled (&body body)
2219  "Evaluate its body in an environment in which process-interrupt
2220has immediate effect."
2221  `(let* ((*interrupt-level* 0))
2222    ,@body))
2223
2224;;; undoes the effect of one enclosing without-interrupts during execution of body.
2225(defmacro ignoring-without-interrupts (&body body)
2226  `(let* ((*interrupt-level* 0))
2227    ,@body))
2228
2229
2230
2231(defmacro error-ignoring-without-interrupts (format-string &rest format-args)
2232  `(ignoring-without-interrupts
2233    (error ,format-string ,@format-args)))
2234
2235
2236;init-list-default: if there is no init pair for <keyword>,
2237;    add a <keyword> <value> pair to init-list
2238(defmacro init-list-default (the-init-list &rest args)
2239  (let ((result)
2240       (init-list-sym (gensym)))
2241   (do ((args args (cddr args)))
2242       ((not args))
2243     (setq result 
2244           (cons `(if (eq '%novalue (getf ,init-list-sym ,(car args) 
2245                                          '%novalue))
2246                    (setq ,init-list-sym (cons ,(car args) 
2247                                               (cons ,(cadr args) 
2248                                                     ,init-list-sym))))
2249                 result)))                                                                               
2250   `(let ((,init-list-sym ,the-init-list))
2251      (progn ,@result)
2252      ,init-list-sym)
2253   ))
2254
2255; This can only be partially backward-compatible: even if only
2256; the "name" arg is supplied, the old function would create the
2257; package if it didn't exist.
2258; Should see how well this works & maybe flush the whole idea.
2259
2260(defmacro in-package (name)
2261  (let ((form nil))
2262    (when (quoted-form-p name)
2263      (warn "Unquoting argument ~S to ~S." name 'in-package )
2264      (setq name (cadr name)))   
2265    (setq form `(set-package ,(string name)))
2266    `(eval-when (:execute :load-toplevel :compile-toplevel)
2267      ,form)))
2268
2269(defmacro defpackage (name &rest options)
2270  "Defines a new package called PACKAGE. Each of OPTIONS should be one of the
2271   following:
2272    (NICKNAMES {package-name}*)
2273
2274    (SIZE <integer>)
2275    (SHADOW {symbol-name}*)
2276    (SHADOWING-IMPORT-FROM <package-name> {symbol-name}*)
2277    (USE {package-name}*)
2278    (IMPORT-FROM <package-name> {symbol-name}*)
2279    (INTERN {symbol-name}*)
2280    (EXPORT {symbol-name}*)
2281    (IMPLEMENT {package-name}*)
2282    (LOCK boolean)
2283    (DOCUMENTATION doc-string)
2284   All options except SIZE, LOCK, and :DOCUMENTATION can be used multiple
2285   times."
2286  (let* ((size nil)
2287         (all-names-size 0)
2288         (intern-export-size 0)
2289         (shadow-etc-size 0)
2290         (documentation nil)
2291         (all-names-hash (let ((all-options-alist nil))
2292                           (dolist (option options)
2293                             (let ((option-name (car option)))
2294                               (when (memq option-name
2295                                           '(:nicknames :shadow :shadowing-import-from
2296                                             :use :import-from :intern :export))
2297                                 (let ((option-size (length (cdr option)))
2298                                       (cell (assq option-name all-options-alist)))
2299                                   (declare (fixnum option-size))
2300                                   (if cell
2301                                     (incf (cdr cell) option-size)
2302                                     (push (cons option-name option-size) all-options-alist))
2303                                   (when (memq option-name '(:shadow :shadowing-import-from :import-from :intern))
2304                                     (incf shadow-etc-size option-size))
2305                                   (when (memq option-name '(:export :intern))
2306                                     (incf intern-export-size option-size))))))
2307                           (dolist (cell all-options-alist)
2308                             (let ((option-size (cdr cell)))
2309                               (when (> option-size all-names-size)
2310                                 (setq all-names-size option-size))))
2311                           (when (> all-names-size 0)
2312                             (make-hash-table :test 'equal :size all-names-size))))
2313         (intern-export-hash (when (> intern-export-size 0)
2314                               (make-hash-table :test 'equal :size intern-export-size)))
2315         (shadow-etc-hash (when (> shadow-etc-size 0)
2316                            (make-hash-table :test 'equal :size shadow-etc-size)))
2317         (external-size nil)
2318         (nicknames nil)
2319         (shadow nil)
2320         (shadowing-import-from-specs nil)
2321         (use :default)
2322         (import-from-specs nil)
2323         (intern nil)
2324         (export nil))
2325    (declare (fixnum all-names-size intern-export-size shadow-etc-size))
2326    (labels ((string-or-name (s) (string s))
2327             (duplicate-option (o)
2328               (signal-program-error "Duplicate ~S option in ~S ." o options))
2329             (duplicate-name (name option-name)
2330               (signal-program-error "Name ~s, used in ~s option, is already used in a conflicting option ." name option-name))
2331             (all-names (option-name tail already)
2332               (when (eq already :default) (setq already nil))
2333               (when all-names-hash
2334                 (clrhash all-names-hash))
2335               (dolist (name already)
2336                 (setf (gethash (string-or-name name) all-names-hash) t))
2337               (dolist (name tail already)
2338                 (setq name (string-or-name name))
2339                 (unless (gethash name all-names-hash)          ; Ok to repeat name in same option.
2340                   (when (memq option-name '(:shadow :shadowing-import-from :import-from :intern))
2341                     (if (gethash name shadow-etc-hash)
2342                       (duplicate-name name option-name))
2343                     (setf (gethash name shadow-etc-hash) t))
2344                   (when (memq option-name '(:export :intern))
2345                     (if (gethash name intern-export-hash)
2346                       (duplicate-name name option-name))
2347                     (setf (gethash name intern-export-hash) t))
2348                   (setf (gethash name all-names-hash) t)
2349                   (push name already)))))
2350      (dolist (option options)
2351        (let ((args (cdr option)))
2352          (ecase (%car option)
2353                 (:size 
2354                  (if size 
2355                    (duplicate-option :size) 
2356                    (setq size (car args))))             
2357                 (:external-size 
2358                  (if external-size 
2359                    (duplicate-option :external-size) 
2360                    (setq external-size (car args))))
2361                 (:nicknames (setq nicknames (all-names nil args nicknames)))
2362                 (:shadow (setq shadow (all-names :shadow args shadow)))
2363                 (:shadowing-import-from
2364                  (destructuring-bind (from &rest shadowing-imports) args
2365                    (push (cons (string-or-name from)
2366                                (all-names :shadowing-import-from shadowing-imports nil))
2367                          shadowing-import-from-specs)))
2368                 (:use (setq use (all-names nil args use)))
2369                 (:import-from
2370                  (destructuring-bind (from &rest imports) args
2371                    (push (cons (string-or-name from)
2372                                (all-names :import-from imports nil))
2373                          import-from-specs)))
2374                 (:intern (setq intern (all-names :intern args intern)))
2375                 (:export (setq export (all-names :export args export)))
2376                 (:documentation
2377                  (if documentation
2378                    (duplicate-option :documentation)
2379                    (setq documentation (cadr option)))))))
2380      `(eval-when (:execute :compile-toplevel :load-toplevel)
2381         (%define-package ',(string-or-name name)
2382          ',size 
2383          ',external-size 
2384          ',nicknames
2385          ',shadow
2386          ',shadowing-import-from-specs
2387          ',use
2388          ',import-from-specs
2389          ',intern
2390          ',export
2391          ',documentation)))))
2392
2393
2394
2395(defmacro with-package-iterator ((mname package-list first-type &rest other-types)
2396                                 &body body)
2397  "Within the lexical scope of the body forms, MNAME is defined via macrolet
2398   such that successive invocations of (MNAME) will return the symbols,
2399   one by one, from the packages in PACKAGE-LIST. SYMBOL-TYPES may be
2400   any of :INHERITED :EXTERNAL :INTERNAL."
2401  (setq mname (require-type mname 'symbol))
2402  (let ((state (make-symbol "WITH-PACKAGE-ITERATOR_STATE")))
2403    (dolist (type (push first-type other-types))
2404      (ecase type
2405        ((:external :internal :inherited))))
2406    `(let ((,state (%setup-pkg-iter-state ,package-list ',other-types)))
2407       (macrolet ((,mname () `(%pkg-iter-next ,',state)))
2408         ,@body))))
2409
2410; Does NOT evaluate the constructor, but DOES evaluate the destructor & initializer
2411(defmacro defresource (name &key constructor destructor initializer)
2412  `(defparameter ,name (make-resource #'(lambda () ,constructor)
2413                                      ,@(when destructor
2414                                          `(:destructor ,destructor))
2415                                      ,@(when initializer
2416                                          `(:initializer ,initializer)))))
2417
2418(defmacro using-resource ((var resource) &body body)
2419  (let ((resource-var (gensym)))
2420  `(let ((,resource-var ,resource)
2421         ,var)
2422     (unwind-protect
2423       (progn
2424         (setq ,var (allocate-resource ,resource-var))
2425         ,@body)
2426       (when ,var
2427         (free-resource ,resource-var ,var))))))
2428
2429;;; Bind per-thread specials which help with lock accounting.
2430(defmacro with-lock-context (&body body)
2431  `(progn ,@body))
2432
2433(defmacro with-lock-grabbed ((lock &optional
2434                                   (whostate "Lock"))
2435                             &body body)
2436  "Wait until a given lock can be obtained, then evaluate its body with
2437the lock held."
2438  (declare (ignore whostate))
2439    (let* ((locked (gensym))
2440           (l (gensym)))
2441      `  (with-lock-context
2442           (let ((,locked (make-lock-acquisition))
2443             (,l ,lock))
2444        (declare (dynamic-extent ,locked))
2445        (unwind-protect
2446             (progn
2447               (%lock-recursive-lock-object ,l ,locked )
2448               ,@body)
2449          (when (lock-acquisition.status ,locked) (%unlock-recursive-lock-object ,l)))))))
2450
2451(defmacro with-lock-grabbed-maybe ((lock &optional
2452                                         (whostate "Lock"))
2453                                   &body body)
2454  (declare (ignore whostate))
2455  (let* ((l (gensym)))
2456    `(with-lock-context
2457      (let* ((,l ,lock))
2458        (when (%try-recursive-lock-object ,l)
2459          (unwind-protect
2460               (progn ,@body)
2461            (%unlock-recursive-lock-object ,l)))))))
2462
2463(defmacro with-standard-abort-handling (abort-message &body body)
2464  (let ((stream (gensym)))
2465    `(restart-case
2466       (catch :abort
2467         (catch-cancel
2468           ,@body))
2469       (abort () ,@(when abort-message
2470                     `(:report (lambda (,stream)
2471                                 (write-string ,abort-message ,stream)))))
2472       (abort-break ()))))
2473       
2474
2475
2476
2477(defmacro %lexpr-count (l)
2478  `(%lisp-word-ref ,l 0))
2479
2480(defmacro %lexpr-ref (lexpr count i)
2481  `(%lisp-word-ref ,lexpr (%i- ,count ,i)))
2482
2483;;; args will be list if old style clos
2484(defmacro apply-with-method-context (magic function args)
2485  (let ((m (gensym))
2486        (f (gensym))
2487        (as (gensym)))
2488      `((lambda (,m ,f ,as)
2489          (if (listp ,as)
2490            (%apply-with-method-context ,m ,f ,as)
2491            (%apply-lexpr-with-method-context ,m ,f ,as))) ,magic ,function ,args)))
2492
2493(defmacro defcallback (name arglist &body body &environment env)
2494  "Proclaim name to be a special variable; sets its value to a MACPTR which,
2495when called by foreign code, calls a lisp function which expects foreign
2496arguments of the specified types and which returns a foreign value of the
2497specified result type. Any argument variables which correspond to foreign
2498arguments of type :ADDRESS are bound to stack-allocated MACPTRs.
2499
2500If name is already a callback function pointer, its value is not changed;
2501instead, it's arranged that an updated version of the lisp callback function
2502will be called. This feature allows for callback functions to be redefined
2503incrementally, just like Lisp functions are.
2504
2505defcallback returns the callback pointer, e.g., the value of name."
2506  (define-callback name arglist body env))
2507
2508(declare-arch-specific-macro %get-single-float-from-double-ptr)
2509
2510(declare-arch-specific-macro lfun-vector)
2511(declare-arch-specific-macro lfun-vector-lfun)
2512
2513(declare-arch-specific-macro symptr->symvector)
2514(declare-arch-specific-macro symvector->symptr)
2515
2516(declare-arch-specific-macro function-to-function-vector)
2517(declare-arch-specific-macro function-vector-to-function)
2518
2519(declare-arch-specific-macro with-ffcall-results)
2520
2521(defvar *trace-print-functions* nil)
2522(defun %trace-print-arg (stream arg val type)
2523  (format stream " ")
2524  (let ((fn (assoc type *trace-print-functions*)))
2525    (if fn
2526      (funcall (cdr fn) stream arg val)
2527      (progn
2528      (when arg
2529        (format stream "~A = " arg))
2530      (if (and type (not (eq type :void)))
2531          (format stream "[:~A] ~A~%" type val)
2532        (format stream ":VOID~%" val))))))
2533
2534(defun def-trace-print-function (type fn)
2535  (push (cons type fn) *trace-print-functions*))
2536
2537(defun define-callback (name args body env)
2538  (let* ((stack-word (gensym))
2539         (stack-ptr (gensym))
2540         (fp-args-ptr (gensym))
2541         (result-type-spec :void)
2542         (args args)
2543         (discard-stack-args nil)
2544         (woi nil)
2545         (need-struct-arg)
2546         (struct-return-arg-name)
2547         (error-return nil))
2548    (collect ((arg-names)
2549              (arg-specs))
2550      (let* ((spec (car (last args)))
2551             (rtype (ignore-errors (parse-foreign-type spec))))
2552        (setq need-struct-arg (typep rtype 'foreign-record-type))
2553        (if rtype
2554          (setq result-type-spec spec args (butlast args))))
2555      (loop
2556        (when (null args) (return))
2557        (if (eq (car args) :without-interrupts)
2558          (setq woi (cadr args) args (cddr args))
2559          (if (eq (car args) :discard-stack-args)
2560            (setq discard-stack-args t args (cdr args))
2561            (if (eq (car args) :error-return)
2562              (setq error-return
2563                    (cadr args)                 
2564                    args (cddr args))
2565              (if need-struct-arg
2566                (setq struct-return-arg-name (pop args) need-struct-arg nil)
2567                (progn
2568                  (arg-specs (pop args))
2569                  (arg-names (pop args))))))))
2570      (multiple-value-bind (rlets lets dynamic-extent-names inits foreign-return-type fp-args-form error-return-offset num-arg-bytes)
2571          (funcall (ftd-callback-bindings-function *target-ftd*)
2572                   stack-ptr fp-args-ptr (arg-names) (arg-specs) result-type-spec struct-return-arg-name)
2573        (unless num-arg-bytes (setq num-arg-bytes 0))
2574        (multiple-value-bind (body decls doc) (parse-body body env t)
2575          `(progn
2576            (declaim (special ,name))
2577            (define-callback-function
2578                (nfunction ,name
2579                 (lambda (,stack-word)
2580                   (declare (ignorable ,stack-word))
2581                   (block ,name
2582                     (with-macptrs ((,stack-ptr))
2583                       (%setf-macptr-to-object ,stack-ptr ,stack-word)
2584                       (with-macptrs (,@(when fp-args-form
2585                                              `((,fp-args-ptr ,fp-args-form))))
2586                         ,(defcallback-body stack-ptr
2587                                            fp-args-ptr
2588                                            lets
2589                                            rlets
2590                                            inits
2591                                            `(declare (dynamic-extent ,@dynamic-extent-names))
2592                                            decls
2593                                            body
2594                                            foreign-return-type
2595                                            struct-return-arg-name
2596                                            error-return
2597                                            error-return-offset
2598                                            ))))))
2599                ,doc
2600              ,woi
2601              ,(if discard-stack-args num-arg-bytes 0))))))))
2602
2603
2604(defun defcallback-body (&rest args)
2605  (declare (dynamic-extent args))
2606  (destructuring-bind (stack-ptr fp-args-ptr lets rlets inits dynamic-extent-decls other-decls body return-type struct-return-arg error-return error-delta) args
2607    (declare (ignorable dynamic-extent-decls))
2608    (let* ((result (gensym))
2609           (condition-name (if (atom error-return) 'error (car error-return)))
2610           (error-return-function (if (atom error-return) error-return (cadr error-return)))
2611           (body
2612            `(rlet ,rlets
2613              (let ,lets
2614                ,dynamic-extent-decls
2615                ,@other-decls
2616                ,@inits
2617                (let ((,result (progn ,@body)))
2618                  (declare (ignorable ,result)
2619                           (dynamic-extent ,result))
2620
2621                  ,(funcall (ftd-callback-return-value-function *target-ftd*)
2622                            stack-ptr
2623                            fp-args-ptr
2624                            result
2625                            return-type
2626                            struct-return-arg)
2627                  nil)))))
2628      (if error-return
2629        (let* ((cond (gensym))
2630               (block (gensym))
2631               (handler (gensym)))
2632          `(block ,block
2633            (let* ((,handler (lambda (,cond)
2634                                           (,error-return-function ,cond ,stack-ptr (%inc-ptr ,stack-ptr ,error-delta))
2635                                           (return-from ,block
2636                                             nil))))
2637              (declare (dynamic-extent ,handler))
2638            (handler-bind ((,condition-name ,handler))
2639              (values ,body)))))
2640        body))))
2641
2642
2643(defmacro define-toplevel-command (group-name name arglist &body body &environment env)
2644  (let* ((key (make-keyword name)))
2645    (multiple-value-bind (body decls doc) (parse-body body env)
2646      `(%define-toplevel-command ',group-name ,key ',name 
2647        (nfunction ,name (lambda ,arglist
2648                           ,@decls
2649                           (block ,name
2650                             ,@body)))
2651        ,doc
2652        ',(mapcar #'symbol-name arglist)))))
2653
2654(defmacro with-toplevel-commands (group-name &body body)
2655  `(let* ((*active-toplevel-commands* *active-toplevel-commands*))
2656    (progn
2657      (%use-toplevel-commands ',group-name)
2658      ,@body)))
2659
2660(defmacro assert (test-form &optional (places ()) string &rest args)
2661  "ASSERT Test-Form [(Place*) [String Arg*]]
2662  If the Test-Form is not true, then signal a correctable error.  If Places
2663  are specified, then new values are prompted for when the error is proceeded.
2664  String and Args are the format string and args to the error call."
2665  (let* ((TOP (gensym))
2666         (setf-places-p (not (null places))))
2667    `(tagbody
2668       ,TOP
2669       (unless ,test-form
2670         (%assertion-failure ,setf-places-p ',test-form ,string ,@args)
2671         ,@(if places
2672             `((write-line "Type expressions to set places to, or nothing to leave them alone."
2673                           *query-io*)
2674               ,@(mapcar #'(lambda (place &aux (new-val (gensym))
2675                                          (set-p (gensym)))
2676                             `(multiple-value-bind
2677                                (,new-val ,set-p)
2678                                (assertion-value-prompt ',place)
2679                                (when ,set-p (setf ,place (values-list ,new-val)))))
2680                         places)))
2681         (go ,TOP)))))
2682
2683
2684(defmacro check-type (place typespec &optional string)
2685  "CHECK-TYPE Place Typespec [String]
2686  Signal a restartable error of type TYPE-ERROR if the value of PLACE is
2687  not of the specified type. If an error is signalled and the restart is
2688  used to return, this can only return if the STORE-VALUE restart is
2689  invoked. In that case it will store into PLACE and start over."
2690  (let* ((val (gensym)))
2691    `(do* ((,val ,place ,place))
2692          ((typep ,val ',typespec))
2693       (setf ,place (%check-type ,val ',typespec ',place ,string)))))
2694
2695
2696
2697
2698(defmacro with-hash-table-iterator ((mname hash-table) &body body &environment env)
2699  "WITH-HASH-TABLE-ITERATOR ((function hash-table) &body body)
2700   provides a method of manually looping over the elements of a hash-table.
2701   FUNCTION is bound to a generator-macro that, within the scope of the
2702   invocation, returns one or three values. The first value tells whether
2703   any objects remain in the hash table. When the first value is non-NIL,
2704   the second and third values are the key and the value of the next object."
2705  (let* ((hash (gensym))
2706         (keys (gensym))
2707         (values (gensym))
2708         (count (gensym))
2709         (state (gensym)))
2710    `(let* ((,hash ,hash-table)
2711            (,count (hash-table-count ,hash))
2712            (,keys (make-array ,count))
2713            (,values (make-array ,count))
2714            (,state (vector ,hash 0 ,keys ,values (enumerate-hash-keys-and-values ,hash ,keys ,values))))
2715      (declare (dynamic-extent ,keys ,state)
2716               (fixnum ,count))
2717      (macrolet ((,mname () `(next-hash-table-iteration-1 ,',state)))
2718        ,@body))))
2719
2720
2721(eval-when (compile load eval)
2722(defmacro pprint-logical-block ((stream-symbol list
2723                                 &key (prefix "" prefixp)
2724                                      (per-line-prefix "" per-line-prefix-p)
2725                                      (suffix "" suffixp))
2726                                &body body)
2727  (cond ((eq stream-symbol nil) (setq stream-symbol '*standard-output*))
2728        ((eq stream-symbol T) (setq stream-symbol '*terminal-io*)))
2729  (when (not (symbolp stream-symbol))
2730    (warn "STREAM-SYMBOL arg ~S to PPRINT-LOGICAL-BLOCK is not a bindable symbol"
2731          stream-symbol)
2732    (setq stream-symbol '*standard-output*))
2733  (when (and prefixp per-line-prefix-p)
2734    (warn "prefix ~S and per-line-prefix ~S cannot both be specified ~
2735           in PPRINT-LOGICAL-BLOCK")
2736    (setq per-line-prefix nil))
2737  `(let ((*logical-block-p* t))
2738     (maybe-initiate-xp-printing
2739      #'(lambda (,stream-symbol)
2740          (let ((+l ,list)
2741                (+p (or (and ,prefixp
2742                             (require-type ,prefix 'string))
2743                        (and ,per-line-prefix-p
2744                             (require-type ,per-line-prefix 'string))))
2745                (+s (require-type ,suffix 'string)))
2746            (pprint-logical-block+
2747                (,stream-symbol +l +p +s ,per-line-prefix-p T nil)
2748              ,@ body nil)))
2749      (decode-stream-arg ,stream-symbol))))
2750
2751
2752;Assumes var and args must be variables.  Other arguments must be literals or variables.
2753
2754(defmacro pprint-logical-block+ ((var args prefix suffix per-line? circle-check? atsign?)
2755                                 &body body)
2756  "Group some output into a logical block. STREAM-SYMBOL should be either a
2757   stream, T (for *TERMINAL-IO*), or NIL (for *STANDARD-OUTPUT*). The printer
2758   control variable *PRINT-LEVEL* is automatically handled."
2759  (when (and circle-check? atsign?)
2760    (setq circle-check? 'not-first-p))
2761  `(let ((*current-level* (1+ *current-level*))
2762         (*current-length* -1)
2763         ;(*parents* *parents*)
2764         ,@(if (and circle-check? atsign?) `((not-first-p (plusp *current-length*)))))
2765     (unless (check-block-abbreviation ,var ,args ,circle-check?)
2766       (start-block ,var ,prefix ,per-line? ,suffix)
2767       (when
2768         (catch 'line-limit-abbreviation-exit
2769           (block logical-block
2770             (macrolet ((pprint-pop () `(pprint-pop+ ,',args ,',var))
2771                        (pprint-exit-if-list-exhausted ()
2772                          `(if (null ,',args) (return-from logical-block nil))))
2773               ,@ body))
2774           (end-block ,var ,suffix)
2775           nil)
2776         (end-block ,var ,suffix)
2777         (throw 'line-limit-abbreviation-exit T)))))
2778) ; eval-when
2779
2780(defmacro %old-class-local-shared-slotds (class &optional default)
2781  (if default                           ; so setf works
2782    `(%class-get ,class '%old-class-local-shared-slotds ,default)
2783    `(%class-get ,class '%old-class-local-shared-slotds)))
2784
2785(defmacro with-slot-values (slot-entries instance-form &body body)
2786; Simplified form of with-slots.  Expands into a let instead of a symbol-macrolet
2787; Thus, you can access the slot values, but you can't setq them.
2788  (let ((instance (gensym)) var slot-name bindings)
2789    (dolist (slot-entry slot-entries)
2790      (cond ((symbolp slot-entry)
2791             (setq var slot-entry slot-name slot-entry))
2792            ((and (listp slot-entry) (cdr slot-entry) (null (cddr slot-entry))
2793                  (symbolp (car slot-entry)) (symbolp (cadr slot-entry)))
2794             (setq var (car slot-entry) slot-name (cadr slot-entry)))
2795            (t (signal-program-error "Malformed slot-entry: ~a to with-slot-values.~@
2796                                      Should be a symbol or a list of two symbols."
2797                                     slot-entry)))
2798      (push `(,var (slot-value ,instance ',slot-name)) bindings))
2799    `(let ((,instance ,instance-form))
2800       (let ,(nreverse bindings)
2801         ,@body))))
2802
2803(defmacro with-slots (slot-entries instance-form &body body)
2804  "Establish a lexical environment for referring to the slots in the
2805instance named by the given slot-names as though they were variables.
2806Within such a context the value of the slot can be specified by using
2807its slot name, as if it were a lexically bound variable. Both setf and
2808setq can be used to set the value of the slot."
2809  (let ((instance (gensym)) var slot-name bindings)
2810    (dolist (slot-entry slot-entries)
2811      (cond ((symbolp slot-entry)
2812             (setq var slot-entry slot-name slot-entry))
2813            ((and (listp slot-entry) (cdr slot-entry) (null (cddr slot-entry))
2814                  (symbolp (car slot-entry)) (symbolp (cadr slot-entry)))
2815             (setq var (car slot-entry) slot-name (cadr slot-entry)))
2816            (t (signal-program-error "Malformed slot-entry: ~a to with-slots.~@
2817                                      Should be a symbol or a list of two symbols."
2818                                     slot-entry)))
2819      (push `(,var (slot-value ,instance ',slot-name)) bindings))
2820    `(let ((,instance ,instance-form))
2821       ,@(if bindings 
2822             (list `(declare (ignorable ,instance)))
2823             (list `(declare (ignore ,instance))))
2824       (symbol-macrolet ,(nreverse bindings)
2825         ,@body))))
2826
2827(defmacro with-accessors (slot-entries instance-form &body body)
2828  "Create a lexical environment in which the slots specified by slot-entry
2829are lexically available through their accessors as if they were variables.
2830The appropriate accessors are invoked to access the slots specified by
2831slot-entry. Both setf and setq can be used to set the value of the slot."
2832  (let ((instance (gensym)) var reader bindings)
2833    (dolist (slot-entry slot-entries)
2834      (cond ((and (listp slot-entry) (cdr slot-entry) (null (cddr slot-entry))
2835                  (symbolp (car slot-entry)) (symbolp (cadr slot-entry)))
2836             (setq var (car slot-entry) reader (cadr slot-entry)))
2837            (t (signal-program-error "Malformed slot-entry: ~a to with-accessors.~@
2838                                     Should be a list of two symbols."
2839                                     slot-entry)))
2840      (push `(,var (,reader ,instance)) bindings))
2841    `(let ((,instance ,instance-form))
2842       ,@(if bindings 
2843             (list `(declare (ignorable ,instance)))
2844             (list `(declare (ignore ,instance))))
2845       (symbol-macrolet ,(nreverse bindings)
2846         ,@body))))
2847
2848; I wanted to call this ":method"
2849(defmacro reference-method (gf &rest qualifiers-and-specializers)
2850  (let ((qualifiers (butlast qualifiers-and-specializers))
2851        (specializers (car (last qualifiers-and-specializers))))
2852    (if (null specializers) (report-bad-arg qualifiers-and-specializers '(not null)))
2853    `(find-method #',gf ',qualifiers (mapcar #'find-specializer ',specializers))))
2854
2855(defmacro time (form)
2856  "Execute FORM and print timing information on *TRACE-OUTPUT*."
2857  `(report-time ',form #'(lambda () (progn ,form))))
2858
2859(defmacro with-error-reentry-detection (&body body)
2860  (let ((thunk (gensym)))
2861    `(let ((,thunk #'(lambda () ,@body)))
2862       (declare (dynamic-extent ,thunk))
2863       (funcall-with-error-reentry-detection ,thunk))))
2864
2865(defmacro without-duplicate-definition-warnings (&body body)
2866  `(compiler-let ((*compiler-warn-on-duplicate-definitions* nil))
2867     ,@body))
2868
2869
2870#+ppc-target
2871(defmacro scan-for-instr (mask opcode fn pc-index &optional (tries *trap-lookup-tries*))
2872  `(%scan-for-instr ,mask ,opcode ,fn ,pc-index ,tries))
2873
2874
2875(declare-arch-specific-macro codevec-header-p)
2876
2877#+ppc-target
2878(defmacro match-instr (instr mask bits-to-match)
2879  `(eql (logand ,instr ,mask) ,bits-to-match))
2880
2881(defmacro with-xp-stack-frames ((xp trap-function &optional stack-frame) &body body)
2882  (let ((thunk (gensym))
2883        (sf (or stack-frame (gensym))))
2884    `(let ((,thunk #'(lambda (&optional ,sf)
2885                       ,@(unless stack-frame `((declare (ignore ,sf))))
2886                       ,@body)))
2887       (declare (dynamic-extent ,thunk))
2888       (funcall-with-xp-stack-frames ,xp ,trap-function ,thunk))))
2889
2890(defmacro signal-eof-error (stream)
2891  `(error 'end-of-file :stream ,stream))
2892
2893(defmacro check-eof (valform stream eof-error-p eof-value)
2894  (let* ((val (gensym)))
2895    `(let ((,val ,valform))
2896      (if (eq ,val :eof)
2897        (if ,eof-error-p
2898          (signal-eof-error ,stream)
2899          ,eof-value)
2900        ,val))))
2901
2902(defmacro designated-input-stream (input-stream)
2903  `(if ,input-stream
2904    (if (eq t ,input-stream)
2905      *terminal-io*
2906      ,input-stream)
2907    *standard-input*))
2908
2909(defmacro pref (pointer accessor)
2910  "Reference an instance of a foreign type (or a component of a foreign
2911type) accessible via ptr.
2912
2913Expand into code which references the indicated scalar type or component,
2914or returns a pointer to a composite type."
2915  (let* ((*target-ftd* (backend-target-foreign-type-data *target-backend*)))
2916    (destructuring-bind (type-name &rest accessors) (decompose-record-accessor accessor)
2917      (%foreign-access-form pointer (%foreign-type-or-record type-name) 0 accessors))))
2918
2919(defmacro paref (pointer type-name index)
2920  (let* ((*target-ftd* (backend-target-foreign-type-data *target-backend*)))
2921    (%foreign-array-access-form  pointer (%foreign-type-or-record type-name) index)))
2922
2923(defmacro rref (pointer accessor &key (storage :pointer storage-p))
2924  (when storage-p
2925    (warn "Use of :storage option ignored: ~a" storage))
2926  `(pref ,pointer ,accessor))
2927
2928(defmacro rlet (spec &body body)
2929  "Execute body in an environment in which each var is bound to a MACPTR
2930encapsulating the address of a stack-allocated foreign memory block,
2931allocated and initialized from typespec and initforms as per make-record.
2932Return whatever value(s) body returns."
2933  (let* ((*target-ftd* (backend-target-foreign-type-data *target-backend*)))
2934    `(%stack-block ,(rlet-sizes spec)
2935      ,@(rlet-inits spec)
2936      ,@body)))
2937
2938(defmacro rletz (spec &body body)
2939  "Execute body in an environment in which each var is bound to a MACPTR
2940encapuslating the address of a stack-allocated foreign memory block,
2941allocated and initialized from typespec and initforms as per make-record.
2942Return whatever value(s) body returns.
2943
2944Unlike rlet, record fields that aren't explicitly initialized are set
2945to binary 0."
2946  (let* ((*target-ftd* (backend-target-foreign-type-data *target-backend*)))
2947    `(%stack-block ,(rlet-sizes spec t)
2948      ,@(rlet-inits spec)
2949      ,@body)))
2950
2951(defun rlet-sizes (inits &optional clear-p &aux result)
2952  (dolist (item inits (nreverse result))
2953    (push `(,(car item)
2954            ,(%foreign-type-or-record-size (cadr item) :bytes)
2955            ,@(if clear-p '(:clear t)))
2956          result)))
2957
2958(defun rlet-inits (inits &aux result)
2959  (dolist (item inits result)
2960    (let* ((name (car item))
2961           (record-name (cadr item))
2962           (inits (cddr item))
2963           (ftype (%foreign-type-or-record record-name))
2964           (ordinal (foreign-type-ordinal ftype))
2965           (ordinal-form (if (< ordinal max-canonical-foreign-type-ordinal)
2966                           ordinal
2967                           `(foreign-type-ordinal (load-time-value (%foreign-type-or-record ',record-name))))))
2968      (when (eq *host-backend* *target-backend*)
2969        (setq result (nconc result `((%set-macptr-type ,name ,ordinal-form)))))
2970      (if (typep ftype 'foreign-record-type)
2971        (setq result
2972              (nconc result (%foreign-record-field-forms name ftype record-name inits)))
2973        (progn
2974          (when inits
2975            (if (and ftype (null (cdr inits)))
2976              (setq result
2977                    (nconc result
2978                           `((setf ,(%foreign-access-form name ftype 0 nil)
2979                              ,(car inits)))))
2980              (signal-program-error "Unexpected or malformed initialization forms: ~s in field type: ~s"
2981                                    inits record-name))))))))
2982
2983(defun %foreign-record-field-forms (ptr record-type record-name inits)
2984  (unless (evenp (length inits))
2985    (signal-program-error "Unexpected or malformed initialization forms: ~s in field type: ~s"
2986                          inits record-name))
2987  (let* ((result ()))
2988    (do* ()
2989         ((null inits)
2990          `((progn
2991              ;(%assert-macptr-ftype ,ptr ,record-type)
2992              ,@(nreverse result))))
2993      (let* ((accessor (decompose-record-accessor (pop inits)))
2994             (valform (pop inits)))
2995        (push `(setf ,(%foreign-access-form ptr record-type 0  accessor) ,valform)
2996              result)))))
2997 
2998(defmacro get-field-offset (accessor)
2999  (destructuring-bind (type-name field-name) (decompose-record-accessor accessor)
3000    (let* ((record-type (require-type (%foreign-type-or-record type-name) 'foreign-record-type))
3001           (field (%find-foreign-record-type-field record-type field-name))
3002           (bit-offset (foreign-record-field-offset field)))
3003      `(values ,(floor bit-offset 8) ,(foreign-record-field-type field) ,bit-offset))))
3004
3005(defmacro record-length (recname)
3006  (%foreign-type-or-record-size recname :bytes))
3007
3008(defun make-record-form (record-name allocator &rest initforms)
3009  (let* ((ftype (%foreign-type-or-record record-name))
3010         (ordinal (foreign-type-ordinal ftype))
3011         (ordinal-form (if (< ordinal max-canonical-foreign-type-ordinal)
3012                         ordinal
3013                         `(foreign-type-ordinal (load-time-value (%foreign-type-or-record ',record-name)))))
3014         (bits (ensure-foreign-type-bits ftype))
3015         (bytes (if bits
3016                  (ceiling bits 8)
3017                  (signal-program-error "Unknown size for foreign type ~S."
3018                                        (unparse-foreign-type ftype))))
3019         (p (gensym))
3020         (memset (read-from-string "#_memset")))   
3021    `(let* ((,p (,allocator ,bytes)))
3022      ,@(when (eq *host-backend* *target-backend*)
3023              `((%set-macptr-type ,p ,ordinal-form)))
3024      (,memset ,p 0 ,bytes)
3025      ,@(%foreign-record-field-forms p ftype record-name initforms)
3026      ,p)))
3027 
3028(defmacro make-record (record-name &rest initforms)
3029  "Expand into code which allocates and initalizes an instance of the type
3030denoted by typespec, on the foreign heap. The record is allocated using the
3031C function malloc, and the user of make-record must explicitly call the C
3032function free to deallocate the record, when it is no longer needed."
3033  (apply 'make-record-form record-name 'malloc initforms))
3034
3035(defmacro make-gcable-record (record-name &rest initforms)
3036  "Like MAKE-RECORD, only advises the GC that the foreign memory can
3037   be deallocated if the returned pointer becomes garbage."
3038  (apply 'make-record-form record-name '%new-gcable-ptr initforms))
3039
3040(defmacro copy-record (type source dest)
3041  (let* ((size (* (%foreign-type-or-record-size type :words) #+64-bit-target 1 #+32-bit-target 2))
3042         (src (gensym "SRC"))
3043         (dst (gensym "DST"))
3044         (accessor #+64-bit-target '%get-unsigned-long #+32-bit-target '%get-unsigned-word)
3045         (i (gensym "I"))
3046         (j (gensym "J")))
3047    `(with-macptrs ((,src ,source)
3048                    (,dst ,dest))
3049      (do* ((,i 0 (+ ,i #+64-bit-target 4 #+32-bit-target 2))
3050            (,j 0 (+ ,j 1)))
3051           ((= ,j ,size))
3052        (declare (fixnum ,i))
3053        (setf (,accessor ,dst ,i) (,accessor ,src ,i))))))
3054
3055(defmacro assert-pointer-type (pointer type)
3056  "Assert that the pointer points to an instance of the specified foreign type.
3057Return the pointer."
3058  (let* ((ptr (gensym)))
3059    `(let* ((,ptr ,pointer))
3060      (%set-macptr-type ,ptr (foreign-type-ordinal (load-time-value (parse-foreign-type ',type))))
3061      ,ptr)))
3062
3063   
3064
3065(defmacro with-terminal-input (&body body)
3066  "Execute body in an environment with exclusive read access to the terminal."
3067  (let* ((got-it (gensym)))
3068    `(let* ((,got-it (%request-terminal-input)))
3069      (unwind-protect
3070           (progn ,@body)
3071        (%restore-terminal-input ,got-it)))))
3072
3073
3074(defmacro with-process-whostate ((whostate) &body body)
3075  `(let* ((*whostate* ,whostate))
3076    ,@body))
3077
3078
3079
3080
3081
3082(defmacro with-read-lock ((lock) &body body)
3083  "Wait until a given lock is available for read-only access, then evaluate
3084its body with the lock held."
3085  (let* ((p (gensym)))
3086    `(with-lock-context
3087      (let* ((,p ,lock))
3088        (unwind-protect
3089             (progn
3090               (read-lock-rwlock ,p)
3091               ,@body)
3092          (unlock-rwlock ,p))))))
3093
3094
3095(defmacro with-write-lock ((lock) &body body)
3096  "Wait until the given lock is available for write access, then execute
3097its body with the lock held."
3098  (let* ((p (gensym)))
3099    `(with-lock-context
3100      (let* ((,p ,lock))
3101      (unwind-protect
3102           (progn
3103             (write-lock-rwlock ,p)
3104             ,@body)
3105        (unlock-rwlock ,p))))))
3106
3107
3108
3109(defmacro without-gcing (&body body)
3110  `(unwind-protect
3111    (progn
3112      (%lock-gc-lock)
3113      ,@body)
3114    (%unlock-gc-lock)))
3115
3116(defmacro with-deferred-gc (&body body)
3117  "Execute BODY without responding to the signal used to suspend
3118threads for GC.  BODY must be very careful not to do anything which
3119could cause an exception (note that attempting to allocate lisp memory
3120may cause an exception.)"
3121  `(let* ((*interrupt-level* -2))
3122    ,@body))
3123
3124(defmacro allowing-deferred-gc (&body body)
3125  "Within the extent of a surrounding WITH-DEFERRED-GC, allow GC."
3126  `(let* ((*interrupt-level* -1))
3127    (%check-deferred-gc)
3128    ,@body))
3129
3130(defmacro defer-gc ()
3131  `(setq *interrupt-level* -2))
3132
3133
3134(defmacro with-pointer-to-ivector ((ptr ivector) &body body)
3135  "Executes BODY with PTR bound to a pointer to the first byte of data
3136in IVECTOR.  The GC is disabled during execution of BODY; PTR has
3137has dynamic-extent (and the address it references may become invalid
3138after the BODY exits.)  IVECTOR should be a (SIMPLE-ARRAY (*)) whose
3139element-type is numeric."
3140  (let* ((v (gensym)))
3141    `(let* ((,v ,ivector))
3142       (unless (typep ,v 'ivector) (report-bad-arg ,v 'ivector))
3143       (without-gcing
3144         (with-macptrs ((,ptr))
3145           (%vect-data-to-macptr ,v ,ptr)
3146           ,@body)))))
3147     
3148
3149
3150(defmacro with-other-threads-suspended (&body body)
3151  `(unwind-protect
3152    (progn
3153      (%suspend-other-threads)
3154      ,@body)
3155    (%resume-other-threads)))
3156
3157(defmacro with-package-read-lock ((p) &body body)
3158  `(with-read-lock ((pkg.lock ,p)) ,@body))
3159
3160(defmacro with-package-write-lock ((p) &body body)
3161  `(with-write-lock ((pkg.lock ,p)) ,@body))
3162
3163(defmacro with-package-lock ((p) &body body)
3164  `(with-package-write-lock (,p) ,@body))
3165
3166;;; Lock %all-packages-lock%, for shared read access to %all-packages%
3167
3168(defmacro with-package-list-read-lock (&body body)
3169  `(with-read-lock (%all-packages-lock%) ,@body))
3170
3171;;; Lock %all-packages-lock%, to allow modification to %all-packages%
3172(defmacro with-package-list-write-lock (&body body)
3173  `(with-write-lock (%all-packages-lock%) ,@body))
3174
3175(defmacro atomic-incf-decf (place delta &environment env)
3176  (setq place (macroexpand place env))
3177  (if (consp place)
3178    (let* ((sym (car place))
3179           (struct-transform (or (environment-structref-info sym env)
3180                                 (gethash sym %structure-refs%))))
3181      (if struct-transform
3182        (setq place (defstruct-ref-transform struct-transform (cdr place))
3183              sym (car place)))
3184      (ecase sym
3185        (the `(the ,(cadr place) (atomic-incf-decf ,(caddr place) ,delta)))
3186         ;; Needed so can handle %svref (which macroexpands into a LET*)
3187         ((let let*) (multiple-value-bind (body decls) (parse-body (cddr place) env t)
3188                       (unless (eql (length body) 1)
3189                         (error "~S is not a valid atomic-incf/decf place" place))
3190                       `(,sym ,(cadr place) ,@decls (atomic-incf-decf ,@body ,delta))))
3191         ;; Ditto
3192         (locally (multiple-value-bind (body decls) (parse-body (cdr place) env t)
3193                    (unless (eql (length body) 1)
3194                      (error "~S is not a valid atomic-incf/decf place" place))
3195                    `(,sym ,@decls (atomic-incf-decf ,@body ,delta))))
3196        (car `(%atomic-incf-car ,(cadr place) ,delta))
3197        (cdr `(%atomic-incf-cdr ,(cadr place) ,delta))
3198        (svref `(%atomic-incf-gvector ,@(cdr place) ,delta))))
3199    (if (and (symbolp place) (eq :special (variable-information place env)))
3200      (let* ((base (gensym))
3201             (offset (gensym)))
3202        `(multiple-value-bind (,base ,offset)
3203          (%symbol-binding-address ',place)
3204          (%atomic-incf-node ,delta ,base ,offset)))
3205      (signal-program-error "~S is not a special variable"  place))))
3206   
3207(defmacro atomic-incf (place)
3208  `(atomic-incf-decf ,place 1))
3209
3210(defmacro atomic-decf (place)
3211  `(atomic-incf-decf ,place -1))
3212
3213; Some of these macros were stolen from CMUCL.  Sort of ...
3214
3215(defmacro iterate (name binds &body body)
3216  "Iterate Name ({(Var Initial-Value)}*) Declaration* Form*
3217  This is syntactic sugar for Labels.  It creates a local function Name with
3218  the specified Vars as its arguments and the Declarations and Forms as its
3219  body.  This function is then called with the Initial-Values, and the result
3220  of the call is return from the macro."
3221  (dolist (x binds)
3222    (unless (and (listp x)
3223                 (= (length x) 2))
3224      (signal-program-error "Malformed iterate variable spec: ~S." x)))
3225
3226  `(labels ((,name ,(mapcar #'first binds) ,@body))
3227     (,name ,@(mapcar #'second binds))))
3228
3229;;;; The Collect macro:
3230
3231;;; Collect-Normal-Expander  --  Internal
3232;;;
3233;;;    This function does the real work of macroexpansion for normal collection
3234;;; macros.  N-Value is the name of the variable which holds the current
3235;;; value.  Fun is the function which does collection.  Forms is the list of
3236;;; forms whose values we are supposed to collect.
3237;;;
3238(eval-when (:compile-toplevel :load-toplevel :execute)
3239
3240
3241(defun collect-normal-expander (n-value fun forms)
3242  `(progn
3243     ,@(mapcar #'(lambda (form) `(setq ,n-value (,fun ,form ,n-value))) forms)
3244     ,n-value))
3245
3246
3247)
3248
3249(defmacro once-only (specs &body body)
3250  "Once-Only ({(Var Value-Expression)}*) Form*
3251  Create a Let* which evaluates each Value-Expression, binding a temporary
3252  variable to the result, and wrapping the Let* around the result of the
3253  evaluation of Body.  Within the body, each Var is bound to the corresponding
3254  temporary variable."
3255  (iterate frob
3256           ((specs specs)
3257            (body body))
3258    (if (null specs)
3259      `(progn ,@body)
3260      (let ((spec (first specs)))
3261        (when (/= (length spec) 2)
3262          (signal-program-error "Malformed ~s binding spec: ~S." 'once-only spec))
3263        (let ((name (first spec))
3264              (exp-temp (gensym)))
3265          `(let ((,exp-temp ,(second spec))
3266                 (,name (gensym)))
3267             `(let ((,,name ,,exp-temp))
3268                ,,(frob (rest specs) body))))))))
3269
3270(eval-when (:compile-toplevel :load-toplevel :execute)
3271(defun form-symbol (first &rest others)
3272  (intern (apply #'concatenate 'simple-base-string (string first) (mapcar #'string others))))
3273)
3274
3275
3276;;; Collect-List-Expander  --  Internal
3277;;;
3278;;;    This function deals with the list collection case.  N-Tail is the pointer
3279;;; to the current tail of the list, which is NIL if the list is empty.
3280;;;
3281(defun collect-list-expander (n-value n-tail forms)
3282  (let ((n-res (gensym)))
3283    `(progn
3284       ,@(mapcar #'(lambda (form)
3285                     `(let ((,n-res (cons ,form nil)))
3286                        (cond (,n-tail
3287                               (setf (cdr ,n-tail) ,n-res)
3288                               (setq ,n-tail ,n-res))
3289                              (t
3290                               (setq ,n-tail ,n-res  ,n-value ,n-res)))))
3291                 forms)
3292       ,n-value)))
3293
3294;;;
3295;;;    The ultimate collection macro...
3296;;;
3297
3298(defmacro collect (collections &body body)
3299  "Collect ({(Name [Initial-Value] [Function])}*) {Form}*
3300  Collect some values somehow.  Each of the collections specifies a bunch of
3301  things which collected during the evaluation of the body of the form.  The
3302  name of the collection is used to define a local macro, a la MACROLET.
3303  Within the body, this macro will evaluate each of its arguments and collect
3304  the result, returning the current value after the collection is done.  The
3305  body is evaluated as a PROGN; to get the final values when you are done, just
3306  call the collection macro with no arguments.
3307
3308  Initial-Value is the value that the collection starts out with, which
3309  defaults to NIL.  Function is the function which does the collection.  It is
3310  a function which will accept two arguments: the value to be collected and the
3311  current collection.  The result of the function is made the new value for the
3312  collection.  As a totally magical special-case, the Function may be Collect,
3313  which tells us to build a list in forward order; this is the default.  If an
3314  Initial-Value is supplied for Collect, the stuff will be rplacd'd onto the
3315  end.  Note that Function may be anything that can appear in the functional
3316  position, including macros and lambdas."
3317 
3318 
3319  (let ((macros ())
3320        (binds ()))
3321    (dolist (spec collections)
3322      (unless (<= 1 (length spec) 3)
3323        (signal-program-error "Malformed collection specifier: ~S." spec))
3324      (let ((n-value (gensym))
3325            (name (first spec))
3326            (default (second spec))
3327            (kind (or (third spec) 'collect)))
3328       
3329        (push `(,n-value ,default) binds)
3330        (if (eq kind 'collect)
3331          (let ((n-tail (gensym)))
3332            (if default
3333              (push `(,n-tail (last ,n-value)) binds)
3334              (push n-tail binds))
3335            (push `(,name (&rest args)
3336                          (collect-list-expander ',n-value ',n-tail args))
3337                  macros))
3338          (push `(,name (&rest args)
3339                        (collect-normal-expander ',n-value ',kind args))
3340                macros))))
3341    `(macrolet ,macros (let* ,(nreverse binds) (declare (ignorable ,@binds)) ,@body))))
3342
3343
3344;;; DEFENUM -- Internal Interface.
3345;;;
3346(defmacro defenum ((&key (prefix "") (suffix "") (start 0) (step 1))
3347                   &rest identifiers)
3348  (let ((results nil)
3349        (index 0)
3350        (start (eval start))
3351        (step (eval step)))
3352    (dolist (id identifiers)
3353      (multiple-value-bind
3354        (root docs)
3355        (if (consp id)
3356          (values (car id) (cdr id))
3357          (values id nil))
3358        (push `(defconstant ,(intern (concatenate 'simple-base-string
3359                                                  (string prefix)
3360                                                  (string root)
3361                                                  (string suffix)))
3362                 ,(+ start (* step index))
3363                 ,@docs)
3364              results))
3365      (incf index))
3366    `(eval-when (:compile-toplevel :load-toplevel :execute)
3367       ,@(nreverse results))))
3368
3369
3370;;; This does something like special binding, but the "bindings" established
3371;;; aren't thread-specific.
3372
3373(defmacro let-globally ((&rest vars) &body body &environment env)
3374  (multiple-value-bind (body decls) (parse-body body env)
3375    (let* ((initforms nil)
3376           (psetform nil)
3377           (specvars nil)
3378           (restoreform nil))
3379      (flet ((pair-name-value (p)
3380               (if (atom p)
3381                 (values (require-global-symbol p env) nil)
3382                 (if (and (consp (%cdr p)) (null (%cddr p)))
3383                   (values (require-global-symbol (%car p) env) (%cadr p))
3384                   (signal-program-error "Invalid variable initialization form : ~s")))))
3385        (declare (inline pair-name-value))
3386        (dolist (v vars)
3387          (let* ((oldval (gensym))
3388                 (newval (gensym)))
3389            (multiple-value-bind (var valueform) (pair-name-value v)
3390              (push var specvars)
3391              (push var restoreform)
3392              (push oldval restoreform)
3393              (push `(,oldval (uvref (symptr->symvector ',var) #.target::symbol.vcell-cell)) initforms)
3394              (push `(,newval ,valueform) initforms)
3395              (push var psetform)
3396              (push newval psetform))))
3397        `(let ,(nreverse initforms)
3398           ,@decls
3399           (locally (declare (special ,@(nreverse specvars)))
3400             (unwind-protect
3401               (progn (psetq ,@(nreverse psetform)) ,@body)
3402               (psetq ,@(nreverse restoreform)))))))))
3403;;; From CLX.
3404
3405;;; The good news is that this uses an interlocked load/store sequence
3406;;; and is fairly efficient.
3407;;; The bad news is that it only handles a few types of "place" forms.
3408;;; The good news is that CLX only uses a few types of "place" forms.
3409
3410(defmacro conditional-store (place old-value new-value &environment env)
3411  (setq place (macroexpand place env))
3412  (if (atom place)
3413    ;; CLX uses special variables' value cells as place forms.
3414    (if (and (symbolp place)
3415             (eq :special (ccl::variable-information place env)))
3416      (let* ((base (gensym))
3417             (offset (gensym)))
3418        `(multiple-value-bind (,base ,offset)
3419          (ccl::%symbol-binding-address ',place)
3420          (ccl::%store-node-conditional ,offset ,base ,old-value ,new-value)))
3421      (signal-program-error "~s is not a special variable ." place))
3422    (let* ((sym (car place))
3423           (struct-transform (or (ccl::environment-structref-info sym env)
3424                                 (gethash sym ccl::%structure-refs%))))
3425      (if struct-transform
3426        (setq place (ccl::defstruct-ref-transform struct-transform (cdr place))
3427              sym (car place)))
3428      (if (member  sym '(svref ccl::%svref ccl::struct-ref))
3429        (let* ((v (gensym)))
3430          `(let* ((,v ,(cadr place)))
3431            (ccl::store-gvector-conditional ,(caddr place)
3432             ,v ,old-value ,new-value)))
3433        (signal-program-error "Don't know how to do conditional store to ~s" place)))))
3434
3435(defmacro step (form)
3436  "The form is evaluated with single stepping enabled. Function calls
3437outside the lexical scope of the form can be stepped into only if the
3438functions in question have been compiled with sufficient DEBUG policy
3439to be at least partially steppable."
3440  form)
3441
3442(defmacro target-arch-case (&rest clauses)
3443  `(case (backend-target-arch-name *target-backend*)
3444    ,@clauses))
3445
3446(defmacro target-os-case (&rest clauses)
3447  `(ecase (backend-target-os *target-backend*)
3448    ,@clauses))
3449
3450(defmacro target-word-size-case (&rest clauses)
3451  `(ecase (arch::target-nbits-in-word (backend-target-arch *target-backend*))
3452    ,@clauses))
3453
3454(defmacro %get-natural (&body body)
3455  "A free copy of the next OpenMCL release to anyone who remembers Flakey Foont"
3456  (target-word-size-case
3457   (32 `(%get-unsigned-long ,@body))
3458   (64 `(%%get-unsigned-longlong ,@body))))
3459
3460(defmacro %get-signed-natural (&body body)
3461  "And that's my final offer."
3462  (target-word-size-case
3463   (32 `(%get-signed-long ,@body))
3464   (64 `(%%get-signed-longlong ,@body))))
3465
3466(declare-arch-specific-macro %target-kernel-global)
3467
3468;;; This behaves like a function, but looks up the kernel global
3469;;; at compile time if possible. Probably should be done as a function
3470;;; and a compiler macro, but we can't define compiler macros yet,
3471;;; and I don't want to add it to "ccl:compiler;optimizers.lisp"
3472(declare-arch-specific-macro %get-kernel-global)
3473
3474(declare-arch-specific-macro %get-kernel-global-ptr)
3475
3476(declare-arch-specific-macro area-code)
3477
3478(declare-arch-specific-macro nth-immediate)
3479
3480(declare-arch-specific-macro set-nth-immediate)
3481
3482(defsetf nth-immediate set-nth-immediate)
3483
3484(defmacro do-consing-areas ((area) &body body)
3485  (let ((code (gensym)))
3486  `(do-gc-areas (,area)
3487     (let ((,code (%fixnum-ref ,area  (area-code))))
3488       (when (or (eql ,code area-readonly)
3489                 (eql ,code area-managed-static)
3490                 (eql ,code area-static)
3491                 (eql ,code area-dynamic))
3492         ,@body)))))
3493
3494(declare-arch-specific-macro area-succ)
3495
3496
3497(defmacro do-gc-areas ((area) &body body)
3498  (let ((initial-area (gensym)))
3499    `(let* ((,initial-area (%get-kernel-global 'all-areas))
3500            (,area ,initial-area))
3501       (declare (fixnum ,initial-area ,area))
3502       (loop
3503         (setq ,area (%fixnum-ref ,area (area-succ)))
3504         (when (eql ,area ,initial-area)
3505           (return))
3506         ,@body))))
3507
3508(defmacro with-ioblock-input-lock-grabbed ((ioblock) &body body)
3509  (let* ((i (gensym)))
3510    `(let* ((,i ,ioblock))
3511      (with-lock-grabbed ((ioblock-inbuf-lock ,i))
3512        (cond ((ioblock-device ,i)
3513               ,@body)
3514              (t (stream-is-closed (ioblock-stream ,i))))))))
3515
3516(defmacro with-ioblock-output-lock-grabbed ((ioblock) &body body)
3517  (let* ((i (gensym)))
3518    `(let* ((,i ,ioblock))
3519      (with-lock-grabbed ((ioblock-outbuf-lock ,i))
3520        (cond ((ioblock-device ,i)
3521               ,@body)
3522              (t (stream-is-closed (ioblock-stream ,i))))))))
3523 
3524
3525(defmacro with-stream-ioblock-input ((ioblock stream &key
3526                                             speedy)
3527                                  &body body)
3528  `(let ((,ioblock (stream-ioblock ,stream t)))
3529     ,@(when speedy `((declare (optimize (speed 3) (safety 0)))))
3530     (with-ioblock-input-locked (,ioblock) ,@body)))
3531
3532(defmacro with-stream-ioblock-output ((ioblock stream &key
3533                                             speedy)
3534                                  &body body)
3535  `(let ((,ioblock (stream-ioblock ,stream t)))
3536     ,@(when speedy `((declare (optimize (speed 3) (safety 0)))))
3537     (with-ioblock-output-locked (,ioblock) ,@body)))
3538
3539(defmacro with-stream-ioblock-output-maybe ((ioblock stream &key
3540                                                     speedy)
3541                                            &body body)
3542  `(let ((,ioblock (stream-ioblock ,stream t)))
3543    ,@(when speedy `((declare (optimize (speed 3) (safety 0)))))
3544    (with-ioblock-output-locked-maybe (,ioblock) ,@body)))
3545
3546(defmacro with-ioblock-input-locked ((ioblock) &body body)
3547  (let* ((lock (gensym)))
3548    `(let* ((,lock (locally (declare (optimize (speed 3) (safety 0)))
3549                                  (ioblock-inbuf-lock ,ioblock))))
3550      (if ,lock
3551        (with-lock-grabbed (,lock)
3552          (cond ((ioblock-device ,ioblock)
3553                 ,@body)
3554                (t (stream-is-closed (ioblock-stream ,ioblock)))))
3555        (progn
3556          (check-ioblock-owner ,ioblock)
3557          ,@body)))))
3558
3559(defmacro with-ioblock-output-locked ((ioblock) &body body)
3560  (let* ((lock (gensym)))
3561    `(let* ((,lock (locally (declare (optimize (speed 3) (safety 0)))
3562                                  (ioblock-outbuf-lock ,ioblock))))
3563      (if ,lock
3564        (with-lock-grabbed (,lock)
3565          (cond ((ioblock-device ,ioblock)
3566                 ,@body)
3567                (t (stream-is-closed (ioblock-stream ,ioblock)))))
3568        (progn
3569          (check-ioblock-owner ,ioblock)
3570          ,@body)))))
3571
3572
3573
3574(defmacro with-ioblock-output-locked-maybe ((ioblock) &body body)
3575  (let* ((lock (gensym)))
3576    `(let* ((,lock (locally (declare (optimize (speed 3) (safety 0)))
3577                     (ioblock-outbuf-lock ,ioblock))))
3578      (if ,lock
3579        (with-lock-grabbed (,lock)
3580          (cond ((ioblock-device ,ioblock)
3581                 ,@body)
3582                (t (stream-is-closed (ioblock-stream ,ioblock)))))
3583        (progn
3584          (check-ioblock-owner ,ioblock)
3585          ,@body)))))
3586
3587;;; Use this when it's possible that the fd might be in
3588;;; a non-blocking state.  Body must return a negative of
3589;;; the os error number on failure.
3590;;; The use of READ-FROM-STRING below is certainly ugly, but macros
3591;;; that expand into reader-macros don't generally trigger the reader-macro's
3592;;; side-effects.  (Besides, the reader-macro might return a different
3593;;; value when the macro function is expanded than it did when the macro
3594;;; function was defined; this can happen during cross-compilation.)
3595(defmacro with-eagain (fd direction &body body)
3596  (let* ((res (gensym))
3597         (eagain (symbol-value (read-from-string "#$EAGAIN"))))
3598   `(loop
3599      (let ((,res (progn ,@body)))
3600        (if (eql ,res (- ,eagain))
3601          (progn
3602            (setq ,res
3603                  (,(ecase direction
3604                           (:input 'process-input-would-block)
3605                           (:output 'process-output-would-block))
3606                    ,fd))
3607            (unless (eq ,res t) (return ,res)))
3608          (return ,res))))))
3609
3610(defmacro ignoring-eintr (&body body)
3611  (let* ((res (gensym))
3612         (eintr (symbol-value (read-from-string "#$EINTR"))))
3613    `(loop
3614       (let* ((,res (progn ,@body)))
3615         (unless (eql ,res (- ,eintr))
3616           (return ,res))))))
3617
3618(defmacro ff-call-ignoring-eintr (&body body)
3619  (let* ((res (gensym))
3620         (eintr (symbol-value (read-from-string "#$EINTR"))))
3621    `(loop
3622       (let* ((,res (progn ,@body)))
3623         (declare (fixnum ,res))
3624         (when (< ,res 0)
3625           (setq ,res (%get-errno)))
3626         (unless (eql ,res (- ,eintr))
3627           (return ,res))))))
3628
3629(defmacro basic-stream-ioblock (s)
3630  `(or (basic-stream.state ,s)
3631    (stream-is-closed ,s)))
3632
3633(defsetf interrupt-level set-interrupt-level)
3634
3635(defmacro %swap-u16 (val)
3636  (let* ((arg (gensym)))
3637    `(let* ((,arg ,val))
3638      (declare (type (unsigned-byte 16) ,arg))
3639      (logand #xffff (the fixnum (logior (the fixnum (ash ,arg -8))
3640                                         (the fixnum (ash ,arg 8))))))))
3641
3642(defmacro %swap-u32 (val)
3643  (let* ((arg (gensym)))
3644    `(let ((,arg ,val))
3645      (declare (type (unsigned-byte 32) ,arg))
3646      (the (unsigned-byte 32) (logior (the (unsigned-byte 32)
3647                                        (ash (logand #xff ,arg) 24))
3648                                      (the (unsigned-byte 24)
3649                                        (logior
3650                                         (the (unsigned-byte 24) (ash (logand #xff00 ,arg) 8))
3651                                         (the (unsigned-byte 16)
3652                                           (logior
3653                                            (the (unsigned-byte 16) (ash (logand #xff0000 ,arg) -8))
3654                                            (the (unsigned-byte 8) (ash ,arg -24)))))))))))
3655   
3656
3657(defmacro multiple-value-bind (varlist values-form &body body &environment env)
3658  (multiple-value-bind (body decls)
3659                       (parse-body body env)
3660    (let ((ignore (make-symbol "IGNORE")))
3661      `(multiple-value-call #'(lambda (&optional ,@varlist &rest ,ignore)
3662                                (declare (ignore ,ignore))
3663                                ,@decls
3664                                ,@body)
3665                            ,values-form))))
3666
3667(defmacro multiple-value-setq (vars val)
3668  (if vars
3669    `(values (setf (values ,@(mapcar #'(lambda (s) (require-type s 'symbol)) vars))  ,val))
3670    `(prog1 ,val)))
3671
3672(defmacro nth-value (n form)
3673  "Evaluate FORM and return the Nth value (zero based). This involves no
3674  consing when N is a trivial constant integer."
3675  `(car (nthcdr ,n (multiple-value-list ,form))))
3676
3677
3678
3679(defmacro with-input-timeout (((stream-var &optional (stream-form stream-var)) timeout) &body body)
3680  "Execute body with STREAM-VAR bound to STREAM-FORM and with that stream's
3681stream-input-timeout set to TIMEOUT."
3682  (let* ((old-input-timeout (gensym))
3683         (stream (gensym)))
3684    `(let* ((,stream ,stream-form)
3685            (,stream-var ,stream)
3686            (,old-input-timeout (stream-input-timeout ,stream)))
3687      (unwind-protect
3688           (progn
3689             (setf (stream-input-timeout ,stream) ,timeout)
3690             ,@body)
3691        (setf (stream-input-timeout ,stream) ,old-input-timeout)))))
3692
3693(defmacro with-output-timeout (((stream-var &optional (stream-form stream-var)) timeout) &body body)
3694  "Execute body with STREAM-VAR bound to STREAM-FORM and with that stream's
3695stream-output-timeout set to TIMEOUT."
3696  (let* ((old-output-timeout (gensym))
3697         (stream (gensym)))
3698    `(let* ((,stream ,stream-form)
3699            (,stream-var ,stream)
3700            (,old-output-timeout (stream-output-timeout ,stream)))
3701      (unwind-protect
3702           (progn
3703             (setf (stream-output-timeout ,stream) ,timeout)
3704             ,@body)
3705        (setf (stream-output-timeout ,stream) ,old-output-timeout)))))
3706
3707;;; FORM returns a signed integer.  If it's non-negative, return that
3708;;; value, otherwise, return the (negative) errnor value returned by
3709;;; %GET-ERRNO
3710(defmacro int-errno-call (form)
3711  (let* ((value (gensym)))
3712    `(let* ((,value ,form))
3713      (if (< ,value 0)
3714        (%get-errno)
3715        ,value))))
3716
3717(defmacro int-errno-ffcall (entry &rest args)
3718  `(int-errno-call (ff-call ,entry ,@args)))
Note: See TracBrowser for help on using the repository browser.