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

Last change on this file since 10653 was 10653, checked in by gz, 12 years ago

per gb, fixes to handler-case (and restart-case et.al.) to fix a possible race condition

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