Changeset 8414

Timestamp:

Feb 4, 2008, 1:22:31 AM (17 years ago)

Author:

Gary Byers

Message:

xload-level-0: copy a minimal set of packages (cl, ccl, keyword, target)
to the image.

File:

• trunk/source/xdump/xfasload.lisp (modified) (4 diffs)

trunk/source/xdump/xfasload.lisp

@@ -847 +847 @@
                                             )))
                         packages)))
-    (flet ((lookup-clone (p) (or (cdr (assq p alist)) (error "Package ~S not cloned ." p))))
+    (flet ((lookup-clone (p) (let* ((clone (cdr (assq p alist))))
+                               (when clone (list clone)))))
       (dolist (pair alist alist)
         (let* ((orig (car pair))
                (dup (cdr pair)))
-          (setf (pkg.used dup) (mapcar #'lookup-clone (pkg.used orig))
-                (pkg.used-by dup) (mapcar #'lookup-clone (pkg.used-by orig))))))))
+          (setf (pkg.used dup) (mapcan #'lookup-clone (pkg.used orig))
+                (pkg.used-by dup) (mapcan #'lookup-clone (pkg.used-by orig))))))))
 
 ;;; Dump each cloned package into dynamic-space; return an alist
@@ -983 +984 @@
     (format t ")")))
 
+(defun xload-initial-packages ()
+  (mapcar #'find-package '("CL" "CCL"  "KEYWORD" "TARGET")))
+
 
 (defun xfasload (output-file &rest pathnames)
@@ -993 +997 @@
          (*xload-managed-static-space* (init-xload-space *xload-managed-static-space-address* *xload-managed-static-space-size* area-managed-static))
                                                  
-         (*xload-package-alist* (xload-clone-packages %all-packages%))
+         (*xload-package-alist* (xload-clone-packages (xload-initial-packages)))
          (*xload-cold-load-functions* nil)
          (*xload-cold-load-documentation* nil)
@@ -1731 +1735 @@
          (*xload-startup-file* (backend-xload-info-default-startup-file-name
                                 *xload-target-backend*)))
-    ;; This just undoes the CLtL1 compatability stuff in
-    ;; "ccl:library;lisp-package".  If someone's created LISP and/or
-    ;; USER packages, nuke 'em.
-    (let* ((user-pkg (find-package "USER"))
-           (lisp-pkg (find-package "LISP")))
-      (when (and user-pkg (not (eq user-pkg (find-package "CL-USER"))))
-        (delete-package user-pkg))
-      (when (and lisp-pkg (not (eq lisp-pkg (find-package "CL"))))
-        (delete-package lisp-pkg)))
     (in-development-mode
      (when recompile