From cde69cceafe034c798eaa77ebffd9c622fda5df4 Mon Sep 17 00:00:00 2001 From: "Guillermo J. Rozas" Date: Sat, 11 Apr 1992 23:49:03 +0000 Subject: [PATCH] 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. --- v7/src/runtime/make.scm | 178 +++++++++++++++++++++---------------- v7/src/runtime/pathnm.scm | 78 +++++++++++++--- v7/src/runtime/runtime.pkg | 20 +++-- v7/src/runtime/unxpth.scm | 7 +- v7/src/runtime/version.scm | 6 +- v8/src/runtime/make.scm | 178 +++++++++++++++++++++---------------- v8/src/runtime/runtime.pkg | 20 +++-- 7 files changed, 302 insertions(+), 185 deletions(-) diff --git a/v7/src/runtime/make.scm b/v7/src/runtime/make.scm index 5a3f5eeb5..576fadb24 100644 --- 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)) ;;;; 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)))))) (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) -;; 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))) -(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 4b603784e..c32af2cbc 100644 --- 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!)) + +(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 dfc859500..eff7935fd 100644 --- 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 6c7407543..1892022f3 100644 --- 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)) ;;;; Pathname Parser diff --git a/v7/src/runtime/version.scm b/v7/src/runtime/version.scm index 04f759d59..e602d3524 100644 --- 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 d8b9f97cd..6842df511 100644 --- 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)) ;;;; 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)))))) (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) -;; 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))) -(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 a9c319f85..7207d7401 100644 --- 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") -- 2.25.1