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     `(progn
  16        ,@(make-alias namespace original new-name)
  17        ',new-name)))
  18
  19 (defmacro defnamespace (namespace &optional docstring)
  20   (check-type namespace symbol)
  21   (check-type docstring (or null string))
  22   `(progn
  23      (pushnew ',namespace *namespaces*)
  24      ,@(when docstring
  25          `((handler-bind ((warning #'muffle-warning))
  26              (setf (documentation ',namespace 'namespace) ,docstring))))
  27      ',namespace))
  28
  29 (defgeneric make-alias (namespace original alias))
  30
  31 (defnamespace function
  32   "The namespace of ordinary and generic functions.")
  33
  34 (defmethod make-alias ((namespace (eql 'function))
  35                        original alias)
  36   `((setf (fdefinition ',alias)
  37           (fdefinition ',original))
  38     (setf (documentation ',alias 'function)
  39           (documentation ',original 'function))
  40     (defalias (compiler-macro ,alias) ,original)))
  41
  42 (defnamespace macro
  43   "The namespace of macros.")
  44
  45 (defmethod make-alias ((namespace (eql 'macro))
  46                        original alias)
  47   `((setf (macro-function ',alias)
  48           (macro-function ',original))
  49     (setf (documentation ',alias 'function)
  50           (documentation ',original 'function))))
  51
  52 (defnamespace compiler-macro
  53   "The namespace of compiler macros.")
  54
  55 (defmethod make-alias ((namespace (eql 'compiler-macro))
  56                        original alias)
  57   `((setf (compiler-macro-function ',alias)
  58           (compiler-macro-function ',original))
  59     (setf (documentation ',alias 'compiler-macro)
  60           (documentation ',original 'compiler-macro))))
  61
  62 (defnamespace special
  63   "The namespace of special variables.")
  64
  65 (defmethod make-alias ((namespace (eql 'special))
  66                        original alias)
  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   `((define-symbol-macro ,alias ,original)
  77     (setf (documentation ',alias 'variable)
  78           (documentation ',original 'variable))))
  79
  80 (defnamespace class
  81   "The namespace of classes.")
  82
  83 (defmethod make-alias ((namespace (eql 'class))
  84                        original alias)
  85   `((setf (find-class ,alias)
  86           (find-class ,original))
  87     (setf (documentation ',alias 'type)
  88           (documentation ',original 'type))))