/*                                                      =====> MAKE_FSL.C    */
/* TIPC Scheme Runtime Support - Conversion To Fast Load Format
   (C) Copyright 1984,1985,1987 by Texas Instruments Incorporated.
   All rights reserved.

   Author:  John C. Jensen
   Installation:  Texas Instruments Incorporated, Dallas, Texas
   Division:  Central Research Laboratories
   Cost Center:  Computer Science Laboratory
   Project:  Computer Architecture Branch
   Date Written:  27 December 1984
   Last Modification:  17 October 1985

   Purpose:  To convert PC Scheme object programs into a fast-load format.

   Description:  Object programs are read in by the make_fsl utility and an
                 equivalent fast-load representation is output.  This utility
                 preforms similarly to the Scheme reader, but it understands
                 only enough about s-expressions to read in valid object
                 programs in a standard format.  Any error condition will
                 abort the exectution of this utility.

                 The format of the object module which can be read by
                 this utility is:

     (execute (quote (pcs-code-block #consts #codebytes (constants) (code))))

                where pcs-code-block is a compiler generated tag indicating
                                 that this is an object module.
                      #consts    is an integer value indicating the number of
                                 source contants in the compiled program.
                                 This is the number of entries in the
                                 "constants" list (see below).
                      #codebytes is an integer value indicating the number
                                 of bytes of executable code in the compiled
                                 program.  This is the number of entries in
                                 the "code" list (see below).
                      (constants) is a list of program constants.  Each
                                 constant is a Scheme s-expression in its
                                 ASCII source representation.
                      (code)     is a list of integer values representing the
                                 executable code of the compiled program.

   Invocation:  The MAKE_FSL utility is executed by entering the following
                command to MS-DOS:

                        MAKE_FSL  PROGRAM.SO  PROGRAM.FSL {/copyright}

                where PROGRAM.SO  is a valid MS-DOS file name of a file
                                  containing the object program (the output
                                  of the PC Scheme compiler),

                      PROGRAM.FSL is a valid MS-DOS file name of the file
                                  which is to contain the fast-load
                                  representation produced by this utility.

                      /copyright  is an optional flag which indicates that,
                                  instead of the standard fast-load module
                                  header record, a TI copyright notice is
                                  to be inserted in the output file.

   Note:  The /copyright option is an undocumented feature designed to
          add some measure of protection for TI proprietary software.  This
          capability is not intended to be visible to the general user
          community and is not documented in any of the messages produced
          by this utility.

   Modification History:
          02 Feb 86 - Made two changes which corrected problems in reading
                      symbols containing backslash characters. According to
                      the Common Lisp standard, a backslash is an escape
                      character, which causes the character following it to
                      be accepted as part of the symbol.
    rb    15 Oct 86 - changed %x to %X; fasl expects uppercase and Lattice C
                      now distinguishes the two printf formats
*/
#include "stdio.h"
#include "ctype.h"

#include "schars.h"     /* copy in special character definitions */

#define MAX_STRING_LENGTH 8192  /* maximum string length */

#define TRUE 1
#define FALSE 0
#define skip_space() ch=fgetc(in_file); while(isspace(ch))ch=fgetc(in_file);

static FILE *in_file, *out_file;        /* input/output file pointers */
static int count = 0;           /* count of characters in current record */

static char *month[12] = {"Jan","Feb","Mar","Apr","May","Jun",
                          "Jul","Aug","Sep","Oct","Nov","Dec"};

int _stack = 12288;     /* Increase Lattice C's default stack size */

int _fmode = 0;         /* default files to text mode translation */

char *getmem();         /* Lattice C's memory allocation routine */

