###############################################################################
#
#	File:     RIC.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.
#
###############################################################################
#DJDSTART
$include "defs.icn"
$include "global_vars.icn"

class RIC_instr(
		op_code,
		arg_arr3,                # Only used if label_arg = FALSE
		n_args,
		label_arr1,
		next_instr,
		prev_instr,
		# Fields set by set_regs
		result_reg,     # The result register
		op1_reg,        # Positions of operand registers, i.e. 0,1,2
		op2_reg,        # or NONE
		#       define NONE -1
		side_effect,
		label_arg,
		second_decl     # This is a redeclaration of a previously used
		# location.
	        )             # Only used if label_arg = TRUE
end
# hash table structure for op codes and special locations
#DJDSTOP
# class hrecord(
#     hr_name,
#     hr_val,
#     hr_next
# )
# end
# 
# # define DEBUG DEBUG
# #include <stdio.h>
# #include <ctype.h>
# #include "../parm.h"
# #include "op_codes.h"
# #include "codegen.h"
# 
# #define OCLENGTH 9  /* maximum length of mnemonics */
# 
# #define MAXLOC 100000  /* Largest plausible location number */
# 
# /* Miscellaneous routines for conversion between representations */
# /* of Russell Intermediate Code                                  */
# 
# /* hash table structure for op codes and special locations */
# typedef struct hrecord {
#     char hr_name[OCLENGTH+1];
#     int hr_val;
#     struct hrecord * hr_next;
# } hrecord;
# 
# # define NIL 0
# 
# # define TABSIZE 50
# # define hash(s) ((((s)[0]<<2) + (((s)[1]) == '\0'? 0 : (s)[1] + (s)[2]))%TABSIZE)
# 
# static hrecord * htable[TABSIZE];
# 
# # Add entry with name nm and value vl to the hash table.  No check is made
# # to see whether it is already there.
# procedure add_RIC_table(nm, val)
#     htable[nm] := hrecord(nm, val)
# end
# 
# extern char * op_code_table[];
# #define NONE ((char *)0)
# 
# /* Initialize htable to contain opcodes and predefined location names */
# void init_RIC_table()
# {
#     int i;
#     /* Op codes */
#       for ( i = 0; i < N_OP_CODES; i++ ) {
#           if (op_code_table[i] != NONE) {
#               add_RIC_table(op_code_table[i], i);
#           }
#       }
#     /* Special locations */
#       add_RIC_table("RS", RS);
#       add_RIC_table("AR", AR);    /* activation record pointer */
#       add_RIC_table("SP", SP);    /* stack pointer             */
#       add_RIC_table("GF", GF);    /* global frame pointer      */
#       add_RIC_table("UN", UN);    /* undefined value constant  */
#       add_RIC_table("SK", SK);    /* value sink                */
#       add_RIC_table("RL", RL);    /* function result location  */
#       add_RIC_table("TL", TL);    /* test result location      */
#       add_RIC_table("C0", C0);    /* constant 0                */
#       add_RIC_table("C1", C1);    /* constant 1                */
#       add_RIC_table("C2", C2);    /* constant 2                */
#       add_RIC_table("C3", C3);    /* constant 3                */
#       add_RIC_table("C4", C4);    /* constant 4                */
#       add_RIC_table("T1", T1);    /* temporary 1               */
#       add_RIC_table("T2", T2);    /* temporary 2               */
#     /* Types for DCL instruction */
#       add_RIC_table("ADDR", DCL_ADDR);
#       add_RIC_table("INT", DCL_INT);
#       add_RIC_table("FLOAT", DCL_FLOAT);
#       add_RIC_table("DBL_FLOAT", DCL_DBL_FLOAT);
#     /* Kinds for HINT instruction */
#       add_RIC_table("OPT", OPT);
#       add_RIC_table("NP", NP);
#       add_RIC_table("PT", PT);
#       add_RIC_table("AL", AL);
#       add_RIC_table("DEA", DEA);
#       add_RIC_table("NSC", NSC);
#       add_RIC_table("STSZ", STSZ);
#       add_RIC_table("DEAD", DEAD);
#       add_RIC_table("GFU",GFU);
#       add_RIC_table("LIVE",LIVE);
#       add_RIC_table("ET", ET);
#       add_RIC_table("ONS", ONS);
# }
# 
# /* Look up the indicated name in the hash table. Return the associated */
# /* value.   Returns MISSING if entry is not found                      */
# int find_RIC_table(name)
# char * name;
# {
#     register hrecord * ce = htable[hash(name)];
# 
#     while (ce != NIL) {
#         if (strcmp(ce -> hr_name, name) == 0) {
#             return (ce -> hr_val);
#         }
#         ce = ce -> hr_next;
#     }
# 
#     return(MISSING);
# }
# 
# /* Copy the string pointed to by p to field_buf.  Stop after OCLENGTH */
# /* characters, or after a \0, \b, \t, \n.                             */
# /* Return a pointer to the field separator.                           */
# static char field_buf[OCLENGTH+1];
# #DJDSTART
procedure extract_field(p)
    field_buf := (p ? tab(upto(' \t\n,;')) | p[0])
    p := p[*field_buf,0]
    return p
