###############################################################################
#
#	File:     tgig_order.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 DEBUG
# # include "parm.h"
# 
# # include "stree/ststructs.mh"
# 
# # include "stree/Array.h"
# 
# # include "pass4/sigs.h"
# 
# int comp_tsc();             /* comparison routine for sorting         */
# 
# void add_dcse();            /* Add to the exception list of the default */
# 			    /* character signature list                 */
# 
# static NODE * type_sig;     /* copy of parameter to tsig_order        */
# 			    /* used by comp_tsc                       */
# 
# char * getname();
# #DJDSTART
#
#  tsig_order(type_signature)
#
#  Rearrange the type_signature in the canonical order given
# in the WHAT file.
#

procedure tsig_order(tsig)
    local a, a_len, constants, i,j, p, q, r, csig, nm
    local  word, bitno , character


    a := list_to_array(tsig . ts_clist)
    a_len := a.a_size
    constants = lock(mknode([DEFCHARSIGS,0,0,0,0]))
    # build constants node
    i := 1
    while i <= a_len do {
#        for(i = 0; i < a_len; i++) {
	if (a.a_body[i] . kind = DEFCHARSIGS) then {
	    p := a.a_body[i] . dcs_0
	    q := constants . dcs_0
	    j := 1
	    while j <= NVECTORS do {
#                for (j = 0; j < NVECTORS; j++) {
		q[j] := ior(q[j],  p[j])
	    }
	    # Cancel the node in the array
	    unlock(a.a_body[i])
	    a.a_body[i] := nil
	} else {
	    csig := a.a_body[i] . tsc_signature;
	    if ( is_const(csig, tsig) ) then {
		nm := getname(a.a_body[i] . tsc_id . id_str_table_index)
		if ( nm[1] == "'" & nm[3] == "'" ) then {
		    # This is a constant
		    character = nm[2]
		    if (special_tp(csig . fsig_special) ~= NOT_SPECIAL |
			\ csig . fsig_inline_code |
			\ csig . fsig_construction ) then {
			    if (\ (constants . dcs_exceptions) ) then {
				constants . dcs_exceptions := emptylist()
			    }
			    add_dcse(constants . dcs_exceptions, character,
				     csig . fsig_inline_code,
				     csig . fsig_special,
				     csig . fsig_construction)
			}
		}
	    }
	}
    }

    # Sort the remaining array
    type_sig := tsig;
#	qsort(&a.a_body[0], a_len, (sizeof (NODE *)), comp_tsc);
    sort(a)

    # Put everything back into the type signature node
    tsig . ts_clist := mklist([constants])
    i := 1
    while i <= a_len do {
	addright(tsig . ts_clist, a.a_body[i])
	i +:= 1
    }
end

#DJDSTOP
# # compare 2 TSCOMPONENT structures
# procedure comp_tsc(p, q)
# local i
# i =  strcmp(getname((*p) . tsc_id . id_str_table_index),
# 		getname((*q) . tsc_id . id_str_table_index));
#     if (i == 0)
# 	return(comp_st((*p) . tsc_signature, (*q) . tsc_signature,
# 		       type_sig, type_sig));
#     else
# 	return(i);
# }
# 
# #
#  *  is_const(sig,tsig)
#  *  returns TRUE iff sig has the form
#  *  func[] val local_type_id and if it is not special.
#  *  (It is unsafe to lose special information, e.g. in enum constructions.
#  *  Thus we check for its presence.  Special constants are never part
#  *  of strings compiled with in-line code.  Thus this shouldn't matter.)
# 
# 
# boolean is_const(sig,tsig)
# NODE * sig, * tsig;
# {
# 
#     if(sig == NIL) return(FALSE);
#     if(sig . kind == FUNCSIGNATURE
#        && is_empty(sig . fsig_param_list)
#        && sig . fsig_result_sig != ERR_SIG
#        && sig . fsig_result_sig . kind == VALSIGNATURE) {
# 	    NODE * tden = sig . fsig_result_sig . val_denotation;
# 
# 	    if( (tden.kind == LETTERID || tden.kind == OPRID)
# 		 && (tden . id_str_table_index == -1
# 		     || tden . id_last_definition == tsig)) {
# 		return(TRUE);
# 	    }
# 
#     }
#     if((sig . kind == LETTERID || sig . kind == OPRID)
#        && sig . id_last_definition != NIL
#        && sig . id_last_definition . kind == DECLARATION
#        && sig . id_last_definition . decl_sig_transp
#        && sig . id_last_definition . post_num < sig . post_num) {
# 	return(is_const(sig . id_last_definition . decl_denotation));
#     }
#     return(FALSE);
# }
# 
# #
#  *  Add an exception with the given character, in-line code, special, and
#  * construction fields to the character constant eception list l.
#  * This is a DESTRUCTIVE operation.
# 
# void add_dcse(l, character, in_line, spcl, construction)
# NODE *l;
# int character;
# char *in_line;
# int spcl;
# NODE *construction;
# {
#     NODE * new_node = mknode(DCSEXCEPTION);
# 
#     new_node . dcse_char = character;
#     new_node . dcse_inline = in_line;
#     new_node . dcse_special = spcl;
#     new_node . dcse_construction = construction;
#     mapinslist(s, l, {
# 	if (s == NIL || s . dcse_char > character) {
# 	    INSERT(new_node);
# 	    break;
# 	} else if (s . dcse_char == character) {
# 	    # Entries are never deleted.  Thus there could still be an
# 	    # obsolete entry for the same character.
# 	    REPLACE(new_node);
# 	    break;
# 	}
#     });
# }
