###############################################################################
#
#	File:     mknode.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.
#
###############################################################################

#DJDSTOP
/* tree building routines for declaration tree */
# include "parm.h"

# include <stdio.h>

# include <varargs.h>

# include "ststructs.mh"

# include "stsizes.mh"

# include "stptrs.mh"

# include "stmkfields.mh"

extern char tokenbuf[];  /* temporary string space, shared with scanner */

/*
 *  the BAD flag (Bad Allocation Debug) is used to catch usage of previously
 *  freed nodes.
 */
#ifdef BAD
    extern boolean BADflag;
#endif

#ifndef BAD

# ifdef UNDEFINED
#   define MINPTR 10
  /* Faster version of initfld. */
#   define initfld(pp,v) \
        if ( (*pp = v) > MINPTR) { \
            (void) lock(v); \
        }

  /* Faster version of lock */
#   define lock(p) \
        (((p) -> refcount)++, p)

  /* Faster version of unlock */
#   define unlock(p) \
	(((p) -> refcount)--, p)
# endif

#endif

int retaddr();

extern int yyvline;

/*
 *    Construct a structure with kind field strkind. Set the vlineno field
 * to the current value of yyvline. Fields with the corresponding bit in 
 * stmkfields set are set to the values of the remaining arguments.
 * Other fields are initialized to NIL.
 *
 * The fundamental MACHINE DEPENDENCY here is that all fields must be the
 * same length -- the length of a C "unsigned".
 */

NODE *mknode( va_alist )
va_dcl
{
    va_list ap;
    int strkind;
    register unsigned *p;
    unsigned q;
    register int v; /* bit vector identifying pointer fields in strkind */
    register int i; /* bit vector identifying fields to be initialized  */
                    /* to the argument values. */
    NODE *result;

#   ifdef BAD
        if (BADflag)
            flcheck (0,0);  /* Do a complete free list check */
        else
            flcheck (0,1);  /* Do a quick free list check */
#   endif

    va_start(ap);
    strkind = va_arg(ap, int);

    p = (unsigned *)salloc(stsize[strkind] * (sizeof (NODE *)));
    result = (NODE *)p;

    v = stptrs[strkind];
    i = stmkfields[strkind];
    /* p -> refcount = 0; */
    result -> kind = strkind;
    result -> vlineno = yyvline;
    /* adjust p, i & v to skip standard prefix. For efficiency only */
	p += SZSTANDARDPREFIX;
	i <<= SZSTANDARDPREFIX;
	v <<= SZSTANDARDPREFIX;


    q = va_arg(ap, int);
    while( p - (unsigned *)result < stsize[strkind] ) {
        if ( i < 0 ) {
            /* initialize this field */
                if( v < 0 ) {
                    /* store a pointer field */
                        initfld( p, q );
                } else {
                    /* store a non-pointer field */
                        *p = q;
                }
                q = va_arg(ap, int);
        } else {
            *p = NIL;
        }
	i <<= 1;
	v <<= 1;
        p++;
    }
    va_end(ap);
    
#   ifdef BAD
        if (BADflag) {
            diagmsg("mknode: addr of new node=0%x, kind=%s\n",
                     result, kindname(strkind));
        }
#   endif

    return( result );
}

# ifdef UNDEFINED
/*
 * vfree(p)
 *
 * if *p's reference count is zero,
 *   free *p
 *   decrement reference counts of descendants
 *   call self recursively on descendants
 */

# define MIN_PTR 10   /* lower limit for real pointers. lower values */
		      /* have special significance.                  */

