source: trunk/source/lib/macros.lisp

Last change on this file was 16685, checked in by rme, 4 years ago

Update copyright/license headers in files.

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