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

Last change on this file since 16649 was 16649, checked in by rme, 5 years ago

Make defun complain if the user attempts to use NIL as a function name.
Closes ticket:613, ticket:1101. (And see ticket:1125 too.)

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