###############################################################################
#
#	File:     mine.icn
#
#	Subject:  russell language support functions
#
#	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"

procedure open_my_files()

# MESSAGING FILES
    if not(errfile:= open("russ_err.tmp","w")) then stop("cannot open russ_err.tmp")
    if not(infofile:= open("russ_info.tmp","w")) then stop("cannot open russ_info.tmp")
# PARSER ACTIONS - etc. 
    if not(reduce := open("reduce.tmp","w")) then stop("cannot open reduce.tmp")
# TOKENS FROM SCANNER 
    if not(progress := open("progress.tmp","w")) then stop("cannot open progress.tmp")
# STAISTICS
    if not(stats := open("stats.tmp","w")) then stop("cannot open stats.tmp")
# NODES
    if not(nodes := open("nodes.tmp","w")) then stop("cannot open nodes.tmp")
# CHARACTER STREAM
    if not(ccode_file := open("ccode.tmp","w")) then stop("cannot open ccode.tmp")
# LISTS CREATED
    if not(lists_created_file := open("lists.tmp","w")) then stop("cannot open lists.tmp")
# NODES CREATED
    if not(nodes_created_file := open("nodes_created.tmp","w")) then stop("cannot open nodes_created.tmp")
    if not(nodes_created_trace_file := open("nodes_created_trace.tmp","w")) then stop("cannot open nodes_created_trace.tmp")
    writes(nodes_created_trace_file,left("NodeTypeName",20),right("kind",10),right("vlineno",10),right("pre_num",10 ),right(dumpost_num),10 ))
    write(nodes_created_trace_file,right(dump_info(self.unique_id),12),right(dump_info(self.cn_hd_field),20),right(dump_info(self.cn_tl_field),20))

# CONS NODES
    if not(cons_file := open("cons.tmp","w")) then stop("cannot open cons.tmp")
# PARSE TREE DUMP
    if not(treefile := open("tree.tmp","w")) then stop("cannot open tree.tmp")
# SYMBOL TABLE
    if not(symfile := open("sym.tmp","w")) then stop("cannot open sym.tmp")
# SYMBOL2 TABLE
    if not(sym2file := open("sym2.tmp","w")) then stop("cannot open sym2.tmp")
    if not(optsfile := open("opts.tmp","w")) then stop("cannot open opts.tmp")
    if not(callfile := open("call.tmp","w")) then stop("cannot open call.tmp")
    return TRUE
end
procedure rpt_call(str)
    write(callfile,str)
    return TRUE
end

procedure rpt_err(str)
    write(&errout,"ERROR: " || str)
    write(errfile,"ERROR: " || str)
    write(infofile,"ERROR: " || str)
    rpt_stats()
    rpt_opts()
    exit(1)
end
procedure rpt_it(str,lvl)
    static counter, hdr
    initial 
	{
	    counter := 0
	    hdr := ["WARNING: ","INFO: ","DEBUG: "]
	}
    counter +:= 1
    if counter > 10000 then
	rpt_err("PROBIBLE INFINITE LOOP max 10000 reached")
    if rpt_lvl >= lvl then
	{
	    write(&errout,hdr[lvl] || str)
	    write(infofile,hdr[lvl] || str)
	}
    return TRUE
end
procedure rpt_warn(str)
    rpt_it(str,1)
    return TRUE
end
procedure rpt_info(str)
    rpt_it(str,2)
    return TRUE
end
procedure rpt_debug(str)
    rpt_it(str,3)
    return TRUE
end
procedure rpt_nd(nd,lvl)
    if rpt_lvl >= lvl then
	if \nd then
	    {
		nd.dump(&errout)
		nd.dump(infofile)
	    }
	else
	    write("node nil")
    return TRUE
end
procedure rpt_warn_node(str,nd)
    rpt_it(str,1)
    rpt_nd(nd,1)
    return TRUE
