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

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

Some changes in support of Slime:

Implement CCL:COMPUTE-APPLICABLE-METHODS-USING-CLASSES

Add a :stream-args argument to CCL:ACCEPT-CONNECTION, for one-time initargs for the stream being created. E.g. (accept-connection listener :stream-args `(:external-format ,external-format-for-this-connection-only))

Add CCL:TEMP-PATHNAME

Bind new var CCL:*TOP-ERROR-FRAME* to the error frame in break loops, to make it available to debugger/break hooks.

Add CCL:*SELECT-INTERACTIVE-PROCESS-HOOK* and call it to select the process to use for handling SIGINT.

Add CCL:*MERGE-COMPILER-WARNINGS* to control whether warnings with the same format string and args but different source locations should be merged.

Export CCL:COMPILER-WARNING, CCL:STYLE-WARNING, CCL:COMPILER-WARNING-FUNCTION-NAME and CCL:COMPILER-WARNING-SOURCE-NOTE.

Create a CCL:COMPILER-WARNING-SOURCE-NOTE even if not otherwise saving source locations, just using the fasl file and toplevel stream position, but taking into account compile-file-original-truename and compiler-file-original-buffer-offset. Get rid of stream-position and file-name slots in compiler warnings.

Export CCL:REPORT-COMPILER-WARNING, and make it accept a :SHORT keyword arg to skip the textual representation of the warning location.

Export CCL:NAME-OF, and make it return the fully qualified name for methods, return object for eql-specializer

Make CCL:FIND-DEFINITION-SOURCES handle xref-entries.

Export CCL:SETF-FUNCTION-SPEC-NAME, make it explicitly ignore the long-form setf method case.

Export the basic inspector API from the inspector package.

Export EQL-SPECIALIZER and SLOT-DEFINITION-DOCUMENTATION from OPENMCL-MOP

Refactor things a bit in backtrace code, define and export an API for examining backtraces:

CCL:MAP-CALL-FRAMES
CCL:FRAME-FUNCTION
CCL:FRAME-SUPPLIED-ARGUMENTS
CCL:FRAME-NAMED-VARIABLES

other misc new exports:

CCL:DEFINITION-TYPE
CCL;CALLER-FUNCTIONS
CCL:SLOT-DEFINITION-DOCUMENTATION
CCL:*SAVE-ARGLIST-INFO*
CCL:NATIVE-TRANSLATED-NAMESTRING
CCL:NATIVE-TO-PATHNAME
CCL:HASH-TABLE-WEAK-P
CCL;PROCESS-SERIAL-NUMBER
CCL:PROCESS-EXHAUSTED-P
CCL:APPLY-IN-FRAME

Other misc tweaks:

Make cbreak-loop use the break message when given a uselessly empty condition.

Use setf-function-name-p more consistently

Make find-applicable-methods handle eql specializers better.

Try to more consistently recognize lists of the form (:method ...) as method names.

Add xref-entry-full-name (which wasn't needed in the end)

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