segment emit;

**********************************************************************
*                                                                    *
* SURVEY OF CONSUMER FINANCES            EMPLOYER SPONSORED PENSIONS *
*                                                                    *
*                     BENEFIT ESTIMATION PROGRAM                     *
*                                                                    *
* RICHARD CURTIN                                     PAUL PICKELMANN *
*                                                    SCOT ALLEN      *
*                                                                    *
*                (c) 1986  THE UNIVERSITY OF MICHIGAN                *
*                                                                    *
**********************************************************************

These routines parse the formulas and add them to the FORMULAS and
PROCEDURES files.  Bad formulas are sent to the PROBLEMS file.

%page
const
  objmax=300;
  strmax=10;
  linesperpage=60;
type
  prt  = (prset,       primp, pror, prand, prnot, prrel,
          pradd,       prmul,       prid);
  oprt = (opset,oppl,  opimp, opor, opand, opnot,
          opgt,opge,opne,opeq,ople,oplt, opadd,opsub, opmul,opdiv, opid);
  symt = (smend, smop, smuop, smid, smnum, smlp, smrp, smlb, smrb, smcoma);
  typt = (tpvar,tpfun,tpred,tperr);
  strt = string(strmax);
normal = packed 0..32767;
objstr = string(objmax);
  objt = record
         oper:  oprt;
         otype: typt;
         opas,
         ostd:  objstr;
         end;
  objp = 0..objmax;
  strp = 0..strmax;
  nptr = @nrec;
  nrec = record
         nlink: nptr;
         nname: strt;
         ntype: typt;
         nused: boolean;
         end;
def
  failfile: text;
static
    found,
     free,
   idlist,
  prelist: nptr;
   nsform,
  pagenum: normal;
  linenum: 1..linesperpage+1;
   header: string(14);
binwasred: boolean;
  objfile: text;
   smtext: arraysymt of string(5);
    pp,sp: arrayoprt of prt;
    po,so: arrayoprt of string(2);

procedure  error(const message: string);  external;
function  stoi(const s:string): integer;  external;
%page
PRINT:  Write to sprint, the formula file.
procedure  print(s: objstr);
var  l: objp;
begin
repeat
  if  linenum>linesperpage  then begin
    linenum := 2;
    pagenum := pagenum + 1;
    page(output);
    writeln(output,header:60,pagenum:5);  end;
  l := length(s);
  if  l>65  then  begin
    l := 65;
    while  not ((sl=',')or(sl+1 in ' ','+','-','*','/','&','!'))
       do  l := l - 1;  end;
  writeln(output,s:l);
  linenum := linenum + 1;
  s  :=   '      '!!substr(s,l+1);
  until s='      ';
end;
%page
PUNCH:  Write to spunch, the procedure file.
procedure  punch(s: objstr);
const width=65;
  var l,c: objp;
begin
c := cols(objfile);
if  s=''  then begin
  if  c>1  then  writeln(objfile);
  writeln(objfile);  end
else begin
  if  c>width-3  then begin  writeln(objfile);  c := 1;  end;
  if  c>1  then  begin write(objfile,' ');  c := c + 1;  end;
  l := length(s);
  while  l>width-c  do begin
    l := width-c;
    while  (l>0) and (not (sl in ' ',',','+','-','*','/','&','!','=','(',')'))  do  l := l -1;
    writeln(objfile,s:l);
    s := substr(s,l+1);
    l := length(s);
    c := 1;  end;
  write(objfile,s);
end;end;
%page
procedure  addaform(const name,form,ras,dat,rot,beg,lng: string;
           isred,isopt: boolean);  external;
DEFASY:  Define a new asy.
procedure  defasy(name:strt);
  var  s: string(24);