vfree(p)
int *p;
{
    register int size;
    register int v; /* bit vector identifying pointers */
    register unsigned *q;

#   ifdef BAD
        if (BADflag)
            flcheck (0,0);  /* Do a complete free list check */
        else
            flcheck (0,1);  /* Do a quick free list check */
#   endif

    if ( p == NIL ) return;

    if ( !is_refd(p) ) {
        /* call vfree for each child */
            if (( p -> kind) == LISTHEADER ) {
                /* traverse list of descendants */
                    maplist(e, p, {
                        if( !is_refd(unlock(e)) )
                            vfree(e);
                    } );
                /* now free the cons nodes */
                    {   ConsNode *c;
                        for ( c = p -> lh_first; c != NIL; c = cn_del_hd(c) );
                    }
            }
            else {  /* use stptrs to find the children */
                v = stptrs[p -> kind];
                q = p;
                while(v) {
		    if(v < 0 /* *q is a pointer */ && *q > MIN_PTR) {
			if( !is_refd( unlock((NODE *) *q) ) )
			    vfree((NODE *) *q);
                    }
		    v <<= 1;
                    q++;
                }
            }
        /* deallocate storage */
            size = stsize[p -> kind];
#           ifdef BAD
                if (BADflag) {
                    diagmsg("vfree: addr of freed node=0%x, kind=%s, retaddr=0%x\n",
                        p, kindname(p->kind), retaddr());
                }
#           endif
            sfree(p, size * sizeof(NODE *));
    }
}
# endif

/*
 * copynode(np)
 *
 * copy the node np;
 * don't copy the children, but increment their reference counts.
 * Return a pointer to the copy.
 */

NODE * copynode(p)
register NODE *p;
{   int size;
    register int v;   /* bit vector giving pointer fields */
    register unsigned *q; /* pointer to middle of new node      */
    register unsigned *r; /* pointer to middle of original node */
    NODE * result;

    if ( is_list(p) ) 
        return( copylist(p) );
    size = stsize[p -> kind];
    v = stptrs[p -> kind];
    q = (unsigned *)salloc(size * sizeof(NODE *));
    result = (NODE *) q;
    /* copy and adjust reference counts where necessary */
	/* q->refcount = 0; */
        result->kind = p->kind;
	result->vlineno = p->vlineno;
	result->pre_num = p -> pre_num;
	result->post_num = p -> post_num;
	q += SZSTANDARDPREFIX;
	r = (unsigned *)p + SZSTANDARDPREFIX;
	size -= SZSTANDARDPREFIX;
	v <<= SZSTANDARDPREFIX;
        while( size-- ) {
            if( v < 0 ) {
                /* copy a pointer */
                initfld( q, *r );
                q++; r++;
            } else {
                /* copy a nonpointer */
                *q++ = *r++;
            }
	    v <<= 1;
        }
#       ifdef BAD
            if (BADflag) {
                diagmsg("copynode: addr of new node=0%x, kind=%s, retaddr=0%x\n",
                        result, kindname(result->kind), retaddr());
            }
#       endif
    return( result );
}

/*
 * copylist(l)
 *
 * Make a new list which has on it the same elements (not copies) that 
 * are on l.
 */
LIST copylist(l)
LIST l;
{   ConsNode *p;                /* The first element of the constructed list. */
    register ConsNode *q;       /* The last element of the constructed list. */

    p = q = NIL;

#   ifdef DEBUG
        if ( !is_list(l) ) {
            dbgmsg("\ncopylist: arg not a list: l=%x\n",l);
            abort();
        }
#   endif

    maplist(v, l, 
            {   if ( v == first(l) ) 
                    p = q = cn_cons(lock(v),NIL);
                else {
                    cn_settail(q, cn_cons(lock(v), NIL));
                    q = cn_tail(q);
                }
            } );
    return( (LIST) mknode(LISTHEADER, p, q) );
}


/*
 * Used by maprlist below
 */
static void maprl1(l,fn)
ConsNode * l;
void (*fn)();
{
    if (l != NIL) {
      maprl1(cn_tail(l),fn);
      (*fn) (cn_head(l));
    }
}

/*
 *  Apply fn to each element of the list l in reverse order
 */
void maprlist(l, fn)
LIST l;
void (*fn)();
{
    maprl1(l -> lh_first, fn);
}

/* 
 *  Return a pointer to a new LETTERID node with name fldname (a string table
 * index).  Set the id_def_found field.
 */