end
procedure rpt_info_node(str,nd)
    rpt_it(str,2)
    rpt_nd(nd,2)
    return TRUE
end
procedure rpt_debug_node(str,nd)
    rpt_it(str,3)
    rpt_nd(nd,3)
    return TRUE
end


procedure rpt_warn_node2(str,nd1,nd2)
    rpt_it(str,1)
    rpt_nd(nd1,1)
    rpt_nd(nd2,1)
    return TRUE
end
procedure rpt_info_node2(str,nd1,nd2)
    rpt_it(str,2)
    rpt_nd(nd1,2)
    rpt_nd(nd2,2)
    return TRUE
end
procedure rpt_debug_node2(str,nd1,nd2)
    rpt_it(str,3)
    rpt_nd(nd1,3)
    rpt_nd(nd2,3)
    return TRUE
end



procedure consinfo(msg)
    write(nodes_created_file,msg)
    write(cons_file,msg)
    write(msg)
    write(&errout,msg)
    return TRUE
end
procedure listinfo(msg)
    write(nodes_created_file,msg)
    write(lists_created_file,msg)
    write(msg)
    write(&errout,msg)
    return TRUE
end
procedure nodeinfo(msg)
    write(nodes_created_file,msg)
    write(msg)
    write(&errout,msg)
    return TRUE
end

procedure yyinfo(msg)
    rpt_info(msg)
    return TRUE
end 

procedure yywarn(msg)
    rpt_warn(msg)
    return TRUE
end
procedure yyperror(msg)
    rpt_err(msg)
    return TRUE
end
procedure yyerror(msg)
    rpt_err(msg)
    return TRUE
end

procedure yylexdebug(msg)
    write( "LEXDEBUG: yystate = " || yystate || " yychar = " || yychar  )   
    write(progress, "LEXDEBUG: yystate = " || yystate || " yychar = " || yychar  )   
    write(errfile , "LEXDEBUG: yystate = " || yystate || " yychar = " || yychar  )   
    write(reduce , "LEXDEBUG: yystate = " || yystate || " yychar = " || yychar  )   
    return TRUE
end

procedure rpt_opts()
    optsline("BADflag",dump_info(BADflag))
    optsline("initflag",dump_info(initflag))
    optsline("yydebug",dump_info(yydebug))
    optsline("dloadflag",dump_info(dloadflag))
    optsline("aflag",dump_info(aflag))
    optsline("Mflag",dump_info(Mflag))
    optsline("cflag",dump_info(cflag))
    optsline("pflag",dump_info(pflag))
    optsline("Lflag",dump_info(Lflag))
    optsline("Pflag",dump_info(Pflag))
    optsline("Tflag",dump_info(Tflag))
    optsline("Gflag",dump_info(Gflag))
    optsline("Vflag",dump_info(Vflag))
    optsline("Nflag",dump_info(Nflag))
    optsline("fflag",dump_info(fflag))
    optsline("Fflag",dump_info(Fflag))
    optsline("Rflag",dump_info(Rflag))
    optsline("Oflag",dump_info(Oflag))
    optsline("OOflag",dump_info(OOflag))
    optsline("OOOflag",dump_info(OOOflag))
    optsline("Xflag",dump_info(Xflag))
    optsline("xflag",dump_info(xflag))
    optsline("hflag",dump_info(hflag))
    optsline("actual_ifname",dump_info(actual_ifname))
    optsline("ifname",dump_info(ifname))
    optsline("ofname",dump_info(ofname))
    optsline("sigfname",dump_info(sigfname))
    optsline("optfname",dump_info(optfname))
    return TRUE
end

procedure optsline(item,val)
    write(optsfile, item || repl(" ",20 - *item) || val)
    return TRUE
end