begin
if name='ASYV' then s := '' else begin
case  stoi(substr(name,4))  of
  51: s := 'ASY1+ASY2';
  52: s := 'ASY3+ASY4';
  53: s := 'ASY1+ASY2+ASY3';
  54: s := 'ASY2+ASY4';
  55: s := 'ASY4+ASY5';
  56: s := 'ASY2+ASY3';
  57: s := 'ASY1+ASY3';
  58: s := 'ASY1+ASY2+ASY3+ASY4';
  59: s := 'ASY1+ASY2+ASY3+ASY4+ASY5';
  60: s := 'ASY1+ASY2+ASY4';
  61: s := 'ASY16+ASY17';
  62: s := 'ASY5+ASY6';
  63: s := 'ASY13+ASY14';
  64: s := 'ASY2+ASY5';
  65: s := 'ASY1+ASY4+ASY5';
  66: s := 'ASY1+ASY2+ASY4+ASY5';
  67: s := 'ASY1+ASY2+ASY10';
  68: s := 'ASY8+ASY9';
  69: s := 'ASY1+ASY2+ASY5';
  70: s := 'ASY4+ASY5+ASY6';
  71: s := 'ASY6+ASY7+ASY8+ASY9';
  72: s := 'ASY9+ASY10';
  73: s := 'ASY1+ASY4';
  otherwise  s := '';  end;
end;
if  s<>''  then  addaform(name,s,'','','','','',false,false);
end;
%page
DEFANN: Define annual contribution.
procedure defann(name:strt);
var  s:string(50);
begin
if name='ANCONT' then s := 'ANNPAY(CNT,BENIFITD)' else
s := 'ANNPAY('!!substr(name,3)!!',BENIFITD)';
addaform(name,s,'','','','','',false,false);
end;
%page
LOOKUP:  Lookup a variable or function
procedure lookup(id: strt;  use: boolean);
  var  wasdef: boolean;  p: strp;
begin
p := index(id,'#');
if  p<>0  then  id := substr(id,1,p-1)!!substr(id,p+1);
found := idlist;
while  (found<>nil) and (found@.nname<>id)  do  found := found@.nlink;
if  (found=nil) and use and (length(id)>3) and (substr(id,1,3)='ASY')
  then  defasy(id);
if  (found=nil) and use and (length(id)>3) and (substr(id,1,2)='AN')
  then  defann(id);
wasdef := found<>nil;
if  not wasdef  then begin
  if free=nil then
     new(found)
  else begin
     found := free;
     free := free@.nlink;  end;
  with  found@  do begin
    nlink := idlist;
    nname := id;
    ntype := tpvar;  end;
  idlist:= found;  end;
if  wasdef<>use  then begin
  if  use  then  error('Not Defined '!!id)
           else  error('Defined twice '!!id);
  found@.ntype := tperr;  end;
found@.nused := use;
end;

WELLDEF:  Check if well defined.
function  welldef(const  id: string): boolean;  external;function welldef;
begin
lookup(id,true);
welldef := found@.ntype<>tperr;
end;

DEFINEER:  Check for error
procedure  defineer(const  id: string; iserr: boolean); external;
procedure  defineer;
begin
lookup(id,false);
if iserr then found@.ntype := tperr else found@.ntype := tpfun;
end;

function  idobj(id: strt;  use: boolean): objt;
  var  obj: objt;  p: strp;
begin with  obj  do begin
lookup(id,use);
oper := opid;
otype:= found@.ntype;
opas := found@.nname;
ostd := found@.nname;
idobj := obj;
end;end;

%page
function  numobj(num: strt): objt;
  var  obj: objt;  i: 0..strmax;  pc: boolean;
begin with  obj  do begin
oper := opid;
otype:= tpvar;
pc := false;
if  numlength(num)='%'  then begin
  pc := true;
  num := delete(num,length(num));  end;
i := index(num,'.');
if  i=0  then begin
  num := num !! '.';
  i := length(num);  end;
if  pc  then begin
  num := '00'!!num;
  num := substr(num,1,i-1)!!'.'!!substr(num,i,2)!!substr(num,i+3);  end;

i   := 1;            while  numi='0'  do  i := i + 1;
num := substr(num,i);
i   := length(num);  while  numi='0'  do  i := i - 1;
num := substr(num,1,i);
if  num     1     ='.'  then  num := '0'!!num;
if  numlength(num)='.'  then  num := num!!'0';
obj.opas := num;
if  substr(num,length(num)-1,2)='.0'  then  num := substr(num,1,length(num)-2);
if  (length(num)>1)and(substr(num,1,2)='0.')  then begin
  if  length(num)<4  then  num := num!!substr('00',1,4-length(num));
  num := substr(num,3,2)!!'.'!!substr(num,5);
  if  num     1     ='0'  then  num := substr(num,2);
  if  numlength(num)='.'  then  num := substr(num,1,length(num)-1);
  num := num!!'%';  end;
