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
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
|
;;; Tests from gitlab issues
(defpackage :issues-tests
(:use :cl :lisp-unit))
(in-package "ISSUES-TESTS")
(defun square (x)
(expt x 2))
(define-compiler-macro square (&whole form arg)
(declare (ignore arg))
form)
(define-test issue.1.a
(:tag :issues)
(assert-equal
'(square x)
(funcall (compiler-macro-function 'square) '(square x) nil)))
(define-test issue.1.b
(:tag :issues)
(assert-equal
'(square x)
(funcall (compiler-macro-function 'square) '(funcall #'square x) nil)))
(define-test issue.4
(:tag :issues)
;; Compile up two versions of elt. F-LIST should get transformed to
;; LISP::LISP-ELT*, and F-VEC should be converted to AREF. Both of
;; thse should signal errors.
(let ((f-list (compile nil '(lambda (list n)
(declare (type list list)
(optimize (speed 1) (safety 1) (compilation-speed 1)
(space 1) (debug 1)))
(elt list n))))
(f-vec (compile nil '(lambda (vec n)
(declare (type (simple-array * (*)) vec)
(optimize (speed 1) (safety 1) (compilation-speed 1)
(space 1) (debug 1)))
(elt vec n)))))
;; Errors because the index is beyond the end of the sequence
(assert-error 'lisp::index-too-large-error (funcall f-list (list 0 1 2) 3))
(assert-error 'type-error (funcall f-vec (make-array 3 :initial-contents '(0 1 2)) 3))
;; Errors because the index is negative.
(assert-error 'type-error (funcall f-list (list 0 1 2) -1))
(assert-error 'type-error (funcall f-vec (make-array 3 :initial-contents '(0 1 2)) -1))))
(define-test issue.4.setters
(:tag :issues)
;; Compile up two versions of (SETF ELT). F-LIST should get transformed to
;; %SETELT, and F-VEC should be converted to (SETF AREF). Both of
;; thse should signal errors.
(let ((s-list (compile nil '(lambda (list n new)
(declare (type list list))
(setf (elt list n) new))))
(s-vec (compile nil '(lambda (vec n new)
(declare (type (simple-array * (*)) vec))
(setf (elt vec n) new)))))
;; Errors because the index is beyond the end of the sequence
(assert-error 'type-error (funcall s-list (list 0 1 2) 3 99))
(assert-error 'type-error (funcall s-vec (make-array 3 :initial-contents '(0 1 2)) 3 99))
;; Errors because the index is negative.
(assert-error 'type-error (funcall s-list (list 0 1 2) -1 99))
(assert-error 'type-error (funcall s-vec (make-array 3 :initial-contents '(0 1 2)) -1 99))))
;; Functions for testing issue-3
(defun sqr (x)
(expt x 2))
(define-compiler-macro sqr (x)
`(expt ,x 2))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defmacro with-square-check (&body body &environment env)
(let ((text (if (compiler-macro-function 'sqr env)
"Yes"
"No")))
`(progn
(format t "SQUARE compiler macro present: ~A.~%" ,text)
,@body))))
(defun test/absent ()
(with-square-check
(sqr 2)))
(defun test/present ()
(flet ((sqr (x)
(print (expt x 3))))
(with-square-check
(sqr 2))))
(define-test issue.3
(:tag :issues)
(assert-prints "SQUARE compiler macro present: Yes."
(test/absent))
(assert-prints "SQUARE compiler macro present: No.
8"
(test/present)))
(defmacro xpop (place &environment env)
(multiple-value-bind (dummies vals new setter getter)
(get-setf-expansion place env)
`(let* (,@(mapcar #'list dummies vals) (,(car new) ,getter))
(if ,(cdr new) (error "Can't expand this."))
(prog1 (car ,(car new))
(setq ,(car new) (cdr ,(car new)))
,setter))))
(defsetf frob (x) (value)
`(setf (car ,x) ,value))
(define-test issue.7
(:tag :issues)
(assert-error 'error
(let ((z (list 1 2)))
(flet ((frob (x) (cdr x)))
(xpop (frob z))))))
|