procedure rpt_stats()

    statsline("Russell Statistics","")
    statsline("Item","Count")
    statsline("Line Count",line_cnt)
    statsline("Character Count",char_cnt)
    statsline("Token Count",token_cnt)
    statsline("Reserved Id Count",reserved_id_cnt)
    statsline("Reserved Op Count",reserved_op_cnt)
    statsline("Defined Id Count",defined_id_cnt)
    statsline("Defined Op Count",defined_op_cnt)
    statsline("Unique Symbol Count",stt_unique_cnt)
    statsline("Referenced Symbol Count",stt_reference_cnt)
    statsline("Numeral Count",numeral_cnt)
    statsline("Seperator Count",seperator_cnt)
    statsline("Nodes Total Count",nodes_total_cnt)	
    statsline("Nodes Made Count",nodes_made_cnt)  
    statsline("Comments Count",comments_cnt)
    statsline("Single Quoted Count",sing_quoted_cnt)
    statsline("Double Quoted Count",dbl_quoted_cnt)

    statsline("Lists Total Count",lists_total_cnt)	
    statsline("Lists Made Count",lists_made_cnt)
    statsline("RIC Op Codes Count",RIC_op_code_cnt)
    statsline("RIC Table Entry Count",RIC_table_entry_cnt)

    statsline("Parser Actions",parser_actions_cnt)
    
    statsline("YYN Compute Count",yyn_compute_cnt)
    statsline("Newstate Count",newstate_cnt)
    statsline("Setstate Count",setstate_cnt)
    statsline("Backup Count",backup_cnt)
    statsline("Default Count",default_cnt)
    statsline("Reduce Count",reduce_cnt)
    statsline("Errlab Count",errlab_cnt)
    statsline("Errlab1 Count",errlab1_cnt)
    statsline("","")
    statsline("Unicon Statistics","")
    statsline("Item","Count")
    statsline("Allocated ", &allocated)
    statsline("Storage", &storage)
    statsline("Regions", &regions)
    statsline("Date", &date)
    statsline("Version", &version)
    statsline("Features", &features)
    statsline("Host", &host)
    statsline("Clock", &clock)
    statsline("Collections", &collections)
    statsline("Exexution Time (ms)", &time)
#    dump_value_stack()
#    dump_state_stack()
    return TRUE
end

procedure  is_real_def(x) 
    if x > 2 
    then return TRUE
    else fail
end


procedure statsline(item,count)
    write(stats, item || repl(" ",40 - *item) || right(count,30))
    return TRUE
end


procedure yyclearin()
     yychar:=-1
return TRUE
end

procedure is_present(x)  
    if x = PRESENT then return TRUE
    else fail
end




##############################################################
#STUBS, etc
##############################################################

# lock is dummy function
procedure lock(it)
    return  it
end
procedure unlock(it)
    return  it
end

procedure rpt_action(yyn)
    write(reduce,"action yyn = " || yyn)
    return TRUE
end
procedure vfree()
# do nothing we are counting on unicons garbage collection
return TRUE
end

procedure free_array(ar)
# do nothing we are counting on unicons garbage collection
return TRUE

end

# Followinf to avoid changes to grammar.icn after I changed these to methods
procedure length(l)
    local x
    x := l.length()
    return x
end

procedure first(l)
    return l.first()
end
procedure last(l)
    return l.last()
end

procedure in(element,list)
  local i
  i := 1
  while (element ~= list[i] & list[i] ~= LIST_END) do {
      i +:= 1
  }	
  return (element = list[i])
  
end

procedure fix_p(p)
    local ret,visited
    ret := p
    while not(has_field(ret,"kind")) do
	{ 
	    ret := ret.cn_hd_field
	}
    return ret
end

procedure fix_p_BAD(p)
    local ret,visited
    if not(has_field(p,"kind")) then 
	{
	ret := p.cn_hd_field
    }
    else 
	{
	    ret := p
	}
    return ret
end

procedure has_field(x,field_name)
    local found,fld
    found := FALSE
    every fld := fieldnames(x) do {
	if fld == field_name then return TRUE
    }
    fail
end


    
