Usenet 1994 January/usenetsourcesnewsgroupsinfomagicjanuary1994.iso/sources/misc/volume23/pascal/part01/pcom.p

Text File | 1991-09-27 | 44.8 KB | 1,588 lines

(*$c+,t-,d-,l-*)
 (***********************************************
  *                        *
  *     Portable Pascal compiler        *
  *     ************************        *
  *                        *
  *        Pascal P4            *
  *                        *
  *     Authors:                *
  *          Urs Ammann            *
  *          Kesav Nori            *
  *          Christian Jacobi            *
  *     Address:                *
  *      Institut Fuer Informatik        *
  *      Eidg. Technische Hochschule        *
  *      CH-8096 Zuerich            *
  *                        *
  *  This code is fully documented in the book    *
  *       "Pascal Implementation"        *
  *   by Steven Pemberton and Martin Daniels    *
  * published by Ellis Horwood, Chichester, UK    *
  *       (also available in Japanese)        *
  *                        *
  * Steven Pemberton, CWI/AA,            *
  * Kruislaan 413, 1098 SJ Amsterdam, NL    *
  * [e-mail]                *
  *                        *
  *                        *
  ***********************************************)

program pascalcompiler(input,output,prr);

const displimit = 20; maxlevel = 10;
   intsize     =      1;
   intal       =      1;
   realsize    =      1;
   realal      =      1;
   charsize    =      1;
   charal      =      1;
   charmax     =      1;
   boolsize    =      1;
   boolal      =      1;
   ptrsize     =      1;
   adral       =      1;
   setsize     =      1;
   setal       =      1;
   stackal     =      1;
   stackelsize =      1;
   strglgth    =     16;
   sethigh     =     47;
   setlow      =      0;
   ordmaxchar  =     63;
   ordminchar  =      0;
   maxint      =  32767;
   lcaftermarkstack = 5;
   fileal      = charal;
   (* stackelsize = minimum size for 1 stackelement
          = k*stackal
      stackal     = scm(all other al-constants)
      charmax     = scm(charsize,charal)
            scm = smallest common multiple
      lcaftermarkstack >= 4*ptrsize+max(x-size)
            = k1*stackelsize      *)
   maxstack   =       1;
   parmal     = stackal;
   parmsize   = stackelsize;
   recal      = stackal;
   filebuffer =       4;
   maxaddr    =  maxint;



type                            (*describing:*)
                                (*************)

     marktype= ^integer;
                                (*basic symbols*)
                                (***************)

     symbol = (ident,intconst,realconst,stringconst,notsy,mulop,addop,relop,
           lparent,rparent,lbrack,rbrack,comma,semicolon,period,arrow,
           colon,becomes,labelsy,constsy,typesy,varsy,funcsy,progsy,
           procsy,setsy,packedsy,arraysy,recordsy,filesy,forwardsy,
           beginsy,ifsy,casesy,repeatsy,whilesy,forsy,withsy,
           gotosy,endsy,elsesy,untilsy,ofsy,dosy,tosy,downtosy,
           thensy,othersy);
     operator = (mul,rdiv,andop,idiv,imod,plus,minus,orop,ltop,leop,geop,gtop,
         neop,eqop,inop,noop);
     setofsys = set of symbol;
     chtp = (letter,number,special,illegal,
         chstrquo,chcolon,chperiod,chlt,chgt,chlparen,chspace);

                                (*constants*)
                                (***********)
     setty = set of setlow..sethigh;
     cstclass = (reel,pset,strg);
     csp = ^ constant;
     constant = record case cclass: cstclass of
             reel: (rval: packed array [1..strglgth] of char);
             pset: (pval: setty);
             strg: (slgth: 0..strglgth;
                sval: packed array [1..strglgth] of char)
               end;

     valu = record case intval: boolean of  (*intval never set nor tested*)
             true:  (ival: integer);
             false: (valp: csp)
           end;

                               (*data structures*)
                               (*****************)
     levrange = 0..maxlevel; addrrange = 0..maxaddr;
     structform = (scalar,subrange,pointer,power,arrays,records,files,
           tagfld,variant);
     declkind = (standard,declared);
     stp = ^ structure; ctp = ^ identifier;

     structure = packed record
           marked: boolean;   (*for test phase only*)
           size: addrrange;
           case form: structform of
             scalar:   (case scalkind: declkind of
                  declared: (fconst: ctp); standard: ());
             subrange: (rangetype: stp; min,max: valu);
             pointer:  (eltype: stp);
             power:    (elset: stp);
             arrays:   (aeltype,inxtype: stp);
             records:  (fstfld: ctp; recvar: stp);
             files:    (filtype: stp);
             tagfld:   (tagfieldp: ctp; fstvar: stp);
             variant:  (nxtvar,subvar: stp; varval: valu)
           end;

                                (*names*)
                                (*******)

     idclass = (types,konst,vars,field,proc,func);
     setofids = set of idclass;
     idkind = (actual,formal);
     alpha = packed array [1..8] of char;

     identifier = packed record
           name: alpha; llink, rlink: ctp;
           idtype: stp; next: ctp;
           case klass: idclass of
             types: ();
             konst: (values: valu);
             vars:  (vkind: idkind; vlev: levrange; vaddr: addrrange);
             field: (fldaddr: addrrange);
             proc, func:  (case pfdeckind: declkind of
                  standard: (key: 1..15);
                  declared: (pflev: levrange; pfname: integer;
                      case pfkind: idkind of
                       actual: (forwdecl, extern: boolean);
                       formal: ()))
           end;


     disprange = 0..displimit;
     where = (blck,crec,vrec,rec);

                                (*expressions*)
                                (*************)
     attrkind = (cst,varbl,expr);
     vaccess = (drct,indrct,inxd);

     attr = record typtr: stp;
          case kind: attrkind of
        cst:   (cval: valu);
        varbl: (case access: vaccess of
              drct: (vlevel: levrange; dplmt: addrrange);
              indrct: (idplmt: addrrange))
          end;

     testp = ^ testpointer;
     testpointer = packed record
             elt1,elt2 : stp;
             lasttestp : testp
           end;

                                 (*labels*)
                                 (********)
     lbp = ^ labl;
     labl = record nextlab: lbp; defined: boolean;
           labval, labname: integer
        end;

     extfilep = ^filerec;
     filerec = record filename:alpha; nextfile:extfilep end;

(*-------------------------------------------------------------------------*)

var
(*    prr: text; (* comment this out when compiling with pcom *)
                    (*returned by source program scanner
                     insymbol:
                     **********)

    sy: symbol;             (*last symbol*)
    op: operator;           (*classification of last symbol*)
    val: valu;              (*value of last constant*)
    lgth: integer;          (*length of last string constant*)
    id: alpha;              (*last identifier (possibly truncated)*)
    kk: 1..8;               (*nr of chars in last identifier*)
    ch: char;               (*last character*)
    eol: boolean;           (*end of line flag*)


                    (*counters:*)
                    (***********)

    chcnt: integer;         (*character counter*)
    lc,ic: addrrange;           (*data location and instruction counter*)
    linecount: integer;


                    (*switches:*)
                    (***********)

    dp,                 (*declaration part*)
    prterr,             (*to allow forward references in pointer type
                      declaration by suppressing error message*)
    list,prcode,prtables: boolean;  (*output options for
                    -- source program listing
                    -- printing symbolic code
                    -- displaying ident and struct tables
                    --> procedure option*)
    debug: boolean;


                    (*pointers:*)
                    (***********)
    parmptr,
    intptr,realptr,charptr,
    boolptr,nilptr,textptr: stp;    (*pointers to entries of standard ids*)
    utypptr,ucstptr,uvarptr,
    ufldptr,uprcptr,ufctptr,    (*pointers to entries for undeclared ids*)
    fwptr: ctp;             (*head of chain of forw decl type ids*)
    fextfilep: extfilep;        (*head of chain of external files*)
    globtestp: testp;           (*last testpointer*)


                    (*bookkeeping of declaration levels:*)
                    (************************************)

    level: levrange;        (*current static level*)
    disx,               (*level of last id searched by searchid*)
    top: disprange;         (*top of display*)

    display:            (*where:   means:*)
      array [disprange] of
    packed record           (*=blck:   id is variable id*)
      fname: ctp; flabel: lbp;  (*=crec:   id is field id in record with*)
      case occur: where of      (*     constant address*)
        crec: (clev: levrange;  (*=vrec:   id is field id in record with*)
          cdspl: addrrange);(*     variable address*)
        vrec: (vdspl: addrrange)
      end;              (* --> procedure withstatement*)


                    (*error messages:*)
                    (*****************)

    errinx: 0..10;          (*nr of errors in current source line*)
    errlist:
      array [1..10] of
    packed record pos: integer;
              nmr: 1..400
           end;



                    (*expression compilation:*)
                    (*************************)

    gattr: attr;            (*describes the expr currently compiled*)


                    (*structured constants:*)
                    (***********************)

    constbegsys,simptypebegsys,typebegsys,blockbegsys,selectsys,facbegsys,
    statbegsys,typedels: setofsys;
    chartp : array[char] of chtp;
    rw:  array [1..35(*nr. of res. words*)] of alpha;
    frw: array [1..9] of 1..36(*nr. of res. words + 1*);
    rsy: array [1..35(*nr. of res. words*)] of symbol;
    ssy: array [char] of symbol;
    rop: array [1..35(*nr. of res. words*)] of operator;
    sop: array [char] of operator;
    na:  array [1..35] of alpha;
    mn:  array [0..60] of packed array [1..4] of char;
    sna: array [1..23] of packed array [1..4] of char;
    cdx: array [0..60] of -4..+4;
    pdx: array [1..23] of -7..+7;
    ordint: array [char] of integer;

    intlabel,mxint10,digmax: integer;
(*-------------------------------------------------------------------------*)
  procedure mark(var p: marktype); begin end;
  procedure release(p: marktype); begin end;

  procedure endofline;
    var lastpos,freepos,currpos,currnmr,f,k: integer;
  begin
    if errinx > 0 then   (*output error messages*)
      begin write(output,linecount:6,' ****  ':9);
    lastpos := 0; freepos := 1;
    for k := 1 to errinx do
      begin
        with errlist[k] do
          begin currpos := pos; currnmr := nmr end;
        if currpos = lastpos then write(output,',')
        else
          begin
        while freepos < currpos do
          begin write(output,' '); freepos := freepos + 1 end;
        write(output,'^');
        lastpos := currpos
          end;
        if currnmr < 10 then f := 1
        else if currnmr < 100 then f := 2
          else f := 3;
        write(output,currnmr:f);
        freepos := freepos + f + 1
      end;
    writeln(output); errinx := 0
      end;
    linecount := linecount + 1;
    if list and (not eof(input)) then
      begin write(output,linecount:6,'  ':2);
    if dp then write(output,lc:7) else write(output,ic:7);
    write(output,' ')
      end;
    chcnt := 0
  end  (*endofline*) ;

  procedure error(ferrnr: integer);
  begin
    if errinx >= 9 then
      begin errlist[10].nmr := 255; errinx := 10 end
    else
      begin errinx := errinx + 1;
    errlist[errinx].nmr := ferrnr
      end;
    errlist[errinx].pos := chcnt
  end (*error*) ;

  procedure insymbol;
    (*read next basic symbol of source program and return its
    description in the global variables sy, op, id, val and lgth*)
    label 1,2,3;
    var i,k: integer;
    digit: packed array [1..strglgth] of char;
    string: packed array [1..strglgth] of char;
    lvp: csp; test: boolean;

    procedure nextch;
    begin if eol then
      begin if list then writeln(output); endofline
      end;
      if not eof(input) then
       begin eol := eoln(input); read(input,ch);
    if list then write(output,ch);
    chcnt := chcnt + 1
       end
      else
    begin writeln(output,'   *** eof ','encountered');
      test := false
    end
    end;

    procedure options;
    begin
      repeat nextch;
    if ch <> '*' then
      begin
        if ch = 't' then
          begin nextch; prtables := ch = '+' end
        else
          if ch = 'l' then
        begin nextch; list := ch = '+';
          if not list then writeln(output)
        end
          else
         if ch = 'd' then
           begin nextch; debug := ch = '+' end
         else
        if ch = 'c' then
          begin nextch; prcode := ch = '+' end;
        nextch
      end
      until ch <> ','
    end (*options*) ;

  begin (*insymbol*)
  1:
    repeat while ((ch = ' ') or (ch = '    ')) and not eol do nextch;
      test := eol;
      if test then nextch
    until not test;
    if chartp[ch] = illegal then
      begin sy := othersy; op := noop;
    error(399); nextch
      end
    else
    case chartp[ch] of
      letter:
    begin k := 0;
      repeat
        if k < 8 then
         begin k := k + 1; id[k] := ch end ;
        nextch
      until chartp[ch] in [special,illegal,chstrquo,chcolon,
                chperiod,chlt,chgt,chlparen,chspace];
      if k >= kk then kk := k
      else
        repeat id[kk] := ' '; kk := kk - 1
        until kk = k;
      for i := frw[k] to frw[k+1] - 1 do
        if rw[i] = id then
          begin sy := rsy[i]; op := rop[i]; goto 2 end;
        sy := ident; op := noop;
  2:    end;
      number:
    begin op := noop; i := 0;
      repeat i := i+1; if i<= digmax then digit[i] := ch; nextch
      until chartp[ch] <> number;
      if ((ch = '.') and (input^ <> '.')) or (ch = 'e') then
        begin
          k := i;
          if ch = '.' then
            begin k := k+1; if k <= digmax then digit[k] := ch;
              nextch; (*if ch = '.' then begin ch := ':'; goto 3 end;*)
              if chartp[ch] <> number then error(201)
              else
            repeat k := k + 1;
              if k <= digmax then digit[k] := ch; nextch
            until chartp[ch] <>  number
            end;
          if ch = 'e' then
            begin k := k+1; if k <= digmax then digit[k] := ch;
              nextch;
              if (ch = '+') or (ch ='-') then
            begin k := k+1; if k <= digmax then digit[k] := ch;
              nextch
            end;
              if chartp[ch] <> number then error(201)
              else
            repeat k := k+1;
              if k <= digmax then digit[k] := ch; nextch
            until chartp[ch] <> number
             end;
           new(lvp,reel); sy:= realconst; lvp^.cclass := reel;
           with lvp^ do
             begin for i := 1 to strglgth do rval[i] := ' ';
               if k <= digmax then
             for i := 2 to k + 1 do rval[i] := digit[i-1]
               else begin error(203); rval[2] := '0';
                  rval[3] := '.'; rval[4] := '0'
                end
             end;
           val.valp := lvp
        end
      else
  3:    begin
          if i > digmax then begin error(203); val.ival := 0 end
          else
        with val do
          begin ival := 0;
            for k := 1 to i do
              begin
            if ival <= mxint10 then
              ival := ival*10+ordint[digit[k]]
            else begin error(203); ival := 0 end
              end;
            sy := intconst
          end
        end
    end;
      chstrquo:
    begin lgth := 0; sy := stringconst;  op := noop;
      repeat
        repeat nextch; lgth := lgth + 1;
           if lgth <= strglgth then string[lgth] := ch
        until (eol) or (ch = '''');
        if eol then error(202) else nextch
      until ch <> '''';
      lgth := lgth - 1;   (*now lgth = nr of chars in string*)
      if lgth = 0 then error(205) else
      if lgth = 1 then val.ival := ord(string[1])
      else
        begin new(lvp,strg); lvp^.cclass:=strg;
          if lgth > strglgth then
        begin error(399); lgth := strglgth end;
          with lvp^ do
        begin slgth := lgth;
          for i := 1 to lgth do sval[i] := string[i]
        end;
          val.valp := lvp
        end
    end;
      chcolon:
    begin op := noop; nextch;
      if ch = '=' then
        begin sy := becomes; nextch end
      else sy := colon
    end;
      chperiod:
    begin op := noop; nextch;
      if ch = '.' then
        begin sy := colon; nextch end
      else sy := period
    end;
      chlt:
    begin nextch; sy := relop;
      if ch = '=' then
        begin op := leop; nextch end
      else
        if ch = '>' then
          begin op := neop; nextch end
        else op := ltop
    end;
      chgt:
    begin nextch; sy := relop;
      if ch = '=' then
        begin op := geop; nextch end
      else op := gtop
    end;
      chlparen:
       begin nextch;
     if ch = '*' then
       begin nextch;
         if ch = '$' then options;
         repeat
           while (ch <> '*') and not eof(input) do nextch;
           nextch
         until (ch = ')') or eof(input);
         nextch; goto 1
       end;
     sy := lparent; op := noop
       end;
      special:
    begin sy := ssy[ch]; op := sop[ch];
      nextch
    end;
      chspace: sy := othersy
    end (*case*)
  end (*insymbol*) ;

  procedure enterid(fcp: ctp);
    (*enter id pointed at by fcp into the name-table,
     which on each declaration level is organised as
     an unbalanced binary tree*)
    var nam: alpha; lcp, lcp1: ctp; lleft: boolean;
  begin nam := fcp^.name;
    lcp := display[top].fname;
    if lcp = nil then
      display[top].fname := fcp
    else
      begin
    repeat lcp1 := lcp;
      if lcp^.name = nam then   (*name conflict, follow right link*)
        begin error(101); lcp := lcp^.rlink; lleft := false end
      else
        if lcp^.name < nam then
          begin lcp := lcp^.rlink; lleft := false end
        else begin lcp := lcp^.llink; lleft := true end
    until lcp = nil;
    if lleft then lcp1^.llink := fcp else lcp1^.rlink := fcp
      end;
    fcp^.llink := nil; fcp^.rlink := nil
  end (*enterid*) ;

  procedure searchsection(fcp: ctp; var fcp1: ctp);
    (*to find record fields and forward declared procedure id's
     --> procedure proceduredeclaration
     --> procedure selector*)
     label 1;
  begin
    while fcp <> nil do
      if fcp^.name = id then goto 1
      else if fcp^.name < id then fcp := fcp^.rlink
    else fcp := fcp^.llink;
1:  fcp1 := fcp
  end (*searchsection*) ;

  procedure searchid(fidcls: setofids; var fcp: ctp);
    label 1;
    var lcp: ctp;
  begin
    for disx := top downto 0 do
      begin lcp := display[disx].fname;
    while lcp <> nil do
      if lcp^.name = id then
        if lcp^.klass in fidcls then goto 1
        else
          begin if prterr then error(103);
        lcp := lcp^.rlink
          end
      else
        if lcp^.name < id then
          lcp := lcp^.rlink
        else lcp := lcp^.llink
      end;
    (*search not successful; suppress error message in case
     of forward referenced type id in pointer type definition
     --> procedure simpletype*)
    if prterr then
      begin error(104);
    (*to avoid returning nil, reference an entry
     for an undeclared id of appropriate class
     --> procedure enterundecl*)
    if types in fidcls then lcp := utypptr
    else
      if vars in fidcls then lcp := uvarptr
      else
        if field in fidcls then lcp := ufldptr
        else
          if konst in fidcls then lcp := ucstptr
          else
        if proc in fidcls then lcp := uprcptr
        else lcp := ufctptr;
      end;
1:  fcp := lcp
  end (*searchid*) ;

  procedure getbounds(fsp: stp; var fmin,fmax: integer);
    (*get internal bounds of subrange or scalar type*)
    (*assume fsp<>intptr and fsp<>realptr*)
  begin
    fmin := 0; fmax := 0;
    if fsp <> nil then
    with fsp^ do
      if form = subrange then
    begin fmin := min.ival; fmax := max.ival end
      else
      if fsp = charptr then
        begin fmin := ordminchar; fmax := ordmaxchar
        end
      else
        if fconst <> nil then
          fmax := fconst^.values.ival
  end (*getbounds*) ;

  function alignquot(fsp: stp): integer;
  begin
    alignquot := 1;
    if fsp <> nil then
      with fsp^ do
    case form of
      scalar:   if fsp=intptr then alignquot := intal
            else if fsp=boolptr then alignquot := boolal
            else if scalkind=declared then alignquot := intal
            else if fsp=charptr then alignquot := charal
            else if fsp=realptr then alignquot := realal
            else (*parmptr*) alignquot := parmal;
      subrange: alignquot := alignquot(rangetype);
      pointer:  alignquot := adral;
      power:    alignquot := setal;
      files:    alignquot := fileal;
      arrays:   alignquot := alignquot(aeltype);
      records:  alignquot := recal;
      variant,tagfld: error(501)
    end
  end (*alignquot*);

  procedure align(fsp: stp; var flc: addrrange);
    var k,l: integer;
  begin
    k := alignquot(fsp);
    l := flc-1;
    flc := l + k  -  (k+l) mod k
  end (*align*);

  procedure printtables(fb: boolean);
    (*print data structure and name table*)
    var i, lim: disprange;

    procedure marker;
      (*mark data structure entries to avoid multiple printout*)
      var i: integer;

      procedure markctp(fp: ctp); forward;

      procedure markstp(fp: stp);
    (*mark data structures, prevent cycles*)
      begin
    if fp <> nil then
      with fp^ do
        begin marked := true;
          case form of
          scalar:   ;
          subrange: markstp(rangetype);
          pointer:  (*don't mark eltype: cycle possible; will be marked
            anyway, if fp = true*) ;
          power:    markstp(elset) ;
          arrays:   begin markstp(aeltype); markstp(inxtype) end;
          records:  begin markctp(fstfld); markstp(recvar) end;
          files:    markstp(filtype);
          tagfld:   markstp(fstvar);
          variant:  begin markstp(nxtvar); markstp(subvar) end
          end (*case*)
        end (*with*)
      end (*markstp*);

      procedure markctp;
      begin
    if fp <> nil then
      with fp^ do
        begin markctp(llink); markctp(rlink);
          markstp(idtype)
        end
      end (*markctp*);

    begin (*marker*)
      for i := top downto lim do
    markctp(display[i].fname)
    end (*marker*);

    procedure followctp(fp: ctp); forward;

    procedure followstp(fp: stp);
    begin
      if fp <> nil then
    with fp^ do
      if marked then
        begin marked := false; write(output,' ':4,ord(fp):6,size:10);
          case form of
          scalar:   begin write(output,'scalar':10);
              if scalkind = standard then
                write(output,'standard':10)
              else write(output,'declared':10,' ':4,ord(fconst):6);
              writeln(output)
            end;
          subrange: begin
              write(output,'subrange':10,' ':4,ord(rangetype):6);
              if rangetype <> realptr then
                write(output,min.ival,max.ival)
              else
                if (min.valp <> nil) and (max.valp <> nil) then
                  write(output,' ',min.valp^.rval:9,
                    ' ',max.valp^.rval:9);
              writeln(output); followstp(rangetype);
            end;
          pointer:  writeln(output,'pointer':10,' ':4,ord(eltype):6);
          power:    begin writeln(output,'set':10,' ':4,ord(elset):6);
              followstp(elset)
            end;
          arrays:   begin
              writeln(output,'array':10,' ':4,ord(aeltype):6,' ':4,
                ord(inxtype):6);
              followstp(aeltype); followstp(inxtype)
            end;
          records:  begin
              writeln(output,'record':10,' ':4,ord(fstfld):6,' ':4,
                ord(recvar):6); followctp(fstfld);
              followstp(recvar)
            end;
          files:    begin write(output,'file':10,' ':4,ord(filtype):6);
              followstp(filtype)
            end;
          tagfld:   begin writeln(output,'tagfld':10,' ':4,ord(tagfieldp):6,
                ' ':4,ord(fstvar):6);
              followstp(fstvar)
            end;
          variant:  begin writeln(output,'variant':10,' ':4,ord(nxtvar):6,
                ' ':4,ord(subvar):6,varval.ival);
              followstp(nxtvar); followstp(subvar)
            end
          end (*case*)
        end (*if marked*)
    end (*followstp*);

    procedure followctp;
      var i: integer;
    begin
      if fp <> nil then
    with fp^ do
      begin write(output,' ':4,ord(fp):6,' ',name:9,' ':4,ord(llink):6,
        ' ':4,ord(rlink):6,' ':4,ord(idtype):6);
        case klass of
          types: write(output,'type':10);
          konst: begin write(output,'constant':10,' ':4,ord(next):6);
               if idtype <> nil then
             if idtype = realptr then
               begin
                 if values.valp <> nil then
                   write(output,' ',values.valp^.rval:9)
               end
             else
               if idtype^.form = arrays then  (*stringconst*)
                 begin
                   if values.valp <> nil then
                 begin write(output,' ');
                   with values.valp^ do
                     for i := 1 to slgth do
                       write(output,sval[i])
                 end
                 end
               else write(output,values.ival)
             end;
          vars:  begin write(output,'variable':10);
               if vkind = actual then write(output,'actual':10)
               else write(output,'formal':10);
               write(output,' ':4,ord(next):6,vlev,' ':4,vaddr:6 );
             end;
          field: write(output,'field':10,' ':4,ord(next):6,' ':4,fldaddr:6);
          proc,
          func:  begin
               if klass = proc then write(output,'procedure':10)
               else write(output,'function':10);
               if pfdeckind = standard then
             write(output,'standard':10, key:10)
               else
             begin write(output,'declared':10,' ':4,ord(next):6);
               write(output,pflev,' ':4,pfname:6);
               if pfkind = actual then
                 begin write(output,'actual':10);
                   if forwdecl then write(output,'forward':10)
                   else write(output,'notforward':10);
                   if extern then write(output,'extern':10)
                   else write(output,'not extern':10);
                 end
               else write(output,'formal':10)
             end
             end
        end (*case*);
        writeln(output);
        followctp(llink); followctp(rlink);
        followstp(idtype)
      end (*with*)
    end (*followctp*);

  begin (*printtables*)
    writeln(output); writeln(output); writeln(output);
    if fb then lim := 0
    else begin lim := top; write(output,' local') end;
    writeln(output,' tables '); writeln(output);
    marker;
    for i := top downto lim do
      followctp(display[i].fname);
    writeln(output);
    if not eol then write(output,' ':chcnt+16)
  end (*printtables*);

  procedure genlabel(var nxtlab: integer);
  begin intlabel := intlabel + 1;
    nxtlab := intlabel
  end (*genlabel*);

  procedure block(fsys: setofsys; fsy: symbol; fprocp: ctp);
    var lsy: symbol; test: boolean;

    procedure skip(fsys: setofsys);
      (*skip input string until relevant symbol found*)
    begin
      if not eof(input) then
    begin while not(sy in fsys) and (not eof(input)) do insymbol;
      if not (sy in fsys) then insymbol
    end
    end (*skip*) ;

    procedure constant(fsys: setofsys; var fsp: stp; var fvalu: valu);
      var lsp: stp; lcp: ctp; sign: (none,pos,neg);
      lvp: csp; i: 2..strglgth;
    begin lsp := nil; fvalu.ival := 0;
      if not(sy in constbegsys) then
    begin error(50); skip(fsys+constbegsys) end;
      if sy in constbegsys then
    begin
      if sy = stringconst then
        begin
          if lgth = 1 then lsp := charptr
          else
        begin
          new(lsp,arrays);
          with lsp^ do
            begin aeltype := charptr; inxtype := nil;
               size := lgth*charsize; form := arrays
            end
        end;
          fvalu := val; insymbol
        end
      else
        begin
          sign := none;
          if (sy = addop) and (op in [plus,minus]) then
        begin if op = plus then sign := pos else sign := neg;
          insymbol
        end;
          if sy = ident then
        begin searchid([konst],lcp);
          with lcp^ do
            begin lsp := idtype; fvalu := values end;
          if sign <> none then
            if lsp = intptr then
              begin if sign = neg then fvalu.ival := -fvalu.ival end
            else
              if lsp = realptr then
            begin
              if sign = neg then
                begin new(lvp,reel);
                  if fvalu.valp^.rval[1] = '-' then
                lvp^.rval[1] := '+'
                  else lvp^.rval[1] := '-';
                  for i := 2 to strglgth do
                lvp^.rval[i] := fvalu.valp^.rval[i];
                  fvalu.valp := lvp;
                end
              end
            else error(105);
          insymbol;
        end
          else
        if sy = intconst then
          begin if sign = neg then val.ival := -val.ival;
            lsp := intptr; fvalu := val; insymbol
          end
        else
          if sy = realconst then
            begin if sign = neg then val.valp^.rval[1] := '-';
              lsp := realptr; fvalu := val; insymbol
            end
          else
            begin error(106); skip(fsys) end
        end;
      if not (sy in fsys) then
        begin error(6); skip(fsys) end
      end;
      fsp := lsp
    end (*constant*) ;

    function equalbounds(fsp1,fsp2: stp): boolean;
      var lmin1,lmin2,lmax1,lmax2: integer;
    begin
      if (fsp1=nil) or (fsp2=nil) then equalbounds := true
      else
    begin
      getbounds(fsp1,lmin1,lmax1);
      getbounds(fsp2,lmin2,lmax2);
      equalbounds := (lmin1=lmin2) and (lmax1=lmax2)
    end
    end (*equalbounds*) ;

    function comptypes(fsp1,fsp2: stp) : boolean;
      (*decide whether structures pointed at by fsp1 and fsp2 are compatible*)
      var nxt1,nxt2: ctp; comp: boolean;
    ltestp1,ltestp2 : testp;
    begin
      if fsp1 = fsp2 then comptypes := true
      else
    if (fsp1 <> nil) and (fsp2 <> nil) then
      if fsp1^.form = fsp2^.form then
        case fsp1^.form of
          scalar:
        comptypes := false;
        (* identical scalars declared on different levels are
         not recognized to be compatible*)
          subrange:
        comptypes := comptypes(fsp1^.rangetype,fsp2^.rangetype);
          pointer:
          begin
            comp := false; ltestp1 := globtestp;
            ltestp2 := globtestp;
            while ltestp1 <> nil do
              with ltestp1^ do
            begin
              if (elt1 = fsp1^.eltype) and
                 (elt2 = fsp2^.eltype) then comp := true;
              ltestp1 := lasttestp
            end;
            if not comp then
              begin new(ltestp1);
            with ltestp1^ do
              begin elt1 := fsp1^.eltype;
                elt2 := fsp2^.eltype;
                lasttestp := globtestp
              end;
            globtestp := ltestp1;
            comp := comptypes(fsp1^.eltype,fsp2^.eltype)
              end;
            comptypes := comp; globtestp := ltestp2
          end;
          power:
        comptypes := comptypes(fsp1^.elset,fsp2^.elset);
          arrays:
        begin
          comp := comptypes(fsp1^.aeltype,fsp2^.aeltype)
              and comptypes(fsp1^.inxtype,fsp2^.inxtype);
          comptypes := comp and (fsp1^.size = fsp2^.size) and
              equalbounds(fsp1^.inxtype,fsp2^.inxtype)
        end;
          records:
        begin nxt1 := fsp1^.fstfld; nxt2 := fsp2^.fstfld; comp:=true;
          while (nxt1 <> nil) and (nxt2 <> nil) do
            begin comp:=comp and comptypes(nxt1^.idtype,nxt2^.idtype);
              nxt1 := nxt1^.next; nxt2 := nxt2^.next
            end;
          comptypes := comp and (nxt1 = nil) and (nxt2 = nil)
                  and(fsp1^.recvar = nil)and(fsp2^.recvar = nil)
        end;
        (*identical records are recognized to be compatible
         iff no variants occur*)
          files:
        comptypes := comptypes(fsp1^.filtype,fsp2^.filtype)
        end (*case*)
      else (*fsp1^.form <> fsp2^.form*)
        if fsp1^.form = subrange then
          comptypes := comptypes(fsp1^.rangetype,fsp2)
        else
          if fsp2^.form = subrange then
        comptypes := comptypes(fsp1,fsp2^.rangetype)
          else comptypes := false
    else comptypes := true
    end (*comptypes*) ;

    function string(fsp: stp) : boolean;
    begin string := false;
      if fsp <> nil then
    if fsp^.form = arrays then
      if comptypes(fsp^.aeltype,charptr) then string := true
    end (*string*) ;

    procedure typ(fsys: setofsys; var fsp: stp; var fsize: addrrange);
      var lsp,lsp1,lsp2: stp; oldtop: disprange; lcp: ctp;
      lsize,displ: addrrange; lmin,lmax: integer;

      procedure simpletype(fsys:setofsys; var fsp:stp; var fsize:addrrange);
    var lsp,lsp1: stp; lcp,lcp1: ctp; ttop: disprange;
        lcnt: integer; lvalu: valu;
      begin fsize := 1;
    if not (sy in simptypebegsys) then
      begin error(1); skip(fsys + simptypebegsys) end;
    if sy in simptypebegsys then
      begin
        if sy = lparent then
          begin ttop := top;   (*decl. consts local to innermost block*)
        while display[top].occur <> blck do top := top - 1;
        new(lsp,scalar,declared);
        with lsp^ do
          begin size := intsize; form := scalar;
            scalkind := declared
          end;
        lcp1 := nil; lcnt := 0;
        repeat insymbol;
          if sy = ident then
            begin new(lcp,konst);
              with lcp^ do
            begin name := id; idtype := lsp; next := lcp1;
              values.ival := lcnt; klass := konst
            end;
              enterid(lcp);
              lcnt := lcnt + 1;
              lcp1 := lcp; insymbol
            end
          else error(2);
          if not (sy in fsys + [comma,rparent]) then
            begin error(6); skip(fsys + [comma,rparent]) end
        until sy <> comma;
        lsp^.fconst := lcp1; top := ttop;
        if sy = rparent then insymbol else error(4)
          end
        else
          begin
        if sy = ident then
          begin searchid([types,konst],lcp);
            insymbol;
            if lcp^.klass = konst then
              begin new(lsp,subrange);
            with lsp^, lcp^ do
              begin rangetype := idtype; form := subrange;
                if string(rangetype) then
                  begin error(148); rangetype := nil end;
                min := values; size := intsize
              end;
            if sy = colon then insymbol else error(5);
            constant(fsys,lsp1,lvalu);
            lsp^.max := lvalu;
            if lsp^.rangetype <> lsp1 then error(107)
              end
            else
              begin lsp := lcp^.idtype;
            if lsp <> nil then fsize := lsp^.size
              end
          end (*sy = ident*)
        else
          begin new(lsp,subrange); lsp^.form := subrange;
            constant(fsys + [colon],lsp1,lvalu);
            if string(lsp1) then
              begin error(148); lsp1 := nil end;
            with lsp^ do
              begin rangetype:=lsp1; min:=lvalu; size:=intsize end;
            if sy = colon then insymbol else error(5);
            constant(fsys,lsp1,lvalu);
            lsp^.max := lvalu;
            if lsp^.rangetype <> lsp1 then error(107)
          end;
        if lsp <> nil then
          with lsp^ do
            if form = subrange then
              if rangetype <> nil then
            if rangetype = realptr then error(399)
            else
              if min.ival > max.ival then error(102)
          end;
        fsp := lsp;
        if not (sy in fsys) then
          begin error(6); skip(fsys) end
      end
        else fsp := nil
      end (*simpletype*) ;

      procedure fieldlist(fsys: setofsys; var frecvar: stp);
    var lcp,lcp1,nxt,nxt1: ctp; lsp,lsp1,lsp2,lsp3,lsp4: stp;
        minsize,maxsize,lsize: addrrange; lvalu: valu;
      begin nxt1 := nil; lsp := nil;
    if not (sy in (fsys+[ident,casesy])) then
      begin error(19); skip(fsys + [ident,casesy]) end;
    while sy = ident do
      begin nxt := nxt1;
        repeat
          if sy = ident then
        begin new(lcp,field);
          with lcp^ do
            begin name := id; idtype := nil; next := nxt;
              klass := field
            end;
          nxt := lcp;
          enterid(lcp);
          insymbol
        end
          else error(2);
          if not (sy in [comma,colon]) then
        begin error(6); skip(fsys + [comma,colon,semicolon,casesy])
        end;
          test := sy <> comma;
          if not test  then insymbol
        until test;
        if sy = colon then insymbol else error(5);
        typ(fsys + [casesy,semicolon],lsp,lsize);
        while nxt <> nxt1 do
          with nxt^ do
        begin align(lsp,displ);
          idtype := lsp; fldaddr := displ;
          nxt := next; displ := displ + lsize
        end;
        nxt1 := lcp;
        while sy = semicolon do
          begin insymbol;
        if not (sy in fsys + [ident,casesy,semicolon]) then
          begin error(19); skip(fsys + [ident,casesy]) end
          end
      end (*while*);
    nxt := nil;
    while nxt1 <> nil do
      with nxt1^ do
        begin lcp := next; next := nxt; nxt := nxt1; nxt1 := lcp end;
    if sy = casesy then
      begin new(lsp,tagfld);
        with lsp^ do
          begin tagfieldp := nil; fstvar := nil; form:=tagfld end;
        frecvar := lsp;
        insymbol;
        if sy = ident then
          begin new(lcp,field);
        with lcp^ do
          begin name := id; idtype := nil; klass:=field;
            next := nil; fldaddr := displ
          end;
        enterid(lcp);
        insymbol;
        if sy = colon then insymbol else error(5);
        if sy = ident then
          begin searchid([types],lcp1);
            lsp1 := lcp1^.idtype;
            if lsp1 <> nil then
              begin align(lsp1,displ);
            lcp^.fldaddr := displ;
            displ := displ+lsp1^.size;
            if (lsp1^.form <= subrange) or string(lsp1) then
              begin if comptypes(realptr,lsp1) then error(109)
                else if string(lsp1) then error(399);
                lcp^.idtype := lsp1; lsp^.tagfieldp := lcp;
              end
            else error(110);
              end;
            insymbol;
          end
        else begin error(2); skip(fsys + [ofsy,lparent]) end
          end
        else begin error(2); skip(fsys + [ofsy,lparent]) end;
        lsp^.size := displ;
        if sy = ofsy then insymbol else error(8);
        lsp1 := nil; minsize := displ; maxsize := displ;
        repeat lsp2 := nil;
          if not (sy in fsys + [semicolon]) then
          begin
        repeat constant(fsys + [comma,colon,lparent],lsp3,lvalu);
          if lsp^.tagfieldp <> nil then
           if not comptypes(lsp^.tagfieldp^.idtype,lsp3)then error(111);
          new(lsp3,variant);
          with lsp3^ do
            begin nxtvar := lsp1; subvar := lsp2; varval := lvalu;
              form := variant
            end;
          lsp4 := lsp1;
          while lsp4 <> nil do
            with lsp4^ do
              begin
            if varval.ival = lvalu.ival then error(178);
            lsp4 := nxtvar
              end;
          lsp1 := lsp3; lsp2 := lsp3;
          test := sy <> comma;
          if not test then insymbol
        until test;
        if sy = colon then insymbol else error(5);
        if sy = lparent then insymbol else error(9);
        fieldlist(fsys + [rparent,semicolon],lsp2);
        if displ > maxsize then maxsize := displ;
        while lsp3 <> nil do
          begin lsp4 := lsp3^.subvar; lsp3^.subvar := lsp2;
            lsp3^.size := displ;
            lsp3 := lsp4
          end;
        if sy = rparent then
          begin insymbol;
            if not (sy in fsys + [semicolon]) then
              begin error(6); skip(fsys + [semicolon]) end
          end
        else error(4);
          end;
          test := sy <> semicolon;
          if not test then
        begin displ := minsize;
              insymbol
        end
        until test;
        displ := maxsize;
        lsp^.fstvar := lsp1;
      end
    else frecvar := nil
      end (*fieldlist*) ;

    begin (*typ*)
      if not (sy in typebegsys) then
     begin error(10); skip(fsys + typebegsys) end;
      if sy in typebegsys then
    begin
      if sy in simptypebegsys then simpletype(fsys,fsp,fsize)
      else
    (*^*)     if sy = arrow then
          begin new(lsp,pointer); fsp := lsp;
        with lsp^ do
          begin eltype := nil; size := ptrsize; form:=pointer end;
        insymbol;
        if sy = ident then
          begin prterr := false; (*no error if search not successful*)
            searchid([types],lcp); prterr := true;
            if lcp = nil then   (*forward referenced type id*)
              begin new(lcp,types);
            with lcp^ do
              begin name := id; idtype := lsp;
                next := fwptr; klass := types
              end;
            fwptr := lcp
              end
            else
              begin
            if lcp^.idtype <> nil then
              if lcp^.idtype^.form = files then error(108)
              else lsp^.eltype := lcp^.idtype
              end;
            insymbol;
          end
        else error(2);
          end
        else
          begin
        if sy = packedsy then
          begin insymbol;
            if not (sy in typedels) then
              begin
            error(10); skip(fsys + typedels)
              end
          end;
    (*array*)     if sy = arraysy then
          begin insymbol;
            if sy = lbrack then insymbol else error(11);
            lsp1 := nil;
            repeat new(lsp,arrays);
              with lsp^ do
            begin aeltype := lsp1; inxtype := nil; form:=arrays end;
              lsp1 := lsp;
              simpletype(fsys + [comma,rbrack,ofsy],lsp2,lsize);
              lsp1^.size := lsize;
              if lsp2 <> nil then
            if lsp2^.form <= subrange then
              begin
                if lsp2 = realptr then
                  begin error(109); lsp2 := nil end
                else
                  if lsp2 = intptr then
                begin error(149); lsp2 := nil end;
                lsp^.inxtype := lsp2
              end
            else begin error(113); lsp2 := nil end;
              test := sy <> comma;
              if not test then insymbol
            until test;
            if sy = rbrack then insymbol else error(12);
            if sy = ofsy then insymbol else error(8);
            typ(fsys,lsp,lsize);
            repeat
              with lsp1^ do
            begin lsp2 := aeltype; aeltype := lsp;
              if inxtype <> nil then
                begin getbounds(inxtype,lmin,lmax);
                  align(lsp,lsize);
                  lsize := lsize*(lmax - lmin + 1);
                  size := lsize
                end
            end;
              lsp := lsp1; lsp1 := lsp2
            until lsp1 = nil
          end
        else
    (*record*)      if sy = recordsy then
            begin insymbol;
              oldtop := top;
              if top < displimit then
            begin top := top + 1;
              with display[top] do
                begin fname := nil;
                  flabel := nil;
                  occur := rec
                end
            end
              else error(250);
              displ := 0;
              fieldlist(fsys-[semicolon]+[endsy],lsp1);
              new(lsp,records);
              with lsp^ do
            begin fstfld := display[top].fname;
              recvar := lsp1; size := displ; form := records
            end;
              top := oldtop;
              if sy = endsy then insymbol else error(13)
            end
          else
    (*set*)       if sy = setsy then
              begin insymbol;
            if sy = ofsy then insymbol else error(8);
            simpletype(fsys,lsp1,lsize);
            if lsp1 <> nil then
              if lsp1^.form > subrange then
                begin error(115); lsp1 := nil end
              else
                if lsp1 = realptr then
                  begin error(114); lsp1 := nil end
                else if lsp1 = intptr then
                  begin error(169); lsp1 := nil end
                else
                  begin getbounds(lsp1,lmin,lmax);
                if (lmin < setlow) or (lmax > sethigh)
                  then error(169);
                  end;
            new(lsp,power);
            with lsp^ do
              begin elset:=lsp1; size:=setsize; form:=power end;
              end
            else
    (*file*)        if sy = filesy then
              begin insymbol;
                error(399); skip(fsys); lsp := nil
              end;
        fsp := lsp
          end;
      if not (sy in fsys) then
        begin error(6); skip(fsys) end
    end
      else fsp := nil;
      if fsp = nil then fsize := 1 else fsize := fsp^.size
    end (*typ*) ;

    procedure labeldeclaration;
      var llp: lbp; redef: boolean; lbname: integer;
    begin
      repeat
    if sy = intconst then
      with display[top] do
        begin llp := flabel; redef := false;
          while (llp <> nil) and not redef do
        if llp^.labval <> val.ival then
          llp := llp^.nextlab
        else begin redef := true; error(166) end;
          if not redef then
        begin new(llp);
          with llp^ do
            begin labval := val.ival; genlabel(lbname);
              defined := false; nextlab := flabel; labname := lbname
            end;
          flabel := llp
        end;
          insymbol
        end
    else error(15);
    if not ( sy in fsys + [comma, semicolon] ) then
      begin error(6); skip(fsys+[comma,semicolon]) end;
    test := sy <> comma;
    if not test then insymbol
      until test;
      if sy = semicolon then insymbol else error(14)
    end (* labeldeclaration *) ;

    procedure constdeclaration;
      var lcp: ctp; lsp: stp; lvalu: valu;
    begin
      if sy <> ident then
    begin error(2); skip(fsys + [ident]) end;
      while sy = ident do
    begin new(lcp,konst);
      with lcp^ do
        begin name := id; idtype := nil; next := nil; klass:=konst end;
      insymbol;
      if (sy = relop) and (op = eqop) then insymbol else error(16);
      constant(fsys + [semicolon],lsp,lvalu);
      enterid(lcp);
      lcp^.idtype := lsp; lcp^.values := lvalu;
      if sy = semicolon then
        begin insymbol;
          if not (sy in fsys + [ident]) then
        begin error(6); skip(fsys + [ident]) end
        end
      else error(14)
    end
    end (*constdeclaration*) ;

    procedure typedeclaration;
      var lcp,lcp1,lcp2: ctp; lsp: stp; lsize: addrrange;
    begin
      if sy <> ident then
    begin error(2); skip(fsys + [ident]) end;
      while sy = ident do
    begin new(lcp,types);
      with lcp^ do
        begin name := id; idtype := nil; klass := types end;
      insymbol;
      if (sy = relop) and (op = eqop) then insymbol else error(16);
      typ(fsys + [semicolon],lsp,lsize);
      enterid(lcp);
      lcp^.idtype := lsp;
      (*has any forward reference been satisfied:*)
      lcp1 := fwptr;
      while lcp1 <> nil do
        begin
          if lcp1^.name = lcp^.name then
        begin lcp1^.idtype^.eltype := lcp^.idtype;
          if lcp1 <> fwptr then
            lcp2^.next := lcp1^.next
          else fwptr := lcp1^.next;
        end
          else lcp2 := lcp1;
          lcp1 := lcp1^.next
        end;
      if sy = semicolon then
        begin insymbol;
          if not (sy in fsys + [ident]) then
        begin error(6); skip(fsys + [ident]) end
        end
      else error(14)
    end;
      if fwptr <> nil then
    begin error(117); writeln(output);
      repeat writeln(output,' type-id ',fwptr^.name);
        fwptr := fwptr^.next
      until fwptr = nil;
      if not eol then write(output,' ': chcnt+16)
    end
    end (*typedeclaration*) ;

    procedure vardeclaration;
      var lcp,nxt: ctp; lsp: stp; lsize: addrrange;
    begin nxt := nil;
      repeat
    repeat
      if sy = ident then
        begin new(lcp,vars);
          with lcp^ do
           begin name := id; next := nxt; klass := vars;
          idtype := nil; vkind := actual; vlev := level
        end;
          enterid(lcp);
          nxt := lcp;
          insymbol;
        end
      else error(2);
      if not (sy in fsys + [comma,colon] + typedels) then
        begin error(6); skip(fsys+[comma,colon,semicolon]+typedels) end;
      test := sy <> comma;
      if not test then insymbol
    until test;
    if sy = colon then insymbol else error(5);
    typ(fsys + [semicolon] + typedels,lsp,lsize);
    while nxt <> nil do
      with  nxt^ do
        begin align(lsp,lc);
          idtype := lsp; vaddr := lc;
          lc := lc + lsize; nxt := next
        end;
    if sy = semicolon then
      begin insymbol;
        if not (sy in fsys + [ident]) then
          begin error(6); skip(fsys + [ident]) end
      end
    else error(14)
      until (sy <> ident) and not (sy in typedels);
      if fwptr <> nil then
    begin error(117); writeln(output);
      repeat writeln(output,' type-id ',fwptr^.name);
        fwptr := fwptr^.next
      until fwptr = nil;
      if not eol then write(output,' ': chcnt+16)
    end
    end (*vardeclaration*) ;

    procedure procdeclaration(fsy: symbol);
      var oldlev: 0..maxlevel; lcp,lcp1: ctp; lsp: stp;
      forw: boolean; oldtop: disprange;
      llc,lcm: addrrange; lbname: integer; markp: marktype;

      procedure parameterlist(fsy: setofsys; var fpar: ctp);
    var lcp,lcp1,lcp2,lcp3: ctp; lsp: stp; lkind: idkind;
      llc,lsize: addrrange; count: integer;
      begin lcp1 := nil;
    if not (sy in fsy + [lparent]) then
      begin error(7); skip(fsys + fsy + [lparent]) end;
    if sy = lparent then
      begin if forw then error(119);
        insymbol;
        if not (sy in [ident,varsy,procsy,funcsy]) then
          begin error(7); skip(fsys + [ident,rparent]) end;
        while sy in [ident,varsy,procsy,funcsy] do
          begin
        if sy = procsy then
          begin error(399);
            repeat insymbol;
              if sy = ident then
            begin new(lcp,proc,declared,formal);
              with lcp^ do
                begin name := id; idtype := nil; next := lcp1;
                  pflev := level (*beware of parameter procedures*);
                  klass:=proc;pfdeckind:=declared;pfkind:=formal
                end;
              enterid(lcp);
              lcp1 := lcp;
              align(parmptr,lc);
              (*lc := lc + some size *)
              insymbol
            end
              else error(2);
              if not (sy in fsys + [comma,semicolon,rparent]) then
            begin error(7);skip(fsys+[comma,semicolon,rparent])end
            until sy <> comma
          end
        else
          begin
            if sy = funcsy then
              begin error(399); lcp2 := nil;
            repeat insymbol;
              if sy = ident then
                begin new(lcp,func,declared,formal);
                  with lcp^ do
                begin name := id; idtype := nil; next := lcp2;
                  pflev := level (*beware param funcs*);
                  klass:=func;pfdeckind:=declared;
                  pfkind:=formal
                end;
                  enterid(lcp);
                 lcp2 := lcp;
                 align(parmptr,lc);
                 (*lc := lc + some size*)
                  insymbol;
                end;
              if not (sy in [comma,colon] + fsys) then
                begin error(7);skip(fsys+[comma,semicolon,rparent])