###############################################################################
#
#	File:     sig_in.icn
#
#	Subject:  russell language support procedures
#
#	Author:   Dennis J Darland
#
#	Date:     October - Novmber, 2015
#
###############################################################################
#
# Copyright 1986-1989 Hans-Juergen Boehm, Alan J. Demers, Kumar Srikantan,
# Vernon Lee, and Lucy Hederman.
# Copyright Digital Equipment Corporation & INRIA 1988, 1989.
# Copyright (c) 1990-1993 by Xerox Corporation.  All rights reserved.
#
# This material is provided as is, with no warranty expressed or implied.
# Any use is at your own risk.
# 
# Permission is hereby granted to copy this compiler for any non-commercial
# purpose, provided the above notices are retained on all copies.  Further
# restrictions apply to the DEC/INRIA BigNum package.  These are stated in
# the file runtime/BigNum/doc/bnbody.tex.
#
# This work uses the BigNum package developed jointly by INRIA and
# Digital PRL.  It has been modified by Hans-J. Boehm in August 1990
# and February 1993 at Xerox PARC.  When you receive this software,
# please send mail to librarian@prl.dec.com to inform them that you
# have a copy of the package.
###############################################################################
#
#   NOTE From Dennis J. Darland (11/2/2015)
#
#   I obtained the "c" language source code for "russell" copyrighted above
#   in the 1990's. I have made efforts to get it to work over the years, but
#   always failed. It has many hardware and OS dependancies. Now (October 2015
#   forward, I am tring to port to the language "Unicon". Practically every
#   line of code will need to be changed, as someing as simple as the
#   assignment operator is different. Also I will not use the BigNum package
#   mentioned above. Also I am doing this not for profit, and am sharing
#   freely. I am not at all confident that I will get it working well, but
#   believe in open source, so am sharing my work as I make progress.
#   Unicon is also much more portable.
#
###############################################################################

$include "defs.icn"
$include "global_vars.icn"
#DJDSTOP


#define TRACE
#undef TRACE
#define DEBUG
#undef DEBUG
/* Routines to read in a signature and optimization information */

# ifdef TRACE
#   define IFTRACE(x) x
# else
#   define IFTRACE(x)
# endif

# include "parm.h"
# include <stdio.h>
# include <a.out.h>
# include "stree/ststructs.mh"
# include "pass3/is_local.h"
# define FMTERR 7  /* exit code if file contents dont look like syntax tree */
# define MAXLISTELMTS 100000  /* Maximum plausible list length */

char FMTMSG[] = "Bad signature format for %s (not compiled with -c?)\n";

extern FILE * unparse_file;

char * Sinf_name;  /* name of last Sinfile passed to sig_in */

extern boolean Gflag;

extern boolean OOflag;

/* List of .o files whose signature information has already been read. */
# define fs_nil ((struct File_Sigs *) 0)
struct File_Sigs {
    char * fs_name;
    NODE * fs_signature;
    struct File_Sigs * fs_next;
} *file_sigs = fs_nil;

/* List of local declarations: */
struct decl_entry {
    NODE * de_decl;
    int de_number;
    struct decl_entry * de_next;
} *decl_nums;       /* list of declaration nodes and corresponding numbers */
                    /* This is a silly data structure, but the list is     */
		    /* unlikely to have huge length                        */

static int decl_num = 0;  /* last number assigned to a declaration */

/* Add a new declaration to decl_nums.  Assign it the next available number */
# define add_decl(decl) { \
    struct decl_entry * o = (struct decl_entry *) \
    			malloc(sizeof (struct decl_entry)); \
    o -> de_number = (++decl_num); \
    o -> de_decl = decl; \
    o -> de_next = decl_nums; \
    decl_nums = o; \
}

# define NONE (NODE *)(-1)

/* Get the node associated with declnum.  Return NONE if there isn't any */
static NODE * get_decl(decl_num)
int decl_num;
{
    struct decl_entry *p = decl_nums;

    while (p != NIL ) {
        if (decl_num == p -> de_number) {
            return(p -> de_decl);
        }
        p = p -> de_next;
    }
    return(NONE);
}

/* free decl_nums structure */
static free_decls()
{
    struct decl_entry *p = decl_nums;
    struct decl_entry *q;

    while (p != NIL ) {
        q = p;
        p = p -> de_next;
        free(q);
    }
}

NODE * sig_in1();

extern char tokenbuf[1000]; /* used as string temporary */

/* Read a 0 terminated string from Sinfile.
 * A NIL pointer is represented as a string consisting of a single FF
 * (delete) character.
 * Allocate space for the string and return a pointer to the heap
 * object.
 */
char * get_string(Sinfile)
FILE * Sinfile;
{
    int len = 0;
    char c;
    char * result;

    while((c = getc(Sinfile)) != 0) {
        if (ferror(Sinfile) || feof(Sinfile) || len >= (sizeof tokenbuf)-1) {
	    fprintf(stderr, FMTMSG, Sinf_name);
#           ifdef TRACE
              printf("bad string\n");
              abort();
#           endif
            exit(FMTERR);
        }
        tokenbuf[len++] = c;
    }
    tokenbuf[len] = 0;
    if (len == 1 && tokenbuf[0] == '\377') {
        return(NIL);
    }
    result = (char *)malloc(len+1);
    strcpy(result, tokenbuf);
    return(result);
}

/* Read a word from Sinfile, and check for errors */
int readw(Sinfile)
FILE * Sinfile;
{
    int result;

    if (ferror(Sinfile) || feof(Sinfile)) {
	fprintf(stderr, FMTMSG, Sinf_name);
#       ifdef TRACE
          printf("readw: read error\n");
          abort();
#       endif
        exit(FMTERR);
    }
    result = getw(Sinfile);
    if (ferror(Sinfile)) {
	fprintf(stderr, FMTMSG, Sinf_name);
#       ifdef TRACE
          printf("readw: read error\n");
          abort();
#       endif
        exit(FMTERR);
    }
    return(result);
}

/* Identifiers are written out as
 *              kind
 *              representation kind
 *              selection expression (if any)
 *              declaration number (local) or address (global)
 *                                 (not used for selection)
 *              name (0 terminated string, empty if local type id)
 *
 * The following options exist for the representation kind field:
 */
