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;
}

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;
}

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);
      }
   }
}