home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / 32XLISP.ZIP / XLIMAGE.C < prev    next >
Text File  |  1988-09-17  |  9KB  |  381 lines
  1. /* xlimage - xlisp memory image save/restore functions */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xlisp.h"
  7.  
  8. #ifdef SAVERESTORE
  9.  
  10. /* external variables */
  11. extern LVAL obarray,xlenv,xlfenv,xldenv,s_gchook,s_gcflag;
  12. extern long nnodes,nfree,total;
  13. extern int anodes,nsegs,gccalls;
  14. extern struct segment *segs,*lastseg,*fixseg,*charseg;
  15. extern CONTEXT *xlcontext;
  16. extern LVAL fnodes;
  17.  
  18. /* local variables */
  19. static OFFTYPE off,foff,doff;
  20. static FILE *fp;
  21.  
  22. /* external procedures */
  23. extern SEGMENT *newsegment();
  24. extern FILE *osbopen();
  25. extern char *malloc();
  26.  
  27. /* forward declarations */
  28. OFFTYPE readptr();
  29. OFFTYPE cvoptr();
  30. LVAL cviptr();
  31.  
  32. /* xlisave - save the memory image */
  33. int xlisave(fname)
  34.   char *fname;
  35. {
  36.     char fullname[STRMAX+1];
  37.     unsigned char *cp;
  38.     SEGMENT *seg;
  39.     int n,i,max;
  40.     LVAL p;
  41.  
  42.     /* default the extension */
  43.     if (needsextension(fname)) {
  44.     strcpy(fullname,fname);
  45.     strcat(fullname,".wks");
  46.     fname = fullname;
  47.     }
  48.  
  49.     /* open the output file */
  50.     if ((fp = osbopen(fname,"w")) == NULL)
  51.     return (FALSE);
  52.  
  53.     /* first call the garbage collector to clean up memory */
  54.     gc();
  55.  
  56.     /* write out the pointer to the *obarray* symbol */
  57.     writeptr(cvoptr(obarray));
  58.  
  59.     /* setup the initial file offsets */
  60.     off = foff = (OFFTYPE)2;
  61.  
  62.     /* write out all nodes that are still in use */
  63.     for (seg = segs; seg != NULL; seg = seg->sg_next) {
  64.     p = &seg->sg_nodes[0];
  65.     for (n = seg->sg_size; --n >= 0; ++p, off += 2)
  66.         switch (ntype(p)) {
  67.         case FREE:
  68.         break;
  69.         case CONS:
  70.         case USTREAM:
  71.         setoffset();
  72.         osbputc(p->n_type,fp);
  73.         writeptr(cvoptr(car(p)));
  74.         writeptr(cvoptr(cdr(p)));
  75.         foff += 2;
  76.         break;
  77.         default:
  78.         setoffset();
  79.         writenode(p);
  80.         break;
  81.         }
  82.     }
  83.  
  84.     /* write the terminator */
  85.     osbputc(FREE,fp);
  86.     writeptr((OFFTYPE)0);
  87.  
  88.     /* write out data portion of vector-like nodes */
  89.     for (seg = segs; seg != NULL; seg = seg->sg_next) {
  90.     p = &seg->sg_nodes[0];
  91.     for (n = seg->sg_size; --n >= 0; ++p)
  92.         switch (ntype(p)) {
  93.         case SYMBOL:
  94.         case OBJECT:
  95.         case VECTOR:
  96.         case CLOSURE:
  97.         case STRUCT:
  98.         max = getsize(p);
  99.         for (i = 0; i < max; ++i)
  100.             writeptr(cvoptr(getelement(p,i)));
  101.         break;
  102.         case STRING:
  103.         max = getslength(p);
  104.         for (cp = getstring(p); --max >= 0; )
  105.             osbputc(*cp++,fp);
  106.         break;
  107.         }
  108.     }
  109.  
  110.     /* close the output file */
  111.     osclose(fp);
  112.  
  113.     /* return successfully */
  114.     return (TRUE);
  115. }
  116.  
  117. /* xlirestore - restore a saved memory image */
  118. int xlirestore(fname)
  119.   char *fname;
  120. {
  121.     extern FUNDEF funtab[];
  122.     char fullname[STRMAX+1];
  123.     unsigned char *cp;
  124.     int n,i,max,type;
  125.     SEGMENT *seg;
  126.     LVAL p;
  127.  
  128.     /* default the extension */
  129.     if (needsextension(fname)) {
  130.     strcpy(fullname,fname);
  131.     strcat(fullname,".wks");
  132.     fname = fullname;
  133.     }
  134.  
  135.     /* open the file */
  136.     if ((fp = osbopen(fname,"r")) == NULL)
  137.     return (FALSE);
  138.  
  139.     /* free the old memory image */
  140.     freeimage();
  141.  
  142.     /* initialize */
  143.     off = (OFFTYPE)2;
  144.     total = nnodes = nfree = 0L;
  145.     fnodes = NIL;
  146.     segs = lastseg = NULL;
  147.     nsegs = gccalls = 0;
  148.     xlenv = xlfenv = xldenv = s_gchook = s_gcflag = NIL;
  149.     xlstack = xlstkbase + EDEPTH;
  150.     xlcontext = NULL;
  151.  
  152.     /* create the fixnum segment */
  153.     if ((fixseg = newsegment(SFIXSIZE)) == NULL)
  154.     xlfatal("insufficient memory - fixnum segment");
  155.  
  156.     /* create the character segment */
  157.     if ((charseg = newsegment(CHARSIZE)) == NULL)
  158.     xlfatal("insufficient memory - character segment");
  159.  
  160.     /* read the pointer to the *obarray* symbol */
  161.     obarray = cviptr(readptr());
  162.  
  163.     /* read each node */
  164.     while ((type = osbgetc(fp)) >= 0)
  165.     switch (type) {
  166.     case FREE:
  167.         if ((off = readptr()) == (OFFTYPE)0)
  168.         goto done;
  169.         break;
  170.     case CONS:
  171.     case USTREAM:
  172.         p = cviptr(off);
  173.         p->n_type = type;
  174.         p->n_flags = 0;
  175.         rplaca(p,cviptr(readptr()));
  176.         rplacd(p,cviptr(readptr()));
  177.         off += 2;
  178.         break;
  179.     default:
  180.         readnode(type,cviptr(off));
  181.         off += 2;
  182.         break;
  183.     }
  184. done:
  185.  
  186.     /* read the data portion of vector-like nodes */
  187.     for (seg = segs; seg != NULL; seg = seg->sg_next) {
  188.     p = &seg->sg_nodes[0];
  189.     for (n = seg->sg_size; --n >= 0; ++p)
  190.         switch (ntype(p)) {
  191.         case SYMBOL:
  192.         case OBJECT:
  193.         case VECTOR:
  194.         case CLOSURE:
  195.         case STRUCT:
  196.         max = getsize(p);
  197.         if ((p->n_vdata = (LVAL *)malloc(max * sizeof(LVAL))) == NULL)
  198.             xlfatal("insufficient memory - vector");
  199.         total += (long)(max * sizeof(LVAL));
  200.         for (i = 0; i < max; ++i)
  201.             setelement(p,i,cviptr(readptr()));
  202.         break;
  203.         case STRING:
  204.         max = getslength(p);
  205.         if ((p->n_string = (unsigned char *)malloc(max)) == NULL)
  206.             xlfatal("insufficient memory - string");
  207.         total += (long)max;
  208.         for (cp = getstring(p); --max >= 0; )
  209.             *cp++ = osbgetc(fp);
  210.         break;
  211.         case STREAM:
  212.         setfile(p,NULL);
  213.         break;
  214.         case SUBR:
  215.         case FSUBR:
  216.         p->n_subr = funtab[getoffset(p)].fd_subr;
  217.         break;
  218.         }
  219.     }
  220.  
  221.     /* close the input file */
  222.     osclose(fp);
  223.  
  224.     /* collect to initialize the free space */
  225.     gc();
  226.  
  227.     /* lookup all of the symbols the interpreter uses */
  228.     xlsymbols();
  229.  
  230.     /* return successfully */
  231.     return (TRUE);
  232. }
  233.  
  234. /* freeimage - free the current memory image */
  235. LOCAL freeimage()
  236. {
  237.     SEGMENT *seg,*next;
  238.     FILE *fp;
  239.     LVAL p;
  240.     int n;
  241.  
  242.     /* free the data portion of vector-like nodes */
  243.     for (seg = segs; seg != NULL; seg = next) {
  244.     p = &seg->sg_nodes[0];
  245.     for (n = seg->sg_size; --n >= 0; ++p)
  246.         switch (ntype(p)) {
  247.         case SYMBOL:
  248.         case OBJECT:
  249.         case VECTOR:
  250.         case CLOSURE:
  251.         case STRUCT:
  252.         if (p->n_vsize)
  253.             free(p->n_vdata);
  254.         break;
  255.         case STRING:
  256.         if (getslength(p))
  257.             free(getstring(p));
  258.         break;
  259.         case STREAM:
  260.         if ((fp = getfile(p)) && (fp != stdin && fp != stdout))
  261.             osclose(getfile(p));
  262.         break;
  263.         }
  264.     next = seg->sg_next;
  265.     free(seg);
  266.     }
  267. }
  268.  
  269. /* setoffset - output a positioning command if nodes have been skipped */
  270. LOCAL setoffset()
  271. {
  272.     if (off != foff) {
  273.     osbputc(FREE,fp);
  274.     writeptr(off);
  275.     foff = off;
  276.     }
  277. }
  278.  
  279. /* writenode - write a node to a file */
  280. LOCAL writenode(node)
  281.   LVAL node;
  282. {
  283.     char *p = (char *)&node->n_info;
  284.     int n = sizeof(union ninfo);
  285.     osbputc(node->n_type,fp);
  286.     while (--n >= 0)
  287.     osbputc(*p++,fp);
  288.     foff += 2;
  289. }
  290.  
  291. /* writeptr - write a pointer to a file */
  292. LOCAL writeptr(off)
  293.   OFFTYPE off;
  294. {
  295.     char *p = (char *)&off;
  296.     int n = sizeof(OFFTYPE);
  297.     while (--n >= 0)
  298.     osbputc(*p++,fp);
  299. }
  300.  
  301. /* readnode - read a node */
  302. LOCAL readnode(type,node)
  303.   int type; LVAL node;
  304. {
  305.     char *p = (char *)&node->n_info;
  306.     int n = sizeof(union ninfo);
  307.     node->n_type = type;
  308.     node->n_flags = 0;
  309.     while (--n >= 0)
  310.     *p++ = osbgetc(fp);
  311. }
  312.  
  313. /* readptr - read a pointer */
  314. LOCAL OFFTYPE readptr()
  315. {
  316.     OFFTYPE off;
  317.     char *p = (char *)&off;
  318.     int n = sizeof(OFFTYPE);
  319.     while (--n >= 0)
  320.     *p++ = osbgetc(fp);
  321.     return (off);
  322. }
  323.  
  324. /* cviptr - convert a pointer on input */
  325. LOCAL LVAL cviptr(o)
  326.   OFFTYPE o;
  327. {
  328.     OFFTYPE off = (OFFTYPE)2;
  329.     SEGMENT *seg;
  330.  
  331.     /* check for nil */
  332.     if (o == (OFFTYPE)0)
  333.     return ((LVAL)o);
  334.  
  335.     /* compute a pointer for this offset */
  336.     for (seg = segs; seg != NULL; seg = seg->sg_next) {
  337.     if (o >= off && o < off + (OFFTYPE)(seg->sg_size << 1))
  338.         return (seg->sg_nodes + ((int)(o - off) >> 1));
  339.     off += (OFFTYPE)(seg->sg_size << 1);
  340.     }
  341.  
  342.     /* create new segments if necessary */
  343.     for (;;) {
  344.  
  345.     /* create the next segment */
  346.     if ((seg = newsegment(anodes)) == NULL)
  347.         xlfatal("insufficient memory - segment");
  348.  
  349.     /* check to see if the offset is in this segment */
  350.     if (o >= off && o < off + (OFFTYPE)(seg->sg_size << 1))
  351.         return (seg->sg_nodes + ((int)(o - off) >> 1));
  352.     off += (OFFTYPE)(seg->sg_size << 1);
  353.     }
  354. }
  355.  
  356. /* cvoptr - convert a pointer on output */
  357. LOCAL OFFTYPE cvoptr(p)
  358.   LVAL p;
  359. {
  360.     OFFTYPE off = (OFFTYPE)2;
  361.     SEGMENT *seg;
  362.  
  363.     /* check for nil and small fixnums */
  364.     if (p == NIL)
  365.     return ((OFFTYPE)p);
  366.  
  367.     /* compute an offset for this pointer */
  368.     for (seg = segs; seg != NULL; seg = seg->sg_next) {
  369.     if (CVPTR(p) >= CVPTR(&seg->sg_nodes[0]) &&
  370.         CVPTR(p) <  CVPTR(&seg->sg_nodes[0] + seg->sg_size))
  371.         return (off + (OFFTYPE)((p - seg->sg_nodes) << 1));
  372.     off += (OFFTYPE)(seg->sg_size << 1);
  373.     }
  374.  
  375.     /* pointer not within any segment */
  376.     xlerror("bad pointer found during image save",p);
  377. }
  378.  
  379. #endif
  380.  
  381.