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

Last change on this file since 14891 was 14891, checked in by gb, 8 years ago

In CASE-KEY-TESTERS: don't try to reduce EQL to EQ here. That should
happen elsewhere and should deal with other types where EQL differs
from EQ. (We've had the notion of pointer-typed constants for a while;
if someone uses #. or otherwise introduces such a constant into a CASE
clause, we need to use EQL. Yes, that'd be a strange thing to do.)

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