# File:    cmacro.icn
# Author:  Thomas Wang
# Purpose: Alternative C++ template generation program
# Date:    Sep 2, 1996
# Usage:
#
# cmacro.exe {-Idir_name} {name=value}  source_file  > output_file
#
# Cmacro will substitute special macros encoded in the source file
# to generate program source files.
#
# Some C++ compiler vendors still do not properly support C++ templates,
# thus cmacro is born.
#
# example:
#   cmacro.exe -I../include myclass=intlist T=int  list.h  > intlist.h
#
#   contents of list.h:
#
#     #ifndef $cap($myclass)_H
#     #define $cap($myclass)_H
#
#     $if($production,/* production version */,#define DEBUG)
#
#     $include(date.h,date=9/2/96 name=Tom)
#     $text(struct) $myclass
#     {
#       $T first;
#       $myclass *next;
#     };
#     #endif
#
#   contents of date.h:
#
#     /* $date $name */
#
# output:
#
#     #ifndef INTLIST_H
#     #define INTLIST_H
#
#     #define DEBUG
#
#     /* 9/2/96 Tom */
#     struct intlist
#     {
#       int first;
#       intlist *next;
#     };
#     #endif
#

global varfirstset
global varrestset
global varendset
global varvalueset
global notcommaset
global notdollarset
global global_status
global search_path

procedure translate_cap(s)
  return map(s,"abcdefghijklmnopqrstuvwxyz.","ABCDEFGHIJKLMNOPQRSTUVWXYZ_");
end

procedure do_cap(vartable)
  local func_fields;
  local result;

  func_fields := tab(bal(')'));
  if match(")") then {
    move(1); # skip over ending )
    result := translate_cap(do_string(func_fields,vartable));
    return result;
  } else {
    write(&errout, "no ending parenthesis");
    global_status := 1;
  }
  fail;
end

procedure do_text(vartable)
  local func_fields;
  local result;

  func_fields := tab(bal(')'));
  if match(")") then {
    move(1); # skip over ending )
    result := do_string(func_fields,vartable);
    return result;
  } else {
    write(&errout, "no ending parenthesis");
    global_status := 1;
  }
  fail;
end

procedure file_open(s,the_list)
local join_name;
local file_desc;

  if *the_list > 0 then {
    join_name := the_list[1] || "/" || s;
    if file_desc := open(join_name) then return file_desc
    else return file_open(s, the_list[2]);
  }
  fail;
end

procedure top_file_open(s,the_list)
local file_desc;

  if file_desc := open(s) then return file_desc
  else return file_open(s, the_list)
end

procedure add_search_path(the_list)
  local the_path;

  move(2);  # skip over -I
  the_path := tab(0);
  return [ the_path, the_list];
end

procedure over_varname()
local result;
  result := "";
  result := tab(any(varfirstset));
  if *result > 0 then {
    result ||:= tab(many(varrestset));
    return result;
  }
  fail;
end


procedure add_var_table(vartable)
local var_name
local var_value

  var_name := "";
  var_name := over_varname();
  if (*var_name = 0) then {
    tab(many(varendset)); # skip over var ending characters
    return 0; # no variable name
  } else if (match("=")) then {
    move(1); # skip over =
    var_value := "";
    var_value := tab(many(varvalueset));
    tab(many(varendset)); # skip over var ending characters
    vartable[var_name] := var_value;
    return 1; # assignment success
  } else {
    write(&errout, "Variable assignment lacks = sign");
    global_status := 1;
    tab(many(varendset)); # skip over var ending characters
  }
  fail;  
end

procedure do_include(vartable)
  local func_fields;
  local result;
  local first_field;
  local second_field;
  local first_field_eval;
  local second_field_eval;
  local local_var_table;
  local file_desc;

  first_field := "";
  second_field := "";
  func_fields := tab(bal(')'));
  if match(")") then {
    move(1); # skip over ending )
    func_fields ? {
      first_field := tab(many(notcommaset));
      if match(",") then {
        move(1); # skip over comma
        second_field := tab(many(notcommaset));
      }
    }
    first_field_eval := do_string(first_field,vartable);
    second_field_eval := do_string(second_field,vartable);
    local_var_table := table("");
    second_field_eval ? {
      while add_var_table(local_var_table) = 1 do {}
    }
    if global_status = 0 then {
      if file_desc := top_file_open(first_field_eval,search_path) then {
        result := do_string(contents_of_file(file_desc),local_var_table);
        close(file_desc);
        return result;
      } else {
        write(&errout,"include file ", first_field_eval, "cannot be opened.");
        global_status := 1;
      }
    }
  } else {
    write(&errout, "no ending parenthesis");
    global_status := 1;
  }
  fail;