ostd := num;
numobj := obj;
end;end;
%page
procedure  unop(op:oprt;  var obj: objt);
begin
if  ppop>ppobj.oper
  then  obj.opas := poop!!'('!!obj.opas!!')'
  else  obj.opas := poop!!obj.opas;
if  spop>spobj.oper
  then  obj.ostd := soop!!'('!!obj.ostd!!')'
  else  obj.ostd := soop!!obj.ostd;
obj.oper := op;
end;

procedure  binop(op: oprt;  var obj: objt;  const sub: objt);
  var  ls,rs: objstr;  nassoc: boolean;
begin
binwasred := false;
if  (obj.otype=tpred) or (sub.otype=tpred)and(op<>opsub)  then begin
  error('Reduction');
  obj.otype := tperr;  end;
if  sub.otype=tpred  then  op := opmul;
nassoc := op in opid,opdiv,opsub;
if  op=opimp
  then  ls := 'ord('!!obj.opas!!')'
else if  ppop>ppobj.oper
  then  ls := '('!!obj.opas!!')'
  else  ls :=      obj.opas;
if  (ppop>ppsub.oper) or nassoc and (ppop=ppsub.oper)
  then  rs := '('!!sub.opas!!')'
  else  rs :=      sub.opas;
if  (op=opmul)and(obj.ostd='1')
  then  obj.opas := rs
  else  obj.opas := ls!!poop!!rs;
if  spop>spobj.oper
  then  ls := '('!!obj.ostd!!')'
  else  ls :=      obj.ostd;
if  (spop>spsub.oper) or nassoc and (spop=spsub.oper)
  then  rs := '('!!sub.ostd!!')'
  else  rs :=      sub.ostd;
if  (op=opmul)and(obj.ostd='1')
  then  obj.ostd := rs
  else  obj.ostd := ls!!soop!!rs;
obj.oper := op;
if  sub.otype=tperr  then  obj.otype := tperr;
end;

procedure  triop(op: oprt;  var obj: objt;  const base,lim: objt);
  var  p,s: string(2);
begin
case  op  of
  opge: begin  p := 'a';  s := '>';  end;
  oplt: begin  p := 'b';  s := '<';  end;
  opgt: begin  p := 'o';  s := '>';  end;
  ople: begin  p := 'u';  s := '<='; end;
  end;
case op of
  oplt,opge: begin
    obj.opas := p!!'('!!obj.opas!!','!!base.opas!! ',' !!lim.opas!!')';
    obj.ostd :=   ''!!base.ostd!! s !!obj.ostd!!s!!'='!!lim.ostd!!'';  end;
  opgt,ople: begin
     obj.opas := p!!'('!!obj.opas!!','!!lim.opas!!')';
     obj.ostd :=    ''!!obj.ostd!! s !!lim.ostd!!''; end;
  end;
if  (base.otype=tperr)or(lim.otype=tperr)  then  obj.otype := tperr;
obj.oper := opid;
end;
%page
ADDAFORM:  Parse the given formula and add write to formulas
 and procedures.
procedure  addaform(const name,form,ras,dat,rot,beg,lng: string;
                     isred,isopt: boolean);  external;
label  1;failure
  var  nextstr: strt;  nextsym: symt;  nextopr: oprt;
       p: normal;  addls,addrs: objt;

  function   expression(lim: prt): objt;  forward;
  procedure  scan;  forward;

  procedure  parseerror(const msg: string);
  begin with  addrs  do begin
  error('Parse '!!msg);
  writeln(failfile,' ':11,form);
  writeln(failfile,'!':11+p);
  otype:= tperr;
  oper := opid;
  opas := '';
  ostd := form;
  goto 1;
  end;end;

  procedure  expecting(sym: symt);
  begin
  if  nextsym<>sym  then  parseerror('Expecting '!! smtextsym);
  scan;
  end;
