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