projects / unix-history / blame
| Commit | Line | Data |
|---|---|---|
| fc2b415a BJ |
1 | procedure block(fsys: symset; isfun: boolean; level: integer); |
| 2 | ||
| 3 | type conrec = | |
| 4 | record case tp: types of | |
| 5 | ints,chars,bools: (i: integer); | |
| 6 | reals: (r: real) | |
| 7 | end ; | |
| 8 | ||
| 9 | var dx: integer; (*data allocation index*) | |
| 10 | prt: integer; (*t-index of this procedure*) | |
| 11 | prb: integer; (*b-index of this procedure*) | |
| 12 | x: integer; | |
| 13 | procedure skip(fsys: symset; n: integer); | |
| 14 | begin error(n); | |
| 15 | while not (sy in fsys) do insymbol | |
| 16 | end (*skip*) ; | |
| 17 | ||
| 18 | procedure test(s1,s2: symset; n: integer); | |
| 19 | begin if not (sy in s1) then | |
| 20 | skip(s1+s2,n) | |
| 21 | end (*test*) ; | |
| 22 | ||
| 23 | procedure testsemicolon; | |
| 24 | begin | |
| 25 | if sy = semicolon then insymbol else | |
| 26 | begin error(14); | |
| 27 | if sy in [comma,colon] then insymbol | |
| 28 | end ; | |
| 29 | test([ident]+blockbegsys, fsys, 6) | |
| 30 | end (*testsemicolon*) ; | |
| 31 | ||
| 32 | procedure enter(id: alfa; k: object); | |
| 33 | var j,l: integer; | |
| 34 | begin if t = tmax then fatal(1) else | |
| 35 | begin tab[0].name := id; | |
| 36 | j := btab[display[level]].last; l := j; | |
| 37 | while tab[j].name <> id do j := tab[j].link; | |
| 38 | if j <> 0 then error(1) else | |
| 39 | begin t := t+1; | |
| 40 | with tab[t] do | |
| 41 | begin name := id; link := l; | |
| 42 | obj := k; typ := notyp; ref := 0; lev := level; adr := 0 | |
| 43 | end ; | |
| 44 | btab[display[level]].last := t | |
| 45 | end | |
| 46 | end | |
| 47 | end (*enter*) ; | |
| 48 | ||
| 49 | function loc(id: alfa): integer; | |
| 50 | var i,j: integer; (*locate id in table*) | |
| 51 | begin i := level; tab[0].name := id; (*sentinel*) | |
| 52 | repeat j := btab[display[i]].last; | |
| 53 | while tab[j].name <> id do j := tab[j].link; | |
| 54 | i := i-1; | |
| 55 | until (i<0) or (j<>0); | |
| 56 | if j = 0 then error(0); loc := j | |
| 57 | end (*loc*) ; | |
| 58 | ||
| 59 | procedure entervariable; | |
| 60 | begin if sy = ident then | |
| 61 | begin enter(id,variable); insymbol | |
| 62 | end | |
| 63 | else error(2) | |
| 64 | end (*entervariable*) ; | |
| 65 | ||
| 66 | procedure constant(fsys: symset; var c: conrec); | |
| 67 | var x, sign: integer; | |
| 68 | begin c.tp := notyp; c.i := 0; | |
| 69 | test(constbegsys, fsys, 50); | |
| 70 | if sy in constbegsys then | |
| 71 | begin | |
| 72 | if sy = charcon then | |
| 73 | begin c.tp := chars; c.i := inum; insymbol | |
| 74 | end | |
| 75 | else | |
| 76 | begin sign := 1; | |
| 77 | if sy in [plus,minus] then | |
| 78 | begin if sy = minus then sign := -1; | |
| 79 | insymbol | |
| 80 | end ; | |
| 81 | if sy = ident then | |
| 82 | begin x := loc(id); | |
| 83 | if x <> 0 then | |
| 84 | if tab[x].obj <> konstant then error(25) else | |
| 85 | begin c.tp := tab[x].typ; | |
| 86 | if c.tp = reals then c.r := sign*rconst[tab[x].adr] | |
| 87 | else c.i := sign*tab[x].adr | |
| 88 | end ; | |
| 89 | insymbol | |
| 90 | end | |
| 91 | else | |
| 92 | if sy = intcon then | |
| 93 | begin c.tp := ints; c.i := sign*inum; insymbol | |
| 94 | end else | |
| 95 | if sy = realcon then | |
| 96 | begin c.tp := reals; c.r := sign*rnum; insymbol | |
| 97 | end else skip(fsys,50) | |
| 98 | end; | |
| 99 | test(fsys, [], 6) | |
| 100 | end | |
| 101 | end (*constant*) ; | |
| 102 | procedure typ(fsys: symset; var tp: types; var rf, sz: integer); | |
| 103 | var x: integer; | |
| 104 | eltp: types; elrf: integer; | |
| 105 | elsz, offset, t0,t1: integer; | |
| 106 | ||
| 107 | procedure arraytyp(var aref,arsz: integer); | |
| 108 | var eltp: types; | |
| 109 | low, high: conrec; | |
| 110 | elrf, elsz: integer; | |
| 111 | begin constant([colon,rbrack,rparent,ofsy]+fsys, low); | |
| 112 | if low.tp = reals then | |
| 113 | begin error(27); low.tp := ints; low.i := 0 | |
| 114 | end ; | |
| 115 | if sy = colon then insymbol else error(13); | |
| 116 | constant([rbrack,comma,rparent,ofsy]+fsys, high); | |
| 117 | if high.tp <> low.tp then | |
| 118 | begin error(27); high.i := low.i | |
| 119 | end ; | |
| 120 | enterarray(low.tp, low.i, high.i); aref := a; | |
| 121 | if sy = comma then | |
| 122 | begin insymbol; eltp := arrays; arraytyp(elrf,elsz) | |
| 123 | end else | |
| 124 | begin | |
| 125 | if sy = rbrack then insymbol else | |
| 126 | begin error(12); | |
| 127 | if sy = rparent then insymbol | |
| 128 | end ; | |
| 129 | if sy = ofsy then insymbol else error(8); | |
| 130 | typ(fsys,eltp,elrf,elsz) | |
| 131 | end ; | |
| 132 | with atab[aref] do | |
| 133 | begin arsz := (high-low+1)*elsz; size := arsz; | |
| 134 | eltyp := eltp; elref := elrf; elsize := elsz | |
| 135 | end ; | |
| 136 | end (*arraytyp*) ; | |
| 137 | ||
| 138 | begin (*typ*) tp := notyp; rf := 0; sz := 0; | |
| 139 | test(typebegsys, fsys, 10); | |
| 140 | if sy in typebegsys then | |
| 141 | begin | |
| 142 | if sy = ident then | |
| 143 | begin x := loc(id); | |
| 144 | if x <> 0 then | |
| 145 | with tab[x] do | |
| 146 | if obj <> type1 then error(29) else | |
| 147 | begin tp := typ; rf := ref; sz := adr; | |
| 148 | if tp = notyp then error(30) | |
| 149 | end ; | |
| 150 | insymbol | |
| 151 | end else | |
| 152 | if sy = arraysy then | |
| 153 | begin insymbol; | |
| 154 | if sy = lbrack then insymbol else | |
| 155 | begin error(11); | |
| 156 | if sy = lparent then insymbol | |
| 157 | end ; | |
| 158 | tp := arrays; arraytyp(rf,sz) | |
| 159 | end else | |
| 160 | begin (*records*) insymbol; | |
| 161 | enterblock; tp := records; rf := b; | |
| 162 | if level = lmax then fatal(5); | |
| 163 | level := level+1; display[level] := b; offset := 0; | |
| 164 | while sy <> endsy do | |
| 165 | begin (*field section*) | |
| 166 | if sy = ident then | |
| 167 | begin t0 := t; entervariable; | |
| 168 | while sy = comma do | |
| 169 | begin insymbol; entervariable | |
| 170 | end ; | |
| 171 | if sy = colon then insymbol else error(5); | |
| 172 | t1 := t; | |
| 173 | typ(fsys+[semicolon,endsy,comma,ident],eltp,elrf,elsz); | |
| 174 | while t0 < t1 do | |
| 175 | begin t0 := t0+1; | |
| 176 | with tab[t0] do | |
| 177 | begin typ := eltp; ref := elrf; normal := true; | |
| 178 | adr := offset; offset := offset + elsz | |
| 179 | end | |
| 180 | end | |
| 181 | end ; | |
| 182 | if sy <> endsy then | |
| 183 | begin if sy = semicolon then insymbol else | |
| 184 | begin error(14); | |
| 185 | if sy = comma then insymbol | |
| 186 | end ; | |
| 187 | test([ident,endsy,semicolon], fsys, 6) | |
| 188 | end | |
| 189 | end ; | |
| 190 | btab[rf].vsize := offset; sz := offset; btab[rf].psize := 0; | |
| 191 | insymbol; level := level-1 | |
| 192 | end ; | |
| 193 | test(fsys, [], 6) | |
| 194 | end | |
| 195 | end (*typ*) ; | |
| 196 | ||
| 197 | procedure parameterlist; (*formal parameter list*) | |
| 198 | var tp: types; | |
| 199 | rf, sz, x, t0: integer; | |
| 200 | valpar: boolean; | |
| 201 | begin insymbol; tp := notyp; rf := 0; sz := 0; | |
| 202 | test([ident, varsy], fsys+[rparent], 7); | |
| 203 | while sy in [ident,varsy] do | |
| 204 | begin if sy <> varsy then valpar := true else | |
| 205 | begin insymbol; valpar := false | |
| 206 | end ; | |
| 207 | t0 := t; entervariable; | |
| 208 | while sy = comma do | |
| 209 | begin insymbol; entervariable; | |
| 210 | end ; | |
| 211 | if sy = colon then | |
| 212 | begin insymbol; | |
| 213 | if sy <> ident then error(2) else | |
| 214 | begin x := loc(id); insymbol; | |
| 215 | if x <> 0 then | |
| 216 | with tab[x] do | |
| 217 | if obj <> type1 then error(29) else | |
| 218 | begin tp := typ; rf := ref; | |
| 219 | if valpar then sz := adr else sz := 1 | |
| 220 | end ; | |
| 221 | end ; | |
| 222 | test([semicolon,rparent], [comma,ident]+fsys, 14) | |
| 223 | end | |
| 224 | else error(5); | |
| 225 | while t0 < t do | |
| 226 | begin t0 := t0+1; | |
| 227 | with tab[t0] do | |
| 228 | begin typ := tp; ref := rf; | |
| 229 | normal := valpar; adr := dx; lev := level; | |
| 230 | dx := dx + sz | |
| 231 | end | |
| 232 | end ; | |
| 233 | if sy <> rparent then | |
| 234 | begin if sy = semicolon then insymbol else | |
| 235 | begin error(14); | |
| 236 | if sy = comma then insymbol | |
| 237 | end ; | |
| 238 | test([ident,varsy], [rparent]+fsys, 6) | |
| 239 | end | |
| 240 | end (*while*) ; | |
| 241 | if sy = rparent then | |
| 242 | begin insymbol; | |
| 243 | test([semicolon,colon], fsys, 6) | |
| 244 | end | |
| 245 | else error(4) | |
| 246 | end (*parameterlist*) ; | |
| 247 | ||
| 248 | procedure constantdeclaration; | |
| 249 | var c: conrec; | |
| 250 | begin insymbol; | |
| 251 | test([ident], blockbegsys, 2); | |
| 252 | while sy = ident do | |
| 253 | begin enter(id,konstant); insymbol; | |
| 254 | if sy = eql then insymbol else | |
| 255 | begin error(16); | |
| 256 | if sy = becomes then insymbol | |
| 257 | end ; | |
| 258 | constant([semicolon,comma,ident]+fsys,c); | |
| 259 | tab[t].typ := c.tp; tab[t].ref := 0; | |
| 260 | if c.tp = reals then | |
| 261 | begin enterreal(c.r); tab[t].adr := c1 end | |
| 262 | else tab[t].adr := c.i; | |
| 263 | testsemicolon | |
| 264 | end | |
| 265 | end (*constantdeclaration*) ; | |
| 266 | ||
| 267 | procedure typedeclaration; | |
| 268 | var tp: types; rf, sz, t1: integer; | |
| 269 | begin insymbol; | |
| 270 | test([ident], blockbegsys, 2); | |
| 271 | while sy = ident do | |
| 272 | begin enter(id,type1); t1 := t; insymbol; | |
| 273 | if sy = eql then insymbol else | |
| 274 | begin error(16); | |
| 275 | if sy = becomes then insymbol | |
| 276 | end ; | |
| 277 | typ([semicolon,comma,ident]+fsys, tp, rf, sz); | |
| 278 | with tab[t1] do | |
| 279 | begin typ := tp; ref := rf; adr := sz | |
| 280 | end ; | |
| 281 | testsemicolon | |
| 282 | end | |
| 283 | end (*typedeclaration*) ; | |
| 284 | ||
| 285 | procedure variabledeclaration; | |
| 286 | var t0, t1, rf, sz: integer; | |
| 287 | tp: types; | |
| 288 | begin insymbol; | |
| 289 | while sy = ident do | |
| 290 | begin t0 := t; entervariable; | |
| 291 | while sy = comma do | |
| 292 | begin insymbol; entervariable; | |
| 293 | end ; | |
| 294 | if sy = colon then insymbol else error(5); | |
| 295 | t1 := t; | |
| 296 | typ([semicolon,comma,ident]+fsys, tp, rf, sz); | |
| 297 | while t0 < t1 do | |
| 298 | begin t0 := t0+1; | |
| 299 | with tab[t0] do | |
| 300 | begin typ := tp; ref := rf; | |
| 301 | lev := level; adr := dx; normal := true; | |
| 302 | dx := dx + sz | |
| 303 | end | |
| 304 | end ; | |
| 305 | testsemicolon | |
| 306 | end | |
| 307 | end (*variabledeclaration*) ; | |
| 308 | ||
| 309 | procedure procdeclaration; | |
| 310 | var isfun: boolean; | |
| 311 | begin isfun := sy = functionsy; insymbol; | |
| 312 | if sy <> ident then | |
| 313 | begin error(2); id := ' ' | |
| 314 | end ; | |
| 315 | if isfun then enter(id,funktion) else enter(id,prozedure); | |
| 316 | tab[t].normal := true; | |
| 317 | insymbol; block([semicolon]+fsys, isfun, level+1); | |
| 318 | if sy = semicolon then insymbol else error(14); | |
| 319 | emit(32+ord(isfun)) (*exit*) | |
| 320 | end (*proceduredeclaration*) ; | |
| 321 | ||
| 322 | (*---------------------------------------------------------statement--*) | |
| 323 | ||
| 324 | procedure statement(fsys: symset); | |
| 325 | var i: integer; | |
| 326 | procedure expression(fsys: symset; var x: item); forward; | |
| 327 | ||
| 328 | procedure selector(fsys: symset; var v:item); | |
| 329 | var x: item; a,j: integer; | |
| 330 | begin (*sy in [lparent, lbrack, period]*) | |
| 331 | repeat | |
| 332 | if sy = period then | |
| 333 | begin insymbol; (*field selector*) | |
| 334 | if sy <> ident then error(2) else | |
| 335 | begin | |
| 336 | if v.typ <> records then error(31) else | |
| 337 | begin (*search field identifier*) | |
| 338 | j := btab[v.ref] .last; tab[0].name := id; | |
| 339 | while tab[j].name <> id do j := tab[j].link; | |
| 340 | if j = 0 then error(0); | |
| 341 | v.typ := tab[j].typ; v.ref := tab[j].ref; | |
| 342 | a := tab[j].adr; if a <> 0 then emit1(9,a) | |
| 343 | end ; | |
| 344 | insymbol | |
| 345 | end | |
| 346 | end else | |
| 347 | begin (*array selector*) | |
| 348 | if sy <> lbrack then error(11); | |
| 349 | repeat insymbol; | |
| 350 | expression(fsys+[comma,rbrack], x); | |
| 351 | if v.typ <> arrays then error(28) else | |
| 352 | begin a := v.ref; | |
| 353 | if atab[a].inxtyp <> x.typ then error(26) else | |
| 354 | if atab[a].elsize = 1 then emit1(20,a) else emit1(21,a); | |
| 355 | v.typ := atab[a].eltyp; v.ref := atab[a].elref | |
| 356 | end | |
| 357 | until sy <> comma; | |
| 358 | if sy = rbrack then insymbol else | |
| 359 | begin error(12); if sy = rparent then insymbol | |
| 360 | end | |
| 361 | end | |
| 362 | until not (sy in [lbrack,lparent,period]); | |
| 363 | test(fsys, [], 6) | |
| 364 | end (*selector*) ; | |
| 365 | ||
| 366 | procedure call(fsys: symset; i: integer); | |
| 367 | var x: item; | |
| 368 | lastp, cp, k: integer; | |
| 369 | begin emit1(18,i); (*mark stack*) | |
| 370 | lastp := btab[tab[i].ref].lastpar; cp := i; | |
| 371 | if sy = lparent then | |
| 372 | begin (*actual parameter list*) | |
| 373 | repeat insymbol; | |
| 374 | if cp >= lastp then error(39) else | |
| 375 | begin cp := cp+1; | |
| 376 | if tab[cp].normal then | |
| 377 | begin (*value parameter*) | |
| 378 | expression(fsys+[comma,colon,rparent], x); | |
| 379 | if x.typ=tab[cp].typ then | |
| 380 | begin | |
| 381 | if x.ref <> tab[cp].ref then error(36) else | |
| 382 | if x.typ = arrays then emit1(22,atab[x.ref].size) else | |
| 383 | if x.typ = records then emit1(22,btab[x.ref].vsize) | |
| 384 | end else | |
| 385 | if (x.typ=ints) and (tab[cp].typ=reals) then | |
| 386 | emit1(26,0) else | |
| 387 | if x.typ<>notyp then error(36); | |
| 388 | end else | |
| 389 | begin (*variable parameter*) | |
| 390 | if sy <> ident then error(2) else | |
| 391 | begin k := loc(id); insymbol; | |
| 392 | if k <> 0 then | |
| 393 | begin if tab[k].obj <> variable then error(37); | |
| 394 | x.typ := tab[k].typ; x.ref := tab[k].ref; | |
| 395 | if tab[k].normal then emit2(0,tab[k].lev,tab[k].adr) | |
| 396 | else emit2(1,tab[k].lev,tab[k].adr); | |
| 397 | if sy in [lbrack,lparent,period] then | |
| 398 | selector(fsys+[comma,colon,rparent], x); | |
| 399 | if (x.typ<>tab[cp].typ) or (x.ref<>tab[cp].ref) then | |
| 400 | error(36) | |
| 401 | end | |
| 402 | end | |
| 403 | end | |
| 404 | end ; | |
| 405 | test([comma,rparent], fsys, 6) | |
| 406 | until sy <> comma; | |
| 407 | if sy = rparent then insymbol else error(4) | |
| 408 | end ; | |
| 409 | if cp < lastp then error(39); (*too few actual parameters*) | |
| 410 | emit1(19, btab[tab[i].ref].psize-1); | |
| 411 | if tab[i].lev < level then emit2(3, tab[i].lev, level) | |
| 412 | end (*call*) ; | |
| 413 | ||
| 414 | function resulttype(a,b: types): types; | |
| 415 | begin | |
| 416 | if (a>reals) or (b>reals) then | |
| 417 | begin error(33); resulttype := notyp | |
| 418 | end else | |
| 419 | if (a=notyp) or (b=notyp) then resulttype := notyp else | |
| 420 | if a=ints then | |
| 421 | if b=ints then resulttype := ints else | |
| 422 | begin resulttype := reals; emit1(26,1) | |
| 423 | end | |
| 424 | else | |
| 425 | begin resulttype := reals; | |
| 426 | if b=ints then emit1(26,0) | |
| 427 | end | |
| 428 | end (*resulttype*) ; | |
| 429 | ||
| 430 | procedure expression; | |
| 431 | var y:item; op:symbol; | |
| 432 | ||
| 433 | procedure simpleexpression(fsys:symset; var x:item); | |
| 434 | var y:item; op:symbol; | |
| 435 | ||
| 436 | procedure term(fsys:symset; var x:item); | |
| 437 | var y:item; op:symbol; | |
| 438 | ||
| 439 | procedure factor(fsys:symset; var x:item); | |
| 440 | var i,f: integer; | |
| 441 | ||
| 442 | procedure standfct(n: integer); | |
| 443 | var ts: typset; | |
| 444 | begin (*standard function no. n*) | |
| 445 | if sy = lparent then insymbol else error(9); | |
| 446 | if n < 17 then | |
| 447 | begin expression(fsys+[rparent],x); | |
| 448 | case n of | |
| 449 | (*abs,sqr*) 0,2: begin ts := [ints,reals]; tab[i].typ := x.typ; | |
| 450 | if x.typ = reals then n := n+1 | |
| 451 | end ; | |
| 452 | (*odd,chr*) 4,5: ts := [ints]; | |
| 453 | (*ord*) 6: begin | |
| 454 | if x.typ = ints then n := 19; | |
| 455 | ts := [ints,bools,chars]; | |
| 456 | end; | |
| 457 | (*succ,pred*) 7,8: ts := [chars]; | |
| 458 | (*round,trunc*) 9,10,11,12,13,14,15,16: | |
| 459 | (*sin,cos,...*) begin ts := [ints,reals]; | |
| 460 | if x.typ = ints then emit1(26,0) | |
| 461 | end ; | |
| 462 | end ; | |
| 463 | if x.typ in ts then emit1(8,n) else | |
| 464 | if x.typ <> notyp then error(48); | |
| 465 | end else | |
| 466 | (*eof,eoln*) begin (*n in [17,18]*) | |
| 467 | if sy <> ident then error(2) else | |
| 468 | if id <> 'input ' then error(0) else insymbol; | |
| 469 | emit1(8,n); | |
| 470 | end ; | |
| 471 | x.typ := tab[i].typ; | |
| 472 | if sy = rparent then insymbol else error(4) | |
| 473 | end (*standfct*) ; | |
| 474 | ||
| 475 | begin (*factor*) x.typ := notyp; x.ref := 0; | |
| 476 | test(facbegsys, fsys, 58); | |
| 477 | while sy in facbegsys do | |
| 478 | begin | |
| 479 | if sy = ident then | |
| 480 | begin i := loc(id); insymbol; | |
| 481 | with tab[i] do | |
| 482 | case obj of | |
| 483 | konstant: begin x.typ := typ; x.ref := 0; | |
| 484 | case x.typ of | |
| 485 | ints: emit1(24,adr); | |
| 486 | reals: emit1(25,adr); | |
| 487 | bools: emit1(64,adr); | |
| 488 | chars: emit1(65,adr); | |
| 489 | end; | |
| 490 | end ; | |
| 491 | variable: begin x.typ := typ; x.ref := ref; | |
| 492 | if sy in [lbrack,lparent,period] then | |
| 493 | begin if normal then f := 0 else f := 1; | |
| 494 | emit2(f, lev, adr); | |
| 495 | selector(fsys,x); | |
| 496 | if x.typ in stantyps then emit(34) | |
| 497 | end else | |
| 498 | begin | |
| 499 | if x.typ in stantyps then | |
| 500 | if normal then f := 1 else f := 2 | |
| 501 | else | |
| 502 | if normal then f := 0 else f := 1; | |
| 503 | emit2(f, lev, adr) | |
| 504 | end | |
| 505 | end ; | |
| 506 | type1, prozedure: error(44); | |
| 507 | funktion :begin x.typ := typ; | |
| 508 | if lev <> 0 then call(fsys, i) | |
| 509 | else standfct(adr) | |
| 510 | end | |
| 511 | end (*case,with*) | |
| 512 | end else | |
| 513 | if sy in [charcon,intcon,realcon] then | |
| 514 | begin | |
| 515 | if sy = realcon then | |
| 516 | begin x.typ := reals; enterreal(rnum); | |
| 517 | emit1(25, c1) | |
| 518 | end else | |
| 519 | begin | |
| 520 | if sy = charcon then begin | |
| 521 | x.typ := chars; | |
| 522 | emit1(65, inum); | |
| 523 | end else begin | |
| 524 | x.typ := ints; | |
| 525 | emit1(24, inum); | |
| 526 | end; | |
| 527 | end ; | |
| 528 | x.ref := 0; insymbol | |
| 529 | end else | |
| 530 | if sy = lparent then | |
| 531 | begin insymbol; expression(fsys+[rparent], x); | |
| 532 | if sy = rparent then insymbol else error(4) | |
| 533 | end else | |
| 534 | if sy = notsy then | |
| 535 | begin insymbol; factor(fsys,x); | |
| 536 | if x.typ=bools then emit(35) else | |
| 537 | if x.typ<>notyp then error(32) | |
| 538 | end ; | |
| 539 | test(fsys, facbegsys, 6) | |
| 540 | end (*while*) | |
| 541 | end (*factor*) ; | |
| 542 | ||
| 543 | begin (*term*) | |
| 544 | factor(fsys+[times,rdiv,idiv,imod,andsy], x); | |
| 545 | while sy in [times,rdiv,idiv,imod,andsy] do | |
| 546 | begin op := sy; insymbol; | |
| 547 | factor(fsys+[times,rdiv,idiv,imod,andsy], y); | |
| 548 | if op = times then | |
| 549 | begin x.typ := resulttype(x.typ, y.typ); | |
| 550 | case x.typ of | |
| 551 | notyp: ; | |
| 552 | ints : emit(57); | |
| 553 | reals: emit(60); | |
| 554 | end | |
| 555 | end else | |
| 556 | if op = rdiv then | |
| 557 | begin | |
| 558 | if x.typ = ints then | |
| 559 | begin emit1(26,1); x.typ := reals | |
| 560 | end ; | |
| 561 | if y.typ = ints then | |
| 562 | begin emit1(26,0); y.typ := reals | |
| 563 | end ; | |
| 564 | if (x.typ=reals) and (y.typ=reals) then emit(61) else | |
| 565 | begin if (x.typ<>notyp) and (y.typ<>notyp) then | |
| 566 | error(33); | |
| 567 | x.typ := notyp | |
| 568 | end | |
| 569 | end else | |
| 570 | if op = andsy then | |
| 571 | begin if (x.typ=bools) and (y.typ=bools) then | |
| 572 | emit(56) else | |
| 573 | begin if (x.typ<>notyp) and (y.typ<>notyp) then | |
| 574 | error(32); | |
| 575 | x.typ := notyp | |
| 576 | end | |
| 577 | end else | |
| 578 | begin (*op in [idiv,imod]*) | |
| 579 | if (x.typ=ints) and (y.typ=ints) then | |
| 580 | if op=idiv then emit(58) | |
| 581 | else emit(59) else | |
| 582 | begin if (x.typ<>notyp) and (y.typ<>notyp) then | |
| 583 | error(34); | |
| 584 | x.typ := notyp | |
| 585 | end | |
| 586 | end | |
| 587 | end | |
| 588 | end (*term*) ; | |
| 589 | ||
| 590 | begin (*simpleexpression*) | |
| 591 | if sy in [plus,minus] then | |
| 592 | begin op := sy; insymbol; | |
| 593 | term(fsys+[plus,minus], x); | |
| 594 | if x.typ > reals then error(33) else | |
| 595 | if op = minus then | |
| 596 | if x.typ = reals then | |
| 597 | emit(66) | |
| 598 | else | |
| 599 | emit(36) | |
| 600 | end else | |
| 601 | term(fsys+[plus,minus,orsy], x); | |
| 602 | while sy in [plus,minus,orsy] do | |
| 603 | begin op := sy; insymbol; | |
| 604 | term(fsys+[plus,minus,orsy], y); | |
| 605 | if op = orsy then | |
| 606 | begin | |
| 607 | if (x.typ=bools) and (y.typ=bools) then emit(51) else | |
| 608 | begin if (x.typ<>notyp) and (y.typ<>notyp) then | |
| 609 | error(32); | |
| 610 | x.typ := notyp | |
| 611 | end | |
| 612 | end else | |
| 613 | begin x.typ := resulttype(x.typ, y.typ); | |
| 614 | case x.typ of | |
| 615 | notyp: ; | |
| 616 | ints : if op = plus then emit(52) | |
| 617 | else emit(53); | |
| 618 | reals: if op = plus then emit(54) | |
| 619 | else emit(55) | |
| 620 | end | |
| 621 | end | |
| 622 | end | |
| 623 | end (*simpleexpression*) ; | |
| 624 | ||
| 625 | begin (*expression*) | |
| 626 | simpleexpression(fsys+[eql,neq,lss,leq,gtr,geq], x); | |
| 627 | if sy in [eql,neq,lss,leq,gtr,geq] then | |
| 628 | begin op := sy; insymbol; | |
| 629 | simpleexpression(fsys, y); | |
| 630 | if (x.typ in [ notyp,ints,bools,chars]) and (x.typ = y.typ) then | |
| 631 | case op of | |
| 632 | eql: emit(45); | |
| 633 | neq: emit(46); | |
| 634 | lss: emit(47); | |
| 635 | leq: emit(48); | |
| 636 | gtr: emit(49); | |
| 637 | geq: emit(50); | |
| 638 | end else | |
| 639 | begin if x.typ = ints then | |
| 640 | begin x.typ := reals; emit1(26,1) | |
| 641 | end else | |
| 642 | if y.typ = ints then | |
| 643 | begin y.typ := reals; emit1(26,0) | |
| 644 | end ; | |
| 645 | if (x.typ=reals) and (y.typ=reals) then | |
| 646 | case op of | |
| 647 | eql: emit(39); | |
| 648 | neq: emit(40); | |
| 649 | lss: emit(41); | |
| 650 | leq: emit(42); | |
| 651 | gtr: emit(43); | |
| 652 | geq: emit(44); | |
| 653 | end | |
| 654 | else error(35) | |
| 655 | end ; | |
| 656 | x.typ := bools | |
| 657 | end | |
| 658 | end (*expression*) ; | |
| 659 | ||
| 660 | procedure assignment(lv,ad: integer); | |
| 661 | var x,y: item; f: integer; | |
| 662 | (*tab[i].obj in [variable,prozedure]*) | |
| 663 | begin x.typ := tab[i].typ; x.ref := tab[i].ref; | |
| 664 | if tab[i].normal then f := 0 else f := 1; | |
| 665 | emit2(f, lv, ad); | |
| 666 | if sy in [lbrack,lparent,period] then | |
| 667 | selector([becomes,eql]+fsys, x); | |
| 668 | if sy = becomes then insymbol else | |
| 669 | begin error(51); if sy = eql then insymbol | |
| 670 | end ; | |
| 671 | expression(fsys, y); | |
| 672 | if x.typ = y.typ then | |
| 673 | if x.typ in stantyps then emit(38) else | |
| 674 | if x.ref <> y.ref then error(46) else | |
| 675 | if x.typ = arrays then emit1(23, atab[x.ref].size) | |
| 676 | else emit1(23, btab[x.ref].vsize) | |
| 677 | else | |
| 678 | if (x.typ=reals) and (y.typ=ints) then | |
| 679 | begin emit1(26,0); emit(38) | |
| 680 | end else | |
| 681 | if (x.typ<>notyp) and (y.typ<>notyp) then error(46) | |
| 682 | end (*assignment*) ; | |
| 683 | ||
| 684 | procedure compoundstatement; | |
| 685 | begin insymbol; | |
| 686 | statement([semicolon,endsy]+fsys); | |
| 687 | while sy in [semicolon]+statbegsys do | |
| 688 | begin if sy = semicolon then insymbol else error(14); | |
| 689 | statement([semicolon,endsy]+fsys) | |
| 690 | end ; | |
| 691 | if sy = endsy then insymbol else error(57) | |
| 692 | end (*compoundstatemenet*) ; | |
| 693 | ||
| 694 | procedure ifstatement; | |
| 695 | var x: item; lc1,lc2: integer; | |
| 696 | begin insymbol; | |
| 697 | expression(fsys+[thensy,dosy], x); | |
| 698 | if not (x.typ in [bools,notyp]) then error(17); | |
| 699 | lc1 := lc; emit(11); (*jmpc*) | |
| 700 | if sy = thensy then insymbol else | |
| 701 | begin error(52); if sy = dosy then insymbol | |
| 702 | end ; | |
| 703 | statement(fsys+[elsesy]); | |
| 704 | if sy = elsesy then | |
| 705 | begin insymbol; lc2 := lc; emit(10); | |
| 706 | code[lc1].y := lc; statement(fsys); code[lc2].y := lc | |
| 707 | end | |
| 708 | else code[lc1].y := lc | |
| 709 | end (*ifstatement*) ; | |
| 710 | ||
| 711 | procedure casestatement; | |
| 712 | var x: item; | |
| 713 | i,j,k,lc1: integer; | |
| 714 | casetab: array [1..csmax] of | |
| 715 | packed record val, lc: index end ; | |
| 716 | exittab: array [1..csmax] of integer; | |
| 717 | ||
| 718 | procedure caselabel; | |
| 719 | var lab: conrec; k: integer; | |
| 720 | begin constant(fsys+[comma,colon], lab); | |
| 721 | if lab.tp <> x.typ then error(47) else | |
| 722 | if i = csmax then fatal(6) else | |
| 723 | begin i := i+1; k := 0; | |
| 724 | casetab[i].val := lab.i; casetab[i].lc := lc; | |
| 725 | repeat k := k+1 until casetab[k].val = lab.i; | |
| 726 | if k < i then error(1); (*multiple definition*) | |
| 727 | end | |
| 728 | end (*caselabel*) ; | |
| 729 | ||
| 730 | procedure onecase; | |
| 731 | begin if sy in constbegsys then | |
| 732 | begin caselabel; | |
| 733 | while sy = comma do | |
| 734 | begin insymbol; caselabel | |
| 735 | end ; | |
| 736 | if sy = colon then insymbol else error(5); | |
| 737 | statement([semicolon,endsy]+fsys); | |
| 738 | j := j+1; exittab[j] := lc; emit(10) | |
| 739 | end | |
| 740 | end (*onecase*) ; | |
| 741 | ||
| 742 | begin insymbol; i := 0; j := 0; | |
| 743 | expression(fsys+[ofsy,comma,colon], x); | |
| 744 | if not (x.typ in [ints,bools,chars,notyp]) then error(23); | |
| 745 | lc1 := lc; emit(12); (*jmpx*) | |
| 746 | if sy = ofsy then insymbol else error(8); | |
| 747 | onecase; | |
| 748 | while sy = semicolon do | |
| 749 | begin insymbol; onecase | |
| 750 | end ; | |
| 751 | code[lc1].y := lc; | |
| 752 | for k := 1 to i do | |
| 753 | begin emit1(13,casetab[k].val); emit1(13,casetab[k].lc) | |
| 754 | end ; | |
| 755 | emit1(10,0); | |
| 756 | for k := 1 to j do code[exittab[k]].y := lc; | |
| 757 | if sy = endsy then insymbol else error(57) | |
| 758 | end (*casestatement*) ; | |
| 759 | ||
| 760 | procedure repeatstatement; | |
| 761 | var x: item; lc1: integer; | |
| 762 | begin lc1 := lc; | |
| 763 | insymbol; statement([semicolon,untilsy]+fsys); | |
| 764 | while sy in [semicolon]+statbegsys do | |
| 765 | begin if sy = semicolon then insymbol else error(14); | |
| 766 | statement([semicolon,untilsy]+fsys) | |
| 767 | end ; | |
| 768 | if sy = untilsy then | |
| 769 | begin insymbol; expression(fsys, x); | |
| 770 | if not (x.typ in [bools,notyp]) then error(17); | |
| 771 | emit1(11,lc1) | |
| 772 | end | |
| 773 | else error(53) | |
| 774 | end (*repeatstatement*) ; | |
| 775 | ||
| 776 | procedure whilestatement; | |
| 777 | var x: item; lc1,lc2: integer; | |
| 778 | begin insymbol; lc1 := lc; | |
| 779 | expression(fsys+[dosy], x); | |
| 780 | if not (x.typ in [bools,notyp]) then error(17); | |
| 781 | lc2 := lc; emit(11); | |
| 782 | if sy = dosy then insymbol else error(54); | |
| 783 | statement(fsys); emit1(10,lc1); code[lc2].y := lc | |
| 784 | end (*whilestatement*) ; | |
| 785 | ||
| 786 | procedure forstatement; | |
| 787 | var cvt: types; x: item; | |
| 788 | i,f,lc1,lc2: integer; | |
| 789 | begin insymbol; | |
| 790 | if sy = ident then | |
| 791 | begin i := loc(id); insymbol; | |
| 792 | if i = 0 then cvt := ints else | |
| 793 | if tab[i].obj = variable then | |
| 794 | begin cvt := tab[i].typ; | |
| 795 | if not tab[i].normal then error(37) else | |
| 796 | emit2(0, tab[i].lev, tab[i].adr); | |
| 797 | if not (cvt in [notyp,ints,bools,chars]) then error(18) | |
| 798 | end else | |
| 799 | begin error(37); cvt := ints | |
| 800 | end | |
| 801 | end else skip([becomes,tosy,downtosy,dosy]+fsys, 2); | |
| 802 | if sy = becomes then | |
| 803 | begin insymbol; expression([tosy,downtosy,dosy]+fsys, x); | |
| 804 | if x.typ <> cvt then error(19); | |
| 805 | end else skip([tosy,downtosy,dosy]+fsys, 51); | |
| 806 | f := 14; | |
| 807 | if sy in [tosy, downtosy] then | |
| 808 | begin if sy = downtosy then f := 16; | |
| 809 | insymbol; expression([dosy]+fsys, x); | |
| 810 | if x.typ <> cvt then error(19) | |
| 811 | end else skip([dosy]+fsys, 55); | |
| 812 | lc1 := lc; emit(f); | |
| 813 | if sy = dosy then insymbol else error(54); | |
| 814 | lc2 := lc; statement(fsys); | |
| 815 | emit1(f+1,lc2); code[lc1].y := lc | |
| 816 | end (*forstatement*) ; | |
| 817 | ||
| 818 | procedure standproc(n: integer); | |
| 819 | var i,f: integer; | |
| 820 | x,y: item; | |
| 821 | begin | |
| 822 | case n of | |
| 823 | 1,2: begin (*read*) | |
| 824 | if not iflag then | |
| 825 | begin error(20); iflag := true | |
| 826 | end ; | |
| 827 | if sy = lparent then | |
| 828 | begin | |
| 829 | repeat insymbol; | |
| 830 | if sy <> ident then error(2) else | |
| 831 | begin i := loc(id); insymbol; | |
| 832 | if i <> 0 then | |
| 833 | if tab[i].obj <> variable then error(37) else | |
| 834 | begin x.typ := tab[i].typ; x.ref := tab[i].ref; | |
| 835 | if tab[i].normal then f := 0 else f := 1; | |
| 836 | emit2(f, tab[i].lev, tab[i].adr); | |
| 837 | if sy in [lbrack,lparent,period] then | |
| 838 | selector(fsys+[comma,rparent], x); | |
| 839 | if x.typ in [ints,reals,chars,notyp] then | |
| 840 | emit1(27, ord(x.typ)) else error(40) | |
| 841 | end | |
| 842 | end ; | |
| 843 | test([comma,rparent], fsys, 6); | |
| 844 | until sy <> comma; | |
| 845 | if sy = rparent then insymbol else error(4) | |
| 846 | end ; | |
| 847 | if n = 2 then emit(62) | |
| 848 | end ; | |
| 849 | 3,4: begin (*write*) | |
| 850 | if sy = lparent then | |
| 851 | begin | |
| 852 | repeat insymbol; | |
| 853 | if sy = string then | |
| 854 | begin emit1(24,sleng); emit1(28,inum); insymbol | |
| 855 | end else | |
| 856 | begin expression(fsys+[comma,colon,rparent], x); | |
| 857 | if not (x.typ in stantyps) then error(41); | |
| 858 | if sy = colon then | |
| 859 | begin insymbol; | |
| 860 | expression(fsys+[comma,colon,rparent], y); | |
| 861 | if y.typ <> ints then error(43); | |
| 862 | if sy = colon then | |
| 863 | begin if x.typ <> reals then error(42); | |
| 864 | insymbol; expression(fsys+[comma,rparent], y); | |
| 865 | if y.typ <> ints then error(43); | |
| 866 | emit(37) | |
| 867 | end | |
| 868 | else emit1(30, ord(x.typ)) | |
| 869 | end | |
| 870 | else emit1(29, ord(x.typ)) | |
| 871 | end | |
| 872 | until sy <> comma; | |
| 873 | if sy = rparent then insymbol else error(4) | |
| 874 | end ; | |
| 875 | if n = 4 then emit(63) | |
| 876 | end ; | |
| 877 | end (*case*) | |
| 878 | end (*standproc*) ; | |
| 879 | ||
| 880 | begin (*statement*) | |
| 881 | if sy in statbegsys+[ident] then | |
| 882 | case sy of | |
| 883 | ident: begin i := loc(id); insymbol; | |
| 884 | if i <> 0 then | |
| 885 | case tab[i].obj of | |
| 886 | konstant, type1: error(45); | |
| 887 | variable: assignment(tab[i].lev, tab[i].adr); | |
| 888 | prozedure: | |
| 889 | if tab[i].lev <> 0 then call(fsys, i) | |
| 890 | else standproc(tab[i].adr); | |
| 891 | funktion: | |
| 892 | if tab[i].ref = display[level] then | |
| 893 | assignment(tab[i].lev+1, 0) else error(45) | |
| 894 | end | |
| 895 | end ; | |
| 896 | beginsy: compoundstatement; | |
| 897 | ifsy: ifstatement; | |
| 898 | casesy: casestatement; | |
| 899 | whilesy: whilestatement; | |
| 900 | repeatsy: repeatstatement; | |
| 901 | forsy: forstatement; | |
| 902 | end; | |
| 903 | test(fsys, [], 14) | |
| 904 | end (*statement*) ; | |
| 905 | ||
| 906 | begin (*block*) dx := 5; prt := t; | |
| 907 | if level > lmax then fatal(5); | |
| 908 | test([lparent,colon,semicolon], fsys, 7); | |
| 909 | enterblock; display[level] := b; prb := b; | |
| 910 | tab[prt].typ := notyp; tab[prt].ref := prb; | |
| 911 | if sy = lparent then parameterlist; | |
| 912 | btab[prb].lastpar := t; btab[prb].psize := dx; | |
| 913 | if isfun then | |
| 914 | if sy = colon then | |
| 915 | begin insymbol; (*function type*) | |
| 916 | if sy = ident then | |
| 917 | begin x := loc(id); insymbol; | |
| 918 | if x <> 0 then | |
| 919 | if tab[x].obj <> type1 then error(29) else | |
| 920 | if tab[x].typ in stantyps then tab[prt].typ := tab[x].typ | |
| 921 | else error(15) | |
| 922 | end else skip([semicolon]+fsys, 2) | |
| 923 | end else error(5); | |
| 924 | if sy = semicolon then insymbol else error(14); | |
| 925 | repeat | |
| 926 | if sy = constsy then constantdeclaration; | |
| 927 | if sy = typesy then typedeclaration; | |
| 928 | if sy = varsy then variabledeclaration; | |
| 929 | btab[prb].vsize := dx; | |
| 930 | while sy in [proceduresy,functionsy] do procdeclaration; | |
| 931 | test([beginsy], blockbegsys+statbegsys, 56) | |
| 932 | until sy in statbegsys; | |
| 933 | tab[prt].adr := lc; | |
| 934 | insymbol; statement([semicolon,endsy]+fsys); | |
| 935 | while sy in [semicolon]+statbegsys do | |
| 936 | begin if sy = semicolon then insymbol else error(14); | |
| 937 | statement([semicolon,endsy]+fsys) | |
| 938 | end ; | |
| 939 | if sy = endsy then insymbol else error(57); | |
| 940 | test(fsys+[period], [], 6) | |
| 941 | end (*block*) ; | |
| 942 |