mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-03 13:20:26 +02:00
fix try-module-autoload, which did not detect failure to find the file
* libguile/load.c (scm_primitive_load_path): If the second argument is a procedure, call it like a thunk. * doc/ref/api-evaluation.texi (Load Paths): Update docs. * module/ice-9/boot-9.scm (resolve-interface): Use `unless'. (try-module-autoload): Use the new primitive-load-path to detect failure to find an appropriate file. Fixes a bug reported by Diogo F. S. Ramos. Thanks to Noah Lavine for tracking it down.
This commit is contained in:
parent
7f420e49e4
commit
f6fd2c03a5
3 changed files with 47 additions and 25 deletions
|
@ -1,6 +1,6 @@
|
||||||
@c -*-texinfo-*-
|
@c -*-texinfo-*-
|
||||||
@c This is part of the GNU Guile Reference Manual.
|
@c This is part of the GNU Guile Reference Manual.
|
||||||
@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2009, 2010, 2011, 2012
|
@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2009, 2010, 2011, 2012, 2013
|
||||||
@c Free Software Foundation, Inc.
|
@c Free Software Foundation, Inc.
|
||||||
@c See the file guile.texi for copying conditions.
|
@c See the file guile.texi for copying conditions.
|
||||||
|
|
||||||
|
@ -881,12 +881,17 @@ relative pathname and is not found in the list of search paths,
|
||||||
an error is signalled. Preferentially loads a compiled version of the
|
an error is signalled. Preferentially loads a compiled version of the
|
||||||
file, if it is available and up-to-date.
|
file, if it is available and up-to-date.
|
||||||
|
|
||||||
By default or if @var{exception-on-not-found} is true, an exception is
|
If @var{filename} is a relative pathname and is not found in the list of
|
||||||
raised if @var{filename} is not found. If @var{exception-on-not-found}
|
search paths, one of three things may happen, depending on the optional
|
||||||
is @code{#f} and @var{filename} is not found, no exception is raised and
|
second argument, @var{exception-on-not-found}. If it is @code{#f},
|
||||||
@code{#f} is returned. For compatibility with Guile 1.8 and earlier,
|
@code{#f} will be returned. If it is a procedure, it will be called
|
||||||
the C function takes only one argument, which can be either a string
|
with no arguments. (This allows a distinction to be made between
|
||||||
(the file name) or an argument list.
|
exceptions raised by loading a file, and exceptions related to the
|
||||||
|
loader itself.) Otherwise an error is signalled.
|
||||||
|
|
||||||
|
For compatibility with Guile 1.8 and earlier, the C function takes only
|
||||||
|
one argument, which can be either a string (the file name) or an
|
||||||
|
argument list.
|
||||||
@end deffn
|
@end deffn
|
||||||
|
|
||||||
@deffn {Scheme Procedure} %search-load-path filename
|
@deffn {Scheme Procedure} %search-load-path filename
|
||||||
|
|
|
@ -1,5 +1,5 @@
|
||||||
/* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2004, 2006, 2008,
|
/* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2004, 2006, 2008,
|
||||||
* 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
|
* 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
|
||||||
*
|
*
|
||||||
* This library is free software; you can redistribute it and/or
|
* This library is free software; you can redistribute it and/or
|
||||||
* modify it under the terms of the GNU Lesser General Public License
|
* modify it under the terms of the GNU Lesser General Public License
|
||||||
|
@ -846,11 +846,13 @@ canonical_suffix (SCM fname)
|
||||||
SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1,
|
SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1,
|
||||||
(SCM args),
|
(SCM args),
|
||||||
"Search @var{%load-path} for the file named @var{filename} and\n"
|
"Search @var{%load-path} for the file named @var{filename} and\n"
|
||||||
"load it into the top-level environment. If @var{filename} is a\n"
|
"load it into the top-level environment.\n\n"
|
||||||
"relative pathname and is not found in the list of search paths,\n"
|
"If @var{filename} is a relative pathname and is not found in\n"
|
||||||
"an error is signalled, unless the optional argument\n"
|
"the list of search paths, one of three things may happen,\n"
|
||||||
"@var{exception_on_not_found} is @code{#f}, in which case\n"
|
"depending on the optional second argument,\n"
|
||||||
"@code{#f} is returned instead.")
|
"@var{exception_on_not_found}. If it is @code{#f}, @code{#f}\n"
|
||||||
|
"will be returned. If it is a procedure, it will be called\n"
|
||||||
|
"with no arguments. Otherwise an error is signalled.")
|
||||||
#define FUNC_NAME s_scm_primitive_load_path
|
#define FUNC_NAME s_scm_primitive_load_path
|
||||||
{
|
{
|
||||||
SCM filename, exception_on_not_found;
|
SCM filename, exception_on_not_found;
|
||||||
|
@ -924,11 +926,13 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1,
|
||||||
|
|
||||||
if (scm_is_false (full_filename) && scm_is_false (compiled_filename))
|
if (scm_is_false (full_filename) && scm_is_false (compiled_filename))
|
||||||
{
|
{
|
||||||
if (scm_is_true (exception_on_not_found))
|
if (scm_is_true (scm_procedure_p (exception_on_not_found)))
|
||||||
|
return scm_call_0 (exception_on_not_found);
|
||||||
|
else if (scm_is_false (exception_on_not_found))
|
||||||
|
return SCM_BOOL_F;
|
||||||
|
else
|
||||||
SCM_MISC_ERROR ("Unable to find file ~S in load path",
|
SCM_MISC_ERROR ("Unable to find file ~S in load path",
|
||||||
scm_list_1 (filename));
|
scm_list_1 (filename));
|
||||||
else
|
|
||||||
return SCM_BOOL_F;
|
|
||||||
}
|
}
|
||||||
|
|
||||||
if (!scm_is_false (hook))
|
if (!scm_is_false (hook))
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
;;; -*- mode: scheme; coding: utf-8; -*-
|
;;; -*- mode: scheme; coding: utf-8; -*-
|
||||||
|
|
||||||
;;;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
|
;;;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
|
||||||
;;;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012
|
;;;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013
|
||||||
;;;; Free Software Foundation, Inc.
|
;;;; Free Software Foundation, Inc.
|
||||||
;;;;
|
;;;;
|
||||||
;;;; This library is free software; you can redistribute it and/or
|
;;;; This library is free software; you can redistribute it and/or
|
||||||
|
@ -2593,7 +2593,7 @@ VALUE."
|
||||||
version)
|
version)
|
||||||
(let* ((module (resolve-module name #t version #:ensure #f))
|
(let* ((module (resolve-module name #t version #:ensure #f))
|
||||||
(public-i (and module (module-public-interface module))))
|
(public-i (and module (module-public-interface module))))
|
||||||
(and (or (not module) (not public-i))
|
(unless public-i
|
||||||
(error "no code for module" name))
|
(error "no code for module" name))
|
||||||
(if (and (not select) (null? hide) (eq? renamer identity))
|
(if (and (not select) (null? hide) (eq? renamer identity))
|
||||||
public-i
|
public-i
|
||||||
|
@ -2765,10 +2765,13 @@ module '(ice-9 q) '(make-q q-length))}."
|
||||||
|
|
||||||
(define autoloads-in-progress '())
|
(define autoloads-in-progress '())
|
||||||
|
|
||||||
;; This function is called from "modules.c". If you change it, be
|
;; This function is called from scm_load_scheme_module in
|
||||||
;; sure to update "modules.c" as well.
|
;; "deprecated.c". Please do not change its interface.
|
||||||
|
;;
|
||||||
(define* (try-module-autoload module-name #:optional version)
|
(define* (try-module-autoload module-name #:optional version)
|
||||||
|
"Try to load a module of the given name. If it is not found, return
|
||||||
|
#f. Otherwise return #t. May raise an exception if a file is found,
|
||||||
|
but it fails to load."
|
||||||
(let* ((reverse-name (reverse module-name))
|
(let* ((reverse-name (reverse module-name))
|
||||||
(name (symbol->string (car reverse-name)))
|
(name (symbol->string (car reverse-name)))
|
||||||
(dir-hint-module-name (reverse (cdr reverse-name)))
|
(dir-hint-module-name (reverse (cdr reverse-name)))
|
||||||
|
@ -2785,6 +2788,13 @@ module '(ice-9 q) '(make-q q-length))}."
|
||||||
(with-fluids ((current-reader #f))
|
(with-fluids ((current-reader #f))
|
||||||
(save-module-excursion
|
(save-module-excursion
|
||||||
(lambda ()
|
(lambda ()
|
||||||
|
(define (call/ec proc)
|
||||||
|
(let ((tag (make-prompt-tag)))
|
||||||
|
(call-with-prompt
|
||||||
|
tag
|
||||||
|
(lambda ()
|
||||||
|
(proc (lambda () (abort-to-prompt tag))))
|
||||||
|
(lambda (k) (values)))))
|
||||||
;; The initial environment when loading a module is a fresh
|
;; The initial environment when loading a module is a fresh
|
||||||
;; user module.
|
;; user module.
|
||||||
(set-current-module (make-fresh-user-module))
|
(set-current-module (make-fresh-user-module))
|
||||||
|
@ -2794,8 +2804,11 @@ module '(ice-9 q) '(make-q q-length))}."
|
||||||
;; out how to locate the compiled file, do auto-compilation,
|
;; out how to locate the compiled file, do auto-compilation,
|
||||||
;; etc. Punt for now, and don't use versions when locating
|
;; etc. Punt for now, and don't use versions when locating
|
||||||
;; the file.
|
;; the file.
|
||||||
(primitive-load-path (in-vicinity dir-hint name) #f)
|
(call/ec
|
||||||
(set! didit #t)))))
|
(lambda (abort)
|
||||||
|
(primitive-load-path (in-vicinity dir-hint name)
|
||||||
|
abort)
|
||||||
|
(set! didit #t)))))))
|
||||||
(lambda () (set-autoloaded! dir-hint name didit)))
|
(lambda () (set-autoloaded! dir-hint name didit)))
|
||||||
didit))))
|
didit))))
|
||||||
|
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue