                        {file DUMPTREE}

implement

procedure dumpvalu (val: valu);
  var i: shortint; p: vcref;
$if bigsets$
        s : setrecptr;                  (* current set record item *)
        j : integer;                    (* simple local counter *)
        bias, rel_elem: shortint;       (* ordinal bias and relative
                                                element value for list *)
$end$

  begin
  with val do
    if intval then write(lp,ival:1)
    else
      with valp^ do
        case cclass of
          reel:       write(lp,rval);
          pset:       begin
                      write(lp,'set:');
$if bigsets$
                      for j := 0 to plgth-1 do
                        begin
                        if (j mod 32) = 0 then
$end$
$if not bigsets$
                      for i := 0 to plgth-1 do
                        begin
                        if (i mod 32) = 0 then
$end$
                          begin
                          incrlinecount;
                          writeln(lp);
                          write(lp,'':2);
                          end;
 $if bigsets$
                       bias := j DIV (oldsethigh + 1);
                       rel_elem := j MOD (oldsethigh + 1);
                       s := pval;
                       for i := 1 to bias do s := s^.nxt;
                       if rel_elem in s^.val then
 $end$
 $if not bigsets$
                        if i in pval then
 $end$
                          write(lp,'1')
                        else write(lp,'0');
                        end;
                      end;
          paofch:     write(lp,'paofchar:',sval:slgth);
          strng:      write(lp,'string:',sval:slgth);
          bigpaoc:    begin
                      write(lp,'paofchar:');
                      for i := 1 to paoclgth do
                        begin
                        if i mod 70 = 0 then
                          begin
                          incrlinecount;
                          writeln(lp);
                          write(lp,'':9);
                          end;
                        $RANGE OFF$
                        write(lp,paocval[i]:1);
                        $IF rangechecking$
                          $RANGE ON$
                        $END$
                        end;
                      end;
          strctconst: begin
                      incrlinecount;
                      write(lp,'structured constant: ');
                      if kstruc = nil then
                        writeln(lp,'value not saved')
                      else
                        with kstruc^ do
                          begin writeln(lp);
                          incrlinecount;
                          if scstp^.form = arrays then writeln(lp,'array')
                          else if scstp^.form = records then
                            writeln(lp,'record');
                          p := scvcp;
                          while p <> nil do
                            begin
                            incrlinecount;
                            dumpvalu(p^.vcval);
                            writeln(lp);
                            p := p^.vcnxt;
                            end;
                          end;
                      end;
          end; {case}
  end; {dumpvalu}
$IF FULLDUMP$
procedure dumpinfobits (inf: infobits);
  var ch: char;
  begin
  ch := '[';
  if predeclared in inf then
    begin write(lp,ch,'PDEC'); ch:=',' end;
  if mustinitialize in inf then
    begin write(lp,ch,'INIT'); ch:=',' end;
  if cantassign in inf then
    begin write(lp,ch,'NOASSGN'); ch:=',' end;
  if nonstandard in inf then
    begin write(lp,ch,'NONSTD'); ch:=',' end;
  if sysprogreq in inf then
    begin write(lp,ch,'SYSPROG'); ch:=',' end;
  if modcalreq in inf then
    begin write(lp,ch,'MODCAL'); ch:=',' end;
  if ucsdreq in inf then
    begin write(lp,ch,'UCSD'); ch:=',' end;
  if ch='[' then write(lp,ch);
  write(lp,']');
  end;
$END$
procedure writename (leadb: shortint; var str: string);
  {Write string, normalized length, at least 1 trailing blank}
  begin
  write(lp,' ':leadb,str,' ':17-strlen(str));
  end;

procedure dumpsymbol (fcp: ctp; indent: shortint); forward;

