home *** CD-ROM | disk | FTP | other *** search
/ Complete Linux / Complete Linux.iso / docs / devel / lisp / kcl_tar.z / kcl_tar / c / fasl_loader.c < prev    next >
Encoding:
C/C++ Source or Header  |  1987-06-04  |  4.6 KB  |  269 lines
  1. /*
  2. (C) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  3. */
  4.  
  5. /*
  6.     fasl_loader.c
  7.     DG-SPECIFIC
  8. */
  9.  
  10. #include "../h/fasl.h"
  11. #include "../h/fasl_global.h"
  12. #include "include.h"
  13.  
  14. #define    ERFDE    025
  15.  
  16. int    debug;
  17.  
  18. #ifdef DGUX
  19. $low32k    short    short_buffer[BUFSIZ];    /* short nrel area buffer */
  20. #endif
  21.  
  22. int
  23. fasl_loader(filename, skip_count, data)
  24. char    *filename;
  25. int    skip_count;
  26. object    data;
  27. {
  28.     char    *alloc_contblock();    /* LISP allocation */
  29.  
  30.     int    ier;
  31.     int    block_type;
  32.     char    *cfun_start;
  33.     int    cfun_length;
  34.     int    m_len;
  35.     object    fasl_obj;
  36. #ifdef DGUX
  37.     char    buff[BUFSIZ];
  38.     char    buff1[BUFSIZ];
  39. #endif
  40.  
  41. #ifdef DGUX
  42.     faslbuff = buff;
  43.     faslbuff1 = buff1;
  44. #endif
  45.  
  46.     ier = fasl_open(filename);
  47. #ifdef AOSVS
  48.     if (ier == ERFDE) return(-1);
  49.     if (ier != 0) sys_emes(ier);
  50. #endif
  51. #ifdef DGUX
  52.     if (ier != 0) return(-1);
  53. #endif
  54.  
  55.     fas_temp_flush = TRUE;
  56.  
  57.     init_pass1();
  58.  
  59. #ifdef AOSVS
  60.     fasl_skip(skip_count);
  61. #endif
  62.  
  63.     for (;;) {
  64.       fasl_nblock();
  65.  
  66.       block_type = (((FAS_HDR_P)fas_buffp) -> hdr_typ) & BLOCK_TYPE;
  67.  
  68.      /* dispatch by block type */
  69.  
  70.       switch(block_type) {
  71.         case DATA_BLOCK:    data_pass1();
  72.                     break;
  73.         case TITL_BLOCK:    titl_pass1();
  74.                     break;
  75.         case EXT_BLOCK:        ext_pass1();
  76.                     break;
  77.         case PAT_BLOCK:        pat_pass1();
  78.                     break;
  79.         case REV_BLOCK:        rev_pass1();
  80.                     break;
  81.         case ALN_BLOCK:        aln_pass1();
  82.                     break;
  83.         case END_BLOCK:
  84.         case ENT_BLOCK:
  85.         case LOCAL_BLOCK:
  86.         case DEBS_BLOCK:
  87.         case DEBL_BLOCK:
  88.         case LTITL_BLOCK:
  89.         case MREV_BLOCK:    break;
  90.         default:        fasl_invalid();
  91.                     break;
  92.         }
  93.  
  94.       if (block_type == END_BLOCK) break;
  95.     }
  96.  
  97. #ifdef AOSVS
  98.     fasl_skip(skip_count);
  99. #endif
  100. #ifdef DGUX
  101.     fasl_rpos();
  102. #endif
  103.  
  104.     check_short_area();
  105.  
  106.     fasl_write_temp();
  107.     fas_temp_flush = FALSE;
  108.     cfun_length = m_len = fasl_len() * 2;    /* to byte length */
  109.     fas_temp_flush = TRUE;
  110.  
  111.     fasl_obj = alloc_object(t_cfun);
  112.     fasl_obj->cf.cf_name = fasl_obj->cf.cf_data = OBJNULL;
  113.     fasl_obj->cf.cf_start = NULL;
  114.     fasl_obj->cf.cf_size = m_len;
  115.     vs_push(fasl_obj);
  116.  
  117.     cfun_start = alloc_contblock(m_len);
  118.     fas_rstart = (short *)cfun_start;
  119.  
  120.     fasl_obj->cf.cf_start = cfun_start;    /* set start addr */
  121.  
  122.     fas_relocation_by_table = FALSE;
  123.  
  124.     fasl_saddr();        /* set actual address */
  125.     fasl_write_temp();    /* be sure all records in file */
  126.  
  127.     /*    watson();    */
  128.  
  129.     fas_temp_flush = FALSE;
  130.  
  131.     for (;;) {
  132.       fasl_nblock();
  133.  
  134.       block_type = (((FAS_HDR_P)fas_buffp) -> hdr_typ) & BLOCK_TYPE;
  135.  
  136.     /* dispatch by block type */
  137.  
  138.       switch(block_type) {
  139.         case DATA_BLOCK:    data_pass2();
  140.                     break;
  141.         case ENT_BLOCK:        ent_pass2();
  142.                     break;
  143.         case TITL_BLOCK:
  144.         case END_BLOCK:
  145.         case EXT_BLOCK:
  146.         case PAT_BLOCK:
  147.         case REV_BLOCK:
  148.         case MREV_BLOCK:
  149.         case ALN_BLOCK:        break;
  150.         default:        fasl_invalid();
  151.                     break;
  152.         }
  153.        if (block_type == END_BLOCK) break;
  154.     }
  155.     fasl_close();
  156.     fasl_close_temp();
  157.  
  158. /*
  159. printf("init addr %o\n", fas_routine_addr);
  160. fflush(stdout);
  161. {
  162. int    i;
  163. for (i = 0; i < m_len / 2; i++)
  164. printf("%o %10o\n", fas_rstart+i, ((unsigned int)fas_rstart[i]) & 0177777);
  165. fflush(stdout);
  166. }
  167. */
  168.     if (fas_routine_addr != 0)
  169.         (*fas_routine_addr)(cfun_start, cfun_length, data);
  170.         else
  171.         FEerror("Init routine not found.", 0);
  172.  
  173. printf("end init routine\n");
  174. fflush(stdout);
  175.     vs_pop;        /* pop dummy string */
  176.     return(m_len);
  177. }
  178.  
  179. #ifdef AOSVS
  180. init_fasl()
  181. {
  182.     fas_stchan = -1;
  183.     init_fasl_io();
  184.     get_pid();
  185.     copypid(fas_temp_name + 1);
  186.  
  187.     sshort(&fas_short_nrel, &fas_short_end);
  188. }
  189. #endif
  190.  
  191. #ifdef DGUX
  192. init_dguxfasl()
  193. {
  194.     init_faslst();
  195.  
  196.     fas_short_nrel = short_buffer;
  197.     fas_short_end = short_buffer + BUFSIZ;
  198. }
  199. #endif
  200.  
  201. /*
  202.     memory saved program initialization.
  203. */
  204. init_fasl1()
  205. {
  206. #ifdef AOSVS
  207.     fas_stchan = -1;
  208.     init_fasl_io();
  209.     get_pid();
  210.     copypid(fas_temp_name + 1);
  211. #endif
  212. }
  213.  
  214. fasl_invalid()
  215. {
  216.     FEerror("Not a LISP object. Can't load.",0);
  217. }
  218.  
  219. fasl_buf_overflow()
  220. {
  221.     FEerror("Internal buffer overflow.", 0);
  222. }
  223.  
  224. fasl_rev_error()
  225. {
  226.     FEerror("Revision unmatch.", 0);
  227. }
  228.  
  229. fasl_undefined(symp)
  230. char    *symp;
  231. {
  232.     char    emess[128];
  233.  
  234.     strcpy(emess, "Undefined symbol : ");
  235.     strcat(emess, symp);
  236.     strcat(emess, ".");
  237.     FEerror(emess, 0);
  238.  
  239. }
  240.  
  241. fasl_align_error()
  242. {
  243.     FEerror("Alignment larger than 1 is not allowed.", 0);
  244. }
  245.  
  246. watson()
  247. {
  248.     PART_TABLE_P    p_table_p;
  249.     int    addr;
  250.     short    i = 0;
  251.  
  252.     printf("\nReport from WATSON :\n");
  253.  
  254.     for (i = 0; i <= max_part_no; i++) {
  255.        part_table_p = fasl_get_table(i);
  256.        addr = fasl_get_addr(i);
  257.  
  258.        printf("\n");
  259.        printf("  number : %o\n", part_table_p -> part_no);
  260.        printf("  length : %o\n", part_table_p -> part_len);
  261.        printf("  addr   : %o  %o\n", part_table_p -> part_addr,
  262.                      addr);
  263.        printf("  align  : %o\n", part_table_p -> part_align);
  264.        printf("  global : %o\n", part_table_p -> part_global);
  265.        printf("  symbol : %o\n", part_table_p -> part_symbol);
  266.        printf("  name   : %s\n", part_table_p -> part_name);
  267.        }
  268. }
  269.