From: Chris Hanson Date: Mon, 21 May 2007 17:33:32 +0000 (+0000) Subject: Add optional REQUIRED? arguments to SYSTEM-LIBRARY-PATHNAME and X-Git-Tag: 20090517-FFI~555 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=bc7e7484c8d67fc79b1e1c2252c651d3cca03a34;p=mit-scheme.git Add optional REQUIRED? arguments to SYSTEM-LIBRARY-PATHNAME and SYSTEM-LIBRARY-DIRECTORY-PATHNAME. When new arg not supplied, each behaves as it used to. --- diff --git a/v7/src/runtime/option.scm b/v7/src/runtime/option.scm index b9b64ff73..f3fdeb607 100644 --- a/v7/src/runtime/option.scm +++ b/v7/src/runtime/option.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: option.scm,v 14.54 2007/05/01 04:55:22 cph Exp $ +$Id: option.scm,v 14.55 2007/05/21 17:33:31 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -50,8 +50,7 @@ USA. (fluid-let ((*options* '()) (*parent* #f)) (fluid-let ((load/suppress-loading-message? #t)) - (load-latest (merge-pathnames file - (library-directory-pathname "")) + (load-latest (system-library-pathname file #f) (make-load-environment) 'DEFAULT #f)) @@ -94,7 +93,8 @@ USA. (define (library-file? library-internal-path) (confirm-pathname - (merge-pathnames library-internal-path (library-directory-pathname "")))) + (merge-pathnames library-internal-path + (system-library-directory-pathname)))) (define (confirm-pathname pathname) (receive (pathname* loader) @@ -122,7 +122,8 @@ USA. (purify obj) (scode-eval obj environment))) (else - (let* ((options (library-directory-pathname "options")) + (let* ((options + (system-library-directory-pathname "options" #t)) (pathname (merge-pathnames file options))) (with-directory-rewriting-rule options runtime (lambda () @@ -138,29 +139,17 @@ USA. (eval init-expression environment)))) (define (declare-shared-library shared-library thunk) - (let ((thunk-valid? - (lambda (thunk) - (not (condition? (ignore-errors thunk)))))) - (add-event-receiver! - event:after-restore - (lambda () - (if (not (thunk-valid? thunk)) - (fluid-let ((load/suppress-loading-message? #t)) - (load - (merge-pathnames shared-library - (library-directory-pathname "lib"))))))))) + (add-event-receiver! + event:after-restore + (lambda () + (if (condition? (ignore-errors thunk)) + (fluid-let ((load/suppress-loading-message? #t)) + (load + (merge-pathnames + shared-library + (system-library-directory-pathname "lib" #t)))))))) (define (force* value) (cond ((procedure? value) (force* (value))) ((promise? value) (force* (force value))) - (else value))) - -(define (library-directory-pathname name) - (or (system-library-directory-pathname name) - (library-directory-pathname - (error:file-operation name - "find" - "directory" - "no such directory in system library path" - library-directory-pathname - (list name))))) \ No newline at end of file + (else value))) \ No newline at end of file diff --git a/v7/src/runtime/pathnm.scm b/v7/src/runtime/pathnm.scm index b9e4622f9..2f16951db 100644 --- a/v7/src/runtime/pathnm.scm +++ b/v7/src/runtime/pathnm.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: pathnm.scm,v 14.51 2007/01/05 21:19:28 cph Exp $ +$Id: pathnm.scm,v 14.52 2007/05/21 17:33:32 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -591,45 +591,43 @@ these rules: local-host))) ((host-type/operation/init-file-pathname (host/type host)) host))) -(define (system-library-pathname pathname) - (let ((try-directory - (lambda (directory) - (let ((pathname (merge-pathnames pathname directory))) - (and (file-exists? pathname) - pathname)))) - (loser - (lambda () - (system-library-pathname - (->pathname - (error:file-operation pathname - "find" - "file" - "no such file in system library path" - system-library-pathname - (list pathname))))))) - (if (pathname-absolute? pathname) - (if (file-exists? pathname) pathname (loser)) - (let loop ((directories library-directory-path)) - (if (null? directories) - (loser) - (or (try-directory (car directories)) - (loop (cdr directories)))))))) +(define (system-library-pathname pathname #!optional required?) + (let ((pathname* (merge-pathnames pathname (%find-library-directory))) + (required? (if (default-object? required?) #t required?))) + (if (and required? (not (file-exists? pathname*))) + (system-library-pathname + (error:file-operation pathname* + "find" + "file" + "no such file in system library path" + system-library-pathname + (list pathname required?))) + pathname*))) + +(define (system-library-directory-pathname #!optional pathname required?) + (if (if (default-object? pathname) #f pathname) + (let ((dir (system-library-pathname pathname #f))) + (cond ((file-directory? dir) + (pathname-as-directory dir)) + ((if (default-object? required?) #f required?) + (system-library-directory-pathname + (error:file-operation + pathname + "find" + "directory" + "no such directory in system library path" + system-library-directory-pathname + (list pathname required?)) + required?)) + (else #f))) + (%find-library-directory))) + +(define (%find-library-directory) + (pathname-as-directory + (or (find-matching-item library-directory-path file-directory?) + (error "Can't find library directory.")))) (define library-directory-path) - -(define (system-library-directory-pathname pathname) - (if (not pathname) - (let ((pathname - (list-search-positive library-directory-path file-directory?))) - (if (not pathname) - (error "can't find system library directory")) - (pathname-as-directory pathname)) - (let loop ((directories library-directory-path)) - (and (not (null? directories)) - (let ((pathname (merge-pathnames pathname (car directories)))) - (if (file-directory? pathname) - (pathname-as-directory pathname) - (loop (cdr directories)))))))) (define known-host-types '((0 UNIX)