home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / C / FASTLOAD.C < prev    next >
Encoding:
C/C++ Source or Header  |  1993-10-24  |  10.5 KB  |  379 lines
  1. /* FASTLOAD.C
  2.  ************************************************************************
  3.  *                                    *
  4.  *        PC Scheme/Geneva 4.00 Borland C code            *
  5.  *                                    *
  6.  * (c) 1985-1988 by Texas Instruments, Inc. See COPYRIGHT.TXT        *
  7.  * (c) 1992 by L. Bartholdi & M. Vuilleumier, University of Geneva    *
  8.  *                                    *
  9.  *----------------------------------------------------------------------*
  10.  *                                    *
  11.  *        Fast-Load a Module from a Port                *
  12.  *                                    *
  13.  *----------------------------------------------------------------------*
  14.  *                                    *
  15.  * Created by: John Jensen        Date: 1985            *
  16.  * Revision history:                            *
  17.  * - 18 Jun 92:    Renaissance (Borland Compilers, ...)            *
  18.  *                                    *
  19.  *                    ``In nomine omnipotentii dei''    *
  20.  ************************************************************************/
  21.  
  22. #include    <stdlib.h>
  23. #include    <stdio.h>
  24. #include    <ctype.h>
  25. #include    "scheme.h"
  26.  
  27. #define skip_space() while(iswhitespace(sgetc()));
  28.  
  29.                     /* data structures to control file access */
  30. #define NUM_FILES 8            /* the maximum nesting of "%fasl" operations */
  31. #define BUF_LENGTH 4096            /* buffer length for fasl files */
  32. #define READ_ACC 0            /* file access code for "read" */
  33.  
  34. static    char    *buffer;        /* character string buffer */
  35. static    int    chr = 0;        /* the current character */
  36. static    int    file_no = -1;        /* the current file number */
  37. static    char    *file_buffer[NUM_FILES]; /* character buffers */
  38. static    int    file_handle[NUM_FILES];    /* handles for open files */
  39. static    char    *file_pos[NUM_FILES];    /* current position in buffer */
  40. static    int    file_end[NUM_FILES];    /* end of buffer */
  41.  
  42. static char    *f_pos, *f_end;
  43.  
  44. /************************************************************************/
  45. /* Read In a Fast Load Format Object Module                */
  46. /************************************************************************/
  47. int    fasl(REGPTR reg)
  48. {
  49.     char        lcl_buffer[256];
  50.     unsigned    codebytes;
  51.     unsigned    constants;
  52.     unsigned    disp;
  53.     int        i;
  54.     int        len;
  55.     unsigned    page;
  56.     int        retstat = 0;
  57.     int        type;
  58.     unsigned long    dummy;
  59.  
  60.     buffer = lcl_buffer;
  61.     page = CORRPAGE(reg->page);
  62.     disp = reg->disp;
  63.     type = ptype[page];
  64.  
  65.     if (type == STRTYPE) {
  66.         if (file_no >= NUM_FILES - 1) {
  67.             sprintf( buffer, "FAST-LOAD nesting too deep. Maximum is %d", NUM_FILES );
  68.             set_error(1, buffer, &nil_reg );
  69.             reset_fasl();
  70.             retstat = -1;
  71.             goto return_eof;
  72.         }
  73.         len = get_word(page, disp + 1);
  74.         if (len < 0)
  75.             len = len + BLK_OVHD;
  76.         else
  77.             len = len - BLK_OVHD;
  78.         get_str(buffer, page, disp);
  79.         buffer[len] = '\0';
  80.         file_no++;
  81.         if ((i = zopen(&file_handle[file_no], buffer, READ_ACC, &dummy)) != 0) {
  82.             i += IO_ERROR_START;
  83.             alloc_string(&tmp_reg, buffer);
  84.             dos_error(1, i, &tmp_reg);
  85.         }
  86.         if (!(file_pos[file_no] = (file_buffer[file_no] = (char *)
  87.                         malloc(BUF_LENGTH))))
  88.             malloc_error("fasl");
  89.         file_end[file_no] = 0;
  90.     }
  91.     f_pos = file_pos[file_no];
  92.     f_end = file_buffer[file_no] + (file_end[file_no]);
  93.  
  94.     /* read and validate fasl program header; get # constants and codebytes */
  95.     skip_space();
  96.     while (chr == '#') {
  97.         for (i = 0; i < 11; i++)
  98.             if (sgetc() != "!fast-load "[i])
  99.                 goto invalid_fasl;
  100.         while (sgetc() != '\n')    /* do nothing */
  101.             ;
  102.         skip_space();
  103.     }
  104.     if (chr == EOF || chr == CTRL_Z)
  105.         goto close_file;
  106.     if (chr != 'h')
  107.         goto invalid_fasl;
  108.     constants = next_word();
  109.     codebytes = next_word();
  110.  
  111.     /* allocate and zero the code block */
  112.     alloc_block(reg, CODETYPE, constants * sizeof(POINTER) + sizeof(POINTER) + codebytes);
  113.     page = CORRPAGE(reg->page);
  114.     disp = reg->disp;
  115.     zero_blk(page, disp);
  116.     disp += BLK_OVHD;
  117.  
  118.     /* insert the entry point offset */
  119.     put_ptr(page, disp, ADJPAGE(SPECFIX), constants * sizeof(POINTER) + sizeof(POINTER) + BLK_OVHD);
  120.  
  121.     /* process the constants list entries */
  122.     disp = sizeof(POINTER) + BLK_OVHD;
  123.     while (constants--) {
  124.         if (read_constant())
  125.             goto invalid_fasl;
  126.         put_ptr(CORRPAGE(reg->page), reg->disp + disp, tmp_reg.page, tmp_reg.disp);
  127.         disp += sizeof(POINTER);
  128.     }
  129.  
  130.     /* validate the "text" portion header and read in bytecodes */
  131.     skip_space();
  132.     if (chr != 't')
  133.         goto invalid_fasl;
  134.     zap_chars(reg, disp, codebytes);
  135.  
  136.     /* validate the fasl module trailer */
  137.     skip_space();
  138.     if (chr == 'z') {
  139.         file_pos[file_no] = f_pos;
  140.         return    retstat;
  141.     }
  142. invalid_fasl:
  143.     set_error(0, "Invalid FAST-LOAD module", &nil_reg);
  144.     retstat = -1;
  145.  
  146. close_file:
  147.     zclose(file_handle[file_no]);
  148.     free(file_buffer[file_no]);
  149.     file_no--;
  150. return_eof:
  151.     reg->page = ADJPAGE(EOF_PAGE);
  152.     reg->disp = EOF_DISP;
  153.  
  154.     return    retstat;
  155. }
  156.  
  157. /************************************************************************/
  158. /* Read In a Constant Entry                        */
  159. /************************************************************************/
  160. int    read_constant(void)
  161. {
  162.     unsigned    disp;
  163.     int        i;
  164.     int        len;
  165.     unsigned    lpage = 0;    /* page number for a list cell */
  166.     unsigned    page;
  167.  
  168. tail_recursion:
  169.     skip_space();
  170.     switch (chr) {
  171.     case 'x':        /* symbol */
  172.         len = next_byte();
  173.         for (i = 0; i < len; i++)
  174.             buffer[i] = sgetc();
  175.         intern(&tmp_reg, buffer, len);
  176.         break;
  177.  
  178.     case 'i':        /* short integer constant */
  179.         tmp_reg.page = ADJPAGE(SPECFIX);
  180.         tmp_reg.disp = next_word();
  181.         break;
  182.  
  183.     case 'l':        /* list cell */
  184.         if (nextcell[listpage] != END_LIST) {
  185.             tmp_reg.page = ADJPAGE(listpage);
  186.             tmp_reg.disp = nextcell[listpage];
  187.             nextcell[listpage] = get_word(listpage, tmp_reg.disp + 1);
  188.         } else
  189.             alloc_list_cell(&tmp_reg);
  190.         toblock(&tmp_reg, 0, &nil_reg, sizeof(LIST));
  191.         if (lpage) {    /* we're building a linked list-- update previous cdr */
  192.             c_pop(&tm2_reg);
  193.             put_ptr((lpage = CORRPAGE(tm2_reg.page)), tm2_reg.disp + 3, tmp_reg.page, tmp_reg.disp);
  194.         } else {    /* starting a list-- preserve list header pointer */
  195.             c_push(&tmp_reg);
  196.         }
  197.         c_push(&tmp_reg);/* record this list cell's location */
  198.         checkstack();
  199.         if(read_constant())
  200.             return    1;
  201.         put_ptr(lpage = CORRPAGE(s_stack[topofstack / sizeof(POINTER)].page),
  202.             s_stack[topofstack / sizeof(POINTER)].disp, tmp_reg.page, tmp_reg.disp);
  203.         goto tail_recursion;
  204.  
  205.     case 'n':
  206.         tmp_reg = nil_reg;
  207.         break;
  208.  
  209.     case 's':        /* string constant */
  210.         len = next_word();
  211.         alloc_block(&tmp_reg, STRTYPE, len);
  212.         zap_chars(&tmp_reg, 3, len);
  213.         break;
  214.  
  215.     case 'c':        /* character constant */
  216.         tmp_reg.page = ADJPAGE(SPECCHAR);
  217.         tmp_reg.disp = next_byte();
  218.         break;
  219.  
  220.     case 'b':        /* bignum constant */
  221.     {
  222.         SCHEMEOBJ    o;
  223.  
  224.         len = next_byte();
  225.         alloc_block(&tmp_reg, BIGTYPE, 2*len + 1);
  226.         o = reg2c(&tmp_reg);
  227.         o->bignum.data.sign = next_byte();
  228.         for( int i = 0; i < len; i++ )
  229.             o->bignum.data.data[i] = next_word();
  230.         break;
  231.     }
  232.     case 'f':        /* flonum constant */
  233.         alloc_flonum(&tmp_reg, next_flonum());
  234.         break;
  235.  
  236.     case 'v':        /* vector */
  237.         len = next_word();
  238.         alloc_block( &tm2_reg, VECTTYPE, 3*len );
  239.         zero_blk( CORRPAGE(tm2_reg.page), tm2_reg.disp );
  240.         checkstack();
  241.         for( i = 0; i < len; i++ )
  242.         {
  243.             SCHEMEOBJ    o;
  244.  
  245.             c_push(&tm2_reg);    /* save pointer to vector object */
  246.             if(read_constant())    /* read next vector entry */
  247.                 return    1;
  248.             c_pop(&tm2_reg);    /* restore pointer to vector object */
  249.             
  250.             o = reg2c(&tm2_reg);
  251.             o->vector.data[i].page = tmp_reg.page;
  252.             o->vector.data[i].disp = tmp_reg.disp;
  253.         }
  254.         tmp_reg = tm2_reg;
  255.         break;
  256.  
  257.     case 'm':    /* machine language */
  258.     {
  259.         SCHEMEOBJ    o;
  260.  
  261.         len = next_word();
  262.         alloc_block( &tmp_reg, I86TYPE, len );
  263.         o = reg2c(&tmp_reg);
  264.  
  265.         for( i = 0; i < len; i++ )
  266.             o->i86block.data[i] = sgetc();
  267.         break;
  268.     }
  269.  
  270.     default:
  271.         zprintf("read_constant:    invalid constant tag '%c'\n", chr);
  272.         return    1;
  273.     }
  274.  
  275.     /* if we're filling in the last cdr field of a linked list, fix it up */
  276.     if (lpage) {
  277.         c_pop(&tm2_reg);
  278.         put_ptr(CORRPAGE(tm2_reg.page), tm2_reg.disp + sizeof(POINTER),
  279.             tmp_reg.page, tmp_reg.disp);
  280.         c_pop(&tmp_reg);    /* restore list header pointer */
  281.     }
  282.     return    0;
  283. }
  284.  
  285. /************************************************************************/
  286. /* Read In a Hexadecimal Byte                        */
  287. /************************************************************************/
  288. unsigned char    next_byte(void)
  289. {
  290.     unsigned    low, high;
  291.  
  292.     skip_space();
  293.     high = (chr <= '9' ? chr - '0' : chr - 'A' + 10);
  294.     sgetc();
  295.     low = (chr <= '9' ? chr - '0' : chr - 'A' + 10);
  296.  
  297.     return    (high << 4) | low;
  298. }
  299.  
  300. /************************************************************************/
  301. /* Read In a Hexadecimal Word                        */
  302. /************************************************************************/
  303. unsigned    next_word(void)
  304. {
  305.     int    highword = next_byte() << 8;
  306.     return    (highword | next_byte());
  307. }
  308.  
  309. /************************************************************************/
  310. /* Read In a Floating Point Value                    */
  311. /************************************************************************/
  312. double    next_flonum(void)
  313. {
  314.     unsigned    flo_parts[4];    /* "words" comprising a floating point value */
  315.     int        i;
  316.  
  317.     /* read in the four words comprising a floating point constant */
  318.     for (i = 0; i < 4; i++)
  319.         flo_parts[i] = next_word();
  320.  
  321.     /* convert "parts" of floating point value to a true floating point number */
  322.  
  323.     return (*((double *) flo_parts));
  324. }
  325.  
  326. /************************************************************************/
  327. /* Read Character From Current Input File                */
  328. /************************************************************************/
  329. char    sgetc(void)
  330. {
  331.     int    stat;
  332.  
  333.     if (f_pos >= f_end) {
  334.         file_end[file_no] = BUF_LENGTH;
  335.         if ((stat = zread(file_handle[file_no], file_buffer[file_no],
  336.                     &file_end[file_no])) != 0) {
  337.             zprintf("[VM INTERNAL ERROR] sfasl: read error status=%d\n", stat);
  338.         }
  339.         if ((f_pos = file_buffer[file_no]) >= (f_end = f_pos + file_end[file_no])) {
  340.             return    chr = EOF;
  341.         }
  342.     }
  343.     return    chr = *f_pos++;
  344. }
  345.  
  346. /************************************************************************/
  347. /* Copy Block of Characters from Input Buffer to Scheme Block        */
  348. /************************************************************************/
  349. void    zap_chars(REGPTR ptr, unsigned offset, unsigned len)
  350. {
  351.     int    actual;    /* the number of characters transfered in one move */
  352.  
  353.     while (len) {
  354.         if (f_pos >= f_end) {
  355.             sgetc();
  356.             f_pos--;
  357.         }
  358.         actual = f_end - f_pos;
  359.         if (len < actual)
  360.             actual = len;
  361.         toblock(ptr, offset, f_pos, actual);
  362.         len -= actual;
  363.         offset += actual;
  364.         f_pos += actual;
  365.     }
  366. }
  367.  
  368. /************************************************************************/
  369. /* Reset Fasl Data Structures                        */
  370. /************************************************************************/
  371. void    reset_fasl(void)
  372. {
  373.     while (file_no >= 0) {
  374.         zclose(file_handle[file_no]);
  375.         free(file_buffer[file_no]);
  376.         file_no--;
  377.     }
  378. }
  379.