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   (copy-list *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          (exports (%package-external-symbols package)))
  89     (oset symbol "package" package)
  90     (oset symbols (symbol-name symbol) symbol)
  91     ;; Turn keywords self-evaluated and export them.
  92     (when (eq package *keyword-package*)
  93       (oset symbol "value" symbol)
  94       (oset exports (symbol-name symbol) symbol))))
  95
  96 (defun find-symbol (name &optional (package *package*))
  97   (let* ((package (find-package-or-fail package))
  98          (externals (%package-external-symbols package))
  99          (symbols (%package-symbols package)))
 100     (cond
 101       ((in name externals)
 102        (values (oget externals name) :external))
 103       ((in name symbols)
 104        (values (oget symbols name) :internal))
 105       (t
 106        (dolist (used (package-use-list package) (values nil nil))
 107          (let ((exports (%package-external-symbols used)))
 108            (when (in name exports)
 109              (return (values (oget exports name) :inherit)))))))))
 110
 111
 112 ;;; It is a function to call when a symbol is interned. The function
 113 ;;; is invoked with the already interned symbol as argument.
 114 (defvar *intern-hook* nil)
 115
 116 (defun intern (name &optional (package *package*))
 117   (let ((package (find-package-or-fail package)))
 118     (multiple-value-bind (symbol foundp)
 119         (find-symbol name package)
 120       (if foundp
 121           (values symbol foundp)
 122           (let ((symbols (%package-symbols package)))
 123             (oget symbols name)
 124             (let ((symbol (make-symbol name)))
 125               (oset symbol "package" package)
 126               (when (eq package *keyword-package*)
 127                 (oset symbol "value" symbol)
 128                 (export (list symbol) package))
 129               (when *intern-hook*
 130                 (funcall *intern-hook* symbol))
 131               (oset symbols name symbol)
 132               (values symbol nil)))))))
 133
 134 (defun symbol-package (symbol)
 135   (unless (symbolp symbol)
 136     (error "`~S' is not a symbol." symbol))
 137   (oget symbol "package"))
 138
 139 (defun export (symbols &optional (package *package*))
 140   (let ((exports (%package-external-symbols package)))
 141     (dolist (symb symbols t)
 142       (oset exports (symbol-name symb) symb))))