source: branches/working-0711/ccl/lib/macros.lisp @ 13070

Last change on this file since 13070 was 13070, checked in by gz, 11 years ago

r13066, r13067 from trunk: copyrights etc

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