procedure dumpstruct (fsp: stp; indent: shortint);
  { Dump a structure node }
  begin
  incrlinecount;
  write(lp,' ':indent);
  if fsp = nil then writeln(lp,'NIL type')
  else with fsp^ do
    begin
    if fsp = intptr then write(lp,'integer')
    else if fsp = realptr then write(lp,'real')
    else if fsp = boolptr then write(lp,'boolean')
    else if fsp = char_ptr then write(lp,'char')
    else
      case form of
        scalar: write(lp,'scalar');
        subrange: begin
                  write(lp,'subrange min=');
                  write(lp,min:1);
                  write(lp,' max=');
                  write(lp,max:1);
                  end;
        prok: write(lp,'prok parmlc=',parmlc:1);
        funk: write(lp,'funk parmlc=',parmlc:1);
        pointer: write(lp,'pointer');
        power: write(lp,'set ',setmin:1,'..',setmax:1);
        files: write(lp,'file');
        arrays: begin
                write(lp,'array ');
                if aispackd then
                  write(lp,'elbitsize=',aelbitsize:1)
                else write(lp,'elsize=',aelsize:1);
                end;
        records: write(lp,'record');
        otherwise write(lp,'unexpected form=',ord(form))
        end; {case form}
    write(lp,' unpacksize=',unpacksize:1);
    if sizeoflo then write(lp,' (OFLO)');
    write(lp,' align=',align:1);
    if ispackable then
      begin
      write(lp,' bitsize=',bitsize:1);
      if signbit then write(lp,' signed');
      end;
    $IF FULLDUMP$
    write(lp,'   ');
    dumpinfobits(info);
    $END$
    writeln(lp);
    case form of
      records: dumpsymbol(fstfld,indent+2);
      prok:    dumpsymbol(params,indent+2);
      otherwise
      end; {2nd case form}
    end {with fsp^}
  end; {dumpstruct}

procedure dumpsymbol (*fcp: ctp; indent: shortint*);
  { Dump symbol table tree rooted at FCP }
  begin
  if fcp <> nil then
    with fcp^ do
      begin
      dumpsymbol(llink,indent);
      incrlinecount;
      writename(indent,namep^);
      case klass of
        types: write(lp,'type');
        konst: begin
               write(lp,'konst '); dumpvalu(values);
               end;
        routineparm,
        vars: begin
              write(lp,'var lev=',vlev:2,' addr=',vaddr:6);
              case vtype of
                shortvar: write(lp,' short');
                longvar:  write(lp,' long');
                relvar:   write(lp,' relative');
                localvar: if globalptr = NIL then write(lp,' local')
                          else write(lp,' globalbase = ',globalptr^);
                valparm:  write(lp,' valparm');
                refparm:  write(lp,' refparm');
                boundparm: write(lp,' boundparm');
                cvalparm: write(lp,' copyparm; addr=',vptraddr:1);
                procparm: begin write(lp,' procparm');
                          dumpstruct(proktype,indent);
                          end;
                funcparm: begin write(lp,' funcparm');
                          dumpstruct(proktype,indent);
                          write(lp,'  result type:');
                          dumpstruct(idtype,indent);
                          end;
                strparm:  begin
                          write(lp,' var string',' maxlength offset:',vaddr+4:6);
                          end;
                anyvarparm:  write(lp,' anyvarparm');
                end;
              end;
        field:  begin
                write(lp,'field offset=',fldaddr:1);
                if fispackd then write(lp,' bitoffset=',fldfbit:1);
                end;
        prox,func:
               begin
               if klass = prox then
                 if ismodulebody then write(lp,'module ')
                                 else write(lp,'proc ')
               else write(lp,'func ');
               case pfdeckind of
                 special:  write(lp,'special ',ord(spkey):1,' ');
                 standard: write(lp,'standard ',ord(spkey):1,' ');
                 declared: begin
                           write(lp,'lev=',pflev:1);
                           if klass=func then write(lp,' result=',pfaddr:1);
                           if forwdecl then write(lp,' forw');
                           if extdecl  then write(lp,' ext');
                           if (klass <> prox) or not ismodulebody
                              and isdumped then
                             begin
                             incrlinecount;
                             writeln(lp);
                             incrlinecount;
                             writeln(lp,'   entry: ',
                                     currentglobal^,'__BASE + ',
                                     location:1);
                             incrlinecount;
                             writeln(lp,'   exit: ',
                                     currentglobal^,'__BASE + ',
                                     exit_location:1);
                             end;
                           end;
                 otherwise
                 end; {pfdeckind}
               end;
        otherwise
        end; {case klass}
      $IF FULLDUMP$
      write(lp,'  ');
      dumpinfobits(info);
      $END$
      writeln(lp);
      if klass = types then dumpstruct(idtype,indent+2);
      dumpsymbol(rlink,indent);
      end; {with}
  end; {dumpsymbol}

procedure dumptree (*curbody: stptr; fprocp: ctp*);
  (* Prints statement/expression trees *)
  var
    lstate: modstateptr;
