src/package.lisp

   1 ;; Packages
   2
   3 (defvar *package-list* nil)
   4
   5 (defun list-all-packages ()
   6   *package-list*)
   7
   8 (defun make-package (name &key use)
   9   (let ((package (new))
  10         (use (mapcar #'find-package-or-fail use)))
  11     (oset package "packageName" name)
  12     (oset package "symbols" (new))
  13     (oset package "exports" (new))
  14     (oset package "use" use)
  15     (push package *package-list*)
  16     package))
  17
  18 (defun packagep (x)
  19   (and (objectp x) (in "symbols" x)))
  20
  21 (defun find-package (package-designator)
  22   (when (packagep package-designator)
  23     (return-from find-package package-designator))
  24   (let ((name (string package-designator)))
  25     (dolist (package *package-list*)
  26       (when (string= (package-name package) name)
  27         (return package)))))
  28
  29 (defun find-package-or-fail (package-designator)
  30   (or (find-package package-designator)
  31       (error "Package unknown.")))
  32
  33 (defun package-name (package-designator)
  34   (let ((package (find-package-or-fail package-designator)))
  35     (oget package "packageName")))
  36
  37 (defun %package-symbols (package-designator)
  38   (let ((package (find-package-or-fail package-designator)))
  39     (oget package "symbols")))
  40
  41 (defun package-use-list (package-designator)
  42   (let ((package (find-package-or-fail package-designator)))
  43     (oget package "use")))
  44
  45 (defun %package-external-symbols (package-designator)
  46   (let ((package (find-package-or-fail package-designator)))
  47     (oget package "exports")))
  48
  49 (defvar *common-lisp-package*
  50   (make-package "CL"))
  51
  52 (defvar *js-package*
  53   (make-package "JS"))
  54
  55 (defvar *user-package*
  56   (make-package "CL-USER" :use (list *common-lisp-package*)))
  57
  58 (defvar *keyword-package*
  59   (make-package "KEYWORD"))
  60
  61 (defun keywordp (x)
  62   (and (symbolp x) (eq (symbol-package x) *keyword-package*)))
  63
  64 (defvar *package* *common-lisp-package*)
  65
  66 (defmacro in-package (package-designator)
  67   `(eval-when-compile
  68      (setq *package* (find-package-or-fail ,package-designator))))
  69
  70 ;; This function is used internally to initialize the CL package
  71 ;; with the symbols built during bootstrap.
  72 (defun %intern-symbol (symbol)
  73   (let* ((package
  74           (if (in "package" symbol)
  75               (find-package-or-fail (oget symbol "package"))
  76               *common-lisp-package*))
  77          (symbols (%package-symbols package)))
  78     (oset symbol "package" package)
  79     (when (eq package *keyword-package*)
  80       (oset symbol "value" symbol))
  81     (oset symbols (symbol-name symbol) symbol)))
  82
  83 (defun find-symbol (name &optional (package *package*))
  84   (let* ((package (find-package-or-fail package))
  85          (externals (%package-external-symbols package))
  86          (symbols (%package-symbols package)))
  87     (cond
  88       ((in name externals)
  89        (values (oget externals name) :external))
  90       ((in name symbols)
  91        (values (oget symbols name) :internal))
  92       (t
  93        (dolist (used (package-use-list package) (values nil nil))
  94          (let ((exports (%package-external-symbols used)))
  95            (when (in name exports)
  96              (return (values (oget exports name) :inherit)))))))))
  97
  98 (defun intern (name &optional (package *package*))
  99   (let ((package (find-package-or-fail package)))
 100     (multiple-value-bind (symbol foundp)
 101         (find-symbol name package)
 102       (if foundp
 103           (values symbol foundp)
 104           (let ((symbols (%package-symbols package)))
 105             (oget symbols name)
 106             (let ((symbol (make-symbol name)))
 107               (oset symbol "package" package)
 108               (when (eq package *keyword-package*)
 109                 (oset symbol "value" symbol)
 110                 (export (list symbol) package))
 111               (when (eq package *js-package*)
 112                 (let ((sym-name (symbol-name symbol))
 113                       (args (gensym)))
 114                   ;; Generate a trampoline to call the JS function
 115                   ;; properly. This trampoline is very inefficient,
 116                   ;; but it still works. Ideas to optimize this are
 117                   ;; provide a special lambda keyword
 118                   ;; cl::&rest-vector to avoid list argument
 119                   ;; consing, as well as allow inline declarations.
 120                   (fset symbol
 121                         (eval `(lambda (&rest ,args)
 122                                  (let ((,args (list-to-vector ,args)))
 123                                    (%js-call (%js-vref ,sym-name) ,args)))))
 124                   ;; Define it as a symbol macro to access to the
 125                   ;; Javascript variable literally.
 126                   (%define-symbol-macro symbol `(%js-vref ,(string symbol)))))
 127               (oset symbols name symbol)
 128               (values symbol nil)))))))
 129
 130 (defun symbol-package (symbol)
 131   (unless (symbolp symbol)
 132     (error "it is not a symbol"))
 133   (oget symbol "package"))
 134
 135 (defun export (symbols &optional (package *package*))
 136   (let ((exports (%package-external-symbols package)))
 137     (dolist (symb symbols t)
 138       (oset exports (symbol-name symb) symb))))