-- (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: cgstmt.pp
-- Author: Andy Lowry
-- SCCS Info: @(#)cgstmt.pp	1.14 3/13/90

-- This procedure translates a single Hermes statement into LI code
-- in the current basic block.  Certain statements will cause the
-- creation of new basic blocks and/or definition of the exit
-- structure for the current basic block.

-- For opcode classes that can be translated automatically, a common
-- procedure for the class is invoked to do the translation.  Other
-- statements have their own specialized translation routines.

-- cgStmt acts like a server.  This works even though certain
-- statements can cause "recursive" translation of other statements,
-- because in those cases we forward the callmessage to another
-- process and can therefore continue the server loop without waiting
-- for the current statement to be finished.

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

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

process (initQ: cgStmtInitQ)

declare
  initArgs: cgStmtInit;
  Q: cgStmtQ;
  args: cgStmt;
  shutQ: signalQ;
  adhoc: adhocStmtMap;
begin

  -- Load up init msg with exported capabilities
  receive initArgs from initQ;
  new Q;
  connect initArgs.cgStmt to Q;
  new shutQ;
  connect initArgs.shutdown to shutQ;
  return initArgs;

  -- Initialize our adhoc translator map to empty.. it gets filled on
  -- demand as each translator gets invoked for the first time
  new adhoc;

  -- Now enter the server loop
  while TRUE repeat
    select
    event Q			-- request to translate a statement
      receive args from Q;

      -- Process the pragma if any
      if B(I(size of args.stmt.prag) > ZERO) then
	block declare
	  prag: charstring;
	  frags: charstringList;
	begin
	  prag := args.stmt.prag;
	  new frags;
	  -- Semicolons delimit pragma fragments
	  while B(I(size of prag) > ZERO) repeat
	    block begin
	      inspect c in prag where (B(c = C(';'))) begin
		block declare
		  frag: charstring;
		  semi: char;
		begin
		  extract frag from c1 in prag where 
		      (B(I(position of c1) < I(position of c)));
		  insert frag into frags;
		  remove semi from AREF(tmp,prag,ZERO);
		end block;
	      end inspect;
	    on (NotFound)
	      -- only one fragment remains
	      insert prag into frags;
	      new prag;
	    end block;
	  end while;
	  
	  -- Now handle each fragment
	  for frag in frags[] inspect
	    block begin
	      -- See if this fragment is of the form 'name=value'
	      block declare
		eqPos: integer;
		name: charstring;
		value: charstring;
		blanks: charstring;
	      begin
		eqPos <- I(position of eqChar in frag where 
		      (B(eqChar = C('='))));
		name <- S(every of c in frag where
		      (B(I(position of c) < eqPos)));
		value <- S(every of c in frag where
		      (B(I(position of c) > eqPos)));
		extract blanks from c in name where (B(c = C(' ')));
		select name
		where (S("trace"))
		  -- Generate trace instruction to set trace level
		  -- to given value
		  block declare
		    op: interpform!operation;
		  begin
		    new op;
		    op.opcode <- interpform!opcode#'trace';
		    new op.operands;-- no operands
		    extract blanks from c in value where (B(c = C(' ')));
		    unite op.qualifier.integer from I(FNS.atoi(value));
		    ADDINSTR(op);
		  end block;
		otherwise
		  exit unknownPragma;
		end select;
	      on (NotFound)
		-- Not of the 'name=value' variety
		exit unknownPragma;
	      end block;
	    on exit(unknownPragma)
	      -- This fragment doesn't make sense
	      call args.cgData.std.terminal.putLine(
		S(S("Unrecognized pragma: ") | frag));
	    end block;
	  end for;
	end block;
      end if;
	    
      -- Look up the statement operator in our opcode map
      inspect opMapEntry in args.cgData.Aux.opMap[args.stmt.operator] begin

	select opMapEntryType#(case of opMapEntry.mapInfo)

	where (opMapEntryType#('DIRECT'))
	  -- LI opcode depends only on Hermes operator
	  -- Special case: don't generate discards of scalars for
	  -- now... when we have optimizers that need kill
	  -- information, this has to go back in, and a later
	  -- optimization should get rid of them
	  block declare
	    tdef: type_definition;
	  begin
	    if B(args.stmt.operator = predefined!operator#'discard') then
	      tdef <- type_definition#(FNS.typeDef(
		  typename#(args.cgData.Proc.objType(
		      objectname#(AREF(tmp,args.stmt.operands,ZERO))))));
	      select primitive_types#(case of tdef.specification)
	      where (primitive_types#'integertype')
	      where (primitive_types#'booleantype')
	      where (primitive_types#'enumerationtype')
	      where (primitive_types#'realtype')
	      otherwise		-- not a scalar type
		send args to FNS.cgDirectStmt;
		exit forwarded;
	      end select;
	    else
	      send args to FNS.cgDirectStmt;
	      exit forwarded;
	    end if;
	    -- Must have been a discard of a scalar
	    return args;
	  on exit(forwarded)
	    -- callmsg forwarded to handler... no return needed
	  end block;
	  
	where (opMapEntryType#('TYPED'))
	  -- LI opcode depends on Hermes operator and operand types    
	  send args to FNS.cgTypedStmt;

	where (opMapEntryType#('ADHOC'))
	  reveal opMapEntry.mapInfo.adhoc;
	  -- Try to locate the handler in the adhoc translator map
	  -- first
	  block begin
	    inspect entry in adhoc[args.stmt.operator] begin
	      send args to entry.translator;
	    end inspect;
	  on (NotFound)
	    -- no table entry... load the operator-specific handler
	    -- over the current stub, forward the current request, and
	    -- add an entry to the table
	    block declare
	      entry: adhocStmtMapEntry;
	    begin
	      new entry;
	      entry.opcode := args.stmt.operator;
	      entry.translator <- cgStmtFn#(procedure of program#
		    (args.cgData.std.pathLoad(opMapEntry.mapInfo.adhoc)));
	      send args to entry.translator;
	      insert entry into adhoc;
	    end block;
	  end block;

	otherwise
	  exit cantHappen;
	end select;		-- operator class dispatch
      end inspect;

    event shutQ			-- time to shut down the server
      exit done;

    otherwise
      exit cantHappen;
    end select;			-- event dispatch

  end while;			-- server loop

on exit (done)
  -- nothing more to do
on exit(cantHappen)
  print S("CantHappen exit taken in cgstmt");
end process
