mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-19 02:00:26 +02:00
Code Activity

* Eliminate some calls to scm_wta.

Browse source
This commit is contained in:
Dirk Herrmann 2001-03-04 17:09:34 +00:00
parent cc6c7feea4
commit db4b4ca64f
13 changed files with 77 additions and 39 deletions
Download patch file Download diff file Expand all files Collapse all files

13
libguile/ChangeLog
View file

@ -1,3 +1,16 @@
2001-03-04 Dirk Herrmann <D.Herrmann@tu-bs.de>
* continuations.c (continuation_apply), eval.c (scm_m_lambda,
scm_m_letstar, scm_m_letrec1, scm_m_let, SCM_APPLY), eval.h
(SCM_EVALIM2), evalext.c (scm_m_generalized_set_x), gc.c
(get_bvec, MARK), goops.c (scm_primitive_generic_generic),
options.c (scm_options), ports.c (scm_remove_from_port_table),
ramap.c (scm_ramapc), read.c (skip_scsh_block_comment, scm_lreadr,
scm_lreadparen, scm_lreadrecparen), script.c (script_get_octal,
script_get_backslash, script_read_arg), unif.c (scm_cvref): Don't
call function scm_wta, call scm_misc_error or scm_wrong_type_arg
instead.
2001-03-04 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
* goops.c (scm_sys_pre_expand_closure_x): New procedure.

9
libguile/continuations.c
View file

@ -59,6 +59,7 @@
#include "libguile/debug.h"
#endif
#include "libguile/validate.h"
#include "libguile/continuations.h"
@ -219,8 +220,10 @@ scm_dynthrow (SCM cont, SCM val)
copy_stack_and_call (continuation, val, dst);
}
static SCM
continuation_apply (SCM cont, SCM args)
#define FUNC_NAME "continuation_apply"
static SCM continuation_apply (SCM cont, SCM args)
{
scm_contregs *continuation = SCM_CONTREGS (cont);
scm_contregs *rootcont = SCM_CONTREGS (scm_rootcont);
@ -229,7 +232,8 @@ static SCM continuation_apply (SCM cont, SCM args)
/* this base comparison isn't needed */
|| continuation->base != rootcont->base)
{
scm_wta (cont, "continuation from wrong top level", FUNC_NAME);
SCM_MISC_ERROR ("continuation from wrong top level: ~S",
SCM_LIST1 (cont));
}
scm_dowinds (continuation->dynenv,
@ -241,6 +245,7 @@ static SCM continuation_apply (SCM cont, SCM args)
}
#undef FUNC_NAME
void
scm_init_continuations ()
{

12
libguile/eval.c
View file

@ -681,13 +681,13 @@ scm_m_lambda (SCM xorig, SCM env)
if (!SCM_SYMBOLP (SCM_CAR (proc)))
goto badforms;
else if (scm_c_improper_memq (SCM_CAR(proc), SCM_CDR(proc)))
scm_wta (xorig, scm_s_duplicate_formals, s_lambda);
scm_misc_error (s_lambda, scm_s_duplicate_formals, SCM_EOL);
proc = SCM_CDR (proc);
}
if (SCM_NNULLP (proc))
{
badforms:
scm_wta (xorig, scm_s_formals, s_lambda);
scm_misc_error (s_lambda, scm_s_formals, SCM_EOL);
}
memlambda:
@ -713,7 +713,7 @@ scm_m_letstar (SCM xorig, SCM env)
SCM_ASSYNT (2 == scm_ilength (arg1), xorig, scm_s_bindings, s_letstar);
SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1)), xorig, scm_s_variable, s_letstar);
if (scm_c_improper_memq (SCM_CAR (arg1), vars))
scm_wta (xorig, scm_s_duplicate_bindings, s_letstar);
scm_misc_error (s_letstar, scm_s_duplicate_bindings, SCM_EOL);
*varloc = scm_cons2 (SCM_CAR (arg1), SCM_CAR (SCM_CDR (arg1)), SCM_EOL);
varloc = SCM_CDRLOC (SCM_CDR (*varloc));
proc = SCM_CDR (proc);
@ -920,7 +920,7 @@ scm_m_letrec1 (SCM op, SCM imm, SCM xorig, SCM env)
SCM_ASSYNT (2 == scm_ilength (arg1), xorig, scm_s_bindings, what);
SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1)), xorig, scm_s_variable, what);
if (scm_c_improper_memq (SCM_CAR (arg1), vars))
scm_wta (xorig, scm_s_duplicate_bindings, what);
scm_misc_error (what, scm_s_duplicate_bindings, SCM_EOL);
vars = scm_cons (SCM_CAR (arg1), vars);
*initloc = scm_cons (SCM_CAR (SCM_CDR (arg1)), SCM_EOL);
initloc = SCM_CDRLOC (*initloc);
@ -982,7 +982,7 @@ scm_m_let (SCM xorig, SCM env)
}
if (!SCM_SYMBOLP (proc))
scm_wta (xorig, scm_s_bindings, s_let); /* bad let */
scm_misc_error (s_let, scm_s_bindings, SCM_EOL); /* bad let */
name = proc; /* named let, build equiv letrec */
x = SCM_CDR (x);
SCM_ASSYNT (scm_ilength (x) >= 2, xorig, scm_s_body, s_let);
@ -3559,7 +3559,7 @@ tail:
scm_wrong_num_args (proc);
default:
badproc:
scm_wta (proc, (char *) SCM_ARG1, "apply");
scm_wrong_type_arg ("apply", SCM_ARG1, proc);
RETURN (arg1);
}
#ifdef DEVAL

2
libguile/eval.h
View file

@ -98,7 +98,7 @@ extern SCM scm_eval_options_interface (SCM setting);
* For an explanation of symbols containing "EVAL", see beginning of eval.c.
*/
#define SCM_EVALIM2(x) (((x) == SCM_EOL) \
? scm_wta ((x), scm_s_expression, NULL) \
? scm_misc_error (NULL, scm_s_expression, SCM_EOL), 0 \
: (x))
#ifdef MEMOIZE_LOCALS
#define SCM_EVALIM(x, env) (SCM_ILOCP (x) \

3
libguile/evalext.c
View file

@ -65,7 +65,8 @@ scm_m_generalized_set_x (SCM xorig, SCM env)
else if (SCM_CONSP (SCM_CAR (x)))
return scm_cons (SCM_LIST2 (scm_sym_setter, SCM_CAAR (x)),
scm_append (SCM_LIST2 (SCM_CDAR (x), SCM_CDR (x))));
return scm_wta (xorig, scm_s_variable, scm_s_set_x);
else
scm_misc_error (scm_s_set_x, scm_s_variable, SCM_EOL);
}
SCM_DEFINE (scm_definedp, "defined?", 1, 1, 0,

9
libguile/gc.c
View file

@ -408,6 +408,7 @@ static scm_mark_space_t *mark_space_head;
static scm_c_bvec_limb_t *
get_bvec ()
#define FUNC_NAME "get_bvec"
{
scm_c_bvec_limb_t *res;
@ -415,7 +416,7 @@ get_bvec ()
{
SCM_SYSCALL (current_mark_space = (scm_mark_space_t *) malloc (sizeof (scm_mark_space_t)));
if (!current_mark_space)
scm_wta (SCM_UNDEFINED, "could not grow", "heap");
SCM_MISC_ERROR ("could not grow heap", SCM_EOL);
current_mark_space->bvec_space = NULL;
current_mark_space->next = NULL;
@ -431,7 +432,7 @@ get_bvec ()
SCM_SYSCALL (current_mark_space->bvec_space =
(scm_c_bvec_limb_t *) calloc (BVEC_GROW_SIZE_IN_BYTES, 1));
if (!(current_mark_space->bvec_space))
scm_wta (SCM_UNDEFINED, "could not grow", "heap");
SCM_MISC_ERROR ("could not grow heap", SCM_EOL);
current_mark_space_offset = 0;
@ -450,6 +451,8 @@ get_bvec ()
return res;
}
#undef FUNC_NAME
static void
clear_mark_space ()
@ -1143,7 +1146,7 @@ gc_mark_loop_first_time:
#if (defined (GUILE_DEBUG_FREELIST))
if (SCM_GC_IN_CARD_HEADERP (SCM2PTR (ptr)))
scm_wta (ptr, "rogue pointer in heap", NULL);
SCM_MISC_ERROR ("rogue pointer in heap", SCM_EOL);
#endif

2
libguile/goops.c
View file

@ -1644,7 +1644,7 @@ SCM_DEFINE (scm_primitive_generic_generic, "primitive-generic-generic", 1, 0, 0,
if (gf)
return gf;
}
return scm_wta (subr, (char *) SCM_ARG1, FUNC_NAME);
SCM_WRONG_TYPE_ARG (SCM_ARG1, subr);
}
#undef FUNC_NAME

3
libguile/options.c
View file

@ -190,7 +190,8 @@ scm_options (SCM arg, scm_option options[], int n, const char *s)
}
#ifndef SCM_RECKLESS
scm_must_free ((char *) flags);
scm_wta (SCM_CAR (new_mode), "Unknown mode flag", s);
scm_misc_error (s, "Unknown mode flag: ~S",
SCM_LIST1 (SCM_CAR (new_mode)));
#endif
cont:
new_mode = SCM_CDR (new_mode);

5
libguile/ports.c
View file

@ -468,12 +468,13 @@ scm_add_to_port_table (SCM port)
void
scm_remove_from_port_table (SCM port)
#define FUNC_NAME "scm_remove_from_port_table"
{
scm_port *p = SCM_PTAB_ENTRY (port);
int i = p->entry;
if (i >= scm_port_table_size)
scm_wta (port, "Port not in table", "scm_remove_from_port_table");
SCM_MISC_ERROR ("Port not in table: ~S", SCM_LIST1 (port));
if (p->putback_buf)
free (p->putback_buf);
free (p);
@ -487,6 +488,8 @@ scm_remove_from_port_table (SCM port)
SCM_SETPTAB_ENTRY (port, 0);
scm_port_table_size--;
}
#undef FUNC_NAME
#ifdef GUILE_DEBUG
/* Functions for debugging. */

2
libguile/ramap.c
View file

@ -329,7 +329,7 @@ scm_ramapc (int (*cproc)(), SCM data, SCM ra0, SCM lra, const char *what)
{
default:
case 0:
scm_wta (ra0, "array shape mismatch", what);
scm_misc_error (what, "array shape mismatch: ~S", ra0);
case 2:
case 3:
case 4: /* Try unrolling arrays */

25
libguile/read.c
View file

@ -255,6 +255,7 @@ recsexpr (SCM obj,int line,int column,SCM filename)
static void
skip_scsh_block_comment (SCM port)
#define FUNC_NAME "skip_scsh_block_comment"
{
/* Is this portable? Dear God, spare me from the non-eight-bit
characters. But is it tasteful? */
@ -265,8 +266,7 @@ skip_scsh_block_comment (SCM port)
int c = scm_getc (port);
if (c == EOF)
scm_wta (SCM_UNDEFINED,
"unterminated `#! ... !#' comment", "read");
SCM_MISC_ERROR ("unterminated `#! ... !#' comment", SCM_EOL);
history = ((history << 8) | (c & 0xff)) & 0xffffffff;
/* Were the last four characters read "\n!#\n"? */
@ -274,6 +274,8 @@ skip_scsh_block_comment (SCM port)
return;
}
}
#undef FUNC_NAME
static SCM scm_get_hash_procedure(int c);
@ -281,6 +283,7 @@ static char s_list[]="list";
SCM
scm_lreadr (SCM *tok_buf,SCM port,SCM *copy)
#define FUNC_NAME "scm_lreadr"
{
int c;
scm_sizet j;
@ -299,7 +302,7 @@ tryagain_no_flush_ws:
? scm_lreadrecparen (tok_buf, port, s_list, copy)
: scm_lreadparen (tok_buf, port, s_list, copy);
case ')':
scm_wta (SCM_UNDEFINED, "unexpected \")\"", "read");
SCM_MISC_ERROR ("unexpected \")\"", SCM_EOL);
goto tryagain;
case '\'':
@ -402,7 +405,7 @@ tryagain_no_flush_ws:
if (scm_charnames[c]
&& (scm_casei_streq (scm_charnames[c], SCM_STRING_CHARS (*tok_buf))))
return SCM_MAKE_CHAR (scm_charnums[c]);
scm_wta (SCM_UNDEFINED, "unknown # object: #\\", SCM_STRING_CHARS (*tok_buf));
SCM_MISC_ERROR ("unknown # object", SCM_EOL);
/* #:SYMBOL is a syntax for keywords supported in all contexts. */
case ':':
@ -504,7 +507,7 @@ tryagain_no_flush_ws:
c = SCM_STRING_CHARS (*tok_buf)[1];
goto callshrp;
}
scm_wta (SCM_UNDEFINED, "unknown # object", SCM_STRING_CHARS (*tok_buf));
SCM_MISC_ERROR ("unknown # object", SCM_EOL);
}
goto tok;
@ -524,6 +527,8 @@ tryagain_no_flush_ws:
return scm_mem2symbol (SCM_STRING_CHARS (*tok_buf), j);
}
}
#undef FUNC_NAME
#ifdef _UNICOS
_Pragma ("noopt"); /* # pragma _CRI noopt */
@ -617,6 +622,7 @@ _Pragma ("opt"); /* # pragma _CRI opt */
SCM
scm_lreadparen (SCM *tok_buf, SCM port, char *name, SCM *copy)
#define FUNC_NAME "scm_lreadparen"
{
SCM tmp;
SCM tl;
@ -632,7 +638,7 @@ scm_lreadparen (SCM *tok_buf, SCM port, char *name, SCM *copy)
ans = scm_lreadr (tok_buf, port, copy);
closeit:
if (')' != (c = scm_flush_ws (port, name)))
scm_wta (SCM_UNDEFINED, "missing close paren", "");
SCM_MISC_ERROR ("missing close paren", SCM_EOL);
return ans;
}
ans = tl = scm_cons (tmp, SCM_EOL);
@ -649,10 +655,12 @@ scm_lreadparen (SCM *tok_buf, SCM port, char *name, SCM *copy)
}
return ans;
}
#undef FUNC_NAME
SCM
scm_lreadrecparen (SCM *tok_buf, SCM port, char *name, SCM *copy)
#define FUNC_NAME "scm_lreadrecparen"
{
register int c;
register SCM tmp;
@ -670,7 +678,7 @@ scm_lreadrecparen (SCM *tok_buf, SCM port, char *name, SCM *copy)
{
ans = scm_lreadr (tok_buf, port, copy);
if (')' != (c = scm_flush_ws (port, name)))
scm_wta (SCM_UNDEFINED, "missing close paren", "");
SCM_MISC_ERROR ("missing close paren", SCM_EOL);
return ans;
}
/* Build the head of the list structure. */
@ -694,7 +702,7 @@ scm_lreadrecparen (SCM *tok_buf, SCM port, char *name, SCM *copy)
: tmp,
SCM_EOL));
if (')' != (c = scm_flush_ws (port, name)))
scm_wta (SCM_UNDEFINED, "missing close paren", "");
SCM_MISC_ERROR ("missing close paren", SCM_EOL);
goto exit;
}
@ -721,6 +729,7 @@ exit:
SCM_EOL));
return ans;
}
#undef FUNC_NAME

