home *** CD-ROM | disk | FTP | other *** search
/ GEMini Atari / GEMini_Atari_CD-ROM_Walnut_Creek_December_1993.iso / files / language / xschm22 / src / xsimage.c < prev    next >
Encoding:
C/C++ Source or Header  |  1990-04-18  |  8.6 KB  |  391 lines
  1. /* xsimage.c - xscheme memory image save/restore functions */
  2. /*    Copyright (c) 1988, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xscheme.h"
  7.  
  8. /* virtual machine registers */
  9. extern LVAL xlfun;        /* current function */
  10. extern LVAL xlenv;        /* current environment */
  11. extern LVAL xlval;        /* value of most recent instruction */
  12.  
  13. /* stack limits */
  14. extern LVAL *xlstkbase;        /* base of value stack */
  15. extern LVAL *xlstktop;        /* top of value stack */
  16.  
  17. /* node space */
  18. extern NSEGMENT *nsegments;    /* list of node segments */
  19.  
  20. /* vector (and string) space */
  21. extern VSEGMENT *vsegments;    /* list of vector segments */
  22. extern LVAL *vfree;        /* next free location in vector space */
  23. extern LVAL *vtop;        /* top of vector space */
  24.  
  25. /* global variables */
  26. extern LVAL obarray,eof_object,default_object;
  27. extern jmp_buf top_level;
  28. extern FUNDEF funtab[];
  29.  
  30. /* local variables */
  31. static OFFTYPE off,foff;
  32. static FILE *fp;
  33.  
  34. /* external routines */
  35. extern FILE *osbopen();
  36.  
  37. /* forward declarations */
  38. OFFTYPE readptr();
  39. OFFTYPE cvoptr();
  40. LVAL cviptr();
  41.  
  42. /* xlisave - save the memory image */
  43. int xlisave(fname)
  44.   char *fname;
  45. {
  46.     unsigned char *cp;
  47.     NSEGMENT *nseg;
  48.     int size,n;
  49.     LVAL p,*vp;
  50.  
  51.     /* open the output file */
  52.     if ((fp = osbopen(fname,"w")) == NULL)
  53.     return (FALSE);
  54.  
  55.     /* first call the garbage collector to clean up memory */
  56.     gc();
  57.  
  58.     /* write out the stack size */
  59.     writeptr((OFFTYPE)(xlstktop-xlstkbase));
  60.  
  61.     /* write out the *obarray* symbol and various constants */
  62.     writeptr(cvoptr(obarray));
  63.     writeptr(cvoptr(eof_object));
  64.     writeptr(cvoptr(default_object));
  65.  
  66.     /* setup the initial file offsets */
  67.     off = foff = (OFFTYPE)2;
  68.  
  69.     /* write out all nodes that are still in use */
  70.     for (nseg = nsegments; nseg != NULL; nseg = nseg->ns_next) {
  71.     p = &nseg->ns_data[0];
  72.     n = nseg->ns_size;
  73.     for (; --n >= 0; ++p, off += sizeof(NODE))
  74.         switch (ntype(p)) {
  75.         case FREE:
  76.         break;
  77.         case CONS:
  78.         case CLOSURE:
  79.         case METHOD:
  80.         case PROMISE:
  81.         case ENV:
  82.         setoffset();
  83.         osbputc(p->n_type,fp);
  84.         writeptr(cvoptr(car(p)));
  85.         writeptr(cvoptr(cdr(p)));
  86.         foff += sizeof(NODE);
  87.         break;
  88.         case SYMBOL:
  89.         case OBJECT:
  90.         case VECTOR:
  91.         case CODE:
  92.         case CONTINUATION:
  93.         setoffset();
  94.         osbputc(p->n_type,fp);
  95.         size = getsize(p);
  96.         writeptr((OFFTYPE)size);
  97.         for (vp = p->n_vdata; --size >= 0; )
  98.             writeptr(cvoptr(*vp++));
  99.         foff += sizeof(NODE);
  100.         break;
  101.         case STRING:
  102.         setoffset();
  103.         osbputc(p->n_type,fp);
  104.         size = getslength(p);
  105.         writeptr((OFFTYPE)size);
  106.         for (cp = getstring(p); --size >= 0; )
  107.             osbputc(*cp++,fp);
  108.         foff += sizeof(NODE);
  109.         break;
  110.         default:
  111.         setoffset();
  112.         writenode(p);
  113.         foff += sizeof(NODE);
  114.         break;
  115.         }
  116.     }
  117.  
  118.     /* write the terminator */
  119.     osbputc(FREE,fp);
  120.     writeptr((OFFTYPE)0);
  121.  
  122.     /* close the output file */
  123.     osclose(fp);
  124.  
  125.     /* return successfully */
  126.     return (TRUE);
  127. }
  128.  
  129. /* xlirestore - restore a saved memory image */
  130. int xlirestore(fname)
  131.   char *fname;
  132. {
  133.     LVAL *getvspace();
  134.     unsigned int ssize;
  135.     unsigned char *cp;
  136.     int size,type;
  137.     LVAL p,*vp;
  138.  
  139.     /* open the file */
  140.     if ((fp = osbopen(fname,"r")) == NULL)
  141.     return (FALSE);
  142.  
  143.     /* free the old memory image */
  144.     freeimage();
  145.  
  146.     /* read the stack size */
  147.     ssize = (unsigned int)readptr();
  148.  
  149.     /* allocate memory for the workspace */
  150.     xlminit(ssize);
  151.  
  152.     /* read the *obarray* symbol and various constants */
  153.     obarray = cviptr(readptr());
  154.     eof_object = cviptr(readptr());
  155.     default_object = cviptr(readptr());
  156.     
  157.     /* read each node */
  158.     for (off = (OFFTYPE)2; (type = osbgetc(fp)) >= 0; )
  159.     switch (type) {
  160.     case FREE:
  161.         if ((off = readptr()) == (OFFTYPE)0)
  162.         goto done;
  163.         break;
  164.     case CONS:
  165.     case CLOSURE:
  166.     case METHOD:
  167.     case PROMISE:
  168.     case ENV:
  169.         p = cviptr(off);
  170.         p->n_type = type;
  171.         rplaca(p,cviptr(readptr()));
  172.         rplacd(p,cviptr(readptr()));
  173.         off += sizeof(NODE);
  174.         break;
  175.     case SYMBOL:
  176.     case OBJECT:
  177.     case VECTOR:
  178.     case CODE:
  179.     case CONTINUATION:
  180.         p = cviptr(off);
  181.         p->n_type = type;
  182.         p->n_vsize = size = (int)readptr();
  183.         p->n_vdata = getvspace(p,size);
  184.         for (vp = p->n_vdata; --size >= 0; )
  185.         *vp++ = cviptr(readptr());
  186.         off += sizeof(NODE);
  187.         break;
  188.     case STRING:
  189.         p = cviptr(off);
  190.         p->n_type = type;
  191.         p->n_vsize = size = (int)readptr();
  192.         p->n_vdata = getvspace(p,btow_size(size));
  193.         for (cp = getstring(p); --size >= 0; )
  194.         *cp++ = osbgetc(fp);
  195.         off += sizeof(NODE);
  196.         break;
  197.     case PORT:
  198.         p = cviptr(off);
  199.         readnode(type,p);
  200.         setfile(p,NULL);
  201.         off += sizeof(NODE);
  202.         break;
  203.     case SUBR:
  204.     case XSUBR:
  205.         p = cviptr(off);
  206.         readnode(type,p);
  207.         p->n_subr = funtab[getoffset(p)].fd_subr;
  208.         off += sizeof(NODE);
  209.         break;
  210.     default:
  211.         readnode(type,cviptr(off));
  212.         off += sizeof(NODE);
  213.         break;
  214.     }
  215. done:
  216.  
  217.     /* close the input file */
  218.     osclose(fp);
  219.  
  220.     /* collect to initialize the free space */
  221.     gc();
  222.  
  223.     /* lookup all of the symbols the interpreter uses */
  224.     xlsymbols();
  225.  
  226.     /* return successfully */
  227.     return (TRUE);
  228. }
  229.  
  230. /* freeimage - free the current memory image */
  231. LOCAL freeimage()
  232. {
  233.     NSEGMENT *nextnseg;
  234.     VSEGMENT *nextvseg;
  235.     FILE *fp;
  236.     LVAL p;
  237.     int n;
  238.  
  239.     /* close all open ports and free each node segment */
  240.     for (; nsegments != NULL; nsegments = nextnseg) {
  241.     nextnseg = nsegments->ns_next;
  242.     p = &nsegments->ns_data[0];
  243.     n = nsegments->ns_size;
  244.     for (; --n >= 0; ++p)
  245.         switch (ntype(p)) {
  246.         case PORT:
  247.         if ((fp = getfile(p))
  248.          && (fp != stdin && fp != stdout && fp != stderr))
  249.             osclose(getfile(p));
  250.         break;
  251.         }
  252.     free(nsegments);
  253.     }
  254.  
  255.     /* free each vector segment */
  256.     for (; vsegments != NULL; vsegments = nextvseg) {
  257.     nextvseg = vsegments->vs_next;
  258.     free(vsegments);
  259.     }
  260.     
  261.     /* free the stack */
  262.     if (xlstkbase)
  263.     free(xlstkbase);
  264. }
  265.  
  266. /* setoffset - output a positioning command if nodes have been skipped */
  267. LOCAL setoffset()
  268. {
  269.     if (off != foff) {
  270.     osbputc(FREE,fp);
  271.     writeptr(off);
  272.     foff = off;
  273.     }
  274. }
  275.  
  276. /* writenode - write a node to a file */
  277. LOCAL writenode(node)
  278.   LVAL node;
  279. {
  280.     char *p = (char *)&node->n_info;
  281.     int n = sizeof(union ninfo);
  282.     osbputc(node->n_type,fp);
  283.     while (--n >= 0)
  284.     osbputc(*p++,fp);
  285. }
  286.  
  287. /* writeptr - write a pointer to a file */
  288. LOCAL writeptr(off)
  289.   OFFTYPE off;
  290. {
  291.     char *p = (char *)&off;
  292.     int n = sizeof(OFFTYPE);
  293.     while (--n >= 0)
  294.     osbputc(*p++,fp);
  295. }
  296.  
  297. /* readnode - read a node */
  298. LOCAL readnode(type,node)
  299.   int type; LVAL node;
  300. {
  301.     char *p = (char *)&node->n_info;
  302.     int n = sizeof(union ninfo);
  303.     node->n_type = type;
  304.     while (--n >= 0)
  305.     *p++ = osbgetc(fp);
  306. }
  307.  
  308. /* readptr - read a pointer */
  309. LOCAL OFFTYPE readptr()
  310. {
  311.     OFFTYPE off;
  312.     char *p = (char *)&off;
  313.     int n = sizeof(OFFTYPE);
  314.     while (--n >= 0)
  315.     *p++ = osbgetc(fp);
  316.     return (off);
  317. }
  318.  
  319. /* cviptr - convert a pointer on input */
  320. LOCAL LVAL cviptr(o)
  321.   OFFTYPE o;
  322. {
  323.     NSEGMENT *newnsegment(),*nseg;
  324.     OFFTYPE off = (OFFTYPE)2;
  325.     OFFTYPE nextoff;
  326.  
  327.     /* check for nil and small fixnums */
  328.     if (o == (OFFTYPE)0 || (o & 1) == 1)
  329.     return ((LVAL)o);
  330.  
  331.     /* compute a pointer for this offset */
  332.     for (nseg = nsegments; nseg != NULL; nseg = nseg->ns_next) {
  333.     nextoff = off + (OFFTYPE)(nseg->ns_size * sizeof(NODE));
  334.     if (o >= off && o < nextoff)
  335.         return ((LVAL)((OFFTYPE)&nseg->ns_data[0] + o - off));
  336.     off = nextoff;
  337.     }
  338.  
  339.     /* create new segments if necessary */
  340.     for (;;) {
  341.  
  342.     /* create the next segment */
  343.     if ((nseg = newnsegment(NSSIZE)) == NULL)
  344.         xlfatal("insufficient memory - segment");
  345.  
  346.     /* check to see if the offset is in this segment */
  347.     nextoff = off + (OFFTYPE)(nseg->ns_size * sizeof(NODE));
  348.     if (o >= off && o < nextoff)
  349.         return ((LVAL)((OFFTYPE)&nseg->ns_data[0] + o - off));
  350.     off = nextoff;
  351.     }
  352. }
  353.  
  354. /* cvoptr - convert a pointer on output */
  355. LOCAL OFFTYPE cvoptr(p)
  356.   LVAL p;
  357. {
  358.     OFFTYPE off = (OFFTYPE)2;
  359.     NSEGMENT *nseg;
  360.  
  361.     /* check for nil and small fixnums */
  362.     if (p == NIL || !ispointer(p))
  363.     return ((OFFTYPE)p);
  364.  
  365.     /* compute an offset for this pointer */
  366.     for (nseg = nsegments; nseg != NULL; nseg = nseg->ns_next) {
  367.     if (INSEGMENT(p,nseg))
  368.         return (off + ((OFFTYPE)p - (OFFTYPE)&nseg->ns_data[0]));
  369.     off += (OFFTYPE)(nseg->ns_size * sizeof(NODE));
  370.     }
  371.  
  372.     /* pointer not within any segment */
  373.     xlerror("bad pointer found during image save",p);
  374. }
  375.  
  376. /* getvspace - allocate vector space */
  377. LOCAL LVAL *getvspace(node,size)
  378.   LVAL node; unsigned int size;
  379. {
  380.     LVAL *p;
  381.     ++size; /* space for the back pointer */
  382.     if (!VCOMPARE(vfree,size,vtop)
  383.     &&  !checkvmemory(size)
  384.     &&  !makevmemory(size))
  385.     xlfatal("insufficient vector space");
  386.     p = vfree;
  387.     vfree += size;
  388.     *p++ = node;
  389.     return (p);
  390. }
  391.