From: Matt Birkholz <matt@birchwood-abbey.net>
Date: Fri, 25 Mar 2016 17:35:19 +0000 (-0700)
Subject: cref/generate-trivial-constructor: Add optional parameter OS-TYPE.
X-Git-Tag: mit-scheme-pucked-9.2.12~261^2~69
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=9804c7040873bf8fd7820fa359a3a9e7f658a53d;p=mit-scheme.git

cref/generate-trivial-constructor: Add optional parameter OS-TYPE.

Plugin installs do not include package descriptions for other OSes.
This causes cref/generate-trivial-constructor to emit warnings.  The
argument #F for OS-TYPE now causes it to punt other OSes.
---

diff --git a/src/cref/toplev.scm b/src/cref/toplev.scm
index 39a47666c..5d76d7997 100644
--- a/src/cref/toplev.scm
+++ b/src/cref/toplev.scm
@@ -42,15 +42,23 @@ USA.
 	    ((memq os-type os-types) (do-type os-type))
 	    (else (error:bad-range-argument os-type #f))))))
 
-(define (cref/generate-trivial-constructor filename)
-  (let ((pathname (merge-pathnames filename)))
-    (for-each (lambda (os-type)
-		(write-external-descriptions
-		 pathname
-		 (read-package-model pathname os-type)
-		 #f
-		 os-type))
-	      os-types)))
+(define (cref/generate-trivial-constructor filename #!optional os-type)
+  (let* ((pathname (merge-pathnames filename))
+	 (do-type
+	  (lambda (os-type)
+	    (write-external-descriptions
+	     pathname
+	     (read-package-model pathname os-type)
+	     #f
+	     os-type))))
+    (cond ((or (default-object? os-type)
+	       (eq? os-type 'ALL))
+	   (for-each do-type os-types))
+	  ((eq? os-type #f)
+	   (do-type microcode-id/operating-system))
+	  ((memq os-type os-types)
+	   (do-type os-type))
+	  (else (error:bad-range-argument os-type #f)))))
 
 (define (cref/package-files filename os-type)
   (append-map package/files