home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / runtime / system.scm < prev    next >
Text File  |  1999-01-02  |  4KB  |  127 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: system.scm,v 14.13 1999/01/02 06:19:10 cph Exp $
  4.  
  5. Copyright (c) 1988-1999 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; Subsystem Identification
  23. ;;; package: (runtime system)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define (add-subsystem-identification! name version)
  28.   (if (not (and (string? name) (not (string-null? name))))
  29.       (error:wrong-type-argument name "non-null string"
  30.                  'ADD-SUBSYSTEM-IDENTIFICATION!))
  31.   (let ((version
  32.      (let loop ((version version))
  33.        (append-map
  34.         (lambda (version)
  35.           (cond ((exact-nonnegative-integer? version)
  36.              (list version))
  37.             ((string? version)
  38.              (if (string-null? version)
  39.              '()
  40.              (list version)))
  41.             ((list? version)
  42.              (loop version))
  43.             (else
  44.              (error "Illegal subsystem version:"
  45.                 version))))
  46.         version))))
  47.     (let ((entry (find-entry name)))
  48.       (if entry
  49.       (begin
  50.         (set-car! entry name)
  51.         (set-cdr! entry version))
  52.       (begin
  53.         (set! subsystem-identifications
  54.           (append! subsystem-identifications
  55.                (list (cons name version))))
  56.         unspecific)))))
  57.  
  58. (define (remove-subsystem-identification! name)
  59.   (let loop ((previous #f) (entries subsystem-identifications))
  60.     (if (not (null? entries))
  61.     (if (match-entry? name (car entries))
  62.         (begin
  63.           (if previous
  64.           (set-cdr! previous (cdr entries))
  65.           (set! subsystem-identifications (cdr entries)))
  66.           (loop previous (cdr entries)))
  67.         (loop entries (cdr entries))))))
  68.  
  69. (define (get-subsystem-names)
  70.   (map (lambda (entry)
  71.      (let ((s (car entry)))
  72.        (let ((i (string-find-next-char s #\space)))
  73.          (if i
  74.          (string-head s i)
  75.          s))))
  76.        subsystem-identifications))
  77.  
  78. (define (get-subsystem-version name)
  79.   (let ((entry (find-entry name)))
  80.     (and entry
  81.      (list-copy (cdr entry)))))
  82.  
  83. (define (get-subsystem-version-string name)
  84.   (let ((entry (find-entry name)))
  85.     (and entry
  86.      (version-string (cdr entry)))))
  87.  
  88. (define (get-subsystem-identification-string name)
  89.   (let ((entry (find-entry name)))
  90.     (and entry
  91.      (let ((name (car entry))
  92.            (s (version-string (cdr entry))))
  93.        (and s
  94.         (if (string-null? s)
  95.             (string-copy name)
  96.             (string-append name " " s)))))))
  97.  
  98. (define (version-string version)
  99.   (if (null? version)
  100.       ""
  101.       (let loop ((version version))
  102.     (let ((s
  103.            (if (string? (car version))
  104.            (car version)
  105.            (number->string (car version)))))
  106.       (if (null? (cdr version))
  107.           s
  108.           (string-append s "." (loop (cdr version))))))))
  109.  
  110. (define (find-entry name)
  111.   (list-search-positive subsystem-identifications
  112.     (lambda (entry)
  113.       (match-entry? name entry))))
  114.  
  115. (define (match-entry? name entry)
  116.   (let ((s (car entry)))
  117.     (substring-ci=? name 0 (string-length name)
  118.             s 0
  119.             (or (string-find-next-char s #\space)
  120.             (string-length s)))))
  121.  
  122. (define subsystem-identifications '())
  123.  
  124. ;;; Upwards compatibility.
  125.  
  126. (define (add-identification! name version modification)
  127.   (add-subsystem-identification! name (list version modification)))