Return to alloc.c CVS log

Up to [CSRG BSD Unix] / 43BSDTahoe / ucb / lisp / franz

Annotation of 43BSDTahoe/ucb/lisp/franz/alloc.c, revision 1.1

1.1     ! root        1: #ifndef lint
        !             2: static char *rcsid =
        !             3:    "$Header: alloc.c,v 1.13 87/12/11 17:27:45 sklower Exp $";
        !             4: #endif
        !             5: 
        !             6: /*
        !             7:  *     alloc.c                         $Locker:  $
        !             8:  * storage allocator and garbage collector
        !             9:  *
        !            10:  * (c) copyright 1982, Regents of the University of California
        !            11:  */
        !            12:  
        !            13: # include "global.h"
        !            14: # include "structs.h"
        !            15: 
        !            16: #include <sys/types.h>
        !            17: #include <sys/times.h>
        !            18: #ifdef METER
        !            19: #include <sys/vtimes.h>
        !            20: #endif
        !            21:  
        !            22: # define NUMWORDS TTSIZE * 128  /*  max number of words in P0 space  */
        !            23: # define BITQUADS TTSIZE * 2   /*  length of bit map in quad words  */
        !            24: # define BITLONGS TTSIZE * 4   /*  length of bit map in long words  */
        !            25: 
        !            26: # ifdef vax
        !            27: # define ftstbit       asm("   ashl    $-2,r11,r3");\
        !            28:                        asm("   bbcs    r3,_bitmapi,1f");\
        !            29:                        asm("   ret"); \
        !            30:                        asm("1:");
        !            31: 
        !            32: /* setbit is a fast way of setting a bit, it is like ftstbit except it
        !            33:  * always continues on to the next instruction
        !            34:  */
        !            35: # define setbit                asm("   ashl    $-2,r11,r0"); \
        !            36:                        asm("   bbcs    r0,_bitmapi,$0");
        !            37: # endif
        !            38: 
        !            39: # if m_68k
        !            40: # define ftstbit       {if(Itstbt()) return;}
        !            41: # define setbit                Itstbt()
        !            42: # endif
        !            43: 
        !            44: # ifdef tahoe
        !            45: # define ftstbit       if( readbit(p) ) return; oksetbit;
        !            46: # define setbit                {bitmapi[(int)p>>7] |= bitmsk[((int)p >> 2)&31];}
        !            47: # define readbit(p)    ((int)bitmapi[r=(int)p>>7] & (s=bitmsk[((int)p>>2)&31]))
        !            48: # define oksetbit      {bitmapi[r] |= s;}
        !            49: # endif
        !            50: 
        !            51: /*     Unused bit macros
        !            52: # define lookbit(p)    (bbitmap[(int)p>>5] & bitmsk[((int)p>>2) & 7])
        !            53: # define readchk(p)    ((int)bitfre[(int)p>>5] & bitmsk[((int)p>>2)&7])
        !            54: # define setchk(p)     {bitfre[(int)p>>5] |= bitmsk[((int)p >> 2) & 7];}
        !            55: */
        !            56: 
        !            57: # define roundup(x,l)  (((x - 1) | (l - 1)) + 1) 
        !            58: 
        !            59: # define MARKVAL(v)    if(((int)v) >= (int)beginsweep) markdp(v);
        !            60: # define ATOLX(p)      ((((int)p)-OFFSET)>>7)
        !            61: 
        !            62: /* the Vax hardware only allows 2^16-1 bytes to be accessed with one
        !            63:  * movc5 instruction.  We use the movc5 instruction to clear the 
        !            64:  * bitmaps.
        !            65:  */
        !            66: # define MAXCLEAR ((1<<16)-1)
        !            67: 
        !            68: /* METER denotes something added to help meter storage allocation. */
        !            69: 
        !            70: extern int *beginsweep;                        /* first sweepable data         */
        !            71: extern char purepage[];
        !            72: extern int fakettsize;
        !            73: extern int gcstrings;
        !            74: int debugin  = FALSE;                  /* temp debug flag */
        !            75: 
        !            76: extern lispval datalim;                        /*  end of data space */
        !            77: int bitmapi[BITLONGS];                 /*  the bit map--one bit per long  */
        !            78: double zeroq;                          /*  a quad word of zeros  */
        !            79: char *bbitmap = (char *) bitmapi;      /*  byte version of bit map array */
        !            80: double  *qbitmap = (double *) bitmapi; /*  integer version of bit map array */
        !            81: #ifdef METER
        !            82: extern int gcstat;
        !            83: extern struct vtimes
        !            84:        premark,presweep,alldone;       /* actually struct tbuffer's */
        !            85: 
        !            86: extern int mrkdpcnt;
        !            87: extern int conssame, consdiff,consnil; /* count of cells whose cdr point
        !            88:                                         * to the same page and different
        !            89:                                         * pages respectively
        !            90:                                         */
        !            91: #endif
        !            92: int bitmsk[32]={1,2,4,8,16,32,64,128,  /*  used by bit-marking macros  */
        !            93:                0x100, 0x200, 0x400, 0x800, 
        !            94:                0x1000, 0x2000, 0x4000, 0x8000, 
        !            95:                0x10000, 0x20000, 0x40000, 0x80000, 
        !            96:                0x100000, 0x200000, 0x400000, 0x800000, 
        !            97:                0x1000000, 0x2000000, 0x4000000, 0x8000000, 
        !            98:                0x10000000, 0x20000000, 0x40000000, 0x80000000}; 
        !            99: extern int  *bind_lists;               /*  lisp data for compiled code */
        !           100: 
        !           101: char *xsbrk();
        !           102: char *gethspace();
        !           103: 
        !           104: 
        !           105: extern struct types atom_str, strng_str, int_str, dtpr_str, doub_str,
        !           106:        array_str, sdot_str, val_str, funct_str, hunk_str[], vect_str,
        !           107:        vecti_str, other_str;
        !           108: 
        !           109: extern struct str_x str_current[];
        !           110: 
        !           111: lispval hunk_items[7], hunk_pages[7], hunk_name[7];
        !           112: 
        !           113: extern int initflag; /* starts off TRUE: initially gc not allowed */
        !           114: 
        !           115: 
        !           116: /* this is a table of pointers to all struct types objects
        !           117:  * the index is the type number.
        !           118:  */
        !           119: static struct types *spaces[NUMSPACES] = 
        !           120:        {&strng_str, &atom_str, &int_str,
        !           121:         &dtpr_str, &doub_str, &funct_str, 
        !           122:         (struct types *) 0,  /* port objects not allocated in this way  */
        !           123:         &array_str,
        !           124:         &other_str,  /* other objects not allocated in this way  */
        !           125:         &sdot_str,&val_str, 
        !           126:         &hunk_str[0], &hunk_str[1], &hunk_str[2],
        !           127:         &hunk_str[3], &hunk_str[4], &hunk_str[5],
        !           128:         &hunk_str[6],
        !           129:         &vect_str, &vecti_str};
        !           130: 
        !           131: 
        !           132: /* this is a table of pointers to collectable struct types objects
        !           133:  * the index is the type number.
        !           134:  */
        !           135: struct types *gcableptr[] = {
        !           136: #ifndef GCSTRINGS
        !           137:      (struct types *) 0,  /* strings not collectable */
        !           138: #else
        !           139:      &strng_str,
        !           140: #endif
        !           141:      &atom_str,
        !           142:      &int_str, &dtpr_str, &doub_str,
        !           143:      (struct types *) 0,  /* binary objects not collectable */
        !           144:      (struct types *) 0,  /* port objects not collectable */
        !           145:      &array_str,
        !           146:      (struct types *) 0,  /* gap in the type number sequence */
        !           147:      &sdot_str,&val_str, 
        !           148:      &hunk_str[0], &hunk_str[1], &hunk_str[2],
        !           149:      &hunk_str[3], &hunk_str[4], &hunk_str[5],
        !           150:      &hunk_str[6],
        !           151:      &vect_str, &vecti_str};
        !           152: 
        !           153: 
        !           154: /*
        !           155:  *   get_more_space(type_struct,purep) 
        !           156:  *                                                                     
        !           157:  *  Allocates and structures a new page, returning 0.
        !           158:  *  If no space is available, returns positive number.
        !           159:  *  If purep is TRUE, then pure space is allocated.
        !           160:  */
        !           161: get_more_space(type_struct,purep)                                 
        !           162: struct types *type_struct;
        !           163: {
        !           164:        int cntr;
        !           165:        char *start;
        !           166:        int *loop, *temp;
        !           167:        lispval p;
        !           168:        extern char holend[];
        !           169: 
        !           170:        if( (int) datalim >= TTSIZE*LBPG+OFFSET ) return(2);
        !           171: 
        !           172:        /*
        !           173:         * If the hole is defined, then we allocate binary objects
        !           174:         * and strings in the hole.  However we don't put strings in
        !           175:         * the hole if strings are gc'ed.
        !           176:         */
        !           177: #ifdef HOLE
        !           178:        if(   purep
        !           179: #ifndef GCSTRINGS
        !           180:           || type_struct==&strng_str
        !           181: #endif
        !           182:           || type_struct==&funct_str)
        !           183:                start = gethspace(LBPG,type_struct->type);
        !           184:        else
        !           185: #endif
        !           186:                start = xsbrk(1);               /* get new page */
        !           187: 
        !           188: 
        !           189:        SETTYPE(start, type_struct->type,20);  /*  set type of page  */
        !           190: 
        !           191:        purepage[ATOX(start)] = (char)purep;  /* remember if page was pure*/
        !           192: 
        !           193:        /* bump the page counter for this space if not pure */
        !           194: 
        !           195:        if(!purep) ++((*(type_struct->pages))->i);
        !           196: 
        !           197:        type_struct->space_left = type_struct->space;
        !           198:        temp = loop = (int *) start;
        !           199:        for(cntr=1; cntr < type_struct->space; cntr++)
        !           200:                loop = (int *) (*loop = (int) (loop + type_struct->type_len));
        !           201: 
        !           202:        /* attach new cells to either the pure space free list  or the 
        !           203:         * standard free list
        !           204:         */
        !           205:        if(purep) {
        !           206:            *loop = (int) (type_struct->next_pure_free);
        !           207:            type_struct->next_pure_free = (char *) temp;
        !           208:        }
        !           209:        else  {
        !           210:            *loop = (int) (type_struct->next_free);
        !           211:            type_struct->next_free = (char *) temp;
        !           212:        }
        !           213: 
        !           214:        /*  if type atom, set pnames to CNIL  */
        !           215: 
        !           216:        if( type_struct == &atom_str )
        !           217:                for(cntr=0, p=(lispval) temp; cntr<atom_str.space; ++cntr)
        !           218:                        {
        !           219:                        p->a.pname = (char *) CNIL;
        !           220:                        p = (lispval) ((int *)p + atom_str.type_len);
        !           221:                        }
        !           222:        return(0);  /*  space was available  */
        !           223: }
        !           224: 
        !           225: 
        !           226: /*
        !           227:  * next_one(type_struct) 
        !           228:  *
        !           229:  *  Allocates one new item of each kind of space, except STRNG.        
        !           230:  *  If there is no space, calls gc, the garbage collector.
        !           231:  *  If there is still no space, allocates a new page using
        !           232:  *  get_more_space
        !           233:  */
        !           234: 
        !           235: lispval
        !           236: next_one(type_struct)
        !           237: struct types *type_struct;
        !           238: {
        !           239: 
        !           240:        register char *temp;
        !           241: 
        !           242:        while(type_struct->next_free == (char *) CNIL)
        !           243:                {
        !           244:                int g;
        !           245: 
        !           246:                if(
        !           247:                   (initflag == FALSE) &&       /* dont gc during init */
        !           248: #ifndef GCSTRINGS
        !           249:                   (type_struct->type != STRNG) && /* can't collect strings */
        !           250: #else
        !           251:                   gcstrings &&                 /* user (sstatus gcstrings) */
        !           252: #endif
        !           253:                   (type_struct->type != BCD) &&   /* nor function headers  */
        !           254:                   gcdis->a.clb == nil )                /* gc not disabled */
        !           255:                                        /* not to collect during load */
        !           256: 
        !           257:                        {
        !           258:                        gc(type_struct);  /*  collect  */
        !           259:                        }
        !           260: 
        !           261:                if( type_struct->next_free != (char *) CNIL ) break;
        !           262: 
        !           263:                if(! (g=get_more_space(type_struct,FALSE))) break;
        !           264: 
        !           265:                space_warn(g);
        !           266:                }
        !           267:        temp = type_struct->next_free;
        !           268:        type_struct->next_free = * (char **)(type_struct->next_free);
        !           269:        (*(type_struct->items))->i ++;
        !           270:        return((lispval) temp);
        !           271: }
        !           272: /*
        !           273:  * Warn about exhaustion of space,
        !           274:  * shared with next_pure_free().
        !           275:  */
        !           276: space_warn(g)
        !           277: {
        !           278:        if( g==1 ) {
        !           279:            plimit->i += NUMSPACES; /*  allow a few more pages  */
        !           280:            copval(plima,plimit);       /*  restore to reserved reg  */
        !           281: 
        !           282:            error("PAGE LIMIT EXCEEDED--EMERGENCY PAGES ALLOCATED", TRUE);
        !           283:        } else error("SORRY, ABSOLUTE PAGE LIMIT HAS BEEN REACHED", TRUE);
        !           284: }
        !           285: 
        !           286: 
        !           287: /* allocate an element of a pure structure.  Pure structures will
        !           288:  * be ignored by the garbage collector.
        !           289:  */
        !           290: lispval
        !           291: next_pure_one(type_struct)
        !           292: struct types *type_struct;
        !           293: {
        !           294: 
        !           295:        register char *temp;
        !           296: 
        !           297:        while(type_struct->next_pure_free == (char *) CNIL)
        !           298:                {
        !           299:                int g;
        !           300:                if(! (g=get_more_space(type_struct,TRUE))) break;
        !           301:                space_warn(g);
        !           302:                }
        !           303: 
        !           304:        temp = type_struct->next_pure_free;
        !           305:        type_struct->next_pure_free = * (char **)(type_struct->next_pure_free);
        !           306:        return((lispval) temp);
        !           307: }
        !           308: 
        !           309: lispval
        !           310: newint()
        !           311: {
        !           312:        return(next_one(&int_str));
        !           313: }
        !           314: 
        !           315: lispval
        !           316: pnewint()
        !           317: {
        !           318:        return(next_pure_one(&int_str));
        !           319: }
        !           320: 
        !           321: lispval
        !           322: newdot()
        !           323: {
        !           324:        lispval temp;
        !           325: 
        !           326:        temp = next_one(&dtpr_str);
        !           327:        temp->d.car = temp->d.cdr = nil;
        !           328:        return(temp);
        !           329: }
        !           330: 
        !           331: lispval
        !           332: pnewdot()
        !           333: {
        !           334:        lispval temp;
        !           335: 
        !           336:        temp = next_pure_one(&dtpr_str);
        !           337:        temp->d.car = temp->d.cdr = nil;
        !           338:        return(temp);
        !           339: }
        !           340: 
        !           341: lispval
        !           342: newdoub()
        !           343: {
        !           344:        return(next_one(&doub_str));
        !           345: }
        !           346: 
        !           347: lispval
        !           348: pnewdb()
        !           349: {
        !           350:        return(next_pure_one(&doub_str));
        !           351: }
        !           352: 
        !           353: lispval
        !           354: newsdot()
        !           355: {
        !           356:        register lispval temp;
        !           357:        temp = next_one(&sdot_str);
        !           358:        temp->d.car = temp->d.cdr = 0;
        !           359:        return(temp);
        !           360: }
        !           361: 
        !           362: lispval
        !           363: pnewsdot()
        !           364: {
        !           365:        register lispval temp;
        !           366:        temp = next_pure_one(&sdot_str);
        !           367:        temp->d.car = temp->d.cdr = 0;
        !           368:        return(temp);
        !           369: }
        !           370: 
        !           371: struct atom *
        !           372: newatom(pure) {
        !           373:        struct atom *save; char *mypname;
        !           374: 
        !           375:        mypname = newstr(pure);
        !           376:        pnameprot = ((lispval) mypname);
        !           377:        save = (struct atom *) next_one(&atom_str) ;    
        !           378:        save->plist = save->fnbnd = nil;
        !           379:        save->hshlnk = (struct atom *)CNIL;
        !           380:        save->clb = CNIL;
        !           381:        save->pname = mypname;
        !           382:        return (save);
        !           383: }
        !           384: 
        !           385: char *
        !           386: newstr(purep) {
        !           387:        char *save, *strcpy();
        !           388:        int atmlen;
        !           389:        register struct str_x *p = str_current + purep;
        !           390: 
        !           391:        atmlen = strlen(strbuf)+1;
        !           392:        if(atmlen > p->space_left) {
        !           393:                if(atmlen >= STRBLEN) {
        !           394:                        save = (char *)csegment(OTHER, atmlen, purep);
        !           395:                        SETTYPE(save,STRNG,40);
        !           396:                        purepage[ATOX(save)] = (char)purep;
        !           397:                        strcpy(save,strbuf);
        !           398:                        return(save);
        !           399:                }
        !           400:                p->next_free =  (char *) (purep ?
        !           401:                        next_pure_one(&strng_str) : next_one(&strng_str)) ;
        !           402:                p->space_left = LBPG;
        !           403:        }
        !           404:        strcpy((save = p->next_free), strbuf);
        !           405:        /*while(atmlen & 3) ++atmlen;   /*  even up length of string  */
        !           406:        p->next_free += atmlen;
        !           407:        p->space_left -= atmlen;
        !           408:        return(save);
        !           409: }
        !           410: 
        !           411: static char * Iinewstr(s,purep) char *s;
        !           412: {
        !           413:        int len = strlen(s);
        !           414:        while(len > (endstrb - strbuf - 1)) atomtoolong(strbuf);
        !           415:        strcpy(strbuf,s);
        !           416:        return(newstr(purep));
        !           417: }
        !           418: 
        !           419: 
        !           420: char *inewstr(s) char *s;
        !           421: {
        !           422:        Iinewstr(s,0);
        !           423: }
        !           424: 
        !           425: char *pinewstr(s) char *s;
        !           426: {
        !           427:        Iinewstr(s,1);
        !           428: }
        !           429: 
        !           430: lispval
        !           431: newarray()
        !           432:        {
        !           433:        register lispval temp;
        !           434: 
        !           435:        temp = next_one(&array_str);
        !           436:        temp->ar.data = (char *)nil;
        !           437:        temp->ar.accfun = nil;
        !           438:        temp->ar.aux = nil;
        !           439:        temp->ar.length = SMALL(0);
        !           440:        temp->ar.delta = SMALL(0);
        !           441:        return(temp);
        !           442:        }
        !           443: 
        !           444: lispval
        !           445: newfunct()
        !           446:        {
        !           447:        register lispval temp;
        !           448:        lispval Badcall();
        !           449:        temp = next_one(&funct_str);
        !           450:        temp->bcd.start = Badcall;
        !           451:        temp->bcd.discipline = nil;
        !           452:        return(temp);
        !           453:        }
        !           454: 
        !           455: lispval
        !           456: newval()
        !           457:        {
        !           458:        register lispval temp;
        !           459:        temp = next_one(&val_str);
        !           460:        temp->l = nil;
        !           461:        return(temp);
        !           462:        }
        !           463: 
        !           464: lispval
        !           465: pnewval()
        !           466:        {
        !           467:        register lispval temp;
        !           468:        temp = next_pure_one(&val_str);
        !           469:        temp->l = nil;
        !           470:        return(temp);
        !           471:        }
        !           472: 
        !           473: lispval
        !           474: newhunk(hunknum)
        !           475: int hunknum;
        !           476:        {
        !           477:        register lispval temp;
        !           478: 
        !           479:        temp = next_one(&hunk_str[hunknum]);    /* Get a hunk */
        !           480:        return(temp);
        !           481:        }
        !           482: 
        !           483: lispval
        !           484: pnewhunk(hunknum)
        !           485: int hunknum;
        !           486:        {
        !           487:        register lispval temp;
        !           488: 
        !           489:        temp = next_pure_one(&hunk_str[hunknum]);       /* Get a hunk */
        !           490:        return(temp);
        !           491:        }
        !           492: 
        !           493: lispval
        !           494: inewval(arg) lispval arg;
        !           495:        {
        !           496:        lispval temp;
        !           497:        temp = next_one(&val_str);
        !           498:        temp->l = arg;
        !           499:        return(temp);
        !           500:        }
        !           501: 
        !           502: /*
        !           503:  * Vector allocators.
        !           504:  * a vector looks like:
        !           505:  *  longword: N = size in bytes
        !           506:  *  longword: pointer to lisp object, this is the vector property field
        !           507:  *  N consecutive bytes
        !           508:  *
        !           509:  */
        !           510: lispval getvec();
        !           511: 
        !           512: lispval
        !           513: newvec(size)
        !           514: {
        !           515:     return(getvec(size,&vect_str,FALSE));
        !           516: }
        !           517: 
        !           518: lispval
        !           519: pnewvec(size)
        !           520: {
        !           521:     return(getvec(size,&vect_str,TRUE));
        !           522: }
        !           523: 
        !           524: lispval
        !           525: nveci(size)
        !           526: {
        !           527:     return(getvec(size,&vecti_str,FALSE));
        !           528: }
        !           529: 
        !           530: lispval
        !           531: pnveci(size)
        !           532: {
        !           533:     return(getvec(size,&vecti_str,TRUE));
        !           534: }
        !           535: 
        !           536: /*
        !           537:  * getvec
        !           538:  *  get a vector of size byte, from type structure typestr and
        !           539:  * get it from pure space if purep is TRUE.
        !           540:  *  vectors are stored linked through their property field.  Thus
        !           541:  * when the code here refers to v.vector[0], it is the prop field
        !           542:  * and vl.vectorl[-1] is the size field.   In other code,
        !           543:  * v.vector[-1] is the prop field, and vl.vectorl[-2] is the size.
        !           544:  */
        !           545: lispval
        !           546: getvec(size,typestr,purep)
        !           547: register struct types *typestr;
        !           548: {
        !           549:     register lispval back, current;
        !           550:     int sizewant, bytes, thissize, pages, pindex, triedgc = FALSE;
        !           551: 
        !           552:     /* we have to round up to a multiple of 4 bytes to determine the
        !           553:      * size of vector we want.  The rounding up assures that the
        !           554:      * property pointers are longword aligned
        !           555:      */
        !           556:     sizewant = VecTotSize(size);
        !           557:     if(debugin) fprintf(stderr,"want vect %db\n",size);    
        !           558:  again:
        !           559:     if(purep)
        !           560:         back = (lispval) &(typestr->next_pure_free);
        !           561:     else
        !           562:         back = (lispval) &(typestr->next_free);
        !           563:     current = back->v.vector[0];
        !           564:     while(current !=  CNIL)
        !           565:     {
        !           566:        if(debugin)
        !           567:             fprintf(stderr,"next free size %db; ", current->vl.vectorl[-1]);
        !           568:        if ((thissize = VecTotSize(current->vl.vectorl[-1])) == sizewant)
        !           569:        {
        !           570:            if(debugin) fprintf(stderr,"exact match of size %d at 0x%x\n",
        !           571:                                4*thissize, &current->v.vector[1]);
        !           572:            back->v.vector[0]
        !           573:                = current->v.vector[0];/* change free pointer*/
        !           574:            current->v.vector[0] = nil; /* put nil in property */
        !           575:            /* to the user, vector begins one after property*/
        !           576:            return((lispval)&current->v.vector[1]);
        !           577:        }
        !           578:        else if (thissize >= sizewant + 3)
        !           579:        {
        !           580:            /* the reason that there is a `+ 3' instead of `+ 2'
        !           581:             * is that we don't want to leave a zero sized vector which
        !           582:             * isn't guaranteed to be followed by another vector
        !           583:             */
        !           584:            if(debugin)
        !           585:             fprintf(stderr,"breaking a %d vector into a ",
        !           586:                                        current->vl.vectorl[-1]);
        !           587: 
        !           588:            current->v.vector[1+sizewant+1]
        !           589:                        = current->v.vector[0];  /* free list pointer */
        !           590:            current->vl.vectorl[1+sizewant]
        !           591:                        = VecTotToByte(thissize - sizewant - 2);/*size info */
        !           592:            back->v.vector[0] = (lispval) &(current->v.vector[1+sizewant+1]);
        !           593:            current->vl.vectorl[-1] = size;
        !           594: 
        !           595:            if(debugin)fprintf(stderr," %d one and a %d one\n",
        !           596:                current->vl.vectorl[-1],current->vl.vectorl[1+sizewant]);
        !           597:            current->v.vector[0] = nil; /* put nil in property */
        !           598:            /* vector begins one after the property */
        !           599:            if(debugin) fprintf(stderr," and returning vector at 0x%x\n",
        !           600:                                &current->v.vector[1]);
        !           601:            return((lispval)(&current->v.vector[1]));
        !           602:        }
        !           603:        back =  current;
        !           604:        current =  current->v.vector[0];
        !           605:     }
        !           606:     if(!triedgc
        !           607:         && !purep
        !           608:        && (gcdis->a.clb == nil)
        !           609:        && (initflag == FALSE))
        !           610:     {
        !           611:        gc(typestr);
        !           612:        triedgc = TRUE;
        !           613:        goto again;
        !           614:     }
        !           615:     
        !           616:     /* set bytes to size needed for this vector */
        !           617:     bytes = size + 2*sizeof(long);
        !           618:     
        !           619:     /* must make sure that if the vector we are allocating doesnt
        !           620:        completely fill a page, there is room for another vector to record
        !           621:        the size left over */
        !           622:     if((bytes & (LBPG - 1)) > (LBPG - 2*sizeof(long))) bytes += LBPG;
        !           623:     bytes = roundup(bytes,LBPG);
        !           624: 
        !           625:     current = csegment(typestr->type,bytes/sizeof(long),purep);
        !           626:     current->vl.vectorl[0] = bytes - 2*sizeof(long);
        !           627:     
        !           628:     if(purep) {
        !           629:         current->v.vector[1] = (lispval)(typestr->next_pure_free);
        !           630:         typestr->next_pure_free = (char *) &(current->v.vector[1]);
        !           631:        /* make them pure */
        !           632:        pages = bytes/LBPG;
        !           633:        for(pindex = ATOX(current); pages ; pages--)
        !           634:        {
        !           635:            purepage[pindex++] = TRUE;
        !           636:        }
        !           637:     } else {
        !           638:         current->v.vector[1] = (lispval)(typestr->next_free);
        !           639:         typestr->next_free = (char *) &(current->v.vector[1]);
        !           640:        if(debugin) fprintf(stderr,"grabbed %d vec pages\n",bytes/LBPG);
        !           641:     }
        !           642:     if(debugin)
        !           643:       fprintf(stderr,"creating a new vec, size %d\n",current->v.vector[0]);
        !           644:     goto again;
        !           645: }
        !           646: 
        !           647: /*
        !           648:  * Ipurep :: routine to check for pureness of a data item
        !           649:  *
        !           650:  */
        !           651: lispval 
        !           652: Ipurep(element)
        !           653: lispval element;
        !           654: {
        !           655:     if(purepage[ATOX(element)]) return(tatom) ; else return(nil);
        !           656: }
        !           657: 
        !           658: /* routines to return space to the free list.  These are used by the
        !           659:  * arithmetic routines which tend to create large intermediate results
        !           660:  * which are know to be garbage after the calculation is over.
        !           661:  *
        !           662:  * There are jsb callable versions of these routines in qfuncl.s
        !           663:  */
        !           664: 
        !           665: /* pruneb   - prune bignum. A bignum is an sdot followed by a list of
        !           666:  *  dtprs.    The dtpr list is linked by car instead of cdr so when we
        !           667:  *  put it in the free list, we have to change the links.
        !           668:  */
        !           669: pruneb(bignum)
        !           670: lispval bignum;
        !           671: {
        !           672:        register lispval temp = bignum;
        !           673: 
        !           674:        if(TYPE(temp) != SDOT) 
        !           675:            errorh(Vermisc,"value to pruneb not a sdot",nil,FALSE,0);
        !           676: 
        !           677:        --(sdot_items->i);
        !           678:        temp->s.I = (int) sdot_str.next_free;
        !           679:        sdot_str.next_free = (char *) temp;
        !           680: 
        !           681:        /* bignums are not terminated by nil on the dual,
        !           682:           they are terminated by (lispval) 0 */
        !           683: 
        !           684:        while(temp = temp->s.CDR)
        !           685:        {
        !           686:            if(TYPE(temp) != DTPR) 
        !           687:              errorh(Vermisc,"value to pruneb not a list",
        !           688:                      nil,FALSE,0);
        !           689:            --(dtpr_items->i);
        !           690:            temp->s.I = (int) dtpr_str.next_free;
        !           691:            dtpr_str.next_free = (char *) temp;
        !           692:        }
        !           693: }
        !           694: lispval
        !           695: Badcall()
        !           696:        { error("BAD FUNCTION DESCRIPTOR USED IN CALL",FALSE); }
        !           697: 
        !           698: 
        !           699: 
        !           700: /*
        !           701:  * Ngc 
        !           702:  *  this is the lisp function gc
        !           703:  *
        !           704:  */
        !           705: 
        !           706: lispval
        !           707: Ngc()
        !           708: {
        !           709:     return(gc((struct types *)CNIL));
        !           710: }
        !           711: 
        !           712: /*
        !           713:  * gc(type_struct) 
        !           714:  *
        !           715:  *  garbage collector:  Collects garbage by mark and sweep algorithm.
        !           716:  *  After this is done, calls the Nlambda, gcafter.
        !           717:  *  gc may also be called from LISP, as an  nlambda of no arguments.
        !           718:  * type_struct is the type of lisp data that ran out causing this
        !           719:  * garbage collection
        !           720:  */
        !           721: int printall = 0;
        !           722: lispval
        !           723: gc(type_struct)
        !           724:        struct types *type_struct;
        !           725:        {
        !           726:        lispval save;
        !           727:        struct tms begin, finish;
        !           728:        extern int gctime;
        !           729: 
        !           730:        /* if this was called automatically when space ran out
        !           731:         * print out a message
        !           732:         */
        !           733:        if((Vgcprint->a.clb != nil)
        !           734:           && (type_struct != (struct types *) CNIL ))
        !           735:        {
        !           736:            FILE *port = okport(Vpoport->a.clb,poport);
        !           737:            fprintf(port,"gc:");
        !           738:            fflush(port);
        !           739:        }
        !           740:        
        !           741:        if(gctime) times(&begin);
        !           742: 
        !           743:        gc1(); /* mark&sweep */
        !           744: 
        !           745:        /* Now we call gcafter--special c ase if gc called from LISP */
        !           746: 
        !           747:        if( type_struct == (struct types *) CNIL )
        !           748:                gccall1->d.cdr = nil;  /* make the call "(gcafter)" */
        !           749:        else
        !           750:                {
        !           751:                gccall1->d.cdr = gccall2;
        !           752:                gccall2->d.car = *(type_struct->type_name);
        !           753:                }
        !           754:        PUSHDOWN(gcdis,gcdis);  /*  flag to indicate in garbage collector  */
        !           755:        save = eval(gccall1);   /*  call gcafter  */
        !           756:        POP;                    /*  turn off flag  */
        !           757: 
        !           758:        if(gctime) {
        !           759:                times(&finish);
        !           760:                gctime += (finish.tms_utime - begin.tms_utime);
        !           761:        }
        !           762:        return(save);   /*  return result of gcafter  */
        !           763:        }
        !           764: 
        !           765:        
        !           766: 
        !           767: /*  gc1()  **************************************************************/
        !           768: /*                                                                     */
        !           769: /*  Mark-and-sweep phase                                               */
        !           770: 
        !           771: gc1()
        !           772: {
        !           773:        int j, k;
        !           774:        register int *start,bvalue,type_len; 
        !           775:        register struct types *s;
        !           776:        int *point,i,freecnt,itemstogo,bits,bindex,type,bytestoclear;
        !           777:        int usedcnt;
        !           778:        char *pindex;
        !           779:        struct argent *loop2;
        !           780:        struct nament *loop3;
        !           781:        struct atom *symb;
        !           782:        int markdp();
        !           783:        extern int hashtop;
        !           784: 
        !           785:        pagerand(); 
        !           786:        /*  decide whether to check LISP structure or not  */
        !           787: 
        !           788: 
        !           789: #ifdef METER
        !           790:        vtimes(&premark,0);
        !           791:        mrkdpcnt = 0;
        !           792:        conssame = consdiff = consnil = 0;
        !           793: #endif
        !           794: 
        !           795:        /*  first set all bit maps to zero  */
        !           796: 
        !           797: 
        !           798: #ifdef SLOCLEAR
        !           799:        {
        !           800:            int enddat;
        !           801:            enddat = (int)(datalim-OFFSET) >> 8;
        !           802:            for(bvalue=0; bvalue < (int)enddat ; ++bvalue)
        !           803:            {
        !           804:                 qbitmap[bvalue] = zeroq; 
        !           805:            }
        !           806:        }
        !           807: #endif
        !           808: 
        !           809:        /* try the movc5 to clear the bit maps */
        !           810:        /* the maximum number of bytes we can clear in one sweep is
        !           811:         * 2^16 (or 1<<16 in the C lingo)
        !           812:         */
        !           813:        bytestoclear = ((((int)datalim)-((int)beginsweep)) >> 9) * 16; 
        !           814:        for(start = bitmapi + ATOLX(beginsweep);
        !           815:            bytestoclear > 0;)
        !           816:            {
        !           817:                if(bytestoclear > MAXCLEAR)
        !           818:                        blzero((int)start,MAXCLEAR);
        !           819:                else
        !           820:                        blzero((int)start,bytestoclear);
        !           821:                start = (int *) (MAXCLEAR + (int) start);
        !           822:                bytestoclear -= MAXCLEAR;
        !           823:            }
        !           824:                        
        !           825:        /* mark all atoms in the oblist */
        !           826:         for( bvalue=0 ; bvalue <= hashtop-1 ; bvalue++ ) /* though oblist */
        !           827:         {
        !           828:            for( symb = hasht[bvalue] ; symb != (struct atom *) CNIL ;
        !           829:                      symb = symb-> hshlnk) {
        !           830:                  markdp((lispval)symb); 
        !           831:            }
        !           832:        }
        !           833: 
        !           834: 
        !           835:        /* Mark all the atoms and ints associated with the hunk
        !           836:           data types */
        !           837:           
        !           838:        for(i=0; i<7; i++) {
        !           839:                markdp(hunk_items[i]);
        !           840:                markdp(hunk_name[i]);
        !           841:                markdp(hunk_pages[i]);
        !           842:        }
        !           843:        /* next run up the name stack */
        !           844:        for(loop2 = np - 1; loop2 >=  orgnp; --loop2) MARKVAL(loop2->val);      
        !           845: 
        !           846:        /* now the bindstack (vals only, atoms are marked elsewhere ) */
        !           847:        for(loop3 = bnp - 1; loop3 >= orgbnp; --loop3)MARKVAL(loop3->val);
        !           848: 
        !           849:        
        !           850:        /* next mark all compiler linked data */
        !           851:        /* if the Vpurcopylits switch is non nil (lisp variable $purcopylits)
        !           852:         * then when compiled code is read in, it tables will not be linked
        !           853:         * into this table and thus will not be marked here.  That is ok
        !           854:         * though, since that data is assumed to be pure.
        !           855:         */
        !           856:         point = bind_lists;
        !           857:         while((start = point) != (int *)CNIL) {
        !           858:                while( *start != -1 )
        !           859:                {
        !           860:                        markdp((lispval)*start);
        !           861:                        start++;
        !           862:                }
        !           863:                point = (int *)*(point-1);
        !           864:         }
        !           865: 
        !           866:        /* next mark all system-significant lisp data */
        !           867: 
        !           868:        
        !           869:        for(i=0; i<SIGNIF; ++i) markdp((lispsys[i]));
        !           870: 
        !           871: #ifdef METER
        !           872:        vtimes(&presweep,0);
        !           873: #endif
        !           874:        /* all accessible data has now been marked. */
        !           875:        /* all collectable spaces must be swept,    */
        !           876:        /* and freelists constructed.               */
        !           877: 
        !           878:        /* first clear the structure elements for types
        !           879:         * we will sweep
        !           880:         */
        !           881:        
        !           882:        for(k=0 ; k <= VECTORI ; k++)
        !           883:        {
        !           884:                if( s=gcableptr[k]) {
        !           885:                    if(k==STRNG && !gcstrings) { /* don't do anything*/ }
        !           886:                    else
        !           887:                        {
        !           888:                          (*(s->items))->i = 0;
        !           889:                          s->space_left = 0;
        !           890:                          s->next_free = (char *) CNIL;
        !           891:                        }
        !           892:                }
        !           893:        }
        !           894: #if m_68k
        !           895:        fixbits(bitmapi+ATOLX(beginsweep),bitmapi+ATOLX(datalim));
        !           896: #endif
        !           897: 
        !           898: 
        !           899:        /* sweep up in memory looking at gcable pages */
        !           900: 
        !           901:        for(start = beginsweep,  bindex = ATOLX(start), 
        !           902:                  pindex = &purepage[ATOX(start)]; 
        !           903:            start < (int *)datalim;
        !           904:            start += 128, pindex++)
        !           905:        {
        !           906:            if(!(s=gcableptr[type = TYPE(start)]) || *pindex
        !           907: #ifdef GCSTRINGS
        !           908:             || (type==STRNG && !gcstrings) 
        !           909: #endif
        !           910:                )
        !           911:            {
        !           912:                /* ignore this page but advance pointer         */
        !           913:                bindex += 4;   /* and 4 words of 32 bit bitmap words */
        !           914:                continue;
        !           915:            }
        !           916: 
        !           917:            freecnt = 0;                /* number of free items found */
        !           918:            usedcnt = 0;                /* number of used items found */
        !           919:            
        !           920:            point = start;
        !           921:            /* sweep dtprs as a special case, since
        !           922:             * 1) there will (usually) be more dtpr pages than any other type
        !           923:             * 2) most dtpr pages will be empty so we can really win by special
        !           924:             *    caseing the sweeping of massive numbers of free cells
        !           925:             */
        !           926:            /* since sdot's have the same structure as dtprs, this code will
        !           927:               work for them too
        !           928:             */
        !           929:            if((type == DTPR) || (type == SDOT))
        !           930:            {
        !           931:                int *head,*lim;
        !           932:                head = (int *) s->next_free;    /* first value on free list*/
        !           933: 
        !           934:                for(i=0; i < 4; i++)    /* 4 bit map words per page  */
        !           935:                {
        !           936:                    bvalue = bitmapi[bindex++]; /* 32 bits = 16 dtprs */
        !           937:                    if(bvalue == 0)     /* if all are free      */
        !           938:                    {
        !           939:                        *point = (int)head;
        !           940:                        lim = point + 32;   /* 16 dtprs = 32 ints */
        !           941:                        for(point += 2; point < lim ; point += 2)
        !           942:                        {
        !           943:                            *point = (int)(point - 2);
        !           944:                        }
        !           945:                        head = point - 2;
        !           946:                        freecnt += 16;
        !           947:                    }
        !           948:                    else for(j = 0; j < 16 ; j++)
        !           949:                    {
        !           950:                        if(!(bvalue & 1))
        !           951:                        {
        !           952:                            freecnt++;
        !           953:                            *point = (int)head;
        !           954:                            head = point;
        !           955:                        }
        !           956: #ifdef METER
        !           957:                        /* check if the page address of this cell is the
        !           958:                         * same as the address of its cdr
        !           959:                         */
        !           960:                        else if(FALSE && gcstat && (type == DTPR))
        !           961:                        {  
        !           962:                           if(((int)point & ~511) 
        !           963:                              == ((int)(*point) & ~511)) conssame++;
        !           964:                           else consdiff++;
        !           965:                           usedcnt++;
        !           966:                        }
        !           967: #endif
        !           968:                        else usedcnt++;         /* keep track of used */
        !           969:                        
        !           970:                        point += 2;
        !           971:                        bvalue = bvalue >> 2;
        !           972:                    }
        !           973:                }
        !           974:                s->next_free = (char *) head;
        !           975:            }
        !           976:            else if((type == VECTOR) || (type == VECTORI))
        !           977:            {
        !           978:                int canjoin = FALSE;
        !           979:                int *tempp;
        !           980: 
        !           981:                /* check if first item on freelist ends exactly at
        !           982:                   this page
        !           983:                 */
        !           984:                if(((tempp = (int *)s->next_free) != (int *)CNIL)
        !           985:                   && ((VecTotSize(((lispval)tempp)->vl.vectorl[-1])
        !           986:                                                            + 1 + tempp)
        !           987:                                        == point))
        !           988:                   canjoin = TRUE;
        !           989:                   
        !           990:                /* arbitrary sized vector sweeper */
        !           991:                /*
        !           992:                 * jump past first word since that is a size fixnum
        !           993:                 * and second word since that is property word
        !           994:                 */
        !           995:                if(debugin)
        !           996:                  fprintf(stderr,"vector sweeping, start at 0x%x\n",
        !           997:                                point);
        !           998:                bits = 30;
        !           999:                bvalue = bitmapi[bindex++] >> 2;
        !          1000:                point += 2;
        !          1001:                while (TRUE) {
        !          1002:                    type_len = point[VSizeOff];
        !          1003:                    if(debugin) {
        !          1004:                      fprintf(stderr,"point: 0x%x, type_len %d\n",
        !          1005:                                point, type_len);
        !          1006:                      fprintf(stderr,"bvalue: 0x%x, bits: %d, bindex: 0x%x\n",
        !          1007:                                bvalue, bits, bindex);
        !          1008:                    }
        !          1009:                                        /* get size of vector */
        !          1010:                    if(!(bvalue & 1))   /* if free */
        !          1011:                    {
        !          1012:                        if(debugin) fprintf(stderr,"free\n");
        !          1013:                        freecnt += type_len + 2*sizeof(long);
        !          1014:                        if(canjoin)
        !          1015:                        {
        !          1016:                            /* join by adjusting size of first vector */
        !          1017:                            ((lispval)(s->next_free))->vl.vectorl[-1]
        !          1018:                              +=  type_len + 2*sizeof(long); 
        !          1019:                            if(debugin)
        !          1020:                              fprintf(stderr,"joined size: %d\n",
        !          1021:                                  ((lispval)(s->next_free))->vl.vectorl[-1]);
        !          1022:                        }
        !          1023:                        else {
        !          1024:                            /* vectors are linked at the property word */
        !          1025:                            *(point - 1) = (int)(s->next_free);
        !          1026:                            s->next_free = (char *) (point - 1);
        !          1027:                        }
        !          1028:                        canjoin = TRUE;
        !          1029:                    }
        !          1030:                    else {
        !          1031:                        canjoin = FALSE;
        !          1032:                        usedcnt += type_len + 2*sizeof(long);
        !          1033:                    }
        !          1034:                    
        !          1035:                    point += VecTotSize(type_len);
        !          1036:                    /* we stop sweeping only when we reach a page
        !          1037:                       boundary since vectors can span pages
        !          1038:                     */
        !          1039:                    if(((int)point & 511) == 0)
        !          1040:                    {
        !          1041:                        /* reset the counters, we cannot predict how
        !          1042:                         * many pages we have crossed over
        !          1043:                         */
        !          1044:                        bindex = ATOLX(point);
        !          1045:                        /* these will be inced, so we must dec */
        !          1046:                        pindex = &purepage[ATOX(point)] - 1;
        !          1047:                        start = point - 128;
        !          1048:                        if(debugin)
        !          1049:                        fprintf(stderr,
        !          1050:                                "out of vector sweep when point = 0x%x\n",
        !          1051:                                point);
        !          1052:                        break;
        !          1053:                    }
        !          1054:                    /* must advance to next point and next value in bitmap.
        !          1055:                     * we add VecTotSize(type_len) + 2 to get us to the 0th
        !          1056:                     * entry in the next vector (beyond the size fixnum)
        !          1057:                     */
        !          1058:                    point += 2;         /* point to next 0th entry */
        !          1059:                    if ( (bits -= (VecTotSize(type_len) + 2)) > 0)  
        !          1060:                        bvalue = bvalue >> (VecTotSize(type_len) + 2);
        !          1061:                    else {
        !          1062:                        bits = -bits;   /* must advance to next word in map */
        !          1063:                        bindex += bits / 32; /* this is tricky stuff... */
        !          1064:                        bits = bits % 32;
        !          1065:                        bvalue = bitmapi[bindex++] >> bits;
        !          1066:                        bits = 32 - bits;
        !          1067:                    }
        !          1068:                }
        !          1069:            }
        !          1070:            else { 
        !          1071:                /* general sweeper, will work for all types */
        !          1072:                itemstogo = s->space;   /* number of items per page  */
        !          1073:                bits = 32;                      /* number of bits per word */
        !          1074:                type_len = s->type_len;
        !          1075: 
        !          1076:                /* printf(" s %d, itemstogo %d, len %d\n",s,itemstogo,type_len);*/
        !          1077:                bvalue = bitmapi[bindex++];
        !          1078: 
        !          1079:                while(TRUE)
        !          1080:                {
        !          1081:                    if(!(bvalue & 1))   /* if data element is not marked */
        !          1082:                    {
        !          1083:                        freecnt++;
        !          1084:                        *point = (int) (s->next_free) ;
        !          1085:                        s->next_free = (char *) point;
        !          1086:                    }
        !          1087:                    else usedcnt++;
        !          1088: 
        !          1089:                    if( --itemstogo <= 0 ) 
        !          1090:                    {    if(type_len >= 64) 
        !          1091:                         {
        !          1092:                            bindex++;
        !          1093:                            if(type_len >=128) bindex += 2;
        !          1094:                         }
        !          1095:                         break;
        !          1096:                    }
        !          1097: 
        !          1098:                    point += type_len;
        !          1099:                    /* shift over mask by number of words in data type */
        !          1100: 
        !          1101:                    if( (bits -= type_len) > 0)
        !          1102:                    {  bvalue = bvalue >> type_len;
        !          1103:                    } 
        !          1104:                    else if( bits == 0 ) 
        !          1105:                    {  bvalue = bitmapi[bindex++];
        !          1106:                       bits = 32;
        !          1107:                    }
        !          1108:                    else
        !          1109:                    {  bits = -bits;
        !          1110:                       while( bits >= 32) { bindex++;
        !          1111:                                            bits -= 32;
        !          1112:                                          }
        !          1113:                       bvalue = bitmapi[bindex++];
        !          1114:                       bvalue = bvalue >> bits;
        !          1115:                       bits = 32 - bits;;
        !          1116:                    }
        !          1117:            }
        !          1118:        }
        !          1119: 
        !          1120:      s->space_left += freecnt;
        !          1121:      (*(s->items))->i += usedcnt;
        !          1122:      }
        !          1123: 
        !          1124: #ifdef METER
        !          1125:         vtimes(&alldone,0);
        !          1126:        if(gcstat) gcdump();
        !          1127: #endif
        !          1128:        pagenorm(); 
        !          1129: }
        !          1130: 
        !          1131: /*
        !          1132:  * alloc
        !          1133:  *
        !          1134:  *  This routine tries to allocate one or more pages of the space named
        !          1135:  *  by the first argument.   Returns the number of pages actually allocated.
        !          1136:  *  
        !          1137:  */
        !          1138: 
        !          1139: lispval
        !          1140: alloc(tname,npages)
        !          1141: lispval tname; long npages;
        !          1142: {
        !          1143:        long ii, jj;
        !          1144:        struct types *typeptr;
        !          1145: 
        !          1146:        ii = typenum(tname);
        !          1147:         typeptr = spaces[ii];
        !          1148:        if(npages <= 0) return(inewint(npages));
        !          1149:        
        !          1150:        if((ATOX(datalim)) + npages > TTSIZE)
        !          1151:           error("Space request would exceed maximum memory allocation",FALSE);
        !          1152:        if((ii == VECTOR) || (ii == VECTORI))
        !          1153:        {
        !          1154:            /* allocate in one big chunk */
        !          1155:            tname = csegment((int) ii,(int) npages*128,0);
        !          1156:            tname->vl.vectorl[0] = (npages*512 - 2*sizeof(long));
        !          1157:            tname->v.vector[1] = (lispval) typeptr->next_free;
        !          1158:            typeptr->next_free = (char *) &(tname->v.vector[1]);
        !          1159:            if(debugin) fprintf(stderr,"alloced %d vec pages\n",npages);
        !          1160:            return(inewint(npages));
        !          1161:        }
        !          1162:           
        !          1163:        for( jj=0; jj<npages; ++jj)
        !          1164:                if(get_more_space(spaces[ii],FALSE)) break;
        !          1165:        return(inewint(jj));
        !          1166: }
        !          1167: 
        !          1168: /*
        !          1169:  * csegment(typecode,nitems,useholeflag)
        !          1170:  *  allocate nitems of type typecode.  If useholeflag is true, then
        !          1171:  * allocate in the hole if there is room.  This routine doesn't look
        !          1172:  * in the free lists, it always allocates space.
        !          1173:  */    
        !          1174: lispval
        !          1175: csegment(typecode,nitems,useholeflag)
        !          1176: {
        !          1177:        register int ii, jj;
        !          1178:        register char *charadd;
        !          1179: 
        !          1180:        ii = typecode;
        !          1181: 
        !          1182:        if(ii!=OTHER) nitems *= 4*spaces[ii]->type_len;
        !          1183:        nitems = roundup(nitems,512);           /*  round up to right length  */
        !          1184: #ifdef HOLE
        !          1185:        if(useholeflag)
        !          1186:                charadd = gethspace(nitems,ii);
        !          1187:        else
        !          1188: #endif
        !          1189:        {
        !          1190:                charadd = sbrk(nitems);
        !          1191:                datalim = (lispval)(charadd+nitems);
        !          1192:        }
        !          1193:        if( (int) charadd <= 0 )
        !          1194:                error("NOT ENOUGH SPACE FOR ARRAY",FALSE);
        !          1195:        /*if(ii!=OTHER)*/ (*spaces[ii]->pages)->i +=  nitems/512;
        !          1196:        if(ATOX(datalim) > fakettsize) {
        !          1197:                datalim = (lispval) (OFFSET + (fakettsize << 9));
        !          1198:                if(fakettsize >= TTSIZE)
        !          1199:                {
        !          1200:                    printf("There isn't room enough to continue, goodbye\n");
        !          1201:                    franzexit(1);
        !          1202:                }
        !          1203:                fakettsize++;
        !          1204:                badmem(53);
        !          1205:        }
        !          1206:        for(jj=0; jj<nitems; jj=jj+512) {
        !          1207:                SETTYPE(charadd+jj, ii,30);
        !          1208:        }
        !          1209:        ii = (int) charadd;
        !          1210:        while(nitems > MAXCLEAR)
        !          1211:        {
        !          1212:            blzero(ii,MAXCLEAR);
        !          1213:            nitems -= MAXCLEAR;
        !          1214:            ii += MAXCLEAR;
        !          1215:        }
        !          1216:        blzero(ii,nitems);
        !          1217:        return((lispval)charadd);
        !          1218: }
        !          1219: 
        !          1220: int csizeof(tname) lispval tname;
        !          1221:        {
        !          1222:        return( spaces[typenum(tname)]->type_len * 4 );
        !          1223:        }
        !          1224: 
        !          1225: int typenum(tname) lispval tname;
        !          1226:        {
        !          1227:        int ii;
        !          1228: 
        !          1229: chek:  for(ii=0; ii<NUMSPACES; ++ii)
        !          1230:                if(spaces[ii] && tname == *(spaces[ii]->type_name)) break;
        !          1231:        if(ii == NUMSPACES)
        !          1232:                {
        !          1233:                tname = error("BAD TYPE NAME",TRUE);
        !          1234:                goto chek;
        !          1235:                }
        !          1236: 
        !          1237:        return(ii);
        !          1238:        
        !          1239:        }
        !          1240: char *
        !          1241: gethspace(segsiz,type)
        !          1242: {
        !          1243:        extern usehole; extern char holend[]; extern char *curhbeg;
        !          1244:        register char *value;
        !          1245: 
        !          1246:        if(usehole) {   
        !          1247:                curhbeg = (char *) roundup(((int)curhbeg),LBPG);
        !          1248:                if((holend - curhbeg) < segsiz)
        !          1249:                {       
        !          1250:                        usehole = FALSE;
        !          1251:                        curhbeg = holend;
        !          1252:                } else {
        !          1253:                        value = curhbeg;
        !          1254:                        curhbeg = curhbeg + segsiz;
        !          1255:                        /*printf("start %d, finish %d, size %d\n",value, curhbeg,segsiz);*/
        !          1256:                        return(value);
        !          1257:                }
        !          1258:        }
        !          1259:        value = (ysbrk(segsiz/LBPG,type));
        !          1260:        datalim = (lispval)(value + segsiz);
        !          1261:        return(value);
        !          1262: }
        !          1263: gcrebear()
        !          1264: {
        !          1265: #ifdef HOLE
        !          1266:         register int i; register struct types *p;
        !          1267: 
        !          1268:        /* this gets done upon rebirth */
        !          1269:        str_current[1].space_left = 0;
        !          1270: #ifndef GCSTRINGS
        !          1271:        str_current[0].space_left = 0;  /* both kinds of strings go in hole*/
        !          1272: #endif
        !          1273:        funct_str.space_left = 0;
        !          1274:        funct_str.next_free = (char *) CNIL;
        !          1275:        /* clear pure space pointers */
        !          1276:        for(i = 0; i < NUMSPACES; i++)
        !          1277:        {
        !          1278:            if(p=spaces[i])
        !          1279:            p->next_pure_free = (char *) CNIL;
        !          1280:        }
        !          1281: #endif
        !          1282: }
        !          1283: 
        !          1284: /** markit(p) ***********************************************************/
        !          1285: /*  just calls markdp                                                  */
        !          1286: 
        !          1287: markit(p) lispval *p; { markdp(*p); }
        !          1288: 
        !          1289: /*
        !          1290:  * markdp(p)
        !          1291:  *
        !          1292:  *  markdp is the routine which marks each data item.  If it is a
        !          1293:  *  dotted pair, the car and cdr are marked also.
        !          1294:  *  An iterative method is used to mark list structure, to avoid
        !          1295:  *  excessive recursion.
        !          1296:  */
        !          1297: markdp(p) register lispval p;
        !          1298:        {
        !          1299: #ifdef tahoe
        !          1300:        register int r, s;      /* (goes with non-asm readbit, oksetbit) */
        !          1301: #endif
        !          1302: /*     register hsize, hcntr;                                           */
        !          1303:        int hsize, hcntr;
        !          1304: 
        !          1305: #ifdef METER
        !          1306:        mrkdpcnt++;
        !          1307: #endif
        !          1308: ptr_loop:
        !          1309:        if(((int)p) <= ((int)nil)) return;      /*  do not mark special data types or nil=0  */
        !          1310: 
        !          1311:                
        !          1312:        switch( TYPE(p) )
        !          1313:                {
        !          1314:                case ATOM:
        !          1315:                        ftstbit;
        !          1316:                        MARKVAL(p->a.clb);
        !          1317:                        MARKVAL(p->a.plist);
        !          1318:                        MARKVAL(p->a.fnbnd);
        !          1319: #ifdef GCSTRINGS
        !          1320:                        if(gcstrings) MARKVAL(((lispval)p->a.pname));
        !          1321:                        return;
        !          1322: 
        !          1323:                case STRNG:
        !          1324:                        p = (lispval) (((int) p) & ~ (LBPG-1));
        !          1325:                        ftstbit;
        !          1326: #endif
        !          1327:                        return;
        !          1328:                        
        !          1329:                case INT:
        !          1330:                case DOUB:
        !          1331:                        ftstbit;
        !          1332:                        return;
        !          1333:                case VALUE:
        !          1334:                        ftstbit;
        !          1335:                        p = p->l;
        !          1336:                        goto ptr_loop;
        !          1337:                case DTPR:
        !          1338:                        ftstbit;
        !          1339:                        MARKVAL(p->d.car);
        !          1340: #ifdef METER
        !          1341:                        /* if we are metering , then check if the cdr is
        !          1342:                         * nil, or if the cdr is on the same page, and if
        !          1343:                         * it isn't one of those, then it is on a different
        !          1344:                         * page
        !          1345:                         */
        !          1346:                         if(gcstat)
        !          1347:                         {
        !          1348:                             if(p->d.cdr == nil) consnil++;
        !          1349:                             else if(((int)p & ~511) 
        !          1350:                                     == (((int)(p->d.cdr)) & ~511))
        !          1351:                                conssame++;
        !          1352:                             else consdiff++;
        !          1353:                          }
        !          1354: #endif
        !          1355:                        p = p->d.cdr;
        !          1356:                        goto ptr_loop;
        !          1357: 
        !          1358:                case ARRAY:
        !          1359:                        ftstbit;        /* mark array itself */
        !          1360: 
        !          1361:                        MARKVAL(p->ar.accfun);  /* mark access function */
        !          1362:                        MARKVAL(p->ar.aux);             /* mark aux data */
        !          1363:                        MARKVAL(p->ar.length);  /* mark length */
        !          1364:                        MARKVAL(p->ar.delta);   /* mark delta */
        !          1365:                        if(TYPE(p->ar.aux)==DTPR && p->ar.aux->d.car==Vnogbar)
        !          1366:                        {
        !          1367:                            /* a non garbage collected array must have its
        !          1368:                             * array space marked but the value of the array
        !          1369:                             * space is not marked
        !          1370:                             */
        !          1371:                             int l; 
        !          1372:                             int cnt,d;
        !          1373:                             if(debugin) {
        !          1374:                               printf("mark array holders len %d, del %d, start 0x%x\n",
        !          1375:                                 p->ar.length->i,p->ar.delta->i,p->ar.data);
        !          1376:                                 fflush(stdout);
        !          1377:                            }
        !          1378:                             l = p->ar.length->i; /* number of elements */
        !          1379:                             d = p->ar.delta->i;  /* bytes per element  */
        !          1380:                             p = (lispval) p->ar.data;/* address of first one*/
        !          1381:                             if(purepage[ATOX(p)]) return;
        !          1382: 
        !          1383:                             for((cnt = 0); cnt<l ; 
        !          1384:                                      p = (lispval)(((char *) p) + d), cnt++)
        !          1385:                             {
        !          1386:                                setbit;
        !          1387:                             }
        !          1388:                        } else {
        !          1389: /*                     register int i, l; int d;               */
        !          1390: /*                     register char *dataptr = p->ar.data;    */
        !          1391:                        int i,l,d;
        !          1392:                        char *dataptr = p->ar.data;
        !          1393: 
        !          1394:                        for(i=0, l=p->ar.length->i, d=p->ar.delta->i; i<l; ++i)
        !          1395:                                {
        !          1396:                                markdp((lispval)dataptr);
        !          1397:                                dataptr += d;
        !          1398:                                }
        !          1399:                        }
        !          1400:                        return;
        !          1401:                case SDOT:
        !          1402:                        do {
        !          1403:                                ftstbit;
        !          1404:                                p = p->s.CDR;
        !          1405:                        } while (p!=0);
        !          1406:                        return;
        !          1407: 
        !          1408:                case BCD:
        !          1409:                        ftstbit;
        !          1410:                        markdp(p->bcd.discipline);
        !          1411:                        return;
        !          1412: 
        !          1413:                case HUNK2:
        !          1414:                case HUNK4:
        !          1415:                case HUNK8:
        !          1416:                case HUNK16:
        !          1417:                case HUNK32:
        !          1418:                case HUNK64:
        !          1419:                case HUNK128:
        !          1420:                        {
        !          1421:                                hsize = 2 << HUNKSIZE(p);
        !          1422:                                ftstbit;
        !          1423:                                for (hcntr = 0; hcntr < hsize; hcntr++)
        !          1424:                                        MARKVAL(p->h.hunk[hcntr]);
        !          1425:                                return;
        !          1426:                        }
        !          1427:                        
        !          1428:                case VECTORI:
        !          1429:                        ftstbit;
        !          1430:                        MARKVAL(p->v.vector[-1]);       /* mark property */
        !          1431:                        return;
        !          1432:                        
        !          1433:                case VECTOR:
        !          1434:                        {
        !          1435:                            register int vsize;
        !          1436:                            ftstbit;
        !          1437:                            vsize = VecSize(p->vl.vectorl[VSizeOff]);
        !          1438:                            if(debugin)
        !          1439:                               fprintf(stderr,"mark vect at %x  size %d\n",
        !          1440:                                        p,vsize);
        !          1441:                            while(--vsize >= -1)
        !          1442:                            {
        !          1443:                                MARKVAL(p->v.vector[vsize]);
        !          1444:                            };
        !          1445:                            return;
        !          1446:                        }
        !          1447:                }
        !          1448:        return;
        !          1449:        }
        !          1450: 
        !          1451: 
        !          1452: /* xsbrk allocates space in large chunks (currently 16 pages)
        !          1453:  * xsbrk(1)  returns a pointer to a page
        !          1454:  * xsbrk(0)  returns a pointer to the next page we will allocate (like sbrk(0))
        !          1455:  */
        !          1456: 
        !          1457: char *
        !          1458: xsbrk(n)
        !          1459:        {
        !          1460:        static char *xx;        /*  pointer to next available blank page  */
        !          1461:        extern int xcycle;      /*  number of blank pages available  */
        !          1462:        lispval u;                      /*  used to compute limits of bit table  */
        !          1463: 
        !          1464:        if( (xcycle--) <= 0 )
        !          1465:                {
        !          1466:                xcycle = 15;
        !          1467:                xx = sbrk(16*LBPG);     /*  get pages 16 at a time  */
        !          1468:                if( (int)xx== -1 )
        !          1469:                        lispend("For sbrk from lisp: no space... Goodbye!");
        !          1470:                }
        !          1471:        else xx += LBPG;
        !          1472: 
        !          1473:        if(n == 0)
        !          1474:        {
        !          1475:            xcycle++;   /* don't allocate the page */
        !          1476:            xx -= LBPG;
        !          1477:            return(xx); /* just return its address */
        !          1478:        }
        !          1479: 
        !          1480:        if( (u = (lispval)(xx+LBPG))  > datalim ) datalim = u;
        !          1481:        return(xx);
        !          1482:        }
        !          1483: 
        !          1484: char *ysbrk(pages,type) int pages, type;
        !          1485:        {
        !          1486:        char *xx;       /*  will point to block of storage  */
        !          1487:        int i;
        !          1488: 
        !          1489:        xx = sbrk(pages*LBPG);
        !          1490:        if((int)xx == -1)
        !          1491:                error("OUT OF SPACE FOR ARRAY REQUEST",FALSE);
        !          1492: 
        !          1493:        datalim = (lispval)(xx+pages*LBPG);     /*  compute bit table limit  */
        !          1494: 
        !          1495:        /*  set type for pages  */
        !          1496: 
        !          1497:        for(i = 0; i < pages; ++i) {
        !          1498:                SETTYPE((xx + i*LBPG),type,10);
        !          1499:        }
        !          1500: 
        !          1501:        return(xx);     /*  return pointer to block of storage  */
        !          1502:        }
        !          1503:        
        !          1504: /*
        !          1505:  * getatom 
        !          1506:  * returns either an existing atom with the name specified in strbuf, or
        !          1507:  * if the atom does not already exist, regurgitates a new one and 
        !          1508:  * returns it.
        !          1509:  */
        !          1510: lispval
        !          1511: getatom(purep)
        !          1512: {   register lispval aptr;
        !          1513:     register char *name, *endname;
        !          1514:     register int hash;
        !          1515:     lispval    b;
        !          1516:     char       c;
        !          1517: 
        !          1518:        name = strbuf;
        !          1519:        if (*name == (char)0377) return (eofa);
        !          1520:        hash = hashfcn(name);
        !          1521:        atmlen = strlen(name) + 1;
        !          1522:        aptr = (lispval) hasht[hash];
        !          1523:        while (aptr != CNIL)
        !          1524:            /* if (strcmp(name,aptr->a.pname)==0) */
        !          1525:            if (*name==*aptr->a.pname && strcmp(name,aptr->a.pname)==0)
        !          1526:                return (aptr);
        !          1527:            else
        !          1528:                aptr = (lispval) aptr->a.hshlnk;
        !          1529:        aptr = (lispval) newatom(purep);  /*share pname of atoms on oblist*/
        !          1530:        aptr->a.hshlnk = hasht[hash];
        !          1531:        hasht[hash] = (struct atom *) aptr;
        !          1532:        endname = name + atmlen - 2;
        !          1533:        if ((atmlen != 4) && (*name == 'c') && (*endname == 'r'))
        !          1534:                {
        !          1535:                b = newdot();
        !          1536:                protect(b);
        !          1537:                b->d.car = lambda;
        !          1538:                b->d.cdr = newdot();
        !          1539:                b = b->d.cdr;
        !          1540:                b->d.car = newdot();
        !          1541:                (b->d.car)->d.car = xatom;
        !          1542:                while(TRUE)
        !          1543:                        {
        !          1544:                        b->d.cdr = newdot();
        !          1545:                        b= b->d.cdr;
        !          1546:                        if(++name == endname)
        !          1547:                                {
        !          1548:                                b->d.car= (lispval) xatom;
        !          1549:                                aptr->a.fnbnd = (--np)->val;
        !          1550:                                break;
        !          1551:                                }
        !          1552:                        b->d.car= newdot();
        !          1553:                        b= b->d.car;
        !          1554:                        if((c = *name) == 'a') b->d.car = cara;
        !          1555:                        else if (c == 'd') b->d.car = cdra;
        !          1556:                        else{ --np;
        !          1557:                           break;
        !          1558:                         }
        !          1559:                        }
        !          1560:                }
        !          1561: 
        !          1562:        return(aptr);
        !          1563:        }
        !          1564: 
        !          1565: /*
        !          1566:  * inewatom is like getatom, except that you provide it a string
        !          1567:  * to be used as the print name.  It doesn't do the automagic
        !          1568:  * creation of things of the form c[ad]*r.
        !          1569:  */
        !          1570: lispval
        !          1571: inewatom(name)
        !          1572: register char *name;
        !          1573: {   register struct atom *aptr;
        !          1574:     register int hash;
        !          1575:     extern struct types atom_str;
        !          1576:     char       c;
        !          1577: 
        !          1578:        if (*name == (char)0377) return (eofa);
        !          1579:        hash = hashfcn(name);
        !          1580:        aptr = hasht[hash];
        !          1581:        while (aptr != (struct atom *)CNIL)
        !          1582:            if (strcmp(name,aptr->pname)==0)
        !          1583:                return ((lispval) aptr);
        !          1584:            else
        !          1585:                aptr = aptr->hshlnk;
        !          1586:        aptr = (struct atom *) next_one(&atom_str) ;    
        !          1587:        aptr->plist = aptr->fnbnd = nil;
        !          1588:        aptr->clb = CNIL;
        !          1589:        aptr->pname = name;
        !          1590:        aptr->hshlnk = hasht[hash];
        !          1591:        hasht[hash] = aptr;
        !          1592:        return((lispval)aptr);
        !          1593: }
        !          1594: 
        !          1595: 
        !          1596: /* our hash function */
        !          1597: 
        !          1598: hashfcn(symb)
        !          1599: register char *symb;
        !          1600: {
        !          1601:        register int i;
        !          1602: /*     for (i=0 ; *symb ; i += i + *symb++); return(i & (HASHTOP-1)); */
        !          1603:        for (i=0 ; *symb ; i += i*2 + *symb++);
        !          1604:        return(i&077777 % HASHTOP);
        !          1605: }
        !          1606: 
        !          1607: lispval
        !          1608: LImemory()
        !          1609: {
        !          1610:     int nextadr, pagesinuse;
        !          1611:     
        !          1612:     printf("Memory report. max pages = %d (0x%x) = %d Bytes\n",
        !          1613:                TTSIZE,TTSIZE,TTSIZE*LBPG);
        !          1614: #ifdef HOLE
        !          1615:         printf("This lisp has a hole:\n");
        !          1616:        printf("  current hole start: %d (0x%x), end %d (0x%x)\n",
        !          1617:                curhbeg, curhbeg, holend, holend);
        !          1618:        printf("  hole free: %d bytes = %d pages\n\n",
        !          1619:               holend-curhbeg, (holend-curhbeg)/LBPG);
        !          1620: #endif 
        !          1621:     nextadr = (int) xsbrk(0);  /* next space to be allocated */
        !          1622:     pagesinuse = nextadr/LBPG;
        !          1623:     printf("Next allocation at addr %d (0x%x) = page %d\n",
        !          1624:                        nextadr, nextadr, pagesinuse);
        !          1625:     printf("Free data pages: %d\n", TTSIZE-pagesinuse);
        !          1626:     return(nil);
        !          1627: }
        !          1628: 
        !          1629: extern struct atom *hasht[HASHTOP];
        !          1630: myhook(){}

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.