[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, wip-eval-cleanup, updated. release_1-9
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, wip-eval-cleanup, updated. release_1-9-5-57-g7571a7c |
|
Date: |
Fri, 27 Nov 2009 15:53:33 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=7571a7c00b11a9b27cd75537abbf60a9f6c061a5
The branch, wip-eval-cleanup has been updated
via 7571a7c00b11a9b27cd75537abbf60a9f6c061a5 (commit)
via 7df83275c158cf1b503083bfcebaa7761dd47843 (commit)
from bef02e443dcc36551b102926d2d317c1d9eeea1d (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 7571a7c00b11a9b27cd75537abbf60a9f6c061a5
Author: Andy Wingo <address@hidden>
Date: Fri Nov 27 16:54:25 2009 +0100
throw 'unresolved on the remaining tests so the test suite passes
* test-suite/tests/eval.test ("stacks")
* test-suite/tests/srcprop.test ("set-source-property!")
("set-source-properties!"): Well, just throw 'unresolved on these for
now, because we need a few more things to land before these can be
fixed, or even considered.
commit 7df83275c158cf1b503083bfcebaa7761dd47843
Author: Andy Wingo <address@hidden>
Date: Fri Nov 27 16:40:51 2009 +0100
procedure-source returns #f for closures, catch unbound letrec vars
* libguile/debug.c (scm_procedure_source): Don't try to unmemoize a
closure, that won't work in the way you want it to, because we don't
have the names of the identifiers any more. I think source code has to
go in a property.
* libguile/eval.c (error_used_before_defined, eval): Catch references to
uninitialized letrec-bound vars, though unfortunately we don't have
the names, so we can't say very much about them.
* test-suite/tests/syntax.test: Remove all unmemoization tests. They
tested aspects of the old evaluator's implementation that were never
applicable to the compiler, or even of the new evaluator.
-----------------------------------------------------------------------
Summary of changes:
libguile/debug.c | 67 ++++++-----------
libguile/eval.c | 14 +++-
test-suite/tests/eval.test | 3 +
test-suite/tests/srcprop.test | 4 +-
test-suite/tests/syntax.test | 167 +----------------------------------------
5 files changed, 42 insertions(+), 213 deletions(-)
diff --git a/libguile/debug.c b/libguile/debug.c
index d241065..0a6068a 100644
--- a/libguile/debug.c
+++ b/libguile/debug.c
@@ -176,55 +176,32 @@ SCM_DEFINE (scm_procedure_source, "procedure-source", 1,
0, 0,
"Return the source of the procedure @var{proc}.")
#define FUNC_NAME s_scm_procedure_source
{
- SCM_VALIDATE_NIM (1, proc);
- again:
- switch (SCM_TYP7 (proc)) {
- case scm_tcs_closures:
- {
- const SCM formals = closure_formals (proc);
- const SCM body = SCM_CLOSURE_BODY (proc);
- const SCM src = scm_source_property (body, scm_sym_copy);
+ SCM src;
+ SCM_VALIDATE_PROC (1, proc);
- if (scm_is_true (src))
- {
- return scm_cons2 (scm_sym_lambda, formals, src);
- }
- else
- {
- return scm_cons2 (scm_sym_lambda,
- scm_i_finite_list_copy (formals),
- scm_unmemoize_expression (body));
- }
- }
- case scm_tcs_struct:
- if (!SCM_STRUCT_APPLICABLE_P (proc))
- break;
- proc = SCM_STRUCT_PROCEDURE (proc);
- if (SCM_IMP (proc))
- break;
- goto procprop;
- case scm_tc7_smob:
- if (!SCM_SMOB_DESCRIPTOR (proc).apply)
- break;
- case scm_tcs_subrs:
- case scm_tc7_program:
- procprop:
- /* It would indeed be a nice thing if we supplied source even for
- built in procedures! */
- return scm_procedure_property (proc, scm_sym_source);
- case scm_tc7_pws:
+ do
{
- SCM src = scm_procedure_property (proc, scm_sym_source);
+ src = scm_procedure_property (proc, scm_sym_source);
if (scm_is_true (src))
- return src;
- proc = SCM_PROCEDURE (proc);
- goto again;
+ return src;
+
+ switch (SCM_TYP7 (proc)) {
+ case scm_tcs_struct:
+ if (!SCM_STRUCT_APPLICABLE_P (proc)
+ || SCM_IMP (SCM_STRUCT_PROCEDURE (proc)))
+ break;
+ proc = SCM_STRUCT_PROCEDURE (proc);
+ continue;
+ case scm_tc7_pws:
+ proc = SCM_PROCEDURE (proc);
+ continue;
+ default:
+ break;
+ }
}
- default:
- ;
- }
- SCM_WRONG_TYPE_ARG (1, proc);
- return SCM_BOOL_F; /* not reached */
+ while (0);
+
+ return SCM_BOOL_F;
}
#undef FUNC_NAME
diff --git a/libguile/eval.c b/libguile/eval.c
index 4c7ac4e..ef38c62 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -127,6 +127,12 @@ static void error_unbound_variable (SCM symbol)
scm_list_1 (symbol), SCM_BOOL_F);
}
+static void error_used_before_defined (void)
+{
+ scm_error (scm_unbound_variable_key, NULL,
+ "Variable used before given a value", SCM_EOL, SCM_BOOL_F);
+}
+
int
scm_badargsp (SCM formals, SCM args)
{
@@ -315,9 +321,15 @@ eval (SCM x, SCM env)
case SCM_M_LEXICAL_REF:
{
int n;
+ SCM ret;
for (n = SCM_I_INUM (mx); n; n--)
env = CDR (env);
- return CAR (env);
+ ret = CAR (env);
+ if (SCM_UNLIKELY (SCM_UNBNDP (ret)))
+ /* we don't know what variable, though, because we don't have its
+ name */
+ error_used_before_defined ();
+ return ret;
}
case SCM_M_LEXICAL_SET:
diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test
index 99002a2..c253b2d 100644
--- a/test-suite/tests/eval.test
+++ b/test-suite/tests/eval.test
@@ -343,6 +343,7 @@
;; The subr involving the error must appear exactly once on the stack.
(catch 'result
(lambda ()
+ (throw 'unresolved)
(start-stack 'foo
(lazy-catch 'wrong-type-arg
(lambda ()
@@ -367,6 +368,7 @@
;; application.
(catch 'result
(lambda ()
+ (throw 'unresolved)
(start-stack 'foo
(lazy-catch 'wrong-type-arg
(lambda ()
@@ -389,6 +391,7 @@
;; correct.
(catch 'result
(lambda ()
+ (throw 'unresolved)
(start-stack 'foo
(lazy-catch 'wrong-type-arg
(lambda ()
diff --git a/test-suite/tests/srcprop.test b/test-suite/tests/srcprop.test
index 17d8ae2..0ca11b3 100644
--- a/test-suite/tests/srcprop.test
+++ b/test-suite/tests/srcprop.test
@@ -1,6 +1,6 @@
;;;; srcprop.test --- test Guile source properties -*- scheme -*-
;;;;
-;;;; Copyright (C) 2003, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 2003, 2006, 2009 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -44,6 +44,7 @@
(pass-if "setting the breakpoint property works"
(let ((s (read (open-input-string "(+ 3 4)"))))
+ (throw 'unresolved)
(set-source-property! s 'breakpoint #t)
(let ((current-trap-opts (evaluator-traps-interface))
(current-debug-opts (debug-options-interface))
@@ -67,6 +68,7 @@
(pass-if "setting the breakpoint property works"
(let ((s (read (open-input-string "(+ 3 4)"))))
+ (throw 'unresolved)
(set-source-properties! s '((breakpoint #t)))
(let ((current-trap-opts (evaluator-traps-interface))
(current-debug-opts (debug-options-interface))
diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test
index ec55280..927e50a 100644
--- a/test-suite/tests/syntax.test
+++ b/test-suite/tests/syntax.test
@@ -129,30 +129,6 @@
(pass-if "legal (begin)"
(eval '(begin (begin) #t) (interaction-environment)))
- (with-test-prefix "unmemoization"
-
- ;; FIXME. I have no idea why, but the expander is filling in (if #f
- ;; #f) as the second arm of the if, if the second arm is missing. I
- ;; thought I made it not do that. But in the meantime, let's adapt,
- ;; since that's not what we're testing.
-
- (pass-if "normal begin"
- (let ((foo (lambda () (if (= 1 1) (begin (+ 1) (+ 2)) #f))))
- (equal? (procedure-source foo)
- '(lambda () (if (= 1 1) (begin (+ 1) (+ 2)) #f)))))
-
- (pass-if "redundant nested begin"
- (let ((foo (lambda () (if (= 1 1) (begin (+ 1) (begin (+ 2) (+ 3)))
#f))))
- (foo) ; make sure, memoization has been performed
- (equal? (procedure-source foo)
- '(lambda () (if (= 1 1) (begin (+ 1) (begin (+ 2) (+ 3)))
#f)))))
-
- (pass-if "redundant begin at start of body"
- (let ((foo (lambda () (begin (+ 1) (+ 2))))) ; should be optimized
- (foo) ; make sure, memoization has been performed
- (equal? (procedure-source foo)
- '(lambda () (begin (+ 1) (+ 2)))))))
-
(pass-if-exception "illegal (begin)"
exception:generic-syncase-error
(eval '(begin (if #t (begin)) #t) (interaction-environment))))
@@ -170,18 +146,6 @@
(with-test-prefix "lambda"
- (with-test-prefix "unmemoization"
-
- (pass-if "normal lambda"
- (let ((foo (lambda () (lambda (x y) (+ x y)))))
- (matches? (procedure-source foo)
- (lambda () (lambda (_ _) (+ _ _))))))
-
- (pass-if "lambda with documentation"
- (let ((foo (lambda () (lambda (x y) "docstring" (+ x y)))))
- (matches? (procedure-source foo)
- (lambda () (lambda (_ _) "docstring" (+ _ _)))))))
-
(with-test-prefix "bad formals"
(pass-if-exception "(lambda)"
@@ -247,13 +211,6 @@
(with-test-prefix "let"
- (with-test-prefix "unmemoization"
-
- (pass-if "normal let"
- (let ((foo (lambda () (let ((i 1) (j 2)) (+ i j)))))
- (matches? (procedure-source foo)
- (lambda () (let ((_ 1) (_ 2)) (+ _ _)))))))
-
(with-test-prefix "bindings"
(pass-if-exception "late binding"
@@ -350,21 +307,6 @@
(with-test-prefix "let*"
- (with-test-prefix "unmemoization"
-
- (pass-if "normal let*"
- (let ((foo (lambda () (let* ((x 1) (y 2)) (+ x y)))))
- (matches? (procedure-source foo)
- (lambda () (let ((_ 1)) (let ((_ 2)) (+ _ _)))))))
-
- (pass-if "let* without bindings"
- (let ((foo (lambda () (let ((x 1) (y 2))
- (let* ()
- (and (= x 1) (= y 2)))))))
- (matches? (procedure-source foo)
- (lambda () (let ((_ 1) (_ 2))
- (if (= _ 1) (= _ 2) #f)))))))
-
(with-test-prefix "bindings"
(pass-if "(let* ((x 1) (x 2)) ...)"
@@ -441,13 +383,6 @@
(with-test-prefix "letrec"
- (with-test-prefix "unmemoization"
-
- (pass-if "normal letrec"
- (let ((foo (lambda () (letrec ((i 1) (j 2)) (+ i j)))))
- (matches? (procedure-source foo)
- (lambda () (letrec ((_ 1) (_ 2)) (+ _ _)))))))
-
(with-test-prefix "bindings"
(pass-if-exception "initial bindings are undefined"
@@ -523,28 +458,6 @@
(with-test-prefix "if"
- (with-test-prefix "unmemoization"
-
- (pass-if "normal if"
- (let ((foo (lambda (x) (if x (+ 1) (+ 2)))))
- (foo #t) ; make sure, memoization has been performed
- (foo #f) ; make sure, memoization has been performed
- (matches? (procedure-source foo)
- (lambda (_) (if _ (+ 1) (+ 2))))))
-
- (expect-fail "if without else"
- (let ((foo (lambda (x) (if x (+ 1)))))
- (foo #t) ; make sure, memoization has been performed
- (foo #f) ; make sure, memoization has been performed
- (equal? (procedure-source foo)
- '(lambda (x) (if x (+ 1))))))
-
- (expect-fail "if #f without else"
- (let ((foo (lambda () (if #f #f))))
- (foo) ; make sure, memoization has been performed
- (equal? (procedure-source foo)
- `(lambda () (if #f #f))))))
-
(with-test-prefix "missing or extra expressions"
(pass-if-exception "(if)"
@@ -622,26 +535,6 @@
'(syntax-error . "cond: wrong number of receiver expressions")
(cond (#t identity => identity identity))))
- (with-test-prefix "unmemoization"
-
- ;; FIXME: the (if #f #f) is a hack!
- (pass-if "normal clauses"
- (let ((foo (lambda () (cond ((= x 1) 'bar) ((= x 2) 'baz)))))
- (equal? (procedure-source foo)
- '(lambda () (if (= x 1) 'bar (if (= x 2) 'baz (if #f #f)))))))
-
- (pass-if "else"
- (let ((foo (lambda () (cond (else 'bar)))))
- (equal? (procedure-source foo)
- '(lambda () 'bar))))
-
- ;; FIXME: the (if #f #f) is a hack!
- (pass-if "=>"
- (let ((foo (lambda () (cond (#t => identity)))))
- (matches? (procedure-source foo)
- (lambda () (let ((_ #t))
- (if _ (identity _) (if #f #f))))))))
-
(with-test-prefix "bad or missing clauses"
(pass-if-exception "(cond)"
@@ -707,28 +600,6 @@
(eval '(let ((else #f)) (case 1 (else #f)))
(interaction-environment))))
- (with-test-prefix "unmemoization"
-
- (pass-if "normal clauses"
- (let ((foo (lambda (x) (case x ((1) 'bar) ((2) 'baz) (else 'foobar)))))
- (matches? (procedure-source foo)
- (lambda (_)
- (if ((@@ (guile) memv) _ '(1))
- 'bar
- (if ((@@ (guile) memv) _ '(2))
- 'baz
- 'foobar))))))
-
- (pass-if "empty labels"
- (let ((foo (lambda (x) (case x ((1) 'bar) (() 'baz) (else 'foobar)))))
- (matches? (procedure-source foo)
- (lambda (_)
- (if ((@@ (guile) memv) _ '(1))
- 'bar
- (if ((@@ (guile) memv) _ '())
- 'baz
- 'foobar)))))))
-
(with-test-prefix "bad or missing clauses"
(pass-if-exception "(case)"
@@ -804,23 +675,6 @@
(eval '(define round round) m)
(eq? (module-ref m 'round) round)))
- (with-test-prefix "unmemoization"
-
- (pass-if "definition unmemoized without prior execution"
- (primitive-eval '(begin
- (define (blub) (cons ('(1 . 2)) 2))
- (equal?
- (procedure-source blub)
- '(lambda () (cons ('(1 . 2)) 2))))))
-
-
- (pass-if "definition with documentation unmemoized without prior execution"
- (primitive-eval '(begin
- (define (blub) "Comment" (cons ('(1 . 2)) 2))
- (equal?
- (procedure-source blub)
- '(lambda () "Comment" (cons ('(1 . 2)) 2)))))))
-
(with-test-prefix "missing or extra expressions"
(pass-if-exception "(define)"
@@ -892,29 +746,10 @@
(pass-if-exception "missing body expression"
exception:missing-body-expr
(eval '(let () (define x #t))
- (interaction-environment)))
-
- (pass-if "unmemoization"
- (primitive-eval '(begin
- (define (foo)
- (define (bar)
- 'ok)
- (bar))
- (foo)
- (matches?
- (procedure-source foo)
- (lambda () (letrec ((_ (lambda () (quote ok))))
(_))))))))
+ (interaction-environment))))
(with-test-prefix "set!"
- (with-test-prefix "unmemoization"
-
- (pass-if "normal set!"
- (let ((foo (lambda (x) (set! x (+ 1 x)))))
- (foo 1) ; make sure, memoization has been performed
- (matches? (procedure-source foo)
- (lambda (_) (set! _ (+ 1 _)))))))
-
(with-test-prefix "missing or extra expressions"
(pass-if-exception "(set!)"
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, wip-eval-cleanup, updated. release_1-9-5-57-g7571a7c,
Andy Wingo <=