source: trunk/ccl/lib/macros.lisp @ 812

Last change on this file since 812 was 812, checked in by gb, 17 years ago

incorporate 0.14.2 changes

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 111.3 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  (setq sym (require-type sym 'symbol)
30        doc (if doc-p (require-type doc 'string)))
31  `(progn
32     (eval-when (:compile-toplevel)
33       (define-compile-time-constant ',sym ',val ,env))
34     (eval-when (:load-toplevel :execute)
35       (%defconstant ',sym ,val ,@(if doc-p (list doc))))))
36
37;; Lists
38
39(defmacro %car (x)
40  `(car (the cons ,x)))
41
42(defmacro %cdr (x)
43  `(cdr (the cons ,x)))
44
45(defmacro %caar (x)
46 `(%car (%car ,x)))
47
48(defmacro %cadr (x)
49 `(%car (%cdr ,x)))
50
51(defmacro %cdar (x)
52 `(%cdr (%car ,x)))
53
54(defmacro %cddr (x)
55 `(%cdr (%cdr ,x)))
56
57(defmacro %caaar (x)
58 `(%car (%car (%car ,x))))
59
60(defmacro %caadr (x)
61 `(%car (%car (%cdr ,x))))
62
63(defmacro %cadar (x)
64 `(%car (%cdr (%car ,x))))
65
66(defmacro %caddr (x)
67 `(%car (%cdr (%cdr ,x))))
68
69(defmacro %cdaar (x)
70 `(%cdr (%car (%car ,x))))
71
72(defmacro %cdadr (x)
73 `(%cdr (%car (%cdr ,x))))
74
75(defmacro %cddar (x)
76 `(%cdr (%cdr (%car ,x))))
77
78(defmacro %cdddr (x)
79 `(%cdr (%cdr (%cdr ,x))))
80
81(defmacro %rplaca (x y)
82  `(rplaca (the cons ,x) ,y))
83
84(defmacro %rplacd (x y)
85  `(rplacd (the cons ,x) ,y))
86
87; These are open-coded by the compiler to isolate platform
88; dependencies.
89
90(defmacro %unbound-marker-8 ()
91  `(%unbound-marker))
92
93(defmacro %slot-missing-marker ()
94  `(%illegal-marker))
95
96
97
98
99(defmacro %null-ptr () '(%int-to-ptr 0))
100
101;;;Assorted useful macro definitions
102
103(defmacro def-accessors (ref &rest names)
104  (define-accessors ref names))
105
106(defmacro def-accessor-macros (ref &rest names)
107  (define-accessors ref names t))
108
109(defun define-accessors (ref names &optional no-constants
110                             &aux (arg (gensym)) (index 0) progn types)
111  (when (listp ref)
112    (setq types ref
113          ref (pop names)))
114  (dolist (name names)
115    (when name
116      (unless (listp name) (setq name (list name)))
117      (dolist (sym name)
118        (when sym
119          (push `(defmacro ,sym (,arg) (list ',ref ,arg ,index)) progn)
120          (unless no-constants
121            (push `(defconstant ,sym ,index) progn)))))
122    (setq index (1+ index)))
123 `(progn
124    ,.(nreverse progn)
125    ,@(if types `((add-accessor-types ',types ',names)))
126    ,index))
127
128(defmacro specialv (var)
129  `(locally (declare (special ,var)) ,var))
130
131
132(defmacro prog1 (valform &rest otherforms)
133 (let ((val (gensym)))
134 `(let ((,val ,valform))
135   ,@otherforms
136   ,val)))
137
138(defmacro prog2 (first second &rest others)
139 `(progn ,first (prog1 ,second ,@others)))
140
141(defmacro prog (inits &body body &environment env)
142  (multiple-value-bind (forms decls) (parse-body body env nil)
143    `(block nil
144       (let ,inits
145         ,@decls
146         (tagbody ,@forms)))))
147
148(defmacro prog* (inits &body body &environment env)
149  (multiple-value-bind (forms decls) (parse-body body env nil)
150    `(block nil
151       (let* ,inits
152         ,@decls
153         (tagbody ,@forms)))))
154
155
156(defmacro %stack-block ((&rest specs) &body forms &aux vars lets)
157  (dolist (spec specs)
158    (destructuring-bind (var ptr &key clear) spec
159      (push var vars)
160      (push `(,var (%new-ptr ,ptr ,clear)) lets)))
161  `(let* ,(nreverse lets)
162     (declare (dynamic-extent ,@vars))
163     (declare (type macptr ,@vars))
164     (declare (unsettable ,@vars))
165     ,@forms))
166
167(defmacro %vstack-block (spec &body forms)
168  `(%stack-block (,spec) ,@forms))
169
170(defmacro dolist ((varsym list &optional ret) &body body &environment env)
171  (if (not (symbolp varsym)) (signal-program-error $XNotSym varsym))
172  (let* ((toplab (gensym))
173         (tstlab (gensym))
174         (lstsym (gensym)))
175    (multiple-value-bind (forms decls) (parse-body body env nil)
176     `(block nil
177       (let* ((,lstsym ,list) ,varsym)
178        ,@decls
179          (tagbody
180            (go ,tstlab)
181            ,toplab
182            (setq ,lstsym (cdr (the list ,lstsym)))
183            ,@forms
184            ,tstlab
185            (setq ,varsym (car ,lstsym))
186            (if ,lstsym (go ,toplab)))
187          ,@(if ret `((progn  ,ret))))))))
188
189
190(defmacro dovector ((varsym vector &optional ret) &body body &environment env)
191  (if (not (symbolp varsym))(signal-program-error $XNotSym varsym))
192  (let* ((toplab (gensym))
193         (tstlab (gensym))
194         (lengthsym (gensym))
195         (indexsym (gensym))
196         (vecsym (gensym)))
197    (multiple-value-bind (forms decls) (parse-body body env nil)
198     `(let* ((,vecsym ,vector)
199             (,lengthsym (length ,vecsym))
200             (,indexsym 0)
201             ,varsym)
202        ,@decls
203        ,@(let ((type (nx-form-type vector env)))
204            (unless (eq type t)
205              `((declare (type ,type ,vecsym)))))
206        (block nil
207          (tagbody
208            (go ,tstlab)
209            ,toplab
210            (setq ,varsym (locally (declare (optimize (speed 3) (safety 0)))
211                            (aref ,vecsym ,indexsym))
212                  ,indexsym (%i+ ,indexsym 1))
213            ,@forms
214            ,tstlab
215            (if (%i< ,indexsym ,lengthsym) (go ,toplab)))
216          ,@(if ret `((progn (setq ,varsym nil) ,ret))))))))
217
218(defmacro report-bad-arg (&rest args)
219  `(values (%badarg ,@args)))
220
221(defmacro %cons-restart (name action report interactive test)
222 `(gvector :istruct 'restart ,name ,action ,report ,interactive ,test))
223
224(defmacro restart-bind (clauses &body body)
225  (let* ((restarts (mapcar #'(lambda (clause) 
226                               (list (make-symbol (symbol-name (require-type (car clause) 'symbol)))
227                                     `(%cons-restart nil nil nil nil nil)))
228                           clauses))
229         (bindings (mapcar #'(lambda (clause name)
230                              `(make-restart ,(car name) ',(car clause)
231                                             ,@(cdr clause)))
232                           clauses restarts))
233        (cluster (gensym)))
234    `(let* (,@restarts)
235       (declare (dynamic-extent ,@(mapcar #'car restarts)))
236       (let* ((,cluster (list ,@bindings))
237              (%restarts% (cons ,cluster %restarts%)))
238         (declare (dynamic-extent ,cluster %restarts%))
239         (progn
240           ,@body)))))
241
242(defmacro handler-bind (clauses &body body)
243  (let* ((fns)
244         (decls)         
245         (bindings (mapcan #'(lambda (clause)
246                               (destructuring-bind (condition handler) clause
247                                 (if (and (consp handler)(eq (car handler) 'function)
248                                          (consp (cadr handler))(eq (car (cadr handler)) 'lambda))
249                                   (let ((fn (gensym)))
250                                     (push `(,fn ,handler) fns)
251                                     (push `(declare (dynamic-extent ,fn)) decls)
252                                     `(',condition ,fn))
253                                   (list `',condition
254                                         `,handler))))
255                           clauses))
256        (cluster (gensym)))   
257    `(let* (,@fns
258            (,cluster (list ,@bindings))
259            (%handlers% (cons ,cluster %handlers%)))
260       (declare (dynamic-extent ,cluster %handlers%))
261       ,@decls
262       (progn
263         ,@body))))
264
265(defmacro restart-case (&environment env form &rest clauses)
266  (let ((cluster nil))
267    (when clauses (setq cluster (gensym) form (restart-case-form form env cluster)))
268    (flet ((restart-case-1 (name arglist &rest forms)
269             (let (interactive report test)
270               (loop
271                 (case (car forms)
272                   (:interactive (setq interactive (cadr forms)))
273                   (:report (setq report (cadr forms)))
274                   (:test (setq test (cadr forms)))
275                   (t (return nil)))
276                 (setq forms (cddr forms)))
277               (when (and report (not (stringp report)))
278                 (setq report `#',report))
279               (when interactive
280                 (setq interactive `#',interactive))
281               (when test
282                 (setq test `#',test))
283               (values (require-type name 'symbol) arglist report interactive test forms))))
284      (cond ((null clauses) form)
285            ((and (null (cdr clauses)) (null (cadr (car clauses))))
286             (let ((block (gensym)) 
287                   (restart-name (gensym)))
288               (multiple-value-bind (name arglist report interactive test body)
289                                    (apply #'restart-case-1 (car clauses))
290                 (declare (ignore arglist))
291                 `(block ,block
292                    (let* ((,restart-name (%cons-restart ',name () ,report ,interactive ,test))
293                           (,cluster (list ,restart-name))
294                           (%restarts% (cons ,cluster %restarts%)))
295                      (declare (dynamic-extent ,restart-name ,cluster %restarts%))
296                      (catch ,cluster (return-from ,block ,form)))
297                    ,@body))))
298            (t
299             (let ((block (gensym)) (val (gensym))
300                   (index -1) restarts restart-names restart-name cases)
301               (while clauses
302                 (setq index (1+ index))
303                 (multiple-value-bind (name arglist report interactive test body)
304                                      (apply #'restart-case-1 (pop clauses))
305                   (push (setq restart-name (make-symbol (symbol-name name))) restart-names)
306                   (push (list restart-name `(%cons-restart ',name ,index ,report ,interactive ,test))
307                         restarts)
308                   (when (null clauses) (setq index t))
309                   (push `(,index (apply #'(lambda ,arglist ,@body) ,val))
310                         cases)))
311               `(block ,block
312                  (let ((,val (let* (,@restarts
313                                     (,cluster (list ,@(reverse restart-names)))
314                                     (%restarts% (cons ,cluster %restarts%)))
315                                (declare (dynamic-extent ,@restart-names ,cluster %restarts%))
316                                (catch ,cluster (return-from ,block ,form)))))
317                    (case (pop ,val)
318                      ,@(nreverse cases))))))))))
319
320
321; Anything this hairy should die a slow and painful death.
322; Unless, of course, I grossly misunderstand...
323(defun restart-case-form (form env clustername)
324  (let ((expansion (macroexpand form env))
325        (head nil))
326    (if (and (listp expansion)          ; already an ugly hack, made uglier by %error case ...
327             (memq (setq head (pop expansion)) '(signal error cerror warn %error)))
328      (let ((condform nil)
329            (signalform nil)
330            (cname (gensym)))
331        (case head
332          (cerror
333           (destructuring-bind 
334             (continue cond &rest args) expansion
335             (setq condform `(condition-arg ,cond (list ,@args) 'simple-error)
336                   signalform `(cerror ,continue ,cname))))
337          ((signal error warn)
338           (destructuring-bind
339             (cond &rest args) expansion
340             (setq condform `(condition-arg ,cond (list ,@args) ,(if (eq head 'warning)
341                                                                   ''simple-warning
342                                                                   (if (eq head 'error)
343                                                                     ''simple-error
344                                                                     ''simple-condition)))
345                   signalform `(,head ,cname))))
346          (t ;%error
347           (destructuring-bind (cond args fp) expansion
348             (setq condform `(condition-arg ,cond ,args 'simple-error)
349                   signalform `(%error ,cname nil ,fp)))))
350        `(let ((,cname ,condform))
351           (with-condition-restarts ,cname ,clustername
352             ,signalform)))
353      form)))
354     
355
356(defmacro handler-case (form &rest clauses &aux last)
357  (flet ((handler-case (type var &rest body)
358           (when (eq type :no-error)
359             (signal-program-error "The :no-error clause must be last."))
360           (values type var body)))
361    (cond ((null clauses) form)
362          ((eq (car (setq last (car (last clauses)))) :no-error)
363           (let ((error (gensym))
364                 (block (gensym))
365                 (var   (cadr last)))
366             (if var
367               `(block ,error
368                  (multiple-value-call #'(lambda ,@(cdr last))
369                                       (block ,block
370                                         (return-from ,error
371                                           (handler-case (return-from ,block ,form)
372                                             ,@(butlast clauses))))))
373               `(block ,error
374                  (block ,block
375                    (return-from ,error
376                      (handler-case (return-from ,block ,form)
377                        ,@(butlast clauses))))
378                  (locally ,@(cddr last))))))
379          ((null (cdr clauses))
380           (let ((block   (gensym))
381                 (cluster (gensym)))
382             (multiple-value-bind (type var body)
383                                  (apply #'handler-case (car clauses))
384               (if var
385                 `(block ,block
386                    ((lambda ,var ,@body)
387                      (let* ((,cluster (list ',type))
388                            (%handlers% (cons ,cluster %handlers%)))
389                       (declare (dynamic-extent ,cluster %handlers%))
390                       (catch ,cluster (return-from ,block ,form)))))
391                 `(block ,block
392                    (let* ((,cluster (list ',type))
393                           (%handlers% (cons ,cluster %handlers%)))
394                      (declare (dynamic-extent ,cluster %handlers%))
395                      (catch ,cluster (return-from ,block ,form)))
396                    (locally ,@body))))))
397          (t (let ((block (gensym)) (cluster (gensym)) (val (gensym))
398                   (index -1) handlers cases)
399               (while clauses
400                 (setq index (1+ index))
401                 (multiple-value-bind (type var body)
402                                      (apply #'handler-case (pop clauses))                   
403                   (push `',type handlers)
404                   (push index handlers)
405                   (when (null clauses) (setq index t))
406                   (push (if var
407                           `(,index ((lambda ,var ,@body) ,val))
408                           `(,index (locally ,@body))) cases)))
409               `(block ,block
410                  (let ((,val (let* ((,cluster (list ,@(nreverse handlers)))
411                                     (%handlers% (cons ,cluster %handlers%)))
412                                (declare (dynamic-extent ,cluster %handlers%))
413                                (catch ,cluster (return-from ,block ,form)))))
414                    (case (pop ,val)
415                      ,@(nreverse cases)))))))))
416
417(defmacro with-simple-restart ((restart-name format-string &rest format-args)
418                               &body body
419                               &aux (cluster (gensym)) (temp (make-symbol (symbol-name restart-name))))
420  (unless (and (stringp format-string)
421               (null format-args)
422               (not (%str-member #\~ (ensure-simple-string format-string))))
423    (let ((stream (gensym)))
424      (setq format-string `#'(lambda (,stream) (format ,stream ,format-string ,@format-args)))))
425  `(let* ((,temp (%cons-restart ',restart-name
426                                'simple-restart
427                                ,format-string
428                                nil
429                                nil))
430          (,cluster (list ,temp))
431          (%restarts% (cons ,cluster %restarts%)))
432     (declare (dynamic-extent ,temp ,cluster %restarts%))
433     (catch ,cluster ,@body)))
434
435;Like with-simple-restart but takes a pre-consed restart.  Not CL.
436(defmacro with-restart (restart &body body &aux (cluster (gensym)))
437  `(let* ((,cluster (list ,restart))
438          (%restarts% (cons ,cluster %restarts%)))
439     (declare (dynamic-extent ,cluster %restarts%))
440     (catch ,cluster ,@body)))
441
442(defmacro ignore-errors (&rest forms)
443  `(handler-case (progn ,@forms)
444     (error (condition) (values nil condition))))
445
446(defmacro def-kernel-restart (&environment env errno name arglist &body body)
447  (multiple-value-bind (body decls)
448                       (parse-body body env)
449    `(let* ((fn (nfunction ,name (lambda ,arglist ,@decls (block ,name ,@body))))
450            (pair (assq ,errno ccl::*kernel-restarts*)))
451       (if pair
452         (rplacd pair fn)
453         (push (cons ,errno fn) ccl::*kernel-restarts*))
454       fn)))
455
456
457;;; Setf.
458
459;  If you change anything here, be sure to make the corresponding change
460;  in get-setf-method.
461(defmacro setf (&rest args &environment env)
462  "Takes pairs of arguments like SETQ.  The first is a place and the second
463  is the value that is supposed to go into that place.  Returns the last
464  value.  The place argument may be any of the access forms for which SETF
465  knows a corresponding setting form."
466  (let ((temp (length args))
467        (accessor nil))
468    (cond ((eq temp 2)
469           (let* ((form (car args)) 
470                  (value (cadr args)))
471             ;This must match get-setf-method .
472             (if (atom form)
473               (progn
474                 (unless (symbolp form)(signal-program-error $XNotSym form))
475                 `(setq ,form ,value))
476               (multiple-value-bind (ftype local-p)
477                                    (function-information (setq accessor (car form)) ENV)
478                 (if local-p
479                   (if (eq ftype :function)
480                     ;Local function, so don't use global setf definitions.
481                     (default-setf form value env)
482                     `(setf ,(macroexpand-1 form env) ,value))
483                   (cond
484                    ((setq temp (%setf-method accessor))
485                     (if (symbolp temp)
486                       `(,temp ,@(cdar args) ,value)
487                       (multiple-value-bind (dummies vals storevars setter #|getter|#)
488                                            (funcall temp form env)
489                         (do* ((d dummies (cdr d))
490                               (v vals (cdr v))
491                               (let-list nil))
492                              ((null d)
493                               (setq let-list (nreverse let-list))
494                               `(let* ,let-list
495                                  (declare (ignorable ,@dummies))
496                                  (multiple-value-bind ,storevars ,value
497                                    #|,getter|#
498                                    ,setter)))
499                           (push (list (car d) (car v)) let-list)))))
500                    ((and (type-and-refinfo-p (setq temp (or (environment-structref-info accessor env)
501                                                             (and #-bccl (boundp '%structure-refs%)
502                                                                  (gethash accessor %structure-refs%)))))
503                          (not (refinfo-r/o (if (consp temp) (%cdr temp) temp))))
504                     (if (consp temp)
505                       ;; strip off type, but add in a require-type
506                       (let ((type (%car temp)))
507                         `(the ,type (setf ,(defstruct-ref-transform (%cdr temp) (%cdar args))
508                                           (require-type ,value ',type))))
509                       `(setf ,(defstruct-ref-transform temp (%cdar args))
510                              ,value)))
511                    (t
512                     (multiple-value-bind (res win)
513                                          (macroexpand-1 form env)
514                       (if win
515                         `(setf ,res ,value)
516                         (default-setf form value env))))))))))
517          ((oddp temp)
518           (error "Odd number of args to SETF : ~s." args))
519          (t (do* ((a args (cddr a)) (l nil))
520                  ((null a) `(progn ,@(nreverse l)))
521               (push `(setf ,(car a) ,(cadr a)) l))))))
522
523
524(defun default-setf (setter value &optional env)
525  (let* ((reader (car setter))
526         (args (cdr setter))
527         (gensyms (mapcar #'(lambda (sym) (declare (ignore sym)) (gensym)) args))
528         types declares)
529    (flet ((form-type (form)
530             (nx-form-type form env)))
531      (declare (dynamic-extent #'form-type))
532      (setq types (mapcar #'form-type args)))
533    (dolist (sym gensyms)
534      (let ((sym-type (pop types)))
535        (unless (eq sym-type t)
536          (push `(type ,sym-type ,sym) declares))))
537    `(let ,(mapcar #'list gensyms args)
538       ,@(and declares (list `(declare ,@(nreverse declares))))
539       (funcall #'(setf ,reader) ,value ,@gensyms))))
540
541;; Establishing these setf-inverses is something that should
542;; happen at compile-time
543(defsetf elt set-elt)
544(defsetf car set-car)
545(defsetf first set-car)
546(defsetf cdr set-cdr)
547(defsetf rest set-cdr)
548(defsetf uvref uvset)
549(defsetf aref aset)
550(defsetf svref svset)
551(defsetf %svref %svset)
552(defsetf char set-char)
553(defsetf schar set-schar)
554(defsetf %scharcode %set-scharcode)
555(defsetf symbol-value set)
556(defsetf symbol-plist set-symbol-plist)
557(defsetf fill-pointer set-fill-pointer)
558
559; This sux; it calls the compiler twice (once to shove the macro in the
560; environment, once to dump it into the file.)
561(defmacro defmacro  (name arglist &body body &environment env)
562  (unless (symbolp name)(signal-program-error $XNotSym name))
563  (unless (listp arglist) (signal-program-error "~S is not a list." arglist))
564  (multiple-value-bind (lambda-form doc)
565                       (parse-macro-1 name arglist body env)
566    (let* ((normalized (normalize-lambda-list arglist t t))
567           (body-pos (position '&body normalized))
568           (argstring (let ((temp nil))
569                        (dolist (arg normalized)
570                          (if (eq arg '&aux)
571                            (return)
572                            (push arg temp)))
573                        (format nil "~:a" (nreverse temp)))))
574      (if (and body-pos (memq '&optional normalized)) (decf body-pos))
575      `(progn
576         (eval-when (:compile-toplevel)
577           (define-compile-time-macro ',name ',lambda-form ',env))
578         (eval-when (:load-toplevel :execute)
579           (%macro 
580            (nfunction ,name ,lambda-form)
581            '(,doc ,body-pos . ,argstring))
582           ',name)))))
583
584(defmacro define-symbol-macro (name expansion &environment env)
585  (unless (symbolp name)(signal-program-error $XNotSym name))
586  `(progn
587    (eval-when (:compile-toplevel)
588      (define-compile-time-symbol-macro ',name ',expansion ',env))
589    (eval-when (:load-toplevel :execute)
590      (%define-symbol-macro ',name ',expansion))))
591
592;; ---- allow inlining setf functions
593(defmacro defun (spec args &body body &environment env &aux global-name inline-spec)
594  (validate-function-name spec)
595  (setq args (require-type args 'list))
596  (setq body (require-type body 'list))
597  (multiple-value-bind (forms decls doc) (parse-body body env t)
598    (cond ((symbolp spec)
599           (setq global-name spec)
600           (setq inline-spec spec)
601           (setq body `(block ,spec ,@forms)))
602          ((and (consp spec) (eq 'setf (%car spec)))
603           (setq inline-spec spec)
604           (setq body `(block ,(cadr spec) ,@forms)))
605          (t (setq body `(progn ,@forms))))
606    (let* ((lambda-expression `(lambda ,args 
607                                ,@(if global-name
608                                    `((declare (global-function-name ,global-name))))
609                                ,@decls ,body))
610           (info (if (and inline-spec
611                          (or (null env)
612                              (definition-environment env t))
613                          (nx-declared-inline-p inline-spec env)
614                          (not (and (symbolp inline-spec)
615                                    (gethash inline-spec *NX1-ALPHATIZERS*))))
616                   (cons doc lambda-expression)
617                   doc)))
618      `(progn
619         (eval-when (:compile-toplevel)
620           (note-function-info ',spec ',lambda-expression ,env))
621         (%defun (nfunction ,spec ,lambda-expression) ',info)
622         ',spec))))
623
624(defmacro %defvar-init (var initform doc)
625  `(unless (%defvar ',var ,doc)
626     (setq ,var ,initform)))
627
628(defmacro defvar (&environment env var &optional (value () value-p) doc)
629  (if (and doc (not (stringp doc))) (report-bad-arg doc 'string))
630  (if (and (compile-file-environment-p env) (not *fasl-save-doc-strings*))
631    (setq doc nil))
632 `(progn
633    (eval-when (:compile-toplevel)
634      (note-variable-info ',var ,value-p ,env))
635    ,(if value-p
636       `(%defvar-init ,var ,value ,doc)
637       `(%defvar ',var))
638    ',var))
639         
640(defmacro def-standard-initial-binding (name &optional (form name) &environment env)
641  `(progn
642    (eval-when (:compile-toplevel)
643      (note-variable-info ',name t ,env))   
644    (define-standard-initial-binding ',name #'(lambda () ,form))
645    ',name))
646
647(defmacro defparameter (&environment env var value &optional doc)
648  (if (and doc (not (stringp doc))) (signal-program-error "~S is not a string." doc))
649  (if (and (compile-file-environment-p env) (not *fasl-save-doc-strings*))
650    (setq doc nil))
651  `(progn
652     (eval-when (:compile-toplevel)
653       (note-variable-info ',var t ,env))
654     (%defparameter ',var ,value ,doc)))
655
656(defmacro defglobal (&environment env var value &optional doc)
657  (if (and doc (not (stringp doc))) (signal-program-error "~S is not a string." doc))
658  (if (and (compile-file-environment-p env) (not *fasl-save-doc-strings*))
659    (setq doc nil))
660  `(progn
661     (eval-when (:compile-toplevel)
662       (note-variable-info ',var :global ,env))
663     (%defglobal ',var ,value ,doc)))
664
665
666(defmacro defloadvar (&environment env var value &optional doc)
667  `(progn
668     (defvar ,var ,@(if doc `(nil ,doc)))
669     (def-ccl-pointers ,var ()
670       (setq ,var ,value))
671     ',var))
672
673
674(defmacro qlfun (name args &body body)
675  `(nfunction ,name (lambda ,args ,@body)))
676
677(defmacro lfun-bits-known-function (f)
678  (let* ((temp (gensym)))
679    `(let* ((,temp ,f))
680      (%svref ,temp (the fixnum (1- (the fixnum (uvsize ,temp))))))))
681
682; %Pascal-Functions% Entry
683; Used by "l1;ppc-callback-support" & "lib;dumplisp"
684(def-accessor-macros %svref
685  pfe.routine-descriptor
686  pfe.proc-info
687  pfe.lisp-function
688  pfe.sym
689  pfe.without-interrupts)
690
691(defmacro cond (&rest args &aux clause)
692  (when args
693     (setq clause (car args))
694     (if (cdr clause)         
695         `(if ,(car clause) (progn ,@(cdr clause)) (cond ,@(cdr args)))
696       (if (cdr args) `(or ,(car clause) (cond ,@(cdr args)))
697                      `(values ,(car clause))))))
698
699(defmacro and (&rest args)
700  (if (null args) t
701    (if (null (cdr args)) (car args)
702      `(if ,(car args) (and ,@(cdr args))))))
703
704(defmacro or (&rest args)
705  (if args
706    (if (cdr args)
707      (do* ((temp (gensym))
708            (handle (list nil))
709            (forms `(let ((,temp ,(pop args)))
710                      (if ,temp ,temp ,@handle))))
711           ((null (cdr args))
712            (%rplaca handle (%car args))
713            forms)
714        (%rplaca handle `(if (setq ,temp ,(%car args)) 
715                           ,temp 
716                           ,@(setq handle (list nil))))
717        (setq args (%cdr args)))
718      (%car args))))
719
720(defmacro case (key &body forms) 
721   (let ((key-var (gensym)))
722     `(let ((,key-var ,key))
723        (declare (ignorable ,key-var))
724        (cond ,@(case-aux forms key-var nil nil)))))
725
726(defmacro ccase (keyplace &body forms)
727  (let* ((key-var (gensym))
728         (tag (gensym)))
729    `(prog (,key-var)
730       ,tag
731       (setq ,key-var ,keyplace)
732       (return (cond ,@(case-aux forms key-var tag keyplace))))))
733
734(defmacro ecase (key &body forms)
735  (let* ((key-var (gensym)))
736    `(let ((,key-var ,key))
737       (declare (ignorable ,key-var))
738       (cond ,@(case-aux forms key-var 'ecase nil)))))
739       
740(defun case-aux (clauses key-var e-c-p placename &optional (used-keys (list (list '%case-core))))
741  (if clauses
742    (let* ((key-list (caar clauses))
743           (stype (if e-c-p (if (eq e-c-p 'ecase) e-c-p 'ccase) 'case))
744           (test (cond ((and (not e-c-p)
745                             (or (eq key-list 't)
746                                 (eq key-list 'otherwise)))
747                        t)
748                       (key-list
749                        (cons 'or
750                              (case-key-testers key-var used-keys key-list stype)))))
751           (consequent-list (or (%cdar clauses) '(nil))))
752      (if (eq test t)
753        (progn
754          (when (%cdr clauses) (warn "~s or ~s clause in the middle of a ~s statement.  Subsequent clauses ignored."
755                                     't 'otherwise 'case))
756          (cons (cons t consequent-list) nil))
757        (cons (cons test consequent-list)
758              (case-aux (%cdr clauses) key-var e-c-p placename used-keys))))
759    (when e-c-p
760      (setq used-keys `(member ,@(mapcar #'car (cdr used-keys))))
761      (if (eq e-c-p 'ecase)
762        `((t (values (%err-disp #.$XWRONGTYPE ,key-var ',used-keys))))
763        `((t (setf ,placename (ensure-value-of-type ,key-var ',used-keys ',placename))
764           (go ,e-c-p)))))))
765
766
767;;; We don't want to descend list structure more than once (like this has
768;;; been doing for the last 18 years or so.)
769(defun case-key-testers (symbol used-keys atom-or-list statement-type &optional recursive)
770  (if (or recursive (atom atom-or-list))
771    (progn
772      (if (assoc atom-or-list used-keys)
773        (warn "Duplicate keyform ~s in ~s statement." atom-or-list statement-type)
774        (nconc used-keys (list (cons atom-or-list t))))
775      `((,(if (typep atom-or-list '(and number (not fixnum)))
776              'eql
777              'eq)
778         ,symbol ',atom-or-list)))
779    (nconc (case-key-testers symbol used-keys (car atom-or-list) statement-type t)
780           (when (cdr atom-or-list)
781             (case-key-testers symbol used-keys (%cdr atom-or-list) statement-type nil)))))
782
783
784; generate the COND body of a {C,E}TYPECASE form
785(defun typecase-aux (key-var clauses &optional e-c-p keyform)
786  (let* ((construct (if e-c-p (if (eq e-c-p 'etypecase) e-c-p 'ctypecase) 'typecase))
787         (types ())
788         (t-clause ())
789         (body ()))
790    (flet ((bad-clause (c) 
791             (error "Invalid clause ~S in ~S form." c construct)))
792      (dolist (clause clauses)
793        (if (atom clause)
794          (bad-clause clause)
795          (destructuring-bind (typespec &body consequents) clause
796            (when (eq construct 'typecase)
797              (if (eq typespec 'otherwise)
798                (setq typespec t))
799              (if (eq typespec t)
800                (if t-clause
801                  (bad-clause clause)   ; seen one already
802                  (setq t-clause `( t nil ,@consequents)))))
803            (unless (and (eq construct 'typecase)
804                         (eq typespec t))
805              (when
806                  (dolist (already types t)
807                    (when (subtypep typespec already)
808                      (warn "Clause ~S ignored in ~S form - shadowed by ~S ." clause construct (assq already clauses))
809                      (return)))
810                (push typespec types)
811                (unless (eq typespec t)
812                  (setq typespec `(typep ,key-var ',typespec)))
813                (push `(,typespec nil ,@consequents) body))))))
814      (when e-c-p
815        (setq types `(or ,@(nreverse types)))
816        (if (eq construct 'etypecase)
817          (push `(t (values (%err-disp #.$XWRONGTYPE ,key-var ',types))) body)
818          (push `(t (setf ,keyform (ensure-value-of-type ,key-var ',types ',keyform))
819                  (go ,e-c-p)) body))))
820    (when t-clause
821      (push t-clause body))
822    `(cond ,@(nreverse body))))
823
824(defmacro typecase (keyform &body clauses)
825  (let ((key-var (gensym)))
826    `(let ((,key-var ,keyform))
827       (declare (ignorable ,key-var))
828       ,(typecase-aux key-var clauses))))
829
830(defmacro etypecase (keyform &body clauses)
831  (let ((key-var (gensym)))
832    `(let ((,key-var ,keyform))
833       (declare (ignorable ,key-var))
834       ,(typecase-aux key-var clauses 'etypecase))))
835
836(defmacro ctypecase (keyform &body clauses)
837  (let ((key-var (gensym))
838        (tag (gensym)))
839    `(prog (,key-var)
840       ,tag
841       (setq ,key-var ,keyform)
842       (return ,(typecase-aux key-var clauses tag keyform)))))
843
844(defmacro destructuring-bind (lambda-list expression &body body)
845  (multiple-value-bind (bindings decls)
846      (%destructure-lambda-list  lambda-list expression nil nil)
847    `(let* ,(nreverse bindings)
848      ,@(when decls `((declare ,@decls)))
849      ,@body)))
850
851(defmacro make-destructure-state (tail whole lambda)
852  `(gvector :istruct 'destructure-state ,tail ,whole ,lambda))
853
854
855; This is supposedly ANSI CL.
856(defmacro lambda (&whole lambda-expression (&rest paramlist) &body body)
857  (unless (lambda-expression-p lambda-expression)
858    (warn "Invalid lambda expression: ~s" lambda-expression))
859  `(function (lambda ,paramlist ,@body)))
860
861
862(defmacro when (test &body body)
863 `(if ,test
864   (progn ,@body)))
865
866(defmacro unless (test &body body)
867 `(if (not ,test)
868   (progn ,@body)))
869
870(defmacro return (&optional (form nil form-p))
871  `(return-from nil ,@(if form-p `(,form))))
872
873; since they use tagbody, while & until BOTH return NIL
874(defmacro while (test &body body)
875  (let ((testlab (gensym))
876        (toplab (gensym)))
877    `(tagbody
878       (go ,testlab)
879      ,toplab
880      (progn ,@body)
881      ,testlab
882      (when ,test (go ,toplab)))))
883
884(defmacro until (test &body body)
885  (let ((testlab (gensym))
886        (toplab (gensym)))
887    `(tagbody
888       (go ,testlab)
889      ,toplab
890      (progn ,@body)
891      ,testlab
892      (if (not ,test)
893        (go ,toplab)))))
894
895(defmacro psetq (&whole call &body pairs &environment env)
896  (when pairs
897   (if (evenp (length pairs))
898     (do* ((l pairs (%cddr l))
899           (sym (%car l) (%car l)))
900          ((null l) (%pset pairs))
901       (unless (symbolp sym) (report-bad-arg sym 'symbol))
902       (when (nth-value 1 (macroexpand-1 sym env))
903         (return `(psetf ,@pairs))))
904     (error "Uneven number of args in the call ~S" call))))
905
906; generates body for psetq.
907; "pairs" is a proper list whose length is not odd.
908(defun %pset (pairs)
909 (when pairs
910   (let (vars vals gensyms let-list var val sets)
911      (loop
912        (setq var (pop pairs)
913              val (pop pairs))
914        (if (null pairs) (return))
915        (push var vars)
916        (push val vals)
917        (push (gensym) gensyms))
918      (dolist (g gensyms)
919        (push g sets)
920        (push (pop vars) sets)
921        (push (list g (pop vals)) let-list))
922      (push val sets)
923      (push var sets)
924      `(progn
925         (let ,let-list
926           (setq ,@sets))
927         nil))))
928
929
930(eval-when (:compile-toplevel :load-toplevel :execute)
931(defun do-loop (binder setter env var-init-steps end-test result body)
932  (let ((toptag (gensym))
933        (testtag (gensym)))
934    (multiple-value-bind (forms decls) (parse-body body env nil)
935      `(block nil
936         (,binder ,(do-let-vars var-init-steps)
937                  ,@decls
938                  (tagbody ; crocks-r-us.
939                    (go ,testtag)
940                    ,toptag
941                    (tagbody
942                      ,@forms)
943                    (,setter ,@(do-step-vars var-init-steps))
944                    ,testtag
945                    (unless ,end-test
946                      (go ,toptag)))
947                  ,@result)))))
948)
949
950(defmacro do (&environment env var-init-steps (&optional end-test &rest result) &body body)
951  (do-loop 'let 'psetq env var-init-steps end-test result body))
952
953(defmacro do* (&environment env var-init-steps (&optional end-test &rest result) &body body)
954  (do-loop 'let* 'setq env var-init-steps end-test result body))
955
956
957(defun do-let-vars (var-init-steps)
958  (if var-init-steps
959      (cons (list (do-let-vars-var (car var-init-steps))
960                  (do-let-vars-init (car var-init-steps)))
961             (do-let-vars (cdr var-init-steps)))))
962
963(defun do-let-vars-var (var-init-step)
964  (if (consp var-init-step)
965       (car var-init-step)
966       var-init-step))
967
968(defun do-let-vars-init (var-init-step)
969   (if (consp var-init-step)
970        (cadr var-init-step)
971        nil))
972
973(defun do-step-vars (var-init-steps)
974    (if var-init-steps
975        (if (do-step-vars-step? (car var-init-steps))
976             (append (list (do-let-vars-var (car var-init-steps))
977                           (do-step-vars-step (car var-init-steps)))
978                     (do-step-vars (cdr var-init-steps)))
979             (do-step-vars (cdr var-init-steps)))))
980
981(defun do-step-vars-step? (var-init-step)
982  (if (consp var-init-step)
983       (cddr var-init-step)))
984
985(defun do-step-vars-step (var-init-step)
986  (if (consp var-init-step)
987       (caddr var-init-step)))
988
989
990(defmacro dotimes ((i n &optional result) &body body &environment env)
991  (multiple-value-bind (forms decls)
992                       (parse-body body env)
993    (if (not (symbolp i))(signal-program-error $Xnotsym i))
994    (let* ((toptag (gensym))
995           (limit (gensym)))
996      `(block nil
997        (let ((,limit ,n) (,i 0))
998         ,@decls
999         (declare (unsettable ,i))
1000           (if (int>0-p ,limit)
1001             (tagbody
1002               ,toptag
1003               ,@forms
1004               (locally
1005                (declare (settable ,i))
1006                (setq ,i (1+ ,i)))
1007               (unless (eql ,i ,limit) (go ,toptag))))
1008           ,result)))))
1009 
1010(defun do-syms-result (var resultform)
1011  (unless (eq var resultform)
1012    (if (and (consp resultform) (not (quoted-form-p resultform)))
1013      `(progn (setq ,var nil) ,resultform)
1014      resultform)))
1015
1016(defun expand-package-iteration-macro (iteration-function var pkg-spec resultform body env)
1017  (multiple-value-bind (body decls) (parse-body body env nil)
1018    (let* ((ftemp (gensym))
1019           (vtemp (gensym))
1020           (result (do-syms-result var resultform)))
1021      `(block nil
1022        (let* ((,var nil))
1023          ,@decls
1024           (flet ((,ftemp (,vtemp) (declare (debugging-function-name nil)) (setq ,var ,vtemp) (tagbody ,@body)))
1025             (declare (dynamic-extent #',ftemp))
1026             (,iteration-function ,pkg-spec #',ftemp))
1027           ,@(when result `(,result)))))))
1028
1029(defmacro do-symbols ((var &optional pkg result) &body body &environment env)
1030  (expand-package-iteration-macro 'iterate-over-accessable-symbols var pkg result body env))
1031
1032(defmacro do-present-symbols ((var &optional pkg result) &body body &environment env)
1033  (expand-package-iteration-macro 'iterate-over-present-symbols var pkg result body env))
1034
1035(defmacro do-external-symbols ((var &optional pkg result) &body body &environment env)
1036  (expand-package-iteration-macro 'iterate-over-external-symbols var pkg result body env))
1037
1038(defmacro do-all-symbols ((var &optional resultform) 
1039                          &body body &environment env)
1040  (multiple-value-bind (body decls) (parse-body body env nil)
1041    (let* ((ftemp (gensym))
1042           (vtemp (gensym))
1043           (result (do-syms-result var resultform)))
1044      `(block nil
1045        (let* ((,var nil))
1046         ,@decls
1047           (flet ((,ftemp (,vtemp) (declare (debugging-function-name nil)) (setq ,var ,vtemp) (tagbody ,@body)))
1048             (declare (dynamic-extent #',ftemp))
1049             (iterate-over-all-symbols #',ftemp))
1050           ,@(when result `(,result)))))))
1051
1052(defmacro multiple-value-list (form)
1053  `(multiple-value-call #'list ,form))
1054
1055(defmacro multiple-value-bind (varlist values-form &body body &environment env)
1056  (multiple-value-bind (body decls)
1057                       (parse-body body env)
1058    (let ((ignore (make-symbol "IGNORE")))
1059      `(multiple-value-call #'(lambda (&optional ,@varlist &rest ,ignore)
1060                                (declare (ignore ,ignore))
1061                                ,@decls
1062                                ,@body)
1063                            ,values-form))))
1064
1065(defmacro multiple-value-setq (vars val)
1066  (if vars
1067    `(values (setf (values ,@(mapcar #'(lambda (s) (require-type s 'symbol)) vars))  ,val))
1068    `(prog1 ,val)))
1069
1070(defmacro nth-value (n form)
1071  `(car (nthcdr ,n (multiple-value-list ,form))))
1072
1073
1074(defmacro %i> (x y)
1075  `(> (the fixnum ,x) (the fixnum ,y)))
1076
1077(defmacro %i< (x y)
1078  `(< (the fixnum ,x) (the fixnum ,y)))
1079
1080(defmacro %i<= (x y)
1081 `(not (%i> ,x ,y)))
1082
1083(defmacro %i>= (x y)
1084 `(not (%i< ,x ,y)))
1085
1086(defmacro bitset (bit number)
1087  `(logior (ash 1 ,bit) ,number))
1088
1089(defmacro bitclr (bit number)
1090  `(logand (lognot (ash 1 ,bit)) ,number))
1091
1092(defmacro bitopf ((op bit place) &environment env)
1093  (multiple-value-bind (vars vals stores store-form access-form)
1094                       (get-setf-method place env)
1095    (let* ((constant-bit-p (constantp bit))
1096           (bitvar (if constant-bit-p bit (gensym))))
1097      `(let ,(unless constant-bit-p `((,bitvar ,bit)))          ; compiler isn't smart enough
1098         (let* ,(mapcar #'list `(,@vars ,@stores) `(,@vals (,op ,bitvar ,access-form)))
1099           ,store-form)))))
1100
1101(defmacro bitsetf (bit place)
1102  `(bitopf (bitset ,bit ,place)))
1103
1104(defmacro bitclrf (bit place)
1105  `(bitopf (bitclr ,bit ,place)))
1106
1107(defmacro %svref (v i)
1108  (let* ((vtemp (make-symbol "VECTOR"))
1109           (itemp (make-symbol "INDEX")))
1110      `(let* ((,vtemp ,v)
1111              (,itemp ,i))
1112         (locally (declare (optimize (speed 3) (safety 0)))
1113           (svref ,vtemp ,itemp)))))
1114
1115(defmacro %svset (v i new)
1116  (let* ((vtemp (make-symbol "VECTOR"))
1117           (itemp (make-symbol "INDEX")))
1118      `(let* ((,vtemp ,v)
1119              (,itemp ,i))
1120         (locally (declare (optimize (speed 3) (safety 0)))
1121           (setf (svref ,vtemp ,itemp) ,new)))))
1122
1123
1124(defmacro %schar (v i)
1125  (let* ((vtemp (make-symbol "STRING"))
1126         (itemp (make-symbol "INDEX")))
1127    `(let* ((,vtemp ,v)
1128            (,itemp ,i))
1129       (locally (declare (optimize (speed 3) (safety 0)))
1130         (schar ,vtemp ,itemp)))))
1131
1132(defmacro %set-schar (v i new)
1133  (let* ((vtemp (make-symbol "STRING"))
1134           (itemp (make-symbol "INDEX")))
1135      `(let* ((,vtemp ,v)
1136              (,itemp ,i))
1137         (locally (declare (optimize (speed 3) (safety 0)))
1138           (setf (schar ,vtemp ,itemp) ,new)))))
1139
1140
1141
1142(defmacro %char-code (c) `(char-code (the character ,c)))
1143(defmacro %code-char (i) `(code-char (the (unsigned-byte 16) ,i)))
1144
1145(defmacro %izerop (x) `(eq ,x 0))
1146(defmacro %iminusp (x) `(< (the fixnum ,x) 0))
1147(defmacro %i+ (&rest (&optional (n0 0) &rest others))
1148  (if others
1149    `(the fixnum (+ (the fixnum ,n0) (%i+ ,@others)))
1150    `(the fixnum ,n0)))
1151(defmacro %i- (x y &rest others) 
1152  (if (not others)
1153    `(the fixnum (- (the fixnum ,x) (the fixnum ,y)))
1154    `(the fixnum (- (the fixnum ,x) (the fixnum (%i+ ,y ,@others))))))
1155
1156
1157(defmacro %i* (x y) `(the fixnum (* (the fixnum ,x) (the fixnum ,y))))
1158
1159(defmacro %ilogbitp (b i)
1160  `(logbitp (the (integer 0 29) ,b) (the fixnum ,i)))
1161
1162;;; Seq-Dispatch does an efficient type-dispatch on the given Sequence.
1163
1164(defmacro seq-dispatch (sequence list-form array-form)
1165  `(if (sequence-type ,sequence)
1166       ,list-form
1167       ,array-form))
1168
1169
1170(defsetf %get-byte %set-byte)
1171(defsetf %get-unsigned-byte %set-byte)
1172(defsetf %get-signed-byte %set-byte)
1173(defsetf %get-word %set-word)
1174(defsetf %get-signed-word %set-word)
1175(defsetf %get-unsigned-word %set-word)
1176(defsetf %get-long %set-long)
1177(defsetf %get-signed-long %set-long)
1178(defsetf %get-unsigned-long %set-long)
1179(defsetf %get-full-long %set-long)
1180(defsetf %get-point %set-long)
1181(defsetf %get-string %set-string)
1182(defsetf %get-ptr %set-ptr)
1183(defsetf %get-double-float %set-double-float)
1184(defsetf %get-single-float %set-single-float)
1185(defsetf %get-bit %set-bit)
1186(defsetf %get-unsigned-long-long %set-unsigned-long-long)
1187(defsetf %%get-unsigned-longlong %%set-unsigned-longlong)
1188(defsetf %get-signed-long-long %set-signed-long-long)
1189(defsetf %%get-signed-longlong %%set-signed-longlong)
1190(defsetf %get-bitfield %set-bitfield)
1191
1192(defmacro %ilognot (int) `(%i- -1 ,int))
1193
1194(defmacro %ilogior2 (x y) 
1195  `(logior (the fixnum ,x) (the fixnum ,y)))
1196
1197(defmacro %ilogior (body &body args)
1198   (while args
1199     (setq body (list '%ilogior2 body (pop args))))
1200   body)
1201
1202(defmacro %ilogand2 (x y)
1203  `(logand (the fixnum ,x) (the fixnum ,y)))
1204
1205(defmacro %ilogand (body &body args)
1206   (while args
1207     (setq body (list '%ilogand2 body (pop args))))
1208   body)
1209
1210(defmacro %ilogxor2 (x y)
1211  `(logxor (the fixnum ,x) (the fixnum ,y)))
1212
1213(defmacro %ilogxor (body &body args)
1214   (while args
1215     (setq body (list '%ilogxor2 body (pop args))))
1216   body)
1217
1218(defmacro with-macptrs (varlist &rest body &aux decls inits)
1219  (dolist (var varlist)
1220    (if (consp var)
1221      (progn
1222        (push (car var) decls)
1223        (push (list (%car var)
1224                    (if (%cdr var)
1225                      `(%setf-macptr (%null-ptr) ,@(%cdr var))
1226                      '(%null-ptr))) inits))
1227      (progn
1228        (push var decls)
1229        (push (list var '(%null-ptr)) inits))))
1230  `(let* ,(nreverse inits)
1231     (declare (dynamic-extent ,@decls))
1232     (declare (type macptr ,@decls))
1233     ,@body))
1234
1235(defmacro with-loading-file (filename &rest body)
1236   `(let ((*loading-files* (cons ,filename (locally (declare (special *loading-files*))
1237                                                    *loading-files*))))
1238      (declare (special *loading-files*))
1239      ,@body))
1240
1241(defmacro with-input-from-string ((var string &key index start end) &body forms &environment env)
1242  (multiple-value-bind (forms decls) (parse-body forms env nil)
1243    `(let ((,var
1244            ,(cond ((null end)
1245                    `(make-string-input-stream ,string ,(or start 0)))
1246                   ((symbolp end)
1247                    `(if ,end
1248                      (make-string-input-stream ,string ,(or start 0) ,end)
1249                      (make-string-input-stream ,string ,(or start 0))))
1250                   (t
1251                    `(make-string-input-stream ,string ,(or start 0) ,end)))))
1252      ,@decls
1253      (unwind-protect
1254           (progn ,@forms)
1255        (close ,var)
1256        ,@(if index `((setf ,index (string-input-stream-index ,var))))))))
1257
1258(defmacro with-output-to-string ((var &optional string &key (element-type 'base-char element-type-p))
1259                                 &body body 
1260                                 &environment env)
1261  (multiple-value-bind (forms decls) (parse-body body env nil)
1262    `(let ((,var ,(if string
1263                    `(%make-string-output-stream ,string)
1264                    `(make-string-output-stream :element-type ,(if element-type-p element-type `'base-char)))))
1265       ,@decls
1266       (unwind-protect
1267         (progn
1268           ,@forms
1269           ,@(if string () `((get-output-stream-string ,var))))
1270         (close ,var)))))
1271
1272(defmacro with-output-to-truncating-string-stream ((var len) &body body
1273                                                   &environment env)
1274  (multiple-value-bind (forms decls) (parse-body body env nil)
1275    `(let* ((,var (make-truncating-string-stream ,len)))
1276      ,@decls
1277      (unwind-protect
1278           (progn
1279             ,@forms
1280             (values (get-output-stream-string ,var)
1281                     (slot-value ,var 'truncated)))
1282        (close ,var)))))
1283
1284(defmacro with-open-file ((var . args) &body body &aux (stream (gensym))(done (gensym)))
1285  `(let (,stream ,done)
1286     (unwind-protect
1287       (multiple-value-prog1
1288         (let ((,var (setq ,stream (open ,@args))))
1289           ,@body)
1290         (setq ,done t))
1291       (when ,stream (close ,stream :abort (null ,done))))))
1292
1293(defmacro with-compilation-unit ((&key override) &body body)
1294  `(let* ((*outstanding-deferred-warnings* (%defer-warnings ,override)))
1295     (multiple-value-prog1 (progn ,@body) (report-deferred-warnings))))
1296
1297; Yow! Another Done Fun.
1298(defmacro with-standard-io-syntax (&body body &environment env)
1299  (multiple-value-bind (decls body) (parse-body body env)
1300    `(let ((*package* (find-package "CL-USER"))
1301           (*print-array* t)
1302           (*print-base* 10.)
1303           (*print-case* :upcase)
1304           (*print-circle* nil)
1305           (*print-escape* t)
1306           (*print-gensym* t)
1307           (*print-length* nil)
1308           (*print-level* nil)
1309           (*print-lines* nil) ; This doesn't exist as of 5/15/90 - does now
1310           (*print-miser-width* nil)
1311           (*print-pprint-dispatch* nil)
1312           (*print-pretty* nil)
1313           (*print-radix* nil)
1314           (*print-readably* t)
1315           (*print-right-margin* nil)
1316           (*read-base* 10.)
1317           (*read-default-float-format* 'single-float)
1318           (*read-eval* t) ; Also MIA as of 5/15/90
1319           (*read-suppress* nil)
1320           (*readtable* %initial-readtable%))
1321       ,@decls
1322       ,@body)))
1323           
1324(defmacro print-unreadable-object (&environment env (object stream &key type identity) &body forms)
1325  (multiple-value-bind (body decls) (parse-body forms env)
1326    (if body
1327      (let ((thunk (gensym)))
1328        `(let ((,thunk #'(lambda () ,@decls ,@body)))
1329           (declare (dynamic-extent ,thunk))
1330          (%print-unreadable-object ,object ,stream ,type ,identity ,thunk)))
1331      `(%print-unreadable-object ,object ,stream ,type ,identity nil))))
1332;; Pointers and Handles
1333
1334;;Add function to lisp system pointer functions, and run it if it's not already
1335;; there.
1336(defmacro def-ccl-pointers (name arglist &body body &aux (old (gensym)))
1337  `(flet ((,name ,arglist ,@body))
1338     (let ((,old (member ',name *lisp-system-pointer-functions* :key #'function-name)))
1339       (if ,old
1340         (rplaca ,old #',name)
1341         (progn
1342           (push #',name *lisp-system-pointer-functions*)
1343           (,name))))))
1344
1345(defmacro def-load-pointers (name arglist &body body &aux (old (gensym)))
1346  `(flet ((,name ,arglist ,@body))
1347     (let ((,old (member ',name *lisp-user-pointer-functions* :key #'function-name)))
1348       (if ,old
1349         (rplaca ,old #',name)
1350         (progn
1351           (push #',name *lisp-user-pointer-functions*)
1352           (,name))))))
1353
1354;Queue up some code to run after ccl all loaded up, or, if ccl is already
1355;loaded up, just run it right now.
1356(defmacro queue-fixup (&rest body &aux (fn (gensym)))
1357  `(let ((,fn #'(lambda () ,@body)))
1358     (if (eq %lisp-system-fixups% T)
1359       (funcall ,fn)
1360       (push (cons ,fn *loading-file-source-file*) %lisp-system-fixups%))))
1361
1362(defmacro %incf-ptr (p &optional (by 1))
1363  (if (symbolp p)  ;once-only
1364    `(%setf-macptr (the macptr ,p) (%inc-ptr ,p ,by))
1365    (let ((var (gensym)))
1366      `(let ((,var ,p)) (%setf-macptr (the macptr ,var) (%inc-ptr ,var ,by))))))
1367
1368(defmacro with-string-from-cstring ((s ptr) &body body)
1369  (let* ((len (gensym))
1370         (p (gensym)))
1371    `(let* ((,p ,ptr)
1372            (,len (%cstrlen ,p))
1373            (,s (make-string ,len)))
1374      (declare (fixnum ,len))
1375      (%copy-ptr-to-ivector ,p 0 ,s 0 ,len)
1376      (locally
1377          ,@body))))
1378
1379
1380(defmacro with-cstr ((sym str &optional start end) &rest body &environment env)
1381  (multiple-value-bind (body decls) (parse-body body env nil)
1382    (if (and (base-string-p str) (null start) (null end))
1383      (let ((strlen (%i+ (length str) 1)))
1384        `(%stack-block ((,sym ,strlen))
1385           ,@decls
1386           (%cstr-pointer ,str ,sym)
1387           ,@body))
1388      (let ((strname (gensym))
1389            (start-name (gensym))
1390            (end-name (gensym)))
1391        `(let ((,strname ,str)
1392               ,@(if (or start end)
1393                   `((,start-name ,(or start 0))
1394                     (,end-name ,(or end `(length ,strname))))))
1395           (%vstack-block (,sym
1396                           (the fixnum
1397                             (1+
1398                              (the fixnum
1399                                ,(if (or start end)
1400                                     `(byte-length
1401                                       ,strname ,start-name ,end-name)
1402                                     `(length ,strname))))))
1403             ,@decls
1404             ,(if (or start end)
1405                `(%cstr-segment-pointer ,strname ,sym ,start-name ,end-name)
1406                `(%cstr-pointer ,strname ,sym))
1407             ,@body))))))
1408
1409
1410
1411
1412
1413(defmacro with-pointers (speclist &body body)
1414   (with-specs-aux 'with-pointer speclist body))
1415
1416
1417
1418(defmacro with-cstrs (speclist &body body)
1419   (with-specs-aux 'with-cstr speclist body))
1420
1421
1422
1423
1424
1425(defun with-specs-aux (name spec-list body)
1426  (setq body (cons 'progn body))
1427  (dolist (spec (reverse spec-list))
1428     (setq body (list name spec body)))
1429  body)
1430
1431
1432(defmacro type-predicate (type)
1433  `(get-type-predicate ,type))
1434
1435(defsetf type-predicate set-type-predicate)
1436
1437(defmacro defmethod (name &rest args &environment env)
1438  (multiple-value-bind (function-form specializers-form qualifiers lambda-list documentation specializers)
1439                       (parse-defmethod name args env)
1440   
1441    `(progn
1442       (eval-when (:compile-toplevel)
1443         (note-function-info ',name nil ,env))
1444       (compiler-let ((*nx-method-warning-name* 
1445                       (list ',name
1446                             ,@(mapcar #'(lambda (x) `',x) qualifiers)
1447                             ',specializers)))
1448         (ensure-method ',name ,specializers-form
1449                        :function ,function-form
1450                        :qualifiers ',qualifiers
1451                        :lambda-list ',lambda-list
1452                        ,@(if documentation `(:documentation ,documentation)))))))
1453
1454
1455(defun seperate-defmethod-decls (decls)
1456  (let (outer inner)
1457    (dolist (decl decls)
1458      (if (neq (car decl) 'declare)
1459        (push decl outer)
1460        (let (outer-list inner-list)
1461          (dolist (d (cdr decl))
1462            (if (and (listp d) (eq (car d) 'dynamic-extent))
1463              (let (in out)
1464                (dolist (fspec (cdr d))
1465                  (if (and (listp fspec)
1466                           (eq (car fspec) 'function)
1467                           (listp (cdr fspec))
1468                           (null (cddr fspec))
1469                           (memq (cadr fspec) '(call-next-method next-method-p)))
1470                    (push fspec in)
1471                    (push fspec out)))
1472                (when out
1473                  (push `(dynamic-extent ,@(nreverse out)) outer-list))
1474                (when in
1475                  (push `(dynamic-extent ,@(nreverse in)) inner-list)))
1476              (push d outer-list)))
1477          (when outer-list
1478            (push `(declare ,@(nreverse outer-list)) outer))
1479          (when inner-list
1480            (push `(declare ,@(nreverse inner-list)) inner)))))
1481    (values (nreverse outer) (nreverse inner))))
1482                   
1483
1484(defun parse-defmethod (name args env)
1485  (validate-function-name name)
1486  (let (qualifiers lambda-list parameters specializers specializers-form refs types temp)
1487    (until (listp (car args))
1488      (push (pop args) qualifiers))
1489    (setq lambda-list (pop args))
1490    (while (and lambda-list (not (memq (car lambda-list) lambda-list-keywords)))
1491      (let ((p (pop lambda-list)))
1492        (cond ((consp p)
1493               (unless (and (consp (%cdr p)) (null (%cddr p)))
1494                 (signal-program-error "Illegal arg ~S" p))
1495               (push (%car p) parameters)
1496               (push (%car p) refs)
1497               (setq p (%cadr p))
1498               (cond ((and (consp p) (eq (%car p) 'eql)
1499                           (consp (%cdr p)) (null (%cddr p)))
1500                      (push `(list 'eql ,(%cadr p)) specializers-form)
1501                      (push p specializers))
1502                     ((or (setq temp (non-nil-symbol-p p))
1503                          (specializer-p p))
1504                      (push `',p specializers-form)
1505                      (push p specializers)
1506                      (unless (or (eq p t) (not temp))
1507                        ;Should be `(guaranteed-type ...).
1508                        (push `(type ,p ,(%car parameters)) types)))
1509                     (t (signal-program-error "Illegal arg ~S" p))))
1510              (t
1511               (push p parameters)
1512               (push t specializers-form)
1513               (push t specializers)))))
1514    (setq lambda-list (nreconc parameters lambda-list))
1515    (multiple-value-bind (body decls doc) (parse-body args env t)
1516      (multiple-value-bind (outer-decls inner-decls) 
1517                           (seperate-defmethod-decls decls)
1518        (let* ((methvar (make-symbol "NEXT-METHOD-CONTEXT"))
1519               (cnm-args (gensym))
1520               (lambda-form `(lambda ,(list* '&method methvar lambda-list)
1521                               (declare ;,@types
1522                                (ignorable ,@refs))
1523                               ,@outer-decls
1524                               (block ,(if (consp name) (cadr name) name)
1525                                 (flet ((call-next-method (&rest ,cnm-args)
1526                                          (declare (dynamic-extent ,cnm-args))
1527                                          (if ,cnm-args
1528                                            (apply #'%call-next-method-with-args ,methvar ,cnm-args)
1529                                            (%call-next-method ,methvar)))
1530                                        (next-method-p () (%next-method-p ,methvar)))
1531                                   (declare (inline call-next-method next-method-p))
1532                                   ,@inner-decls
1533                                   ,@body)))))
1534          (values
1535           (if name `(nfunction ,name ,lambda-form) `(function ,lambda-form))
1536           `(list ,@(nreverse specializers-form))
1537           (nreverse qualifiers)
1538           lambda-list
1539           doc
1540           (nreverse specializers)))))))
1541
1542(defmacro anonymous-method (name &rest args &environment env)
1543  (multiple-value-bind (function-form specializers-form qualifiers method-class documentation)
1544                       (parse-defmethod name args env)
1545   
1546    `(%anonymous-method
1547      ,function-form
1548      ,specializers-form
1549      ',qualifiers
1550      ,@(if (or method-class documentation) `(',method-class))
1551      ,@(if documentation `(,documentation)))))
1552
1553
1554
1555(defmacro defclass (class-name superclasses slots &rest class-options &environment env)
1556  (flet ((duplicate-options (where) (signal-program-error "Duplicate options in ~S" where))
1557         (illegal-option (option) (signal-program-error "Illegal option ~s" option))
1558         (make-initfunction (form)
1559           (cond ((or (eq form 't)
1560                      (equal form ''t))
1561                  '(function true))
1562                 ((or (eq form 'nil)
1563                      (equal form ''nil))
1564                  '(function false))
1565                 (t
1566                  `(function (lambda () ,form))))))
1567    (setq class-name (require-type class-name '(and symbol (not null))))
1568    (setq superclasses (mapcar #'(lambda (s) (require-type s 'symbol)) superclasses))
1569    (let* ((options-seen ())
1570           (signatures ())
1571           (slot-names))
1572      (flet ((canonicalize-defclass-option (option)
1573               (let* ((option-name (car option)))
1574                 (if (member option-name options-seen :test #'eq)
1575                   (duplicate-options class-options)
1576                   (push option-name options-seen))
1577                 (case option-name
1578                   (:default-initargs
1579                       (let ((canonical ()))
1580                         (let (key val (tail (cdr option)))
1581                           (loop (when (null tail) (return nil))
1582                               (setq key (pop tail)
1583                                     val (pop tail))
1584                             (push ``(,',key ,',val  ,,(make-initfunction val)) canonical))
1585                           `(':direct-default-initargs (list ,@(nreverse canonical))))))
1586                   (:metaclass
1587                    (unless (and (cadr option)
1588                                 (typep (cadr option) 'symbol))
1589                      (illegal-option option))
1590                    `(:metaclass (find-class ',(cadr option))))
1591                   (t
1592                    (list `',option-name `',(cdr option))))))
1593             (canonicalize-slot-spec (slot)
1594               (if (null slot) (signal-program-error "Illegal slot NIL"))
1595               (if (not (listp slot)) (setq slot (list slot)))
1596               (let* ((slot-name (require-type (car slot) 'symbol))
1597                      (initargs nil)
1598                      (other-options ())
1599                      (initform nil)
1600                      (initform-p nil)
1601                      (initfunction nil)
1602                      (type nil)
1603                      (type-p nil)
1604                      (allocation nil)
1605                      (allocation-p nil)
1606                      (documentation nil)
1607                      (documentation-p nil)
1608                      (readers nil)
1609                      (writers nil))
1610                 (when (memq slot-name slot-names)
1611                   (SIGNAL-PROGRAM-error "Duplicate slot name ~S" slot-name))
1612                 (push slot-name slot-names)
1613                 (do ((options (cdr slot) (cddr options))
1614                      name)
1615                     ((null options))
1616                   (when (null (cdr options)) (signal-program-error "Illegal slot spec ~S" slot))
1617                   (case (car options)
1618                     (:reader
1619                      (setq name (cadr options))
1620                      (push name signatures)
1621                      (push name readers))
1622                     (:writer                     
1623                      (setq name (cadr options))
1624                      (push name signatures)
1625                      (push name writers))
1626                     (:accessor
1627                      (setq name (cadr options))
1628                      (push name signatures)
1629                      (push name readers)
1630                      (push `(setf ,name) signatures)
1631                      (push `(setf ,name) writers))
1632                     (:initarg
1633                      (push (require-type (cadr options) 'symbol) initargs))
1634                     (:type
1635                      (if type-p
1636                        (duplicate-options slot)
1637                        (setq type-p t))
1638                      ;(when (null (cadr options)) (signal-program-error "Illegal options ~S" options))
1639                      (setq type (cadr options)))
1640                     (:initform
1641                      (if initform-p
1642                        (duplicate-options slot)
1643                        (setq initform-p t))
1644                      (let ((option (cadr options)))
1645                        (setq initform `',option
1646                              initfunction
1647                              (if (constantp option)
1648                                `(constantly ,option)
1649                                `#'(lambda () ,option)))))
1650                     (:allocation
1651                      (if allocation-p
1652                        (duplicate-options slot)
1653                        (setq allocation-p t))
1654                      (setq allocation (cadr options)))
1655                     (:documentation
1656                      (if documentation-p
1657                        (duplicate-options slot)
1658                        (setq documentation-p t))
1659                      (setq documentation (require-type (cadr options) 'string)))
1660                     (t
1661                      (let* ((pair (or (assq (car options) other-options)
1662                                       (car (push (list (car options)) other-options)))))
1663                        (push (cadr options) (cdr pair))))))
1664                 `(list :name ',slot-name
1665                   ,@(when allocation `(:allocation ',allocation))
1666                   ,@(when initform-p `(:initform ,initform
1667                                        :initfunction ,initfunction))
1668                   ,@(when initargs `(:initargs ',initargs))
1669                   ,@(when readers `(:readers ',readers))
1670                   ,@(when writers `(:writers ',writers))
1671                   ,@(when type-p `(:type ',type))
1672                   ,@(when documentation `(:documentation ,documentation))
1673                   ,@(mapcan #'(lambda (opt)
1674                                 `(',(car opt) ',(cdr opt))) other-options)))))
1675        (let* ((direct-superclasses (or superclasses '(standard-object)))
1676               (direct-slot-specs (mapcar #'canonicalize-slot-spec slots))
1677               (other-options (apply #'append (mapcar #'canonicalize-defclass-option class-options ))))
1678          `(progn
1679            (eval-when (:compile-toplevel)
1680              (%compile-time-defclass ',class-name ,env)
1681              (progn
1682                ,@(mapcar #'(lambda (s) `(note-function-info ',s nil ,env))
1683                          signatures)))
1684              (ensure-class-for-defclass ',class-name
1685                            :direct-superclasses ',direct-superclasses
1686                            :direct-slots ,`(list ,@direct-slot-specs)
1687                            ,@other-options)))))))
1688
1689(defmacro define-method-combination (name &rest rest &environment env)
1690  (setq name (require-type name 'symbol))
1691  (cond ((or (null rest) (and (car rest) (symbolp (car rest))))
1692         `(short-form-define-method-combination ',name ',rest))
1693        ((listp (car rest))
1694         (destructuring-bind (lambda-list method-group-specifiers . forms) rest
1695           (long-form-define-method-combination 
1696            name lambda-list method-group-specifiers forms env)))
1697        (t (%badarg (car rest) '(or (and null symbol) list)))))
1698
1699(defmacro defgeneric (function-name lambda-list &rest options-and-methods &environment env)
1700  (fboundp function-name)             ; type-check
1701  (multiple-value-bind (method-combination generic-function-class options methods)
1702                       (parse-defgeneric function-name t lambda-list options-and-methods)
1703    (let ((gf (gensym)))
1704      `(progn
1705         (eval-when (:compile-toplevel)
1706           (note-function-info ',function-name nil ,env))
1707         (let ((,gf (%defgeneric
1708                     ',function-name ',lambda-list ',method-combination ',generic-function-class 
1709                     ',(apply #'append options))))
1710           (%set-defgeneric-methods ,gf ,@methods)
1711           ,gf)))))
1712
1713
1714
1715(defun parse-defgeneric (function-name global-p lambda-list options-and-methods)
1716  (check-generic-function-lambda-list lambda-list)
1717  (let ((method-combination '(standard))
1718        (generic-function-class 'standard-generic-function)
1719        options declarations methods option-keywords method-class)
1720    (flet ((bad-option (o)
1721             (signal-program-error "Bad option: ~s to ~s." o 'defgeneric)))
1722      (dolist (o options-and-methods)
1723        (let ((keyword (car o))
1724              (defmethod (if global-p 'defmethod 'anonymous-method)))
1725          (if (eq keyword :method)
1726            (push `(,defmethod ,function-name ,@(%cdr o)) methods)
1727            (cond ((and (not (eq keyword 'declare))
1728                        (memq keyword (prog1 option-keywords (push keyword option-keywords))))             
1729                   (signal-program-error "Duplicate option: ~s to ~s" keyword 'defgeneric))
1730                  ((eq keyword :method-name)    ; used by generic-flet
1731                   (if function-name (bad-option o))
1732                   (setq function-name (cadr o)))
1733                  ((eq keyword :method-combination)
1734                   (unless (symbolp (cadr o))
1735                     (bad-option o))
1736                   (setq method-combination (cdr o)))
1737                  ((eq keyword :generic-function-class)
1738                   (unless (and (cdr o) (symbolp (cadr o)) (null (%cddr o)))
1739                     (bad-option o))
1740                   (setq generic-function-class (%cadr o)))
1741                  ((eq keyword 'declare)
1742                   (push (cadr o) declarations))
1743                  ((eq keyword :argument-precedence-order)
1744                   (dolist (arg (cdr o))
1745                     (unless (and (symbolp arg) (memq arg lambda-list))
1746                       (bad-option o)))
1747                   (push (list keyword (cdr o)) options))
1748                  ((eq keyword :method-class)
1749                   (push o options)
1750                   (when (or (cddr o) (not (symbolp (setq method-class (%cadr o)))))
1751                     (bad-option o)))
1752                  ((eq keyword :documentation)
1753                   (push o options)
1754                   (when (or (cddr o) (not (stringp (%cadr o))))
1755                     (bad-option o)))
1756                  (t (bad-option o)))))))
1757    (when method-class
1758      (dolist (m methods)
1759        (push `(:method-class ,method-class) (cddr m))))
1760    (when declarations
1761      (setq options `((:declarations ,declarations) ,@options)))
1762    (values method-combination generic-function-class options methods)))
1763
1764                 
1765(defmacro def-aux-init-functions (class &rest functions)
1766  `(set-aux-init-functions ',class (list ,@functions)))
1767
1768
1769
1770
1771
1772
1773; A powerful way of defining REPORT-CONDITION...
1774; Do they really expect that each condition type has a unique method on PRINT-OBJECT
1775; which tests *print-escape* ?  Scary if so ...
1776
1777(defmacro define-condition (name (&rest supers) &optional ((&rest slots)) &body options)
1778  ; If we could tell what environment we're being expanded in, we'd
1779  ; probably want to check to ensure that all supers name conditions
1780  ; in that environment.
1781  (let ((classopts nil)
1782        (duplicate nil)
1783        (docp nil)
1784        (default-initargs-p nil)
1785        (reporter nil))
1786    (dolist (option options)
1787      (unless (and (consp option)
1788                   (consp (%cdr option)))
1789        (error "Invalid option ~s ." option))
1790      (ecase (%car option)
1791        (:default-initargs 
1792            (unless (plistp (cdr option)) 
1793              (signal-program-error "~S is not a plist." (%cdr option))) 
1794            (if default-initargs-p 
1795              (setq duplicate t) 
1796              (push (setq default-initargs-p option) classopts))) 
1797        (:documentation 
1798         (unless (null (%cddr option)) 
1799           (error "Invalid option ~s ." option)) 
1800         (if docp
1801           (setq duplicate t)
1802           (push (setq docp option) classopts)))
1803        (:report 
1804         (unless (null (%cddr option)) 
1805           (error "Invalid option ~s ." option)) 
1806         (if reporter
1807           (setq duplicate t)
1808           (progn
1809             (if (or (lambda-expression-p (setq reporter (%cadr option)))
1810                     (symbolp reporter))
1811               (setq reporter `(function ,reporter))
1812               (if (stringp reporter)
1813                 (setq reporter `(function (lambda (c s) (declare (ignore c)) (write-string ,reporter s))))
1814                 (error "~a expression is not a string, symbol, or lambda expression ." (%car option))))
1815             (setq reporter `((defmethod report-condition ((c ,name) s)
1816                                (funcall ,reporter c s))))))))
1817      (if duplicate (error "Duplicate option ~s ." option)))
1818    `(progn
1819       (defclass ,name ,(or supers '(condition)) ,slots ,@classopts)
1820       ,@reporter
1821       ',name)))
1822
1823(defmacro with-condition-restarts (&environment env condition restarts &body body)
1824  (multiple-value-bind (body decls)
1825                       (parse-body body env)
1826    (let ((cond (gensym))
1827          (r (gensym)))
1828          `(let* ((*condition-restarts* *condition-restarts*))
1829             ,@decls
1830             (let ((,cond ,condition))
1831               (dolist (,r ,restarts) (push (cons ,r ,cond) *condition-restarts*))
1832               ,@body)))))
1833 
1834(defmacro setf-find-class (name arg1 &optional (arg2 () 2-p) (arg3 () 3-p))
1835  (cond (3-p ;might want to pass env (arg2) to find-class someday?
1836         `(set-find-class ,name (progn ,arg1 ,arg2 ,arg3)))
1837        (2-p
1838         `(set-find-class ,name (progn ,arg1 ,arg2)))
1839        (t `(set-find-class ,name ,arg1))))
1840
1841(defsetf find-class setf-find-class)
1842
1843(defmacro restoring-interrupt-level (var &body body)
1844  `(unwind-protect
1845    (progn ,@body)
1846    (restore-interrupt-level ,var)
1847    (%interrupt-poll)))
1848
1849(defmacro without-interrupts (&body body)
1850  (let* ((level (gensym)))
1851    `(let* ((,level (disable-lisp-interrupts)))
1852      (restoring-interrupt-level ,level ,@body))))
1853
1854
1855;; undoes the effect of one enclosing without-interrupts during execution of body.
1856(defmacro ignoring-without-interrupts (&body body)
1857  (let* ((level (gensym)))
1858    `(let ((,level (interrupt-level)))
1859       (unwind-protect
1860            (progn
1861              (setf (interrupt-level) 0)
1862              ,@body)
1863         (setf (interrupt-level) ,level)))))
1864
1865(defmacro error-ignoring-without-interrupts (format-string &rest format-args)
1866  `(ignoring-without-interrupts
1867    (error ,format-string ,@format-args)))
1868
1869
1870;init-list-default: if there is no init pair for <keyword>,
1871;    add a <keyword> <value> pair to init-list
1872(defmacro init-list-default (the-init-list &rest args)
1873  (let ((result)
1874       (init-list-sym (gensym)))
1875   (do ((args args (cddr args)))
1876       ((not args))
1877     (setq result 
1878           (cons `(if (eq '%novalue (getf ,init-list-sym ,(car args) 
1879                                          '%novalue))
1880                    (setq ,init-list-sym (cons ,(car args) 
1881                                               (cons ,(cadr args) 
1882                                                     ,init-list-sym))))
1883                 result)))                                                                               
1884   `(let ((,init-list-sym ,the-init-list))
1885      (progn ,@result)
1886      ,init-list-sym)
1887   ))
1888
1889; This can only be partially backward-compatible: even if only
1890; the "name" arg is supplied, the old function would create the
1891; package if it didn't exist.
1892; Should see how well this works & maybe flush the whole idea.
1893
1894(defmacro in-package (&whole call name &rest gratuitous-backward-compatibility)
1895  (let ((form nil))
1896    (cond (gratuitous-backward-compatibility
1897           (cerror "Macroexpand into a call to the old IN-PACKAGE function."
1898                   "Macro call ~S contains extra arguments." call )
1899           (setq form `(ccl::old-in-package ,name ,@gratuitous-backward-compatibility)))
1900        (t
1901         (when (quoted-form-p name)
1902           (warn "Unquoting argument ~S to ~S." name 'in-package )
1903           (setq name (cadr name)))   
1904         (setq form `(set-package ,(string name)))))
1905         `(eval-when (:execute :load-toplevel :compile-toplevel)
1906            ,form)))
1907
1908(defmacro defpackage (name &rest options)
1909  (let* ((size nil)
1910         (all-names-size 0)
1911         (intern-export-size 0)
1912         (shadow-etc-size 0)
1913         (documentation nil)
1914         (all-names-hash (let ((all-options-alist nil))
1915                           (dolist (option options)
1916                             (let ((option-name (car option)))
1917                               (when (memq option-name
1918                                           '(:nicknames :shadow :shadowing-import-from
1919                                             :use :import-from :intern :export))
1920                                 (let ((option-size (length (cdr option)))
1921                                       (cell (assq option-name all-options-alist)))
1922                                   (declare (fixnum option-size))
1923                                   (if cell
1924                                     (incf (cdr cell) option-size)
1925                                     (push (cons option-name option-size) all-options-alist))
1926                                   (when (memq option-name '(:shadow :shadowing-import-from :import-from :intern))
1927                                     (incf shadow-etc-size option-size))
1928                                   (when (memq option-name '(:export :intern))
1929                                     (incf intern-export-size option-size))))))
1930                           (dolist (cell all-options-alist)
1931                             (let ((option-size (cdr cell)))
1932                               (when (> option-size all-names-size)
1933                                 (setq all-names-size option-size))))
1934                           (when (> all-names-size 0)
1935                             (make-hash-table :test 'equal :size all-names-size))))
1936         (intern-export-hash (when (> intern-export-size 0)
1937                               (make-hash-table :test 'equal :size intern-export-size)))
1938         (shadow-etc-hash (when (> shadow-etc-size 0)
1939                            (make-hash-table :test 'equal :size shadow-etc-size)))
1940         (external-size nil)
1941         (nicknames nil)
1942         (shadow nil)
1943         (shadowing-import-from-specs nil)
1944         (use :default)
1945         (import-from-specs nil)
1946         (intern nil)
1947         (export nil))
1948    (declare (fixnum all-names-size intern-export-size shadow-etc-size))
1949    (labels ((string-or-name (s) (string s))
1950             (duplicate-option (o)
1951               (signal-program-error "Duplicate ~S option in ~S ." o options))
1952             (duplicate-name (name option-name)
1953               (signal-program-error "Name ~s, used in ~s option, is already used in a conflicting option ." name option-name))
1954             (all-names (option-name tail already)
1955               (when (eq already :default) (setq already nil))
1956               (when all-names-hash
1957                 (clrhash all-names-hash))
1958               (dolist (name already)
1959                 (setf (gethash (string-or-name name) all-names-hash) t))
1960               (dolist (name tail already)
1961                 (setq name (string-or-name name))
1962                 (unless (gethash name all-names-hash)          ; Ok to repeat name in same option.
1963                   (when (memq option-name '(:shadow :shadowing-import-from :import-from :intern))
1964                     (if (gethash name shadow-etc-hash)
1965                       (duplicate-name name option-name))
1966                     (setf (gethash name shadow-etc-hash) t))
1967                   (when (memq option-name '(:export :intern))
1968                     (if (gethash name intern-export-hash)
1969                       (duplicate-name name option-name))
1970                     (setf (gethash name intern-export-hash) t))
1971                   (setf (gethash name all-names-hash) t)
1972                   (push name already)))))
1973      (dolist (option options)
1974        (let ((args (cdr option)))
1975          (ecase (%car option)
1976                 (:size 
1977                  (if size 
1978                    (duplicate-option :size) 
1979                    (setq size (car args))))             
1980                 (:external-size 
1981                  (if external-size 
1982                    (duplicate-option :external-size) 
1983                    (setq external-size (car args))))
1984                 (:nicknames (setq nicknames (all-names nil args nicknames)))
1985                 (:shadow (setq shadow (all-names :shadow args shadow)))
1986                 (:shadowing-import-from
1987                  (destructuring-bind (from &rest shadowing-imports) args
1988                    (push (cons (string-or-name from)
1989                                (all-names :shadowing-import-from shadowing-imports nil))
1990                          shadowing-import-from-specs)))
1991                 (:use (setq use (all-names nil args use)))
1992                 (:import-from
1993                  (destructuring-bind (from &rest imports) args
1994                    (push (cons (string-or-name from)
1995                                (all-names :import-from imports nil))
1996                          import-from-specs)))
1997                 (:intern (setq intern (all-names :intern args intern)))
1998                 (:export (setq export (all-names :export args export)))
1999                 (:documentation
2000                  (if documentation
2001                    (duplicate-option :documentation)
2002                    (setq documentation (cadr option)))))))
2003      `(eval-when (:execute :compile-toplevel :load-toplevel)
2004         (%define-package ',(string-or-name name)
2005          ',size 
2006          ',external-size 
2007          ',nicknames
2008          ',shadow
2009          ',shadowing-import-from-specs
2010          ',use
2011          ',import-from-specs
2012          ',intern
2013          ',export
2014          ',documentation)))))
2015
2016
2017(defmacro %cons-pkg-iter (pkgs types)
2018  `(vector ,pkgs ,types #'%start-with-package-iterator
2019           nil nil nil nil))
2020
2021(defmacro with-package-iterator ((mname package-list first-type &rest other-types)
2022                                 &body body)
2023  (setq mname (require-type mname 'symbol))
2024  (let ((state (make-symbol "WITH-PACKAGE-ITERATOR_STATE"))
2025        (types 0))
2026    (declare (fixnum types))
2027    (dolist (type (push first-type other-types))
2028      (case type
2029        (:external (setq types (bitset $pkg-iter-external types)))
2030        (:internal (setq types (bitset $pkg-iter-internal types)))
2031        (:inherited (setq types (bitset $pkg-iter-inherited types)))
2032        (t (%badarg type '(member :internal :external :inherited)))))
2033    `(let ((,state (%cons-pkg-iter ,package-list ',types)))
2034       (declare (dynamic-extent ,state))
2035       (macrolet ((,mname () `(funcall (%svref ,',state #.pkg-iter.state) ,',state)))
2036         ,@body))))
2037
2038; Does NOT evaluate the constructor, but DOES evaluate the destructor & initializer
2039(defmacro defresource (name &key constructor destructor initializer)
2040  `(defparameter ,name (make-resource #'(lambda () ,constructor)
2041                                      ,@(when destructor
2042                                          `(:destructor ,destructor))
2043                                      ,@(when initializer
2044                                          `(:initializer ,initializer)))))
2045
2046(defmacro using-resource ((var resource) &body body)
2047  (let ((resource-var (gensym)))
2048  `(let ((,resource-var ,resource)
2049         ,var)
2050     (unwind-protect
2051       (progn
2052         (setq ,var (allocate-resource ,resource-var))
2053         ,@body)
2054       (when ,var
2055         (free-resource ,resource-var ,var))))))
2056
2057(defmacro with-lock-grabbed ((lock &optional
2058                                   (whostate "Lock"))
2059                             &body body)
2060  (declare (ignore whostate))
2061  `(with-recursive-lock (,lock) ,@body))
2062
2063(defmacro with-lock-grabbed-maybe ((lock &optional
2064                                         (whostate "Lock"))
2065                                   &body body)
2066  (declare (ignore whostate))
2067  `(with-recursive-lock-maybe (,lock) ,@body))
2068
2069(defmacro with-standard-abort-handling (abort-message &body body)
2070  (let ((stream (gensym)))
2071    `(restart-case
2072       (catch :abort
2073         (catch-cancel
2074           ,@body))
2075       (abort () ,@(when abort-message
2076                     `(:report (lambda (,stream)
2077                                 (write-string ,abort-message ,stream)))))
2078       (abort-break ()))))
2079       
2080
2081
2082
2083(defmacro %lexpr-count (l)
2084  `(%lisp-word-ref ,l 0))
2085
2086(defmacro %lexpr-ref (lexpr count i)
2087  `(%lisp-word-ref ,lexpr (%i- ,count ,i)))
2088
2089; args will be list if old style clos
2090(defmacro apply-with-method-context (magic function args)
2091  (let ((m (gensym))
2092        (f (gensym))
2093        (as (gensym)))
2094      `((lambda (,m ,f ,as)
2095          (if (listp ,as)
2096            (%apply-with-method-context ,m ,f ,as)
2097            (%apply-lexpr-with-method-context ,m ,f ,as))) ,magic ,function ,args)))
2098
2099(defmacro defcallback (name arglist &body body &environment env)
2100  (define-callback name arglist body env))
2101
2102(defmacro %get-single-float-from-double-ptr (ptr offset)
2103  `(%double-float->short-float (%get-double-float ,ptr ,offset)))
2104
2105(defun define-callback (name args body env)
2106  (let* ((stack-word (gensym))
2107         (stack-ptr (gensym))
2108         (arg-names ())
2109         (arg-types ())
2110         (return-type :void)
2111         (args args)
2112         (woi nil)
2113         (monitor nil)
2114         (dynamic-extent-names ())
2115         (error-return nil))
2116    (loop
2117      (when (null args) (return))
2118      (when (null (cdr args))
2119        (setq return-type (car args))
2120        (return))
2121      (if (eq (car args) :without-interrupts)
2122        (setq woi (cadr args) args (cddr args))
2123        (if (eq (car args) :monitor-exception-ports)
2124          (setq monitor (cadr args) args (cddr args))
2125          (if (eq (car args) :error-return)
2126            (setq error-return
2127                  #+poweropen-target (cadr args)
2128                  #-poweropen-target (warn "~s not yet implemented on this platform"
2129                                           :error-return)
2130                  args (cddr args))
2131            (progn
2132              (push (foreign-type-to-representation-type (pop args)) arg-types)
2133              (push (pop args) arg-names))))))
2134    (setq arg-names (nreverse arg-names)
2135          arg-types (nreverse arg-types))
2136    (setq return-type (foreign-type-to-representation-type return-type))
2137    (when (eq return-type :void)
2138      (setq return-type nil))
2139    (let* ((offset #+poweropen-target 0 #+eabi-target 96)
2140           #+eabi-target (gpr 0)
2141           #+eabi-target (fpr 32)
2142           (need-stack-pointer (or arg-names return-type error-return))
2143           (lets
2144             (mapcar
2145              #+poweropen-target
2146              #'(lambda (name type)
2147                  (let* ((delta 4)
2148                         (bias 0))
2149                    (prog1
2150                        (list name
2151                              `(,
2152                                (if (typep type 'unsigned-byte)
2153                                  (progn (setq delta (* 4 type)) '%inc-ptr)
2154                                  (ecase type
2155                                    (:single-float '%get-single-float)
2156                                    (:double-float (setq delta 8)'%get-double-float)
2157                                    (:signed-doubleword (setq delta 8) '%%get-signed-longlong)
2158                                    (:signed-fullword '%get-signed-long)
2159                                    (:signed-halfword (setq bias 2) '%get-signed-word)
2160                                    (:signed-byte (setq bias 3) '%get-signed-byte)
2161                                    (:unsigned-doubleword (setq delta 8) '%%get-unsigned-longlong)
2162                                    (:unsigned-fullword '%get-unsigned-long)
2163                                    (:unsigned-halfword (setq bias 2) '%get-unsigned-word)
2164                                    (:unsigned-byte (setq bias 3) '%get-unsigned-byte)
2165                                    (:address '%get-ptr)))
2166                                ,stack-ptr
2167                                (+ ,offset ,bias)))
2168                      (when (or (eq type :address)
2169                                (typep type 'unsigned-byte))
2170                        (push name dynamic-extent-names))
2171                      (incf offset delta))))
2172              #+eabi-target
2173              #'(lambda (name type)
2174                  (let* ((nextgpr gpr)
2175                         (nextfpr fpr)
2176                         (nextoffset offset)
2177                         (target gpr)
2178                         (bias 0))
2179                    (prog1
2180                        (list name
2181                              `(,
2182                                (case type
2183                                  (:single-float
2184                                   (incf nextfpr 8)
2185                                   (if (< fpr 96)
2186                                     (setq target fpr)
2187                                     (setq target (+ offset (logand offset 4))
2188                                           nextoffset (+ target 8)))
2189                                   '%get-single-float-from-double-ptr)
2190                                  (:double-float
2191                                   (incf nextfpr 8)
2192                                   (if (< fpr 96)
2193                                     (setq target fpr)
2194                                     (setq target (+ offset (logand offset 4))
2195                                           nextoffset (+ target 8)))
2196                                   '%get-double-float)
2197                                  (:signed-doubleword
2198                                   (if (< gpr 56)
2199                                     (setq target (+ gpr (logand gpr 4))
2200                                           nextgpr (+ 8 target))
2201                                     (setq target (+ offset (logand offset 4))
2202                                           nextoffset (+ 8 offset)))
2203                                   '%%get-signed-longlong)
2204                                  (:unsigned-doubleword
2205                                   (if (< gpr 56)
2206                                     (setq target (+ gpr (logand gpr 4))
2207                                           nextgpr (+ 8 target))
2208                                     (setq target (+ offset (logand offset 4))
2209                                           nextoffset (+ 8 offset)))
2210                                   '%%get-unsigned-longlong)
2211                                  (t
2212                                   (incf nextgpr 4)
2213                                   (if (< gpr 64)
2214                                     (setq target gpr)
2215                                     (setq target offset nextoffset (+ offset 4)))
2216                                   (ecase type
2217                                     (:signed-fullword '%get-signed-long)
2218                                     (:signed-halfword (setq bias 2) '%get-signed-word)
2219                                     (:signed-byte (setq bias 3) '%get-signed-byte)
2220                                     (:unsigned-fullword '%get-unsigned-long)
2221                                     (:unsigned-halfword (setq bias 2) '%get-unsigned-word)
2222                                     (:unsigned-byte (setq bias 3) '%get-unsigned-byte)
2223                                     (:address '%get-ptr))))
2224                                ,stack-ptr
2225                                (+ ,target ,bias)))
2226                      (when (eq type :address)
2227                        (push name dynamic-extent-names))
2228                      (setq gpr nextgpr fpr nextfpr offset nextoffset))))
2229              arg-names arg-types)))
2230      (multiple-value-bind (body decls doc) (parse-body body env t)
2231        `(progn
2232           (declaim (special ,name))
2233           (define-callback-function
2234             (nfunction ,name
2235                        (lambda (,stack-word)
2236                          (declare (ignorable ,stack-word))
2237                          (block ,name
2238                            (with-macptrs (,@(and need-stack-pointer (list `(,stack-ptr))))
2239                              ,(when need-stack-pointer
2240                                 `(%setf-macptr-to-object ,stack-ptr ,stack-word))
2241                              ,(defcallback-body stack-ptr lets dynamic-extent-names
2242                                                 decls body return-type error-return
2243                                                 #+poweropen-target
2244                                                 (- ppc32::c-frame.savelr ppc32::c-frame.param0)
2245                                                 #-poweropen-target 0)))))
2246             ,doc
2247             ,woi
2248             ,monitor))))))
2249
2250(defun defcallback-body (stack-ptr lets dynamic-extent-names decls body return-type error-return error-delta)
2251  (let* ((result (gensym))
2252         (condition-name (if (atom error-return) 'error (car error-return)))
2253         (error-return-function (if (atom error-return) error-return (cadr error-return)))
2254         (body
2255          `(let ,lets
2256            (declare (dynamic-extent ,@dynamic-extent-names))
2257            ,@decls
2258            (let ((,result (progn ,@body)))
2259              (declare (ignorable ,result))
2260              , (when return-type
2261                  `(setf (,
2262                          (case return-type
2263                            (:address '%get-ptr)
2264                            (:signed-doubleword '%%get-signed-longlong)
2265                            (:unsigned-doubleword '%%get-unsigned-longlong)
2266                            (:double-float '%get-double-float)
2267                            (:single-float '%get-single-float)
2268                            (t '%get-long)) ,stack-ptr) ,result))))))
2269    (if error-return
2270      (let* ((cond (gensym)))
2271        `(handler-case ,body
2272          (,condition-name (,cond) (,error-return-function ,cond ,stack-ptr (%inc-ptr ,stack-ptr ,error-delta)))))
2273      body)))
2274 
2275
2276(defmacro errchk (form)
2277  (let* ((res (gensym)))
2278    `(let* ((,res ,form))
2279       (if (eql 0 ,res)
2280         0
2281         (signal-posix-error ,res)))))
2282
2283(defmacro define-toplevel-command (group-name name arglist &body body &environment env)
2284  (let* ((key (make-keyword name)))
2285    (multiple-value-bind (body decls doc) (parse-body body env)
2286      `(%define-toplevel-command ',group-name ,key ',name 
2287        (nfunction ,name (lambda ,arglist
2288                           ,@decls
2289                           (block ,name
2290                             ,@body)))
2291        ,doc
2292        ',(mapcar #'symbol-name arglist)))))
2293
2294(defmacro with-toplevel-commands (group-name &body body)
2295  `(let* ((*active-toplevel-commands* *active-toplevel-commands*))
2296    (progn
2297      (%use-toplevel-commands ',group-name)
2298      ,@body)))
2299
2300(defmacro assert (test-form &optional (places ()) string &rest args)
2301  "ASSERT Test-Form [(Place*) [String Arg*]]
2302  If the Test-Form is not true, then signal a correctable error.  If Places
2303  are specified, then new values are prompted for when the error is proceeded.
2304  String and Args are the format string and args to the error call."
2305  (let* ((TOP (gensym))
2306         (setf-places-p (not (null places))))
2307    `(tagbody
2308       ,TOP
2309       (unless ,test-form
2310         (%assertion-failure ,setf-places-p ',test-form ,string ,@args)
2311         ,@(if places
2312             `((write-line "Type expressions to set places to, or nothing to leave them alone."
2313                           *query-io*)
2314               ,@(mapcar #'(lambda (place &aux (new-val (gensym))
2315                                          (set-p (gensym)))
2316                             `(multiple-value-bind
2317                                (,new-val ,set-p)
2318                                (assertion-value-prompt ',place)
2319                                (when ,set-p (setf ,place (values-list ,new-val)))))
2320                         places)))
2321         (go ,TOP)))))
2322
2323
2324(defmacro check-type (place typespec &optional string)
2325  "CHECK-TYPE Place Typespec [String]
2326  Signal a correctable error if Place does not hold an object of the type
2327  specified by Typespec."
2328  `(progn
2329     (setf ,place 
2330           (ensure-value-of-type 
2331            ,place 
2332            ',typespec 
2333            ',place 
2334            ,(if string string (list 'quote typespec))))
2335     nil))
2336
2337(defmacro with-hash-table-iterator ((mname hash-table) &body body &environment env)
2338  (let ((state (gensym)))
2339    (multiple-value-bind (body decls) (parse-body body env)
2340      `(let ((,state (vector nil nil ,hash-table nil nil)))
2341        (declare (dynamic-extent ,state))
2342        (unwind-protect
2343             (macrolet ((,mname () `(do-hash-table-iteration ,',state)))
2344               (start-hash-table-iterator ,state)
2345               (locally ,@decls ,@body))
2346          (finish-hash-table-iterator ,state))))))
2347
2348(eval-when (compile load eval)
2349(defmacro pprint-logical-block ((stream-symbol list
2350                                 &key (prefix nil) (per-line-prefix nil)
2351                                      (suffix ""))
2352                                &body body)
2353  (cond ((eq stream-symbol nil) (setq stream-symbol '*standard-output*))
2354        ((eq stream-symbol T) (setq stream-symbol '*terminal-io*)))
2355  (when (not (symbolp stream-symbol))
2356    (warn "STREAM-SYMBOL arg ~S to PPRINT-LOGICAL-BLOCK is not a bindable symbol"
2357          stream-symbol)
2358    (setq stream-symbol '*standard-output*))
2359  (when (and prefix per-line-prefix)
2360    (warn "prefix ~S and per-line-prefix ~S cannot both be specified ~
2361           in PPRINT-LOGICAL-BLOCK")
2362    (setq per-line-prefix nil))
2363  `(maybe-initiate-xp-printing
2364     #'(lambda (,stream-symbol)
2365         (let ((+l ,list)
2366               (+p ,(or prefix per-line-prefix ""))
2367               (+s ,suffix))
2368           (pprint-logical-block+
2369             (,stream-symbol +l +p +s ,(not (null per-line-prefix)) T nil)
2370             ,@ body nil)))
2371     (decode-stream-arg ,stream-symbol)))
2372
2373
2374;Assumes var and args must be variables.  Other arguments must be literals or variables.
2375
2376(defmacro pprint-logical-block+ ((var args prefix suffix per-line? circle-check? atsign?)
2377                                 &body body)
2378  (when (and circle-check? atsign?)
2379    (setq circle-check? 'not-first-p))
2380  `(let ((*current-level* (1+ *current-level*))
2381         (*current-length* -1)
2382         ;(*parents* *parents*)
2383         ,@(if (and circle-check? atsign?) `((not-first-p (plusp *current-length*)))))
2384     (unless (check-block-abbreviation ,var ,args ,circle-check?)
2385       (start-block ,var ,prefix ,per-line? ,suffix)
2386       (when
2387         (catch 'line-limit-abbreviation-exit
2388           (block logical-block
2389             (macrolet ((pprint-pop () `(pprint-pop+ ,',args ,',var))
2390                        (pprint-exit-if-list-exhausted ()
2391                          `(if (null ,',args) (return-from logical-block nil))))
2392               ,@ body))
2393           (end-block ,var ,suffix)
2394           nil)
2395         (end-block ,var ,suffix)
2396         (throw 'line-limit-abbreviation-exit T)))))
2397) ; eval-when
2398
2399(defmacro %old-class-local-shared-slotds (class &optional default)
2400  (if default                           ; so setf works
2401    `(%class-get ,class '%old-class-local-shared-slotds ,default)
2402    `(%class-get ,class '%old-class-local-shared-slotds)))
2403
2404(defmacro with-slot-values (slot-entries instance-form &body body)
2405; Simplified form of with-slots.  Expands into a let instead of a symbol-macrolet
2406; Thus, you can access the slot values, but you can't setq them.
2407  (let ((instance (gensym)) var slot-name bindings)
2408    (dolist (slot-entry slot-entries)
2409      (cond ((symbolp slot-entry)
2410             (setq var slot-entry slot-name slot-entry))
2411            ((and (listp slot-entry) (cdr slot-entry) (null (cddr slot-entry))
2412                  (symbolp (car slot-entry)) (symbolp (cadr slot-entry)))
2413             (setq var (car slot-entry) slot-name (cadr slot-entry)))
2414            (t (error "Malformed slot-entry: ~a to with-slot-values.~@
2415                       Should be a symbol or a list of two symbols."
2416                      slot-entry)))
2417      (push `(,var (slot-value ,instance ',slot-name)) bindings))
2418    `(let ((,instance ,instance-form))
2419       (let ,(nreverse bindings)
2420         ,@body))))
2421
2422(defmacro with-slots (slot-entries instance-form &body body)
2423  (let ((instance (gensym)) var slot-name bindings)
2424    (dolist (slot-entry slot-entries)
2425      (cond ((symbolp slot-entry)
2426             (setq var slot-entry slot-name slot-entry))
2427            ((and (listp slot-entry) (cdr slot-entry) (null (cddr slot-entry))
2428                  (symbolp (car slot-entry)) (symbolp (cadr slot-entry)))
2429             (setq var (car slot-entry) slot-name (cadr slot-entry)))
2430            (t (error "Malformed slot-entry: ~a to with-slots.~@
2431                       Should be a symbol or a list of two symbols."
2432                      slot-entry)))
2433      (push `(,var (slot-value ,instance ',slot-name)) bindings))
2434    `(let ((,instance ,instance-form))
2435       ,@(unless bindings (list `(declare (ignore ,instance))))
2436       (symbol-macrolet ,(nreverse bindings)
2437         ,@body))))
2438
2439(defmacro with-accessors (slot-entries instance-form &body body)
2440  (let ((instance (gensym)) var reader bindings)
2441    (dolist (slot-entry slot-entries)
2442      (cond ((and (listp slot-entry) (cdr slot-entry) (null (cddr slot-entry))
2443                  (symbolp (car slot-entry)) (symbolp (cadr slot-entry)))
2444             (setq var (car slot-entry) reader (cadr slot-entry)))
2445            (t (error "Malformed slot-entry: ~a to with-accessors.~@
2446                       Should be a list of two symbols."
2447                      slot-entry)))
2448      (push `(,var (,reader ,instance)) bindings))
2449    `(let ((,instance ,instance-form))
2450       ,@(unless bindings (list `(declare (ignore ,instance))))
2451       (symbol-macrolet ,(nreverse bindings)
2452         ,@body))))
2453
2454; I wanted to call this ":method"
2455(defmacro reference-method (gf &rest qualifiers-and-specializers)
2456  (let ((qualifiers (butlast qualifiers-and-specializers))
2457        (specializers (car (last qualifiers-and-specializers))))
2458    (if (null specializers) (report-bad-arg qualifiers-and-specializers '(not null)))
2459    `(find-method #',gf ',qualifiers (mapcar #'find-specializer ',specializers))))
2460
2461(defmacro time (form)
2462  `(report-time ',form #'(lambda () (progn ,form))))
2463
2464(defmacro with-error-reentry-detection (&body body)
2465  (let ((thunk (gensym)))
2466    `(let ((,thunk #'(lambda () ,@body)))
2467       (declare (dynamic-extent ,thunk))
2468       (funcall-with-error-reentry-detection ,thunk))))
2469
2470(defmacro scan-for-instr (mask opcode fn pc-index &optional (tries *trap-lookup-tries*))
2471  `(%scan-for-instr ,mask ,opcode ,fn ,pc-index ,tries))
2472
2473(defmacro codevec-header-p (word)
2474  `(eql ppc32::subtag-code-vector
2475    (logand ,word ppc32::subtag-mask)))
2476
2477(defmacro match-instr (instr mask bits-to-match)
2478  `(eql (logand ,instr ,mask) ,bits-to-match))
2479
2480(defmacro with-xp-stack-frames ((xp trap-function &optional stack-frame) &body body)
2481  (let ((thunk (gensym))
2482        (sf (or stack-frame (gensym))))
2483    `(let ((,thunk #'(lambda (&optional ,sf)
2484                       ,@(unless stack-frame `((declare (ignore ,sf))))
2485                       ,@body)))
2486       (declare (dynamic-extent ,thunk))
2487       (funcall-with-xp-stack-frames ,xp ,trap-function ,thunk))))
2488
2489(defmacro signal-eof-error (stream)
2490  `(error 'end-of-file :stream ,stream))
2491
2492(defmacro check-eof (valform stream eof-error-p eof-value)
2493  (let* ((val (gensym)))
2494    `(let ((,val ,valform))
2495      (if (eq ,val :eof)
2496        (if ,eof-error-p
2497          (signal-eof-error ,stream)
2498          ,eof-value)
2499        ,val))))
2500
2501(defmacro designated-input-stream (input-stream)
2502  `(if ,input-stream
2503    (if (eq t ,input-stream)
2504      *terminal-io*
2505      ,input-stream)
2506    *standard-input*))
2507
2508(defmacro pref (pointer accessor)
2509  (destructuring-bind (type-name &rest accessors) (decompose-record-accessor accessor)
2510    (%foreign-access-form pointer (%foreign-type-or-record type-name) 0 accessors)))
2511
2512(defmacro rref (pointer accessor &key (storage :pointer storage-p))
2513  (when storage-p
2514    (warn "Use of :storage option ignored: ~a" storage))
2515  `(pref ,pointer ,accessor))
2516
2517(defmacro rlet (spec &body body)
2518  `(%stack-block ,(rlet-sizes spec)
2519     ,@(rlet-inits spec)
2520     ,@body))
2521
2522(defmacro rletZ (spec &body body)
2523  `(%stack-block ,(rlet-sizes spec t)
2524     ,@(rlet-inits spec)
2525     ,@body))
2526
2527(defun rlet-sizes (inits &optional clear-p &aux result)
2528  (dolist (item inits (nreverse result))
2529    (push `(,(car item)
2530            ,(%foreign-type-or-record-size (cadr item) :bytes)
2531            ,@(if clear-p '(:clear t)))
2532          result)))
2533
2534(defun rlet-inits (inits &aux result)
2535  (dolist (item inits result)
2536    (let* ((name (car item))
2537           (record-name (cadr item))
2538           (inits (cddr item))
2539           (ftype (%foreign-type-or-record record-name)))
2540      (if (typep ftype 'foreign-record-type)
2541        (setq result (nconc result (%foreign-record-field-forms name ftype record-name inits)))
2542        (progn
2543          ;(setq result (nconc result `((%assert-macptr-ftype ,name ,ftype))))
2544          (when inits
2545            (if (and ftype (null (cdr inits)))
2546              (setq result
2547                    (nconc result
2548                           `((setf ,(%foreign-access-form name ftype 0 nil)
2549                              ,(car inits)))))
2550              (error "Unexpected or malformed initialization forms: ~s in field type: ~s"
2551                     inits record-name))))))))
2552
2553(defun %foreign-record-field-forms (ptr record-type record-name inits)
2554  (unless (evenp (length inits))
2555    (error "Unexpected or malformed initialization forms: ~s in field type: ~s"
2556                     inits record-name))
2557  (let* ((result ()))
2558    (do* ()
2559         ((null inits)
2560          `((progn
2561              ;(%assert-macptr-ftype ,ptr ,record-type)
2562              ,@(nreverse result))))
2563      (let* ((accessor (decompose-record-accessor (pop inits)))
2564             (valform (pop inits)))
2565        (push `(setf ,(%foreign-access-form ptr record-type 0  accessor) ,valform)
2566              result)))))
2567 
2568(defmacro get-field-offset (accessor)
2569  (destructuring-bind (type-name field-name) (decompose-record-accessor accessor)
2570    (let* ((record-type (require-type (%foreign-type-or-record type-name) 'foreign-record-type))
2571           (field (%find-foreign-record-type-field record-type field-name))
2572           (bit-offset (foreign-record-field-offset field)))
2573      `(values ,(floor bit-offset 8) ,(foreign-record-field-type field) ,bit-offset))))
2574
2575(defmacro record-length (recname)
2576  (%foreign-type-or-record-size recname :bytes))
2577
2578(defmacro make-record (record-name &rest initforms)
2579  (let* ((ftype (%foreign-type-or-record record-name))
2580         (bits (ensure-foreign-type-bits ftype))
2581         (bytes (if bits
2582                  (ceiling bits 8)
2583                  (error "Unknown size for foreign type ~S."
2584                         (unparse-foreign-type ftype))))
2585         (p (gensym))
2586         (bzero (read-from-string "#_bzero")))   
2587    `(let* ((,p (malloc ,bytes)))
2588      (,bzero ,p ,bytes)
2589      ,@(%foreign-record-field-forms p ftype record-name initforms)
2590      ,p)))
2591
2592(defmacro with-terminal-input (&body body)
2593  (let* ((got-it (gensym)))
2594    `(let* ((,got-it (%request-terminal-input)))
2595      (unwind-protect
2596           (progn ,@body)
2597        (%restore-terminal-input ,got-it)))))
2598
2599
2600
2601
2602
2603(defmacro %with-recursive-lock-ptr ((lockptr) &body body)
2604  `(unwind-protect
2605    (progn
2606      (%lock-recursive-lock ,lockptr)
2607      ,@body)
2608    (%unlock-recursive-lock ,lockptr)))
2609
2610(defmacro %with-recursive-lock-ptr-maybe ((lockptr) &body body)
2611  `(when (%try-recursive-lock ,lockptr)
2612    (unwind-protect
2613         (progn ,@body)
2614      (%unlock-recursive-lock ,lockptr))))
2615
2616(defmacro with-recursive-lock ((lock) &body body)
2617  (let* ((p (gensym)))
2618    `(let* ((,p (recursive-lock-ptr ,lock)))
2619      (%with-recursive-lock-ptr (,p) ,@body))))
2620
2621(defmacro with-recursive-lock-maybe ((lock) &body body)
2622  (let* ((p (gensym)))
2623    `(let* ((,p (recursive-lock-ptr ,lock)))
2624      (%with-recursive-lock-ptr-maybe (,p) ,@body))))
2625
2626(defmacro with-read-lock ((lock) &body body)
2627  (let* ((p (gensym)))
2628    `(let* ((,p ,lock))
2629      (unwind-protect
2630           (progn
2631             (read-lock-rwlock ,p)
2632             ,@body)
2633        (unlock-rwlock ,p)))))
2634
2635
2636(defmacro with-write-lock ((lock) &body body)
2637  (let* ((p (gensym)))
2638    `(let* ((,p ,lock))
2639      (unwind-protect
2640           (progn
2641             (write-lock-rwlock ,p)
2642             ,@body)
2643        (unlock-rwlock ,p)))))
2644
2645
2646
2647(defmacro without-gcing (&body body)
2648  `(unwind-protect
2649    (progn
2650      (%lock-gc-lock)
2651      ,@body)
2652    (%unlock-gc-lock)))
2653
2654(defmacro with-other-threads-suspended (&body body)
2655  `(unwind-protect
2656    (progn
2657      (%suspend-other-threads)
2658      ,@body)
2659    (%resume-other-threads)))
2660
2661(defmacro with-package-read-lock ((p) &body body)
2662  `(with-read-lock ((pkg.lock ,p)) ,@body))
2663
2664(defmacro with-package-write-lock ((p) &body body)
2665  `(with-write-lock ((pkg.lock ,p)) ,@body))
2666
2667(defmacro with-package-lock ((p) &body body)
2668  `(with-package-write-lock (,p) ,@body))
2669
2670;;; Lock %all-packages-lock%, for shared read access to %all-packages%
2671
2672(defmacro with-package-list-read-lock (&body body)
2673  `(with-read-lock (%all-packages-lock%) ,@body))
2674
2675;;; Lock %all-packages-lock%, to allow modification to %all-packages%
2676(defmacro with-package-list-write-lock (&body body)
2677  `(with-write-lock (%all-packages-lock%) ,@body))
2678
2679(defmacro atomic-incf-decf (place delta &environment env)
2680  (setq place (macroexpand place env))
2681  (if (consp place)
2682    (let* ((sym (car place))
2683           (struct-transform (or (environment-structref-info sym env)
2684                                 (gethash sym %structure-refs%))))
2685      (if struct-transform
2686        (setq place (defstruct-ref-transform struct-transform (cdr place))
2687              sym (car place)))
2688      (ecase sym
2689        (the `(the ,(cadr place) (atomic-incf-decf ,(caddr place) ,delta)))
2690        (car `(%atomic-incf-car ,(cadr place) ,delta))
2691        (cdr `(%atomic-incf-cdr ,(cadr place) ,delta))
2692        ((svref %svref) `(%atomic-incf-gvector ,@(cdr place) ,delta))))
2693    (if (and (symbolp place) (eq :special (variable-information place env)))
2694      (let* ((base (gensym))
2695             (offset (gensym)))
2696        `(multiple-value-bind (,base ,offset)
2697          (%symbol-binding-address ',place)
2698          (%atomic-incf-node ,delta ,base ,offset)))
2699      (error "~S is not a special variable"  place))))
2700   
2701(defmacro atomic-incf (place)
2702  `(atomic-incf-decf ,place 1))
2703
2704(defmacro atomic-decf (place)
2705  `(atomic-incf-decf ,place -1))
2706
2707; Some of these macros were stolen from CMUCL.  Sort of ...
2708
2709(defmacro iterate (name binds &body body)
2710  "Iterate Name ({(Var Initial-Value)}*) Declaration* Form*
2711  This is syntactic sugar for Labels.  It creates a local function Name with
2712  the specified Vars as its arguments and the Declarations and Forms as its
2713  body.  This function is then called with the Initial-Values, and the result
2714  of the call is return from the macro."
2715  (dolist (x binds)
2716    (unless (and (listp x)
2717                 (= (length x) 2))
2718      (error "Malformed iterate variable spec: ~S." x)))
2719
2720  `(labels ((,name ,(mapcar #'first binds) ,@body))
2721     (,name ,@(mapcar #'second binds))))
2722
2723;;;; The Collect macro:
2724
2725;;; Collect-Normal-Expander  --  Internal
2726;;;
2727;;;    This function does the real work of macroexpansion for normal collection
2728;;; macros.  N-Value is the name of the variable which holds the current
2729;;; value.  Fun is the function which does collection.  Forms is the list of
2730;;; forms whose values we are supposed to collect.
2731;;;
2732(eval-when (:compile-toplevel :load-toplevel :execute)
2733
2734
2735(defun collect-normal-expander (n-value fun forms)
2736  `(progn
2737     ,@(mapcar #'(lambda (form) `(setq ,n-value (,fun ,form ,n-value))) forms)
2738     ,n-value))
2739
2740
2741)
2742
2743(defmacro once-only (specs &body body)
2744  "Once-Only ({(Var Value-Expression)}*) Form*
2745  Create a Let* which evaluates each Value-Expression, binding a temporary
2746  variable to the result, and wrapping the Let* around the result of the
2747  evaluation of Body.  Within the body, each Var is bound to the corresponding
2748  temporary variable."
2749  (iterate frob
2750           ((specs specs)
2751            (body body))
2752    (if (null specs)
2753      `(progn ,@body)
2754      (let ((spec (first specs)))
2755        (when (/= (length spec) 2)
2756          (error "Malformed Once-Only binding spec: ~S." spec))
2757        (let ((name (first spec))
2758              (exp-temp (gensym)))
2759          `(let ((,exp-temp ,(second spec))
2760                 (,name (gensym)))
2761             `(let ((,,name ,,exp-temp))
2762                ,,(frob (rest specs) body))))))))
2763
2764(eval-when (:compile-toplevel :load-toplevel :execute)
2765(defun form-symbol (first &rest others)
2766  (intern (apply #'concatenate 'simple-base-string (string first) (mapcar #'string others))))
2767)
2768
2769
2770;;; Collect-List-Expander  --  Internal
2771;;;
2772;;;    This function deals with the list collection case.  N-Tail is the pointer
2773;;; to the current tail of the list, which is NIL if the list is empty.
2774;;;
2775(defun collect-list-expander (n-value n-tail forms)
2776  (let ((n-res (gensym)))
2777    `(progn
2778       ,@(mapcar #'(lambda (form)
2779                     `(let ((,n-res (cons ,form nil)))
2780                        (cond (,n-tail
2781                               (setf (cdr ,n-tail) ,n-res)
2782                               (setq ,n-tail ,n-res))
2783                              (t
2784                               (setq ,n-tail ,n-res  ,n-value ,n-res)))))
2785                 forms)
2786       ,n-value)))
2787
2788;;;
2789;;;    The ultimate collection macro...
2790;;;
2791
2792(defmacro collect (collections &body body)
2793  "Collect ({(Name [Initial-Value] [Function])}*) {Form}*
2794  Collect some values somehow.  Each of the collections specifies a bunch of
2795  things which collected during the evaluation of the body of the form.  The
2796  name of the collection is used to define a local macro, a la MACROLET.
2797  Within the body, this macro will evaluate each of its arguments and collect
2798  the result, returning the current value after the collection is done.  The
2799  body is evaluated as a PROGN; to get the final values when you are done, just
2800  call the collection macro with no arguments.
2801
2802  Initial-Value is the value that the collection starts out with, which
2803  defaults to NIL.  Function is the function which does the collection.  It is
2804  a function which will accept two arguments: the value to be collected and the
2805  current collection.  The result of the function is made the new value for the
2806  collection.  As a totally magical special-case, the Function may be Collect,
2807  which tells us to build a list in forward order; this is the default.  If an
2808  Initial-Value is supplied for Collect, the stuff will be rplacd'd onto the
2809  end.  Note that Function may be anything that can appear in the functional
2810  position, including macros and lambdas."
2811 
2812 
2813  (let ((macros ())
2814        (binds ()))
2815    (dolist (spec collections)
2816      (unless (<= 1 (length spec) 3)
2817        (error "Malformed collection specifier: ~S." spec))
2818      (let ((n-value (gensym))
2819            (name (first spec))
2820            (default (second spec))
2821            (kind (or (third spec) 'collect)))
2822       
2823        (push `(,n-value ,default) binds)
2824        (if (eq kind 'collect)
2825          (let ((n-tail (gensym)))
2826            (if default
2827              (push `(,n-tail (last ,n-value)) binds)
2828              (push n-tail binds))
2829            (push `(,name (&rest args)
2830                          (collect-list-expander ',n-value ',n-tail args))
2831                  macros))
2832          (push `(,name (&rest args)
2833                        (collect-normal-expander ',n-value ',kind args))
2834                macros))))
2835    `(macrolet ,macros (let* ,(nreverse binds) ,@body))))
2836
2837
2838;;; DEFENUM -- Internal Interface.
2839;;;
2840(defmacro defenum ((&key (prefix "") (suffix "") (start 0) (step 1))
2841                   &rest identifiers)
2842  (let ((results nil)
2843        (index 0)
2844        (start (eval start))
2845        (step (eval step)))
2846    (dolist (id identifiers)
2847      (multiple-value-bind
2848        (root docs)
2849        (if (consp id)
2850          (values (car id) (cdr id))
2851          (values id nil))
2852        (push `(defconstant ,(intern (concatenate 'simple-base-string
2853                                                  (string prefix)
2854                                                  (string root)
2855                                                  (string suffix)))
2856                 ,(+ start (* step index))
2857                 ,@docs)
2858              results))
2859      (incf index))
2860    `(eval-when (:compile-toplevel :load-toplevel :execute)
2861       ,@(nreverse results))))
2862
2863
2864;;; This does something like special binding, but the "bindings" established
2865;;; aren't thread-specific.
2866
2867(defmacro let-globally ((&rest vars) &body body &environment env)
2868  (multiple-value-bind (body decls) (parse-body body env)
2869    (let* ((initforms nil)
2870           (psetform nil)
2871           (specvars nil)
2872           (restoreform nil))
2873      (flet ((pair-name-value (p)
2874               (if (atom p)
2875                 (values (require-global-symbol p env) nil)
2876                 (if (and (consp (%cdr p)) (null (%cddr p)))
2877                   (values (require-global-symbol (%car p) env) (%cadr p))
2878                   (error "Invalid variable initialization form : ~s")))))
2879        (declare (inline pair-name-value))
2880        (dolist (v vars)
2881          (let* ((oldval (gensym))
2882                 (newval (gensym)))
2883            (multiple-value-bind (var valueform) (pair-name-value v)
2884              (push var specvars)
2885              (push var restoreform)
2886              (push oldval restoreform)
2887              (push `(,oldval (uvref ',var #.ppc32::symbol.vcell-cell)) initforms)
2888              (push `(,newval ,valueform) initforms)
2889              (push var psetform)
2890              (push newval psetform))))
2891        `(let ,(nreverse initforms)
2892           ,@decls
2893           (locally (declare (special ,@(nreverse specvars)))
2894             (unwind-protect
2895               (progn (psetq ,@(nreverse psetform)) ,@body)
2896               (psetq ,@(nreverse restoreform)))))))))
2897;;; From CLX.
2898
2899;;; The good news is that this uses an interlocked load/store sequence
2900;;; and is fairly efficient.
2901;;; The bad news is that it only handles a few types of "place" forms.
2902;;; The good news is that CLX only uses a few types of "place" forms.
2903
2904(defmacro conditional-store (place old-value new-value &environment env)
2905  (setq place (macroexpand place env))
2906  (if (atom place)
2907    ;; CLX uses special variables' value cells as place forms.
2908    (if (and (symbolp place)
2909             (eq :special (ccl::variable-information place env)))
2910      (let* ((base (gensym))
2911             (offset (gensym)))
2912        `(multiple-value-bind (,base ,offset)
2913          (ccl::%symbol-binding-address ',place)
2914          (ccl::%store-node-conditional ,offset ,base ,old-value ,new-value)))
2915      (error "~s is not a special variable ." place))
2916    (let* ((sym (car place))
2917           (struct-transform (or (ccl::environment-structref-info sym env)
2918                                 (gethash sym ccl::%structure-refs%))))
2919      (if struct-transform
2920        (setq place (ccl::defstruct-ref-transform struct-transform (cdr place))
2921              sym (car place)))
2922      (if (member  sym '(svref ccl::%svref ccl::struct-ref))
2923        (let* ((v (gensym)))
2924          `(let* ((,v ,(cadr place)))
2925            (ccl::store-gvector-conditional ,(caddr place)
2926             ,v ,old-value ,new-value)))
2927        (error "Don't know how to do conditional store to ~s" place)))))
2928
2929(defmacro step (form)
2930  form)
Note: See TracBrowser for help on using the repository browser.