26
libguile/script.c
View file

@ -51,6 +51,7 @@
#include "libguile/load.h"
#include "libguile/version.h"
#include "libguile/validate.h"
#include "libguile/script.h"
#ifdef HAVE_STRING_H
@ -168,6 +169,7 @@ scm_find_executable (const char *name)
/* Read a \nnn-style escape. We've just read the backslash. */
static int
script_get_octal (FILE *f)
#define FUNC_NAME "script_get_octal"
{
int i;
int value = 0;
@ -178,16 +180,17 @@ script_get_octal (FILE *f)
if ('0' <= c && c <= '7')
value = (value * 8) + (c - '0');
else
scm_wta (SCM_UNDEFINED,
"malformed script: bad octal backslash escape",
"script argument parser");
SCM_MISC_ERROR ("malformed script: bad octal backslash escape",
SCM_EOL);
}
return value;
}
#undef FUNC_NAME
static int
script_get_backslash (FILE *f)
#define FUNC_NAME "script_get_backslash"
{
int c = getc (f);
@ -211,24 +214,22 @@ script_get_backslash (FILE *f)
case '4': case '5': case '6': case '7':
ungetc (c, f);
return script_get_octal (f);
case EOF:
scm_wta (SCM_UNDEFINED,
"malformed script: backslash followed by EOF",
"script argument parser");
SCM_MISC_ERROR ("malformed script: backslash followed by EOF", SCM_EOL);
return 0; /* not reached? */
default:
scm_wta (SCM_UNDEFINED,
"malformed script: bad backslash sequence",
"script argument parser");
SCM_MISC_ERROR ("malformed script: bad backslash sequence", SCM_EOL);
return 0; /* not reached? */
}
}
#undef FUNC_NAME
static char *
script_read_arg (FILE *f)
#define FUNC_NAME "script_read_arg"
{
int size = 7;
char *buf = malloc (size + 1);
@ -275,13 +276,12 @@ script_read_arg (FILE *f)
case '\t':
free (buf);
scm_wta (SCM_UNDEFINED,
"malformed script: TAB in meta-arguments",
"argument parser");
SCM_MISC_ERROR ("malformed script: TAB in meta-arguments", SCM_EOL);
return 0; /* not reached? */
}
}
}
#undef FUNC_NAME
static int

5
libguile/unif.c
View file

@ -1156,11 +1156,12 @@ SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0,
SCM
scm_cvref (SCM v, scm_sizet pos, SCM last)
#define FUNC_NAME "scm_cvref"
{
switch SCM_TYP7 (v)
{
default:
scm_wta (v, (char *) SCM_ARG1, "PROGRAMMING ERROR: scm_cvref");
SCM_WRONG_TYPE_ARG (SCM_ARG1, v);
case scm_tc7_bvect:
if (SCM_BITVEC_REF(v,pos))
return SCM_BOOL_T;
@ -1222,6 +1223,8 @@ scm_cvref (SCM v, scm_sizet pos, SCM last)
}
}
}
#undef FUNC_NAME
SCM_REGISTER_PROC(s_uniform_array_set1_x, "uniform-array-set1!", 3, 0, 0, scm_array_set_x);