void Action_Hook (Widget w, XtPointer client_data, char *name, XEvent *ep,
char **argv, int *argc) {
ACTION *ap;
Object args, params, tail;
register int i;
GC_Node3;
for (ap = actions; ap; ap = ap->next) {
if (strcmp (ap->name, name))
continue;
args = params = tail = Null;
GC_Link3 (args, params, tail);
params = P_Make_List (Make_Integer (*argc), Null);
for (i = 0, tail = params; i < *argc; tail = Cdr (tail), i++) {
Object tmp;
tmp = Make_String (argv[i], strlen (argv[i]));
Car (tail) = tmp;
}
args = Cons (params, Null);
params = Get_Event_Args (ep);
args = Cons (Copy_List (params), args);
Destroy_Event_Args (params);
args = Cons (Make_Widget_Foreign (w), args);
(void)Funcall (Get_Function (ap->num), args, 0);
GC_Unlink;
}
}
sexp lisp_incf_expander(sexp sym_sexp,env *cur_env){
/* (incf <var>) ->
`(setq ,var (++ ,var))
(setq . (var . ((++ . (var . nil)) . nil)))
*/
symref inc_symbol=xmalloc(sizeof(symbol));
inc_symbol->name="++";
inc_symbol->val=UNBOUND;
sexp body=Cons(symref_sexp(inc_symbol),
Cons(eval_sub(sym_sexp,cur_env),NIL));
sexp code=Cons(spec_sexp(_setq),Cons(sym_sexp,Cons(body,NIL)));
/* cons *code=xmalloc(5*sizeof(cons));
cons *code_ptr=code;
code_ptr->car=spec_sexp(_setq);// (setq .
code_ptr->cdr=cons_sexp(code+1);// (setq . (
code_ptr=code_ptr->cdr.val.cons;
code_ptr->car=sym_sexp;//(setq . (var
code_ptr->car.has_comma=1;//(setq . (,var
code_ptr->cdr=cons_sexp(code+2);
code_ptr=code_ptr->cdr.val.cons;
code_ptr->cdr=NIL;//(setq . (,var . (_ . nil)))
code_ptr->car=cons_sexp(code+3);
code_ptr=code_ptr->car.val.cons;
code_ptr->car=symref_sexp(inc_symbol);
code_ptr->cdr=cons_sexp(code+4);
code_ptr->car=sym_sexp;
code_ptr->cdr=NIL;
sexp retval=cons_sexp(code);
retval.quoted=1;
retval.has_comma=1;
return retval;*/
}
static Object P_Query_Tree (Object w) {
Window root, parent, *children;
Display *dpy;
unsigned int i, n;
Object v, ret;
GC_Node2;
Check_Type (w, T_Window);
dpy = WINDOW(w)->dpy;
Disable_Interrupts;
XQueryTree (dpy, WINDOW(w)->win, &root, &parent, &children, &n);
Enable_Interrupts;
v = ret = Null;
GC_Link2 (v, ret);
v = Make_Window (0, dpy, root);
ret = Cons (v, Null);
v = Make_Window (0, dpy, parent);
ret = Cons (v, ret);
v = Make_Vector (n, Null);
for (i = 0; i < n; i++) {
Object x;
x = Make_Window (0, dpy, children[i]);
VECTOR(v)->data[i] = x;
}
ret = Cons (v, ret);
GC_Unlink;
return ret;
}
static thing_th *rejigger_with_left_as_cons(thing_th *left,
thing_th *right,
thing_th *bacro) {
thing_th *arg1=Cons(Car(left), Cdr(left));
set_car(left, Atom(sym(bacro)));
set_cdr(left, Cons(arg1, Cons(right, NULL)));
return left;
}
static thing_th *rejigger_with_left_as_atom(thing_th *left,
thing_th *right,
thing_th *bacro) {
thing_th *bcall=Cons(Atom(sym(bacro)),
Cons(Car(left),
Cons(right, NULL)));
set_car(left, bcall);
return left;
}
static thing_th *unknown_symbol_handling(const char *label,
thing_th *handlingInstructions) {
if(streq(sym(handlingInstructions), UNKNOWN_ERR))
return Err(Cons(String("Unknown symbol"),
Cons(Atom(label), NULL)));
if(streq(sym(handlingInstructions), UNKNOWN_LIT))
return Atom(label);
return NULL;
}
static thing_th *open_sub_cons(FILE *src, text_buffer *tb, char opener) {
switch(opener) {
case '{':
return Cons(Atom("grid"), read_expressions(src, tb));
case '[':
return Cons(Atom("list"), read_expressions(src, tb));
default:
return read_expressions(src, tb);
}
}
static thing_th *grid_vals(grid_th *grid) {
thing_th *keys=grid_keys(grid);
thing_th *values;
if(!keys)
return NULL;
values=Cons(grid_get(grid, sym(Car(keys))), NULL);
keys=Cdr(keys);
while(keys) {
append(values, Cons(grid_get(grid, sym(Car(keys))), NULL));
keys=Cdr(keys);
}
return values;
}
thing_th *accumulate(thing_th *thing) {
thing_th *accum=Cons(thing, NULL);
thing_th *cur=accum;
while(cur) {
thing_th *item=Car(cur);
if(th_kind(item)==grid_k)
insert(cur, Vals(item));
if(Cdr(item))
insert(cur, Cons(Cdr(item), NULL));
if(Car(item))
insert(cur, Cons(Car(item), NULL));
cur=Cdr(cur);
}
return accum;
}
static thing_th *expand_bacros_in_this_level(thing_th *bacroSrc,
thing_th *trace,
thing_th *cur,
thing_th *prev) {
thing_th *bacr=NULL;
thing_th *subs=NULL;
while(cur) {
subs=Cdr(cur);
set_car(trace, cur);
if(th_kind(Car(cur))==cons_k)
return Cons(Car(cur), trace);
if((bacr=Get(bacroSrc, sym(Car(cur))))) {
if(!prev) {
fprintf(stderr, "Can't expand bacro onto nothing.\n");
return NULL;
}
rejigger_cells(prev, Car(subs), bacr);
subs=Cdr(subs);
set_cdr(prev, subs);
set_car(trace, subs);
} else {
prev=cur;
}
cur=subs;
}
return Cdr(trace);
}
/* Bind values to variables in the current scope according to the format of the argument list */
void BindArguments(ArgList arguments, VyObj values[], int num_args){
int i;
for(i = 0; i < num_args; i++){
Param cur = arguments.params[i];
/* Normal arguments can just be bound right away */
if(!cur.rest){
VariableBind(cur.name, values[i]);
} else {
VyObj list = Nil();
int j;
for(j = num_args - 1; j >= i; j--)
list = Cons(values[j], list);
VariableBind(cur.name, list);
i = num_args;
}
}
/* Finish filling in arguments that weren't passed */
for(; i < arguments.num_params; i++){
Param cur = arguments.params[i];
if(cur.rest)
VariableBind(cur.name, Nil());
else {
if(IsNone(cur.default_value))
cur.default_value = Nil();
VariableBind(cur.name, cur.default_value);
}
}
}
thing_th *funky_def(thing_th *args) {
switch(th_kind(Car(args))) {
case atom_k:
return env_set(sym(Car(args)),
define_procedure(Cdr(args)));
case cons_k:
return define_procedure(args);
default:
return Err(Cons(Atom(ERRMSG_TYPES),
Cons(Atom(ERRMSG_BADDEF), NULL)));
}
if(th_kind(Car(args))==atom_k)
return env_set(sym(Car(args)),
define_procedure(Cdr(args)));
return define_procedure(args);
}
static Object P_Read_Directory(Object fn) {
DIR *d;
#ifdef HAVE_DIRENT_H
struct dirent *dp;
#else
struct direct *dp;
#endif
Object ret;
GC_Node;
ret = Null;
GC_Link(ret);
Disable_Interrupts;
if ((d = opendir(Get_Strsym(fn))) == NULL) {
Saved_Errno = errno;
Enable_Interrupts;
Raise_System_Error1("~s: cannot open", fn);
}
while ((dp = readdir(d)) != NULL) {
Object x;
x = Make_String(dp->d_name, strlen(dp->d_name));
ret = Cons(x, ret);
}
/* closedir() is void under 4.3BSD, should check result elsewhere.
*/
(void)closedir(d);
Enable_Interrupts;
GC_Unlink;
return ret;
}
static thing_th *dup_cell(thing_th *thing) {
switch(th_kind(thing)) {
case number_k:
return Number(sym(thing));
case string_k:
return String(sym(thing));
case atom_k:
return Atom(sym(thing));
case cons_k:
return Cons(Car(thing), Cdr(thing));
case error_k:
return Err(Cdr(thing));
case procedure_k:
return Proc(Car(thing), Cdr(thing));
case macro_k:
return Mac(Car(thing), Cdr(thing));
case gen_k:
return Gen(Car(thing), Cdr(thing));
case routine_k:
return Routine(call_rt(thing));
case method_k:
return Method(call_rt(thing));
case grid_k:
return duplicate_grid(thing);
case null_k:
return NULL;
}
}
static thing_th *identifyTypes(thing_th *args, thing_th *cur) {
while(args) {
cur=set_cdr(cur, Cons(String(debug_lbl(Car(args))), NULL));
args=Cdr(args);
}
return cur;
}
sexp lisp_dotimes_expander(sexp var,sexp times,sexp body,sexp cur_env_sexp,int expand){
env *cur_env=cur_env_sexp.val.cur_env;
sexp test=Cons(function_sexp(&lisp_numlt_call),Cons(var,Cons(times,NIL)));
sexp do_parameters=
Cons(var,Cons(long_sexp(0),Cons(long_sexp(1),Cons(test,NIL))));
sexp code=Cons(spec_sexp(_do),
Cons(do_parameters,body));
if(expand){
return code;
} else {
return eval(code,cur_env);
}
}
thing_th *funky_type_symbol(thing_th *args) {
thing_th *head=NULL;
if(args) {
head=Cons(String(debug_lbl(Car(args))), NULL);
identifyTypes(Cdr(args), head);
}
return head;
}
static thing_th *grid_keys(grid_th *grid) {
char **keys=grid_keys_list(grid->data);
char **kw=keys;
thing_th *allKeys;
if(!keys)
return NULL;
if(!*keys) {
wipe_keys_list(keys);
return NULL;
}
allKeys=Cons(Atom(*kw++), NULL);
while(kw && *kw) {
append(allKeys, Cons(Atom(*kw), NULL));
kw++;
}
wipe_keys_list(keys);
return allKeys;
}
thing_th *insert(thing_th *left, thing_th *right) {
thing_th *tmp;
if(!left || !is_list(left))
return NULL;
if(!is_list(right))
right=Cons(right, NULL);
tmp=Cdr(left);
set_cdr(left, append(right, tmp));
return right;
}
static thing_th *inner_expand_bacros(thing_th *bacroSrc, thing_th *head) {
thing_th *trace=Cons(head, NULL);
thing_th *prev=NULL;
while(trace) {
trace=expand_bacros_in_this_level(bacroSrc, trace, Car(trace), prev);
prev=Car(trace);
set_car(trace, Cdr(Car(trace)));
}
return head;
}
void sexp_closure_call(ffi_cif *CIF,sexp *RET,void **ARGS,void *USER_DATA){
sexp *retval=(sexp*)RET;
sexp **args=(sexp**)ARGS;
cons *fun_and_env=(cons*)USER_DATA;
sexp lambda_fun=fun_and_env->car;
sexp lambda_env=fun_and_env->cdr;
int numargs=CIF->nargs;
sexp arglist=NIL;
if(numargs){
int i;
for(i=(numargs-1);i>=0;i--){
arglist=Cons((*args[i]),arglist);
}
}
symbol lambda_sym={.val=lambda_fun};
sexp sexp_retval=call_lambda(Cons(symref_sexp(&lambda_sym),arglist),
lambda_env.val.cur_env);
*retval=sexp_retval;
return;
}
Object Read_Sequence (Object port, int vec, int konst, int start_chr) {
Object ret, e, tail, t;
GC_Node3;
ret = tail = Null;
GC_Link3 (ret, tail, port);
while (1) {
e = Read_Special (port, konst);
if (TYPE(e) == T_Special) {
if (CHAR(e) == ')' || CHAR(e) == ']') {
if ((start_chr == '(' && CHAR(e) == ']')
|| (start_chr == '[' && CHAR(e) == ')')) {
char buf[64];
sprintf(buf, "expression starts with '%c' but ends "
"with '%c'", start_chr, CHAR(e));
Reader_Error (port, buf);
}
GC_Unlink;
return ret;
}
if (vec)
Reader_Error (port, "wrong syntax in vector");
if (CHAR(e) == '.') {
if (Nullp (tail)) {
ret = Read_Atom (port, konst);
} else {
e = Read_Atom (port, konst);
/*
* Possibly modifying pure cons. Must be fixed!
*/
Cdr (tail) = e;
}
e = Read_Special (port, konst);
if (TYPE(e) == T_Special && (CHAR(e) == ')' || CHAR(e) == ']')) {
GC_Unlink;
return ret;
}
Reader_Error (port, "dot in wrong context");
}
Reader_Error (port, "syntax error");
}
if (konst) t = Const_Cons (e, Null); else t = Cons (e, Null);
if (!Nullp (tail))
/*
* Possibly modifying pure cons. Must be fixed!
*/
Cdr (tail) = t;
else
ret = t;
tail = t;
}
/*NOTREACHED*/
}
int establish_root_environment(void) {
spawn_env(NULL, Primordial_Grid(GC_SKIPREG));
rootEnvironment=Car(env);
rootBacros=Grid();
unknownSymbolError=Err(Cons(String("Unknown symbol"), NULL));
Set(rootEnvironment, "nil", NULL);
Set(rootEnvironment, "true", Atom("true"));
Set(rootEnvironment, "add", Routine(&dirty_sum));
Set(rootEnvironment, "+", Get(rootEnvironment, "add"));
Set(rootEnvironment, "subtract", Routine(&dirty_sub));
Set(rootEnvironment, "-", Get(rootEnvironment, "subtract"));
Set(rootEnvironment, "if", Method(&funky_if));
Set(rootEnvironment, "&ver", String("Funky Lisp Draft 3"));
Set(rootEnvironment, "set!", Routine(&funky_set));
Set(rootEnvironment, "print_", Routine(&funky_print));
Set(rootEnvironment, "list", Routine(&funky_list));
Set(rootEnvironment, "pair", Routine(&funky_pair));
Set(rootEnvironment, "grid", Routine(&funky_grid));
Set(rootEnvironment, "get", Routine(&funky_grid_get));
Set(rootEnvironment, "quote", Method(&funky_quote));
Set(rootEnvironment, "apply", Routine(&apply));
Set(rootEnvironment, "mac", Method(&funky_macro));
Set(rootEnvironment, "def", Method(&funky_def));
Set(rootEnvironment, "head", Routine(&funky_head));
Set(rootEnvironment, "rest_", Routine(&funky_rest));
Set(rootEnvironment, "last", Routine(&funky_last));
Set(rootEnvironment, "err", Routine(&funky_err));
Set(rootEnvironment, "dump", Routine(&funky_dump));
Set(rootEnvironment, "&bacros", rootBacros);
Set(rootEnvironment, ">", Routine(&funky_greater_than));
Set(rootEnvironment, "<", Routine(&funky_less_than));
Set(rootEnvironment, "=", Routine(&funky_equivalent));
Set(rootEnvironment, "not", Routine(&funky_not_operator));
Set(rootEnvironment, "eval", Method(&funky_evaluator));
Set(rootEnvironment, "true?", Routine(&funky_truthy));
Set(rootEnvironment, "false?", Routine(&funky_nilly));
Set(rootEnvironment, "lambda?", Routine(&funky_callable));
Set(rootEnvironment, "atom?", Routine(&funky_is_atom));
Set(rootEnvironment, "gen?", Routine(&funky_is_gen));
Set(rootEnvironment, "len", Routine(&funky_length));
Set(rootEnvironment, "gen", Routine(&funky_gen));
Set(rootEnvironment, "cons", Routine(&funky_cons));
Set(rootEnvironment, "append", Routine(&funky_append));
Set(rootEnvironment, "error?", Routine(&funky_is_error));
Set(rootEnvironment, "grid?", Routine(&funky_is_grid));
Set(rootEnvironment, "txt-concatenate_", Routine(&funky_make_txt));
Set(rootEnvironment, "type", Routine(&funky_type_symbol));
Set(rootEnvironment, UNKNOWN_HANDLER, Atom(UNKNOWN_LIT));
establish_bacros(rootBacros);
return new_env();
}
void ClientHangupToBlakod(session_node *session)
{
val_type command,parm_list;
parm_node parms[1];
command.v.tag = TAG_INT;
command.v.data = BP_REQ_QUIT;
parm_list.int_val = NIL;
parm_list.v.data = Cons(command,parm_list);
parm_list.v.tag = TAG_LIST;
parms[0].type = CONSTANT;
parms[0].value = parm_list.int_val;
parms[0].name_id = CLIENT_PARM;
SendTopLevelBlakodMessage(session->game->object_id,RECEIVE_CLIENT_MSG,1,parms);
}
sexp lisp_dolist_expander(sexp var,sexp list,sexp body,sexp cur_env_sexp,int expand){
env *cur_env=cur_env_sexp.val.cur_env;
sexp test=Cons(function_sexp(&lisp_consp_call),Cons(list,NIL));
sexp var_step=Cons(spec_sexp(_setq),
Cons(var,Cons(function_sexp(&car_call),Cons(list,NIL))));
sexp list_step=Cons(spec_sexp(_setq),
Cons(list,Cons(function_sexp(&cdr_call),Cons(list,NIL))));
sexp step=Cons(spec_sexp(_progn),Cons(var_step,Cons(list_step,NIL)));
sexp loop=Cons(spec_sexp(_while),Cons(test,Cons(step,Cons(body,NIL))));
if(expand){
return loop;
} else {
return eval(loop,cur_env);
}
}
sexp lisp_defun(sexp var,sexp arglist,sexp body,env *cur_env){
sexp val=Cons(spec_sexp(_lambda),Cons(arglist,body));//(lambda <arglist> <body>...)
addSymFromSexp(var,val,cur_env);
return var;
}
Object Internal_GC_Status (strat, flags) {
return (Cons (Sym_Stop_And_Copy_GC, Null));
}
thing_th *funky_cons(thing_th *args) {
return Cons(Car(args), Car(Cdr(args)));
}
thing_th *funky_gen(thing_th *args) {
if(!Car(args) || !Cdr(args))
return Err(Cons(String("Incomplete Gen construction"), NULL));
return Gen(Car(args), Cdr(args));
}
thing_th *funky_pair(thing_th *args) {
return Cons(Car(args),
Cons(Car(Cdr(args)),
NULL));
}