From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 12 Feb 1998 05:58:12 +0000 (+0000)
Subject: Eliminate "system" datatype.  Replace it by a simpler "subsystem
X-Git-Tag: 20090517-FFI~4862
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=8ea394ab4eca58b57dd1762388b550b0e566ca6a;p=mit-scheme.git

Eliminate "system" datatype.  Replace it by a simpler "subsystem
identification" mechanism.
---

diff --git a/v7/src/compiler/machines/C/cout.scm b/v7/src/compiler/machines/C/cout.scm
index c0aef95eb..e3c035b82 100644
--- a/v7/src/compiler/machines/C/cout.scm
+++ b/v7/src/compiler/machines/C/cout.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: cout.scm,v 1.19 1993/11/16 16:36:44 gjr Exp $
+$Id: cout.scm,v 1.20 1998/02/12 05:58:04 cph Exp $
 
-Copyright (c) 1992-1993 Massachusetts Institute of Technology
+Copyright (c) 1992-98 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -306,19 +306,7 @@ MIT in each case. |#
 	  " at "
 	  (decoded-time/time-string time)
 	  "\n   by Liar version "
-	  (let ((version false))
-	    (for-each-system!
-	     (lambda (system)
-	       (if (substring? "Liar" (system/name system))
-		   (set! version
-			 (cons (system/version system)
-			       (system/modification system))))
-	       unspecific))
-	    (if (not version)
-		"?.?"
-		(string-append (number->string (car version))
-			       "."
-			       (number->string (cdr version)))))
+	  (or (get-subsystem-version-string "liar") "?.?")
 	  ".\n */\n\n"
 	  "#include \"liarc.h\"\n\n")))
 
diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg
index 24e269ed9..62bc19c5a 100644
--- a/v7/src/edwin/edwin.pkg
+++ b/v7/src/edwin/edwin.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: edwin.pkg,v 1.220 1998/02/01 05:12:21 cph Exp $
+$Id: edwin.pkg,v 1.221 1998/02/12 05:57:40 cph Exp $
 
 Copyright (c) 1989-98 Massachusetts Institute of Technology
 
@@ -1517,9 +1517,7 @@ MIT in each case. |#
 	  make-mail-buffer
 	  prepare-mail-buffer-for-sending
 	  rfc822-quote
-	  send-mail-buffer)
-  (import (runtime system)
-	  known-systems))
+	  send-mail-buffer))
 
 (define-package (edwin mail-alias)
   (files "malias")
diff --git a/v7/src/edwin/sendmail.scm b/v7/src/edwin/sendmail.scm
index ea03202e0..201c03d00 100644
--- a/v7/src/edwin/sendmail.scm
+++ b/v7/src/edwin/sendmail.scm
@@ -1,8 +1,8 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Id: sendmail.scm,v 1.40 1997/11/06 07:43:46 cph Exp $
+;;;	$Id: sendmail.scm,v 1.41 1998/02/12 05:58:12 cph Exp $
 ;;;
-;;;	Copyright (c) 1991-97 Massachusetts Institute of Technology
+;;;	Copyright (c) 1991-98 Massachusetts Institute of Technology
 ;;;
 ;;;	This material was developed by the Scheme project at the
 ;;;	Massachusetts Institute of Technology, Department of
@@ -392,18 +392,11 @@ is inserted."
 
 (define (mailer-version-string buffer)
   (and (ref-variable mail-identify-reader buffer)
-       (let ((id
-	      (system/identification-string
-	       (list-search-positive known-systems
-		 (lambda (system)
-		   (string-ci=? "edwin" (system/name system)))))))
-	 (let ((space (string-find-next-char id #\space)))
-	   (string-append (string-head id space)
-			  " [version"
-			  (string-tail id space)
-			  ", MIT Scheme Release "
-			  microcode-id/release-string
-			  "]")))))
+       (string-append "Edwin [version"
+		      (get-subsystem-version-string "edwin")
+		      ", MIT Scheme Release "
+		      microcode-id/release-string
+		      "]")))
 
 (define-variable mail-setup-hook
   "An event distributor invoked immediately after a mail buffer is initialized.
diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 3ba91b04d..ab916850a 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.290 1998/02/11 05:11:34 cph Exp $
+$Id: runtime.pkg,v 14.291 1998/02/12 05:57:16 cph Exp $
 
 Copyright (c) 1988-98 Massachusetts Institute of Technology
 
@@ -3063,16 +3063,12 @@ MIT in each case. |#
   (parent ())
   (export ()
 	  add-identification!
-	  add-system!
-	  for-each-system!
-	  load-system!
-	  make-system
-	  set-system/modification!
-	  set-system/version!
-	  system/identification-string
-	  system/modification
-	  system/name
-	  system/version))
+	  add-subsystem-identification!
+	  get-subsystem-identification-string
+	  get-subsystem-names
+	  get-subsystem-version
+	  get-subsystem-version-string
+	  remove-subsystem-identification!))
 
 (define-package (runtime system-clock)
   (files "sysclk")
diff --git a/v7/src/runtime/savres.scm b/v7/src/runtime/savres.scm
index 0a97827b4..4a5dd2501 100644
--- a/v7/src/runtime/savres.scm
+++ b/v7/src/runtime/savres.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: savres.scm,v 14.28 1995/06/21 18:19:39 robblau Exp $
+$Id: savres.scm,v 14.29 1998/02/12 05:57:34 cph Exp $
 
-Copyright (c) 1988-1992 Massachusetts Institute of Technology
+Copyright (c) 1988-98 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -167,8 +167,8 @@ MIT in each case. |#
     (newline port)
     (write-string "  Release " port)
     (write-string microcode-id/release-string port)
-    (for-each-system!
-     (lambda (system)
-       (newline port)
-       (write-string "  " port)
-       (write-string (system/identification-string system) port)))))
\ No newline at end of file
+    (for-each (lambda (name)
+		(newline port)
+		(write-string "  " port)
+		(write-string (get-subsystem-identification-string name) port))
+	      (get-subsystem-names))))
\ No newline at end of file
diff --git a/v7/src/runtime/system.scm b/v7/src/runtime/system.scm
index 3092ecad0..2b1c8c9a1 100644
--- a/v7/src/runtime/system.scm
+++ b/v7/src/runtime/system.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: system.scm,v 14.9 1998/02/12 04:31:37 cph Exp $
+$Id: system.scm,v 14.10 1998/02/12 05:56:48 cph Exp $
 
 Copyright (c) 1988-98 Massachusetts Institute of Technology
 