# define LOCALREP  0
# define GLOBALREP 1
# define SELECTREP 2 

/* Read an identifier.  Return a pointer to the corresponding id node */
/* It is assumed that the kind field has already been read.           */
NODE * get_name(Sinfile,kindno)
FILE *Sinfile;
int kindno;
{
    unsigned string_index;
    int rep;
    NODE * selt = NIL;
    NODE * last_def = NIL;
    NODE * result;
    int decl_number;

#   ifdef DEBUG
	if (kindno != LETTERID && kindno != OPRID) {
            dbgmsg("get_name: bad node kind\n");
            abort();
        }
#   endif
    rep = readw(Sinfile);
    switch(rep) {
        case SELECTREP:
            selt = sig_in1(Sinfile);
            break;
        case GLOBALREP:
            last_def = (NODE *)readw(Sinfile);
            break;
        case LOCALREP:
            decl_number = readw(Sinfile);
            last_def = get_decl(decl_number);
            if (last_def == NONE) {
		fprintf(stderr, FMTMSG, Sinf_name);
#               ifdef TRACE
                  printf("No declaration %d\n", decl_number);
                  abort();
#               endif
                exit(FMTERR);
            }
            break;
    }
#   ifdef DEBUG
	if (last_def != NIL &&
	    last_def -> kind != DECLARATION &&
            last_def -> kind != PARAMETER &&
            last_def -> kind != TYPESIGNATURE &&
            last_def -> kind != PRODCONSTRUCTION &&
            last_def -> kind != UNIONCONSTRUCTION &&
	    last_def -> kind != MODPRIMARY) {
	    dbgmsg("get_name: bad definition %X\n", last_def);
            abort();
        }
#   endif
    /* Read identifier name */
    {
      int len = 0;
      char c;

      while((c = getc(Sinfile)) != 0) {
          if (ferror(Sinfile) || feof(Sinfile) || len >= (sizeof tokenbuf)-1) {
	      fprintf(stderr, FMTMSG, Sinf_name);
#             ifdef TRACE
                printf("error reading id name \n");
                abort();
#             endif
              exit(FMTERR);
          }
          tokenbuf[len++] = c;
      }
      tokenbuf[len] = 0;
      if (len == 0) {
          string_index = -1;
      } else {
#         ifdef TRACE
	      printf("getname: read identifier name: %s\n", tokenbuf);
#         endif
          string_index = stt_enter(tokenbuf, len+1);
      }
    }
    result = mknode(kindno, string_index);
    result -> id_last_definition = last_def;
    initfld(&(result -> sel_type), selt);
    result -> id_def_found = TRUE;
    return(result);
}

/* Read in a list of expression (or signature) trees from Sinfile     */
/* The next number on Sinfile is assumed to be the number of elements */
/* in the list.                                                       */
NODE * list_in(Sinfile)
FILE * Sinfile;
{
    int nelements = readw(Sinfile);
    int i;
    NODE * result = emptylist();

    if (((unsigned) nelements) > MAXLISTELMTS) {
	fprintf(stderr, FMTMSG, Sinf_name);
#       ifdef TRACE
          printf("absurdly long list\n");
          abort();
#       endif
        exit(FMTERR);
    }
    for (i = 0; i < nelements; i++) {
        result := addright(result, sig_in1(Sinfile));
    }
    return(result);
}

/* Read an expression tree from Sinfile.  Return a pointer to the tree.    */
/* This is the same representation used by sig_out. It is designed to be   */
/* relatively efficient.  Local identifiers are represented by the number  */
/* of their declaration.  Such numbers are assigned in preorder fashion.   */
/* This may theoretically build an incorrectly structured tree, if it      */
/* is asked to read a file not produced by sig_out.                        */
NODE * sig_in(Sinfile, name)
FILE * Sinfile;
char * name;
{
  NODE * result;
  /* Save current state, in case this is a nested call */
  char * old_Sinf_name = Sinf_name;
  struct decl_entry * old_decl_nums = decl_nums;
  long old_decl_num = decl_num;

  decl_nums = NIL;
  decl_num = 0;
  Sinf_name = name;
  result = sig_in1(Sinfile);
# ifdef TRACE
    printf("Read signature\n");
    unparse_file = stdout;
    unparse(result);
    printf("\n");
# endif
  free_decls();
  /* Restore previous state */
    Sinf_name = old_Sinf_name;
    decl_nums = old_decl_nums;
    decl_num = old_decl_num;
  return(result);
}


/* Read and return the signature information from fn.o.  (The ".o" */
/* is appended by read_signature.)                                 */
/* Expects to be called only during parsing phase.                 */
/* The string fn is expected to be heap allocated, and not to      */
/* be deallocated by the caller after the call.                    */
NODE * read_signature(fn)
char *fn;
{
  int name_length = strlen(fn);
  FILE * extern_file;
  char * ext_fname;
  NODE * result;
  struct File_Sigs * p;
  extern char etext;

  /* Check whether signature has already been read.  If so, simply return */
  /* previously read signature.                                           */
    for (p = file_sigs; p != fs_nil; p = p -> fs_next) {
	if (strcmp(fn, p -> fs_name) == 0) {
	    return(p -> fs_signature);
	}
    }

  ext_fname = (char *) malloc(name_length+3);
  /* build file name */
    strcpy(ext_fname, fn);
    ext_fname[name_length] = '.';
    ext_fname[name_length+1] = 'o';
    ext_fname[name_length+2] = 0;
          /* Get and fill in signature info */
    if ((extern_file = fopen(ext_fname, "r")) == NULL) {
      fprintf(stderr, "Couldn't open %s\n", ext_fname);
      yyperror("Cant open external Russell object file");
      result = mknode (REXTERNDEF, NIL, NIL);
    } else {
      unsigned long strsize;
      struct exec header;
      extern FILE * optfile;
      unsigned long optsize;
      int c;

      /* seek past end of string table */
	fread(&header, sizeof (struct exec), 1, extern_file);
	fseek(extern_file, N_STROFF(header), 0);
	fread(&strsize, sizeof (long), 1, extern_file);
	fseek(extern_file, N_STROFF(header) + strsize, 0);

#     if defined(SUN) && defined(EXTRA_MAGIC)
	/* Skip past secondary section header */
	{
	  struct extra_sections es;
	  
	  fread(&es, sizeof (struct extra_sections), 1, extern_file);
	  if (es.extra_magic != EXTRA_MAGIC) {
	    fprintf(stderr, "Bad secondary magic number in %s (%s)\n",
	            ext_fname, "Not compiled with -c?");
	    exit(1);
	  }
	  if (es.extra_nsects != 1) {
	    fprintf(stderr, "Unrecognized extra sections in executable %s\n",
	            ext_fname);
	    exit(1);
	  }
	  /* Discard secondary section size */
	    (void) getw(extern_file);
	}
#     endif
      	  
      /* Copy or discard optimization information */
	optsize = getw(extern_file);
	for (; optsize > 0; optsize--) {
	    if ((c = getc(extern_file)) == EOF) {
		fprintf(stderr, "Bad optimization info in %s (not compiled with -c?)\n",
			ext_fname);
		exit(1);
	    }
	    if (OOflag) {
		putc(c, optfile);
	    }
	}
	
      /* Check that signature info was generated by this version of the */
      /* compiler.							*/
        if ((char *)(getw(extern_file)) != &etext) {
            fprintf(stderr, "Outdated executable %s - must be recompiled\n",
                    ext_fname);
            exit(1);
        }


      /* Copy any nested external files to OBJFILELIST       */
      /* This should really be done when we know that these  */
      /* are really needed, but it's very unlikely they      */
      /* won't be.                                           */
	{
	    extern char str_code_buf[];  /* General purpose buffer */
	    char *p;
	    extern void add_objfile();
	    int c;  /* actually a character */

	    do {
		/* Read a line from extern_file */
		    p = str_code_buf;
		    do {
			c = getc(extern_file);
			if (c == '\n') {
			    *p = '\0';
			} else if (c == EOF) {
			    fprintf(stderr, "%s has bad format\n",
				    ext_fname);
			    yyperror("Bad external object file");
			    exit(1);
			} else {
			    *p++ = c;
			}
		    } while (c != '\n');
		if (p != str_code_buf) {
		    add_objfile(str_code_buf);
		}
	    } while (p != str_code_buf);
	}

      /* Now read signature info */
       result = sig_in(extern_file, ext_fname);

      fclose(extern_file);
    }
  free(ext_fname);
  /* Add result to file_sigs list */
    p = (struct File_Sigs *) malloc(sizeof (struct File_Sigs));
    p -> fs_next = file_sigs;
    p -> fs_name = fn;
    p -> fs_signature = lock(result);
    file_sigs = p;

  return(result);
}

