evalmacros.lsp 14.3 KB
Newer Older
1
2
3
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: SYSTEM -*-
;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab:

jgarcia's avatar
jgarcia committed
4
;;;;
jjgarcia's avatar
jjgarcia committed
5
6
;;;;  Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
;;;;  Copyright (c) 1990, Giuseppe Attardi.
7
;;;;  Copyright (c) 2001, Juan Jose Garcia Ripoll.
jjgarcia's avatar
jjgarcia committed
8
9
10
11
12
13
14
15
;;;;
;;;;    This program is free software; you can redistribute it and/or
;;;;    modify it under the terms of the GNU Library General Public
;;;;    License as published by the Free Software Foundation; either
;;;;    version 2 of the License, or (at your option) any later version.
;;;;
;;;;    See file '../Copyright' for full details.

jjgarcia's avatar
src/c    
jjgarcia committed
16
(in-package "SYSTEM")
jjgarcia's avatar
jjgarcia committed
17

18
19
20
21
22
23
(defmacro unless (pred &rest body)
  "Syntax: (unless test {form}*)
If TEST evaluates to NIL, then evaluates FORMs and returns all values of the
last FORM.  If not, simply returns NIL."
  `(IF (NOT ,pred) (PROGN ,@body)))

24
(defmacro defmacro (&whole whole name vl &body body &aux doc-string)
25
  ;; Documentation in help.lsp
26
  (multiple-value-bind (function pprint doc-string)
27
      (sys::expand-defmacro name vl body)
28
29
30
31
    (setq function `(function ,function))
    (when *dump-defun-definitions*
      (print function)
      (setq function `(si::bc-disassemble ,function)))
32
    `(eval-when (:compile-toplevel :load-toplevel :execute)
33
       ,(ext:register-with-pde whole `(si::fset ',name ,function t ,pprint))
34
35
       ,@(si::expand-set-documentation name 'function doc-string)
       ',name)))
36

37
(defmacro defvar (&whole whole var &optional (form nil form-sp) doc-string)
38
39
40
41
42
  "Syntax: (defvar name [form [doc]])
Declares the variable named by NAME as a special variable.  If the variable
does not have a value, then evaluates FORM and assigns the value to the
variable.  FORM defaults to NIL.  The doc-string DOC, if supplied, is saved
as a VARIABLE doc and can be retrieved by (documentation 'NAME 'variable)."
43
44
  `(LOCALLY (DECLARE (SPECIAL ,var))
    (SYS:*MAKE-SPECIAL ',var)
45
    ,@(when form-sp
Daniel Kochmański's avatar
Daniel Kochmański committed
46
47
          `((UNLESS (BOUNDP ',var)
              (SETQ ,var ,form))))
48
    ,@(si::expand-set-documentation var 'variable doc-string)
49
    ,(ext:register-with-pde whole)
50
51
52
53
54
    ,(if *bytecodes-compiler*
         `(eval-when (:compile-toplevel)
            (sys:*make-special ',var))
         `(eval-when (:compile-toplevel)
            (si::register-global ',var)))
jjgarcia's avatar
jjgarcia committed
55
56
    ',var))

57
(defmacro defparameter (&whole whole var form &optional doc-string)
58
59
60
61
  "Syntax: (defparameter name form [doc])
Declares the global variable named by NAME as a special variable and assigns
the value of FORM to the variable.  The doc-string DOC, if supplied, is saved
as a VARIABLE doc and can be retrieved by (documentation 'NAME 'variable)."
62
63
  `(LOCALLY (DECLARE (SPECIAL ,var))
    (SYS:*MAKE-SPECIAL ',var)
jjgarcia's avatar
jjgarcia committed
64
    (SETQ ,var ,form)
65
    ,@(si::expand-set-documentation var 'variable doc-string)
66
    ,(ext:register-with-pde whole)
67
68
69
70
71
    ,(if *bytecodes-compiler*
         `(eval-when (:compile-toplevel)
            (sys:*make-special ',var))
         `(eval-when (:compile-toplevel)
            (si::register-global ',var)))
jjgarcia's avatar
jjgarcia committed
72
73
    ',var))

74
(defmacro defconstant (&whole whole var form &optional doc-string)
75
76
77
78
79
  "Syntax: (defconstant symbol form [doc])

Declares that the global variable named by SYMBOL is a constant with the value
of FORM as its constant value.  The doc-string DOC, if supplied, is saved as a
VARIABLE doc and can be retrieved by (DOCUMENTATION 'SYMBOL 'VARIABLE)."
80
  `(PROGN
81
     (SYS:*MAKE-CONSTANT ',var ,form)
82
    ,@(si::expand-set-documentation var 'variable doc-string)
83
    ,(ext:register-with-pde whole)
84
85
86
87
88
89
    ,(if *bytecodes-compiler*
         `(eval-when (:compile-toplevel)
            (sys:*make-constant ',var ,form))
         `(eval-when (:compile-toplevel)
            (sys:*make-constant ',var ,form)
            (si::register-global ',var)))
jjgarcia's avatar
jjgarcia committed
90
91
    ',var))

92
93
94
95
96
97
98
99
100
101
102
(defparameter *defun-inline-hook*
  #'(lambda (fname form env)
      ;; To prevent inlining of stale function definitions by the native
      ;; compiler after a new definition has been established by the
      ;; bytecodes compiler, we save function definitions in the global
      ;; environment when the function has been proclaimed inline.
      (declare (ignore env))
      (let ((proclaimed (si:get-sysprop fname 'inline)))
        (when proclaimed
          `(eval-when (:compile-toplevel :load-toplevel :execute)
             (si:put-sysprop ',fname 'inline ',form))))))
103
104
105
106
107

(defmacro defun (&whole whole name vl &body body &environment env &aux doc-string)
  ;; Documentation in help.lsp
  (multiple-value-setq (body doc-string) (remove-documentation body))
  (let* ((function `#'(ext::lambda-block ,name ,vl ,@body))
Daniel Kochmański's avatar
Daniel Kochmański committed
108
         (global-function `#'(ext::lambda-block ,name ,vl
109
110
111
112
113
114
115
116
117
                                                (declare (si::c-global))
                                                ,@body)))
    (when *dump-defun-definitions*
      (print function)
      (setq function `(si::bc-disassemble ,function)))
    `(progn
       ,(ext:register-with-pde whole `(si::fset ',name ,global-function))
       ,@(si::expand-set-documentation name 'function doc-string)
       ,(let ((hook *defun-inline-hook*))
Daniel Kochmański's avatar
Daniel Kochmański committed
118
          (and hook (funcall hook name global-function env)))
119
120
       ',name)))

121
122
123
;;;
;;; This is a no-op unless the compiler is installed
;;;
124
(defmacro define-compiler-macro (&whole whole name vl &rest body)
125
  (multiple-value-bind (function pprint doc-string)
126
      (sys::expand-defmacro name vl body 'cl:define-compiler-macro)
127
    (declare (ignore pprint))
128
129
130
131
132
133
    (setq function `(function ,function))
    (when *dump-defun-definitions*
      (print function)
      (setq function `(si::bc-disassemble ,function)))
    `(progn
       (put-sysprop ',name 'sys::compiler-macro ,function)
134
       ,@(si::expand-set-documentation name 'compiler-macro doc-string)
135
       ,(ext:register-with-pde whole)
136
       ',name)))
137
138

(defun compiler-macro-function (name &optional env)
139
  (declare (ignorable env))
140
  (values (get-sysprop name 'sys::compiler-macro)))
141

jjgarcia's avatar
jjgarcia committed
142
143
144
145
146
;;; Each of the following macros is also defined as a special form,
;;; as required by CLtL. Some of them are used by the compiler (e.g.
;;; dolist), some not at all (e.g. defun).
;;; Thus their names need not be exported.

147
(let ()
148
149
150
  ;; We enclose the macro in a LET form so that it is no longer a
  ;; toplevel form. This solves the problem of this simple LOOP
  ;; replacing the more complex form in loop.lsp when evalmacros.lsp
151
  ;; gets compiled.
jjgarcia's avatar
jjgarcia committed
152
(defmacro loop (&rest body &aux (tag (gensym)))
153
154
155
  "Syntax: (loop {form}*)
Establishes a NIL block and executes FORMs repeatedly.  The loop is normally
terminated by a non-local exit."
jjgarcia's avatar
jjgarcia committed
156
  `(BLOCK NIL (TAGBODY ,tag (PROGN ,@body) (GO ,tag))))
157
)
jjgarcia's avatar
jjgarcia committed
158
159
160
161
162
163
164

(defmacro lambda (&rest body)
  `(function (lambda ,@body)))

(defmacro lambda-block (name lambda-list &rest lambda-body)
  (multiple-value-bind (decl body doc)
      (si::process-declarations lambda-body)
165
166
167
168
169
    (let ((decl (and decl (list (cons 'declare decl))))
          (block-name (si:function-block-name name)))
      `(lambda ,lambda-list ,@doc ,@decl
         (declare (si::function-block-name ,block-name))
         (block ,block-name ,@body)))))
jjgarcia's avatar
jjgarcia committed
170
171
172
173

; assignment

(defmacro psetq (&rest args)
174
175
176
  "Syntax: (psetq {var form}*)
Similar to SETQ, but evaluates all FORMs first, and then assigns each value to
the corresponding VAR.  Returns NIL."
jjgarcia's avatar
jjgarcia committed
177
178
179
180
181
182
183
184
185
186
187
188
   (do ((l args (cddr l))
        (forms nil)
        (bindings nil))
       ((endp l) (list* 'LET* (nreverse bindings) (nreverse (cons nil forms))))
       (let ((sym (gensym)))
            (push (list sym (cadr l)) bindings)
            (push (list 'setq (car l) sym) forms)))
   )

; conditionals

(defmacro cond (&rest clauses &aux (form nil))
189
190
191
192
193
  "Syntax: (cond {(test {form}*)}*)
Evaluates TESTs in order until one evaluates to non-NIL.  Then evaluates FORMs
in order that follow the TEST and returns all values of the last FORM.  If no
forms follow the TEST, then returns the value of the TEST.  Returns NIL, if no
TESTs evaluates to non-NIL."
Daniel Kochmański's avatar
Daniel Kochmański committed
194
  (dolist (l (reverse clauses) form)    ; don't use nreverse here
jjgarcia's avatar
jjgarcia committed
195
    (if (endp (cdr l))
Daniel Kochmański's avatar
Daniel Kochmański committed
196
197
198
199
200
201
202
203
204
205
206
207
208
        (if (eq (car l) 't)
            (setq form 't)
            (let ((sym (gensym)))
              (setq form `(LET ((,sym ,(car l)))
;                          (DECLARE (:READ-ONLY ,sym)) ; Beppe
                           (IF ,sym ,sym ,form)))))
        (if (eq (car l) 't)
            (setq form (if (endp (cddr l))
                           (cadr l)
                           `(PROGN ,@(cdr l))))
            (setq form (if (endp (cddr l))
                           `(IF ,(car l) ,(cadr l) ,form)
                           `(IF ,(car l) (PROGN ,@(cdr l)) ,form))))))
jjgarcia's avatar
jjgarcia committed
209
210
211
212
213
  )

; program feature

(defmacro prog (vl &rest body &aux (decl nil))
214
215
216
  "Syntax: (prog ({var | (var [init])}*) {decl}* {tag | statement}*)
Establishes a NIL block, binds each VAR to the value of INIT (which defaults
to NIL) in parallel, and executes STATEMENTs.  Returns NIL."
jjgarcia's avatar
jjgarcia committed
217
218
219
220
221
222
  (multiple-value-setq (decl body)
    (find-declarations body))
  `(BLOCK NIL (LET ,vl ,@decl (TAGBODY ,@body)))
  )

(defmacro prog* (vl &rest body &aux (decl nil))
223
224
225
  "Syntax: (prog* ({var | (var [init])}*) {decl}* {tag | statement}*)
Establishes a NIL block, binds each VAR to the value of INIT (which defaults
to NIL) sequentially, and executes STATEMENTs.  Returns NIL."
jjgarcia's avatar
jjgarcia committed
226
227
228
229
230
231
232
233
  (multiple-value-setq (decl body)
    (find-declarations body))
  `(BLOCK NIL (LET* ,vl ,@decl (TAGBODY ,@body)))
  )

; sequencing

(defmacro prog1 (first &rest body &aux (sym (gensym)))
234
235
  "Syntax: (prog1 first-form {form}*)
Evaluates FIRST-FORM and FORMs in order.  Returns the value of FIRST-FORM."
jjgarcia's avatar
jjgarcia committed
236
237
  `(LET ((,sym ,first))
;    (DECLARE (:READ-ONLY ,sym)) ; Beppe
238
     ,@body ,sym))
jjgarcia's avatar
jjgarcia committed
239
240

(defmacro prog2 (first second &rest body &aux (sym (gensym)))
241
242
243
  "Syntax: (prog2 first-form second-form {forms}*)
Evaluates FIRST-FORM, SECOND-FORM, and FORMs in order.  Returns the value of
SECOND-FORM."
jjgarcia's avatar
jjgarcia committed
244
  `(PROGN ,first (LET ((,sym ,second))
Daniel Kochmański's avatar
Daniel Kochmański committed
245
246
;                      (DECLARE (:READ-ONLY ,sym)) ; Beppe
                       ,@body ,sym)))
jjgarcia's avatar
jjgarcia committed
247
248
249
250

; multiple values

(defmacro multiple-value-list (form)
251
  "Evaluates FORM and returns a list of all values FORM returns."
jjgarcia's avatar
jjgarcia committed
252
253
254
  `(MULTIPLE-VALUE-CALL 'LIST ,form))

(defmacro multiple-value-setq (vars form)
255
256
257
258
259
  "Syntax: (multiple-value-setq {var}* form)

Evaluates FORM and binds the N-th VAR to the N-th value of FORM or, if FORM
returns less than N values, to NIL.  Returns the first value of FORM or, if
FORM returns no value, NIL."
jjgarcia's avatar
jjgarcia committed
260
261
262
  (do ((vl vars (cdr vl))
       (sym (gensym))
       (forms nil)
263
       (n 0 (truly-the fixnum (1+ n))))
jjgarcia's avatar
jjgarcia committed
264
      ((endp vl) `(LET ((,sym (MULTIPLE-VALUE-LIST ,form))) ,@forms))
265
266
    (declare (fixnum n))
    (push `(SETQ ,(car vl) (NTH ,n ,sym)) forms)))
jjgarcia's avatar
jjgarcia committed
267

268
269
;; We do not use this macroexpanso, and thus we do not care whether
;; it is efficiently compiled by ECL or not.
jjgarcia's avatar
jjgarcia committed
270
(defmacro multiple-value-bind (vars form &rest body)
271
272
273
274
275
  "Syntax: (multiple-value-bind ({var}*) init {decl}* {form}*)

Evaluates INIT and binds the N-th VAR to the N-th value of INIT or, if INIT
returns less than N values, to NIL.  Then evaluates FORMs, and returns all
values of the last FORM.  If no FORM is given, returns NIL."
276
  (declare (notinline mapcar))
277
  `(multiple-value-call #'(lambda (&optional ,@(mapcar #'list vars)) ,@body) ,form))
jjgarcia's avatar
jjgarcia committed
278

279
280
(defun while-until (test body jmp-op)
  (declare (si::c-local))
281
  (let ((label (gensym))
Daniel Kochmański's avatar
Daniel Kochmański committed
282
        (exit (gensym)))
283
284
285
286
287
    `(TAGBODY
        (GO ,exit)
      ,label
        ,@body
      ,exit
Daniel Kochmański's avatar
Daniel Kochmański committed
288
        (,jmp-op ,test (GO ,label)))))
289
290
291
292
293
294

(defmacro sys::while (test &body body)
  (while-until test body 'when))

(defmacro sys::until (test &body body)
  (while-until test body 'unless))
jjgarcia's avatar
jjgarcia committed
295

296
297
(defmacro case (keyform &rest clauses)
  (let* ((last t)
Daniel Kochmański's avatar
Daniel Kochmański committed
298
299
         (form nil)
         (key (gensym)))
300
    (dolist (clause (reverse clauses)
Daniel Kochmański's avatar
Daniel Kochmański committed
301
302
303
             `(LET ((,key ,keyform))
                ;;(DECLARE (:READ-ONLY ,key)) ; Beppe
                ,form))
304
      (let ((selector (car clause)))
Daniel Kochmański's avatar
Daniel Kochmański committed
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
        (cond ((or (eq selector T) (eq selector 'OTHERWISE))
               (unless last
                 (si::signal-simple-error
                  'program-error nil
                  "CASE: The selector ~A can only appear at the last position."
                  (list selector)))
               (setq form `(PROGN ,@(cdr clause))))
              ((consp selector)
               (setq form `(IF (MEMBER ,key ',selector)
                               (PROGN ,@(cdr clause))
                               ,form)))
              (selector
               (setq form `(IF (EQL ,key ',selector)
                               (PROGN ,@(cdr clause))
                               ,form))))
        (setq last nil)))))
jjgarcia's avatar
jjgarcia committed
321
322
323
324

(defmacro return (&optional (val nil)) `(RETURN-FROM NIL ,val))

;; Declarations
325
(let ()
jjgarcia's avatar
jjgarcia committed
326
327
(defmacro declaim (&rest decl-specs)
  (if (cdr decl-specs)
328
329
330
331
    `(eval-when (:compile-toplevel :load-toplevel :execute)
       (mapcar #'proclaim ',decl-specs))
    `(eval-when (:compile-toplevel :load-toplevel :execute)
       (proclaim ',(car decl-specs)))))
332
)
jjgarcia's avatar
jjgarcia committed
333

334
(let ()
335
336
(defmacro c-declaim (&rest decl-specs)
  (if (cdr decl-specs)
337
338
339
340
    `(eval-when (:compile-toplevel)
       (mapcar #'proclaim ',decl-specs))
    `(eval-when (:compile-toplevel)
       (proclaim ',(car decl-specs)))))
341
)
342

jjgarcia's avatar
jjgarcia committed
343
(defmacro in-package (name)
344
345
  `(eval-when (:compile-toplevel :load-toplevel :execute)
     (si::select-package ,(string name))))
jjgarcia's avatar
jjgarcia committed
346

347
(defmacro define-symbol-macro (&whole whole symbol expansion)
jjgarcia's avatar
jjgarcia committed
348
  (cond ((not (symbolp symbol))
Daniel Kochmański's avatar
Daniel Kochmański committed
349
350
351
352
353
354
355
356
         (error "DEFINE-SYMBOL-MACRO: ~A is not a symbol"
                symbol))
        ((specialp symbol)
         (error "DEFINE-SYMBOL-MACRO: cannot redefine a special variable, ~A"
                symbol))
        (t
         `(eval-when (:compile-toplevel :load-toplevel :execute)
           (put-sysprop ',symbol 'si::symbol-macro 
357
358
359
                        (lambda (form env) 
                          (declare (ignore form env))
                          ',expansion))
Daniel Kochmański's avatar
Daniel Kochmański committed
360
361
           ,(ext:register-with-pde whole)
           ',symbol))))
jjgarcia's avatar
jjgarcia committed
362
363
364

(defmacro nth-value (n expr)
  `(nth ,n (multiple-value-list ,expr)))
365

366
367
368
369
(defun maybe-unquote (form)
  (if (and (consp form) (eq (car form) 'quote))
      (second form)
      form))
370
371
372
373
374

(defun maybe-quote (form)
  ;; Quotes a form only if strictly required. This happens only when FORM is
  ;; either a symbol and not a keyword
  (if (if (atom form)
Daniel Kochmański's avatar
Daniel Kochmański committed
375
376
          (typep form '(and symbol (not keyword) (not boolean)))
          (not (eq (first form) 'quote)))
377
378
      (list 'quote form)
      form))
379
380
381
382
383
384

(defmacro ext:truly-the (&rest args)
  `(the ,@args))

(defmacro ext:checked-value (&rest args)
  `(the ,@args))