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

Last change on this file since 9467 was 9467, checked in by mb, 12 years ago

Make define-condition's slot argument required (as per the hyperspec)

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