end

procedure do_if(vartable)
  local func_fields;
  local result;
  local first_field;
  local first_field_eval;
  local second_field;
  local third_field;

  first_field := "";
  second_field := "";
  third_field := "";
  func_fields := tab(bal(')'));
  if match(")") then {
    move(1); # skip over ending )
    func_fields ? {
      first_field := tab(many(notcommaset));
      if match(",") then {
        move(1); # skip over comma
        second_field := tab(many(notcommaset));
        if match(",") then {
          move(1); # skip over comma
          third_field := tab(many(notcommaset));
        }
      }
    }
    first_field_eval := do_string(first_field,vartable);
    if *first_field_eval > 0 then result := do_string(second_field,vartable)
    else result := do_string(third_field,vartable);
    return result;
  } else {
    write(&errout, "no ending parenthesis");
    global_status := 1;
  }
  fail;
end

procedure contents_of_file(file_desc)
local result;
local append_str;

  result := reads(file_desc,31000);
  while (append_str := reads(file_desc,31000)) do {
    result ||:= append_str
  }
  return result;
end

procedure do_string(s,vartable)
local no_star;
local var_name;
local result_str;

  result_str := "";
  s ? {  # scan s
    while no_star := tab(find("$")) do {
      result_str ||:= no_star;
      move(1);  # move over the $
      if tab(match("cap(")) then {  # scan over $cap(
        result_str ||:= do_cap(vartable);
      } else if tab(match("include(")) then {  # scan over $include(
        result_str ||:= do_include(vartable);
      } else if tab(match("text(")) then {  # scan over $text(
        result_str ||:= do_text(vartable);
      } else if tab(match("if(")) then {  # scan over $if(
        result_str ||:= do_if(vartable);
      } else if var_name := over_varname() then {
        result_str ||:= vartable[var_name];  # append replaced text
      } else {
        result_str ||:= "$";  # nothing matches, just append $
      }
      if global_status > 0 then return result_str
    }
    result_str ||:= tab(0);
  }
  return result_str;
end

procedure print_file(s,vartable)
local no_star;
local var_name;
local var_str;

  s ? {  # scan s
    while no_star := tab(find("$")) do {
      writes(no_star);
      move(1);   # move over the $
      if tab(match("cap(")) then {  # scan over $cap(
        writes(do_cap(vartable));
      } else if tab(match("include(")) then {  # scan over $include(
        writes(do_include(vartable));
      } else if tab(match("text(")) then {  # scan over $text(
        writes(do_text(vartable));
      } else if tab(match("if(")) then {  # scan over $if(
        writes(do_if(vartable));
      } else if var_name := over_varname() then {
        var_str := "";
        var_str := vartable[var_name];
        writes(var_str);  # write out replaced text
      } else {
        writes("$");  # nothing matches, just print out $
      }
      if global_status > 0 then return
    }
    writes(tab(0));
  }
end


procedure main(argv)
  local var_table;
  local file_desc;
  local path;
  local indx;

  varfirstset := &lcase ++ &ucase ++ '_';
  varrestset := varfirstset ++ '0123456789';
  varendset := ~varfirstset;
  varvalueset := ~ ' ';
  notcommaset := ~ ',';
  notdollarset := ~ '$';
  var_table := table("");
  search_path := list(0);
  global_status := 0;
  path := "";
  every indx := 1 to *argv do {
    if match("-I",argv[indx]) then {
      search_path := (argv[indx] ? add_search_path(search_path));
    } else if find("=",argv[indx]) then {
      if (argv[indx] ? add_var_table(var_table)) = 0 then {
        write(&errout,"Invalid null variable name");
        global_status := 1;
      }
    } else {
      path := argv[indx];
      if file_desc := top_file_open(path,search_path) then {
        print_file(contents_of_file(file_desc),var_table);
        close(file_desc);
      } else {
        writes(&errout, "File ");
        writes(&errout, path);
        writes(&errout, " cannot be opened.\n");
        global_status := 1;
      }
    }
    if global_status > 0 then return global_status
  }

  return global_status;
end