at *copy_tree(at *p)
{
MM_ENTER;
if (CONSP(p)) {
/* detect circular lists */
at *p0 = p;
bool move_p0 = false;
at *q = NIL;
at **qp = &q;
while (CONSP(p)) {
*qp = new_cons(Car(p), NIL);
qp = &Cdr(*qp);
p = Cdr(p);
if (p == p0)
RAISEF("can't do circular structures", NIL);
move_p0 = !move_p0;
if (move_p0)
p0 = Cdr(p0);
}
*qp = copy_tree(p);
/* descend */
p = q;
while (CONSP(p)) {
AssignCar(p, copy_tree(Car(p)));
p = Cdr(p);
}
MM_RETURN(q);
} else
MM_RETURN(p);
}
static Object P_Read_Bitmap_File (Object d, Object fn) {
Display *dpy;
Drawable dr = Get_Drawable (d, &dpy);
unsigned width, height;
int r, xhot, yhot;
Pixmap bitmap;
Object t, ret, x;
GC_Node2;
Disable_Interrupts;
r = XReadBitmapFile (dpy, dr, Get_Strsym (fn), &width, &height, &bitmap,
&xhot, &yhot);
Enable_Interrupts;
if (r != BitmapSuccess)
return Bits_To_Symbols ((unsigned long)r, 0, Bitmapstatus_Syms);
t = ret = P_Make_List (Make_Integer (5), Null);
GC_Link2 (ret, t);
x = Make_Pixmap (dpy, bitmap);
Car (t) = x;
t = Cdr (t);
Car (t) = Make_Integer (width);
t = Cdr (t);
Car (t) = Make_Integer (height);
t = Cdr (t);
Car (t) = Make_Integer (xhot);
t = Cdr (t);
Car (t) = Make_Integer (yhot);
GC_Unlink;
return ret;
}
void undump(char *s)
{
at *atf = OPEN_READ(s,0);
FILE *f = Gptr(atf);
int magic = readmagic32(f);
int version = read32(f);
if ( magic != DUMPMAGIC )
error(NIL, "incorrect dump file format", NIL);
if ( version > DUMPVERSION )
error(NIL, "dump file format version not supported", NIL);
/* The macro character map */
size_t sr = fread(char_map,1,256,f);
if (sr < 256 || feof(f) || ferror(f))
error(NIL, "corrupted dump file (1)",NIL);
/* The unified list */
at *val, *sym, *p = bread(f, NIL);
while (CONSP(p)) {
if (CONSP(Car(p))) {
sym = Caar(p);
val = Cdar(p);
ifn (SYMBOLP(sym))
error(NIL, "corrupted dump file (4)", NIL);
var_SET(sym, val);
} else if (SYMBOLP(Car(p)))
var_lock(Car(p));
val = p;
p = Cdr(p);
Cdr(val) = NIL;
}
/* define special symbols */
at_NULL = var_get(named("NULL"));
}
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);
}
void putmethod(class_t *cl, at *name, at *value)
{
ifn (SYMBOLP(name))
RAISEF("not a symbol", name);
if (value && !FUNCTIONP(value))
RAISEF("not a function", value);
clear_hashok(cl);
at **last = &(cl->methods);
at *list = *last;
while (CONSP(list)) {
at *q = Car(list);
ifn (CONSP(q))
RAISEF("not a pair", q);
if (Car(q) == name) {
if (value) {
/* replace */
Cdr(q) = value;
return;
} else {
/* remove */
*last = Cdr(list);
Cdr(list) = NIL;
return;
}
}
last = &Cdr(list);
list = *last;
}
/* not an existing method, append */
if (value)
*last = new_cons(new_cons(name, value), NIL);
}
int node_compare(ast_node_t tok1, ast_node_t tok2) {
if(tok1==tok2) {
return 0;
}
if(isNil(tok1)) {
return isNil(tok2)?0:-1;
} else if(isNil(tok2)) {
return 1;
} else if(isAtom(tok1)) {
return isPair(tok2)
? 1
: isAtom(tok2)
? strcmp(node_compare_tag(Value(tok1)), node_compare_tag(Value(tok2)))
: 0;
} else if(isPair(tok1)) {
if(isPair(tok2)) {
int ret = node_compare(Car(tok1), Car(tok2));
return ret?ret:node_compare(Cdr(tok1), Cdr(tok2));
} else {
return 1;
}
}
return tok1>tok2?1:-1;
}
/* event_get --
* Return the next event associated with the specified handler.
* The event is removed from the queue if <remove> is true.
*/
at *event_get(void *handler, bool remove)
{
at *pp = head;
if (CONSP(pp)) {
while (CONSP(Cdr(pp))) {
at *p = Cdr(pp);
void *hndl = ev_hndl(Car(p));
if (hndl == handler) {
at *event = Cdr(Cdar(p));
ev_parsedesc(Car(Cdar(p)));
if (remove)
ev_remove(pp, p);
return event;
}
if (!hndl) {
ev_remove(pp, p);
continue;
}
pp = p;
}
if (Cdr(pp))
Cdr(pp) = NIL;
}
return NIL;
}
thing_th *last_el(thing_th *thing) {
if(!thing || !is_list(thing))
return NULL;
while(thing && is_list(Cdr(thing)))
thing=Cdr(thing);
return thing;
}
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;
}
}
thing_th *funky_append(thing_th *args) {
thing_th *output=duplicate(Car(args));
while(Cdr(args)) {
output=append(output, Car(Cdr(args)));
args=Cdr(args);
}
return output;
}
static void ev_remove(at *pp, at *p)
{
if (Cdr(pp) != p)
error(NIL, "internal error", NIL);
Cdr(pp) = Cdr(p);
Cdr(p) = NIL;
if (tail == p)
tail = pp;
}
int Equal (Object x1, Object x2) {
register int t1, t2;
register unsigned int i;
again:
if (EQ(x1, x2))
return 1;
t1 = TYPE(x1);
t2 = TYPE(x2);
if (Numeric (t1) && Numeric (t2))
return Generic_Equal (x1, x2);
if (t1 != t2)
return 0;
switch (t1) {
case T_Boolean:
case T_Character:
case T_Compound:
case T_Control_Point:
case T_Promise:
case T_Port:
case T_Macro:
return 0;
case T_Primitive:
case T_Environment:
return Eqv (x1, x2);
case T_Symbol: {
struct S_Symbol *p1 = SYMBOL(x1), *p2 = SYMBOL(x2);
return Equal (p1->name, p2->name) && Equal (p1->plist, p2->plist);
}
case T_Pair:
if (!Equal (Car (x1), Car (x2)))
return 0;
x1 = Cdr (x1); x2 = Cdr (x2);
goto again;
case T_String: {
struct S_String *p1 = STRING(x1), *p2 = STRING(x2);
return p1->size == p2->size &&
memcmp (p1->data, p2->data, p1->size) == 0;
}
case T_Vector: {
struct S_Vector *p1 = VECTOR(x1), *p2 = VECTOR(x2);
if (p1->size != p2->size)
return 0;
for (i = 0; i < p1->size; i++)
if (!Equal (p1->data[i], p2->data[i]))
return 0;
return 1;
}
default:
if (t1 < 0 || t1 >= Num_Types)
Panic ("bad type in equal");
if (Types[t1].equal == NOFUNC)
return 0;
return (Types[t1].equal)(x1, x2);
}
/*NOTREACHED*/
}
at *files(const char *s)
{
at *ans = NIL;
at **where = &ans;
#ifdef UNIX
DIR *dirp = opendir(s);
if (dirp) {
struct dirent *d;
while ((d = readdir(dirp))) {
int n = NAMLEN(d);
at *ats = make_string_of_length(n);
char *s = (char *)String(ats);
strncpy(s, d->d_name, n); s[n] = 0;
*where = new_cons(ats,NIL);
where = &Cdr(*where);
}
closedir(dirp);
}
#endif
#ifdef WIN32
struct _finddata_t info;
if ((s[0]=='/' || s[0]=='\\') &&
(s[1]=='/' || s[1]=='\\') && !s[2]) {
long hfind = GetLogicalDrives();
strcpy(info.name,"A:\\");
for (info.name[0]='A'; info.name[0]<='Z'; info.name[0]++)
if (hfind & (1<<(info.name[0]-'A'))) {
*where = new_cons(new_string(info.name),NIL);
where = &Cdr(*where);
}
} else if (dirp(s)) {
*where = new_cons(new_string(".."),NIL);
where = &Cdr(*where);
}
strcpy(string_buffer,s);
char *last = string_buffer + strlen(string_buffer);
if (last>string_buffer && last[-1]!='/' && last[-1]!='\\')
strcpy(last,"\\*.*");
else
strcpy(last,"*.*");
long hfind = _findfirst(string_buffer, &info);
if (hfind != -1) {
do {
if (strcmp(".",info.name) && strcmp("..",info.name)) {
*where = new_cons(new_string(info.name),NIL);
where = &Cdr(*where);
}
} while ( _findnext(hfind, &info) != -1 );
_findclose(hfind);
}
#endif
return ans;
}
thing_th *funky_less_than(thing_th *args) {
thing_th *cur=args;
while(cur && Cdr(cur)) {
if(!lft_greater_than_rit(Car(Cdr(cur)), Car(cur)))
return NULL;
cur=Cdr(cur);
}
return lookup_txt("true");
}
thing_th *funky_equivalent(thing_th *args) {
thing_th *cur=args;
while(cur && Cdr(cur)) {
if(!recursive_lists_are_equivalent(Car(cur), Car(Cdr(cur))))
return NULL;
cur=Cdr(cur);
}
return lookup_txt("true");
}
static thing_th *inner_dup(thing_th *head) {
if(!head)
return NULL;
if(Car(head))
set_car(head, dup_cell(Car(head)));
if(Cdr(head))
set_cdr(head, dup_cell(Cdr(head)));
inner_dup(Car(head));
inner_dup(Cdr(head));
return head;
}
at *displace(at *q, at *p)
{
ifn (CONSP(q))
RAISEF("not a cons", q);
ifn (CONSP(p))
RAISEF("not a cons", p);
AssignCar(q, Car(p));
Cdr(q) = Cdr(p);
return q;
}
static void update_hashtable(class_t *cl)
{
int nclass = 0;
class_t *c = cl;
while (c) {
nclass += length(c->methods);
c = c->super;
}
int size = 16;
while (size < nclass)
size *= 2;
restart:
size *= 2;
/* Make larger hashtable */
size_t s = size * sizeof(struct hashelem);
cl->hashtable = mm_allocv(mt_method_hash, s);
/* Grab the methods */
at **pp, *p;
c = cl;
while (c) {
pp = &c->methods;
while ((p = *pp) && CONSP(p)) {
at *prop = Caar(p);
at *value = Cdar(p);
if (!value || ZOMBIEP(value)) {
*pp = Cdr(p);
Cdr(p) = NIL;
continue;
}
pp = &Cdr(p);
int hx = HASH(prop,size);
at *q = cl->hashtable[hx].symbol;
if (q)
if (q != prop)
if ((q = cl->hashtable[++hx].symbol))
if (q != prop)
if ((q = cl->hashtable[++hx].symbol))
if (q != prop)
goto restart;
if (! q) {
cl->hashtable[hx].symbol = prop;
cl->hashtable[hx].function = value;
cl->hashtable[hx].sofar = c->num_slots;
}
}
c = c->super;
}
cl->hashsize = size;
cl->hashok = 1;
}
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*/
}
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;
}
static thing_th *inner_funky_length(thing_th *args) {
unsigned long len=0;
char *num;
thing_th *outcome;
while(args && (Cdr(args) || Car(args))) {
++len;
args=Cdr(args);
}
asprintf(&num, "%ld", len);
outcome=Number(num);
erase_string(num);
return outcome;
}
int length(at *p)
{
at *q = p;
int i = 0;
while (CONSP(p)) {
i++;
p = Cdr(p);
if (p == q)
return -1;
if (i & 1)
q = Cdr(q);
}
return i;
}
static void ev_notify(at *handler, void *_)
{
at *pp = head;
if (CONSP(pp)) {
at *p = Cdr(pp);
while (CONSP(p)) {
void *hndl = ev_hndl(Car(p));
if (hndl==0 || hndl==(gptr)handler)
ev_remove(pp, p);
else
pp = p;
p = Cdr(pp);
}
}
}
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;
}
/* Parse a parameter. Currently only supports normal ones. */
Param ParseParam(VyObj param, bool opt, bool rest){
VyObj default_val = None();
if(opt){
if(IsType(param, TypeCons)){
VyObj name = ListGet(UNWRAP(param, VyCons), 0);
default_val = ListGet(UNWRAP(param, VyCons), 0);
param = name;
}
}
Param p = {optional: opt,
rest: rest,
default_value: default_val,
name: UNWRAP(param, VySymbol)};
return p;
}
/* Find how many actual parameters there are */
int CountParams(VyObj list){
int count = 0;
while(!IsNil(list)){
if(!ObjEq(Car(list), CreateSymbol("?")) &&
!ObjEq(Car(list), CreateSymbol("..")))
count++;
list = Cdr(list);
}
return count;
}
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;
}
int InspectConsCell(char* str, int len, Object* cell){
char car_buf[512] = {'\0'}, cdr_buf[512] = {'\0'};
Inspect(car_buf, 512, Car(cell));
Inspect(cdr_buf, 512, Cdr(cell));
return snprintf(str, len, "#<cell:%lld, car=%s, cdr=%s>", IdToInt(cell->id), car_buf, cdr_buf);
}
/*-------------------------------------------------------------------------*
* READ_ARG *
* *
*-------------------------------------------------------------------------*/
static WamWord
Read_Arg(WamWord **lst_adr)
{
WamWord word, tag_mask;
WamWord *adr;
WamWord car_word;
DEREF(**lst_adr, word, tag_mask);
if (tag_mask != TAG_LST_MASK)
{
if (tag_mask == TAG_REF_MASK)
Pl_Err_Instantiation();
if (word == NIL_WORD)
Pl_Err_Domain(pl_domain_non_empty_list, word);
Pl_Err_Type(pl_type_list, word);
}
adr = UnTag_LST(word);
car_word = Car(adr);
*lst_adr = &Cdr(adr);
DEREF(car_word, word, tag_mask);
return word;
}
thing_th *funky_dump(thing_th *args) {
while(args) {
debug_list(Car(args));
args=Cdr(args);
}
return args;
}
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);
}
