Implement eq and equal hash tables

[jscl.git] / src / package.lisp

diff --git a/src/package.lisp b/src/package.lisp
index ebbd6bf..6fd379b 100644 (file)
--- a/src/package.lisp
+++ b/src/package.lisp
@@ -13,21 +13,35 @@
 ;; You should have received a copy of the GNU General Public License
 ;; along with JSCL.  If not, see <http://www.gnu.org/licenses/>.
 
 ;; You should have received a copy of the GNU General Public License
 ;; along with JSCL.  If not, see <http://www.gnu.org/licenses/>.
 

+(/debug "loading package.lisp!")
+

 (defvar *package-list* nil)
 
 (defun list-all-packages ()
   (copy-list *package-list*))
 
 (defvar *package-list* nil)
 
 (defun list-all-packages ()
   (copy-list *package-list*))
 

-(defun make-package (name &key use)
-  (let ((package (new))
-        (use (mapcar #'find-package-or-fail use)))
+(defun %make-package (name use)
+  (let ((package (new)))

     (setf (oget package "packageName") name)
     (setf (oget package "symbols") (new))
     (setf (oget package "exports") (new))
     (setf (oget package "use") use)
     (setf (oget package "packageName") name)
     (setf (oget package "symbols") (new))
     (setf (oget package "exports") (new))
     (setf (oget package "use") use)

-    (push package *package-list*)
+    (if (find name *package-list* :key (lambda (s) (oget s "packageName")) :test #'equal)
+        (error "A package namded `~a' already exists." name)
+        (push package *package-list*))

     package))
 
     package))
 

+(defun resolve-package-list (packages)
+  (let (result)
+    (dolist (package (mapcar #'find-package-or-fail packages))
+      (pushnew package result :test #'eq))
+    (reverse result)))
+
+(defun make-package (name &key use)
+  (%make-package
+   (string name)
+   (resolve-package-list use)))
+

 (defun packagep (x)
   (and (objectp x) (in "symbols" x)))
 
 (defun packagep (x)
   (and (objectp x) (in "symbols" x)))
 

@@ -74,9 +88,29 @@
 (defvar *package* *common-lisp-package*)
 
 (defmacro in-package (string-designator)
 (defvar *package* *common-lisp-package*)
 
 (defmacro in-package (string-designator)

-  `(eval-when-compile
+  `(eval-when (:compile-toplevel :load-toplevel :execute)

      (setq *package* (find-package-or-fail ',string-designator))))
 
      (setq *package* (find-package-or-fail ',string-designator))))
 

+(defmacro defpackage (package &rest options)
+  (let (use)
+    (dolist (option options)
+      (ecase (car option)
+       (:use
+        (setf use (append use (cdr option))))))
+    `(eval-when (:compile-toplevel :load-toplevel :execute)
+       (%defpackage ',(string package) ',use))))
+
+(defun redefine-package (package use)
+  (setf (oget package "use") use)
+  package)
+
+(defun %defpackage (name use)
+  (let ((package (find-package name))
+        (use (resolve-package-list use)))
+    (if package
+        (redefine-package package use)
+        (%make-package name use))))
+

 ;; This function is used internally to initialize the CL package
 ;; with the symbols built during bootstrap.
 (defun %intern-symbol (symbol)
 ;; This function is used internally to initialize the CL package
 ;; with the symbols built during bootstrap.
 (defun %intern-symbol (symbol)

@@ -153,6 +187,10 @@
   (dolist (package *package-list*)
     (map-for-in function (%package-symbols package))))
 
   (dolist (package *package-list*)
     (map-for-in function (%package-symbols package))))
 

+(defun %map-all-external-symbols (function)
+  (dolist (package *package-list*)
+    (map-for-in function (%package-external-symbols package))))
+

 (defmacro do-symbols ((var &optional (package '*package*) result-form)
                       &body body)
   `(block nil
 (defmacro do-symbols ((var &optional (package '*package*) result-form)
                       &body body)
   `(block nil

@@ -173,9 +211,12 @@
 (defmacro do-all-symbols ((var &optional result-form) &body body)
   `(block nil (%map-all-symbols (lambda (,var) ,@body)) ,result-form))
 
 (defmacro do-all-symbols ((var &optional result-form) &body body)
   `(block nil (%map-all-symbols (lambda (,var) ,@body)) ,result-form))
 

-(defun find-all-symbols (string)
+(defmacro do-all-external-symbols ((var &optional result-form) &body body)
+  `(block nil (%map-all-external-symbols (lambda (,var) ,@body)) ,result-form))
+
+(defun find-all-symbols (string &optional external-only)

   (let (symbols)
     (dolist (package *package-list* symbols)
       (multiple-value-bind (symbol status) (find-symbol string package)
   (let (symbols)
     (dolist (package *package-list* symbols)
       (multiple-value-bind (symbol status) (find-symbol string package)

-        (when status
+        (when (if external-only (eq status :external) status)

           (pushnew symbol symbols :test #'eq))))))
           (pushnew symbol symbols :test #'eq))))))