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

Last change on this file since 14307 was 14307, checked in by rme, 9 years ago

In typecheck macro, call nx1-typespec-for-typep with :whine nil.
This prevents a warning from getting pushed onto *nx-warnings*
as a side-effect.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 155.0 KB
RevLine 
[6]1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
[13067]3;;;   Copyright (C) 2009 Clozure Associates
[6]4;;;   Copyright (C) 1994-2001 Digitool, Inc
[13066]5;;;   This file is part of Clozure CL. 
[6]6;;;
[13066]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
[6]9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
[13066]10;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
[6]11;;;   conflict, the preamble takes precedence. 
12;;;
[13066]13;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
[6]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
[2325]20(in-package "CCL")
[6]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)
[929]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."
[6]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)
[10081]45  `(car (the list ,x)))
[6]46
[10081]47(defmacro set-%car (x y)
48  `(setf (car (the cons ,x)) ,y))
49
[6]50(defmacro %cdr (x)
[10081]51  `(cdr (the list ,x)))
[6]52
[10081]53(defmacro set-%cdr (x y)
54  `(setf (cdr (the cons ,x)) ,y))
55
[6]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
[13080]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
[6]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)
[13080]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)))))))
[6]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 (&rest args)
267  `(values (%badarg ,@args)))
268
269(defmacro %cons-restart (name action report interactive test)
[10219]270 `(%istruct 'restart ,name ,action ,report ,interactive ,test))
[6]271
272(defmacro restart-bind (clauses &body body)
[929]273  "Executes forms in a dynamic context where the given restart bindings are
274   in effect. Users probably want to use RESTART-CASE. When clauses contain
275   the same restart name, FIND-RESTART will find the first such clause."
[6]276  (let* ((restarts (mapcar #'(lambda (clause) 
277                               (list (make-symbol (symbol-name (require-type (car clause) 'symbol)))
278                                     `(%cons-restart nil nil nil nil nil)))
279                           clauses))
280         (bindings (mapcar #'(lambda (clause name)
281                              `(make-restart ,(car name) ',(car clause)
282                                             ,@(cdr clause)))
283                           clauses restarts))
284        (cluster (gensym)))
285    `(let* (,@restarts)
286       (declare (dynamic-extent ,@(mapcar #'car restarts)))
287       (let* ((,cluster (list ,@bindings))
288              (%restarts% (cons ,cluster %restarts%)))
289         (declare (dynamic-extent ,cluster %restarts%))
290         (progn
291           ,@body)))))
292
293(defmacro handler-bind (clauses &body body)
[929]294  "(HANDLER-BIND ( {(type handler)}* )  body)
295   Executes body in a dynamic context where the given handler bindings are
296   in effect. Each handler must take the condition being signalled as an
297   argument. The bindings are searched first to last in the event of a
298   signalled condition."
[6]299  (let* ((fns)
300         (decls)         
301         (bindings (mapcan #'(lambda (clause)
302                               (destructuring-bind (condition handler) clause
303                                 (if (and (consp handler)(eq (car handler) 'function)
304                                          (consp (cadr handler))(eq (car (cadr handler)) 'lambda))
305                                   (let ((fn (gensym)))
306                                     (push `(,fn ,handler) fns)
307                                     (push `(declare (dynamic-extent ,fn)) decls)
308                                     `(',condition ,fn))
309                                   (list `',condition
[338]310                                         `,handler))))
[6]311                           clauses))
312        (cluster (gensym)))   
[11138]313    (if (null bindings)
314      `(progn ,@body)
315      `(let* (,@fns
316              (,cluster (list ,@bindings))
317              (%handlers% (cons ,cluster %handlers%)))
318         (declare (dynamic-extent ,cluster %handlers%))
319         ,@decls
[6]320         ,@body))))
321
322(defmacro restart-case (&environment env form &rest clauses)
[929]323  "(RESTART-CASE form
324   {(case-name arg-list {keyword value}* body)}*)
325   The form is evaluated in a dynamic context where the clauses have special
326   meanings as points to which control may be transferred (see INVOKE-RESTART).
327   When clauses contain the same case-name, FIND-RESTART will find the first
328   such clause. If Expression is a call to SIGNAL, ERROR, CERROR or WARN (or
329   macroexpands into such) then the signalled condition will be associated with
330   the new restarts."
[6]331  (let ((cluster nil))
332    (when clauses (setq cluster (gensym) form (restart-case-form form env cluster)))
333    (flet ((restart-case-1 (name arglist &rest forms)
334             (let (interactive report test)
335               (loop
336                 (case (car forms)
337                   (:interactive (setq interactive (cadr forms)))
338                   (:report (setq report (cadr forms)))
339                   (:test (setq test (cadr forms)))
340                   (t (return nil)))
341                 (setq forms (cddr forms)))
342               (when (and report (not (stringp report)))
343                 (setq report `#',report))
344               (when interactive
345                 (setq interactive `#',interactive))
346               (when test
347                 (setq test `#',test))
348               (values (require-type name 'symbol) arglist report interactive test forms))))
349      (cond ((null clauses) form)
350            ((and (null (cdr clauses)) (null (cadr (car clauses))))
351             (let ((block (gensym)) 
352                   (restart-name (gensym)))
353               (multiple-value-bind (name arglist report interactive test body)
354                                    (apply #'restart-case-1 (car clauses))
355                 (declare (ignore arglist))
356                 `(block ,block
357                    (let* ((,restart-name (%cons-restart ',name () ,report ,interactive ,test))
[11138]358                           (,cluster (list ,restart-name)))
359                      (declare (dynamic-extent ,restart-name ,cluster))
360                      (catch ,cluster
361                        (let ((%restarts% (cons ,cluster %restarts%)))
362                          (declare (dynamic-extent %restarts%))
363                          (return-from ,block ,form))))
[6]364                    ,@body))))
365            (t
366             (let ((block (gensym)) (val (gensym))
367                   (index -1) restarts restart-names restart-name cases)
368               (while clauses
369                 (setq index (1+ index))
370                 (multiple-value-bind (name arglist report interactive test body)
371                                      (apply #'restart-case-1 (pop clauses))
372                   (push (setq restart-name (make-symbol (symbol-name name))) restart-names)
373                   (push (list restart-name `(%cons-restart ',name ,index ,report ,interactive ,test))
374                         restarts)
375                   (when (null clauses) (setq index t))
376                   (push `(,index (apply #'(lambda ,arglist ,@body) ,val))
377                         cases)))
378               `(block ,block
379                  (let ((,val (let* (,@restarts
[11138]380                                     (,cluster (list ,@(reverse restart-names))))
381                                (declare (dynamic-extent ,@restart-names ,cluster))
382                                (catch ,cluster
383                                  (let ((%restarts% (cons ,cluster %restarts%)))
384                                    (declare (dynamic-extent %restarts%))
385                                    (return-from ,block ,form))))))
[6]386                    (case (pop ,val)
387                      ,@(nreverse cases))))))))))
388
389
390; Anything this hairy should die a slow and painful death.
391; Unless, of course, I grossly misunderstand...
392(defun restart-case-form (form env clustername)
393  (let ((expansion (macroexpand form env))
394        (head nil))
395    (if (and (listp expansion)          ; already an ugly hack, made uglier by %error case ...
396             (memq (setq head (pop expansion)) '(signal error cerror warn %error)))
397      (let ((condform nil)
398            (signalform nil)
399            (cname (gensym)))
400        (case head
401          (cerror
402           (destructuring-bind 
403             (continue cond &rest args) expansion
404             (setq condform `(condition-arg ,cond (list ,@args) 'simple-error)
405                   signalform `(cerror ,continue ,cname))))
406          ((signal error warn)
407           (destructuring-bind
408             (cond &rest args) expansion
409             (setq condform `(condition-arg ,cond (list ,@args) ,(if (eq head 'warning)
410                                                                   ''simple-warning
411                                                                   (if (eq head 'error)
412                                                                     ''simple-error
413                                                                     ''simple-condition)))
414                   signalform `(,head ,cname))))
415          (t ;%error
416           (destructuring-bind (cond args fp) expansion
417             (setq condform `(condition-arg ,cond ,args 'simple-error)
418                   signalform `(%error ,cname nil ,fp)))))
419        `(let ((,cname ,condform))
420           (with-condition-restarts ,cname ,clustername
421             ,signalform)))
422      form)))
423     
424
[5025]425(defmacro handler-case (form &rest clauses)
[929]426  "(HANDLER-CASE form
427   { (type ([var]) body) }* )
428   Execute FORM in a context with handlers established for the condition
429   types. A peculiar property allows type to be :NO-ERROR. If such a clause
430   occurs, and form returns normally, all its values are passed to this clause
431   as if by MULTIPLE-VALUE-CALL.  The :NO-ERROR clause accepts more than one
432   var specification."
[5025]433  (let* ((no-error-clause (assoc :no-error clauses)))
434    (if no-error-clause
435      (let* ((normal-return (gensym))
436             (error-return (gensym)))
437        `(block ,error-return
438          (multiple-value-call #'(lambda ,@(cdr no-error-clause))
439            (block ,normal-return
440              (return-from ,error-return
441                (handler-case (return-from ,normal-return ,form)
442                  ,@(remove no-error-clause clauses)))))))
443      (flet ((handler-case (type var &rest body)
444               (when (eq type :no-error)
445                 (signal-program-error "Duplicate :no-error clause. "))
[6]446           (values type var body)))
[5025]447        (cond ((null clauses) form)
[6]448          ((null (cdr clauses))
449           (let ((block   (gensym))
450                 (cluster (gensym)))
451             (multiple-value-bind (type var body)
452                                  (apply #'handler-case (car clauses))
453               (if var
454                 `(block ,block
455                    ((lambda ,var ,@body)
[11138]456                      (let* ((,cluster (list ',type)))
457                        (declare (dynamic-extent ,cluster))
458                        (catch ,cluster
459                          (let ((%handlers% (cons ,cluster %handlers%)))
460                            (declare (dynamic-extent %handlers%))
461                            (return-from ,block ,form))))))
[6]462                 `(block ,block
[11138]463                    (let* ((,cluster (list ',type)))
464                      (declare (dynamic-extent ,cluster))
465                      (catch ,cluster
466                        (let ((%handlers% (cons ,cluster %handlers%)))
467                          (declare (dynamic-extent %handlers%))
468                          (return-from ,block ,form)))
469                      (locally ,@body)))))))
[6]470          (t (let ((block (gensym)) (cluster (gensym)) (val (gensym))
471                   (index -1) handlers cases)
472               (while clauses
473                 (setq index (1+ index))
474                 (multiple-value-bind (type var body)
475                                      (apply #'handler-case (pop clauses))                   
476                   (push `',type handlers)
477                   (push index handlers)
478                   (when (null clauses) (setq index t))
479                   (push (if var
480                           `(,index ((lambda ,var ,@body) ,val))
481                           `(,index (locally ,@body))) cases)))
482               `(block ,block
[11138]483                  (let ((,val (let* ((,cluster (list ,@(nreverse handlers))))
484                                (declare (dynamic-extent ,cluster))
485                                (catch ,cluster
486                                  (let ((%handlers% (cons ,cluster %handlers%)))
487                                    (declare (dynamic-extent %handlers%))
488                                    (return-from ,block ,form))))))
[6]489                    (case (pop ,val)
[5025]490                      ,@(nreverse cases)))))))))))
[6]491
492(defmacro with-simple-restart ((restart-name format-string &rest format-args)
493                               &body body
494                               &aux (cluster (gensym)) (temp (make-symbol (symbol-name restart-name))))
[929]495  "(WITH-SIMPLE-RESTART (restart-name format-string format-arguments)
496   body)
497   If restart-name is not invoked, then all values returned by forms are
498   returned. If control is transferred to this restart, it immediately
499   returns the values NIL and T."
[6]500  (unless (and (stringp format-string)
501               (null format-args)
502               (not (%str-member #\~ (ensure-simple-string format-string))))
503    (let ((stream (gensym)))
504      (setq format-string `#'(lambda (,stream) (format ,stream ,format-string ,@format-args)))))
505  `(let* ((,temp (%cons-restart ',restart-name
[578]506                                'simple-restart
[6]507                                ,format-string
508                                nil
509                                nil))
[11138]510          (,cluster (list ,temp)))
511     (declare (dynamic-extent ,temp ,cluster))
512     (catch ,cluster
513       (let ((%restarts% (cons ,cluster %restarts%)))
514         (declare (dynamic-extent %restarts%))
515         ,@body))))
[6]516
517;Like with-simple-restart but takes a pre-consed restart.  Not CL.
518(defmacro with-restart (restart &body body &aux (cluster (gensym)))
[11138]519  `(let* ((,cluster (list ,restart)))
520     (declare (dynamic-extent ,cluster))
521     (catch ,cluster
522       (let ((%restarts% (cons ,cluster %restarts%)))
523         (declare (dynamic-extent %restarts%))
524         ,@body))))
[6]525
526(defmacro ignore-errors (&rest forms)
[929]527  "Execute FORMS handling ERROR conditions, returning the result of the last
528  form, or (VALUES NIL the-ERROR-that-was-caught) if an ERROR was handled."
[6]529  `(handler-case (progn ,@forms)
530     (error (condition) (values nil condition))))
531
532(defmacro def-kernel-restart (&environment env errno name arglist &body body)
533  (multiple-value-bind (body decls)
534                       (parse-body body env)
535    `(let* ((fn (nfunction ,name (lambda ,arglist ,@decls (block ,name ,@body))))
536            (pair (assq ,errno ccl::*kernel-restarts*)))
537       (if pair
538         (rplacd pair fn)
539         (push (cons ,errno fn) ccl::*kernel-restarts*))
540       fn)))
541
542
543;;; Setf.
544
545;  If you change anything here, be sure to make the corresponding change
546;  in get-setf-method.
547(defmacro setf (&rest args &environment env)
[929]548  "Takes pairs of arguments like SETQ. The first is a place and the second
549  is the value that is supposed to go into that place. Returns the last
550  value. The place argument may be any of the access forms for which SETF
[6]551  knows a corresponding setting form."
552  (let ((temp (length args))
553        (accessor nil))
554    (cond ((eq temp 2)
555           (let* ((form (car args)) 
556                  (value (cadr args)))
557             ;This must match get-setf-method .
[11285]558             (cond ((atom form)
559                    (progn
560                      (unless (symbolp form)(signal-program-error $XNotSym form))
561                      `(setq ,form ,value)))
562                   ((eq (car form) 'the)
563                    (unless (eql (length form) 3)
564                      (error "Bad THE place form in (SETF ~S ~S)" form value))
565                    (destructuring-bind (type place) (cdr form)
566                      `(setf ,place (the ,type ,value))))
567                   (t
568                    (multiple-value-bind (ftype local-p)
569                        (function-information (setq accessor (car form)) ENV)
570                      (if local-p
571                        (if (eq ftype :function)
572                                        ;Local function, so don't use global setf definitions.
573                          (default-setf form value env)
574                          `(setf ,(macroexpand-1 form env) ,value))
575                        (cond
576                          ((setq temp (%setf-method accessor))
577                           (if (symbolp temp)
578                             `(,temp ,@(cdar args) ,value)
579                             (multiple-value-bind (dummies vals storevars setter #|getter|#)
580                                 (funcall temp form env)
581                               (do* ((d dummies (cdr d))
582                                     (v vals (cdr v))
583                                     (let-list nil))
584                                    ((null d)
585                                     (setq let-list (nreverse let-list))
586                                     `(let* ,let-list
587                                       (declare (ignorable ,@dummies))
588                                       (multiple-value-bind ,storevars ,value
589                                         #|,getter|#
590                                         ,setter)))
591                                 (push (list (car d) (car v)) let-list)))))
[14258]592                          ((and (setq temp (structref-info accessor env))
593                                (accessor-structref-info-p temp)
594                                (not (refinfo-r/o (structref-info-refinfo temp))))
595                           (let ((form (defstruct-ref-transform temp (%cdar args) env t))
596                                 (type (defstruct-type-for-typecheck (structref-info-type temp) env)))
597                             (if (eq type t)
598                               `(setf ,form ,value)
599                               ;; strip off type, but add in a typecheck
600                               `(the ,type (setf ,form (typecheck ,value ,type))))))
[11285]601                          (t
602                           (multiple-value-bind (res win)
603                               (macroexpand-1 form env)
604                             (if win
605                               `(setf ,res ,value)
606                               (default-setf form value env)))))))))))
[6]607          ((oddp temp)
[9163]608           (signal-program-error "Odd number of args to SETF : ~s." args))
[6]609          (t (do* ((a args (cddr a)) (l nil))
610                  ((null a) `(progn ,@(nreverse l)))
611               (push `(setf ,(car a) ,(cadr a)) l))))))
612
613
614(defun default-setf (setter value &optional env)
615  (let* ((reader (car setter))
616         (args (cdr setter))
617         (gensyms (mapcar #'(lambda (sym) (declare (ignore sym)) (gensym)) args))
618         types declares)
619    (flet ((form-type (form)
620             (nx-form-type form env)))
621      (declare (dynamic-extent #'form-type))
622      (setq types (mapcar #'form-type args)))
623    (dolist (sym gensyms)
624      (let ((sym-type (pop types)))
625        (unless (eq sym-type t)
626          (push `(type ,sym-type ,sym) declares))))
627    `(let ,(mapcar #'list gensyms args)
628       ,@(and declares (list `(declare ,@(nreverse declares))))
629       (funcall #'(setf ,reader) ,value ,@gensyms))))
630
631;; Establishing these setf-inverses is something that should
632;; happen at compile-time
633(defsetf elt set-elt)
634(defsetf car set-car)
[10081]635(defsetf %car set-%car)
[6]636(defsetf first set-car)
637(defsetf cdr set-cdr)
[10081]638(defsetf %cdr set-%cdr)
[6]639(defsetf rest set-cdr)
640(defsetf uvref uvset)
641(defsetf aref aset)
642(defsetf svref svset)
643(defsetf %svref %svset)
644(defsetf char set-char)
645(defsetf schar set-schar)
646(defsetf %scharcode %set-scharcode)
647(defsetf symbol-value set)
648(defsetf symbol-plist set-symbol-plist)
649(defsetf fill-pointer set-fill-pointer)
650
651; This sux; it calls the compiler twice (once to shove the macro in the
652; environment, once to dump it into the file.)
653(defmacro defmacro  (name arglist &body body &environment env)
654  (unless (symbolp name)(signal-program-error $XNotSym name))
655  (unless (listp arglist) (signal-program-error "~S is not a list." arglist))
656  (multiple-value-bind (lambda-form doc)
657                       (parse-macro-1 name arglist body env)
658    (let* ((normalized (normalize-lambda-list arglist t t))
659           (body-pos (position '&body normalized))
660           (argstring (let ((temp nil))
661                        (dolist (arg normalized)
662                          (if (eq arg '&aux)
663                            (return)
664                            (push arg temp)))
665                        (format nil "~:a" (nreverse temp)))))
666      (if (and body-pos (memq '&optional normalized)) (decf body-pos))
667      `(progn
668         (eval-when (:compile-toplevel)
669           (define-compile-time-macro ',name ',lambda-form ',env))
670         (eval-when (:load-toplevel :execute)
671           (%macro 
672            (nfunction ,name ,lambda-form)
673            '(,doc ,body-pos . ,argstring))
674           ',name)))))
675
676(defmacro define-symbol-macro (name expansion &environment env)
677  (unless (symbolp name)(signal-program-error $XNotSym name))
678  `(progn
679    (eval-when (:compile-toplevel)
680      (define-compile-time-symbol-macro ',name ',expansion ',env))
681    (eval-when (:load-toplevel :execute)
682      (%define-symbol-macro ',name ',expansion))))
683
684;; ---- allow inlining setf functions
685(defmacro defun (spec args &body body &environment env &aux global-name inline-spec)
[929]686  "Define a function at top level."
[6]687  (validate-function-name spec)
688  (setq args (require-type args 'list))
689  (setq body (require-type body 'list))
690  (multiple-value-bind (forms decls doc) (parse-body body env t)
691    (cond ((symbolp spec)
692           (setq global-name spec)
693           (setq inline-spec spec)
694           (setq body `(block ,spec ,@forms)))
[12463]695          ((setf-function-name-p spec)
[6]696           (setq inline-spec spec)
697           (setq body `(block ,(cadr spec) ,@forms)))
698          (t (setq body `(progn ,@forms))))
699    (let* ((lambda-expression `(lambda ,args 
700                                ,@(if global-name
701                                    `((declare (global-function-name ,global-name))))
702                                ,@decls ,body))
703           (info (if (and inline-spec
704                          (or (null env)
705                              (definition-environment env t))
706                          (nx-declared-inline-p inline-spec env)
707                          (not (and (symbolp inline-spec)
708                                    (gethash inline-spec *NX1-ALPHATIZERS*))))
709                   (cons doc lambda-expression)
710                   doc)))
711      `(progn
712         (%defun (nfunction ,spec ,lambda-expression) ',info)
713         ',spec))))
714
715(defmacro %defvar-init (var initform doc)
716  `(unless (%defvar ',var ,doc)
[8996]717    (set ',var ,initform)))
[6]718
719(defmacro defvar (&environment env var &optional (value () value-p) doc)
[929]720  "Define a global variable at top level. Declare the variable
721  SPECIAL and, optionally, initialize it. If the variable already has a
722  value, the old value is not clobbered. The third argument is an optional
723  documentation string for the variable."
[6]724  (if (and doc (not (stringp doc))) (report-bad-arg doc 'string))
725  (if (and (compile-file-environment-p env) (not *fasl-save-doc-strings*))
726    (setq doc nil))
727 `(progn
728    (eval-when (:compile-toplevel)
729      (note-variable-info ',var ,value-p ,env))
730    ,(if value-p
731       `(%defvar-init ,var ,value ,doc)
732       `(%defvar ',var))
733    ',var))
734         
[11138]735(defmacro def-standard-initial-binding (name &optional (form name) (doc nil doc-p) &environment env)
[6]736  `(progn
737    (eval-when (:compile-toplevel)
738      (note-variable-info ',name t ,env))   
739    (define-standard-initial-binding ',name #'(lambda () ,form))
[11138]740    ,@(when doc-p
741           `((set-documentation ',name 'variable ,doc)))
[6]742    ',name))
743
744(defmacro defparameter (&environment env var value &optional doc)
[929]745  "Define a parameter that is not normally changed by the program,
746  but that may be changed without causing an error. Declare the
747  variable special and sets its value to VAL, overwriting any
748  previous value. The third argument is an optional documentation
749  string for the parameter."
[6]750  (if (and doc (not (stringp doc))) (signal-program-error "~S is not a string." doc))
751  (if (and (compile-file-environment-p env) (not *fasl-save-doc-strings*))
752    (setq doc nil))
753  `(progn
754     (eval-when (:compile-toplevel)
755       (note-variable-info ',var t ,env))
756     (%defparameter ',var ,value ,doc)))
757
[6222]758
759(defmacro defstatic (&environment env var value &optional doc)
760  "Syntax is like DEFPARAMETER.  Proclaims the symbol to be special,
761but also asserts that it will never be given a per-thread dynamic
762binding.  The value of the variable can be changed (via SETQ, etc.),
763but since all threads access the same static binding of the variable,
764such changes should be made with care."
[6]765  (if (and doc (not (stringp doc))) (signal-program-error "~S is not a string." doc))
766  (if (and (compile-file-environment-p env) (not *fasl-save-doc-strings*))
767    (setq doc nil))
768  `(progn
769     (eval-when (:compile-toplevel)
770       (note-variable-info ',var :global ,env))
771     (%defglobal ',var ,value ,doc)))
772
[11622]773(defmacro defstaticvar (&environment env var value &optional doc)
774  "Syntax is like DEFVAR.  Proclaims the symbol to be special,
775but also asserts that it will never be given a per-thread dynamic
776binding.  The value of the variable can be changed (via SETQ, etc.),
777but since all threads access the same static binding of the variable,
778such changes should be made with care.  Like DEFVAR, the initial value
779form is not evaluated if the variable is already BOUNDP."
780  (if (and doc (not (stringp doc))) (signal-program-error "~S is not a string." doc))
781  (if (and (compile-file-environment-p env) (not *fasl-save-doc-strings*))
782    (setq doc nil))
783  `(progn
784     (eval-when (:compile-toplevel)
785       (note-variable-info ',var :global ,env))
[11739]786      (%symbol-bits ',var (logior (ash 1 $sym_vbit_global) (the fixnum (%symbol-bits ',var))))
[11622]787     (%defvar-init ,var ,value ,doc)))
[6]788
[11622]789
[6222]790(defmacro defglobal (&rest args)
791  "Synonym for DEFSTATIC."
792  `(defstatic ,@args))
793
794
[12535]795(defmacro defloadvar (var value &optional doc)
[6]796  `(progn
[11622]797     (defstaticvar ,var ,nil ,@(if doc `(,doc)))
[6]798     (def-ccl-pointers ,var ()
799       (setq ,var ,value))
800     ',var))
801
802
[6222]803
804
[6]805(defmacro qlfun (name args &body body)
806  `(nfunction ,name (lambda ,args ,@body)))
807
808(defmacro lfun-bits-known-function (f)
809  (let* ((temp (gensym)))
[3901]810    `(let* ((,temp (function-to-function-vector ,f)))
[6]811      (%svref ,temp (the fixnum (1- (the fixnum (uvsize ,temp))))))))
812
[11128]813(defmacro lfunloop (for var in function &body loop-body)
814  "Loop over immediates in function"
815  (assert (and (or (equal (symbol-name for) "FOR") (equal (symbol-name for) "AS"))
816               (equal (symbol-name in) "IN")))
817  (let ((fn (gensym))
818        (lfv (gensym))
819        (i (gensym)))
820    `(loop with ,fn = ,function
821           with ,lfv = (function-to-function-vector ,fn)
[14119]822           for ,i from #+ppc-target 1 #+x86-target (%function-code-words ,fn) #+arm-target 2  below (%i- (uvsize  ,lfv) 1)
[11128]823           as ,var = (%svref ,lfv ,i)
824           ,@loop-body)))
825
[6]826(defmacro cond (&rest args &aux clause)
827  (when args
828     (setq clause (car args))
829     (if (cdr clause)         
830         `(if ,(car clause) (progn ,@(cdr clause)) (cond ,@(cdr args)))
831       (if (cdr args) `(or ,(car clause) (cond ,@(cdr args)))
832                      `(values ,(car clause))))))
833
834(defmacro and (&rest args)
[1261]835  "And Form*
836AND evaluates each form in sequence, from left to right.  If any form
837returns NIL, AND returns NIL; otherwise, AND returns the values(s) returned
838by the last form.  If there are no forms, AND returns T."
[6]839  (if (null args) t
840    (if (null (cdr args)) (car args)
841      `(if ,(car args) (and ,@(cdr args))))))
842
843(defmacro or (&rest args)
[1261]844  "Or Form*
845OR evaluates each Form, in sequence, from left to right.
846If any Form but the last returns a non-NIL value, OR returns that
847single value (without evaluating any subsequent Forms.)  If OR evaluates
848the last Form, it returns all values returned by that Form.  If there
849are no Forms, OR returns NIL."
[6]850  (if args
851    (if (cdr args)
852      (do* ((temp (gensym))
853            (handle (list nil))
854            (forms `(let ((,temp ,(pop args)))
[1261]855                     (if ,temp ,temp ,@handle))))
[6]856           ((null (cdr args))
857            (%rplaca handle (%car args))
858            forms)
859        (%rplaca handle `(if (setq ,temp ,(%car args)) 
[1261]860                          ,temp 
861                          ,@(setq handle (list nil))))
[6]862        (setq args (%cdr args)))
863      (%car args))))
864
[929]865(defmacro case (key &body forms)
866  "CASE Keyform {({(Key*) | Key} Form*)}*
867  Evaluates the Forms in the first clause with a Key EQL to the value of
868  Keyform. If a singleton key is T then the clause is a default clause."
[6]869   (let ((key-var (gensym)))
870     `(let ((,key-var ,key))
871        (declare (ignorable ,key-var))
872        (cond ,@(case-aux forms key-var nil nil)))))
873
874(defmacro ccase (keyplace &body forms)
[929]875  "CCASE Keyform {({(Key*) | Key} Form*)}*
876  Evaluates the Forms in the first clause with a Key EQL to the value of
877  Keyform. If none of the keys matches then a correctable error is
878  signalled."
[6]879  (let* ((key-var (gensym))
880         (tag (gensym)))
881    `(prog (,key-var)
882       ,tag
883       (setq ,key-var ,keyplace)
884       (return (cond ,@(case-aux forms key-var tag keyplace))))))
885
886(defmacro ecase (key &body forms)
[929]887  "ECASE Keyform {({(Key*) | Key} Form*)}*
888  Evaluates the Forms in the first clause with a Key EQL to the value of
889  Keyform. If none of the keys matches then an error is signalled."
[6]890  (let* ((key-var (gensym)))
891    `(let ((,key-var ,key))
892       (declare (ignorable ,key-var))
893       (cond ,@(case-aux forms key-var 'ecase nil)))))
894       
895(defun case-aux (clauses key-var e-c-p placename &optional (used-keys (list (list '%case-core))))
896  (if clauses
897    (let* ((key-list (caar clauses))
898           (stype (if e-c-p (if (eq e-c-p 'ecase) e-c-p 'ccase) 'case))
899           (test (cond ((and (not e-c-p)
900                             (or (eq key-list 't)
901                                 (eq key-list 'otherwise)))
902                        t)
903                       (key-list
904                        (cons 'or
905                              (case-key-testers key-var used-keys key-list stype)))))
906           (consequent-list (or (%cdar clauses) '(nil))))
907      (if (eq test t)
908        (progn
909          (when (%cdr clauses) (warn "~s or ~s clause in the middle of a ~s statement.  Subsequent clauses ignored."
910                                     't 'otherwise 'case))
911          (cons (cons t consequent-list) nil))
912        (cons (cons test consequent-list)
913              (case-aux (%cdr clauses) key-var e-c-p placename used-keys))))
914    (when e-c-p
915      (setq used-keys `(member ,@(mapcar #'car (cdr used-keys))))
916      (if (eq e-c-p 'ecase)
917        `((t (values (%err-disp #.$XWRONGTYPE ,key-var ',used-keys))))
918        `((t (setf ,placename (ensure-value-of-type ,key-var ',used-keys ',placename))
919           (go ,e-c-p)))))))
920
921
922;;; We don't want to descend list structure more than once (like this has
923;;; been doing for the last 18 years or so.)
924(defun case-key-testers (symbol used-keys atom-or-list statement-type &optional recursive)
925  (if (or recursive (atom atom-or-list))
926    (progn
927      (if (assoc atom-or-list used-keys)
928        (warn "Duplicate keyform ~s in ~s statement." atom-or-list statement-type)
[11138]929        (setq used-keys (nconc used-keys (list (cons atom-or-list t)))))
[6]930      `((,(if (typep atom-or-list '(and number (not fixnum)))
931              'eql
932              'eq)
933         ,symbol ',atom-or-list)))
934    (nconc (case-key-testers symbol used-keys (car atom-or-list) statement-type t)
935           (when (cdr atom-or-list)
936             (case-key-testers symbol used-keys (%cdr atom-or-list) statement-type nil)))))
937
938
939; generate the COND body of a {C,E}TYPECASE form
940(defun typecase-aux (key-var clauses &optional e-c-p keyform)
941  (let* ((construct (if e-c-p (if (eq e-c-p 'etypecase) e-c-p 'ctypecase) 'typecase))
942         (types ())
[909]943         (body ())
944         otherwise-seen-p)
[6]945    (flet ((bad-clause (c) 
[9163]946             (signal-program-error "Invalid clause ~S in ~S form." c construct)))
[6]947      (dolist (clause clauses)
948        (if (atom clause)
[909]949            (bad-clause clause))
950        (if otherwise-seen-p
[9163]951            (signal-program-error "OTHERWISE must be final clause in ~S form." construct))
[909]952        (destructuring-bind (typespec &body consequents) clause
953          (when (eq construct 'typecase)
954            (if (eq typespec 'otherwise)
955                (progn (setq typespec t)
956                       (setq otherwise-seen-p t))))
957          (unless
958              (dolist (already types nil)
959                (when (subtypep typespec already)
960                  (warn "Clause ~S ignored in ~S form - shadowed by ~S ." clause construct (assq already clauses))
961                  (return t)))
962            (push typespec types)
963            (setq typespec `(typep ,key-var ',typespec))
964            (push `(,typespec nil ,@consequents) body))))
[6]965      (when e-c-p
966        (setq types `(or ,@(nreverse types)))
967        (if (eq construct 'etypecase)
[909]968            (push `(t (values (%err-disp #.$XWRONGTYPE ,key-var ',types))) body)
[5674]969            (push `(t (setf ,keyform (ensure-value-of-type  ,key-var ',types ',keyform))
[909]970                      (go ,e-c-p)) body))))
[6]971    `(cond ,@(nreverse body))))
972
973(defmacro typecase (keyform &body clauses)
[929]974  "TYPECASE Keyform {(Type Form*)}*
975  Evaluates the Forms in the first clause for which TYPEP of Keyform and Type
976  is true."
[6]977  (let ((key-var (gensym)))
978    `(let ((,key-var ,keyform))
979       (declare (ignorable ,key-var))
980       ,(typecase-aux key-var clauses))))
981
982(defmacro etypecase (keyform &body clauses)
[929]983  "ETYPECASE Keyform {(Type Form*)}*
984  Evaluates the Forms in the first clause for which TYPEP of Keyform and Type
985  is true. If no form is satisfied then an error is signalled."
[6]986  (let ((key-var (gensym)))
987    `(let ((,key-var ,keyform))
988       (declare (ignorable ,key-var))
989       ,(typecase-aux key-var clauses 'etypecase))))
990
[5674]991(defmacro ctypecase (keyplace &body clauses)
992  "CTYPECASE Key {(Type Form*)}*
[929]993  Evaluates the Forms in the first clause for which TYPEP of Keyform and Type
994  is true. If no form is satisfied then a correctable error is signalled."
[6]995  (let ((key-var (gensym))
996        (tag (gensym)))
997    `(prog (,key-var)
998       ,tag
[5674]999       (setq ,key-var ,keyplace)
1000       (return ,(typecase-aux key-var clauses tag keyplace)))))
[6]1001
1002(defmacro destructuring-bind (lambda-list expression &body body)
[929]1003  "Bind the variables in LAMBDA-LIST to the contents of ARG-LIST."
[6]1004  (multiple-value-bind (bindings decls)
1005      (%destructure-lambda-list  lambda-list expression nil nil)
1006    `(let* ,(nreverse bindings)
1007      ,@(when decls `((declare ,@decls)))
1008      ,@body)))
1009
1010(defmacro make-destructure-state (tail whole lambda)
[10219]1011  `(%istruct 'destructure-state ,tail ,whole ,lambda))
[6]1012
1013
1014; This is supposedly ANSI CL.
1015(defmacro lambda (&whole lambda-expression (&rest paramlist) &body body)
[12215]1016  (declare (ignore paramlist body))
[6]1017  (unless (lambda-expression-p lambda-expression)
1018    (warn "Invalid lambda expression: ~s" lambda-expression))
[12215]1019  `(function ,lambda-expression))
[6]1020
[10942]1021; This isn't
1022(defmacro nlambda (name (&rest arglist) &body body)
1023  `(nfunction ,name (lambda ,arglist ,@body)))
[6]1024
1025(defmacro when (test &body body)
[929]1026  "If the first argument is true, the rest of the forms are
1027  evaluated as a PROGN."
[6]1028 `(if ,test
1029   (progn ,@body)))
1030
1031(defmacro unless (test &body body)
[929]1032  "If the first argument is not true, the rest of the forms are
1033  evaluated as a PROGN."
[6]1034 `(if (not ,test)
1035   (progn ,@body)))
1036
1037(defmacro return (&optional (form nil form-p))
1038  `(return-from nil ,@(if form-p `(,form))))
1039
1040; since they use tagbody, while & until BOTH return NIL
1041(defmacro while (test &body body)
1042  (let ((testlab (gensym))
1043        (toplab (gensym)))
1044    `(tagbody
1045       (go ,testlab)
1046      ,toplab
1047      (progn ,@body)
1048      ,testlab
1049      (when ,test (go ,toplab)))))
1050
1051(defmacro until (test &body body)
1052  (let ((testlab (gensym))
1053        (toplab (gensym)))
1054    `(tagbody
1055       (go ,testlab)
1056      ,toplab
1057      (progn ,@body)
1058      ,testlab
1059      (if (not ,test)
1060        (go ,toplab)))))
1061
1062(defmacro psetq (&whole call &body pairs &environment env)
[929]1063  "PSETQ {var value}*
1064   Set the variables to the values, like SETQ, except that assignments
1065   happen in parallel, i.e. no assignments take place until all the
1066   forms have been evaluated."
[6]1067  (when pairs
1068   (if (evenp (length pairs))
1069     (do* ((l pairs (%cddr l))
1070           (sym (%car l) (%car l)))
1071          ((null l) (%pset pairs))
1072       (unless (symbolp sym) (report-bad-arg sym 'symbol))
1073       (when (nth-value 1 (macroexpand-1 sym env))
1074         (return `(psetf ,@pairs))))
[9163]1075     (signal-program-error "Uneven number of args in the call ~S" call))))
[6]1076
1077; generates body for psetq.
1078; "pairs" is a proper list whose length is not odd.
1079(defun %pset (pairs)
1080 (when pairs
1081   (let (vars vals gensyms let-list var val sets)
1082      (loop
1083        (setq var (pop pairs)
1084              val (pop pairs))
1085        (if (null pairs) (return))
1086        (push var vars)
1087        (push val vals)
1088        (push (gensym) gensyms))
1089      (dolist (g gensyms)
1090        (push g sets)
1091        (push (pop vars) sets)
1092        (push (list g (pop vals)) let-list))
1093      (push val sets)
1094      (push var sets)
1095      `(progn
1096         (let ,let-list
1097           (setq ,@sets))
1098         nil))))
1099
1100
1101(eval-when (:compile-toplevel :load-toplevel :execute)
1102(defun do-loop (binder setter env var-init-steps end-test result body)
1103  (let ((toptag (gensym))
1104        (testtag (gensym)))
1105    (multiple-value-bind (forms decls) (parse-body body env nil)
1106      `(block nil
1107         (,binder ,(do-let-vars var-init-steps)
1108                  ,@decls
1109                  (tagbody ; crocks-r-us.
1110                    (go ,testtag)
1111                    ,toptag
1112                    (tagbody
1113                      ,@forms)
1114                    (,setter ,@(do-step-vars var-init-steps))
1115                    ,testtag
1116                    (unless ,end-test
1117                      (go ,toptag)))
1118                  ,@result)))))
1119)
1120
1121(defmacro do (&environment env var-init-steps (&optional end-test &rest result) &body body)
[929]1122  "DO ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form*
1123  Iteration construct. Each Var is initialized in parallel to the value of the
1124  specified Init form. On subsequent iterations, the Vars are assigned the
1125  value of the Step form (if any) in parallel. The Test is evaluated before
1126  each evaluation of the body Forms. When the Test is true, the Exit-Forms
1127  are evaluated as a PROGN, with the result being the value of the DO. A block
1128  named NIL is established around the entire expansion, allowing RETURN to be
1129  used as an alternate exit mechanism."
[6]1130  (do-loop 'let 'psetq env var-init-steps end-test result body))
1131
1132(defmacro do* (&environment env var-init-steps (&optional end-test &rest result) &body body)
[929]1133  "DO* ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form*
1134  Iteration construct. Each Var is initialized sequentially (like LET*) to the
1135  value of the specified Init form. On subsequent iterations, the Vars are
1136  sequentially assigned the value of the Step form (if any). The Test is
1137  evaluated before each evaluation of the body Forms. When the Test is true,
1138  the Exit-Forms are evaluated as a PROGN, with the result being the value
1139  of the DO. A block named NIL is established around the entire expansion,
1140  allowing RETURN to be used as an laternate exit mechanism."
[6]1141  (do-loop 'let* 'setq env var-init-steps end-test result body))
1142
1143
1144(defun do-let-vars (var-init-steps)
1145  (if var-init-steps
1146      (cons (list (do-let-vars-var (car var-init-steps))
1147                  (do-let-vars-init (car var-init-steps)))
1148             (do-let-vars (cdr var-init-steps)))))
1149
1150(defun do-let-vars-var (var-init-step)
1151  (if (consp var-init-step)
1152       (car var-init-step)
1153       var-init-step))
1154
1155(defun do-let-vars-init (var-init-step)
1156   (if (consp var-init-step)
1157        (cadr var-init-step)
1158        nil))
1159
1160(defun do-step-vars (var-init-steps)
1161    (if var-init-steps
1162        (if (do-step-vars-step? (car var-init-steps))
1163             (append (list (do-let-vars-var (car var-init-steps))
1164                           (do-step-vars-step (car var-init-steps)))
1165                     (do-step-vars (cdr var-init-steps)))
1166             (do-step-vars (cdr var-init-steps)))))
1167
1168(defun do-step-vars-step? (var-init-step)
1169  (if (consp var-init-step)
1170       (cddr var-init-step)))
1171
1172(defun do-step-vars-step (var-init-step)
1173  (if (consp var-init-step)
1174       (caddr var-init-step)))
1175
1176
1177(defmacro dotimes ((i n &optional result) &body body &environment env)
1178  (multiple-value-bind (forms decls)
1179                       (parse-body body env)
1180    (if (not (symbolp i))(signal-program-error $Xnotsym i))
1181    (let* ((toptag (gensym))
1182           (limit (gensym)))
1183      `(block nil
1184        (let ((,limit ,n) (,i 0))
1185         ,@decls
1186         (declare (unsettable ,i))
1187           (if (int>0-p ,limit)
1188             (tagbody
1189               ,toptag
1190               ,@forms
1191               (locally
1192                (declare (settable ,i))
1193                (setq ,i (1+ ,i)))
1194               (unless (eql ,i ,limit) (go ,toptag))))
1195           ,result)))))
1196 
1197(defun do-syms-result (var resultform)
1198  (unless (eq var resultform)
1199    (if (and (consp resultform) (not (quoted-form-p resultform)))
1200      `(progn (setq ,var nil) ,resultform)
1201      resultform)))
1202
1203(defun expand-package-iteration-macro (iteration-function var pkg-spec resultform body env)
1204  (multiple-value-bind (body decls) (parse-body body env nil)
1205    (let* ((ftemp (gensym))
1206           (vtemp (gensym))
[2188]1207           (ptemp (gensym))
[6]1208           (result (do-syms-result var resultform)))
1209      `(block nil
[2188]1210        (let* ((,var nil)
1211               (,ptemp ,pkg-spec))
[6]1212          ,@decls
1213           (flet ((,ftemp (,vtemp) (declare (debugging-function-name nil)) (setq ,var ,vtemp) (tagbody ,@body)))
1214             (declare (dynamic-extent #',ftemp))
[2188]1215             (,iteration-function ,ptemp #',ftemp))
[6]1216           ,@(when result `(,result)))))))
1217
1218(defmacro do-symbols ((var &optional pkg result) &body body &environment env)
[929]1219  "DO-SYMBOLS (VAR [PACKAGE [RESULT-FORM]]) {DECLARATION}* {TAG | FORM}*
1220   Executes the FORMs at least once for each symbol accessible in the given
1221   PACKAGE with VAR bound to the current symbol."
[6]1222  (expand-package-iteration-macro 'iterate-over-accessable-symbols var pkg result body env))
1223
1224(defmacro do-present-symbols ((var &optional pkg result) &body body &environment env)
1225  (expand-package-iteration-macro 'iterate-over-present-symbols var pkg result body env))
1226
1227(defmacro do-external-symbols ((var &optional pkg result) &body body &environment env)
[929]1228  "DO-EXTERNAL-SYMBOLS (VAR [PACKAGE [RESULT-FORM]]) {DECL}* {TAG | FORM}*
1229   Executes the FORMs once for each external symbol in the given PACKAGE with
1230   VAR bound to the current symbol."
[6]1231  (expand-package-iteration-macro 'iterate-over-external-symbols var pkg result body env))
1232
[929]1233(defmacro do-all-symbols ((var &optional resultform)
[6]1234                          &body body &environment env)
[929]1235  "DO-ALL-SYMBOLS (VAR [RESULT-FORM]) {DECLARATION}* {TAG | FORM}*
1236   Executes the FORMs once for each symbol in every package with VAR bound
1237   to the current symbol."
[6]1238  (multiple-value-bind (body decls) (parse-body body env nil)
1239    (let* ((ftemp (gensym))
1240           (vtemp (gensym))
1241           (result (do-syms-result var resultform)))
1242      `(block nil
1243        (let* ((,var nil))
1244         ,@decls
1245           (flet ((,ftemp (,vtemp) (declare (debugging-function-name nil)) (setq ,var ,vtemp) (tagbody ,@body)))
1246             (declare (dynamic-extent #',ftemp))
1247             (iterate-over-all-symbols #',ftemp))
1248           ,@(when result `(,result)))))))
1249
1250(defmacro multiple-value-list (form)
1251  `(multiple-value-call #'list ,form))
1252
1253
1254
1255
1256(defmacro %i> (x y)
1257  `(> (the fixnum ,x) (the fixnum ,y)))
1258
1259(defmacro %i< (x y)
1260  `(< (the fixnum ,x) (the fixnum ,y)))
1261
1262(defmacro %i<= (x y)
1263 `(not (%i> ,x ,y)))
1264
1265(defmacro %i>= (x y)
1266 `(not (%i< ,x ,y)))
1267
1268(defmacro bitset (bit number)
1269  `(logior (ash 1 ,bit) ,number))
1270
1271(defmacro bitclr (bit number)
1272  `(logand (lognot (ash 1 ,bit)) ,number))
1273
1274(defmacro bitopf ((op bit place) &environment env)
1275  (multiple-value-bind (vars vals stores store-form access-form)
1276                       (get-setf-method place env)
1277    (let* ((constant-bit-p (constantp bit))
1278           (bitvar (if constant-bit-p bit (gensym))))
1279      `(let ,(unless constant-bit-p `((,bitvar ,bit)))          ; compiler isn't smart enough
1280         (let* ,(mapcar #'list `(,@vars ,@stores) `(,@vals (,op ,bitvar ,access-form)))
1281           ,store-form)))))
1282
1283(defmacro bitsetf (bit place)
1284  `(bitopf (bitset ,bit ,place)))
1285
1286(defmacro bitclrf (bit place)
1287  `(bitopf (bitclr ,bit ,place)))
1288
1289(defmacro %svref (v i)
1290  (let* ((vtemp (make-symbol "VECTOR"))
1291           (itemp (make-symbol "INDEX")))
1292      `(let* ((,vtemp ,v)
1293              (,itemp ,i))
1294         (locally (declare (optimize (speed 3) (safety 0)))
1295           (svref ,vtemp ,itemp)))))
1296
[12535]1297(defmacro %svset (v i new)
[6]1298  (let* ((vtemp (make-symbol "VECTOR"))
[3410]1299         (itemp (make-symbol "INDEX"))
1300         (ntemp (make-symbol "NEW")))
1301    `(let* ((,vtemp ,v)
1302            (,itemp ,i)
1303            (,ntemp ,new))
1304      (locally (declare (optimize (speed 3) (safety 0)))
1305        (setf (svref ,vtemp ,itemp) ,ntemp)))))
[6]1306
1307
1308(defmacro %schar (v i)
1309  (let* ((vtemp (make-symbol "STRING"))
1310         (itemp (make-symbol "INDEX")))
1311    `(let* ((,vtemp ,v)
1312            (,itemp ,i))
1313       (locally (declare (optimize (speed 3) (safety 0)))
1314         (schar ,vtemp ,itemp)))))
1315
1316(defmacro %set-schar (v i new)
1317  (let* ((vtemp (make-symbol "STRING"))
[3410]1318         (itemp (make-symbol "INDEX"))
1319         (ntemp (make-symbol "NEW")))
[6]1320      `(let* ((,vtemp ,v)
[3410]1321              (,itemp ,i)
1322              (,ntemp ,new))
[6]1323         (locally (declare (optimize (speed 3) (safety 0)))
[3410]1324           (setf (schar ,vtemp ,itemp) ,ntemp)))))
[6]1325
1326
1327(defmacro %char-code (c) `(char-code (the character ,c)))
[14228]1328;;; %CODE-CHAR is used internally.  It can sometimes exploit the
1329;;; assertion that the character code is an (UNSIGNED-BYTE 8) to
1330;;; generate better compiled code (partly because all such character
1331;;; codes denote characters.)
1332;;; Confusingly, it's not just the inverse of %CHAR-CODE.  It's
1333;;; almost always going to be open-coded, so this macro definition
1334;;; is mostly just a kind of documentation.
1335(defmacro %code-char (i) `(code-char (the (mod 256) ,i)))
[6]1336
1337(defmacro %izerop (x) `(eq ,x 0))
1338(defmacro %iminusp (x) `(< (the fixnum ,x) 0))
1339(defmacro %i+ (&rest (&optional (n0 0) &rest others))
1340  (if others
1341    `(the fixnum (+ (the fixnum ,n0) (%i+ ,@others)))
1342    `(the fixnum ,n0)))
1343(defmacro %i- (x y &rest others) 
1344  (if (not others)
1345    `(the fixnum (- (the fixnum ,x) (the fixnum ,y)))
1346    `(the fixnum (- (the fixnum ,x) (the fixnum (%i+ ,y ,@others))))))
1347
1348
1349(defmacro %i* (x y) `(the fixnum (* (the fixnum ,x) (the fixnum ,y))))
1350
1351(defmacro %ilogbitp (b i)
[3539]1352  (target-word-size-case
1353   (32
[1765]1354    `(logbitp (the (integer 0 29) ,b) (the fixnum ,i)))
[3539]1355   (64
[1765]1356    `(logbitp (the (integer 0 60) ,b) (the fixnum ,i)))))
[6]1357
1358;;; Seq-Dispatch does an efficient type-dispatch on the given Sequence.
1359
1360(defmacro seq-dispatch (sequence list-form array-form)
1361  `(if (sequence-type ,sequence)
1362       ,list-form
1363       ,array-form))
1364
1365
1366(defsetf %get-byte %set-byte)
[3439]1367(defsetf %get-unsigned-byte %set-unsigned-byte)
[6]1368(defsetf %get-signed-byte %set-byte)
1369(defsetf %get-word %set-word)
1370(defsetf %get-signed-word %set-word)
[3439]1371(defsetf %get-unsigned-word %set-unsigned-word)
[6]1372(defsetf %get-long %set-long)
1373(defsetf %get-signed-long %set-long)
[3439]1374(defsetf %get-unsigned-long %set-unsigned-long)
[6]1375(defsetf %get-full-long %set-long)
1376(defsetf %get-point %set-long)
1377(defsetf %get-ptr %set-ptr)
1378(defsetf %get-double-float %set-double-float)
1379(defsetf %get-single-float %set-single-float)
1380(defsetf %get-bit %set-bit)
1381(defsetf %get-unsigned-long-long %set-unsigned-long-long)
1382(defsetf %%get-unsigned-longlong %%set-unsigned-longlong)
1383(defsetf %get-signed-long-long %set-signed-long-long)
1384(defsetf %%get-signed-longlong %%set-signed-longlong)
1385(defsetf %get-bitfield %set-bitfield)
1386
1387(defmacro %ilognot (int) `(%i- -1 ,int))
1388
1389(defmacro %ilogior2 (x y) 
1390  `(logior (the fixnum ,x) (the fixnum ,y)))
1391
[12215]1392(defmacro %ilogior (body &rest args)
[6]1393   (while args
1394     (setq body (list '%ilogior2 body (pop args))))
1395   body)
1396
1397(defmacro %ilogand2 (x y)
1398  `(logand (the fixnum ,x) (the fixnum ,y)))
1399
1400(defmacro %ilogand (body &body args)
1401   (while args
1402     (setq body (list '%ilogand2 body (pop args))))
1403   body)
1404
1405(defmacro %ilogxor2 (x y)
1406  `(logxor (the fixnum ,x) (the fixnum ,y)))
1407
1408(defmacro %ilogxor (body &body args)
1409   (while args
1410     (setq body (list '%ilogxor2 body (pop args))))
1411   body)
1412
[5974]1413(defmacro with-macptrs (varlist &rest body &environment env)
1414  (multiple-value-bind (body other-decls) (parse-body body env)
[6222]1415    (collect ((temp-bindings)
1416              (temp-decls)
1417              (bindings)
[5974]1418              (our-decls)
1419              (inits))
1420      (dolist (var varlist)
[6222]1421        (let* ((temp (gensym)))
1422          (temp-decls temp)
[5974]1423        (if (consp var)
1424          (progn
1425            (our-decls (car var))
[6222]1426            (temp-bindings `(,temp (%null-ptr)))
1427            (bindings `(,(car var) ,temp))
[5974]1428            (if (cdr var)
[6222]1429              (inits `(%setf-macptr ,temp ,@(cdr var)))))
[5974]1430          (progn
1431            (our-decls var)
[6222]1432            (temp-bindings  `(,temp  (%null-ptr)))
1433            (bindings `(,var ,temp))))))
1434  `(let* ,(temp-bindings)
1435    (declare (dynamic-extent ,@(temp-decls)))
1436    (declare (type macptr ,@(temp-decls)))
[5974]1437    ,@(inits)
[6222]1438    (let* ,(bindings)
1439      (declare (type macptr ,@(our-decls)))
1440      ,@other-decls
1441      ,@body)))))
[6]1442
[6222]1443
[6]1444(defmacro with-loading-file (filename &rest body)
1445   `(let ((*loading-files* (cons ,filename (locally (declare (special *loading-files*))
1446                                                    *loading-files*))))
1447      (declare (special *loading-files*))
1448      ,@body))
1449
1450(defmacro with-input-from-string ((var string &key index start end) &body forms &environment env)
[2453]1451  "Create an input string stream, provide an opportunity to perform
1452operations on the stream (returning zero or more values), and then close
1453the string stream.
1454
1455STRING is evaluated first, and VAR is bound to a character input string
1456stream that supplies characters from the subsequence of the resulting
1457string bounded by start and end. BODY is executed as an implicit progn."
[6]1458  (multiple-value-bind (forms decls) (parse-body forms env nil)
1459    `(let ((,var
1460            ,(cond ((null end)
1461                    `(make-string-input-stream ,string ,(or start 0)))
1462                   ((symbolp end)
1463                    `(if ,end
1464                      (make-string-input-stream ,string ,(or start 0) ,end)
1465                      (make-string-input-stream ,string ,(or start 0))))
1466                   (t
1467                    `(make-string-input-stream ,string ,(or start 0) ,end)))))
1468      ,@decls
[5397]1469      (unwind-protect
1470           (multiple-value-prog1
1471               (progn ,@forms)
1472             ,@(if index `((setf ,index (string-input-stream-index ,var)))))
1473        (close ,var)))))
[6]1474
[13454]1475(defmacro with-input-from-vector ((var vector &key index (start 0) end external-format) &body forms &environment env)
1476  (multiple-value-bind (forms decls) (parse-body forms env nil)
1477    `(let ((,var (%make-vector-input-stream ,vector ,start ,end ,external-format)))
1478      ,@decls
1479      (unwind-protect
1480           (multiple-value-prog1
1481               (progn ,@forms)
1482             ,@(if index `((setf ,index (vector-input-stream-index ,var)))))
1483        (close ,var)))))
1484
[539]1485(defmacro with-output-to-string ((var &optional string &key (element-type 'base-char element-type-p))
[6]1486                                 &body body 
1487                                 &environment env)
[2451]1488  "Create a character output stream, perform a series of operations that
1489may send results to this stream, and then close the stream.  BODY is
1490executed as an implicit progn with VAR bound to an output string stream.
1491All output to that string stream is saved in a string."
[13454]1492  (let* ((string-p (not (null string))))
[2190]1493    (multiple-value-bind (forms decls) (parse-body body env nil)
[13454]1494      `(let* ((,var ,@(if string-p
[13456]1495                          `(,@(if element-type-p
[13454]1496                                   `((progn
1497                                       ,element-type
1498                                       (%make-string-output-stream ,string)))
[13456]1499                                   `((%make-string-output-stream ,string))))
1500                          `(,@(if element-type-p
[13454]1501                                   `((make-string-output-stream :element-type ,element-type))
[13456]1502                                   `((make-string-output-stream)))))))
[13454]1503        ,@decls
1504        (unwind-protect
1505             (progn
1506               ,@forms
1507               ,@(if string-p () `((get-output-stream-string ,var))))
1508          (close ,var))))))
1509
1510(defmacro with-output-to-vector ((var &optional vector &key external-format)
1511                                 &body body 
1512                                 &environment env)
1513  (let* ((vector-p (not (null vector))))
1514    (multiple-value-bind (forms decls) (parse-body body env nil)
1515      `(let* ((,var ,@(if vector-p
[13458]1516                          `((%make-vector-output-stream ,vector ,external-format))
1517                          `((make-vector-output-stream :external-format ,external-format)))))
[2190]1518         ,@decls
1519         (unwind-protect
1520              (progn
1521                ,@forms
[13454]1522                ,@(if vector-p () `((get-output-stream-vector ,var))))
[2190]1523           (close ,var))))))
[6]1524
1525(defmacro with-output-to-truncating-string-stream ((var len) &body body
1526                                                   &environment env)
1527  (multiple-value-bind (forms decls) (parse-body body env nil)
1528    `(let* ((,var (make-truncating-string-stream ,len)))
1529      ,@decls
1530      (unwind-protect
1531           (progn
1532             ,@forms
1533             (values (get-output-stream-string ,var)
1534                     (slot-value ,var 'truncated)))
1535        (close ,var)))))
1536
[12215]1537(defmacro with-open-file ((var filename . args) &body body &aux (stream (gensym))(done (gensym)))
1538  "Use open to create a file stream to file named by filename. Filename is
[2453]1539the name of the file to be opened. Options are used as keyword arguments
1540to open."
[6]1541  `(let (,stream ,done)
1542     (unwind-protect
1543       (multiple-value-prog1
[12215]1544         (let ((,var (setq ,stream (open ,filename ,@args))))
[6]1545           ,@body)
1546         (setq ,done t))
1547       (when ,stream (close ,stream :abort (null ,done))))))
1548
1549(defmacro with-compilation-unit ((&key override) &body body)
[929]1550  "WITH-COMPILATION-UNIT ({Key Value}*) Form*
1551  This form affects compilations that take place within its dynamic extent. It
1552  is intended to be wrapped around the compilation of all files in the same
1553  system. These keywords are defined:
1554    :OVERRIDE Boolean-Form
1555        One of the effects of this form is to delay undefined warnings
1556        until the end of the form, instead of giving them at the end of each
1557        compilation. If OVERRIDE is NIL (the default), then the outermost
1558        WITH-COMPILATION-UNIT form grabs the undefined warnings. Specifying
1559        OVERRIDE true causes that form to grab any enclosed warnings, even if
1560        it is enclosed by another WITH-COMPILATION-UNIT."
[10942]1561  `(flet ((with-compilation-unit-body ()
1562            ,@body))
1563     (declare (dynamic-extent #'with-compilation-unit-body))
1564     (call-with-compilation-unit #'with-compilation-unit-body :override ,override)))
[6]1565
1566; Yow! Another Done Fun.
1567(defmacro with-standard-io-syntax (&body body &environment env)
[929]1568  "Bind the reader and printer control variables to values that enable READ
1569   to reliably read the results of PRINT. These values are:
1570       *PACKAGE*                        the COMMON-LISP-USER package
1571       *PRINT-ARRAY*                    T
1572       *PRINT-BASE*                     10
1573       *PRINT-CASE*                     :UPCASE
1574       *PRINT-CIRCLE*                   NIL
1575       *PRINT-ESCAPE*                   T
1576       *PRINT-GENSYM*                   T
1577       *PRINT-LENGTH*                   NIL
1578       *PRINT-LEVEL*                    NIL
1579       *PRINT-LINES*                    NIL
1580       *PRINT-MISER-WIDTH*              NIL
1581       *PRINT-PRETTY*                   NIL
1582       *PRINT-RADIX*                    NIL
1583       *PRINT-READABLY*                 T
1584       *PRINT-RIGHT-MARGIN*             NIL
1585       *READ-BASE*                      10
1586       *READ-DEFAULT-FLOAT-FORMAT*      SINGLE-FLOAT
1587       *READ-EVAL*                      T
1588       *READ-SUPPRESS*                  NIL
1589       *READTABLE*                      the standard readtable"
[6]1590  (multiple-value-bind (decls body) (parse-body body env)
[11138]1591    `(let ((*package* (pkg-arg "COMMON-LISP-USER"))
[6]1592           (*print-array* t)
1593           (*print-base* 10.)
1594           (*print-case* :upcase)
1595           (*print-circle* nil)
1596           (*print-escape* t)
1597           (*print-gensym* t)
1598           (*print-length* nil)
1599           (*print-level* nil)
1600           (*print-lines* nil) ; This doesn't exist as of 5/15/90 - does now
1601           (*print-miser-width* nil)
1602           (*print-pprint-dispatch* nil)
1603           (*print-pretty* nil)
1604           (*print-radix* nil)
1605           (*print-readably* t)
1606           (*print-right-margin* nil)
1607           (*read-base* 10.)
1608           (*read-default-float-format* 'single-float)
1609           (*read-eval* t) ; Also MIA as of 5/15/90
1610           (*read-suppress* nil)
[12889]1611           (*readtable* %standard-readtable%)
[12429]1612           ; ccl extensions (see l1-io.lisp)
1613           (*print-abbreviate-quote* t)
1614           (*print-structure* t)
1615           (*print-simple-vector* nil)
1616           (*print-simple-bit-vector* nil)
1617           (*print-string-length* nil))
[6]1618       ,@decls
1619       ,@body)))
[929]1620
[7624]1621(defmacro with-self-bound-io-control-vars (&body body)
1622  `(let (
1623         (*print-array* *print-array*)
1624         (*print-base* *print-base*)
1625         (*print-case* *print-case*)
1626         (*print-circle* *print-circle*)
1627         (*print-escape* *print-escape*)
1628         (*print-gensym* *print-gensym*)
1629         (*print-length* *print-length*)
1630         (*print-level* *print-level*)
1631         (*print-lines* *print-lines*)
1632         (*print-miser-width* *print-miser-width*)
1633         (*print-pprint-dispatch* *print-pprint-dispatch*)
1634         (*print-pretty* *print-pretty*)
1635         (*print-radix* *print-radix*)
1636         (*print-readably* *print-readably*)
1637         (*print-right-margin* *print-right-margin*)
1638         (*read-base* *read-base*)
1639         (*read-default-float-format* *read-default-float-format*)
1640         (*read-eval* *read-eval*)
1641         (*read-suppress* *read-suppress*)
1642         (*readtable* *readtable*))
1643     ,@body))
1644
[6]1645(defmacro print-unreadable-object (&environment env (object stream &key type identity) &body forms)
[929]1646  "Output OBJECT to STREAM with \"#<\" prefix, \">\" suffix, optionally
1647  with object-type prefix and object-identity suffix, and executing the
1648  code in BODY to provide possible further output."
[6]1649  (multiple-value-bind (body decls) (parse-body forms env)
1650    (if body
1651      (let ((thunk (gensym)))
1652        `(let ((,thunk #'(lambda () ,@decls ,@body)))
1653           (declare (dynamic-extent ,thunk))
1654          (%print-unreadable-object ,object ,stream ,type ,identity ,thunk)))
1655      `(%print-unreadable-object ,object ,stream ,type ,identity nil))))
1656;; Pointers and Handles
1657
1658;;Add function to lisp system pointer functions, and run it if it's not already
1659;; there.
1660(defmacro def-ccl-pointers (name arglist &body body &aux (old (gensym)))
1661  `(flet ((,name ,arglist ,@body))
1662     (let ((,old (member ',name *lisp-system-pointer-functions* :key #'function-name)))
1663       (if ,old
1664         (rplaca ,old #',name)
1665         (progn
1666           (push #',name *lisp-system-pointer-functions*)
1667           (,name))))))
1668
1669(defmacro def-load-pointers (name arglist &body body &aux (old (gensym)))
1670  `(flet ((,name ,arglist ,@body))
1671     (let ((,old (member ',name *lisp-user-pointer-functions* :key #'function-name)))
1672       (if ,old
1673         (rplaca ,old #',name)
1674         (progn
1675           (push #',name *lisp-user-pointer-functions*)
1676           (,name))))))
1677
1678;Queue up some code to run after ccl all loaded up, or, if ccl is already
1679;loaded up, just run it right now.
1680(defmacro queue-fixup (&rest body &aux (fn (gensym)))
1681  `(let ((,fn #'(lambda () ,@body)))
1682     (if (eq %lisp-system-fixups% T)
1683       (funcall ,fn)
[11373]1684       (push (cons ,fn (or *loading-toplevel-location* *loading-file-source-file*)) %lisp-system-fixups%))))
[6]1685
1686(defmacro %incf-ptr (p &optional (by 1))
1687  (if (symbolp p)  ;once-only
1688    `(%setf-macptr (the macptr ,p) (%inc-ptr ,p ,by))
1689    (let ((var (gensym)))
1690      `(let ((,var ,p)) (%setf-macptr (the macptr ,var) (%inc-ptr ,var ,by))))))
1691
[419]1692(defmacro with-string-from-cstring ((s ptr) &body body)
1693  (let* ((len (gensym))
1694         (p (gensym)))
1695    `(let* ((,p ,ptr)
1696            (,len (%cstrlen ,p))
1697            (,s (make-string ,len)))
1698      (declare (fixnum ,len))
1699      (%copy-ptr-to-ivector ,p 0 ,s 0 ,len)
1700      (locally
1701          ,@body))))
[6]1702
1703
1704(defmacro with-cstr ((sym str &optional start end) &rest body &environment env)
1705  (multiple-value-bind (body decls) (parse-body body env nil)
1706    (if (and (base-string-p str) (null start) (null end))
1707      (let ((strlen (%i+ (length str) 1)))
1708        `(%stack-block ((,sym ,strlen))
1709           ,@decls
1710           (%cstr-pointer ,str ,sym)
1711           ,@body))
1712      (let ((strname (gensym))
1713            (start-name (gensym))
1714            (end-name (gensym)))
1715        `(let ((,strname ,str)
1716               ,@(if (or start end)
1717                   `((,start-name ,(or start 0))
1718                     (,end-name ,(or end `(length ,strname))))))
1719           (%vstack-block (,sym
1720                           (the fixnum
1721                             (1+
1722                              (the fixnum
1723                                ,(if (or start end)
1724                                     `(byte-length
1725                                       ,strname ,start-name ,end-name)
1726                                     `(length ,strname))))))
1727             ,@decls
1728             ,(if (or start end)
1729                `(%cstr-segment-pointer ,strname ,sym ,start-name ,end-name)
1730                `(%cstr-pointer ,strname ,sym))
1731             ,@body))))))
1732
[7624]1733(defmacro with-utf-8-cstr ((sym str) &body body)
1734  (let* ((data (gensym))
1735         (offset (gensym))
1736         (string (gensym))
1737         (len (gensym))
1738         (noctets (gensym))
1739         (end (gensym)))
1740    `(let* ((,string ,str)
1741            (,len (length ,string)))
1742      (multiple-value-bind (,data ,offset) (array-data-and-offset ,string)
1743        (let* ((,end (+ ,offset ,len))
1744               (,noctets (utf-8-octets-in-string ,data ,offset ,end)))
1745          (%stack-block ((,sym (1+ ,noctets)))
1746            (utf-8-memory-encode ,data ,sym 0 ,offset ,end)
1747            (setf (%get-unsigned-byte ,sym ,noctets) 0)
1748            ,@body))))))
[6]1749
1750
1751
[10658]1752(defmacro with-native-utf-16-cstr ((sym str) &body body)
1753  (let* ((data (gensym))
1754         (offset (gensym))
1755         (string (gensym))
1756         (len (gensym))
1757         (noctets (gensym))
1758         (end (gensym)))
1759    `(let* ((,string ,str)
1760            (,len (length ,string)))
1761      (multiple-value-bind (,data ,offset) (array-data-and-offset ,string)
1762        (let* ((,end (+ ,offset ,len))
1763               (,noctets (utf-16-octets-in-string ,data ,offset ,end)))
1764          (%stack-block ((,sym (1+ ,noctets)))
1765            (native-utf-16-memory-encode ,data ,sym 0 ,offset ,end)
1766            (setf (%get-unsigned-word ,sym ,noctets) 0)
1767            ,@body))))))
[6]1768
1769(defmacro with-pointers (speclist &body body)
1770   (with-specs-aux 'with-pointer speclist body))
1771
1772
1773
1774(defmacro with-cstrs (speclist &body body)
1775   (with-specs-aux 'with-cstr speclist body))
1776
[7647]1777(defmacro with-utf-8-cstrs (speclist &body body)
1778   (with-specs-aux 'with-utf-8-cstr speclist body))
1779
[10658]1780(defmacro with-native-utf-16-cstrs (speclist &body body)
1781  (with-specs-aux 'with-native-utf-16-cstr speclist body))
1782
[6552]1783(defmacro with-encoded-cstr ((encoding-name (sym string &optional start end))
1784                             &rest body &environment env)
[10354]1785  (let* ((encoding (gensym))
1786         (str (gensym)))
[6552]1787      (multiple-value-bind (body decls) (parse-body body env nil)
[10354]1788        `(let* ((,str ,string)
1789                (,encoding (get-character-encoding ,encoding-name)))
1790          (%stack-block ((,sym (cstring-encoded-length-in-bytes ,encoding ,str ,start ,end) :clear t))
[6552]1791            ,@decls
[10354]1792            (encode-string-to-memory ,encoding ,sym 0 ,str ,start ,end)
1793            ,@body)))))
[6]1794
[5296]1795(defmacro with-encoded-cstrs (encoding-name bindings &body body)
1796  (with-specs-aux 'with-encoded-cstr (mapcar #'(lambda (b)
1797                                                 `(,encoding-name ,b))
1798                                             bindings) body))
1799
[10694]1800(defmacro with-filename-cstrs (&rest rest)
[11207]1801  (case (target-os-name)
1802    (:darwin `(with-utf-8-cstrs ,@rest))
1803    (:windows `(with-native-utf-16-cstrs ,@rest))
1804    (t `(with-encoded-cstrs (pathname-encoding-name) ,@rest))))
[5296]1805
[10694]1806
[6552]1807(defun with-specs-aux (name spec-list original-body)
1808  (multiple-value-bind (body decls) (parse-body original-body nil)
[9163]1809    (when decls (signal-program-error "declarations not allowed in ~s" original-body))
[6552]1810    (setq body (cons 'progn body))
1811    (dolist (spec (reverse spec-list))
1812      (setq body (list name spec body)))
1813    body))
[6]1814
1815
1816(defmacro type-predicate (type)
1817  `(get-type-predicate ,type))
1818
1819(defsetf type-predicate set-type-predicate)
1820
[8764]1821(defun adjust-defmethod-lambda-list (ll)
1822  ;; If the lambda list contains &key, ensure that it also contains
1823  ;; &allow-other-keys
1824  (if (or (not (memq '&key ll))
1825          (memq '&allow-other-keys ll))
1826    ll
1827    (if (memq '&aux ll)
1828      (let* ((ll (copy-list ll))
1829             (aux (memq '&aux ll)))
1830        (setf (car aux) '&allow-other-keys
1831              (cdr aux) (cons '&aux (cdr aux)))
1832        ll)
1833      (append ll '(&allow-other-keys)))))
1834
[6]1835(defmacro defmethod (name &rest args &environment env)
[13980]1836  (let* ((method (gensym)))
1837    (multiple-value-bind (function-form specializers-form qualifiers lambda-list documentation specializers)
1838        (parse-defmethod name args env)
1839      `(progn
1840        (eval-when (:compile-toplevel)
1841          (record-function-info ',(maybe-setf-function-name name)
1842                                ',(multiple-value-bind (bits keyvect) (encode-lambda-list lambda-list t)
1843                                                       (unless bits;; verify failed
1844                                                         (signal-program-error "Invalid lambda list ~s"
1845                                                                               (find-if #'listp args)))
1846                                                       (%cons-def-info 'defmethod bits keyvect nil specializers qualifiers))
1847                                ,env))
1848        (compiler-let ((*nx-method-warning-name* '(,name ,@qualifiers ,specializers)))
1849          (let* ((,method (ensure-method ',name ,specializers-form
1850                                         :function ,function-form
1851                                         :qualifiers ',qualifiers
1852                                         :lambda-list ',lambda-list
1853                                         ,@(if documentation `(:documentation ,documentation)))))
1854            (record-source-file ,method 'method)
1855            ,method))))))
[6]1856
1857
1858(defun seperate-defmethod-decls (decls)
1859  (let (outer inner)
1860    (dolist (decl decls)
1861      (if (neq (car decl) 'declare)
1862        (push decl outer)
1863        (let (outer-list inner-list)
1864          (dolist (d (cdr decl))
1865            (if (and (listp d) (eq (car d) 'dynamic-extent))
1866              (let (in out)
1867                (dolist (fspec (cdr d))
1868                  (if (and (listp fspec)
1869                           (eq (car fspec) 'function)
1870                           (listp (cdr fspec))
1871                           (null (cddr fspec))
1872                           (memq (cadr fspec) '(call-next-method next-method-p)))
1873                    (push fspec in)
1874                    (push fspec out)))
1875                (when out
1876                  (push `(dynamic-extent ,@(nreverse out)) outer-list))
1877                (when in
1878                  (push `(dynamic-extent ,@(nreverse in)) inner-list)))
1879              (push d outer-list)))
1880          (when outer-list
1881            (push `(declare ,@(nreverse outer-list)) outer))
1882          (when inner-list
1883            (push `(declare ,@(nreverse inner-list)) inner)))))
1884    (values (nreverse outer) (nreverse inner))))
1885                   
1886
[13675]1887(defvar *warn-about-unreferenced-required-args-in-methods* #+ccl-qres nil #-ccl-qres T)
[11138]1888
[6]1889(defun parse-defmethod (name args env)
1890  (validate-function-name name)
1891  (let (qualifiers lambda-list parameters specializers specializers-form refs types temp)
1892    (until (listp (car args))
1893      (push (pop args) qualifiers))
1894    (setq lambda-list (pop args))
1895    (while (and lambda-list (not (memq (car lambda-list) lambda-list-keywords)))
1896      (let ((p (pop lambda-list)))
1897        (cond ((consp p)
1898               (unless (and (consp (%cdr p)) (null (%cddr p)))
1899                 (signal-program-error "Illegal arg ~S" p))
1900               (push (%car p) parameters)
1901               (push (%car p) refs)
1902               (setq p (%cadr p))
1903               (cond ((and (consp p) (eq (%car p) 'eql)
1904                           (consp (%cdr p)) (null (%cddr p)))
1905                      (push `(list 'eql ,(%cadr p)) specializers-form)
1906                      (push p specializers))
1907                     ((or (setq temp (non-nil-symbol-p p))
1908                          (specializer-p p))
1909                      (push `',p specializers-form)
1910                      (push p specializers)
1911                      (unless (or (eq p t) (not temp))
1912                        ;Should be `(guaranteed-type ...).
1913                        (push `(type ,p ,(%car parameters)) types)))
1914                     (t (signal-program-error "Illegal arg ~S" p))))
1915              (t
1916               (push p parameters)
[11138]1917               (unless *warn-about-unreferenced-required-args-in-methods*
1918                 (push p refs))
[6]1919               (push t specializers-form)
1920               (push t specializers)))))
1921    (setq lambda-list (nreconc parameters lambda-list))
1922    (multiple-value-bind (body decls doc) (parse-body args env t)
1923      (multiple-value-bind (outer-decls inner-decls) 
1924                           (seperate-defmethod-decls decls)
1925        (let* ((methvar (make-symbol "NEXT-METHOD-CONTEXT"))
1926               (cnm-args (gensym))
1927               (lambda-form `(lambda ,(list* '&method methvar lambda-list)
1928                               (declare ;,@types
1929                                (ignorable ,@refs))
1930                               ,@outer-decls
1931                               (block ,(if (consp name) (cadr name) name)
1932                                 (flet ((call-next-method (&rest ,cnm-args)
1933                                          (declare (dynamic-extent ,cnm-args))
1934                                          (if ,cnm-args
1935                                            (apply #'%call-next-method-with-args ,methvar ,cnm-args)
1936                                            (%call-next-method ,methvar)))
1937                                        (next-method-p () (%next-method-p ,methvar)))
1938                                   (declare (inline call-next-method next-method-p))
[14256]1939                                   (declare (ftype (function (&rest t)) ,name))
[6]1940                                   ,@inner-decls
1941                                   ,@body)))))
1942          (values
1943           (if name `(nfunction ,name ,lambda-form) `(function ,lambda-form))
1944           `(list ,@(nreverse specializers-form))
1945           (nreverse qualifiers)
1946           lambda-list
1947           doc
1948           (nreverse specializers)))))))
1949
1950(defmacro anonymous-method (name &rest args &environment env)
1951  (multiple-value-bind (function-form specializers-form qualifiers method-class documentation)
1952                       (parse-defmethod name args env)
1953   
1954    `(%anonymous-method
1955      ,function-form
1956      ,specializers-form
1957      ',qualifiers
1958      ,@(if (or method-class documentation) `(',method-class))
1959      ,@(if documentation `(,documentation)))))
1960
1961
1962
1963(defmacro defclass (class-name superclasses slots &rest class-options &environment env)
1964  (flet ((duplicate-options (where) (signal-program-error "Duplicate options in ~S" where))
1965         (illegal-option (option) (signal-program-error "Illegal option ~s" option))
1966         (make-initfunction (form)
1967           (cond ((or (eq form 't)
1968                      (equal form ''t))
1969                  '(function true))
1970                 ((or (eq form 'nil)
1971                      (equal form ''nil))
1972                  '(function false))
1973                 (t
1974                  `(function (lambda () ,form))))))
1975    (setq class-name (require-type class-name '(and symbol (not null))))
1976    (setq superclasses (mapcar #'(lambda (s) (require-type s 'symbol)) superclasses))
1977    (let* ((options-seen ())
1978           (signatures ())
[11766]1979           (slot-names ())
1980           (slot-initargs ()))
[6]1981      (flet ((canonicalize-defclass-option (option)
1982               (let* ((option-name (car option)))
1983                 (if (member option-name options-seen :test #'eq)
1984                   (duplicate-options class-options)
1985                   (push option-name options-seen))
1986                 (case option-name
1987                   (:default-initargs
[982]1988                       (let ((canonical ())
1989                             (initargs-seen ()))
[6]1990                         (let (key val (tail (cdr option)))
1991                           (loop (when (null tail) (return nil))
[982]1992                              (setq key (pop tail)
1993                                    val (pop tail))
1994                              (when (memq key initargs-seen)
1995                                (SIGNAL-PROGRAM-error "Duplicate initialization argument name ~S in :DEFAULT-INITARGS of DEFCLASS ~S" key class-name))
1996                              (push key initargs-seen)
1997                              (push ``(,',key ,',val  ,,(make-initfunction val)) canonical))
[6]1998                           `(':direct-default-initargs (list ,@(nreverse canonical))))))
1999                   (:metaclass
2000                    (unless (and (cadr option)
2001                                 (typep (cadr option) 'symbol))
2002                      (illegal-option option))
[882]2003                    `(:metaclass  ',(cadr option)))
2004                   (:documentation
2005                    `(:documentation ',(cadr option)))
[2295]2006                   (t
2007                     (list `',option-name `',(cdr option))))))
[6]2008             (canonicalize-slot-spec (slot)
2009               (if (null slot) (signal-program-error "Illegal slot NIL"))
2010               (if (not (listp slot)) (setq slot (list slot)))
2011               (let* ((slot-name (require-type (car slot) 'symbol))
2012                      (initargs nil)
2013                      (other-options ())
2014                      (initform nil)
2015                      (initform-p nil)
2016                      (initfunction nil)
2017                      (type nil)
2018                      (type-p nil)
2019                      (allocation nil)
2020                      (allocation-p nil)
2021                      (documentation nil)
2022                      (documentation-p nil)
[8866]2023                      (readers nil)
2024                      (writers nil)
[10942]2025                      (reader-info (%cons-def-info 'defmethod (dpb 1 $lfbits-numreq 0) nil nil (list class-name)))
2026                      (writer-info (%cons-def-info 'defmethod (dpb 2 $lfbits-numreq 0) nil nil (list t class-name))))
[6]2027                 (when (memq slot-name slot-names)
[11687]2028                   (signal-program-error "Multiple slots named ~S in DEFCLASS ~S" slot-name class-name))
[6]2029                 (push slot-name slot-names)
2030                 (do ((options (cdr slot) (cddr options))
2031                      name)
2032                     ((null options))
2033                   (when (null (cdr options)) (signal-program-error "Illegal slot spec ~S" slot))
2034                   (case (car options)
2035                     (:reader
2036                      (setq name (cadr options))
[10983]2037                      (unless (memq name readers)
2038                        (push (cons name reader-info) signatures)
2039                        (push name readers)))
[6]2040                     (:writer                     
2041                      (setq name (cadr options))
[10983]2042                      (unless (member name writers :test 'equal)
2043                        (push (cons name writer-info) signatures)
2044                        (push name writers)))
[6]2045                     (:accessor
2046                      (setq name (cadr options))
[10983]2047                      (unless (memq name readers)
2048                        (push (cons name reader-info) signatures)
2049                        (push name readers))
2050                      (let ((setf-name `(setf ,name)))
2051                        (unless (member setf-name writers :test 'equal)
2052                          (push (cons (setf-function-name name) writer-info) signatures)
2053                          (push setf-name writers))))
[6]2054                     (:initarg
[11766]2055                      (let* ((initarg (require-type (cadr options) 'symbol))
2056                             (other (position initarg slot-initargs :test #'memq)))
2057                        (when other
2058                          (warn "Initarg ~s occurs in both ~s and ~s slots"
2059                                initarg (nth (1+ other) slot-names) slot-name))
2060                        (push initarg initargs)))
[6]2061                     (:type
2062                      (if type-p
2063                        (duplicate-options slot)
2064                        (setq type-p t))
[11687]2065                      (setq type (cadr options))
[12045]2066                      ;; complain about illegal typespecs and continue
[11687]2067                      (handler-case (specifier-type type env)
[12045]2068                        (program-error ()
[11687]2069                          (warn "Invalid type ~s in ~s slot definition ~s" type class-name slot))))
[6]2070                     (:initform
2071                      (if initform-p
2072                        (duplicate-options slot)
2073                        (setq initform-p t))
2074                      (let ((option (cadr options)))
2075                        (setq initform `',option
2076                              initfunction
2077                              (if (constantp option)
2078                                `(constantly ,option)
2079                                `#'(lambda () ,option)))))
2080                     (:allocation
2081                      (if allocation-p
2082                        (duplicate-options slot)
2083                        (setq allocation-p t))
2084                      (setq allocation (cadr options)))
2085                     (:documentation
2086                      (if documentation-p
2087                        (duplicate-options slot)
2088                        (setq documentation-p t))
[882]2089                      (setq documentation (cadr options)))
[6]2090                     (t
[812]2091                      (let* ((pair (or (assq (car options) other-options)
2092                                       (car (push (list (car options)) other-options)))))
2093                        (push (cadr options) (cdr pair))))))
[11766]2094                 (push initargs slot-initargs)
[6]2095                 `(list :name ',slot-name
2096                   ,@(when allocation `(:allocation ',allocation))
2097                   ,@(when initform-p `(:initform ,initform
2098                                        :initfunction ,initfunction))
2099                   ,@(when initargs `(:initargs ',initargs))
2100                   ,@(when readers `(:readers ',readers))
2101                   ,@(when writers `(:writers ',writers))
2102                   ,@(when type-p `(:type ',type))
[882]2103                   ,@(when documentation-p `(:documentation ,documentation))
[812]2104                   ,@(mapcan #'(lambda (opt)
[957]2105                                 `(',(car opt) ',(if (null (cddr opt))
2106                                                     (cadr opt)
2107                                                     (cdr opt)))) other-options)))))
[882]2108        (let* ((direct-superclasses superclasses)
[6]2109               (direct-slot-specs (mapcar #'canonicalize-slot-spec slots))
[9049]2110               (other-options (apply #'append (mapcar #'canonicalize-defclass-option class-options )))
2111               (keyvect (class-keyvect class-name other-options)))
2112          (when (vectorp keyvect)
2113            (let ((illegal (loop for arg in other-options by #'cddr
2114                              as key = (if (quoted-form-p arg) (%cadr arg) arg)
2115                              unless (or (eq key :metaclass) (find key keyvect)) collect key)))
2116              (when illegal
2117                (signal-program-error "Class option~p~{ ~s~} is not one of ~s"
[14294]2118                                      (length illegal) illegal (coerce keyvect 'list)))))
[6]2119          `(progn
[12045]2120             (when (memq ',class-name *nx-known-declarations*)
2121               (check-declaration-redefinition ',class-name 'defclass))
[6]2122            (eval-when (:compile-toplevel)
2123              (%compile-time-defclass ',class-name ,env)
2124              (progn
[8866]2125                ,@(mapcar #'(lambda (sig) `(record-function-info ',(car sig) ',(cdr sig) ,env))
[6]2126                          signatures)))
[274]2127              (ensure-class-for-defclass ',class-name
[6]2128                            :direct-superclasses ',direct-superclasses
2129                            :direct-slots ,`(list ,@direct-slot-specs)
[274]2130                            ,@other-options)))))))
[6]2131
2132(defmacro define-method-combination (name &rest rest &environment env)
2133  (setq name (require-type name 'symbol))
2134  (cond ((or (null rest) (and (car rest) (symbolp (car rest))))
2135         `(short-form-define-method-combination ',name ',rest))
2136        ((listp (car rest))
2137         (destructuring-bind (lambda-list method-group-specifiers . forms) rest
2138           (long-form-define-method-combination 
2139            name lambda-list method-group-specifiers forms env)))
2140        (t (%badarg (car rest) '(or (and null symbol) list)))))
2141
2142(defmacro defgeneric (function-name lambda-list &rest options-and-methods &environment env)
[11088]2143  (fboundp function-name)             ; type-check
[6]2144  (multiple-value-bind (method-combination generic-function-class options methods)
[8866]2145      (parse-defgeneric function-name t lambda-list options-and-methods)
[6]2146    (let ((gf (gensym)))
2147      `(progn
[11088]2148         (eval-when (:compile-toplevel)
2149           (record-function-info ',(maybe-setf-function-name function-name)
[12940]2150                                 ',(multiple-value-bind (bits keyvect) (encode-lambda-list lambda-list t)
2151                                     (%cons-def-info 'defgeneric bits keyvect))
[8866]2152                                 ,env))
[11088]2153         (let ((,gf (%defgeneric
2154                     ',function-name ',lambda-list ',method-combination ',generic-function-class 
2155                     ',(apply #'append options))))
2156           (%set-defgeneric-methods ,gf ,@methods)
2157           ,gf)))))
[6]2158
2159
2160
2161(defun parse-defgeneric (function-name global-p lambda-list options-and-methods)
2162  (check-generic-function-lambda-list lambda-list)
2163  (let ((method-combination '(standard))
2164        (generic-function-class 'standard-generic-function)
[338]2165        options declarations methods option-keywords method-class)
[6]2166    (flet ((bad-option (o)
[274]2167             (signal-program-error "Bad option: ~s to ~s." o 'defgeneric)))
[6]2168      (dolist (o options-and-methods)
2169        (let ((keyword (car o))
2170              (defmethod (if global-p 'defmethod 'anonymous-method)))
2171          (if (eq keyword :method)
[11088]2172            (let ((defn `(,defmethod ,function-name ,@(%cdr o))))
[12328]2173              (note-source-transformation o defn)
[11088]2174              (push defn methods))
[338]2175            (cond ((and (not (eq keyword 'declare))
2176                        (memq keyword (prog1 option-keywords (push keyword option-keywords))))             
[274]2177                   (signal-program-error "Duplicate option: ~s to ~s" keyword 'defgeneric))
[6]2178                  ((eq keyword :method-combination)
2179                   (unless (symbolp (cadr o))
2180                     (bad-option o))
2181                   (setq method-combination (cdr o)))
2182                  ((eq keyword :generic-function-class)
2183                   (unless (and (cdr o) (symbolp (cadr o)) (null (%cddr o)))
2184                     (bad-option o))
2185                   (setq generic-function-class (%cadr o)))
2186                  ((eq keyword 'declare)
[338]2187                   (push (cadr o) declarations))
[6]2188                  ((eq keyword :argument-precedence-order)
2189                   (dolist (arg (cdr o))
2190                     (unless (and (symbolp arg) (memq arg lambda-list))
2191                       (bad-option o)))
2192                   (push (list keyword (cdr o)) options))
2193                  ((eq keyword :method-class)
2194                   (push o options)
2195                   (when (or (cddr o) (not (symbolp (setq method-class (%cadr o)))))
2196                     (bad-option o)))
2197                  ((eq keyword :documentation)
2198                   (push o options)
2199                   (when (or (cddr o) (not (stringp (%cadr o))))
2200                     (bad-option o)))
2201                  (t (bad-option o)))))))
2202    (when method-class
2203      (dolist (m methods)
2204        (push `(:method-class ,method-class) (cddr m))))
[338]2205    (when declarations
[445]2206      (setq options `((:declarations ,declarations) ,@options)))
[6]2207    (values method-combination generic-function-class options methods)))
2208
2209                 
2210(defmacro def-aux-init-functions (class &rest functions)
2211  `(set-aux-init-functions ',class (list ,@functions)))
2212
2213
2214
2215
2216
2217
[2230]2218;;; A powerful way of defining REPORT-CONDITION...
2219;;; Do they really expect that each condition type has a unique method on PRINT-OBJECT
2220;;; which tests *print-escape* ?  Scary if so ...
[6]2221
[10356]2222(defmacro define-condition (name (&rest supers) (&rest slots) &body options)
[929]2223  "DEFINE-CONDITION Name (Parent-Type*) (Slot-Spec*) Option*
2224   Define NAME as a condition type. This new type inherits slots and its
2225   report function from the specified PARENT-TYPEs. A slot spec is a list of:
2226     (slot-name :reader <rname> :initarg <iname> {Option Value}*
2227
2228   The DEFINE-CLASS slot options :ALLOCATION, :INITFORM, [slot] :DOCUMENTATION
2229   and :TYPE and the overall options :DEFAULT-INITARGS and
2230   [type] :DOCUMENTATION are also allowed.
2231
2232   The :REPORT option is peculiar to DEFINE-CONDITION. Its argument is either
2233   a string or a two-argument lambda or function name. If a function, the
2234   function is called with the condition and stream to report the condition.
2235   If a string, the string is printed.
2236
2237   Condition types are classes, but (as allowed by ANSI and not as described in
2238   CLtL2) are neither STANDARD-OBJECTs nor STRUCTURE-OBJECTs. WITH-SLOTS and
2239   SLOT-VALUE may not be used on condition objects."
[6]2240  ; If we could tell what environment we're being expanded in, we'd
2241  ; probably want to check to ensure that all supers name conditions
2242  ; in that environment.
2243  (let ((classopts nil)
2244        (duplicate nil)
2245        (docp nil)
2246        (default-initargs-p nil)
2247        (reporter nil))
2248    (dolist (option options)
2249      (unless (and (consp option)
2250                   (consp (%cdr option)))
[9163]2251        (signal-program-error "Invalid option ~s ." option))
[6]2252      (ecase (%car option)
2253        (:default-initargs 
2254            (unless (plistp (cdr option)) 
2255              (signal-program-error "~S is not a plist." (%cdr option))) 
2256            (if default-initargs-p 
2257              (setq duplicate t) 
2258              (push (setq default-initargs-p option) classopts))) 
2259        (:documentation 
2260         (unless (null (%cddr option)) 
[9163]2261           (signal-program-error "Invalid option ~s ." option)) 
[6]2262         (if docp
2263           (setq duplicate t)
2264           (push (setq docp option) classopts)))
2265        (:report 
2266         (unless (null (%cddr option)) 
[9163]2267           (signal-program-error "Invalid option ~s ." option)) 
[6]2268         (if reporter
2269           (setq duplicate t)
2270           (progn
2271             (if (or (lambda-expression-p (setq reporter (%cadr option)))
2272                     (symbolp reporter))
2273               (setq reporter `(function ,reporter))
2274               (if (stringp reporter)
2275                 (setq reporter `(function (lambda (c s) (declare (ignore c)) (write-string ,reporter s))))
[9163]2276                 (signal-program-error "~a expression is not a string, symbol, or lambda expression ." (%car option))))
[6]2277             (setq reporter `((defmethod report-condition ((c ,name) s)
2278                                (funcall ,reporter c s))))))))
[9163]2279      (if duplicate (signal-program-error "Duplicate option ~s ." option)))
[6]2280    `(progn
2281       (defclass ,name ,(or supers '(condition)) ,slots ,@classopts)
2282       ,@reporter
2283       ',name)))
2284
2285(defmacro with-condition-restarts (&environment env condition restarts &body body)
[929]2286  "Evaluates the BODY in a dynamic environment where the restarts in the list
2287   RESTARTS-FORM are associated with the condition returned by CONDITION-FORM.
2288   This allows FIND-RESTART, etc., to recognize restarts that are not related
2289   to the error currently being debugged. See also RESTART-CASE."
[6]2290  (multiple-value-bind (body decls)
2291                       (parse-body body env)
2292    (let ((cond (gensym))
2293          (r (gensym)))
2294          `(let* ((*condition-restarts* *condition-restarts*))
2295             ,@decls
2296             (let ((,cond ,condition))
2297               (dolist (,r ,restarts) (push (cons ,r ,cond) *condition-restarts*))
2298               ,@body)))))
2299 
2300(defmacro setf-find-class (name arg1 &optional (arg2 () 2-p) (arg3 () 3-p))
2301  (cond (3-p ;might want to pass env (arg2) to find-class someday?
2302         `(set-find-class ,name (progn ,arg1 ,arg2 ,arg3)))
2303        (2-p
2304         `(set-find-class ,name (progn ,arg1 ,arg2)))
2305        (t `(set-find-class ,name ,arg1))))
2306
2307(defsetf find-class setf-find-class)
2308
2309(defmacro restoring-interrupt-level (var &body body)
2310  `(unwind-protect
2311    (progn ,@body)
2312    (restore-interrupt-level ,var)
2313    (%interrupt-poll)))
2314
2315(defmacro without-interrupts (&body body)
[2438]2316  "Evaluate its body in an environment in which process-interrupt
2317requests are deferred."
[2690]2318  `(let* ((*interrupt-level* -1))
2319    ,@body))
[6]2320
[2696]2321(defmacro with-interrupts-enabled (&body body)
2322  "Evaluate its body in an environment in which process-interrupt
2323has immediate effect."
2324  `(let* ((*interrupt-level* 0))
2325    ,@body))
[6]2326
[2690]2327;;; undoes the effect of one enclosing without-interrupts during execution of body.
[6]2328(defmacro ignoring-without-interrupts (&body body)
[2690]2329  `(let* ((*interrupt-level* 0))
2330    ,@body))
[6]2331
[2618]2332
2333
[6]2334(defmacro error-ignoring-without-interrupts (format-string &rest format-args)
2335  `(ignoring-without-interrupts
2336    (error ,format-string ,@format-args)))
2337
2338
2339;init-list-default: if there is no init pair for <keyword>,
2340;    add a <keyword> <value> pair to init-list
2341(defmacro init-list-default (the-init-list &rest args)
2342  (let ((result)
2343       (init-list-sym (gensym)))
2344   (do ((args args (cddr args)))
2345       ((not args))
2346     (setq result 
2347           (cons `(if (eq '%novalue (getf ,init-list-sym ,(car args) 
2348                                          '%novalue))
2349                    (setq ,init-list-sym (cons ,(car args) 
2350                                               (cons ,(cadr args) 
2351                                                     ,init-list-sym))))
2352                 result)))                                                                               
2353   `(let ((,init-list-sym ,the-init-list))
2354      (progn ,@result)
2355      ,init-list-sym)
2356   ))
2357
2358; This can only be partially backward-compatible: even if only
2359; the "name" arg is supplied, the old function would create the
2360; package if it didn't exist.
2361; Should see how well this works & maybe flush the whole idea.
2362
[1924]2363(defmacro in-package (name)
[6]2364  (let ((form nil))
[1924]2365    (when (quoted-form-p name)
2366      (warn "Unquoting argument ~S to ~S." name 'in-package )
2367      (setq name (cadr name)))   
2368    (setq form `(set-package ,(string name)))
2369    `(eval-when (:execute :load-toplevel :compile-toplevel)
2370      ,form)))
[6]2371
2372(defmacro defpackage (name &rest options)
[929]2373  "Defines a new package called PACKAGE. Each of OPTIONS should be one of the
2374   following:
2375    (NICKNAMES {package-name}*)
2376
2377    (SIZE <integer>)
2378    (SHADOW {symbol-name}*)
2379    (SHADOWING-IMPORT-FROM <package-name> {symbol-name}*)
2380    (USE {package-name}*)
2381    (IMPORT-FROM <package-name> {symbol-name}*)
2382    (INTERN {symbol-name}*)
2383    (EXPORT {symbol-name}*)
2384    (IMPLEMENT {package-name}*)
2385    (LOCK boolean)
2386    (DOCUMENTATION doc-string)
2387   All options except SIZE, LOCK, and :DOCUMENTATION can be used multiple
2388   times."
[6]2389  (let* ((size nil)
2390         (all-names-size 0)
2391         (intern-export-size 0)
2392         (shadow-etc-size 0)
2393         (documentation nil)
2394         (all-names-hash (let ((all-options-alist nil))
2395                           (dolist (option options)
2396                             (let ((option-name (car option)))
2397                               (when (memq option-name
2398                                           '(:nicknames :shadow :shadowing-import-from
2399                                             :use :import-from :intern :export))
2400                                 (let ((option-size (length (cdr option)))
2401                                       (cell (assq option-name all-options-alist)))
2402                                   (declare (fixnum option-size))
2403                                   (if cell
2404                                     (incf (cdr cell) option-size)
2405                                     (push (cons option-name option-size) all-options-alist))
2406                                   (when (memq option-name '(:shadow :shadowing-import-from :import-from :intern))
2407                                     (incf shadow-etc-size option-size))
2408                                   (when (memq option-name '(:export :intern))
2409                                     (incf intern-export-size option-size))))))
2410                           (dolist (cell all-options-alist)
2411                             (let ((option-size (cdr cell)))
2412                               (when (> option-size all-names-size)
2413                                 (setq all-names-size option-size))))
2414                           (when (> all-names-size 0)
2415                             (make-hash-table :test 'equal :size all-names-size))))
2416         (intern-export-hash (when (> intern-export-size 0)
2417                               (make-hash-table :test 'equal :size intern-export-size)))
2418         (shadow-etc-hash (when (> shadow-etc-size 0)
2419                            (make-hash-table :test 'equal :size shadow-etc-size)))
2420         (external-size nil)
2421         (nicknames nil)
2422         (shadow nil)
2423         (shadowing-import-from-specs nil)
2424         (use :default)
2425         (import-from-specs nil)
2426         (intern nil)
2427         (export nil))
2428    (declare (fixnum all-names-size intern-export-size shadow-etc-size))
2429    (labels ((string-or-name (s) (string s))
2430             (duplicate-option (o)
2431               (signal-program-error "Duplicate ~S option in ~S ." o options))
2432             (duplicate-name (name option-name)
2433               (signal-program-error "Name ~s, used in ~s option, is already used in a conflicting option ." name option-name))
2434             (all-names (option-name tail already)
2435               (when (eq already :default) (setq already nil))
2436               (when all-names-hash
2437                 (clrhash all-names-hash))
2438               (dolist (name already)
2439                 (setf (gethash (string-or-name name) all-names-hash) t))
2440               (dolist (name tail already)
2441                 (setq name (string-or-name name))
2442                 (unless (gethash name all-names-hash)          ; Ok to repeat name in same option.
2443                   (when (memq option-name '(:shadow :shadowing-import-from :import-from :intern))
2444                     (if (gethash name shadow-etc-hash)
2445                       (duplicate-name name option-name))
2446                     (setf (gethash name shadow-etc-hash) t))
2447                   (when (memq option-name '(:export :intern))
2448                     (if (gethash name intern-export-hash)
2449                       (duplicate-name name option-name))
2450                     (setf (gethash name intern-export-hash) t))
2451                   (setf (gethash name all-names-hash) t)
2452                   (push name already)))))
2453      (dolist (option options)
2454        (let ((args (cdr option)))
2455          (ecase (%car option)
2456                 (:size 
2457                  (if size 
2458                    (duplicate-option :size) 
2459                    (setq size (car args))))             
2460                 (:external-size 
2461                  (if external-size 
2462                    (duplicate-option :external-size) 
2463                    (setq external-size (car args))))
2464                 (:nicknames (setq nicknames (all-names nil args nicknames)))
2465                 (:shadow (setq shadow (all-names :shadow args shadow)))
2466                 (:shadowing-import-from
2467                  (destructuring-bind (from &rest shadowing-imports) args
2468                    (push (cons (string-or-name from)
2469                                (all-names :shadowing-import-from shadowing-imports nil))
2470                          shadowing-import-from-specs)))
2471                 (:use (setq use (all-names nil args use)))
2472                 (:import-from
2473                  (destructuring-bind (from &rest imports) args
2474                    (push (cons (string-or-name from)
2475                                (all-names :import-from imports nil))
2476                          import-from-specs)))
2477                 (:intern (setq intern (all-names :intern args intern)))
2478                 (:export (setq export (all-names :export args export)))
2479                 (:documentation
2480                  (if documentation
2481                    (duplicate-option :documentation)
2482                    (setq documentation (cadr option)))))))
2483      `(eval-when (:execute :compile-toplevel :load-toplevel)
2484         (%define-package ',(string-or-name name)
2485          ',size 
2486          ',external-size 
2487          ',nicknames
2488          ',shadow
2489          ',shadowing-import-from-specs
2490          ',use
2491          ',import-from-specs
2492          ',intern
2493          ',export
2494          ',documentation)))))
2495
2496
2497
2498(defmacro with-package-iterator ((mname package-list first-type &rest other-types)
2499                                 &body body)
[929]2500  "Within the lexical scope of the body forms, MNAME is defined via macrolet
2501   such that successive invocations of (MNAME) will return the symbols,
2502   one by one, from the packages in PACKAGE-LIST. SYMBOL-TYPES may be
2503   any of :INHERITED :EXTERNAL :INTERNAL."
[6]2504  (setq mname (require-type mname 'symbol))
[2081]2505  (let ((state (make-symbol "WITH-PACKAGE-ITERATOR_STATE")))
[6]2506    (dolist (type (push first-type other-types))
[2081]2507      (ecase type
2508        ((:external :internal :inherited))))
2509    `(let ((,state (%setup-pkg-iter-state ,package-list ',other-types)))
2510       (macrolet ((,mname () `(%pkg-iter-next ,',state)))
[6]2511         ,@body))))
2512
2513; Does NOT evaluate the constructor, but DOES evaluate the destructor & initializer
2514(defmacro defresource (name &key constructor destructor initializer)
2515  `(defparameter ,name (make-resource #'(lambda () ,constructor)
2516                                      ,@(when destructor
2517                                          `(:destructor ,destructor))
2518                                      ,@(when initializer
2519                                          `(:initializer ,initializer)))))
2520
2521(defmacro using-resource ((var resource) &body body)
2522  (let ((resource-var (gensym)))
2523  `(let ((,resource-var ,resource)
2524         ,var)
2525     (unwind-protect
2526       (progn
2527         (setq ,var (allocate-resource ,resource-var))
2528         ,@body)
2529       (when ,var
2530         (free-resource ,resource-var ,var))))))
2531
[7678]2532;;; Bind per-thread specials which help with lock accounting.
2533(defmacro with-lock-context (&body body)
[7854]2534  `(progn ,@body))
[7678]2535
[6]2536(defmacro with-lock-grabbed ((lock &optional
2537                                   (whostate "Lock"))
2538                             &body body)
[2438]2539  "Wait until a given lock can be obtained, then evaluate its body with
2540the lock held."
[6]2541  (declare (ignore whostate))
[7742]2542    (let* ((locked (gensym))
2543           (l (gensym)))
2544      `  (with-lock-context
2545           (let ((,locked (make-lock-acquisition))
2546             (,l ,lock))
2547        (declare (dynamic-extent ,locked))
2548        (unwind-protect
2549             (progn
2550               (%lock-recursive-lock-object ,l ,locked )
2551               ,@body)
2552          (when (lock-acquisition.status ,locked) (%unlock-recursive-lock-object ,l)))))))
[6]2553
2554(defmacro with-lock-grabbed-maybe ((lock &optional
2555                                         (whostate "Lock"))
2556                                   &body body)
2557  (declare (ignore whostate))
[7742]2558  (let* ((l (gensym)))
2559    `(with-lock-context
2560      (let* ((,l ,lock))
2561        (when (%try-recursive-lock-object ,l)
2562          (unwind-protect
2563               (progn ,@body)
2564            (%unlock-recursive-lock-object ,l)))))))
[6]2565
2566(defmacro with-standard-abort-handling (abort-message &body body)
2567  (let ((stream (gensym)))
2568    `(restart-case
2569       (catch :abort
2570         (catch-cancel
2571           ,@body))
2572       (abort () ,@(when abort-message
2573                     `(:report (lambda (,stream)
2574                                 (write-string ,abort-message ,stream)))))
2575       (abort-break ()))))
2576       
2577
2578
2579
2580(defmacro %lexpr-count (l)
2581  `(%lisp-word-ref ,l 0))
2582
2583(defmacro %lexpr-ref (lexpr count i)
2584  `(%lisp-word-ref ,lexpr (%i- ,count ,i)))
2585
[3568]2586;;; args will be list if old style clos
[6]2587(defmacro apply-with-method-context (magic function args)
2588  (let ((m (gensym))
2589        (f (gensym))
2590        (as (gensym)))
2591      `((lambda (,m ,f ,as)
2592          (if (listp ,as)
2593            (%apply-with-method-context ,m ,f ,as)
2594            (%apply-lexpr-with-method-context ,m ,f ,as))) ,magic ,function ,args)))
2595
2596(defmacro defcallback (name arglist &body body &environment env)
[2442]2597  "Proclaim name to be a special variable; sets its value to a MACPTR which,
2598when called by foreign code, calls a lisp function which expects foreign
2599arguments of the specified types and which returns a foreign value of the
2600specified result type. Any argument variables which correspond to foreign
2601arguments of type :ADDRESS are bound to stack-allocated MACPTRs.
2602
2603If name is already a callback function pointer, its value is not changed;
2604instead, it's arranged that an updated version of the lisp callback function
2605will be called. This feature allows for callback functions to be redefined
2606incrementally, just like Lisp functions are.
2607
2608defcallback returns the callback pointer, e.g., the value of name."
[6]2609  (define-callback name arglist body env))
2610
[3606]2611(declare-arch-specific-macro %get-single-float-from-double-ptr)
[6]2612
[3712]2613(declare-arch-specific-macro lfun-vector)
2614(declare-arch-specific-macro lfun-vector-lfun)
2615
[3829]2616(declare-arch-specific-macro symptr->symvector)
2617(declare-arch-specific-macro symvector->symptr)
2618
[3901]2619(declare-arch-specific-macro function-to-function-vector)
2620(declare-arch-specific-macro function-vector-to-function)
2621
[5721]2622(declare-arch-specific-macro with-ffcall-results)
2623
[1135]2624(defvar *trace-print-functions* nil)
2625(defun %trace-print-arg (stream arg val type)
2626  (format stream " ")
2627  (let ((fn (assoc type *trace-print-functions*)))
2628    (if fn
2629      (funcall (cdr fn) stream arg val)
2630      (progn
2631      (when arg
2632        (format stream "~A = " arg))
2633      (if (and type (not (eq type :void)))
2634          (format stream "[:~A] ~A~%" type val)
[13187]2635        (format stream ":VOID~%"))))))
[1135]2636
2637(defun def-trace-print-function (type fn)
2638  (push (cons type fn) *trace-print-functions*))
2639
[6]2640(defun define-callback (name args body env)
[5802]2641  (let* ((stack-word (gensym))
2642         (stack-ptr (gensym))
2643         (fp-args-ptr (gensym))
2644         (result-type-spec :void)
2645         (args args)
[11590]2646         (discard-stack-args nil)       ;only meaningful on win32
2647         (discard-hidden-arg nil)       ;only meaningful on x8632
2648         (info nil)
[5802]2649         (woi nil)
2650         (need-struct-arg)
2651         (struct-return-arg-name)
2652         (error-return nil))
2653    (collect ((arg-names)
2654              (arg-specs))
2655      (let* ((spec (car (last args)))
2656             (rtype (ignore-errors (parse-foreign-type spec))))
2657        (setq need-struct-arg (typep rtype 'foreign-record-type))
[11590]2658        (when need-struct-arg
2659          (setq discard-hidden-arg
2660                (funcall (ftd-ff-call-struct-return-by-implicit-arg-function
2661                          *target-ftd*) rtype)))
[5802]2662        (if rtype
2663          (setq result-type-spec spec args (butlast args))))
2664      (loop
2665        (when (null args) (return))
2666        (if (eq (car args) :without-interrupts)
2667          (setq woi (cadr args) args (cddr args))
[11189]2668          (if (eq (car args) :discard-stack-args)
[12524]2669            (setq discard-stack-args (eq (backend-target-os *target-backend*) :win32) args (cdr args))
[5802]2670            (if (eq (car args) :error-return)
2671              (setq error-return
2672                    (cadr args)                 
2673                    args (cddr args))
2674              (if need-struct-arg
2675                (setq struct-return-arg-name (pop args) need-struct-arg nil)
2676                (progn
2677                  (arg-specs (pop args))
2678                  (arg-names (pop args))))))))
[11189]2679      (multiple-value-bind (rlets lets dynamic-extent-names inits foreign-return-type fp-args-form error-return-offset num-arg-bytes)
[5802]2680          (funcall (ftd-callback-bindings-function *target-ftd*)
2681                   stack-ptr fp-args-ptr (arg-names) (arg-specs) result-type-spec struct-return-arg-name)
[11590]2682        ;; x8632 hair
2683        (when discard-hidden-arg
2684          (if discard-stack-args
2685            ;; We already have to discard some number of args, so just
2686            ;; discard the extra hidden arg while we're at it.
2687            (incf num-arg-bytes 4)
2688            ;; Otherwise, indicate that we'll need to discard the
2689            ;; hidden arg.
2690            (setq info (ash 1 23))))
2691        (when discard-stack-args
2692          (setq info 0)
2693          ;; put number of words to discard in high-order byte
2694          (setf (ldb (byte 8 24) info)
2695                (ash num-arg-bytes (- target::word-shift))))
[5802]2696        (multiple-value-bind (body decls doc) (parse-body body env t)
2697          `(progn
2698            (declaim (special ,name))
2699            (define-callback-function
2700                (nfunction ,name
2701                 (lambda (,stack-word)
2702                   (declare (ignorable ,stack-word))
2703                   (block ,name
2704                     (with-macptrs ((,stack-ptr))
2705                       (%setf-macptr-to-object ,stack-ptr ,stack-word)
2706                       (with-macptrs (,@(when fp-args-form
[6929]2707                                              `((,fp-args-ptr ,fp-args-form))))
2708                         ,(defcallback-body stack-ptr
2709                                            fp-args-ptr
2710                                            lets
2711                                            rlets
2712                                            inits
2713                                            `(declare (dynamic-extent ,@dynamic-extent-names))
2714                                            decls
2715                                            body
2716                                            foreign-return-type
2717                                            struct-return-arg-name
2718                                            error-return
2719                                            error-return-offset
2720                                            ))))))
[5802]2721                ,doc
2722              ,woi
[11590]2723              ,info)))))))
[2049]2724
[6]2725
[4032]2726(defun defcallback-body (&rest args)
[5802]2727  (declare (dynamic-extent args))
2728  (destructuring-bind (stack-ptr fp-args-ptr lets rlets inits dynamic-extent-decls other-decls body return-type struct-return-arg error-return error-delta) args
[6929]2729    (declare (ignorable dynamic-extent-decls))
[12591]2730    (let* ((condition-name (if (atom error-return) 'error (car error-return)))
[6929]2731           (error-return-function (if (atom error-return) error-return (cadr error-return)))
[12591]2732           (result (if struct-return-arg (gensym)))
[6929]2733           (body
2734            `(rlet ,rlets
2735              (let ,lets
2736                ,dynamic-extent-decls
2737                ,@other-decls
2738                ,@inits
[12591]2739                ,(if result
2740                     `(let* ((,result ,@body))
2741                       (declare (dynamic-extent ,result)
2742                                (ignorable ,result))
2743                       ,(funcall (ftd-callback-return-value-function *target-ftd*)
2744                              stack-ptr
2745                              fp-args-ptr
2746                              result
2747                              return-type
2748                              struct-return-arg))
2749                     (if (eq return-type *void-foreign-type*)
2750                       `(progn ,@body)
2751                       (funcall (ftd-callback-return-value-function *target-ftd*)
2752                                stack-ptr
2753                                fp-args-ptr
2754                                `(progn ,@body)
2755                                return-type
2756                                struct-return-arg)))
2757                nil))))
[6929]2758      (if error-return
2759        (let* ((cond (gensym))
2760               (block (gensym))
2761               (handler (gensym)))
2762          `(block ,block
2763            (let* ((,handler (lambda (,cond)
[12591]2764                               (,error-return-function ,cond ,stack-ptr (%inc-ptr ,stack-ptr ,error-delta))
2765                               (return-from ,block
2766                                 nil))))
[6929]2767              (declare (dynamic-extent ,handler))
[12591]2768              (handler-bind ((,condition-name ,handler))
2769                (values ,body)))))
[6929]2770        body))))
[4018]2771
[2049]2772
[6]2773(defmacro define-toplevel-command (group-name name arglist &body body &environment env)
2774  (let* ((key (make-keyword name)))
2775    (multiple-value-bind (body decls doc) (parse-body body env)
2776      `(%define-toplevel-command ',group-name ,key ',name 
2777        (nfunction ,name (lambda ,arglist
2778                           ,@decls
2779                           (block ,name
2780                             ,@body)))
2781        ,doc
2782        ',(mapcar #'symbol-name arglist)))))
2783
2784(defmacro with-toplevel-commands (group-name &body body)
2785  `(let* ((*active-toplevel-commands* *active-toplevel-commands*))
2786    (progn
2787      (%use-toplevel-commands ',group-name)
2788      ,@body)))
2789
2790(defmacro assert (test-form &optional (places ()) string &rest args)
2791  "ASSERT Test-Form [(Place*) [String Arg*]]
2792  If the Test-Form is not true, then signal a correctable error.  If Places
2793  are specified, then new values are prompted for when the error is proceeded.
2794  String and Args are the format string and args to the error call."
2795  (let* ((TOP (gensym))
2796         (setf-places-p (not (null places))))
[12345]2797    `(without-compiling-code-coverage
2798      (tagbody
[6]2799       ,TOP
2800       (unless ,test-form
2801         (%assertion-failure ,setf-places-p ',test-form ,string ,@args)
2802         ,@(if places
2803             `((write-line "Type expressions to set places to, or nothing to leave them alone."
2804                           *query-io*)
2805               ,@(mapcar #'(lambda (place &aux (new-val (gensym))
2806                                          (set-p (gensym)))
2807                             `(multiple-value-bind
2808                                (,new-val ,set-p)
2809                                (assertion-value-prompt ',place)
2810                                (when ,set-p (setf ,place (values-list ,new-val)))))
2811                         places)))
[12345]2812         (go ,TOP))))))
[6]2813
2814
2815(defmacro check-type (place typespec &optional string)
2816  "CHECK-TYPE Place Typespec [String]
[929]2817  Signal a restartable error of type TYPE-ERROR if the value of PLACE is
2818  not of the specified type. If an error is signalled and the restart is
2819  used to return, this can only return if the STORE-VALUE restart is
2820  invoked. In that case it will store into PLACE and start over."
[8989]2821  (let* ((val (gensym)))
[12345]2822    `(without-compiling-code-coverage
2823      (do* ((,val ,place ,place))
[8989]2824          ((typep ,val ',typespec))
[12345]2825       (setf ,place (%check-type ,val ',typespec ',place ,string))))))
[6]2826
[14258]2827(defmacro typecheck (object typespec &environment env)
2828  (cond ((eq typespec 't)
2829         object)
2830        ((nx-inhibit-safety-checking env)
2831         `(the ,typespec ,object))
2832        (t
[14307]2833         `(require-type ,object ',(nx1-typespec-for-typep typespec env
2834                                                          :whine nil)))))
[2427]2835
[12535]2836(defmacro with-hash-table-iterator ((mname hash-table) &body body)
[929]2837  "WITH-HASH-TABLE-ITERATOR ((function hash-table) &body body)
2838   provides a method of manually looping over the elements of a hash-table.
2839   FUNCTION is bound to a generator-macro that, within the scope of the
2840   invocation, returns one or three values. The first value tells whether
2841   any objects remain in the hash table. When the first value is non-NIL,
2842   the second and third values are the key and the value of the next object."
[7742]2843  (let* ((hash (gensym))
2844         (keys (gensym))
[7956]2845         (values (gensym))
2846         (count (gensym))
[7742]2847         (state (gensym)))
2848    `(let* ((,hash ,hash-table)
[7956]2849            (,count (hash-table-count ,hash))
2850            (,keys (make-array ,count))
2851            (,values (make-array ,count))
2852            (,state (vector ,hash 0 ,keys ,values (enumerate-hash-keys-and-values ,hash ,keys ,values))))
2853      (declare (dynamic-extent ,keys ,state)
2854               (fixnum ,count))
2855      (macrolet ((,mname () `(next-hash-table-iteration-1 ,',state)))
[7742]2856        ,@body))))
[6]2857
[7742]2858
[6]2859(eval-when (compile load eval)
2860(defmacro pprint-logical-block ((stream-symbol list
[2158]2861                                 &key (prefix "" prefixp)
2862                                      (per-line-prefix "" per-line-prefix-p)
2863                                      (suffix "" suffixp))
[6]2864                                &body body)
2865  (cond ((eq stream-symbol nil) (setq stream-symbol '*standard-output*))
2866        ((eq stream-symbol T) (setq stream-symbol '*terminal-io*)))
2867  (when (not (symbolp stream-symbol))
2868    (warn "STREAM-SYMBOL arg ~S to PPRINT-LOGICAL-BLOCK is not a bindable symbol"
2869          stream-symbol)
2870    (setq stream-symbol '*standard-output*))
[2158]2871  (when (and prefixp per-line-prefix-p)
[6]2872    (warn "prefix ~S and per-line-prefix ~S cannot both be specified ~
[11855]2873           in PPRINT-LOGICAL-BLOCK" prefix per-line-prefix)
[6]2874    (setq per-line-prefix nil))
[2137]2875  `(let ((*logical-block-p* t))
2876     (maybe-initiate-xp-printing
2877      #'(lambda (,stream-symbol)
2878          (let ((+l ,list)
[2158]2879                (+p (or (and ,prefixp
2880                             (require-type ,prefix 'string))
2881                        (and ,per-line-prefix-p
2882                             (require-type ,per-line-prefix 'string))))
2883                (+s (require-type ,suffix 'string)))
[2137]2884            (pprint-logical-block+
[2158]2885                (,stream-symbol +l +p +s ,per-line-prefix-p T nil)
[2137]2886              ,@ body nil)))
2887      (decode-stream-arg ,stream-symbol))))
[6]2888
2889
2890;Assumes var and args must be variables.  Other arguments must be literals or variables.
2891
2892(defmacro pprint-logical-block+ ((var args prefix suffix per-line? circle-check? atsign?)
2893                                 &body body)
[929]2894  "Group some output into a logical block. STREAM-SYMBOL should be either a
2895   stream, T (for *TERMINAL-IO*), or NIL (for *STANDARD-OUTPUT*). The printer
2896   control variable *PRINT-LEVEL* is automatically handled."
[6]2897  (when (and circle-check? atsign?)
2898    (setq circle-check? 'not-first-p))
2899  `(let ((*current-level* (1+ *current-level*))
2900         (*current-length* -1)
2901         ;(*parents* *parents*)
2902         ,@(if (and circle-check? atsign?) `((not-first-p (plusp *current-length*)))))
2903     (unless (check-block-abbreviation ,var ,args ,circle-check?)
2904       (start-block ,var ,prefix ,per-line? ,suffix)
2905       (when
2906         (catch 'line-limit-abbreviation-exit
2907           (block logical-block
2908             (macrolet ((pprint-pop () `(pprint-pop+ ,',args ,',var))
2909                        (pprint-exit-if-list-exhausted ()
2910                          `(if (null ,',args) (return-from logical-block nil))))
2911               ,@ body))
2912           (end-block ,var ,suffix)
2913           nil)
2914         (end-block ,var ,suffix)
2915         (throw 'line-limit-abbreviation-exit T)))))
2916) ; eval-when
2917
2918(defmacro %old-class-local-shared-slotds (class &optional default)
2919  (if default                           ; so setf works
2920    `(%class-get ,class '%old-class-local-shared-slotds ,default)
2921    `(%class-get ,class '%old-class-local-shared-slotds)))
2922
2923(defmacro with-slot-values (slot-entries instance-form &body body)
2924; Simplified form of with-slots.  Expands into a let instead of a symbol-macrolet
2925<