mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-22 04:30:19 +02:00
* libguile/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. * 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
parent
d6754c2398
commit
216286857b
4 changed files with 116 additions and 52 deletions
|
|
@ -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>
|
||||
|
||||
* eval.c (scm_m_let, scm_m_letstar, scm_m_letrec,
|
||||
|
|
|
|||
123
libguile/eval.c
123
libguile/eval.c
|
|
@ -54,36 +54,36 @@ char *alloca ();
|
|||
#endif
|
||||
|
||||
#include "libguile/_scm.h"
|
||||
#include "libguile/alist.h"
|
||||
#include "libguile/async.h"
|
||||
#include "libguile/continuations.h"
|
||||
#include "libguile/debug.h"
|
||||
#include "libguile/dynwind.h"
|
||||
#include "libguile/alist.h"
|
||||
#include "libguile/eq.h"
|
||||
#include "libguile/continuations.h"
|
||||
#include "libguile/feature.h"
|
||||
#include "libguile/fluids.h"
|
||||
#include "libguile/futures.h"
|
||||
#include "libguile/strings.h"
|
||||
#include "libguile/throw.h"
|
||||
#include "libguile/smob.h"
|
||||
#include "libguile/goops.h"
|
||||
#include "libguile/hash.h"
|
||||
#include "libguile/hashtab.h"
|
||||
#include "libguile/lang.h"
|
||||
#include "libguile/list.h"
|
||||
#include "libguile/macros.h"
|
||||
#include "libguile/modules.h"
|
||||
#include "libguile/objects.h"
|
||||
#include "libguile/ports.h"
|
||||
#include "libguile/procprop.h"
|
||||
#include "libguile/hashtab.h"
|
||||
#include "libguile/hash.h"
|
||||
#include "libguile/root.h"
|
||||
#include "libguile/smob.h"
|
||||
#include "libguile/srcprop.h"
|
||||
#include "libguile/stackchk.h"
|
||||
#include "libguile/objects.h"
|
||||
#include "libguile/async.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/strings.h"
|
||||
#include "libguile/throw.h"
|
||||
#include "libguile/validate.h"
|
||||
#include "libguile/values.h"
|
||||
#include "libguile/vectors.h"
|
||||
|
||||
#include "libguile/eval.h"
|
||||
#include "libguile/lang.h"
|
||||
|
||||
|
||||
|
||||
|
|
@ -755,7 +755,9 @@ SCM
|
|||
scm_m_begin (SCM expr, SCM env SCM_UNUSED)
|
||||
{
|
||||
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);
|
||||
|
||||
SCM_SETCAR (expr, SCM_IM_BEGIN);
|
||||
|
|
@ -1359,14 +1361,23 @@ SCM_SYNTAX (s_or, "or", scm_i_makbimacro, scm_m_or);
|
|||
SCM_GLOBAL_SYMBOL (scm_sym_or, s_or);
|
||||
|
||||
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));
|
||||
SCM_ASSYNT (len >= 0, s_test, s_or);
|
||||
if (len >= 1)
|
||||
return scm_cons (SCM_IM_OR, SCM_CDR (xorig));
|
||||
else
|
||||
const SCM cdr_expr = SCM_CDR (expr);
|
||||
const long length = scm_ilength (cdr_expr);
|
||||
|
||||
ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
|
||||
|
||||
if (length == 0)
|
||||
{
|
||||
/* Special case: (or) is replaced by #f. */
|
||||
return SCM_BOOL_F;
|
||||
}
|
||||
else
|
||||
{
|
||||
SCM_SETCAR (expr, SCM_IM_OR);
|
||||
return expr;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -1382,17 +1393,17 @@ iqq (SCM form, SCM env, unsigned long int depth)
|
|||
{
|
||||
if (SCM_CONSP (form))
|
||||
{
|
||||
SCM tmp = SCM_CAR (form);
|
||||
const SCM tmp = SCM_CAR (form);
|
||||
if (SCM_EQ_P (tmp, scm_sym_quasiquote))
|
||||
{
|
||||
SCM args = SCM_CDR (form);
|
||||
SCM_ASSYNT (scm_ilength (args) == 1, s_expression, s_quasiquote);
|
||||
const SCM args = SCM_CDR (form);
|
||||
ASSERT_SYNTAX (scm_ilength (args) == 1, s_expression, form);
|
||||
return scm_list_2 (tmp, iqq (SCM_CAR (args), env, depth + 1));
|
||||
}
|
||||
else if (SCM_EQ_P (tmp, scm_sym_unquote))
|
||||
{
|
||||
SCM args = SCM_CDR (form);
|
||||
SCM_ASSYNT (scm_ilength (args) == 1, s_expression, s_quasiquote);
|
||||
const SCM args = SCM_CDR (form);
|
||||
ASSERT_SYNTAX (scm_ilength (args) == 1, s_expression, form);
|
||||
if (depth - 1 == 0)
|
||||
return scm_eval_car (args, env);
|
||||
else
|
||||
|
|
@ -1401,13 +1412,14 @@ iqq (SCM form, SCM env, unsigned long int depth)
|
|||
else if (SCM_CONSP (tmp)
|
||||
&& SCM_EQ_P (SCM_CAR (tmp), scm_sym_uq_splicing))
|
||||
{
|
||||
SCM args = SCM_CDR (tmp);
|
||||
SCM_ASSYNT (scm_ilength (args) == 1, s_expression, s_quasiquote);
|
||||
const SCM args = SCM_CDR (tmp);
|
||||
ASSERT_SYNTAX (scm_ilength (args) == 1, s_expression, form);
|
||||
if (depth - 1 == 0)
|
||||
{
|
||||
SCM list = scm_eval_car (args, env);
|
||||
SCM rest = SCM_CDR (form);
|
||||
SCM_ASSYNT (scm_ilength (list) >= 0, s_splicing, s_quasiquote);
|
||||
const SCM list = scm_eval_car (args, env);
|
||||
const SCM rest = SCM_CDR (form);
|
||||
ASSERT_SYNTAX_2 (scm_ilength (list) >= 0,
|
||||
s_splicing, list, form);
|
||||
return scm_append (scm_list_2 (list, iqq (rest, env, depth)));
|
||||
}
|
||||
else
|
||||
|
|
@ -1433,11 +1445,12 @@ iqq (SCM form, SCM env, unsigned long int depth)
|
|||
}
|
||||
|
||||
SCM
|
||||
scm_m_quasiquote (SCM xorig, SCM env)
|
||||
scm_m_quasiquote (SCM expr, SCM env)
|
||||
{
|
||||
SCM x = SCM_CDR (xorig);
|
||||
SCM_ASSYNT (scm_ilength (x) == 1, s_expression, s_quasiquote);
|
||||
return iqq (SCM_CAR (x), env, 1);
|
||||
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);
|
||||
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
|
||||
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);
|
||||
return scm_cons (SCM_IM_QUOTE, SCM_CDR (xorig));
|
||||
SCM quotee;
|
||||
|
||||
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 p;
|
||||
if (!SCM_CONSP (x))
|
||||
|
||||
if (SCM_VECTORP (x))
|
||||
{
|
||||
return scm_list_2 (scm_sym_quote, x);
|
||||
}
|
||||
else if (!SCM_CONSP (x))
|
||||
return x;
|
||||
|
||||
p = scm_whash_lookup (scm_source_whash, x);
|
||||
switch (SCM_ITAG7 (SCM_CAR (x)))
|
||||
{
|
||||
|
|
|
|||
|
|
@ -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>
|
||||
|
||||
* lib.scm (exception:bad-variable): New.
|
||||
|
|
|
|||
|
|
@ -24,9 +24,9 @@
|
|||
(define exception: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"))
|
||||
(define exception:missing/extra-expr-syntax
|
||||
(define exception:missing/extra-expr
|
||||
(cons 'syntax-error "missing or extra expression"))
|
||||
(define exception:missing-expr
|
||||
(cons 'syntax-error "Missing expression"))
|
||||
|
|
@ -89,7 +89,7 @@
|
|||
|
||||
;; Fixed on 2001-3-3
|
||||
(pass-if-exception "empty parentheses \"()\""
|
||||
exception:missing/extra-expr
|
||||
exception:missing/extra-expr-misc
|
||||
(eval '()
|
||||
(interaction-environment)))))
|
||||
|
||||
|
|
@ -433,12 +433,12 @@
|
|||
(with-test-prefix "missing or extra expressions"
|
||||
|
||||
(pass-if-exception "(if)"
|
||||
exception:missing/extra-expr-syntax
|
||||
exception:missing/extra-expr
|
||||
(eval '(if)
|
||||
(interaction-environment)))
|
||||
|
||||
(pass-if-exception "(if 1 2 3 4)"
|
||||
exception:missing/extra-expr-syntax
|
||||
exception:missing/extra-expr
|
||||
(eval '(if 1 2 3 4)
|
||||
(interaction-environment)))))
|
||||
|
||||
|
|
@ -611,17 +611,17 @@
|
|||
(with-test-prefix "missing or extra expressions"
|
||||
|
||||
(pass-if-exception "(set!)"
|
||||
exception:missing/extra-expr
|
||||
exception:missing/extra-expr-misc
|
||||
(eval '(set!)
|
||||
(interaction-environment)))
|
||||
|
||||
(pass-if-exception "(set! 1)"
|
||||
exception:missing/extra-expr
|
||||
exception:missing/extra-expr-misc
|
||||
(eval '(set! 1)
|
||||
(interaction-environment)))
|
||||
|
||||
(pass-if-exception "(set! 1 2 3)"
|
||||
exception:missing/extra-expr
|
||||
exception:missing/extra-expr-misc
|
||||
(eval '(set! 1 2 3)
|
||||
(interaction-environment))))
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue