SETQ signals error if the first argument is not a symbol

[jscl.git] / src / package.lisp

diff --git a/src/package.lisp b/src/package.lisp
index b93fe02..6fd379b 100644 (file)
--- a/src/package.lisp
+++ b/src/package.lisp
@@ -20,16 +20,28 @@
 (defun list-all-packages ()
   (copy-list *package-list*))
 
 (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)))
 

@@ -76,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)