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

Last change on this file since 11687 was 11687, checked in by gz, 10 years ago

r11680-r11686 from working-0711. Primarily make more cases of invalid-type-specifier errors come through at compile time.

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