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

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

Propagate r10938:r10941 (duplicate definition warnings) to trunk

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