%page
  procedure  scan;
    var  i,l: normal;  nextch: char;  point: boolean;
  begin
  assert nextsym<>smend;
  l := length(form);
  p := p + length(nextstr);
  i := p + 1;
  if  i>l  then  nextch := ' '  else  nextch := formi;
  if  p>l  then
    nextsym := smend
  else begin
    nextsym := smop;
    case  formp  of
      ',': nextsym := smcoma;
      '(': nextsym := smlp;   ')': nextsym := smrp;
      '': nextsym := smlb;   '': nextsym := smrb;
      '&': nextopr := opand;  '!': nextopr := opor;
      '/': nextopr := opdiv;  '*': nextopr := opmul;
      '+': nextopr := opadd;
      '^': begin nextsym := smuop; nextopr := opnot;  end;
      '-': if  nextch<>'>'  then  nextopr := opsub
           else begin  i := i+1;  nextopr := opimp end;
      '<': if  nextch<>'='  then  nextopr := oplt
           else begin  i := i+1;  nextopr := ople  end;
      '>': if  nextch<>'='  then  nextopr := opgt
           else begin  i := i+1;  nextopr := opge  end;
      '$','.','0'..'9':begin
           nextsym := smnum;  nextopr := opid;
           point := false;
           if  formp='$'  then  p := i  else  i := p;
           while  (i<=l) and (formi>='0') and (formi<='9')  do
             i := i + 1;
           if (i<=l) and (formi='.') then begin
             i := i + 1;  point := true;
             while  (i<=l) and (formi>='0') and (formi<='9')  do
               i:=i+ 1;  end;
           if  i=p+ord(point)  then  parseerror('Bad number');
           if  (i<=l)and(formi='%')  then  i := i + 1;
           end;
      'A','B','C','D','E','F','G','H','I','J','K','L','M',
      'N','O','P','Q','R','S','T','U','V','W','X','Y','Z': begin
           nextsym := smid;
           while  (i<=l) and (formi in '0'..'9','#','A','B','C',
                   'D','E','F','G','H','I','J','K','L','M','N','O',
                   'P','Q','R','S','T','U','V','W','X','Y','Z')  do
             i := i + 1;
             if  i-p>strmax  then  parseerror('Name too long');  end;
      otherwise  parseerror('Invalid Character');  end;
    nextstr := substr(form,p,i-p);
  end;end;
%page
  function  factor: objt;
    var  fact,base,expr,dup: objt;  typ: typt;  op: oprt;
  begin
  case  nextsym  of
    smnum: begin
      fact := numobj(nextstr);
      scan;  end;
    smlp: begin
      scan;
      fact := expression(prset);
      expecting(smrp);   end;
    smid: begin
      fact := idobj(nextstr,true);
      scan;
      if  (fact.otype=tpfun) and (nextsym=smlp)  then begin
        scan;
        base := expression(prset);
        while  nextsym=smcoma  do begin
          scan;
          binop(oppl,base,expression(prset));  end;
        binop(opid,fact,base);
        expecting(smrp);
        end;  end;
    otherwise
      parseerror('Expecting a name');  end;
  if  nextsym=smlb  then begin
    scan;
    base := expression(prrel);
    op  := nextopr;
    expecting(smop);
    if  not (op in oplt,ople,opgt)  then  parseerror('Bad range');
    expr := expression(prrel);
    if  nextsym=smrb  then
      dup := base
    else begin
      dup := expr;
      if  not ((op=oplt)and(nextopr=ople)or(op=opgt)and(nextopr=opge))
        then parseerror('Bad range');
      if  op=opgt  then  op := opge;
      expecting(smop);
      expr := expression(prrel);  end;
    if  dup.ostd<>fact.ostd  then  parseerror('Range missmatch');
    triop(op,fact,base,expr);
    expecting(smrb);  end;
  factor := fact;
  end;