NODE * sig_in1(Sinfile)
FILE * Sinfile;
{
register NODE * result;
int kindno;

#   ifdef TRACE
      printf("sig_in: position = %d\n", ftell(Sinfile));
#   endif
    kindno = readw(Sinfile);
    if (feof(Sinfile)) {
#       ifdef TRACE
	    printf("End of file\n");
	    abort();
#       endif
	fprintf(stderr, FMTMSG, Sinf_name);
	exit(FMTERR);
    }
#   ifdef TRACE
      printf("sig_in: kind = %d(%s)\n", kindno, kindname(kindno));
#   endif

    switch ( kindno ) {

        case -1:
                return(NIL);

        case DECLARATION:
                {
                    NODE * id;
                    NODE * sig;
		    NODE * den;
		    int sig_transp;
		    NODE * result;

		    id = sig_in1(Sinfile);
		    sig_transp = readw(Sinfile);
                    sig = sig_in1(Sinfile);
                    den = sig_in1(Sinfile);
		    result = mknode(DECLARATION, id, den, sig);
		    result -> decl_sig_transp = sig_transp;
		    return(result);
                }

        case BLOCKDENOTATION:
                {
                    NODE * decl_l;
                    NODE * den_s;
                    int len_decl_l = readw(Sinfile);
                    int i;
                    NODE * v;
                          
                    if (((unsigned) len_decl_l) > MAXLISTELMTS) {
			fprintf(stderr, FMTMSG, Sinf_name);
#                       ifdef TRACE
                          printf("declaration list too long\n");
                          abort();
#                       endif
                        exit(FMTERR);
                    }
                    decl_l = emptylist();
                    /* First add dummy declaration nodes to decl_nums */
                      for (i = 0; i < len_decl_l; i++) {
                        v = mknode(DECLARATION, NIL, NIL, NIL);
                        decl_l := addright(decl_l, v);
			add_decl(v);
#                       ifdef TRACE
			    printf("Added explicit declaration number %d\n",
				   decl_num);
#                       endif
                      }
                    maplist(v, decl_l, {
                      int decl_kind;
                      NODE * id;
                      NODE * sig;
                      NODE * den;

                      decl_kind = readw(Sinfile);
                      if (decl_kind != DECLARATION) {
			fprintf(stderr, FMTMSG, Sinf_name);
			IFTRACE(
                          printf("bad declaration\n");
			  abort();
			)
			exit(FMTERR);
                      }
                      id = sig_in1(Sinfile);
                      sig = sig_in1(Sinfile);
                      den = sig_in1(Sinfile);
                      initfld(&(v -> decl_id), id);
                      initfld(&(v -> decl_denotation), den);
                      initfld(&(v -> decl_signature), sig);
                    });
                    den_s = list_in(Sinfile);
                    return(mknode(BLOCKDENOTATION, decl_l, den_s));
                }

        case APPLICATION:
                {
                    NODE * op;
                    NODE * args;
    
                    op = sig_in1(Sinfile);
                    args = list_in(Sinfile);
                    return(mknode(APPLICATION, op, args));
                }

        case LOOPDENOTATION:
        case GUARDEDLIST:
                return(mknode(kindno, list_in(Sinfile)));

        case GUARDEDELEMENT:
                {
                    NODE * guard;
                    NODE * element;

                    guard = sig_in1(Sinfile);
                    element = sig_in1(Sinfile);
                    return(mknode(GUARDEDELEMENT, guard, element));
                }

        case OPRID:
        case LETTERID:
                return(get_name(Sinfile, kindno));

        case FUNCCONSTR:
                {
                    NODE * sig;
                    NODE * body;

                    sig = sig_in1(Sinfile);
                    body = sig_in1(Sinfile);
                    return(mknode(FUNCCONSTR, sig, body));
                }

        case USELIST:
                {
                    NODE * type_list;
                    NODE * den_seq;

                    type_list = list_in(Sinfile);
                    den_seq = list_in(Sinfile);
                    return(mknode(USELIST, type_list, den_seq));
                }

        case MODPRIMARY:
                {
                    NODE * result = mknode(MODPRIMARY, NIL, NIL);

                    add_decl(result);
#                   ifdef TRACE
			printf("Added mp declaration number %d\n",
			       decl_num);
#                   endif
                    initfld(&(result -> mp_primary),
                            sig_in1(Sinfile));
                    initfld(&(result -> mp_type_modifier),
                            sig_in1(Sinfile));
                    return(result);
                }

        case PRODCONSTRUCTION:
        case UNIONCONSTRUCTION:
                {
                    NODE * result = mknode(kindno, NIL, NIL);

                    add_decl(result);
#                   ifdef TRACE
			printf("Added type c. declaration number %d\n",
			       decl_num);
#                   endif
                    initfld(&(result -> prod_local_type_id),
                            sig_in1(Sinfile));
                    initfld(&(result -> prod_components),
                            list_in(Sinfile));
                    return(result);
                }

	case WORDELSE:
                return(mknode(WORDELSE));
                                         
        case PARAMETER:
                {
                    NODE * id;
                    NODE * sig;

                    id = sig_in1(Sinfile);
                    sig = sig_in1(Sinfile);
                    return(mknode(PARAMETER, id, sig));
                }

        case FUNCSIGNATURE:
                {
                    NODE * param_list = emptylist();
                    int nparams;
                    int i, param_kind;
                    int constr_info;
		    NODE * constr;
		    int spcl;
			     
		    spcl = readw(Sinfile);
		    result = mknode(FUNCSIGNATURE,
				    (Gflag?
				       (char *) get_RIC(Sinfile)
				       	  /* in-line code */
				     : get_string(Sinfile)),
				    NIL, NIL);
		    result -> fsig_special = spcl;

                    /* Read number of parameters and add blank nodes to */
                    /* decl_nums.                                       */
                        nparams = readw(Sinfile);
                        if (((unsigned) nparams) > MAXLISTELMTS) {
			    fprintf(stderr, FMTMSG, Sinf_name);
#                           ifdef TRACE
                              printf("Too many parameters\n");
#                           endif
                            exit(FMTERR);
                        }
                        for (i = 0; i < nparams; i++) {
                            NODE * v;

                            v = mknode(PARAMETER, NIL, NIL);
                            param_list := addright(param_list, v);
                            add_decl(v);
#                           ifdef TRACE
			      printf("Added parameter declaration number %d\n",
				     decl_num);
#                           endif
                        }

                    /* Fill in parameter nodes */
                        maplist(v, param_list, {
                            param_kind = readw(Sinfile);
                            if (param_kind != PARAMETER) {
				fprintf(stderr, FMTMSG, Sinf_name);
				IFTRACE(
                                  printf("bad parameter\n");
                                  abort();
				)
                                exit(FMTERR);
                            }
                            initfld(&(v -> par_id), sig_in1(Sinfile));
                            initfld(&(v -> par_signature), sig_in1(Sinfile));
                        });

                    initfld(&(result -> fsig_param_list), param_list);
                    initfld(&(result -> fsig_result_sig), sig_in1(Sinfile));
                    /* Restore info about function construction */
#                     define CONSTR_UNKNOWN 0
#                     define CONSTR_AVAIL 1
#                     define SLINK_AVAIL 2
                      constr_info = readw(Sinfile);
                      switch (constr_info) {
                        case CONSTR_UNKNOWN:
                            break;

			case SLINK_AVAIL:
			    result -> fsig_slink_known = TRUE;
			    /* and continue: */

                        case CONSTR_AVAIL:
                            constr = mknode(FUNCCONSTR,
                                            result,
					    mknode(EXTERNDEF,NIL));
                            lock(constr);
                            result -> fsig_construction = constr;
                            constr -> fc_complexity = readw(Sinfile);
                            constr -> fc_code_label = get_string(Sinfile);
			    constr -> ar_static_level =  readw(Sinfile);
			    constr -> ar_size = readw(Sinfile);
#                           ifdef TRACE
				printf("Construction=%X, label=%s, compl=%d\n",
				       constr, constr -> fc_code_label,
				       constr -> fc_complexity);
#                           endif
                    }
                    return(result);
                }

        case VALSIGNATURE:
        case VARSIGNATURE:
		return(mknode(kindno, sig_in1(Sinfile)));

	case SIGNATURESIG:
		return(mknode(SIGNATURESIG));

        case TYPESIGNATURE:
                result = mknode(TYPESIGNATURE, NIL, NIL, NIL, NIL, NIL);
                add_decl(result);
#               ifdef TRACE
		    printf("Added type sig. declaration number %d\n",
			   decl_num);
#               endif
                initfld(&(result -> ts_local_type_id), sig_in1(Sinfile));
                initfld(&(result -> ts_clist), list_in(Sinfile));
                /* recover optimization information: */
                    result -> ts_const_code = get_string(Sinfile);
                    result -> ts_string_code = get_string(Sinfile);
		    result -> ts_element_code = get_string(Sinfile);
		    result -> ts_string_max = readw(Sinfile);
		    result -> ts_simple_type = readw(Sinfile);
                return(result);

        case TSCOMPONENT:
                {
                    NODE * id;
                    NODE * sig;

                    id = sig_in1(Sinfile);
                    sig = sig_in1(Sinfile);
                    return(mknode(TSCOMPONENT, id, sig));
                }

        case DEFCHARSIGS:
                {
                    int i;
                    unsigned * base;

		    result = mknode(DEFCHARSIGS, 0, 0, 0, 0);
		    base = &(result -> dcs_0);
                    for(i = 0; i < NVECTORS; i++) {
                        base[i] = readw(Sinfile);
                    }
                    return(result);
		}

	case REXTERNDEF:
		{
		    char * name = get_string(Sinfile);
		    NODE * sig = read_signature(name);

		    result = mknode(REXTERNDEF, sig, name);
		    result -> sig_done = SIG_DONE;
		    return(result);
		}

        case RECORDCONSTRUCTION:
        case EXTENSION:
        case ENUMERATION:
        case RECORDELEMENT:
        case WITHLIST:
        case EXPORTLIST:
        case HIDELIST:
        case EXPORTELEMENT:
		dbgmsg("Signature input can't handle %s yet\n",
                       kindname(kindno));
                return(NIL);

        case QSTR:
        case UQSTR:
        case LISTHEADER:
        case FREEVARNODE:
        case WORDCAND:
        case WORDCOR:
        case EXTERNDEF:
        default:
#               ifdef TRACE
                  printf("Bad kind\n");
                  abort();
#               endif
		fprintf(stderr, FMTMSG, Sinf_name);
                exit(FMTERR);

    };
}
# Read and return the signature information from fn.o.  (The ".o" 
# is appended by read_signature.)                                 
# Expects to be called only during parsing phase.                 
# The string fn is expected to be heap allocated, and not to      
# be deallocated by the caller after the call.                    
procedure read_signature(fn)
local name_length, extern_file, ext_fname, result, p
#  extern char etext;
name_length := *fn
  # Check whether signature has already been read.  If so, simply return 
  # previously read signature.
