home *** CD-ROM | disk | FTP | other *** search
/ Atari FTP / ATARI_FTP_0693.zip / ATARI_FTP_0693 / Languages / xscheme.arc / xsimage.c < prev    next >
C/C++ Source or Header  |  1989-01-29  |  9KB  |  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.     free(xlstkbase);
  263. }
  264.  
  265. /* setoffset - output a positioning command if nodes have been skipped */
  266. LOCAL setoffset()
  267. {
  268.     if (off != foff) {
  269.     osbputc(FREE,fp);
  270.     writeptr(off);
  271.     foff = off;
  272.     }
  273. }
  274.  
  275. /* writenode - write a node to a file */
  276. LOCAL writenode(node)
  277.   LVAL node;
  278. {
  279.     char *p = (char *)&node->n_info;
  280.     int n = sizeof(union ninfo);
  281.     osbputc(node->n_type,fp);
  282.     while (--n >= 0)
  283.     osbputc(*p++,fp);
  284. }
  285.  
  286. /* writeptr - write a pointer to a file */
  287. LOCAL writeptr(off)
  288.   OFFTYPE off;
  289. {
  290.     char *p = (char *)&off;
  291.     int n = sizeof(OFFTYPE);
  292.     while (--n >= 0)
  293.     osbputc(*p++,fp);
  294. }
  295.  
  296. /* readnode - read a node */
  297. LOCAL readnode(type,node)
  298.   int type; LVAL node;
  299. {
  300.     char *p = (char *)&node->n_info;
  301.     int n = sizeof(union ninfo);
  302.     node->n_type = type;
  303.     while (--n >= 0)
  304.     *p++ = osbgetc(fp);
  305. }
  306.  
  307. /* readptr - read a pointer */
  308. LOCAL OFFTYPE readptr()
  309. {
  310.     OFFTYPE off;
  311.     char *p = (char *)&off;
  312.     int n = sizeof(OFFTYPE);
  313.     while (--n >= 0)
  314.     *p++ = osbgetc(fp);
  315.     return (off);
  316. }
  317.  
  318. /* cviptr - convert a pointer on input */
  319. LOCAL LVAL cviptr(o)
  320.   OFFTYPE o;
  321. {
  322.     NSEGMENT *newnsegment(),*nseg;
  323.     OFFTYPE off = (OFFTYPE)2;
  324.     OFFTYPE nextoff;
  325.  
  326.     /* check for nil and small fixnums */
  327.     if (o == (OFFTYPE)0 || (o & 1) == 1)
  328.     return ((LVAL)o);
  329.  
  330.     /* compute a pointer for this offset */
  331.     for (nseg = nsegments; nseg != NULL; nseg = nseg->ns_next) {
  332.     nextoff = off + (OFFTYPE)(nseg->ns_size * sizeof(NODE));
  333.     if (o >= off && o < nextoff)
  334.         return ((LVAL)((OFFTYPE)&nseg->ns_data[0] + o - off));
  335.     off = nextoff;
  336.     }
  337.  
  338.     /* create new segments if necessary */
  339.     for (;;) {
  340.  
  341.     /* create the next segment */
  342.     if ((nseg = newnsegment(NSSIZE)) == NULL)
  343.         xlfatal("insufficient memory - segment");
  344.  
  345.     /* check to see if the offset is in this segment */
  346.     nextoff = off + (OFFTYPE)(nseg->ns_size * sizeof(NODE));
  347.     if (o >= off && o < nextoff)
  348.         return ((LVAL)((OFFTYPE)&nseg->ns_data[0] + o - off));
  349.     off = nextoff;
  350.     }
  351. }
  352.  
  353. /* cvoptr - convert a pointer on output */
  354. LOCAL OFFTYPE cvoptr(p)
  355.   LVAL p;
  356. {
  357.     OFFTYPE off = (OFFTYPE)2;
  358.     NSEGMENT *nseg;
  359.  
  360.     /* check for nil and small fixnums */
  361.     if (p == NIL || !ispointer(p))
  362.     return ((OFFTYPE)p);
  363.  
  364.     /* compute an offset for this pointer */
  365.     for (nseg = nsegments; nseg != NULL; nseg = nseg->ns_next) {
  366.     if (INSEGMENT(p,nseg))
  367.         return (off + ((OFFTYPE)p - (OFFTYPE)&nseg->ns_data[0]));
  368.     off += (OFFTYPE)(nseg->ns_size * sizeof(NODE));
  369.     }
  370.  
  371.     /* pointer not within any segment */
  372.     xlerror("bad pointer found during image save",p);
  373. }
  374.  
  375. /* getvspace - allocate vector space */
  376. LOCAL LVAL *getvspace(node,size)
  377.   LVAL node; unsigned int size;
  378. {
  379.     LVAL *p;
  380.     ++size; /* space for the back pointer */
  381.     if (vfree + size >= vtop) {
  382.     findvmemory(size);
  383.     if (vfree + size >= vtop)
  384.         xlfatal("insufficient vector space");
  385.     }
  386.     p = vfree;
  387.     vfree += size;
  388.     *p++ = node;
  389.     return (p);
  390. }
  391.