-- (C) Copyright International Business Machines Corporation 23 January 
-- 1990.  All Rights Reserved. 
--  
-- See the file USERAGREEMENT distributed with this software for full 
-- terms and conditions of use. 
-- File: cgdirectstmt.pp
-- Author: Andy Lowry
-- SCCS Info: @(#)cgdirectstmt.pp	1.22 3/15/90

-- This process translates statements containing roughly 60 percent of
-- the Hermes absprog operators.  Specifically, any operator that
-- always gets translated to a single, unique LI opcode, and whose
-- qualifier does generate code, can be handled.  Operator-dependent
-- handling of the qualifier follows generic instruction assembly.

-- This process operates as a statement translation server throughout
-- the life of a single codegend invocation, so startup overhead is
-- not repeated.

#include "typemark.h"
#include "codegen.h"

cgDirectStmt: using (interpform, common, cgInternal, cgInit)

process (initQ: cgStmtInitQ)

declare
  initArgs: cgStmtInit;
  shutQ: signalQ;
  Q: cgStmtQ;
  args: cgStmt;
  op: interpform!operation;
  emptyQual: interpform!qualifier;
  empty: empty;
begin
  receive initArgs from initQ;

  -- Establish connections for services and shutdown
  new Q;
  connect initArgs.cgStmt to Q;
  new shutQ;
  connect initArgs.shutdown to shutQ;
  return initArgs;

  -- Allocate an 'absent' LI qualifier so we can do a single 'copy'
  -- rather than a 'new' and a 'unite' wherever we need one of these.
  unite emptyQual.empty from empty;

  -- Now keep performing translation requests until we get a shutdown
  -- message.
  while TRUE repeat
    select
    event shutQ
      exit done;		-- shut down when we're told to
    event Q
      receive args from Q;	-- Stmt translation request

      new op;			-- allocate LI operation record

      -- get the opMap entry for this operator and extract LI opcode
      inspect opMapEntry in args.cgData.Aux.opMap[args.stmt.operator] begin
        reveal opMapEntry.mapInfo.direct;
	op.opcode := opMapEntry.mapInfo.direct;
      end inspect;

      -- Translate all the operands into offset lists
      new op.operands;
      for operand in args.stmt.operands[] inspect
        insert interpform!operand#(args.cgData.Proc.objAddr(operand)) 
	    into op.operands;
      end for;

      -- Now do operator-dependent handling
      select args.stmt.operator
      where (predefined!operator#'assert')
	-- NYI: handle 'constraintname' incoming qualifier, don't know
	-- what to do to LI qualifier
        op.qualifier := emptyQual;

      where (predefined!operator#'attributename')
	-- copy the attribute_name literal from incoming qual
	reveal args.stmt.qualifier.attributename;
	unite op.qualifier.attributename from predefined!attribute_name#(
	    copy of args.stmt.qualifier.attributename);

      where (predefined!operator#'call')
	-- We build up a user exception structure with the callmessage type
	-- and the exception id corresponding to minimum typestate.
        block declare
	  tname: typename;
	  tdef: type_definition;
	  discarded: user_exception;
	begin
	  -- find type definition of outport (1st operand)
	  inspect AREF(firstOp,args.stmt.operands,ZERO) begin
	    tname <- typename#(args.cgData.Proc.objType(firstOp));
	  end inspect;
	  tdef <- type_definition#(FNS.typeDef(tname));
	  reveal tdef.specification.outport_info;
	  -- find type definition of inport
	  tdef <- type_definition#(
	      FNS.typeDef(tdef.specification.outport_info));
	  reveal tdef.specification.inport_info;
	  -- get the callmessage type name
	  new discarded;
	  discarded.type := tdef.specification.inport_info.message_type;
	  -- now get the discarded exception id
	  tdef <- type_definition#(
	      FNS.typeDef(tdef.specification.inport_info.message_type));
	  reveal tdef.specification.callmessage_info;
	  discarded.exceptionid := tdef.specification.callmessage_info.minimum;
	  unite op.qualifier.exception from discarded;	      
	end block;

      where (predefined!operator#'create')
	-- get the typename of the initport (infer from type of
	-- returned outport, which is 1st operand), and copy it into
	-- the outgoing qualifier
	block declare
	  tname: typename;
	  tdef: type_definition;
	begin
	  -- find type of outport (1st operand)
	  inspect AREF(firstOp,args.stmt.operands,ZERO) begin
	    tname <- typename#(args.cgData.Proc.objType(firstOp));
	  end inspect;
	  tdef <- type_definition#(FNS.typeDef(tname));
	  reveal tdef.specification.outport_info;
	  -- copy out the initport type name
	  unite op.qualifier.typename 
	      from typename#(copy of tdef.specification.outport_info);
	end block;

      where (predefined!operator#'dissolve')
	-- Remove the final component from the source operand...
	-- qualifier is empty
	block declare
	  srcAddr: interpform!operand;
	  junk: integer;
	begin
	  remove srcAddr from AREF(tmp,op.operands,ONE);
	  remove junk from AREF(tmp,srcAddr,I(I(size of srcAddr)-ONE));
	  insert srcAddr into op.operands;
	  op.qualifier := emptyQual;
	end block;
	
      where (predefined!operator#'exit')
	-- Copy the exit ID from the incoming qualifier
	reveal args.stmt.qualifier.exit;
	unite op.qualifier.exit from exitid#(copy of args.stmt.qualifier.exit);

      where (predefined!operator#'integer_literal')
	-- Convert the literal string from the incoming qualifier to
	-- an integer and stuff it in the outgoing qualifier
	reveal args.stmt.qualifier.literal;
	unite op.qualifier.integer from
	    I(FNS.atoi(args.stmt.qualifier.literal));

      where (predefined!operator#'procedure')
	-- identical to 'create' above... grab the typename of the
	-- initport 
	block declare
	  tname: typename;
	  tdef: type_definition;
	begin
	  -- find type of outport (1st operand)
	  inspect AREF(firstOp,args.stmt.operands,ZERO) begin
	    tname <- typename#(args.cgData.Proc.objType(firstOp));
	  end inspect;
	  tdef <- type_definition#(FNS.typeDef(tname));
	  reveal tdef.specification.outport_info;
	  -- copy out the initport type name
	  unite op.qualifier.typename 
	      from typename#(copy of tdef.specification.outport_info);
	end block;

      where (predefined!operator#'real_literal')
	-- convert the literal string from the incoming qualifier to a
	-- real constant, then stuff it in the outgoing qualifier
	reveal args.stmt.qualifier.literal;
--	unite op.qualifier.real from
--	    real#(FNS.ator(args.stmt.qualifier.literal));
	op.qualifier := emptyQual;

      where (predefined!operator#'return_exception')
	-- We need to put together a predefined!user_exception object
	-- for the outgoing qualifier.  For this we need the
	-- callmessage type name (which we get from the first
	-- operand), and an exceptionid, which is in the incoming
	-- qualifier.
	block declare
 	  ue: predefined!user_exception;
	begin
	  new ue;
	  -- extract the callmessage type name
	  inspect AREF(firstOp,args.stmt.operands,ZERO) begin
	    ue.type <- typename#(args.cgData.Proc.objType(firstOp));
	  end inspect;
	  -- now get the exceptionid
	  reveal args.stmt.qualifier.exceptionid;
	  ue.exceptionid := args.stmt.qualifier.exceptionid;
	  -- now set the outgoing qualifier
	  unite op.qualifier.exception from ue;
	end block;

      where (predefined!operator#'reveal')
	-- Here we need to get the case id of the case being revealed.
	-- We also need to fix our 1st operand, since as translated it
	-- includes the offset for the variant component, whereas it
	-- should really just extend to the variant itself.
	block declare
 	  operand: interpform!operand;
	  offset: integer;
	begin
	  -- extract the case ID of the first operand
	  inspect AREF(hOperand,args.stmt.operands,ZERO) begin
	    unite op.qualifier.integer from 
		I(FNS.varCaseID(hOperand, args.cgData));
	  end inspect;
	  -- now fix the offset list addressing that operand
	  remove operand from AREF(tmp,op.operands,ZERO);
	  remove offset from AREF(tmp,operand,I(I(size of operand) - ONE));
	  insert operand into op.operands at ZERO;
	end block;

      where (predefined!operator#'string_literal')
	-- copy the string from the incoming literal to the outgoing
	-- string qualifier
	reveal args.stmt.qualifier.literal;
	unite op.qualifier.string from S(copy of args.stmt.qualifier.literal);

      where (predefined!operator#'typename')
	-- copy typename literal from incoming to outgoing qualifier
	reveal args.stmt.qualifier.typename;
	unite op.qualifier.typename from
	    typename#(copy of args.stmt.qualifier.typename);

      where (predefined!operator#'unite')
	-- get the case ID of the first operand, and also fix that
	-- operand's offset list as in the case for 'reveal'
	block declare
 	  operand: interpform!operand;
	  offset: integer;
	begin
	  -- extract the case ID of the first operand
	  inspect AREF(hOperand,args.stmt.operands,ZERO) begin
	    unite op.qualifier.integer from 
		I(FNS.varCaseID(hOperand, args.cgData));
	  end inspect;
	  -- now fix the offset list addressing that operand
	  remove operand from AREF(tmp,op.operands,ZERO);
	  remove offset from AREF(tmp,operand,(I(I(size of operand) - ONE)));
	  insert operand into op.operands at ZERO;
        end block;	

-- 'wrap' currently doesn't come with a qualifier... we leave it empty
-- in the LI instruction too... reactivate this code when the absprog
-- gets built correctly
#ifdef undefined
      where (predefined!operator#'wrap')
	-- We need to build an interpform!polymorph_info record, which
	-- contains the typename of the object being wrapped (2nd
	-- operand), and the formal typestate from the incoming
	-- qualifier.
        block declare
	  pi: interpform!polymorph_info;
	begin
	  new pi;
	  -- get type of wrapped object
	  inspect AREF(srcOp,args.stmt.operands,ONE) begin
	    pi.type <- typename#(args.cgData.Proc.objType(srcOp));
	  end inspect;
	  -- copy formal typestate from incoming qualifier
	  reveal args.stmt.qualifier.formal_typestate;
	  pi.typestate := args.stmt.qualifier.formal_typestate;
	  unite op.qualifier.polymorph from pi;
	end block;
#endif

-- Ditto for unwrap, though i don't understand why...
#ifdef undefined
      where (predefined!operator#'unwrap')
	-- Just like 'wrap', but we get the type from the object being
	-- unwrapped into (1st operand).
        block declare
	  pi: interpform!polymorph_info;
	begin
	  new pi;
	  -- get type of wrapped object
	  inspect AREF(dstOp,args.stmt.operands,ZERO) begin
	    pi.type <- typename#(args.cgData.Proc.objType(dstOp));
	  end inspect;
	  -- copy formal typestate from incoming qualifier
	  reveal args.stmt.qualifier.formal_typestate;
	  pi.typestate := args.stmt.qualifier.formal_typestate;
	  unite op.qualifier.polymorph from pi;
	end block;
#endif
	
      otherwise
	-- No other operator needs a qualifier
	op.qualifier := emptyQual;

      end select;

      -- The instruction is complete... add it to the current BB
      ADDINSTR(op);

    otherwise
      -- why do we need an 'otherwise' clause on an events-only select???
      exit cantHappen;
    end select;			-- end of event dispatcher

    return args;		-- finished translating statement

  end while;

on exit(done)
  -- Branch here to terminate

on exit(cantHappen)
  print S("CantHappen exit taken in cgdirectstmt");
end process
