mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-22 12:30:32 +02:00
Code Activity

* libguile/eval.c: Sorted include files alphabetically.

Browse source 
(scm_m_begin): Added comment.

	(scm_m_or): Use ASSERT_SYNTAX to signal syntax errors.  Avoid
	unnecessary consing when creating the memoized code.

	(iqq, scm_m_quasiquote, scm_m_quote): Use ASSERT_SYNTAX to signal
	syntax errors.  Be more specific about the kind of error that was
	detected.

	(scm_m_quote, unmemocopy): As an optimization, vector constants
	are now inserted unquoted into the memoized code.  During
	unmemoization the quotes are added again to provide syntactically
	correct code.

	* test-suite/tests/syntax.test (exception:missing/extra-expr,
	exception:missing/extra-expr-misc): Renamed
	exception:missing/extra-expr to exception:missing/extra-expr-misc.

	(exception:missing/extra-expr-syntax,
	exception:missing/extra-expr): Renamed
	exception:missing/extra-expr-syntax to
	exception:missing/extra-expr.
This commit is contained in:
Dirk Herrmann 2003-10-18 14:49:55 +00:00
parent d6754c2398
commit 216286857b
4 changed files with 116 additions and 52 deletions
Download patch file Download diff file Expand all files Collapse all files

18
libguile/ChangeLog
View file

