/
main.lisp
56 lines (50 loc) · 2.04 KB
/
main.lisp
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
(in-package #:with-shadowed-bindings)
(defun %analyze (binding &optional env)
'(values kind name)
(etypecase binding
(symbol (values :variable binding))
((cons (eql function) (cons t null))
(let ((name (second binding)))
(values (etypecase name
(symbol (if (macro-function name env)
:macro
:function))
((cons (eql setf) (cons symbol null))
:function))
name)))))
(define-condition with-shadowed-bindings:invalid-access (error)
((%kind :initarg :kind
:reader with-shadowed-bindings:kind)
(%name :initarg :name
:reader with-shadowed-bindings:name))
(:report (lambda (condition stream)
(format stream "Can't access shadowed ~A ~S."
(ecase (with-shadowed-bindings:kind condition)
(:variable "variable")
(:macro "macro")
(:function "function"))
(with-shadowed-bindings:name condition)))))
(defun with-shadowed-bindings:invalid-access (kind name)
(error 'invalid-access :kind kind :name name))
(defun (setf with-shadowed-bindings:invalid-access) (new kind name)
(declare (ignore new))
(with-shadowed-bindings:invalid-access kind name))
(defun %add-shadowing (body kind name)
(let ((invalid-access `(with-shadowed-bindings:invalid-access ',kind ',name)))
(ecase kind
(:variable
`(symbol-macrolet ((,name ,invalid-access))
(declare (ignorable ,name))
,@body))
((:function :macro)
`(flet ((,name (&rest rest)
(declare (ignore rest))
,invalid-access))
(declare (ignorable #',name))
,@body)))))
(defmacro with-shadowed-bindings (bindings &body body &environment env)
(if bindings
(reduce (lambda (binding body)
(multiple-value-call #'%add-shadowing body (%analyze binding env)))
bindings :from-end t :initial-value body)
`(progn ,@body)))