Add changes for DOS:

- Add dos-specific packages, similar to Unix packages.
- Conditionalize the loading of the Unix and DOS -specific packages.
- Add a mechanism to make.scm to avoid loading unconditional files:
  If the binary file runtim.bad is in the current directory when make
  is running, it should contain a list of strings, each the name of a
  file that should be avoided.  Examples: graphics, x11graph, starbase.
- pathnm.scm now uses the OS-NAME-STRING in the microcode
  identification to initialize the default host.  It no longer
  constructs the host types.  These are constructed when the
  system-dependent files invoke add-pathname-host-type!
  Caveat: There is now a funny ordering dependency.
    pathnm must be loaded before the system-dependeng files (unxpth, dospth)
    but it must be initialized _afterwards_!
- pathnm.scm now has symbolic names for three file system types: Unix,
  DOS, and VMS.

diff --git a/v7/src/runtime/make.scm b/v7/src/runtime/make.scm
index 5a3f5eeb5e60a5512db8ca3082c871b9563cded1..576fadb24a238d53afc450cd3c7b9314df53895d 100644 (file)
--- a/v7/src/runtime/make.scm
+++ b/v7/src/runtime/make.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/make.scm,v 14.34 1992/02/25 22:55:38 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/make.scm,v 14.35 1992/04/11 23:48:12 jinx Exp $
 
-Copyright (c) 1988-92 Massachusetts Institute of Technology
+Copyright (c) 1988-1992 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -48,7 +48,7 @@ MIT in each case. |#
   binary-fasload
   (channel-write 4)
   environment-link-name
-  exit
+  exit-with-value
   (file-exists? 1)
   garbage-collect
   get-fixed-objects-vector
@@ -56,6 +56,7 @@ MIT in each case. |#
   get-primitive-address
   get-primitive-name
   lexical-reference
+  lexical-unreferenceable?
   microcode-identify
   scode-eval
   set-fixed-objects-vector!
@@ -93,7 +94,7 @@ MIT in each case. |#
   (tty-write-char newline-char)
   (tty-write-string message)
   (tty-write-char newline-char)
-  (exit))
+  (exit-with-value 1))
 \f
 ;;;; GC, Interrupts, Errors
 
@@ -145,23 +146,37 @@ MIT in each case. |#
     (tty-write-string " evaluated")
     value))
 
