1 ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
3 ;;; --- Creating aliases in CL namespaces
6 (in-package :iolib.base
)
8 (defvar *namespaces
* nil
)
10 (defmacro defalias
(alias original
)
11 (destructuring-bind (namespace new-name
)
13 (assert (member namespace
*namespaces
*) (namespace)
14 "Namespace ~A does not exist" namespace
)
16 ,@(make-alias namespace original new-name
)
19 (defmacro defnamespace
(namespace &optional docstring
)
20 (check-type namespace symbol
)
21 (check-type docstring
(or null string
))
23 (pushnew ',namespace
*namespaces
*)
25 `((handler-bind ((warning #'muffle-warning
))
26 (setf (documentation ',namespace
'namespace
) ,docstring
))))
29 (defgeneric make-alias
(namespace original alias
))
31 (defnamespace function
32 "The namespace of ordinary and generic functions.")
34 (defmethod make-alias ((namespace (eql 'function
))
36 `((setf (fdefinition ',alias
)
37 (fdefinition ',original
))
38 (setf (documentation ',alias
'function
)
39 (documentation ',original
'function
))
40 (defalias (compiler-macro ,alias
) ,original
)))
43 "The namespace of macros.")
45 (defmethod make-alias ((namespace (eql 'macro
))
47 `((setf (macro-function ',alias
)
48 (macro-function ',original
))
49 (setf (documentation ',alias
'function
)
50 (documentation ',original
'function
))))
52 (defnamespace compiler-macro
53 "The namespace of compiler macros.")
55 (defmethod make-alias ((namespace (eql 'compiler-macro
))
57 `((setf (compiler-macro-function ',alias
)
58 (compiler-macro-function ',original
))
59 (setf (documentation ',alias
'compiler-macro
)
60 (documentation ',original
'compiler-macro
))))
63 "The namespace of special variables.")
65 (defmethod make-alias ((namespace (eql 'special
))
67 `((define-symbol-macro ,alias
,original
)
68 (setf (documentation ',alias
'variable
)
69 (documentation ',original
'variable
))))
71 (defnamespace constant
72 "The namespace of constant variables.")
74 (defmethod make-alias ((namespace (eql 'constant
))
76 `((define-symbol-macro ,alias
,original
)
77 (setf (documentation ',alias
'variable
)
78 (documentation ',original
'variable
))))
81 "The namespace of classes.")
83 (defmethod make-alias ((namespace (eql 'class
))
85 `((setf (find-class ,alias
)
86 (find-class ,original
))
87 (setf (documentation ',alias
'type
)
88 (documentation ',original
'type
))))