main(argc, argv)
int argc;               /* number of arguments */
char *argv[];           /* array of ptrs to arg strings */
 {
  int cflag = FALSE;            /* copyright notice flag */
  int ch;                       /* current character */
  int codebytes = 0;            /* number of codebytes */
  int constants = 0;            /* number of constants */
  int date[3];                  /* array to receive current date */
  int module = 0;               /* module count */
  int n;                        /* number of fields read */
  int time[4];                  /* array to receive current time */
  static char *invalid_module = "***Error-- Invalid Object Module***\n%s\n";

  /* Print Welcome to Scheme */
  printf("\nFast-Load Conversion Utility for PC Scheme\n%s%s%s\n",
           "         Version 3.03  7 June 88\n",
           " (C) Copyright 1987 by Texas Instruments\n",
           "           All Rights Reserved.\n");

  /* test for generation of copyright notice */
  if (argc == 4)
   {
    if (!strcmp(argv[3], "/copyright"))
     {
      cflag = TRUE;
      argc = 3;
     }
   }

  /* test for proper number of arguments */
  if (argc != 3)
   {
    printf("***Error-- Wrong Number of Arguments to MAKE_FSL***\n");
describe:
    printf("\nMAKE_FSL expects two file names as follows:\n\n%s%s%s%s%s",
   "     MAKE_FSL  PROGRAM.SO  PROGRAM.FSL\n\n",
   "where PROGRAM.SO  is the output of the 'compile-file' function of",
   "                  the PC Scheme Compiler\n",
   "      PROGRAM.FSL is the name of the file which is to contain the\n",
   "                  output of the MAKE_FSL utility.\n");
    exit();
   }

  /* open input file */
  _fmode = 0x8000;      /* make files use binary (untranslated) output */
  if (!(in_file = fopen(argv[1], "r")))
   {
    printf("***Error-- Unable to Open Input File '%s'***\n", argv[1]);
    goto describe;
   }

  /* open output file */
  if (!(out_file = fopen(argv[2], "w")))
   {
    printf("***Error-- Unable to Open Output File '%s'***\n", argv[2]);
    goto describe;
   }
  _fmode = 0;           /* reset to text mode translation */

  /* obtain current time and date */
  get_date(date);

  /* Output header record(s) to output file */
  if (cflag)
   {
    /* Output TI Copyright notice */
    fprintf(out_file,
        "#!fast-load  (C) Copyright %4d by Texas Instruments\r\n%s",date[2],
        "#!fast-load            All Rights Reserved.\r\n");
   }
  else
   {
    /* Output module header to output file */
    get_time(time);
fprintf(out_file, "#!fast-load  Version 3.0  %2d %s %2d  %02d:%02d:%02d\r\n",
        date[1], month[date[0]-1], date[2]-1900, time[0], time[1], time[2]);
   }

  /* read 'til end-of-file */
  skip_space();
  while (ch != EOF && ch != '\032')
   {
    /* read (skip over) object module "header" */
    n = -1;
    if (ch != '(') goto oops_header;
    ch = fgetc(in_file);
    if (ch == '%') ch = fgetc(in_file);  /* "optional" % in front of execute */
    for (n = 0; n < 30; n++)
     {
      ch = tolower(ch);
      if (ch != "execute (quote (pcs-code-block "[n])
       {
oops_header:
        printf(invalid_module, "Bad Module Header");
        printf("n = %d    ch = '%c'\n", n, ch);
        exit();
       }
      ch = fgetc(in_file);
     }

    /* read number of constants, number of code bytes */
    fscanf(in_file, "%d %d", &constants, &codebytes);
    fprintf(out_file, "h%04X %04X\r\n", constants, codebytes);

    /* skip over '(' which begins constants list */
    skip_space();
    if (ch != '(')
     {
      if (constants || ch != 'n' || (ch = fgetc(in_file)) != 'i' ||
                                    (ch = fgetc(in_file)) != 'l')
       {
        printf (invalid_module, "Bad Start of Constants List");
        printf("ch = '%c'\n", ch);
        exit();
       }
      else goto good_const;
     }

    /* read and output constants */
    for (n = 0; n < constants; n++)
     {
      count = 0;
      process_constant();
      fprintf(out_file, "\r\n");
     }

    /* make sure constants list was exhausted */
    skip_space();
    if (ch != ')')
     {
      printf (invalid_module, "Bad End of Constants List");
      printf("ch = '%c'\n", ch);
      exit();
     }
good_const:
    /* output start of code bytes */
    fputc('t', out_file);

    /* read and format code bytes */
    skip_space();
    if (ch != '(')
     {
      printf(invalid_module,"Bad Start of Codebytes");
      printf("Looking For '('\n");
      exit();
     }

    for (count = n = 0; n < codebytes; n++)
     {
      fscanf(in_file, "%d", &ch);
      fprintf(out_file, "%c", (ch & 0x00ff));
count++;
/*    if (count++ == 34)
       {
        fprintf(out_file, "\r\n");
        count = 0;
       } */
     }
    if (count) fprintf(out_file, "\r\n");  /* complete last text record */

    /* flush closing parenthesis from program's end */
    for (n = 0; n < 4; n++)
     {
      skip_space();
      if (ch != ')')
       {
        printf(invalid_module,"Closing Parenthesis");
        exit();
       }
     }

    /* write trailer record for object program */
    fprintf(out_file, "z\r\n");
    printf("module %d complete\n", module++);

    /* skip over white space at end of program */
    skip_space();
  }

  /* close the input and output files */
  if (fclose(in_file)) printf("***Error Closing Input File***\n");
  if (fclose(out_file)) printf("***Error Closing Output File***\n");

 } /* end of function:  main(argc, argv) */

