Managing generation of binary encoders

<*>= [D->]
link pretty
procedure emit_encoding(outfilename)
  local i, f
  emit_encoding_interface(open(i := outfilename || interface_extension, "w")) |
    error("Could not open ", image(i), " for writing")
  emit_encoding_implementation(
         open(f := outfilename || implementation_extension, "w"), i, outfilename) |
    error("Could not open ", image(f), " for writing")
end
Defines emit_encoding (links are to index).

<*>+= [<-D->]
procedure emit_encoding_interface(outfile)
  local cons, t, u
  verbose("Emitting encoding interface")
  pp := PPnew(outfile)
  every PPwrite(pp, pretty(!header_lines))
  PPwrite(pp, "/* must #include <mclib.h> before this file */")
  <write definitions of all instance types>
  if \gen_counters then declare_counter_types(pp)
  if \indirectname then
    PPxwrite(pp, "struct ", indirecttype, " {$t")
  <emit declarations for all of the kept constructors>
  if \gen_counters then declare_counter_funs(pp)
  if \indirectname then
    PPxwrite(pp, "$b$n};")
  return
end
Defines emit_encoding_interface (links are to index).

<write definitions of all instance types>= (<-U)
s := set([instructionctype])  # don't try to emit instance def for untyped constructors
every cons := kept_constructors() & not member(s, cons.type) do {
  insert(s, cons.type)
  emit_instance_type(pp, cons.type)
}
s := &null # enable garbage collection

If an indirect encoder is emitted, the order of the constructors has to match exactly the order used in emit_encoding_interface. At one time we rearranged things to put typed constructors first, but on March 3, 1996, we decided there was no good reason to rearrange the users' constructor declarations. 

<emit declarations for all of the kept constructors>= (<-U)
every emit_proc_declaration(pp, kept_constructors())

<*>+= [<-D->]
procedure emit_indirect_encoder(pp)
  e := []
  every cons := kept_constructors() do
    put(e, Cnoreserve(cons.name) || ", $o")
  c := if \gen_counters then counter_names() else ""
  emit_template(pp, "proc-structure.t", 
                    "indirectname", indirectname, "indirecttype", indirecttype,
                    "encoders", e, "counters", c)
  return
end
Defines emit_indirect_encoder (links are to index).

<proc-structure.t>=
static struct %indirecttype encoding_procs = {$t%encoders%counters$b
};
struct %indirecttype *%indirectname = &encoding_procs;

Here's some old code 

<proc-structure.t (segregated version)>=
static struct %indirecttype encoding_procs = {$t%typed%untyped%counters$b
};
struct %indirecttype *%indirectname = &encoding_procs;

<emit declarations for all of the kept constructors (segregated version)>=
every t | u := []
every cons := kept_constructors() do
  put(if cons.type === instructionctype then u else t, cons)
    every emit_proc_declaration(pp, !t | !u)


<*>+= [<-D->]
procedure emit_encoding_implementation(outfile, interfacename, basename)
  verbose("Emitting encoding implementation")
  pp := PPnew(outfile)
  every PPwrite(pp, pretty(!header_lines))
  PPwrite(pp, "#include <mclib.h>")
  PPwrite(pp, "#include ", image(interfacename))
  PPwrite(pp, "#define sign_extend(N,SIZE) \\")
  PPwrite(pp, "  (((int)((N) << (sizeof(unsigned)*8-(SIZE)))) ",
              ">> (sizeof(unsigned)*8-(SIZE)))")

  pushtrace("ASS")
  if \gen_counters then declare_counters(pp)
  <write tag definitions for typed kept_constructors>
  every cons := kept_constructors() do {
    verbose("Encoder for constructor ", cons.name)
    PPwrite(pp, "/**************")
    show_constructor(pp, cons)
    PPwrite(pp, "***********/")
    if cons.type ~=== instructionctype then
      emit_create_instance_body(pp, cons)
    else 
      emit_emitter_body(pp, cons) 
  }
  PPwrite(pp)   # flush prettyprinter
  poptrace()
  if \gen_counters then define_counter_funs(pp)
  if \indirectname then emit_indirect_encoder(pp)
  emit_closure_functions_postfix(pp, basename)
  return
end
Defines emit_encoding_implementation (links are to index).

<write tag definitions for typed kept_constructors>= (<-U)
every cons := kept_constructors() & cons.type ~=== instructionctype do 
  PPwrite(pp, "#define ", cons.name, "_TAG ", cons.tag)


<*>+= [<-D->]
procedure show_constructor(pp, cons)
  PPwrite(pp)
  PPwrites(pp, cons.name, " ")
  every o := !cons.operands do 
    case type(o) of {
      "literal" : PPwrites(pp, o.s)
      "input"   : PPwrites(pp, o.name, 
                         if type(o.meaning) == "integer" then "!" else "")
      default   : impossible("operand")
    }
  PPxwrites(pp, " is $t${$c")
  PPxwrite(pp, ppexpimage(pattern_to_case(crhs(cons))), "$}$b$n")
  return
end
Defines show_constructor (links are to index).

<*>+= [<-D->]
procedure show_constype(outfile, type)
  write(outfile)  
  l := []; every put(l, kept_constructors(type).name)
  PPwrite(pp, type.name, " (", commaseparate(l, " | "), "):")
  show_case(outfile, pattern_to_case(constype_pattern(type)))
  write(outfile)
  return
end
Defines show_constype (links are to index).

<*>+= [<-D]
procedure declare_counters(pp)
  every PPwrite(pp, "static int ", kept_constructors().name, "_ctr = 0;")
  return
end
procedure declare_counter_types(pp)
  PPwrite(pp, "typedef void (*Printer)(void *closure, char *fmt, ...);")
  return
end
procedure declare_counter_funs(pp)
  c_function_declaration(pp, "void", "reset_cons_counters", "(void)")
  c_function_declaration(pp, "void", "dump_cons_counters","(Printer p, void *closure)")
  return
end
procedure counter_names()
  return "reset_cons_counters, dump_cons_counters, $o"
end
procedure define_counter_funs(pp)  
  PPxwrites(pp, if \indirectname then "static " else "",
               "void reset_cons_counters(void) {$t")
  every PPxwrites(pp, "$n", kept_constructors().name, "_ctr = 0;")
  PPxwrite(pp, "$b$n}")
  PPxwrites(pp, if \indirectname then "static " else "",
                 "void dump_cons_counters(Printer p, void *closure) {$t")
  every cons := kept_constructors() do
    PPxwrites(pp, "$np(closure, \"%d ", cons.name, " : ", <type of cons>, 
          "\\n\", ", cons.name, "_ctr);")
  PPxwrite(pp, "$b$n}")
end
Defines counter_names, declare_counter_funs, declare_counters, declare_counter_types, define_counter_funs (links are to index).

<type of cons>= (<-U)
(if cons.type === instructionctype then "<instruction>" else cons.type.name)

<refman: counter functions>=
The C procedure
\begin{quote}
\tt void reset\_cons\_counters(void);
\end{quote}
resets the counters; the procedure
\begin{quote}
\tt
typedef void (*Printer)(void *closure, char *fmt, ...);\\
void dump\_cons\_counters(Printer p, void *closure);
\end{quote}
dumps the values of all the counters.
The user must provide a function of type {\tt Printer}, a variadic
function which
accepts a closure, a {\tt printf}-style format, and additional arguments.
The closure encapsulates any information needed by the
user's printing function.
For example, the standard C~function {\tt fprintf} may be used as a {\tt Printer},
in which case a file pointer acts as a closure.