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   *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 *js-package*
  66   (make-package "JS"))
  67
  68 (defvar *user-package*
  69   (make-package "CL-USER" :use (list *common-lisp-package*)))
  70
  71 (defvar *keyword-package*
  72   (make-package "KEYWORD"))
  73
  74 (defun keywordp (x)
  75   (and (symbolp x) (eq (symbol-package x) *keyword-package*)))
  76
  77 (defvar *package* *common-lisp-package*)
  78
  79 (defmacro in-package (package-designator)
  80   `(eval-when-compile
  81      (setq *package* (find-package-or-fail ,package-designator))))
  82
  83 ;; This function is used internally to initialize the CL package
  84 ;; with the symbols built during bootstrap.
  85 (defun %intern-symbol (symbol)
  86   (let* ((package
  87           (if (in "package" symbol)
  88               (find-package-or-fail (oget symbol "package"))
  89               *common-lisp-package*))
  90          (symbols (%package-symbols package)))
  91     (oset symbol "package" package)
  92     (when (eq package *keyword-package*)
  93       (oset symbol "value" symbol))
  94     (oset symbols (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 (defun intern (name &optional (package *package*))
 112   (let ((package (find-package-or-fail package)))
 113     (multiple-value-bind (symbol foundp)
 114         (find-symbol name package)
 115       (if foundp
 116           (values symbol foundp)
 117           (let ((symbols (%package-symbols package)))
 118             (oget symbols name)
 119             (let ((symbol (make-symbol name)))
 120               (oset symbol "package" package)
 121               (when (eq package *keyword-package*)
 122                 (oset symbol "value" symbol)
 123                 (export (list symbol) package))
 124               (when (eq package *js-package*)
 125                 (let ((sym-name (symbol-name symbol))
 126                       (args (gensym)))
 127                   ;; Generate a trampoline to call the JS function
 128                   ;; properly. This trampoline is very inefficient,
 129                   ;; but it still works. Ideas to optimize this are
 130                   ;; provide a special lambda keyword
 131                   ;; cl::&rest-vector to avoid list argument
 132                   ;; consing, as well as allow inline declarations.
 133                   (fset symbol
 134                         (eval `(lambda (&rest ,args)
 135                                  (let ((,args (list-to-vector ,args)))
 136                                    (%js-call (%js-vref ,sym-name) ,args)))))
 137                   ;; Define it as a symbol macro to access to the
 138                   ;; Javascript variable literally.
 139                   (%define-symbol-macro symbol `(%js-vref ,(string symbol)))))
 140               (oset symbols name symbol)
 141               (values symbol nil)))))))
 142
 143 (defun symbol-package (symbol)
 144   (unless (symbolp symbol)
 145     (error "`~S' is not a symbol." symbol))
 146   (oget symbol "package"))
 147
 148 (defun export (symbols &optional (package *package*))
 149   (let ((exports (%package-external-symbols package)))
 150     (dolist (symb symbols t)
 151       (oset exports (symbol-name symb) symb))))