From c49b2bdaa55c3535bb129e75c0ca5623bb9eea30 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Thu, 14 Mar 2002 04:58:51 +0000 Subject: [PATCH] Allow end user to specify operating-system type, in order to do cross compilation. --- v7/src/cref/redpkg.scm | 40 ++++++++++++++++------------ v7/src/cref/toplev.scm | 60 ++++++++++++++++++++++++------------------ 2 files changed, 58 insertions(+), 42 deletions(-) diff --git a/v7/src/cref/redpkg.scm b/v7/src/cref/redpkg.scm index 7c9f967ac..fda8f3c86 100644 --- 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")) -(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)))) -(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. ;;;; 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 6542910dc..ec1006b5e 100644 --- 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)) (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