From 3d0a46fe309a8c5b04dd4e1e38e82509d0ef9674 Mon Sep 17 00:00:00 2001 From: Mark Friedman Date: Thu, 12 Apr 1990 21:56:31 +0000 Subject: [PATCH] Added LOAD-LATEST and FASLOAD-LATEST to load the most recently modified version among the LOAD/DEFAULT-TYPES. Added a variable LOAD/DEFAULT-FIND-PATHNAME-WITH-TYPE which may be set to a procedure which tells load how to decide which file type to use. The procedure accepts a pathname and a list of file type strings (usually this will be LOAD/DEFAULT-TYPES) and should return the complete pathname for load to use. --- v7/src/runtime/load.scm | 60 ++++++++++++++++++++++++++++++-------- v7/src/runtime/runtime.pkg | 5 +++- v8/src/runtime/load.scm | 60 ++++++++++++++++++++++++++++++-------- v8/src/runtime/runtime.pkg | 5 +++- 4 files changed, 104 insertions(+), 26 deletions(-) diff --git a/v7/src/runtime/load.scm b/v7/src/runtime/load.scm index ddfcb7f23..bf2e0efd8 100644 --- a/v7/src/runtime/load.scm +++ b/v7/src/runtime/load.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/load.scm,v 14.12 1990/04/10 15:53:06 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/load.scm,v 14.13 1990/04/12 21:56:31 markf Exp $ Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology @@ -141,22 +141,58 @@ MIT in each case. |# (loop (cdr filenames))))) (kernel filename/s true))))) +(define (load-latest . args) + (fluid-let ((load/default-find-pathname-with-type find-latest-file)) + (apply load args))) + +(define (fasload-latest . args) + (fluid-let ((load/default-find-pathname-with-type find-latest-file)) + (apply fasload args))) + +(define (find-latest-file pathname default-types) + (let loop ((types default-types) + (latest-pathname #f) + (latest-modification-time 0)) + (if (not (pair? types)) + latest-pathname + (let* ((complete-pathname + (find-complete-pathname + (pathname-new-type pathname (car types)))) + (modification-time + (if complete-pathname + (file-modification-time complete-pathname) + -1))) + (if (> modification-time latest-modification-time) + (loop (cdr types) + complete-pathname + modification-time) + (loop (cdr types) + latest-pathname + latest-modification-time)))))) + (define default-object "default-object") (define (find-true-pathname pathname default-types) - (or (let ((try - (lambda (pathname) - (pathname->input-truename - (pathname-default-version pathname 'NEWEST))))) - (if (pathname-type pathname) - (try pathname) - (or (pathname->input-truename pathname) - (let loop ((types default-types)) - (and (not (null? types)) - (or (try (pathname-new-type pathname (car types))) - (loop (cdr types)))))))) + (or (if (pathname-type pathname) + (find-complete-pathname pathname) + (or (pathname->input-truename pathname) + (load/default-find-pathname-with-type + pathname + default-types))) (error "No such file" pathname))) + +(define (search-types-in-order pathname default-types) + (let loop ((types default-types)) + (and (not (null? types)) + (or (find-complete-pathname + (pathname-new-type pathname (car types))) + (loop (cdr types)))))) + +(define (find-complete-pathname pathname) + (pathname->input-truename + (pathname-default-version pathname 'NEWEST))) + (define (load/internal pathname true-pathname environment syntax-table purify? load-noisily?) diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index ba305bd03..fa9f817f7 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.64 1990/04/10 20:05:18 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.65 1990/04/12 21:53:41 markf Exp $ Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology @@ -909,9 +909,12 @@ MIT in each case. |# fasload fasload/default-types load + load-latest + fasload-latest load-noisily load-noisily? load/default-types + load/default-find-pathname-with-type load/suppress-loading-message? read-file) (initialization (initialize-package!))) diff --git a/v8/src/runtime/load.scm b/v8/src/runtime/load.scm index a12533761..c65c23a7b 100644 --- a/v8/src/runtime/load.scm +++ b/v8/src/runtime/load.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/load.scm,v 14.12 1990/04/10 15:53:06 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/load.scm,v 14.13 1990/04/12 21:56:31 markf Exp $ Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology @@ -141,22 +141,58 @@ MIT in each case. |# (loop (cdr filenames))))) (kernel filename/s true))))) +(define (load-latest . args) + (fluid-let ((load/default-find-pathname-with-type find-latest-file)) + (apply load args))) + +(define (fasload-latest . args) + (fluid-let ((load/default-find-pathname-with-type find-latest-file)) + (apply fasload args))) + +(define (find-latest-file pathname default-types) + (let loop ((types default-types) + (latest-pathname #f) + (latest-modification-time 0)) + (if (not (pair? types)) + latest-pathname + (let* ((complete-pathname + (find-complete-pathname + (pathname-new-type pathname (car types)))) + (modification-time + (if complete-pathname + (file-modification-time complete-pathname) + -1))) + (if (> modification-time latest-modification-time) + (loop (cdr types) + complete-pathname + modification-time) + (loop (cdr types) + latest-pathname + latest-modification-time)))))) + (define default-object "default-object") (define (find-true-pathname pathname default-types) - (or (let ((try - (lambda (pathname) - (pathname->input-truename - (pathname-default-version pathname 'NEWEST))))) - (if (pathname-type pathname) - (try pathname) - (or (pathname->input-truename pathname) - (let loop ((types default-types)) - (and (not (null? types)) - (or (try (pathname-new-type pathname (car types))) - (loop (cdr types)))))))) + (or (if (pathname-type pathname) + (find-complete-pathname pathname) + (or (pathname->input-truename pathname) + (load/default-find-pathname-with-type + pathname + default-types))) (error "No such file" pathname))) + +(define (search-types-in-order pathname default-types) + (let loop ((types default-types)) + (and (not (null? types)) + (or (find-complete-pathname + (pathname-new-type pathname (car types))) + (loop (cdr types)))))) + +(define (find-complete-pathname pathname) + (pathname->input-truename + (pathname-default-version pathname 'NEWEST))) + (define (load/internal pathname true-pathname environment syntax-table purify? load-noisily?) diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg index 483cf1343..6f11d52f3 100644 --- a/v8/src/runtime/runtime.pkg +++ b/v8/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.64 1990/04/10 20:05:18 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.65 1990/04/12 21:53:41 markf Exp $ Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology @@ -909,9 +909,12 @@ MIT in each case. |# fasload fasload/default-types load + load-latest + fasload-latest load-noisily load-noisily? load/default-types + load/default-find-pathname-with-type load/suppress-loading-message? read-file) (initialization (initialize-package!))) -- 2.25.1