Context Navigation

source: trunk/source/lib/macros.lisp @ 16532

Visit:

Last change on this file since 16532 was 16532, checked in by svspire, 5 years ago
Make atomic-incf-decf handle structure references. Fixes #1309.
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 158.0 KB

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

Note: See TracBrowser for help on using the repository browser.

Download in other formats: