From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 5 Jan 1995 20:21:58 +0000 (+0000)
Subject: Implement new OS-TYPE-CASE expression; this is used to have
X-Git-Tag: 20090517-FFI~6840
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=4ad801ddf2fd1db292dd311efdeb600cc85fe5b5;p=mit-scheme.git

Implement new OS-TYPE-CASE expression; this is used to have
operating-system specific conditionalizations in the package file.
Also change all of the file types generated by CREF to be 3 characters
long instead of 4; the code will automatically rename or delete the
old names when they are seen.
---

diff --git a/v7/src/cref/make.scm b/v7/src/cref/make.scm
index 66d4b31ce..1826934b3 100644
--- a/v7/src/cref/make.scm
+++ b/v7/src/cref/make.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: make.scm,v 1.12 1994/06/21 19:38:49 cph Exp $
+$Id: make.scm,v 1.13 1995/01/05 20:21:58 cph Exp $
 
-Copyright (c) 1988-94 Massachusetts Institute of Technology
+Copyright (c) 1988-95 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -46,4 +46,4 @@ MIT in each case. |#
      (lambda ()
        (load-option 'RB-TREE)
        (package/system-loader "cref" '() false)))))
-(add-system! (make-system "CREF" 1 12 '()))
\ No newline at end of file
+(add-system! (make-system "CREF" 1 13 '()))
\ No newline at end of file
diff --git a/v7/src/cref/redpkg.scm b/v7/src/cref/redpkg.scm
index 42cf0d533..d9cd41983 100644
--- a/v7/src/cref/redpkg.scm
+++ b/v7/src/cref/redpkg.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: redpkg.scm,v 1.5 1993/10/11 23:31:43 cph Exp $
+$Id: redpkg.scm,v 1.6 1995/01/05 20:21:16 cph Exp $
 
-Copyright (c) 1988-93 Massachusetts Institute of Technology
+Copyright (c) 1988-95 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -46,21 +46,34 @@ MIT in each case. |#
 		  (parse-package-expression expression))
 		(read-package-description-file model-pathname))))
       (lambda (packages globals)
-	(let ((pmodel (descriptions->pmodel packages model-pathname)))
-	  (for-each
-	   (let ((root-package (pmodel/root-package pmodel)))
-	     (lambda (pathname)
-	       (for-each (let ((expression
-				(make-expression root-package
-						 (->namestring pathname)
-						 false)))
-			   (lambda (name)
-			     (bind! root-package name expression)))
-			 (fasload
-			  (merge-pathnames (pathname-new-type pathname "glob")
-					   model-pathname)))))
-	   globals)
-	  pmodel)))))
+	(descriptions->pmodel
+	 packages
+	 (map (lambda (pathname)
+		(cons
+		 (->namestring pathname)
+		 (let ((pathname
+			(pathname-new-type (merge-pathnames pathname
+							    model-pathname)
+					   "glo")))
+		   (handle-old-pathname-type pathname "glob")
+		   (if (file-exists? pathname)
+		       (let ((contents (fasload pathname)))
+			 (cond ((check-list contents symbol?)
+				(list (cons '() contents)))
+			       ((check-list contents
+				  (lambda (element)
+				    (and (pair? element)
+					 (check-list (car element) symbol?)
+					 (check-list (cdr element) symbol?))))
+				contents)
+			       (else
+				(warn "Malformed globals file:" pathname)
+				'())))
+		       (begin
+			 (warn "Can't find globals file:" pathname)
+			 '())))))
+	      globals)
+	 model-pathname)))))
 
 (define (sort-descriptions descriptions)
   (let loop
@@ -69,15 +82,22 @@ MIT in each case. |#
        (globals '()))
     (cond ((null? descriptions)
 	   (values (reverse! packages) globals))
+	  ((not (car descriptions))
+	   (loop (cdr descriptions) packages globals))
 	  ((package-description? (car descriptions))
 	   (loop (cdr descriptions)
 		 (cons (car descriptions) packages)
 		 globals))
 	  ((and (pair? (car descriptions))
-		(eq? (car (car descriptions)) 'GLOBAL-DEFINITIONS))
+		(eq? (caar descriptions) 'GLOBAL-DEFINITIONS))
 	   (loop (cdr descriptions)
 		 packages
 		 (append globals (cdr (car descriptions)))))
+	  ((and (pair? (car descriptions))
+		(eq? (caar descriptions) 'NESTED-DESCRIPTIONS))
+	   (loop (append (cdr descriptions) (cdar descriptions))
+		 packages
+		 globals))
 	  (else
 	   (error "Illegal description" (car descriptions))))))
 
@@ -101,7 +121,8 @@ MIT in each case. |#
   (data false))
 
 (define (cache-file-analyses! pmodel)
-  (let ((pathname (pathname-new-type (pmodel/pathname pmodel) "free")))
+  (let ((pathname (pathname-new-type (pmodel/pathname pmodel) "fre")))
+    (handle-old-pathname-type pathname "free")
     (let ((result
 	   (let ((caches (if (file-exists? pathname) (fasload pathname) '())))
 	     (append-map! (lambda (package)
@@ -199,6 +220,24 @@ MIT in each case. |#
        (if (not (check-list filenames string?))
 	   (error "illegal filenames" filenames))
        (cons 'GLOBAL-DEFINITIONS (map parse-filename filenames))))
+    ((OS-TYPE-CASE)
+     (if (not (and (list? (cdr expression))
+		   (for-all? (cdr expression)
+		     (lambda (clause)
+		       (and (or (eq? 'ELSE (car clause))
+				(and (list? (car clause))
+				     (for-all? (car clause) symbol?)))
+			    (list? (cdr clause)))))))
+	 (error "Malformed expression:" expression))
+     (cons 'NESTED-DESCRIPTIONS
+	   (let loop ((clauses (cdr expression)))
+	     (cond ((null? clauses)
+		    '())
+		   ((or (eq? 'ELSE (caar clauses))
+			(memq microcode-id/operating-system (caar clauses)))
+		    (map parse-package-expression (cdar clauses)))
+		   (else
+		    (loop (cdr clauses)))))))
     (else
      (error "unrecognized expression keyword" (car expression)))))
 
@@ -291,12 +330,15 @@ MIT in each case. |#
   (cons (parse-name (car export)) (cdr export)))
 
 (define (check-list items predicate)
-  (let loop ((items items))
-    (if (pair? items)
-	(if (predicate (car items))
-	    (loop (cdr items))
-	    false)
-	(null? items))))
+  (and (list? items)
+       (for-all? items predicate)))
+
+(define (handle-old-pathname-type pathname type)
+  (let ((old (pathname-new-type pathname type)))
+    (if (file-exists? old)
+	(if (file-exists? pathname)
+	    (delete-file old)
+	    (rename-file old pathname)))))
 
 ;;;; Packages
 
@@ -311,7 +353,7 @@ MIT in each case. |#
     (lambda (package)
       (symbol-list=? name (package/name package)))))
 
-(define (descriptions->pmodel descriptions pathname)
+(define (descriptions->pmodel descriptions globals pathname)
   (let ((packages
 	 (map (lambda (description)
 		(make-package
@@ -329,9 +371,25 @@ MIT in each case. |#
 	       (if (null? name)
 		   root-package
 		   (or (name->package packages name)
+		       (name->package extra-packages name)
 		       (let ((package (make-package name '() #F 'UNKNOWN)))
 			 (set! extra-packages (cons package extra-packages))
 			 package))))))
+	;; GLOBALS is a list of the bindings supplied externally.
+	(for-each
+	 (lambda (global)
+	   (for-each
+	    (let ((namestring (->namestring (car global))))
+	      (lambda (entry)
+		(for-each
+		 (let ((package (get-package (car entry))))
+		   (lambda (name)
+		     (bind! package
+			    name
+			    (make-expression package namestring #f))))
+		 (cdr entry))))
+	    (cdr global)))
+	 globals)
 	(for-each (lambda (package description)
 		    (let ((parent
 			   (let ((parent-name
diff --git a/v7/src/cref/toplev.scm b/v7/src/cref/toplev.scm
index 88b618924..104f53748 100644
--- a/v7/src/cref/toplev.scm
+++ b/v7/src/cref/toplev.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: toplev.scm,v 1.6 1993/10/11 23:31:44 cph Exp $
+$Id: toplev.scm,v 1.7 1995/01/05 20:21:50 cph Exp $
 
-Copyright (c) 1988-93 Massachusetts Institute of Technology
+Copyright (c) 1988-95 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -73,7 +73,7 @@ MIT in each case. |#
      (write-globals pathname pmodel)
      (write-constructor pathname pmodel)
      (write-loader pathname pmodel))))
-
+
 (define (write-constructor pathname pmodel)
   (let ((constructor (construct-constructor pmodel)))
     (with-output-to-file (pathname-new-type pathname "con")
@@ -97,18 +97,30 @@ MIT in each case. |#
 		  loader)))))
 
 (define (write-cref pathname pmodel)
-  (with-output-to-file (pathname-new-type pathname "cref")
+  (let ((old (pathname-new-type pathname "cref")))
+    (if (file-exists? old)
+	(delete-file old)))
+  (with-output-to-file (pathname-new-type pathname "crf")
     (lambda ()
       (format-packages pmodel))))
 
 (define (write-cref-unusual pathname pmodel)
-  (with-output-to-file (pathname-new-type pathname "cref")
+  (let ((old (pathname-new-type pathname "cref")))
+    (if (file-exists? old)
+	(delete-file old)))
+  (with-output-to-file (pathname-new-type pathname "crf")
     (lambda ()
       (format-packages-unusual pmodel))))
 
 (define (write-globals pathname pmodel)
-  (fasdump (map binding/name
-		(list-transform-positive
-		    (package/sorted-bindings (pmodel/root-package pmodel))
-		  binding/source-binding))
-	   (pathname-new-type pathname "glob")))
\ No newline at end of file
+  (let ((old (pathname-new-type pathname "glob")))
+    (if (file-exists? old)
+	(delete-file old)))
+  (fasdump (map (lambda (package)
+		  (cons (package/name package)
+			(map binding/name
+			     (list-transform-positive
+				 (package/sorted-bindings package)
+			       binding/source-binding))))
+		(pmodel/packages pmodel))
+	   (pathname-new-type pathname "glo")))
\ No newline at end of file