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.
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.
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/>.
16 (/debug "loading package.lisp!")
18 (defvar *package-list* nil)
20 (defun list-all-packages ()
21 (copy-list *package-list*))
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*))
34 (defun resolve-package-list (packages)
36 (dolist (package (mapcar #'find-package-or-fail packages))
37 (pushnew package result :test #'eq))
40 (defun make-package (name &key use)
43 (resolve-package-list use)))
46 (and (objectp x) (in "symbols" x)))
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)
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)))
60 (defun package-name (package-designator)
61 (let ((package (find-package-or-fail package-designator)))
62 (oget package "packageName")))
64 (defun %package-symbols (package-designator)
65 (let ((package (find-package-or-fail package-designator)))
66 (oget package "symbols")))
68 (defun package-use-list (package-designator)
69 (let ((package (find-package-or-fail package-designator)))
70 (oget package "use")))
72 (defun %package-external-symbols (package-designator)
73 (let ((package (find-package-or-fail package-designator)))
74 (oget package "exports")))
76 (defvar *common-lisp-package*
79 (defvar *user-package*
80 (make-package "CL-USER" :use (list *common-lisp-package*)))
82 (defvar *keyword-package*
83 (make-package "KEYWORD"))
86 (and (symbolp x) (eq (symbol-package x) *keyword-package*)))
88 (defvar *package* *common-lisp-package*)
90 (defmacro in-package (string-designator)
91 `(eval-when (:compile-toplevel :load-toplevel :execute)
92 (setq *package* (find-package-or-fail ',string-designator))))
94 (defmacro defpackage (package &rest options)
96 (dolist (option options)
99 (setf use (append use (cdr option))))))
100 `(eval-when (:compile-toplevel :load-toplevel :execute)
101 (%defpackage ',(string package) ',use))))
103 (defun redefine-package (package use)
104 (setf (oget package "use") use)
107 (defun %defpackage (name use)
108 (let ((package (find-package name))
109 (use (resolve-package-list use)))
111 (redefine-package package use)
112 (%make-package name use))))
114 ;; This function is used internally to initialize the CL package
115 ;; with the symbols built during bootstrap.
116 (defun %intern-symbol (symbol)
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))))
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)))
136 (values (oget externals name) :external))
138 (values (oget symbols name) :internal))
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)))))))))
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)
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)
155 (values symbol foundp)
156 (let ((symbols (%package-symbols package)))
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))
164 (funcall *intern-hook* symbol))
165 (setf (oget symbols name) symbol)
166 (values symbol nil)))))))
168 (defun symbol-package (symbol)
169 (unless (symbolp symbol)
170 (error "`~S' is not a symbol." symbol))
171 (oget symbol "package"))
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))))
178 (defun %map-external-symbols (function package)
179 (map-for-in function (%package-external-symbols package)))
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)))
186 (defun %map-all-symbols (function)
187 (dolist (package *package-list*)
188 (map-for-in function (%package-symbols package))))
190 (defun %map-all-external-symbols (function)
191 (dolist (package *package-list*)
192 (map-for-in function (%package-external-symbols package))))
194 (defmacro do-symbols ((var &optional (package '*package*) result-form)
198 (lambda (,var) ,@body)
199 (find-package ,package))
202 (defmacro do-external-symbols ((var &optional (package '*package*)
206 (%map-external-symbols
207 (lambda (,var) ,@body)
208 (find-package ,package))
211 (defmacro do-all-symbols ((var &optional result-form) &body body)
212 `(block nil (%map-all-symbols (lambda (,var) ,@body)) ,result-form))
214 (defmacro do-all-external-symbols ((var &optional result-form) &body body)
215 `(block nil (%map-all-external-symbols (lambda (,var) ,@body)) ,result-form))
217 (defun find-all-symbols (string &optional external-only)
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))))))