-- (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: formaterror.p
-- Author: Rob Strom, then Andy Lowry
-- SCCS Info: @(#)formaterror.pp	1.2 3/13/90

-- During early phases of the bootstrapping we provide an abbreviated
-- facility that prints only the source file name and line number and,
-- in most cases, the error code number.  The portions that are used
-- during boot phases are fully typemarked

-- enforce hierarchy of boot phases
#ifdef CGBOOT
#  define TCBOOT
#endif
#ifdef TCBOOT
#  define TSBOOT
#endif
#ifdef TSBOOT
#  define ANYBOOT
#endif

#include "typemark.h"

formatError:
using (formatError, absFormat, inferredType, positions, errors, 
  type_inference, posmap, itoa)
#ifndef ANYBOOT
linking (getformatters)
#endif
process (Q: formatErrorQ)
declare
  args: formatError;
  posmark: charString;
  msg: charString;
  itoa: itoaFn;
  errObj: ErrorObject;
#ifndef ANYBOOT
  temp: charstring;
  temp2: charstring;
  temp3: charstring;
  temp4: charstring;
  fmt: formatters;
#endif ANYBOOT
begin

#ifndef ANYBOOT
  fmt<- (getFormattersOutport#(create of process getformatters))();
#endif ANYBOOT

  -- short procedure to convert an integer value to a charstring (this
  -- exists as a tool, but we need it during compiler booting, before
  -- the tools are ready)
  itoa <- itoaFn#(procedure of program#(process (Q: itoaQ)
      declare
	args: itoa;
	n: integer;
      begin
	receive args from Q;
	n := args.int;
	new args.str;
	if B(n < ZERO) then
	  n <- I(- n);
	end if;
	while B(n >= I(10)) repeat
	  insert char#(convert of I(I(convert of char#'0') + I(n mod I(10))))
	      into args.str at ZERO;
	  n <- I(n / I(10));
	end while;
	insert char#(convert of I(I(convert of char#'0') + n))
	    into args.str at ZERO;
	if B(args.int < ZERO) then
	  insert char#'-' into args.str at ZERO;
	end if;
	return args;
      end process));

  receive args from Q;

  if B(positionType#(case of args.error.position) = positionType#'absprog')
  then
    reveal args.error.position.aPos;
    block begin
      inspect map in args.positions[args.error.position.aPos] begin
	posMark <-S(S(map.cPosition.file | S(": "))
	      | S(S(itoa(map.cPosition.line)) | S(": ")));
      end inspect;
    on (notFound)
      -- in case cannot find stmt or clause.  for example, if initport
      -- is of wrong type, the error has a bogus stmt id.  
      posMark <- S("?: ?: ");
    end block;
  else
    reveal args.error.position.cPos;
    posMark <- S(S(args.error.position.cPos.file | S(": "))
	  | S(S(itoa(args.error.position.cPos.line)) | S(": ")));
  end if;


  select (args.error.code)

  -- catch-all
  where (errorcode#'general error')
    errObj <- errorObject#(args.error.objects[]);
    reveal errObj.charString;
    msg := errObj.charString;

#ifdef ANYBOOT
  otherwise
    msg <- S(S("Error code ") | S(itoa(I(convert of args.error.code))));
#else
  -- typestate errors
  where ('DeadCode')
    msg <- "Dead code in this block";

  where ('Constant')
    errObj <- args.error.objects[];
    reveal errObj.objectName;
    temp <- fmt.FormatObject(fmt, args.decls, args.infdecls, args.defs,
      args.defMap, args.procMap, errObj.objectName);
    msg <- "Operation attempts to modify constant object " | temp;

  where ('Position')
    errObj <- args.error.objects[];
    reveal errObj.objectName;
    temp <- fmt.FormatObject(fmt, args.decls, args.infdecls, args.defs,
      args.defMap, args.procMap, errObj.objectName);
    msg <- "Variable " | temp | " is not associated with a table position";

  where ('NotAsserted')
    errObj <- args.error.objects[];
    reveal errObj.attribute;
    temp <- fmt.formatAttribute(fmt, args.defs, args.decls, args.infdecls,
      args.defMap, args.procMap, errObj.attribute);
    msg <- "Typestate attribute not present: " | temp;
    
  where ('NotLowerable')
    errObj <- args.error.objects[];
    reveal errObj.attribute;
    temp <- fmt.formatAttribute(fmt, args.defs, args.decls, args.infdecls,
      args.defMap, args.procMap, errObj.attribute);
    msg <- "Typestate attribute cannot be dropped: " | temp;
    
  where ('CannotAdd')
    errObj <- args.error.objects[];
    reveal errObj.attribute;
    temp <- fmt.formatAttribute(fmt, args.defs, args.decls, args.infdecls, 
      args.defMap, args.procMap, errObj.attribute);
    msg <- "Adding attribute " | temp 
	| " would yield an impossible typestate";

  where ('CannotDrop')
    errObj <- args.error.objects[];
    reveal errObj.attribute;
    temp <- fmt.formatAttribute(fmt, args.defs, args.decls, args.infdecls,
      args.defMap, args.procMap, errObj.attribute);
    msg <- "Dropping attribute " | temp 
	| " would yield an impossible typestate";

  -- type errors
  where ('type inference mismatch')
    errObj <- args.error.objects[0];
    reveal errObj.objectName;
    temp <- fmt.formatObject(fmt, args.decls, args.infdecls, args.defs, 
      args.defMap, args.procMap, errObj.objectName);
    errObj <- args.error.objects[1];
    reveal errObj.typename;
    temp2 <- fmt.formatType(fmt, args.defs, args.defMap, errObj.typename);
    errObj <- args.error.objects[3];
    reveal errObj.typename;
    temp3 <- fmt.formatType(fmt, args.defs, args.defMap, errObj.typename);
    errObj <- args.error.objects[2];
    reveal errObj.objectName;
    temp4 <- fmt.formatObject(fmt, args.decls, args.infdecls, args.defs,
      args.defMap, args.procMap, errObj.objectName);
    msg <- "Type of " | temp | " is " | temp2 | " but should be " | temp3
	| " as inferred from " | temp4;

  where ('type assignment mismatch')
    errObj <- args.error.objects[0];
    reveal errObj.objectName;
    temp <- fmt.formatObject(fmt, args.decls, args.infdecls, args.defs,
      args.defMap, args.procMap, errObj.objectName);
    errObj <- args.error.objects[1];
    reveal errObj.typename;
    temp2 <- fmt.formatType(fmt, args.defs, args.defMap, errObj.typename);
    errObj <- args.error.objects[2];
    reveal errObj.typename;
    temp3 <- fmt.formatType(fmt, args.defs, args.defMap, errObj.typename);
    msg <- "Type of " | temp | " is " | temp2 | " but should be " | temp3;

  where ('class rule violation')
    errObj <- args.error.objects[0];
    reveal errObj.objectName;
    temp <- fmt.formatObject(fmt, args.decls, args.infdecls, args.defs, 
      args.defMap, args.procMap, errObj.objectName);
    errObj <- args.error.objects[1];
    reveal errObj.typeName;
    temp2 <- fmt.formatType(fmt, args.defs, args.defMap, errObj.typename);
    errObj <- args.error.objects[2];
    reveal errObj.type_class_function;

    select errObj.type_class_function
    where ('boolean')
      temp3 <- "boolean";
    where ('numeric')
      temp3 <- "numeric";
    where ('variant')
      temp3 <- "variant";
    where ('string')
      temp3 <- "string";
    where ('inport')
      temp3 <- "inport";
    where ('outport')
      temp3 <- "outport";
    where ('copyable')
      temp3 <- "copyable";
    where ('orderedscalar')
      temp3 <- "orderedscalar";
    where ('table')
      temp3 <- "table";
    where ('integer')
      temp3 <- "integer";
    where ('enumerationorboolean')
      temp3 <- "enumerationorboolean";
    where ('nominal')
      temp3 <- "nominal";
    where ('enumeration')
      temp3 <- "enumeration";
    where ('newable')
      temp3 <- "newable";
    where ('polymorph')
      temp3 <- "polymorph";
    where ('callmessage')
      temp3 <- "callmessage";
    otherwise
      temp3 <- "*UNKNOWN*";
    end select;

    msg <- "Type of " | temp | " is " | temp2 | " but should be in class "
	| temp3;

  where ('named literal not found')
    errObj <- args.error.objects[1];
    reveal errObj.charString;
    temp := errObj.charString;
    errObj <- args.error.objects[0];
    reveal errObj.typename;
    temp2 <- fmt.formatType(fmt, args.defs, args.defMap, errObj.typeName);
    msg <- "The named literal '" | temp | "' does not belong to type "
	| temp2;
    
  where ('incorrect number of args')
    errObj <- args.error.objects[0];
    reveal errObj.objectName;
    temp <- fmt.formatObject(fmt, args.decls, args.infDecls, args.defs, 
      args.defMap, args.procMap, errObj.objectName);
    errObj <- args.error.objects[1];
    reveal errObj.integer;
    temp2 <- itoa(errObj.integer);
    errObj <- args.error.objects[2];
    reveal errObj.integer;
    temp3 <- itoa(errObj.integer);
    msg <- "Function " | temp | " expects " | temp2 | " arguments, not "
	| temp3;
    
  where ('arg of incorrect type')
    errobj <- args.error.objects[0];
    reveal errObj.integer;
    temp <- itoa(errObj.integer);
    errObj <- args.error.objects[3];
    reveal errObj.objectName;      
    temp2 <- fmt.formatObject(fmt, args.decls, args.infDecls, args.defs, 
      args.defMap, args.procMap, errObj.objectName);
    errObj <- args.error.objects[1];
    reveal errObj.typename;
    temp3 <- fmt.formatType(fmt, args.defs, args.defMap, errObj.typename);
    errObj <- args.error.objects[2];
    reveal errObj.typename;
    temp4 <- fmt.formatType(fmt, args.defs, args.defMap, errObj.typename);
    msg <- "Argument " | temp | " in call to " | temp2 | " is of type "
	| temp3 | " but should be " | temp4;

      
  where ('overlapping args')
    errobj <- args.error.objects[1];
    reveal errObj.objectName;
    temp <- fmt.formatObject(fmt, args.decls, args.infDecls, args.defs, 
      args.defMap, args.procMap, errObj.objectName);
    errObj <- args.error.objects[0];
    reveal errObj.objectName;
    temp2 <- fmt.formatObject(fmt, args.decls, args.infDecls, args.defs, 
      args.defMap, args.procMap, errObj.objectName);
    msg <- "Call " | "to " | temp | " has overlapping arguments: "
	| temp2 | " appears twice";
    
  where ('outport expected')
    errobj <- args.error.objects[];
    reveal errObj.objectName;
    temp <- fmt.formatObject(fmt, args.decls, args.infDecls, args.defs, 
      args.defMap, args.procMap, errObj.objectName);
    msg <- temp | " is called but is not a callable outport";
    
  where ('uninferred type')
    errObj <- args.error.objects[];
    reveal errObj.objectName;
    temp <- fmt.formatObject(fmt, args.decls, args.infDecls, args.defs, 
      args.defMap, args.procMap, errObj.objectName);
    msg <- "Cannot infer type of " | temp;
    
  where ('variantcomponent')
    errObj <- args.error.objects[];
    reveal errObj.objectName;
    temp <- fmt.formatObject(fmt, args.decls, args.infDecls, args.defs, 
      args.defMap, args.procMap, errObj.objectName);
    msg <- temp | " is not a variant component";
    
  otherwise
    msg <- "Unknown error";
#endif ANYBOOT

  end select;
  
  args.errMsg <- S(posMark | msg);
  return args;
  
end process
