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