p := file_sigs
while \p do {
    if (fn == p.fs_name) then {
	return(p.fs_signature)
    }
p := p.fs_next
}
ext_fname = ext_fname || ".o"
# build file name 
# Get and fill in signature info 
if not(extern_file := open("ext_fname","r")) then stop("read_sigature cannot open external file " || type(ext_fname))
#      unsigned long strsize;
#      struct exec header;
#      extern FILE * optfile;
#      unsigned long optsize;
#      int c;

      # seek past end of string table 
	fread(&header, sizeof (struct exec), 1, extern_file);
	fseek(extern_file, N_STROFF(header), 0);
	fread(&strsize, sizeof (long), 1, extern_file);
	fseek(extern_file, N_STROFF(header) + strsize, 0);

      # Copy or discard optimization information 
	optsize = getw(extern_file);
	for (; optsize > 0; optsize--) {
	    if ((c = getc(extern_file)) == EOF) {
		fprintf(stderr, "Bad optimization info in %s (not compiled with -c?)\n",
			ext_fname);
		exit(1);
	    }
	    if (OOflag) {
		putc(c, optfile);
	    }
	}
	
      # Check that signature info was generated by this version of the 
      # compiler.							
        if ((char *)(getw(extern_file)) != &etext) {
            fprintf(stderr, "Outdated executable %s - must be recompiled\n",
                    ext_fname);
            exit(1);
        }


      # Copy any nested external files to OBJFILELIST       
      # This should really be done when we know that these  
      # are really needed, but it's very unlikely they      
      # won't be.                                           
	{
	    extern char str_code_buf[];  # General purpose buffer 
	    char *p;
	    extern void add_objfile();
	    int c;  # actually a character 

	    do {
		# Read a line from extern_file 
		    p = str_code_buf;
		    do {
			c = getc(extern_file);
			if (c == '\n') {
			    *p = '\0';
			} else if (c == EOF) {
			    fprintf(stderr, "%s has bad format\n",
				    ext_fname);
			    yyperror("Bad external object file");
			    exit(1);
			} else {
			    *p++ = c;
			}
		    } while (c != '\n');
		if (p != str_code_buf) {
		    add_objfile(str_code_buf);
		}
	    } while (p != str_code_buf);
	}

      # Now read signature info 
       result = sig_in(extern_file, ext_fname);

      fclose(extern_file);
    }
  free(ext_fname);
  # Add result to file_sigs list 
    p = (struct File_Sigs *) malloc(sizeof (struct File_Sigs));
    p -> fs_next = file_sigs;
    p -> fs_name = fn;
    p -> fs_signature = lock(result);
    file_sigs = p;

  return(result);
end
#DJDSTART
# List of .o files whose signature information has already been read. 
# define fs_nil ((struct File_Sigs *) 0)
class File_Sigs(fs_name,fs_signature,fs_next)
end
# } *file_sigs = fs_nil;
#DJDSTOP 
# this class defined in sig_out.icn
# List of local declarations: 
struct decl_entry {
    NODE * de_decl;
    int de_number;
    struct decl_entry * de_next;
} *decl_nums;  
     # list of declaration nodes and corresponding numbers 
                    # This is a silly data structure, but the list is     
		    # unlikely to have huge length                        


# Add a new declaration to decl_nums.  Assign it the next available number 
# define add_decl(decl) { \
    struct decl_entry * o = (struct decl_entry *) \
    			malloc(sizeof (struct decl_entry)); \
    o -> de_number = (++decl_num); \
    o -> de_decl = decl; \
    o -> de_next = decl_nums; \
    decl_nums = o; \
}
# will use nil for NONE

# Get the node associated with declnum.  Return NONE if there isn't any 
procedure get_decl(decl_num)
    p := decl_nums

    while (\p) do {
        if (decl_num = p.de_number) then {
            return(p.de_decl)
        }
        p := p.de_next
    }
    return(nil);
end
#DJDSTOP
# free decl_nums structure 
static free_decls()
{
    struct decl_entry *p = decl_nums;
    struct decl_entry *q;

    while (p != NIL ) {
        q = p;
        p = p -> de_next;
        free(q);
    }
}
NODE * sig_in1();

extern char tokenbuf[1000]; # used as string temporary 
#DJDSTART

# Read a 0 terminated string from Sinfile.
# A NIL pointer is represented as a string consisting of a single FF
# (delete) character.
# Allocate space for the string and return a pointer to the heap
# object.
#
procedure get_string(Sinfile)
    local result
    result := Sinfile[infilepos]
    infilepos +:= 1
    return(result)
end

# Read a word from Sinfile, and check for errors 
procedure readw(Sinfile)
local result
    result := Sinfile[infilepos]
    infilepos +:= 1
    return(result)
end
# Identifiers are written out as
#              kind
#              representation kind
#              selection expression (if any)
#              declaration number (local) or address (global)
#                                 (not used for selection)
#             name (0 terminated string, empty if local type id)
#
# The following options exist for the representation kind field:
#
$define LOCALREP  0
$define GLOBALREP 1
$define SELECTREP 2 

