1
Fork 0
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:
Andy Wingo 2013-01-20 19:33:42 +01:00
parent 7f420e49e4
commit f6fd2c03a5
3 changed files with 47 additions and 25 deletions

View file

@ -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.
@ -878,15 +878,20 @@ of modifying the path both at compile-time and at run-time.
Search @code{%load-path} for the file named @var{filename} and Search @code{%load-path} for the file named @var{filename} and
load it into the top-level environment. If @var{filename} is a load it into the top-level environment. If @var{filename} is a
relative pathname and is not found in the list of search paths, 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

View file

@ -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))

View file

@ -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,8 +2593,8 @@ 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
(let ((selection (or select (module-map (lambda (sym var) sym) (let ((selection (or select (module-map (lambda (sym var) sym)
@ -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))))