static SCM
lookup (SCM x, SCM env)
{
int d = 0;
for (; scm_is_pair (env); env = CDR (env), d++)
{
SCM link = CAR (env);
if (env_link_is_flat (link))
{
int w;
SCM vars;
for (vars = env_link_vars (link), w = scm_ilength (vars) - 1;
scm_is_pair (vars);
vars = CDR (vars), w--)
if (scm_is_eq (x, (CAAR (vars))))
return make_pos (d, w);
env_link_add_flat_var (link, x, lookup (x, CDR (env)));
return make_pos (d, scm_ilength (env_link_vars (link)) - 1);
}
else
{
int w = try_lookup_rib (x, env_link_vars (link));
if (w < 0)
continue;
return make_pos (d, w);
}
}
abort ();
}
char *
gdbscm_exception_message_to_string (SCM exception)
{
SCM port = scm_open_output_string ();
SCM key, args;
char *result;
gdb_assert (gdbscm_is_exception (exception));
key = gdbscm_exception_key (exception);
args = gdbscm_exception_args (exception);
if (scm_is_eq (key, with_stack_error_symbol)
/* Don't crash on a badly generated gdb:with-stack exception. */
&& scm_is_pair (args)
&& scm_is_pair (scm_cdr (args)))
{
key = scm_car (args);
args = scm_cddr (args);
}
gdbscm_print_exception_message (port, SCM_BOOL_F, key, args);
result = gdbscm_scm_to_c_string (scm_get_output_string (port));
scm_close_port (port);
return result;
}
static void
syntax_error (const char* const msg, const SCM form, const SCM expr)
{
SCM msg_string = scm_from_locale_string (msg);
SCM filename = SCM_BOOL_F;
SCM linenr = SCM_BOOL_F;
const char *format;
SCM args;
if (scm_is_pair (form))
{
filename = scm_source_property (form, scm_sym_filename);
linenr = scm_source_property (form, scm_sym_line);
}
if (scm_is_false (filename) && scm_is_false (linenr) && scm_is_pair (expr))
{
filename = scm_source_property (expr, scm_sym_filename);
linenr = scm_source_property (expr, scm_sym_line);
}
if (!SCM_UNBNDP (expr))
{
if (scm_is_true (filename))
{
format = "In file ~S, line ~S: ~A ~S in expression ~S.";
args = scm_list_5 (filename, linenr, msg_string, form, expr);
}
else if (scm_is_true (linenr))
{
format = "In line ~S: ~A ~S in expression ~S.";
args = scm_list_4 (linenr, msg_string, form, expr);
}
else
{
format = "~A ~S in expression ~S.";
args = scm_list_3 (msg_string, form, expr);
}
}
else
{
if (scm_is_true (filename))
{
format = "In file ~S, line ~S: ~A ~S.";
args = scm_list_4 (filename, linenr, msg_string, form);
}
else if (scm_is_true (linenr))
{
format = "In line ~S: ~A ~S.";
args = scm_list_3 (linenr, msg_string, form);
}
else
{
format = "~A ~S.";
args = scm_list_2 (msg_string, form);
}
}
scm_error (syntax_error_key, "memoization", format, args, SCM_BOOL_F);
}
/* According to Section 5.2.1 of R5RS we first have to make sure that the
variable is bound, and then perform the `(set! variable expression)'
operation. However, EXPRESSION _can_ be evaluated before VARIABLE is
bound. This means that EXPRESSION won't necessarily be able to assign
values to VARIABLE as in `(define foo (begin (set! foo 1) (+ foo 1)))'. */
static SCM
expand_define (SCM expr, SCM env)
{
const SCM cdr_expr = CDR (expr);
SCM body;
SCM variable;
ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
ASSERT_SYNTAX (!scm_is_pair (env), s_bad_define, expr);
body = CDR (cdr_expr);
variable = CAR (cdr_expr);
if (scm_is_pair (variable))
{
ASSERT_SYNTAX_2 (scm_is_symbol (CAR (variable)), s_bad_variable, variable, expr);
return TOPLEVEL_DEFINE
(scm_source_properties (expr),
CAR (variable),
expand_lambda (scm_cons (scm_sym_lambda, scm_cons (CDR (variable), body)),
env));
}
ASSERT_SYNTAX_2 (scm_is_symbol (variable), s_bad_variable, variable, expr);
ASSERT_SYNTAX (scm_ilength (body) == 1, s_expression, expr);
return TOPLEVEL_DEFINE (scm_source_properties (expr), variable,
expand (CAR (body), env));
}
static Expr* list(Expr* args) {
assert(args);
if(args == EMPTY_LIST) return EMPTY_LIST;
Expr* head = scm_mk_pair(EMPTY_LIST, EMPTY_LIST);
Expr* cur = head;
if(!head) return OOM;
scm_stack_push(&head);
while(scm_is_pair(args) && scm_is_pair(scm_cdr(args))) {
cur->pair.car = scm_car(args);
Expr* next = scm_mk_pair(EMPTY_LIST, EMPTY_LIST);
if(!next) {
cur = NULL;
break;
}
cur->pair.cdr = next;
cur = next;
args = scm_cdr(args);
}
scm_stack_pop(&head);
if(!cur) return OOM;
if(scm_cdr(args) != EMPTY_LIST) return scm_mk_error("Args to list aren't in a proper list");
cur->pair.car = scm_car(args);
return head;
}
static void conv_highlight_keywords(struct conv *conv)
{
int key_index = 0;
scheme *sc = conv->proc->sc;
pointer sym = conv->proc->code;
assert(sc);
assert(sym);
if (sym == sc->NIL) {
warn("%s: conv proc not a symbol", __FUNCTION__);
return;
}
pointer ifc = sc->vptr->find_slot_in_env(sc, sc->envir, sym, 1);
if (! scm_is_pair(sc, ifc)) {
warn("%s: conv '%s' has no value", __FUNCTION__, scm_sym_val(sc, sym));
return;
}
pointer clos = scm_cdr(sc, ifc);
if (! scm_is_closure(sc, clos)) {
warn("%s: conv '%s' not a closure", __FUNCTION__, scm_sym_val(sc, sym));
return;
}
pointer env = scm_cdr(sc, clos);
pointer vtable = scm_cdr(sc, scm_car(sc, scm_car(sc, env)));
conv->n_keywords = scm_len(sc, vtable);
if (!(conv->keywords = (char**)calloc(conv->n_keywords, sizeof(char*)))) {
warn("%s: failed to allocate keyword array size %d", __FUNCTION__, conv->n_keywords);
return;
}
if (!(conv->marked = bitset_alloc(conv->n_keywords))) {
warn("%s: failed to allocate bitset array size %d", __FUNCTION__, conv->n_keywords);
return;
}
while (scm_is_pair(sc, vtable)) {
pointer binding = scm_car(sc, vtable);
vtable = scm_cdr(sc, vtable);
pointer var = scm_car(sc, binding);
if (conv_add_keyword(conv, scm_sym_val(sc, var), key_index)) {
return;
}
key_index++;
}
conv_sort_keywords(conv);
}
static SCM
ppscm_search_pp_list (SCM list, SCM value)
{
SCM orig_list = list;
if (scm_is_null (list))
return SCM_BOOL_F;
if (gdbscm_is_false (scm_list_p (list))) /* scm_is_pair? */
{
return ppscm_make_pp_type_error_exception
(_("pretty-printer list is not a list"), list);
}
for ( ; scm_is_pair (list); list = scm_cdr (list))
{
SCM matcher = scm_car (list);
SCM worker;
pretty_printer_smob *pp_smob;
if (!ppscm_is_pretty_printer (matcher))
{
return ppscm_make_pp_type_error_exception
(_("pretty-printer list contains non-pretty-printer object"),
matcher);
}
pp_smob = (pretty_printer_smob *) SCM_SMOB_DATA (matcher);
/* Skip if disabled. */
if (gdbscm_is_false (pp_smob->enabled))
continue;
if (!gdbscm_is_procedure (pp_smob->lookup))
{
return ppscm_make_pp_type_error_exception
(_("invalid lookup object in pretty-printer matcher"),
pp_smob->lookup);
}
worker = gdbscm_safe_call_2 (pp_smob->lookup, matcher,
value, gdbscm_memory_error_p);
if (!gdbscm_is_false (worker))
{
if (gdbscm_is_exception (worker))
return worker;
if (ppscm_is_pretty_printer_worker (worker))
return worker;
return ppscm_make_pp_type_error_exception
(_("invalid result from pretty-printer lookup"), worker);
}
}
if (!scm_is_null (list))
{
return ppscm_make_pp_type_error_exception
(_("pretty-printer list is not a list"), orig_list);
}
return SCM_BOOL_F;
}
static Expr* eqv(Expr* args) {
assert(args);
if(scm_list_len(args) != 2) return scm_mk_error("eqv? expects 2 args");
Expr* fst = scm_car(args);
Expr* snd = scm_cadr(args);
if(fst == snd) return TRUE;
if(scm_is_pair(fst) || scm_is_pair(snd)) return FALSE;
if(scm_is_closure(fst) || scm_is_closure(snd)) return FALSE;
if(scm_is_num(fst) && scm_is_num(snd)) return num_eq(args);
if(scm_is_string(fst) && scm_is_string(snd) && strcmp(scm_sval(fst), scm_sval(snd)) == 0) return TRUE;
return FALSE;
}
static Expr* num_lte(Expr* args) {
assert(args);
if(args == EMPTY_LIST) return TRUE;
Expr* cur = scm_car(args);
checknum(cur);
bool ok = true;
double curVal = scm_is_int(cur) ? scm_ival(cur) : scm_rval(cur);
args = scm_cdr(args);
while(scm_is_pair(args)) {
cur = scm_car(args);
checknum(cur);
double newVal = scm_is_int(cur) ? scm_ival(cur) : scm_rval(cur);
if(newVal < curVal) {
ok = false;
break;
}
curVal = newVal;
args = scm_cdr(args);
}
if(ok && args != EMPTY_LIST) return scm_mk_error("arguments to <= aren't a proper list");
return ok ? TRUE : FALSE;
}
static Expr* mul(Expr* args) {
assert(args);
double dbuf = 1.0;
long long lbuf = 1;
bool exact = true;
while(scm_is_pair(args)) {
Expr* cur = scm_car(args);
if(scm_is_int(cur)) {
lbuf *= scm_ival(cur);
dbuf *= scm_ival(cur);
} else if(scm_is_real(cur)) {
exact = false;
dbuf *= scm_rval(cur);
} else {
return scm_mk_error("Wrong type of argument to *");
}
args = scm_cdr(args);
}
if(args != EMPTY_LIST) {
return scm_mk_error("args to * aren't a proper list");
}
return exact ? scm_mk_int(lbuf) : scm_mk_real(dbuf);
}
static Expr* pair(Expr* args) {
assert(args);
if(scm_cdr(args) != EMPTY_LIST) return scm_mk_error("passed more than 1 arg to pair?");
return scm_is_pair(scm_car(args)) ? TRUE : FALSE;
}
/* Do our best to translate a Scheme evaluation result into a C integer. */
int closure_translate_result(scheme *sc, pointer result)
{
if (result == sc->NIL ||
result == sc->F) {
return 0;
}
if (sc->vptr->is_number(result)) {
if (sc->vptr->is_integer(result)) {
return sc->vptr->ivalue(result);
}
/* coerce it */
return (int)sc->vptr->rvalue(result);
}
if (scm_is_sym(sc, result)) {
pointer pair;
pair = sc->vptr->find_slot_in_env(sc,
sc->envir,
result,
1);
assert(scm_is_pair(sc, pair));
result = sc->vptr->pair_cdr(pair);
/* recursive call... */
return closure_translate_result(sc, result);
}
if (scm_is_ptr(sc, result)) {
return (long)sc->vptr->ffvalue(result);
}
return 1;
}
static SCM
memoize_exps (SCM exps, SCM env)
{
SCM ret;
for (ret = SCM_EOL; scm_is_pair (exps); exps = CDR (exps))
ret = scm_cons (memoize (CAR (exps), env), ret);
return scm_reverse_x (ret, SCM_UNDEFINED);
}
static SCM
expand (SCM exp, SCM env)
{
if (scm_is_pair (exp))
{
SCM car;
scm_t_macro_primitive trans = NULL;
SCM macro = SCM_BOOL_F;
car = CAR (exp);
if (scm_is_symbol (car))
macro = expand_env_ref_macro (env, car);
if (scm_is_true (macro))
trans = scm_i_macro_primitive (macro);
if (trans)
return trans (exp, env);
else
{
SCM arg_exps = SCM_EOL;
SCM args = SCM_EOL;
SCM proc = CAR (exp);
for (arg_exps = CDR (exp); scm_is_pair (arg_exps);
arg_exps = CDR (arg_exps))
args = scm_cons (expand (CAR (arg_exps), env), args);
if (scm_is_null (arg_exps))
return CALL (scm_source_properties (exp),
expand (proc, env),
scm_reverse_x (args, SCM_UNDEFINED));
else
syntax_error ("expected a proper list", exp, SCM_UNDEFINED);
}
}
else if (scm_is_symbol (exp))
{
SCM gensym = expand_env_lexical_gensym (env, exp);
if (scm_is_true (gensym))
return LEXICAL_REF (SCM_BOOL_F, exp, gensym);
else
return TOPLEVEL_REF (SCM_BOOL_F, exp);
}
else
return CONST (SCM_BOOL_F, exp);
}
static int
expand_env_var_is_free (SCM env, SCM x)
{
for (; scm_is_pair (env); env = CDR (env))
if (scm_is_eq (x, CAAR (env)))
return 0; /* bound */
return 1; /* free */
}
static SCM
expand_env_lexical_gensym (SCM env, SCM name)
{
for (; scm_is_pair (env); env = CDR (env))
if (scm_is_eq (name, CAAR (env)))
return CDAR (env); /* bound */
return SCM_BOOL_F; /* free */
}
static int
lookup (SCM x, SCM env)
{
int i = 0;
for (; scm_is_pair (env); env = CDR (env), i++)
if (scm_is_eq (x, CAR (env)))
return i; /* bound */
abort ();
}
static SCM
expand_case_lambda_star (SCM expr, SCM env)
{
ASSERT_SYNTAX (scm_is_pair (CDR (expr)), s_missing_expression, expr);
return LAMBDA (scm_source_properties (expr),
SCM_EOL,
expand_case_lambda_star_clauses (CADR (expr), CDDR (expr), env));
}
/*! \todo Finish function documentation!!!
* \brief
* \par Function Description
*
*/
SCM g_funcs_filesel(SCM scm_msg, SCM scm_templ, SCM scm_flags)
{
int c_flags;
char *r, *msg, *templ;
SCM v;
SCM_ASSERT (scm_is_string (scm_msg), scm_msg,
SCM_ARG1, "gschem-filesel");
SCM_ASSERT (scm_is_string (scm_templ), scm_templ,
SCM_ARG2, "gschem-filesel");
/*! \bug FIXME -- figure out the magic SCM_ASSERT for the flags */
/*! \bug FIXME -- how to deal with conflicting flags?
* Should I throw a scheme error? Just deal in the c code?
*/
for (c_flags = 0; scm_is_pair (scm_flags); scm_flags = SCM_CDR (scm_flags)) {
char *flag;
SCM scm_flag = SCM_CAR (scm_flags);
flag = scm_to_utf8_string (scm_flag);
if (strcmp (flag, "may_exist") == 0) {
c_flags |= FSB_MAY_EXIST;
} else if (strcmp (flag, "must_exist") == 0) {
c_flags |= FSB_MUST_EXIST;
} else if (strcmp (flag, "must_not_exist") == 0) {
c_flags |= FSB_SHOULD_NOT_EXIST;
} else if (strcmp (flag, "save") == 0) {
c_flags |= FSB_SAVE;
} else if (strcmp (flag, "open") == 0) {
c_flags |= FSB_LOAD;
} else {
free(flag);
scm_wrong_type_arg ("gschem-filesel", SCM_ARG3, scm_flag);
}
free(flag);
}
msg = scm_to_utf8_string (scm_msg);
templ = scm_to_utf8_string (scm_templ);
r = generic_filesel_dialog (msg, templ, c_flags);
free(msg);
free(templ);
v = scm_from_utf8_string (r);
g_free (r);
return v;
}
static Expr* num_eq(Expr* args) {
assert(args);
if(args == EMPTY_LIST) return TRUE;
Expr* cur = scm_car(args);
checknum(cur);
bool eq = true;
bool exact = scm_is_int(cur);
long long ex;
double in;
if(exact) {
ex = scm_ival(cur);
in = ex;
} else {
in = scm_rval(cur);
ex = in;
exact = ((double)ex) == in;
}
args = scm_cdr(args);
while(scm_is_pair(args)) {
cur = scm_car(args);
checknum(cur);
if(exact && scm_is_int(cur)) {
if(ex != scm_ival(cur)) {
eq = false;
break;
}
} else if(exact) {
if(in != scm_rval(cur)) {
eq = false;
break;
}
} else if(scm_is_real(cur)) {
if(in != scm_rval(cur)) {
eq = false;
break;
}
} else {
eq = false;
break;
}
args = scm_cdr(args);
}
if(eq && args != EMPTY_LIST) return scm_mk_error("arguments to = aren't a proper list");
return eq ? TRUE : FALSE;
}
static Expr* cdr(Expr* args) {
assert(args);
if(scm_cdr(args) != EMPTY_LIST) return scm_mk_error("passed more than 1 arg to cdr");
Expr* arg = scm_car(args);
if(!scm_is_pair(arg)) return scm_mk_error("arg to cdr must be a pair");
return scm_cdr(arg);
}
static SCM
show_invoice (SCM col_list)
{
GttGhtml *ghtml = ghtml_guile_global_hack;
SCM rc;
SCM_ASSERT ( scm_is_pair (col_list), col_list, SCM_ARG1, "gtt-show-invoice");
rc = decode_scm_col_list (ghtml, col_list);
do_show_table (ghtml, ghtml->prj, TRUE);
return rc;
}
/* A helper function for expand_lambda to support checking for duplicate
* formal arguments: Return true if OBJ is `eq?' to one of the elements of
* LIST or to the CDR of the last cons. Therefore, LIST may have any of the
* forms that a formal argument can have:
* <rest>, (<arg1> ...), (<arg1> ... . <rest>) */
static int
c_improper_memq (SCM obj, SCM list)
{
for (; scm_is_pair (list); list = CDR (list))
{
if (scm_is_eq (CAR (list), obj))
return 1;
}
return scm_is_eq (list, obj);
}
static SCM
expand_env_extend (SCM env, SCM names, SCM vars)
{
while (scm_is_pair (names))
{
env = scm_acons (CAR (names), CAR (vars), env);
names = CDR (names);
vars = CDR (vars);
}
return env;
}
static SCM
expand_case_lambda_star_clauses (SCM expr, SCM rest, SCM env)
{
SCM alt;
if (scm_is_pair (rest))
alt = expand_case_lambda_star_clauses (CAR (rest), CDR (rest), env);
else
alt = SCM_BOOL_F;
return expand_lambda_star_case (expr, alt, env);
}
static Expr* set_cdr(Expr* args) {
assert(args);
if(scm_list_len(args) != 2) return scm_mk_error("set-cdr! expects 2 arguments");
Expr* arg = scm_car(args);
if(!scm_is_pair(arg)) return scm_mk_error("first arg to set-cdr! must be a pair");
Expr* val = scm_cadr(args);
arg->pair.cdr = val;
return EMPTY_LIST;
}
int scm_is_alist(SCM x) {
SCM item;
if (!scm_is_list(x))
return 0;
while (!scm_is_null(x)) {
item = SCM_CAR(x);
if (!scm_is_pair(item))
return 0;
x = SCM_CDR(x);
}
return 1;
}
static SCM
capture_flat_env (SCM lambda, SCM env)
{
int nenv;
SCM vars, link, locs;
link = CAR (env);
vars = env_link_vars (link);
nenv = scm_ilength (vars);
locs = scm_c_make_vector (nenv, SCM_BOOL_F);
for (; scm_is_pair (vars); vars = CDR (vars))
scm_c_vector_set_x (locs, --nenv, CDAR (vars));
return MAKMEMO_CAPTURE_ENV (locs, lambda);
}
static Expr* sub(Expr* args) {
assert(args);
if(args == EMPTY_LIST) return scm_mk_error("no arguments passed to - (expected at least 1)");
// unary case
if(scm_cdr(args) == EMPTY_LIST) {
Expr* v = scm_car(args);
if(scm_is_int(v)) return scm_mk_int(-scm_ival(v));
if(scm_is_real(v)) return scm_mk_int(-scm_rval(v));
return scm_mk_error("wrong type of argument to -");
}
Expr* first = scm_car(args);
if(!scm_is_num(first)) return scm_mk_error("wrong type of argument to -");
bool exact = scm_is_int(first);
double dbuf = exact ? scm_ival(first) : scm_rval(first);
long long lbuf = exact ? scm_ival(first) : 0;
args = scm_cdr(args);
while(scm_is_pair(args)) {
Expr* cur = scm_car(args);
if(scm_is_int(cur)) {
lbuf -= scm_ival(cur);
dbuf -= scm_ival(cur);
} else if(scm_is_real(cur)) {
exact = false;
dbuf -= scm_rval(cur);
} else {
return scm_mk_error("Wrong type of argument to +");
}
args = scm_cdr(args);
}
if(args != EMPTY_LIST) {
return scm_mk_error("args to + aren't a proper list");
}
return exact ? scm_mk_int(lbuf) : scm_mk_real(dbuf);
}
static SCM
show_export (SCM col_list)
{
GttGhtml *ghtml = ghtml_guile_global_hack;
SCM rc;
SCM_ASSERT ( scm_is_pair (col_list), col_list, SCM_ARG1, "gtt-show-export");
rc = decode_scm_col_list (ghtml, col_list);
ghtml->show_html = FALSE;
ghtml->show_links = FALSE;
ghtml->delim = "\t";
do_show_table (ghtml, ghtml->prj, FALSE);
return rc;
}
