+
+ ;; Packages
+
+ (defvar *package-list* nil)
+
+ (defun list-all-packages ()
+ *package-list*)
+
+ (defun make-package (name &optional use)
+ (let ((package (new))
+ (use (mapcar #'find-package-or-fail use)))
+ (oset package "packageName" name)
+ (oset package "symbols" (new))
+ (oset package "exports" (new))
+ (oset package "use" use)
+ (push package *package-list*)
+ package))
+
+ (defun packagep (x)
+ (and (objectp x) (in "symbols" x)))
+
+ (defun find-package (package-designator)
+ (when (packagep package-designator)
+ (return-from find-package package-designator))
+ (let ((name (string package-designator)))
+ (dolist (package *package-list*)
+ (when (string= (package-name package) name)
+ (return package)))))
+
+ (defun find-package-or-fail (package-designator)
+ (or (find-package package-designator)
+ (error "Package unknown.")))
+
+ (defun package-name (package-designator)
+ (let ((package (find-package-or-fail package-designator)))
+ (oget package "packageName")))
+
+ (defun %package-symbols (package-designator)
+ (let ((package (find-package-or-fail package-designator)))
+ (oget package "symbols")))
+
+ (defun package-use-list (package-designator)
+ (let ((package (find-package-or-fail package-designator)))
+ (oget package "use")))
+
+ (defun %package-external-symbols (package-designator)
+ (let ((package (find-package-or-fail package-designator)))
+ (oget package "exports")))
+
+ (defvar *common-lisp-package*
+ (make-package "CL"))
+
+ (defvar *user-package*
+ (make-package "CL-USER" (list *common-lisp-package*)))
+
+ (defvar *keyword-package*
+ (make-package "KEYWORD"))
+
+ (defun keywordp (x)
+ (and (symbolp x) (eq (symbol-package x) *keyword-package*)))
+
+ (defvar *package* *common-lisp-package*)
+
+ (defmacro in-package (package-designator)
+ `(eval-when-compile
+ (setq *package* (find-package-or-fail ,package-designator))))
+
+ ;; This function is used internally to initialize the CL package
+ ;; with the symbols built during bootstrap.
+ (defun %intern-symbol (symbol)
+ (let ((symbols (%package-symbols *common-lisp-package*)))
+ (oset symbol "package" *common-lisp-package*)
+ (oset symbols (symbol-name symbol) symbol)))
+
+ (defun %find-symbol (name package)
+ (let ((package (find-package-or-fail package)))
+ (let ((symbols (%package-symbols package)))
+ (if (in name symbols)
+ (cons (oget symbols name) t)
+ (dolist (used (package-use-list package) (cons nil nil))
+ (let ((exports (%package-external-symbols used)))
+ (when (in name exports)
+ (return-from %find-symbol
+ (cons (oget exports name) t)))))))))
+
+ (defun find-symbol (name &optional (package *package*))
+ (car (%find-symbol name package)))
+
+ (defun intern (name &optional (package *package*))
+ (let ((package (find-package-or-fail package)))
+ (let ((result (%find-symbol name package)))
+ (if (cdr result)
+ (car result)
+ (let ((symbols (%package-symbols package)))
+ (oget symbols name)
+ (let ((symbol (make-symbol name)))
+ (oset symbol "package" package)
+ (when (eq package *keyword-package*)
+ (oset symbol "value" symbol)
+ (export (list symbol) package))
+ (oset symbols name symbol)))))))
+
+ (defun symbol-package (symbol)
+ (unless (symbolp symbol)
+ (error "it is not a symbol"))
+ (oget symbol "package"))
+
+ (defun export (symbols &optional (package *package*))
+ (let ((exports (%package-external-symbols package)))
+ (dolist (symb symbols t)
+ (oset exports (symbol-name symb) symb)))))
+