@ -1,3 +1,21 @@
2003-10-18 Dirk Herrmann <D.Herrmann@tu-bs.de>
* eval.c: Sorted include files alphabetically.
(scm_m_begin): Added comment.
(scm_m_or): Use ASSERT_SYNTAX to signal syntax errors. Avoid
unnecessary consing when creating the memoized code.
(iqq, scm_m_quasiquote, scm_m_quote): Use ASSERT_SYNTAX to signal
syntax errors. Be more specific about the kind of error that was
detected.
(scm_m_quote, unmemocopy): As an optimization, vector constants
are now inserted unquoted into the memoized code. During
unmemoization the quotes are added again to provide syntactically
correct code.
2003-10-18 Dirk Herrmann <D.Herrmann@tu-bs.de> 2003-10-18 Dirk Herrmann <D.Herrmann@tu-bs.de>
* eval.c (scm_m_let, scm_m_letstar, scm_m_letrec, * eval.c (scm_m_let, scm_m_letstar, scm_m_letrec,

123
libguile/eval.c
View file

@ -54,36 +54,36 @@ char *alloca ();
#endif #endif
#include "libguile/_scm.h" #include "libguile/_scm.h"
#include "libguile/alist.h"
#include "libguile/async.h"
#include "libguile/continuations.h"
#include "libguile/debug.h" #include "libguile/debug.h"
#include "libguile/dynwind.h" #include "libguile/dynwind.h"
#include "libguile/alist.h"
#include "libguile/eq.h" #include "libguile/eq.h"
#include "libguile/continuations.h" #include "libguile/feature.h"
#include "libguile/fluids.h"
#include "libguile/futures.h" #include "libguile/futures.h"
#include "libguile/strings.h" #include "libguile/goops.h"
#include "libguile/throw.h" #include "libguile/hash.h"
#include "libguile/smob.h" #include "libguile/hashtab.h"
#include "libguile/lang.h"
#include "libguile/list.h" #include "libguile/list.h"
#include "libguile/macros.h" #include "libguile/macros.h"
#include "libguile/modules.h"
#include "libguile/objects.h"
#include "libguile/ports.h"
#include "libguile/procprop.h" #include "libguile/procprop.h"
#include "libguile/hashtab.h" #include "libguile/root.h"
#include "libguile/hash.h" #include "libguile/smob.h"
#include "libguile/srcprop.h" #include "libguile/srcprop.h"
#include "libguile/stackchk.h" #include "libguile/stackchk.h"
#include "libguile/objects.h" #include "libguile/strings.h"
#include "libguile/async.h" #include "libguile/throw.h"
#include "libguile/feature.h"
#include "libguile/modules.h"
#include "libguile/ports.h"
#include "libguile/root.h"
#include "libguile/vectors.h"
#include "libguile/fluids.h"
#include "libguile/goops.h"
#include "libguile/values.h"
#include "libguile/validate.h" #include "libguile/validate.h"
#include "libguile/values.h"
#include "libguile/vectors.h"
#include "libguile/eval.h" #include "libguile/eval.h"
#include "libguile/lang.h"
@ -755,7 +755,9 @@ SCM
scm_m_begin (SCM expr, SCM env SCM_UNUSED) scm_m_begin (SCM expr, SCM env SCM_UNUSED)
{ {
const SCM cdr_expr = SCM_CDR (expr); const SCM cdr_expr = SCM_CDR (expr);
/* Dirk:FIXME:: An empty begin clause is not generally allowed by R5RS.
* That means, there should be a distinction between uses of begin where an
* empty clause is OK and where it is not. */
ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr); ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
SCM_SETCAR (expr, SCM_IM_BEGIN); SCM_SETCAR (expr, SCM_IM_BEGIN);
@ -1359,15 +1361,24 @@ SCM_SYNTAX (s_or, "or", scm_i_makbimacro, scm_m_or);
SCM_GLOBAL_SYMBOL (scm_sym_or, s_or); SCM_GLOBAL_SYMBOL (scm_sym_or, s_or);
SCM SCM
scm_m_or (SCM xorig, SCM env SCM_UNUSED) scm_m_or (SCM expr, SCM env SCM_UNUSED)
{ {
long len = scm_ilength (SCM_CDR (xorig)); const SCM cdr_expr = SCM_CDR (expr);
SCM_ASSYNT (len >= 0, s_test, s_or); const long length = scm_ilength (cdr_expr);
if (len >= 1)
return scm_cons (SCM_IM_OR, SCM_CDR (xorig)); ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
else
if (length == 0)
{
/* Special case: (or) is replaced by #f. */
return SCM_BOOL_F; return SCM_BOOL_F;
} }
else
{
SCM_SETCAR (expr, SCM_IM_OR);
return expr;
}
}
SCM_SYNTAX (s_quasiquote, "quasiquote", scm_makacro, scm_m_quasiquote); SCM_SYNTAX (s_quasiquote, "quasiquote", scm_makacro, scm_m_quasiquote);
@ -1382,17 +1393,17 @@ iqq (SCM form, SCM env, unsigned long int depth)
{ {
if (SCM_CONSP (form)) if (SCM_CONSP (form))
{ {
SCM tmp = SCM_CAR (form); const SCM tmp = SCM_CAR (form);
if (SCM_EQ_P (tmp, scm_sym_quasiquote)) if (SCM_EQ_P (tmp, scm_sym_quasiquote))
{ {
SCM args = SCM_CDR (form); const SCM args = SCM_CDR (form);
SCM_ASSYNT (scm_ilength (args) == 1, s_expression, s_quasiquote); ASSERT_SYNTAX (scm_ilength (args) == 1, s_expression, form);
return scm_list_2 (tmp, iqq (SCM_CAR (args), env, depth + 1)); return scm_list_2 (tmp, iqq (SCM_CAR (args), env, depth + 1));
} }
else if (SCM_EQ_P (tmp, scm_sym_unquote)) else if (SCM_EQ_P (tmp, scm_sym_unquote))
{ {
SCM args = SCM_CDR (form); const SCM args = SCM_CDR (form);
SCM_ASSYNT (scm_ilength (args) == 1, s_expression, s_quasiquote); ASSERT_SYNTAX (scm_ilength (args) == 1, s_expression, form);
if (depth - 1 == 0) if (depth - 1 == 0)
return scm_eval_car (args, env); return scm_eval_car (args, env);
else else
@ -1401,13 +1412,14 @@ iqq (SCM form, SCM env, unsigned long int depth)
else if (SCM_CONSP (tmp) else if (SCM_CONSP (tmp)
&& SCM_EQ_P (SCM_CAR (tmp), scm_sym_uq_splicing)) && SCM_EQ_P (SCM_CAR (tmp), scm_sym_uq_splicing))
{ {
SCM args = SCM_CDR (tmp); const SCM args = SCM_CDR (tmp);
SCM_ASSYNT (scm_ilength (args) == 1, s_expression, s_quasiquote); ASSERT_SYNTAX (scm_ilength (args) == 1, s_expression, form);
if (depth - 1 == 0) if (depth - 1 == 0)
{ {
SCM list = scm_eval_car (args, env); const SCM list = scm_eval_car (args, env);
SCM rest = SCM_CDR (form); const SCM rest = SCM_CDR (form);
SCM_ASSYNT (scm_ilength (list) >= 0, s_splicing, s_quasiquote); ASSERT_SYNTAX_2 (scm_ilength (list) >= 0,
s_splicing, list, form);
return scm_append (scm_list_2 (list, iqq (rest, env, depth))); return scm_append (scm_list_2 (list, iqq (rest, env, depth)));
} }
else else
@ -1433,11 +1445,12 @@ iqq (SCM form, SCM env, unsigned long int depth)
} }
SCM SCM
scm_m_quasiquote (SCM xorig, SCM env) scm_m_quasiquote (SCM expr, SCM env)
{ {
SCM x = SCM_CDR (xorig); const SCM cdr_expr = SCM_CDR (expr);
SCM_ASSYNT (scm_ilength (x) == 1, s_expression, s_quasiquote); ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
return iqq (SCM_CAR (x), env, 1); ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr);
return iqq (SCM_CAR (cdr_expr), env, 1);
} }
@ -1445,10 +1458,26 @@ SCM_SYNTAX (s_quote, "quote", scm_i_makbimacro, scm_m_quote);
SCM_GLOBAL_SYMBOL (scm_sym_quote, s_quote); SCM_GLOBAL_SYMBOL (scm_sym_quote, s_quote);
SCM SCM
scm_m_quote (SCM xorig, SCM env SCM_UNUSED) scm_m_quote (SCM expr, SCM env SCM_UNUSED)
{ {
SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, s_expression, s_quote); SCM quotee;
return scm_cons (SCM_IM_QUOTE, SCM_CDR (xorig));
const SCM cdr_expr = SCM_CDR (expr);
ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr);
quotee = SCM_CAR (cdr_expr);
if (SCM_IMP (quotee) && !SCM_NULLP (quotee))
return quotee;
else if (SCM_VECTORP (quotee))
return quotee;
#if 0
/* The following optimization would be possible if all variable references
* were resolved during memoization: */
else if (SCM_SYMBOLP (quotee))
return quotee;
#endif
SCM_SETCAR (expr, SCM_IM_QUOTE);
return expr;
} }
@ -1868,8 +1897,14 @@ unmemocopy (SCM x, SCM env)
{ {
SCM ls, z; SCM ls, z;
SCM p; SCM p;
if (!SCM_CONSP (x))
if (SCM_VECTORP (x))
{
return scm_list_2 (scm_sym_quote, x);
}
else if (!SCM_CONSP (x))
return x; return x;
p = scm_whash_lookup (scm_source_whash, x); p = scm_whash_lookup (scm_source_whash, x);
switch (SCM_ITAG7 (SCM_CAR (x))) switch (SCM_ITAG7 (SCM_CAR (x)))
{ {

11
test-suite/ChangeLog
View file

@ -1,3 +1,14 @@
2003-10-18 Dirk Herrmann <D.Herrmann@tu-bs.de>
* tests/syntax.test (exception:missing/extra-expr,
exception:missing/extra-expr-misc): Renamed
exception:missing/extra-expr to exception:missing/extra-expr-misc.
(exception:missing/extra-expr-syntax,
exception:missing/extra-expr): Renamed
exception:missing/extra-expr-syntax to
exception:missing/extra-expr.
2003-10-18 Dirk Herrmann <D.Herrmann@tu-bs.de> 2003-10-18 Dirk Herrmann <D.Herrmann@tu-bs.de>
* lib.scm (exception:bad-variable): New. * lib.scm (exception:bad-variable): New.

16
test-suite/tests/syntax.test
View file

@ -24,9 +24,9 @@
(define exception:bad-expression (define exception:bad-expression
(cons 'syntax-error "Bad expression")) (cons 'syntax-error "Bad expression"))
(define exception:missing/extra-expr (define exception:missing/extra-expr-misc
(cons 'misc-error "^missing or extra expression")) (cons 'misc-error "^missing or extra expression"))
(define exception:missing/extra-expr-syntax (define exception:missing/extra-expr
(cons 'syntax-error "missing or extra expression")) (cons 'syntax-error "missing or extra expression"))
(define exception:missing-expr (define exception:missing-expr
(cons 'syntax-error "Missing expression")) (cons 'syntax-error "Missing expression"))
@ -89,7 +89,7 @@
;; Fixed on 2001-3-3 ;; Fixed on 2001-3-3
(pass-if-exception "empty parentheses \"()\"" (pass-if-exception "empty parentheses \"()\""
exception:missing/extra-expr exception:missing/extra-expr-misc
(eval '() (eval '()
(interaction-environment))))) (interaction-environment)))))
@ -433,12 +433,12 @@
(with-test-prefix "missing or extra expressions" (with-test-prefix "missing or extra expressions"
(pass-if-exception "(if)" (pass-if-exception "(if)"
exception:missing/extra-expr-syntax exception:missing/extra-expr
(eval '(if) (eval '(if)
(interaction-environment))) (interaction-environment)))
(pass-if-exception "(if 1 2 3 4)" (pass-if-exception "(if 1 2 3 4)"
exception:missing/extra-expr-syntax exception:missing/extra-expr
(eval '(if 1 2 3 4) (eval '(if 1 2 3 4)
(interaction-environment))))) (interaction-environment)))))
@ -611,17 +611,17 @@
(with-test-prefix "missing or extra expressions" (with-test-prefix "missing or extra expressions"
(pass-if-exception "(set!)" (pass-if-exception "(set!)"
exception:missing/extra-expr exception:missing/extra-expr-misc
(eval '(set!) (eval '(set!)
(interaction-environment))) (interaction-environment)))
(pass-if-exception "(set! 1)" (pass-if-exception "(set! 1)"
exception:missing/extra-expr exception:missing/extra-expr-misc
(eval '(set! 1) (eval '(set! 1)
(interaction-environment))) (interaction-environment)))
(pass-if-exception "(set! 1 2 3)" (pass-if-exception "(set! 1 2 3)"
exception:missing/extra-expr exception:missing/extra-expr-misc
(eval '(set! 1 2 3) (eval '(set! 1 2 3)
(interaction-environment)))) (interaction-environment))))