NODE * mkcompnm(sttptr)
unsigned sttptr;
{
    register NODE * result;
    result = mknode(LETTERID, sttptr);
    result -> id_def_found = TRUE;
    return(result);
}

/*
 * return an identifier node for an identifer with name
 * consisting of string concatenated with the name of id.
 * Id may not be an OPRID.
 * The returned id has id_def_found set.  (It is presumed to be a
 * a field name.)
 */
NODE * prefix(string, id)
char * string;
NODE * id;
{
#   ifdef DEBUG
	if (id -> kind != LETTERID) {
            dbgmsg("prefix: bad identifier node\n");
	}
#   endif
    strcpy(tokenbuf, string);
    strcat(tokenbuf, getname(id -> id_str_table_index));
    return(mkcompnm(stt_enter(tokenbuf, strlen(tokenbuf)+1)));
}

NODE *mknode( va_alist )
va_dcl
{
    va_list ap;
    int strkind;
    register unsigned *p;
    unsigned q;
    register int v; /* bit vector identifying pointer fields in strkind */
    register int i; /* bit vector identifying fields to be initialized  */
                    /* to the argument values. */
    NODE *result;

#   ifdef BAD
        if (BADflag)
            flcheck (0,0);  /* Do a complete free list check */
        else
            flcheck (0,1);  /* Do a quick free list check */
#   endif

    va_start(ap);
    strkind = va_arg(ap, int);

    p = (unsigned *)salloc(stsize[strkind] * (sizeof (NODE *)));
    result = (NODE *)p;

    v = stptrs[strkind];
    i = stmkfields[strkind];
    /* p -> refcount = 0; */
    result -> kind = strkind;
    result -> vlineno = yyvline;
    /* adjust p, i & v to skip standard prefix. For efficiency only */
	p += SZSTANDARDPREFIX;
	i <<= SZSTANDARDPREFIX;
	v <<= SZSTANDARDPREFIX;


    q = va_arg(ap, int);
    while( p - (unsigned *)result < stsize[strkind] ) {
        if ( i < 0 ) {
            /* initialize this field */
                if( v < 0 ) {
                    /* store a pointer field */
                        initfld( p, q );
                } else {
                    /* store a non-pointer field */
                        *p = q;
                }
                q = va_arg(ap, int);
        } else {
            *p = NIL;
        }
	i <<= 1;
	v <<= 1;
        p++;
    }
    va_end(ap);
    
#   ifdef BAD
        if (BADflag) {
            diagmsg("mknode: addr of new node=0%x, kind=%s\n",
                     result, kindname(strkind));
        }
#   endif

    return( result );
}
#DJDSTART
$include "defs.icn"
$include "global_vars.icn"

procedure mknode(va_alist)
# yyvline is a global
    local i,arg,arg1,arg2,arg3,arg4,arg5,arg6,arg7,arg8,arg9,arg10,arg11,arg12,arg13,arg14,arg15,arg16,ret,kind,pre_num,post_num,cn_tl_field,cn_hd_field
    
    cn_tl_field := cn_hd_field := pre_num := post_num := arg1 := arg2 := arg3 := arg4 := arg5 := arg6 := arg7 := arg8 := arg9 := arg10 := arg11 := arg12 := arg13 := nil
    i := 1
    yyinfo("mknode va_alist")
    nodes_total_cnt +:=  1
    nodes_made_cnt +:= 1
    every (arg := !va_alist) do {
	case i of {
	    1: arg1 := arg
	    2: arg2 := arg
	    3: arg3 := arg
	    4: arg4 := arg
	    5: arg5 := arg
	    6: arg6 := arg
	    7: arg7 := arg
	    8: arg8 := arg
	    9: arg9 := arg
	    10: arg10 := arg
	    11: arg11 := arg
	    12:  arg12 := arg
	    13: arg13 := arg
	    14: arg14 := arg
	    15: arg15 := arg
	    16: arg16 := arg
	    default: rpt_err("mknode no of args not implemented")
	}
	i +:= 1
    }

    case arg1 of {
	DECLARATION:  ret :=  DeclarationNode(arg2,arg3,arg4,arg5,arg6,arg7,arg8,arg9,arg10,arg11,arg12,arg13,arg14,arg15,arg16,arg1,yyvline,pre_num,post_num)  
	PARAMETER: ret :=  ParameterNode(arg2,arg3,arg4,arg5,arg6,arg7,arg8,arg1,yyvline,pre_num,post_num) 
	RECORDELEMENT:    ret :=   RElementNode(arg2,arg3,arg4,arg5,arg6,arg1,yyvline,pre_num,post_num)
	VARSIGNATURE: ret :=  VarSignature(arg2,arg3,arg4,arg1,yyvline,pre_num,post_num) 
	VALSIGNATURE: ret :=  ValSignature(arg2,arg3,arg4,arg1,yyvline,pre_num,post_num) 
	FUNCSIGNATURE: ret :=     FSignature(arg2,arg3,arg4,arg5,arg6,arg7,arg8,arg9,arg10,arg1,yyvline,pre_num,post_num) 
	TYPESIGNATURE: ret :=  TSignature(arg2,arg3,arg4,arg5,arg6,arg7,arg8,arg9,arg10,arg11,arg12,arg1,yyvline,pre_num,post_num)
	TSCOMPONENT:   ret :=  TSComponentNode(arg2,arg3,arg1,yyvline,pre_num,post_num)
	DEFCHARSIGS: ret :=  DefCharSigNode(arg2,arg3,arg4,arg5,arg6,arg1,yyvline,pre_num,post_num)
	LISTHEADER: ret :=  ListHeaderNode(arg2,arg3,arg1,yyvline,pre_num,post_num) 

	SIGNATURESIG: ret :=  SignatureSigNode(arg2,arg3,arg1,yyvline,pre_num,post_num) 
	BLOCKDENOTATION: ret :=  BlDenotationNode(arg2,arg3,arg4,arg5,arg6,arg7,arg8,arg9,arg10,arg11,arg1,yyvline) 
	USELIST: ret :=  UseListNode(arg2,arg3,arg4,arg5,arg6,arg7,arg1,yyvline,pre_num,post_num) 
	APPLICATION: ret :=  ApplicationNode(arg2,arg3,arg4,arg5,arg6,arg1,yyvline,pre_num,post_num)
	ENUMERATION: ret :=  EnumerationNode(arg2,arg3,arg4,arg1,yyvline,pre_num,post_num)
	EXTENSION: ret :=  ExtensionNode(arg2,arg3,arg4,arg5,arg6,arg1,yyvline,pre_num,post_num)
	PRODCONSTRUCTION: ret :=  ProductNode(arg2,arg3,arg4,arg5,arg6,arg1,yyvline,pre_num,post_num)  
	RECORDCONSTRUCTION: ret :=  RecordConstructionNode(arg2,arg3,arg4,arg5,arg1,yyvline,pre_num,post_num)
	UNIONCONSTRUCTION: ret :=  UnionConstructionNode(arg2,arg3,arg4,arg5,arg6,arg1,yyvline,pre_num,post_num)
	WITHLIST: ret :=   WithListNode(arg2,arg3,arg4,arg1,yyvline,pre_num,post_num) 
	MODPRIMARY: ret :=   ModPrimaryNode(arg2,arg3,arg4,arg5,arg6,arg7,arg8,arg9,arg10,arg11,arg1,yyvline,pre_num,post_num) 
# looks 1 extra
	EXPORTLIST: ret :=  ExportListNode(arg2,arg3,arg4,arg1,yyvline,pre_num,post_num)
# looks 3 extra
	HIDELIST: HideListNode(arg2,arg3,arg4,arg1,yyvline,pre_num,post_num)

	EXPORTELEMENT: ret :=  ExportElementNode(arg2,arg3,arg4,arg1,yyvline,pre_num,post_num)
	ALLCONSTANTS: ret :=  AllConstantsNode(arg1,yyvline,pre_num,post_num)
	WORDELSE: ret :=  WordElseNode(arg2,arg3,arg1,yyvline,pre_num,post_num) 
	WORDCAND:     ret :=  WordCandNode(arg1,yyvline,pre_num,post_num) 
	WORDCOR: ret :=   WordCorNode(arg1,yyvline,pre_num,post_num)
	GUARDEDLIST: ret :=  GuardedListNode(arg2,arg3,arg4,arg1,yyvline,pre_num,post_num) 
	LOOPDENOTATION: ret :=  LoopDenotationNode(arg2,arg3,arg4,arg1,yyvline,pre_num,post_num) 
	GUARDEDELEMENT: ret :=  GuardedElementNode(arg2,arg3,arg1,yyvline,pre_num,post_num) 



	OPRID: ret :=  OpridNode(arg2,arg3,arg4,arg5,arg6,arg7,arg8,arg9,arg10,arg11,arg1,yyvline,pre_num,post_num) 
	LETTERID: ret :=  LetterId(arg2,arg3,arg4,arg5,arg6,arg7,arg8,arg9,arg10,arg11,arg1,yyvline,pre_num,post_num)
	QSTR: ret :=  QStrNode(arg2,arg3,arg4,arg5,arg6,arg7,arg1,yyvline,pre_num,post_num) 
	UQSTR: ret :=  UQStrNode(arg2,arg3,arg4,arg5,arg6,arg7,arg1,yyvline,pre_num,post_num) 
	FUNCCONSTR: ret :=  FConstruction(arg2,arg3,arg4,arg5,arg6,arg7,arg8,arg9,arg10,arg11,arg1,yyvline,pre_num,post_num)  
# looks 3 extra
	FREEVARNODE: ret :=  FreeVarNode(arg2,arg3,arg4,arg5,arg1,yyvline,pre_num,post_num)
	EXTERNDEF: ret :=  ExternDefNode(arg2,arg1,yyvline,pre_num,post_num) 
	REXTERNDEF: ret :=  RExternDef(arg2,arg3,arg4,arg1,yyvline,pre_num,post_num)  
	DCSEXCEPTION:  ret :=   DcsException(arg2,arg3,arg4,arg5,arg1,yyvline,pre_num,post_num) 
	default: rpt_err("mknode not implemented dump_info(arg1) = " || dump_info(arg1))
    }
    rpt_node("mkode return",ret)

#    ret.dump()
     return ret
end

#
# copylist(l)
#
# Make a new list which has on it the same elements (not copies) that 
# are on l.
#
procedure copylist(l)
    local l2
    l2 := copy(l)
    return l2
end
procedure rpt_node(where,node_it)
local kind
initial  nodeinfo("where" || repl(" ",32 - *"where") || "kind" || repl(" ",8 - *"kind") || "type(node)")
kind := node_it.kind
if \kind then
    nodeinfo(where || repl(" ",32 - *where) || kind || repl(" ",8 - *kind) || type(node_it))
else
    nodeinfo(where || repl(" ",32 - *where) || "nil")
return TRUE
end

#

# 
 #  Return a pointer to a new LETTERID node with name fldname (a string table
 # index).  Set the id_def_found field.
 #
procedure mkcompnm(sttptr)
local    result
    result := mknode([LETTERID, sttptr])
    result.id_def_found := TRUE;
    return(result)
end


 # return an identifier node for an identifer with name
 # consisting of string concatenated with the name of id.
 # Id may not be an OPRID.
 # The returned id has id_def_found set.  (It is presumed to be a
 # a field name.)
 #

procedure prefix(string, id)
local tokenbuf
    tokenbuf := string || getname(id.id_str_table_index) 
    return(mkcompnm(stt_enter(tokenbuf, *tokenbuf)))
end

#
#  Apply fn to each element of the list l in reverse order
#
procedure maprlist(l, fn)
    maprl1(l.lh_first, fn)
end

#
# Used by maprlist above
#
procedure maprl1(l,fn)
    if \l  then {
      maprl1(l.cn_tl_field,fn)
      fn(l.cn_hd_field)
    }
end




#DJDSTOP