@@ -32,123 +32,97 @@ Technology nor of any adaptation thereof in any advertising,
 promotional, or sales literature without prior written consent from
 MIT in each case. |#
 
-;;;; Systems
+;;;; Subsystem Identification
 ;;; package: (runtime system)
 
 (declare (usual-integrations))
 
-(define (add-identification! name version modification)
-  (add-system! (make-system name version modification '())))
-
-(define-structure (system
-		   (constructor
-		    make-system
-		    (name version modification files-lists))
-		   (conc-name system/))
-  (name false read-only true)
-  (version false)
-  (modification false)
-  (files-lists false read-only true)
-  (files false))
-
-(define known-systems '())
-
-(define (add-system! system)
-  (let ((system*
-	 (list-search-positive known-systems
-	   (lambda (system*)
-	     (string=? (system/name system) (system/name system*))))))
-    (if system*
-	(set! known-systems (delq! system* known-systems))))
-  (set! known-systems (append! known-systems (list system)))
+(define (add-subsystem-identification! name version)
+  (if (not (and (string? name) (not (string-null? name))))
+      (error:wrong-type-argument name "non-null string"
+				 'ADD-SUBSYSTEM-IDENTIFICATION!))
+  (let ((version
+	 (let loop ((version version))
+	   (append-map
+	    (lambda (version)
+	      (cond ((exact-nonnegative-integer? version)
+		     (list version))
+		    ((string? version)
+		     (if (string-null? version)
+			 '()
+			 (list version)))
+		    ((list? version)
+		     (loop version))
+		    (else
+		     (error "Illegal subsystem version:"
+			    version))))
+	    version))))
+    (remove-subsystem-identification! name)
+    (set! subsystem-identifications
+	  (append! subsystem-identifications (list (cons name version)))))
   unspecific)
 
-(define (for-each-system! procedure)
-  (for-each procedure known-systems))
-
-(define (system/identification-string system)
-  (string-append
-   (system/name system)
-   (let ((version
-	  (string-append
-	   (version->string (system/version system))
-	   (let ((modification (version->string (system/modification system))))
-	     (if (string-null? modification)
-		 ""
-		 (string-append "." modification))))))
-     (if (string-null? version)
-	 ""
-	 (string-append " " version)))))
-
-(define (version->string version)
-  (cond ((string? version) version)
-	((exact-nonnegative-integer? version) (number->string version))
-	((null? version) "")
-	((list? version)
-	 (let loop ((version version))
-	   (if (null? (cdr version))
-	       (version->string (car version))
-	       (string-append (version->string (car version))
-			      "."
-			      (loop (cdr version))))))
-	(else
-	 (error "Illegal system version" version))))
+(define (remove-subsystem-identification! name)
+  (let loop ((previous #f) (entries subsystem-identifications))
+    (if (not (null? entries))
+	(if (match-entry? name (car entries))
+	    (begin
+	      (if previous
+		  (set-cdr! previous (cdr entries))
+		  (set! subsystem-identifications (cdr entries)))
+	      (loop previous (cdr entries)))
+	    (loop entries (cdr entries))))))
+
+(define (get-subsystem-names)
+  (map car subsystem-identifications))
+
+(define (get-subsystem-version name)
+  (let ((entry (find-entry name)))
+    (and entry
+	 (list-copy (cdr entry)))))
+
+(define (get-subsystem-version-string name)
+  (let ((entry (find-entry name)))
+    (and entry
+	 (version-string (cdr entry)))))
+
+(define (get-subsystem-identification-string name)
+  (let ((entry (find-entry name)))
+    (and entry
+	 (let ((name (car entry))
+	       (s (version-string (cdr entry))))
+	   (and s
+		(if (string-null? s)
+		    (string-copy name)
+		    (string-append name " " s)))))))
 
-;;; Load the given system.
-
-;;; SYSTEM/FILES will be assigned the list of filenames actually
-;;; loaded.
-
-;;; SYSTEM/FILES-LISTS should contain a list of pairs, the car of each
-;;; pair being an environment, and the cdr a list of filenames.  The
-;;; files are loaded in the order specified, into the environments
-;;; specified.  COMPILED?, if false, means change all of the file
-;;; types to "BIN".
-
-(define (load-system! system #!optional compiled?)
-  (let ((files
-	 (format-files-list (system/files-lists system)
-			    (if (default-object? compiled?)
-				(prompt-for-confirmation "Load compiled")
-				compiled?))))
-    (set-system/files! system
-		       (map (lambda (file) (->namestring (car file))) files))
-    (for-each (lambda (file scode)
-		(newline) (write-string "Eval ")
-		(write (->namestring (car file)))
-		(scode-eval scode (cdr file)))
-	      files
-	      (let loop ((files (map car files)))
-		(if (null? files)
-		    '()
-		    (split-list files 20
-		      (lambda (head tail)
-			(let ((expressions (map fasload head)))
-			  (newline)
-			  (write-string "Purify")
-			  (purify (list->vector expressions) true)
-			  (append! expressions (loop tail))))))))
-    (newline)
-    (write-string "Done"))
-  (add-system! system)
-  unspecific)
+(define (version-string version)
+  (if (null? version)
+      ""
+      (let loop ((version version))
+	(let ((s
+	       (if (string? (car version))
+		   (car version)
+		   (number->string (car version)))))
+	  (if (null? (cdr version))
+	      s
+	      (string-append s "." (loop (cdr version))))))))
+
+(define (find-entry name)
+  (list-search-positive subsystem-identifications
+    (lambda (entry)
+      (match-entry? name entry))))
+
+(define (match-entry? name entry)
+  (let ((s (car entry)))
+    (substring-ci=? name 0 (string-length name)
+		    s 0
+		    (or (string-find-next-char s #\space)
+			(string-length s)))))
+
+(define subsystem-identifications '())
+
+;;; Upwards compatibility.
 
-(define (split-list list n receiver)
-  (if (or (not (pair? list)) (zero? n))
-      (receiver '() list)
-      (split-list (cdr list) (-1+ n)
-	(lambda (head tail)
-	  (receiver (cons (car list) head) tail)))))
-
-(define (format-files-list files-lists compiled?)
-  (append-map! (lambda (files-list)
-		 (map (lambda (filename)
-			(let ((pathname (->pathname filename)))
-			  (cons (if (and (not compiled?)
-					 (equal? "com"
-						 (pathname-type pathname)))
-				    (pathname-new-type pathname "bin")
-				    pathname)
-				(car files-list))))
-		      (cdr files-list)))
-	       files-lists))
\ No newline at end of file
+(define (add-identification! name version modification)
+  (add-subsystem-identification! name (list version modification)))
\ No newline at end of file
diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg
index 9f67adc67..d0bebe444 100644
--- a/v8/src/runtime/runtime.pkg
+++ b/v8/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.296 1998/02/11 05:11:07 cph Exp $
+$Id: runtime.pkg,v 14.297 1998/02/12 05:57:01 cph Exp $
 
 Copyright (c) 1988-98 Massachusetts Institute of Technology
 
@@ -3067,16 +3067,12 @@ MIT in each case. |#
   (parent ())
   (export ()
 	  add-identification!
-	  add-system!
-	  for-each-system!
-	  load-system!
-	  make-system
-	  set-system/modification!
-	  set-system/version!
-	  system/identification-string
-	  system/modification
-	  system/name
-	  system/version))
+	  add-subsystem-identification!
+	  get-subsystem-identification-string
+	  get-subsystem-names
+	  get-subsystem-version
+	  get-subsystem-version-string
+	  remove-subsystem-identification!))
 
 (define-package (runtime system-clock)
   (files "sysclk")