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