File: define-compiler-macro.impure.lisp

package info (click to toggle)
sbcl 1%3A0.9.16.0-1
  • links: PTS
  • area: main
  • in suites: etch, etch-m68k
  • size: 19,960 kB
  • ctags: 16,537
  • sloc: lisp: 231,164; ansic: 19,558; asm: 2,539; sh: 1,925; makefile: 308
file content (41 lines) | stat: -rw-r--r-- 1,244 bytes parent folder | download | duplicates (5)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
;;;; Compiler-macro tests

;;; taken from CLHS example
(defun square (x)
  (expt x 2))

(define-compiler-macro square (&whole form arg)
  (if (atom arg)
      `(expt ,arg 2)
      (case (car arg)
        (square (if (= (length arg) 2)
                    `(expt ,(nth 1 arg) 4)
                    form))
        (expt   (if (= (length arg) 3)
                    (if (numberp (nth 2 arg))
                        `(expt ,(nth 1 arg) ,(* 2 (nth 2 arg)))
                         `(expt ,(nth 1 arg) (* 2 ,(nth 2 arg))))
                    form))
        (otherwise `(expt ,arg 2)))))

(assert (eql 81 (square (square 3))))

(multiple-value-bind (expansion expanded-p) (macroexpand '(square x))
  (assert (equal '(square x) expansion))
  (assert (not expanded-p)))

(assert (equal '(expt x 2)
               (funcall (compiler-macro-function 'square)
                        '(square x)
                        nil)))

(assert (equal '(expt x 4)
               (funcall (compiler-macro-function 'square)
                        '(square (square x))
                        nil)))

(assert (equal '(expt x 2)
               (funcall (compiler-macro-function 'square)
                        '(funcall #'square x)
                        nil)))