source: release/1.3/source/lib/macros.lisp @ 11814

Last change on this file since 11814 was 11814, checked in by rme, 11 years ago

Merge trunk changes r11790-r11794, r11796, r11801, r11803

(GC fixes, additional x8632 vinsns, easygui enhancements, x8632 callback fix)

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