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     (setf (oget package "packageName") name)
  25     (setf (oget package "symbols") (new))
  26     (setf (oget package "exports") (new))
  27     (setf (oget 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 (string-designator)
  77   `(eval-when-compile
  78      (setq *package* (find-package-or-fail ',string-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     (setf (oget symbol "package") package)
  90     (setf (oget symbols (symbol-name symbol)) symbol)
  91     ;; Turn keywords self-evaluated and export them.
  92     (when (eq package *keyword-package*)
  93       (setf (oget symbol "value") symbol)
  94       (setf (oget 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               (setf (oget symbol "package") package)
 126               (when (eq package *keyword-package*)
 127                 (setf (oget symbol "value") symbol)
 128                 (export (list symbol) package))
 129               (when *intern-hook*
 130                 (funcall *intern-hook* symbol))
 131               (setf (oget 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       (setf (oget exports (symbol-name symb)) symb))))
 143
 144 (defun %map-external-symbols (function package)
 145   (map-for-in function (%package-external-symbols package)))
 146
 147 (defun %map-symbols (function package)
 148   (map-for-in function (%package-symbols package))
 149   (dolist (used (package-use-list package))
 150     (%map-external-symbols function used)))
 151
 152 (defun %map-all-symbols (function)
 153   (dolist (package *package-list*)
 154     (map-for-in function (%package-symbols package))))
 155
 156 (defmacro do-symbols ((var &optional (package '*package*) result-form)
 157                       &body body)
 158   `(block nil
 159      (%map-symbols
 160       (lambda (,var) ,@body)
 161       (find-package ,package))
 162      ,result-form))
 163
 164 (defmacro do-external-symbols ((var &optional (package '*package*)
 165                                               result-form)
 166                                &body body)
 167   `(block nil
 168      (%map-external-symbols
 169       (lambda (,var) ,@body)
 170       (find-package ,package))
 171      ,result-form))
 172
 173 (defmacro do-all-symbols ((var &optional result-form) &body body)
 174   `(block nil (%map-all-symbols (lambda (,var) ,@body)) ,result-form))
 175
 176 (defun find-all-symbols (string)
 177   (let (symbols)
 178     (dolist (package *package-list* symbols)
 179       (multiple-value-bind (symbol status) (find-symbol string package)
 180         (when status
 181           (pushnew symbol symbols :test #'eq))))))