source: branches/ia32/lib/macros.lisp @ 7287

Last change on this file since 7287 was 7287, checked in by rme, 13 years ago

Merged trunk changes r7244:7286

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