← Back to branch summary

~ubuntu-branches/ubuntu/quantal/gclcvs/quantal

« back to all changes in this revision

Viewing changes to lsp/gcl_evalmacros.lsp

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2004-06-24 15:13:46 UTC
  • Revision ID: james.westby@ubuntu.com-20040624151346-xh0xaaktyyp7aorc
Tags: 2.7.0-26
C_GC_OFFSET is 2 on m68k-linux

Show diffs side-by-side

added added

removed removed

Lines of Context:
lsp/gcl_evalmacros.lsp
 
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
;;;;    evalmacros.lsp
 
21
 
 
22
 
 
23
(in-package "LISP")
 
24
 
 
25
(export '(defvar defparameter defconstant))
 
26
 
 
27
(in-package "SYSTEM")
 
28
 
 
29
 
 
30
(eval-when (compile) (proclaim '(optimize (safety 2) (space 3))))
 
31
(eval-when (eval compile) (defun si:clear-compiler-properties (symbol)))
 
32
(eval-when (eval compile) (setq si:*inhibit-macro-special* nil))
 
33
 
 
34
 
 
35
(defmacro defvar (var &optional (form nil form-sp) doc-string)
 
36
  `(progn (si:*make-special ',var)
 
37
          ,(if doc-string
 
38
               `(si:putprop ',var ,doc-string 'variable-documentation))
 
39
          ,(if form-sp
 
40
               `(or (boundp ',var)
 
41
                    (setq ,var ,form)))
 
42
          ',var)
 
43
          )
 
44
 
 
45
(defmacro defparameter (var form &optional doc-string)
 
46
  (if doc-string
 
47
      `(progn (si:*make-special ',var)
 
48
              (si:putprop ',var ,doc-string 'variable-documentation)
 
49
              (setq ,var ,form)
 
50
              ',var)
 
51
      `(progn (si:*make-special ',var)
 
52
              (setq ,var ,form)
 
53
              ',var)))
 
54
 
 
55
(defmacro defconstant (var form &optional doc-string)
 
56
  (if doc-string
 
57
      `(progn (si:*make-constant ',var ,form)
 
58
              (si:putprop ',var ,doc-string 'variable-documentation)
 
59
              ',var)
 
60
      `(progn (si:*make-constant ',var ,form)
 
61
              ',var)))
 
62
 
 
63
 
 
64
;;; Each of the following macros is also defined as a special form.
 
65
;;; Thus their names need not be exported.
 
66
 
 
67
(defmacro and (&rest forms)
 
68
  (if (endp forms)
 
69
      t
 
70
      (let ((x (reverse forms)))
 
71
           (do ((forms (cdr x) (cdr forms))
 
72
                (form (car x) `(if ,(car forms) ,form)))
 
73
               ((endp forms) form))))
 
74
  )
 
75
 
 
76
(defmacro or (&rest forms)
 
77
  (if (endp forms)
 
78
      nil
 
79
      (let ((x (reverse forms)))
 
80
           (do ((forms (cdr x) (cdr forms))
 
81
                (form (car x)
 
82
                      (let ((temp (gensym)))
 
83
                           `(let ((,temp ,(car forms)))
 
84
                                 (if ,temp ,temp ,form)))))
 
85
               ((endp forms) form))))
 
86
  )
 
87
               
 
88
(defmacro locally (&rest body) `(let () ,@body))
 
89
 
 
90
(defmacro loop (&rest body &aux (tag (gensym)))
 
91
  `(block nil (tagbody ,tag (progn ,@body) (go ,tag))))
 
92
 
 
93
(defmacro defmacro (name vl &rest body)
 
94
  `(si:define-macro ',name (si:defmacro* ',name ',vl ',body)))
 
95
 
 
96
(defmacro defun (name lambda-list &rest body)
 
97
  (multiple-value-bind (doc decl body)
 
98
       (find-doc body nil)
 
99
    (if doc
 
100
        `(progn (setf (get ',name 'si:function-documentation) ,doc)
 
101
                (setf (symbol-function ',name)
 
102
                      #'(lambda ,lambda-list
 
103
                          ,@decl (block ,name ,@body)))
 
104
                ',name)
 
105
        `(progn (setf (symbol-function ',name)
 
106
                      #'(lambda ,lambda-list
 
107
                          ,@decl (block ,name ,@body)))
 
108
                ',name))))
 
109
 
 
110
; assignment
 
111
 
 
112
(defmacro psetq (&rest args)
 
113
   (do ((l args (cddr l))
 
114
        (forms nil)
 
115
        (bindings nil))
 
116
       ((endp l) (list* 'let* (reverse bindings) (reverse (cons nil forms))))
 
117
       (declare (object l))
 
118
       (let ((sym (gensym)))
 
119
            (push (list sym (cadr l)) bindings)
 
120
            (push (list 'setq (car l) sym) forms)))
 
121
   )
 
122
 
 
123
; conditionals
 
124
 
 
125
(defmacro cond (&rest clauses &aux (form nil))
 
126
  (dolist (l (reverse clauses) form)
 
127
          (declare (object l))
 
128
    (cond ((endp (cdr l))
 
129
           (if (eq (car l) 't)
 
130
               (setq form 't)
 
131
               (let ((sym (gensym)))
 
132
                    (setq form `(let ((,sym ,(car l)))
 
133
                                     (if ,sym ,sym ,form))))))
 
134
          ((eq (car l) 't)
 
135
           (setq form (if (endp (cddr l))
 
136
                          (cadr l)
 
137
                          `(progn ,@(cdr l)))))
 
138
          (t (setq form (if (endp (cddr l))
 
139
                            `(if ,(car l) ,(cadr l) ,form)
 
140
                            `(if ,(car l) (progn ,@(cdr l)) ,form))))))
 
141
  )
 
142
 
 
143
(defmacro when (pred &rest body)
 
144
  `(if ,pred (progn ,@body)))
 
145
 
 
146
(defmacro unless (pred &rest body)
 
147
  `(if (not ,pred) (progn ,@body)))
 
148
 
 
149
; program feature
 
150
 
 
151
(defmacro prog (vl &rest body &aux (decl nil))
 
152
  (do ()
 
153
      ((or (endp body)
 
154
           (not (consp (car body)))
 
155
           (not (eq (caar body) 'declare)))
 
156
       `(block nil (let ,vl ,@decl (tagbody ,@body)))
 
157
       )
 
158
      (push (car body) decl)
 
159
      (pop body))
 
160
  )
 
161
 
 
162
(defmacro prog* (vl &rest body &aux (decl nil))
 
163
  (do ()
 
164
      ((or (endp body)
 
165
           (not (consp (car body)))
 
166
           (not (eq (caar body) 'declare)))
 
167
       `(block nil (let* ,vl ,@decl (tagbody ,@body)))
 
168
       )
 
169
      (push (car body) decl)
 
170
      (pop body))
 
171
  )
 
172
 
 
173
; sequencing
 
174
 
 
175
(defmacro prog1 (first &rest body &aux (sym (gensym)))
 
176
  `(let ((,sym ,first)) ,@body ,sym))
 
177
 
 
178
(defmacro prog2 (first second &rest body &aux (sym (gensym)))
 
179
  `(progn ,first (let ((,sym ,second)) ,@body ,sym)))
 
180
 
 
181
; multiple values
 
182
 
 
183
(defmacro multiple-value-list (form)
 
184
  `(multiple-value-call 'list ,form))
 
185
 
 
186
(defmacro multiple-value-setq (vars form)
 
187
  (do ((vl vars (cdr vl))
 
188
       (sym (gensym))
 
189
       (forms nil)
 
190
       (n 0 (1+ n)))
 
191
      ((endp vl) `(let ((,sym (multiple-value-list ,form))) ,@forms))
 
192
      (declare (fixnum n) (object vl))
 
193
      (push `(setq ,(car vl) (nth ,n ,sym)) forms))
 
194
  )
 
195
 
 
196
(defmacro multiple-value-bind (vars form &rest body)
 
197
  (do ((vl vars (cdr vl))
 
198
       (sym (gensym))
 
199
       (bind nil)
 
200
       (n 0 (1+ n)))
 
201
      ((endp vl) `(let* ((,sym (multiple-value-list ,form)) ,@(reverse bind))
 
202
                        ,@body))
 
203
      (declare (fixnum n) (object vl))
 
204
      (push `(,(car vl) (nth ,n ,sym)) bind))
 
205
  )
 
206
 
 
207
(defmacro do (control (test . result) &rest body
 
208
              &aux (decl nil) (label (gensym)) (vl nil) (step nil))
 
209
  (do ()
 
210
      ((or (endp body)
 
211
           (not (consp (car body)))
 
212
           (not (eq (caar body) 'declare))))
 
213
      (push (car body) decl)
 
214
      (pop body))
 
215
  (dolist (c control)
 
216
          (declare (object c))
 
217
    (if(symbolp  c) (setq c (list c)))
 
218
        (push (list (car c) (cadr c)) vl)
 
219
    (unless (endp (cddr c))
 
220
            (push (car c) step)
 
221
            (push (caddr c) step)))
 
222
  `(block nil
 
223
          (let ,(reverse vl)
 
224
               ,@decl
 
225
               (tagbody
 
226
                ,label (if ,test (return (progn ,@result)))
 
227
                       (tagbody ,@body)
 
228
                       (psetq ,@(reverse step))
 
229
                       (go ,label)))))
 
230
 
 
231
(defmacro do* (control (test . result) &rest body
 
232
               &aux (decl nil) (label (gensym)) (vl nil) (step nil))
 
233
  (do ()
 
234
      ((or (endp body)
 
235
           (not (consp (car body)))
 
236
           (not (eq (caar body) 'declare))))
 
237
      (push (car body) decl)
 
238
      (pop body))
 
239
  (dolist (c control)
 
240
          (declare (object c))
 
241
    (if(symbolp  c) (setq c (list c)))
 
242
        (push (list (car c) (cadr c)) vl)
 
243
    (unless (endp (cddr c))
 
244
            (push (car c) step)
 
245
            (push (caddr c) step)))
 
246
  `(block nil
 
247
          (let* ,(reverse vl)
 
248
                ,@decl
 
249
                (tagbody
 
250
                 ,label (if ,test (return (progn ,@result)))
 
251
                        (tagbody ,@body)
 
252
                        (setq ,@(reverse step))
 
253
                        (go ,label))))
 
254
  )
 
255
 
 
256
(defmacro case (keyform &rest clauses &aux (form nil) (key (gensym)))
 
257
  (dolist (clause (reverse clauses) `(let ((,key ,keyform)) ,form))
 
258
          (declare (object clause))
 
259
    (cond ((or (eq (car clause) 't) (eq (car clause) 'otherwise))
 
260
           (setq form `(progn ,@(cdr clause))))
 
261
          ((consp (car clause))
 
262
           (setq form `(if (member ,key ',(car clause))
 
263
                           (progn ,@(cdr clause))
 
264
                           ,form)))
 
265
          ((car clause)
 
266
           (setq form `(if (eql ,key ',(car clause))
 
267
                           (progn ,@(cdr clause))
 
268
                           ,form)))))
 
269
  )
 
270
 
 
271
 
 
272
(defmacro return (&optional (val nil)) `(return-from nil ,val))
 
273
 
 
274
(defmacro dolist ((var form &optional (val nil)) &rest body
 
275
                                                 &aux (temp (gensym)))
 
276
  `(do* ((,temp ,form (cdr ,temp)) (,var (car ,temp) (car ,temp)))
 
277
        ((endp ,temp) ,val)
 
278
        ,@body))
 
279
 
 
280
;; In principle, a more complete job could be done here by trying to
 
281
;; capture fixnum type declarations from the surrounding context or
 
282
;; environment, or from within the compiler's internal structures at
 
283
;; compile time.  See gcl-devel archives for examples.  This
 
284
;; implementation relies on the fact that the gcc optimizer will
 
285
;; eliminate the bignum branch if the supplied form is a symbol
 
286
;; declared to be fixnum, as the comparison of a long integer variable
 
287
;; with most-positive-fixnum is then vacuous.  Care must be taken in
 
288
;; making comparisons with most-negative-fixnum, as the C environment
 
289
;; appears to treat this as positive or negative depending on the sign
 
290
;; of the other argument in the comparison, apparently to symmetrize
 
291
;; the long integer range.  20040403 CM.
 
292
(defmacro dotimes ((var form &optional (val nil)) &rest body)
 
293
  (cond ((symbolp form)
 
294
         `(cond ((< ,form 0)
 
295
                 (let ((,var 0))
 
296
                   (declare (fixnum ,var) (ignorable ,var))
 
297
                   ,val))
 
298
                ((<= ,form most-positive-fixnum)
 
299
                 (let ((,form ,form))
 
300
                   (declare (fixnum ,form))
 
301
                   (do* ((,var 0 (1+ ,var))) ((>= ,var ,form) ,val)
 
302
                     (declare (fixnum ,var))
 
303
                     ,@body)))
 
304
                (t 
 
305
                 (do* ((,var 0 (1+ ,var))) ((>= ,var ,form) ,val)
 
306
                   ,@body))))
 
307
        ((constantp form)
 
308
         (cond ((< form 0)
 
309
                `(let ((,var 0))
 
310
                   (declare (fixnum ,var) (ignorable ,var))
 
311
                   ,val))
 
312
               ((<= form most-positive-fixnum)
 
313
                `(do* ((,var 0 (1+ ,var))) ((>= ,var ,form) ,val)
 
314
                   (declare (fixnum ,var))
 
315
                   ,@body))
 
316
               (t
 
317
                `(do* ((,var 0 (1+ ,var))) ((>= ,var ,form) ,val)
 
318
                   ,@body))))
 
319
        (t
 
320
         (let ((temp (gensym)))
 
321
         `(let ((,temp ,form))
 
322
            (cond ((< ,temp 0)
 
323
                   (let ((,var 0))
 
324
                     (declare (fixnum ,var) (ignorable ,var))
 
325
                     ,val))
 
326
                  ((<= ,temp most-positive-fixnum)
 
327
                   (let ((,temp ,temp))
 
328
                     (declare (fixnum ,temp))
 
329
                     (do* ((,var 0 (1+ ,var))) ((>= ,var ,temp) ,val)
 
330
                       (declare (fixnum ,var))
 
331
                       ,@body)))
 
332
                  (t 
 
333
                   (do* ((,var 0 (1+ ,var))) ((>= ,var ,temp) ,val)
 
334
                     ,@body))))))))
 
335
 
 
336
(defmacro declaim (&rest l)
 
337
 `(eval-when (compile eval load)
 
338
             ,@(mapcar #'(lambda (x) `(proclaim ',x)) l)))
 
339
 
 
340
(defmacro lambda ( &rest l) `(function (lambda ,@l)))