From 646ebee63501bb1adb16b89d97f2bef0e17bc0af Mon Sep 17 00:00:00 2001
From: wlott <wlott>
Date: Wed, 26 Feb 1992 01:10:20 +0000
Subject: [PATCH] Added NEW-BACKEND for use with cross-compiling.  Some tweeks
 to package state dumping.

---
 tools/setup.lisp | 88 +++++++++++++++++++++++++++++++++++++++++++-----
 1 file changed, 79 insertions(+), 9 deletions(-)

diff --git a/tools/setup.lisp b/tools/setup.lisp
index 4f67f905b..577bbd4d6 100644
--- a/tools/setup.lisp
+++ b/tools/setup.lisp
@@ -17,8 +17,9 @@
 	(let ((nicks (package-nicknames pkg))
 	      (name (package-name pkg))
 	      (shad (package-shadowing-symbols pkg)))
-	  (forms `(unless (find-package ,name)
-		    (make-package ,name :nicknames ',nicks :use nil)))
+	  (forms `(if (find-package ,name)
+		      (rename-package ,name ,name ',nicks)
+		      (make-package ,name :nicknames ',nicks :use nil)))
 	  (when shad
 	    (forms `(shadow ',(mapcar #'string shad) ,name)))))
 
@@ -45,13 +46,25 @@
 		      (pushnew name (gethash pkg imports) :test #'string=))
 		    (when (eq how :external)
 		      (exports name)))))))
-	    (forms `(defpackage ,(package-name old)
-		      ,@(loop for pkg being each hash-key in imports
-			      for names being each hash-value in imports
-			      collect `(:import-from ,(package-name pkg)
-						     ,@names))
-		      ,@(when (exports)
-			  `((:export ,@(exports)))))))))
+	    (collect ((import-froms))
+	      (maphash #'(lambda (pkg raw-names)
+			   (let ((names (sort (delete-duplicates raw-names
+								 :test
+								 #'string=)
+					      #'string<))
+				 (pkg-name (package-name pkg)))
+			     (when names
+			       (import-froms `(:import-from ,pkg-name ,@names))
+			       (dolist (name names)
+				 (forms `(intern ,name ,pkg-name))))))
+		       imports)
+	      (forms `(defpackage ,(package-name old)
+			,@(import-froms)
+			,@(when (exports)
+			    `((:export
+			       ,@(sort (delete-duplicates (exports)
+							  :test #'string=)
+				       #'string<))))))))))
 
       (with-open-file (s file :direction :output :if-exists :new-version)
 	(dolist (form (forms))
@@ -114,6 +127,63 @@
 			(export nsym new)))))))))))))
   (values))
 
+
+;;;; NEW-BACKEND
+
+(defparameter machine-specific-features
+  '(:small :mach :sunos :unix :pmax :decstation-3100
+    :ibm-pc-rt :ibmrt :rt :SPARCstation :sparc :sun4))
+
+(defun new-backend (name &rest features)
+  ;; If VM names a different package, rename that package so that VM doesn't
+  ;; name it.  
+  (let* ((pkg (find-package "VM"))
+	 (pkg-name (package-name pkg)))
+    (unless (string= pkg-name name)
+      (rename-package pkg pkg-name
+		      (remove "VM" (package-nicknames pkg) :test #'string=))
+      (unuse-package pkg "C")))
+  ;; Make sure VM names our package, creating it if necessary.
+  (let* ((pkg (or (find-package name)
+		  (make-package name :nicknames '("VM"))))
+	 (nicknames (package-nicknames pkg)))
+    (unless (member "VM" nicknames :test #'string=)
+      (rename-package pkg name (cons "VM" nicknames)))
+    ;; And make sure we are using the necessary packages.
+    (use-package "C" pkg)
+    (use-package "ASSEM" pkg)
+    (use-package "EXT" pkg)
+    (use-package "KERNEL" pkg)
+    (use-package "SYSTEM" pkg)
+    (use-package "ALIEN" pkg)
+    (use-package "C-CALL" pkg))
+  ;; Make sure the native info env and features list are stored in
+  ;; *native-backend*
+  (unless (c:backend-info-environment c:*native-backend*)
+    (setf (c:backend-info-environment c:*native-backend*) *info-environment*))
+  (unless (c:backend-features c:*native-backend*)
+    (setf (c:backend-features c:*native-backend*) *features*))
+  ;; Cons up a backend structure, filling in the info-env and features slots.
+  (let ((backend (c::make-backend
+		  :name name
+		  :info-environment
+		  (cons (c::make-info-environment
+			 :name
+			 (concatenate 'string name " backend"))
+			(remove-if #'(lambda (name)
+				       (let ((len (length name)))
+					 (and (> len 8)
+					      (string= name " backend"
+						       :start1 (- len 8)))))
+				   *info-environment*
+				   :key #'c::info-env-name))
+		  :features
+		  (append features
+			  (set-difference *features*
+					  machine-specific-features)))))
+    (setf c:*target-backend* backend)))
+
+
 
 ;;;; Compile utility:
 
-- 
GitLab