static LObject *
lisp_string_append (LObject *args)
{
LObject *obj = lipa_new_string ();
L_STRING(obj) = _append (args, L_STRING(obj));
return obj;
}
LObject *
lisp_string_equalp (LObject *args)
{
if (!lipa_list_length (args, 2))
{
fputs ("string=? wants 2 arguments\n", stderr);
return NULL;
}
if (!(STRINGP (lipa_car (args)) && STRINGP (lipa_car (lipa_cdr (args)))))
{
fputs ("string=? want string arguments\n", stderr);
return NULL;
}
return (strcmp (L_STRING (lipa_car (args))->str,
L_STRING (lipa_car (lipa_cdr (args)))->str) ?
lisp_false : lisp_true);
}
LObject *
lisp_string_smaller_thanp (LObject *args)
{
if (!lipa_list_length (args, 2))
{
fputs ("string<? wants 2 arguments\n", stderr);
return NULL;
}
if (!STRINGP (lipa_car (args)) || !STRINGP (lipa_car (lipa_cdr (args))))
{
fputs ("string<? wants string arguments\n", stderr);
return NULL;
}
return ((strcmp (L_STRING (lipa_car (args))->str,
L_STRING (lipa_car (lipa_cdr (args)))->str) < 0) ?
lisp_true : lisp_false);
}
LObject *
lisp_string_greater_than_or_equalp_ci (LObject *args)
{
if (!lipa_list_length (args, 2))
{
fputs ("string-ci>=? wants 2 arguments\n", stderr);
return NULL;
}
if (!STRINGP (lipa_car (args)) || !STRINGP (lipa_car (lipa_cdr (args))))
{
fputs ("string-ci>=? wants string arguments\n", stderr);
return NULL;
}
return ((strcasecmp (L_STRING (lipa_car (args))->str,
L_STRING (lipa_car (lipa_cdr (args)))->str) >= 0) ?
lisp_true : lisp_false);
}
LObject *
lipa_new_symbolname ()
{
LObject *obj = g_new0 (LObject, 1);
obj->type = L_OBJ_SYMBOLNAME;
L_STRING(obj) = g_string_new ("");
return obj;
}
LObject *
lipa_new_string ()
{
LObject *obj = g_new0 (LObject, 1);
obj->type = L_OBJ_STRING;
L_STRING (obj) = g_string_new ("");
return obj;
}
/* _from_state:
*/
static LObject *_from_state ( LObjectClass *cls,
LObject *state )
{
LObject *nspec;
ASSERT(L_IS_TUPLE(state));
ASSERT(L_TUPLE_SIZE(state) == 1);
nspec = l_object_new(cls, NULL);
LPT_NSPEC(nspec)->name = g_strdup(L_STRING(L_TUPLE_ITEM(state, 0))->str);
return nspec;
}
static LObject *
lisp_display (LObject *args)
{
while (!lipa_null(args))
{
fputs (L_STRING(lipa_car (args))->str, stdout);
args = lipa_cdr (args);
}
return NULL;
}
LObject *
lisp_substring (LObject *args)
{
char *str;
LObject *obj = lipa_new_string ("");
gint x, y, i;
if (!lipa_list_length (args, 3))
{
fputs ("substring wants 3 arguments\n", stderr);
return NULL;
}
if (!STRINGP (lipa_car (args)) || !INTP (lipa_car (lipa_cdr (args))) ||
!INTP (lipa_car (lipa_cdr (lipa_cdr (args)))))
{
fputs ("substring wants 1 string and 2 ints as arguments\n", stderr);
return NULL;
}
x = L_INT (lipa_car (lipa_cdr (args)));
y = L_INT (lipa_car (lipa_cdr (lipa_cdr (args))));
if ((x < 0) || (y > strlen (L_STRING (lipa_car (args))->str)) || (x >= y))
{
fputs ("substring: int arguments out of range\n", stderr);
return NULL;
}
str = strdup (L_STRING (lipa_car (args))->str);
for (i = x; i < y; i++)
{
g_string_append_c (L_STRING (obj), str[i]);
}
return obj;
}
/* _set_property:
*/
static void _set_property ( LObject *object,
LParamSpec *pspec,
LObject *value )
{
switch (pspec->param_id)
{
case PROP_NAME:
ASSERT(L_IS_STRING(value)); /* [removeme] */
altk_widget_set_name(ALTK_WIDGET(object),
L_STRING(value)->str);
break;
default:
ASSERT(0);
}
}
static LObject *
special_form_define (LObject *args)
{
if (!lipa_list_length (args, 2))
{
fputs ("error!! wrong number of arguments to define. ", stderr);
return NULL;
}
else
{
LObject *todefine = lipa_car (args);
LObject *defineto = lipa_car (lipa_cdr (args));
if (todefine->type == L_OBJ_SYMBOLNAME)
{
return lipa_define (L_STRING (todefine)->str,
lipa_eval (defineto));
}
else if (todefine->type == L_OBJ_LIST)
{
LObject *symname = lipa_car (todefine);
LObject *args = lipa_cdr (todefine);
LObject *fun = lipa_new_function_lambda (args, defineto);
return lipa_define (L_STRING (symname)->str,
fun);
}
else
{
fputs ("first argument to define should be a symbolname\n",
stderr);
return NULL;
}
}
}
static LObject *
lisp_string_length (LObject *args)
{
LObject *obj = lipa_new_int (0);
if (!lipa_list_length (args, 1))
{
fputs ("string-length wants 1 argument\n", stderr);
return NULL;
}
if (!STRINGP (lipa_car (args)))
{
fputs ("string-length wants a string argument\n", stderr);
return NULL;
}
L_INT (obj) = strlen (L_STRING (lipa_car (args))->str);
return obj;
}
static GString *
_append (LObject *args, GString *str)
{
if (!lipa_null (args))
{
LObject *obj = lipa_car (args);
if (obj->type == L_OBJ_STRING)
{
return g_string_prepend (_append (lipa_cdr (args), str),
L_STRING(obj)->str);
}
else
{
fprintf (stderr, "append can only take string arguments");
}
}
else
return str;
return NULL;
}
static LObject *
eval_special_form (LObject *obj, LObject *args, gboolean *found)
{
*found = TRUE;
if (obj->type == L_OBJ_SYMBOLNAME)
{
gchar *name = L_STRING(obj)->str;
if (!strcmp (name, "define"))
{
return special_form_define (args);
}
else if (!strcmp (name, "if"))
{
return special_form_if (args);
}
else if (!strcmp (name, "lambda"))
{
return special_form_lambda (args);
}
else if (!strcmp (name, "quote"))
{
return special_form_quote (args);
}
else if (!strcmp (name, "and"))
{
return special_form_and (args);
}
else if (!strcmp (name, "or"))
{
return special_form_or (args);
}
else if (!strcmp (name, "begin"))
{
return special_form_begin (args);
}
}
*found = FALSE;
return NULL;
}
LObject *
lipa_apply_func (LObject *function, LObject *args)
{
#if 0
LObject *args2 = args;
#endif
/* this is no good - you gotta be able to do (null? '())... but
* there sure are problems with the nil handling. currently, nil
* and void are the same thing, NULL... which is bad. maybe nil
* should be a special type just like L_TRUE and L_FALSE... I
* dunno.. - Simon */
#if 0
while (args2)
{
if (!(lipa_car (args2)))
{
fprintf (stderr, "Nailed your ass!!! No coredump here.\n");
return NULL;
}
else if (!lipa_cdr (args2))
break;
else
args2 = lipa_cdr (args2);
}
#endif
if (L_FUNCTION (function).functype == L_FUNC_SUBR &&
L_FUNCTION (function).subr)
return ((L_FUNCTION (function).subr) (args));
else if (L_FUNCTION (function).functype == L_FUNC_LAMBDA)
{
LObject *fargs = L_FUNCTION (function).arguments;
LObject *pushed_symbols = NULL;
LObject *body_ret = NULL;
/* push arguments on symbols list */
while (!lipa_null (fargs))
{
gchar *name;
LObject *sym;
if (lipa_null (args))
{
fputs ("too few arguments! lamer!\n", stderr);
return NULL;
}
name = L_STRING (lipa_car (fargs))->str;
sym = lipa_new_symbol (name, lipa_car (args));
pushed_symbols = lipa_cons (sym, pushed_symbols);
lipa_register_symbol (sym);
args = lipa_cdr (args);
fargs = lipa_cdr (fargs);
}
/* evaluate body */
body_ret = lipa_eval (L_FUNCTION (function).body);
/* remove arguments from symbols list */
while (!lipa_null (pushed_symbols))
{
lipa_unregister_symbol (lipa_car (pushed_symbols));
pushed_symbols = lipa_cdr (pushed_symbols);
}
return body_ret;
}
else
{
fputs ("This is a function from outer space.\n", stderr);
return NULL;
}
return NULL;
}
