static SCM
gdbscm_string_to_argv (SCM string_scm)
{
char *string;
char **c_argv;
int i;
SCM result = SCM_EOL;
gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, NULL, "s",
string_scm, &string);
if (string == NULL || *string == '\0')
{
xfree (string);
return SCM_EOL;
}
c_argv = gdb_buildargv (string);
for (i = 0; c_argv[i] != NULL; ++i)
result = scm_cons (gdbscm_scm_from_c_string (c_argv[i]), result);
freeargv (c_argv);
xfree (string);
return scm_reverse_x (result, SCM_EOL);
}
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_exprs (SCM forms, const SCM env)
{
SCM ret = SCM_EOL;
for (; !scm_is_null (forms); forms = CDR (forms))
ret = scm_cons (expand (CAR (forms), env), ret);
return scm_reverse_x (ret, SCM_UNDEFINED);
}
/*! \brief Get input files from command line.
* \par Function Description
* This function returns a list of the files named on the command line.
*
* \return A list of filenames as strings.
*/
SCM g_get_input_files()
{
SCM list = SCM_EOL;
GSList *current = input_files;
while (current != NULL) {
list = scm_cons (scm_from_locale_string (current->data), list);
current = g_slist_next(current);
}
return scm_reverse_x (list, SCM_EOL);
}
/*! \brief Obtain a list of `-O' backend arguments.
* \par Function Description
* Returns a list of arguments passed to the gnetlist backend via the
* `-O' gnetlist command-line option.
*/
SCM
g_get_backend_arguments()
{
SCM result = SCM_EOL;
GSList *iter;
for (iter = backend_params; iter != NULL; iter = g_slist_next (iter)) {
result = scm_cons (scm_from_locale_string ((char *) iter->data),
result);
}
return scm_reverse_x (result, SCM_UNDEFINED);
}
/*! \brief Runs a object hook for a list of objects.
* \par Function Description
* Runs a hook called \a name, which should expect a list of #OBJECT
* smobs as its argument, with \a obj_lst as the argument list.
*
* \see g_run_hook_object()
*
* \param name name of hook to run.
* \param obj_lst list of #OBJECT smobs as hook argument.
*/
void
g_run_hook_object_list (const char *name, GList *obj_lst)
{
SCM lst = SCM_EOL;
GList *iter;
for (iter = obj_lst; iter != NULL; iter = g_list_next (iter)) {
lst = scm_cons (edascm_from_object ((OBJECT *) iter->data), lst);
}
SCM args = scm_list_1 (scm_reverse_x (lst, SCM_EOL));
scm_run_hook (g_get_hook_by_name (name), args);
scm_remember_upto_here_2 (lst, args);
}
/* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are
* transformed to the lists (vn .. v2 v1) and (i1 i2 ... in). If a duplicate
* variable name is detected, an error is signalled. */
static void
transform_bindings (const SCM bindings, const SCM expr,
SCM *const names, SCM *const vars, SCM *const initptr)
{
SCM rnames = SCM_EOL;
SCM rvars = SCM_EOL;
SCM rinits = SCM_EOL;
SCM binding_idx = bindings;
for (; !scm_is_null (binding_idx); binding_idx = CDR (binding_idx))
{
const SCM binding = CAR (binding_idx);
const SCM CDR_binding = CDR (binding);
const SCM name = CAR (binding);
ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name, rnames)),
s_duplicate_binding, name, expr);
rnames = scm_cons (name, rnames);
rvars = scm_cons (scm_gensym (SCM_UNDEFINED), rvars);
rinits = scm_cons (CAR (CDR_binding), rinits);
}
*names = scm_reverse_x (rnames, SCM_UNDEFINED);
*vars = scm_reverse_x (rvars, SCM_UNDEFINED);
*initptr = scm_reverse_x (rinits, SCM_UNDEFINED);
}
static SCM
expand_with_fluids (SCM expr, SCM env)
{
SCM binds, fluids, vals;
ASSERT_SYNTAX (scm_ilength (expr) >= 3, s_bad_expression, expr);
binds = CADR (expr);
ASSERT_SYNTAX_2 (scm_ilength (binds) >= 0, s_bad_bindings, binds, expr);
for (fluids = SCM_EOL, vals = SCM_EOL;
scm_is_pair (binds);
binds = CDR (binds))
{
SCM binding = CAR (binds);
ASSERT_SYNTAX_2 (scm_ilength (CAR (binds)) == 2, s_bad_binding,
binding, expr);
fluids = scm_cons (expand (CAR (binding), env), fluids);
vals = scm_cons (expand (CADR (binding), env), vals);
}
return DYNLET (scm_source_properties (expr),
scm_reverse_x (fluids, SCM_UNDEFINED),
scm_reverse_x (vals, SCM_UNDEFINED),
expand_sequence (CDDR (expr), env));
}
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);
}
/*! \brief Get attribute value(s) from a package with given uref.
* \par Function Description
* This function returns the values of a specific attribute type
* attached to the symbol instances with the given refdes.
*
* Every first attribute value found is added to the return list. A
* Scheme false value is added if the instance has no such attribute.
*
* \note The order of the values in the return list is the order of
* symbol instances within gnetlist (the first element is the value
* associated with the first symbol instance).
*
* \param [in] scm_uref Package reference.
* \param [in] scm_wanted_attrib Attribute name.
* \return A list of attribute values as strings and #f.
*/
SCM g_get_all_package_attributes(SCM scm_uref, SCM scm_wanted_attrib)
{
SCM ret = SCM_EOL;
NETLIST *nl_current;
char *uref;
char *wanted_attrib;
SCM_ASSERT(scm_is_string (scm_uref),
scm_uref, SCM_ARG1, "gnetlist:get-all-package-attributes");
SCM_ASSERT(scm_is_string (scm_wanted_attrib),
scm_wanted_attrib, SCM_ARG2, "gnetlist:get-all-package-attributes");
uref = scm_to_utf8_string (scm_uref);
wanted_attrib = scm_to_utf8_string (scm_wanted_attrib);
/* here is where you make it multi page aware */
nl_current = netlist_head;
/* search for uref instances and through the entire list */
while (nl_current != NULL) {
if (nl_current->component_uref) {
if (strcmp(nl_current->component_uref, uref) == 0) {
char *value =
o_attrib_search_object_attribs_by_name (nl_current->object_ptr,
wanted_attrib, 0);
ret = scm_cons (value ? scm_from_utf8_string (value) : SCM_BOOL_F, ret);
g_free (value);
}
}
nl_current = nl_current->next;
}
free (uref);
free (wanted_attrib);
return scm_reverse_x (ret, SCM_EOL);
}
/*! \brief Runs a object hook for a list of objects.
* \par Function Description
* Runs a hook called \a name, which should expect a list of #OBJECT
* smobs as its argument, with \a obj_lst as the argument list.
*
* \see g_run_hook_object()
*
* \param name name of hook to run.
* \param obj_lst list of #OBJECT smobs as hook argument.
*/
void
g_run_hook_object_list (GschemToplevel *w_current, const char *name,
GList *obj_lst)
{
SCM lst = SCM_EOL;
GList *iter;
scm_dynwind_begin (0);
g_dynwind_window (w_current);
for (iter = obj_lst; iter != NULL; iter = g_list_next (iter)) {
lst = scm_cons (edascm_from_object ((OBJECT *) iter->data), lst);
}
SCM expr = scm_list_3 (run_hook_sym,
g_get_hook_by_name (name),
scm_cons (list_sym,
scm_reverse_x (lst, SCM_EOL)));
g_scm_eval_protected (expr, scm_interaction_environment ());
scm_dynwind_end ();
scm_remember_upto_here_1 (expr);
}
static SCM
gdbscm_string_to_argv (SCM string_scm)
{
char *string;
SCM result = SCM_EOL;
gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, NULL, "s",
string_scm, &string);
if (string == NULL || *string == '\0')
{
xfree (string);
return SCM_EOL;
}
gdb_argv c_argv (string);
for (char *arg : c_argv)
result = scm_cons (gdbscm_scm_from_c_string (arg), result);
xfree (string);
return scm_reverse_x (result, SCM_EOL);
}
static SCM
memoize (SCM exp, SCM env)
{
if (!SCM_EXPANDED_P (exp))
abort ();
switch (SCM_EXPANDED_TYPE (exp))
{
case SCM_EXPANDED_VOID:
return MAKMEMO_QUOTE (SCM_UNSPECIFIED);
case SCM_EXPANDED_CONST:
return MAKMEMO_QUOTE (REF (exp, CONST, EXP));
case SCM_EXPANDED_PRIMITIVE_REF:
if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
return MAKMEMO_TOP_REF (REF (exp, PRIMITIVE_REF, NAME));
else
return MAKMEMO_MOD_REF (list_of_guile, REF (exp, PRIMITIVE_REF, NAME),
SCM_BOOL_F);
case SCM_EXPANDED_LEXICAL_REF:
return MAKMEMO_LEX_REF (lookup (REF (exp, LEXICAL_REF, GENSYM), env));
case SCM_EXPANDED_LEXICAL_SET:
return MAKMEMO_LEX_SET (lookup (REF (exp, LEXICAL_SET, GENSYM), env),
memoize (REF (exp, LEXICAL_SET, EXP), env));
case SCM_EXPANDED_MODULE_REF:
return MAKMEMO_MOD_REF (REF (exp, MODULE_REF, MOD),
REF (exp, MODULE_REF, NAME),
REF (exp, MODULE_REF, PUBLIC));
case SCM_EXPANDED_MODULE_SET:
return MAKMEMO_MOD_SET (memoize (REF (exp, MODULE_SET, EXP), env),
REF (exp, MODULE_SET, MOD),
REF (exp, MODULE_SET, NAME),
REF (exp, MODULE_SET, PUBLIC));
case SCM_EXPANDED_TOPLEVEL_REF:
return MAKMEMO_TOP_REF (REF (exp, TOPLEVEL_REF, NAME));
case SCM_EXPANDED_TOPLEVEL_SET:
return MAKMEMO_TOP_SET (REF (exp, TOPLEVEL_SET, NAME),
memoize (REF (exp, TOPLEVEL_SET, EXP), env));
case SCM_EXPANDED_TOPLEVEL_DEFINE:
return MAKMEMO_DEFINE (REF (exp, TOPLEVEL_DEFINE, NAME),
memoize (REF (exp, TOPLEVEL_DEFINE, EXP), env));
case SCM_EXPANDED_CONDITIONAL:
return MAKMEMO_IF (memoize (REF (exp, CONDITIONAL, TEST), env),
memoize (REF (exp, CONDITIONAL, CONSEQUENT), env),
memoize (REF (exp, CONDITIONAL, ALTERNATE), env));
case SCM_EXPANDED_CALL:
{
SCM proc, args;
proc = REF (exp, CALL, PROC);
args = memoize_exps (REF (exp, CALL, ARGS), env);
return MAKMEMO_CALL (memoize (proc, env), scm_ilength (args), args);
}
case SCM_EXPANDED_PRIMCALL:
{
SCM name, args;
int nargs;
name = REF (exp, PRIMCALL, NAME);
args = memoize_exps (REF (exp, PRIMCALL, ARGS), env);
nargs = scm_ilength (args);
if (nargs == 3
&& scm_is_eq (name, scm_from_latin1_symbol ("call-with-prompt")))
return MAKMEMO_CALL_WITH_PROMPT (CAR (args),
CADR (args),
CADDR (args));
else if (nargs == 2
&& scm_is_eq (name, scm_from_latin1_symbol ("apply")))
return MAKMEMO_APPLY (CAR (args), CADR (args));
else if (nargs == 1
&& scm_is_eq (name,
scm_from_latin1_symbol
("call-with-current-continuation")))
return MAKMEMO_CONT (CAR (args));
else if (nargs == 2
&& scm_is_eq (name,
scm_from_latin1_symbol ("call-with-values")))
return MAKMEMO_CALL_WITH_VALUES (CAR (args), CADR (args));
else if (nargs == 2
&& scm_is_eq (name, scm_from_latin1_symbol ("wind")))
return MAKMEMO_CALL (MAKMEMO_QUOTE (wind), 2, args);
else if (nargs == 0
&& scm_is_eq (name, scm_from_latin1_symbol ("unwind")))
return MAKMEMO_CALL (MAKMEMO_QUOTE (unwind), 0, SCM_EOL);
else if (nargs == 2
&& scm_is_eq (name, scm_from_latin1_symbol ("push-fluid")))
return MAKMEMO_CALL (MAKMEMO_QUOTE (push_fluid), 2, args);
else if (nargs == 0
&& scm_is_eq (name, scm_from_latin1_symbol ("pop-fluid")))
return MAKMEMO_CALL (MAKMEMO_QUOTE (pop_fluid), 0, SCM_EOL);
else if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
return MAKMEMO_CALL (MAKMEMO_TOP_REF (name), nargs, args);
else
return MAKMEMO_CALL (MAKMEMO_MOD_REF (list_of_guile, name,
SCM_BOOL_F),
nargs,
args);
}
case SCM_EXPANDED_SEQ:
return MAKMEMO_SEQ (memoize (REF (exp, SEQ, HEAD), env),
memoize (REF (exp, SEQ, TAIL), env));
case SCM_EXPANDED_LAMBDA:
/* The body will be a lambda-case or #f. */
{
SCM meta, docstring, body, proc;
meta = REF (exp, LAMBDA, META);
docstring = scm_assoc_ref (meta, scm_sym_documentation);
body = REF (exp, LAMBDA, BODY);
if (scm_is_false (body))
/* Give a body to case-lambda with no clauses. */
proc = MAKMEMO_LAMBDA
(MAKMEMO_CALL
(MAKMEMO_MOD_REF (list_of_guile,
scm_from_latin1_symbol ("throw"),
SCM_BOOL_F),
5,
scm_list_5 (MAKMEMO_QUOTE (scm_args_number_key),
MAKMEMO_QUOTE (SCM_BOOL_F),
MAKMEMO_QUOTE (scm_from_latin1_string
("Wrong number of arguments")),
MAKMEMO_QUOTE (SCM_EOL),
MAKMEMO_QUOTE (SCM_BOOL_F))),
FIXED_ARITY (0),
SCM_BOOL_F /* docstring */);
else
proc = memoize (body, env);
if (scm_is_string (docstring))
{
SCM args = SCM_MEMOIZED_ARGS (proc);
SCM_SETCAR (SCM_CDR (args), docstring);
}
return proc;
}
case SCM_EXPANDED_LAMBDA_CASE:
{
SCM req, rest, opt, kw, inits, vars, body, alt;
SCM walk, minits, arity, new_env;
int nreq, nopt, ntotal;
req = REF (exp, LAMBDA_CASE, REQ);
rest = scm_not (scm_not (REF (exp, LAMBDA_CASE, REST)));
opt = REF (exp, LAMBDA_CASE, OPT);
kw = REF (exp, LAMBDA_CASE, KW);
inits = REF (exp, LAMBDA_CASE, INITS);
vars = REF (exp, LAMBDA_CASE, GENSYMS);
body = REF (exp, LAMBDA_CASE, BODY);
alt = REF (exp, LAMBDA_CASE, ALTERNATE);
nreq = scm_ilength (req);
nopt = scm_is_pair (opt) ? scm_ilength (opt) : 0;
ntotal = scm_ilength (vars);
/* The vars are the gensyms, according to the divine plan. But we need
to memoize the inits within their appropriate environment,
complicating things. */
new_env = env;
for (walk = req; scm_is_pair (walk);
walk = CDR (walk), vars = CDR (vars))
new_env = scm_cons (CAR (vars), new_env);
minits = SCM_EOL;
for (walk = opt; scm_is_pair (walk);
walk = CDR (walk), vars = CDR (vars), inits = CDR (inits))
{
minits = scm_cons (memoize (CAR (inits), new_env), minits);
new_env = scm_cons (CAR (vars), new_env);
}
if (scm_is_true (rest))
{
new_env = scm_cons (CAR (vars), new_env);
vars = CDR (vars);
}
for (; scm_is_pair (inits); vars = CDR (vars), inits = CDR (inits))
{
minits = scm_cons (memoize (CAR (inits), new_env), minits);
new_env = scm_cons (CAR (vars), new_env);
}
if (!scm_is_null (vars))
abort ();
minits = scm_reverse_x (minits, SCM_UNDEFINED);
if (scm_is_true (kw))
{
/* (aok? (kw name sym) ...) -> (aok? (kw . index) ...) */
SCM aok = CAR (kw), indices = SCM_EOL;
for (kw = CDR (kw); scm_is_pair (kw); kw = CDR (kw))
{
SCM k;
int idx;
k = CAR (CAR (kw));
idx = ntotal - 1 - lookup (CADDR (CAR (kw)), new_env);
indices = scm_acons (k, SCM_I_MAKINUM (idx), indices);
}
kw = scm_cons (aok, scm_reverse_x (indices, SCM_UNDEFINED));
}
if (scm_is_false (alt) && scm_is_false (kw) && scm_is_false (opt))
{
if (scm_is_false (rest))
arity = FIXED_ARITY (nreq);
else
arity = REST_ARITY (nreq, SCM_BOOL_T);
}
else if (scm_is_true (alt))
arity = FULL_ARITY (nreq, rest, nopt, kw, minits,
SCM_MEMOIZED_ARGS (memoize (alt, env)));
else
arity = FULL_ARITY (nreq, rest, nopt, kw, minits, SCM_BOOL_F);
return MAKMEMO_LAMBDA (memoize (body, new_env), arity,
SCM_BOOL_F /* docstring */);
}
case SCM_EXPANDED_LET:
{
SCM vars, exps, body, inits, new_env;
vars = REF (exp, LET, GENSYMS);
exps = REF (exp, LET, VALS);
body = REF (exp, LET, BODY);
inits = SCM_EOL;
new_env = env;
for (; scm_is_pair (vars); vars = CDR (vars), exps = CDR (exps))
{
new_env = scm_cons (CAR (vars), new_env);
inits = scm_cons (memoize (CAR (exps), env), inits);
}
return MAKMEMO_LET (scm_reverse_x (inits, SCM_UNDEFINED),
memoize (body, new_env));
}
case SCM_EXPANDED_LETREC:
{
SCM vars, exps, body, undefs, new_env;
int i, nvars, in_order_p;
vars = REF (exp, LETREC, GENSYMS);
exps = REF (exp, LETREC, VALS);
body = REF (exp, LETREC, BODY);
in_order_p = scm_is_true (REF (exp, LETREC, IN_ORDER_P));
nvars = i = scm_ilength (vars);
undefs = SCM_EOL;
new_env = env;
for (; scm_is_pair (vars); vars = CDR (vars))
{
new_env = scm_cons (CAR (vars), new_env);
undefs = scm_cons (MAKMEMO_QUOTE (SCM_UNDEFINED), undefs);
}
if (in_order_p)
{
SCM body_exps = SCM_EOL, seq;
for (; scm_is_pair (exps); exps = CDR (exps), i--)
body_exps = scm_cons (MAKMEMO_LEX_SET (i-1,
memoize (CAR (exps), new_env)),
body_exps);
seq = memoize (body, new_env);
for (; scm_is_pair (body_exps); body_exps = CDR (body_exps))
seq = MAKMEMO_SEQ (CAR (body_exps), seq);
return MAKMEMO_LET (undefs, seq);
}
else
{
SCM sets = SCM_EOL, inits = SCM_EOL, set_seq;
for (; scm_is_pair (exps); exps = CDR (exps), i--)
{
sets = scm_cons (MAKMEMO_LEX_SET ((i-1) + nvars,
MAKMEMO_LEX_REF (i-1)),
sets);
inits = scm_cons (memoize (CAR (exps), new_env), inits);
}
inits = scm_reverse_x (inits, SCM_UNDEFINED);
sets = scm_reverse_x (sets, SCM_UNDEFINED);
if (scm_is_null (sets))
return memoize (body, env);
for (set_seq = CAR (sets), sets = CDR (sets); scm_is_pair (sets);
sets = CDR (sets))
set_seq = MAKMEMO_SEQ (CAR (sets), set_seq);
return MAKMEMO_LET (undefs,
MAKMEMO_SEQ (MAKMEMO_LET (inits, set_seq),
memoize (body, new_env)));
}
}
default:
abort ();
}
}
static void
shell_main (void *data, int argc, char **argv)
{
SCM setup_lst = SCM_EOL; /* We reverse! this before using it. */
SCM run_lst = SCM_EOL; /* We reverse! this before using it. */
int c;
int interactive = 1;
int inhibit_rc = 0;
int status;
TOPLEVEL *toplevel;
#include "shell.x"
/* Parse command-line arguments */
opterr = 0;
while ((c = getopt (argc, argv, GETOPT_OPTIONS)) != -1) {
switch (c) {
case 's':
/* Construct an application of LOAD to the script name */
run_lst = scm_cons (scm_list_2 (sym_load,
scm_from_locale_string (optarg)),
run_lst);
interactive = 0;
goto endoptloop;
case 'c':
/* We need to evaluate an expression */
run_lst = scm_cons (scm_list_2 (sym_eval_string,
scm_from_locale_string (optarg)),
run_lst);
interactive = 0;
goto endoptloop;
case 'L':
/* Add argument to %load-path */
setup_lst = scm_cons (scm_list_3 (sym_set_x,
sym_load_path,
scm_list_3 (sym_cons,
scm_from_locale_string (optarg),
sym_load_path)),
setup_lst);
break;
case 'l':
/* Same as -s, pretty much */
run_lst = scm_cons (scm_list_2 (sym_load,
scm_from_locale_string (optarg)),
run_lst);
break;
case 'q':
inhibit_rc = 1;
break;
case 'h':
usage (0);
case 'V':
version();
case '?':
if ((optopt != ':') && (strchr (GETOPT_OPTIONS, optopt) != NULL)) {
fprintf (stderr,
"ERROR: -%c option requires an argument.\n\n",
optopt);
usage (1);
} else if (isprint (optopt)) {
fprintf (stderr, "ERROR: Unknown option -%c\n\n", optopt);
usage (1);
} else {
fprintf (stderr,
"ERROR: Unknown option character `\\x%x'.\n\n",
optopt);
usage (1);
}
default:
g_assert_not_reached ();
}
}
endoptloop:
/* Set program arguments visible from Guile */
scm_set_program_arguments (argc - optind, argv + optind, "geda-shell");
/* If interactive mode, load readline and run top REPL. */
if (interactive) {
run_lst = scm_cons (scm_list_2 (sym_use_modules,
scm_list_2 (sym_ice_9, sym_readline)),
run_lst);
run_lst = scm_cons (scm_list_1 (sym_activate_readline), run_lst);
run_lst = scm_cons (scm_list_1 (sym_top_repl), run_lst);
/* Print GPL bumf if necessary */
if (isatty (1) && isatty (0)) {
printf (
"gEDA " PACKAGE_GIT_VERSION "\n"
"Copyright (C) 1998-2010 gEDA developers\n"
"This is free software, and you are welcome to redistribute it under\n"
"certain conditions. For details, see the file `COPYING', which is\n"
"included in the gEDA distribution.\n"
"There is NO WARRANTY, to the extent permitted by law.\n"
);
}
} else {
run_lst = scm_cons (scm_list_1 (sym_quit), run_lst);
}
/* Reverse lists */
setup_lst = scm_reverse_x (setup_lst, SCM_UNDEFINED);
run_lst = scm_reverse_x (run_lst, SCM_UNDEFINED);
/* Initialise libgeda */
libgeda_init ();
scm_dynwind_begin (0);
toplevel = s_toplevel_new ();
edascm_dynwind_toplevel (toplevel);
/* First run the setup list */
if (setup_lst != SCM_EOL) {
setup_lst = scm_cons (sym_begin, setup_lst);
scm_eval_x (setup_lst, scm_current_module ());
}
/* Now load rc files, if necessary */
if (!inhibit_rc)
g_rc_parse (toplevel, argv[0], NULL, NULL);
i_vars_libgeda_set (toplevel); /* Ugh */
/* Finally evaluate run list */
run_lst = scm_cons (sym_begin, run_lst);
status = scm_exit_status (scm_eval_x (run_lst, scm_current_module ()));
exit (status);
scm_dynwind_end ();
scm_remember_upto_here_2 (setup_lst, run_lst);
}
static SCM
memoize (SCM exp, SCM env)
{
if (!SCM_EXPANDED_P (exp))
abort ();
switch (SCM_EXPANDED_TYPE (exp))
{
case SCM_EXPANDED_VOID:
return MAKMEMO_QUOTE (SCM_UNSPECIFIED);
case SCM_EXPANDED_CONST:
return MAKMEMO_QUOTE (REF (exp, CONST, EXP));
case SCM_EXPANDED_PRIMITIVE_REF:
if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
return maybe_makmemo_capture_module
(MAKMEMO_BOX_REF (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_REF,
REF (exp, PRIMITIVE_REF, NAME))),
env);
else
return MAKMEMO_BOX_REF (MAKMEMO_MOD_BOX (SCM_EXPANDED_MODULE_REF,
list_of_guile,
REF (exp, PRIMITIVE_REF, NAME),
SCM_BOOL_F));
case SCM_EXPANDED_LEXICAL_REF:
return MAKMEMO_LEX_REF (lookup (REF (exp, LEXICAL_REF, GENSYM), env));
case SCM_EXPANDED_LEXICAL_SET:
return MAKMEMO_LEX_SET (lookup (REF (exp, LEXICAL_SET, GENSYM), env),
memoize (REF (exp, LEXICAL_SET, EXP), env));
case SCM_EXPANDED_MODULE_REF:
return MAKMEMO_BOX_REF (MAKMEMO_MOD_BOX
(SCM_EXPANDED_MODULE_REF,
REF (exp, MODULE_REF, MOD),
REF (exp, MODULE_REF, NAME),
REF (exp, MODULE_REF, PUBLIC)));
case SCM_EXPANDED_MODULE_SET:
return MAKMEMO_BOX_SET (MAKMEMO_MOD_BOX
(SCM_EXPANDED_MODULE_SET,
REF (exp, MODULE_SET, MOD),
REF (exp, MODULE_SET, NAME),
REF (exp, MODULE_SET, PUBLIC)),
memoize (REF (exp, MODULE_SET, EXP), env));
case SCM_EXPANDED_TOPLEVEL_REF:
return maybe_makmemo_capture_module
(MAKMEMO_BOX_REF (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_REF,
REF (exp, TOPLEVEL_REF, NAME))),
env);
case SCM_EXPANDED_TOPLEVEL_SET:
return maybe_makmemo_capture_module
(MAKMEMO_BOX_SET (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_SET,
REF (exp, TOPLEVEL_SET, NAME)),
memoize (REF (exp, TOPLEVEL_SET, EXP),
capture_env (env))),
env);
case SCM_EXPANDED_TOPLEVEL_DEFINE:
return maybe_makmemo_capture_module
(MAKMEMO_BOX_SET (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_DEFINE,
REF (exp, TOPLEVEL_DEFINE, NAME)),
memoize (REF (exp, TOPLEVEL_DEFINE, EXP),
capture_env (env))),
env);
case SCM_EXPANDED_CONDITIONAL:
return MAKMEMO_IF (memoize (REF (exp, CONDITIONAL, TEST), env),
memoize (REF (exp, CONDITIONAL, CONSEQUENT), env),
memoize (REF (exp, CONDITIONAL, ALTERNATE), env));
case SCM_EXPANDED_CALL:
{
SCM proc, args;
proc = REF (exp, CALL, PROC);
args = memoize_exps (REF (exp, CALL, ARGS), env);
return MAKMEMO_CALL (memoize (proc, env), args);
}
case SCM_EXPANDED_PRIMCALL:
{
SCM name, args;
int nargs;
name = REF (exp, PRIMCALL, NAME);
args = memoize_exps (REF (exp, PRIMCALL, ARGS), env);
nargs = scm_ilength (args);
if (nargs == 3
&& scm_is_eq (name, scm_from_latin1_symbol ("call-with-prompt")))
return MAKMEMO_CALL_WITH_PROMPT (CAR (args),
CADR (args),
CADDR (args));
else if (nargs == 2
&& scm_is_eq (name, scm_from_latin1_symbol ("apply")))
return MAKMEMO_APPLY (CAR (args), CADR (args));
else if (nargs == 1
&& scm_is_eq (name,
scm_from_latin1_symbol
("call-with-current-continuation")))
return MAKMEMO_CONT (CAR (args));
else if (nargs == 2
&& scm_is_eq (name,
scm_from_latin1_symbol ("call-with-values")))
return MAKMEMO_CALL_WITH_VALUES (CAR (args), CADR (args));
else if (nargs == 1
&& scm_is_eq (name,
scm_from_latin1_symbol ("variable-ref")))
return MAKMEMO_BOX_REF (CAR (args));
else if (nargs == 2
&& scm_is_eq (name,
scm_from_latin1_symbol ("variable-set!")))
return MAKMEMO_BOX_SET (CAR (args), CADR (args));
else if (nargs == 2
&& scm_is_eq (name, scm_from_latin1_symbol ("wind")))
return MAKMEMO_CALL (MAKMEMO_QUOTE (wind), args);
else if (nargs == 0
&& scm_is_eq (name, scm_from_latin1_symbol ("unwind")))
return MAKMEMO_CALL (MAKMEMO_QUOTE (unwind), SCM_EOL);
else if (nargs == 2
&& scm_is_eq (name, scm_from_latin1_symbol ("push-fluid")))
return MAKMEMO_CALL (MAKMEMO_QUOTE (push_fluid), args);
else if (nargs == 0
&& scm_is_eq (name, scm_from_latin1_symbol ("pop-fluid")))
return MAKMEMO_CALL (MAKMEMO_QUOTE (pop_fluid), SCM_EOL);
else if (nargs == 1
&& scm_is_eq (name,
scm_from_latin1_symbol ("push-dynamic-state")))
return MAKMEMO_CALL (MAKMEMO_QUOTE (push_dynamic_state), args);
else if (nargs == 0
&& scm_is_eq (name,
scm_from_latin1_symbol ("pop-dynamic-state")))
return MAKMEMO_CALL (MAKMEMO_QUOTE (pop_dynamic_state), SCM_EOL);
else if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
return MAKMEMO_CALL (maybe_makmemo_capture_module
(MAKMEMO_BOX_REF
(MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_REF,
name)),
env),
args);
else
return MAKMEMO_CALL (MAKMEMO_BOX_REF
(MAKMEMO_MOD_BOX (SCM_EXPANDED_MODULE_REF,
list_of_guile,
name,
SCM_BOOL_F)),
args);
}
case SCM_EXPANDED_SEQ:
return MAKMEMO_SEQ (memoize (REF (exp, SEQ, HEAD), env),
memoize (REF (exp, SEQ, TAIL), env));
case SCM_EXPANDED_LAMBDA:
/* The body will be a lambda-case. */
{
SCM meta, body, proc, new_env;
meta = REF (exp, LAMBDA, META);
body = REF (exp, LAMBDA, BODY);
new_env = push_flat_link (capture_env (env));
proc = memoize (body, new_env);
SCM_SETCAR (SCM_CDR (SCM_MEMOIZED_ARGS (proc)), meta);
return maybe_makmemo_capture_module (capture_flat_env (proc, new_env),
env);
}
case SCM_EXPANDED_LAMBDA_CASE:
{
SCM req, rest, opt, kw, inits, vars, body, alt;
SCM unbound, arity, rib, new_env;
int nreq, nopt, ninits;
req = REF (exp, LAMBDA_CASE, REQ);
rest = scm_not (scm_not (REF (exp, LAMBDA_CASE, REST)));
opt = REF (exp, LAMBDA_CASE, OPT);
kw = REF (exp, LAMBDA_CASE, KW);
inits = REF (exp, LAMBDA_CASE, INITS);
vars = REF (exp, LAMBDA_CASE, GENSYMS);
body = REF (exp, LAMBDA_CASE, BODY);
alt = REF (exp, LAMBDA_CASE, ALTERNATE);
nreq = scm_ilength (req);
nopt = scm_is_pair (opt) ? scm_ilength (opt) : 0;
ninits = scm_ilength (inits);
/* This relies on assignment conversion turning inits into a
sequence of CONST expressions whose values are a unique
"unbound" token. */
unbound = ninits ? REF (CAR (inits), CONST, EXP) : SCM_BOOL_F;
rib = scm_vector (vars);
new_env = push_nested_link (rib, env);
if (scm_is_true (kw))
{
/* (aok? (kw name sym) ...) -> (aok? (kw . index) ...) */
SCM aok = CAR (kw), indices = SCM_EOL;
for (kw = CDR (kw); scm_is_pair (kw); kw = CDR (kw))
{
SCM k;
int idx;
k = CAR (CAR (kw));
idx = lookup_rib (CADDR (CAR (kw)), rib);
indices = scm_acons (k, SCM_I_MAKINUM (idx), indices);
}
kw = scm_cons (aok, scm_reverse_x (indices, SCM_UNDEFINED));
}
if (scm_is_false (alt) && scm_is_false (kw) && scm_is_false (opt))
{
if (scm_is_false (rest))
arity = FIXED_ARITY (nreq);
else
arity = REST_ARITY (nreq, SCM_BOOL_T);
}
else if (scm_is_true (alt))
arity = FULL_ARITY (nreq, rest, nopt, kw, ninits, unbound,
SCM_MEMOIZED_ARGS (memoize (alt, env)));
else
arity = FULL_ARITY (nreq, rest, nopt, kw, ninits, unbound,
SCM_BOOL_F);
return MAKMEMO_LAMBDA (memoize (body, new_env), arity,
SCM_EOL /* meta, filled in later */);
}
case SCM_EXPANDED_LET:
{
SCM vars, exps, body, varsv, inits, new_env;
int i;
vars = REF (exp, LET, GENSYMS);
exps = REF (exp, LET, VALS);
body = REF (exp, LET, BODY);
varsv = scm_vector (vars);
inits = scm_c_make_vector (VECTOR_LENGTH (varsv),
SCM_BOOL_F);
new_env = push_nested_link (varsv, capture_env (env));
for (i = 0; scm_is_pair (exps); exps = CDR (exps), i++)
VECTOR_SET (inits, i, memoize (CAR (exps), env));
return maybe_makmemo_capture_module
(MAKMEMO_LET (inits, memoize (body, new_env)), env);
}
default:
abort ();
}
}
static SCM
expand_lambda_case (SCM clause, SCM alternate, SCM env)
{
SCM formals;
SCM rest;
SCM req = SCM_EOL;
SCM vars = SCM_EOL;
SCM body;
int nreq = 0;
ASSERT_SYNTAX (scm_is_pair (clause) && scm_is_pair (CDR (clause)),
s_bad_expression, scm_cons (scm_sym_lambda, clause));
/* Before iterating the list of formal arguments, make sure the formals
* actually are given as either a symbol or a non-cyclic list. */
formals = CAR (clause);
if (scm_is_pair (formals))
{
/* Dirk:FIXME:: We should check for a cyclic list of formals, and if
* detected, report a 'Bad formals' error. */
}
else
ASSERT_SYNTAX_2 (scm_is_symbol (formals) || scm_is_null (formals),
s_bad_formals, formals, scm_cons (scm_sym_lambda, clause));
/* Now iterate the list of formal arguments to check if all formals are
* symbols, and that there are no duplicates. */
while (scm_is_pair (formals))
{
const SCM formal = CAR (formals);
formals = CDR (formals);
ASSERT_SYNTAX_2 (scm_is_symbol (formal), s_bad_formal, formal,
scm_cons (scm_sym_lambda, clause));
ASSERT_SYNTAX_2 (!c_improper_memq (formal, formals), s_duplicate_formal,
formal, scm_cons (scm_sym_lambda, clause));
nreq++;
req = scm_cons (formal, req);
vars = scm_cons (scm_gensym (SCM_UNDEFINED), vars);
env = scm_acons (formal, CAR (vars), env);
}
ASSERT_SYNTAX_2 (scm_is_null (formals) || scm_is_symbol (formals),
s_bad_formal, formals, scm_cons (scm_sym_lambda, clause));
if (scm_is_symbol (formals))
{
rest = formals;
vars = scm_cons (scm_gensym (SCM_UNDEFINED), vars);
env = scm_acons (rest, CAR (vars), env);
}
else
rest = SCM_BOOL_F;
body = expand_sequence (CDR (clause), env);
req = scm_reverse_x (req, SCM_UNDEFINED);
vars = scm_reverse_x (vars, SCM_UNDEFINED);
if (scm_is_true (alternate) && !(SCM_EXPANDED_P (alternate) && SCM_EXPANDED_TYPE (alternate) == SCM_EXPANDED_LAMBDA_CASE))
abort ();
return LAMBDA_CASE (SCM_BOOL_F, req, SCM_BOOL_F, rest, SCM_BOOL_F,
SCM_EOL, vars, body, alternate);
}
static SCM
expand_lambda_star_case (SCM clause, SCM alternate, SCM env)
{
SCM req, opt, kw, allow_other_keys, rest, formals, vars, body, tmp;
SCM inits;
int nreq, nopt;
const long length = scm_ilength (clause);
ASSERT_SYNTAX (length >= 1, s_bad_expression,
scm_cons (sym_lambda_star, clause));
ASSERT_SYNTAX (length >= 2, s_missing_expression,
scm_cons (sym_lambda_star, clause));
formals = CAR (clause);
body = CDR (clause);
nreq = nopt = 0;
req = opt = kw = SCM_EOL;
rest = allow_other_keys = SCM_BOOL_F;
while (scm_is_pair (formals) && scm_is_symbol (CAR (formals)))
{
nreq++;
req = scm_cons (CAR (formals), req);
formals = scm_cdr (formals);
}
if (scm_is_pair (formals) && scm_is_eq (CAR (formals), kw_optional))
{
formals = CDR (formals);
while (scm_is_pair (formals)
&& (scm_is_symbol (CAR (formals)) || scm_is_pair (CAR (formals))))
{
nopt++;
opt = scm_cons (CAR (formals), opt);
formals = scm_cdr (formals);
}
}
if (scm_is_pair (formals) && scm_is_eq (CAR (formals), kw_key))
{
formals = CDR (formals);
while (scm_is_pair (formals)
&& (scm_is_symbol (CAR (formals)) || scm_is_pair (CAR (formals))))
{
kw = scm_cons (CAR (formals), kw);
formals = scm_cdr (formals);
}
}
if (scm_is_pair (formals) && scm_is_eq (CAR (formals), kw_allow_other_keys))
{
formals = CDR (formals);
allow_other_keys = SCM_BOOL_T;
}
if (scm_is_pair (formals) && scm_is_eq (CAR (formals), kw_rest))
{
ASSERT_SYNTAX (scm_ilength (formals) == 2, s_bad_formals,
CAR (clause));
rest = CADR (formals);
}
else if (scm_is_symbol (formals))
rest = formals;
else
{
ASSERT_SYNTAX (scm_is_null (formals), s_bad_formals, CAR (clause));
rest = SCM_BOOL_F;
}
/* Now, iterate through them a second time, building up an expansion-time
environment, checking, expanding and canonicalizing the opt/kw init forms,
and eventually memoizing the body as well. Note that the rest argument, if
any, is expanded before keyword args, thus necessitating the second
pass.
Also note that the specific environment during expansion of init
expressions here needs to coincide with the environment when psyntax
expands. A lot of effort for something that is only used in the bootstrap
expandr, you say? Yes. Yes it is.
*/
vars = SCM_EOL;
req = scm_reverse_x (req, SCM_EOL);
for (tmp = req; scm_is_pair (tmp); tmp = scm_cdr (tmp))
{
vars = scm_cons (scm_gensym (SCM_UNDEFINED), vars);
env = scm_acons (CAR (tmp), CAR (vars), env);
}
/* Build up opt inits and env */
inits = SCM_EOL;
opt = scm_reverse_x (opt, SCM_EOL);
for (tmp = opt; scm_is_pair (tmp); tmp = scm_cdr (tmp))
{
SCM x = CAR (tmp);
vars = scm_cons (scm_gensym (SCM_UNDEFINED), vars);
env = scm_acons (x, CAR (vars), env);
if (scm_is_symbol (x))
inits = scm_cons (CONST (SCM_BOOL_F, SCM_BOOL_F), inits);
else
{
ASSERT_SYNTAX (scm_ilength (x) == 2 && scm_is_symbol (CAR (x)),
s_bad_formals, CAR (clause));
inits = scm_cons (expand (CADR (x), env), inits);
}
env = scm_acons (scm_is_symbol (x) ? x : CAR (x), CAR (vars), env);
}
if (scm_is_null (opt))
opt = SCM_BOOL_F;
/* Process rest before keyword args */
if (scm_is_true (rest))
{
vars = scm_cons (scm_gensym (SCM_UNDEFINED), vars);
env = scm_acons (rest, CAR (vars), env);
}
/* Build up kw inits, env, and kw-canon list */
if (scm_is_null (kw))
kw = SCM_BOOL_F;
else
{
SCM kw_canon = SCM_EOL;
kw = scm_reverse_x (kw, SCM_UNDEFINED);
for (tmp = kw; scm_is_pair (tmp); tmp = scm_cdr (tmp))
{
SCM x, sym, k, init;
x = CAR (tmp);
if (scm_is_symbol (x))
{
sym = x;
init = SCM_BOOL_F;
k = scm_symbol_to_keyword (sym);
}
else if (scm_ilength (x) == 2 && scm_is_symbol (CAR (x)))
{
sym = CAR (x);
init = CADR (x);
k = scm_symbol_to_keyword (sym);
}
else if (scm_ilength (x) == 3 && scm_is_symbol (CAR (x))
&& scm_is_keyword (CADDR (x)))
{
sym = CAR (x);
init = CADR (x);
k = CADDR (x);
}
else
syntax_error (s_bad_formals, CAR (clause), SCM_UNDEFINED);
inits = scm_cons (expand (init, env), inits);
vars = scm_cons (scm_gensym (SCM_UNDEFINED), vars);
kw_canon = scm_cons (scm_list_3 (k, sym, CAR (vars)), kw_canon);
env = scm_acons (sym, CAR (vars), env);
}
kw_canon = scm_reverse_x (kw_canon, SCM_UNDEFINED);
kw = scm_cons (allow_other_keys, kw_canon);
}
/* We should check for no duplicates, but given that psyntax does this
already, we can punt on it here... */
vars = scm_reverse_x (vars, SCM_UNDEFINED);
inits = scm_reverse_x (inits, SCM_UNDEFINED);
body = expand_sequence (body, env);
return LAMBDA_CASE (SCM_BOOL_F, req, opt, rest, kw, inits, vars, body,
alternate);
}
/*! \brief Parse gschem command-line options.
* \par Function Description
* Parse command line options, displaying usage message or version
* information as required.
*
* \param argc Number of command-line arguments.
* \param argv Array of command-line arguments.
* \return index into \a argv of first non-option argument.
*/
int
parse_commandline(int argc, char *argv[])
{
int ch;
SCM sym_cons = scm_from_utf8_symbol ("cons");
SCM sym_set_x = scm_from_utf8_symbol ("set!");
SCM sym_load_path = scm_from_utf8_symbol ("%load-path");
SCM sym_begin = scm_from_utf8_symbol ("begin");
SCM sym_load = scm_from_utf8_symbol ("load");
SCM sym_eval_string = scm_from_utf8_symbol ("eval-string");
#ifdef HAVE_GETOPT_LONG
while ((ch = getopt_long (argc, argv, GETOPT_OPTIONS, long_options, NULL)) != -1) {
#else
while ((ch = getopt (argc, argv, GETOPT_OPTIONS)) != -1) {
#endif
switch (ch) {
case 'v':
verbose_mode = TRUE;
break;
case 'q':
quiet_mode = TRUE;
break;
case 's':
/* Argument is filename of a Scheme script to be run on gschem
* load. Add the necessary expression to be evaluated after
* loading. */
s_post_load_expr =
scm_cons (scm_list_2 (sym_load,
scm_from_locale_string (optarg)),
s_post_load_expr);
break;
case 'c':
/* Argument is a Scheme expression to be evaluated on gschem
* load. Add the necessary expression to be evaluated after
* loading. */
s_post_load_expr =
scm_cons (scm_list_2 (sym_eval_string,
scm_from_locale_string (optarg)),
s_post_load_expr);
break;
case 'o':
output_filename_s = scm_from_locale_string (optarg);
break;
case 'p':
auto_place_mode = TRUE;
break;
case 'L':
/* Argument is a directory to add to the Scheme load path.
* Add the necessary expression to be evaluated before rc file
* loading. */
s_pre_load_expr =
scm_cons (scm_list_3 (sym_set_x,
sym_load_path,
scm_list_3 (sym_cons,
scm_from_locale_string (optarg),
sym_load_path)),
s_pre_load_expr);
break;
case 'h':
usage(argv[0]);
break;
case 'V':
version ();
break;
case '?':
#ifndef HAVE_GETOPT_LONG
if ((optopt != ':') && (strchr (GETOPT_OPTIONS, optopt) != NULL)) {
fprintf (stderr,
"ERROR: -%c option requires an argument.\n\n",
optopt);
} else if (isprint (optopt)) {
fprintf (stderr, "ERROR: Unknown option -%c.\n\n", optopt);
} else {
fprintf (stderr, "ERROR: Unknown option character `\\x%x'.\n\n",
optopt);
}
#endif
fprintf (stderr, "\nRun `%s --help' for more information.\n", argv[0]);
exit (1);
break;
default:
g_assert_not_reached ();
}
}
if (quiet_mode) {
verbose_mode = FALSE;
}
/* Make sure Scheme expressions can be passed straight to eval */
s_pre_load_expr = scm_cons (sym_begin,
scm_reverse_x (s_pre_load_expr, SCM_UNDEFINED));
scm_gc_protect_object (s_pre_load_expr);
s_post_load_expr = scm_cons (sym_begin,
scm_reverse_x (s_post_load_expr, SCM_UNDEFINED));
scm_gc_protect_object (s_post_load_expr);
return(optind);
}