end

# Free a sequence of RIC instructions
procedure free_RIC(p)
    local current, next2

    current := p
    while \ current do {
	next2 := current . next_instr
	current := NULL
	current := next2
    }
end

# Write out a sequence of RIC instructions onto stream f
procedure put_RIC(seq, f)
    local current

    current := seq
    while \ current do {
	writes(f, current . op_code, ",") # Must be non-zero
	writes(f, current . label_arg, ",")
	writes(f, current . n_args, ",")
	if (current . label_arg == "TRUE") then {
	    write(f, current . label, ";")
	} else {
	    writes(f, current . arg[0], ",")
	    writes(f, current . arg[1], ",")
	    write(f, current . arg[2], ";")
	}
	 current := current . next_instr
    }
    # Write a terminating null op code
    writes(f,";")
end

# Read a sequence of RIC instructions written by put_RIC
# update avail_loc to be larger than any location encountered.
procedure get_RIC(f)
    local current
    local last;
    local result
    local opcode
    local label_arg
    local n_args
    local arg0
    local label_buf
    local line
    local arg3 := list(3,0)
    result := NULL

    while line := read(f) do {
	line ? (opcode := tab(upto(',')) &
		label_arg := tab(upto(',')) &
		n_args := tab(upto(',')) &
		rest := tab(upto(';')))
	if label_arg == "TRUE" then
	    {
		label_buf := rest
	    }
	else
	    {
		rest ? (arg3[1] := arg0 := tab(upto(',')) &
			arg3[2] := tab(upto(',')) &
			arg3[3] := tab(0))
		label_buf := ""
	    }
	current := RIC_instr(op_code,arg3,n_args,label_buf)
	# update avail_loc
	if (opcode = DCL & arg0 >= avail_loc) then
	    {
		if (iand(arg0 , ARG_BIT) ~= 0 | arg0 = RS) then
		    {
			dbgmsg("get_RIC: Attempt to declare argument or result\n")
			abort(arg0)
		    }
		avail_loc := arg0 + 1
	    }
	# Add current to the end of result sequence
	if / result then
	    {
		result := last := current
	    }
	else
		{
		    last . next_instr := current
		    last := current
		}
    }
    return(result)
end
# Write out the RIC instruction on stream f.  Add n-1 to each argument
# number appearing in the instruction, except if n = 0.
# If n = 0, map the first argument to the top of the stack, the second
# one to below the top of the stack, etc.  RS location by the value of
# rs.
procedure write_RIC(f, RIC_i, n, rs)
    local result, arg
    local i, is_ldn
    writes(f, RIC_i -> op_code, ",")
    if (RIC_i . label_arg == "TRUE") then
	{
	    write(f, RIC_i . label,";")
	    putc('\0',f)
	}
    else
	    {
		while i < RIC_i.n_args do {
		    writes(f, RIC_i.arg3[i+1],",")
		    i += 1
		}
		write(f, ";")
	    }
end
# Parse a sequence of RIC instructions, represented as above.      */
# Translate arguments and RS references as above.                  */
procedure write_RIC_seq(f, RIC_seq, n, rs)

   local p
   p := RIC_seq

    while \p do {
	write_RIC(f, p, n, rs)
	p = p . next_instr
    }
end

# Write out a label operand instruction onto file f
procedure genl_RIC(f, op, label)
    writes(f,op,",")
    write(f,label, ";")
end

# Write out a location operand instruction onto file f
procedure gen_RIC(f, op, arg1, arg2, arg3)
    writes(f, op, ",")
    writes(f, arg1, ",")
    writes(f, arg2, ",")
    write(f, arg3, ";")
end

# Copy a sequence of RIC instructions
procedure copy_RIC(p)
    local result
    result := deepcopy(p)
    return(result)
end

# Destructively concatenate two sequences of RIC instructions
procedure cat_RIC(p,q)
    local r

    if / p then
	return(q)
    else {
	r := p
	while / (r . next_instr) do {
	    r -> next_instr = q
	    r := r . next_instr
	}
    }
    return(p);
end

# Replace arguments in RIC sequence by consecutively numbered locations
# (virtual registers) starting with location n.
# This is done destructively.
procedure RIC_inst_args(p, n)
    local r
    local i
    local is_ldn     # First argument to current instruction is a
    # potentially huge integer constant. Ignore
    # its ARG_BIT.
    local arg_no

    r := p
    while \r do {
	if (r . op_code = LDN | r . op_code = IDT) then
	    is_ldn := 1
	else
	    is_ldn := 0
	i := 0
	while i < r -> n_args & r . label_arg ~== "TRUE" do {
	    if (is_ldn ~= 0 | i >= 1) then {
		if (iand(r . arg[i]) , ARG_BIT) ~= 0 then  {
		    arg_no := iand(r . arg[i + 1] , icomp( ARG_BIT))
		    r . arg[i] := arg_no + n - 1
		}
	    }
	    i +:= 1
	}
	r := r . next_instr
    }
    return(p)
end

# Replace RS in RIC sequence by the location n.
# This is done destructively.
procedure RIC_inst_rs(p, n)

    local r
    local i
    local is_ldn     # First argument to current instruction is a
		     # potentially huge integer constant. Ignore.

    r := p
    while \r do {
	if (r . op_code = LDN | r . op_code = IDT) then
	    is_ldn := 1
	else
	    is_ldn := 0
	i := 0
	while i < r . n_args & r . label_arg ~= 0 do {
	    if (is_ldn ~= 0 | i >= 1) then {
		if ((r . arg[i + 1]) = RS) then {
		    r . arg[i] := n
		}
	    }
	    i +:= 1
	}
	r := r . next_instr
    }
    return(p)
end

# Return the length of an instruction sequence, discounting HINT
# instructions and optional code.
procedure RIC_len(p)
    local r
    local i

    i := 0

    r := p
    while \r do {
	i +:= 1
	if (r . op_code = HINT) then {
	    i -:= 1
	    if (r . arg[1] = OPT) then {
		i -:= r . arg[2]
	    }
	}
	r := r . next_instr
    }
    return(i)
end

# Initialize htable to contain opcodes and predefined location names */
    procedure init_RIC_table()
local i,op_code_table

# RIC (Russell Intermediate Code) Op codes */
    $define RIC_TABSIZE 200
$define NONE  "0"
op_code_table := [
		  NONE,   "BR",   "BRT",  "BRF",  "CLL",
		  "LBL",  "EXT",  "LBA",  NONE,   "BFN",
		  "TFB",  "TFE",  "PRO",  "ADT",  "ERR",
		  "BSF",  "LBR",  "DDT",  "FDT",  NONE,
		  "DCL",  "UDC",  "ALH",  "GAR",  "ALS",
		  "LDI",  "STI",  "CLI",  "LDN",  "RTN",
		  "LDL",  "MOV",  "TAR",  "PSH",  NONE,
		  "ADP",  "CLC",  "ALA",  "HINT", "ARG",
		  "ADI",  "SBI",  "MLI",  "DVI",  "NGI",
		  "IDT",  "EQI",  "LTI",  "GTI",  "NEI",
		  "LEI",  "GEI",  "SHI",  "ABI",  NONE,
		  NONE,   NONE,   NONE,   NONE,   NONE,
		  "TRU",  "FLS",  "AND",  "OR",   "NOT",
		  NONE,   NONE,   NONE,   NONE,   NONE,
		  "LDS",  "LDC",  NONE,   NONE,   NONE,
		  NONE,   NONE,   NONE,   NONE,   NONE,
		  "ADF",  "SBF",  "MLF",  "DVF",  "NGF",
		  "EXF",  "EQF",  "LTF",  "GTF",  "NEF",
		  "LEF",  "GEF",  "SHF",  NONE,   NONE,
		  NONE,   NONE,   NONE,   NONE,   NONE,
		  NONE,   NONE,   NONE,   NONE,   NONE]





RIC_table := table(RIC_TABSIZE,0)

# Op codes
# arrays (really lists) in unicon start at 1
i := 1
while (i <= *op_code_table) do {
if (op_code_table[i] ~== NONE) then {
RIC_op_code_cnt +:= 1
add_RIC_table(op_code_table[i], i-1 )
}
i +:= 1
}

# Special locations
add_RIC_table("RS", RS);
add_RIC_table("AR", AR);    # activation record pointer
add_RIC_table("SP", SP);    # stack pointer
add_RIC_table("GF", GF);    # global frame pointer
add_RIC_table("UN", UN);    # undefined value constant
add_RIC_table("SK", SK);    # value sink
add_RIC_table("RL", RL);    # function result location
add_RIC_table("TL", TL);    # test result location
add_RIC_table("C0", C0);    # constant 0
add_RIC_table("C1", C1);    # constant 1
add_RIC_table("C2", C2);    # constant 2
add_RIC_table("C3", C3);    # constant 3
add_RIC_table("C4", C4);    # constant 4
add_RIC_table("T1", T1);    # temporary 1
add_RIC_table("T2", T2);    # temporary 2
# Types for DCL instruction
add_RIC_table("ADDR", DCL_ADDR);
add_RIC_table("INT", DCL_INT);
add_RIC_table("FLOAT", DCL_FLOAT);
add_RIC_table("DBL_FLOAT", DCL_DBL_FLOAT);
# Kinds for HINT instruction
add_RIC_table("OPT", OPT);
add_RIC_table("NP", NP);
add_RIC_table("PT", PT);
add_RIC_table("AL", AL);
add_RIC_table("DEA", DEA);
add_RIC_table("NSC", NSC);
add_RIC_table("STSZ", STSZ);
add_RIC_table("DEAD", DEAD);
add_RIC_table("GFU",GFU);
add_RIC_table("LIVE",LIVE);
add_RIC_table("ET", ET);
add_RIC_table("ONS", ONS);
return TRUE
end

procedure add_RIC_table(nm, val)
    if \val then {
	RIC_table_entry_cnt +:= 1
	RIC_table[nm] := val
    }
return TRUE
end



# Look up the indicated name in the hash table. Return the associated
# value.   Returns MISSING if entry is not found
procedure find_RIC_table(name)
    local it
    if (\it := RIC_table[name]) then
	return it
    else
	return(MISSING)
end


#DJDSTOP
# # Write out a label operand instruction onto file f
# procedure genl_RIC(f, op, label)
# #    putw(op, f);
# #    fputs(label, f);
# #    putc('\0', f);
#     write(f, "label(" ||  dump_info(op) || ","  || dump_info(label) || ")" )
#     return TRUE
# end
# 
# # Write out a location operand instruction onto file f/
# procedure gen_RIC(f, op, arg1, arg2, arg3)
# #    ASSERT((arg1 <= MAXLOC || op == LDN || op == IDT)
# #	   && arg2 <= MAXLOC && arg3 <= MAXLOC,
# #	   "Bad operand to gen_RIC\n");
# 
# #    putw(op, f);
# #    putw(arg1, f);
# #    putw(arg2, f);
# #    putw(arg3, f);
# write(f, dump_info(op) || "(" || dump_info(arg1) || "," || dump_info(arg2) || "," || dump_info(arg3) || ")" )
#     return TRUE
# end
# #DJDSTART
# Convert a string representing RIC code to internal form. The string
# is assumed to contain a number of newline or ; separated
# instructions. The result is a linked list of RIC_instr nodes.
# The original string is freed unless it was statically allocated.
procedure Ginline_cnvt(s)
local p, first, lastq, q

    p := s
    first := nil
    last := nil
    q := nil

    every  p :=  !s do {
	if p == ";" then next
	q := parse_RIC(p)
	if ( / first ) then {
	    first := last := q
	} else {
	    last . next_instr := q
	    last := q
	}
    }
    last . next_instr := nil
#    if (s > &end) {
#      free(s);
#    }
    return(first)
end
# Parse the text line *s, which is assumed to contain a mnemonic
# description of an RIC instruction.  Return a pointer to a newly
# allocated RIC_instr node.   A pointer to the ';', \n, or \0 character
# trailing the line is returned in *s.
procedure parse_RIC(s)
#   define skip_blanks while (*p == ' ' || *p == '\t' || *p == ',') { p++; }
#   define AT_END (*p == '\0' || *p == '\n' || *p == ';')
    local p := s
    local op_code
    local i
    local result
    local q

    s := trim(s,' \t',1)
    p := extract_field(p)
    op_code := find_RIC_table(field_buf)
#    skip_blanks ## DJD TRIM??
    if (p == '\"') then {
        # label
        p := p[1,0]
	n_args := 1
	next_instr := NULL
	if p[1] == "\"" then {
	    p := p[1,0]
	    if p[1] ~= "\\" then {
		k := 0
		every j := 1 to 3 do  {
		    k := 8*k + p[j]
		}
		label := k
	    }
	    else
		label := p ? (tab(upto("\"")))
	    skip_blanks
	    label_arg := TRUE

	    result := RIC_instr(op_code,,next_instr,,,,,,label_arg,,label)
	}
    }
    else
	{
	    # numeric arguments
	    label_arg := FALSE
	    n_args := 0;
	    next_instr := NULL
	    n_args := 0
	    arg_arr3[1]:= (p ? tab(any(&digits)))
	    p := p[*(arg_arr3[1]),0]
	    if *(arg_arr3[1]) > 0 then {
		n_args += 1
		arg_arr3[2]:= (p ? tab(any(&digits)))
		p := p[*(arg_arr3[2]),0]
		if *(arg_arr3[2]) > 0 then {
		    n_args += 1
		    arg_arr3[3]:= (p ? tab(any(&digits)))
		    p := p[*(arg_arr3[3]),0]
		    if *(arg_arr3[3]) > 0 then {
			n_args += 1
		    }
		}
	    }
	    result := RIC_instr(op_code,arg_arr3,next_instr,,,,,,,,)
	}
    s := p
    return result
end