$IF FULLDUMP$ { SUPPRESS EXPR/STMT DUMP }
  procedure dumpelist (fexp: elistptr; setdeno: boolean);
    (* on entry
         fexp points to the head of a (possibly empty) list of
           'explist' records.
         setdeno indicates the variant of the records.
       on exit
         the 'enum's associated with the list have been printed to file lp.
         NO end-of-line mark has been written to the file *)
    begin
      while fexp<>nil do
        with fexp^ do begin
          if not setdeno then
          if expptr = nil then write(lp,' NIL')
          else write(lp,' ',expptr^.enum:1)
          else write(lp,' ',lowptr^.enum:1,':',hiptr^.enum:1);
          fexp := nextptr;
          end;
    end (*dumpelist*);

  procedure dumpexprs;
    (* prints expression records to file lp. The expressions are printed
       as encountered on the linear list headed by firstexp^.echain and
       linked by echain fields. *)
     var lexp: exptr;

     procedure dumpoperands;
       begin
         with lexp^ do
           case eclass of
             eqnode..andnode,concatnode:
               begin
               incrlinecount;
               writeln(lp,'  operands: ',
                    opnd1^.enum:1,',',opnd2^.enum:1);
               end;
             negnode..truncnode:
               write(lp,'  operand: ',opnd^.enum:1);
             idnode: writename(2,symptr^.namep^);
             subscrnode,
             substrnode:
               begin write(lp,'  arayp: ',arayp^.enum:1,
                     ', index: ',indxp^.enum:1);
               if eclass = substrnode then
                 begin write(lp,', lengthp = ');
                 if lengthp = nil then write(lp,'NIL')
                 else write(lp,lengthp^.enum:1);
                 end;
               end;
             selnnode:    begin write(lp,'  rec: ',recptr^.enum:1,', field:');
                          writename(1,fieldptr^.namep^);
                          end;
             unqualfldnode:
                          begin write(lp,'  withst: ',withstptr^.snum:1,
                                                      ', field:');
                          writename(1,fieldref^.namep^);
                          end;
             litnode:     begin
                          incrlinecount;
                          write(lp,'  ');
                          dumpvalu(litval); writeln(lp)
                          end;
             fcallnode:   begin
                          incrlinecount;
                          writename(2,fptr^.namep^);
                          if actualp = nil then writeln(lp,' no parms')
                          else begin
                               write(lp,' parms:');
                               dumpelist(actualp,false);
                               writeln(lp)
                               end
                          end;
             setdenonode: begin
                          with etyptr^ do
                            begin
                            write(lp,'  unpacksize=',unpacksize:1);
                            if ispackable then write(lp,' bitsize=',bitsize:1);
                            end;
                          if setcstpart.valp <> nil then
                            begin
                            incrlinecount;
                            write(lp,', cst part: ');
                            dumpvalu(setcstpart); writeln(lp);
                            end
                          else writeln(lp,', no cst part');
                          if setvarpart<>nil then
                            begin
                            incrlinecount;
                            write(lp,'var part:':43);
                            dumpelist(setvarpart,true); writeln(lp)
                            end;
                          end;
             otherwise    begin
                          incrlinecount;
                          writeln(lp,'???');
                          end;
             end (*case eclass*)
       end(*dumpoperands*);

     procedure printclass (cls: exprs);
       begin
         case cls of
           eqnode:        write(lp,'eqnode':12);
           nenode:        write(lp,'nenode':12);
           ltnode:        write(lp,'ltnode':12);
           lenode:        write(lp,'lenode':12);
           gtnode:        write(lp,'gtnode':12);
           genode:        write(lp,'genode':12);
           innode:        write(lp,'innode':12);
           subsetnode:    write(lp,'subsetnode':12);
           supersetnode:  write(lp,'supersetnd':12);
           concatnode:    write(lp,'concatnode':12);
           addnode:       write(lp,'addnode':12);
           subnode:       write(lp,'subnode':12);
           ornode:        write(lp,'ornode':12);
           unionnode:     write(lp,'unionnode':12);
           diffnode:      write(lp,'diffnode':12);
           mulnode:       write(lp,'mulnode':12);
           divnode:       write(lp,'divnode':12);
           modnode:       write(lp,'modnode':12);
           andnode:       write(lp,'andnode':12);
           intersectnode: write(lp,'intersectnd':12);
           selnnode:      write(lp,'selnnode':12);
           negnode:       write(lp,'negnode':12);
           floatnode:     write(lp,'floatnode':12);
           strlennode:    write(lp,'strlennode':12);
           notnode:       write(lp,'notnode':12);
           unqualfldnode: write(lp,'unqualfldnd':12);
           derfnode:      write(lp,'derfnode':12);
           absnode:       write(lp,'absnode':12);
           chrnode:       write(lp,'chrnode':12);
           oddnode:       write(lp,'oddnode':12);
           ordnode:       write(lp,'ordnode':12);
           roundnode:     write(lp,'roundnode':12);
           sqrnode:       write(lp,'sqrnode':12);
           truncnode:     write(lp,'truncnode':12);
           fcallnode:     write(lp,'fcallnode':12);
           setdenonode:   write(lp,'setdenonode':12);
           subscrnode:    write(lp,'subscrnode':12);
           substrnode:    write(lp,'substrnode':12);
           idnode:        write(lp,'idnode':12);
           litnode:       write(lp,'litnode':12);
           otherwise      write(lp,' eclass is garbage: ',ord(cls):1)
           end;
       end;

     begin (*dumpexprs*)
       lexp := firstexp^.echain;
       incrlinecount;
       if lexp = nil then writeln(lp,' no expressions')
       else begin
         writeln(lp,'ENUM':5,'EKIND':6,'TYPE':9,'ECLASS':12);
         repeat
           with lexp^ do
             begin
             incrlinecount;
             write(lp,enum:5);
             case ekind of
               cnst: write(lp,'cnst':6);
               vrbl: write(lp,'vrbl':6);
               xpr:  write(lp,'xpr':6)
               end;
             if etyptr = boolptr then write(lp,'bool':9)
             else if etyptr = char_ptr then write(lp,'char':9)
             else if etyptr = intptr  then write(lp,'int':9)
             else if etyptr = shortintptr then write(lp,'shortint':9)
             else if etyptr = realptr then write(lp,'real':9)
             else if etyptr = nil then write(lp,'NIL':9)
             else
               case etyptr^.form of
                 scalar:   write(lp,'scalar':9);
                 subrange: write(lp,'subrange':9);
                 prok:     write(lp,'prok':9);
                 funk:     write(lp,'funk':9);
                 pointer:  write(lp,'pointer':9);
                 power:    write(lp,'power':9);
                 arrays:   write(lp,'arrays':9);
                 records:  write(lp,'records':9);
                 files:    write(lp,'files':9);
                 otherwise write(lp,' form=',ord(etyptr^.form):3)
                 end;
             printclass(eclass);
             dumpoperands;
             end; (*with lexp^*)
           lexp := lexp^.echain; writeln(lp);
         until lexp = nil
       end (*lexp <> nil*)
    end (*dumpexprs*);

  procedure dumpstmts (curstmt:stptr);
    var lexp: elistptr;

    procedure namebody (name: alpha; body: stptr);
      begin
        write(lp,name);
        if body=nil then write(lp,'nil')
        else write(lp,body^.snum:1);
      end (*namebody*);

    procedure dumpbody (name: alpha; body: stptr);
      begin
      incrlinecount;
      namebody(name,body); writeln(lp);
      dumpstmts(body)
      end (*dumpbody*);

    procedure dumpcasest (curstmt: stptr);
      var lclabp: clabptr; lstmt,nextsave: stptr;
      begin
        with curstmt^ do
          begin
          incrlinecount;
          writeln(lp,'casest':10,'  nrlabs: ',nrlabs:1,', nrstmts: ',nrstmts:1,
                  ', selecter: ',selecter^.enum:1);
          write(lp,' ':40);
          namebody('firstmt: ',firstmt);
          namebody(', otherwyse: ',otherwyse);
          incrlinecount;
          writeln(lp);
          incrlinecount;
          writeln(lp,' ':40,'case list elements:');
          lclabp := minlab;
          while lclabp <> nil do
            with lclabp^ do
              begin
              incrlinecount;
              writeln(lp,' ':40,lowval:1,'..',hival:1,': ',cstmt^.snum:1);
              lclabp := clabp
              end;
          lstmt := firstmt;
          while lstmt<>nil do
            with lstmt^ do begin
              nextsave := next; next := nil;
              dumpstmts(lstmt);
              next := nextsave;
              lstmt := nextsave
              end;
          dumpstmts(otherwyse)
          end (* with curstmt^ *)
      end (*dumpcasest*);

    begin (*dumpstmts*)
      while curstmt<>nil do
        with curstmt^ do begin
          write(lp,snum:5);
          if next<>nil then write(lp,next^.snum:7) else write(lp,'NIL':7);
          if labp<>nil then write(lp,labp^.labval:7) else write(lp,' ':7);
          write(lp,lineno:7); write(lp,' ');
          case sclass of
            becomest: begin
                      incrlinecount;writeln(lp,'becomest':10,'  lhs: ',lhs^.enum:1,
                          ', rhs: ',rhs^.enum:1);
                      end;
            pcallst:  begin
                      incrlinecount;
                      write(lp,'pcallst':10);
                      writename(2,psymptr^.namep^);
                      if actualp = nil then writeln(lp,' no parms')
                      else begin
                           write(lp,' parms:');
                           dumpelist(actualp,false);
                           writeln(lp)
                           end
                      end;
            casest:   dumpcasest(curstmt);
            compndst: begin write(lp,'compndst':10);
                      dumpbody('  cbody: ',cbody) end;
            forst:    begin
                      incrlinecount;
                      write(lp,'forst':10);
                      writeln(lp,'  ctrl: ',ctrl^.enum:1,', init: ',init^.enum:1,
                              ', incr ',incr:1,', limit: ',limit^.enum:1);
                      write(lp,' ':40); dumpbody('fbody: ',fbody) end;
            gotost:   begin
                      incrlinecount;
                      writeln(lp,'gotost':10,
                              '  target: ',target^.labval:1);
                      end;
            ifst:     begin
                      incrlinecount;
                      write(lp,'ifst':10,'  ifcond: ',ifcond^.enum:1);
                      namebody(', tru: ',tru); namebody(', fals: ',fals);
                      writeln(lp); dumpstmts(tru); dumpstmts(fals)
                      end;
            repst:    begin write(lp,'repeatst':10,'  rcond: ',rcond^.enum:1);
                      dumpbody(', rbody: ',rbody) end;
            whilest:  begin write(lp,'whilest':10,'  rcond: ',rcond^.enum:1);
                      dumpbody(', rbody: ',rbody) end;
            tryst:    begin
                      incrlinecount;
                      write(lp,'tryst':10); namebody('  tbody: ',tbody);
                      namebody(', recov: ',recov); writeln(lp);
                      dumpstmts(tbody); dumpstmts(recov);
                      end;
            withst:   begin write(lp,'withst':10,'  record: ',refexpr^.enum:1);
                      dumpbody(', wbody: ',wbody) end;
            emptyst:  begin
                      incrlinecount;
                      writeln(lp,'emptyst':10);
                      end;
            endofbodyst: begin
                         incrlinecount;
                         writeln(lp,' endofbodyst');
                         end;
            otherwise begin
                      incrlinecount;
                      writeln(lp,' sclass is garbage: ',ord(sclass):1)
                      end;
            end (*case*);
          curstmt := next
        end (*with curstmt^*)
    end (*dumpstmts*);
