/
defalias.lisp
88 lines (71 loc) · 2.7 KB
/
defalias.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
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
;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
;;;
;;; --- Creating aliases in CL namespaces
;;;
(in-package :iolib/base)
(defvar *namespaces* nil)
(defmacro defalias (alias original)
(destructuring-bind (namespace new-name)
alias
(assert (member namespace *namespaces*) (namespace)
"Namespace ~A does not exist" namespace)
`(progn
,@(make-alias namespace original new-name)
',new-name)))
(defmacro defnamespace (namespace &optional docstring)
(check-type namespace symbol)
(check-type docstring (or null string))
`(progn
(pushnew ',namespace *namespaces*)
,@(when docstring
`((handler-bind ((warning #'muffle-warning))
(setf (documentation ',namespace 'namespace) ,docstring))))
',namespace))
(defgeneric make-alias (namespace original alias))
(defnamespace function
"The namespace of ordinary and generic functions.")
(defmethod make-alias ((namespace (eql 'function))
original alias)
`((setf (fdefinition ',alias)
(fdefinition ',original))
(setf (documentation ',alias 'function)
(documentation ',original 'function))
(defalias (compiler-macro ,alias) ,original)))
(defnamespace macro
"The namespace of macros.")
(defmethod make-alias ((namespace (eql 'macro))
original alias)
`((setf (macro-function ',alias)
(macro-function ',original))
(setf (documentation ',alias 'function)
(documentation ',original 'function))))
(defnamespace compiler-macro
"The namespace of compiler macros.")
(defmethod make-alias ((namespace (eql 'compiler-macro))
original alias)
`((setf (compiler-macro-function ',alias)
(compiler-macro-function ',original))
(setf (documentation ',alias 'compiler-macro)
(documentation ',original 'compiler-macro))))
(defnamespace special
"The namespace of special variables.")
(defmethod make-alias ((namespace (eql 'special))
original alias)
`((define-symbol-macro ,alias ,original)
(setf (documentation ',alias 'variable)
(documentation ',original 'variable))))
(defnamespace constant
"The namespace of constant variables.")
(defmethod make-alias ((namespace (eql 'constant))
original alias)
`((define-symbol-macro ,alias ,original)
(setf (documentation ',alias 'variable)
(documentation ',original 'variable))))
(defnamespace class
"The namespace of classes.")
(defmethod make-alias ((namespace (eql 'class))
original alias)
`((setf (find-class ,alias)
(find-class ,original))
(setf (documentation ',alias 'type)
(documentation ',original 'type))))