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