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

Last change on this file since 12889 was 12889, checked in by rme, 10 years ago

In WITH-STANDARD-IO-SYNTAX, bind *READTABLE* to the standard readtable,
now that we make a distinction between the standard readtable and the
initial readtable. (see ticket:568)

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