%page
  function  expressionlim: sprt): objt;  forward;
    var  obj: objt;  op: oprt;  hadadd: boolean;
  begin
  hadadd := false;
  if  (nextsym<>smuop) or (spnextopr<=lim)  then
    obj := factor
  else begin
    op := nextopr;
    scan;
    obj := expression(spnextopr);
    unop(op,obj);  end;
  while  (nextsym=smop) and (spnextopr>lim) do begin
    op := nextopr;
    scan;
    binop(op,obj,expression(spop));
    if  hadadd and binwasred  then parseerror('Reduce what');
    if  spop=pradd  then  hadadd := true;  end;
  expression := obj;
  end;
%page
ADDAFORM's main code
begin
nsform := nsform + 1;
p := 1;  nextstr := '';  nextsym := smcoma;  scan;
addrs := expression(prset);
if  nextsym<>smend  then  parseerror('Junk at end');
1:
addls := idobj(name,false);
if  isred  then  found@.ntype := tpred;
binop(opset,addls,addrs);
if  addls.otype<>tperr  then
  punch(addls.opas!!';')
else begin
  addls.ostdindex(addls.ostd,'=') := ' ';
  found@.ntype := tperr;  end;
found@.nused := isopt;
print(addls.ostd);
end;

ADDFORM:  Calls addaform with isred and isopt set to false
procedure  addform(const name,form: string);  external;
procedure  addform;
begin  addaform(name,form,'','','','','',false,false);  end;
%page
BEGCASE:  Begin a plan, print header in formulas and procedure
 name in procedures.
procedure  begcase(const code,seq,ppid,plan: string);  external;
procedure  begcase;
begin
nsform := 0;
header := 'C-'!!code;
print('_________________________________________________________________');
if  linenum<linesperpage-5  then  print('')
                            else  linenum := linesperpage+1;
print('CodeID:'!!code!!' SEQ#:'!!seq!!' PPID:'!!ppid!!' Plan:'!!plan);
print('');
punch('');
punch('procedure c'!!code!!'s'!!seq!!'; begin');
end;

ENDCASE:  End a plan, check for negative formulas with a big
 if min statement in procedures.
function  endcase: integer;  external;
function  endcase;
  var  n,p: nptr; s: objstr;  nt: strt;
begin
p := nil;  n := idlist; s := '';
punch('if min(');
while  n<>prelist  do with  n@  do begin
  if  not (nused or (ntype=tperr)) then  error('Defined, but not used: '!!nname);
  nt := substr(nname,1,min(3,length(nname)));
  if  (ntype<>tpfun)and(ntype<>tperr)and(nt<>'RAS')and(nt<>'ROT')and(nt<>'DAT') then begin
    if  length(s)>objmax-strmax-1  then
      begin  punch(s);  s := '';  end;
    s := s!!nname!!',';  end;
  p := n;
  n := nlink;  end;
if  p<>nil  then begin
  p@.nlink := free;
  free := idlist;
  idlist := prelist;  end;
slength(s) := ')';
punch(s);
punch('<0 then negative end;');
endcase := nsform;
end;
%page
EMITINIT:  Initialization
procedure emitinit; external;
procedure emitinit;
begin
spopid :=prid;  ppopid :=prid;  soopid :='';   poopid :='';
spopmul:=prmul; ppopmul:=prmul; soopmul:='*';  poopmul:='*';
spopdiv:=prmul; ppopdiv:=prmul; soopdiv:='/';  poopdiv:='/';
spopadd:=pradd; ppopadd:=pradd; soopadd:='+';  poopadd:='+';
spopsub:=pradd; ppopsub:=pradd; soopsub:='-';  poopsub:='-';
spoplt :=prrel; ppoplt :=prrel; sooplt :='<';  pooplt :='<';
spople :=prrel; ppople :=prrel; soople :='<='; poople :='<=';
spopeq :=prrel; ppopeq :=prrel; soopeq :='=';  poopeq :='=';
spopne :=prrel; ppopne :=prrel; soopne :='<>'; poopne :='<>';
spopge :=prrel; ppopge :=prrel; soopge :='>='; poopge :='>=';
spopgt :=prrel; ppopgt :=prrel; soopgt :='>';  poopgt :='>';
spopnot:=prnot; ppopnot:=prid;  soopnot:='^';  poopnot:='^';
spopand:=prand; ppopand:=prmul; soopand:='&';  poopand:='&';
spopor :=pror;  ppopor :=pradd; soopor :='!';  poopor :='!';
spopimp:=primp; ppopimp:=prmul; soopimp:='->'; poopimp:='*';
spoppl :=prset; ppoppl :=prset; sooppl :=',';  pooppl :=',';
spopset:=prset; ppopset:=prset; soopset:='=';  poopset:=':=';

