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 (/debug "loading package.lisp!")
  17
  18 (defvar *package-list* nil)
  19
  20 (defun list-all-packages ()
  21   (copy-list *package-list*))
  22
  23 (defun make-package (name &key use)
  24   (let ((package (new))
  25         (use (mapcar #'find-package-or-fail use)))
  26     (setf (oget package "packageName") name)
  27     (setf (oget package "symbols") (new))
  28     (setf (oget package "exports") (new))
  29     (setf (oget package "use") use)
  30     (push package *package-list*)
  31     package))
  32
  33 (defun packagep (x)
  34   (and (objectp x) (in "symbols" x)))
  35
  36 (defun find-package (package-designator)
  37   (when (packagep package-designator)
  38     (return-from find-package package-designator))
  39   (let ((name (string package-designator)))
  40     (dolist (package *package-list*)
  41       (when (string= (package-name package) name)
  42         (return package)))))
  43
  44 (defun find-package-or-fail (package-designator)
  45   (or (find-package package-designator)
  46       (error "The name `~S' does not designate any package." package-designator)))
  47
  48 (defun package-name (package-designator)
  49   (let ((package (find-package-or-fail package-designator)))
  50     (oget package "packageName")))
  51
  52 (defun %package-symbols (package-designator)
  53   (let ((package (find-package-or-fail package-designator)))
  54     (oget package "symbols")))
  55
  56 (defun package-use-list (package-designator)
  57   (let ((package (find-package-or-fail package-designator)))
  58     (oget package "use")))
  59
  60 (defun %package-external-symbols (package-designator)
  61   (let ((package (find-package-or-fail package-designator)))
  62     (oget package "exports")))
  63
  64 (defvar *common-lisp-package*
  65   (make-package "CL"))
  66
  67 (defvar *user-package*
  68   (make-package "CL-USER" :use (list *common-lisp-package*)))
  69
  70 (defvar *keyword-package*
  71   (make-package "KEYWORD"))
  72
  73 (defun keywordp (x)
  74   (and (symbolp x) (eq (symbol-package x) *keyword-package*)))
  75
  76 (defvar *package* *common-lisp-package*)
  77
  78 (defmacro in-package (string-designator)
  79   `(eval-when (:compile-toplevel :load-toplevel :execute)
  80      (setq *package* (find-package-or-fail ',string-designator))))
  81
  82 ;; This function is used internally to initialize the CL package
  83 ;; with the symbols built during bootstrap.
  84 (defun %intern-symbol (symbol)
  85   (let* ((package
  86           (if (in "package" symbol)
  87               (find-package-or-fail (oget symbol "package"))
  88               *common-lisp-package*))
  89          (symbols (%package-symbols package))
  90          (exports (%package-external-symbols package)))
  91     (setf (oget symbol "package") package)
  92     (setf (oget symbols (symbol-name symbol)) symbol)
  93     ;; Turn keywords self-evaluated and export them.
  94     (when (eq package *keyword-package*)
  95       (setf (oget symbol "value") symbol)
  96       (setf (oget exports (symbol-name symbol)) symbol))))
  97
  98 (defun find-symbol (name &optional (package *package*))
  99   (let* ((package (find-package-or-fail package))
 100          (externals (%package-external-symbols package))
 101          (symbols (%package-symbols package)))
 102     (cond
 103       ((in name externals)
 104        (values (oget externals name) :external))
 105       ((in name symbols)
 106        (values (oget symbols name) :internal))
 107       (t
 108        (dolist (used (package-use-list package) (values nil nil))
 109          (let ((exports (%package-external-symbols used)))
 110            (when (in name exports)
 111              (return (values (oget exports name) :inherit)))))))))
 112
 113
 114 ;;; It is a function to call when a symbol is interned. The function
 115 ;;; is invoked with the already interned symbol as argument.
 116 (defvar *intern-hook* nil)
 117
 118 (defun intern (name &optional (package *package*))
 119   (let ((package (find-package-or-fail package)))
 120     (multiple-value-bind (symbol foundp)
 121         (find-symbol name package)
 122       (if foundp
 123           (values symbol foundp)
 124           (let ((symbols (%package-symbols package)))
 125             (oget symbols name)
 126             (let ((symbol (make-symbol name)))
 127               (setf (oget symbol "package") package)
 128               (when (eq package *keyword-package*)
 129                 (setf (oget symbol "value") symbol)
 130                 (export (list symbol) package))
 131               (when *intern-hook*
 132                 (funcall *intern-hook* symbol))
 133               (setf (oget symbols name) symbol)
 134               (values symbol nil)))))))
 135
 136 (defun symbol-package (symbol)
 137   (unless (symbolp symbol)
 138     (error "`~S' is not a symbol." symbol))
 139   (oget symbol "package"))
 140
 141 (defun export (symbols &optional (package *package*))
 142   (let ((exports (%package-external-symbols package)))
 143     (dolist (symb symbols t)
 144       (setf (oget exports (symbol-name symb)) symb))))
 145
 146 (defun %map-external-symbols (function package)
 147   (map-for-in function (%package-external-symbols package)))
 148
 149 (defun %map-symbols (function package)
 150   (map-for-in function (%package-symbols package))
 151   (dolist (used (package-use-list package))
 152     (%map-external-symbols function used)))
 153
 154 (defun %map-all-symbols (function)
 155   (dolist (package *package-list*)
 156     (map-for-in function (%package-symbols package))))
 157
 158 (defun %map-all-external-symbols (function)
 159   (dolist (package *package-list*)
 160     (map-for-in function (%package-external-symbols package))))
 161
 162 (defmacro do-symbols ((var &optional (package '*package*) result-form)
 163                       &body body)
 164   `(block nil
 165      (%map-symbols
 166       (lambda (,var) ,@body)
 167       (find-package ,package))
 168      ,result-form))
 169
 170 (defmacro do-external-symbols ((var &optional (package '*package*)
 171                                               result-form)
 172                                &body body)
 173   `(block nil
 174      (%map-external-symbols
 175       (lambda (,var) ,@body)
 176       (find-package ,package))
 177      ,result-form))
 178
 179 (defmacro do-all-symbols ((var &optional result-form) &body body)
 180   `(block nil (%map-all-symbols (lambda (,var) ,@body)) ,result-form))
 181
 182 (defmacro do-all-external-symbols ((var &optional result-form) &body body)
 183   `(block nil (%map-all-external-symbols (lambda (,var) ,@body)) ,result-form))
 184
 185 (defun find-all-symbols (string &optional external-only)
 186   (let (symbols)
 187     (dolist (package *package-list* symbols)
 188       (multiple-value-bind (symbol status) (find-symbol string package)
 189         (when (if external-only (eq status :external) status)
 190           (pushnew symbol symbols :test #'eq))))))