From 8ea394ab4eca58b57dd1762388b550b0e566ca6a Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Thu, 12 Feb 1998 05:58:12 +0000 Subject: [PATCH] Eliminate "system" datatype. Replace it by a simpler "subsystem identification" mechanism. --- v7/src/compiler/machines/C/cout.scm | 18 +-- v7/src/edwin/edwin.pkg | 6 +- v7/src/edwin/sendmail.scm | 21 +-- v7/src/runtime/runtime.pkg | 18 +-- v7/src/runtime/savres.scm | 14 +- v7/src/runtime/system.scm | 200 ++++++++++++---------------- v8/src/runtime/runtime.pkg | 18 +-- 7 files changed, 120 insertions(+), 175 deletions(-) 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") -- 2.25.1