Skip to content
Snippets Groups Projects
Commit 646ebee6 authored by wlott's avatar wlott
Browse files

Added NEW-BACKEND for use with cross-compiling. Some tweeks to package

state dumping.
parent 85028b44
No related branches found
No related tags found
No related merge requests found
...@@ -17,8 +17,9 @@ ...@@ -17,8 +17,9 @@
(let ((nicks (package-nicknames pkg)) (let ((nicks (package-nicknames pkg))
(name (package-name pkg)) (name (package-name pkg))
(shad (package-shadowing-symbols pkg))) (shad (package-shadowing-symbols pkg)))
(forms `(unless (find-package ,name) (forms `(if (find-package ,name)
(make-package ,name :nicknames ',nicks :use nil))) (rename-package ,name ,name ',nicks)
(make-package ,name :nicknames ',nicks :use nil)))
(when shad (when shad
(forms `(shadow ',(mapcar #'string shad) ,name))))) (forms `(shadow ',(mapcar #'string shad) ,name)))))
...@@ -45,13 +46,25 @@ ...@@ -45,13 +46,25 @@
(pushnew name (gethash pkg imports) :test #'string=)) (pushnew name (gethash pkg imports) :test #'string=))
(when (eq how :external) (when (eq how :external)
(exports name))))))) (exports name)))))))
(forms `(defpackage ,(package-name old) (collect ((import-froms))
,@(loop for pkg being each hash-key in imports (maphash #'(lambda (pkg raw-names)
for names being each hash-value in imports (let ((names (sort (delete-duplicates raw-names
collect `(:import-from ,(package-name pkg) :test
,@names)) #'string=)
,@(when (exports) #'string<))
`((:export ,@(exports))))))))) (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) (with-open-file (s file :direction :output :if-exists :new-version)
(dolist (form (forms)) (dolist (form (forms))
...@@ -114,6 +127,63 @@ ...@@ -114,6 +127,63 @@
(export nsym new))))))))))))) (export nsym new)))))))))))))
(values)) (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: ;;;; Compile utility:
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment