1 |
|
;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa |
2 |
|
|
3 |
|
;; This file is part of GNU Common Lisp, herein referred to as GCL |
4 |
|
;; |
5 |
|
;; GCL is free software; you can redistribute it and/or modify it under |
6 |
|
;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by |
7 |
|
;; the Free Software Foundation; either version 2, or (at your option) |
8 |
|
;; any later version. |
9 |
|
;; |
10 |
|
;; GCL is distributed in the hope that it will be useful, but WITHOUT |
11 |
|
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or |
12 |
|
;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public |
13 |
|
;; License for more details. |
14 |
|
;; |
15 |
|
;; You should have received a copy of the GNU Library General Public License |
16 |
|
;; along with GCL; see the file COPYING. If not, write to the Free Software |
17 |
|
;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |
18 |
|
|
19 |
|
|
20 |
|
;;;; defmacro.lsp |
21 |
|
;;;; |
22 |
|
;;;; defines SI:DEFMACRO*, the defmacro preprocessor |
23 |
|
|
24 |
|
|
25 |
|
(in-package 'lisp) |
26 |
|
(export '(&whole &environment &body)) |
27 |
|
|
28 |
|
|
29 |
|
(in-package 'system) |
30 |
|
|
31 |
|
|
32 |
|
(eval-when (compile) (proclaim '(optimize (safety 2) (space 3)))) |
33 |
|
|
34 |
|
|
35 |
|
;;; valid lambda-list to DEFMACRO is: |
36 |
|
;;; |
37 |
|
;;; ( [ &whole sym ] |
38 |
|
;;; [ &environment sym ] |
39 |
|
;;; { v }* |
40 |
|
;;; [ &optional { sym | ( v [ init [ v ] ] ) }* ] |
41 |
|
;;; { [ { &rest | &body } v ] |
42 |
|
;;; [ &key { sym | ( { sym | ( key v ) } [ init [ v ]] ) }* |
43 |
|
;;; [ &allow-other-keys ]] |
44 |
|
;;; [ &aux { sym | ( v [ init ] ) }* ] |
45 |
|
;;; | . sym } |
46 |
|
;;; ) |
47 |
|
;;; |
48 |
|
;;; where v is short for { defmacro-lambda-list | sym }. |
49 |
|
;;; A symbol may be accepted as a DEFMACRO lambda-list, in which case |
50 |
|
;;; (DEFMACRO <name> <symbol> ... ) is equivalent to |
51 |
|
;;; (DEFMACRO <name> (&REST <symbol>) ...). |
52 |
|
;;; Defamcro-lambda-list is defined as: |
53 |
|
;;; |
54 |
|
;;; ( { v }* |
55 |
|
;;; [ &optional { sym | ( v [ init [ v ] ] ) }* ] |
56 |
|
;;; { [ { &rest | &body } v ] |
57 |
|
;;; [ &key { sym | ( { sym | ( key v ) } [ init [ v ]] ) }* |
58 |
|
;;; [ &allow-other-keys ]] |
59 |
|
;;; [ &aux { sym | ( v [ init ] ) }* ] |
60 |
|
;;; | . sym } |
61 |
|
;;; ) |
62 |
|
|
63 |
|
;; defvar is not yet available. |
64 |
|
(mapc '*make-special '(*dl* *key-check* *arg-check*)) |
65 |
|
|
66 |
|
|
67 |
|
(defun get-&environment(vl &aux env) |
68 |
|
(let ((env-m |
69 |
|
(and (listp vl) |
70 |
|
(do ((tail vl (cdr tail))) |
71 |
|
((not (consp tail)) nil) |
72 |
|
(when (eq '&environment (car tail)) |
73 |
|
(return tail)))))) |
74 |
|
(cond (env-m |
75 |
|
(setq env (cadr env-m)) |
76 |
|
(setq vl (append (ldiff vl env-m) (cddr env-m))))) |
77 |
|
(values vl env))) |
78 |
|
|
79 |
|
|
80 |
|
|
81 |
|
(defun si:defmacro* (name vl body |
82 |
|
&aux *dl* (*key-check* nil) |
83 |
|
(*arg-check* nil) |
84 |
|
doc decls whole ppn (env nil) envp) |
85 |
|
(cond ((listp vl)) |
86 |
|
((symbolp vl) (setq vl (list '&rest vl))) |
87 |
|
(t (error "The defmacro-lambda-list ~s is not a list." vl))) |
88 |
|
(multiple-value-setq (doc decls body) (find-doc body nil)) |
89 |
|
(cond ((and (listp vl) (eq (car vl) '&whole)) |
90 |
|
(setq whole (cadr vl)) (setq vl (cddr vl))) |
91 |
|
(t (setq whole (gensym)))) |
92 |
|
(multiple-value-setq (vl env) |
93 |
|
(get-&environment vl)) |
94 |
|
(setq envp env) |
95 |
|
(or env (setq env (gensym))) |
96 |
|
(setq *dl* `(&aux ,env ,whole)) |
97 |
|
(setq ppn (dm-vl vl whole t)) |
98 |
|
(dolist (kc *key-check*) |
99 |
|
(push `(unless (getf ,(car kc) :allow-other-keys) |
100 |
|
(do ((vl ,(car kc) (cddr vl))) |
101 |
|
((endp vl)) |
102 |
|
(unless (member (car vl) ',(cdr kc)) |
103 |
|
(dm-key-not-allowed (car vl)) |
104 |
|
))) |
105 |
|
body)) |
106 |
|
(dolist (ac *arg-check*) |
107 |
|
(push `(unless (endp ,(dm-nth-cdr (cdr ac) (car ac))) |
108 |
|
(dm-too-many-arguments)) body)) |
109 |
|
(unless envp (push `(declare (ignore ,env)) body)) |
110 |
|
(list doc ppn `(lambda-block ,name ,(reverse *dl*) ,@(append decls body))) |
111 |
|
) |
112 |
|
|
113 |
|
(defun dm-vl (vl whole top) |
114 |
|
(do ((optionalp nil) (restp nil) (keyp nil) |
115 |
|
(allow-other-keys-p nil) (auxp nil) |
116 |
|
(rest nil) (allow-other-keys nil) (keys nil) (no-check nil) |
117 |
|
(n (if top 1 0)) (ppn nil) |
118 |
|
) |
119 |
|
((not (consp vl)) |
120 |
|
(when vl |
121 |
|
(when restp (dm-bad-key '&rest)) |
122 |
|
(push (list vl (dm-nth-cdr n whole)) *dl*) |
123 |
|
(setq no-check t)) |
124 |
|
(when (and rest (not allow-other-keys)) |
125 |
|
(push (cons rest keys) *key-check*)) |
126 |
|
(unless no-check (push (cons whole n) *arg-check*)) |
127 |
|
ppn |
128 |
|
) |
129 |
|
(let ((v (car vl))) |
130 |
|
(cond |
131 |
|
((eq v '&optional) |
132 |
|
(when optionalp (dm-bad-key '&optional)) |
133 |
|
(setq optionalp t) |
134 |
|
(pop vl)) |
135 |
|
((or (eq v '&rest) (eq v '&body)) |
136 |
|
(when restp (dm-bad-key v)) |
137 |
|
(dm-v (cadr vl) (dm-nth-cdr n whole)) |
138 |
|
(setq restp t optionalp t no-check t) |
139 |
|
(setq vl (cddr vl)) |
140 |
|
(when (eq v '&body) (setq ppn (if top (1- n) n)))) |
141 |
|
((eq v '&key) |
142 |
|
(when keyp (dm-bad-key '&key)) |
143 |
|
(setq rest (gensym)) |
144 |
|
(push (list rest (dm-nth-cdr n whole)) *dl*) |
145 |
|
(setq keyp t restp t optionalp t no-check t) |
146 |
|
(pop vl)) |
147 |
|
((eq v '&allow-other-keys) |
148 |
|
(when (or (not keyp) allow-other-keys-p) |
149 |
|
(dm-bad-key '&allow-other-keys)) |
150 |
|
(setq allow-other-keys-p t) |
151 |
|
(setq allow-other-keys t) |
152 |
|
(pop vl)) |
153 |
|
((eq v '&aux) |
154 |
|
(when auxp (dm-bad-key '&aux)) |
155 |
|
(setq auxp t allow-other-keys-p t keyp t restp t optionalp t) |
156 |
|
(pop vl)) |
157 |
|
(auxp |
158 |
|
(let (x (init nil)) |
159 |
|
(cond ((symbolp v) (setq x v)) |
160 |
|
(t (setq x (car v)) |
161 |
|
(unless (endp (cdr v)) (setq init (cadr v))))) |
162 |
|
(dm-v x init)) |
163 |
|
(pop vl)) |
164 |
|
(keyp |
165 |
|
(let ((temp (gensym)) x k (init nil) (sv nil)) |
166 |
|
(cond ((symbolp v) (setq x v k (intern (string v) 'keyword))) |
167 |
|
(t (if (symbolp (car v)) |
168 |
|
(setq x (car v) |
169 |
|
k (intern (string (car v)) 'keyword)) |
170 |
|
(setq x (cadar v) k (caar v))) |
171 |
|
(unless (endp (cdr v)) |
172 |
|
(setq init (cadr v)) |
173 |
|
(unless (endp (cddr v)) |
174 |
|
(setq sv (caddr v)))))) |
175 |
|
(dm-v temp `(getf ,rest ,k 'failed)) |
176 |
|
(dm-v x `(if (eq ,temp 'failed) ,init ,temp)) |
177 |
|
(when sv (dm-v sv `(not (eq ,temp 'failed)))) |
178 |
|
(push k keys)) |
179 |
|
(pop vl)) |
180 |
|
(optionalp |
181 |
|
(let (x (init nil) (sv nil)) |
182 |
|
(cond ((symbolp v) (setq x v)) |
183 |
|
(t (setq x (car v)) |
184 |
|
(unless (endp (cdr v)) |
185 |
|
(setq init (cadr v)) |
186 |
|
(unless (endp (cddr v)) |
187 |
|
(setq sv (caddr v)))))) |
188 |
|
(dm-v x `(if ,(dm-nth-cdr n whole) ,(dm-nth n whole) ,init)) |
189 |
|
(when sv (dm-v sv `(not (null ,(dm-nth-cdr n whole)))))) |
190 |
|
(incf n) |
191 |
|
(pop vl) |
192 |
|
) |
193 |
|
(t (dm-v v `(if ,(dm-nth-cdr n whole) |
194 |
|
,(dm-nth n whole) |
195 |
|
(dm-too-few-arguments))) |
196 |
|
(incf n) |
197 |
|
(pop vl)) |
198 |
|
)))) |
199 |
|
|
200 |
|
(defun dm-v (v init) |
201 |
|
(if (symbolp v) |
202 |
|
(push (if init (list v init) v) *dl*) |
203 |
|
(let ((temp (gensym))) |
204 |
|
(push (if init (list temp init) temp) *dl*) |
205 |
|
(dm-vl v temp nil)))) |
206 |
|
|
207 |
|
(defun dm-nth (n v) |
208 |
|
(multiple-value-bind (q r) (floor n 4) |
209 |
|
(dotimes (i q) (setq v (list 'cddddr v))) |
210 |
|
(case r |
211 |
|
(0 (list 'car v)) |
212 |
|
(1 (list 'cadr v)) |
213 |
|
(2 (list 'caddr v)) |
214 |
|
(3 (list 'cadddr v)) |
215 |
|
))) |
216 |
|
|
217 |
|
(defun dm-nth-cdr (n v) |
218 |
|
(multiple-value-bind (q r) (floor n 4) |
219 |
|
(dotimes (i q) (setq v (list 'cddddr v))) |
220 |
|
(case r |
221 |
|
(0 v) |
222 |
|
(1 (list 'cdr v)) |
223 |
|
(2 (list 'cddr v)) |
224 |
|
(3 (list 'cdddr v)) |
225 |
|
))) |
226 |
|
|
227 |
|
(defun dm-bad-key (key) |
228 |
|
(error "Defmacro-lambda-list contains illegal use of ~s." key)) |
229 |
|
|
230 |
|
(defun dm-too-few-arguments () |
231 |
|
(error "Too few arguments are supplied to defmacro-lambda-list.")) |
232 |
|
|
233 |
|
(defun dm-too-many-arguments () |
234 |
|
(error "Too many arguments are supplied to defmacro-lambda-list.")) |
235 |
|
|
236 |
|
(defun dm-key-not-allowed (key) |
237 |
|
(error "The key ~s is not allowed." key)) |
238 |
|
|
239 |
|
(defun find-doc (body ignore-doc) |
240 |
|
(if (endp body) |
241 |
|
(values nil nil nil) |
242 |
|
(let ((d (macroexpand (car body)))) |
243 |
|
(cond ((stringp d) |
244 |
|
(if (or (endp (cdr body)) ignore-doc) |
245 |
|
(values nil nil (cons d (cdr body))) |
246 |
|
(multiple-value-bind (doc decls b) (find-doc (cdr body) t) |
247 |
|
(declare (ignore doc)) |
248 |
|
(values d decls b)))) |
249 |
|
((and (consp d) (eq (car d) 'declare)) |
250 |
|
(multiple-value-bind (doc decls b) |
251 |
|
(find-doc (cdr body) ignore-doc) |
252 |
|
(values doc (cons d decls) b))) |
253 |
|
(t (values nil nil (cons d (cdr body)))))))) |
254 |
|
|
255 |
|
(defun find-declarations (body) |
256 |
|
(if (endp body) |
257 |
|
(values nil nil) |
258 |
|
(let ((d (macroexpand (car body)))) |
259 |
|
(cond ((stringp d) |
260 |
|
(if (endp (cdr body)) |
261 |
|
(values nil (list d)) |
262 |
|
(multiple-value-bind (ds b) |
263 |
|
(find-declarations (cdr body)) |
264 |
|
(values (cons d ds) b)))) |
265 |
|
((and (consp d) (eq (car d) 'declare)) |
266 |
|
(multiple-value-bind (ds b) |
267 |
|
(find-declarations (cdr body)) |
268 |
|
(values (cons d ds) b))) |
269 |
|
(t |
270 |
|
(values nil (cons d (cdr body)))))))) |
271 |
|
|