# Read an identifier.  Return a pointer to the corresponding id node 
# It is assumed that the kind field has already been read.           
procedure get_name(Sinfile,kindno)
    local  string_index, rep, result,decl_number
    static selt, last_def
    initial {
	selt := 0
	last_def := nil
    }
    rep := readw(Sinfile)
    case (rep) of {
	SELECTREP: {
            selt := sig_in1(Sinfile)
	}
         GLOBALREP: {
	     last_def := readw(Sinfile)
	}
	LOCALREP: {
            decl_number := readw(Sinfile)
            last_def := get_decl(decl_number)
            if (/last_def) then {
		rpt_err(" error in sin_in " || FMTMSG)
            }
	    # Read identifier name 
	    result := Sinfile[infilepos]
	    infilepos +:= 1
	    return(result)
	}
    }
end

# Read in a list of expression (or signature) trees from Sinfile     
# The next number on Sinfile is assumed to be the number of elements 
# in the list.                                                       
procedure list_in(Sinfile)
    local i
    static nelements, result
    initial {
	nelements := readw(Sinfile)
	result := emptylist()
    }
    
    if (nelements > MAXLISTELMTS) then {
	rpt_err("sig_in FMTMSG")
    }
    i := 0
    while (i < nelements) do {
        result := addright(result, sig_in1(Sinfile))
	i +:= 1
    }
    return(result)
end

# Read an expression tree from Sinfile.  Return a pointer to the tree.    
# This is the same representation used by sig_out. It is designed to be   
# relatively efficient.  Local identifiers are represented by the number  
# of their declaration.  Such numbers are assigned in preorder fashion.   
# This may theoretically build an incorrectly structured tree, if it      
# is asked to read a file not produced by sig_out.                        
procedure sig_in(Sinfile, name)
    local  result,  decl_entry
    static old_Sinf_name, old_decl_nums, old_decl_num
# Save current state, in case this is a nested call 
    initial { 
	old_Sinf_name := Sinf_name
	old_decl_nums := decl_nums;
	old_decl_num := decl_num;
    }
    decl_nums := nil
    decl_num := 0
    Sinf_name := name
    result := sig_in1(Sinfile)
    free_decls()
# Restore previous state 
    Sinf_name := old_Sinf_name
    decl_nums := old_decl_nums
    decl_num := old_decl_num
    return(result)
end


# Read and return the signature information from fn.o.  (The ".o" 
# is appended by read_signature.)                                 
# Expects to be called only during parsing phase.                 
# The string fn is expected to be heap allocated, and not to      
# be deallocated by the caller after the call.                    
procedure read_signature(fn)
    local   name_length, e, extern_file, ext_fname, result
 
    name_length := *fn
    
#DJDSTOP    
    # Check whether signature has already been read.  If so, simply return 
    # previously read signature.                                           
    for (p = file_sigs; p != fs_nil; p = p -> fs_next) {
	if (strcmp(fn, p -> fs_name) == 0) {
	    return(p -> fs_signature);
	}
    }
#DJDSTART
    # build file name
    # really get list from table of lists - pretend file
    extern_file := sig_table(name || ".o")
#DJDSTOP
    # seek past end of string table 
    fread(&header, sizeof (struct exec), 1, extern_file);
    fseek(extern_file, N_STROFF(header), 0);
    fread(&strsize, sizeof (long), 1, extern_file);
    fseek(extern_file, N_STROFF(header) + strsize, 0);

    # Copy or discard optimization information 
    optsize := getw(extern_file)
    while (optsize > 0) do {
	
	for (; optsize > 0; optsize--) {
	    if ((c = getc(extern_file)) == EOF) {
		fprintf(stderr, "Bad optimization info in %s (not compiled with -c?)\n",
			ext_fname);
		exit(1);
	    }
	    if (OOflag) {
		putc(c, optfile);
	    }
	}
    }
	
    # Check that signature info was generated by this version of the 
    # compiler.							
    if ((char *)(getw(extern_file)) != &etext) {
	fprintf(stderr, "Outdated executable %s - must be recompiled\n",
		ext_fname);
	exit(1);
    }
	
    
    # Copy any nested external files to OBJFILELIST       
    # This should really be done when we know that these  
    # are really needed, but it's very unlikely they      
    # won't be.                                           
    {
	extern char str_code_buf[];  # General purpose buffer 
	char *p;
	extern void add_objfile();
	int c;  # actually a character 
	
	do {
	    # Read a line from extern_file 
	    p = str_code_buf;
	    do {
		c = getc(extern_file);
		    if (c == '\n') {
			*p = '\0';
		    } else if (c == EOF) {
			fprintf(stderr, "%s has bad format\n",
				ext_fname);
			yyperror("Bad external object file");
			exit(1);
		    } else {
			*p++ = c;
		    }
	    } while (c != '\n');
	    if (p != str_code_buf) {
		    add_objfile(str_code_buf);
		}
	} while (p != str_code_buf);
    }
#DJDSTART
    
    # Now read signature info 
    result := sig_in(extern_file, ext_fname);
    
    free(ext_fname);
    # Add result to file_sigs list 
    p := File_Sigs(fn,lock(result),file_sigs)
    file_sigs := p;
    
    return(result);
end

procedure sig_in1(Sinfile)
    local result, kindno
    
    kindno := readw(Sinfile)
    if (infilepos = *Sinfile ) then {
	rpt_err("sig_in1 EOF")
    }
    else {
	result := Sinfile[infilepos]
	infilepos +:= 1
    }
    return result
