Relay-Version: version B 2.10 5/3/83; site utzoo.UUCP
Posting-Version: version B 2.10.1 6/24/83; site umcp-cs.UUCP
Path: utzoo!watmath!clyde!burl!ulysses!allegra!mit-eddie!think!harvard!seismo!umcp-cs!chris
From: chris@umcp-cs.UUCP (Chris Torek)
Newsgroups: net.lang.c
Subject: Re: Adding integral bytes to foo pointers
Message-ID: <1513@umcp-cs.UUCP>
Date: Sat, 7-Sep-85 23:44:45 EDT
Article-I.D.: umcp-cs.1513
Posted: Sat Sep  7 23:44:45 1985
Date-Received: Tue, 10-Sep-85 03:35:24 EDT
References: <90@rtp47.UUCP> <5400011@prism.UUCP> <167@rtp47.UUCP> <306@aphasia.UUCP>
Distribution: net
Organization: U of Maryland, Computer Science Dept., College Park, MD
Lines: 483

>I have an application where I want to be able to save masses of objects
>most with lots of pointers in them to other objects, and then use this
>result to initialize the program the next time it runs. . . .

Here is a fairly hacky way we did this for Franz Lisp under 4.1BSD.
It has a couple of nonportable things in it (``but *I* didn't write
them,'' he protests): in particular, readint() is wrong; it assumes
32 bit integers; and it uses a free()d value in HashFree().

However, it does handle circular data structures and show how to
dump pointers to objects, then restore them.

Credit department: this idea was originated by Rehmi Post; the code
was rewritten by Craig Stanfill, Randy Trigg, and myself.

-------------------------------------------------------------------
/*
 * This file contains C code for the lisp structure dumper package. The main
 * lisp-callable functions are sdump and sscoop.  The format is 
 *	(sdump <lispobj> <filename>)
 *	(sscoop <filename>) 
 *
 * Sdump takes a pointer to an (almost) arbitrary data structure in lisp and
 * dumps the contents in binary to the file.  It handles cons nodes, atoms
 * (including value, pname, and plist), hunks, integers, and strings. It DOES
 * watch out for cycles (using a hash table of pointers) and so will preserve
 * any in the structure.  Sscoop returns the pointer that was originally
 * dumped.
 *
 * One weird feature:  if an atom is actually a flavor then its property list
 * is NOT followed.  The check for flavor works by checking the plist of the
 * atom for a property 'type' with value 'flavor'. 
 */

#include <sys/types.h>
#include <stdio.h>
#include "global.h"

/*
 * Give lisp the following to start 'er up:
 *	(cfasl 'strc.o '_init_strc 'init-strc "function")
 *	(init-strc) 
 */

extern lispval matom(), inewint(), mstr(), newdot(), newhunk();

static int MaxHash;
static FILE *dumpfile;

typedef struct Bucket {
	struct Bucket *next;
	lispval lval;
	int ival;
} bucket;

#define HashLog		9
#define HashMask	((1<<HashLog)-1)
#define HashTabSize	(1<<HashLog)
#define HashFunc(x)	(((x)>>4)&HashMask)
#define NODUMP		99
#define FLAVOR		OTHER
#define NOTSEEN		(-100)
#define readbyt()	(getc(dumpfile))
#define printbyt(b)	(putc(b,dumpfile))
#define printint(i)	(putc(i,dumpfile),putc((i)>>8,dumpfile),\
			 putc((i)>>16,dumpfile),putc((i)>>24,dumpfile))
#define printptr(p)	(printint((int)(p)))
#define MAXSTRLEN 2*STRBLEN+1

static bucket HashTable[HashTabSize];
static char locstrbuf[MAXSTRLEN];

/* clear all elements in this bucket */
static
HashFree(b)
	register bucket *b;
{

	while (b->next)
		free(b = b->next);
}

/*
 * called when sdumping - checks whether x is in the hash table - If so,
 * return 1. If not, return 0 after installing. 
 */
static
dump_seen(x)
	register lispval x;
{
	register bucket *buck1, *buck2;
	register int i;

	for (buck1 = &HashTable[HashFunc((int) x)], i = 0;
	     buck1->lval != x && buck1->next;
	     buck1 = buck1->next, i++)
		/*void*/;
	if (buck1->lval == x)
		return (1);
	if (MaxHash < i)
		MaxHash = i;
	buck2 = (bucket *) malloc(sizeof (bucket));
	buck1->next = buck2;
	buck2->next = 0;
	buck2->lval = x;
	return (0);
}

/*
 * like the above, this searches down the hash table.  The difference is that
 * this one (called when scooping) returns the bucket itself - either the
 * found bucket, or the new one just created. 
 */
static bucket *
scoop_seen(x)
	register int x;
{
	register bucket *buck1, *buck2;
	register int i;

	for (buck1 = &HashTable[HashFunc((int) x)], i = 0;
	     buck1->ival != x && buck1->next;
	     buck1 = buck1->next, i++)
		/*void*/;
	if (buck1->ival == x)
		return (buck1);
	if (MaxHash < i)
		MaxHash = i;
	buck2 = (bucket *) malloc(sizeof (bucket));
	buck1->next = buck2;
	buck2->next = 0;
	buck2->ival = x;
	buck2->lval = (lispval) NOTSEEN;
	return (buck2);
}

/*
 * 'main' lisp-callable function to do the structure dumping - checks file
 * arg and then calls dump with the first pointer. 
 */

static lispval 
Lsdump()
{
	register int i;
	char *dfile;

	chkarg(2, "sdump");

	if (TYPE(lbot[1].val) == ATOM)
		dfile = lbot[1].val->a.pname;
	else if (TYPE(lbot[1].val) == STRNG)
		dfile = (char *) lbot[1].val;
	else {
		error("Improper file argument");
		return (nil);
	}

	if ((dumpfile = fopen(dfile, "w")) == NULL) {
		perror(dfile);
		return (nil);
	}
	MaxHash = 0;
	for (i = 0; i < HashTabSize; i++) {
		if (HashTable[i].next) {
			HashFree(HashTable[i]);
			HashTable[i].next = 0;
		}
		HashTable[i].lval = 0;
	}
	printptr(lbot[0].val);
	dump(lbot[0].val);
	fclose(dumpfile);
	return (inewint(MaxHash));
}

/* the */
static
dump(lispptr)
	register lispval lispptr;
{

	if (!dump_seen(lispptr))
		switch (TYPE(lispptr)) {
		case UNBO:
			error("sdump: Can't handle this type: UNBO");
		case STRNG:
			printbyt(TYPE(lispptr));
			printstr(lispptr);
			break;
		case ATOM:
			dump_atom(lispptr);
			break;
		case INT:
			printbyt(TYPE(lispptr));
			printint(lispptr->i);
			break;
		case DTPR:
			printbyt(TYPE(lispptr));
			printptr(lispptr->d.car);
			dump(lispptr->d.car);
			printptr(lispptr->d.cdr);
			dump(lispptr->d.cdr);
			break;
		case DOUB:
			error("sdump: Can't handle this type: DOUB");
		case BCD:
			error("sdump: Can't handle this type: BCD");
		case PORT:
			error("sdump: Can't handle this type: PORT");
		case ARRAY:
			error("sdump: Can't handle this type: ARRAY");
		case OTHER:
			error("sdump: Can't handle this type: OTHER");
		case SDOT:
			error("sdump: Can't handle this type: SDOT");
		case VALUE:
			error("sdump: Can't handle this type: VALUE");
		case HUNK2:
			dump_hunk(2, lispptr);
			break;
		case HUNK4:
			dump_hunk(4, lispptr);
			break;
		case HUNK8:
			dump_hunk(8, lispptr);
			break;
		case HUNK16:
			dump_hunk(16, lispptr);
			break;
		case HUNK32:
			dump_hunk(32, lispptr);
			break;
		case HUNK64:
			dump_hunk(64, lispptr);
			break;
		case HUNK128:
			dump_hunk(128, lispptr);
			break;
		default:
			error("Unknown type: sdump");
			break;
		}
}

/* dumps an atom or a flavor - in the latter case we don't dump plist */
static
dump_atom(ptr)
	register lispval ptr;
{

	switch (atomtype(ptr)) {
	case NODUMP:
		printbyt(NODUMP);
		printstr(ptr->a.pname);
		break;
	case FLAVOR:
		printbyt(FLAVOR);
		printstr(ptr->a.pname);
		printptr(ptr->a.clb);
		if (ptr->a.clb != CNIL)
			dump(ptr->a.clb);
		break;
	default:
		printbyt(TYPE(ptr));
		printstr(ptr->a.pname);
		printptr(ptr->a.clb);
		if (ptr->a.clb != CNIL)
			dump(ptr->a.clb);
		printptr(ptr->a.plist);
		dump(ptr->a.plist);
	}
}

/* run down hunk elements (num of them) dumping */
static
dump_hunk(num, ptr)
	register int num;
	register lispval ptr;
{
	register int i;

	printbyt(TYPE(ptr));
	for (i = 0; i < num; i++) {
		printptr(ptr->h.hunk[i]);
		dump(ptr->h.hunk[i]);
	}
}

/*
 * check whether ptr has either the si:flavor (it's a flavor) or the $$NODUMP
 * property.  In the latter case we dump only the name, in the former, we
 * also dump the value - neither dumps the plist 
 */
static
atomtype(ptr)
	register lispval ptr;
{
	register lispval tmp;
	int nodump = 0;
	static beenhere;
	static lispval tmptype, tmptype1;

	if (!beenhere) {
		beenhere++;
		tmptype = matom("si:flavor");
		tmptype1 = matom("$$NODUMP");
	}
	for (tmp = ptr->a.plist; tmp != nil; tmp = tmp->d.cdr->d.cdr)
		if (tmp->d.car == tmptype)
			return (FLAVOR);
		else if (tmp->d.car == tmptype1)
			nodump++;
	return (nodump ? NODUMP : 0);
}

/* dumps a string with 0 at the end */
static
printstr(str)
	register char *str;
{

	do {
		putc(*str, dumpfile);
	} while (*str++);
}

/*
 * the lisp-callable scoop'er - checks file arg and calls scoop with the
 * first pointer in the file. 
 */
static
lispval 
Lsscoop()
{
	lispval scoop(), ptr;
	register int i;
	char *dfile;

	chkarg(1, "sscoop");

	if (TYPE(lbot[0].val) == ATOM)
		dfile = lbot[0].val->a.pname;
	else if (TYPE(lbot[0].val) == STRNG)
		dfile = (char *) lbot[0].val;
	else {
		error("Improper file argument");
		return (nil);
	}

	if ((dumpfile = fopen(dfile, "r")) == NULL) {
		perror(dfile);
		return (nil);
	}
	/* clean out hash table */
	MaxHash = 0;
	for (i = 0; i < HashTabSize; i++) {
		if (HashTable[i].next) {
			HashFree(HashTable[i]);
			HashTable[i].next = 0;
		}
		HashTable[i].lval = 0;
		HashTable[i].ival = 0;
	}
	ptr = scoop(readint());
	fclose(dumpfile);
	return (ptr);
}

/*
 * the scoop'ing workhorse - if seen before (present in hash table) then
 * return the lispval entry in the hash table - otherwise, build the lispval
 * and stick in hash table. 
 */
static
lispval 
scoop(iptr)
	int iptr;
{
	register lispval ptr1;
	register bucket *buck;
	int type, hunknum;
	register i;
	char *readstr();

	buck = scoop_seen(iptr);
	if (buck->lval != (lispval) NOTSEEN)
		return (buck->lval);
	switch (type = readbyt()) {
	case STRNG:
		return (buck->lval = mstr(readstr()));
		break;
	case NODUMP:
		return (buck->lval = matom(readstr()));
		break;
	case ATOM:
		buck->lval = ptr1 = matom(readstr());
		if ((i = readint()) != (int) CNIL)
			ptr1->a.clb = scoop(i);
		else
			ptr1->a.clb = CNIL;
		ptr1->a.plist = scoop(readint());
		return (ptr1);
		break;
	case FLAVOR:
		buck->lval = ptr1 = matom(readstr());
		if ((i = readint()) != (int) CNIL)
			ptr1->a.clb = scoop(i);
		else
			ptr1->a.clb = CNIL;
		return (ptr1);
		break;
	case INT:
		return (buck->lval = inewint(readint()));
		break;
	case DTPR:
		protect(buck->lval = ptr1 = newdot());
		ptr1->d.car = scoop(readint());
		ptr1->d.cdr = scoop(readint());
		--np;
		return (ptr1);
		break;
	case HUNK2:
	case HUNK4:
	case HUNK8:
	case HUNK16:
	case HUNK32:
	case HUNK64:
	case HUNK128:
		hunknum = type - HUNK2;
		protect(buck->lval = ptr1 = newhunk(hunknum));
		for (i = 0; i < (2 << hunknum); i++)
			ptr1->h.hunk[i] = scoop(readint());
		--np;
		return (ptr1);
		break;
	default:
		error("unknown type in scoop");
	}
}

/* reads one int as 4 bytes */
static
readint()
{
	union {
		int i;
		char c[4];
	}     u;

	u.c[0] = readbyt();
	u.c[1] = readbyt();
	u.c[2] = readbyt();
	u.c[3] = readbyt();
	return u.i;
}

/*
 * reads a string - uses locstrbuf for storage.  Size of locstrbuf is a
 * function of STRBLEN (which is defined in global.h) 
 */
static char *
readstr()
{
	register char *s = locstrbuf;

	while (*s++ = getc(dumpfile))
		/*void*/;
	return (locstrbuf);
}

/* initializer for this package - should call after doing cfasl */
lispval 
init_strc()
{

	mfun("sdump", Lsdump, lambda);
	mfun("sscoop", Lsscoop, lambda);
}
-- 
In-Real-Life: Chris Torek, Univ of MD Comp Sci Dept (+1 301 454 4251)
UUCP:	seismo!umcp-cs!chris
CSNet:	chris@umcp-cs		ARPA:	chris@maryland