Remove references to non-symbol literals
[jscl.git] / 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))))