$END$
  begin (*dumptree*)
  if (initlistmode = listfull) and listopen then
    begin
    incrlinecount;
    writeln(lp);
    incrlinecount;
    writeln(lp,'Dump of ',fprocp^.namep^);
    with display[top] do
      begin
      if occur = MODULEscope then
        begin
        incrlinecount;
        writeln(lp,'Imported:');
        lstate := fmodule^.modinfo^.usemodule;
          begin
          dumpsymbol(fmodule^.modinfo^.useids,0);
          while lstate <> nil do
            begin
            dumpsymbol(lstate^.defineids,0);
            lstate := lstate^.nextmodule;
            end;
          end;
        incrlinecount; writeln(lp);
        incrlinecount;
        writeln(lp,'Exported:');
        lstate := fmodule;
        while lstate <> nil do
          begin dumpsymbol(lstate^.defineids,0);
          lstate := lstate^.contmodule;
          end;
        incrlinecount; writeln(lp);
        incrlinecount; writeln(lp);
        end;
      dumpsymbol(fname,0);
      incrlinecount; writeln(lp)
      end;
    $IF FULLDUMP$
    incrlinecount;
    writeln(lp,' SNUM   NEXT  LABEL LINENO     SCLASS');
    dumpstmts(curbody);
    incrlinecount; writeln(lp);
    dumpexprs;
    $END$
    incrlinecount;
    writeln(lp,fprocp^.namep^,' dump complete');
    incrlinecount; writeln(lp);
    if ioresult <> ord(inoerror) then
      begin
      listabort := true;
      list := listnone;
      listopen := false;
      warning(linenumber,'Listing aborted');
      end;
    end;
  end (*dumptree*);



