source: branches/working-0711/ccl/lib/macros.lisp @ 11279

Last change on this file since 11279 was 11279, checked in by gz, 13 years ago

Backport compiler source location changes from trunk, mostly reorg and move file-compiler stuff out of the compiler, but also a fix to record a source note for inner functions

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