-(define (package-initialize package-name procedure-name)
-  (tty-write-char newline-char)
-  (tty-write-string "initialize: (")
-  (let loop ((name package-name))
-    (if (not (null? name))
-       (begin
-         (if (not (eq? name package-name))
-             (tty-write-string " "))
-         (tty-write-string (system-pair-car (car name)))
-         (loop (cdr name)))))
-  (tty-write-string ")")
-  (if (not (eq? procedure-name 'INITIALIZE-PACKAGE!))
-      (begin
-       (tty-write-string " [")
-       (tty-write-string (system-pair-car procedure-name))
-       (tty-write-string "]")))
-  ((lexical-reference (package-reference package-name) procedure-name)))
+(define (package-initialize package-name procedure-name mandatory?)
+  (define (print-name string)
+    (tty-write-char newline-char)
+    (tty-write-string string)
+    (tty-write-string " (")
+    (let loop ((name package-name))
+      (if (not (null? name))
+         (begin
+           (if (not (eq? name package-name))
+               (tty-write-string " "))
+           (tty-write-string (system-pair-car (car name)))
+           (loop (cdr name)))))
+    (tty-write-string ")"))
+
+  (let ((env (package-reference package-name)))
+    (cond ((not (lexical-unreferenceable? env procedure-name))
+          (print-name "initialize:")
+          (if (not (eq? procedure-name 'INITIALIZE-PACKAGE!))
+              (begin
+                (tty-write-string " [")
+                (tty-write-string (system-pair-car procedure-name))
+                (tty-write-string "]")))
+          ((lexical-reference env procedure-name)))
+         ((not mandatory?)
+          (print-name "* skipping:"))
+         (else
+          ;; Missing mandatory package! Report it and die.
+          (print-name "Package")
+          (tty-write-string " is missing initialization procedure ")
+          (tty-write-string (system-pair-car procedure-name))
+          (fatal-error "Could not initialize a required package.")))))
 
 (define (package-reference name)
   (package/environment (find-package name)))
@@ -170,7 +185,7 @@ MIT in each case. |#
   (let loop ((packages packages))
     (if (not (null? packages))
        (begin
-         (package-initialize (car packages) 'INITIALIZE-PACKAGE!)
+         (package-initialize (car packages) 'INITIALIZE-PACKAGE! false)
          (loop (cdr packages))))))
 \f
 (define (string-append x y)
@@ -236,65 +251,66 @@ MIT in each case. |#
 (package/add-child! system-global-package 'PACKAGE environment-for-package)
 (eval (fasload "runtim.bcon" #f) system-global-environment)
 
-;; Global databases.  Load, then initialize.
-(let loop
-    ((files
-      '(("gcdemn" . (RUNTIME GC-DAEMONS))
-       ("poplat" . (RUNTIME POPULATION))
-       ("prop1d" . (RUNTIME 1D-PROPERTY))
-       ("events" . (RUNTIME EVENT-DISTRIBUTOR))
-       ("gdatab" . (RUNTIME GLOBAL-DATABASE))
-       ("boot" . ())
-       ("queue" . ())
-       ("gc" . (RUNTIME GARBAGE-COLLECTOR))
-       ("equals" . ())
-       ("list" . (RUNTIME LIST))
-       ("record" . (RUNTIME RECORD)))))
-  (if (not (null? files))
-      (begin
-       (eval (fasload (map-filename (car (car files))) #t)
-             (package-reference (cdr (car files))))
-       (loop (cdr files)))))
-(package-initialize '(RUNTIME GC-DAEMONS) 'INITIALIZE-PACKAGE!)
-(package-initialize '(RUNTIME POPULATION) 'INITIALIZE-PACKAGE!)
-(package-initialize '(RUNTIME 1D-PROPERTY) 'INITIALIZE-PACKAGE!)
-(package-initialize '(RUNTIME EVENT-DISTRIBUTOR) 'INITIALIZE-PACKAGE!)
-(package-initialize '(RUNTIME GLOBAL-DATABASE) 'INITIALIZE-PACKAGE!)
-(package-initialize '(RUNTIME POPULATION) 'INITIALIZE-UNPARSER!)
-(package-initialize '(RUNTIME 1D-PROPERTY) 'INITIALIZE-UNPARSER!)
-(package-initialize '(RUNTIME EVENT-DISTRIBUTOR) 'INITIALIZE-UNPARSER!)
-(package-initialize '(PACKAGE) 'INITIALIZE-UNPARSER!)
-(package-initialize '(RUNTIME GARBAGE-COLLECTOR) 'INITIALIZE-PACKAGE!)
-(lexical-assignment (package-reference '(RUNTIME GARBAGE-COLLECTOR))
-                   'CONSTANT-SPACE/BASE
-                   constant-space/base)
-(package-initialize '(RUNTIME LIST) 'INITIALIZE-PACKAGE!)
-(package-initialize '(RUNTIME RECORD) 'INITIALIZE-PACKAGE!)
+;;; Global databases.  Load, then initialize.
+(let ((sine-qua-non
+       '(("gcdemn" . (RUNTIME GC-DAEMONS))
+        ("poplat" . (RUNTIME POPULATION))
+        ("prop1d" . (RUNTIME 1D-PROPERTY))
+        ("events" . (RUNTIME EVENT-DISTRIBUTOR))
+        ("gdatab" . (RUNTIME GLOBAL-DATABASE))
+        ("boot" . ())
+        ("queue" . ())
+        ("gc" . (RUNTIME GARBAGE-COLLECTOR))
+        ("equals" . ())
+        ("list" . (RUNTIME LIST))
+        ("record" . (RUNTIME RECORD)))))
+  (let loop ((files sine-qua-non))
+    (if (not (null? files))
+       (begin
+         (eval (fasload (map-filename (car (car files))) #t)
+               (package-reference (cdr (car files))))
+         (loop (cdr files)))))
+  (package-initialize '(RUNTIME GC-DAEMONS) 'INITIALIZE-PACKAGE! true)
+  (package-initialize '(RUNTIME POPULATION) 'INITIALIZE-PACKAGE! true)
+  (package-initialize '(RUNTIME 1D-PROPERTY) 'INITIALIZE-PACKAGE! true)
+  (package-initialize '(RUNTIME EVENT-DISTRIBUTOR) 'INITIALIZE-PACKAGE! true)
+  (package-initialize '(RUNTIME GLOBAL-DATABASE) 'INITIALIZE-PACKAGE! true)
+  (package-initialize '(RUNTIME POPULATION) 'INITIALIZE-UNPARSER! true)
+  (package-initialize '(RUNTIME 1D-PROPERTY) 'INITIALIZE-UNPARSER! true)
+  (package-initialize '(RUNTIME EVENT-DISTRIBUTOR) 'INITIALIZE-UNPARSER! true)
+  (package-initialize '(PACKAGE) 'INITIALIZE-UNPARSER! true)
+  (package-initialize '(RUNTIME GARBAGE-COLLECTOR) 'INITIALIZE-PACKAGE! true)
+  (lexical-assignment (package-reference '(RUNTIME GARBAGE-COLLECTOR))
+                     'CONSTANT-SPACE/BASE
+                     constant-space/base)
+  (package-initialize '(RUNTIME LIST) 'INITIALIZE-PACKAGE! true)
+  (package-initialize '(RUNTIME RECORD) 'INITIALIZE-PACKAGE! true)
 
 ;; Load everything else.
-((eval (fasload "runtim.bldr" #f) system-global-environment)
- (lambda (filename environment)
-   (if (not (or (string=? filename "packag")
-               (string=? filename "gcdemn")
-               (string=? filename "poplat")
-               (string=? filename "prop1d")
-               (string=? filename "events")
-               (string=? filename "gdatab")
-               (string=? filename "boot")
-               (string=? filename "queue")
-               (string=? filename "gc")
-               (string=? filename "equals")
-               (string=? filename "list")
-               (string=? filename "record")))
-       (eval (fasload (map-filename filename) #t) environment))
-   unspecific)
- `((SORT-TYPE . MERGE-SORT)
-   (OS-TYPE . ,(intern os-name-string))
-   (OPTIONS . NO-LOAD)))
-
-(package-initialize '(RUNTIME MICROCODE-TABLES) 'READ-MICROCODE-TABLES!)
+;; Note: The following code needs MAP* and MEMBER-PROCEDURE
+;; from runtime/list. Fortunately that file has already been loaded.
+
+  ((eval (fasload "runtim.bldr" #f) system-global-environment)
+   (let ((to-avoid
+         (cons "packag"
+               (map* (if (and (implemented-primitive-procedure? file-exists?)
+                              (file-exists? "runtim.bad"))
+                         (fasload "runtim.bad" #f)
+                         '())
+                     car
+                     sine-qua-non)))
+        (string-member? (member-procedure string=?)))
+     (lambda (filename environment)
+       (if (not (string-member? filename to-avoid))
+          (eval (fasload (map-filename filename) #t) environment))
+       unspecific))
+   `((SORT-TYPE . MERGE-SORT)
+     (OS-TYPE . ,(intern os-name-string))
+     (OPTIONS . NO-LOAD))))
+
+(package-initialize '(RUNTIME MICROCODE-TABLES) 'READ-MICROCODE-TABLES! true)
 \f
-;; Funny stuff is done.  Rest of sequence is standardized.
+;;; Funny stuff is done.  Rest of sequence is standardized.
 (package-initialization-sequence
  '(
    ;; Microcode interface
@@ -333,6 +349,10 @@ MIT in each case. |#
    (RUNTIME STRING-INPUT)
    (RUNTIME STRING-OUTPUT)
    (RUNTIME TRUNCATED-STRING-OUTPUT)
+   ;; These MUST be done before (RUNTIME PATHNAME) 
+   ;; Typically only one of them is loaded.
+   (RUNTIME PATHNAME UNIX)
+   (RUNTIME PATHNAME DOS)
    (RUNTIME PATHNAME)
    (RUNTIME WORKING-DIRECTORY)
    (RUNTIME LOAD)
@@ -364,7 +384,7 @@ MIT in each case. |#
    ;; Emacs -- last because it grabs the kitchen sink.
    (RUNTIME EMACS-INTERFACE)))
 \f
-(package-initialize '(RUNTIME CONTINUATION-PARSER) 'INITIALIZE-SPECIAL-FRAMES!)
+(package-initialize '(RUNTIME CONTINUATION-PARSER) 'INITIALIZE-SPECIAL-FRAMES! false)
 
 (let ((filename (map-filename "site")))
   (if (file-exists? filename)

diff --git a/v7/src/runtime/pathnm.scm b/v7/src/runtime/pathnm.scm
index 4b603784e5727ba821b06a5dd3e21fd6cd142ff9..c32af2cbcbc18255c14d79b4f544392bd171db92 100644 (file)
--- a/v7/src/runtime/pathnm.scm
+++ b/v7/src/runtime/pathnm.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/pathnm.scm,v 14.18 1991/11/05 20:37:02 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/pathnm.scm,v 14.19 1992/04/11 23:48:35 jinx Exp $
 
-Copyright (c) 1988-91 Massachusetts Institute of Technology
+Copyright (c) 1988-1992 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -535,6 +535,8 @@ these rules:
              (or (try-directory (car directories))
                  (loop (cdr directories))))))))
 
+(define library-directory-path)
+
 (define (system-library-directory-pathname pathname)
   (if (not pathname)
       (let ((pathname
@@ -548,20 +550,72 @@ these rules:
               (if (file-directory? pathname)
                   (pathname-as-directory pathname)
                   (loop (cdr directories))))))))
-
-(define library-directory-path)
-
-(define (initialize-package!)
-  (reset-package!)
-  (add-event-receiver! event:after-restore reset-package!))
+\f
+(define known-host-types
+  '((UNIX . 0)
+    (DOS . 1)
+    (VMS . 2)))
+
+(define (make-unimplemented-host-type index)
+  (let* ((name (let loop ((types known-host-types))
+                (cond ((null? types)
+                       'UNKNOWN)
+                      ((= index (cdar types))
+                       (caar types))
+                      (else
+                       (loop (cdr types))))))
+        (fail (lambda all
+                (error "(runtime pathname): Unimplemented host type"
+                       name all))))
+    (make-host-type index name
+                   fail fail fail fail fail
+                   fail fail fail fail fail)))
+
+(define available-host-types
+  '())
+
+(define (add-pathname-host-type! name constructor)
+  (let ((host-type (constructor
+                   (let ((place (assq name known-host-types)))
+                     (if (not place)
+                         (error "add-host-type!: Unknown host type"
+                                name)
+                         (cdr place)))))
+        (place (assq name available-host-types)))
+    (if place
+       (set-cdr! place host-type)
+       (set! available-host-types
+             (cons (cons name host-type)
+                   available-host-types)))
+    unspecific))
 
 (define (reset-package!)
-  (let ((unix-host-type (make-unix-host-type 0)))
-    (set! host-types (vector unix-host-type))
-    (set! local-host (make-host unix-host-type false)))
+  (let* ((host-type
+         (cdr
+          (let ((os-type (intern (microcode-identification-item
+                                 'OS-NAME-STRING))))
+           (or (assq os-type available-host-types)
+               (error "(runtime pathname) reset-package!: Unknown OS type"
+                      os-type)))))
+        (len (length known-host-types))
+        (vec (make-vector len false)))
+    (do ((types available-host-types (cdr types)))
+       ((null? types))
+      (let ((type (cdar types)))
+       (vector-set! vec (host-type/index type) type)))
+    (do ((i 0 (1+ i)))
+       ((>= i len))
+      (if (not (vector-ref vec i))
+         (vector-set! vec i (make-unimplemented-host-type i))))
+    (set! host-types vec)
+    (set! local-host (make-host host-type false)))
   (set! *default-pathname-defaults*
        (make-pathname local-host false false false false false))
   (set! library-directory-path
        (map pathname-as-directory
             (vector->list ((ucode-primitive microcode-library-path 0)))))
-  unspecific)
\ No newline at end of file
+  unspecific)
+
+(define (initialize-package!)
+  (reset-package!)
+  (add-event-receiver! event:after-restore reset-package!))
\ No newline at end of file

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index dfc8595008d265a554a779726b79a8d95c3a6deb..eff7935fdd7505e247e830cff4f4c26bd7269c97 100644 (file)
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.144 1992/04/06 19:54:43 bal Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.145 1992/04/11 23:48:00 jinx Exp $
 
-Copyright (c) 1988-92 Massachusetts Institute of Technology
+Copyright (c) 1988-1992 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -53,6 +53,7 @@ MIT in each case. |#
     (else))
   (file-case os-type
     ((unix) "unxprm")
+    ((dos) "dosprm")
     (else)))
 
 (define-package (package)
@@ -435,6 +436,7 @@ MIT in each case. |#
 (define-package (runtime directory)
   (file-case os-type
     ((unix) "unxdir")
+    ((dos) "dosdir")
     ;;(else "unkdir")
     (else))
   (parent ())
@@ -1455,10 +1457,18 @@ MIT in each case. |#
   (initialization (initialize-package!)))
 
 (define-package (runtime pathname unix)
-  (files "unxpth")
   (parent (runtime pathname))
-  (export (runtime pathname)
-         make-unix-host-type))
+  (file-case os-type
+   ((unix) "unxpth")
+   (else))
+  (initialization (initialize-package!)))
+
+(define-package (runtime pathname dos)
+  (parent (runtime pathname))
+  (file-case os-type
+   ((dos) "dospth")
+   (else))
+  (initialization (initialize-package!)))
 
 (define-package (runtime population)
   (files "poplat")

diff --git a/v7/src/runtime/unxpth.scm b/v7/src/runtime/unxpth.scm
index 6c74075435fe4f6f978b2fd088452b2146296f60..1892022f3d9b822adc7b0d7acb5c9643aad88e40 100644 (file)
--- a/v7/src/runtime/unxpth.scm
+++ b/v7/src/runtime/unxpth.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unxpth.scm,v 14.9 1992/02/13 18:26:43 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unxpth.scm,v 14.10 1992/04/11 23:48:27 jinx Exp $
 
-Copyright (c) 1988-92 Massachusetts Institute of Technology
+Copyright (c) 1988-1992 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -50,6 +50,9 @@ MIT in each case. |#
                  unix/user-homedir-pathname
                  unix/init-file-pathname
                  unix/pathname-simplify))
+
+(define (initialize-package!)
+  (add-pathname-host-type! 'UNIX make-unix-host-type))
 \f
 ;;;; Pathname Parser
 

diff --git a/v7/src/runtime/version.scm b/v7/src/runtime/version.scm
index 04f759d59a3c5f3a8e18f1e69aaa05fc97c0afde..e602d3524665d8b5144f45f4e30e83a9f63f516e 100644 (file)
--- a/v7/src/runtime/version.scm
+++ b/v7/src/runtime/version.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.148 1992/03/20 05:18:31 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.149 1992/04/11 23:49:03 jinx Exp $
 
-Copyright (c) 1988-92 Massachusetts Institute of Technology
+Copyright (c) 1988-1992 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -45,7 +45,7 @@ MIT in each case. |#
                     '()))
   (add-system! microcode-system)
   (add-event-receiver! event:after-restore snarf-microcode-version!)
-  (add-identification! "Runtime" 14 148))
+  (add-identification! "Runtime" 14 149))
 
 (define microcode-system)
 

diff --git a/v8/src/runtime/make.scm b/v8/src/runtime/make.scm
index d8b9f97cd9a024241a3719c738ab02229bac273a..6842df511cfbe09c14576dadb68f54c7889807af 100644 (file)
--- a/v8/src/runtime/make.scm
+++ b/v8/src/runtime/make.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/make.scm,v 14.34 1992/02/25 22:55:38 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/make.scm,v 14.35 1992/04/11 23:48:12 jinx Exp $
 
-Copyright (c) 1988-92 Massachusetts Institute of Technology
+Copyright (c) 1988-1992 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -48,7 +48,7 @@ MIT in each case. |#
   binary-fasload
   (channel-write 4)
   environment-link-name
-  exit
+  exit-with-value
   (file-exists? 1)
   garbage-collect
   get-fixed-objects-vector
@@ -56,6 +56,7 @@ MIT in each case. |#
   get-primitive-address
   get-primitive-name
   lexical-reference
+  lexical-unreferenceable?
   microcode-identify
   scode-eval
   set-fixed-objects-vector!
@@ -93,7 +94,7 @@ MIT in each case. |#
   (tty-write-char newline-char)
   (tty-write-string message)
   (tty-write-char newline-char)
-  (exit))
+  (exit-with-value 1))
 \f
 ;;;; GC, Interrupts, Errors
 
@@ -145,23 +146,37 @@ MIT in each case. |#
     (tty-write-string " evaluated")
     value))
 
-(define (package-initialize package-name procedure-name)
-  (tty-write-char newline-char)
-  (tty-write-string "initialize: (")
-  (let loop ((name package-name))
-    (if (not (null? name))
-       (begin
-         (if (not (eq? name package-name))
-             (tty-write-string " "))
-         (tty-write-string (system-pair-car (car name)))
-         (loop (cdr name)))))
-  (tty-write-string ")")
-  (if (not (eq? procedure-name 'INITIALIZE-PACKAGE!))
-      (begin
-       (tty-write-string " [")
-       (tty-write-string (system-pair-car procedure-name))
-       (tty-write-string "]")))
-  ((lexical-reference (package-reference package-name) procedure-name)))
+(define (package-initialize package-name procedure-name mandatory?)
+  (define (print-name string)
+    (tty-write-char newline-char)
+    (tty-write-string string)
+    (tty-write-string " (")
+    (let loop ((name package-name))
+      (if (not (null? name))
+         (begin
+           (if (not (eq? name package-name))
+               (tty-write-string " "))
+           (tty-write-string (system-pair-car (car name)))
+           (loop (cdr name)))))
+    (tty-write-string ")"))
+
+  (let ((env (package-reference package-name)))
+    (cond ((not (lexical-unreferenceable? env procedure-name))
+          (print-name "initialize:")
+          (if (not (eq? procedure-name 'INITIALIZE-PACKAGE!))
+              (begin
+                (tty-write-string " [")
+                (tty-write-string (system-pair-car procedure-name))
+                (tty-write-string "]")))
+          ((lexical-reference env procedure-name)))
+         ((not mandatory?)
+          (print-name "* skipping:"))
+         (else
+          ;; Missing mandatory package! Report it and die.
+          (print-name "Package")
+          (tty-write-string " is missing initialization procedure ")
+          (tty-write-string (system-pair-car procedure-name))
+          (fatal-error "Could not initialize a required package.")))))
 
 (define (package-reference name)
   (package/environment (find-package name)))
@@ -170,7 +185,7 @@ MIT in each case. |#
   (let loop ((packages packages))
     (if (not (null? packages))
        (begin
-         (package-initialize (car packages) 'INITIALIZE-PACKAGE!)
+         (package-initialize (car packages) 'INITIALIZE-PACKAGE! false)
          (loop (cdr packages))))))
 \f
 (define (string-append x y)
@@ -236,65 +251,66 @@ MIT in each case. |#
 (package/add-child! system-global-package 'PACKAGE environment-for-package)
 (eval (fasload "runtim.bcon" #f) system-global-environment)
 
-;; Global databases.  Load, then initialize.
-(let loop
-    ((files
-      '(("gcdemn" . (RUNTIME GC-DAEMONS))
-       ("poplat" . (RUNTIME POPULATION))
-       ("prop1d" . (RUNTIME 1D-PROPERTY))
-       ("events" . (RUNTIME EVENT-DISTRIBUTOR))
-       ("gdatab" . (RUNTIME GLOBAL-DATABASE))
-       ("boot" . ())
-       ("queue" . ())
-       ("gc" . (RUNTIME GARBAGE-COLLECTOR))
-       ("equals" . ())
-       ("list" . (RUNTIME LIST))
-       ("record" . (RUNTIME RECORD)))))
-  (if (not (null? files))
-      (begin
-       (eval (fasload (map-filename (car (car files))) #t)
-             (package-reference (cdr (car files))))
-       (loop (cdr files)))))
-(package-initialize '(RUNTIME GC-DAEMONS) 'INITIALIZE-PACKAGE!)
-(package-initialize '(RUNTIME POPULATION) 'INITIALIZE-PACKAGE!)
-(package-initialize '(RUNTIME 1D-PROPERTY) 'INITIALIZE-PACKAGE!)
-(package-initialize '(RUNTIME EVENT-DISTRIBUTOR) 'INITIALIZE-PACKAGE!)
-(package-initialize '(RUNTIME GLOBAL-DATABASE) 'INITIALIZE-PACKAGE!)
-(package-initialize '(RUNTIME POPULATION) 'INITIALIZE-UNPARSER!)
-(package-initialize '(RUNTIME 1D-PROPERTY) 'INITIALIZE-UNPARSER!)
-(package-initialize '(RUNTIME EVENT-DISTRIBUTOR) 'INITIALIZE-UNPARSER!)
-(package-initialize '(PACKAGE) 'INITIALIZE-UNPARSER!)
-(package-initialize '(RUNTIME GARBAGE-COLLECTOR) 'INITIALIZE-PACKAGE!)
-(lexical-assignment (package-reference '(RUNTIME GARBAGE-COLLECTOR))
-                   'CONSTANT-SPACE/BASE
-                   constant-space/base)
-(package-initialize '(RUNTIME LIST) 'INITIALIZE-PACKAGE!)
-(package-initialize '(RUNTIME RECORD) 'INITIALIZE-PACKAGE!)
+;;; Global databases.  Load, then initialize.
+(let ((sine-qua-non
+       '(("gcdemn" . (RUNTIME GC-DAEMONS))
+        ("poplat" . (RUNTIME POPULATION))
+        ("prop1d" . (RUNTIME 1D-PROPERTY))
+        ("events" . (RUNTIME EVENT-DISTRIBUTOR))
+        ("gdatab" . (RUNTIME GLOBAL-DATABASE))
+        ("boot" . ())
+        ("queue" . ())
+        ("gc" . (RUNTIME GARBAGE-COLLECTOR))
+        ("equals" . ())
+        ("list" . (RUNTIME LIST))
+        ("record" . (RUNTIME RECORD)))))
+  (let loop ((files sine-qua-non))
+    (if (not (null? files))
+       (begin
+         (eval (fasload (map-filename (car (car files))) #t)
+               (package-reference (cdr (car files))))
+         (loop (cdr files)))))
+  (package-initialize '(RUNTIME GC-DAEMONS) 'INITIALIZE-PACKAGE! true)
+  (package-initialize '(RUNTIME POPULATION) 'INITIALIZE-PACKAGE! true)
+  (package-initialize '(RUNTIME 1D-PROPERTY) 'INITIALIZE-PACKAGE! true)
+  (package-initialize '(RUNTIME EVENT-DISTRIBUTOR) 'INITIALIZE-PACKAGE! true)
+  (package-initialize '(RUNTIME GLOBAL-DATABASE) 'INITIALIZE-PACKAGE! true)
+  (package-initialize '(RUNTIME POPULATION) 'INITIALIZE-UNPARSER! true)
+  (package-initialize '(RUNTIME 1D-PROPERTY) 'INITIALIZE-UNPARSER! true)
+  (package-initialize '(RUNTIME EVENT-DISTRIBUTOR) 'INITIALIZE-UNPARSER! true)
+  (package-initialize '(PACKAGE) 'INITIALIZE-UNPARSER! true)
+  (package-initialize '(RUNTIME GARBAGE-COLLECTOR) 'INITIALIZE-PACKAGE! true)
+  (lexical-assignment (package-reference '(RUNTIME GARBAGE-COLLECTOR))
+                     'CONSTANT-SPACE/BASE
+                     constant-space/base)
+  (package-initialize '(RUNTIME LIST) 'INITIALIZE-PACKAGE! true)
+  (package-initialize '(RUNTIME RECORD) 'INITIALIZE-PACKAGE! true)
 
 ;; Load everything else.
-((eval (fasload "runtim.bldr" #f) system-global-environment)
- (lambda (filename environment)
-   (if (not (or (string=? filename "packag")
-               (string=? filename "gcdemn")
-               (string=? filename "poplat")
-               (string=? filename "prop1d")
-               (string=? filename "events")
-               (string=? filename "gdatab")
-               (string=? filename "boot")
-               (string=? filename "queue")
-               (string=? filename "gc")
-               (string=? filename "equals")
-               (string=? filename "list")
-               (string=? filename "record")))
-       (eval (fasload (map-filename filename) #t) environment))
-   unspecific)
- `((SORT-TYPE . MERGE-SORT)
-   (OS-TYPE . ,(intern os-name-string))
-   (OPTIONS . NO-LOAD)))
-
-(package-initialize '(RUNTIME MICROCODE-TABLES) 'READ-MICROCODE-TABLES!)
+;; Note: The following code needs MAP* and MEMBER-PROCEDURE
+;; from runtime/list. Fortunately that file has already been loaded.
+
+  ((eval (fasload "runtim.bldr" #f) system-global-environment)
+   (let ((to-avoid
+         (cons "packag"
+               (map* (if (and (implemented-primitive-procedure? file-exists?)
+                              (file-exists? "runtim.bad"))
+                         (fasload "runtim.bad" #f)
+                         '())
+                     car
+                     sine-qua-non)))
+        (string-member? (member-procedure string=?)))
+     (lambda (filename environment)
+       (if (not (string-member? filename to-avoid))
+          (eval (fasload (map-filename filename) #t) environment))
+       unspecific))
+   `((SORT-TYPE . MERGE-SORT)
+     (OS-TYPE . ,(intern os-name-string))
+     (OPTIONS . NO-LOAD))))
+
+(package-initialize '(RUNTIME MICROCODE-TABLES) 'READ-MICROCODE-TABLES! true)
 \f
-;; Funny stuff is done.  Rest of sequence is standardized.
+;;; Funny stuff is done.  Rest of sequence is standardized.
 (package-initialization-sequence
  '(
    ;; Microcode interface
@@ -333,6 +349,10 @@ MIT in each case. |#
    (RUNTIME STRING-INPUT)
    (RUNTIME STRING-OUTPUT)
    (RUNTIME TRUNCATED-STRING-OUTPUT)
+   ;; These MUST be done before (RUNTIME PATHNAME) 
+   ;; Typically only one of them is loaded.
+   (RUNTIME PATHNAME UNIX)
+   (RUNTIME PATHNAME DOS)
    (RUNTIME PATHNAME)
    (RUNTIME WORKING-DIRECTORY)
    (RUNTIME LOAD)
@@ -364,7 +384,7 @@ MIT in each case. |#
    ;; Emacs -- last because it grabs the kitchen sink.
    (RUNTIME EMACS-INTERFACE)))
 \f
-(package-initialize '(RUNTIME CONTINUATION-PARSER) 'INITIALIZE-SPECIAL-FRAMES!)
+(package-initialize '(RUNTIME CONTINUATION-PARSER) 'INITIALIZE-SPECIAL-FRAMES! false)
 
 (let ((filename (map-filename "site")))
   (if (file-exists? filename)

diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg
index a9c319f85ed6560e12483f5f4b597e64d61c8dc2..7207d74017e8fc929434844dafdac2c236838fbf 100644 (file)
--- a/v8/src/runtime/runtime.pkg
+++ b/v8/src/runtime/runtime.pkg
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.144 1992/04/06 19:54:43 bal Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.145 1992/04/11 23:48:00 jinx Exp $
 
-Copyright (c) 1988-92 Massachusetts Institute of Technology
+Copyright (c) 1988-1992 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -53,6 +53,7 @@ MIT in each case. |#
     (else))
   (file-case os-type
     ((unix) "unxprm")
+    ((dos) "dosprm")
     (else)))
 
 (define-package (package)
@@ -435,6 +436,7 @@ MIT in each case. |#
 (define-package (runtime directory)
   (file-case os-type
     ((unix) "unxdir")
+    ((dos) "dosdir")
     ;;(else "unkdir")
     (else))
   (parent ())
@@ -1455,10 +1457,18 @@ MIT in each case. |#
   (initialization (initialize-package!)))
 
 (define-package (runtime pathname unix)
-  (files "unxpth")
   (parent (runtime pathname))
-  (export (runtime pathname)
-         make-unix-host-type))
+  (file-case os-type
+   ((unix) "unxpth")
+   (else))
+  (initialization (initialize-package!)))
+
+(define-package (runtime pathname dos)
+  (parent (runtime pathname))
+  (file-case os-type
+   ((dos) "dospth")
+   (else))
+  (initialization (initialize-package!)))
 
 (define-package (runtime population)
   (files "poplat")