end 
#DJDSTOP   
    switch ( kindno ) {

         -1:
                return(NIL);

         DECLARATION:
                {
                    NODE * id;
                    NODE * sig;
		    NODE * den;
		    int sig_transp;
		    NODE * result;

		    id = sig_in1(Sinfile);
		    sig_transp = readw(Sinfile);
                    sig = sig_in1(Sinfile);
                    den = sig_in1(Sinfile);
		    result = mknode(DECLARATION, id, den, sig);
		    result -> decl_sig_transp = sig_transp;
		    return(result);
                }

         BLOCKDENOTATION:
                {
                    NODE * decl_l;
                    NODE * den_s;
                    int len_decl_l = readw(Sinfile);
                    int i;
                    NODE * v;
                          
                    if (((unsigned) len_decl_l) > MAXLISTELMTS) {
			fprintf(stderr, FMTMSG, Sinf_name);
#                       ifdef TRACE
                          printf("declaration list too long\n");
                          abort();
#                       endif
                        exit(FMTERR);
                    }
                    decl_l = emptylist();
                    # First add dummy declaration nodes to decl_nums 
                      for (i = 0; i < len_decl_l; i++) {
                        v = mknode(DECLARATION, NIL, NIL, NIL);
                        decl_l := addright(decl_l, v);
			add_decl(v);
#                       ifdef TRACE
			    printf("Added explicit declaration number %d\n",
				   decl_num);
#                       endif
                      }
                    maplist(v, decl_l, {
                      int decl_kind;
                      NODE * id;
                      NODE * sig;
                      NODE * den;

                      decl_kind = readw(Sinfile);
                      if (decl_kind != DECLARATION) {
			fprintf(stderr, FMTMSG, Sinf_name);
			IFTRACE(
                          printf("bad declaration\n");
			  abort();
			)
			exit(FMTERR);
                      }
                      id = sig_in1(Sinfile);
                      sig = sig_in1(Sinfile);
                      den = sig_in1(Sinfile);
                      initfld(&(v -> decl_id), id);
                      initfld(&(v -> decl_denotation), den);
                      initfld(&(v -> decl_signature), sig);
                    });
                    den_s = list_in(Sinfile);
                    return(mknode(BLOCKDENOTATION, decl_l, den_s));
                }

         APPLICATION:
                {
                    NODE * op;
                    NODE * args;
    
                    op = sig_in1(Sinfile);
                    args = list_in(Sinfile);
                    return(mknode(APPLICATION, op, args));
                }

         LOOPDENOTATION:
         GUARDEDLIST:
                return(mknode(kindno, list_in(Sinfile)));

         GUARDEDELEMENT:
                {
                    NODE * guard;
                    NODE * element;

                    guard = sig_in1(Sinfile);
                    element = sig_in1(Sinfile);
                    return(mknode(GUARDEDELEMENT, guard, element));
                }

         OPRID:
         LETTERID:
                return(get_name(Sinfile, kindno));

         FUNCCONSTR:
                {
                    NODE * sig;
                    NODE * body;

                    sig = sig_in1(Sinfile);
                    body = sig_in1(Sinfile);
                    return(mknode(FUNCCONSTR, sig, body));
                }

         USELIST:
                {
                    NODE * type_list;
                    NODE * den_seq;

                    type_list = list_in(Sinfile);
                    den_seq = list_in(Sinfile);
                    return(mknode(USELIST, type_list, den_seq));
                }

         MODPRIMARY:
                {
                    NODE * result = mknode(MODPRIMARY, NIL, NIL);

                    add_decl(result);
#                   ifdef TRACE
			printf("Added mp declaration number %d\n",
			       decl_num);
#                   endif
                    initfld(&(result -> mp_primary),
                            sig_in1(Sinfile));
                    initfld(&(result -> mp_type_modifier),
                            sig_in1(Sinfile));
                    return(result);
                }

         PRODCONSTRUCTION:
         UNIONCONSTRUCTION:
                {
                    NODE * result = mknode(kindno, NIL, NIL);

                    add_decl(result);
#                   ifdef TRACE
			printf("Added type c. declaration number %d\n",
			       decl_num);
#                   endif
                    initfld(&(result -> prod_local_type_id),
                            sig_in1(Sinfile));
                    initfld(&(result -> prod_components),
                            list_in(Sinfile));
                    return(result);
                }

	 WORDELSE:
                return(mknode(WORDELSE));
                                         
         PARAMETER:
                {
                    NODE * id;
                    NODE * sig;

                    id = sig_in1(Sinfile);
                    sig = sig_in1(Sinfile);
                    return(mknode(PARAMETER, id, sig));
                }

         FUNCSIGNATURE:
                {
                    NODE * param_list = emptylist();
                    int nparams;
                    int i, param_kind;
                    int constr_info;
		    NODE * constr;
		    int spcl;
			     
		    spcl = readw(Sinfile);
		    result = mknode(FUNCSIGNATURE,
				    (Gflag?
				       (char *) get_RIC(Sinfile)
				       	  # in-line code 
				     : get_string(Sinfile)),
				    NIL, NIL);
		    result -> fsig_special = spcl;

                    # Read number of parameters and add blank nodes to 
                    # decl_nums.                                       
                        nparams = readw(Sinfile);
                        if (((unsigned) nparams) > MAXLISTELMTS) {
			    fprintf(stderr, FMTMSG, Sinf_name);
#                           ifdef TRACE
                              printf("Too many parameters\n");
#                           endif
                            exit(FMTERR);
                        }
                        for (i = 0; i < nparams; i++) {
                            NODE * v;

                            v = mknode(PARAMETER, NIL, NIL);
                            param_list := addright(param_list, v);
                            add_decl(v);
#                           ifdef TRACE
			      printf("Added parameter declaration number %d\n",
				     decl_num);
#                           endif
                        }

                    # Fill in parameter nodes 
                        maplist(v, param_list, {
                            param_kind = readw(Sinfile);
                            if (param_kind != PARAMETER) {
				fprintf(stderr, FMTMSG, Sinf_name);
				IFTRACE(
                                  printf("bad parameter\n");
                                  abort();
				)
                                exit(FMTERR);
                            }
                            initfld(&(v -> par_id), sig_in1(Sinfile));
                            initfld(&(v -> par_signature), sig_in1(Sinfile));
                        });

                    initfld(&(result -> fsig_param_list), param_list);
                    initfld(&(result -> fsig_result_sig), sig_in1(Sinfile));
                    # Restore info about function construction 
#                     define CONSTR_UNKNOWN 0
#                     define CONSTR_AVAIL 1
#                     define SLINK_AVAIL 2
                      constr_info = readw(Sinfile);
                      switch (constr_info) {
                         CONSTR_UNKNOWN:
                            break;

			 SLINK_AVAIL:
			    result -> fsig_slink_known = TRUE;
			    # and continue: 

                         CONSTR_AVAIL:
                            constr = mknode(FUNCCONSTR,
                                            result,
					    mknode(EXTERNDEF,NIL));
                            lock(constr);
                            result -> fsig_construction = constr;
                            constr -> fc_complexity = readw(Sinfile);
                            constr -> fc_code_label = get_string(Sinfile);
			    constr -> ar_static_level =  readw(Sinfile);
			    constr -> ar_size = readw(Sinfile);
#                           ifdef TRACE
				printf("Construction=%X, label=%s, compl=%d\n",
				       constr, constr -> fc_code_label,
				       constr -> fc_complexity);
#                           endif
                    }
                    return(result);
                }

         VALSIGNATURE:
         VARSIGNATURE:
		return(mknode(kindno, sig_in1(Sinfile)));

	 SIGNATURESIG:
		return(mknode(SIGNATURESIG));

         TYPESIGNATURE:
                result = mknode(TYPESIGNATURE, NIL, NIL, NIL, NIL, NIL);
                add_decl(result);
#               ifdef TRACE
		    printf("Added type sig. declaration number %d\n",
			   decl_num);
#               endif
                initfld(&(result -> ts_local_type_id), sig_in1(Sinfile));
                initfld(&(result -> ts_clist), list_in(Sinfile));
                # recover optimization information: 
                    result -> ts_const_code = get_string(Sinfile);
                    result -> ts_string_code = get_string(Sinfile);
		    result -> ts_element_code = get_string(Sinfile);
		    result -> ts_string_max = readw(Sinfile);
		    result -> ts_simple_type = readw(Sinfile);
                return(result);

         TSCOMPONENT:
                {
                    NODE * id;
                    NODE * sig;

                    id = sig_in1(Sinfile);
                    sig = sig_in1(Sinfile);
                    return(mknode(TSCOMPONENT, id, sig));
                }

         DEFCHARSIGS:
                {
                    int i;
                    unsigned * base;

		    result = mknode(DEFCHARSIGS, 0, 0, 0, 0);
		    base = &(result -> dcs_0);
                    for(i = 0; i < NVECTORS; i++) {
                        base[i] = readw(Sinfile);
                    }
                    return(result);
		}

	 REXTERNDEF:
		{
		    char * name = get_string(Sinfile);
		    NODE * sig = read_signature(name);

		    result = mknode(REXTERNDEF, sig, name);
		    result -> sig_done = SIG_DONE;
		    return(result);
		}

         RECORDCONSTRUCTION:
         EXTENSION:
         ENUMERATION:
         RECORDELEMENT:
         WITHLIST:
         EXPORTLIST:
         HIDELIST:
         EXPORTELEMENT:
		dbgmsg("Signature input can't handle %s yet\n",
                       kindname(kindno));
                return(NIL);

         QSTR:
         UQSTR:
         LISTHEADER:
         FREEVARNODE:
         WORDCAND:
         WORDCOR:
         EXTERNDEF:
        default:
#               ifdef TRACE
                  printf("Bad kind\n");
                  abort();
#               endif
		fprintf(stderr, FMTMSG, Sinf_name);
                exit(FMTERR);

    };
}
# Read and return the signature information from fn.o.  (The ".o" 
# is appended by read_signature.)                                 
# Expects to be called only during parsing phase.                 
# The string fn is expected to be heap allocated, and not to      
# be deallocated by the caller after the call.                    
procedure read_signature(fn)
local name_length, extern_file, ext_fname, result, p
#  extern char etext;
name_length := *fn
  # Check whether signature has already been read.  If so, simply return 
  # previously read signature.
