src/base/defalias.lisp

   1 ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; --- Creating aliases in CL namespaces
   4 ;;;
   5
   6 (in-package :iolib.base)
   7
   8 (defvar *namespaces* nil)
   9
  10 (defmacro defalias (alias original)
  11   (destructuring-bind (namespace new-name)
  12       alias
  13     (assert (member namespace *namespaces*) (namespace)
  14             "Namespace ~A does not exist" namespace)
  15     (make-alias namespace original new-name)))
  16
  17 (defmacro defnamespace (namespace &optional docstring)
  18   (check-type namespace symbol)
  19   (check-type docstring (or null string))
  20   `(progn
  21      (pushnew ',namespace *namespaces*)
  22      (handler-bind ((warning #'muffle-warning))
  23        (setf (documentation ',namespace 'namespace) ,docstring))))
  24
  25 (defgeneric make-alias (namespace original alias))
  26
  27 (defnamespace function
  28   "The namespace of ordinary and generic functions.")
  29
  30 (defmethod make-alias ((namespace (eql 'function))
  31                        original alias)
  32   `(progn
  33      (setf (fdefinition ',alias)
  34            (fdefinition ',original))
  35      (setf (documentation ',alias 'function)
  36            (documentation ',original 'function))
  37      (defalias (compiler-macro ,alias) ,original)))
  38
  39 (defnamespace macro
  40   "The namespace of macros.")
  41
  42 (defmethod make-alias ((namespace (eql 'macro))
  43                        original alias)
  44   `(progn
  45      (setf (macro-function ',alias)
  46            (macro-function ',original))
  47      (setf (documentation ',alias 'function)
  48            (documentation ',original 'function))))
  49
  50 (defnamespace compiler-macro
  51   "The namespace of compiler macros.")
  52
  53 (defmethod make-alias ((namespace (eql 'compiler-macro))
  54                        original alias)
  55   `(progn
  56      (setf (compiler-macro-function ',alias)
  57            (compiler-macro-function ',original))
  58      (setf (documentation ',alias 'compiler-macro)
  59            (documentation ',original 'compiler-macro))))
  60
  61 (defnamespace special
  62   "The namespace of special variables.")
  63
  64 (defmethod make-alias ((namespace (eql 'special))
  65                        original alias)
  66   `(progn
  67      (define-symbol-macro ,alias ,original)
  68      (setf (documentation ',alias 'variable)
  69            (documentation ',original 'variable))))
  70
  71 (defnamespace constant
  72   "The namespace of constant variables.")
  73
  74 (defmethod make-alias ((namespace (eql 'constant))
  75                        original alias)
  76   `(progn
  77      (define-symbol-macro ,alias ,original)
  78      (setf (documentation ',alias 'variable)
  79            (documentation ',original 'variable))))
  80
  81 (defnamespace class
  82   "The namespace of classes.")
  83
  84 (defmethod make-alias ((namespace (eql 'class))
  85                        original alias)
  86   `(progn
  87      (setf (find-class ,alias)
  88            (find-class ,original))
  89      (setf (documentation ',alias 'type)
  90            (documentation ',original 'type))))