自学教程：C++ Cdr函数代码示例

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

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

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