/* 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 SCM
expand_let (SCM expr, SCM env)
{
SCM bindings;
const SCM cdr_expr = CDR (expr);
const long length = scm_ilength (cdr_expr);
ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
ASSERT_SYNTAX (length >= 2, s_missing_expression, expr);
bindings = CAR (cdr_expr);
if (scm_is_symbol (bindings))
{
ASSERT_SYNTAX (length >= 3, s_missing_expression, expr);
return expand_named_let (expr, env);
}
check_bindings (bindings, expr);
if (scm_is_null (bindings))
return expand_sequence (CDDR (expr), env);
else
{
SCM var_names, var_syms, inits;
transform_bindings (bindings, expr, &var_names, &var_syms, &inits);
return LET (SCM_BOOL_F,
var_names, var_syms, expand_exprs (inits, env),
expand_sequence (CDDR (expr),
expand_env_extend (env, var_names,
var_syms)));
}
}
static SCM make_doc(SCM ingredients, SCM recipe) {
MAKE_NODE *node;
FILE_NODE *fnode;
SCM smob, cursor;
if (scm_is_symbol(ingredients)) {
if (ingredients == file_sym) {
node = make_node(TYPE_FILE);
node->filepath = scm_to_locale_string(recipe);
node->dirty = 1;
fnode = (FILE_NODE *)malloc(sizeof(FILE_NODE));
fnode->node = node;
fnode->mtime = 0;
fnode->next = file_nodes;
file_nodes = fnode;
}
else {
node = make_node(TYPE_DATUM);
node->dirty = 0;
node->payload = recipe;
}
SCM_RETURN_NEWSMOB(make_node_tag, node);
}
node = make_node(TYPE_CHAIN);
node->dirty = 1;
node->callback = recipe;
SCM_NEWSMOB(smob, make_node_tag, node);
cursor = ingredients;
while (cursor != SCM_EOL) {
add_ascendant(SCM_CAR(cursor), smob);
cursor = SCM_CDR(cursor);
}
scm_remember_upto_here_2(ingredients, recipe);
scm_remember_upto_here_2(smob, cursor);
return smob;
}
/*! \brief Exports the keymap in scheme to a GLib GArray.
* \par Function Description
* This function converts the list of key sequence/action pairs
* returned by the scheme function \c dump-current-keymap into an
* array of C structures.
*
* The returned value must be freed by caller.
*
* \return A GArray with keymap data.
*/
GArray*
g_keys_dump_keymap (void)
{
SCM dump_proc = scm_c_lookup ("dump-current-keymap");
SCM scm_ret;
GArray *ret = NULL;
struct keyseq_action_t {
gchar *keyseq, *action;
};
dump_proc = scm_variable_ref (dump_proc);
g_return_val_if_fail (SCM_NFALSEP (scm_procedure_p (dump_proc)), NULL);
scm_ret = scm_call_0 (dump_proc);
g_return_val_if_fail (SCM_CONSP (scm_ret), NULL);
ret = g_array_sized_new (FALSE,
FALSE,
sizeof (struct keyseq_action_t),
(guint)scm_ilength (scm_ret));
for (; scm_ret != SCM_EOL; scm_ret = SCM_CDR (scm_ret)) {
SCM scm_keymap_entry = SCM_CAR (scm_ret);
struct keyseq_action_t keymap_entry;
g_return_val_if_fail (SCM_CONSP (scm_keymap_entry) &&
scm_is_symbol (SCM_CAR (scm_keymap_entry)) &&
scm_is_string (SCM_CDR (scm_keymap_entry)), ret);
keymap_entry.action = g_strdup (SCM_SYMBOL_CHARS (SCM_CAR (scm_keymap_entry)));
keymap_entry.keyseq = g_strdup (SCM_STRING_CHARS (SCM_CDR (scm_keymap_entry)));
ret = g_array_append_val (ret, keymap_entry);
}
return ret;
}
static SCM
decode_scm_col_list (GttGhtml *ghtml, SCM col_list)
{
SCM col_name;
char * tok = NULL;
/* reset the parser */
ghtml->ninvl_cols = 0;
ghtml->ntask_cols = 0;
while (!scm_is_null (col_list))
{
col_name = SCM_CAR (col_list);
/* either a 'symbol or a "quoted string" */
if (!scm_is_symbol(col_name) && !scm_is_string (col_name))
{
col_list = SCM_CDR (col_list);
continue;
}
tok = scm_to_locale_string (col_name);
decode_column (ghtml, tok);
free (tok);
col_list = SCM_CDR (col_list);
}
return SCM_UNSPECIFIED;
}
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 SCM
expand_atat (SCM expr, SCM env SCM_UNUSED)
{
ASSERT_SYNTAX (scm_ilength (expr) == 3, s_bad_expression, expr);
ASSERT_SYNTAX (scm_ilength (CADR (expr)) > 0, s_bad_expression, expr);
ASSERT_SYNTAX (scm_is_symbol (CADDR (expr)), s_bad_expression, expr);
return MODULE_REF (scm_source_properties (expr),
CADR (expr), CADDR (expr), SCM_BOOL_F);
}
SCM guileGetElementProperty(SCM keySymbol)
{
if(scm_is_symbol(keySymbol))
{
char* key = scm_to_utf8_string(scm_symbol_to_string(keySymbol));
return guihckStackGetElementProperty(threadLocalContext.ctx, key);
}
else
{
return SCM_UNDEFINED;
}
}
SCM guilePushNewElement(SCM typeSymbol)
{
if(scm_is_symbol(typeSymbol))
{
char* typeName = scm_to_utf8_string(scm_symbol_to_string(typeSymbol));
guihckStackPushNewElement(threadLocalContext.ctx, typeName);
return SCM_BOOL_T;
}
else
{
return SCM_BOOL_F;
}
}
SCM guilePushElementById(SCM idSymbol)
{
if(scm_is_symbol(idSymbol))
{
char* id = scm_to_utf8_string(scm_symbol_to_string(idSymbol));
guihckStackPushElementById(threadLocalContext.ctx, id);
return SCM_BOOL_T;
}
else
{
return SCM_BOOL_F;
}
}
SCM guileSetElementProperty(SCM keySymbol, SCM value)
{
if(scm_is_symbol(keySymbol))
{
char* key = scm_to_utf8_string(scm_symbol_to_string(keySymbol));
guihckStackElementProperty(threadLocalContext.ctx, key, value);
free(key);
return SCM_BOOL_T;
}
else
{
return SCM_BOOL_F;
}
}
SCM guileKeyCode(SCM keyName)
{
char* keyNameStr;
if(scm_is_symbol(keyName))
keyNameStr = scm_to_utf8_string(scm_symbol_to_string(keyName));
else if(scm_is_string(keyName))
keyNameStr = scm_to_utf8_string(keyName);
else
assert(false && "Key name must be a symbol or a string");
guihckKey keyCode = guihckContextGetKeyCode(threadLocalContext.ctx, keyNameStr);
free(keyNameStr);
return scm_from_int32(keyCode);
}
VISIBLE int
scm_to_FontFormat (SCM symbol)
{
// Returns -1 if the argument is not a symbol representing one of
// the outline font formats.
int result = -1;
if (scm_is_symbol (symbol))
{
int i = ff_none;
while (i != -1 && !scm_is_eq (symbol, symbol_lookup[i] ()))
i--;
result = i;
}
return result;
}
/* Check if the format of the bindings is ((<symbol> <init-form>) ...). */
static void
check_bindings (const SCM bindings, const SCM expr)
{
SCM binding_idx;
ASSERT_SYNTAX_2 (scm_ilength (bindings) >= 0,
s_bad_bindings, bindings, expr);
binding_idx = bindings;
for (; !scm_is_null (binding_idx); binding_idx = CDR (binding_idx))
{
SCM name; /* const */
const SCM binding = CAR (binding_idx);
ASSERT_SYNTAX_2 (scm_ilength (binding) == 2,
s_bad_binding, binding, expr);
name = CAR (binding);
ASSERT_SYNTAX_2 (scm_is_symbol (name), s_bad_variable, name, expr);
}
}
static SCM pg_format_sql(SCM conn, SCM obj) {
struct pg_conn *pgc;
SCM out;
if (SCM_SMOB_PREDICATE(time_tag, obj)) {
out = format_time(obj, c2s("'%Y-%m-%d %H:%M:%S'"));
}
else if (scm_boolean_p(obj) == SCM_BOOL_T) {
if (scm_is_true(obj)) out = c2s("'t'");
else out = c2s("'f'");
}
else if (scm_is_number(obj)) {
out = scm_number_to_string(obj,
scm_from_signed_integer(10));
}
else if (scm_is_symbol(obj)) {
out = pg_format_sql(conn, scm_symbol_to_string(obj));
}
else if (scm_is_string(obj)) {
if (scm_string_null_p(obj) == SCM_BOOL_T) out = c2s("NULL");
else {
char *src = scm_to_utf8_string(obj);
scm_assert_smob_type(pg_conn_tag, conn);
pgc = (struct pg_conn *)SCM_SMOB_DATA(conn);
scm_lock_mutex(pgc->mutex);
char *sql = PQescapeLiteral(pgc->conn,
src, strlen(src));
out = safe_from_utf8(sql);
scm_unlock_mutex(pgc->mutex);
free(src);
PQfreemem(sql);
}
}
else if (scm_is_null(obj)) out = c2s("NULL");
else out = c2s("NULL");
scm_remember_upto_here_1(out);
scm_remember_upto_here_2(conn, obj);
return out;
}
/********************************************************************\
* gnc_guile_call1_symbol_to_string *
* returns the malloc'ed string returned by the guile function *
* or NULL if it can't be retrieved. The return value of the *
* function should be a symbol. *
* *
* Args: func - the guile function to call *
* arg - the single function argument *
* Returns: malloc'ed char * or NULL *
\********************************************************************/
char *
gnc_guile_call1_symbol_to_string(SCM func, SCM arg)
{
SCM value;
if (scm_is_procedure(func))
{
value = scm_call_1(func, arg);
if (scm_is_symbol(value))
return g_strdup(SCM_SYMBOL_CHARS(value));
else
{
PERR("bad value\n");
}
}
else
{
PERR("not a procedure\n");
}
return NULL;
}
int (scm_is_symbol) (SCM obj)
{
return scm_is_symbol(obj);
}
inline char *symstr(SCM key) {
if (scm_is_symbol(key))
return scm_to_locale_string(scm_symbol_to_string(key));
return scm_to_locale_string(key);
}
int _scm_is_symbol(SCM x) {
return scm_is_symbol(x);
}
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);
}
inline bool tmscm_is_symbol (tmscm obj) { return scm_is_symbol (obj); }
static int
supports_source_props (SCM obj)
{
return SCM_NIMP (obj) && !scm_is_symbol (obj) && !scm_is_keyword (obj);
}
