src/package.lisp

   1 ;;; package.lisp ---
   2
   3 ;; JSCL is free software: you can redistribute it and/or
   4 ;; modify it under the terms of the GNU General Public License as
   5 ;; published by the Free Software Foundation, either version 3 of the
   6 ;; License, or (at your option) any later version.
   7 ;;
   8 ;; JSCL is distributed in the hope that it will be useful, but
   9 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  10 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11 ;; General Public License for more details.
  12 ;;
  13 ;; You should have received a copy of the GNU General Public License
  14 ;; along with JSCL.  If not, see <http://www.gnu.org/licenses/>.
  15
  16 (defvar *package-list* nil)
  17
  18 (defun list-all-packages ()
  19   *package-list*)
  20
  21 (defun make-package (name &key use)
  22   (let ((package (new))
  23         (use (mapcar #'find-package-or-fail use)))
  24     (oset package "packageName" name)
  25     (oset package "symbols" (new))
  26     (oset package "exports" (new))
  27     (oset package "use" use)
  28     (push package *package-list*)
  29     package))
  30
  31 (defun packagep (x)
  32   (and (objectp x) (in "symbols" x)))
  33
  34 (defun find-package (package-designator)
  35   (when (packagep package-designator)
  36     (return-from find-package package-designator))
  37   (let ((name (string package-designator)))
  38     (dolist (package *package-list*)
  39       (when (string= (package-name package) name)
  40         (return package)))))
  41
  42 (defun find-package-or-fail (package-designator)
  43   (or (find-package package-designator)
  44       (error "The name `~S' does not designate any package." package-designator)))
  45
  46 (defun package-name (package-designator)
  47   (let ((package (find-package-or-fail package-designator)))
  48     (oget package "packageName")))
  49
  50 (defun %package-symbols (package-designator)
  51   (let ((package (find-package-or-fail package-designator)))
  52     (oget package "symbols")))
  53
  54 (defun package-use-list (package-designator)
  55   (let ((package (find-package-or-fail package-designator)))
  56     (oget package "use")))
  57
  58 (defun %package-external-symbols (package-designator)
  59   (let ((package (find-package-or-fail package-designator)))
  60     (oget package "exports")))
  61
  62 (defvar *common-lisp-package*
  63   (make-package "CL"))
  64
  65 (defvar *user-package*
  66   (make-package "CL-USER" :use (list *common-lisp-package*)))
  67
  68 (defvar *keyword-package*
  69   (make-package "KEYWORD"))
  70
  71 (defun keywordp (x)
  72   (and (symbolp x) (eq (symbol-package x) *keyword-package*)))
  73
  74 (defvar *package* *common-lisp-package*)
  75
  76 (defmacro in-package (package-designator)
  77   `(eval-when-compile
  78      (setq *package* (find-package-or-fail ,package-designator))))
  79
  80 ;; This function is used internally to initialize the CL package
  81 ;; with the symbols built during bootstrap.
  82 (defun %intern-symbol (symbol)
  83   (let* ((package
  84           (if (in "package" symbol)
  85               (find-package-or-fail (oget symbol "package"))
  86               *common-lisp-package*))
  87          (symbols (%package-symbols package)))
  88     (oset symbol "package" package)
  89     (when (eq package *keyword-package*)
  90       (oset symbol "value" symbol))
  91     (oset symbols (symbol-name symbol) symbol)))
  92
  93 (defun find-symbol (name &optional (package *package*))
  94   (let* ((package (find-package-or-fail package))
  95          (externals (%package-external-symbols package))
  96          (symbols (%package-symbols package)))
  97     (cond
  98       ((in name externals)
  99        (values (oget externals name) :external))
 100       ((in name symbols)
 101        (values (oget symbols name) :internal))
 102       (t
 103        (dolist (used (package-use-list package) (values nil nil))
 104          (let ((exports (%package-external-symbols used)))
 105            (when (in name exports)
 106              (return (values (oget exports name) :inherit)))))))))
 107
 108
 109 ;;; It is a function to call when a symbol is interned. The function
 110 ;;; is invoked with the already interned symbol as argument.
 111 (defvar *intern-hook* nil)
 112
 113 (defun intern (name &optional (package *package*))
 114   (let ((package (find-package-or-fail package)))
 115     (multiple-value-bind (symbol foundp)
 116         (find-symbol name package)
 117       (if foundp
 118           (values symbol foundp)
 119           (let ((symbols (%package-symbols package)))
 120             (oget symbols name)
 121             (let ((symbol (make-symbol name)))
 122               (oset symbol "package" package)
 123               (when (eq package *keyword-package*)
 124                 (oset symbol "value" symbol)
 125                 (export (list symbol) package))
 126               (when *intern-hook*
 127                 (funcall *intern-hook* symbol))
 128               (oset symbols name symbol)
 129               (values symbol nil)))))))
 130
 131 (defun symbol-package (symbol)
 132   (unless (symbolp symbol)
 133     (error "`~S' is not a symbol." symbol))
 134   (oget symbol "package"))
 135
 136 (defun export (symbols &optional (package *package*))
 137   (let ((exports (%package-external-symbols package)))
 138     (dolist (symb symbols t)
 139       (oset exports (symbol-name symb) symb))))