/[gcl]/gcl/lsp/gcl_defmacro.lsp
ViewVC logotype

Diff of /gcl/lsp/gcl_defmacro.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by camm, Sun Sep 14 02:30:35 2003 UTC revision 1.2 by camm, Sun Sep 14 02:43:04 2003 UTC
# Line 0  Line 1 
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    

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26