Allow end user to specify operating-system type, in order to do cross

compilation.

diff --git a/v7/src/cref/redpkg.scm b/v7/src/cref/redpkg.scm
index 7c9f967ac934b9dcae3d406f98265f0727720b84..fda8f3c86ad21239a7fe02ee4a9cca3a67d18550 100644 (file)
--- a/v7/src/cref/redpkg.scm
+++ b/v7/src/cref/redpkg.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: redpkg.scm,v 1.25 2001/12/19 01:54:09 cph Exp $
+$Id: redpkg.scm,v 1.26 2002/03/14 04:58:51 cph Exp $
 
-Copyright (c) 1988-2001 Massachusetts Institute of Technology
+Copyright (c) 1988-2002 Massachusetts Institute of Technology
 
 This program is free software; you can redistribute it and/or modify
 it under the terms of the GNU General Public License as published by
@@ -25,11 +25,11 @@ USA.
 (declare (usual-integrations)
         (integrate-external "object"))
 \f
-(define (read-package-model filename)
+(define (read-package-model filename os-type)
   (let ((model-pathname (merge-pathnames filename)))
     (with-values
        (lambda ()
-         (sort-descriptions (read-and-parse-model model-pathname)))
+         (sort-descriptions (read-and-parse-model model-pathname os-type)))
       (lambda (packages extensions loads globals)
        (descriptions->pmodel
         packages
@@ -40,7 +40,8 @@ USA.
                 (->namestring pathname)
                 (let ((pathname
                        (package-set-pathname
-                        (merge-pathnames pathname model-pathname))))
+                        (merge-pathnames pathname model-pathname)
+                        os-type)))
                   (if (file-exists? pathname)
                       (let ((contents (fasload pathname)))
                         (if (package-file? contents)
@@ -110,8 +111,8 @@ USA.
       (pair? (package-description/initializations description))
       (pair? (package-description/finalizations description))))
 \f
-(define (read-file-analyses! pmodel)
-  (call-with-values (lambda () (cache-file-analyses! pmodel))
+(define (read-file-analyses! pmodel os-type)
+  (call-with-values (lambda () (cache-file-analyses! pmodel os-type))
     (lambda (analyses changes?)
       (for-each (lambda (p&c)
                  (record-file-analysis! pmodel
@@ -129,9 +130,10 @@ USA.
   (time #f)
   (data #f))
 
-(define (cache-file-analyses! pmodel)
+(define (cache-file-analyses! pmodel os-type)
   (let ((pathname
-        (pathname-new-type (package-set-pathname (pmodel/pathname pmodel))
+        (pathname-new-type (package-set-pathname (pmodel/pathname pmodel)
+                                                 os-type)
                            "fre"))
        (changes? (list #f)))
     (let ((result
@@ -232,17 +234,18 @@ USA.
 \f
 ;;;; Package Descriptions
 
-(define (read-and-parse-model pathname)
+(define (read-and-parse-model pathname os-type)
   (parse-package-expressions
    (read-file (pathname-default-type pathname "pkg"))
-   pathname))
+   pathname
+   os-type))
 
-(define (parse-package-expressions expressions pathname)
+(define (parse-package-expressions expressions pathname os-type)
   (map (lambda (expression)
-        (parse-package-expression expression pathname))
+        (parse-package-expression expression pathname os-type))
        expressions))
 
-(define (parse-package-expression expression pathname)
+(define (parse-package-expression expression pathname os-type)
   (let ((lose
         (lambda ()
           (error "Ill-formed package expression:" expression))))
@@ -278,8 +281,10 @@ USA.
               (cond ((null? clauses)
                      '())
                     ((or (eq? 'ELSE (caar clauses))
-                         (memq microcode-id/operating-system (caar clauses)))
-                     (parse-package-expressions (cdar clauses) pathname))
+                         (memq os-type (caar clauses)))
+                     (parse-package-expressions (cdar clauses)
+                                                pathname
+                                                os-type))
                     (else
                      (loop (cdr clauses)))))))
       ((INCLUDE)
@@ -289,7 +294,8 @@ USA.
                   (lose))
               (append-map (lambda (filename)
                             (read-and-parse-model
-                             (merge-pathnames filename pathname)))
+                             (merge-pathnames filename pathname)
+                             os-type))
                           filenames))))
       (else
        (lose)))))

diff --git a/v7/src/cref/toplev.scm b/v7/src/cref/toplev.scm
index 6542910dc94cf7dd4fb25f96f9b90eb9a5f2b449..ec1006b5e133dca155826815b30ae1133089ca87 100644 (file)
--- a/v7/src/cref/toplev.scm
+++ b/v7/src/cref/toplev.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: toplev.scm,v 1.16 2001/12/17 17:40:58 cph Exp $
+$Id: toplev.scm,v 1.17 2002/03/14 04:58:39 cph Exp $
 
-Copyright (c) 1988-2001 Massachusetts Institute of Technology
+Copyright (c) 1988-2002 Massachusetts Institute of Technology
 
 This program is free software; you can redistribute it and/or modify
 it under the terms of the GNU General Public License as published by
@@ -25,50 +25,60 @@ USA.
 (declare (usual-integrations))
 \f
 (define (generate/common kernel)
-  (lambda (filename)
-    (let ((pathname (merge-pathnames filename)))
-      (let ((pmodel (read-package-model pathname)))
-       (let ((changes? (read-file-analyses! pmodel)))
+  (lambda (filename #!optional os-type)
+    (let ((pathname (merge-pathnames filename))
+         (os-type
+          (if (or (default-object? os-type) (not os-type))
+              microcode-id/operating-system
+              os-type)))
+      (let ((pmodel (read-package-model pathname os-type)))
+       (let ((changes? (read-file-analyses! pmodel os-type)))
          (resolve-references! pmodel)
-         (kernel pathname pmodel changes?))))))
+         (kernel pathname pmodel changes? os-type))))))
 
-(define (cref/generate-trivial-constructor filename)
+(define (cref/generate-trivial-constructor filename #!optional os-type)
   (let ((pathname (merge-pathnames filename)))
-    (write-external-descriptions pathname (read-package-model pathname) #f)))
+    (write-external-descriptions pathname
+                                (read-package-model pathname)
+                                #f
+                                (if (or (default-object? os-type)
+                                        (not os-type))
+                                    microcode-id/operating-system
+                                    os-type))))
 
 (define cref/generate-cref
   (generate/common
-   (lambda (pathname pmodel changes?)
-     (write-cref pathname pmodel changes?))))
+   (lambda (pathname pmodel changes? os-type)
+     (write-cref pathname pmodel changes? os-type))))
 
 (define cref/generate-cref-unusual
   (generate/common
-   (lambda (pathname pmodel changes?)
-     (write-cref-unusual pathname pmodel changes?))))
+   (lambda (pathname pmodel changes? os-type)
+     (write-cref-unusual pathname pmodel changes? os-type))))
 
 (define cref/generate-constructors
   (generate/common
-   (lambda (pathname pmodel changes?)
-     (write-cref-unusual pathname pmodel changes?)
-     (write-external-descriptions pathname pmodel changes?))))
+   (lambda (pathname pmodel changes? os-type)
+     (write-cref-unusual pathname pmodel changes? os-type)
+     (write-external-descriptions pathname pmodel changes? os-type))))
 
 (define cref/generate-all
   (generate/common
-   (lambda (pathname pmodel changes?)
-     (write-cref pathname pmodel changes?)
-     (write-external-descriptions pathname pmodel changes?))))
+   (lambda (pathname pmodel changes? os-type)
+     (write-cref pathname pmodel changes? os-type)
+     (write-external-descriptions pathname pmodel changes? os-type))))
 
-(define (write-external-descriptions pathname pmodel changes?)
-  (let ((package-set (package-set-pathname pathname)))
+(define (write-external-descriptions pathname pmodel changes? os-type)
+  (let ((package-set (package-set-pathname pathname os-type)))
     (if (or changes?
            (not (file-modification-time<?
                  (pathname-default-type pathname "pkg")
                  package-set)))
        (fasdump (construct-external-descriptions pmodel) package-set))))
 
-(define (write-cref pathname pmodel changes?)
+(define (write-cref pathname pmodel changes? os-type)
   (let ((cref-pathname
-        (pathname-new-type (package-set-pathname pathname) "crf")))
+        (pathname-new-type (package-set-pathname pathname os-type) "crf")))
     (if (or changes?
            (not (file-modification-time<?
                  (pathname-default-type pathname "pkg")
@@ -77,9 +87,9 @@ USA.
          (lambda ()
            (format-packages pmodel))))))
 
-(define (write-cref-unusual pathname pmodel changes?)
+(define (write-cref-unusual pathname pmodel changes? os-type)
   (let ((cref-pathname
-        (pathname-new-type (package-set-pathname pathname) "crf")))
+        (pathname-new-type (package-set-pathname pathname os-type) "crf")))
     (if (or changes?
            (not (file-modification-time<?
                  (pathname-default-type pathname "pkg")