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
)
15 (make-alias namespace original new-name
)))
17 (defmacro defnamespace
(namespace &optional docstring
)
18 (check-type namespace symbol
)
19 (check-type docstring
(or null string
))
21 (pushnew ',namespace
*namespaces
*)
22 (handler-bind ((warning #'muffle-warning
))
23 (setf (documentation ',namespace
'namespace
) ,docstring
))))
25 (defgeneric make-alias
(namespace original alias
))
27 (defnamespace function
28 "The namespace of ordinary and generic functions.")
30 (defmethod make-alias ((namespace (eql 'function
))
33 (setf (fdefinition ',alias
)
34 (fdefinition ',original
))
35 (setf (documentation ',alias
'function
)
36 (documentation ',original
'function
))
37 (defalias (compiler-macro ,alias
) ,original
)))
40 "The namespace of macros.")
42 (defmethod make-alias ((namespace (eql 'macro
))
45 (setf (macro-function ',alias
)
46 (macro-function ',original
))
47 (setf (documentation ',alias
'function
)
48 (documentation ',original
'function
))))
50 (defnamespace compiler-macro
51 "The namespace of compiler macros.")
53 (defmethod make-alias ((namespace (eql 'compiler-macro
))
56 (setf (compiler-macro-function ',alias
)
57 (compiler-macro-function ',original
))
58 (setf (documentation ',alias
'compiler-macro
)
59 (documentation ',original
'compiler-macro
))))
62 "The namespace of special variables.")
64 (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 special variables.")
74 (defmethod make-alias ((namespace (eql 'constant
))
77 (define-symbol-macro ,alias
,original
)
78 (setf (documentation ',alias
'variable
)
79 (documentation ',original
'variable
))))
82 "The namespace of classes.")
84 (defmethod make-alias ((namespace (eql 'class
))
87 (setf (find-class ,alias
)
88 (find-class ,original
))
89 (setf (documentation ',alias
'type
)
90 (documentation ',original
'type
))))