/************************************************************************/
/*                      Process Constant List Entry                     */
/************************************************************************/
process_constant()
 {
  int big_parts[2];     /* the two words of a 32-bit bignum value */
  char buffer[300];     /* input buffer */
  int ch;               /* the current character */
  char *ch_buffer;      /* character string buffer (dynamic) */
  double flonum;        /* a floating point value */
  int flo_parts[4];     /* the four words of a floating point value */
  int i,j;              /* our old favorite index variables */
  int n;                /* character count */
  int sign;             /* sign flag for integer values */
  long value;           /* accumulator for integer values */
  int  vect_count;      /* number of entries in a vector */
  long vect_end;        /* ending offset in out_file for a vector */
  long vect_start;      /* starting offset in out_file for a vector */

  long ftell();         /* returns the current position of a file */

  /* if current constant entry is "long enough", break this record */
  if (count > 72)
   {
    fprintf(out_file, "\r\n");
    count = 0;
   }

  /* skip over white space in front of constant */
  skip_space();

  /* make an initial attempt to decide the constant's type */
  switch (ch)
   {
    case '"':  /* the beginnings of a character string */
               if (!(ch_buffer = getmem(MAX_STRING_LENGTH)))
                {
                 printf("***Error-- Memory Exhausted***\n");
                 exit();
                }
               n = 0;
               do {
                   ch = fgetc(in_file);
                   if (ch != '\r')
                    {
                     if (ch == '\\')
                      {
                       ch_buffer[n++] = fgetc(in_file);
                      }
                     else
                      {
                       ch_buffer[n++] = ch;
                      }
                    }
                  } while (ch != '"');
               n--; /* decrement to remove the closing '"' */
               if (n > MAX_STRING_LENGTH)
                {
                 printf("***Error-- String Too Long***\n%s",
                        "MAKE_FSL limits strings to %d characters\n",
                        MAX_STRING_LENGTH);
                 exit();
                }
               fprintf(out_file, "s%04X", n);
               for (i = 0; i < n; i++) fputc(ch_buffer[i], out_file);
               count += (n + 3);
               if (rlsmem(ch_buffer, MAX_STRING_LENGTH))
                {
                 printf("***Warning-- Release Memory Error***\n");
                }
               break;

    case '(':  /* begin a list */
               ch = fgetc(in_file);
               if (ch == ')')
                { /* empty list found-- output "nil" */
                 fputc('n', out_file);
                 count++;
                 goto blow_this_place;
                }
               else
                {
nuther_list:
                 ungetc(ch, in_file);
                 fputc('l', out_file);
                 count++;
                 process_constant();
                 skip_space();
                 if (ch == ')')
                  {
                   fputc('n', out_file);
                   count++;
                   goto blow_this_place;
                  }
                 else
                  {
                   if (ch == '.')
                    {
                     ch = fgetc(in_file);
                     if (!isspace(ch))
                      {
                       /* character after '.'-- it's a symbol */
                       ungetc(ch, in_file);
                       ch = '.';
                       goto nuther_list;
                      }
                     process_constant();
                     skip_space();
                     if (ch != ')')
                      {
                       printf("***Error-- Invalid List Constant (cdr)***\n");
                       exit();
                      }
                     goto blow_this_place;
                    }
                   else goto nuther_list;
                  }
                }


    case '|':  /* a special slashified symbol */
               n = 0;
               do {
                   ch = fgetc(in_file);
                   if (ch == '\\') ch = fgetc(in_file);    /*** 2/14/86 ***/
                   if (ch != '\r')
                    {
                     if (ch == '|')
                      {
                       if (n > 0x00ff)
                        {
                         printf("***Error-- Symbol Too Long***\n%s",
                                "MAKE_FSL limits symbols to 255 characters\n");
                         exit();
                        }
                       fprintf(out_file, "x%02X", n);
                       for (i = 0; i < n; i++) fputc(buffer[i], out_file);
                       count += (n+3);
                       goto blow_this_place;
                      }
                     buffer[n++] = ch;
                    }
                  } while (TRUE);

    case '#':  /* special constants (we hope) */
               n = 0;
               buffer[n++] = ch;
               ch = fgetc(in_file);
               switch(ch)
                {
                 case '\\':  /* character constant */
                             buffer[n++] = ch;  /* store '\' */
                             ch = fgetc(in_file);
                             buffer[n++] = ch;  /* store 1st character */
                             ch = fgetc(in_file);
                             while ((!isspace(ch)) && ch != ')')
                              {
                               buffer[n++] = ch;
                               ch = fgetc(in_file);
                              }
                             if (ch == ')') ungetc(ch, in_file);
                             if (n == 3)
                              {
                               fprintf(out_file, "c%02X", buffer[2]);
                               count += 3;
                              }
                             else
                              { /* test for a multi-character character */
                               buffer[n] = '\0';
                               for (j = 0; j < test_num; j++)
                                {
                                 if (!strcmp(buffer+2, test_string[j]))
                                  {
                                   fprintf(out_file, "c%02X", test_char[j]);
                                   count += 3;
                                   break;
                                  }
                                 if (j == test_num-1)
                                  {
                                   printf("Invalid Character Constant\n");
                                   exit();
                                  }
                                } /* end: for (j = 0; j < test_num; j++) */
                              }
                             goto blow_this_place;

                 case '(':   /* vector constant */
                             vect_start = ftell(out_file);
                             vect_count = 0;
                             fprintf(out_file, "vxxxx");
                             skip_space();
                             while(ch != ')')
                              {
                               ungetc(ch, in_file);
                               process_constant();
                               vect_count++;
                               skip_space();
                              } /* end:  while(ch != ')') */
                             vect_end = ftell(out_file);
                             if (fseek(out_file, vect_start, 0))
                              {
                               printf("file seek error-- vector start\n");
                               exit();
                              }
                             fprintf(out_file, "v%04X", vect_count);
                             if (fseek(out_file, vect_end, 0))
                              {
                               printf("file seek error-- vector end\n");
                               exit();
                              }
                             goto blow_this_place;

                 default:    /* other special constant */
                             goto right_here;  /* treat as a symbol */
                }

    default:   /* must look at symbol to see what it is */
               n = 0;
right_here:
               while (!isspace(ch))
                {
                 if (ch == ')')
                  {
                   ungetc(ch, in_file);
                   break;
                  }
                 else
                  {
                   if (n >= sizeof(buffer)) goto too_long;
                   buffer[n++] = ch;
                   ch = fgetc(in_file);
                  }
                }
               i = 0;
               if (buffer[0] == '-' && n > 1) i++;
               for (i; i < n; i++)
                {
                 if (!isdigit(buffer[i]))
                  {
                   if (buffer[i] == '.' && (i > 0 || isdigit(buffer[i+1])))
                    {
                     buffer[n++] = '\0';
                     sscanf(buffer, "%lf", &flonum);
                     get_parts(flo_parts, flonum);
                     fprintf(out_file, "f%04X%04X%04X%04X", flo_parts[0],
                        flo_parts[1], flo_parts[2], flo_parts[3]);
                     count += 17;
                     goto blow_this_place;
                    }
                   else
                    { /* this here's got to be a symbol */
                     if (n > 0x00ff)
                      {
too_long:
                       printf("***Error-- Symbol Too Long***\n%s",
                              "MAKE_FSL limits symbols to 255 characters\n");
                       exit();
                      }
                     /* special fixup to remove escaping \'s */
                     for (i=0; i<n; i++)
                     {
                       if (buffer[i] == '\\')
                       {
                         for (j=i; j < n-1; j++) buffer[j] = buffer[j+1];
                         n--;
                       }
                     }
                     fprintf(out_file, "x%02X", n);
                     for (i = 0; i < n; i++) fputc(toupper(buffer[i]),
                                                                out_file);
                     count += (n + 3);
                     goto blow_this_place;
                    }
                  } /* end:  if (!isdigit(buffer[i]))) */
                } /* end:  for (i; i < n; i++) */
               /* if loop exits, we've got a fixnum */
               i = sign = 0;
               value = 0L;
               if (buffer[0] == '-')
                {
                 sign = 1;
                 i++;
                }
               for (i; i < n; i++)
                {
                 j = (buffer[i] - '0');
                 if (value > ((0x7fffffff - j)/10))
                  {
                   printf("***Error-- Integer Too Big***\n%s",
"MAKE_FSL requires integers be between -2,147,483,647 and 2,147,483,647\n");
                   exit();
                  }
                 value = (value * 10) + j;
                }
               if (sign) value = -value;
               if (value <= 16383 && value >= -16384)
                {
                 i = value & 0x00007fff;
                 fprintf(out_file, "i%04X", i);
                 count += 5;
                 goto blow_this_place;
                }
               else
                {
                 if (sign) value = -value;
                 get_pieces(big_parts, value);
                 fprintf(out_file, "b02%02X%04X%04X", (sign ? 1 : 0),
                                big_parts[0], big_parts[1]);
                 count += 13;
                }
   } /* end:  switch (ch) */

blow_this_place:
 } /* end of function:  process_constant() */

/************************************************************************/
/*              Coerce a floating point value to "words"                */
/************************************************************************/
get_parts(flo_parts, flonum)
double *flo_parts, flonum;
 {
  *flo_parts = flonum;
 }

/************************************************************************/
/*                    Coerce a bignum value to "words"                  */
/************************************************************************/
get_pieces(big_parts, value)
long *big_parts, value;
 {
  *big_parts = value;
 }