smtextsmend := '<end>';  smtextsmop  := '<op>';
smtextsmid  := '<var>';  smtextsmnum := '<num>';
smtextsmlp  := '(';      smtextsmrp  := ')';
smtextsmlb  := '';      smtextsmrb  := '';
smtextsmcoma:= ',';

rewrite(output);
rewrite(objfile,'unit=spunch,nocc');
linenum := linesperpage+1;
pagenum := 0;
header  := '';

free := nil;
idlist := nil;
Variables and functions that will be defined in CALCULATE
lookup('QAPPROVL',false);
lookup('QCHILD21',false);
lookup('QCODABLE',false);
lookup('QHAZDUTY',false);
lookup('QJRDABLE',false);
lookup('QJRDEATH',false);
lookup('QPASTSRV',false);
lookup('QSSBENIF',false);
lookup('QSSDABLE',false);
lookup('QVETERAN',false);
lookup('QVOLCNTR',false);
lookup('QWDMAN',  false);
lookup('QWDVOL',  false);
lookup('ACPIG',   false);
lookup('AWAGEG',  false);
lookup('UNFINISH',false);
lookup('OTHERB',  false);
lookup('ERD',     false);
lookup('NRD',     false);
lookup('JSRED',   false);
lookup('COSTRED', false);
lookup('FAR',     false);  found@.ntype := tpfun;
lookup('TAR',     false);  found@.ntype := tpfun;
lookup('AA',      false);  found@.ntype := tpfun;
lookup('ANYTIME', false);  found@.ntype := tpfun;
lookup('AI',      false);  found@.ntype := tpfun;
lookup('AR',      false);  found@.ntype := tpfun;
lookup('SS',      false);  found@.ntype := tpfun;
lookup('SSAGE',   false);  found@.ntype := tpfun;
lookup('SSBASE',  false);  found@.ntype := tpfun;
lookup('AVGMIN',  false);  found@.ntype := tpfun;
lookup('SUMMIN',  false);  found@.ntype := tpfun;
lookup('SUM',     false);  found@.ntype := tpfun;
lookup('AVG',     false);  found@.ntype := tpfun;
lookup('MIN',     false);  found@.ntype := tpfun;
lookup('MAX',     false);  found@.ntype := tpfun;
lookup('NN',      false);  found@.ntype := tpfun;
lookup('NNMIN',   false);  found@.ntype := tpfun;
lookup('WAGE',    false);  found@.ntype := tpfun;
lookup('SUMI',    false);  found@.ntype := tpfun;
lookup('ANNPAY',  false);  found@.ntype := tpfun;
lookup('OTHCONT', false);  found@.ntype := tpfun;
lookup('VOPT',    false);  found@.ntype := tpfun;
lookup('CRVOL',   false);
lookup('CRPROF1', false);
lookup('CRFORT1', false);
lookup('CRPROF2', false);
lookup('CRFORT2', false);
lookup('CRPROF3', false);
lookup('CRFORT3', false);
lookup('MMANNAR', false);
lookup('MVOLNAR', false);
lookup('COENAR',  false);
lookup('MANNAR',  false);
lookup('VOL1NAR', false);
lookup('VOL2NAR', false);
lookup('SURVEYD', false);
lookup('AGE',     false);
lookup('QUITAGE', false);
lookup('BENIFITD',false);
lookup('BIRTHD',  false);
lookup('HIRED',   false);
lookup('PARTD',   false);
lookup('QUITD',   false);
------------------------
lookup('RAS96',   false);
lookup('ROT96',   false);
lookup('DAT96',   false);
lookup('BGN96',   false);
lookup('LNG96',   false);
------------------------
lookup('WRKHRS',  false);
prelist := found;
end;
 .
