mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

primitive-load returns the value(s) of the last expression

Browse source 
* libguile/load.c (scm_primitive_load): Return the values yielded from
  evaluating the last expression in the file.

* test-suite/tests/load.test ("return value of `load'"): Add tests.
This commit is contained in:
Andy Wingo 2012-01-09 16:07:46 +01:00
parent 9858e52962
commit 017eb4a6be
2 changed files with 25 additions and 7 deletions
Download patch file Download diff file Expand all files Collapse all files

12
libguile/load.c
View file

@ -87,7 +87,9 @@ SCM_DEFINE (scm_primitive_load, "primitive-load", 1, 0, 0,
#define FUNC_NAME s_scm_primitive_load #define FUNC_NAME s_scm_primitive_load
{ {
SCM hook = *scm_loc_load_hook; SCM hook = *scm_loc_load_hook;
SCM ret = SCM_UNSPECIFIED;
char *encoding; char *encoding;
SCM_VALIDATE_STRING (1, filename); SCM_VALIDATE_STRING (1, filename);
if (scm_is_true (hook) && scm_is_false (scm_procedure_p (hook))) if (scm_is_true (hook) && scm_is_false (scm_procedure_p (hook)))
SCM_MISC_ERROR ("value of %load-hook is neither a procedure nor #f", SCM_MISC_ERROR ("value of %load-hook is neither a procedure nor #f",
@ -96,8 +98,10 @@ SCM_DEFINE (scm_primitive_load, "primitive-load", 1, 0, 0,
if (!scm_is_false (hook)) if (!scm_is_false (hook))
scm_call_1 (hook, filename); scm_call_1 (hook, filename);
{ /* scope */ {
SCM port = scm_open_file (filename, scm_from_locale_string ("r")); SCM port;
port = scm_open_file (filename, scm_from_locale_string ("r"));
scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE); scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
scm_i_dynwind_current_load_port (port); scm_i_dynwind_current_load_port (port);
@ -124,13 +128,13 @@ SCM_DEFINE (scm_primitive_load, "primitive-load", 1, 0, 0,
if (SCM_EOF_OBJECT_P (form)) if (SCM_EOF_OBJECT_P (form))
break; break;
scm_primitive_eval_x (form); ret = scm_primitive_eval_x (form);
} }
scm_dynwind_end (); scm_dynwind_end ();
scm_close_port (port); scm_close_port (port);
} }
return SCM_UNSPECIFIED; return ret;
} }
#undef FUNC_NAME #undef FUNC_NAME

20
test-suite/tests/load.test
View file

@ -1,7 +1,7 @@
;;;; load.test --- test LOAD and path searching functions -*- scheme -*- ;;;; load.test --- test LOAD and path searching functions -*- scheme -*-
;;;; Jim Blandy <jimb@red-bean.com> --- September 1999 ;;;; Jim Blandy <jimb@red-bean.com> --- September 1999
;;;; ;;;;
;;;; Copyright (C) 1999, 2001, 2006, 2010 Free Software Foundation, Inc. ;;;; Copyright (C) 1999, 2001, 2006, 2010, 2012 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 ;;;; modify it under the terms of the GNU Lesser General Public
@ -18,8 +18,9 @@
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-suite test-load) (define-module (test-suite test-load)
:use-module (test-suite lib) #:use-module (test-suite lib)
:use-module (test-suite guile-test)) #:use-module (test-suite guile-test)
#:use-module (system base compile))
(define temp-dir (data-file-name "load-test.dir")) (define temp-dir (data-file-name "load-test.dir"))
@ -124,4 +125,17 @@
(try-search-with-extensions path "ugly.scm" extensions "dir3/ugly.scm") (try-search-with-extensions path "ugly.scm" extensions "dir3/ugly.scm")
(try-search-with-extensions path "ugly.ss" extensions #f)) (try-search-with-extensions path "ugly.ss" extensions #f))
(with-test-prefix "return value of `load'"
(let ((temp-file (in-vicinity temp-dir "foo.scm")))
(call-with-output-file temp-file
(lambda (port)
(write '(+ 2 3) port)
(newline port)))
(pass-if "primitive-load"
(equal? 5 (primitive-load temp-file)))
(let ((temp-compiled-file (in-vicinity temp-dir "foo.go")))
(compile-file temp-file #:output-file temp-compiled-file)
(pass-if "load-compiled"
(equal? 5 (load-compiled temp-compiled-file))))))
(delete-tree temp-dir) (delete-tree temp-dir)