├── .gitignore ├── README.txt ├── btran ├── Makefile └── btran.c ├── doc ├── bcpl4raspi.pdf ├── bcplman.pdf └── ocode-intcode.pdf ├── gen-intcode ├── Makefile └── gen-intcode.c ├── intcode ├── Makefile ├── blib.c ├── blib.h └── intcode.c ├── test-codegen ├── Makefile ├── bcpl-tran ├── cmpltest.b ├── cmpltest.bcpl └── iclib.intcode ├── test-hello ├── Makefile ├── bcpl-tran ├── hello.b ├── hello.bcpl └── iclib.intcode └── test-tran ├── LIBHDR ├── Makefile ├── SYNHDR ├── TRNHDR ├── bcpl-tran ├── blib.b ├── blib.bcpl ├── iclib.intcode ├── syn.b ├── syn.bcpl ├── trn.b └── trn.bcpl /.gitignore: -------------------------------------------------------------------------------- 1 | # Object files 2 | *.o 3 | 4 | # Libraries 5 | *.lib 6 | *.a 7 | 8 | # Shared objects (inc. Windows DLLs) 9 | *.dll 10 | *.so 11 | *.so.* 12 | *.dylib 13 | 14 | # Executables 15 | *.exe 16 | *.out 17 | *.app 18 | -------------------------------------------------------------------------------- /README.txt: -------------------------------------------------------------------------------- 1 | BCPL compiler 2 | = 3 | 4 | Based on legacy BCPL sources, restored by Robert Nordier, www.nordier.com. 5 | -------------------------------------------------------------------------------- /btran/Makefile: -------------------------------------------------------------------------------- 1 | CC = cc -m32 2 | CFLAGS = -g -O1 -Wall -Werror 3 | LDFLAGS = -g 4 | 5 | PREFIX = /usr/local 6 | 7 | all: btran 8 | 9 | # 10 | # B-to-ocode translator 11 | # 12 | btran: btran.o 13 | $(CC) $(LDFLAGS) -o btran btran.o 14 | 15 | # 16 | # Installation 17 | # 18 | install: btran 19 | -mkdir $(PREFIX)/lib/bcpl 20 | install -c btran $(PREFIX)/lib/bcpl/btran 21 | 22 | clean: 23 | rm -f OCODE INTCODE ASM *.o *.int btran 24 | -------------------------------------------------------------------------------- /doc/bcpl4raspi.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sergev/bcpl-compiler/99b1209fb83e7cb30922e8b972609983dadf4e52/doc/bcpl4raspi.pdf -------------------------------------------------------------------------------- /doc/bcplman.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sergev/bcpl-compiler/99b1209fb83e7cb30922e8b972609983dadf4e52/doc/bcplman.pdf -------------------------------------------------------------------------------- /doc/ocode-intcode.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sergev/bcpl-compiler/99b1209fb83e7cb30922e8b972609983dadf4e52/doc/ocode-intcode.pdf -------------------------------------------------------------------------------- /gen-intcode/Makefile: -------------------------------------------------------------------------------- 1 | CC = cc -m32 2 | CFLAGS = -g -O1 -Wall -Werror 3 | LDFLAGS = -g 4 | 5 | PREFIX = /usr/local 6 | 7 | all: gen-intcode 8 | 9 | # 10 | # Intcode generator, native 11 | # 12 | gen-intcode: gen-intcode.o 13 | $(CC) $(LDFLAGS) -o $@ $< 14 | 15 | clean: 16 | rm -f OCODE INTCODE ASM *.o *.int gen-intcode 17 | -------------------------------------------------------------------------------- /gen-intcode/gen-intcode.c: -------------------------------------------------------------------------------- 1 | /* 2 | * OCODE to INTCODE generator rewritten to C. 3 | * Based on BCPL sources from Robert Nordier, www.nordier.com. 4 | * 5 | * Copyright (C) 2013 Serge Vakulenko 6 | * 7 | * It is free software; you can redistribute it and/or modify it 8 | * under the terms of the "Artistic License". 9 | */ 10 | #include 11 | #include 12 | 13 | // 14 | // OCODE operators 15 | // 16 | #define S_TRUE 4 17 | #define S_FALSE 5 18 | #define S_RV 8 19 | #define S_FNAP 10 20 | #define S_MULT 11 21 | #define S_DIV 12 22 | #define S_REM 13 23 | #define S_PLUS 14 24 | #define S_MINUS 15 25 | #define S_QUERY 16 26 | #define S_NEG 17 27 | #define S_EQ 20 28 | #define S_NE 21 29 | #define S_LS 22 30 | #define S_GR 23 31 | #define S_LE 24 32 | #define S_GE 25 33 | #define S_NOT 30 34 | #define S_LSHIFT 31 35 | #define S_RSHIFT 32 36 | #define S_LOGAND 33 37 | #define S_LOGOR 34 38 | #define S_EQV 35 39 | #define S_NEQV 36 40 | #define S_COND 37 41 | #define S_LP 40 42 | #define S_LG 41 43 | #define S_LN 42 44 | #define S_LSTR 43 45 | #define S_LL 44 46 | #define S_LLP 45 47 | #define S_LLG 46 48 | #define S_LLL 47 49 | 50 | #define S_RTAP 51 51 | #define S_GOTO 52 52 | #define S_RETURN 67 53 | #define S_FINISH 68 54 | #define S_SWITCHON 70 55 | #define S_GLOBAL 76 56 | 57 | #define S_SP 80 58 | #define S_SG 81 59 | #define S_SL 82 60 | #define S_STIND 83 61 | #define S_JUMP 85 62 | #define S_JT 86 63 | #define S_JF 87 64 | #define S_LAB 90 65 | #define S_STACK 91 66 | #define S_STORE 92 67 | #define S_RSTACK 93 68 | #define S_ENTRY 94 69 | #define S_SAVE 95 70 | #define S_FNRN 96 71 | #define S_RTRN 97 72 | #define S_RES 98 73 | #define S_RESLAB 99 74 | #define S_DATALAB 100 75 | #define S_ITEML 101 76 | #define S_ITEMN 102 77 | #define S_ENDPROC 103 78 | #define S_END 104 79 | #define S_CHAR 105 80 | #define ERROR 108 81 | #define S_DEBUG 109 82 | 83 | #define M_N 0 84 | #define M_I 1 85 | #define M_P 2 86 | #define M_IP 3 87 | #define M_L 4 88 | #define M_IL 5 89 | #define M_G 6 90 | #define M_IG 7 91 | 92 | #define F_L 'L' 93 | #define F_S 'S' 94 | #define F_A 'A' 95 | #define F_J 'J' 96 | #define F_T 'T' 97 | #define F_F 'F' 98 | #define F_K 'K' 99 | #define F_X 'X' 100 | #define F_D 'D' 101 | #define F_C 'C' 102 | 103 | #define TRUE -1 104 | #define FALSE 0 105 | #define NIL 0 106 | #define AD 1 107 | #define AC 2 108 | #define ACAD 3 109 | 110 | int ch; 111 | int *wordv; 112 | int ssp; 113 | int state; 114 | int ad_a; 115 | int ad_k; 116 | int *datav; 117 | int datap; 118 | int datat; 119 | int proglength; 120 | int linep; 121 | int param; 122 | int op; 123 | 124 | static int wp = 0; 125 | static int strsize = 0; 126 | 127 | void putbyte(s, i, c) 128 | int *s; 129 | { 130 | int shift = (i & 3) << 3; 131 | s += i >> 2; 132 | int w = *s & ~(0xff << shift); 133 | *s = w | (c << shift); 134 | } 135 | 136 | int packstring(src, dest) 137 | int *src, *dest; 138 | { 139 | int i, c; 140 | 141 | for (i=0; (c = src[i]); i++) { 142 | putbyte(dest, i, c); 143 | } 144 | do { 145 | putbyte(dest, i++, 0); 146 | } while (i & 3); 147 | return i >> 2; 148 | } 149 | 150 | int t(str) 151 | char *str; 152 | { 153 | #if 1 154 | return strcmp (str, (char*) wordv) == 0; 155 | #else 156 | int i; 157 | int *s = (int*)str; 158 | 159 | for (i = 0; i < strsize; i++) 160 | if (s[i] != wordv[i]) 161 | return FALSE; 162 | return TRUE; 163 | #endif 164 | } 165 | 166 | int readop() 167 | { 168 | int s [20]; 169 | 170 | do { 171 | ch = getchar(); 172 | } while (ch == '\n' || ch == ' '); 173 | wp = 0; 174 | 175 | while ('A' <= ch && ch <= 'Z') { 176 | s[wp] = ch; 177 | wp = wp + 1; 178 | ch = getchar(); 179 | } 180 | 181 | s[wp] = 0; 182 | strsize = packstring(s, wordv); 183 | 184 | switch (s[0]) { 185 | default: 186 | if (ch == EOF) 187 | return S_END; 188 | return ERROR; 189 | 190 | case 'D': 191 | return t("DATALAB") ? S_DATALAB : 192 | t("DIV") ? S_DIV : 193 | t("DEBUG") ? S_DEBUG : ERROR; 194 | 195 | case 'E': 196 | return t("EQ") ? S_EQ : 197 | t("ENTRY") ? S_ENTRY : 198 | t("EQV") ? S_EQV : 199 | t("ENDPROC") ? S_ENDPROC : 200 | t("END") ? S_END : ERROR; 201 | 202 | case 'F': 203 | return t("FNAP") ? S_FNAP : 204 | t("FNRN") ? S_FNRN : 205 | t("FALSE") ? S_FALSE : 206 | t("FINISH") ? S_FINISH : ERROR; 207 | 208 | case 'G': 209 | return t("GOTO") ? S_GOTO : 210 | t("GE") ? S_GE : 211 | t("GR") ? S_GR : 212 | t("GLOBAL") ? S_GLOBAL : ERROR; 213 | 214 | case 'I': 215 | return t("ITEMN") ? S_ITEMN : 216 | t("ITEML") ? S_ITEML : ERROR; 217 | 218 | case 'J': 219 | return t("JUMP") ? S_JUMP : 220 | t("JF") ? S_JF : 221 | t("JT") ? S_JT : ERROR; 222 | 223 | case 'L': 224 | if (wp == 2) { 225 | switch (s[1]) { 226 | default: return ERROR; 227 | case 'E': return S_LE; 228 | case 'N': return S_LN; 229 | case 'G': return S_LG; 230 | case 'P': return S_LP; 231 | case 'L': return S_LL; 232 | case 'S': return S_LS; 233 | } 234 | } 235 | return t("LAB") ? S_LAB : 236 | t("LLG") ? S_LLG : 237 | t("LLL") ? S_LLL : 238 | t("LLP") ? S_LLP : 239 | t("LOGAND") ? S_LOGAND : 240 | t("LOGOR") ? S_LOGOR : 241 | t("LSHIFT") ? S_LSHIFT : 242 | t("LSTR") ? S_LSTR : ERROR; 243 | 244 | case 'M': 245 | return t("MINUS") ? S_MINUS : 246 | t("MULT") ? S_MULT : ERROR; 247 | 248 | case 'N': 249 | return t("NE") ? S_NE : 250 | t("NEG") ? S_NEG : 251 | t("NEQV") ? S_NEQV : 252 | t("NOT") ? S_NOT : ERROR; 253 | 254 | case 'P': 255 | return t("PLUS") ? S_PLUS : ERROR; 256 | 257 | case 'Q': 258 | return t("QUERY") ? S_QUERY : ERROR; 259 | 260 | case 'R': 261 | return t("RES") ? S_RES : 262 | t("REM") ? S_REM : 263 | t("RTAP") ? S_RTAP : 264 | t("RTRN") ? S_RTRN : 265 | t("RSHIFT") ? S_RSHIFT : 266 | t("RSTACK") ? S_RSTACK : 267 | t("RV") ? S_RV : ERROR; 268 | 269 | case 'S': 270 | return t("SG") ? S_SG : 271 | t("SP") ? S_SP : 272 | t("SL") ? S_SL : 273 | t("STIND") ? S_STIND : 274 | t("STACK") ? S_STACK : 275 | t("SAVE") ? S_SAVE : 276 | t("SWITCHON") ? S_SWITCHON : 277 | t("STORE") ? S_STORE : ERROR; 278 | 279 | case 'T': 280 | return t("TRUE") ? S_TRUE : ERROR; 281 | } 282 | } 283 | 284 | int rdn() 285 | { 286 | int a = 0; 287 | int neg = FALSE; 288 | 289 | do { 290 | ch = getchar(); 291 | } while (ch == '\n' || ch == ' '); 292 | 293 | if (ch == '-') { 294 | neg = TRUE; 295 | ch = getchar(); 296 | } 297 | 298 | while ('0' <= ch && ch <= '9') { 299 | a = a*10 + ch - '0'; 300 | ch = getchar(); 301 | } 302 | 303 | return neg ? -a : a; 304 | } 305 | 306 | int rdl() 307 | { 308 | int a = 0; 309 | 310 | do { 311 | ch = getchar(); 312 | } while (ch == '\n' || ch == ' '); 313 | 314 | if (ch == 'L') { 315 | ch = getchar(); 316 | } 317 | 318 | while ('0' <= ch && ch <= '9') { 319 | a = a*10 + ch - '0'; 320 | ch = getchar(); 321 | } 322 | 323 | return a; 324 | } 325 | 326 | void wr(ch) 327 | { 328 | if (ch == '\n') { 329 | putchar('\n'); 330 | linep = 0; 331 | return; 332 | } 333 | 334 | if (linep == 71) { 335 | putchar('/'); 336 | putchar('\n'); 337 | linep = 0; 338 | } 339 | linep = linep + 1; 340 | putchar(ch); 341 | } 342 | 343 | void wrn(n) 344 | { 345 | if (n < 0) { 346 | wr('-'); 347 | n = -n; 348 | } 349 | if (n > 9) { 350 | wrn(n/10); 351 | } 352 | wr(n % 10 + '0'); 353 | } 354 | 355 | void code(f, a, k) 356 | { 357 | wr(f); 358 | switch (k) { 359 | case M_I: wr('I'); 360 | case M_N: break; 361 | 362 | case M_IG: wr('I'); 363 | case M_G: wr('G'); break; 364 | 365 | case M_IP: wr('I'); 366 | case M_P: wr('P'); break; 367 | 368 | case M_IL: wr('I'); 369 | case M_L: wr('L'); break; 370 | } 371 | 372 | wrn(a); 373 | wr(' '); 374 | proglength = proglength + 1; 375 | } 376 | 377 | void force_nil() 378 | { 379 | switch (state) { 380 | case ACAD: code(F_S, ssp-2, M_P); 381 | case AD: code(F_L, ad_a, ad_k); 382 | case AC: code(F_S, ssp-1, M_P); 383 | state = NIL; 384 | case NIL: ; 385 | } 386 | } 387 | 388 | void force_ad() 389 | { 390 | switch (state) { 391 | case ACAD: code(F_S, ssp-2, M_P); 392 | goto L; 393 | case AC: code(F_S, ssp-1, M_P); 394 | case NIL: ad_a = ssp-1; 395 | ad_k = M_IP; 396 | L: state = AD; 397 | case AD: ; 398 | } 399 | } 400 | 401 | void force_ac() 402 | { 403 | switch (state) { 404 | case NIL: code(F_L, ssp-1, M_IP); 405 | goto L; 406 | case ACAD: code(F_S, ssp-2, M_P); 407 | case AD: code(F_L, ad_a, ad_k); 408 | L: state = AC; 409 | case AC: ; 410 | } 411 | } 412 | 413 | void force_acad() 414 | { 415 | switch (state) { 416 | case AD: code(F_L, ssp-2, M_IP); 417 | goto L; 418 | case AC: code(F_S, ssp-1, M_P); 419 | case NIL: code(F_L, ssp-2, M_IP); 420 | ad_a = ssp-1; 421 | ad_k = M_IP; 422 | L: state = ACAD; 423 | case ACAD: ; 424 | } 425 | } 426 | 427 | void load(a, k) 428 | { 429 | switch (state) { 430 | case NIL: state = AD; 431 | goto M; 432 | case ACAD: 433 | case AD: force_ac(); 434 | case AC: state = ACAD; 435 | M: ad_a = a; 436 | ad_k = k; 437 | ssp = ssp + 1; 438 | } 439 | } 440 | 441 | void storein(a, k) 442 | { 443 | force_ac(); 444 | code(F_S, a, k); 445 | ssp = ssp-1; 446 | state = NIL; 447 | } 448 | 449 | int nextparam() 450 | { 451 | param = param - 1; 452 | return param; 453 | } 454 | 455 | void data(k, v) 456 | { 457 | int p = datap; 458 | 459 | datav[p] = k; 460 | datav[p+1] = v; 461 | datap = datap + 2; 462 | if (datap > datat) { 463 | fprintf(stderr, "Too many constants!\n"); 464 | datap = 0; 465 | } 466 | } 467 | 468 | void cgstring(n) 469 | { 470 | int l = nextparam(); 471 | int i; 472 | 473 | data(S_DATALAB, l); 474 | data(S_CHAR, n); 475 | for (i = 0; i < n; i++) { 476 | data(S_CHAR, rdn()); 477 | } 478 | load(l, M_L); 479 | } 480 | 481 | void complab(n) 482 | { 483 | wrn(n); 484 | wr(' '); 485 | } 486 | 487 | void wrdata(k, n) 488 | { 489 | switch (k) { 490 | case S_DATALAB: complab(n); return; 491 | case S_ITEMN: code(F_D, n, M_N); return; 492 | case S_ITEML: code(F_D, n, M_L); return; 493 | case S_CHAR: code(F_C, n, M_N); return; 494 | } 495 | } 496 | 497 | int opcode(op) 498 | { 499 | switch (op) { 500 | case S_RV: return 1; 501 | case S_NEG: return 2; 502 | case S_NOT: return 3; 503 | case S_RTRN: return 4; 504 | case S_MULT: return 5; 505 | case S_DIV: return 6; 506 | case S_REM: return 7; 507 | case S_PLUS: return 8; 508 | case S_MINUS: return 9; 509 | case S_EQ: return 10; 510 | case S_NE: return 11; 511 | case S_LS: return 12; 512 | case S_GE: return 13; 513 | case S_GR: return 14; 514 | case S_LE: return 15; 515 | case S_LSHIFT: return 16; 516 | case S_RSHIFT: return 17; 517 | case S_LOGAND: return 18; 518 | case S_LOGOR: return 19; 519 | case S_NEQV: return 20; 520 | case S_EQV: return 21; 521 | case S_FINISH: return 22; 522 | case S_SWITCHON: return 23; 523 | 524 | default: 525 | fprintf(stderr, "Unknown op %u\n", op); 526 | return 0; 527 | } 528 | } 529 | 530 | void gencode() 531 | { 532 | int i; 533 | next: 534 | op = readop(); 535 | 536 | switch (op) { 537 | default: 538 | fprintf(stderr, "Unknown key word: '%s'\n", (char*) wordv); 539 | goto next; 540 | 541 | case S_END: return; 542 | 543 | case S_DEBUG: 544 | fprintf(stderr, "STATE=%u, SSP=%#x, AD.A=%u, AD.K=%u\n", 545 | state, ssp, ad_a, ad_k); 546 | goto next; 547 | 548 | case S_LP: load(rdn(), M_IP); goto next; 549 | case S_LG: load(rdn(), M_IG); goto next; 550 | case S_LL: load(rdl(), M_IL); goto next; 551 | case S_LN: load(rdn(), M_N); goto next; 552 | 553 | case S_LSTR: cgstring(rdn()); goto next; 554 | 555 | case S_TRUE: load(-1, M_N); goto next; 556 | case S_FALSE: load(0, M_N); goto next; 557 | 558 | case S_LLP: load(rdn(), M_P); goto next; 559 | case S_LLG: load(rdn(), M_G); goto next; 560 | case S_LLL: load(rdl(), M_L); goto next; 561 | 562 | case S_SP: storein(rdn(), M_P); goto next; 563 | case S_SG: storein(rdn(), M_G); goto next; 564 | case S_SL: storein(rdl(), M_L); goto next; 565 | 566 | case S_STIND: 567 | force_acad(); 568 | code(F_S, ad_a, ad_k); 569 | ssp = ssp-2; 570 | state = NIL; 571 | goto next; 572 | 573 | case S_MULT: case S_DIV: case S_REM: 574 | case S_MINUS: case S_EQ: case S_NE: 575 | case S_LS: case S_GR: case S_LE: case S_GE: 576 | case S_LSHIFT: case S_RSHIFT: 577 | case S_LOGAND: case S_LOGOR: case S_NEQV: case S_EQV: 578 | force_acad(); 579 | code(F_L, ad_a, ad_k); 580 | code(F_X, opcode(op), M_N); 581 | state = AC; 582 | ssp = ssp-1; 583 | goto next; 584 | 585 | case S_RV: case S_NEG: case S_NOT: 586 | force_ac(); 587 | code(F_X, opcode(op), M_N); 588 | goto next; 589 | 590 | case S_PLUS: 591 | force_acad(); 592 | code(F_A, ad_a, ad_k); 593 | state = AC; 594 | ssp = ssp-1; 595 | goto next; 596 | 597 | case S_JUMP: 598 | force_nil(); 599 | code(F_J, rdl(), M_L); 600 | goto next; 601 | 602 | case S_JT: case S_JF: 603 | force_ac(); 604 | code((op == S_JT) ? F_T : F_F, rdl(), M_L); 605 | ssp = ssp-1; 606 | state = NIL; 607 | goto next; 608 | 609 | case S_GOTO: 610 | force_ad(); 611 | code(F_J, ad_a, ad_k); 612 | ssp = ssp-1; 613 | state = NIL; 614 | goto next; 615 | 616 | case S_LAB: force_nil(); complab(rdl()); goto next; 617 | case S_QUERY: force_nil(); ssp = ssp + 1; goto next; 618 | case S_STACK: force_nil(); ssp = rdn(); goto next; 619 | case S_STORE: force_nil(); goto next; 620 | 621 | case S_ENTRY: { 622 | int n = rdn(); 623 | int l = rdl(); 624 | 625 | wr('\n'); 626 | wr('$'); 627 | for (i = 0; i < n; i++) 628 | rdn(); 629 | wr(' '); 630 | complab(l); 631 | goto next; 632 | } 633 | 634 | case S_SAVE: ssp = rdn(); goto next; 635 | case S_ENDPROC: rdn(); goto next; 636 | 637 | case S_RTAP: 638 | case S_FNAP: { 639 | int k = rdn(); 640 | 641 | force_ac(); 642 | code(F_K, k, M_N); 643 | if (op == S_FNAP) { 644 | ssp = k+1; 645 | state = AC; 646 | } else { 647 | ssp = k; 648 | state = NIL; 649 | } 650 | goto next; 651 | } 652 | 653 | case S_FNRN: 654 | force_ac(); 655 | ssp = ssp - 1; 656 | case S_RTRN: 657 | code(F_X, opcode(S_RTRN), M_N); 658 | state = NIL; 659 | goto next; 660 | 661 | case S_RES: 662 | force_ac(); 663 | code(F_J, rdl(), M_L); 664 | ssp = ssp-1; 665 | state = NIL; 666 | goto next; 667 | 668 | case S_RSTACK: 669 | force_nil(); 670 | ssp = rdn()+1; 671 | state = AC; 672 | goto next; 673 | 674 | case S_FINISH: code(F_X, opcode(op), M_N); goto next; 675 | 676 | case S_SWITCHON: { 677 | int n = rdn(); 678 | int d = rdl(); 679 | 680 | force_ac(); 681 | code(F_X, opcode(op), M_N); 682 | code(F_D, n, M_N); 683 | code(F_D, d, M_L); 684 | ssp = ssp-1; 685 | state = NIL; 686 | for (i = 0; i < n; i++) { 687 | code(F_D, rdn(), M_N); 688 | code(F_D, rdl(), M_L); 689 | } 690 | goto next; 691 | } 692 | 693 | case S_GLOBAL: 694 | wr('\n'); 695 | for (i = 0; i < datap-2; i += 2) { 696 | wrdata(datav[i], datav[i+1]); 697 | } 698 | wr('\n'); 699 | for (i = rdn(); i > 0; i--) { 700 | wr('G'); 701 | wrn(rdn()); 702 | wr('L'); 703 | wrn(rdl()); 704 | wr(' '); 705 | } 706 | wr('\n'); 707 | wr('Z'); 708 | wr('\n'); 709 | return; 710 | 711 | case S_DATALAB: 712 | case S_ITEML: data(op, rdl()); goto next; 713 | case S_ITEMN: data(op, rdn()); goto next; 714 | } 715 | } 716 | 717 | int main() 718 | { 719 | int v [4000]; 720 | int w [50]; 721 | 722 | datav = v; 723 | datat = 4000; 724 | wordv = w; 725 | 726 | if (freopen ("INTCODE", "w", stdout) != stdout) { 727 | perror ("INTCODE"); 728 | return -1; 729 | } 730 | proglength = 0; 731 | 732 | do { 733 | ssp = 2; 734 | state = NIL; 735 | datap = 0; 736 | linep = 0; 737 | param = 500; 738 | gencode(); 739 | } while (op == S_GLOBAL); 740 | 741 | fprintf(stderr, "Program length = %u instructions\n", proglength); 742 | return 0; 743 | } 744 | -------------------------------------------------------------------------------- /intcode/Makefile: -------------------------------------------------------------------------------- 1 | CC = cc -m32 2 | CFLAGS = -g -O1 -Wall -Werror 3 | LDFLAGS = -g 4 | 5 | PREFIX = /usr/local 6 | 7 | all: intcode 8 | 9 | # 10 | # Intcode interpreter 11 | # 12 | intcode: intcode.o blib.o 13 | $(CC) $(LDFLAGS) -o intcode intcode.o blib.o 14 | 15 | blib.o: blib.c 16 | $(CC) $(CFLAGS) -c blib.c 17 | 18 | intcode.o: intcode.c 19 | $(CC) $(CFLAGS) -c intcode.c 20 | 21 | # 22 | # Installation 23 | # 24 | install: intcode 25 | install -c -s intcode $(PREFIX)/bin/intcode 26 | 27 | clean: 28 | rm -f OCODE INTCODE ASM *.o *.int intcode 29 | -------------------------------------------------------------------------------- /intcode/blib.c: -------------------------------------------------------------------------------- 1 | /* Copyright (c) 2004 Robert Nordier. All rights reserved. */ 2 | 3 | #include 4 | #include 5 | #include "blib.h" 6 | 7 | #define FTSZ 20 8 | 9 | extern int *M; 10 | 11 | static FILE *ft[FTSZ]; 12 | static int fi, fo; 13 | 14 | int 15 | getbyte(s, i) 16 | int s, i; 17 | { 18 | int w = M[s + i / 4]; 19 | int m = (i % 4) ^ 3; 20 | w = w >> (8 * m); 21 | return w & 255; 22 | } 23 | 24 | void 25 | putbyte(s, i, ch) 26 | { 27 | int p = s + i / 4; 28 | int m = (i % 4) ^ 3; 29 | int w = M[p]; 30 | int x = 0xff; 31 | x = x << (8 * m); 32 | x = x ^ 0xffffffff; 33 | w = w & x; 34 | x = ch; 35 | x = x & 0xff; 36 | x = x << (8 * m); 37 | w = w | x; 38 | M[p] = w; 39 | } 40 | 41 | static char * 42 | cstr(s) 43 | { 44 | char *st; 45 | int n, i; 46 | 47 | n = getbyte(s, 0); 48 | st = malloc(n + 1); 49 | for (i = 1; i <= n; i++) 50 | st[i - 1] = getbyte(s, i); 51 | st[n] = 0; 52 | return st; 53 | } 54 | 55 | static int 56 | ftslot() 57 | { 58 | int i; 59 | 60 | for (i = 3; i < FTSZ; i++) 61 | if (ft[i] == NULL) 62 | return i; 63 | return -1; 64 | } 65 | 66 | void 67 | initio() 68 | { 69 | ft[0] = stdin; 70 | ft[1] = stdout; 71 | ft[2] = stderr; 72 | fi = 0; 73 | fo = 1; 74 | } 75 | 76 | int 77 | findinput(s) 78 | int s; 79 | { 80 | char *st = cstr(s); 81 | int x; 82 | 83 | x = ftslot(); 84 | if (x != -1) { 85 | ft[x] = fopen(st, "r"); 86 | if (ft[x] == NULL) 87 | x = -1; 88 | } 89 | free(st); 90 | return x + 1; 91 | } 92 | 93 | int 94 | findoutput(s) 95 | int s; 96 | { 97 | char *st = cstr(s); 98 | int x; 99 | 100 | x = ftslot(); 101 | if (x != -1) { 102 | ft[x] = fopen(st, "w"); 103 | if (ft[x] == NULL) 104 | x = -1; 105 | } 106 | free(st); 107 | return x + 1; 108 | } 109 | 110 | void 111 | selectinput(x) 112 | int x; 113 | { 114 | fi = x - 1; 115 | } 116 | 117 | void 118 | selectoutput(x) 119 | int x; 120 | { 121 | fo = x - 1; 122 | } 123 | 124 | int 125 | input() 126 | { 127 | return fi + 1; 128 | } 129 | 130 | int 131 | output() 132 | { 133 | return fo + 1; 134 | } 135 | 136 | int 137 | rdch() 138 | { 139 | return fgetc(ft[fi]); 140 | } 141 | 142 | void 143 | wrch(c) 144 | int c; 145 | { 146 | fputc(c, ft[fo]); 147 | } 148 | 149 | void 150 | endread() 151 | { 152 | if (fi > 2) { 153 | fclose(ft[fi]); 154 | ft[fi] = NULL; 155 | } 156 | fi = 0; 157 | } 158 | 159 | void 160 | endwrite() 161 | { 162 | if (fo > 2) { 163 | fclose(ft[fo]); 164 | ft[fo] = NULL; 165 | } else 166 | fflush(ft[fo]); 167 | fo = 1; 168 | } 169 | -------------------------------------------------------------------------------- /intcode/blib.h: -------------------------------------------------------------------------------- 1 | void selectinput(int x); 2 | void selectoutput(int x); 3 | int rdch(void); 4 | void wrch(int c); 5 | int findinput(int s); 6 | int findoutput(int s); 7 | void endread(void); 8 | void endwrite(void); 9 | int getbyte(int s, int i); 10 | void putbyte(int s, int i, int ch); 11 | int input(void); 12 | int output(void); 13 | void initio(void); 14 | -------------------------------------------------------------------------------- /intcode/intcode.c: -------------------------------------------------------------------------------- 1 | /* Copyright (c) 2004 Robert Nordier. All rights reserved. */ 2 | 3 | #include 4 | #include "blib.h" 5 | 6 | #define VSIZE 64000 7 | #define MGLOB 1 8 | #define MPROG 402 9 | 10 | #define FALSE 0 11 | #define TRUE 1 12 | 13 | #define FSHIFT 13 14 | #define IBIT 010000 15 | #define PBIT 04000 16 | #define GBIT 02000 17 | #define DBIT 01000 18 | #define ABITS 0777 19 | #define WORDSIZE 32 20 | #define BYTESIZE 8 21 | 22 | #define LIG1 0012001 23 | #define K2 0140002 24 | #define X22 0160026 25 | 26 | int *M; 27 | FILE *fp; 28 | 29 | static int G; 30 | static int P; 31 | static int Ch; 32 | static int Cyclecount; 33 | static int *Labv; 34 | static int Cp; 35 | static int A; 36 | static int B; 37 | static int C; 38 | static int D; 39 | static int W; 40 | 41 | static void 42 | rch() 43 | { 44 | for (;;) { 45 | Ch = fgetc(fp); 46 | if (Ch != '/') 47 | return; 48 | do { 49 | Ch = fgetc(fp); 50 | } while (Ch != '\n'); 51 | } 52 | } 53 | 54 | static void 55 | setlab(n) 56 | { 57 | int k = Labv[n]; 58 | if (k < 0) 59 | printf("L%d ALREADY SET TO %d AT P = %d\n", n, -k, P); 60 | while (k > 0) { 61 | int n = M[k]; 62 | M[k] = P; 63 | k = n; 64 | } 65 | Labv[n] = -P; 66 | } 67 | 68 | static void 69 | labref(n, a) 70 | { 71 | int k = Labv[n]; 72 | if (k < 0) 73 | k = -k; 74 | else 75 | Labv[n] = a; 76 | M[a] += k; 77 | } 78 | 79 | static int 80 | rdn() 81 | { 82 | int a = 0, b = FALSE; 83 | if (Ch == '-') { b = TRUE; rch(); } 84 | while ('0' <= Ch && Ch <= '9') { a = 10 * a + Ch - '0'; rch(); } 85 | if (b) a = -a; 86 | return a; 87 | } 88 | 89 | static void 90 | stw(w) 91 | { 92 | M[P++] = w; 93 | Cp = 0; 94 | } 95 | 96 | static void 97 | stc(c) 98 | { 99 | if (Cp == 0) { 100 | stw(0); 101 | Cp = WORDSIZE; 102 | } 103 | Cp -= BYTESIZE; 104 | M[P - 1] += c << Cp; 105 | } 106 | 107 | static void 108 | assemble() 109 | { 110 | int v[501]; 111 | int f = 0; 112 | int i; 113 | 114 | /* Skip #! header, if any. */ 115 | Ch = fgetc(fp); 116 | if (Ch != '#') 117 | ungetc(Ch, fp); 118 | else { 119 | while (Ch != '\n') 120 | Ch = fgetc(fp); 121 | } 122 | 123 | Labv = v; 124 | clear: 125 | for (i = 0; i <= 500; i++) 126 | Labv[i] = 0; 127 | Cp = 0; 128 | next: 129 | rch(); 130 | sw: 131 | switch (Ch) { 132 | 133 | default: if (Ch == EOF) return; 134 | printf("\nBAD CH %c AT P = %d\n", Ch, P); 135 | goto next; 136 | 137 | case '0': case '1': case '2': case '3': case '4': 138 | case '5': case '6': case '7': case '8': case '9': 139 | setlab(rdn()); 140 | Cp = 0; 141 | goto sw; 142 | 143 | case '$': case ' ': case '\n': goto next; 144 | 145 | case 'L': f = 0; break; 146 | case 'S': f = 1; break; 147 | case 'A': f = 2; break; 148 | case 'J': f = 3; break; 149 | case 'T': f = 4; break; 150 | case 'F': f = 5; break; 151 | case 'K': f = 6; break; 152 | case 'X': f = 7; break; 153 | 154 | case 'C': rch(); stc(rdn()); goto sw; 155 | 156 | case 'D': rch(); 157 | if (Ch == 'L') { 158 | rch(); 159 | stw(0); 160 | labref(rdn(), P - 1); 161 | } else 162 | stw(rdn()); 163 | goto sw; 164 | 165 | case 'G': rch(); 166 | A = rdn() + G; 167 | if (Ch == 'L') rch(); 168 | else printf("\nBAD CODE AT P = %d\n", P); 169 | M[A] = 0; 170 | labref(rdn(), A); 171 | goto sw; 172 | case 'Z': for (i = 0; i <= 500; i++) 173 | if (Labv[i] > 0) printf("L%d UNSET\n", i); 174 | goto clear; 175 | } 176 | W = f << FSHIFT; 177 | rch(); 178 | if (Ch == 'I') { W = W + IBIT; rch(); } 179 | if (Ch == 'P') { W = W + PBIT; rch(); } 180 | if (Ch == 'G') { W = W + GBIT; rch(); } 181 | 182 | if (Ch == 'L') { 183 | rch(); 184 | stw(W + DBIT); 185 | stw(0); 186 | labref(rdn(), P - 1); 187 | } else { 188 | int a = rdn(); 189 | if ((a & ABITS) == a) 190 | stw(W + a); 191 | else { stw(W + DBIT); stw(a); } 192 | } 193 | goto sw; 194 | } 195 | 196 | static int 197 | interpret() 198 | { 199 | fetch: 200 | Cyclecount++; 201 | W = M[C++]; 202 | if ((W & DBIT) == 0) 203 | D = W & ABITS; 204 | else 205 | D = M[C++]; 206 | 207 | if ((W & PBIT) != 0) D += P; 208 | if ((W & GBIT) != 0) D += G; 209 | if ((W & IBIT) != 0) D = M[D]; 210 | 211 | switch (W >> FSHIFT) { 212 | error: default: printf("\nINTCODE ERROR AT C = %d\n", C - 1); 213 | return -1; 214 | case 0: B = A; A = D; goto fetch; 215 | case 1: M[D] = A; goto fetch; 216 | case 2: A = A + D; goto fetch; 217 | case 3: C = D; goto fetch; 218 | case 4: A = !A; 219 | case 5: if (!A) C = D; goto fetch; 220 | case 6: D += P; 221 | M[D] = P; M[D + 1] = C; 222 | P = D; C = A; 223 | goto fetch; 224 | case 7: switch (D) { 225 | default: goto error; 226 | case 1: A = M[A]; goto fetch; 227 | case 2: A = -A; goto fetch; 228 | case 3: A = ~A; goto fetch; 229 | case 4: C = M[P + 1]; 230 | P = M[P]; 231 | goto fetch; 232 | case 5: A = B * A; goto fetch; 233 | case 6: A = B / A; goto fetch; 234 | case 7: A = B % A; goto fetch; 235 | case 8: A = B + A; goto fetch; 236 | case 9: A = B - A; goto fetch; 237 | case 10: A = B == A ? ~0 : 0; goto fetch; 238 | case 11: A = B != A ? ~0 : 0; goto fetch; 239 | case 12: A = B < A ? ~0 : 0; goto fetch; 240 | case 13: A = B >= A ? ~0 : 0; goto fetch; 241 | case 14: A = B > A ? ~0 : 0; goto fetch; 242 | case 15: A = B <= A ? ~0 : 0; goto fetch; 243 | case 16: A = B << A; goto fetch; 244 | case 17: A = B >> A; goto fetch; 245 | case 18: A = B & A; goto fetch; 246 | case 19: A = B | A; goto fetch; 247 | case 20: A = B ^ A; goto fetch; 248 | case 21: A = B ^ ~A; goto fetch; 249 | case 22: return 0; 250 | case 23: B = M[C]; D = M[C + 1]; 251 | while (B != 0) { 252 | B--; C += 2; 253 | if (A == M[C]) { D = M[C + 1]; break; } 254 | } 255 | C = D; 256 | goto fetch; 257 | 258 | case 24: selectinput(A); goto fetch; 259 | case 25: selectoutput(A); goto fetch; 260 | case 26: A = rdch(); goto fetch; 261 | case 27: wrch(A); goto fetch; 262 | case 28: A = findinput(A); goto fetch; 263 | case 29: A = findoutput(A); goto fetch; 264 | case 30: return A; 265 | case 31: A = M[P]; goto fetch; 266 | case 32: P = A; C = B; goto fetch; 267 | case 33: endread(); goto fetch; 268 | case 34: endwrite(); goto fetch; 269 | case 35: D = P + B + 1; 270 | M[D] = M[P]; 271 | M[D + 1] = M[P + 1]; 272 | M[D + 2] = P; 273 | M[D + 3] = B; 274 | P = D; 275 | C = A; 276 | goto fetch; 277 | case 36: A = getbyte(A, B); goto fetch; 278 | case 37: putbyte(A, B, M[P + 4]); goto fetch; 279 | case 38: A = input(); goto fetch; 280 | case 39: A = output(); goto fetch; 281 | } 282 | } 283 | } 284 | 285 | int 286 | main(argc, argv) 287 | char **argv; 288 | { 289 | int pgvec[VSIZE]; 290 | 291 | if (argc != 2) { 292 | fprintf(stderr, "usage: intcode file\n"); 293 | return 1; 294 | } 295 | fp = fopen(argv[1], "r"); 296 | if (fp == NULL) { 297 | fprintf(stderr, "%s: Can't open\n", argv[1]); 298 | return 0; 299 | } 300 | M = pgvec; 301 | G = MGLOB; 302 | P = MPROG; 303 | M[P++] = LIG1; 304 | M[P++] = K2; 305 | M[P++] = X22; 306 | initio(); 307 | //printf("INTCODE SYSTEM ENTERED\n"); 308 | assemble(); 309 | fclose(fp); 310 | //printf("INTCODE SIZE = %d\n", P - MPROG); 311 | C = MPROG; 312 | Cyclecount = 0; 313 | A = interpret(); 314 | //printf("EXECUTION CYCLES = %d, STATUS = %d\n", Cyclecount, A); 315 | return A; 316 | } 317 | -------------------------------------------------------------------------------- /test-codegen/Makefile: -------------------------------------------------------------------------------- 1 | 2 | all: cmpltest 3 | 4 | cmpltest: ../btran/btran ../gen-intcode/gen-intcode cmpltest.b iclib.intcode 5 | ../btran/btran < cmpltest.b 6 | ../gen-intcode/gen-intcode < OCODE 7 | echo '#!/usr/bin/env intcode' > $@ 8 | cat iclib.intcode INTCODE >> $@ 9 | chmod +x $@ 10 | 11 | bcmpltest: bcpl-tran ../gen-intcode/gen-intcode cmpltest.bcpl iclib.intcode 12 | ./bcpl-tran < cmpltest.bcpl 13 | ../gen-intcode/gen-intcode < OCODE 14 | echo '#!/usr/bin/env intcode' > $@ 15 | cat iclib.intcode INTCODE >> $@ 16 | chmod +x $@ 17 | 18 | clean: 19 | rm -f OCODE INTCODE ASM *.o cmpltest bcmpltest 20 | -------------------------------------------------------------------------------- /test-codegen/cmpltest.b: -------------------------------------------------------------------------------- 1 | // 2 | // This is a universal code-generator test program 3 | // written by M. Richards originally to test the 4 | // CII 10070 code-generator. 5 | // 6 | extern { 7 | start : 1 8 | 9 | // Built-in functions of INTCODE interpreter 10 | selectinput : 11 11 | selectoutput : 12 12 | rdch : 13 13 | wrch : 14 14 | unrdch : 15 15 | input : 16 16 | output : 17 17 | 18 | stop : 30 19 | level : 31 20 | longjump : 32 21 | 22 | rewind : 35 23 | 24 | aptovec : 40 25 | findoutput : 41 26 | findinput : 42 27 | 28 | endread : 46 29 | endwrite : 47 30 | 31 | getbyte : 85 32 | putbyte : 86 33 | } 34 | 35 | extern { 36 | f : 100 37 | g : 101 38 | h : 102 39 | testno : 103; 40 | failcount : 104 41 | v : 105 42 | testcount : 106 43 | quiet : 107 44 | t : 108 45 | } 46 | 47 | static { 48 | a = 10 49 | b = 11 50 | c = 12 51 | w = 0 52 | } 53 | 54 | define { 55 | K0 = 0 56 | K1 = 1 57 | K2 = 2 58 | } 59 | 60 | writes(s) 61 | { 62 | FOR i = 1 TO getbyte(s, 0) DO 63 | wrch(getbyte(s, i)) 64 | } 65 | 66 | writeoct(n, d) 67 | { 68 | IF d>1 DO 69 | writeoct(n>>3, d-1) 70 | wrch((n/\7)+'0') 71 | } 72 | 73 | writehex(n, d) 74 | { 75 | IF d>1 DO 76 | writehex(n>>4, d-1) 77 | wrch((n&15)!TABLE 78 | '0','1','2','3','4','5','6','7', 79 | '8','9','A','B','C','D','E','F') 80 | } 81 | 82 | writed(n, d) 83 | { 84 | auto t = VEC 20 85 | auto i, k = 0, n 86 | 87 | IF n<0 DO 88 | d, k := d-1, -n 89 | t!i, k, i := k REM 10, k/10, i+1 REPEATUNTIL k=0 90 | FOR j = i+1 TO d DO 91 | wrch('*S') 92 | IF n<0 DO 93 | wrch('-') 94 | FOR j = i-1 TO 0 BY -1 DO 95 | wrch(t!j+'0') 96 | } 97 | 98 | writef(format, a, b, c, d, e, f, g, h, i, j, k) 99 | { 100 | auto t = @a 101 | 102 | FOR p = 1 TO getbyte(format, 0) DO { 103 | auto k = getbyte(format, p) 104 | 105 | TEST k='%' THEN { 106 | auto f, q, n = 0, t!0, 0 107 | auto type = getbyte(format, p+1) 108 | p := p + 1 109 | SWITCHON type INTO { 110 | DEFAULT: wrch(type); ENDCASE 111 | 112 | CASE 'S': f := writes; GOTO L 113 | CASE 'C': f := wrch; GOTO L 114 | CASE 'O': f := writeoct; GOTO M 115 | CASE 'X': f := writehex; GOTO M 116 | CASE 'I': f := writed; GOTO M 117 | CASE 'N': f := writed; GOTO L 118 | 119 | M: p := p + 1 120 | n := getbyte(format, p) 121 | n := '0'<=n<='9' -> n-'0', n-'A'+10 122 | 123 | L: f(q, n); t := t + 1 124 | } 125 | } 126 | OR wrch(k) 127 | } 128 | RETURN 129 | } 130 | 131 | t(x, y) 132 | { 133 | testno := testno + 1 134 | testcount := testcount + 1 135 | IF x=y & quiet 136 | RESULTIS y 137 | 138 | writef("%I3 %I5 ", testno, y) 139 | TEST x=y THEN 140 | writes("OK*N") 141 | ELSE { 142 | writef("FAILED %X8(%N) %X8(%N)*N", x, x, y, y) 143 | failcount := failcount + 1 144 | } 145 | RESULTIS y 146 | } 147 | 148 | t1(a,b,c,D,E,f,g) 149 | { 150 | RESULTIS t(a+b+c+D+E+f, g) 151 | } 152 | 153 | tester(x, y, z, v1, v2) 154 | { 155 | writef("*NCGTESTER ENTERED *N*N") 156 | 157 | // 158 | // First initialize certain variables 159 | // 160 | f, g, h := 100, 101, 102 161 | testno, testcount, failcount := 0, 0, 0 162 | v, w := v1, v2 163 | 164 | FOR i = 0 TO 200 DO v!i, w!i := 1000+i, 10000+i 165 | 166 | quiet := FALSE 167 | //quiet := GETBYTE(parm,0)>0 & GETBYTE(parm,1)='Q' -> TRUE, FALSE 168 | 169 | // 170 | // Test simple variables and expressions 171 | // 172 | t(a+b+c, 33) 173 | t(f+g+h, 303) 174 | t(x+y+z, 3) 175 | 176 | t(123+321-400, 44) 177 | t(x=0, TRUE) 178 | t(y=0, FALSE) 179 | t(!(@y+x), 1) 180 | t(!(@b+x), 11) 181 | t(!(@g+x), 101) 182 | 183 | x, a, f := 5, 15, 105 184 | t(x, 5) 185 | t(a, 15) 186 | t(f, 105) 187 | 188 | v!1, v!2 := 1234, 5678 189 | t(v!1, 1234) 190 | t(v!z, 5678) 191 | 192 | t(x*a, 75) 193 | t(1*x+2*y+3*z+f*4,433) 194 | t(x*a+a*x, 150) 195 | 196 | t(100/2, 50) 197 | t(a/x, 3) 198 | t(a/-x, -3) 199 | t((-a)/x, -3) 200 | t((-a)/(-x), 3) 201 | t((a+a)/a, 2) 202 | t((a*x)/(x*a), 1) 203 | t((a+b)*(x+y)*123/(6*123), 26) 204 | 205 | t(7 REM 2, 1) 206 | t(f REM 100, 5) 207 | t(a REM x, 0) 208 | 209 | t(-f, -105) 210 | t(f=105, TRUE) 211 | t(f NE 105, FALSE) 212 | t(f<105, FALSE) 213 | t(f>=105, TRUE) 214 | t(f>105, FALSE) 215 | t(f<=105, TRUE) 216 | 217 | t(#1775<<3, #17750) 218 | t(#1775>>3, #177) 219 | t(#1775<>z+1, #177) 221 | 222 | t(#B1100&#B1010, #B1000) 223 | t(#B1100 \/ #B1010, #B1110) 224 | t((#B1100 EQV #B1010) & #B11111, #B11001) 225 | t(#B1100 NEQV #B1010, #B0110) 226 | 227 | t(NOT TRUE, FALSE) 228 | t(NOT FALSE, TRUE) 229 | t(NOT(1234 EQV -4321), 1234 NEQV -4321) 230 | 231 | t(-f, -105) 232 | 233 | t(!v, 1000) 234 | t(v!0, 1000) 235 | t(v!1, 1234) 236 | t(v!(!v-998), 5678) 237 | t(!w, 10000) 238 | t(w!0, 10000) 239 | t(0!w, 10000) 240 | t(1!w, 10001) 241 | t(w!1, 10001) 242 | t(!(w+200), 10200) 243 | 244 | a := TRUE 245 | b := FALSE 246 | 247 | IF a DO x := 16 248 | t(x, 16) 249 | x := 16 250 | 251 | IF b DO x := 15 252 | t(x, 16) 253 | x := 15 254 | 255 | { 256 | auto w = VEC 20 257 | GOTO L1 258 | L2: writes("GOTO ERROR*N") 259 | failcount := failcount+1 260 | } 261 | 262 | L1: a := 11 263 | 264 | // 265 | // Test simulated stack routines 266 | // 267 | testno := 100 268 | 269 | { 270 | auto v1 = VEC 1 271 | v1!0, v1!1 := -1, -2 272 | { 273 | auto v2 = VEC 10 274 | FOR i = 0 TO 10 DO 275 | v2!i := -i 276 | t(v2!5, -5) 277 | } 278 | t(v1!1, -2) 279 | } 280 | 281 | x := x + t(x, 15, t(f, 105), t(a, 11)) - 15 282 | t(x, 15) 283 | 284 | x := x+1 285 | t(x, 16) 286 | x := x-1 287 | t(x, 15) 288 | x := x+7 289 | t(x, 22) 290 | x := x-22 291 | t(x, 0) 292 | x := x+15 293 | t(x, 15) 294 | x := x + f 295 | t(x, 120) 296 | x := 1 297 | 298 | // 299 | // Test switchon commands 300 | // 301 | testno := 200 302 | 303 | { 304 | auto s1, s1f = 0, 0 305 | auto s2, s2f = 0, 0 306 | 307 | FOR i = -200 TO 200 DO { 308 | SWITCHON i INTO { 309 | DEFAULT: s1 := s1+1000; ENDCASE 310 | CASE -1000: s1f := s1f + i; ENDCASE 311 | CASE -200: s1 := s1 + 1 312 | CASE -190: s1 := s1 + 1 313 | CASE -180: s1 := s1 + 1 314 | CASE -5: s1 := s1 + 1 315 | CASE 0: s1 := s1 + 1 316 | CASE -145: s1 := s1 + 1 317 | CASE 7: s1 := s1 + 1 318 | CASE 8: s1 := s1 + 1 319 | CASE 200: s1 := s1 + 1 320 | CASE 190: s1 := s1 + 1 321 | CASE 100: s1 := s1 + 1 322 | CASE 90: s1 := s1 + 1 323 | CASE 199: s1 := s1 + 1 324 | CASE 95: s1 := s1 + 1 325 | CASE 76: s1 := s1 + 1 326 | CASE 88: s1 := s1 + 1 327 | CASE 99: s1 := s1 + 1 328 | CASE -98: s1 := s1 + 1 329 | CASE 11: s1 := s1 + 1 330 | CASE 12: s1 := s1 + 1 331 | CASE 13: s1 := s1 + 1 332 | CASE 41: s1 := s1 + 1 333 | CASE 91: s1 := s1 + 1 334 | CASE 92: s1 := s1 + 1 335 | CASE 71: s1 := s1 + 1 336 | CASE 73: s1 := s1 + 1 337 | CASE 74: s1 := s1 + 1 338 | CASE 81: s1 := s1 + 1 339 | CASE 82: s1 := s1 + 1 340 | CASE 61: s1 := s1 + 1 341 | CASE -171: s1 := s1 + 1 342 | CASE -162: s1 := s1 + 1 343 | } 344 | 345 | SWITCHON i+10000 INTO { 346 | DEFAULT: s2 := s2+1000; ENDCASE 347 | CASE 10020: s2 := s2 + 1 348 | CASE 10021: s2 := s2 + 1 349 | CASE 10022: s2 := s2 + 1 350 | CASE 10023: s2 := s2 + 1 351 | CASE 10024: s2 := s2 + 1 352 | CASE 10025: s2 := s2 + 1 353 | CASE 10026: s2 := s2 + 1 354 | CASE 10027: s2 := s2 + 1 355 | CASE 10028: s2 := s2 + 1 356 | CASE 10029: s2 := s2 + 1 357 | CASE 10010: s2 := s2 + 1 358 | CASE 10011: s2 := s2 + 1 359 | CASE 10012: s2 := s2 + 1 360 | CASE 10013: s2 := s2 + 1 361 | CASE 10014: s2 := s2 + 1 362 | CASE 10015: s2 := s2 + 1 363 | } 364 | } 365 | t(s1f, 0) 366 | t(s2f, 0) 367 | t(s1, (401-32)*1000 + 32*(32+1)/2) 368 | t(s2, (401-16)*1000 + 16*(16+1)/2) 369 | } 370 | 371 | // 372 | // Test function calling 373 | // 374 | testno := 250 375 | 376 | t1(1,2,3,4,5,6, 21) 377 | t1(t(1,1), t(2,2), t(3,3), t(4,4), t(5,5), t(6,6), 378 | t(21,21)) 379 | t1(!v,v!0,v!200,!w,w!0,w!200, 2*1000+1200+2*10000+10200) 380 | (t1+(x+x)/x-2)(1,1,1,1,1,1,6) 381 | (!@t1)(1,2,3,4,5,6,21) 382 | 383 | // 384 | // Test expression operators 385 | // 386 | testno := 300 387 | 388 | t((2+3)+f+6,116) 389 | t(f+2+3+6,116) 390 | t(6+3+2+f, 116) 391 | t(f-104, 1) 392 | t((x+2)=(x+2)->99,98, 99) 393 | t(f21,22, 21) 394 | t(f>f+1->31,32, 32) 395 | t(f<=105->41,42, 41) 396 | t(f>=105->51,52, 51) 397 | 398 | // 399 | // Test register allocation etc. 400 | // 401 | testno := 400 402 | 403 | x := 0 404 | y := 1 405 | z := 2 406 | t(x, 0) 407 | t(y, 1) 408 | t(z, 2) 409 | f,g,h := 101,102,103 410 | a,b,c := 11,12,13 411 | t(x+1,1) 412 | t(f+1, 102) 413 | t(a+1, 12) 414 | t(!(@a*2/2+f-101),11) 415 | a := @f 416 | t(!a, 101) 417 | b := @g 418 | a := @b 419 | t(!!a, 102) 420 | w!0 := @w!1 421 | w!1 := @h 422 | t(z*y+(w!0)!0!0-2, 103) 423 | t(z*y+w!1!0-2, 103) 424 | t(t(123,123),t(123,123)) 425 | 426 | writef("*N%N TESTS COMPLETED, %N FAILURE(S)*N*N", 427 | testcount, failcount) 428 | } 429 | 430 | start(parm) 431 | { 432 | auto v1 = VEC 200 433 | auto v2 = VEC 200 434 | tester(0, 1, 2, v1, v2) 435 | } 436 | -------------------------------------------------------------------------------- /test-codegen/cmpltest.bcpl: -------------------------------------------------------------------------------- 1 | // 2 | // This is a universal code-generator test program 3 | // written by M. Richards originally to test the 4 | // CII 10070 code-generator. 5 | // 6 | GLOBAL $( 7 | start : 1 8 | 9 | // Built-in functions of INTCODE interpreter 10 | selectinput : 11 11 | selectoutput : 12 12 | rdch : 13 13 | wrch : 14 14 | unrdch : 15 15 | input : 16 16 | output : 17 17 | 18 | stop : 30 19 | level : 31 20 | longjump : 32 21 | 22 | rewind : 35 23 | 24 | aptovec : 40 25 | findoutput : 41 26 | findinput : 42 27 | 28 | endread : 46 29 | endwrite : 47 30 | 31 | getbyte : 85 32 | putbyte : 86 33 | $) 34 | 35 | GLOBAL $( 36 | f : 100 37 | g : 101 38 | h : 102 39 | testno : 103; 40 | failcount : 104 41 | v : 105 42 | testcount : 106 43 | quiet : 107 44 | t : 108 45 | $) 46 | 47 | STATIC $( 48 | a = 10 49 | b = 11 50 | c = 12 51 | w = 0 52 | $) 53 | 54 | MANIFEST $( 55 | K0 = 0 56 | K1 = 1 57 | K2 = 2 58 | $) 59 | 60 | LET writes(s) BE 61 | $( 62 | FOR i = 1 TO getbyte(s, 0) DO wrch(getbyte(s, i)) 63 | $) 64 | 65 | AND writeoct(n, d) BE 66 | $( 67 | IF d>1 DO 68 | writeoct(n>>3, d-1) 69 | wrch((n/\7)+'0') 70 | $) 71 | 72 | AND writehex(n, d) BE 73 | $( 74 | IF d>1 DO 75 | writehex(n>>4, d-1) 76 | wrch((n&15)!TABLE 77 | '0','1','2','3','4','5','6','7', 78 | '8','9','A','B','C','D','E','F') 79 | $) 80 | 81 | AND writed(n, d) BE 82 | $(1 83 | LET t = VEC 20 84 | AND i, k = 0, n 85 | IF n<0 DO 86 | d, k := d-1, -n 87 | t!i, k, i := k REM 10, k/10, i+1 REPEATUNTIL k=0 88 | FOR j = i+1 TO d DO 89 | wrch('*S') 90 | IF n<0 DO 91 | wrch('-') 92 | FOR j = i-1 TO 0 BY -1 DO 93 | wrch(t!j+'0') 94 | $)1 95 | 96 | AND writef(format, a, b, c, d, e, f, g, h, i, j, k) BE 97 | $(1 98 | LET t = @a 99 | 100 | FOR p = 1 TO getbyte(format, 0) DO $(2 101 | LET k = getbyte(format, p) 102 | 103 | TEST k='%' THEN $(3 104 | LET f, q, n = 0, t!0, 0 105 | AND TYPE = getbyte(format, p+1) 106 | p := p + 1 107 | SWITCHON TYPE INTO $( 108 | DEFAULT: wrch(TYPE); ENDCASE 109 | 110 | CASE 'S': f := writes; GOTO L 111 | CASE 'C': f := wrch; GOTO L 112 | CASE 'O': f := writeoct; GOTO M 113 | CASE 'X': f := writehex; GOTO M 114 | CASE 'I': f := writed; GOTO M 115 | CASE 'N': f := writed; GOTO L 116 | 117 | M: p := p + 1 118 | n := getbyte(format, p) 119 | n := '0'<=n<='9' -> n-'0', n-'A'+10 120 | 121 | L: f(q, n); t := t + 1 122 | $)3 123 | OR wrch(k) 124 | $)2 125 | $)1 126 | 127 | LET t(x, y) = VALOF 128 | $( 129 | testno := testno + 1 130 | testcount := testcount + 1 131 | IF x=y & quiet 132 | RESULTIS y 133 | 134 | writef("%I3 %I5 ", testno, y) 135 | TEST x=y THEN 136 | writes("OK*N") 137 | ELSE $( 138 | writef("FAILED %X8(%N) %X8(%N)*N", x, x, y, y) 139 | failcount := failcount + 1 140 | $) 141 | RESULTIS y 142 | $) 143 | 144 | LET t1(a,b,c,D,E,f,g) = t(a+b+c+D+E+f, g) 145 | 146 | LET start(parm) BE 147 | $(1 148 | LET v1 = VEC 200 149 | AND v2 = VEC 200 150 | tester(0, 1, 2, v1, v2) 151 | $)1 152 | 153 | AND tester(x, y, z, v1, v2) BE 154 | $(1 155 | writef("*NCGTESTER ENTERED *N*N") 156 | 157 | // 158 | // First initialize certain variables 159 | // 160 | f, g, h := 100, 101, 102 161 | testno, testcount, failcount := 0, 0, 0 162 | v, w := v1, v2 163 | 164 | FOR i = 0 TO 200 DO v!i, w!i := 1000+i, 10000+i 165 | 166 | quiet := FALSE 167 | //quiet := GETBYTE(parm,0)>0 & GETBYTE(parm,1)='Q' -> TRUE, FALSE 168 | 169 | // 170 | // Test simple variables and expressions 171 | // 172 | t(a+b+c, 33) 173 | t(f+g+h, 303) 174 | t(x+y+z, 3) 175 | 176 | t(123+321-400, 44) 177 | t(x=0, TRUE) 178 | t(y=0, FALSE) 179 | t(!(@y+x), 1) 180 | t(!(@b+x), 11) 181 | t(!(@g+x), 101) 182 | 183 | x, a, f := 5, 15, 105 184 | t(x, 5) 185 | t(a, 15) 186 | t(f, 105) 187 | 188 | v!1, v!2 := 1234, 5678 189 | t(v!1, 1234) 190 | t(v!z, 5678) 191 | 192 | t(x*a, 75) 193 | t(1*x+2*y+3*z+f*4,433) 194 | t(x*a+a*x, 150) 195 | 196 | t(100/2, 50) 197 | t(a/x, 3) 198 | t(a/-x, -3) 199 | t((-a)/x, -3) 200 | t((-a)/(-x), 3) 201 | t((a+a)/a, 2) 202 | t((a*x)/(x*a), 1) 203 | t((a+b)*(x+y)*123/(6*123), 26) 204 | 205 | t(7 REM 2, 1) 206 | t(f REM 100, 5) 207 | t(a REM x, 0) 208 | 209 | t(-f, -105) 210 | t(f=105, TRUE) 211 | t(f NE 105, FALSE) 212 | t(f<105, FALSE) 213 | t(f>=105, TRUE) 214 | t(f>105, FALSE) 215 | t(f<=105, TRUE) 216 | 217 | t(#1775<<3, #17750) 218 | t(#1775>>3, #177) 219 | t(#1775<>z+1, #177) 221 | 222 | t(#B1100&#B1010, #B1000) 223 | t(#B1100 \/ #B1010, #B1110) 224 | t((#B1100 EQV #B1010) & #B11111, #B11001) 225 | t(#B1100 NEQV #B1010, #B0110) 226 | 227 | t(NOT TRUE, FALSE) 228 | t(NOT FALSE, TRUE) 229 | t(NOT(1234 EQV -4321), 1234 NEQV -4321) 230 | 231 | t(-f, -105) 232 | 233 | t(!v, 1000) 234 | t(v!0, 1000) 235 | t(v!1, 1234) 236 | t(v!(!v-998), 5678) 237 | t(!w, 10000) 238 | t(w!0, 10000) 239 | t(0!w, 10000) 240 | t(1!w, 10001) 241 | t(w!1, 10001) 242 | t(!(w+200), 10200) 243 | 244 | a := TRUE 245 | b := FALSE 246 | 247 | IF a DO x := 16 248 | t(x, 16) 249 | x := 16 250 | 251 | IF b DO x := 15 252 | t(x, 16) 253 | x := 15 254 | 255 | $( 256 | LET w = VEC 20 257 | GOTO L1 258 | L2: writes("GOTO ERROR*N") 259 | failcount := failcount+1 260 | $) 261 | 262 | L1: a := VALOF RESULTIS 11 263 | t(a, 11) 264 | 265 | // 266 | // Test simulated stack routines 267 | // 268 | testno := 100 269 | 270 | $( 271 | LET v1 = VEC 1 272 | v1!0, v1!1 := -1, -2 273 | $( 274 | LET v2 = VEC 10 275 | FOR i = 0 TO 10 DO 276 | v2!i := -i 277 | t(v2!5, -5) 278 | $) 279 | t(v1!1, -2) 280 | $) 281 | 282 | x := x + t(x,15, t(f, 105), t(a, 11)) - 15 283 | t(x, 15) 284 | 285 | x := x+1 286 | t(x, 16) 287 | x := x-1 288 | t(x, 15) 289 | x := x+7 290 | t(x, 22) 291 | x := x-22 292 | t(x, 0) 293 | x := x+15 294 | t(x, 15) 295 | x := x + f 296 | t(x, 120) 297 | x := 1 298 | 299 | // 300 | // Test switchon commands 301 | // 302 | testno := 200 303 | 304 | $(SW 305 | LET s1, s1f = 0, 0 306 | AND s2, s2f = 0, 0 307 | 308 | FOR i = -200 TO 200 DO $( 309 | SWITCHON i INTO $( 310 | DEFAULT: s1 := s1+1000; ENDCASE 311 | CASE -1000: s1f := s1f + i; ENDCASE 312 | CASE -200: s1 := s1 + 1 313 | CASE -190: s1 := s1 + 1 314 | CASE -180: s1 := s1 + 1 315 | CASE -5: s1 := s1 + 1 316 | CASE 0: s1 := s1 + 1 317 | CASE -145: s1 := s1 + 1 318 | CASE 7: s1 := s1 + 1 319 | CASE 8: s1 := s1 + 1 320 | CASE 200: s1 := s1 + 1 321 | CASE 190: s1 := s1 + 1 322 | CASE 100: s1 := s1 + 1 323 | CASE 90: s1 := s1 + 1 324 | CASE 199: s1 := s1 + 1 325 | CASE 95: s1 := s1 + 1 326 | CASE 76: s1 := s1 + 1 327 | CASE 88: s1 := s1 + 1 328 | CASE 99: s1 := s1 + 1 329 | CASE -98: s1 := s1 + 1 330 | CASE 11: s1 := s1 + 1 331 | CASE 12: s1 := s1 + 1 332 | CASE 13: s1 := s1 + 1 333 | CASE 41: s1 := s1 + 1 334 | CASE 91: s1 := s1 + 1 335 | CASE 92: s1 := s1 + 1 336 | CASE 71: s1 := s1 + 1 337 | CASE 73: s1 := s1 + 1 338 | CASE 74: s1 := s1 + 1 339 | CASE 81: s1 := s1 + 1 340 | CASE 82: s1 := s1 + 1 341 | CASE 61: s1 := s1 + 1 342 | CASE -171: s1 := s1 + 1 343 | CASE -162: s1 := s1 + 1 344 | $) 345 | 346 | SWITCHON i+10000 INTO $( 347 | DEFAULT: s2 := s2+1000; ENDCASE 348 | CASE 10020: s2 := s2 + 1 349 | CASE 10021: s2 := s2 + 1 350 | CASE 10022: s2 := s2 + 1 351 | CASE 10023: s2 := s2 + 1 352 | CASE 10024: s2 := s2 + 1 353 | CASE 10025: s2 := s2 + 1 354 | CASE 10026: s2 := s2 + 1 355 | CASE 10027: s2 := s2 + 1 356 | CASE 10028: s2 := s2 + 1 357 | CASE 10029: s2 := s2 + 1 358 | CASE 10010: s2 := s2 + 1 359 | CASE 10011: s2 := s2 + 1 360 | CASE 10012: s2 := s2 + 1 361 | CASE 10013: s2 := s2 + 1 362 | CASE 10014: s2 := s2 + 1 363 | CASE 10015: s2 := s2 + 1 364 | $) 365 | $) 366 | t(s1f, 0) 367 | t(s2f, 0) 368 | t(s1, (401-32)*1000 + 32*(32+1)/2) 369 | t(s2, (401-16)*1000 + 16*(16+1)/2) 370 | $)SW 371 | 372 | // 373 | // Test function calling 374 | // 375 | testno := 250 376 | 377 | t1(1,2,3,4,5,6, 21) 378 | t1(t(1,1), t(2,2), t(3,3), t(4,4), t(5,5), t(6,6), 379 | t(21,21)) 380 | t1(VALOF RESULTIS 1, 381 | VALOF RESULTIS 2, 382 | VALOF RESULTIS 3, 383 | VALOF RESULTIS 4, 384 | VALOF RESULTIS 5, 385 | VALOF RESULTIS 6, 386 | 21) 387 | t1(VALOF RESULTIS 1, 388 | t(2,2), 389 | VALOF RESULTIS 3, 390 | t(4,4), 391 | VALOF RESULTIS 5, 392 | t(6,6), 393 | 21) 394 | t1( 1, t(2,2), VALOF RESULTIS 3, 395 | 4, t(5,5), VALOF RESULTIS 6, 396 | 21) 397 | t1(!v,v!0,v!200,!w,w!0,w!200, 2*1000+1200+2*10000+10200) 398 | (t1+(x+x)/x-2)(1,1,1,1,1,1,6) 399 | (!@t1)(1,2,3,4,5,6,21) 400 | 401 | // 402 | // Test expression operators 403 | // 404 | testno := 300 405 | 406 | t((2+3)+f+6,116) 407 | t(f+2+3+6,116) 408 | t(6+3+2+f, 116) 409 | t(f-104, 1) 410 | t((x+2)=(x+2)->99,98, 99) 411 | t(f21,22, 21) 412 | t(f>f+1->31,32, 32) 413 | t(f<=105->41,42, 41) 414 | t(f>=105->51,52, 51) 415 | 416 | // 417 | // Test register allocation etc. 418 | // 419 | testno := 400 420 | 421 | x := 0 422 | y := 1 423 | z := 2 424 | t(x, 0) 425 | t(y, 1) 426 | t(z, 2) 427 | f,g,h := 101,102,103 428 | a,b,c := 11,12,13 429 | t(x+1,1) 430 | t(f+1, 102) 431 | t(a+1, 12) 432 | t(!(@a*2/2+f-101),11) 433 | a := @f 434 | t(!a, 101) 435 | b := @g 436 | a := @b 437 | t(!!a, 102) 438 | w!0 := @w!1 439 | w!1 := @h 440 | t(z*y+(w!0)!0!0-2, 103) 441 | t(z*y+w!1!0-2, 103) 442 | t(t(123,123),t(123,123)) 443 | 444 | writef("*N%N TESTS COMPLETED, %N FAILURE(S)*N*N", 445 | testcount, failcount) 446 | $)1 447 | -------------------------------------------------------------------------------- /test-codegen/iclib.intcode: -------------------------------------------------------------------------------- 1 | 11 LIP2 X24 X4 G11L11 /SELECTINPUT 2 | 12 LIP2 X25 X4 G12L12 /SELECTOUTPUT 3 | 13 X26 X4 G13L13 /RDCH 4 | 14 LIP2 X27 X4 G14L14 /WRCH 5 | 42 LIP2 X28 X4 G42L42 /FINDINPUT 6 | 41 LIP2 X29 X4 G41L41 /FINDOUTPUT 7 | 30 LIP2 X30 X4 G30L30 /STOP 8 | 31 X31 X4 G31L31 /LEVEL 9 | 32 LIP3 LIP2 X32 G32L32 /LONGJUMP 10 | 46 X33 X4 G46L46 /ENDREAD 11 | 47 X34 X4 G47L47 /ENDWRITE 12 | 40 LIP3 LIP2 X35 G40L40 /APTOVEC 13 | 85 LIP3 LIP2 X36 X4 G85L85 / GETBYTE 14 | 86 LIP3 LIP2 X37 X4 G86L86 / PUTBYTE 15 | 16 X38 X4 G16L16 /INPUT 16 | 17 X39 X4 G17L17 /OUTPUT 17 | 15 LIP2 X40 X4 G15L15 /UNRDCH 18 | 35 X41 X4 G35L35 /REWIND 19 | Z 20 | -------------------------------------------------------------------------------- /test-hello/Makefile: -------------------------------------------------------------------------------- 1 | 2 | all: hello 3 | 4 | hello: ../btran/btran ../gen-intcode/gen-intcode hello.b iclib.intcode 5 | ../btran/btran < hello.b 6 | ../gen-intcode/gen-intcode < OCODE 7 | echo '#!/usr/bin/env intcode' > $@ 8 | cat iclib.intcode INTCODE >> $@ 9 | chmod +x $@ 10 | 11 | bhello: bcpl-tran ../gen-intcode/gen-intcode hello.bcpl iclib.intcode 12 | ./bcpl-tran < hello.bcpl 13 | ../gen-intcode/gen-intcode < OCODE 14 | echo '#!/usr/bin/env intcode' > $@ 15 | cat iclib.intcode INTCODE >> $@ 16 | chmod +x $@ 17 | 18 | clean: 19 | rm -f OCODE INTCODE ASM *.o hello bhello 20 | -------------------------------------------------------------------------------- /test-hello/hello.b: -------------------------------------------------------------------------------- 1 | extern { 2 | start : 1 3 | 4 | // Built-in functions of INTCODE interpreter 5 | selectinput : 11 6 | selectoutput : 12 7 | rdch : 13 8 | wrch : 14 9 | unrdch : 15 10 | input : 16 11 | output : 17 12 | 13 | stop : 30 14 | level : 31 15 | longjump : 32 16 | 17 | rewind : 35 18 | 19 | aptovec : 40 20 | findoutput : 41 21 | findinput : 42 22 | 23 | endread : 46 24 | endwrite : 47 25 | 26 | getbyte : 85 27 | putbyte : 86 28 | } 29 | 30 | writes(s) 31 | { 32 | FOR i = 1 TO getbyte(s, 0) DO 33 | wrch(getbyte(s, i)) 34 | } 35 | 36 | start() 37 | { 38 | writes("Hello, World!*N ") 39 | } 40 | -------------------------------------------------------------------------------- /test-hello/hello.bcpl: -------------------------------------------------------------------------------- 1 | GLOBAL $( 2 | start : 1 3 | 4 | // Built-in functions of INTCODE interpreter 5 | selectinput : 11 6 | selectoutput : 12 7 | rdch : 13 8 | wrch : 14 9 | unrdch : 15 10 | input : 16 11 | output : 17 12 | 13 | stop : 30 14 | level : 31 15 | longjump : 32 16 | 17 | rewind : 35 18 | 19 | aptovec : 40 20 | findoutput : 41 21 | findinput : 42 22 | 23 | endread : 46 24 | endwrite : 47 25 | 26 | getbyte : 85 27 | putbyte : 86 28 | $) 29 | 30 | LET writes(s) BE 31 | $( 32 | FOR i = 1 TO getbyte(s, 0) DO wrch(getbyte(s, i)) 33 | $) 34 | 35 | AND start() BE 36 | $( 37 | writes("Hello, World!*N ") 38 | $) 39 | -------------------------------------------------------------------------------- /test-hello/iclib.intcode: -------------------------------------------------------------------------------- 1 | 11 LIP2 X24 X4 G11L11 /SELECTINPUT 2 | 12 LIP2 X25 X4 G12L12 /SELECTOUTPUT 3 | 13 X26 X4 G13L13 /RDCH 4 | 14 LIP2 X27 X4 G14L14 /WRCH 5 | 42 LIP2 X28 X4 G42L42 /FINDINPUT 6 | 41 LIP2 X29 X4 G41L41 /FINDOUTPUT 7 | 30 LIP2 X30 X4 G30L30 /STOP 8 | 31 X31 X4 G31L31 /LEVEL 9 | 32 LIP3 LIP2 X32 G32L32 /LONGJUMP 10 | 46 X33 X4 G46L46 /ENDREAD 11 | 47 X34 X4 G47L47 /ENDWRITE 12 | 40 LIP3 LIP2 X35 G40L40 /APTOVEC 13 | 85 LIP3 LIP2 X36 X4 G85L85 / GETBYTE 14 | 86 LIP3 LIP2 X37 X4 G86L86 / PUTBYTE 15 | 16 X38 X4 G16L16 /INPUT 16 | 17 X39 X4 G17L17 /OUTPUT 17 | 15 LIP2 X40 X4 G15L15 /UNRDCH 18 | 35 X41 X4 G35L35 /REWIND 19 | Z 20 | -------------------------------------------------------------------------------- /test-tran/LIBHDR: -------------------------------------------------------------------------------- 1 | // LIBHDR 2 | 3 | define { 4 | ENDSTREAMCH = -1 5 | BYTESPERWORD = 4 6 | BITSPERWORD = 32 7 | MAXINT = #X7FFFFFFF 8 | MININT = #X80000000 9 | FIRSTFREEGLOBAL = 150 10 | } 11 | 12 | extern { 13 | start : 1 14 | 15 | selectinput : 11 16 | selectoutput : 12 17 | 18 | rdch : 13 19 | wrch : 14 20 | unrdch : 15 21 | 22 | input : 16 23 | output : 17 24 | 25 | stop : 30 26 | 27 | level : 31 28 | longjump : 32 29 | 30 | rewind : 35 31 | aptovec : 40 32 | 33 | findoutput : 41 34 | findinput : 42 35 | endread : 46 36 | endwrite : 47 37 | 38 | stackbase : 54 39 | stackend : 55 40 | 41 | writes : 60 42 | writen : 62 43 | newline : 63 44 | newpage : 64 45 | 46 | packstring : 66 47 | unpackstring : 67 48 | writed : 68 49 | 50 | readn : 70 51 | terminator : 71 52 | 53 | writehex : 75 54 | writef : 76 55 | writeoct : 77 56 | 57 | mapstore : 78 58 | 59 | getbyte : 85 60 | putbyte : 86 61 | 62 | result2 : 91 63 | } 64 | -------------------------------------------------------------------------------- /test-tran/Makefile: -------------------------------------------------------------------------------- 1 | 2 | all: trantest 3 | 4 | trantest: ../btran/btran ../gen-intcode/gen-intcode syn.b trn.b blib.b iclib.intcode 5 | echo '#!/usr/bin/env intcode' > $@ 6 | cat iclib.intcode >> $@ 7 | ../btran/btran < syn.b && ../gen-intcode/gen-intcode < OCODE && cat INTCODE >> $@ 8 | ../btran/btran < trn.b && ../gen-intcode/gen-intcode < OCODE && cat INTCODE >> $@ 9 | ../btran/btran < blib.b && ../gen-intcode/gen-intcode < OCODE && cat INTCODE >> $@ 10 | chmod +x $@ 11 | 12 | btrantest: bcpl-tran ../gen-intcode/gen-intcode syn.bcpl trn.bcpl blib.bcpl iclib.intcode 13 | echo '#!/usr/bin/env intcode' > $@ 14 | cat iclib.intcode >> $@ 15 | ./bcpl-tran < syn.bcpl && ../gen-intcode/gen-intcode < OCODE && cat INTCODE >> $@ 16 | ./bcpl-tran < trn.bcpl && ../gen-intcode/gen-intcode < OCODE && cat INTCODE >> $@ 17 | ./bcpl-tran < blib.bcpl && ../gen-intcode/gen-intcode < OCODE && cat INTCODE >> $@ 18 | chmod +x $@ 19 | 20 | clean: 21 | rm -f OCODE INTCODE ASM *.o trantest btrantest 22 | -------------------------------------------------------------------------------- /test-tran/SYNHDR: -------------------------------------------------------------------------------- 1 | // SYNHDR 2 | 3 | GET "LIBHDR" 4 | 5 | define { // AE operators and symbols 6 | S.NUMBER=1; S.NAME=2; S.STRING=3; S.TRUE=4; S.FALSE=5 7 | S.VALOF=6; S.LV=7; S.RV=8; S.VECAP=9; S.FNAP=10 8 | S.MULT=11; S.DIV=12; S.REM=13 9 | S.PLUS=14; S.MINUS=15; S.QUERY=16; S.NEG=17 10 | S.EQ=20; S.NE=21; S.LS=22; S.GR=23; S.LE=24; S.GE=25 11 | S.NOT=30; S.LSHIFT=31; S.RSHIFT=32; S.LOGAND=33; S.LOGOR=34 12 | S.EQV=35; S.NEQV=36; S.COND=37; S.COMMA=38; S.TABLE=39 13 | 14 | S.AND=40; S.VALDEF=41; S.VECDEF=42; S.CONSTDEF=43 15 | S.FNDEF=44; S.RTDEF=45 16 | 17 | S.ASS=50; S.RTAP=51; S.GOTO=52; S.RESULTIS=53 18 | S.COLON=54 19 | S.TEST=55; S.FOR=56; S.IF=57; S.UNLESS=58 20 | S.WHILE=59; S.UNTIL=60; S.REPEAT=61; S.REPEATWHILE=62 21 | S.REPEATUNTIL=63; S.LOOP=65; S.BREAK=66; S.RETURN=67; S.FINISH=68 22 | S.ENDCASE=69; S.SWITCHON=70; S.CASE=71; S.DEFAULT=72 23 | S.SEQ=73; S.LET=74; S.MANIFEST=75; S.GLOBAL=76; S.STATIC=79 24 | } 25 | 26 | define { // Other canonical symbols 27 | S.BE=89; S.END=90; S.LSECT=91; S.RSECT=92; S.GET=93 28 | S.SEMICOLON=97; S.INTO=98; S.TO=99; S.BY=100; S.DO=101; S.OR=102 29 | S.VEC=103; S.LPAREN=105; S.RPAREN=106 30 | } 31 | 32 | extern { // Globals used in lex 33 | CHBUF:100; DECVAL:101 34 | GETV=103; GETP=104; GETT=105 35 | WORDV:106; WORDSIZE:107; CHARV:108; CHARP:109 36 | PRSOURCE:110; PRLINE:111 37 | SYMB:115; WORDNODE:116; CH:117; RDTAG:118 38 | NEXTSYMB:120; DECLSYSWORDS:121; NLPENDING:122 39 | LOOKUPWORD:125; RCH:126; PPTRACE:127; OPTION:128 40 | wrchbuf:131; CHCOUNT:132; LINECOUNT:133 41 | NULLTAG:134; REC.P:135; REC.L:136 42 | } 43 | 44 | extern { // Globals used in CAE 45 | RDBLOCKBODY:140; RDSECT:141 46 | RNAMELIST:142; RNAME:143 47 | REXP:144; RDEF:145; RCOM:146 48 | RDCDEFS:147; NAMETABLE:148; NAMETABLESIZE:149 49 | FORMTREE:150; CAEREPORT:151; PLIST:152 50 | CHECKFOR:153; IGNORE:154; PERFORMGET:155; REXPLIST:156 51 | RDSEQ:157 52 | LIST1:161; LIST2:162; LIST3:163; LIST4:164; LIST5:165 53 | NEWVEC:166; TREEP:167; TREEVEC:168; LIST6:169 54 | CHARCODE:190; REPORTCOUNT:191; REPORTMAX:192 55 | SOURCESTREAM:193; SYSPRINT:194; OCODE:195; SYSIN:196 56 | } 57 | 58 | define { // Selectors 59 | H1=0; H2=1; H3=2; H4=3; H5=4; H6=5 60 | } 61 | -------------------------------------------------------------------------------- /test-tran/TRNHDR: -------------------------------------------------------------------------------- 1 | // TRNHDR 2 | 3 | GET "LIBHDR" 4 | 5 | define { // AE OPERATORS AND SYMBOLS 6 | S.NUMBER=1; S.NAME=2; S.STRING=3; S.TRUE=4; S.FALSE=5 7 | S.VALOF=6; S.LV=7; S.RV=8; S.VECAP=9; S.FNAP=10 8 | S.MULT=11; S.DIV=12; S.REM=13; S.PLUS=14; S.MINUS=15; S.QUERY=16 9 | S.NEG=17 10 | S.EQ=20; S.NE=21; S.LS=22; S.GR=23; S.LE=24; S.GE=25 11 | S.NOT=30; S.LSHIFT=31; S.RSHIFT=32; S.LOGAND=33; S.LOGOR=34 12 | S.EQV=35; S.NEQV=36; S.COND=37; S.COMMA=38; S.TABLE=39 13 | 14 | S.AND=40; S.VALDEF=41; S.VECDEF=42; S.CONSTDEF=43 15 | S.FNDEF=44; S.RTDEF=45 16 | 17 | S.ASS=50; S.RTAP=51; S.GOTO=52; S.RESULTIS=53 18 | S.COLON=54 19 | S.TEST=55; S.FOR=56; S.IF=57; S.UNLESS=58 20 | S.WHILE=59; S.UNTIL=60; S.REPEAT=61; S.REPEATWHILE=62 21 | S.REPEATUNTIL=63; S.LOOP=65; S.BREAK=66; S.RETURN=67; S.FINISH=68 22 | S.ENDCASE=69; S.SWITCHON=70; S.CASE=71; S.DEFAULT=72 23 | S.SEQ=73; S.LET=74; S.MANIFEST=75; S.GLOBAL=76 24 | S.LOCAL=77; S.LABEL=78; S.STATIC=79 25 | } 26 | 27 | define { // SELECTORS 28 | H1=0; H2=1; H3=2; H4=3; H5=4; H6=5 29 | } 30 | 31 | define { 32 | S.LP=40; S.LG=41; S.LN=42; S.LSTR=43; S.LL=44 33 | S.LLP=45; S.LLG=46; S.LLL=47 34 | 35 | S.SP=80; S.SG=81; S.SL=82; S.STIND=83 36 | S.JUMP=85; S.JT=86; S.JF=87 37 | S.LAB=90; S.STACK=91; S.STORE=92; S.RSTACK=93; S.ENTRY=94 38 | S.SAVE=95; S.FNRN=96; S.RTRN=97; S.RES=98; S.RESLAB=99 39 | S.DATALAB=100; S.ITEML=101; S.ITEMN=102 40 | S.ENDPROC=103 41 | } 42 | 43 | extern { 44 | OPTION:128 45 | PLIST:152 46 | 47 | CHARCODE:190; REPORTCOUNT:191; REPORTMAX:192 48 | SYSPRINT:194; OCODE:195 49 | 50 | TRANS:200; DECLNAMES:201; DECLDYN:202; DECLSTAT:203 51 | CHECKDISTINCT:204; ADDNAME:205; CELLWITHNAME:206 52 | TRANSDEF:207; SCANLABEL:208; DECLLABELS:209 53 | TRANSREPORT:210 54 | JUMPCOND:220; TRANSSWITCH:221; TRANSFOR:222 55 | ASSIGN:230; LOAD:231; LOADLV:232; LOADLIST:233; COMPDATALAB:234 56 | EVALCONST:235; LOADZERO:236; TRANSNAME:237 57 | COMPLAB:240; COMPJUMP:241; COMPENTRY:242 58 | NEXTPARAM:243; PARAMNUMBER:244; COMPILEAE:245 59 | 60 | WRC:250; OCOUNT:251; ENDOCODE:252; WRN:253; WRPN:254 61 | DVEC:260; DVECS:261; DVECE:262; DVECP:263; DVECT:264 62 | CASEK:265; CASEL:266; CASEP:267; CASET:268; CASEB:269 63 | CURRENTBRANCH:270 64 | BREAKLABEL:271; RESULTLABEL:272; DEFAULTLABEL:273; ENDCASELABEL:274 65 | LOOPLABEL:275 66 | SSP:280; VECSSP:281; SAVESPACESIZE:282 67 | GLOBDECL:285; GLOBDECLS:286; GLOBDECLT:287 68 | COMCOUNT:288 69 | } 70 | 71 | extern { 72 | OUT1:290; OUT2:291; OUT2P:292 73 | OUT3:293; OUT3P:294 74 | OUTN:295; OUTL:296; OUTC:297 75 | WRITEOP:298 76 | } 77 | -------------------------------------------------------------------------------- /test-tran/blib.b: -------------------------------------------------------------------------------- 1 | // BLIB 2 | 3 | GET "LIBHDR" 4 | 5 | unpackstring(s, v) 6 | { 7 | FOR i = 0 TO getbyte(s, 0) DO 8 | v!i := getbyte(s, i) 9 | } 10 | 11 | packstring(v, s) 12 | { 13 | auto n = v!0 & 255 14 | auto i = n/4 15 | FOR p = 0 TO n DO putbyte(s, p, v!p) 16 | SWITCHON n&3 INTO { 17 | CASE 0: putbyte(s, n+3, 0) 18 | CASE 1: putbyte(s, n+2, 0) 19 | CASE 2: putbyte(s, n+1, 0) 20 | CASE 3: 21 | } 22 | RESULTIS i 23 | } 24 | 25 | // The definitions that follow are machine independent 26 | 27 | writes(s) 28 | { 29 | FOR i = 1 TO getbyte(s, 0) DO 30 | wrch(getbyte(s, i)) 31 | } 32 | 33 | writed(n, d) 34 | { 35 | auto t = VEC 20 36 | auto i, k = 0, n 37 | IF n<0 DO 38 | d, k := d-1, -n 39 | t!i, k, i := k REM 10, k/10, i+1 REPEATUNTIL k=0 40 | FOR j = i+1 TO d DO 41 | wrch('*S') 42 | IF n<0 DO 43 | wrch('-') 44 | FOR j = i-1 TO 0 BY -1 DO 45 | wrch(t!j+'0') 46 | } 47 | 48 | writen(n) 49 | { 50 | writed(n, 0) 51 | } 52 | 53 | newline() 54 | { 55 | wrch('*N') 56 | } 57 | 58 | newpage() 59 | { 60 | wrch('*P') 61 | } 62 | 63 | readn() 64 | { 65 | auto sum = 0 66 | auto neg = FALSE 67 | 68 | L: terminator := rdch() 69 | SWITCHON terminator INTO { 70 | CASE '*S': 71 | CASE '*T': 72 | CASE '*N': GOTO L 73 | 74 | CASE '-': neg := TRUE 75 | CASE '+': terminator := rdch() 76 | } 77 | WHILE '0'<=terminator<='9' DO { 78 | sum := 10*sum + terminator - '0' 79 | terminator := rdch() 80 | } 81 | IF neg DO 82 | sum := -sum 83 | RESULTIS sum 84 | } 85 | 86 | writeoct(n, d) 87 | { 88 | IF d>1 DO 89 | writeoct(n>>3, d-1) 90 | wrch((n/\7)+'0') 91 | } 92 | 93 | writehex(n, d) 94 | { 95 | IF d>1 DO 96 | writehex(n>>4, d-1) 97 | wrch((n&15)!TABLE 98 | '0','1','2','3','4','5','6','7', 99 | '8','9','A','B','C','D','E','F') 100 | } 101 | 102 | writef(format, a, b, c, d, e, f, g, h, i, j, k) 103 | { 104 | auto t = @a 105 | 106 | FOR p = 1 TO getbyte(format, 0) DO { 107 | auto k = getbyte(format, p) 108 | 109 | TEST k='%' THEN { 110 | auto f, q, n = 0, t!0, 0 111 | auto type = getbyte(format, p+1) 112 | p := p + 1 113 | SWITCHON type INTO { 114 | DEFAULT: wrch(type); ENDCASE 115 | 116 | CASE 'S': f := writes; GOTO L 117 | CASE 'C': f := wrch; GOTO L 118 | CASE 'O': f := writeoct; GOTO M 119 | CASE 'X': f := writehex; GOTO M 120 | CASE 'I': f := writed; GOTO M 121 | CASE 'N': f := writed; GOTO L 122 | 123 | M: p := p + 1 124 | n := getbyte(format, p) 125 | n := '0'<=n<='9' -> n-'0', n-'A'+10 126 | 127 | L: f(q, n); t := t + 1 128 | } 129 | } 130 | OR wrch(k) 131 | } 132 | } 133 | -------------------------------------------------------------------------------- /test-tran/blib.bcpl: -------------------------------------------------------------------------------- 1 | // BLIB 2 | 3 | GET "LIBHDR" 4 | 5 | LET writes(s) BE 6 | FOR i = 1 TO getbyte(s, 0) DO wrch(getbyte(s, i)) 7 | 8 | AND unpackstring(s, v) BE 9 | FOR i = 0 TO getbyte(s, 0) DO 10 | v!i := getbyte(s, i) 11 | 12 | AND packstring(v, s) = VALOF 13 | $( 14 | LET n = v!0 & 255 15 | LET i = n/4 16 | FOR p = 0 TO n DO putbyte(s, p, v!p) 17 | SWITCHON n&3 INTO $( 18 | CASE 0: putbyte(s, n+3, 0) 19 | CASE 1: putbyte(s, n+2, 0) 20 | CASE 2: putbyte(s, n+1, 0) 21 | CASE 3: 22 | $) 23 | RESULTIS i 24 | $) 25 | 26 | // THE DEFINITIONS THAT FOLLOW ARE MACHINE INDEPENDENT 27 | 28 | AND writed(n, d) BE 29 | $(1 30 | LET t = VEC 20 31 | AND i, k = 0, n 32 | IF n<0 DO 33 | d, k := d-1, -n 34 | t!i, k, i := k REM 10, k/10, i+1 REPEATUNTIL k=0 35 | FOR j = i+1 TO d DO 36 | wrch('*S') 37 | IF n<0 DO 38 | wrch('-') 39 | FOR j = i-1 TO 0 BY -1 DO 40 | wrch(t!j+'0') 41 | $)1 42 | 43 | AND writen(n) BE writed(n, 0) 44 | 45 | AND newline() BE wrch('*N') 46 | 47 | AND newpage() BE wrch('*P') 48 | 49 | AND readn() = VALOF 50 | $(1 51 | LET sum = 0 52 | AND neg = FALSE 53 | 54 | L: terminator := rdch() 55 | SWITCHON terminator INTO $( 56 | CASE '*S': 57 | CASE '*T': 58 | CASE '*N': GOTO L 59 | 60 | CASE '-': neg := TRUE 61 | CASE '+': terminator := rdch() 62 | $) 63 | WHILE '0'<=terminator<='9' DO $( 64 | sum := 10*sum + terminator - '0' 65 | terminator := rdch() 66 | $) 67 | IF neg DO 68 | sum := -sum 69 | RESULTIS sum 70 | $)1 71 | 72 | AND writeoct(n, d) BE 73 | $( 74 | IF d>1 DO 75 | writeoct(n>>3, d-1) 76 | wrch((n/\7)+'0') 77 | $) 78 | 79 | AND writehex(n, d) BE 80 | $( 81 | IF d>1 DO 82 | writehex(n>>4, d-1) 83 | wrch((n&15)!TABLE 84 | '0','1','2','3','4','5','6','7', 85 | '8','9','A','B','C','D','E','F') 86 | $) 87 | 88 | AND writef(format, a, b, c, d, e, f, g, h, i, j, k) BE 89 | $(1 90 | LET t = @a 91 | 92 | FOR p = 1 TO getbyte(format, 0) DO $(2 93 | LET k = getbyte(format, p) 94 | 95 | TEST k='%' THEN $(3 96 | LET f, q, n = 0, t!0, 0 97 | AND TYPE = getbyte(format, p+1) 98 | p := p + 1 99 | SWITCHON TYPE INTO $( 100 | DEFAULT: wrch(TYPE); ENDCASE 101 | 102 | CASE 'S': f := writes; GOTO L 103 | CASE 'C': f := wrch; GOTO L 104 | CASE 'O': f := writeoct; GOTO M 105 | CASE 'X': f := writehex; GOTO M 106 | CASE 'I': f := writed; GOTO M 107 | CASE 'N': f := writed; GOTO L 108 | 109 | M: p := p + 1 110 | n := getbyte(format, p) 111 | n := '0'<=n<='9' -> n-'0', n-'A'+10 112 | 113 | L: f(q, n); t := t + 1 114 | $)3 115 | OR wrch(k) 116 | $)2 117 | $)1 118 | 119 | //AND mapstore() BE writes("*Nmapstore NOT IMPLEMENTED*N") 120 | -------------------------------------------------------------------------------- /test-tran/iclib.intcode: -------------------------------------------------------------------------------- 1 | 11 LIP2 X24 X4 G11L11 /SELECTINPUT 2 | 12 LIP2 X25 X4 G12L12 /SELECTOUTPUT 3 | 13 X26 X4 G13L13 /RDCH 4 | 14 LIP2 X27 X4 G14L14 /WRCH 5 | 42 LIP2 X28 X4 G42L42 /FINDINPUT 6 | 41 LIP2 X29 X4 G41L41 /FINDOUTPUT 7 | 30 LIP2 X30 X4 G30L30 /STOP 8 | 31 X31 X4 G31L31 /LEVEL 9 | 32 LIP3 LIP2 X32 G32L32 /LONGJUMP 10 | 46 X33 X4 G46L46 /ENDREAD 11 | 47 X34 X4 G47L47 /ENDWRITE 12 | 40 LIP3 LIP2 X35 G40L40 /APTOVEC 13 | 85 LIP3 LIP2 X36 X4 G85L85 / GETBYTE 14 | 86 LIP3 LIP2 X37 X4 G86L86 / PUTBYTE 15 | 16 X38 X4 G16L16 /INPUT 16 | 17 X39 X4 G17L17 /OUTPUT 17 | 15 LIP2 X40 X4 G15L15 /UNRDCH 18 | 35 X41 X4 G35L35 /REWIND 19 | Z 20 | -------------------------------------------------------------------------------- /test-tran/syn.b: -------------------------------------------------------------------------------- 1 | // MASTER 2 | 3 | GET "LIBHDR" 4 | 5 | extern { 6 | CHBUF:100; PRSOURCE:110 7 | PPTRACE:127; OPTION:128 8 | FORMTREE:150; PLIST:152 9 | TREEP:167; TREEVEC:168 10 | REPORTCOUNT:191; REPORTMAX:192 11 | SOURCESTREAM:193; SYSPRINT:194; OCODE:195; SYSIN:196 12 | COMPILEAE:245 13 | SAVESPACESIZE:282 14 | } 15 | 16 | COMP(V, TREEMAX) 17 | { 18 | auto B = VEC 63 19 | CHBUF := B 20 | { 21 | TREEP, TREEVEC := V+TREEMAX, V 22 | { 23 | auto A = FORMTREE() 24 | IF A=0 BREAK 25 | 26 | writef("*NTREE SIZE %N*N", TREEMAX+TREEVEC-TREEP) 27 | 28 | IF OPTION!2 DO { writes('AE TREE*N') 29 | PLIST(A, 0, 20) 30 | newline() } 31 | 32 | UNLESS REPORTCOUNT=0 DO stop(8) 33 | 34 | UNLESS OPTION!3 DO 35 | { selectoutput(OCODE) 36 | COMPILEAE(A) 37 | selectoutput(SYSPRINT) } 38 | } 39 | } REPEAT 40 | } 41 | 42 | start(PARM) 43 | { 44 | SYSIN := input() 45 | SYSPRINT := output() 46 | selectoutput(SYSPRINT) 47 | 48 | writef("*NBCPL %N*N", @start) 49 | 50 | { auto OPT = VEC 20 51 | auto TREESIZE = 5500 52 | OPTION := OPT 53 | SAVESPACESIZE := 2 54 | PPTRACE := FALSE 55 | PRSOURCE := FALSE 56 | FOR I = 0 TO 20 DO OPT!I := FALSE 57 | 58 | SOURCESTREAM := findinput("OPTIONS") 59 | 60 | UNLESS SOURCESTREAM=0 DO 61 | { auto CH = 0 62 | auto N = 0 63 | selectinput(SOURCESTREAM) 64 | writes("OPTIONS ") 65 | 66 | { CH := rdch() 67 | L: IF CH='*N' \/ CH=ENDSTREAMCH BREAK 68 | wrch(CH) 69 | IF CH='P' DO N := 1 70 | IF CH='T' DO N := 2 71 | IF CH='C' DO N := 3 72 | IF CH='M' DO N := 4 73 | IF CH='N' DO N := 5 74 | IF CH='S' DO PRSOURCE := TRUE 75 | IF CH='E' DO PPTRACE := TRUE 76 | IF CH='L' DO { TREESIZE := readn() 77 | writen(TREESIZE) 78 | CH := terminator 79 | GOTO L } 80 | IF CH='3' DO SAVESPACESIZE := 3 81 | OPTION!N := TRUE 82 | } REPEAT 83 | 84 | newline() 85 | endread() } 86 | 87 | REPORTMAX := 20 88 | REPORTCOUNT := 0 89 | 90 | 91 | 92 | SOURCESTREAM := SYSIN 93 | selectinput(SOURCESTREAM) 94 | 95 | OCODE := findoutput("OCODE") 96 | IF OCODE=0 DO OCODE := SYSPRINT 97 | 98 | { 99 | 100 | aptovec(COMP, TREESIZE) 101 | 102 | endread() 103 | //IF OPTION!4 DO mapstore() 104 | writes('*NPHASE 1 COMPLETE*N') 105 | UNLESS REPORTCOUNT=0 DO stop(8) 106 | FINISH 107 | }}} 108 | . 109 | 110 | // LEX1 111 | 112 | 113 | GET "SYNHDR" 114 | 115 | value(CH) 116 | { 117 | RESULTIS '0'<=CH<='9' -> CH-'0', 118 | 'A'<=CH<='F' -> CH-'A'+10, 119 | 100 120 | } 121 | 122 | readnumber(RADIX) 123 | { 124 | auto D = value(CH) 125 | DECVAL := D 126 | IF D>=RADIX DO CAEREPORT(33) 127 | 128 | { RCH() 129 | D := value(CH) 130 | IF D>=RADIX RETURN 131 | DECVAL := RADIX*DECVAL + D } REPEAT 132 | } 133 | 134 | NEXTSYMB() 135 | { 136 | NLPENDING := FALSE 137 | NEXT: 138 | IF PPTRACE DO wrch(CH) 139 | 140 | SWITCHON CH INTO { 141 | CASE '*P': 142 | CASE '*N': LINECOUNT := LINECOUNT + 1 143 | NLPENDING := TRUE // IGNORABLE CHARACTERS 144 | CASE '*T': 145 | CASE '*S': RCH() REPEATWHILE CH='*S' 146 | GOTO NEXT 147 | 148 | CASE '0':CASE '1':CASE '2':CASE '3':CASE '4': 149 | CASE '5':CASE '6':CASE '7':CASE '8':CASE '9': 150 | SYMB := S.NUMBER 151 | readnumber(10) 152 | RETURN 153 | 154 | CASE 'A':CASE 'B':CASE 'C':CASE 'D':CASE 'E': 155 | CASE 'F':CASE 'G':CASE 'H':CASE 'I':CASE 'J': 156 | CASE 'K':CASE 'L':CASE 'M':CASE 'N':CASE 'O': 157 | CASE 'P':CASE 'Q':CASE 'R':CASE 'S':CASE 'T': 158 | CASE 'U':CASE 'V':CASE 'W':CASE 'X':CASE 'Y': 159 | CASE 'Z': 160 | CASE 'a':CASE 'b':CASE 'c':CASE 'd':CASE 'e': 161 | CASE 'f':CASE 'g':CASE 'h':CASE 'i':CASE 'j': 162 | CASE 'k':CASE 'l':CASE 'm':CASE 'n':CASE 'o': 163 | CASE 'p':CASE 'q':CASE 'r':CASE 's':CASE 't': 164 | CASE 'u':CASE 'v':CASE 'w':CASE 'x':CASE 'y': 165 | CASE 'z': 166 | RDTAG(CH) 167 | SYMB := LOOKUPWORD() 168 | IF SYMB=S.GET DO { PERFORMGET(); GOTO NEXT } 169 | RETURN 170 | 171 | CASE '$': RCH() 172 | UNLESS CH='(' \/ CH=')' DO CAEREPORT(91) 173 | SYMB := CH='(' -> S.LSECT, S.RSECT 174 | RDTAG('$') 175 | LOOKUPWORD() 176 | RETURN 177 | 178 | CASE '[': 179 | CASE '(': SYMB := S.LPAREN; GOTO L 180 | CASE ']': 181 | CASE ')': SYMB := S.RPAREN; GOTO L 182 | 183 | CASE '#': SYMB := S.NUMBER 184 | RCH() 185 | IF '0'<=CH<='7' DO { readnumber(8); RETURN } 186 | IF CH='B' DO { RCH(); readnumber(2); RETURN } 187 | IF CH='O' DO { RCH(); readnumber(8); RETURN } 188 | IF CH='X' DO { RCH(); readnumber(16); RETURN } 189 | CAEREPORT(33) 190 | 191 | CASE '?': SYMB := S.QUERY; GOTO L 192 | CASE '+': SYMB := S.PLUS; GOTO L 193 | CASE ',': SYMB := S.COMMA; GOTO L 194 | CASE ';': SYMB := S.SEMICOLON; GOTO L 195 | CASE '@': SYMB := S.LV; GOTO L 196 | CASE '&': SYMB := S.LOGAND; GOTO L 197 | CASE '=': SYMB := S.EQ; GOTO L 198 | CASE '!': SYMB := S.VECAP; GOTO L 199 | CASE '_': SYMB := S.ASS; GOTO L 200 | CASE '**': SYMB := S.MULT; GOTO L 201 | 202 | CASE '/': RCH() 203 | IF CH='\' DO { SYMB := S.LOGAND; GOTO L } 204 | IF CH='/' GOTO COMMENT 205 | UNLESS CH='**' DO { SYMB := S.DIV; RETURN } 206 | 207 | RCH() 208 | 209 | UNTIL CH=ENDSTREAMCH DO TEST CH='**' 210 | 211 | THEN { RCH() 212 | UNLESS CH='/' LOOP 213 | RCH() 214 | GOTO NEXT } 215 | 216 | OR { IF CH='*N' DO LINECOUNT := LINECOUNT+1 217 | RCH() } 218 | 219 | CAEREPORT(63) 220 | 221 | 222 | COMMENT: RCH() REPEATUNTIL CH='*N' \/ CH=ENDSTREAMCH 223 | GOTO NEXT 224 | 225 | CASE '|': RCH() 226 | IF CH='|' GOTO COMMENT 227 | SYMB := S.LOGOR 228 | RETURN 229 | 230 | CASE '\': RCH() 231 | IF CH='/' DO { SYMB := S.LOGOR; GOTO L } 232 | IF CH='=' DO { SYMB := S.NE; GOTO L } 233 | SYMB := S.NOT 234 | RETURN 235 | 236 | CASE '<': RCH() 237 | IF CH='=' DO { SYMB := S.LE; GOTO L } 238 | IF CH='<' DO { SYMB := S.LSHIFT; GOTO L } 239 | SYMB := S.LS 240 | RETURN 241 | 242 | CASE '>': RCH() 243 | IF CH='=' DO { SYMB := S.GE; GOTO L } 244 | IF CH='>' DO { SYMB := S.RSHIFT; GOTO L } 245 | SYMB := S.GR 246 | RETURN 247 | 248 | CASE '-': RCH() 249 | IF CH='>' DO { SYMB := S.COND; GOTO L } 250 | SYMB := S.MINUS 251 | RETURN 252 | 253 | CASE ':': RCH() 254 | IF CH='=' DO { SYMB := S.ASS; GOTO L } 255 | SYMB := S.COLON 256 | RETURN 257 | 258 | CASE '*'':CASE '*"': 259 | { auto QUOTE = CH 260 | CHARP := 0 261 | 262 | { RCH() 263 | IF CH=QUOTE \/ CHARP=255 DO 264 | { UNLESS CH=QUOTE DO CAEREPORT(95) 265 | IF CHARP=1 & CH='*'' DO 266 | { SYMB := S.NUMBER 267 | GOTO L } 268 | CHARV!0 := CHARP 269 | WORDSIZE := packstring(CHARV, WORDV) 270 | SYMB := S.STRING 271 | GOTO L } 272 | 273 | 274 | IF CH='*N' DO LINECOUNT := LINECOUNT + 1 275 | 276 | IF CH='**' DO 277 | { RCH() 278 | IF CH='*N' DO 279 | { LINECOUNT := LINECOUNT+1 280 | RCH() REPEATWHILE CH='*S' \/ CH='*T' 281 | UNLESS CH='**' DO CAEREPORT(34) 282 | LOOP } 283 | IF CH='T' DO CH := '*T' 284 | IF CH='S' DO CH := '*S' 285 | IF CH='N' DO CH := '*N' 286 | IF CH='B' DO CH := '*B' 287 | IF CH='P' DO CH := '*P' } 288 | 289 | DECVAL, CHARP := CH, CHARP+1 290 | CHARV!CHARP := CH } REPEAT } 291 | 292 | 293 | 294 | DEFAULT: IF CH=ENDSTREAMCH DO 295 | CASE '.': { IF GETP=0 DO 296 | { SYMB := S.END 297 | RETURN } 298 | 299 | endread() 300 | GETP := GETP - 3 301 | SOURCESTREAM := GETV!GETP 302 | selectinput(SOURCESTREAM) 303 | LINECOUNT := GETV!(GETP+1) 304 | CH := GETV!(GETP+2) 305 | GOTO NEXT } 306 | 307 | CH := '*S' 308 | CAEREPORT(94) 309 | RCH() 310 | GOTO NEXT 311 | 312 | L: RCH() } 313 | } 314 | . 315 | 316 | // LEX2 317 | 318 | 319 | GET "SYNHDR" 320 | 321 | D(S, ITEM) 322 | { 323 | unpackstring(S, CHARV) 324 | WORDSIZE := packstring(CHARV, WORDV) 325 | LOOKUPWORD() 326 | WORDNODE!0 := ITEM 327 | } 328 | 329 | DECLSYSWORDS() 330 | { 331 | D("AND", S.AND) 332 | 333 | D("BE", S.BE) 334 | D("BREAK", S.BREAK) 335 | D("BY", S.BY) 336 | 337 | D("CASE", S.CASE) 338 | 339 | D("DO", S.DO) 340 | D("DEFAULT", S.DEFAULT) 341 | 342 | D("EQ", S.EQ) 343 | D("EQV", S.EQV) 344 | D("ELSE", S.OR) 345 | D("ENDCASE", S.ENDCASE) 346 | 347 | D("FALSE", S.FALSE) 348 | D("FOR", S.FOR) 349 | D("FINISH", S.FINISH) 350 | 351 | D("GOTO", S.GOTO) 352 | D("GE", S.GE) 353 | D("GR", S.GR) 354 | D("GLOBAL", S.GLOBAL) 355 | D("GET", S.GET) 356 | 357 | D("IF", S.IF) 358 | D("INTO", S.INTO) 359 | 360 | D("LET", S.LET) 361 | D("LV", S.LV) 362 | D("LE", S.LE) 363 | D("LS", S.LS) 364 | D("LOGOR", S.LOGOR) 365 | D("LOGAND", S.LOGAND) 366 | D("LOOP", S.LOOP) 367 | D("LSHIFT", S.LSHIFT) 368 | 369 | D("MANIFEST", S.MANIFEST) 370 | 371 | D("NE", S.NE) 372 | D("NOT", S.NOT) 373 | D("NEQV", S.NEQV) 374 | 375 | D("OR", S.OR) 376 | 377 | D("RESULTIS", S.RESULTIS) 378 | D("RETURN", S.RETURN) 379 | D("REM", S.REM) 380 | D("RSHIFT", S.RSHIFT) 381 | D("RV", S.RV) 382 | D("REPEAT", S.REPEAT) 383 | D("REPEATWHILE", S.REPEATWHILE) 384 | D("REPEATUNTIL", S.REPEATUNTIL) 385 | 386 | D("SWITCHON", S.SWITCHON) 387 | D("STATIC", S.STATIC) 388 | 389 | D("TO", S.TO) 390 | D("TEST", S.TEST) 391 | D("TRUE", S.TRUE) 392 | D("THEN", S.DO) 393 | D("TABLE", S.TABLE) 394 | 395 | D("UNTIL", S.UNTIL) 396 | D("UNLESS", S.UNLESS) 397 | 398 | D("VEC", S.VEC) 399 | D("VALOF", S.VALOF) 400 | 401 | D("WHILE", S.WHILE) 402 | 403 | D("$", 0); NULLTAG := WORDNODE 404 | } 405 | 406 | LOOKUPWORD() 407 | { 408 | auto HASHVAL = (WORDV!0+WORDV!WORDSIZE >> 1) REM NAMETABLESIZE 409 | auto M = @NAMETABLE!HASHVAL 410 | 411 | NEXT: WORDNODE := !M 412 | UNLESS WORDNODE=0 DO 413 | { FOR I = 0 TO WORDSIZE DO 414 | IF WORDNODE!(I+2) NE WORDV!I DO 415 | { M := WORDNODE+1 416 | GOTO NEXT } 417 | RESULTIS WORDNODE!0 } 418 | 419 | WORDNODE := NEWVEC(WORDSIZE+2) 420 | WORDNODE!0, WORDNODE!1 := S.NAME, NAMETABLE!HASHVAL 421 | FOR I = 0 TO WORDSIZE DO WORDNODE!(I+2) := WORDV!I 422 | NAMETABLE!HASHVAL := WORDNODE 423 | RESULTIS S.NAME 424 | } 425 | 426 | . 427 | 428 | // LEX3 429 | 430 | GET "SYNHDR" 431 | 432 | RCH() 433 | { 434 | CH := rdch() 435 | 436 | IF PRSOURCE DO IF GETP=0 /\ CH NE ENDSTREAMCH DO 437 | { UNLESS LINECOUNT=PRLINE DO { writef("%I4 ", LINECOUNT) 438 | PRLINE := LINECOUNT } 439 | wrch(CH) } 440 | 441 | CHCOUNT := CHCOUNT + 1 442 | CHBUF!(CHCOUNT&63) := CH 443 | } 444 | 445 | wrchbuf() 446 | { 447 | writes("*N...") 448 | FOR P = CHCOUNT-63 TO CHCOUNT DO 449 | { auto K = CHBUF!(P&63) 450 | UNLESS K=0 DO wrch(K) } 451 | newline() 452 | } 453 | 454 | RDTAG(X) 455 | { 456 | CHARP, CHARV!1 := 1, X 457 | 458 | { RCH() 459 | UNLESS 'A'<=CH<='Z' \/ 460 | 'a'<=CH<='z' \/ 461 | '0'<=CH<='9' \/ 462 | CH='.' BREAK 463 | CHARP := CHARP+1 464 | CHARV!CHARP := CH } REPEAT 465 | 466 | CHARV!0 := CHARP 467 | WORDSIZE := packstring(CHARV, WORDV) 468 | } 469 | 470 | append(D, S) 471 | { 472 | auto ND = getbyte(D, 0) 473 | auto NS = getbyte(S, 0) 474 | FOR I = 1 TO NS DO { 475 | ND := ND + 1 476 | putbyte(D, ND, getbyte(S, I)) } 477 | putbyte(D, 0, ND) 478 | } 479 | 480 | findlibinput(NAME) 481 | { 482 | auto PATH = VEC 64 483 | auto DIR = "/usr/lib/bcpl/" 484 | TEST getbyte(DIR, 0) + getbyte(NAME, 0) > 255 485 | THEN RESULTIS 0 486 | OR { putbyte(PATH, 0, 0) 487 | append(PATH, DIR) 488 | append(PATH, NAME) 489 | RESULTIS findinput(PATH) } 490 | } 491 | 492 | PERFORMGET() 493 | { 494 | NEXTSYMB() 495 | UNLESS SYMB=S.STRING THEN CAEREPORT(97) 496 | 497 | IF OPTION!5 RETURN 498 | 499 | GETV!GETP := SOURCESTREAM 500 | GETV!(GETP+1) := LINECOUNT 501 | GETV!(GETP+2) := CH 502 | GETP := GETP + 3 503 | LINECOUNT := 1 504 | SOURCESTREAM := findinput(WORDV) 505 | IF SOURCESTREAM=0 THEN 506 | SOURCESTREAM := findlibinput(WORDV) 507 | IF SOURCESTREAM=0 THEN CAEREPORT(96,WORDV) 508 | selectinput(SOURCESTREAM) 509 | RCH() 510 | } 511 | . 512 | 513 | // CAE0 514 | 515 | 516 | GET "SYNHDR" 517 | 518 | NEWVEC(N) 519 | { 520 | TREEP := TREEP - N - 1 521 | IF TREEP<=TREEVEC DO 522 | { REPORTMAX := 0 523 | CAEREPORT(98) } 524 | RESULTIS TREEP 525 | } 526 | 527 | LIST1(X) 528 | { 529 | auto P = NEWVEC(0) 530 | P!0 := X 531 | RESULTIS P 532 | } 533 | 534 | LIST2(X, Y) 535 | { 536 | auto P = NEWVEC(1) 537 | P!0, P!1 := X, Y 538 | RESULTIS P 539 | } 540 | 541 | LIST3(X, Y, Z) 542 | { 543 | auto P = NEWVEC(2) 544 | P!0, P!1, P!2 := X, Y, Z 545 | RESULTIS P 546 | } 547 | 548 | LIST4(X, Y, Z, T) 549 | { 550 | auto P = NEWVEC(3) 551 | P!0, P!1, P!2, P!3 := X, Y, Z, T 552 | RESULTIS P 553 | } 554 | 555 | LIST5(X, Y, Z, T, U) 556 | { 557 | auto P = NEWVEC(4) 558 | P!0, P!1, P!2, P!3, P!4 := X, Y, Z, T, U 559 | RESULTIS P 560 | } 561 | 562 | LIST6(X, Y, Z, T, U, V) 563 | { 564 | auto P = NEWVEC(5) 565 | P!0, P!1, P!2, P!3, P!4, P!5 := X, Y, Z, T, U, V 566 | RESULTIS P 567 | } 568 | 569 | caemessage(n, a) 570 | { 571 | auto s = 0; 572 | 573 | SWITCHON n INTO { 574 | DEFAULT: writen(n); RETURN 575 | 576 | CASE 91: s := "'8' '(' OR ')' EXPECTED"; ENDCASE 577 | CASE 94: s := "ILLEGAL CHARACTER"; ENDCASE 578 | CASE 95: s := "STRING TOO LONG"; ENDCASE 579 | CASE 96: s := "NO INPUT %S"; ENDCASE 580 | CASE 97: s := "STRING OR NUMBER EXPECTED"; ENDCASE 581 | CASE 98: s := "PROGRAM TOO LARGE"; ENDCASE 582 | CASE 99: s := "INCORRECT TERMINATION"; ENDCASE 583 | 584 | CASE 8:CASE 40:CASE 43: 585 | s := "NAME EXPECTED"; ENDCASE 586 | CASE 6: s := "'{' EXPECTED"; ENDCASE 587 | CASE 7: s := "'}' EXPECTED"; ENDCASE 588 | CASE 9: s := "UNTAGGED '}' MISMATCH"; ENDCASE 589 | CASE 32: s := "ERROR IN EXPRESSION"; ENDCASE 590 | CASE 33: s := "ERROR IN NUMBER"; ENDCASE 591 | CASE 34: s := "BAD STRING"; ENDCASE 592 | CASE 15:CASE 19:CASE 41: s := "')' MISSING"; ENDCASE 593 | CASE 30: s := "',' MISSING"; ENDCASE 594 | CASE 42: s := "'=' OR 'BE' EXPECTED"; ENDCASE 595 | CASE 44: s := "'=' OR '(' EXPECTED"; ENDCASE 596 | CASE 50: s := "ERROR IN LABEL"; ENDCASE 597 | CASE 51: s := "ERROR IN COMMAND"; ENDCASE 598 | CASE 54: s := "'OR' EXPECTED"; ENDCASE 599 | CASE 57: s := "'=' EXPECTED"; ENDCASE 600 | CASE 58: s := "'TO' EXPECTED"; ENDCASE 601 | CASE 60: s := "'INTO' EXPECTED"; ENDCASE 602 | CASE 61:CASE 62: s := "':' EXPECTED"; ENDCASE 603 | CASE 63: s := "'**/' MISSING"; ENDCASE 604 | } 605 | writef(s, a) 606 | } 607 | 608 | CAEREPORT(N, A) 609 | { 610 | REPORTCOUNT := REPORTCOUNT + 1 611 | writef("*NSYNTAX ERROR NEAR LINE %N: ", LINECOUNT) 612 | caemessage(N, A) 613 | wrchbuf() 614 | IF REPORTCOUNT GR REPORTMAX DO 615 | { writes('*NCOMPILATION ABORTED*N') 616 | stop(8) } 617 | NLPENDING := FALSE 618 | 619 | UNTIL SYMB=S.LSECT \/ SYMB=S.RSECT \/ 620 | SYMB=S.LET \/ SYMB=S.AND \/ 621 | SYMB=S.END \/ NLPENDING DO NEXTSYMB() 622 | longjump(REC.P, REC.L) 623 | } 624 | 625 | FORMTREE() 626 | { 627 | CHCOUNT := 0 628 | FOR I = 0 TO 63 DO CHBUF!I := 0 629 | 630 | { auto V = VEC 10 // FOR 'GET' STREAMS 631 | GETV, GETP, GETT := V, 0, 10 632 | 633 | { auto V = VEC 100 634 | WORDV := V 635 | 636 | { auto V = VEC 256 637 | CHARV, CHARP := V, 0 638 | 639 | { auto V = VEC 100 640 | NAMETABLE, NAMETABLESIZE := V, 100 641 | FOR I = 0 TO 100 DO NAMETABLE!I := 0 642 | 643 | REC.P, REC.L := level(), L 644 | 645 | LINECOUNT, PRLINE := 1, 0 646 | RCH() 647 | 648 | IF CH=ENDSTREAMCH RESULTIS 0 649 | DECLSYSWORDS() 650 | 651 | L: NEXTSYMB() 652 | 653 | IF OPTION!1 DO // PP DEBUGGING OPTION 654 | { writef("%N %S*N", SYMB, WORDV) 655 | IF SYMB=S.END RESULTIS 0 656 | GOTO L } 657 | 658 | { auto A = RDBLOCKBODY() 659 | UNLESS SYMB=S.END DO { CAEREPORT(99); GOTO L } 660 | 661 | RESULTIS A } 662 | }}}}} 663 | . 664 | 665 | // CAE1 666 | 667 | GET "SYNHDR" 668 | 669 | RDBLOCKBODY() 670 | { 671 | auto P, L = REC.P, REC.L 672 | auto A = 0 673 | 674 | REC.P, REC.L := level(), RECOVER 675 | 676 | IGNORE(S.SEMICOLON) 677 | 678 | SWITCHON SYMB INTO { 679 | CASE S.MANIFEST: 680 | CASE S.STATIC: 681 | CASE S.GLOBAL: 682 | { auto OP = SYMB 683 | NEXTSYMB() 684 | A := RDSECT(RDCDEFS) 685 | A := LIST3(OP, A, RDBLOCKBODY()) 686 | GOTO RET } 687 | 688 | 689 | CASE S.LET: NEXTSYMB() 690 | A := RDEF() 691 | RECOVER: WHILE SYMB=S.AND DO 692 | { NEXTSYMB() 693 | A := LIST3(S.AND, A, RDEF()) } 694 | A := LIST3(S.LET, A, RDBLOCKBODY()) 695 | GOTO RET 696 | 697 | DEFAULT: A := RDSEQ() 698 | 699 | UNLESS SYMB=S.RSECT \/ SYMB=S.END DO 700 | CAEREPORT(51) 701 | 702 | CASE S.RSECT: CASE S.END: 703 | RET: REC.P, REC.L := P, L 704 | RESULTIS A } 705 | } 706 | 707 | RDSEQ() 708 | { 709 | auto A = 0 710 | IGNORE(S.SEMICOLON) 711 | A := RCOM() 712 | IF SYMB=S.RSECT \/ SYMB=S.END RESULTIS A 713 | RESULTIS LIST3(S.SEQ, A, RDSEQ()) 714 | } 715 | 716 | RDCDEFS() 717 | { 718 | auto A, B = 0, 0 719 | auto PTR = @A 720 | auto P, L = REC.P, REC.L 721 | REC.P, REC.L := level(), RECOVER 722 | 723 | { B := RNAME() 724 | TEST SYMB=S.EQ \/ SYMB=S.COLON THEN NEXTSYMB() 725 | OR CAEREPORT(45) 726 | !PTR := LIST4(S.CONSTDEF, 0, B, REXP(0)) 727 | PTR := @H2!(!PTR) 728 | RECOVER: IGNORE(S.SEMICOLON) } REPEATWHILE SYMB=S.NAME 729 | 730 | REC.P, REC.L := P, L 731 | RESULTIS A 732 | } 733 | 734 | RDSECT(R) 735 | { 736 | auto TAG, A = WORDNODE, 0 737 | CHECKFOR(S.LSECT, 6) 738 | A := R() 739 | UNLESS SYMB=S.RSECT DO CAEREPORT(7) 740 | TEST TAG=WORDNODE 741 | THEN NEXTSYMB() 742 | OR IF WORDNODE=NULLTAG DO 743 | { SYMB := 0 744 | CAEREPORT(9) } 745 | RESULTIS A 746 | } 747 | 748 | RNAMELIST() 749 | { 750 | auto A = RNAME() 751 | UNLESS SYMB=S.COMMA RESULTIS A 752 | NEXTSYMB() 753 | RESULTIS LIST3(S.COMMA, A, RNAMELIST()) 754 | } 755 | 756 | RNAME() 757 | { 758 | auto A = WORDNODE 759 | CHECKFOR(S.NAME, 8) 760 | RESULTIS A 761 | } 762 | 763 | IGNORE(ITEM) 764 | { 765 | IF SYMB=ITEM DO NEXTSYMB() 766 | } 767 | 768 | CHECKFOR(ITEM, N) 769 | { 770 | UNLESS SYMB=ITEM DO CAEREPORT(N) 771 | NEXTSYMB() 772 | } 773 | . 774 | 775 | // CAE2 776 | 777 | GET "SYNHDR" 778 | 779 | RBEXP() 780 | { 781 | auto A, OP = 0, SYMB 782 | 783 | SWITCHON SYMB INTO { 784 | DEFAULT: 785 | CAEREPORT(32) 786 | 787 | CASE S.QUERY: 788 | NEXTSYMB(); RESULTIS LIST1(S.QUERY) 789 | 790 | CASE S.TRUE: 791 | CASE S.FALSE: 792 | CASE S.NAME: 793 | A := WORDNODE 794 | NEXTSYMB() 795 | RESULTIS A 796 | 797 | CASE S.STRING: 798 | A := NEWVEC(WORDSIZE+1) 799 | A!0 := S.STRING 800 | FOR I = 0 TO WORDSIZE DO A!(I+1) := WORDV!I 801 | NEXTSYMB() 802 | RESULTIS A 803 | 804 | CASE S.NUMBER: 805 | A := LIST2(S.NUMBER, DECVAL) 806 | NEXTSYMB() 807 | RESULTIS A 808 | 809 | CASE S.LPAREN: 810 | NEXTSYMB() 811 | A := REXP(0) 812 | CHECKFOR(S.RPAREN, 15) 813 | RESULTIS A 814 | 815 | CASE S.VALOF: 816 | NEXTSYMB() 817 | RESULTIS LIST2(S.VALOF, RCOM()) 818 | 819 | CASE S.VECAP: OP := S.RV 820 | CASE S.LV: 821 | CASE S.RV: NEXTSYMB(); RESULTIS LIST2(OP, REXP(35)) 822 | 823 | CASE S.PLUS: NEXTSYMB(); RESULTIS REXP(34) 824 | 825 | CASE S.MINUS: NEXTSYMB() 826 | A := REXP(34) 827 | TEST H1!A=S.NUMBER 828 | THEN H2!A := - H2!A 829 | OR A := LIST2(S.NEG, A) 830 | RESULTIS A 831 | 832 | CASE S.NOT: NEXTSYMB(); RESULTIS LIST2(S.NOT, REXP(24)) 833 | 834 | CASE S.TABLE: NEXTSYMB() 835 | RESULTIS LIST2(S.TABLE, REXPLIST()) } 836 | } 837 | 838 | REXP(N) 839 | { 840 | auto A = RBEXP() 841 | 842 | auto B, C, P, Q = 0, 0, 0, 0 843 | 844 | L: { auto OP = SYMB 845 | 846 | IF NLPENDING RESULTIS A 847 | 848 | SWITCHON OP INTO 849 | { DEFAULT: RESULTIS A 850 | 851 | CASE S.LPAREN: NEXTSYMB() 852 | B := 0 853 | UNLESS SYMB=S.RPAREN DO B := REXPLIST() 854 | CHECKFOR(S.RPAREN, 19) 855 | A := LIST3(S.FNAP, A, B) 856 | GOTO L 857 | 858 | CASE S.VECAP: P := 40; GOTO LASSOC 859 | 860 | CASE S.REM:CASE S.MULT:CASE S.DIV: P := 35; GOTO LASSOC 861 | 862 | CASE S.PLUS:CASE S.MINUS: P := 34; GOTO LASSOC 863 | 864 | CASE S.EQ:CASE S.NE: 865 | CASE S.LE:CASE S.GE: 866 | CASE S.LS:CASE S.GR: 867 | IF N>=30 RESULTIS A 868 | 869 | { NEXTSYMB() 870 | B := REXP(30) 871 | A := LIST3(OP, A, B) 872 | TEST C=0 THEN C := A 873 | OR C := LIST3(S.LOGAND, C, A) 874 | A, OP := B, SYMB } REPEATWHILE S.EQ<=OP<=S.GE 875 | 876 | A := C 877 | GOTO L 878 | 879 | CASE S.LSHIFT:CASE S.RSHIFT: P, Q := 25, 30; GOTO DIADIC 880 | 881 | CASE S.LOGAND: P := 23; GOTO LASSOC 882 | 883 | CASE S.LOGOR: P := 22; GOTO LASSOC 884 | 885 | CASE S.EQV:CASE S.NEQV: P := 21; GOTO LASSOC 886 | 887 | CASE S.COND: 888 | IF N>=13 RESULTIS A 889 | NEXTSYMB() 890 | B := REXP(0) 891 | CHECKFOR(S.COMMA, 30) 892 | A := LIST4(S.COND, A, B, REXP(0)) 893 | GOTO L 894 | 895 | LASSOC: Q := P 896 | 897 | DIADIC: IF N>=P RESULTIS A 898 | NEXTSYMB() 899 | A := LIST3(OP, A, REXP(Q)) 900 | GOTO L } } 901 | } 902 | 903 | REXPLIST() 904 | { 905 | auto A = 0 906 | auto PTR = @A 907 | 908 | { auto B = REXP(0) 909 | UNLESS SYMB=S.COMMA DO { !PTR := B 910 | RESULTIS A } 911 | NEXTSYMB() 912 | !PTR := LIST3(S.COMMA, B, 0) 913 | PTR := @H3!(!PTR) } REPEAT 914 | } 915 | 916 | RDEF() 917 | { 918 | auto N = RNAMELIST() 919 | 920 | SWITCHON SYMB INTO { 921 | CASE S.LPAREN: 922 | { auto A = 0 923 | NEXTSYMB() 924 | UNLESS H1!N=S.NAME DO CAEREPORT(40) 925 | IF SYMB=S.NAME DO A := RNAMELIST() 926 | CHECKFOR(S.RPAREN, 41) 927 | 928 | IF SYMB=S.BE DO 929 | { NEXTSYMB() 930 | RESULTIS LIST5(S.RTDEF, N, A, RCOM(), 0) } 931 | 932 | IF SYMB=S.EQ DO 933 | { NEXTSYMB() 934 | RESULTIS LIST5(S.FNDEF, N, A, REXP(0), 0) } 935 | 936 | CAEREPORT(42) } 937 | 938 | DEFAULT: CAEREPORT(44) 939 | 940 | CASE S.EQ: 941 | NEXTSYMB() 942 | IF SYMB=S.VEC DO 943 | { NEXTSYMB() 944 | UNLESS H1!N=S.NAME DO CAEREPORT(43) 945 | RESULTIS LIST3(S.VECDEF, N, REXP(0)) } 946 | RESULTIS LIST3(S.VALDEF, N, REXPLIST()) } 947 | } 948 | . 949 | 950 | // CAE4 951 | 952 | GET "SYNHDR" 953 | 954 | RBCOM() 955 | { 956 | auto A, B, OP = 0, 0, SYMB 957 | 958 | SWITCHON SYMB INTO { 959 | DEFAULT: RESULTIS 0 960 | 961 | CASE S.NAME:CASE S.NUMBER:CASE S.STRING: 962 | CASE S.TRUE:CASE S.FALSE:CASE S.LV:CASE S.RV:CASE S.VECAP: 963 | CASE S.LPAREN: 964 | A := REXPLIST() 965 | 966 | IF SYMB=S.ASS THEN 967 | { OP := SYMB 968 | NEXTSYMB() 969 | RESULTIS LIST3(OP, A, REXPLIST()) } 970 | 971 | IF SYMB=S.COLON DO 972 | { UNLESS H1!A=S.NAME DO CAEREPORT(50) 973 | NEXTSYMB() 974 | RESULTIS LIST4(S.COLON, A, RBCOM(), 0) } 975 | 976 | IF H1!A=S.FNAP DO 977 | { H1!A := S.RTAP 978 | RESULTIS A } 979 | 980 | CAEREPORT(51) 981 | RESULTIS A 982 | 983 | CASE S.GOTO:CASE S.RESULTIS: 984 | NEXTSYMB() 985 | RESULTIS LIST2(OP, REXP(0)) 986 | 987 | CASE S.IF:CASE S.UNLESS: 988 | CASE S.WHILE:CASE S.UNTIL: 989 | NEXTSYMB() 990 | A := REXP(0) 991 | IGNORE(S.DO) 992 | RESULTIS LIST3(OP, A, RCOM()) 993 | 994 | CASE S.TEST: 995 | NEXTSYMB() 996 | A := REXP(0) 997 | IGNORE(S.DO) 998 | B := RCOM() 999 | CHECKFOR(S.OR, 54) 1000 | RESULTIS LIST4(S.TEST, A, B, RCOM()) 1001 | 1002 | CASE S.FOR: 1003 | { auto I, J, K = 0, 0, 0 1004 | NEXTSYMB() 1005 | A := RNAME() 1006 | CHECKFOR(S.EQ, 57) 1007 | I := REXP(0) 1008 | CHECKFOR(S.TO, 58) 1009 | J := REXP(0) 1010 | IF SYMB=S.BY DO { NEXTSYMB() 1011 | K := REXP(0) } 1012 | IGNORE(S.DO) 1013 | RESULTIS LIST6(S.FOR, A, I, J, K, RCOM()) } 1014 | 1015 | CASE S.LOOP: 1016 | CASE S.BREAK:CASE S.RETURN:CASE S.FINISH:CASE S.ENDCASE: 1017 | A := WORDNODE 1018 | NEXTSYMB() 1019 | RESULTIS A 1020 | 1021 | CASE S.SWITCHON: 1022 | NEXTSYMB() 1023 | A := REXP(0) 1024 | CHECKFOR(S.INTO, 60) 1025 | RESULTIS LIST3(S.SWITCHON, A, RDSECT(RDSEQ)) 1026 | 1027 | CASE S.CASE: 1028 | NEXTSYMB() 1029 | A := REXP(0) 1030 | CHECKFOR(S.COLON, 61) 1031 | RESULTIS LIST3(S.CASE, A, RBCOM()) 1032 | 1033 | CASE S.DEFAULT: 1034 | NEXTSYMB() 1035 | CHECKFOR(S.COLON, 62) 1036 | RESULTIS LIST2(S.DEFAULT, RBCOM()) 1037 | 1038 | CASE S.LSECT: 1039 | RESULTIS RDSECT(RDBLOCKBODY) } 1040 | } 1041 | 1042 | RCOM() 1043 | { 1044 | auto A = RBCOM() 1045 | 1046 | IF A=0 DO CAEREPORT(51) 1047 | 1048 | WHILE SYMB=S.REPEAT \/ SYMB=S.REPEATWHILE \/ 1049 | SYMB=S.REPEATUNTIL DO 1050 | { auto OP = SYMB 1051 | NEXTSYMB() 1052 | TEST OP=S.REPEAT 1053 | THEN A := LIST2(OP, A) 1054 | OR A := LIST3(OP, A, REXP(0)) } 1055 | 1056 | RESULTIS A 1057 | } 1058 | . 1059 | 1060 | // PLIST 1061 | 1062 | GET "SYNHDR" 1063 | 1064 | PLIST(X, N, D) 1065 | { 1066 | auto SIZE = 0 1067 | auto V = TABLE 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 1068 | 1069 | IF X=0 DO { writes("NIL"); RETURN } 1070 | 1071 | SWITCHON H1!X INTO 1072 | { CASE S.NUMBER: writen(H2!X); RETURN 1073 | 1074 | CASE S.NAME: writes(X+2); RETURN 1075 | 1076 | CASE S.STRING: writef("*"%S*"", X+1); RETURN 1077 | 1078 | CASE S.FOR: 1079 | SIZE := SIZE + 2 1080 | 1081 | CASE S.COND:CASE S.FNDEF:CASE S.RTDEF: 1082 | CASE S.TEST:CASE S.CONSTDEF: 1083 | SIZE := SIZE + 1 1084 | 1085 | CASE S.VECAP:CASE S.FNAP: 1086 | CASE S.MULT:CASE S.DIV:CASE S.REM:CASE S.PLUS:CASE S.MINUS: 1087 | CASE S.EQ:CASE S.NE:CASE S.LS:CASE S.GR:CASE S.LE:CASE S.GE: 1088 | CASE S.LSHIFT:CASE S.RSHIFT:CASE S.LOGAND:CASE S.LOGOR: 1089 | CASE S.EQV:CASE S.NEQV:CASE S.COMMA: 1090 | CASE S.AND:CASE S.VALDEF:CASE S.VECDEF: 1091 | CASE S.ASS:CASE S.RTAP:CASE S.COLON:CASE S.IF:CASE S.UNLESS: 1092 | CASE S.WHILE:CASE S.UNTIL:CASE S.REPEATWHILE: 1093 | CASE S.REPEATUNTIL: 1094 | CASE S.SWITCHON:CASE S.CASE:CASE S.SEQ:CASE S.LET: 1095 | CASE S.MANIFEST:CASE S.STATIC:CASE S.GLOBAL: 1096 | SIZE := SIZE + 1 1097 | 1098 | CASE S.VALOF:CASE S.LV:CASE S.RV:CASE S.NEG:CASE S.NOT: 1099 | CASE S.TABLE:CASE S.GOTO:CASE S.RESULTIS:CASE S.REPEAT: 1100 | CASE S.DEFAULT: 1101 | SIZE := SIZE + 1 1102 | 1103 | CASE S.LOOP: 1104 | CASE S.BREAK:CASE S.RETURN:CASE S.FINISH:CASE S.ENDCASE: 1105 | CASE S.TRUE:CASE S.FALSE:CASE S.QUERY: 1106 | DEFAULT: 1107 | SIZE := SIZE + 1 1108 | 1109 | IF N=D DO { writes("ETC") 1110 | RETURN } 1111 | 1112 | writes ("OP") 1113 | writen(H1!X) 1114 | FOR I = 2 TO SIZE DO 1115 | { newline() 1116 | FOR J=0 TO N-1 DO writes( V!J ) 1117 | writes("**-") 1118 | V!N := I=SIZE->" ","! " 1119 | PLIST(H1!(X+I-1), N+1, D) } 1120 | RETURN } 1121 | } 1122 | -------------------------------------------------------------------------------- /test-tran/syn.bcpl: -------------------------------------------------------------------------------- 1 | // MASTER 2 | 3 | GET "LIBHDR" 4 | 5 | GLOBAL $( 6 | CHBUF:100; PRSOURCE:110 7 | PPTRACE:127; OPTION:128 8 | FORMTREE:150; PLIST:152 9 | TREEP:167; TREEVEC:168 10 | REPORTCOUNT:191; REPORTMAX:192 11 | SOURCESTREAM:193; SYSPRINT:194; OCODE:195; SYSIN:196 12 | COMPILEAE:245 13 | SAVESPACESIZE:282 14 | $) 15 | 16 | LET start(PARM) BE 17 | $(1 18 | SYSIN := input() 19 | SYSPRINT := output() 20 | selectoutput(SYSPRINT) 21 | 22 | writef("*NBCPL %N*N", @start) 23 | 24 | $( LET OPT = VEC 20 25 | AND TREESIZE = 5500 26 | OPTION := OPT 27 | SAVESPACESIZE := 2 28 | PPTRACE := FALSE 29 | PRSOURCE := FALSE 30 | FOR I = 0 TO 20 DO OPT!I := FALSE 31 | 32 | SOURCESTREAM := findinput("OPTIONS") 33 | 34 | UNLESS SOURCESTREAM=0 DO 35 | $(P LET CH = 0 36 | AND N = 0 37 | selectinput(SOURCESTREAM) 38 | writes("OPTIONS ") 39 | 40 | $( CH := rdch() 41 | L: IF CH='*N' \/ CH=ENDSTREAMCH BREAK 42 | wrch(CH) 43 | IF CH='P' DO N := 1 44 | IF CH='T' DO N := 2 45 | IF CH='C' DO N := 3 46 | IF CH='M' DO N := 4 47 | IF CH='N' DO N := 5 48 | IF CH='S' DO PRSOURCE := TRUE 49 | IF CH='E' DO PPTRACE := TRUE 50 | IF CH='L' DO $( TREESIZE := readn() 51 | writen(TREESIZE) 52 | CH := terminator 53 | GOTO L $) 54 | IF CH='3' DO SAVESPACESIZE := 3 55 | OPTION!N := TRUE 56 | $) REPEAT 57 | 58 | newline() 59 | endread() $)P 60 | 61 | REPORTMAX := 20 62 | REPORTCOUNT := 0 63 | 64 | 65 | 66 | SOURCESTREAM := SYSIN 67 | selectinput(SOURCESTREAM) 68 | 69 | OCODE := findoutput("OCODE") 70 | IF OCODE=0 DO OCODE := SYSPRINT 71 | 72 | $(2 LET COMP(V, TREEMAX) BE 73 | $(C LET B = VEC 63 74 | CHBUF := B 75 | 76 | $(3 TREEP, TREEVEC := V+TREEMAX, V 77 | 78 | $( LET A = FORMTREE() 79 | IF A=0 BREAK 80 | 81 | writef("*NTREE SIZE %N*N", TREEMAX+TREEVEC-TREEP) 82 | 83 | IF OPTION!2 DO $( writes('AE TREE*N') 84 | PLIST(A, 0, 20) 85 | newline() $) 86 | 87 | 88 | UNLESS REPORTCOUNT=0 DO stop(8) 89 | 90 | UNLESS OPTION!3 DO 91 | $( selectoutput(OCODE) 92 | COMPILEAE(A) 93 | selectoutput(SYSPRINT) $) 94 | 95 | $)3 REPEAT 96 | $)C 97 | 98 | aptovec(COMP, TREESIZE) 99 | 100 | endread() 101 | //IF OPTION!4 DO mapstore() 102 | writes('*NPHASE 1 COMPLETE*N') 103 | UNLESS REPORTCOUNT=0 DO stop(8) 104 | FINISH $)1 105 | . 106 | 107 | // LEX1 108 | 109 | 110 | GET "SYNHDR" 111 | 112 | LET NEXTSYMB() BE 113 | $(1 NLPENDING := FALSE 114 | 115 | NEXT: IF PPTRACE DO wrch(CH) 116 | 117 | SWITCHON CH INTO 118 | 119 | $( CASE '*P': 120 | CASE '*N': LINECOUNT := LINECOUNT + 1 121 | NLPENDING := TRUE // IGNORABLE CHARACTERS 122 | CASE '*T': 123 | CASE '*S': RCH() REPEATWHILE CH='*S' 124 | GOTO NEXT 125 | 126 | CASE '0':CASE '1':CASE '2':CASE '3':CASE '4': 127 | CASE '5':CASE '6':CASE '7':CASE '8':CASE '9': 128 | SYMB := S.NUMBER 129 | readnumber(10) 130 | RETURN 131 | 132 | CASE 'A':CASE 'B':CASE 'C':CASE 'D':CASE 'E': 133 | CASE 'F':CASE 'G':CASE 'H':CASE 'I':CASE 'J': 134 | CASE 'K':CASE 'L':CASE 'M':CASE 'N':CASE 'O': 135 | CASE 'P':CASE 'Q':CASE 'R':CASE 'S':CASE 'T': 136 | CASE 'U':CASE 'V':CASE 'W':CASE 'X':CASE 'Y': 137 | CASE 'Z': 138 | CASE 'a':CASE 'b':CASE 'c':CASE 'd':CASE 'e': 139 | CASE 'f':CASE 'g':CASE 'h':CASE 'i':CASE 'j': 140 | CASE 'k':CASE 'l':CASE 'm':CASE 'n':CASE 'o': 141 | CASE 'p':CASE 'q':CASE 'r':CASE 's':CASE 't': 142 | CASE 'u':CASE 'v':CASE 'w':CASE 'x':CASE 'y': 143 | CASE 'z': 144 | RDTAG(CH) 145 | SYMB := LOOKUPWORD() 146 | IF SYMB=S.GET DO $( PERFORMGET(); GOTO NEXT $) 147 | RETURN 148 | 149 | CASE '$': RCH() 150 | UNLESS CH='(' \/ CH=')' DO CAEREPORT(91) 151 | SYMB := CH='(' -> S.LSECT, S.RSECT 152 | RDTAG('$') 153 | LOOKUPWORD() 154 | RETURN 155 | 156 | CASE '[': 157 | CASE '(': SYMB := S.LPAREN; GOTO L 158 | CASE ']': 159 | CASE ')': SYMB := S.RPAREN; GOTO L 160 | 161 | CASE '#': SYMB := S.NUMBER 162 | RCH() 163 | IF '0'<=CH<='7' DO $( readnumber(8); RETURN $) 164 | IF CH='B' DO $( RCH(); readnumber(2); RETURN $) 165 | IF CH='O' DO $( RCH(); readnumber(8); RETURN $) 166 | IF CH='X' DO $( RCH(); readnumber(16); RETURN $) 167 | CAEREPORT(33) 168 | 169 | CASE '?': SYMB := S.QUERY; GOTO L 170 | CASE '+': SYMB := S.PLUS; GOTO L 171 | CASE ',': SYMB := S.COMMA; GOTO L 172 | CASE ';': SYMB := S.SEMICOLON; GOTO L 173 | CASE '@': SYMB := S.LV; GOTO L 174 | CASE '&': SYMB := S.LOGAND; GOTO L 175 | CASE '=': SYMB := S.EQ; GOTO L 176 | CASE '!': SYMB := S.VECAP; GOTO L 177 | CASE '_': SYMB := S.ASS; GOTO L 178 | CASE '**': SYMB := S.MULT; GOTO L 179 | 180 | CASE '/': RCH() 181 | IF CH='\' DO $( SYMB := S.LOGAND; GOTO L $) 182 | IF CH='/' GOTO COMMENT 183 | UNLESS CH='**' DO $( SYMB := S.DIV; RETURN $) 184 | 185 | RCH() 186 | 187 | UNTIL CH=ENDSTREAMCH DO TEST CH='**' 188 | 189 | THEN $( RCH() 190 | UNLESS CH='/' LOOP 191 | RCH() 192 | GOTO NEXT $) 193 | 194 | OR $( IF CH='*N' DO LINECOUNT := LINECOUNT+1 195 | RCH() $) 196 | 197 | CAEREPORT(63) 198 | 199 | 200 | COMMENT: RCH() REPEATUNTIL CH='*N' \/ CH=ENDSTREAMCH 201 | GOTO NEXT 202 | 203 | CASE '|': RCH() 204 | IF CH='|' GOTO COMMENT 205 | SYMB := S.LOGOR 206 | RETURN 207 | 208 | CASE '\': RCH() 209 | IF CH='/' DO $( SYMB := S.LOGOR; GOTO L $) 210 | IF CH='=' DO $( SYMB := S.NE; GOTO L $) 211 | SYMB := S.NOT 212 | RETURN 213 | 214 | CASE '<': RCH() 215 | IF CH='=' DO $( SYMB := S.LE; GOTO L $) 216 | IF CH='<' DO $( SYMB := S.LSHIFT; GOTO L $) 217 | SYMB := S.LS 218 | RETURN 219 | 220 | CASE '>': RCH() 221 | IF CH='=' DO $( SYMB := S.GE; GOTO L $) 222 | IF CH='>' DO $( SYMB := S.RSHIFT; GOTO L $) 223 | SYMB := S.GR 224 | RETURN 225 | 226 | CASE '-': RCH() 227 | IF CH='>' DO $( SYMB := S.COND; GOTO L $) 228 | SYMB := S.MINUS 229 | RETURN 230 | 231 | CASE ':': RCH() 232 | IF CH='=' DO $( SYMB := S.ASS; GOTO L $) 233 | SYMB := S.COLON 234 | RETURN 235 | 236 | CASE '*'':CASE '*"': 237 | $(1 LET QUOTE = CH 238 | CHARP := 0 239 | 240 | $( RCH() 241 | IF CH=QUOTE \/ CHARP=255 DO 242 | $( UNLESS CH=QUOTE DO CAEREPORT(95) 243 | IF CHARP=1 & CH='*'' DO 244 | $( SYMB := S.NUMBER 245 | GOTO L $) 246 | CHARV!0 := CHARP 247 | WORDSIZE := packstring(CHARV, WORDV) 248 | SYMB := S.STRING 249 | GOTO L $) 250 | 251 | 252 | IF CH='*N' DO LINECOUNT := LINECOUNT + 1 253 | 254 | IF CH='**' DO 255 | $( RCH() 256 | IF CH='*N' DO 257 | $( LINECOUNT := LINECOUNT+1 258 | RCH() REPEATWHILE CH='*S' \/ CH='*T' 259 | UNLESS CH='**' DO CAEREPORT(34) 260 | LOOP $) 261 | IF CH='T' DO CH := '*T' 262 | IF CH='S' DO CH := '*S' 263 | IF CH='N' DO CH := '*N' 264 | IF CH='B' DO CH := '*B' 265 | IF CH='P' DO CH := '*P' $) 266 | 267 | DECVAL, CHARP := CH, CHARP+1 268 | CHARV!CHARP := CH $) REPEAT $)1 269 | 270 | 271 | 272 | DEFAULT: IF CH=ENDSTREAMCH DO 273 | CASE '.': $( IF GETP=0 DO 274 | $( SYMB := S.END 275 | RETURN $) 276 | 277 | endread() 278 | GETP := GETP - 3 279 | SOURCESTREAM := GETV!GETP 280 | selectinput(SOURCESTREAM) 281 | LINECOUNT := GETV!(GETP+1) 282 | CH := GETV!(GETP+2) 283 | GOTO NEXT $) 284 | 285 | CH := '*S' 286 | CAEREPORT(94) 287 | RCH() 288 | GOTO NEXT 289 | 290 | L: RCH() $)1 291 | 292 | AND readnumber(RADIX) BE 293 | $( LET D = VALUE(CH) 294 | DECVAL := D 295 | IF D>=RADIX DO CAEREPORT(33) 296 | 297 | $( RCH() 298 | D := VALUE(CH) 299 | IF D>=RADIX RETURN 300 | DECVAL := RADIX*DECVAL + D $) REPEAT 301 | $) 302 | 303 | 304 | AND VALUE(CH) = '0'<=CH<='9' -> CH-'0', 305 | 'A'<=CH<='F' -> CH-'A'+10, 306 | 100 307 | 308 | . 309 | 310 | // LEX2 311 | 312 | 313 | GET "SYNHDR" 314 | 315 | LET D(S, ITEM) BE $( unpackstring(S, CHARV) 316 | WORDSIZE := packstring(CHARV, WORDV) 317 | LOOKUPWORD() 318 | WORDNODE!0 := ITEM $) 319 | 320 | AND DECLSYSWORDS() BE 321 | $( D("AND", S.AND) 322 | 323 | D("BE", S.BE) 324 | D("BREAK", S.BREAK) 325 | D("BY", S.BY) 326 | 327 | D("CASE", S.CASE) 328 | 329 | D("DO", S.DO) 330 | D("DEFAULT", S.DEFAULT) 331 | 332 | D("EQ", S.EQ) 333 | D("EQV", S.EQV) 334 | D("ELSE", S.OR) 335 | D("ENDCASE", S.ENDCASE) 336 | 337 | D("FALSE", S.FALSE) 338 | D("FOR", S.FOR) 339 | D("FINISH", S.FINISH) 340 | 341 | D("GOTO", S.GOTO) 342 | D("GE", S.GE) 343 | D("GR", S.GR) 344 | D("GLOBAL", S.GLOBAL) 345 | D("GET", S.GET) 346 | 347 | D("IF", S.IF) 348 | D("INTO", S.INTO) 349 | 350 | D("LET", S.LET) 351 | D("LV", S.LV) 352 | D("LE", S.LE) 353 | D("LS", S.LS) 354 | D("LOGOR", S.LOGOR) 355 | D("LOGAND", S.LOGAND) 356 | D("LOOP", S.LOOP) 357 | D("LSHIFT", S.LSHIFT) 358 | 359 | D("MANIFEST", S.MANIFEST) 360 | 361 | D("NE", S.NE) 362 | D("NOT", S.NOT) 363 | D("NEQV", S.NEQV) 364 | 365 | D("OR", S.OR) 366 | 367 | D("RESULTIS", S.RESULTIS) 368 | D("RETURN", S.RETURN) 369 | D("REM", S.REM) 370 | D("RSHIFT", S.RSHIFT) 371 | D("RV", S.RV) 372 | D("REPEAT", S.REPEAT) 373 | D("REPEATWHILE", S.REPEATWHILE) 374 | D("REPEATUNTIL", S.REPEATUNTIL) 375 | 376 | D("SWITCHON", S.SWITCHON) 377 | D("STATIC", S.STATIC) 378 | 379 | D("TO", S.TO) 380 | D("TEST", S.TEST) 381 | D("TRUE", S.TRUE) 382 | D("THEN", S.DO) 383 | D("TABLE", S.TABLE) 384 | 385 | D("UNTIL", S.UNTIL) 386 | D("UNLESS", S.UNLESS) 387 | 388 | D("VEC", S.VEC) 389 | D("VALOF", S.VALOF) 390 | 391 | D("WHILE", S.WHILE) 392 | 393 | D("$", 0); NULLTAG := WORDNODE $) 394 | 395 | AND LOOKUPWORD() = VALOF 396 | 397 | $(1 LET HASHVAL = (WORDV!0+WORDV!WORDSIZE >> 1) REM NAMETABLESIZE 398 | LET M = @NAMETABLE!HASHVAL 399 | 400 | NEXT: WORDNODE := !M 401 | UNLESS WORDNODE=0 DO 402 | $(2 FOR I = 0 TO WORDSIZE DO 403 | IF WORDNODE!(I+2) NE WORDV!I DO 404 | $( M := WORDNODE+1 405 | GOTO NEXT $) 406 | RESULTIS WORDNODE!0 $)2 407 | 408 | WORDNODE := NEWVEC(WORDSIZE+2) 409 | WORDNODE!0, WORDNODE!1 := S.NAME, NAMETABLE!HASHVAL 410 | FOR I = 0 TO WORDSIZE DO WORDNODE!(I+2) := WORDV!I 411 | NAMETABLE!HASHVAL := WORDNODE 412 | RESULTIS S.NAME 413 | $)1 414 | 415 | . 416 | 417 | // LEX3 418 | 419 | 420 | GET "SYNHDR" 421 | 422 | LET RCH() BE 423 | $( CH := rdch() 424 | 425 | IF PRSOURCE DO IF GETP=0 /\ CH NE ENDSTREAMCH DO 426 | $( UNLESS LINECOUNT=PRLINE DO $( writef("%I4 ", LINECOUNT) 427 | PRLINE := LINECOUNT $) 428 | wrch(CH) $) 429 | 430 | CHCOUNT := CHCOUNT + 1 431 | CHBUF!(CHCOUNT&63) := CH $) 432 | 433 | AND wrchbuf() BE 434 | $( writes("*N...") 435 | FOR P = CHCOUNT-63 TO CHCOUNT DO 436 | $( LET K = CHBUF!(P&63) 437 | UNLESS K=0 DO wrch(K) $) 438 | newline() $) 439 | 440 | 441 | AND RDTAG(X) BE 442 | $( CHARP, CHARV!1 := 1, X 443 | 444 | $( RCH() 445 | UNLESS 'A'<=CH<='Z' \/ 446 | 'a'<=CH<='z' \/ 447 | '0'<=CH<='9' \/ 448 | CH='.' BREAK 449 | CHARP := CHARP+1 450 | CHARV!CHARP := CH $) REPEAT 451 | 452 | CHARV!0 := CHARP 453 | WORDSIZE := packstring(CHARV, WORDV) $) 454 | 455 | 456 | AND PERFORMGET() BE 457 | $( NEXTSYMB() 458 | UNLESS SYMB=S.STRING THEN CAEREPORT(97) 459 | 460 | IF OPTION!5 RETURN 461 | 462 | GETV!GETP := SOURCESTREAM 463 | GETV!(GETP+1) := LINECOUNT 464 | GETV!(GETP+2) := CH 465 | GETP := GETP + 3 466 | LINECOUNT := 1 467 | SOURCESTREAM := findinput(WORDV) 468 | IF SOURCESTREAM=0 THEN 469 | SOURCESTREAM := findlibinput(WORDV) 470 | IF SOURCESTREAM=0 THEN CAEREPORT(96,WORDV) 471 | selectinput(SOURCESTREAM) 472 | RCH() $) 473 | 474 | AND APPEND(D, S) BE 475 | $( LET ND = getbyte(D, 0) 476 | AND NS = getbyte(S, 0) 477 | FOR I = 1 TO NS DO $( 478 | ND := ND + 1 479 | putbyte(D, ND, getbyte(S, I)) $) 480 | putbyte(D, 0, ND) $) 481 | 482 | AND findlibinput(NAME) = VALOF 483 | $( LET PATH = VEC 64 484 | AND DIR = "/usr/lib/bcpl/" 485 | TEST getbyte(DIR, 0) + getbyte(NAME, 0) > 255 486 | THEN RESULTIS 0 487 | OR $( putbyte(PATH, 0, 0) 488 | APPEND(PATH, DIR) 489 | APPEND(PATH, NAME) 490 | RESULTIS findinput(PATH) $) 491 | $) 492 | 493 | 494 | . 495 | 496 | // CAE0 497 | 498 | 499 | GET "SYNHDR" 500 | 501 | LET NEWVEC(N) = VALOF 502 | $( TREEP := TREEP - N - 1 503 | IF TREEP<=TREEVEC DO 504 | $( REPORTMAX := 0 505 | CAEREPORT(98) $) 506 | RESULTIS TREEP $) 507 | 508 | AND LIST1(X) = VALOF 509 | $( LET P = NEWVEC(0) 510 | P!0 := X 511 | RESULTIS P $) 512 | 513 | AND LIST2(X, Y) = VALOF 514 | $( LET P = NEWVEC(1) 515 | P!0, P!1 := X, Y 516 | RESULTIS P $) 517 | 518 | AND LIST3(X, Y, Z) = VALOF 519 | $( LET P = NEWVEC(2) 520 | P!0, P!1, P!2 := X, Y, Z 521 | RESULTIS P $) 522 | 523 | AND LIST4(X, Y, Z, T) = VALOF 524 | $( LET P = NEWVEC(3) 525 | P!0, P!1, P!2, P!3 := X, Y, Z, T 526 | RESULTIS P $) 527 | 528 | AND LIST5(X, Y, Z, T, U) = VALOF 529 | $( LET P = NEWVEC(4) 530 | P!0, P!1, P!2, P!3, P!4 := X, Y, Z, T, U 531 | RESULTIS P $) 532 | 533 | AND LIST6(X, Y, Z, T, U, V) = VALOF 534 | $( LET P = NEWVEC(5) 535 | P!0, P!1, P!2, P!3, P!4, P!5 := X, Y, Z, T, U, V 536 | RESULTIS P $) 537 | 538 | AND CAEREPORT(N, A) BE 539 | $( REPORTCOUNT := REPORTCOUNT + 1 540 | writef("*NSYNTAX ERROR NEAR LINE %N: ", LINECOUNT) 541 | CAEMESSAGE(N, A) 542 | wrchbuf() 543 | IF REPORTCOUNT GR REPORTMAX DO 544 | $( writes('*NCOMPILATION ABORTED*N') 545 | stop(8) $) 546 | NLPENDING := FALSE 547 | 548 | UNTIL SYMB=S.LSECT \/ SYMB=S.RSECT \/ 549 | SYMB=S.LET \/ SYMB=S.AND \/ 550 | SYMB=S.END \/ NLPENDING DO NEXTSYMB() 551 | longjump(REC.P, REC.L) $) 552 | 553 | AND FORMTREE() = VALOF 554 | $(1 CHCOUNT := 0 555 | FOR I = 0 TO 63 DO CHBUF!I := 0 556 | 557 | $( LET V = VEC 10 // FOR 'GET' STREAMS 558 | GETV, GETP, GETT := V, 0, 10 559 | 560 | $( LET V = VEC 100 561 | WORDV := V 562 | 563 | $( LET V = VEC 256 564 | CHARV, CHARP := V, 0 565 | 566 | $( LET V = VEC 100 567 | NAMETABLE, NAMETABLESIZE := V, 100 568 | FOR I = 0 TO 100 DO NAMETABLE!I := 0 569 | 570 | REC.P, REC.L := level(), L 571 | 572 | LINECOUNT, PRLINE := 1, 0 573 | RCH() 574 | 575 | IF CH=ENDSTREAMCH RESULTIS 0 576 | DECLSYSWORDS() 577 | 578 | L: NEXTSYMB() 579 | 580 | IF OPTION!1 DO // PP DEBUGGING OPTION 581 | $( writef("%N %S*N", SYMB, WORDV) 582 | IF SYMB=S.END RESULTIS 0 583 | GOTO L $) 584 | 585 | $( LET A = RDBLOCKBODY() 586 | UNLESS SYMB=S.END DO $( CAEREPORT(99); GOTO L $) 587 | 588 | RESULTIS A $)1 589 | 590 | 591 | 592 | AND CAEMESSAGE(N, A) BE 593 | $( LET S = VALOF 594 | 595 | SWITCHON N INTO 596 | 597 | $( DEFAULT: writen(N); RETURN 598 | 599 | CASE 91: RESULTIS "'8' '(' OR ')' EXPECTED" 600 | CASE 94: RESULTIS "ILLEGAL CHARACTER" 601 | CASE 95: RESULTIS "STRING TOO LONG" 602 | CASE 96: RESULTIS "NO INPUT %S" 603 | CASE 97: RESULTIS "STRING OR NUMBER EXPECTED" 604 | CASE 98: RESULTIS "PROGRAM TOO LARGE" 605 | CASE 99: RESULTIS "INCORRECT TERMINATION" 606 | 607 | CASE 8:CASE 40:CASE 43: 608 | RESULTIS "NAME EXPECTED" 609 | CASE 6: RESULTIS "'$(' EXPECTED" 610 | CASE 7: RESULTIS "'$)' EXPECTED" 611 | CASE 9: RESULTIS "UNTAGGED '$)' MISMATCH" 612 | CASE 32: RESULTIS "ERROR IN EXPRESSION" 613 | CASE 33: RESULTIS "ERROR IN NUMBER" 614 | CASE 34: RESULTIS "BAD STRING" 615 | CASE 15:CASE 19:CASE 41: RESULTIS "')' MISSING" 616 | CASE 30: RESULTIS "',' MISSING" 617 | CASE 42: RESULTIS "'=' OR 'BE' EXPECTED" 618 | CASE 44: RESULTIS "'=' OR '(' EXPECTED" 619 | CASE 50: RESULTIS "ERROR IN LABEL" 620 | CASE 51: RESULTIS "ERROR IN COMMAND" 621 | CASE 54: RESULTIS "'OR' EXPECTED" 622 | CASE 57: RESULTIS "'=' EXPECTED" 623 | CASE 58: RESULTIS "'TO' EXPECTED" 624 | CASE 60: RESULTIS "'INTO' EXPECTED" 625 | CASE 61:CASE 62: RESULTIS "':' EXPECTED" 626 | CASE 63: RESULTIS "'**/' MISSING" 627 | $) 628 | 629 | writef(S, A) $) 630 | 631 | 632 | . 633 | 634 | // CAE1 635 | 636 | 637 | GET "SYNHDR" 638 | 639 | LET RDBLOCKBODY() = VALOF 640 | $(1 LET P, L = REC.P, REC.L 641 | LET A = 0 642 | 643 | REC.P, REC.L := level(), RECOVER 644 | 645 | IGNORE(S.SEMICOLON) 646 | 647 | SWITCHON SYMB INTO 648 | $( CASE S.MANIFEST: 649 | CASE S.STATIC: 650 | CASE S.GLOBAL: 651 | $( LET OP = SYMB 652 | NEXTSYMB() 653 | A := RDSECT(RDCDEFS) 654 | A := LIST3(OP, A, RDBLOCKBODY()) 655 | GOTO RET $) 656 | 657 | 658 | CASE S.LET: NEXTSYMB() 659 | A := RDEF() 660 | RECOVER: WHILE SYMB=S.AND DO 661 | $( NEXTSYMB() 662 | A := LIST3(S.AND, A, RDEF()) $) 663 | A := LIST3(S.LET, A, RDBLOCKBODY()) 664 | GOTO RET 665 | 666 | DEFAULT: A := RDSEQ() 667 | 668 | UNLESS SYMB=S.RSECT \/ SYMB=S.END DO 669 | CAEREPORT(51) 670 | 671 | CASE S.RSECT: CASE S.END: 672 | RET: REC.P, REC.L := P, L 673 | RESULTIS A $)1 674 | 675 | AND RDSEQ() = VALOF 676 | $( LET A = 0 677 | IGNORE(S.SEMICOLON) 678 | A := RCOM() 679 | IF SYMB=S.RSECT \/ SYMB=S.END RESULTIS A 680 | RESULTIS LIST3(S.SEQ, A, RDSEQ()) $) 681 | 682 | 683 | AND RDCDEFS() = VALOF 684 | $(1 LET A, B = 0, 0 685 | LET PTR = @A 686 | LET P, L = REC.P, REC.L 687 | REC.P, REC.L := level(), RECOVER 688 | 689 | $( B := RNAME() 690 | TEST SYMB=S.EQ \/ SYMB=S.COLON THEN NEXTSYMB() 691 | OR CAEREPORT(45) 692 | !PTR := LIST4(S.CONSTDEF, 0, B, REXP(0)) 693 | PTR := @H2!(!PTR) 694 | RECOVER: IGNORE(S.SEMICOLON) $) REPEATWHILE SYMB=S.NAME 695 | 696 | REC.P, REC.L := P, L 697 | RESULTIS A $)1 698 | 699 | AND RDSECT(R) = VALOF 700 | $( LET TAG, A = WORDNODE, 0 701 | CHECKFOR(S.LSECT, 6) 702 | A := R() 703 | UNLESS SYMB=S.RSECT DO CAEREPORT(7) 704 | TEST TAG=WORDNODE 705 | THEN NEXTSYMB() 706 | OR IF WORDNODE=NULLTAG DO 707 | $( SYMB := 0 708 | CAEREPORT(9) $) 709 | RESULTIS A $) 710 | 711 | 712 | AND RNAMELIST() = VALOF 713 | $( LET A = RNAME() 714 | UNLESS SYMB=S.COMMA RESULTIS A 715 | NEXTSYMB() 716 | RESULTIS LIST3(S.COMMA, A, RNAMELIST()) $) 717 | 718 | 719 | AND RNAME() = VALOF 720 | $( LET A = WORDNODE 721 | CHECKFOR(S.NAME, 8) 722 | RESULTIS A $) 723 | 724 | AND IGNORE(ITEM) BE IF SYMB=ITEM DO NEXTSYMB() 725 | 726 | AND CHECKFOR(ITEM, N) BE 727 | $( UNLESS SYMB=ITEM DO CAEREPORT(N) 728 | NEXTSYMB() $) 729 | 730 | . 731 | 732 | // CAE2 733 | 734 | 735 | GET "SYNHDR" 736 | LET RBEXP() = VALOF 737 | $(1 LET A, OP = 0, SYMB 738 | 739 | SWITCHON SYMB INTO 740 | 741 | $( DEFAULT: 742 | CAEREPORT(32) 743 | 744 | CASE S.QUERY: 745 | NEXTSYMB(); RESULTIS LIST1(S.QUERY) 746 | 747 | CASE S.TRUE: 748 | CASE S.FALSE: 749 | CASE S.NAME: 750 | A := WORDNODE 751 | NEXTSYMB() 752 | RESULTIS A 753 | 754 | CASE S.STRING: 755 | A := NEWVEC(WORDSIZE+1) 756 | A!0 := S.STRING 757 | FOR I = 0 TO WORDSIZE DO A!(I+1) := WORDV!I 758 | NEXTSYMB() 759 | RESULTIS A 760 | 761 | CASE S.NUMBER: 762 | A := LIST2(S.NUMBER, DECVAL) 763 | NEXTSYMB() 764 | RESULTIS A 765 | 766 | CASE S.LPAREN: 767 | NEXTSYMB() 768 | A := REXP(0) 769 | CHECKFOR(S.RPAREN, 15) 770 | RESULTIS A 771 | 772 | CASE S.VALOF: 773 | NEXTSYMB() 774 | RESULTIS LIST2(S.VALOF, RCOM()) 775 | 776 | CASE S.VECAP: OP := S.RV 777 | CASE S.LV: 778 | CASE S.RV: NEXTSYMB(); RESULTIS LIST2(OP, REXP(35)) 779 | 780 | CASE S.PLUS: NEXTSYMB(); RESULTIS REXP(34) 781 | 782 | CASE S.MINUS: NEXTSYMB() 783 | A := REXP(34) 784 | TEST H1!A=S.NUMBER 785 | THEN H2!A := - H2!A 786 | OR A := LIST2(S.NEG, A) 787 | RESULTIS A 788 | 789 | CASE S.NOT: NEXTSYMB(); RESULTIS LIST2(S.NOT, REXP(24)) 790 | 791 | CASE S.TABLE: NEXTSYMB() 792 | RESULTIS LIST2(S.TABLE, REXPLIST()) $)1 793 | 794 | 795 | 796 | AND REXP(N) = VALOF 797 | $(1 LET A = RBEXP() 798 | 799 | LET B, C, P, Q = 0, 0, 0, 0 800 | 801 | L: $( LET OP = SYMB 802 | 803 | IF NLPENDING RESULTIS A 804 | 805 | SWITCHON OP INTO 806 | $(B DEFAULT: RESULTIS A 807 | 808 | CASE S.LPAREN: NEXTSYMB() 809 | B := 0 810 | UNLESS SYMB=S.RPAREN DO B := REXPLIST() 811 | CHECKFOR(S.RPAREN, 19) 812 | A := LIST3(S.FNAP, A, B) 813 | GOTO L 814 | 815 | CASE S.VECAP: P := 40; GOTO LASSOC 816 | 817 | CASE S.REM:CASE S.MULT:CASE S.DIV: P := 35; GOTO LASSOC 818 | 819 | CASE S.PLUS:CASE S.MINUS: P := 34; GOTO LASSOC 820 | 821 | CASE S.EQ:CASE S.NE: 822 | CASE S.LE:CASE S.GE: 823 | CASE S.LS:CASE S.GR: 824 | IF N>=30 RESULTIS A 825 | 826 | $(R NEXTSYMB() 827 | B := REXP(30) 828 | A := LIST3(OP, A, B) 829 | TEST C=0 THEN C := A 830 | OR C := LIST3(S.LOGAND, C, A) 831 | A, OP := B, SYMB $)R REPEATWHILE S.EQ<=OP<=S.GE 832 | 833 | A := C 834 | GOTO L 835 | 836 | CASE S.LSHIFT:CASE S.RSHIFT: P, Q := 25, 30; GOTO DIADIC 837 | 838 | CASE S.LOGAND: P := 23; GOTO LASSOC 839 | 840 | CASE S.LOGOR: P := 22; GOTO LASSOC 841 | 842 | CASE S.EQV:CASE S.NEQV: P := 21; GOTO LASSOC 843 | 844 | CASE S.COND: 845 | IF N>=13 RESULTIS A 846 | NEXTSYMB() 847 | B := REXP(0) 848 | CHECKFOR(S.COMMA, 30) 849 | A := LIST4(S.COND, A, B, REXP(0)) 850 | GOTO L 851 | 852 | LASSOC: Q := P 853 | 854 | DIADIC: IF N>=P RESULTIS A 855 | NEXTSYMB() 856 | A := LIST3(OP, A, REXP(Q)) 857 | GOTO L $)B $)1 858 | 859 | LET REXPLIST() = VALOF 860 | $(1 LET A = 0 861 | LET PTR = @A 862 | 863 | $( LET B = REXP(0) 864 | UNLESS SYMB=S.COMMA DO $( !PTR := B 865 | RESULTIS A $) 866 | NEXTSYMB() 867 | !PTR := LIST3(S.COMMA, B, 0) 868 | PTR := @H3!(!PTR) $) REPEAT 869 | $)1 870 | 871 | LET RDEF() = VALOF 872 | $(1 LET N = RNAMELIST() 873 | 874 | SWITCHON SYMB INTO 875 | 876 | $( CASE S.LPAREN: 877 | $( LET A = 0 878 | NEXTSYMB() 879 | UNLESS H1!N=S.NAME DO CAEREPORT(40) 880 | IF SYMB=S.NAME DO A := RNAMELIST() 881 | CHECKFOR(S.RPAREN, 41) 882 | 883 | IF SYMB=S.BE DO 884 | $( NEXTSYMB() 885 | RESULTIS LIST5(S.RTDEF, N, A, RCOM(), 0) $) 886 | 887 | IF SYMB=S.EQ DO 888 | $( NEXTSYMB() 889 | RESULTIS LIST5(S.FNDEF, N, A, REXP(0), 0) $) 890 | 891 | CAEREPORT(42) $) 892 | 893 | DEFAULT: CAEREPORT(44) 894 | 895 | CASE S.EQ: 896 | NEXTSYMB() 897 | IF SYMB=S.VEC DO 898 | $( NEXTSYMB() 899 | UNLESS H1!N=S.NAME DO CAEREPORT(43) 900 | RESULTIS LIST3(S.VECDEF, N, REXP(0)) $) 901 | RESULTIS LIST3(S.VALDEF, N, REXPLIST()) $)1 902 | 903 | . 904 | 905 | 906 | // CAE4 907 | 908 | 909 | 910 | GET "SYNHDR" 911 | 912 | LET RBCOM() = VALOF 913 | $(1 LET A, B, OP = 0, 0, SYMB 914 | 915 | SWITCHON SYMB INTO 916 | $( DEFAULT: RESULTIS 0 917 | 918 | CASE S.NAME:CASE S.NUMBER:CASE S.STRING: 919 | CASE S.TRUE:CASE S.FALSE:CASE S.LV:CASE S.RV:CASE S.VECAP: 920 | CASE S.LPAREN: 921 | A := REXPLIST() 922 | 923 | IF SYMB=S.ASS THEN 924 | $( OP := SYMB 925 | NEXTSYMB() 926 | RESULTIS LIST3(OP, A, REXPLIST()) $) 927 | 928 | IF SYMB=S.COLON DO 929 | $( UNLESS H1!A=S.NAME DO CAEREPORT(50) 930 | NEXTSYMB() 931 | RESULTIS LIST4(S.COLON, A, RBCOM(), 0) $) 932 | 933 | IF H1!A=S.FNAP DO 934 | $( H1!A := S.RTAP 935 | RESULTIS A $) 936 | 937 | CAEREPORT(51) 938 | RESULTIS A 939 | 940 | CASE S.GOTO:CASE S.RESULTIS: 941 | NEXTSYMB() 942 | RESULTIS LIST2(OP, REXP(0)) 943 | 944 | CASE S.IF:CASE S.UNLESS: 945 | CASE S.WHILE:CASE S.UNTIL: 946 | NEXTSYMB() 947 | A := REXP(0) 948 | IGNORE(S.DO) 949 | RESULTIS LIST3(OP, A, RCOM()) 950 | 951 | CASE S.TEST: 952 | NEXTSYMB() 953 | A := REXP(0) 954 | IGNORE(S.DO) 955 | B := RCOM() 956 | CHECKFOR(S.OR, 54) 957 | RESULTIS LIST4(S.TEST, A, B, RCOM()) 958 | 959 | CASE S.FOR: 960 | $( LET I, J, K = 0, 0, 0 961 | NEXTSYMB() 962 | A := RNAME() 963 | CHECKFOR(S.EQ, 57) 964 | I := REXP(0) 965 | CHECKFOR(S.TO, 58) 966 | J := REXP(0) 967 | IF SYMB=S.BY DO $( NEXTSYMB() 968 | K := REXP(0) $) 969 | IGNORE(S.DO) 970 | RESULTIS LIST6(S.FOR, A, I, J, K, RCOM()) $) 971 | 972 | CASE S.LOOP: 973 | CASE S.BREAK:CASE S.RETURN:CASE S.FINISH:CASE S.ENDCASE: 974 | A := WORDNODE 975 | NEXTSYMB() 976 | RESULTIS A 977 | 978 | CASE S.SWITCHON: 979 | NEXTSYMB() 980 | A := REXP(0) 981 | CHECKFOR(S.INTO, 60) 982 | RESULTIS LIST3(S.SWITCHON, A, RDSECT(RDSEQ)) 983 | 984 | CASE S.CASE: 985 | NEXTSYMB() 986 | A := REXP(0) 987 | CHECKFOR(S.COLON, 61) 988 | RESULTIS LIST3(S.CASE, A, RBCOM()) 989 | 990 | CASE S.DEFAULT: 991 | NEXTSYMB() 992 | CHECKFOR(S.COLON, 62) 993 | RESULTIS LIST2(S.DEFAULT, RBCOM()) 994 | 995 | CASE S.LSECT: 996 | RESULTIS RDSECT(RDBLOCKBODY) $)1 997 | 998 | 999 | AND RCOM() = VALOF 1000 | $(1 LET A = RBCOM() 1001 | 1002 | IF A=0 DO CAEREPORT(51) 1003 | 1004 | WHILE SYMB=S.REPEAT \/ SYMB=S.REPEATWHILE \/ 1005 | SYMB=S.REPEATUNTIL DO 1006 | $( LET OP = SYMB 1007 | NEXTSYMB() 1008 | TEST OP=S.REPEAT 1009 | THEN A := LIST2(OP, A) 1010 | OR A := LIST3(OP, A, REXP(0)) $) 1011 | 1012 | RESULTIS A $)1 1013 | 1014 | . 1015 | 1016 | // PLIST 1017 | 1018 | 1019 | GET "SYNHDR" 1020 | 1021 | LET PLIST(X, N, D) BE 1022 | $(1 LET SIZE = 0 1023 | LET V = TABLE 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 1024 | 1025 | IF X=0 DO $( writes("NIL"); RETURN $) 1026 | 1027 | SWITCHON H1!X INTO 1028 | $( CASE S.NUMBER: writen(H2!X); RETURN 1029 | 1030 | CASE S.NAME: writes(X+2); RETURN 1031 | 1032 | CASE S.STRING: writef("*"%S*"", X+1); RETURN 1033 | 1034 | CASE S.FOR: 1035 | SIZE := SIZE + 2 1036 | 1037 | CASE S.COND:CASE S.FNDEF:CASE S.RTDEF: 1038 | CASE S.TEST:CASE S.CONSTDEF: 1039 | SIZE := SIZE + 1 1040 | 1041 | CASE S.VECAP:CASE S.FNAP: 1042 | CASE S.MULT:CASE S.DIV:CASE S.REM:CASE S.PLUS:CASE S.MINUS: 1043 | CASE S.EQ:CASE S.NE:CASE S.LS:CASE S.GR:CASE S.LE:CASE S.GE: 1044 | CASE S.LSHIFT:CASE S.RSHIFT:CASE S.LOGAND:CASE S.LOGOR: 1045 | CASE S.EQV:CASE S.NEQV:CASE S.COMMA: 1046 | CASE S.AND:CASE S.VALDEF:CASE S.VECDEF: 1047 | CASE S.ASS:CASE S.RTAP:CASE S.COLON:CASE S.IF:CASE S.UNLESS: 1048 | CASE S.WHILE:CASE S.UNTIL:CASE S.REPEATWHILE: 1049 | CASE S.REPEATUNTIL: 1050 | CASE S.SWITCHON:CASE S.CASE:CASE S.SEQ:CASE S.LET: 1051 | CASE S.MANIFEST:CASE S.STATIC:CASE S.GLOBAL: 1052 | SIZE := SIZE + 1 1053 | 1054 | CASE S.VALOF:CASE S.LV:CASE S.RV:CASE S.NEG:CASE S.NOT: 1055 | CASE S.TABLE:CASE S.GOTO:CASE S.RESULTIS:CASE S.REPEAT: 1056 | CASE S.DEFAULT: 1057 | SIZE := SIZE + 1 1058 | 1059 | CASE S.LOOP: 1060 | CASE S.BREAK:CASE S.RETURN:CASE S.FINISH:CASE S.ENDCASE: 1061 | CASE S.TRUE:CASE S.FALSE:CASE S.QUERY: 1062 | DEFAULT: 1063 | SIZE := SIZE + 1 1064 | 1065 | IF N=D DO $( writes("ETC") 1066 | RETURN $) 1067 | 1068 | writes ("OP") 1069 | writen(H1!X) 1070 | FOR I = 2 TO SIZE DO 1071 | $( newline() 1072 | FOR J=0 TO N-1 DO writes( V!J ) 1073 | writes("**-") 1074 | V!N := I=SIZE->" ","! " 1075 | PLIST(H1!(X+I-1), N+1, D) $) 1076 | RETURN $)1 1077 | -------------------------------------------------------------------------------- /test-tran/trn.b: -------------------------------------------------------------------------------- 1 | // TRN0 2 | 3 | GET "TRNHDR" 4 | 5 | NEXTPARAM() 6 | { 7 | PARAMNUMBER := PARAMNUMBER + 1 8 | RESULTIS PARAMNUMBER 9 | } 10 | 11 | TRNMESSAGE(N) 12 | { 13 | auto S = 0 14 | 15 | SWITCHON N INTO { 16 | DEFAULT: writef("COMPILER ERROR %N", N); RETURN 17 | 18 | CASE 141: S := "TOO MANY CASES"; ENDCASE 19 | CASE 104: S := "ILLEGAL USE OF BREAK, LOOP OR RESULTIS"; ENDCASE 20 | CASE 101: 21 | CASE 105: S := "ILLEGAL USE OF CASE OR DEFAULT"; ENDCASE 22 | CASE 106: S := "TWO CASES WITH SAME CONSTANT"; ENDCASE 23 | CASE 144: S := "TOO MANY GLOBALS"; ENDCASE 24 | CASE 142: S := "NAME DECLARED TWICE"; ENDCASE 25 | CASE 143: S := "TOO MANY NAMES DECLARED"; ENDCASE 26 | CASE 115: S := "NAME NOT DECLARED"; ENDCASE 27 | CASE 116: S := "DYNAMIC FREE VARIABLE USED"; ENDCASE 28 | CASE 117: CASE 118: CASE 119: 29 | S := "ERROR IN CONSTANT EXPRESSION"; ENDCASE 30 | CASE 110: CASE 112: 31 | S := "LHS AND RHS DO NOT MATCH"; ENDCASE 32 | CASE 109: CASE 113: 33 | S := "LTYPE EXPRESSION EXPECTED"; ENDCASE 34 | } 35 | writes(S) 36 | } 37 | 38 | TRANSREPORT(N, X) 39 | { 40 | selectoutput(SYSPRINT) 41 | REPORTCOUNT := REPORTCOUNT + 1 42 | IF REPORTCOUNT GE REPORTMAX DO 43 | { writes("*NCOMPILATION ABORTED*N") 44 | stop(8) } 45 | writes("*NREPORT: "); TRNMESSAGE(N) 46 | writef("*NCOMMANDS COMPILED %N*N", COMCOUNT) 47 | PLIST(X, 0, 4); newline() 48 | selectoutput(OCODE) 49 | } 50 | 51 | COMPILEAE(X) 52 | { 53 | auto A = VEC 1200 54 | auto D = VEC 100 55 | auto K = VEC 150 56 | auto L = VEC 150 57 | 58 | DVEC, DVECS, DVECE, DVECP, DVECT := A, 3, 3, 3, 1200 59 | DVEC!0, DVEC!1, DVEC!2 := 0, 0, 0 60 | 61 | GLOBDECL, GLOBDECLS, GLOBDECLT := D, 0, 100 62 | 63 | CASEK, CASEL, CASEP, CASET, CASEB := K, L, 0, 150, -1 64 | ENDCASELABEL, DEFAULTLABEL := 0, 0 65 | 66 | RESULTLABEL, BREAKLABEL, LOOPLABEL := -1, -1, -1 67 | 68 | COMCOUNT, CURRENTBRANCH := 0, X 69 | 70 | OCOUNT := 0 71 | 72 | PARAMNUMBER := 0 73 | SSP := SAVESPACESIZE 74 | OUT2(S.STACK, SSP) 75 | DECLLABELS(X) 76 | TRANS(X) 77 | OUT2(S.GLOBAL, GLOBDECLS/2) 78 | 79 | { auto I = 0 80 | UNTIL I=GLOBDECLS DO 81 | { OUTN(GLOBDECL!I) 82 | OUTL(GLOBDECL!(I+1)) 83 | I := I + 2 } 84 | 85 | ENDOCODE() } 86 | } 87 | . 88 | 89 | // TRN1 90 | 91 | GET "TRNHDR" 92 | 93 | TRANS(X) 94 | { 95 | NEXT: 96 | { auto SW = FALSE 97 | IF X=0 RETURN 98 | CURRENTBRANCH := X 99 | 100 | SWITCHON H1!X INTO 101 | { DEFAULT: TRANSREPORT(100, X); RETURN 102 | 103 | CASE S.LET: 104 | { auto A, B, S, S1 = DVECE, DVECS, SSP, 0 105 | auto V = VECSSP 106 | DECLNAMES(H2!X) 107 | CHECKDISTINCT(B, DVECS) 108 | DVECE := DVECS 109 | VECSSP, S1 := SSP, SSP 110 | SSP := S 111 | TRANSDEF(H2!X) 112 | UNLESS SSP=S1 DO TRANSREPORT(110, X) 113 | UNLESS SSP=VECSSP DO { SSP := VECSSP 114 | OUT2(S.STACK, SSP) } 115 | OUT1(S.STORE) 116 | DECLLABELS(H3!X) 117 | TRANS(H3!X) 118 | VECSSP := V 119 | UNLESS SSP=S DO OUT2(S.STACK, S) 120 | DVECE, DVECS, SSP := A, B, S 121 | RETURN } 122 | 123 | CASE S.STATIC: 124 | CASE S.GLOBAL: 125 | CASE S.MANIFEST: 126 | { auto A, B, S = DVECE, DVECS, SSP 127 | auto OP = H1!X 128 | auto Y = H2!X 129 | 130 | IF OP=S.MANIFEST DO OP := S.NUMBER 131 | 132 | UNTIL Y=0 DO 133 | { TEST OP=S.STATIC THEN 134 | { auto M = NEXTPARAM() 135 | ADDNAME(H3!Y, S.LABEL, M) 136 | COMPDATALAB(M) 137 | OUT2(S.ITEMN, EVALCONST(H4!Y)) } 138 | 139 | OR ADDNAME(H3!Y, OP, EVALCONST(H4!Y)) 140 | 141 | Y := H2!Y 142 | DVECE := DVECS } 143 | 144 | DECLLABELS(H3!X) 145 | TRANS(H3!X) 146 | DVECE, DVECS, SSP := A, B, S 147 | RETURN } 148 | 149 | 150 | CASE S.ASS: 151 | ASSIGN(H2!X, H3!X) 152 | RETURN 153 | 154 | CASE S.RTAP: 155 | { auto S = SSP 156 | SSP := SSP+SAVESPACESIZE 157 | OUT2(S.STACK, SSP) 158 | LOADLIST(H3!X) 159 | LOAD(H2!X) 160 | OUT2(S.RTAP, S) 161 | SSP := S 162 | RETURN } 163 | 164 | CASE S.GOTO: 165 | LOAD(H2!X) 166 | OUT1(S.GOTO) 167 | SSP := SSP-1 168 | RETURN 169 | 170 | CASE S.COLON: 171 | COMPLAB(H4!X) 172 | TRANS(H3!X) 173 | RETURN 174 | 175 | CASE S.UNLESS: SW := TRUE 176 | CASE S.IF: 177 | { auto L = NEXTPARAM() 178 | JUMPCOND(H2!X, SW, L) 179 | TRANS(H3!X) 180 | COMPLAB(L) 181 | RETURN } 182 | 183 | CASE S.TEST: 184 | { auto L, M = NEXTPARAM(), NEXTPARAM() 185 | JUMPCOND(H2!X, FALSE, L) 186 | TRANS(H3!X) 187 | COMPJUMP(M) 188 | COMPLAB(L) 189 | TRANS(H4!X) 190 | COMPLAB(M) 191 | RETURN } 192 | 193 | CASE S.LOOP: 194 | IF LOOPLABEL<0 DO TRANSREPORT(104, X) 195 | IF LOOPLABEL=0 DO LOOPLABEL := NEXTPARAM() 196 | COMPJUMP(LOOPLABEL) 197 | RETURN 198 | 199 | CASE S.BREAK: 200 | IF BREAKLABEL<0 DO TRANSREPORT(104, X) 201 | IF BREAKLABEL=0 DO BREAKLABEL := NEXTPARAM() 202 | COMPJUMP(BREAKLABEL) 203 | RETURN 204 | 205 | CASE S.RETURN: OUT1(S.RTRN) 206 | RETURN 207 | 208 | CASE S.FINISH: OUT1(S.FINISH) 209 | RETURN 210 | 211 | CASE S.RESULTIS: 212 | IF RESULTLABEL<0 DO TRANSREPORT(104, X) 213 | LOAD(H2!X) 214 | OUT2P(S.RES, RESULTLABEL) 215 | SSP := SSP - 1 216 | RETURN 217 | 218 | CASE S.WHILE: SW := TRUE 219 | CASE S.UNTIL: 220 | { auto L, M = NEXTPARAM(), NEXTPARAM() 221 | auto BL, LL = BREAKLABEL, LOOPLABEL 222 | BREAKLABEL, LOOPLABEL := 0, M 223 | 224 | COMPJUMP(M) 225 | COMPLAB(L) 226 | TRANS(H3!X) 227 | COMPLAB(M) 228 | JUMPCOND(H2!X, SW, L) 229 | UNLESS BREAKLABEL=0 DO COMPLAB(BREAKLABEL) 230 | BREAKLABEL, LOOPLABEL := BL, LL 231 | RETURN } 232 | 233 | CASE S.REPEATWHILE: SW := TRUE 234 | CASE S.REPEATUNTIL: 235 | CASE S.REPEAT: 236 | { auto L, BL, LL = NEXTPARAM(), BREAKLABEL, LOOPLABEL 237 | BREAKLABEL, LOOPLABEL := 0, 0 238 | COMPLAB(L) 239 | TEST H1!X=S.REPEAT 240 | THEN { LOOPLABEL := L 241 | TRANS(H2!X) 242 | COMPJUMP(L) } 243 | OR { TRANS(H2!X) 244 | UNLESS LOOPLABEL=0 DO COMPLAB(LOOPLABEL) 245 | JUMPCOND(H3!X, SW, L) } 246 | UNLESS BREAKLABEL=0 DO COMPLAB(BREAKLABEL) 247 | BREAKLABEL, LOOPLABEL := BL, LL 248 | RETURN } 249 | 250 | CASE S.CASE: 251 | { auto L, K = NEXTPARAM(), EVALCONST(H2!X) 252 | IF CASEP>=CASET DO TRANSREPORT(141, X) 253 | IF CASEB<0 DO TRANSREPORT(105, X) 254 | FOR I = CASEB TO CASEP-1 DO 255 | IF CASEK!I=K DO TRANSREPORT(106, X) 256 | CASEK!CASEP := K 257 | CASEL!CASEP := L 258 | CASEP := CASEP + 1 259 | COMPLAB(L) 260 | TRANS(H3!X) 261 | RETURN } 262 | 263 | CASE S.DEFAULT: 264 | IF CASEB<0 DO TRANSREPORT(105, X) 265 | UNLESS DEFAULTLABEL=0 DO TRANSREPORT(101, X) 266 | DEFAULTLABEL := NEXTPARAM() 267 | COMPLAB(DEFAULTLABEL) 268 | TRANS(H2!X) 269 | RETURN 270 | 271 | CASE S.ENDCASE: IF CASEB<0 DO TRANSREPORT(105, X) 272 | COMPJUMP(ENDCASELABEL) 273 | RETURN 274 | 275 | CASE S.SWITCHON: 276 | TRANSSWITCH(X) 277 | RETURN 278 | 279 | CASE S.FOR: TRANSFOR(X) 280 | RETURN 281 | 282 | CASE S.SEQ: 283 | TRANS(H2!X) 284 | COMCOUNT := COMCOUNT + 1 285 | X := H3!X 286 | GOTO NEXT } 287 | }} 288 | . 289 | 290 | // TRN2 291 | 292 | 293 | GET "TRNHDR" 294 | 295 | DECLNAMES(X) 296 | { 297 | UNLESS X=0 SWITCHON H1!X INTO { 298 | DEFAULT: TRANSREPORT(102, CURRENTBRANCH) 299 | RETURN 300 | 301 | CASE S.VECDEF: CASE S.VALDEF: 302 | DECLDYN(H2!X) 303 | RETURN 304 | 305 | CASE S.RTDEF: CASE S.FNDEF: 306 | H5!X := NEXTPARAM() 307 | DECLSTAT(H2!X, H5!X) 308 | RETURN 309 | 310 | CASE S.AND: 311 | DECLNAMES(H2!X) 312 | DECLNAMES(H3!X) 313 | RETURN 314 | } 315 | } 316 | 317 | DECLDYN(X) 318 | { 319 | UNLESS X=0 DO 320 | { IF H1!X=S.NAME DO 321 | { ADDNAME(X, S.LOCAL, SSP) 322 | SSP := SSP + 1 323 | RETURN } 324 | 325 | IF H1!X=S.COMMA DO 326 | { ADDNAME(H2!X, S.LOCAL, SSP) 327 | SSP := SSP + 1 328 | DECLDYN(H3!X) 329 | RETURN } 330 | 331 | TRANSREPORT(103, X) } 332 | } 333 | 334 | DECLSTAT(X, L) 335 | { 336 | auto T = CELLWITHNAME(X) 337 | 338 | IF DVEC!(T+1)=S.GLOBAL DO 339 | { auto N = DVEC!(T+2) 340 | ADDNAME(X, S.GLOBAL, N) 341 | IF GLOBDECLS>=GLOBDECLT DO TRANSREPORT(144, X) 342 | GLOBDECL!GLOBDECLS := N 343 | GLOBDECL!(GLOBDECLS+1) := L 344 | GLOBDECLS := GLOBDECLS + 2 345 | RETURN } 346 | 347 | 348 | { auto M = NEXTPARAM() 349 | ADDNAME(X, S.LABEL, M) 350 | COMPDATALAB(M) 351 | OUT2P(S.ITEML, L) } 352 | } 353 | 354 | SCANLABELS(X) 355 | { 356 | UNLESS X=0 SWITCHON H1!X INTO 357 | 358 | { DEFAULT: RETURN 359 | 360 | CASE S.COLON: 361 | H4!X := NEXTPARAM() 362 | DECLSTAT(H2!X, H4!X) 363 | 364 | CASE S.IF: CASE S.UNLESS: CASE S.WHILE: CASE S.UNTIL: 365 | CASE S.SWITCHON: CASE S.CASE: 366 | SCANLABELS(H3!X) 367 | RETURN 368 | 369 | CASE S.SEQ: 370 | SCANLABELS(H3!X) 371 | 372 | CASE S.REPEAT: 373 | CASE S.REPEATWHILE: CASE S.REPEATUNTIL: CASE S.DEFAULT: 374 | SCANLABELS(H2!X) 375 | RETURN 376 | 377 | CASE S.TEST: 378 | SCANLABELS(H3!X) 379 | SCANLABELS(H4!X) 380 | RETURN } 381 | } 382 | 383 | DECLLABELS(X) 384 | { 385 | auto B = DVECS 386 | SCANLABELS(X) 387 | CHECKDISTINCT(B, DVECS) 388 | DVECE := DVECS 389 | } 390 | 391 | CHECKDISTINCT(E, S) 392 | { 393 | UNTIL E=S DO 394 | { auto P = E + 3 395 | auto N = DVEC!E 396 | WHILE P=DVECT DO TRANSREPORT(143, CURRENTBRANCH) 405 | DVEC!DVECS, DVEC!(DVECS+1), DVEC!(DVECS+2) := N, P, A 406 | DVECS := DVECS + 3 407 | } 408 | 409 | CELLWITHNAME(N) 410 | { 411 | auto X = DVECE 412 | 413 | X := X - 3 REPEATUNTIL X=0 \/ DVEC!X=N 414 | 415 | RESULTIS X 416 | } 417 | 418 | TRANSDYNDEFS(X) 419 | { 420 | SWITCHON H1!X INTO { 421 | CASE S.AND: 422 | TRANSDYNDEFS(H2!X) 423 | TRANSDYNDEFS(H3!X) 424 | RETURN 425 | 426 | CASE S.VECDEF: 427 | OUT2(S.LLP, VECSSP) 428 | SSP := SSP + 1 429 | VECSSP := VECSSP + 1 + EVALCONST(H3!X) 430 | RETURN 431 | 432 | CASE S.VALDEF: LOADLIST(H3!X) 433 | RETURN 434 | 435 | DEFAULT: RETURN } 436 | } 437 | 438 | TRANSSTATDEFS(X) 439 | { 440 | SWITCHON H1!X INTO { 441 | CASE S.AND: 442 | TRANSSTATDEFS(H2!X) 443 | TRANSSTATDEFS(H3!X) 444 | RETURN 445 | 446 | CASE S.FNDEF: CASE S.RTDEF: 447 | { auto A, B, C = DVECE, DVECS, DVECP 448 | auto BL, LL = BREAKLABEL, LOOPLABEL 449 | auto RL, CB = RESULTLABEL, CASEB 450 | BREAKLABEL, LOOPLABEL := -1, -1 451 | RESULTLABEL, CASEB := -1, -1 452 | 453 | COMPENTRY(H2!X, H5!X) 454 | SSP := SAVESPACESIZE 455 | 456 | DVECP := DVECS 457 | DECLDYN(H3!X) 458 | CHECKDISTINCT(B, DVECS) 459 | DVECE := DVECS 460 | DECLLABELS(H4!X) 461 | 462 | OUT2(S.SAVE, SSP) 463 | 464 | TEST H1!X=S.FNDEF 465 | THEN { LOAD(H4!X); OUT1(S.FNRN) } 466 | OR { TRANS(H4!X); OUT1(S.RTRN) } 467 | 468 | OUT2(S.ENDPROC, 0) 469 | 470 | BREAKLABEL, LOOPLABEL := BL, LL 471 | RESULTLABEL, CASEB := RL, CB 472 | DVECE, DVECS, DVECP := A, B, C } 473 | 474 | DEFAULT: RETURN 475 | } 476 | } 477 | 478 | STATDEFS(X) 479 | { 480 | RESULTIS H1!X=S.FNDEF \/ H1!X=S.RTDEF -> TRUE, 481 | H1!X NE S.AND -> FALSE, 482 | STATDEFS(H2!X) -> TRUE, 483 | STATDEFS(H3!X) 484 | } 485 | 486 | TRANSDEF(X) 487 | { 488 | TRANSDYNDEFS(X) 489 | IF STATDEFS(X) DO 490 | { auto L, S= NEXTPARAM(), SSP 491 | COMPJUMP(L) 492 | TRANSSTATDEFS(X) 493 | SSP := S 494 | OUT2(S.STACK, SSP) 495 | COMPLAB(L) } 496 | } 497 | . 498 | 499 | // TRN3 500 | 501 | GET "TRNHDR" 502 | 503 | JUMPCOND(X, B, L) 504 | { auto SW = B 505 | SWITCHON H1!X INTO 506 | { CASE S.FALSE: B := NOT B 507 | CASE S.TRUE: IF B DO COMPJUMP(L) 508 | RETURN 509 | 510 | CASE S.NOT: JUMPCOND(H2!X, NOT B, L) 511 | RETURN 512 | 513 | CASE S.LOGAND: SW := NOT SW 514 | CASE S.LOGOR: 515 | TEST SW THEN { JUMPCOND(H2!X, B, L) 516 | JUMPCOND(H3!X, B, L) } 517 | 518 | OR { auto M = NEXTPARAM() 519 | JUMPCOND(H2!X, NOT B, M) 520 | JUMPCOND(H3!X, B, L) 521 | COMPLAB(M) } 522 | 523 | RETURN 524 | 525 | DEFAULT: LOAD(X) 526 | OUT2P(B -> S.JT, S.JF, L) 527 | SSP := SSP - 1 528 | RETURN } 529 | } 530 | 531 | TRANSSWITCH(X) 532 | { 533 | auto P, B, DL = CASEP, CASEB, DEFAULTLABEL 534 | auto ECL = ENDCASELABEL 535 | auto L = NEXTPARAM() 536 | ENDCASELABEL := NEXTPARAM() 537 | CASEB := CASEP 538 | 539 | COMPJUMP(L) 540 | DEFAULTLABEL := 0 541 | TRANS(H3!X) 542 | COMPJUMP(ENDCASELABEL) 543 | 544 | COMPLAB(L) 545 | LOAD(H2!X) 546 | IF DEFAULTLABEL=0 DO DEFAULTLABEL := ENDCASELABEL 547 | OUT3P(S.SWITCHON, CASEP-P, DEFAULTLABEL) 548 | 549 | FOR I = CASEB TO CASEP-1 DO { OUTN(CASEK!I) 550 | OUTL(CASEL!I) } 551 | 552 | SSP := SSP - 1 553 | COMPLAB(ENDCASELABEL) 554 | ENDCASELABEL := ECL 555 | CASEP, CASEB, DEFAULTLABEL := P, B, DL } 556 | 557 | TRANSFOR(X) 558 | { 559 | auto A, B = DVECE, DVECS 560 | auto L, M = NEXTPARAM(), NEXTPARAM() 561 | auto BL, LL = BREAKLABEL, LOOPLABEL 562 | auto K, N = 0, 0 563 | auto STEP = 1 564 | auto S = SSP 565 | BREAKLABEL, LOOPLABEL := 0, 0 566 | 567 | ADDNAME(H2!X, S.LOCAL, S) 568 | DVECE := DVECS 569 | LOAD(H3!X) 570 | 571 | TEST H1!(H4!X)=S.NUMBER 572 | THEN K, N := S.LN, H2!(H4!X) 573 | OR { K, N := S.LP, SSP 574 | LOAD(H4!X) } 575 | 576 | UNLESS H5!X=0 DO STEP := EVALCONST(H5!X) 577 | 578 | OUT1(S.STORE) 579 | COMPJUMP(L) 580 | DECLLABELS(H6!X) 581 | COMPLAB(M) 582 | TRANS(H6!X) 583 | UNLESS LOOPLABEL=0 DO COMPLAB(LOOPLABEL) 584 | OUT2(S.LP, S); OUT2(S.LN, STEP); OUT1(S.PLUS); OUT2(S.SP, S) 585 | COMPLAB(L) 586 | OUT2(S.LP, S); OUT2(K, N); OUT1(STEP<0 -> S.GE, S.LE) 587 | OUT2P(S.JT, M) 588 | 589 | UNLESS BREAKLABEL=0 DO COMPLAB(BREAKLABEL) 590 | BREAKLABEL, LOOPLABEL, SSP := BL, LL, S 591 | OUT2(S.STACK, SSP) 592 | DVECE, DVECS := A, B } 593 | 594 | . 595 | 596 | // TRN4 597 | 598 | 599 | GET "TRNHDR" 600 | 601 | LOAD(X) 602 | { 603 | IF X=0 DO { TRANSREPORT(148, CURRENTBRANCH) 604 | LOADZERO() 605 | RETURN } 606 | 607 | { auto OP = H1!X 608 | 609 | SWITCHON OP INTO 610 | { DEFAULT: TRANSREPORT(147, CURRENTBRANCH) 611 | LOADZERO() 612 | RETURN 613 | 614 | CASE S.DIV: CASE S.REM: CASE S.MINUS: 615 | CASE S.LS: CASE S.GR: CASE S.LE: CASE S.GE: 616 | CASE S.LSHIFT: CASE S.RSHIFT: 617 | LOAD(H2!X) 618 | LOAD(H3!X) 619 | OUT1(OP) 620 | SSP := SSP - 1 621 | RETURN 622 | 623 | CASE S.VECAP: CASE S.MULT: CASE S.PLUS: CASE S.EQ: CASE S.NE: 624 | CASE S.LOGAND: CASE S.LOGOR: CASE S.EQV: CASE S.NEQV: 625 | { auto A, B = H2!X, H3!X 626 | IF H1!A=S.NAME \/ H1!A=S.NUMBER DO 627 | A, B := H3!X, H2!X 628 | LOAD(A) 629 | LOAD(B) 630 | IF OP=S.VECAP DO { OUT1(S.PLUS); OP := S.RV } 631 | OUT1(OP) 632 | SSP := SSP - 1 633 | RETURN } 634 | 635 | CASE S.NEG: CASE S.NOT: CASE S.RV: 636 | LOAD(H2!X) 637 | OUT1(OP) 638 | RETURN 639 | 640 | CASE S.TRUE: CASE S.FALSE: CASE S.QUERY: 641 | OUT1(OP) 642 | SSP := SSP + 1 643 | RETURN 644 | 645 | CASE S.LV: LOADLV(H2!X) 646 | RETURN 647 | 648 | CASE S.NUMBER: 649 | OUT2(S.LN, H2!X) 650 | SSP := SSP + 1 651 | RETURN 652 | 653 | CASE S.STRING: 654 | { auto S = @H2!X 655 | OUT2(S.LSTR, getbyte(S, 0)) 656 | FOR I = 1 TO getbyte(S, 0) DO OUTC(getbyte(S, I)) 657 | WRC('*S') 658 | SSP := SSP + 1 659 | RETURN } 660 | 661 | CASE S.NAME: 662 | TRANSNAME(X, S.LP, S.LG, S.LL, S.LN) 663 | SSP := SSP + 1 664 | RETURN 665 | 666 | CASE S.VALOF: 667 | { auto RL = RESULTLABEL 668 | auto A, B = DVECS, DVECE 669 | DECLLABELS(H2!X) 670 | RESULTLABEL := NEXTPARAM() 671 | TRANS(H2!X) 672 | COMPLAB(RESULTLABEL) 673 | OUT2(S.RSTACK, SSP) 674 | SSP := SSP + 1 675 | DVECS, DVECE := A, B 676 | RESULTLABEL := RL 677 | RETURN } 678 | 679 | 680 | CASE S.FNAP: 681 | { auto S = SSP 682 | SSP := SSP + SAVESPACESIZE 683 | OUT2(S.STACK, SSP) 684 | LOADLIST(H3!X) 685 | LOAD(H2!X) 686 | OUT2(S.FNAP, S) 687 | SSP := S + 1 688 | RETURN } 689 | 690 | CASE S.COND: 691 | { auto L, M = NEXTPARAM(), NEXTPARAM() 692 | auto S = SSP 693 | JUMPCOND(H2!X, FALSE, M) 694 | LOAD(H3!X) 695 | COMPJUMP(L) 696 | SSP := S; OUT2(S.STACK, SSP) 697 | COMPLAB(M) 698 | LOAD(H4!X) 699 | COMPLAB(L) 700 | RETURN } 701 | 702 | CASE S.TABLE: 703 | { auto M = NEXTPARAM() 704 | COMPDATALAB(M) 705 | X := H2!X 706 | WHILE H1!X=S.COMMA DO 707 | { OUT2(S.ITEMN, EVALCONST(H2!X)) 708 | X := H3!X } 709 | OUT2(S.ITEMN, EVALCONST(X)) 710 | OUT2P(S.LLL, M) 711 | SSP := SSP + 1 712 | RETURN } } 713 | } 714 | } 715 | 716 | LOADLV(X) 717 | { 718 | IF X=0 GOTO ERR 719 | 720 | SWITCHON H1!X INTO { 721 | DEFAULT: 722 | ERR: TRANSREPORT(113, CURRENTBRANCH) 723 | LOADZERO() 724 | RETURN 725 | 726 | CASE S.NAME: 727 | TRANSNAME(X, S.LLP, S.LLG, S.LLL, 0) 728 | SSP := SSP + 1 729 | RETURN 730 | 731 | CASE S.RV: 732 | LOAD(H2!X) 733 | RETURN 734 | 735 | CASE S.VECAP: 736 | { auto A, B = H2!X, H3!X 737 | IF H1!A=S.NAME DO A, B := H3!X, H2!X 738 | LOAD(A) 739 | LOAD(B) 740 | OUT1(S.PLUS) 741 | SSP := SSP - 1 742 | RETURN } } 743 | } 744 | 745 | LOADZERO() 746 | { 747 | OUT2(S.LN, 0) 748 | SSP := SSP + 1 749 | } 750 | 751 | LOADLIST(X) 752 | { 753 | UNLESS X=0 DO 754 | { UNLESS H1!X=S.COMMA DO { LOAD(X); RETURN } 755 | 756 | LOADLIST(H2!X) 757 | LOADLIST(H3!X) } 758 | } 759 | . 760 | 761 | // TRN5 762 | 763 | GET "TRNHDR" 764 | 765 | EVALCONST(X) 766 | { 767 | IF X=0 DO { TRANSREPORT(117, CURRENTBRANCH) 768 | RESULTIS 0 } 769 | 770 | SWITCHON H1!X INTO 771 | { DEFAULT: TRANSREPORT(118, X) 772 | RESULTIS 0 773 | 774 | CASE S.NAME: 775 | { auto T = CELLWITHNAME(X) 776 | IF DVEC!(T+1)=S.NUMBER RESULTIS DVEC!(T+2) 777 | TRANSREPORT(119, X) 778 | RESULTIS 0 } 779 | 780 | CASE S.NUMBER: RESULTIS H2!X 781 | CASE S.TRUE: RESULTIS TRUE 782 | CASE S.FALSE: RESULTIS FALSE 783 | 784 | CASE S.NEG: RESULTIS - EVALCONST(H2!X) 785 | 786 | CASE S.MULT: RESULTIS EVALCONST(H2!X) * EVALCONST(H3!X) 787 | CASE S.DIV: RESULTIS EVALCONST(H2!X) / EVALCONST(H3!X) 788 | CASE S.PLUS: RESULTIS EVALCONST(H2!X) + EVALCONST(H3!X) 789 | CASE S.MINUS:RESULTIS EVALCONST(H2!X) - EVALCONST(H3!X) 790 | } 791 | } 792 | 793 | ASSIGN(X, Y) 794 | { 795 | IF X=0 \/ Y=0 DO 796 | { TRANSREPORT(110, CURRENTBRANCH) 797 | RETURN } 798 | 799 | SWITCHON H1!X INTO 800 | { CASE S.COMMA: 801 | UNLESS H1!Y=S.COMMA DO 802 | { TRANSREPORT(112, CURRENTBRANCH) 803 | RETURN } 804 | ASSIGN(H2!X, H2!Y) 805 | ASSIGN(H3!X, H3!Y) 806 | RETURN 807 | 808 | CASE S.NAME: 809 | LOAD(Y) 810 | TRANSNAME(X, S.SP, S.SG, S.SL, 0) 811 | SSP := SSP - 1 812 | RETURN 813 | 814 | CASE S.RV: CASE S.VECAP: CASE S.COND: 815 | LOAD(Y) 816 | LOADLV(X) 817 | OUT1(S.STIND) 818 | SSP := SSP - 2 819 | RETURN 820 | 821 | DEFAULT: TRANSREPORT(109, CURRENTBRANCH) } 822 | } 823 | 824 | TRANSNAME(X, P, G, L, N) 825 | { 826 | auto T = CELLWITHNAME(X) 827 | auto K, A = DVEC!(T+1), DVEC!(T+2) 828 | 829 | IF T=0 DO { TRANSREPORT(115, X) 830 | OUT2(G, 2) 831 | RETURN } 832 | 833 | SWITCHON K INTO 834 | { CASE S.LOCAL: IF T9 DO WRPN(N/10) 1000 | WRC(N REM 10 + '0') 1001 | } 1002 | 1003 | ENDOCODE() 1004 | { 1005 | wrch('*N'); OCOUNT := 0 1006 | } 1007 | 1008 | WRC(CH) 1009 | { 1010 | OCOUNT := OCOUNT + 1 1011 | IF OCOUNT>62 /\ CH='*S' DO { 1012 | wrch('*N'); OCOUNT := 0; RETURN 1013 | } 1014 | wrch(CH) 1015 | } 1016 | -------------------------------------------------------------------------------- /test-tran/trn.bcpl: -------------------------------------------------------------------------------- 1 | // TRN0 2 | 3 | GET "TRNHDR" 4 | 5 | LET NEXTPARAM() = VALOF 6 | $( PARAMNUMBER := PARAMNUMBER + 1 7 | RESULTIS PARAMNUMBER $) 8 | 9 | AND TRANSREPORT(N, X) BE 10 | $( selectoutput(SYSPRINT) 11 | REPORTCOUNT := REPORTCOUNT + 1 12 | IF REPORTCOUNT GE REPORTMAX DO 13 | $( writes("*NCOMPILATION ABORTED*N") 14 | stop(8) $) 15 | writes("*NREPORT: "); TRNMESSAGE(N) 16 | writef("*NCOMMANDS COMPILED %N*N", COMCOUNT) 17 | PLIST(X, 0, 4); newline() 18 | selectoutput(OCODE) $) 19 | 20 | AND TRNMESSAGE(N) BE 21 | $( LET S = VALOF 22 | SWITCHON N INTO 23 | 24 | $( DEFAULT: writef("COMPILER ERROR %N", N); RETURN 25 | 26 | CASE 141: RESULTIS "TOO MANY CASES" 27 | CASE 104: RESULTIS "ILLEGAL USE OF BREAK, LOOP OR RESULTIS" 28 | CASE 101: 29 | CASE 105: RESULTIS "ILLEGAL USE OF CASE OR DEFAULT" 30 | CASE 106: RESULTIS "TWO CASES WITH SAME CONSTANT" 31 | CASE 144: RESULTIS "TOO MANY GLOBALS" 32 | CASE 142: RESULTIS "NAME DECLARED TWICE" 33 | CASE 143: RESULTIS "TOO MANY NAMES DECLARED" 34 | CASE 115: RESULTIS "NAME NOT DECLARED" 35 | CASE 116: RESULTIS "DYNAMIC FREE VARIABLE USED" 36 | CASE 117:CASE 118:CASE 119: 37 | RESULTIS "ERROR IN CONSTANT EXPRESSION" 38 | CASE 110:CASE 112: 39 | RESULTIS "LHS AND RHS DO NOT MATCH" 40 | CASE 109:CASE 113: 41 | RESULTIS "LTYPE EXPRESSION EXPECTED" 42 | $) 43 | 44 | writes(S) $) 45 | 46 | 47 | LET COMPILEAE(X) BE 48 | $(1 LET A = VEC 1200 49 | LET D = VEC 100 50 | LET K = VEC 150 51 | LET L = VEC 150 52 | 53 | DVEC, DVECS, DVECE, DVECP, DVECT := A, 3, 3, 3, 1200 54 | DVEC!0, DVEC!1, DVEC!2 := 0, 0, 0 55 | 56 | GLOBDECL, GLOBDECLS, GLOBDECLT := D, 0, 100 57 | 58 | CASEK, CASEL, CASEP, CASET, CASEB := K, L, 0, 150, -1 59 | ENDCASELABEL, DEFAULTLABEL := 0, 0 60 | 61 | RESULTLABEL, BREAKLABEL, LOOPLABEL := -1, -1, -1 62 | 63 | COMCOUNT, CURRENTBRANCH := 0, X 64 | 65 | OCOUNT := 0 66 | 67 | PARAMNUMBER := 0 68 | SSP := SAVESPACESIZE 69 | OUT2(S.STACK, SSP) 70 | DECLLABELS(X) 71 | TRANS(X) 72 | OUT2(S.GLOBAL, GLOBDECLS/2) 73 | 74 | $( LET I = 0 75 | UNTIL I=GLOBDECLS DO 76 | $( OUTN(GLOBDECL!I) 77 | OUTL(GLOBDECL!(I+1)) 78 | I := I + 2 $) 79 | 80 | ENDOCODE() $)1 81 | 82 | . 83 | 84 | // TRN1 85 | 86 | 87 | GET "TRNHDR" 88 | 89 | LET TRANS(X) BE 90 | $(TR 91 | NEXT: 92 | $( LET SW = FALSE 93 | IF X=0 RETURN 94 | CURRENTBRANCH := X 95 | 96 | SWITCHON H1!X INTO 97 | $( DEFAULT: TRANSREPORT(100, X); RETURN 98 | 99 | CASE S.LET: 100 | $( LET A, B, S, S1 = DVECE, DVECS, SSP, 0 101 | LET V = VECSSP 102 | DECLNAMES(H2!X) 103 | CHECKDISTINCT(B, DVECS) 104 | DVECE := DVECS 105 | VECSSP, S1 := SSP, SSP 106 | SSP := S 107 | TRANSDEF(H2!X) 108 | UNLESS SSP=S1 DO TRANSREPORT(110, X) 109 | UNLESS SSP=VECSSP DO $( SSP := VECSSP 110 | OUT2(S.STACK, SSP) $) 111 | OUT1(S.STORE) 112 | DECLLABELS(H3!X) 113 | TRANS(H3!X) 114 | VECSSP := V 115 | UNLESS SSP=S DO OUT2(S.STACK, S) 116 | DVECE, DVECS, SSP := A, B, S 117 | RETURN $) 118 | 119 | CASE S.STATIC: 120 | CASE S.GLOBAL: 121 | CASE S.MANIFEST: 122 | $(1 LET A, B, S = DVECE, DVECS, SSP 123 | AND OP = H1!X 124 | AND Y = H2!X 125 | 126 | IF OP=S.MANIFEST DO OP := S.NUMBER 127 | 128 | UNTIL Y=0 DO 129 | $( TEST OP=S.STATIC THEN 130 | $( LET M = NEXTPARAM() 131 | ADDNAME(H3!Y, S.LABEL, M) 132 | COMPDATALAB(M) 133 | OUT2(S.ITEMN, EVALCONST(H4!Y)) $) 134 | 135 | OR ADDNAME(H3!Y, OP, EVALCONST(H4!Y)) 136 | 137 | Y := H2!Y 138 | DVECE := DVECS $) 139 | 140 | DECLLABELS(H3!X) 141 | TRANS(H3!X) 142 | DVECE, DVECS, SSP := A, B, S 143 | RETURN $)1 144 | 145 | 146 | CASE S.ASS: 147 | ASSIGN(H2!X, H3!X) 148 | RETURN 149 | 150 | CASE S.RTAP: 151 | $( LET S = SSP 152 | SSP := SSP+SAVESPACESIZE 153 | OUT2(S.STACK, SSP) 154 | LOADLIST(H3!X) 155 | LOAD(H2!X) 156 | OUT2(S.RTAP, S) 157 | SSP := S 158 | RETURN $) 159 | 160 | CASE S.GOTO: 161 | LOAD(H2!X) 162 | OUT1(S.GOTO) 163 | SSP := SSP-1 164 | RETURN 165 | 166 | CASE S.COLON: 167 | COMPLAB(H4!X) 168 | TRANS(H3!X) 169 | RETURN 170 | 171 | CASE S.UNLESS: SW := TRUE 172 | CASE S.IF: 173 | $( LET L = NEXTPARAM() 174 | JUMPCOND(H2!X, SW, L) 175 | TRANS(H3!X) 176 | COMPLAB(L) 177 | RETURN $) 178 | 179 | CASE S.TEST: 180 | $( LET L, M = NEXTPARAM(), NEXTPARAM() 181 | JUMPCOND(H2!X, FALSE, L) 182 | TRANS(H3!X) 183 | COMPJUMP(M) 184 | COMPLAB(L) 185 | TRANS(H4!X) 186 | COMPLAB(M) 187 | RETURN $) 188 | 189 | CASE S.LOOP: 190 | IF LOOPLABEL<0 DO TRANSREPORT(104, X) 191 | IF LOOPLABEL=0 DO LOOPLABEL := NEXTPARAM() 192 | COMPJUMP(LOOPLABEL) 193 | RETURN 194 | 195 | CASE S.BREAK: 196 | IF BREAKLABEL<0 DO TRANSREPORT(104, X) 197 | IF BREAKLABEL=0 DO BREAKLABEL := NEXTPARAM() 198 | COMPJUMP(BREAKLABEL) 199 | RETURN 200 | 201 | CASE S.RETURN: OUT1(S.RTRN) 202 | RETURN 203 | 204 | CASE S.FINISH: OUT1(S.FINISH) 205 | RETURN 206 | 207 | CASE S.RESULTIS: 208 | IF RESULTLABEL<0 DO TRANSREPORT(104, X) 209 | LOAD(H2!X) 210 | OUT2P(S.RES, RESULTLABEL) 211 | SSP := SSP - 1 212 | RETURN 213 | 214 | CASE S.WHILE: SW := TRUE 215 | CASE S.UNTIL: 216 | $( LET L, M = NEXTPARAM(), NEXTPARAM() 217 | LET BL, LL = BREAKLABEL, LOOPLABEL 218 | BREAKLABEL, LOOPLABEL := 0, M 219 | 220 | COMPJUMP(M) 221 | COMPLAB(L) 222 | TRANS(H3!X) 223 | COMPLAB(M) 224 | JUMPCOND(H2!X, SW, L) 225 | UNLESS BREAKLABEL=0 DO COMPLAB(BREAKLABEL) 226 | BREAKLABEL, LOOPLABEL := BL, LL 227 | RETURN $) 228 | 229 | CASE S.REPEATWHILE: SW := TRUE 230 | CASE S.REPEATUNTIL: 231 | CASE S.REPEAT: 232 | $( LET L, BL, LL = NEXTPARAM(), BREAKLABEL, LOOPLABEL 233 | BREAKLABEL, LOOPLABEL := 0, 0 234 | COMPLAB(L) 235 | TEST H1!X=S.REPEAT 236 | THEN $( LOOPLABEL := L 237 | TRANS(H2!X) 238 | COMPJUMP(L) $) 239 | OR $( TRANS(H2!X) 240 | UNLESS LOOPLABEL=0 DO COMPLAB(LOOPLABEL) 241 | JUMPCOND(H3!X, SW, L) $) 242 | UNLESS BREAKLABEL=0 DO COMPLAB(BREAKLABEL) 243 | BREAKLABEL, LOOPLABEL := BL, LL 244 | RETURN $) 245 | 246 | CASE S.CASE: 247 | $( LET L, K = NEXTPARAM(), EVALCONST(H2!X) 248 | IF CASEP>=CASET DO TRANSREPORT(141, X) 249 | IF CASEB<0 DO TRANSREPORT(105, X) 250 | FOR I = CASEB TO CASEP-1 DO 251 | IF CASEK!I=K DO TRANSREPORT(106, X) 252 | CASEK!CASEP := K 253 | CASEL!CASEP := L 254 | CASEP := CASEP + 1 255 | COMPLAB(L) 256 | TRANS(H3!X) 257 | RETURN $) 258 | 259 | CASE S.DEFAULT: 260 | IF CASEB<0 DO TRANSREPORT(105, X) 261 | UNLESS DEFAULTLABEL=0 DO TRANSREPORT(101, X) 262 | DEFAULTLABEL := NEXTPARAM() 263 | COMPLAB(DEFAULTLABEL) 264 | TRANS(H2!X) 265 | RETURN 266 | 267 | CASE S.ENDCASE: IF CASEB<0 DO TRANSREPORT(105, X) 268 | COMPJUMP(ENDCASELABEL) 269 | RETURN 270 | 271 | CASE S.SWITCHON: 272 | TRANSSWITCH(X) 273 | RETURN 274 | 275 | CASE S.FOR: TRANSFOR(X) 276 | RETURN 277 | 278 | CASE S.SEQ: 279 | TRANS(H2!X) 280 | COMCOUNT := COMCOUNT + 1 281 | X := H3!X 282 | GOTO NEXT $)TR 283 | . 284 | 285 | // TRN2 286 | 287 | 288 | GET "TRNHDR" 289 | 290 | LET DECLNAMES(X) BE UNLESS X=0 SWITCHON H1!X INTO 291 | 292 | $( DEFAULT: TRANSREPORT(102, CURRENTBRANCH) 293 | RETURN 294 | 295 | CASE S.VECDEF: CASE S.VALDEF: 296 | DECLDYN(H2!X) 297 | RETURN 298 | 299 | CASE S.RTDEF: CASE S.FNDEF: 300 | H5!X := NEXTPARAM() 301 | DECLSTAT(H2!X, H5!X) 302 | RETURN 303 | 304 | CASE S.AND: 305 | DECLNAMES(H2!X) 306 | DECLNAMES(H3!X) 307 | RETURN $) 308 | 309 | 310 | AND DECLDYN(X) BE UNLESS X=0 DO 311 | 312 | $( IF H1!X=S.NAME DO 313 | $( ADDNAME(X, S.LOCAL, SSP) 314 | SSP := SSP + 1 315 | RETURN $) 316 | 317 | IF H1!X=S.COMMA DO 318 | $( ADDNAME(H2!X, S.LOCAL, SSP) 319 | SSP := SSP + 1 320 | DECLDYN(H3!X) 321 | RETURN $) 322 | 323 | TRANSREPORT(103, X) $) 324 | 325 | AND DECLSTAT(X, L) BE 326 | $(1 LET T = CELLWITHNAME(X) 327 | 328 | IF DVEC!(T+1)=S.GLOBAL DO 329 | $( LET N = DVEC!(T+2) 330 | ADDNAME(X, S.GLOBAL, N) 331 | IF GLOBDECLS>=GLOBDECLT DO TRANSREPORT(144, X) 332 | GLOBDECL!GLOBDECLS := N 333 | GLOBDECL!(GLOBDECLS+1) := L 334 | GLOBDECLS := GLOBDECLS + 2 335 | RETURN $) 336 | 337 | 338 | $( LET M = NEXTPARAM() 339 | ADDNAME(X, S.LABEL, M) 340 | COMPDATALAB(M) 341 | OUT2P(S.ITEML, L) $)1 342 | 343 | 344 | AND DECLLABELS(X) BE 345 | $( LET B = DVECS 346 | SCANLABELS(X) 347 | CHECKDISTINCT(B, DVECS) 348 | DVECE := DVECS $) 349 | 350 | 351 | AND CHECKDISTINCT(E, S) BE 352 | UNTIL E=S DO 353 | $( LET P = E + 3 354 | AND N = DVEC!E 355 | WHILE P=DVECT DO TRANSREPORT(143, CURRENTBRANCH) 363 | DVEC!DVECS, DVEC!(DVECS+1), DVEC!(DVECS+2) := N, P, A 364 | DVECS := DVECS + 3 $) 365 | 366 | 367 | AND CELLWITHNAME(N) = VALOF 368 | $( LET X = DVECE 369 | 370 | X := X - 3 REPEATUNTIL X=0 \/ DVEC!X=N 371 | 372 | RESULTIS X $) 373 | 374 | 375 | AND SCANLABELS(X) BE UNLESS X=0 SWITCHON H1!X INTO 376 | 377 | $( DEFAULT: RETURN 378 | 379 | CASE S.COLON: 380 | H4!X := NEXTPARAM() 381 | DECLSTAT(H2!X, H4!X) 382 | 383 | CASE S.IF: CASE S.UNLESS: CASE S.WHILE: CASE S.UNTIL: 384 | CASE S.SWITCHON: CASE S.CASE: 385 | SCANLABELS(H3!X) 386 | RETURN 387 | 388 | CASE S.SEQ: 389 | SCANLABELS(H3!X) 390 | 391 | CASE S.REPEAT: 392 | CASE S.REPEATWHILE: CASE S.REPEATUNTIL: CASE S.DEFAULT: 393 | SCANLABELS(H2!X) 394 | RETURN 395 | 396 | CASE S.TEST: 397 | SCANLABELS(H3!X) 398 | SCANLABELS(H4!X) 399 | RETURN $) 400 | 401 | 402 | AND TRANSDEF(X) BE 403 | $(1 TRANSDYNDEFS(X) 404 | IF STATDEFS(X) DO 405 | $( LET L, S= NEXTPARAM(), SSP 406 | COMPJUMP(L) 407 | TRANSSTATDEFS(X) 408 | SSP := S 409 | OUT2(S.STACK, SSP) 410 | COMPLAB(L) $)1 411 | 412 | 413 | AND TRANSDYNDEFS(X) BE 414 | SWITCHON H1!X INTO 415 | $( CASE S.AND: 416 | TRANSDYNDEFS(H2!X) 417 | TRANSDYNDEFS(H3!X) 418 | RETURN 419 | 420 | CASE S.VECDEF: 421 | OUT2(S.LLP, VECSSP) 422 | SSP := SSP + 1 423 | VECSSP := VECSSP + 1 + EVALCONST(H3!X) 424 | RETURN 425 | 426 | CASE S.VALDEF: LOADLIST(H3!X) 427 | RETURN 428 | 429 | DEFAULT: RETURN $) 430 | 431 | AND TRANSSTATDEFS(X) BE 432 | SWITCHON H1!X INTO 433 | $( CASE S.AND: 434 | TRANSSTATDEFS(H2!X) 435 | TRANSSTATDEFS(H3!X) 436 | RETURN 437 | 438 | CASE S.FNDEF: CASE S.RTDEF: 439 | $(2 LET A, B, C = DVECE, DVECS, DVECP 440 | AND BL, LL = BREAKLABEL, LOOPLABEL 441 | AND RL, CB = RESULTLABEL, CASEB 442 | BREAKLABEL, LOOPLABEL := -1, -1 443 | RESULTLABEL, CASEB := -1, -1 444 | 445 | COMPENTRY(H2!X, H5!X) 446 | SSP := SAVESPACESIZE 447 | 448 | DVECP := DVECS 449 | DECLDYN(H3!X) 450 | CHECKDISTINCT(B, DVECS) 451 | DVECE := DVECS 452 | DECLLABELS(H4!X) 453 | 454 | OUT2(S.SAVE, SSP) 455 | 456 | TEST H1!X=S.FNDEF 457 | THEN $( LOAD(H4!X); OUT1(S.FNRN) $) 458 | OR $( TRANS(H4!X); OUT1(S.RTRN) $) 459 | 460 | OUT2(S.ENDPROC, 0) 461 | 462 | BREAKLABEL, LOOPLABEL := BL, LL 463 | RESULTLABEL, CASEB := RL, CB 464 | DVECE, DVECS, DVECP := A, B, C $)2 465 | 466 | DEFAULT: RETURN $) 467 | 468 | AND STATDEFS(X) = H1!X=S.FNDEF \/ H1!X=S.RTDEF -> TRUE, 469 | H1!X NE S.AND -> FALSE, 470 | STATDEFS(H2!X) -> TRUE, 471 | STATDEFS(H3!X) 472 | 473 | 474 | . 475 | 476 | // TRN3 477 | 478 | 479 | GET "TRNHDR" 480 | 481 | LET JUMPCOND(X, B, L) BE 482 | $(JC LET SW = B 483 | SWITCHON H1!X INTO 484 | $( CASE S.FALSE: B := NOT B 485 | CASE S.TRUE: IF B DO COMPJUMP(L) 486 | RETURN 487 | 488 | CASE S.NOT: JUMPCOND(H2!X, NOT B, L) 489 | RETURN 490 | 491 | CASE S.LOGAND: SW := NOT SW 492 | CASE S.LOGOR: 493 | TEST SW THEN $( JUMPCOND(H2!X, B, L) 494 | JUMPCOND(H3!X, B, L) $) 495 | 496 | OR $( LET M = NEXTPARAM() 497 | JUMPCOND(H2!X, NOT B, M) 498 | JUMPCOND(H3!X, B, L) 499 | COMPLAB(M) $) 500 | 501 | RETURN 502 | 503 | DEFAULT: LOAD(X) 504 | OUT2P(B -> S.JT, S.JF, L) 505 | SSP := SSP - 1 506 | RETURN $)JC 507 | 508 | AND TRANSSWITCH(X) BE 509 | $(1 LET P, B, DL = CASEP, CASEB, DEFAULTLABEL 510 | AND ECL = ENDCASELABEL 511 | LET L = NEXTPARAM() 512 | ENDCASELABEL := NEXTPARAM() 513 | CASEB := CASEP 514 | 515 | COMPJUMP(L) 516 | DEFAULTLABEL := 0 517 | TRANS(H3!X) 518 | COMPJUMP(ENDCASELABEL) 519 | 520 | COMPLAB(L) 521 | LOAD(H2!X) 522 | IF DEFAULTLABEL=0 DO DEFAULTLABEL := ENDCASELABEL 523 | OUT3P(S.SWITCHON, CASEP-P, DEFAULTLABEL) 524 | 525 | FOR I = CASEB TO CASEP-1 DO $( OUTN(CASEK!I) 526 | OUTL(CASEL!I) $) 527 | 528 | SSP := SSP - 1 529 | COMPLAB(ENDCASELABEL) 530 | ENDCASELABEL := ECL 531 | CASEP, CASEB, DEFAULTLABEL := P, B, DL $)1 532 | 533 | AND TRANSFOR(X) BE 534 | $( LET A, B = DVECE, DVECS 535 | LET L, M = NEXTPARAM(), NEXTPARAM() 536 | LET BL, LL = BREAKLABEL, LOOPLABEL 537 | LET K, N = 0, 0 538 | LET STEP = 1 539 | LET S = SSP 540 | BREAKLABEL, LOOPLABEL := 0, 0 541 | 542 | ADDNAME(H2!X, S.LOCAL, S) 543 | DVECE := DVECS 544 | LOAD(H3!X) 545 | 546 | TEST H1!(H4!X)=S.NUMBER 547 | THEN K, N := S.LN, H2!(H4!X) 548 | OR $( K, N := S.LP, SSP 549 | LOAD(H4!X) $) 550 | 551 | UNLESS H5!X=0 DO STEP := EVALCONST(H5!X) 552 | 553 | OUT1(S.STORE) 554 | COMPJUMP(L) 555 | DECLLABELS(H6!X) 556 | COMPLAB(M) 557 | TRANS(H6!X) 558 | UNLESS LOOPLABEL=0 DO COMPLAB(LOOPLABEL) 559 | OUT2(S.LP, S); OUT2(S.LN, STEP); OUT1(S.PLUS); OUT2(S.SP, S) 560 | COMPLAB(L) 561 | OUT2(S.LP, S); OUT2(K, N); OUT1(STEP<0 -> S.GE, S.LE) 562 | OUT2P(S.JT, M) 563 | 564 | UNLESS BREAKLABEL=0 DO COMPLAB(BREAKLABEL) 565 | BREAKLABEL, LOOPLABEL, SSP := BL, LL, S 566 | OUT2(S.STACK, SSP) 567 | DVECE, DVECS := A, B $) 568 | 569 | . 570 | 571 | // TRN4 572 | 573 | 574 | GET "TRNHDR" 575 | 576 | LET LOAD(X) BE 577 | $(1 IF X=0 DO $( TRANSREPORT(148, CURRENTBRANCH) 578 | LOADZERO() 579 | RETURN $) 580 | 581 | $( LET OP = H1!X 582 | 583 | SWITCHON OP INTO 584 | $( DEFAULT: TRANSREPORT(147, CURRENTBRANCH) 585 | LOADZERO() 586 | RETURN 587 | 588 | CASE S.DIV: CASE S.REM: CASE S.MINUS: 589 | CASE S.LS: CASE S.GR: CASE S.LE: CASE S.GE: 590 | CASE S.LSHIFT: CASE S.RSHIFT: 591 | LOAD(H2!X) 592 | LOAD(H3!X) 593 | OUT1(OP) 594 | SSP := SSP - 1 595 | RETURN 596 | 597 | CASE S.VECAP: CASE S.MULT: CASE S.PLUS: CASE S.EQ: CASE S.NE: 598 | CASE S.LOGAND: CASE S.LOGOR: CASE S.EQV: CASE S.NEQV: 599 | $( LET A, B = H2!X, H3!X 600 | IF H1!A=S.NAME \/ H1!A=S.NUMBER DO 601 | A, B := H3!X, H2!X 602 | LOAD(A) 603 | LOAD(B) 604 | IF OP=S.VECAP DO $( OUT1(S.PLUS); OP := S.RV $) 605 | OUT1(OP) 606 | SSP := SSP - 1 607 | RETURN $) 608 | 609 | CASE S.NEG: CASE S.NOT: CASE S.RV: 610 | LOAD(H2!X) 611 | OUT1(OP) 612 | RETURN 613 | 614 | CASE S.TRUE: CASE S.FALSE: CASE S.QUERY: 615 | OUT1(OP) 616 | SSP := SSP + 1 617 | RETURN 618 | 619 | CASE S.LV: LOADLV(H2!X) 620 | RETURN 621 | 622 | CASE S.NUMBER: 623 | OUT2(S.LN, H2!X) 624 | SSP := SSP + 1 625 | RETURN 626 | 627 | CASE S.STRING: 628 | $( LET S = @H2!X 629 | OUT2(S.LSTR, getbyte(S, 0)) 630 | FOR I = 1 TO getbyte(S, 0) DO OUTC(getbyte(S, I)) 631 | WRC('*S') 632 | SSP := SSP + 1 633 | RETURN $) 634 | 635 | CASE S.NAME: 636 | TRANSNAME(X, S.LP, S.LG, S.LL, S.LN) 637 | SSP := SSP + 1 638 | RETURN 639 | 640 | CASE S.VALOF: 641 | $( LET RL = RESULTLABEL 642 | LET A, B = DVECS, DVECE 643 | DECLLABELS(H2!X) 644 | RESULTLABEL := NEXTPARAM() 645 | TRANS(H2!X) 646 | COMPLAB(RESULTLABEL) 647 | OUT2(S.RSTACK, SSP) 648 | SSP := SSP + 1 649 | DVECS, DVECE := A, B 650 | RESULTLABEL := RL 651 | RETURN $) 652 | 653 | 654 | CASE S.FNAP: 655 | $( LET S = SSP 656 | SSP := SSP + SAVESPACESIZE 657 | OUT2(S.STACK, SSP) 658 | LOADLIST(H3!X) 659 | LOAD(H2!X) 660 | OUT2(S.FNAP, S) 661 | SSP := S + 1 662 | RETURN $) 663 | 664 | CASE S.COND: 665 | $( LET L, M = NEXTPARAM(), NEXTPARAM() 666 | LET S = SSP 667 | JUMPCOND(H2!X, FALSE, M) 668 | LOAD(H3!X) 669 | COMPJUMP(L) 670 | SSP := S; OUT2(S.STACK, SSP) 671 | COMPLAB(M) 672 | LOAD(H4!X) 673 | COMPLAB(L) 674 | RETURN $) 675 | 676 | CASE S.TABLE: 677 | $( LET M = NEXTPARAM() 678 | COMPDATALAB(M) 679 | X := H2!X 680 | WHILE H1!X=S.COMMA DO 681 | $( OUT2(S.ITEMN, EVALCONST(H2!X)) 682 | X := H3!X $) 683 | OUT2(S.ITEMN, EVALCONST(X)) 684 | OUT2P(S.LLL, M) 685 | SSP := SSP + 1 686 | RETURN $) $)1 687 | 688 | 689 | AND LOADLV(X) BE 690 | $(1 IF X=0 GOTO ERR 691 | 692 | SWITCHON H1!X INTO 693 | $( DEFAULT: 694 | ERR: TRANSREPORT(113, CURRENTBRANCH) 695 | LOADZERO() 696 | RETURN 697 | 698 | CASE S.NAME: 699 | TRANSNAME(X, S.LLP, S.LLG, S.LLL, 0) 700 | SSP := SSP + 1 701 | RETURN 702 | 703 | CASE S.RV: 704 | LOAD(H2!X) 705 | RETURN 706 | 707 | CASE S.VECAP: 708 | $( LET A, B = H2!X, H3!X 709 | IF H1!A=S.NAME DO A, B := H3!X, H2!X 710 | LOAD(A) 711 | LOAD(B) 712 | OUT1(S.PLUS) 713 | SSP := SSP - 1 714 | RETURN $) $)1 715 | 716 | AND LOADZERO() BE $( OUT2(S.LN, 0) 717 | SSP := SSP + 1 $) 718 | 719 | AND LOADLIST(X) BE UNLESS X=0 DO 720 | $( UNLESS H1!X=S.COMMA DO $( LOAD(X); RETURN $) 721 | 722 | LOADLIST(H2!X) 723 | LOADLIST(H3!X) $) 724 | . 725 | 726 | // TRN5 727 | 728 | 729 | GET "TRNHDR" 730 | 731 | LET EVALCONST(X) = VALOF 732 | $(1 IF X=0 DO $( TRANSREPORT(117, CURRENTBRANCH) 733 | RESULTIS 0 $) 734 | 735 | SWITCHON H1!X INTO 736 | $( DEFAULT: TRANSREPORT(118, X) 737 | RESULTIS 0 738 | 739 | CASE S.NAME: 740 | $( LET T = CELLWITHNAME(X) 741 | IF DVEC!(T+1)=S.NUMBER RESULTIS DVEC!(T+2) 742 | TRANSREPORT(119, X) 743 | RESULTIS 0 $) 744 | 745 | CASE S.NUMBER: RESULTIS H2!X 746 | CASE S.TRUE: RESULTIS TRUE 747 | CASE S.FALSE: RESULTIS FALSE 748 | 749 | CASE S.NEG: RESULTIS - EVALCONST(H2!X) 750 | 751 | CASE S.MULT: RESULTIS EVALCONST(H2!X) * EVALCONST(H3!X) 752 | CASE S.DIV: RESULTIS EVALCONST(H2!X) / EVALCONST(H3!X) 753 | CASE S.PLUS: RESULTIS EVALCONST(H2!X) + EVALCONST(H3!X) 754 | CASE S.MINUS:RESULTIS EVALCONST(H2!X) - EVALCONST(H3!X) 755 | $)1 756 | 757 | 758 | AND ASSIGN(X, Y) BE 759 | $(1 IF X=0 \/ Y=0 DO 760 | $( TRANSREPORT(110, CURRENTBRANCH) 761 | RETURN $) 762 | 763 | SWITCHON H1!X INTO 764 | $( CASE S.COMMA: 765 | UNLESS H1!Y=S.COMMA DO 766 | $( TRANSREPORT(112, CURRENTBRANCH) 767 | RETURN $) 768 | ASSIGN(H2!X, H2!Y) 769 | ASSIGN(H3!X, H3!Y) 770 | RETURN 771 | 772 | CASE S.NAME: 773 | LOAD(Y) 774 | TRANSNAME(X, S.SP, S.SG, S.SL, 0) 775 | SSP := SSP - 1 776 | RETURN 777 | 778 | CASE S.RV: CASE S.VECAP: CASE S.COND: 779 | LOAD(Y) 780 | LOADLV(X) 781 | OUT1(S.STIND) 782 | SSP := SSP - 2 783 | RETURN 784 | 785 | DEFAULT: TRANSREPORT(109, CURRENTBRANCH) $)1 786 | 787 | 788 | AND TRANSNAME(X, P, G, L, N) BE 789 | $(1 LET T = CELLWITHNAME(X) 790 | LET K, A = DVEC!(T+1), DVEC!(T+2) 791 | 792 | IF T=0 DO $( TRANSREPORT(115, X) 793 | OUT2(G, 2) 794 | RETURN $) 795 | 796 | SWITCHON K INTO 797 | $( CASE S.LOCAL: IF T9 DO WRPN(N/10) 930 | WRC(N REM 10 + '0') $) 931 | 932 | AND ENDOCODE() BE $( wrch('*N'); OCOUNT := 0 $) 933 | 934 | 935 | AND WRC(CH) BE $( OCOUNT := OCOUNT + 1 936 | IF OCOUNT>62 /\ CH='*S' DO 937 | $( wrch('*N'); OCOUNT := 0; RETURN $) 938 | wrch(CH) $) 939 | --------------------------------------------------------------------------------