source: branches/qres/ccl/lib/macros.lisp @ 14172

Last change on this file since 14172 was 14056, checked in by gz, 9 years ago

r13980 from trunk (defmethod memory leak)

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