p := file_sigs
while \p do {
    if (fn == p.fs_name) then {
	return(p.fs_signature)
    }
p := p.fs_next
}
ext_fname = ext_fname || ".o"
# build file name 
# Get and fill in signature info 
if not(extern_file := open("ext_fname","r")) then stop("read_sigature cannot open external file " || type(ext_fname))
#      unsigned long strsize;
#      struct exec header;
#      extern FILE * optfile;
#      unsigned long optsize;
#      int c;

      # seek past end of string table 
	fread(&header, sizeof (struct exec), 1, extern_file);
	fseek(extern_file, N_STROFF(header), 0);
	fread(&strsize, sizeof (long), 1, extern_file);
	fseek(extern_file, N_STROFF(header) + strsize, 0);

      # Copy or discard optimization information 
	optsize = getw(extern_file);
	for (; optsize > 0; optsize--) {
	    if ((c = getc(extern_file)) == EOF) {
		fprintf(stderr, "Bad optimization info in %s (not compiled with -c?)\n",
			ext_fname);
		exit(1);
	    }
	    if (OOflag) {
		putc(c, optfile);
	    }
	}
	
      # Check that signature info was generated by this version of the 
      # compiler.							
        if ((char *)(getw(extern_file)) != &etext) {
            fprintf(stderr, "Outdated executable %s - must be recompiled\n",
                    ext_fname);
            exit(1);
        }


      # Copy any nested external files to OBJFILELIST       
      # This should really be done when we know that these  
      # are really needed, but it's very unlikely they      
      # won't be.                                           
	{
	    extern char str_code_buf[];  # General purpose buffer 
	    char *p;
	    extern void add_objfile();
	    int c;  # actually a character 

	    do {
		# Read a line from extern_file 
		    p = str_code_buf;
		    do {
			c = getc(extern_file);
			if (c == '\n') {
			    *p = '\0';
			} else if (c == EOF) {
			    fprintf(stderr, "%s has bad format\n",
				    ext_fname);
			    yyperror("Bad external object file");
			    exit(1);
			} else {
			    *p++ = c;
			}
		    } while (c != '\n');
		if (p != str_code_buf) {
		    add_objfile(str_code_buf);
		}
	    } while (p != str_code_buf);
	}

      # Now read signature info 
       result = sig_in(extern_file, ext_fname);

      fclose(extern_file);
    }
  free(ext_fname);
  # Add result to file_sigs list 
    p = (struct File_Sigs *) malloc(sizeof (struct File_Sigs));
    p -> fs_next = file_sigs;
    p -> fs_name = fn;
    p -> fs_signature = lock(result);
    file_sigs = p;

  return(result);
end
