automat.pas

This is Pascal compiler

     1  (*$c+,t-,d-,l-*)
     2   (***********************************************
     3    *                                             *
     4    *      Portable Pascal compiler               *
     5    *      ************************               *
     6    *                                             *
     7    *             Pascal P4                       *
     8    *                                             *
     9    *     Authors:                                *
    10    *           Urs Ammann                        *
    11    *           Kesav Nori                        *
    12    *           Christian Jacobi                  *
    13    *     Address:                                *
    14    *       Institut Fuer Informatik              *
    15    *       Eidg. Technische Hochschule           *
    16    *       CH-8096 Zuerich                       *
    17    *                                             *
    18    *  This code is fully documented in the book  *
    19    *        "Pascal Implementation"              *
    20    *   by Steven Pemberton and Martin Daniels    *
    21    * published by Ellis Horwood, Chichester, UK  *
    22    *         ISBN: 0-13-653-0311                 *
    23    *       (also available in Japanese)          *
    24    *                                             *
    25    * Steven Pemberton, CWI, Amsterdam            *
    26    * http://www.cwi.nl/~steven/                  *
    27    * [e-mail]                     *
    28    *                                             *
    29    ***********************************************)
    30  
    31  program pascalcompiler(input,output,prr);
    32  
    33  const displimit = 20; maxlevel = 10;
    34     intsize     =      1;
    35     intal       =      1;
    36     realsize    =      1;
    37     realal      =      1;
    38     charsize    =      1;
    39     charal      =      1;
    40     charmax     =      1;
    41     boolsize    =      1;
    42     boolal      =      1;
    43     ptrsize     =      1;
    44     adral       =      1;
    45     setsize     =      1;
    46     setal       =      1;
    47     stackal     =      1;
    48     stackelsize =      1;
    49     strglgth    =     16;
    50     sethigh     =     47;
    51     setlow      =      0;
    52     ordmaxchar  =     63;
    53     ordminchar  =      0;
    54     maxint      =  32767;
    55     lcaftermarkstack = 5;
    56     fileal      = charal;
    57     (* stackelsize = minimum size for 1 stackelement
    58                    = k*stackal
    59        stackal     = scm(all other al-constants)
    60        charmax     = scm(charsize,charal)
    61                      scm = smallest common multiple
    62        lcaftermarkstack >= 4*ptrsize+max(x-size)
    63                          = k1*stackelsize          *)
    64     maxstack   =       1;
    65     parmal     = stackal;
    66     parmsize   = stackelsize;
    67     recal      = stackal;
    68     filebuffer =       4;
    69     maxaddr    =  maxint;
    70  
    71  
    72  
    73  type                                                        (*describing:*)
    74                                                              (*************)
    75  
    76       marktype= ^integer;
    77                                                              (*basic symbols*)
    78                                                              (***************)
    79  
    80       symbol = (ident,intconst,realconst,stringconst,notsy,mulop,addop,relop,
    81                 lparent,rparent,lbrack,rbrack,comma,semicolon,period,arrow,
    82                 colon,becomes,labelsy,constsy,typesy,varsy,funcsy,progsy,
    83                 procsy,setsy,packedsy,arraysy,recordsy,filesy,forwardsy,
    84                 beginsy,ifsy,casesy,repeatsy,whilesy,forsy,withsy,
    85                 gotosy,endsy,elsesy,untilsy,ofsy,dosy,tosy,downtosy,
    86                 thensy,othersy);
    87       operator = (mul,rdiv,andop,idiv,imod,plus,minus,orop,ltop,leop,geop,gtop,
    88                   neop,eqop,inop,noop);
    89       setofsys = set of symbol;
    90       chtp = (letter,number,special,illegal,
    91               chstrquo,chcolon,chperiod,chlt,chgt,chlparen,chspace);
    92  
    93                                                              (*constants*)
    94                                                              (***********)
    95       setty = set of setlow..sethigh;
    96       cstclass = (reel,pset,strg);
    97       csp = ^ constant;
    98       constant = record case cclass: cstclass of
    99                           reel: (rval: packed array [1..strglgth] of char);
   100                           pset: (pval: setty);
   101                           strg: (slgth: 0..strglgth;
   102                                  sval: packed array [1..strglgth] of char)
   103                         end;
   104  
   105       valu = record case intval: boolean of  (*intval never set nor tested*)
   106                       true:  (ival: integer);
   107                       false: (valp: csp)
   108                     end;
   109  
   110                                                             (*data structures*)
   111                                                             (*****************)
   112       levrange = 0..maxlevel; addrrange = 0..maxaddr;
   113       structform = (scalar,subrange,pointer,power,arrays,records,files,
   114                     tagfld,variant);
   115       declkind = (standard,declared);
   116       stp = ^ structure; ctp = ^ identifier;
   117  
   118       structure = packed record
   119                     marked: boolean;   (*for test phase only*)
   120                     size: addrrange;
   121                     case form: structform of
   122                       scalar:   (case scalkind: declkind of
   123                                    declared: (fconst: ctp); standard: ());
   124                       subrange: (rangetype: stp; min,max: valu);
   125                       pointer:  (eltype: stp);
   126                       power:    (elset: stp);
   127                       arrays:   (aeltype,inxtype: stp);
   128                       records:  (fstfld: ctp; recvar: stp);
   129                       files:    (filtype: stp);
   130                       tagfld:   (tagfieldp: ctp; fstvar: stp);
   131                       variant:  (nxtvar,subvar: stp; varval: valu)
   132                     end;
   133  
   134                                                              (*names*)
   135                                                              (*******)
   136  
   137       idclass = (types,konst,vars,field,proc,func);
   138       setofids = set of idclass;
   139       idkind = (actual,formal);
   140       alpha = packed array [1..8] of char;
   141  
   142       identifier = packed record
   143                     name: alpha; llink, rlink: ctp;
   144                     idtype: stp; next: ctp;
   145                     case klass: idclass of
   146                       types: ();
   147                       konst: (values: valu);
   148                       vars:  (vkind: idkind; vlev: levrange; vaddr: addrrange);
   149                       field: (fldaddr: addrrange);
   150                       proc, func:  (case pfdeckind: declkind of
   151                                standard: (key: 1..15);
   152                                declared: (pflev: levrange; pfname: integer;
   153                                            case pfkind: idkind of
   154                                             actual: (forwdecl, externl: boolean);
   155                                             formal: ()))
   156                     end;
   157  
   158  
   159       disprange = 0..displimit;
   160       where = (blck,crec,vrec,rec);
   161  
   162                                                              (*expressions*)
   163                                                              (*************)
   164       attrkind = (cst,varbl,expr);
   165       vaccess = (drct,indrct,inxd);
   166  
   167       attr = record typtr: stp;
   168                case kind: attrkind of
   169                  cst:   (cval: valu);
   170                  varbl: (case access: vaccess of
   171                            drct: (vlevel: levrange; dplmt: addrrange);
   172                            indrct: (idplmt: addrrange))
   173                end;
   174  
   175       testp = ^ testpointer;
   176       testpointer = packed record
   177                       elt1,elt2 : stp;
   178                       lasttestp : testp
   179                     end;
   180  
   181                                                                   (*labels*)
   182                                                                   (********)
   183       lbp = ^ labl;
   184       labl = record nextlab: lbp; defined: boolean;
   185                     labval, labname: integer
   186              end;
   187  
   188       extfilep = ^filerec;
   189       filerec = record filename:alpha; nextfile:extfilep end;
   190  
   191  (*-------------------------------------------------------------------------*)
   192  
   193  var
   194      prr: text; (* comment this out when compiling with pcom *)
   195                                      (*returned by source program scanner
   196                                       insymbol:
   197                                       **********)
   198  
   199      sy: symbol;                     (*last symbol*)
   200      op: operator;                   (*classification of last symbol*)
   201      val: valu;                      (*value of last constant*)
   202      lgth: integer;                  (*length of last string constant*)
   203      id: alpha;                      (*last identifier (possibly truncated)*)
   204      kk: 1..8;                       (*nr of chars in last identifier*)
   205      ch: char;                       (*last character*)
   206      eol: boolean;                   (*end of line flag*)
   207  
   208  
   209                                      (*counters:*)
   210                                      (***********)
   211  
   212      chcnt: integer;                 (*character counter*)
   213      lc,ic: addrrange;               (*data location and instruction counter*)
   214      linecount: integer;
   215  
   216  
   217                                      (*switches:*)
   218                                      (***********)
   219  
   220      dp,                             (*declaration part*)
   221      prterr,                         (*to allow forward references in pointer type
   222                                        declaration by suppressing error message*)
   223      list,prcode,prtables: boolean;  (*output options for
   224                                          -- source program listing
   225                                          -- printing symbolic code
   226                                          -- displaying ident and struct tables
   227                                          --> procedure option*)
   228      debug: boolean;
   229  
   230  
   231                                      (*pointers:*)
   232                                      (***********)
   233      parmptr,
   234      intptr,realptr,charptr,
   235      boolptr,nilptr,textptr: stp;    (*pointers to entries of standard ids*)
   236      utypptr,ucstptr,uvarptr,
   237      ufldptr,uprcptr,ufctptr,        (*pointers to entries for undeclared ids*)
   238      fwptr: ctp;                     (*head of chain of forw decl type ids*)
   239      fextfilep: extfilep;            (*head of chain of external files*)
   240      globtestp: testp;               (*last testpointer*)
   241  
   242  
   243                                      (*bookkeeping of declaration levels:*)
   244                                      (************************************)
   245  
   246      level: levrange;                (*current static level*)
   247      disx,                           (*level of last id searched by searchid*)
   248      top: disprange;                 (*top of display*)
   249  
   250      display:                        (*where:   means:*)
   251        array [disprange] of
   252          packed record               (*=blck:   id is variable id*)
   253            fname: ctp; flabel: lbp;  (*=crec:   id is field id in record with*)
   254            case occur: where of      (*         constant address*)
   255              crec: (clev: levrange;  (*=vrec:   id is field id in record with*)
   256                    cdspl: addrrange);(*         variable address*)
   257              vrec: (vdspl: addrrange)
   258            end;                      (* --> procedure withstatement*)
   259  
   260  
   261                                      (*error messages:*)
   262                                      (*****************)
   263  
   264      errinx: 0..10;                  (*nr of errors in current source line*)
   265      errlist:
   266        array [1..10] of
   267          packed record pos: integer;
   268                        nmr: 1..400
   269                 end;
   270  
   271  
   272  
   273                                      (*expression compilation:*)
   274                                      (*************************)