From 73924f53b80e4c0c08676a2b1529a99d5c11790a Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Mon, 13 Jun 1988 10:50:01 +0000 Subject: [PATCH] *** empty log message *** --- v7/src/runtime/packag.scm | 121 ++++++++++++++++++++++++++++++++ v7/src/runtime/unxdir.scm | 138 +++++++++++++++++++++++++++++++++++++ v7/src/runtime/version.scm | 43 ++++++++++++ v7/src/runtime/wrkdir.scm | 52 ++++++++++++++ 4 files changed, 354 insertions(+) create mode 100644 v7/src/runtime/packag.scm create mode 100644 v7/src/runtime/unxdir.scm create mode 100644 v7/src/runtime/version.scm create mode 100644 v7/src/runtime/wrkdir.scm diff --git a/v7/src/runtime/packag.scm b/v7/src/runtime/packag.scm new file mode 100644 index 000000000..0efecfce5 --- /dev/null +++ b/v7/src/runtime/packag.scm @@ -0,0 +1,121 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/packag.scm,v 14.1 1988/06/13 10:49:50 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Simple Package Namespace + +(declare (usual-integrations)) + +(define-structure (package + (constructor make-package (parent %name environment)) + (conc-name package/) + (print-procedure false)) + (parent false read-only true) + (children '()) + (%name false read-only true) + (environment false read-only true)) + +(define (package/child package name) + (let loop ((children (package/children package))) + (and (not (null? children)) + (if (eq? name (package/%name (car children))) + (car children) + (loop (cdr children)))))) + +(define (package/name package) + (let loop ((package package) (result '())) + (if (package/parent package) + (loop (package/parent package) (cons (package/%name package) result)) + result))) + +(define (name->package name) + (let loop ((path name) (package system-global-package)) + (if (null? path) + package + (let ((child (package/child package (car path)))) + (and child + (loop (cdr path) child)))))) + +(define (find-package name) + (let loop ((path name) (package system-global-package)) + (if (null? path) + package + (loop (cdr path) + (or (package/child package (car path)) + (error "Unable to find package" + (list-difference name (cdr path)))))))) + +(define (list-difference list tail) + (let loop ((list list)) + (if (eq? list tail) + '() + (cons (car list) (loop (cdr list)))))) + +(define (package/add-child! package name environment) + (if (package/child package name) + (error "Package already has child of given name" package name)) + (let ((child (make-package package name environment))) + (set-package/children! package (cons child (package/children package))) + child)) + +(define system-global-package) + +(define (package/system-loader filename options load-interpreted?) + (let ((pathname (->pathname filename))) + (with-working-directory-pathname (pathname-directory-path pathname) + (lambda () + (fluid-let ((load/default-types + (if (if (eq? load-interpreted? 'QUERY) + (prompt-for-confirmation "Load interpreted? ") load-interpreted?) + '("bin" "scm") + load/default-types))) + (load (pathname-new-type pathname "bcon") system-global-environment) + ((load (pathname-new-type pathname "bldr") system-global-environment) + (let ((syntax-table (standard-repl-syntax-table))) + (lambda (filename environment) + (load filename environment syntax-table true))) + options))))) + *the-non-printing-object*) + +(define-integrable (package/reference package name) + (lexical-reference (package/environment package) name)) + +(define (initialize-package!) + (set! system-global-package + (make-package false false system-global-environment))) + +(define (initialize-unparser!) + (unparser/set-tagged-vector-method! package + (unparser/standard-method 'PACKAGE + (lambda (state package) + (unparse-object state (package/name package)))))) \ No newline at end of file diff --git a/v7/src/runtime/unxdir.scm b/v7/src/runtime/unxdir.scm new file mode 100644 index 000000000..5f1aaed66 --- /dev/null +++ b/v7/src/runtime/unxdir.scm @@ -0,0 +1,138 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unxdir.scm,v 14.1 1988/06/13 10:49:56 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Directory Operations -- unix +;;; package: (directory) + +(declare (usual-integrations)) + +(define (initialize-package!) + (set! associate-on-name (association-procedure string=? car)) + (set! typeabsolute-pathname (->pathname pattern)))) + (map (let ((directory-path (pathname-directory-path pattern))) + (lambda (pathname) + (merge-pathnames directory-path pathname))) + (let ((pathnames + (generate-directory-pathnames + (pathname-directory-string pattern)))) + (if (eq? (pathname-version pattern) 'NEWEST) + (extract-greatest-versions + (list-transform-positive pathnames + (lambda (instance) + (match-name&type pattern instance)))) + (list-transform-positive pathnames + (lambda (instance) + (and (match-name&type pattern instance) + (match-component + (pathname-version pattern) + (pathname-version instance))))))))))) + +(define (match-name&type pattern instance) + (and (match-component (pathname-name pattern) (pathname-name instance)) + (match-component (pathname-type pattern) (pathname-type instance)))) + +(define (match-component pattern instance) + (or (eq? pattern 'WILD) + (equal? pattern instance))) + +(define (extract-greatest-versions pathnames) + (let ((name-alist '())) + (for-each (lambda (pathname) + (let ((name (pathname-name pathname)) + (type (pathname-type pathname))) + (let ((name-entry (associate-on-name name name-alist))) + (if (not name-entry) + (set! name-alist + (cons (list name (cons type pathname)) + name-alist)) + (let ((type-entry + (associate-on-type type (cdr name-entry)))) + (cond ((not type-entry) + (set-cdr! name-entry + (cons (cons type pathname) + (cdr name-entry)))) + ((versionpathname + (let loop ((name ((ucode-primitive open-directory) directory-string))) + (if name + (cons name (loop ((ucode-primitive directory-read)))) + '())))) \ No newline at end of file diff --git a/v7/src/runtime/version.scm b/v7/src/runtime/version.scm new file mode 100644 index 000000000..515b9b25d --- /dev/null +++ b/v7/src/runtime/version.scm @@ -0,0 +1,43 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.1 1988/06/13 10:47:01 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Runtime System Version Information + +(declare (usual-integrations)) + +(add-system! (make-system "Microcode" + microcode-id/version + microcode-id/modification + '())) +(add-system! (make-system "Runtime" 14 1 '())) \ No newline at end of file diff --git a/v7/src/runtime/wrkdir.scm b/v7/src/runtime/wrkdir.scm new file mode 100644 index 000000000..af756329c --- /dev/null +++ b/v7/src/runtime/wrkdir.scm @@ -0,0 +1,52 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/wrkdir.scm,v 14.1 1988/06/13 10:50:01 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Working Directory +;;; package: (working-directory) + +(declare (usual-integrations)) + +(define (with-working-directory-pathname name thunk) + (let ((old-pathname)) + (dynamic-wind (lambda () + (set! old-pathname (working-directory-pathname)) + (set-working-directory-pathname! name)) + thunk + (lambda () + (set! name (working-directory-pathname)) + (set-working-directory-pathname! old-pathname))))) + +(define (hook/set-working-directory-pathname! pathname) + pathname + false) \ No newline at end of file -- 2.25.1