Edinburgh IMP77 Compiler - Version 8.4 1 !Graham Toal - new development version of SKIMPD 13/02/80 13.27 2 3 %const %string (1) snl = " 4+ " 5 6 %external %integer %array %spec a(1 : 500) 7 8 %external %byte %integer %array %spec named(1 : 1024) 9 10 %external %integer %array %spec namedlink(0 : 255) 11 12 %external %integer %array %spec taglink(0 : 255) 13 14 %external %integer %array %spec tag(1 : 512) 15 16 %external %integer %array %spec link(1 : 512) 17 18 %external %integer %array %spec nextrad(0 : 15) 19 20 %external %integer %array %spec rt(0 : 15) 21 22 %external %integer %array %spec parms(0 : 15) 23 24 %external %string (5) %array %spec display(0 : 15) 25 26 %external %integer faults = 0 27 %external %integer %spec tagasl, level, tagsopt, nextcad, namedp, %c 28+ traceopt, aopt, pstr 29 !----------------------------------------------------------------------- 30 %external %integer %fn %spec intstr(%string (6) val) 31 %external %routine %spec expr(%integer exprp) 32 %routine %spec popitem(%integer %name f, l) 33 ! Local 34 %external %integer %fn %spec outstream 35 !----------------------------------------------------------------------- 36 %own %integer %array used(0 : 15) = 0(*) 37 38 %own %integer %array worklist(0 : 15) = 0(16) 39 40 %own %integer %array namelist(0 : 15) = 0(16) 41 42 %own %integer %array branchlist(0 : 15) = 0(16) 43 44 %own %integer %array startlist(0 : 15) = 0(16) 45 46 %own %integer %array cot(0 : 127) 47 48 %own %integer cotp, params 49 !----------------------------------------------------------------------- 50 %external %string (255) %fn strint(%integer n, p) 51 %string (255) r 52 %string (1) s 53 %if n < 0 %then s = "-" %and n = -n %else s = "" 54 r = "" 55 r = tostring(n - n // 10 * 10 + '0') . r %and n = n // 10 %until n = 0 56 r = s . r 57 r = " " . r %while length(r) < p 58 %result = r 59 %end 60 !----------------------------------------------------------------------- 61 %external %string (7) %fn s(%integer i) 62 %result = strint(i, 0) 63 %end 64 !----------------------------------------------------------------------- 65 %external %string (8) %fn strhex(%integer n) 66 %const %string (1) %array h(0 : 15) = %c 67+ "0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "A", "B", "C", "D", "E", "F" 68 69 %integer i 70 %string (8) sh 71 sh = "" 72 %for i = 1, 1, 8 %cycle 73 sh = h(n & 16_F) . sh 74 n = n >> 4 75 %repeat 76 %result = sh 77 %end 78 !----------------------------------------------------------------------- 79 %external %routine fault(%string (63) mess) 80 %integer st 81 printstring("? " . mess . " 82+ 83+ ") 84 st = outstream 85 selectoutput(0) 86 printstring("*" . mess . snl) 87 selectoutput(st) 88 faults = faults + 1 89 %end 90 !----------------------------------------------------------------------- 91 %external %routine dump(%string (7) lab, op, reg, addr) 92 %own %string (7) label = "" 93 %routine %spec codeout(%string (7) l, o, r, a) 94 %if label # "" %start 95 %if lab = "" %then lab = label %else %start 96 codeout(label, "EQU", "", "*") 97 label = "" 98 %finish 99 %finish 100 %if (op = "ADD" %or op = "SUB" %or op = "EOR" %or op = "OR") %and addr = "#0" %then %return 101 %if (op = "AND" %or op = "LD") %and reg # "D" %and addr = "#0" %then op = "CLR" %and addr = "" 102 %if op = "ADD" %and addr = "#1" %and reg # "D" %then %start 103 op = "INC" 104 addr = "" 105 %finish 106 %if op = "SUB" %and addr = "#1" %and reg # "D" %then %start 107 op = "DEC" 108 addr = "" 109 %finish 110 %if op = "CMP" %and addr = "#0" %and reg # "D" %then op = "TST" %and addr = "" 111 %if op = "EQU" %and addr = "*" %then label = lab %c 112+ %else label = "" %and codeout(lab, op, reg, addr) 113 114 %routine codeout(%string (7) lab, op, reg, addr) 115 %string (6) nums 116 %integer i 117 %routine dump2(%string (7) lab, op, reg, addr) 118 %own %string (7) lastop = "silly" 119 %own %integer inhibit = 0 120 %if reg = "B" %and op = "LD" %and addr -> ("#") . nums %c 121+ %and (%not nums -> ("-") . nums) %and intstr(nums) > 255 %then reg = "D" 122 %if lab # "" %then %start 123 %if op = "EQU" %and addr = "*" %then inhibit = 0 124 %if op # "EQU" %then inhibit = 0 125 %finish 126 %if inhibit = 0 %or op = "EQU" %then %start 127 lastop = op 128 %return %if op = "TST" %and reg = "B" %and lab = "" 129 ! ****FRIG**** 130 %if op = "CMP" %and addr = "#1" %then addr = "" %and op = "DEC" 131 printstring(lab) 132 spaces(10 - length(lab)) 133 op = op . reg 134 printstring(op) 135 spaces(10 - length(op)) 136 printstring(addr) 137 newline 138 nextcad = nextcad + 1 139 %finish 140 %if op = "LBRA" %or op = "SWI2" %or (op = "SWI" %and reg = "2") %c 141+ %then inhibit = 1 142 %return %unless op = "LBSR" 143 %if addr = "SHL" %then used(12) = 1 144 %if addr = "SHR" %then used(13) = 1 145 %if addr = "EXP" %then used(14) = 1 146 %if addr = "DIV" %then used(15) = 1 147 %end 148 %own %string (7) %array l(1 : 2) = ""(2) 149 150 %own %string (7) %array o(1 : 2) = ""(2) 151 152 %own %string (7) %array r(1 : 2) = ""(2) 153 154 %own %string (7) %array a(1 : 2) = ""(2) 155 156 %own %integer buffptr = 0 157 %switch load(0:2) 158 %switch store(0:2) 159 %routine flushbuffer 160 %integer i 161 %for i = 1, 1, buffptr %cycle 162 dump2(l(i), o(i), r(i), a(i)) 163 %repeat 164 buffptr = 0 165 %end 166 %routine checklabel(%integer buff) 167 %if buff = 3 %then %start 168 %if lab # "" %then dump2(lab, "EQU", "", "*") 169 %return 170 %finish 171 %if l(buff) # "" %then dump2(l(buff), "EQU", "", "*") 172 %end 173 %routine savethisinstr 174 buffptr = buffptr + 1 175 %if buffptr > 2 %then %start 176 printstring("*?????Buffer full..." . snl) 177 flushbuffer 178 %finish 179 l(buffptr) = lab 180 o(buffptr) = op 181 r(buffptr) = reg 182 a(buffptr) = addr 183 %end 184 %if op = "SEX" %and buffptr # 0 %and o(buffptr) = "LD" %c 185+ %and a(buffptr) -> ("#") . nums %and (%not nums -> ("-") . nums) %c 186+ %and intstr(nums) > 255 %then %return 187 %if reg # "B" %then %start 188 flushbuffer 189 dump2(lab, op, reg, addr) 190 %return 191 %finish 192 %if op = "LD" %then %start 193 -> load(buffptr) 194 load(0): 195 savethisinstr 196 %return 197 load(1): 198 %if o(1) = "LD" %then checklabel(1) %and buffptr = 0 %else %start 199 %if o(1) = "ST" %and a(1) = addr %then %start 200 %if lab # "" %then %start 201 flushbuffer 202 savethisinstr 203 %return 204 %finish %else %return 205 %finish 206 %finish 207 savethisinstr 208 %return 209 load(2): 210 dump2(l(1), o(1), r(1), a(1)) 211 l(1) = l(2) 212 r(1) = r(2) 213 o(1) = o(2) 214 a(1) = a(2) 215 buffptr = 1 216 printstring("?***** Unexpected third el = load" . snl) 217 -> load(1) 218 %finish 219 %if op = "ST" %then %start 220 -> store(buffptr) 221 store(0): 222 savethisinstr 223 %return 224 store(1): 225 %if o(1) = "LD" %or o(1) = "ST" %then %start 226 %if a(1) = addr %then %start 227 %if lab # "" %then %start 228 flushbuffer 229 savethisinstr 230 %return 231 %finish %else %return 232 %finish %else %start 233 flushbuffer 234 savethisinstr 235 %return 236 %finish 237 %finish 238 %if o(1) = "CLR" %then %start 239 checklabel(1) 240 buffptr = 0 241 dump2(lab, "CLR", "", addr) 242 %return 243 %finish 244 flushbuffer 245 savethisinstr 246 %return 247 store(2): 248 %if o(1) = "LD" %and a(1) = addr %and (o(2) = "INC" %or o(2) = "DEC" %c 249+ %or o(2) = "NEG" %or o(2) = "COM") %then %start 250 checklabel(2) 251 checklabel(3) 252 dump2(l(1), o(2), "", addr) 253 buffptr = 0 254 %return 255 %finish 256 dump2(l(1), o(1), r(1), a(1)) 257 l(1) = l(2) 258 o(1) = o(2) 259 r(1) = r(2) 260 a(1) = a(2) 261 buffptr = 1 262 -> store(1) 263 %finish 264 %if op = "TST" %then %start 265 %if buffptr # 0 %then %start 266 %if o(buffptr) = "LD" %then %start 267 dump2(l(buffptr), op, "", a(buffptr)) 268 checklabel(3) 269 buffptr = buffptr - 1 270 %return 271 %finish 272 %finish 273 flushbuffer 274 dump2(lab, op, reg, addr) 275 %return 276 %finish 277 %if op = "INC" %or op = "DEC" %or op = "CLR" %or op = "NEG" %c 278+ %or op = "COM" %then %start 279 %if buffptr = 2 %then %start 280 dump2(l(1), o(1), r(1), a(1)) 281 l(1) = l(2) 282 o(1) = o(2) 283 r(1) = r(2) 284 a(1) = a(2) 285 l(2) = lab 286 o(2) = op 287 r(2) = reg 288 a(2) = addr 289 buffptr = 2 290 %return 291 %finish 292 savethisinstr 293 %return 294 %finish 295 flushbuffer 296 dump2(lab, op, reg, addr) 297 %end ?I unused 298 %end 299 !----------------------------------------------------------------------- 300 %external %string (255) %fn name(%integer ident) 301 %unless 0 <= ident <= 255 %and namedlink(ident) # 0 %then %result = "" 302 %result = string(addr(named(namedlink(ident)))) 303 %end 304 !----------------------------------------------------------------------- 305 %external %integer %fn newtag 306 %integer i 307 %if tagasl = 0 %then fault("TAG SPACE FULL") %and %stop 308 i = tagasl 309 tagasl = link(tagasl) 310 %result = i 311 %end 312 !----------------------------------------------------------------------- 313 %external %integer %fn returntag(%integer tagi) 314 %integer l 315 l = link(tagi) 316 link(tagi) = tagasl 317 tagasl = tagi 318 %result = l 319 %end 320 !----------------------------------------------------------------------- 321 %external %integer %fn getwork 322 !%integername cell 323 ! cell==worklist(level) 324 ! %while cell#0 %cycle 325 ! %if tag(cell)<0 %then tag(cell)=-tag(cell) %and %result=tag(cell) 326 ! cell==link(cell) 327 ! %repeat 328 ! cell=newtag 329 ! tag(cell)=nextrad(level) 330 ! nextrad(level)=nextrad(level)+1 331 ! link(cell)=0 332 ! %result=tag(cell) 333 %result = 0 334 %end 335 !----------------------------------------------------------------------- 336 %external %routine returnwork(%integer work) 337 !%integer cell 338 ! cell=worklist(level) 339 ! %while cell#0 %cycle 340 ! %if tag(cell)=work %then tag(cell)=-work %and %return 341 ! cell=link(cell) 342 ! %repeat 343 %end ?WORK unused 344 !----------------------------------------------------------------------- 345 %external %routine clearwork 346 %integer cell 347 cell = worklist(level) 348 cell = returntag(cell) %while cell # 0 349 worklist(level) = 0 350 %end 351 !----------------------------------------------------------------------- 352 %external %integer %fn getcoti(%integer const) 353 %integer coti 354 %if cotp > 0 %then %start 355 %for coti = 0, 1, cotp - 1 %cycle 356 %if cot(coti) = const %then %result = coti 357 %repeat 358 %finish 359 %if cotp = 128 %then fault("CONSTANT TABLE FULL") %and %stop 360 cot(cotp) = const 361 cotp = cotp + 1 362 %result = cotp - 1 363 %end 364 !----------------------------------------------------------------------- 365 %external %routine pushtag(%integer ident, form, type, dim, level, rad) 366 %integer tagi 367 %if taglink(ident) # 0 %and tag(taglink(ident)) >> 16 & 16_F = level %c 368+ %then fault("NAME " . name(ident) . " DECLARED TWICE") 369 tagi = newtag 370 tag(tagi) = form << 28 ! type << 24 ! dim << 20 ! level << 16 ! rad 371 link(tagi) = taglink(ident) 372 taglink(ident) = tagi 373 tagi = newtag 374 tag(tagi) = ident 375 link(tagi) = namelist(level) 376 namelist(level) = tagi 377 %end 378 !----------------------------------------------------------------------- 379 %external %routine poptags 380 %integer cell, ident, nametag, params 381 %string (63) s 382 %if tagsopt = 1 %then newline 383 cell = namelist(level) 384 %while cell # 0 %cycle 385 ident = tag(cell) 386 cell = returntag(cell) 387 nametag = tag(taglink(ident)) 388 taglink(ident) = returntag(taglink(ident)) 389 %if tagsopt = 1 %then %start 390 s = name(ident) 391 printstring(strint(ident, 3) . " " . s) 392 spaces(10 - length(s)) 393 printstring(strhex(nametag)) 394 %finish 395 %if nametag >> 28 = 4 %then %start 396 ! procedure type 397 params = nametag >> 20 & 16_F 398 %while params # 0 %cycle 399 %if tagsopt = 1 %then printstring(" 400+ " . strhex(tag(taglink(ident)))) 401 taglink(ident) = returntag(taglink(ident)) 402 params = params - 1 403 ! pop up parameter tags 404 %repeat 405 %finish 406 %if tagsopt = 1 %then newline 407 %if taglink(ident) = 0 %then namedp = namedlink(ident) %and namedlink(ident) = 0 408 ! backtrack name dictionary 409 %repeat 410 %if tagsopt = 1 %then newline 411 namelist(level) = 0 412 %end 413 !----------------------------------------------------------------------- 414 %external %integer %fn getlabel(%integer constp) 415 %integer label 416 label = a(constp + 1) 417 %if label > 9999 %then fault("LABEL " . strint(label, 1) . " TOO LARGE") %c 418+ %and %result = -1 %else %result = label 419 %end 420 !----------------------------------------------------------------------- 421 %external %routine filllabel(%integer label) 422 !%integer cell 423 %return %if label < 0 424 ! for conditional statements 425 ! cell=branchlist(level) 426 ! %while cell#0 %cycle 427 ! %if tag(cell)>>16=label %then %start 428 ! %if tag(cell)&16_8000=0 %then fault("DUPLICATE LABEL ". ! strint(label,1)) %else %start 429 dump("L" . s(label), "EQU", "", "*") 430 ! tag(cell)=label<<16!nextcad 431 ! %finish 432 ! %return 433 ! %finish 434 ! cell=link(cell) 435 ! %repeat 436 ! cell=newtag 437 ! link(cell)=branchlist(level) 438 ! branchlist(level)=cell 439 ! tag(cell)=label<<16!nextcad 440 %end 441 !----------------------------------------------------------------------- 442 %external %integer %fn fillbranch(%integer label) 443 %integer cell, cad 444 %result = 0 %if label < 0 445 cell = branchlist(level) 446 %while cell # 0 %cycle 447 %if tag(cell) >> 16 = label %then %start 448 cad = tag(cell) & 16_7FFF 449 %if tag(cell) & 16_8000 # 0 %then tag(cell) = label << 16 ! 16_8000 ! nextcad 450 %result = cad 451 %finish 452 cell = link(cell) 453 %repeat 454 cell = newtag 455 link(cell) = branchlist(level) 456 branchlist(level) = cell 457 tag(cell) = label << 16 ! 16_8000 ! nextcad 458 %result = 0 459 %end 460 !----------------------------------------------------------------------- 461 %external %routine poplabels 462 %integer cell 463 cell = branchlist(level) 464 %while cell # 0 %cycle 465 %if tag(cell) & 16_8000 # 0 %then fault("LABEL " . strint(tag(cell) >> 16, 1) . %c 466+ " NOT SET (BRANCH LIST " . strint(tag(cell) & 16_7FFF, 1) . ")") 467 cell = returntag(cell) 468 %repeat 469 branchlist(level) = 0 470 %end 471 !----------------------------------------------------------------------- 472 %external %integer %fn nextplabel 473 %own %integer plabel = 9999 474 plabel = plabel + 1 475 %result = plabel 476 %end 477 !----------------------------------------------------------------------- 478 %external %routine pushstart(%integer flag, plab) 479 %integer cell 480 cell = newtag 481 tag(cell) = flag << 16 ! plab & 16_FFFF 482 ! plab may be -1 483 link(cell) = startlist(level) 484 startlist(level) = cell 485 %end 486 %external %predicate find(%integer type, %integer %name t, lab) 487 %integer cell 488 cell = startlist(level) 489 %while cell # 0 %cycle 490 t = tag(cell) >> 16 491 %if t & 2 = type %then %start 492 lab = tag(cell) & 16_FFFF 493 %true 494 %finish 495 cell = link(cell) 496 %repeat 497 t = 0 498 lab = 0 499 %false 500 %end 501 %external %routine findcontinue(%integer %name type, lab) 502 %if find(2, type, lab) %then lab = lab + 1 %c 503+ %else type = 0 %and lab = 0 %and fault("%CYCLE MISSING") 504 %end 505 %external %routine findexit(%integer %name type, lab) 506 %if find(2, type, lab) %then lab = lab + 2 %c 507+ %else type = 0 %and lab = 0 %and fault("%CYCLE MISSING") 508 %end 509 %predicate findcycle 510 %integer t, l 511 %if find(2, t, l) %then %true 512 %false 513 %end 514 %predicate findstart 515 %integer t, l 516 %if find(0, t, l) %then %true 517 %false 518 %end 519 %external %routine popcycle(%integer %name type, lab) 520 popitem(type, lab) 521 %if type & 2 = 0 %then %start 522 %if findcycle %then %start 523 fault("%FINISH MISSING {Or spurious %REPEAT??}") 524 %finish %else %start 525 fault("SPURIOUS %REPEAT") 526 pushstart(type, lab) %if lab # 0 527 %finish 528 lab = 0 529 type = 3 530 %finish 531 %end 532 %external %routine popstart(%integer %name type, lab) 533 popitem(type, lab) 534 %if type & 2 = 2 %or lab = 0 %then %start 535 %if findstart %then %start 536 fault("%REPEAT MISSING {Or spurious %FINISH??}") 537 %finish %else %start 538 fault("SPURIOUS %FINISH") 539 pushstart(type, lab) %if lab # 0 540 %finish 541 lab = 0 542 type = 0 543 %finish 544 %end 545 !----------------------------------------------------------------------- 546 %routine popitem(%integer %name flag, plab) 547 %integer cell 548 cell = startlist(level) 549 %if cell = 0 %then %start 550 flag = 0 551 plab = 0 552 %finish %else %start 553 flag = tag(cell) >> 16 554 plab = tag(cell) & 16_FFFF 555 %if plab = 16_FFFF %then plab = -1 556 startlist(level) = returntag(cell) 557 %finish 558 %end 559 !----------------------------------------------------------------------- 560 %external %routine clearstart 561 %integer cell 562 %const %string (7) %array what(0 : 1) = "%FINISH", "%REPEAT" 563 564 cell = startlist(level) 565 %while cell # 0 %cycle 566 fault(what(tag(cell) >> 17) . " MISSING") 567 cell = returntag(cell) 568 %repeat 569 startlist(level) = 0 570 %end 571 !----------------------------------------------------------------------- 572 %external %integer %fn enter 573 %own %string (4) %array regs(1 : 2) = "A", "A,B" 574 575 %string (4) base 576 %integer alloc, dim 577 %if level = 1 %then %start 578 %if nextcad # 1 %then fault("%BEGIN NOT FIRST STATEMENT") 579 dump("", "ORG", "", "$F800") 580 dump("START", "EQU", "", "*") 581 dump("", "SWI", "3", "") %if traceopt = 1 582 dump("", "LD", "U", "#STACK") 583 dump("", "LEA", "X", "-USTK,U") 584 base = ",X" 585 alloc = 34 586 ! Already set up by calling program 587 ! Rest for I/O buffers and perm locations. 588 %finish %else %start 589 ! STORE STP (=Y) IF NECCESARY 590 %if level > 2 %start 591 dump("", "ST", "Y", display(level - 1)) 592 %finish 593 dump("", "PSH", "S", "Y") 594 dump("", "TFR", "", "S,Y") 595 alloc = 0 596 base = ",Y" 597 %finish 598 ! cad=nextcad 599 %if level # 1 %then %start 600 ! REMOVED TO 'SKIMPB' 601 %finish %else %start 602 dump("", "LEA", "S", "-A" . s(rt(level)) . ",X") 603 %finish 604 nextrad(level) = alloc 605 %result = alloc 606 %end ?DIM unused ?REGS unused 607 !----------------------------------------------------------------------- 608 %external %routine dumpreturn 609 dump("", "TFR", "", "Y,S") 610 dump("", "PUL", "S", "Y,PC") 611 %end 612 !----------------------------------------------------------------------- 613 %external %routine array(%integer arrayp) 614 %integer namep, actualp, exprp, exprsp, ident, nametag, basep, disp 615 %string (4) base 616 namep = a(arrayp + 1) 617 actualp = a(arrayp + 2) 618 ident = a(namep + 1) 619 %if a(actualp) = 1 %then %start 620 dump(" ", "CLR", "A", "") 621 dump("", "ANDCC", "", "0") 622 exprp = a(actualp + 1) 623 exprsp = a(actualp + 2) 624 expr(exprp) 625 nametag = tag(taglink(ident)) 626 basep = nametag >> 16 & 16_F 627 base = display(basep) 628 base = ",Y" %if basep = level 629 base = ",X" %if basep = 1 630 disp = nametag & 16_FFFF 631 dump("", "BCC", "", "*+3") 632 dump("", "INC", "A", "") 633 %if basep = 1 %or basep = level %start 634 dump("", "ADD", "D", "-" . s(disp) . base) 635 %finish %else %start 636 dump("", "PSH", "U", "A,B") 637 dump("", "LD", "D", display(basep)) 638 dump("", "SUB", "D", "#" . s(disp)) 639 dump("", "ST", "D", "0,X") 640 dump("", "LD", "D", "[0,X]") 641 dump("", "ADD", "D", ",U++") 642 %finish 643 dump("", "ST", "D", "0,X") %if aopt = 0 644 aopt = 0 645 ! dump("ADD","ACC",display(nametag>>16&16_f),nametag&16_ffff) 646 %if a(exprsp) = 1 %then fault("ARRAY " . name(ident) . " HAS EXTRA INDEX") 647 %finish %else fault("ARRAY " . name(ident) . " HAS NO INDEX") 648 %end 649 !----------------------------------------------------------------------- 650 %external %routine proc(%integer procp) 651 %string (4) opn, base, reg 652 %integer namep, ident, nametag, ptagl, l, actualp, exprp, unaryp, operandp, %c 653+ npars, ptag, pnamep, pident, pnametag, pactualp, disp, exprrestp, exprsp, %c 654+ oldparams, basep, size 655 ! %if params>2 %then dump("LDA","STP","STP",params) 656 !***! hack !***! 657 %if params >= 2 %then dump("", "LEA", "S", "-" . s(params + 1) . ",S") 658 !***! hack !***! 659 oldparams = params 660 params = 4 661 namep = a(procp + 1) 662 actualp = a(procp + 2) 663 ident = a(namep + 1) 664 l = taglink(ident) 665 nametag = tag(l) 666 ptagl = link(l) 667 npars = nametag >> 20 & 16_F 668 %if npars = 0 %then %start 669 %if a(actualp) = 1 %then fault(name(ident) . " HAS PARAMETERS") %and %return 670 %finish %else %start 671 %if a(actualp) = 2 %then fault(name(ident) . " MISSING PARAMETERS") %and %return 672 exprp = a(actualp + 1) 673 exprsp = a(actualp + 2) 674 %cycle 675 ! for each parameter 676 ptag = tag(ptagl) 677 %if ptag >> 28 = 0 %then expr(exprp) %and reg = "B" %else %start 678 reg = "D" 679 unaryp = a(exprp + 1) 680 operandp = a(exprp + 2) 681 exprrestp = a(exprp + 3) 682 %unless a(unaryp) = 4 %and a(operandp) = 1 %and a(exprrestp) = 2 %c 683+ %then fault("NOT A %NAME PARAMETER") %else %start 684 pnamep = a(operandp + 1) 685 pactualp = a(operandp + 2) 686 pident = a(pnamep + 1) 687 !? %if taglink(pident)=0 %then fault(name(pident). !? " NOT DECLARED") %else %start 688 %if taglink(pident) = 0 %then %start 689 dump("", "LD", "B", name(pident)) 690 %finish %else %start 691 pnametag = tag(taglink(pident)) 692 %if pnametag >> 28 = 4 %then fault(name(pident) . " NOT A %NAME") %else %start 693 basep = pnametag >> 16 & 16_F 694 base = display(basep) 695 disp = pnametag & 16_FFFF 696 base = "Y" %if basep = level 697 base = "X" %if basep = 1 698 %if ptag >> 28 = 1 %then %start 699 ! %name 700 %if pnametag >> 28 >= 2 %then aopt = 1 %and array(operandp) %else %start 701 %if pnametag >> 28 = 1 %then %start 702 %if 1 < basep < level %start 703 dump("", "LD", reg, base) 704 dump("", "SUB", reg, "#" . s(disp)) 705 dump("", "ST", reg, "0,X") 706 dump("", "LD", reg, "[0,X]") 707 %finish %else %start 708 dump("", "LD", reg, "-" . s(disp) . "," . base) 709 %finish 710 %finish %else %start 711 %if 1 < basep < level %start 712 dump("", "LD", reg, base) 713 dump("", "SUB", reg, "#" . s(disp)) 714 %finish %else %start 715 %if basep = 1 = level %then %start 716 dump("", "LEA", "Y", "-" . s(disp) . ",X") 717 reg = "Y" 718 %finish %else %start 719 dump("", "TFR", "", base . ",D") 720 dump("", "SUB", reg, "#" . s(disp)) 721 %finish 722 ! GET ADDRESS OF A %NAME INTO B 723 %finish 724 %finish 725 ! CHECK FOR SILLY BASE REGISTER 726 ! dump(opn,"ACC",base,disp) 727 %if a(pactualp) = 1 %then fault(name(pident) . " DECLARED AS SCALAR") 728 %finish 729 %finish %else %start 730 ! dump("LOAD","ACC",base,disp) ;! %array 731 %if base = "Y" %or base = "X" %start 732 dump("", "LD", reg, "-" . s(disp) . "," . base) 733 %finish %else %start 734 dump("", "LD", reg, base) 735 dump("", "SUB", reg, "#" . s(disp)) 736 dump("", "ST", reg, "0,X") 737 dump("", "LD", reg, "[0,X]") 738 %finish 739 ! CHECK SILLY BASE REGISTER 740 %if a(pactualp) = 1 %then fault("%ARRAYNAME " . name(pident) . " HAS INDEX") 741 %finish 742 %finish 743 %finish 744 %finish 745 %finish 746 ! dump("STR","ACC","STP",params) 747 %if reg = "D" %or reg = "Y" %then size = 2 %else size = 1 748 params = params + size 749 dump("", "ST", reg, "-" . s(params) . ",S") 750 npars = npars - 1 751 %if npars = 0 %then %start 752 %if a(exprsp) = 1 %then fault(name(ident) . " HAS EXTRA PARAMETERS") 753 %exit 754 %finish 755 ptagl = link(ptagl) 756 %if a(exprsp) = 2 %then fault(name(ident) . " IS MISSING PARAMETERS") %and %exit 757 exprp = a(exprsp + 1) 758 exprsp = a(exprsp + 2) 759 %repeat 760 %finish 761 ! external i/o routines at level 0 762 %if nametag >> 16 & 16_F = 0 %then base = "EXT" %else base = "E" 763 %if nametag >> 16 & 16_F = 0 %then %start 764 used(nametag & 16_F) = 1 765 %finish 766 dump("", "LBSR", "", base . s(nametag & 16_FFFF)) 767 params = oldparams 768 ! EH?????? 769 !***! frig !***! 770 %if params >= 2 %then dump("", "LEA", "S", s(params + 1) . ",S") 771 ! %if params>2 %then dump("SUB","STP","COT",getcoti(params)) 772 %end ?OPN unused 773 !----------------------------------------------------------------------- 774 %external %routine endofprog 775 %integer i 776 dump("", "SWI", "2", "") 777 dump("STACK", "EQU", "", "$0800-1") 778 dump("USTK", "EQU", "", "$20") 779 ! DUMP("EXT1","EQU","","") %IF USED(1)=1 780 ! DUMP("EXT2","EQU","","") %IF USED(2)=1 781 ! DUMP("EXT3","EQU","","") %IF USED(3)=1 782 ! DUMP("EXT4","EQU","","") %IF USED(4)=1 783 ! DUMP("EXT5","EQU","","") %IF USED(5)=1 784 ! DUMP("EXT6","EQU","","") %IF USED(6)=1 785 ! DUMP("EXT7","EQU","","") %IF USED(7)=1 786 ! DUMP("EXT8","EQU","","") %IF USED(8)=1 787 ! DUMP("EXT9","EQU","","") %IF USED(9)=1 788 ! DUMP("EXT10","EQU","","") %IF USED(10)=1 789 !! READSYMBOL POSING AS READ 790 ! DUMP("EXT11","EQU","","") %AND USED(15)=1 %IF USED(11)=1 791 %if used(12) = 1 %then %start 792 dump("DOSHL", "LSL", "B", "") 793 dump("", "SUB", "A", "#1") 794 dump("SHL", "CMP", "A", "#0") 795 dump("", "BGT", "", "DOSHL") 796 dump("", "RTS", "", "") 797 %finish 798 %if used(13) = 1 %then %start 799 dump("DOSHR", "LSR", "B", "") 800 dump("", "SUB", "A", "#1") 801 dump("SHR", "CMP", "A", "#0") 802 dump("", "BGT", "", "DOSHR") 803 dump("", "RTS", "", "") 804 %finish 805 %if used(14) = 1 %then %start 806 dump("EXP", "PSH", "S", "B") 807 dump("EXP2", "CMP", "A", "#1") 808 dump("", "BGT", "", "DOEXP") 809 dump("", "LEA", "S", "1,S") 810 dump("", "RTS", "", "") 811 dump("DOEXP", "PSH", "U", "A") 812 dump("", "LDA", "", "0,S") 813 dump("", "MUL", "", "") 814 dump("", "PUL", "U", "A") 815 dump("", "SUB", "A", "#1") 816 dump("", "BRA", "", "EXP2") 817 %finish 818 %if used(15) = 1 %then %start 819 ! 'B'//'A' 820 dump("DIV", "EQU", "", "*") 821 dump("", "CLR", "", "-1,S") 822 dump("", "CLR", "", "-2,S") 823 dump("", "INC", "", "-2,S") 824 dump("", "TST", "B", "") 825 dump("", "BGE", "", "TRYA") 826 dump("", "NEG", "B", "") 827 dump("", "CLR", "", "-2,S") 828 dump("TRYA", "TST", "A", "") 829 dump("", "BGE", "", "OK") 830 dump("", "NEG", "A", "") 831 dump("", "TST", "", "-2,S") 832 dump("", "BNE", "", "OK") 833 dump("", "INC", "", "-2,S") 834 dump("OK", "TST", "B", "") 835 dump("", "BLT", "", "DONE") 836 dump("", "INC", "", "-1,S") 837 dump("", "PSH", "U", "A") 838 dump("", "SUB", "B", ",U+") 839 dump("", "BRA", "", "OK") 840 dump("DONE", "DEC", "", "-1,S") 841 dump("", "TST", "", "-2,S") 842 dump("", "BNE", "", "RET") 843 dump("", "NEG", "", "-1,S") 844 dump("RET", "LD", "B", "-1,S") 845 dump("", "RTS", "", "") 846 %finish %else dump("DIV", "EQU", "", "0") 847 ! newline 848 %if pstr # 0 %then %start 849 dump("OUTCH", "LD", "A", "ACIAS") 850 dump("", "AND", "A", "#2") 851 dump("", "BEQ", "", "OUTCH") 852 dump("", "ST", "B", "ACIAD") 853 dump("WAITX", "LD", "B", "#$FF") 854 dump("", "DEC", "B", "") 855 dump("", "BNE", "", "WAITX") 856 dump("PSTR", "LD", "B", "[0,S]") 857 dump("", "INC", "", "1,S") 858 dump("", "BNE", "", "NOCAR") 859 dump("", "INC", "", "0,S") 860 dump("NOCAR", "CMP", "B", "#$80") 861 dump("", "BNE", "", "OUTCH") 862 dump("", "RTS", "", "") 863 %finish 864 %if faults > 0 %start 865 %begin 866 %integer st 867 st = outstream 868 selectoutput(0) 869 printstring("Program contains " . s(faults) . " fault") 870 printsymbol('s') %if faults > 1 871 newline 872 selectoutput(st) 873 %end 874 %finish 875 newline 876 %if faults > 0 %then printstring("?" . strint(faults, 4)) %else printstring("*NO") 877 printstring(" FAULT") 878 printsymbol('S') %if faults # 1 879 printstring(" IN THIS PROGRAM 880+ ") 881 %signal %event 13 882 ! Not again!!! 883 %end ?I unused 884 %end %of %file 724 Statements compiled