diff --git a/source/XBASIC/STQB64.BAS b/source/XBASIC/STQB64.BAS new file mode 100644 index 0000000..02c8902 --- /dev/null +++ b/source/XBASIC/STQB64.BAS @@ -0,0 +1,1250 @@ +1 REM THE VENERABLE STAR TREK COMPUTER GAME -- ANTTI J YLIKOSKI 12/19/2010 +2 REM ENTERED, MODIFIED AND DEBUGGED BY ANTTI J YLIKOSKI +3 REM ORIGINALLY FROM: THE BEST OF CREATIVE COMPUTING, VOL 1, +4 REM EDITED BY DAVID H. AHL, CREATIVE COMPUTING PRESS, +5 REM P.O.BOX 789-M, MORRISTOWN, N. J. 07960, USA +6 REM ISBN 0-916688-01-1, (C) 1976 BY CREATIVE COMPUTING +7 REM +8 REM THE QB64 VERSION -- SOME IDIOSYNCRACIES FIXED +9 REM +10 REM [VERSION "STREK7", 1/12/75 RCL] +12 REM EDITED AND DEBUGGED BY ANTTI J. YLIKOSKI 02/10/2010 -- +14 REM THE PROGRAM EXHIBITS THE CONTROL STRUCTURE AFFECTIONATELY +18 REM CALLED A "RAT'S NEST". +20 REM IT PROBABLY STEMS FROM THE ERA OF THE GOTO AND THE GOSUB +25 REM ONCOLOGICAL SURGERY WOULD HAVE BEEN POSSIBLE BUT ANYWAY: +27 REM "IF IT AIN'T BROKEN, DON'T FIX IT!" +29 REM +30 REM +40 REM *** *** STAR TREK *** +50 REM *** SIMULATION OF A MISSION OF THE STARSHIP ENTERPRISE, +60 REM *** AS SEEN ON THE STAR TREK TV SHOW +70 REM *** ORIGINAL PROGRAM BY MIKE MAYFIELD, MODIFIED VERSION +80 REM *** PUBLISHED IN DEC'S "101 BASIC GAMES" BY DAVE AHL +90 REM *** MODIFICATIONS TO THE LATTER (PLUS DEBUGGINGS) BY +100 REM *** BOB LEEDOM -- APRIL & DECEMBER 1974, +110 REM *** WITH A LITTLE HELP FROM HIS FRIENDS... +120 REM *** COMMENTS, EPITETHS, AND SUGGESTIONS SOLICITED (IN 1975) +130 REM *** ADDRESS TO: R. C. LEEDOM +140 REM *** WESTINGHOUSE DEFENSE & ELECTRONIC SYSTEMS CNTR. +150 REM *** BOX 746, M. S. 338 BALTIMORE, MD 21283, USA +152 REM +153 REM ORIGINALLY CONVERTED TO THE FREEBASIC, SEE +154 REM HTTP://WWW.FREEBASIC.NET +155 REM AND THE DOCUMENTATION +156 REM HTTP://WWW.FREEBASIC.NET/WIKI/ +157 REM BY ANTTI J YLIKOSKI 10-16-2010 +158 REM +159 REM QB64 VERSION BY ANTTI J. YLIKOSKI 12-19-2010, UPDATED 03-02-2012. +160 REM START THE QB64.EXE, OPEN THE PROGRAM FILE AND EXECUTE CTL-F5 +161 REM TO ENJOY THE GAME -- GOOD LUCK, ADMIRAL!!!!! +164 REM +165 REM SEE http://www.qb64.net/ +166 REM +167 REM EXISTING BUGS: THE CALCLULATION OF THE PHOTON TORPEDO COURSE +168 REM IS PARTIALLY FLAWED. +169 REM +172 RANDOMIZE TIMER +175 PRINT TAB(15); "* * * STAR TREK * * *" +180 PRINT +190 PRINT "DO YOU NEED INSTRUCTIONS (YES/NO)"; +200 DIM A$ +210 INPUT A$ +220 IF UCASE$(A$) = "YES" THEN GOSUB 10000 +240 REM THE PROGRAM BEGINS HERE.... +242 DIM Q9$ +244 DIM R9$ +246 DIM S4$ +250 DIM Z$ +251 DIM Q$(72) +252 DIM R$(72) +253 DIM S$(72) +260 DIM G1$ +261 DIM G2$ +262 DIM G3$ +263 DIM G4$ +265 DIM D7$ +270 LET Z$ = "" +272 LET Q$ = "" +274 LET R$ = "" +276 LET S$ = "" +278 FOR I = 1 TO 72 + 280 LET Z$ = Z$ + " " + 290 LET Q$ = Q$ + " " + 300 LET R$ = R$ + " " + 310 LET S$ = S$ + " " +320 NEXT I +322 REM Z$ IS SO TO SPEAK A ZERO STRING -- FULL OF SPACES +324 REM Q$ + R$ + S$ ARE ALTOGETHER 3*72 = 216 CHARACTERS OF MEMORY +326 REM THE VIDEO OF THE CURRENT QUADRANT ARE (3*8)*8 CHARACTERS, IE. +327 REM 192 CHARACTERS, STORED IN THE STRINGS Q$+R$+S$. +330 DIM G(1 TO 8, 1 TO 8) AS INTEGER +331 DIM C(1 TO 9, 1 TO 2) AS INTEGER +332 DIM K(1 TO 3, 1 TO 3) AS INTEGER +333 DIM N(1 TO 3) AS INTEGER +334 DIM Z(1 TO 8, 1 TO 8) AS INTEGER +340 DIM O1$ +341 DIM C$ +350 DIM A1$ +351 DIM T$ +360 DIM D$ +361 DIM O3$ +362 REM THE VARIABLE A1 IS THE GOOD LUCK FACTOR +363 REM A1 = 1 <=> ALMOST IMPOSSIBLE GAME +364 REM A1 = 3 <=> POSSIBLE GAME +365 REM A1 = 5 <=> EASY GAME +367 LET A1 = 5 +370 DIM C9 AS DOUBLE, A9 AS DOUBLE, W9 AS DOUBLE, D4 AS DOUBLE, D1 AS DOUBLE +372 DIM P7 AS DOUBLE +374 DIM A8 AS DOUBLE, X8 AS DOUBLE +379 LET T = INT(RND(1) * 20 + 20) * 100 +380 LET T0 = T +390 LET T9 = 30 + 5 * (A1 - 1): REM I WANT THE GAME TO BE WINNABLE +400 LET D0 = 0 +410 LET E0 = 3000 * A1: REM THE ENERGY AVAILABLE +420 LET E = E0 +430 LET P = 10 +440 LET P0 = P +450 LET S9 = 200 +460 LET S = 0 +465 LET F7 = 0 +470 REM AN AUXILIARY FUNCTION DEF FND(Z) SUBSTITUTED IN THE PROGRAM TEXT +485 REM INITIALIZE ENTERPRISE'S POSITION +490 LET Q1 = INT(RND(1) * 8 + 1) +500 LET Q2 = INT(RND(1) * 8 + 1) +510 LET S1 = INT(RND(1) * 8 + 1) +520 LET S2 = INT(RND(1) * 8 + 1) +530 REM MAT C=ZER +531 FOR F8 = 1 TO 9 + 532 FOR F9 = 1 TO 2 + 533 LET C(F8, F9) = 0 + 534 NEXT F9 +535 NEXT F8 +540 LET C(3, 1) = -1 +550 LET C(2, 1) = -1 +560 LET C(4, 1) = -1 +570 LET C(4, 2) = -1 +580 LET C(5, 2) = -1 +590 LET C(6, 2) = -1 +600 LET C(1, 2) = 1 +610 LET C(2, 2) = 1 +620 LET C(6, 1) = 1 +630 LET C(7, 1) = 1 +640 LET C(8, 1) = 1 +650 LET C(8, 2) = 1 +660 LET C(9, 2) = 1 +670 DIM D(8) AS INTEGER +680 FOR I = 1 TO 8 + 690 LET D(I) = 0 +700 NEXT I +710 LET A1$ = "NSLPTSDCX" +720 LET D$ = "WARP ENGINESS.R.SENSORS L.R.SENSORS PHASER CNTRL" +730 LET D$ = D$ + "PHOTON TUBESDAMAGE CNTRLSHIELD CNTRLCOMPUTER " +740 LET G4$ = "III" +750 LET G1$ = " ANTARES. SIRIUS. RIGEL. DENEB. PROCYON. CAPELLA. VEGA. " +760 LET G1$ = G1$ + "BETELGEUZE. CANOPUS. ALDEBARAN. ALTAIR. REGULUS. " +770 LET G1$ = G1$ + "SAGITTARIUS. ARCTURUS. POLLUX. SPICA. " +780 LET B9 = 0 +790 LET K9 = 0 +800 LET A1$ = "NSLPTSDCX" +810 REM SET UP WHAT EXISTS IN THE GALAXY.... +820 FOR I = 1 TO 8 + 830 FOR J = 1 TO 8 + 840 LET R1 = RND(1) + 850 IF R1 > 0.98 THEN GOTO 900 + 860 IF R1 > 0.95 THEN GOTO 930 + 870 IF R1 > 0.8 THEN GOTO 960 + 880 LET K3 = 0 + 890 GOTO 980 + 900 LET K3 = 3 + 910 LET K9 = K9 + 3 + 920 GOTO 980 + 930 LET K3 = 2 + 940 LET K9 = K9 + 2 + 950 GOTO 980 + 960 LET K3 = 1 + 970 LET K9 = K9 + 1 + 980 LET R1 = RND(1) + 990 IF R1 > 0.96 THEN GOTO 1020 + 1000 LET B3 = 0 + 1010 GOTO 1040 + 1020 LET B3 = 1 + 1030 LET B9 = B9 + 1 + 1040 LET S3 = INT(RND(1) * 8 + 1) + 1050 LET G(I, J) = K3 * 100 + B3 * 10 + S3 + 1060 REM K3=#KLINGONS; B3=#STARBASES; S3=#STARS + 1070 LET Z(I, J) = 0 + 1080 NEXT J +1090 NEXT I +1100 LET K7 = K9 +1110 DIM X$ +1111 DIM X0$ +1120 LET X$ = "" +1130 LET X0$ = " IS " +1140 IF B9 <> 0 THEN GOTO 1200 +1150 LET B9 = 1 +1160 IF G(6, 3) = 200 THEN GOTO 1190 +1170 LET G(6, 3) = G(6, 3) + 100 +1180 LET K9 = K9 + 1 +1190 G(6, 3) = G(6, 3) + 10 +1200 IF B9 = 1 THEN GOTO 1230 +1210 LET X$ = "S" +1220 LET X0$ = " ARE " +1230 PRINT +1235 PRINT "YOUR ORDERS ARE AS FOLLOWS:" +1240 PRINT " DESTROY THE"; K9; " KLINGON WARSHIPS WHICH HAVE INVADED" +1250 PRINT " THE GALAXY BEFORE THEY CAN ATTACK FEDERATION HEADQUARTERS" +1260 PRINT " ON STARDATE"; T0 + T9; "; THIS GIVES YOU"; T9; " DAYS. THERE"; X0$ +1270 PRINT " "; B9; " STARBASE"; X$; " IN THE GALAXY FOR RESUPPLYING YOUR SHIP." +1280 PRINT +1290 PRINT "HIT 'RETURN' WHEN READY TO ASSUME COMMAND ----" +1300 INPUT A$ +1310 REM *** HERE ANY TIME ENTER NEW QUADRANT *** +1320 LET Z4 = Q1 +1330 LET Z5 = Q2 +1340 LET K3 = 0 +1350 LET B3 = 0 +1360 LET S3 = 0 +1370 LET G5 = 0 +1380 LET D4 = 0.5 * RND(1) +1385 REM EXCEEDING GALAXY BORDERS? +1390 IF Q1 < 1 THEN GOTO 1600 +1400 IF Q1 > 8 THEN GOTO 1600 +1410 IF Q2 < 1 THEN GOTO 1600 +1420 IF Q2 > 8 THEN GOTO 1600 +1430 GOSUB 9030 +1440 PRINT +1450 IF T <> T0 THEN GOTO 1490 +1460 PRINT "YOUR MISSION BEGINS WITH YOUR STARSHIP LOCATED" +1470 PRINT "IN THE GALACTIC QUADRANT, '"; G2$; "'." +1472 LET F7 = 1 +1480 GOTO 1505 +1490 PRINT "NOW ENTERING '"; G2$; "' QUARDANT ..." +1500 PRINT +1505 LET F7 = 1 +1510 LET X = G(Q1, Q2) * 0.01 +1520 LET K3 = INT(X) +1530 LET B3 = INT((X - K3) * 10) +1540 LET S3 = G(Q1, Q2) - INT(G(Q1, Q2) * 0.1) * 10 +1550 IF K3 = 0 THEN GOTO 1590 +1560 PRINT "COMBAT AREA CONDITION RED" +1570 IF S > 200 THEN GOTO 1590 +1580 PRINT " SHIELDS DANGEROUSLY LOW" +1590 REM MAT K=ZER +1592 FOR F8 = 1 TO 3 + 1594 FOR F9 = 1 TO 3 + 1596 LET K(F8, F9) = 0 + 1597 NEXT F9 +1598 NEXT F8 +1600 FOR I = 1 TO 3 + 1610 LET K(I, 3) = 0 +1620 NEXT I +1630 LET Q$ = Z$ +1640 LET R$ = Z$ +1650 LET S$ = MID$(Z$, 1, 48) +1660 REM POSITION ENTERPRISE IN QUADRANT, THEN PLACE 'K3' KLINGONS, +1670 REM 'B3' STARBASES, AND 'S3' STARS ELSEWHERE +1680 LET A$ = "<*>" +1690 LET Z1 = S1 +1700 LET Z2 = S2 +1710 GOSUB 8670 +1715 IF K3 <= 0 THEN GOTO 1815 +1720 FOR I = 1 TO K3 + 1730 GOSUB 8590 + 1740 LET A$ = "+++" + 1750 LET Z1 = R1 + 1760 LET Z2 = R2 + 1770 GOSUB 8670 + 1780 LET K(I, 1) = R1 + 1790 LET K(I, 2) = R2 + 1800 LET K(I, 3) = S9 +1810 NEXT I +1815 IF B3 <= 0 THEN GOTO 1905 +1820 FOR I = 1 TO B3 + 1830 GOSUB 8590 + 1840 LET A$ = ">!<" + 1850 LET Z1 = R1 + 1860 LET Z2 = R2 + 1870 GOSUB 8670 + 1880 LET B4 = Z1 + 1890 LET B5 = Z2 +1900 NEXT I +1905 IF S3 <= 0 THEN GOTO 1975 +1910 FOR I = 1 TO S3 + 1920 GOSUB 8590 + 1930 LET A$ = " * " + 1940 LET Z1 = R1 + 1950 LET Z2 = R2 + 1960 GOSUB 8670 +1970 NEXT I +1975 REM +1980 GOSUB 6430 +1985 REM ***** THE LOOP BEGINS HERE ***** CHECK ENERGY, RECEIVE COMMAND +1986 REM ***** LOOP BEGINS AT STATEMENT 1990 +1990 IF S + E <= 10 THEN GOTO 2020 +2000 IF E > 10 THEN GOTO 2060 +2010 IF D(7) = 0 THEN GOTO 2060 +2020 PRINT "** FATAL ERROR ** YOU'VE JUST STRANDED YOUR SHIP IN SPACE!!" +2030 PRINT "YOU HAVE INSUFFICIENT MANEUVERING ENERGY, AND SHIELD CONTROL" +2040 PRINT "IS PRESENTLY INCAPABLE OF CROSS-CIRCUITING TO ENGINE ROOM!" +2050 GOTO 6260 +2060 PRINT "COMMAND (CAR RET FOR HELP) "; +2070 INPUT A$ +2072 DIM H9$ +2074 DIM I9$ +2076 DIM J9$ +2080 FOR I = 1 TO 9 + 2082 LET H9$ = MID$(A$, 1, 1) + 2084 LET I9$ = MID$(A1$, I, 1) + 2090 IF H9$ <> I9$ THEN GOTO 2160 + 2100 IF I <> 2 THEN GOTO 2140 + 2110 IF LEN(A$) < 2 THEN GOTO 2140 + 2115 LET J9$ = MID$(A$, 2, 1) + 2120 IF J9$ = "R" THEN GOTO 2140 + 2130 LET I = 6 + 2140 ON I GOTO 2300, 1980, 4000, 4260, 4700, 5530, 5690, 7290 + 2150 IF A$ = "XXX" THEN GOTO 6270 +2160 NEXT I +2170 PRINT "ENTER ONE OF THE FOLLOWING:" +2180 PRINT "NAV (TO SET COURSE)" +2190 PRINT "SRS (FOR SHORT RANGE SENSOR SCAN)" +2200 PRINT "LRS (FOR LONG RANGE SENSOR SCAN)" +2210 PRINT "PHA (TO FIRE PHASERS)" +2220 PRINT "TOR (TO FIRE PHOTON TODPEDOS)" +2230 PRINT "SHE (TO RAISE OR LOWER SHIELDS)" +2240 PRINT "DAM (FOR DAMAGE CONTROL REPORT)" +2250 PRINT "COM (TO CALL ON THE LIBRARY-COMPUTER" +2260 PRINT "XXX (TO RESIGN YOUR COMMAND)" +2270 PRINT +2280 GOTO 1990 +2290 REM COURSE CONTROL BEGINS HERE +2300 PRINT "COURSE (1-9) "; +2310 INPUT C1 +2320 IF C1 >= 1 THEN GOTO 2350 +2330 PRINT " LT. SULU REPORTS, 'INCORRECT COURSE DATA, SIR!'" +2340 GOTO 1990 +2350 IF C1 < 9 THEN GOTO 2380 +2360 IF C1 > 9 THEN GOTO 2330 +2370 LET C1 = 1 +2380 PRINT "WARP FACTOR (0-8) "; +2390 INPUT W1 +2400 IF W1 <= 0 THEN GOTO 2420 +2410 IF W1 <= 8 THEN GOTO 2450 +2420 PRINT "CHIEF ENGINEER SCOTT REPORTS 'THE ENGINES WON'T" +2430 PRINT " TAKE WARP "; W1; " !'" +2440 GOTO 1990 +2450 IF D(1) >= 0 THEN GOTO 2490 +2460 IF (W1 <= 0.2) THEN GOTO 2490 +2465 IF (W1 = 0.2) THEN GOTO 2490 +2470 PRINT "WARP ENGINES ARE DAMAGED. MAXIMUM SPEED = WARP 0.2" +2480 GOTO 2300 +2490 LET N7 = INT(W1 * 8 + 0.5) +2500 IF E - N7 > 0 THEN GOTO 2590 +2510 PRINT "ENGINEERING REPORTS 'INSUFFICIENT ENRGY AVAILABLE" +2520 PRINT " FOR MANEUVERING AT WARP "; W1; "!'" +2530 IF S < N7 - E THEN GOTO 1990 +2540 IF D(7) < 0 THEN GOTO 1990 +2550 PRINT "DEFLECTOR CONTROL ROOM ACKNOWLEDGES "; S; " UNITS" +2560 PRINT " OF ENERGY DEPLOYED TO THE SHIELDS." +2570 GOTO 5530 +2580 REM KLINGONS MOVE/FIRE ON MOVING STARSHIP............ +2590 FOR I = 1 TO K3 + 2600 IF K(I, 3) <= 0 THEN GOTO 2700 + 2610 LET A$ = " " + 2620 LET Z1 = K(I, 1) + 2630 LET Z2 = K(1, 2) + 2640 GOSUB 8670 + 2650 GOSUB 8570 + 2660 LET K(I, 1) = Z1 + 2670 LET K(I, 2) = Z2 + 2680 LET A$ = "+++" + 2690 GOSUB 8670 +2700 NEXT I +2710 GOSUB 6000 +2720 LET D1 = 0 +2730 LET D6 = W1 +2740 IF W1 < 1 THEN GOTO 2770 +2750 LET D6 = 1 +2760 REM MAKE REPAIRS TO THE SHIP +2770 FOR I = 1 TO 8 + 2780 IF D(I) >= 0 THEN GOTO 2880 + 2790 LET D(I) = D(I) + D6 + 2800 IF D(I) < 0 THEN GOTO 2880 + 2810 IF D1 = 1 THEN GOTO 2840 + 2820 LET D1 = 1 + 2830 PRINT "DAMAGE CONTROL REPORT: " + 2840 PRINT " "; + 2850 LET R1 = I + 2860 GOSUB 8790 + 2870 PRINT " REPAIR COMPLETED" +2880 NEXT I +2890 REM DAMAGE/IMPROVEMENT DURING SOME VES +2900 IF (RND(1) > 0.2) THEN GOTO 3070 +2910 LET R1 = INT(RND(1) * 8 + 1) +2920 IF (RND(1) >= 0.9) THEN GOTO 3000 +2925 REM CHANGED 0.6 TO 0.9 TO MAKE THE GAME LESS IMPOSSIBLE - A. J. Y. +2930 LET D(R1) = D(R1) - (RND(1) * 5 + 1) / A1 +2932 REM ADDED / A1 TO MAKE THE GAME LESS IMPOSSIBLE +2940 PRINT +2950 PRINT "DAMAGE CONTROL REPORT: "; +2960 GOSUB 8790 +2970 PRINT " DAMAGED" +2980 PRINT +2990 GOTO 3070 +3000 LET D(R1) = D(R1) + (RND(1) * 3.0 + 1.0) +3010 PRINT +3020 PRINT "DAMAGE CONTROL REPORT: "; +3030 GOSUB 8790 +3040 PRINT " STATE OF REPAIR IMPROVED" +3050 PRINT +3060 REM BEGIN MOVING STARSHIP ** +3070 REM EMPTY THE STARSHIP'S PLACE ON THE SCREEN +3075 LET A$ = " " +3080 LET Z1 = INT(S1 + 0.5) +3090 LET Z2 = INT(S2 + 0.5) +3100 GOSUB 8670 +3110 LET X1 = C(C1, 1) + (C(C1 + 1, 1) - C(C1, 1)) * (C1 - INT(C1)) +3120 LET X = S1 +3130 LET Y = S2 +3140 LET X2 = C(C1, 2) + (C(C1 + 1, 2) - C(C1, 2)) * (C1 - INT(C1)) +3150 LET Q4 = Q1 +3160 LET Q5 = Q2 +3164 DIM X8$ +3170 FOR I = 1 TO N7 + 3180 LET S1 = S1 + X1 + 3190 LET S2 = S2 + X2 + 3200 IF S1 < 1 THEN GOTO 3500 + 3210 IF S1 >= 9 THEN GOTO 3500 + 3220 IF S2 < 1 THEN GOTO 3500 + 3230 IF S2 >= 9 THEN GOTO 3500 + 3240 LET S8 = INT(S1 + 0.5) * 24 + INT(S2 + 0.5) * 3 - 26 + 3250 IF S8 > 72 THEN 3280 + 3255 LET X8$ = MID$(Q$, S8, 3) + 3257 REM IF NAVIGATING THRU EMPTY SPACE, GO ON: + 3260 IF X8$ = " " THEN GOTO 3360 + 3270 GOTO 3320 + 3280 IF S8 > 144 THEN GOTO 3310 + 3285 LET X8$ = MID$(R$, S8 - 72, 3) + 3290 IF X8$ = " " THEN GOTO 3360 + 3300 GOTO 3320 + 3310 LET X8$ = MID$(S$, S8 - 144, 3) + 3315 IF X8$ = " " THEN GOTO 3360 + 3320 LET S1 = S1 - X1 + 3330 LET S2 = S2 - X2 + 3340 PRINT "WARP ENGINES SHUT DOWN AT SECTOR "; S1; ", "; S2; " DUE TO " + 3345 PRINT "BAD NAVIGATION" + 3350 GOTO 3370 +3360 NEXT I +3370 LET A$ = "<*>" +3380 LET Z1 = INT(S1 + 0.5) +3390 LET Z2 = INT(S2 + 0.5) +3400 GOSUB 8670 +3410 GOSUB 3910 +3420 LET T8 = 1 +3430 IF W1 > 1 THEN GOTO 3450 +3440 LET T8 = 0.1 * INT(10 * W1) +3450 LET T = T + T8 +3460 IF T > T0 + T9 THEN GOTO 6220 +3470 REM SEE IF DOCKED, THEN GET COMMAND +3480 GOTO 1980 +3490 REM EXCEED QUADRANT LIMITS +3500 LET X = 8 * Q1 + X + N7 * X1 +3510 LET Y = 8 * Q2 + Y + N7 * X2 +3520 LET Q1 = INT(X / 8) +3530 LET Q2 = INT(Y / 8) +3540 LET S1 = INT(X - Q1 * 8) +3550 LET S2 = INT(Y - Q2 * 8) +3560 IF S1 <> 0 THEN GOTO 3590 +3570 LET Q1 = Q1 - 1 +3580 LET S1 = 8 +3590 IF S2 <> 0 THEN GOTO 3620 +3600 LET Q2 = Q2 - 1 +3610 LET S2 = 8 +3620 LET X5 = 0 +3630 IF Q1 >= 1 THEN GOTO 3670 +3640 LET X5 = 1 +3650 LET Q1 = 1 +3660 LET S1 = 1 +3670 IF Q1 <= 8 THEN GOTO 3710 +3680 LET X5 = 1 +3690 LET Q1 = 8 +3700 LET S1 = 8 +3710 IF Q2 >= 1 THEN GOTO 3750 +3720 LET X5 = 1 +3730 LET Q2 = 1 +3740 LET S2 = 1 +3750 IF Q2 <= 8 THEN GOTO 3790 +3760 LET X5 = 1 +3770 LET Q2 = 8 +3780 LET S2 = 8 +3790 IF X5 = 0 THEN GOTO 3860 +3800 PRINT "LT. UHURA REPORTS FROM STARFLEET COMMAND:" +3810 PRINT " 'PERMISSION TO ATTEMPT CROSSING OF GALACTIC PERIMETER" +3820 PRINT " IS HEREBY *DENIED*. SHUT DOWN YOUR ENGINES.'" +3830 PRINT "CHIEF ENGINEER SCOTT REPORTS 'WARP ENGINES SHUT DOWN" +3840 PRINT " AT SECTOR "; S1; " "; S2; " OF QUADRANT "; Q1; ", "; Q2; ".'" +3850 IF T > T0 + T9 THEN GOTO 3370 +3860 REM REMOVED THIS MYSTERY LINE: IF (8*Q1 + Q2) = (8*Q4 + Q5) THEN GOTO 3370 +3870 LET T = T + 1 +3880 GOSUB 3910 +3890 GOTO 1320 +3900 REM MANEUVER ENERGY S/R +3910 LET E = E - N7 - 10 +3920 IF E > 0 THEN GOTO 3980 +3930 PRINT "SHIELD CONTROL SUPPLIED ENERGY TO COMPLETE THE MANEUVER." +3940 LET S = S + E +3950 LET E = 0 +3960 IF S > 0 THEN GOTO 3980 +3970 LET S = 0 +3980 RETURN +3990 REM L. R. SCAN SENSOR SCAN CODE *** +4000 IF D(3) >= 0 THEN GOTO 4030 +4010 PRINT "LONG RANGE SENSORS ARE INOPERABLE" +4020 GOTO 1990 +4030 PRINT "LONG RANGE SENSOR SCAN FOR QUADRANT "; Q1; ", "; Q2 +4040 LET O1$ = "................." +4050 PRINT O1$ +4060 FOR I = Q1 - 1 TO Q1 + 1 + 4070 DIM N(3) + 4080 FOR I1 = 1 TO 3 + 4090 LET N(I1) = 0 + 4100 NEXT I1 + 4110 FOR J = Q2 - 1 TO Q2 + 1 + 4120 IF I < 1 THEN GOTO 4180 + 4130 IF I > 8 THEN GOTO 4180 + 4140 IF J < 1 THEN GOTO 4180 + 4150 IF J > 8 THEN GOTO 4180 + 4160 LET N(J - Q2 + 2) = G(I, J) + 4170 LET Z(I, J) = G(I, J) + 4180 NEXT J + 4190 DIM P1$ + 4200 LET P1$ = ": ### : ### : ### :" + 4210 PRINT USING P1$; N(1), N(2), N(3) + 4220 PRINT O1$ +4230 NEXT I +4240 GOTO 1990 +4250 REM *** PHASER CONTROL CODE BEGINS HERE +4260 IF K3 > 0 THEN GOTO 4300 +4270 PRINT "SCIENCE OFFICER SPOCK REPORTS 'SENSORS SHOW" +4280 PRINT " NO ENEMY SHIPS IN THIS QUADRANT.'" +4290 GOTO 1990 +4300 IF D(4) >= 0 THEN GOTO 4330 +4310 PRINT "PHASERS INOPERATIVE" +4320 GOTO 1990 +4330 IF D(8) >= 0 THEN GOTO 4350 +4340 PRINT "COMPUTER FAILURE HAMPERS ACCURACY" +4350 PRINT "PHASERS LOCKED ON TARGET; " +4360 PRINT "ENERGY AVAILABLE ="; E +4370 PRINT "NUMBER OF UNITS TO FIRE: "; +4380 INPUT X +4390 IF X <= 0 THEN GOTO 1990 +4400 IF E - X < 0 THEN GOTO 4360 +4410 LET E = E - X +4420 GOSUB 6000 +4430 IF D(7) >= 0 THEN GOTO 4450 +4440 LET X = X * RND(1) +4450 LET H1 = INT(X / K3) +4460 FOR I = 1 TO 3 + 4470 IF K(I, 3) <= 0 THEN GOTO 4670 + 4480 LET H = INT((H1 / (SQR((K(I, 1) - S1) ^ 2 + (K(I, 2) - S2) ^ 2)) * (RND(1) + 2))) + 4490 IF H > 0.15 * K(I, 3) THEN GOTO 4530 + 4500 PRINT "SENSORS SHOW NO DAMAGE" + 4510 PRINT " TO ENEMY AT "; K(I, 1); ", "; K(I, 2) + 4520 GOTO 4670 + 4530 LET K(I, 3) = K(I, 3) - H + 4540 PRINT H; " UNIT HIT ON KLINGON AT SECTOR "; K(I, 1); ", "; K(I, 2) + 4550 IF K(I, 3) <= O THEN GOTO 4580 + 4560 PRINT " (SENSORS SHOW "; K(I, 3), " UNITS REMAINING)" + 4570 GOTO 4670 + 4580 PRINT " *** KLINGON DESTROYED ***" + 4590 LET K3 = K3 - 1 + 4600 LET K9 = K9 - 1 + 4610 LET A$ = " " + 4620 LET Z1 = K(I, 1) + 4630 LET Z2 = K(I, 2) + 4640 GOSUB 8670 + 4650 LET G(Q1, Q2) = K3 * 100 + B3 * 10 + S3 + 4655 LET Z(Q1, Q2) = G(Q1, Q2) + 4660 IF K9 <= 0 THEN GOTO 6370 +4670 NEXT I +4680 GOTO 1990 +4690 REM PHOTON TORPEDO CODE BEGINS *** +4700 IF D(5) >= O THEN GOTO 4730 +4710 PRINT "PHOTON TUBES ARE NOT OPERATIONAL " +4720 GOTO 1990 +4730 IF P > 0 THEN GOTO 4760 +4740 PRINT "ALL PHOTON TORPEDOS EXPENDED" +4750 GOTO 1990 +4760 PRINT "TORPEDO COURSE (1-9) "; +4770 INPUT C1 +4780 IF C1 >= 1 THEN GOTO 4810 +4790 PRINT " ENSIGN CHEKOV REPORTS, 'INCORRECT COURSE DATA, SIR!'" +4800 GOTO 1990 +4810 IF C1 > 9 THEN GOTO 4790 +4820 IF C1 < 9 THEN GOTO 4850 +4830 IF C1 >= 9 THEN GOTO 4760 +4840 LET C1 = 1 +4850 LET X1 = C(C1, 1) + (C(C1 + 1, 1) - C(C1, 1)) * (C1 - INT(C1)) +4860 LET X2 = C(C1, 2) + (C(C1 + 1, 2) - C(C1, 2)) * (C1 - INT(C1)) +4870 LET E = E - 2 +4880 LET X = S1 +4890 LET Y = S2 +4900 LET P = P - 1 +4910 PRINT "TORPEDO TRACK:" +4920 LET X = X + X1 +4930 LET Y = Y + X2 +4940 LET X3 = INT(X + 0.5) +4950 LET Y3 = INT(Y + 0.5) +4960 IF X3 < 1 THEN GOTO 5490 +4970 IF X3 >= 9 THEN GOTO 5490 +4980 IF Y3 < 1 THEN GOTO 5490 +4990 IF Y3 >= 9 THEN GOTO 5490 +5000 PRINT " "; X3; ", "; Y3 +5010 LET A$ = " " +5020 LET Z1 = X +5030 LET Z2 = Y +5040 GOSUB 8830 +5050 IF Z3 <> 0 THEN GOTO 4920 +5060 LET A$ = "+++" +5070 LET Z1 = X +5080 LET Z2 = Y +5090 GOSUB 8830 +5100 IF Z3 = 0 THEN GOTO 5210 +5110 PRINT "*** KLINGON DESTROYED ***" +5120 LET K3 = K3 - 1 +5130 LET K9 = K9 - 1 +5140 IF K9 <= 0 THEN GOTO 6370 +5150 FOR I = 1 TO 3 + 5160 IF X3 <> K(I, 1) THEN GOTO 5180 + 5170 IF Y3 = K(I, 2) THEN GOTO 5190 +5180 NEXT I +5190 LET K(I, 3) = 0 +5200 GOTO 5430 +5210 LET A$ = " * " +5220 LET Z1 = X +5230 LET Z2 = Y +5240 GOSUB 8830 +5250 IF Z3 = 0 THEN GOTO 5280 +5260 PRINT "STAR AT "; X3; ", "; Y3; " ABSORBED TORPEDO ENERGY" +5270 GOTO 5500 +5280 LET A$ = ">!<" +5290 LET Z1 = X +5300 LET Z2 = Y +5310 GOSUB 8830 +5320 IF Z3 = 0 THEN GOTO 4760 +5330 PRINT "*** STARBASE DESTROYED ***" +5340 LET B3 = B3 - 1 +5350 LET B9 = B9 - 1 +5360 IF B9 > 0 THEN GOTO 5400 +5370 PRINT "THAT DOES IT, CAPTAIN!! YOU ARE HEREBY RELIEVED OF COMMMAND" +5380 PRINT " AND SENTENCED TO 99 STARDATES AT HARD LABOR ON CYGNUS 12!!" +5390 GOTO 6270 +5400 PRINT "STARFLEET COMMAND REVIEWING YOUR RECORD TO CONSIDER" +5410 PRINT " COURT MARTIAL!" +5420 LET D0 = 0 +5430 LET A$ = " " +5440 LET Z1 = X +5450 LET Z2 = Y +5460 GOSUB 8670 +5470 LET G(Q1, Q2) = K3 * 100 + B3 * 10 + S3 +5480 GOTO 5500 +5490 PRINT "TORPEDO MISSED" +5500 GOSUB 6000 +5510 GOTO 1990 +5520 REM ** SHIELD CONTROL STARTS HERE +5530 IF D(7) >= 0 THEN GOTO 5560 +5540 PRINT "SHIELD CONTROL INOPERABLE" +5550 GOTO 1990 +5560 PRINT "ENERGY AVAILABLE = "; E + S; " NUMBER OF UNITS TO SHIELDS: "; +5570 INPUT X +5580 IF X >= 0 THEN GOTO 5620 +5590 IF S <> X THEN GOTO 5620 +5600 PRINT "(SHIELDS UNCHANGED)" +5610 GOTO 1990 +5620 IF E + S - X < 0 THEN GOTO 5560 +5630 LET E = E + S - X +5640 LET S = X +5650 PRINT "DEFLECTOR CONTROL ROOM REPORT:" +5660 PRINT " 'SHIELDS NOW AT "; S; " PER YOUR COMMAND'" +5670 GOTO 1990 +5680 REM *** DAMAGE CONTROL STARTS HERE +5690 IF D(6) >= 0 THEN GOTO 5910 +5700 PRINT "DAMAGE CONTROL REPORT NOT AVAILABLE" +5710 IF D0 = 0 THEN GOTO 1990 +5720 LET D3 = 0 +5730 FOR I = 1 TO 8 + 5740 IF D(I) >= 0 THEN GOTO 5760 + 5750 LET D3 = D3 + 0.1 +5760 NEXT I +5770 IF D3 = 0 THEN GOTO 1990 +5780 LET D3 = D3 + D4 +5790 IF D3 < 1 THEN GOTO 5810 +5800 LET D3 = 0.9 +5810 PRINT "TECHNICIANS STANDING BY TO EFFECT REPAIRS TO YOUR SHIP." +5820 PRINT "ESTIMATED TIME TO REPAIR:"; +5830 PRINT USING ".# STARDATES"; D3 +5840 PRINT "WILL YOU AUTHORIZE THE REPAIR ORDER (YES/NO)"; +5850 INPUT A$ +5860 IF A$ <> "YES" THEN GOTO 1990 +5870 FOR I = 1 TO 8 + 5880 LET D(I) = 0 +5890 NEXT I +5900 LET T = T + D3 + 0.1 +5910 PRINT +5920 PRINT "DEVICE STATE OF REPAIR" +5930 FOR R1 = 1 TO 8 + 5940 GOSUB 8790 + 5950 PRINT USING " -##.##"; D(R1) +5960 NEXT R1 +5970 PRINT +5980 GOTO 5710 +5990 REM "KLINGONS SHOOTING" CODE BEGINS *** +6000 IF K3 <= O THEN GOTO 6210 +6010 IF D0 = 0 THEN GOTO 6040 +6020 PRINT "STAR BASE SHIELDS PROTECT THE ENTERPRISE" +6030 GOTO 6210 +6040 FOR I = 1 TO 3 + 6050 IF K(I, 3) <= 0 THEN GOTO 6200 + 6060 LET H = INT((K(I, 3) / (SQR((K(I, 1) - S1) ^ 2 + (K(I, 2) - S2) ^ 2)) * (2 + RND(1)))) + 6062 REM ADDED THE FOLLOWING TO MAKE THE GAME LESS IMPOSSIBLE + 6064 LET H = INT(H / A1) + 6070 LET S = S - H + 6080 PRINT H; " UNIT HIT ON ENTERPRISE FROM SECTOR "; K(I, 1); ", "; K(I, 2) + 6090 IF S < 0 THEN GOTO 6240 + 6100 PRINT " (SHIELDS DOWN TO "; S; " UNITS.)" + 6110 IF H < 20 THEN GOTO 6200 + 6120 IF RND(1) > 0.6 THEN GOTO 6200 + 6130 IF H / S <= 0.02 THEN GOTO 6200 + 6140 LET D2 = H / S + 0.5 * RND(1) + 6150 LET R1 = INT(RND(1) * 8 + 1) + 6160 LET D(R1) = D(R1) - D2 + 6170 PRINT "DAMAGE CONTROL REPORTS '"; + 6180 GOSUB 8790 + 6190 PRINT "DAMAGED BY THE HIT!'" +6200 NEXT I +6210 RETURN +6220 PRINT "IT IS STARDATE "; T +6230 GOTO 6270 +6240 PRINT +6250 PRINT "THE ENTERPRISE HAS BEEN DESTROYED."; +6255 PRINT " THE FEDERATION WILL BE CONQUERED." +6260 PRINT "IT IS STARDATE "; T +6270 PRINT "THERE WERE "; K9; " KLINGON BATTLE CRUISERS LEFT AT" +6280 PRINT " THE END OF YOUR MISSION." +6290 PRINT +6300 PRINT +6310 PRINT "THE FEDERATION IS IN NEED OF A NEW STARSHIP COMMANDER" +6320 PRINT "FOR A SIMILAR MISSION -- IF THERE IS A VOLUNTEER," +6330 PRINT "LET HIM STEP FORWARD AND ENTER 'AYE'." +6335 PRINT "OTHERWISE, DISCONTINUE PLAYING BY ENTERING (CAR RET)." +6340 INPUT A$ +6350 IF UCASE$(A$) = "AYE" THEN GOTO 240 +6360 GOTO 9250 +6370 PRINT "CONGRATULATIONS, CAPTAIN! THE LAST KLINGON BATTLE CRUISER" +6380 PRINT " MENACING THE FEDERATION HAS BEEN DESTROYED." +6390 PRINT +6400 PRINT "YOUR EFFICIENCY RATING IS "; ((K7 / (T - T0)) * 1000); ". " +6410 GOTO 6290 +6420 REM S. R. SENSOR SCAN & STARTUP SUBR. *** +6430 FOR I = S1 - 1 TO S1 + 1 + 6440 FOR J = S2 - 1 TO S2 + 1 + 6450 IF INT(I + 0.5) < 1 THEN GOTO 6540 + 6460 IF INT(I + 0.5) > 8 THEN GOTO 6540 + 6470 IF INT(J + 0.5) < 1 THEN GOTO 6540 + 6480 IF INT(J + 0.5) > 8 THEN GOTO 6540 + 6490 LET A$ = ">!<" + 6500 LET Z1 = I + 6510 LET Z2 = J + 6520 GOSUB 8830 + 6530 IF Z3 = 1 THEN GOTO 6580 + 6540 NEXT J +6550 NEXT I +6560 LET D0 = 0 +6570 GOTO 6650 +6580 LET D0 = 1 +6590 LET C$ = "DOCKED" +6600 LET E = 3000 * A1 +6602 REM THE VARIABLE E == ENERGY +6610 LET P = 10 +6612 REM THE VARIABLE P == # OF TORPEDOS +6620 PRINT "SHIELDS DROPPED FOR DOCKING PURPOSES" +6630 LET S = 0 +6632 REM THE VARIABLE S == ENERGY IN SHIELDS +6640 GOTO 6720 +6650 IF K3 > 0 THEN GOTO 6690 +6660 IF E < E0 * 0.1 THEN GOTO 6710 +6670 LET C$ = "GREEN" +6680 GOTO 6720 +6690 LET C$ = "*RED*" +6700 GOTO 6720 +6710 LET C$ = "YELLOW" +6720 IF D(2) >= 0 THEN GOTO 6770 +6730 PRINT +6740 PRINT "*** SHORT RANGE SENSORS ARE OUT ***" +6750 PRINT +6760 GOTO 7270 +6770 LET Z4 = Q1 +6771 LET Z5 = Q2 +6772 LET Q5 = 0 +6773 GOSUB 9030 +6774 IF F7 = 1 THEN 6777 +6775 PRINT "YOU ARE LOCATED IN THE GALACTIC QUADRANT, '"; G2$; "'..." +6777 PRINT +6778 LET F7 = 0 +6779 LET O1$ = "---------------------------------" +6780 PRINT O1$ +6790 DIM N5$ +6800 LET N5$ = "#####" +6810 PRINT " "; +6820 FOR I = 1 TO 22 STEP 3 + 6825 LET Q9$ = MID$(Q$, I, 3) + 6830 PRINT Q9$; " "; +6840 NEXT I +6850 PRINT +6860 PRINT " "; +6870 FOR I = 25 TO 46 STEP 3 + 6875 LET Q9$ = MID$(Q$, I, 3) + 6880 PRINT Q9$; " "; +6890 NEXT I +6900 PRINT " STARDATE "; +6910 PRINT USING "####.#"; T +6920 PRINT " "; +6930 FOR I = 49 TO 70 STEP 3 + 6935 LET Q9$ = MID$(Q$, I, 3) + 6940 PRINT Q9$; " "; +6950 NEXT I +6960 PRINT " CONDITION "; +6970 PRINT C$ +6980 PRINT " "; +6990 FOR I = 1 TO 22 STEP 3 + 6995 LET R9$ = MID$(R$, I, 3) + 7000 PRINT R9$; " "; +7010 NEXT I +7020 PRINT " QUADRANT "; Q1; ", "; Q2 +7030 PRINT " "; +7040 FOR I = 25 TO 46 STEP 3 + 7045 LET R9$ = MID$(R$, I, 3) + 7050 PRINT R9$; " "; +7060 NEXT I +7070 PRINT " SECTOR "; S1; ", "; S2 +7080 PRINT " "; +7090 FOR I = 49 TO 70 STEP 3 + 7095 LET R9$ = MID$(R$, I, 3) + 7100 PRINT R9$; " "; +7110 NEXT I +7120 PRINT " TOTAL ENERGY "; +7130 PRINT USING N5$; E + S +7140 PRINT " "; +7150 FOR I = 1 TO 22 STEP 3 + 7155 LET S4$ = MID$(S$, I, 3) + 7160 PRINT S4$; " "; +7170 NEXT I +7180 PRINT " PHOTON TORPEDOS "; +7190 PRINT USING N5$; P +7200 PRINT " "; +7210 FOR I = 25 TO 46 STEP 3 + 7215 LET S4$ = MID$(S$, I, 3) + 7220 PRINT S4$; " "; +7230 NEXT I +7240 PRINT " SHIELDS "; +7250 PRINT USING N5$; S +7260 PRINT O1$ +7270 RETURN +7280 REM *** LIBRARY COMPUTER CODE BEGINS HERE +7290 IF D(8) >= 0 THEN GOTO 7320 +7300 PRINT "COMPUTER DISABLED" +7310 GOTO 1990 +7320 PRINT "COMPUTER ACTIVE AND AWAITING COMMAND: (9 FOR HELP) "; +7330 INPUT a +7340 IF a < 0 THEN GOTO 1990 +7350 PRINT +7360 LET H8 = 1 +7370 IF a = 0 THEN GOTO 7540 +7380 ON a GOTO 7900, 8070, 8500, 8150, 7400 +7390 GOTO 7450 +7400 REM *** CREATED S/R 20000 TO FIX CRIPPLING BUGS +7410 LET H8 = 0 +7420 LET Q5 = 1 +7430 PRINT " THE GALAXY" +7440 GOSUB 20000 +7445 GOTO 1990 +7450 PRINT "FUNCTIONS AVAILABLE FROM LIBRARY-COMPUTER:" +7460 PRINT " 0 = CUMULATIVE GALACTIC RECORD" +7470 PRINT " 1 = STATUS REPORT" +7480 PRINT " 2 = PHOTON TORPEDO DATA" +7490 PRINT " 3 = STARBASE NAV DATA" +7500 PRINT " 4 = DIRECTION/DISTANCE CALCULATOR" +7510 PRINT " 5 = GALAXY 'REGION NAME' MAP" +7520 GOTO 7320 +7530 REM *** CUMULATIVE GALACTIC RECORD CODE BEGINS *** +7540 PRINT "COMPUTER RECORD OF GALAXY FOR QUADRANT "; Q1; ", "; Q2 +7550 PRINT " 1 2 3 4 5 6 7 8" +7560 LET O3$ = " ----- ----- ----- ----- ----- ----- ----- -----" +7570 PRINT O3$ +7580 DIM N1$ +7582 DIM N2$ +7584 DIM N$ +7590 FOR I = 1 TO 8 + 7600 LET N1$ = "#" + 7610 PRINT USING N1$; I; + 7620 IF H8 = 0 THEN GOTO 7740 + 7630 FOR J = 1 TO 8 + 7640 LET N2$ = " ###" + 7650 LET N$ = "" + 7660 IF I <> Q1 THEN GOTO 7700 + 7670 IF J <> Q2 THEN GOTO 7700 + 7680 LET N$ = "" + 7690 PRINT N$; + 7700 PRINT USING N2$; Z(I, J); + 7710 PRINT N$; + 7720 NEXT J + 7730 GOTO 7850 + 7740 LET Z4 = I + 7750 LET Z5 = J + 7760 GOSUB 9030 + 7770 LET J0 = INT(15 - 0.5 * LEN(G2$)) + 7780 PRINT TAB(J0); + 7790 PRINT G2$; + 7800 LET Z5 = 5 + 7810 GOSUB 9030 + 7820 LET J0 = INT(39 - 0.5 * LEN(G2$)) + 7830 PRINT TAB(J0); + 7840 PRINT G2$; + 7850 PRINT + 7860 PRINT O3$ +7870 NEXT I +7880 GOTO 1990 +7890 REM *** STATUS REPORT CODE BEGINS HERE *** +7900 PRINT " STATUS REPORT" +7910 LET X$ = "" +7920 IF K9 = 1 THEN GOTO 7940 +7930 LET X$ = "S" +7940 PRINT K9; " KLINGON"; X$; " LEFT" +7950 LET V5 = (T0 + T9) - T +7960 PRINT USING "MISSION MUST BE COMPLETED IN ##.# STARDATES"; V5 +7970 LET X$ = "" +7980 IF B9 = 1 THEN GOTO 8040 +7990 LET X$ = "S" +8000 IF B9 <> 0 THEN GOTO 8040 +8010 PRINT "YOUR STUPIDITY HAS LEFT YOU ON YOUR OWN IN" +8020 PRINT " THE GALAXY -- YOU HAVE NO STARBASES LEFT!" +8030 GOTO 5690 +8040 PRINT "THE FEDERATION IS MAINTAINING "; B9; " STARBASE"; X$; +8045 PRINT " IN THE GALAXY" +8050 GOTO 5690 +8060 REM CODE FOR TORPEDO DATA, BASE NAV, D/D CALCULATOR +8070 PRINT "PHOTON TORPEDO SIGINT, PLUS GATHERED HUMINT:" +8071 IF K3 = 0 THEN GOTO 8492 +8072 LET H8 = 0 +8074 LET K5 = 1 +8080 FOR I = 1 TO 3 + 8090 IF K(I, 3) <= 0 THEN GOTO 8480 + 8100 LET W9 = CDBL(K(I, 2)) + 8110 LET X9 = CDBL(K(I, 1)) + 8120 LET C9 = CDBL(S2) + 8130 LET A9 = CDBL(S1) + 8140 GOTO 8220 + 8150 PRINT "DIRECTION/DISTANCE CALULATOR:" + 8160 PRINT "YOU ARE AT QUADRANT ("; Q1; ", "; Q2; ") SECTOR ("; + 8165 PRINT S1; ", "; S2; ")" + 8170 PRINT "PLEASE ENTER --" + 8180 PRINT " INITIAL COORDINATES (X, Y) "; + 8190 INPUT C9, A9 + 8200 PRINT " FINAL COORDINATES (X, Y) "; + 8210 INPUT W9, X9 + 8211 REM REWORKED THIS CODE ENTIRELY WITH THE ATN() FUNCTION /AJY + 8212 LET P7 = ATN(1.0#) + 8213 REM ARCUS TANGENS (1.0) = PI / 4.0 + 8214 LET P7 = 4.0# * P7 + 8215 PRINT "COMPUTER RESPONDS:" + 8220 LET X8 = A9 - X9 + 8221 REM THE Y COORDINATE GROWS GOING DOWNWARDS + 8222 REM X8 = DELTA(Y) + 8230 LET A8 = W9 - C9 + 8331 REM THE X COORDINATE GROWS GOING LEFTWARDS + 8232 REM A8 = DELTA(X) + 8234 REM D-Y AND D-X + 8250 IF (X8 > 0.0#) AND (A8 > 0.0#) THEN GOTO 8300 + 8260 IF (X8 < 0.0#) AND (A8 > 0.0#) THEN GOTO 8360 + 8270 IF (X8 < 0.0#) AND (A8 < 0.0#) THEN GOTO 8330 + 8280 IF (X8 > 0.0#) AND (A8 < 0.0#) THEN GOTO 8317 + 8282 IF (X8 = 0.0#) AND (A8 = 0.0#) THEN GOTO 8370 + 8284 IF (X8 = 0.0#) AND (A8 <> 0.0#) THEN GOTO 8401 + 8286 IF (X8 <> 0.0#) AND (A8 = 0.0#) THEN GOTO 8380 + 8290 PRINT "IMPOSSIBLE, I QUIT!" + 8292 END + 8300 REM HERE D-Y IS POS. AND D-X IS POS. + 8305 GOSUB 30000 + 8310 PRINT "'DIRECTION = "; (D1 + 1.0#), + 8315 GOTO 8460 + 8317 REM HERE D-Y IS POS. AND D-X IS NEG. + 8318 GOSUB 30000 + 8320 PRINT "'DIRECTION = "; (5.0# - D1), + 8322 GOTO 8460 + 8330 REM HERE D-Y AND D-Y ARE BOTH NEG. + 8332 GOSUB 30000 + 8340 PRINT "'DIRECTION = "; (5.0# + D1), + 8350 GOTO 8460 + 8360 REM HERE D-Y IS NEG. AND D-X IS POS. + 8361 GOSUB 30000 + 8362 PRINT "'DIRECTION = "; (9.0# - D1), + 8364 GOTO 8460 + 8370 PRINT "NO TRAVEL NECESSARY.'" + 8372 GOTO 1990 + 8380 PRINT "'DIRECTION = "; + 8382 IF X8 < 0 THEN GOTO 8390 + 8384 PRINT 1.0, + 8386 GOTO 8460 + 8390 PRINT 5.0, + 8400 GOTO 8460 + 8401 PRINT "'DIRECTION = "; + 8402 IF A8 < 0 THEN GOTO 8390 + 8406 PRINT 3.0, + 8410 GOTO 8460 + 8412 PRINT 7.0, + 8414 GOTO 8460 + 8460 PRINT " DISTANCE = "; SQR(X8 ^ 2 + A8 ^ 2); "'" + 8470 IF H8 = 1 THEN GOTO 1990 +8480 NEXT I +8490 GOTO 1990 +8492 PRINT "NO KLINGONS DETECTED." +8494 GOTO 1990 +8500 IF B3 <> 0 THEN GOTO 8530 +8510 PRINT "MR. SPOCK REPORTS, 'SENSORS SHOW NO STARBASES IN THIS QUADRANT.'" +8520 GOTO 1990 +8530 PRINT "FROM ENTERPRISE TO STARBASE:" +8532 PRINT "'"; +8540 LET W1 = B4 +8550 LET X = B5 +8560 GOTO 8120 +8570 REM *** END OF LIBRARY-COMPUTER CODE +8580 REM S/R FINDS RANDOM HOLE IN QUADRANT +8590 LET R1 = INT(RND(1) * 8.0 + 1.0) +8600 LET R2 = INT(RND(1) * 8.0 + 1.0) +8610 LET A$ = " " +8620 LET Z1 = R1 +8630 LET Z2 = R2 +8640 GOSUB 8830 +8650 IF Z3 = 0 THEN GOTO 8590 +8660 RETURN +8670 REM *** INSERTION IN STRING ARRAY FOR QUARDANT *** +8680 LET S8 = INT(Z1 + 0.5) * 24 + INT(Z2 + 0.5) * 3 - 26 +8690 IF S8 > 72 THEN GOTO 8720 +8692 MID$(Q$, S8, 3) = A$ +8710 GOTO 8780 +8720 IF S8 > 144 THEN GOTO 8760 +8730 LET S8 = S8 - 72 +8740 MID$(R$, S8, 3) = A$ +8750 GOTO 8780 +8760 LET S8 = S8 - 144 +8765 REM TO THE LOCATION OF S8 IS ASSIGNED THE CHAR STRING A$ +8770 MID$(S$, S8, 3) = A$ +8780 RETURN +8790 REM *** PRINTS DEVICE NAME FROM ARRAY *** +8800 LET S8 = R1 * 12 - 11 +8807 LET D7$ = MID$(D$, S8, 12) +8810 PRINT D7$; " "; +8820 RETURN +8830 REM *** STRING COMPARISON IN QUADRANT ARRAY *** +8840 LET Z1 = INT(Z1 + 0.5) +8850 LET Z2 = INT(Z2 + 0.5) +8860 LET S8 = Z1 * 24 + Z2 * 3 - 26 +8865 DIM X9$ +8870 LET Z3 = 0 +8880 IF S8 > 72 THEN GOTO 8920 +8890 LET X9$ = MID$(Q$, S8, 3) +8895 IF X9$ <> A$ THEN GOTO 9000 +8900 LET Z3 = 1 +8910 GOTO 9000 +8920 IF S8 > 144 THEN GOTO 8970 +8930 LET S8 = S8 - 72 +8940 LET X9$ = MID$(R$, S8, 3) +8945 IF X9$ <> A$ THEN GOTO 9000 +8950 LET Z3 = 1 +8960 GOTO 9000 +8970 LET S8 = S8 - 144 +8980 LET X9$ = MID$(S$, S8, 3) +8985 IF X9$ <> A$ THEN GOTO 9000 +8990 LET Z3 = 1 +9000 RETURN +9010 REM *** S/R PRODUCES QUADRANT NAME IN G2$ FROM Z4, Z5 (=Q1,Q2) +9020 REM *** (CALL WITH Q5=1 TO GET REGION NAME ONLY) +9030 LET L2 = 2 +9035 REM IF Z5 > 5 THEN IT IS THE RIGHTMOST OF A PAIR OF NAMES +9040 IF Z5 >= 5 THEN GOTO 9060 +9050 LET L2 = 1 +9060 LET L3 = 2 * (Z4 - 1) + L2 +9070 LET I3 = 1 +9080 LET I0 = 1 +9085 DIM Y7$ +9090 FOR L = 1 TO LEN(G1$) + 9095 LET Y7$ = MID$(G1$, L, 2) + 9100 IF Y7$ <> ". " THEN GOTO 9140 + 9110 IF I3 = L3 THEN GOTO 9150 + 9120 LET I0 = L + 1 + 9130 LET I3 = I3 + 1 +9140 NEXT L +9150 LET G2$ = MID$(G1$, I0 + 1, L - 1 - I0) +9160 IF Q5 = 1 THEN GOTO 9240 +9170 LET L3 = 25 +9180 IF Z5 <= 4 THEN GOTO 9200 +9190 LET L3 = Z5 - 4 +9200 LET G3$ = "IV" +9210 IF L3 = 4 THEN GOTO 9230 +9220 LET G3$ = MID$(G4$, 1, L3) +9230 LET G2$ = G2$ + " " + G3$ +9240 RETURN +9250 END +10000 REM THE INSTRUCTIONS SUBROUTINE +10030 DIM A5$ +10040 FOR I = 1 TO 9 + 10050 ON I GOSUB 10240, 10360, 10540, 10640, 10720, 10780, 10860, 10910, 10960 + 10060 PRINT + 10070 PRINT "(TO CONTINUE, HIT 'RETURN')" + 10080 PRINT + 10090 INPUT A5$: CLS +10100 NEXT I +10110 PRINT "1. WHEN YOU SEE 'COMMAND ?' PRINTED, ENTER ONE OF THE LEGAL" +10120 PRINT " COMMANDS (NAV, SRS, LRS, PHA, TOR, SHE, DAM, COM, OR XXX)." +10130 PRINT "2. IF YOU SHOULD TYPE IN AN ILLEGAL COMMAND, YOU'LL GET A SHORT" +10140 PRINT " LIST OF THE LEGAL COMMANDS PRINTED OUT." +10150 PRINT "3. SOME COMMANDS REQUIRE YOU TO ENTER DATA. (FOR EXAMPLE, THE" +10160 PRINT " 'NAV' COMMAND COMES BACK WITH 'COURSE (1-9)?'. IF YOU" +10170 PRINT " TYPE IN ILLEGAL DATA (LIKE NEGATIVE NUMBERS), THAT COMMAND" +10180 PRINT " WILL BE ABORTED." +10190 PRINT +10200 PRINT "HIT (CAR RET) TO CONTINUE " +10210 INPUT A5$ +10215 PRINT +10220 RETURN +10230 REM ***** EXIT HERE ***** +10240 PRINT +10250 PRINT " INSTRUCTIONS FOR ** STAR TREK **" +10260 PRINT +10270 PRINT "THE GALAXY IS DIVIDED INTO AN 8 X 8 QUADRANT GRID," +10280 PRINT "AND EACH QUADRANT IS FURTHER DIVIDED INTO AN 8 X 8 SECTOR GRID." +10290 PRINT +10300 PRINT " YOU WILL BE ASSIGNED A STARTING POINT SOMEWHERE IN THE GALAXY" +10310 PRINT "TO BEGIN A TOUR OF DUTY AS COMMANDER OF THE STARSHIP 'ENTERPRISE';" +10320 PRINT "YOUR MISSION: TO SEEK AND DESTROY THE FLEET OF KLINGON WARSHIPS" +10330 PRINT "WHICH ARE MENACING THE UNITED FEREDATION OF PLANETS." +10340 PRINT +10350 RETURN +10360 PRINT +10370 PRINT "YOU HAVE THE FOLLOWING COMMANDS AVAILABLE TO YOU AS" +10380 PRINT "CAPTAIN OF THE STARSHIP:" +10390 PRINT "'NAV' COMMAND = WARP ENGINE CONTROL --" +10400 PRINT " COURSE IS IN A CIRCULAR NUMERICAL 4 3 2" +10410 PRINT " VECTOR ARRANGEMENT AS SHOWN. . . . " +10420 PRINT " INTEGER AND REAL VALUES MAY BE ... " +10430 PRINT " USED. (THUS, COURSE 1.5 IS HALF - 5-----1" +10440 PRINT " WAY BETWEEN 1 AND 2.) ... " +10450 PRINT " . . . " +10460 PRINT " VALUES MAY APPROACH 9.0, WHICH 6 7 8" +10470 PRINT " ITSELF IS EQUIVALENT TO 1.0." +10480 PRINT " COURSE " +10490 PRINT " ONE WARP FACTOR IS THE SIZE OF" +10500 PRINT " ONE QUADRANT. THEREFORE, TO GET" +10510 PRINT " FROM QUADRANT 6, 5 TO 5, 5, YOU WOULD" +10520 PRINT " USE COURSE 3, WARP FACTOR 1." +10530 RETURN +10540 PRINT +10545 PRINT "'SRS' COMMAND = SHORT RANGE SENSOR SCAN" +10550 PRINT " SHOWS YOU A SCAN OF YOUR PRESENT QUADRANT." +10560 PRINT " SYMBOLOGY ON YOUR SENSOR SCREEN IS A FOLLOWS:" +10570 PRINT " <*> = YOUR STARSHIP'S POSITION" +10580 PRINT " +++ = KLINGON BATTLE CRUISER" +10590 PRINT " >!< = FEDERATION STARBASE (REFUEL/REPAIR/RE-ARM HERE!)" +10600 PRINT " * = STAR" +10610 PRINT " A CONDENSED 'STATUS REPORT' WILL ALSO BE PRESENTED." +10620 PRINT +10630 RETURN +10640 PRINT +10645 PRINT "'LRS' COMMAND = LONG RANGE SENSOR SCAN" +10650 PRINT " SHOWS CONDITIONS IN SPACE FOR ONE QUADRANT ON EACH SIDE" +10660 PRINT " OF THE ENTERPRISE (WHICH IS IN THE MIDDLE OF THE SCAN)" +10670 PRINT " THE SCAN IS CODED IN THE FORM '###', WHERE THE UNITS DIGIT" +10680 PRINT " IS THE NUMBER OF STARS, TENS DIGIT IS THE NUMBER OF STARBASES," +10690 PRINT " AND HUNDREDS DIGIT IS THE NUMBER OF KLINGONS." +10700 PRINT " EXAMPLE -- 207 = 2 KLINGONS, NO STARBASES, 7 STARS." +10710 RETURN +10720 PRINT +10725 PRINT "'PHA' COMMAND = PHASER CONTROL" +10730 PRINT " ALLOWS YOU TO DESTROY THE KLINGON BATTLE CRUISERS BY" +10740 PRINT " ZAPPING THEM WITH SUITABLY LARGE UNITS OF ENERGY TO" +10750 PRINT " DEPLETE THEIR SHIELD POWER. (REMEMBER, KLINGONS HAVE" +10760 PRINT " PHASERS, TOO!)" +10770 RETURN +10780 PRINT +10785 PRINT "'TOR' COMMAND = PHOTON TORPEDO CONTROL." +10790 PRINT " TORPEDO COURSE IS THE SAME AS USED IN WARP ENGINE CONTROL." +10800 PRINT " IF YOU HIT THE KLINGON VESSEL, HE IS DESTROYED AND" +10810 PRINT " CANNOT FIRE BACK AT YOU. IF YOU MISS, YOU ARE SUBJECT TO" +10820 PRINT " HIS PHASER FIRE." +10830 PRINT " NOTE: THE LIBRARY-COMPUTER ('COM' COMMAND) HAS AN" +10840 PRINT " OPTION TO COMPUTE TORPEDO TRAJECTORY FOR YOU (OPTION 2))." +10850 RETURN +10860 PRINT +10865 PRINT "'SHE' COMMMAND = SHIELD CONTROL." +10870 PRINT " DEFINES NUMBER OF ENERGY UNITS TO BE ASSIGNED TO SHIELDS." +10880 PRINT " ENERGY IS TAKEN FROM TOTAL SHIP'S ENERGY. NOTE THAT THE" +10890 PRINT " TOTAL ENERGY INCLUDES SHIELD ENERGY." +10900 RETURN +10910 PRINT +10915 PRINT "'DAM' COMMAND = DAMAGE CONTROL REPORT" +10920 PRINT " GIVES STATE OF REPAIR OF ALL DEVICES, WHERE A NEGATIVE" +10930 PRINT " 'STATE OF REPAIR' SHOWS THAT THE DEVICE IS TEMPORARILY" +10940 PRINT " DAMAGED." +10950 RETURN +10960 PRINT +10965 PRINT "'COM' COMMMAND = LIBRARY-COMPUTER" +10970 PRINT " THE LIBRARY-COMPUTER CONTAINS SIX OPTIONS:" +10980 PRINT " OPTION 0 = CUMULATIVE GALACTIC RECORD" +10990 PRINT " WHICH SHOWS COMPUTER MEMORY OF THE RESULTS OF ALL PREVIOUS" +11000 PRINT " LONG RANGE SENSOR SCANS." +11010 PRINT " OPTION 1 = STATUS REPORT" +11020 PRINT " WHICH THE NUMBER OF KLINGONS, STARDATES, AND STARBASES" +11030 PRINT " REMAINING IN THE GAME." +11040 PRINT " OPTION 2 = PHOTON TORPEDO DATA" +11050 PRINT " WHICH GIVES DIRECTIONS AND DISTANCE FROM THE ENTERPRISE" +11060 PRINT " TO ALL KLINGONS IN YOU QUADRANT" +11070 PRINT " OPTION 3 = STARBASE NAV DATA" +11080 PRINT " WHICH GIVES DIRECTION AND DISTANCE TO ANY STARBASE" +11090 PRINT " WITHIN YOUR QUADRANT" +11100 PRINT " OPTION 4 = DIRECTION/DISTANCE CALCULATOR" +11110 PRINT " WHICH ALLOWS YOU TO ENTER COORDINATES FOR" +11120 PRINT " DIRECTION/DISTANCE CALCULATIONS." +11130 PRINT " OPTION 5 = GALACTIC 'REGION NAME' MAP" +11140 PRINT " WHICH PRINTS THE NAMES OF THE SIXTEEN MAJOR GALACTIC" +11150 PRINT " REGIONS REFERRED TO IN THE GAME." +11160 RETURN +20000 REM **** PROGRAMMMED A NEW SUBROUTINE TO DISPLAY THE GALAXY +20010 PRINT " 1 2 3 4 5 6 7 8" +20020 LET O3$ = " ----- ----- ----- ----- ----- ----- ----- -----" +20030 PRINT O3$ +20040 FOR J = 1 TO 8 + 20050 PRINT USING "#"; J; + 20060 PRINT " "; + 20065 LET Q5 = 1 + 20066 LET Z4 = J + 20067 LET Z5 = 2 + 20070 GOSUB 9030 + 20080 PRINT G2$; + 20082 FOR J9 = 1 TO (25 - LEN(G2$)) + 20090 PRINT " "; + 20092 NEXT J9 + 20100 LET Z5 = 7 + 20110 GOSUB 9030 + 20120 PRINT G2$ + 20130 PRINT " I II III IV I II III IV" +20200 NEXT J +20210 LET Q5 = 0 +20220 RETURN +30000 REM AUX S/R FOR DIRECTION/DISTANCE CALCLULATION +30005 REM REWORKED ALL OF THIS CODE TO USE TRIGONOMETRY A. J. Y. 10-18-2010 +30010 LET D4 = ABS(ATN(ABS(X9) / ABS(A8))) +30012 LET P7 = ATN(1.0#) +30014 LET P7 = 4.0# * P7 +30020 LET D1 = (D4 / (2.0# * P7)) * 8.0# +30030 RETURN +99999 END diff --git a/source/XBASIC/XBASIC.alg_m b/source/XBASIC/XBASIC.alg_m new file mode 100644 index 0000000..1bac9fd --- /dev/null +++ b/source/XBASIC/XBASIC.alg_m @@ -0,0 +1,1567 @@ +?COMPILE 0XBASIC/UTILITY WITH XALGOL +?XALGOL STACK = 5000 +?DATA CARD +$ CARD LIST SINGLE XREF + BEGIN +COMMENT::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: +::::: XBASIC -- A CONVERSATIONAL BASIC INTERPRETER ::::: +::::: ::::: +::::: MK XV 1.04: 1 DECEMBER 1975 ::::: +::::: ::::: +:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: + + XBASIC IS A BASIC INTERPRETER DEVELOPED FOR THE BURROUGHS RANGE +OF COMPUTERS BY STAFF AT PAISLEY COLLEGE OF TECHNOLOGY. ITS PURPOSE +IS TO PROVIDE FAST RESPONSE TO SIMPLE BASIC PROGRAMS UNDER TIME- +SHARING. ACTUAL RUNNING OF PROGRAMS IS MUCH SLOWER FOR XBASIC, BUT +EXPERIENCE SHOWS THAT MOST CLASS TIME IS SPENT ON INPUT AND COMPILE. + + XBASIC IS AN IMPLEMENTATION OF STANDARD BASIC, AND DIFFERS +FROM BURROUGHS BASIC IN CERTAIN MATTERS OF DETAIL. THE COMMANDS +ALLOWED IN XBASIC FORM A SUBSET OF THE COMMANDS AVAILABLE UNDER CANDE. +FILES ARE EDITABLE UNDER CANDE. TRACE AND UNTRACE STATEMENTS +CAN BE MADE AVAILABLE - SEE LINES 83300-83400 AND 107300-108700. +XBASIC OUTPUT MAY BE DIVERTED FROM REMOTE TO PRINTER ("SEND"). +VIDEO TERMINALS ARE SUPPORTED FOR EASY CORRECTION OF SOURCE PROGRAM. +PROGRAMS ARE MONITORED FOR EXCESS LOOPING. + + TO USE XBASIC FROM THE BATCH TERMINAL, THE FOLLOWING +CARDS SHOULD BE SUPPLIED: + ? EXECUTE 0XBASIC/UTILITY + ? COMMON=2 + ? DATA CRD + (INSERT DECK HERE: USE TERMINAL FORMAT) + ? END +:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::; +COMMENT + THE BLOCK STRUCTURE FOR THE PROGRAM IS AS FOLLOWS: + + ------------- /------| + 1 SOURCEIN: 1 / DOES | + START-->--1 & EXECUTE 1--RUN->----< OBJECT >--YES--->---| + 1 1 COMMANDS 1 | EXIST? / 1 + A ------------- |------| V + 1 1 1 1 + 1 1 (YES) V (NO) 1 + 1 /------| 1 1 + 1 / ANY | ------------- 1 + 1 < SYNTAX >------<----1 COMPILE: 1 1 + 1 | ERRORS?/ 1 1 1 + 1 |------/ ------------- 1 + 1 1 1 + 1 V (NO) 1 + 1 1 1 + 1 ------------- 1 + |---<---1 EXECUTE: 1------------------<--------------/ + ------------- + +:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::; + + INTEGER IU; % (COMMON) INPUT UNIT=0 VDU,1 TTY,2 CRD + + INTEGER ARRAY PROG[0:200,2:11], % SOURCE STRINGS + SSEQ[0:200], % SEQUENCE NUMBERS + STYP, % STATEMENT TYPES + SPOB[1:200], % POINTERS TO OBJECTPROGRAM + SUB[1:26], % INFO ON USER FUNCTIONS + ARR[1:26,0:2], % ARRAYS + STRAR[1:26,0:1], % STRING ARRAYS + IOB[1:240],IOF[1:10], % I/O PSEUDOBUFFERS + IOBE[1:14], % " " + KEY[1:38], % COMPILE KEYWORDS + FNM[1:3,1:2]; % FILENAMES FOR EXECUTE + + REAL ARRAY OBJ[0:999], % PSEUDO-OBJECTPROGRAM + FORX[1:10,1:4], % INFO ON FOR STATEMENTS + CONST[1:1000], % SOURCE PROGRAM CONSTANTS + ANSA[0:9], % FOR DISK SEARCH + IO[0:3]; % FILENAMES + + INTEGER MS, % NUMBER OF LINES OF PROGRAM + ACS, % FIRST EXECUTABLE STATEMENT + CS, % CURRENT STATEMENT NUMBER + CHA, % CURRENT SOURCE CHARACTER + CP, % POSITION OF CHA IN SOURCE + LP, % SEE LOOK + CO, % POSITION IN OBJ + OU, % OUTPUT UNIT (0 REMOTE, 1 PRINTER) + MSTO, % CURRENT TOP OF ARRAYS + MSTR, % CURRENT TOP OF STRING ARRAYS + NCON, % NUMBER OF CONSTANTS + DELIM, % SEE NCH + TIM, % MAX EXECUTION TIME (2 MIN USUALLY) + LL, % CURRENT LINE NUMBER IN INPUT PAGE + AREASIZE, % FOR EXECUTE OUTPUT FILE IF ANY + BEG, % LIST COMMAND INITIAL LINE + EN, % FINAL LINE + NDEP, % ARITH STACK COUNTER + ADDR, % CURRENT VARIABLE ADDRESS + FORE,FORC, % HELP COMPILE FOR NESTS + NF, % NUMBER OF EXECUTE FILES + A,B,C,D,K; % HASH + + REAL R,S,T; % HASH + + BOOLEAN OBJECT, % "THERE IS AN ORJECTPROGRAM" + STRIN, % "EXPRESSION IS A STRING" + HDDR, % "PRINTER HEADER PRINTED" + INFILTOG, % "PROGRAM NEEDS INPUT FILE" + OUTFILTOG, % "PROGRAM NEEDS OUTPUT FILE" + FIRSTOFF, % "HELLO" + DANGER, % "NEW MATERIAL IN WORKFILE" + VAR, % "EXPRESSION IS A VARIABLE" + SY, % "PROGRAM CONTAINS SYNTAX ERRORS" + EQOK, % "EXPRESSION MAY CONTAIN =" + AA; % "SUCCESSIVE EXPNS TO PRINT" + + POINTER PINB, % START OF LINE IN IOB[*] + PIOB, % CURRENT CHARACTER " + PIBE, % LAST CHARACTER IN IOBE[1] + POB, % FIRST CHARCTER IN OBJ[*] + APR,BPR,CPR; % HASH + + FORMAT WHT ("ERR- ",A6," IS NOT A COMMAND IN XBASIC"), + STP (/"END ",A6), + SPC (/), + WRN ("MORE THAN 100 GOTOS. IS YOUR PROGRAM ALL RIGHT?"), + REP (A3), + SYER ("SYNTAX ERRORS: CLEAR SCREEN AND TRANSMIT A SPACE"), + SYR ("SYNTAX ERRORS:"), + WT ("WAIT-"), + MESS ("EXECUTING"), + INTR ("ILLEGAL NUMBER"), + LNGPRG("PROGRAM TOO LONG AT LINE ",I6), + INVIT ("VDU ASSUMED - ELSE SAY TTY"), + DVO ("OUTPUT IS BEING DIVERTED TO PRINTER"), + BK ("EXECUTION STOPPED - EXCESS TIME."/ + "FOR LONG PROGRAMS USE MAIN SYSTEM"), + SNUM (X72,I8), + F1 ("USE RENAME XXXXXX OR SAVE XXXXXX COMMAND"), + F2 ("ERR? THIS WILL DELETE THE WORKFILE"), + F3 ("OK- ",I3," RECORDS",A6,"D, LAST RECORD =",I7), + F4 ("FILE ",A6," - ",A6,A1," BY XBASIC"), + F5 ("YOUR WORKFILE IS AS AT LAST RUN COMMAND"), + F6 (I6,X3,"DIM OR FILES STATEMENT OUT OF SEQUENCE"/ + "ERR RUN"), + F7 ("WORKFILE NOW EMPTY"), + HD1 ("FURTHER OUTPUT WILL BE PRINTED WHEN YOU SIGN OFF"), + HD3 (X40,"XBASIC MK XV",X8,"RUN ",A6,"DAY ", + A2,"/",A2,"/",A2,/X54,"USER NO. ",A3,A4,/X52,20("*")//), + + F9 ("XBASIC IS RUNNING-"), + F10 ("UNNAMED WORKFILE HAS",I4," RECORDS, LAST RECORD =",I6), + F11 (A6," (WORKFILE) HAS",I4," RECORDS, LAST RECORD =",I6), + F12 ("ERR- ILLEGAL PARAMETER"), + F13 ("ARE PRESENT CONTENTS OF FILE ",A6," TO BE DESTROYED?"); + + SWITCH FORMAT NUM:=(U10),(U6),(X20,U10); + SWITCH FORMAT MNP:=("NOT ENOUGH INPUT AT LINE",I6,X5,"TRY AGAIN"), + ("BLANK INPUT AT LINE",I6,X5,"IGNORED"); + + FILE TTY 19(2,10);FILE IN CRD 2(2,10); FILE IN VDU 19(1,240); + FILE OUT LIN 1(2,14);SWITCH FILE FN:=TTY,CRD;SWITCH FILE FL:=TTY,LIN; + + MONITOR INTOVR,EXPOVR,INDEX,FLAG,ZERO; + + LABEL SOURCEIN,COMPILE,EXECUTE,STOP,FINSH,ERR,INCST,PER,INER, + TOOLONG; + + LABEL EXS,EQL,LET,CAR,ONX,RON,IFF,FEQ,GOT,GOS,RET,FOX,NEX, + DEF,REA,RREA,INP,RAN,RES,PRI,RPRI,XPRI,DIM,ENX,REM,RFIL, + INTVR,QUOTE,RDUM,DAT,RDAT,RDIM,PAG,MAT,IOMT,FLAGR,FIL,CGO; + SWITCH OPN:=LET,GOT,GOS,RET,INP,REA,PRI,FOX,NEX,MAT, + DEF,DAT,RAN,PAG,RES,REM,ENX,ENX,IFF,ONX; + + + DEFINE ON(ON1)=IF CHA=ON1 THEN #; + + COMMENT::::::::::::::::GLOBAL PROCEDURES::::::::::::::::::::::::::: + + --- CHCONV CONVERTS CHA TO LETTER CODE 1-26 ; + + INTEGER PROCEDURE CHCONV(A);VALUE A; INTEGER A; + BEGIN CHCONV:=0;IF A GTR 16 AND A LSS 26 THEN CHCONV:=A-16 ELSE + IF A GTR 32 AND A LSS 42 THEN CHCONV:=A-23 ELSE + IF A GTR 49 AND A LSS 58 THEN CHCONV:=A-31 END; + COMMENT + --- NCH PICKS NEXT CHARACTER FROM SOURCE STRING + AND STORE IT IN CHA. BLANKS ARE SKIPPED. + IF LAST CHAR- RETURN "%" AT DELIM. + CP IS UPDATED. IOBE[*] IS USED AS HASH.; + + INTEGER PROCEDURE NCH; + BEGIN INTEGER A;LABEL RPT; POINTER CPR; + IOBE[1]:=0;A:=CP; + RPT: IF A GEQ DELIM THEN CHA:=NCH:="%" ELSE BEGIN + CPR:=POINTER(PROG[CS,2])+A; + REPLACE PIBE BY CPR:CPR FOR 1;A:=A+1; + IF IOBE[1]=48 THEN GO TO RPT;CHA:=NCH:=IOBE[1];CP:=A + END END; + COMMENT + --- NMBR PICKS UP STATEMENT NUMBER ; + INTEGER PROCEDURE NMBR(N);VALUE N;INTEGER N; + BEGIN LABEL DONE,RNB,BLK,NST,SKB; + DEFINE RD(RD1)=REPLACE BPR BY APR:APR FOR 1; + IF DELTA(PINB,APR) GEQ RD1 THEN GO BLK;IF IOBE[1]#; + CHA:=NMBR:=IOBE[1]:=0; + NST: RD(N)=48 THEN GO NST;IF (CHA:=IOBE[1]) GEQ 10 THEN GO DONE; + RNB: RD(72) LSS 10 THEN BEGIN CHA:=CHA|10+IOBE[1];GO RNB END; + NMBR:=CHA;CHA:=IOBE[1];IF CHA NEQ 48 THEN GO DONE; + SKB: RD(72)=48 THEN GO SKB;CHA:=IOBE[1];GO DONE; + + + BLK: CHA:="%"; + DONE: END; + COMMENT + --- FILECONTROL DEALS WITH SOURCE FILE OPERATIONS + A=0 "MAKE"/"RENAME", + 1 "SAVE", 2 "LOAD"/"COPY", + 3 "REMOVE", 4 SAVE WORKFILE(AT "RUN") + 5 LOAD WORKFILE(AT XBASIC ENTRY), + 6 EXPLICIT REMOVE (AT "BYE",ETC) + 7 EXPLICIT SAVE, 8 EXPLICIT LOAD; + + PROCEDURE FILECONTROL(A,C,D,L);VALUE A,C,D;INTEGER A;REAL C,D;LABEL L; + % C AND D CARRY LABEL EQUATE FOR EXPLICIT OPERATIONS + BEGIN INTEGER B,X,Y; + PROCEDURE FILERR(E);VALUE E;INTEGER E; + BEGIN SWITCH FORMAT ERR:=("ERR- ",A3,A4,"/",A3,A4,"- NOT ON DISK"), + ("ERR- ",A3,A4,"/",A3,A4," - INVALID USER"), + ("ERR- ",A3,A4,"/",A3,A4," - NON-STANDARD"), + ("ERR- ",A3,A4,"/",A3,A4," - ILLEGAL NAME"), + ("ERR- ",A3,A4,"/",A3,A4," - DUPLICATE NAME"), + ("ERR- NO FILENAME"), + ("ERR- WORKFILE"), + ("ERR- WORKFILE IS EMPTY"); + + IF E>4 THEN WRITE(TTY,ERR[E]) ELSE WRITE(TTY,ERR[E], + FOR X:=B,2 DO [IO[X].[41:18],IO[X].[23:24]]); + IF B=0 THEN IO[0]:=0;IF A=1 AND E=3 THEN WRITE(TTY,F1); + GO SOURCEIN END; + LABEL SKIP,MK,SV,LD,RM,EF,SW,LW,EW; + SWITCH OP:=MK,SV,LD,RM,SW,LW,RM,SV,LD; + FILE DSK DISK "XBWKFL "(2,10,300,SAVE 7);% NB LABEL EQN ABOVE SKIP + IF DANGER AND (C="CREATE" OR A=2 OR A=6) THEN BEGIN DANGER:=FALSE; + WRITE(TTY,F2);GO SOURCEIN END; + B:=IF A=0 THEN 0 ELSE 1;IF A>3 THEN BEGIN + FILL DSK WITH C,D;IO[1]:=C;IO[2]:=D;GO SKIP END; + IO[B]:=" "; % FILENAME + SCAN APR:APR FOR 5 UNTIL NEQ " ";IF DELTA(PINB,APR)<12 THEN + REPLACE POINTER(IO[B])+1 BY APR:APR FOR IF A<2 THEN 6 ELSE 7 + WHILE IN ALPHA; + IF IO[B]=" " THEN BEGIN % ON SAVE SAVE WKFILE IF NO NAME + IF A=1 AND IO[0] NEQ 0 THEN IO[1]:=IO[0] ELSE FILERR(5) END; + IO[2]:=0;IF A GTR 1 THEN BEGIN % PROCESS "/USERCODE" IF PRESENT + SCAN CPR:CPR:=APR FOR 10 WHILE NEQ "/";IF DELTA(PINB,CPR) LSS 15 THEN + BEGIN IO[2]:=" "; + REPLACE POINTER(IO[2])+1 BY APR:CPR+1 FOR 7 WHILE IN ALPHA END END; + IF IO[2]=0 THEN IO[2]:=TIME(-1); + IF IO[B]="XBWKFL " OR IO[B].[41:36] LSS "A00000" THEN FILERR(3); + FILL DSK WITH IO[B],IO[2];DSK.SAVE:=7; + SKIP: IF NOT FIRSTOFF THEN BEGIN X:=CHA;Y:=NMBR(72); + IF Y NEQ 0 OR CHA NEQ "%" THEN GO PER;CHA:=X END; + SEARCH(DSK,ANSA[*]);IF (A=5 OR A=6) AND ANSA[0]=-1 THEN GO L; + IF A=0 AND ANSA[0] NEQ -1 THEN FILERR(4); + IF A=1 AND IO[1] NEQ IO[0] AND ANSA[0] NEQ -1 THEN FILERR(4); + IF A>1 AND A NEQ 4 THEN BEGIN IF ANSA[0] LEQ 0 THEN FILERR(ANSA[0]+1); + IF ANSA[3] NEQ 10 OR ANSA[4] NEQ 300 THEN FILERR(2) END; + IF CHA="MAKE00" THEN BEGIN MS:=0;OBJECT:=FALSE END; + GO OP[A+1]; + SV: IF IO[0]=0 THEN IO[0]:=IO[B]; % NAME WORKFILE + IF MS=0 THEN FILERR(7);IF ANSA[0] NEQ -1 AND ANSA[0] NEQ 7 THEN + FILERR(1);DSK.AREAS:=20;DSK.AREASIZE:=10; + FOR CS:=1 STEP 1 UNTIL MS DO BEGIN % SAVE IT IN CANDE FORMAT + REPLACE POINTER(IOBE[10]) BY SSEQ[CS] FOR 8 DIGITS; + REPLACE POINTER(IOBE[*]) BY POINTER(PROG[CS,2]) FOR 9 WORDS; + WRITE(DSK,10,IOBE[*]) END;LOCK(DSK);DANGER:=FALSE;GO MK; + LD: FOR MS:=1 STEP 1 UNTIL 200 DO BEGIN % LOAD FROM + READ(DSK,10,IOBE[*])[EF];READ(IOBE[*],SNUM,SSEQ[MS]); % CANDE FORMAT + WRITE(PROG[MS,*],9,IOBE[*]);PROG[MS,11]:=SSEQ[MS] END; + EF: MS:=MS-1;OBJECT:=FALSE;LOCK(DSK); + WRITE(TTY,F3,MS,C,SSEQ[MS]); + ON("LOAD00") IO[0]:=IF IO[2]=TIME(-1) THEN IO[1] ELSE 0;GO MK; + RM: IF IO[B]=IO[0] AND A=3 THEN BEGIN IF MS=0 THEN + IO[0]:=0 ELSE FILERR(6) END;IF ANSA[0] NEQ 7 THEN FILERR(1); + WRITE(DSK,*,0);CLOSE(DSK,PURGE);GO MK; + SW: DSK.AREAS:=20;DSK.AREASIZE:=11; + IF MS=0 THEN FILERR(7); + WRITE(DSK,*,IO[0]);FOR CS:=1 STEP 1 UNTIL MS DO + WRITE(DSK,10,PROG[CS,*]);LOCK(DSK);DANGER:=FALSE;GO MK; + LW: READ(DSK,*,IO[0]);FOR MS:=1 STEP 1 UNTIL 200 DO + BEGIN READ(DSK,10,PROG[MS,*])[EW];SSEQ[MS]:=PROG[MS,11] END; + EW: LOCK(DSK);MS:=MS-1;OBJECT:=FALSE;GO MK; + MK: IF A<4 AND CHA NEQ "COPY00" THEN + WRITE(TTY,F4,IO[B].[41:36],C,D); + IF A=5 THEN WRITE(TTY,F5); + IF CHA="COPY00" THEN WRITE(TTY,STP,"COPY "); + GO L END; + COMMENT + --- SYNT DEALS WITH SYNTAX ERRORS ; + + PROCEDURE SYNT(A);VALUE A;REAL A; + BEGIN IF SY THEN BEGIN IF IU=0 THEN BEGIN WRITE(TTY,SYER); + READ(TTY[STOP]) END ELSE WRITE(TTY,SYR);SY:=FALSE END; + REPLACE APR:=POINTER(IOBE[*]) BY " " FOR 72; + WRITE(IOBE[*],NUM[0],SSEQ[CS]);SCAN APR:APR WHILE NEQ 48; + IF IU=0 THEN BEGIN REPLACE APR:APR BY POINTER(PROG[CS,*]) FOR 72; + APR:=POINTER(IOBE[*])+72; + REPLACE APR:APR BY "!" FOR 1 END ELSE APR:=APR+3; + REPLACE POB BY A FOR 8;REPLACE APR BY POB+1 FOR 7; + OBJ[1]:=0;REPLACE POB+7 BY POINTER(IOBE[*])+79 FOR 1; + IF IU GTR 0 THEN WRITE(TTY,9,IOBE[*]) ELSE IF OBJ[1]=48 THEN + WRITE(TTY,10,IOBE[*]) ELSE WRITE(TTY[NO],10,IOBE[*]);GO TO ERR END; + COMMENT + --- NWC MODIFIES NCH FOR COMPILE ; + + INTEGER PROCEDURE NWC; + BEGIN ON("%") SYNT("MISG OP");NWC:=NCH END; + + COMMENT + --- PUT STORES CHARACTER IN OBJ ; + + PROCEDURE PUT(A);VALUE A;INTEGER A; + BEGIN IF A>63 THEN SYNT("STR >63"); + IOBE[1]:=A;REPLACE POB+CO BY PIBE FOR 1;CO:=CO+1; + IF CO GEQ 8000 THEN GO TO TOOLONG;IF CO MOD 8=0 THEN CO:=CO+1 END; + COMMENT + --- RED MOVES BACK ONE SPACE IN OBJ; + + DEFINE RED=CO:=IF CO.[2:3]=1 THEN CO-2 ELSE CO-1#; + + COMMENT + --- LOOK LOOKS AT A STRING IN SOURCE PROG ; + + INTEGER PROCEDURE LOOK(A);VALUE A;INTEGER A; + BEGIN INTEGER B,C,D,E;E:=C:=CHA;B:=CP; + FOR D:=1 STEP 1 UNTIL A-1 DO IF CHA NEQ "%" THEN C:=C|64+NWC; + LOOK:=C;LP:=CP;CP:=B;CHA:=E END; + COMMENT + --- NUMB PICKS UP DIM AND MAT SIZES ; + + INTEGER PROCEDURE NUMB; + BEGIN LABEL RP;INTEGER A; + A:=0; + RP: IF NWC LSS 10 THEN BEGIN A:=A|10+CHA;GO TO RP END; + IF A=0 THEN SYNT("IL STMT"); + NUMB:=A END; + COMMENT + --- ARITH(1) CONVERTS EXPNS TO REVERSE POLISH ; + + PROCEDURE ARITH(TT);VALUE TT;INTEGER TT; + BEGIN INTEGER I,A,B,C,J,K,OP,STCK;BOOLEAN INMOK,VOK,STROK; + LABEL S,SS,RPT,EXPON,DONE,FINEV,FORM1,FORM2,FORM3,FIN,RP; + INTEGER ARRAY OPK[1:20]; + + COMMENT AN EXPRESSION CONSISTS OF A NUMBER OF PRIMARIES + SEPARATED BY OPERATORS, POSSIBLY PRECEDED BY INITIAL - . + PRIMARIES: OPERATORS: + NUMBER + + VARIABLE - + ARRAY WITH SUBSCRIPT(S) * + FUNCTION WITH PARAMETER(S) / + STRING ** + STRING VARIABLE = + STRING ARRAY WITH SUBSCRIPT + EXPRESSION IN BRACKETS + + EXPRESSION HAS TYPE REAL UNLESS STRING PRIMARY + OCCURS: IF SO IT HAS TYPE STRING. A VARIABLE PRIMARY IS + A PRIMARY OTHER THAN NUMBER, FUNCTION, OR STRING. + IN OBJ AN EXPRESSION HAS FORM + A OPS A OPS ... A OPS 0 + WHERE A IS A CHARACTER BETWEEN 1 AND 16 GIVING THE PRIMARY + OR OPERATOR TYPE. OPS IS 0-2 CHARACTERS GIVING MORE INFORMATION + DEPENDING ON A. ; + + STRIN:=FALSE;NDEP:=NDEP+1;IF NDEP=10 THEN SYNT("SIMPLFY"); + STCK:=OP:=0;INMOK:=VOK:=TRUE;STROK:=TT=0; + + COMMENT PRIMARIES: ; + + SS: CHA:=NWC; + COMMENT BRACKETED EXPRESSION; + S: ON(29) BEGIN ARITH(1);IF CHA NEQ 45 THEN SYNT("NO ) ,A"); + RED;GO TO FORM1 END; + COMMENT 1 NUMBER ; + IF CHA LSS 10 OR CHA = 26 THEN BEGIN R:=I:=0; + RPT: ON(26) BEGIN I:=1;CHA:=NWC END; + IF CHA GEQ 10 THEN GO TO EXPON;IF I>0 THEN BEGIN R:=R+CHA|10*(-I); + I:=I+1 END ELSE R:=R|10+CHA;CHA:=NWC; GO TO RPT; + EXPON: IF CHA NEQ 21 THEN GO TO DONE;I:=1;CHA:=NWC;J:=0; + ON(44) BEGIN I:=-1;CHA:=NWC END ELSE ON(16) CHA:=NWC;J:=CHA; + IF CHA GEQ 10 THEN SYNT("NO EXPN");CHA:=NWC; + IF CHA LSS 10 THEN BEGIN J:=J|10+CHA;CHA:=NWC END;R:=R|10*(I|J); + DONE: PUT(1);NCON:=NCON+1;CONST[NCON]:=R; + PUT(NCON.[11:6]);PUT(NCON.[5:6]);GO FORM2 END; + COMMENT 8 INITIAL - ; + ON(44) BEGIN IF NOT INMOK THEN SYNT ("MISPL -");PUT(8); + GO TO FORM2 END; + COMMENT 16 STRING ; + ON(63) BEGIN IF NOT STROK THEN SYNT("ILL STR");PUT(16); + SCAN CPR:APR:=POINTER(PROG[CS,2])+CP WHILE NEQ 63;A:=DELTA(APR,CPR); + STRIN:=TRUE;IF A>14 THEN SYNT("LONGSTR");PUT(A);PUT(CP); + CP:=CP+A+1;CHA:=NWC;VAR:=FALSE;GO TO FORM3 END; + IF CHCONV(CHA)=0 THEN SYNT("ILL NUM"); + B:=CHA;A:=LOOK(2) MOD 64;IF CHCONV(A) NEQ 0 THEN BEGIN + A:=LOOK(3) MOD 4096;CHA:=B; + IF A NEQ "ST" AND A NEQ "TH" AND A NEQ"TO" AND A NEQ "GO" THEN + BEGIN LABEL EQL,FNQ,RDUM; + COMMENT 5 STANDARD FNS; + INTEGER B,AS,AP; + B:=LOOK(3);CP:=LP; + FOR A:=21 STEP 1 UNTIL 32 DO IF B=KEY[A] THEN GO TO EQL; + GO TO FNQ; + EQL: IF NWC NEQ 29 THEN SYNT("NO PARM");ARITH(1);RED; + PUT(5);PUT(A-2); + IF CHA NEQ 45 THEN SYNT("NO ) A");GO TO FORM1; + COMMENT 4 USER FNS ; + FNQ: K:=B DIV 64; IF K NEQ "FN" THEN SYNT("UNRC FN"); + B:=CHCONV(B MOD 64);IF SUB[B]=0 THEN SYNT("UNDC FN"); + IF NWC NEQ 29 THEN SYNT("NO PARM");A:=0; + RDUM: A:=A+1;ARITH(1);RED;ON(58) GO TO RDUM; + IF CHA NEQ 45 OR A NEQ SUB[B] THEN SYNT("PARAMTR"); + CHA:=NWC;PUT(4);PUT(B);GO TO FORM2 END END; + B:=CHCONV(B);IF B=0 THEN SYNT("INV VAR");CHA:=NWC; + COMMENT 3 ARRAY ; + ON(29) BEGIN IF ARR[B,1]=0 THEN SYNT("UNDC AR"); + ARITH(1);RED;ON(58) BEGIN IF ARR[B,2]=0 THEN SYNT("SUBSCPT"); + ARITH(1);RED END;IF CHA NEQ 45 THEN SYNT("SUBSCPT");STROK:=FALSE; + PUT(3);PUT(B);CHA:=NWC END + ELSE ON("$") BEGIN IF NOT STROK THEN SYNT("ILL STR"); + COMMENT 15 STRING ARRAY; + CHA:=NWC;ON(29)BEGIN IF STRAR[B,1]=0 THEN SYNT("UNDSTAR");ARITH(1); + RED; + IF CHA NEQ 45 THEN SYNT("NO ) ,5");PUT(15);CHA:=NWC END ELSE + PUT(14);PUT(B);STRIN:=TRUE;VAR:=VOK;GO TO FORM3 END + ELSE BEGIN PUT(2);PUT(B);IF CHA LSS 10 THEN BEGIN PUT(C:=CHA+1); + COMMENT 14 STRING VBLE + 2 VARIABLE ; + CHA:=NCH END ELSE PUT(C:=0);IF STCK=0 THEN ADDR:=11|(B-1)+C; + STROK:=FALSE END;VAR:=VOK;GO TO FORM3; + FORM1: CHA:=NWC; + FORM2: STROK:=VAR:=FALSE;IF STRIN THEN SYNT("ILL STR"); + COMMENT 7-13 OPERATORS: + DANGER: REVERSE POLISH SECTION ; + FORM3: BEGIN LABEL RPT,TEST,BOP,XOP; + STCK:=STCK+1;INMOK:=FALSE; + RPT: I:=0;ON(16) I:=3 ELSE ON(44) I:=4 ELSE + ON(43) BEGIN IF NWC=43 THEN I:=7 ELSE BEGIN CP:=CP-1;I:=5 END; + END ELSE ON(49) I:=6 ELSE IF CHA=61 AND EQOK THEN BEGIN INMOK:=TRUE; + IF NOT VAR THEN SYNT("ILL ASN");I:=1 END;VOK:=I LEQ 1; + IF NOT VOK THEN BEGIN STROK:=FALSE;IF STRIN THEN SYNT("ILL STR") END; + TEST: IF OP=0 THEN GO TO BOP; IF OP LSS 0 + THEN SYNT(" ARITH"); + J:=OPK[OP];IF I|J NEQ 1 AND (I+1) DIV 2 LEQ (J+1) DIV 2 THEN BEGIN + OP:=OP-1;GO TO XOP END; + BOP: IF I=0 THEN GO TO FIN;OP:=OP+1;OPK[OP]:=1;GO TO SS; + XOP: VAR:=FALSE;STCK:=STCK-1; + PUT(J+6);IF STCK LEQ 0 THEN SYNT(" ARITH"); + GO TO TEST END; + COMMENT 6 END EXPN ; + FIN: NDEP:=NDEP-1;IF STCK NEQ 1 THEN SYNT(" ARITH"); + PUT(0) END; + COMMENT + --- SKIP SKIPS GIVEN STRING IF FOUND ; + + PROCEDURE SKIP(A,B);VALUE A,B;INTEGER A,B; + BEGIN INTEGER C,D,E;E:=CP;C:=NWC; + FOR D:=1 STEP 1 UNTIL A-1 DO IF CHA NEQ "%" THEN C:=C|64+NWC; + IF C NEQ B THEN BEGIN CP:=E;CHA:=0 END END; + COMMENT + --- CHMAT CHECK USED IN MAT STATEMENT ; + + INTEGER PROCEDURE CHMAT(A);VALUE A;INTEGER A; + BEGIN A:=CHCONV(A);IF A=0 THEN SYNT("ILL ARR"); + IF ARR[A,1]=0 THEN SYNT("UNDC AR");IF ARR[A,2]=0 THEN + SYNT(" TYPE");CHMAT:=A END; + + + COMMENT ---- CFN FOR FILE INPUT ANO OUTPUT; + + PROCEDURE CFN; + BEGIN LABEL L,M; + CHA:=NWC;IF LOOK(4)="FILE" THEN BEGIN CP:=LP;D:=IF A=15 THEN 5 ELSE A; + FOR C:=1 STEP 1 UNTIL NF DO BEGIN CHA:=NWC;B:=LOOK(FNM[2,C]); + IF B=FNM[1,C] THEN BEGIN IF FNM[3,C]=0 THEN FNM[3,C]:=D ELSE IF D NEQ + FNM[3,C] THEN SYNT("IN+OUT?");CP:=LP;PUT(A);IF D=5 THEN + INFILTOG:=TRUE;IF A=7 THEN OUTFILTOG:=TRUE; + IF NWC=":" THEN BEGIN A:=NUMB;FOR B:=ACS STEP 1 UNTIL MS DO + IF A=SSEQ[B] THEN BEGIN PUT(B.[11:6]);PUT(B.[5:6]);GO ON(58) L ELSE M + END;SYNT("UNDF GO") END;PUT(0);PUT(0);ON(58) GO L; + GO TO M END ELSE BEGIN CP:=CP-1;CHA:=0 END END;SYNT("UNDC FL") END; + PUT(0);ON("%") GO TO M;CP:=CP-1;CHA:=0;GO TO L; + M: IF A=5 THEN SYNT("NOINPUT");PUT(0);GO TO INCST; + L: END; + +COMMENT------------------------------------------------------- +----------- XBASIC STARTS HERE ----------------- +-------------------------------------------------------------; + + FIRSTOFF:=IU NEQ 2;IF IU=2 THEN TTY.TYPE:=1; + PIBE:=POINTER(IOBE[1])+7; PINB:=POINTER(IOB[1]); + DELIM:=72;TIM:=10800;LL:=-1; + OBJECT:=HDDR:=FALSE;OU:=0; + + FILL KEY[*] WITH "LET","GOT","GOS","RET","INP", + "REA","PRI","FOR","NFX","MAT","DEF","DAT", + "RAN","PAG","RES","REM","STO","END","IF ","ON ","SIN","COS", + "TAN","ATN","EXP","LOG","ABS","INT","SQR","FIX","SGN","RND", + "EQ","LT","LE","GT","GE","NE"; + + COMMENT------------------------------------------------------ +------------SOURCEIN: FOR INPUT OF SOURCE PROGRAM ------- +------------ AND EXECUTION OF COMMANDS ------- +-----------------------------------------------------------------; + + COMMENT: COMMANDS ALLOWED IN XBASIC + + HELLO SAME AS BYE + BYE TERMINATES XBASIC. PRINTER OUTPUT IS SCHEDULED + RUN EXECUTES PROGRAM IF FREE OF SYNTAX ERRORS + SCR DELETES WORKFILE + DELETE SAME AS SCR + LIST LISTS ENTIRE WORKFILE + LIST E WHERE E IS A NUMBER OF ELEMENTS OF FORM + N OR M-N (M,N STATEMENT NUMBERS) + SEPARATED BY COMMAS. LISTS PART OF PROGRAM + MAKE NNNNNN INITIALISES AND NAMES WORKFILE + SAVE SAVES WORKFILE IF NAMED + SAVE NNNNNN SAVES WORKFILE IN NNNNNN. NAMES WORKFILE + IF NOT ALREADY NAMED + LOAD NNNNNN LOADS WORKFILE AND NAMES IT + LOAD NNNNNN/UUUUUUU COPIES WORKFILE FROM NNNNNN/UUUUUUU + WORKFILE BECOMES UNNAMED + COPY NNNNNN COPIES NNNNNN INTO WORKFILE + COPY NNNNNN/UUUUUUU SAME FOR NNNNNN/UUUUUUU + REMOVE NNNNNN REMOVES FILE NNNNNN/USER NO. + RENAME NNNNNN RENAMES WORKFILE + PLOP RESETS WORKFILE TO LAST RUN STATUS + WHATS OBTAINS WORKFILE STATUS + TTY INPUT UNIT IS TTY + VDU INPUT UNIT IS VDU + SEND DIVERTS OUTPUT TO PRINTER + NOSEND TERMINATES DIVERSION OF OUTPUT + TIME N RESETS MAX EXECUTION TIME TO N MINUTES +-------------------------------------------------------------; + + SOURCEIN: BEGIN LABEL SOURCEIN,EF,COPY,NEWL,SOURCE,RMOB, + FST; + + INTOVR:=INER; + IF FIRSTOFF THEN BEGIN FILECONTROL(5,"XBWKFL ",TIME(-1),FST); + FST: IF IU=0 THEN WRITE(TTY,INVIT);FIRSTOFF:=FALSE END; + IF LL=-1 THEN GO TO SOURCE; + SOURCEIN: IF IU GTR 0 THEN GO TO SOURCE;PINB:=PINB+80; + LL:=LL+1;IF LL LSS 24 THEN GO TO NEWL; + SOURCE: LL:=0;IF IU GTR 0 THEN READ(FN[IU-1][STOP],10,IOB[*]) + ELSE READ(VDU[STOP],240,IOB[*]); + IF IU=2 THEN WRITE(TTY,10,IOB[*]); + PINB:=POINTER(IOB[*]);IOBE[1]:=0; + NEWL: C:=IF MS>0 THEN SSEQ[MS] ELSE 0;APR:=PINB;BPR:=PIBE; + A:=NMBR(6);IF A=0 THEN BEGIN IF CHA="%" THEN GO TO SOURCEIN; + COMMENT NONVOID INPUT WITH ZERO STATEMENT NO. MUST BE COMMAND; + IOBE[1]:=0;REPLACE BPR-5 BY APR:CPR:=APR-1 FOR 1; + REPLACE BPR-4 BY APR:APR FOR 5 WHILE IN ALPHA;CHA:=IOBE[1]; + ON("RUN000") BEGIN IF OBJECT THEN BEGIN IF NMBR(72) NEQ 0 OR + CHA NEQ "%" THEN GO PER;GO EXECUTE END + ELSE IF IU=2 THEN GO COMPILE + ELSE BEGIN WRITE(TTY,WT); + FILECONTROL(4,"XBWKFL ",TIME(-1),COMPILE) END END; + ON("DELETE" OR CHA="SCR000") BEGIN C:=NMBR(72); + IF C NEQ 0 OR CHA NEQ "%" THEN GO PER;WRITE(TTY,F7); + CS:=MS:=IO[0]:=0;DANGER:=OBJECT:=FALSE;GO SOURCEIN END; + ON("LIST00") BEGIN + + COMMENT PROCESS LIST COMMAND; + + LABEL NEX,LEX; + IF OU=1 THEN WRITE(TTY,DVO); + WRITE(FL[OU],SPC); + NEX: BEG:=NMBR(72);IF CHCONV(CHA) NEQ 0 THEN GO PER; + EN:=ON("%" AND BEG=0) 1000000 ELSE ON(44) NMBR(72) ELSE BEG; + IF CHCONV(CHA) NEQ 0 THEN GO PER; + FOR A:=1 STEP 1 UNTIL MS DO IF SSEQ[A] LEQ EN + AND SSEQ[A] GEQ BEG THEN BEGIN + REPLACE POINTER(IOBE[1]) BY " " FOR 112; + WRITE(IOBE[*],NUM[2|OU],SSEQ[A]); + SCAN CPR:POINTER(IOBE[1])+20|OU FOR 20 WHILE NEQ 48; + REPLACE CPR BY POINTER(PROG[A,2]) FOR 72;WRITE(FL[OU],14,IOBE[*]) + END;ON(58) GO TO NEX;WRITE(TTY,STP,"LIST ");GO TO SOURCEIN END; + ON("RENAME") FILECONTROL(0," NAMED"," ",SOURCEIN); + ON("MAKE00") FILECONTROL(0,"CREATE","D",SOURCEIN); + ON("SAVE00") FILECONTROL(1," SAVED"," ",SOURCEIN); + + ON("LOAD00") FILECONTROL(2," LOADE","D",SOURCEIN); + ON("REMOVE") FILECONTROL(3,"REMOVE","D",SOURCEIN); + ON("COPY00") FILECONTROL(2," COPIE",0,SOURCEIN); + ON("BYE000" OR CHA="HELL00") BEGIN IF IU=2 THEN GO FINSH; + FILECONTROL(6,"XBWKFL ",TIME(-1),FINSH) END; + ON("SEND00") BEGIN OU:=1;IF NOT HDDR THEN BEGIN + WRITE(LIN,HD3,TIME(6),TIME(5).[23:12],TIME(5).[35:12],TIME(5).[11:12], + TIME(-1).[41:18],TIME(-1).[23:24]); + HDDR:=TRUE END;WRITE(TTY,HD1);GO SOURCEIN END; + ON("NOSEND") BEGIN OU:=0;WRITE(TTY,STP,"NOSEND");GO TO SOURCEIN END; + ON("TTY000") BEGIN IU:=1;WRITE(TTY,STP,"SETTTY");GO TO SOURCE END; + ON("VDU000") BEGIN IU:=0;WRITE(TTY,STP,"SETVDU");GO TO SOURCEIN END; + ON("TIME00") BEGIN TIM:=3600|NMBR(10);WRITE(TTY,STP,"SETTIM"); + GO TO SOURCEIN END; + ON("PLOP00") FILECONTROL(5,0,0,SOURCEIN); + ON("WHATSO") BEGIN WRITE(TTY,F9);IF IO[0]=0 THEN + WRITE(TTY,F10,MS,SSEQ[MS]) ELSE + WRITE(TTY,F11,IO[0].[41:36],MS,SSEQ[MS]); + GO SOURCEIN END; + % ILLEGAL COMMAND + WRITE(TTY,WHT," "&CHA[35:35:6|DELTA(CPR,APR)]);GO SOURCEIN END; + + COMMENT PROCESS SOURCE STATEMENT; + + OBJECT:=FALSE;DANGER:=TRUE; + + COMMENT DELETE STATEMENT; + + ON("%") BEGIN CHA:=A;FOR A:=1 STEP 1 UNTIL MS DO + ON(SSEQ[A]) BEGIN MS:=MS-1;FOR B:=A STEP 1 UNTIL MS DO + BEGIN SSEQ[B]:=SSEQ[B+1];WRITE(PROG[B,*],10,PROG[B+1,*]) END END; + GO TO SOURCEIN END; + CHA:=A;APR:=APR-1; + COMMENT ADD NEW LAST STATEMENT; + + IF CHA GTR C THEN BEGIN CS:=MS;MS:=A:=MS+1; + IF MS GTR 200 THEN GO TOOLONG; + GO TO COPY END; + + COMMENT REPLACE EARLIER STATEMENT; + FOR A:=1 STEP 1 UNTIL MS DO ON(SSEQ[A]) GO TO COPY + ELSE IF CHA LSS SSEQ[A] THEN BEGIN MS:=MS+1; + + COMMENT INSERT STATEMENT; + + IF MS GTR 200 THEN GO TO TOOLONG; + FOR B:=MS STEP -1 UNTIL A+1 DO + BEGIN SSEQ[B]:=SSEQ[B-1];WRITE(PROG[B,*],10,PROG[B-1,*]) END; + GO TO COPY END; + COPY: PROG[A,11]:=SSEQ[A]:=CHA; + REPLACE BPR:CPR:=POINTER(PROG[A,2]) BY " " FOR 1; + B:=DELTA(APR,PINB+80);IF B>71 THEN B:=71; + REPLACE BPR:BPR BY APR FOR B WHILE NEQ "!"; + REPLACE BPR BY " " FOR 72-DELTA(CPR,BPR);GO SOURCEIN END SOURCEIN; + INER: WRITE(TTY,INTR);GO TO SOURCEIN; + TOOLONG: WRITE(TTY,LNGPRG,SSEQ[CS]);GO TO SOURCEIN; + PER: WRITE(TTY,F12);GO SOURCEIN; + COMMENT---------------------------------------------------------- +-------------------- END SOURCEIN --------------------------- +------------------------------------------------------------------ +----------- COMPILE: SEARCH FOR SYNTAX ERRORS --------- +----------- AND MAKE PSEUDO-OBJECT CODE --------- +--------------------------------------------------------------------; + COMMENT + SYNTAX ERROR MESSAGES: OUTPUT AFTER "RUN" + WITH NEW FAULTY PROGRAM + + ARITH MISSING OPERATOR OR OPERAND IN ARITHMETIC + EXPRESSION (SHOULD NOT OCCUR) + FILES PROGRAM CAN HAVE ONLY ONE INPUT AND ONE OUTPUT + FILE + IL GOSB THIS STATEMENT HAS BEEN ILLEGALLY REFERENCED + BY A GOSUB STATEMENT (IT IS IN A FOR LOOP) + IL RELN AN ILLEGAL RELATION OF FORM X?? HAS BEEN + FOUND IN AN IF STATEMENT + ILL ARR ARRAY NAME EXPECTED BUT CHARACTER IS NOT + A LETTER + ILL ASN AN ASSIGNMENT IS ATTEMPTED BUT LEFT HAND SIDE + IS NOT A VARIABLE + ILL FN THE NAME OF A DEFINED FUNCTION MUST BE OF FORM + FN LETTER. PARAMETER(S) MUST BE SUPPLIED. + ILL FOR A FOR STATENENT IS ALREADY IN OPERATION + FOR THIS VARIABLE + ILL NEX NEXT MUST REFER TO AN UNSUBSCRIPTED REAL VBLE + ILL NUM A PRIMARY IS MISSING OR ILLEGAL + ILL STR A STRING PRIMARY HAS BEEN ENCOUNTERED IN + A REAL EXPRESSION + IL STMT ILLEGAL STATEMENT + INV IF STRINGS CAN ONLY BE COMPARED FOR EQUALITY + OR INEQUALITY + INV PAR A FORMAL PARAMETER IN A DEF STATEMENT + MUST BE A VARIABLE + INV VAR A PRIMARY IS MISSING OR ILLEGAL. IN A READ + STATEMENT EVERY EXPRESSION MUST CONSIST OF + A SINGLE VARIABLE PRIMARY. + IN+OUT? A FILE IS BEING USED FOR INPUT AND OUTPUT + LONGSTR A STRING CONTAINS MORE THAN 14 CHARACTERS + IN A STATEMENT OTHER THAN PRINT. + MISG OP AN OPERAND ESSENTIAL TO THIS STATEMENT HAS + BEEN OMITTED (END OF STATEMENT ERROR). + MISP = MISPLACED OR MISSING = IN DEF STATEMENT + MISPL - A - SIGN HAS BEEN PLACED ILLEGALLY IN AN + EXPRESSION (E.G. A*-B). + NAME PROBABLY CAUSED BY ILLEGAL FILENAME + NESTING INCORRECTLY NESTED FOR AND NEXT STATEMENTS + NO ) X MISSING PARENTHESES: X=A IN ARITH EXPRESSION + NO ( X P IN FUNCTION PARAMETER + S IN SUBSCRIPT + F IN FILE DECLARATION + NO EXPN E HAS BEEN FOUND IN A NUMBER BUT NO EXPONENT + FOLLOWS + NO FOR A NEXT STATEMENT HAS NO CORRESPONDING FOR + NOINPUT INPUT STATEMENT MUST HAVE LIST OF VARIABLES + NO NEXT A FOR STATEMENT EARLIER IN PROGRAM HAS NO NEXT + NO PARM EVERY FUNCTION MUST HAVE PARAMETER(S) IN + BRACKETS + NO PROG THERE IS NO PROGRAM TO RUN + NO RELN NO RELATION HAS BEEN FOUND IN AN IF STATEMENT + NO SEPR CONSECUTIVE ARITH EXPRESSIONS IN PRINT + STATEMENT MUST BE SEPARATED BY , OR SEMICOLON + NO TO A FOR STATEMENT MUST HAVE A FINAL VALUE + (FOR X=1 TO 10 ETC.) + NOT END THE LAST STATEMENT MUST BE AN END STATEMENT + NOTLAST THE END STATEMENT MUST BE THE LAST STATEMENT + OVERFLW A NUMBER IS TOO LARGE + QUOTES MISMATCHED STRING QUOTES + REDC AR ARRAY TWICE DIMENSIONED + REDC FN A FUNCTION HAS BEEN DEFINED MORE THAN ONCE + SAMEFIL A FILE HAS BEEN DECLARED MORE THAN ONCE + PARAMTR WRONG NUMBER OF PARAMETERS IN A FUNCTION CALL + SIMPLFY AN EXPRESSION IS NESTED TO A DEPTH OF 10 OR + MORE AND SHOULD RE BROKEN UP + SIZE AN ARRAY DIMENSION IS GREATER THAN 64 OR + (IN MAT STATEMENT) IS GREATER THAN THE DECLARED + DIMENSION OF THE ARRAY + STORAGE ARRAY STORAGE HAS BEEN EXCEEDED (700 WORDS OF + TYPE REAL, 70 OF TYPE ALPHA) + STR >63 ILLEGAL OBJECT CHARACTER (E.G. PRINT STRING + HAS >63 CHARS OR STARTS LATER THAN COL 63) + STR=STR A STRING CAN ONLY BE COMPARED WITH ANOTHER + SUBSCPT AN ARRAY REFERENCE HAS THE WRONG NUMBER OF + SUBSCRIPTS + TOO MCH PROCESSING OF THE SOURCE STATEMENT HAS NOT + USED UP ALL THE INFORMATION IN IT. (CAN BE + CAUSED BY OMISSION OF AN OPERATOR IN AN + EXPRESSION) + TYPE AN ATTEMPT HAS BEEN MADE TO USE A MAT STATEMENT + FOR A 1-DIMENSIONAL ARRAY + UNDC AR AN ARRAY HAS BEEN REFERENCED BUT NOT DECLARED + UNDC FL A FILE HAS BEEN REFERENCED BUT NOT DECLARED + UNDC FN A FUNCTION OF TYPE FN* HAS BEEN REFERENCED BUT + NOT DECLARED + UNDF GO THERE IS NO STATEMENT IN THE PROGRAM WITH THE + SEQUENCE NUMBER REFERENCED BY THIS STATEMENT + UNDSTAR A STRING ARRAY HAS BEEN REFERENCED BUT NOT + DECLARED + UNRC FN A FUNCTION NAME OR KEYWORD HAS BEEN MISSPELLED + OR MISPLACED + 3 FILES NOT MORE THAN TWO FILES MAY BE DECLARED + 11 FORS FOR STATEMENTS NESTED TOO DEEP + :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::; + + COMPILE: + + COMMENT IN THE FOLLOWING COMMENTS, + IS ANY EXPRESSION (POSSIBLY WITH =) + IS ANY LETTER + IS ANY VARIABLE PRIMARY + IS ANY UNSIGNED INTEGER + IS A STATEMENT NUMBER + IS A FILENAME + + ALLOWED VARIANTS ARE LISTED BELOW. THREE LETTER + ABBREVIATIONS OF INITIAL KEYWORDS ARE ALLOWED WHERE UNAMBIGUOUS. + SPACES ARE IGNORED EXCEPT INSIDE STRING QUOTES; + + INTOVR:=INTVR;INDEX:=QUOTE;FLAG:=FLAGR; + MSTO:=287;MSTR:=27;INFILTOG:=OUTFILTOG:=FALSE; + FOR A:=1 STEP 1 UNTIL 26 DO STRAR[A,1]:=ARR[A,1]:=ARR[A,2]:=SUB[A]:=0; + IO[1]:=IO[2]:=FNM[2,1]:=FNM[2,2]:=FNM[3,1]:=FNM[3,2]:=AREASIZE:=0; + NDEP:=CO:=1;POB:=POINTER(OBJ[*]); + CS:=0;SY:=EQOK:=TRUE; + IF MS =0 THEN SYNT("NO PROG"); + FORE:=FORC:=NCON:=0;FOR A:=1 STEP 1 UNTIL 200 DO STYP[A]:=0; + + COMMENT FILES + FILES ,.. + WHERE IS (EXISTING FILE) + OR () (FILE TO BE CREATED: N=MAX NO OF RECS) + WHERE IS A CANDE FILENAME + THERE CAN ONLY BE ONE FILES STATEMENT. IT MUST BE THE FIRST STATEMENT. + THERE CAN BE AT MOST ONE INPUT FILE AND ONE OUTPUT FILE; + + FIL: ACS:=CS:=CS+1;CP:=CHA:=0;CHA:=NWC;B:=LOOK(3); + IF B="REM" THEN GO FIL;IF B="FIL" THEN BEGIN CP:=LP;SKIP(2,"ES");A:=0; + RFIL: A:=A+1;IF A>3 THEN SYNT("3 FILES"); + CHA:=NWC;IO[A]:=" ";BPR:=POINTER(PROG[CS,2])+CP-1; + SCAN APR:BPR FOR 6 WHILE IN ALPHA;FNM[2,A]:=B:=DELTA(BPR,APR); + REPLACE POINTER(IO[A])+1 BY BPR FOR B;FNM[1,A]:=LOOK(B);CP:=LP; + NF:=A;CHA:=NWC;ON("(") BEGIN AREASIZE:=NUMB/20+1;FNM[3,A]:=7; + IF CHA NEQ ")" THEN SYNT("NO ) ,F");CHA:=NWC END;ON(",") GO TO RFIL; + IF A=2 AND IO[1]=IO[2] THEN SYNT("SAMEFIL");IF CHA NEQ "%" THEN + SYNT("TOO MCH") END ELSE CS:=0; + IF ACS>MS THEN SYNT("NO PROG"); + COMMENT DIM + DIM (),... + DIMENSION (),... + WHERE IS OR $ + IS OR , + DIM STATEMENTS MUST PRECEDE ALL EXECUTABLE STATEMENTS + STRING ARRAY MUST BE ONE-DIMENSIONAL. + ALL DIMENSIONS MUST BE <64. + 713 WORDS REAL AND 73 STRINGS ARE AVAILABLE FOR ARRAYS ; + + DIM: ACS:=CS:=CS+1;CP:=CHA:=0;CHA:=NWC; + B:=LOOK(3);IF B="REM" THEN GO DIM; + IF B="DIM" THEN BEGIN CP:=LP;SKIP(6,"ENSION"); + RDIM: K:=CHCONV(NWC);IF K=0 THEN SYNT("ILL ARR"); + IF NWC="$" THEN BEGIN STRAR[K,0]:=MSTR;IF NWC NEQ "(" THEN + SYNT("NO ( ,S");A:=STRAR[K,1]:=NUMB;MSTR:=MSTR+A; + IF CHA NEQ ")" THEN SYNT("NO ) ,S");IF NWC="," THEN GO TO RDIM; + GO TO DIM END; ARR[K,0]:=MSTO;IF CHA NEQ "(" THEN SYNT("NO ( ,S"); + IF ARR[K,1] NEQ 0 THEN SYNT("REDC AR"); + B:=ARR[K,1]:=NUMB;IF B>64 THEN SYNT(" SIZE "); + ON(",") BEGIN A:=ARR[K,2]:=NUMB;B:=B|A END; + MSTO:=MSTO+B;IF MSTO GTR 1000 THEN SYNT("STORAGE"); + IF CHA NEQ ")" THEN SYNT("NO ) ,S");IF NWC="," THEN GO TO RDIM; + GO TO DIM END;IF ACS>MS THEN SYNT("NO PROG"); + + COMMENT PROGRAM COMPILATION BEGINS HERE ; + + FOR CS:=ACS STEP 1 UNTIL MS DO BEGIN + COMMENT IF GOSUB ENTRY THEN FIX FOR LEVEL ; + EXS: IF STYP[CS] NEQ 0 THEN BEGIN IF FORC NEQ FORE THEN + SYNT("IL GOSB");FORE:=FORC:=STYP[CS] END; + COMMENT IDENTITY STATEMENT TYPE ; + NDEP:=CP:=CHA:=0;CHA:=NWC;B:=LOOK(3);EQOK:=TRUE; + FOR A:=1 STEP 1 UNTIL 18 DO IF B=KEY[A] THEN GO TO EQL; + IF B="DIM" OR B="FIL" THEN BEGIN WRITE(TTY,F6,SSEQ[CS]); + GO SOURCEIN END; +%IF B="TRA" THEN BEGIN STYP[CS]:=20;GO REM END; +%IF B="UNT" THEN BEGIN STYP[CS]:=21;GO REM END; + B:=B DIV 64; + IF B="IF" THEN BEGIN LP:=LP-1;A:=19;GO TO EQL END; + IF B="ON" THEN BEGIN LP:=LP-1;A:=20;GO TO EQL END; + LP:=0;A:=1; + EQL: CP:=LP;STYP[CS]:=A;SPOB[CS]:=CO; + IF CS=MS AND A NEQ 18 THEN SYNT("NOT END");GO TO OPN[A]; + COMMENT 1 LET + LET + + WHERE E MAY BE A STRING ASSIGNMENT ; + + LET: ARITH(0);GO TO INCST; + CAR: ARITH(1); GO TO INCST; + COMMENT 20 ON + ON GO TO ,... ; + + ONX: ARITH(1);SKIP(3,"OTO"); + RON: A:=NUMB;FOR B:=ACS STEP 1 UNTIL MS DO IF A=SSEQ[B] + THEN BEGIN PUT(B.[11:6]);PUT(B.[5:6]); + IF STYP[CS]=3 AND STYP[B] IF THEN + IF GO TO + IS AN EXPRESSION WITHOUT = + IS ONE OF THE FOLLOWING + |EQ |GT |LT |GE |LE |NE + = > < >= <= <> + STRINGS CAN BE COMPARED ONLY FOR EQUALITY OR INEQUALITY; + + IFF: EQOK:=FALSE;ARITH(0);EQOK:=TRUE; + C:=IF STRIN THEN 0 ELSE 1; + B:=0;IF CHA=30 THEN BEGIN B:=B+2;CHA:=NWC END; + IF CHA=14 THEN BEGIN B:=B+4;CHA:=NWC END;IF CHA=61 THEN B:=B+1 + ELSE CP:=CP-1;IF B=0 THEN CHA:=NWC ELSE GO TO FEQ; + IF CHA NEQ "|" THEN SYNT("NO RELN");CHA:=NWC; + A:=CHA|64+NWC;FOR B:=1 STEP 1 UNTIL 6 DO IF A=KEY[B+32] + THEN GO TO FEQ;SYNT("IL RELN"); + FEQ: PUT(B);ARITH(C);IF C=0 AND NOT STRIN THEN SYNT("STR=STR"); + IF STRIN AND B NEQ 1 AND B NEQ 6 THEN SYNT("INV IF "); + SKIP(3,"OTO");SKIP(3,"HEN");GO TO RON; + COMMENT 2 GO TO + GO TO ; + + GOT: SKIP(1,"0");GO TO RON; + COMMENT 3 GOSUB + GOSUB ; + + GOS: SKIP(2,"UB");GO TO RON; + COMMENT 4 RETURN + RETURN ; + + RET: SKIP(3,"URN");CHA:=NWC;GO TO INCST; + COMMENT 8 FOR + FOR TO STEP + FOR TO ; + + COMMENT DURING COMPILE, FOR INFO IS STORED IN FORX AS FOLLOWS: + 2 3 4 + OBJPOINTER TO STORE NEXTLINE FORLINE ADDR + + EACH FOR IS ASSIGNED A LEVEL (=FORC), WHICH 1S USED TO CHECK + NESTING AND DURING EXECUTION. IN SUBROUTINES FORC IS INITIALISED + TO MAX FORC OF CALLING (GOSUB) STATEMENT: THIS LEVEL 1S STORED + TEMPORARILY IN STYP. OBJECT FORM OF FOR STATEMENT IS AS FOLLOWS: + LEVEL ASSIGN FINAL INCREMENT NEXTLINE ; + + FOX: FORC:=FORC+1;PUT(FORC);IF FORC>10 THEN SYNT("11 FORS"); + ARITH(1);FORX[FORC,4]:=ADDR+1;IF CHA NEQ "T" THEN SYNT(" NO TO"); + SKIP(1,"0");FOR A:=1 STEP 1 UNTIL FORC-1 DO IF FORX[A,4]=ADDR THEN + SYNT("ILL FOR");ARITH(1);IF CHA="S" THEN BEGIN SKIP(3,"TEP");ARITH(1) + END ELSE PUT(0);FORX[FORC,2]:=CO;PUT(0);PUT(0);FORX[FORC,3]:=CS; + GO INCST; + COMMENT 9 NEXT + NEXT + WHERE IS A VARIABLE NAME ; + + NEX: SKIP(1,"T");B:=CHCONV(NWC)-1;IF B=-1 THEN SYNT("ILL NEX"); + IF NWC LSS 10 THEN BEGIN B:=11|B+CHA+1;CHA:=NWC END ELSE B:=11|B; + IF FORC=FORE THEN SYNT("NO FOR "); + IF B+1 NEQ FORX[FORC,4] THEN SYNT("NESTING"); + A:=CO;CO:=FORX[FORC,2];PUT(CS.[11:6]);PUT(CS.[5:6]); + CO:=A;SPOB[CS]:=FORC+16|FORX[FORC,3];FORX[FORC,4]:=0;FORC:=FORC-1; + GO INCST; + COMMENT 11 DEF + DEF FN(....)= + FORMAL PARAMETERS MUST BE SINGLE LETTERS ; + + DEF: SKIP(3,"INE");SKIP(2,"FN");K:=CHCONV(NWC); + IF K=0 OR NWC NEQ 29 THEN SYNT(" ILL FN");A:=0;PUT(K); + IF SUB[K] NEQ 0 THEN SYNT("REDC FN"); + RDUM: A:=A+1;B:=11|CHCONV(NWC)-11;IF B=-11 THEN SYNT("INV PAR"); + CONST[NCON+A]:=B;IF NWC=58 THEN GO RDUM;IF CHA NEQ 45 THEN SYNT + (" NO ) P");SUB[K]:=A;FOR B:=A STEP -1 UNTIL 1 DO BEGIN + PUT((C:=CONST[NCON+B]).[11:6]);PUT(C.[5:6]) END; + IF NWC NEQ "=" THEN SYNT("MISP = ");ARITH(1);SUB[K]:=A;GO TO INCST; + COMMENT 6 READ + READ ,... ; + + REA: SKIP(1,"D"); + RREA: ARITH(0);IF NOT VAR THEN SYNT("INV VAR"); + ON(58) GO TO RREA;PUT(0);GO TO INCST; + COMMENT 5 INPUT + INPUT ,... + INPUT FILE ,,... + WHERE IS THE FILENAME; + INP: SKIP(2,"UT");CFN;GO TO RREA; + COMMENT 13 RANDOMISE + RANDOMISE + RANDOMIZE ; + RAN: SKIP(6,"DOMISE");SKIP(6,"DOMIZE");CHA:=NWC;GO TO INCST; + COMMENT 15 RESTORE + RESTORE + RESTORE FILE + WHERE IS THE INPUT FILE ; + RES: SKIP(4,"TORE");CFN; GO TO INCST; + COMMENT 7 PRINT + PRINT

+ PRINT FILE ,,... + WHERE IS A FILENAME + WHERE

IS A NUMBER OF ELEMENTS OF FORM + "" 4 + , 2 OR 6, 1 + ; COMMENT 2 OR 6 + , 1 (1,5 IF TRAILS) + ; COMMENT 5 IF TRAILS + TAB() 3 + WHERE IS ANY STRING + WHERE IS "" OR ; + PRI: SKIP(2,"NT");CFN;CHA:=NWC;AA:=FALSE; + RPRI: ON("%") BEGIN PUT(0);GO TO INCST END; + ON(58) BEGIN PUT(1);AA:=FALSE; + IF NWC="%" THEN BEGIN PUT(5); GO TO INCST END + ELSE GO TO RPRI END; + ON(";" OR CHA=":") BEGIN AA:=FALSE;IF NWC="%" THEN BEGIN PUT(5); + GO INCST END;GO TO RPRI END; + ON(63) BEGIN AA:=FALSE;PUT(4);PUT(CP);CPR:=POINTER(PROG[CS,2])+CP; + SCAN APR:CPR UNTIL=63;B:=DELTA(CPR,APR);PUT(B); + CP:=CP+B+1;CHA:=NWC;GO TO RPRI END; + IF LOOK(4)="TAB(" THEN BEGIN AA:=FALSE;PUT(3);CP:=LP;ARITH(1); + IF CHA NEQ 45 THEN SYNT("NO ) P");CHA:=NWC;GO TO RPRI END; + CP:=CP-1;IF AA THEN SYNT("NO SEPR");AA:=TRUE; + B:=CO;PUT(2);ARITH(0);IF STRIN THEN + REPLACE POB+B BY "6" FOR 1;GO TO RPRI; + COMMENT 14 PAGE + PAGE ; + PAG: SKIP(1,"E");CHA:=NWC;GO TO INCST; + COMMENT 10 MAT + MAT READ 1 + MAT READ (,) 1 + MAT PRINT 2 + MAT PRINT (,) 2 + MAT LET =()* 4 + MAT =()* 4 + MAT LET = 3 + MAT = 3 + WHERE IS AS DESCRIBED IN EXECUTE(PROCEDURE MATOP) ; + MAT: CHA:=NWC;A:=LOOK(4);IF A="READ" THEN BEGIN PUT(1);CP:=LP; + GO TO IOMT END;IF A="PRIN" THEN BEGIN PUT(2);CP:=LP;SKIP(1,"T"); + GO TO IOMT END;CP:=CP-1;SKIP(3,"LET");A:=CP;B:=CHMAT(NWC);CHA:=NWC; + IF NWC=29 THEN BEGIN PUT(4);PUT(B);ARITH(1);CHA:=NWC;PUT(CHMAT(NWC)); + END ELSE BEGIN PUT(3);PUT(A) END;GO TO REM; + IOMT: K:=CHMAT(NWC);PUT(K);IF NWC=29 THEN BEGIN + FOR B:=1,2 DO BEGIN A:=NUMB;IF A LSS 0 OR A GTR ARR[K,B] THEN + SYNT(" SIZE");PUT(A) END;CHA:=NWC; + END ELSE BEGIN PUT(ARR[K,1]);PUT(ARR[K,2]) END; + PUT(ON(";") 1 ELSE 0);ON(";") CHA:=NWC;GO TO INCST; + COMMENT 12 DATA + DATA ,... ; + DAT: SKIP(1,"A"); + RDAT: ARITH(0);ON(58) GO TO RDAT;PUT(0);GO INCST; + COMMENT 17 STOP + STOP + 18 END + END ; + ENX: IF CS NEQ MS AND A=18 THEN SYNT("NOTLAST");CHA:=NWC; + IF A=17 THEN CHA:=NWC; + INCST: IF CHA NEQ "%" THEN SYNT("TOO MCH"); + COMMENT 16 REM + REM + WHERE IS ANYTHING ; + REM:ERR: END; + + % SORT OUT FILES IF 2 TO BE USED + CS:=MS;IF NF=2 AND FNM[3,1]=FNM[3,2] THEN SYNT(" FILES "); + IF FNM[3,1]=7 THEN BEGIN IO[3]:=IO[1];IO[1]:=IO[2]; + IO[2]:=IO[3] END; + IF NOT SY THEN BEGIN WRITE(TTY,STP,"ERRORS");GO TO SOURCEIN END; + OBJECT:=TRUE;GO TO EXECUTE; + + INTVR: SYNT("OVERFLW"); QUOTE: SYNT(" QUOTES"); + FLAGR: SYNT("NAME "); + + + COMMENT---------------------------------------------------------------- +-------------- END COMPILE ------------------------ +------------------------------------------------------------------------ +-------------- EXECUTE: EXECUTION OF -------------------- +-------------- USERS PROGRAM -------------------- +-----------------------------------------------------------------------; + EXECUTE: BEGIN + + FILE IN FIL1 DISK " "(2,10,300); + FILE OUT FIL2 DISK[20:AREASIZE] " "(2,10,300,SAVE 7); + + INTEGER ARRAY SVE[1:10], % HOLDS GOSUB CALLS + FUNC[1:26], % DEFINES + STRGS[-1:100,0:2], % STRINGS + IOB[1:14], % I/O PSEUDOBUFFER + IOF[1:10], % " + ADR[0:20]; % ADDRESS STCK FOR EVAL + + ARRAY STORE[0:1000], % HOLDS VARIABLE VALUES ETC + STK[0:20]; % VALUE STACK FOR EVAL + + INTEGER XRND, % PSEUDO-RANDOM NUMBER INDEX + CO, % CURRENT POSITION IN OBJ[*] + RDAT, % DATA STATEMENT + NGOT, % GO COUNTER + SLVE, % GOSUB COUNTER + RDTP, % POSITION IN DATA STATEMENT + MSTO, % TOP OF STORE[*] + MSTR, % TOP OF STRGS[*, ] + IR, % INPUT FILE SEQUENCE NO + NR, % OUTPUT FILE COUNTER + RT, % RUN TERMINATION TIME + MF, % FILE (0=TTY,OTHERWISE DISK) + STCK, % STACK POINTER FOR EVAL + A,B,C,D,I,J,K,L,U,V,W,X,Y,Z,AS; + + REAL R,S,T; % HASH + + POINTER PIOB, % CURRENT POSITION IN IOB[*] + POUB, % INITIAL + PBR,IPR; + + LABEL INCST; + + % TRACE PACKAGE +%FORMAT T1(I6,X2,A3,X5,"VALUE ASSIGNED= "U),T2(I6,X2,A3,X5," TO STMT " +% ,I6),T3(I6,X2,A3); + BOOLEAN TRACEON,TLIN;%POINTER ITR; +%PROCEDURE DSTR(A);VALUE A;INTEGER A; +%BEGIN WRITE(IOF[*],T3,SSEQ[CS],IF TLIN THEN KEY[STYP[CS]] ELSE " "); +%REPLACE ITR:POINTER(IOF[*])+14 BY "STRING ASSIGNED=";REPLACE ITR:ITR +%BY """ FOR 1;REPLACE ITR:ITR BY POINTER(STRGS[A,1]) FOR STRGS[A,0]; +%REPLACE ITR BY """ FOR 1;WRITE(FL[OU],9,IOF[*]);TLIN:=FALSE END; + DEFINE TR0(TR01,TR02)=#,%IF TR01 THEN BEGIN WRITE(FL[OU],TR02,SSEQ[CS], + % IF TLIN THEN KEY[STYP[CS]] ELSE " "#, + TR1(TR11)=#, %=TR0(TRACEON,T1),TR11);TLIN:=FALSE END#, + TR2(TR21)=#, %=TR0(TRACEON,T2),SSEQ[TR21]);TLIN:=FALSE END#, + TR3 =#, %=TR0(TLIN,T3));TLIN:=FALSE END#, + TR4(TR41)=#; %=IF TRACEON THEN DSTR(TR41)#; + + % PROCEDURES FOR EXECUTE: + + COMMENT + --- GET GETS NEXT CHARACTER FROM OBJ ; + + DEFINE GET=0&OBJ[CO.[46:44]][5:47-CO.[2:3]|6:6];CO:=CO+1; + IF CO.[2:3]=0 THEN CO:=CO+1#; + COMMENT + --- ERROR DEALS WITH EXECUTION TIME ERRORS; + + PROCEDURE ERROR(A);VALUE A;INTEGER A; + BEGIN SWITCH FORMAT ERR:=("ERR0",I6), % SHOULD NOT OCCUR.. %0 + ("SUBSCRIPT OUT OF BOUNDS AT LINE ",I6), %1 + ("LOG OF NEGATIVE OR ZERO NUMBER AT LINE ",I6), %2 + ("SQR OF NEGATIVE NUMBER AT LINE ",I6), %3 + ("UNDEFINED FUNCTION AT LINE ",I6), %4 + ("INPUT STATEMENT ATTEMPTED IN BATCH MODE AT LINE",I6), + ("GO TO UNDEFINED STATEMENT NUMBER AT LINE ",I6), %6 + ("RETURN WITHOUT GOSUB AT LINE ",I6), %7 + ("ARGUMENT FOR SIN,COS,TAN OR EXP EXCEEDS 158 AT LINE",I6), %8 + ("INCREMENT UNDEFINED OR ZERO AT LINE ",I6), %9 + ("NEXT WITHOUT FOR AT LINE ",I6), %10 + ("STORAGE EXCEEDED AT LINE ",I6), %11 + ("INTEGER OVERFLOW AT LINE ",I6), %12 + ("INVALID ADDRESS AT LINE ",I6), %13 + ("DIVIDE BY ZERO AT LINE ",I6), %14 + ("ILLEGAL EXPONENTIATION AT LINE ",I6), %15 + ("FLOATING-POINT OVERFLOW AT LINE ",I6), %16 + ("GOSUBS NESTED TOO DEEP (MORE THAN 10) AT LINE ",I6), %17 + ("ILLEGAL EXPONENT ON INPUT AT LINE ",I6), %18 + ("MISPLACED STRING IN INPUT AT LINE ",I6), %19 + ("INPUT STRING TOO LONG AT LINE ",I6), %20 + ("OUT OF DATA AT LINE ",I6),("ERR22",I6), % ERR22 SHOULDNT OCCUR 21,22 + ("ILLEGAL MATRIX OPERATION AT LINE ",I6), %23 + ("INVERSE OF ILL-CONDITIONED MATRIX AT LINE ",I6), %24 + ("INSUFFICIENT SPARE STORAGE FOR MAT OP AT LINE ",I6), %25 + ("ILLEGAL FILE OPERATION AT LINE ",I6), %26 + ("INPUT FILE NOT ON DISK AT LINE",I6), %27 + ("INPUT FILE - INVALID USER AT LINE",I6), %28 + ("INPUT FILE IS NON-STANDARD AT LINE",I6), %29 + ("OUTPUT FILE - DUPLICATE NAME AT LINE",I6); %30 + COMMENT LAST MESSAGE HERE IS NO. 30 ; + FORMAT DUR("THE FOLLOWING LINE WAS AWAITING OUTPUT:"), + FILAT(A6," FILE SEQUENCE NO.",I8); + WRITE(TTY,ERR[A],SSEQ[CS]); + IF INFILTOG THEN WRITE(TTY,FILAT," INPUT",IR); + IF OUTFILTOG THEN WRITE(TTY,FILAT,"OUTPUT",NR); + IF DELTA(POUB,PIOB) GTR 0 THEN BEGIN WRITE(TTY,DUR); + WRITE(TTY,9,IOB[*]) END; + LOCK(FIL1);LOCK(FIL2);GO TO STOP END; + + COMMENT --- EVAL EVALUATES ARITHMETIC EXPRESSION + (REVERSE POLISH DECODER) ; + REAL PROCEDURE EVAL; + BEGIN + LABEL EQ,DONE,EXPON,RPT,SS,S,NUM,VR,AR,SF,UF,AD,SU,MU,DI,EX,FIN, + INM,STRGA,STRGC,STRGV; + SWITCH TYP:=FIN,NUM,VR,AR,UF,SF,FIN,EQ,INM,AD,SU,MU,DI,EX,STRGV, + STRGA,STRGC; + DEFINE TOP=STK[STCK];STCK:=STCK-1#; + DEFINE STACK(STACK1)=STCK:=STCK+1;STK[STCK]:=STACK1;GO TO SS#; + COMMENT ADDR RETURNS RESULT ADDRESS (IN STORE IF REAL, STRGS + IF STRING). INTERMEDIATE RESULTS AND ADDRESSES ARE STACKED + IN STK AND ADR RESECTIVELY. ; + STRIN:=FALSE;STCK:=0; + SS: ADR[STCK]:=ADDR;CHA:=GET;GO TO TYP[CHA+1]; + NUM: A:=GET;A:=A|64+GET;STACK(CONST[A]); + STRGV: ADDR:=GET;STRIN:=TRUE;STACK(0); + STRGA: K:=GET;A:=TOP;IF A LEQ 0 OR A GTR STRAR[K,1] + THEN ERROR(1);ADDR:=STRAR[K,0]+A;STRIN:=TRUE;STACK(0); + STRGC: A:=GET;K:=GET;REPLACE POINTER(STRGS[0,1])BY POINTER + (PROG[CS,2])+K FOR A;STRGS[0,0]:=A;STRIN:=TRUE;ADDR:=0;STACK(0); + INM: STACK(0); + VR: K:=GET;K:=K-1;ADDR:=11|K+GET;STACK(STORE[ADDR]); + AR: K:=GET;A:=B:=TOP;IF ARR[K,2] NEQ 0 THEN BEGIN + A:=TOP;IF B LEQ 0 OR B GTR ARR[K,2] THEN ERROR(1) END; + IF A LEQ 0 OR A GTR ARR[K,1] THEN ERROR(1); + ADDR:=ARR[K,0]+(A-1)|ARR[K,2]+B-1;STACK(STORE[ADDR]); + SF: + BEGIN LABEL SQR,SIF,COF,TAF,ATF,EXF,LOF,ABF,ENF,FNQ,DC, + FIX,SGN,RND; + SWITCH SFUN:=SIF,COF,TAF,ATF,EXF,LOF,ABF,ENF,SQR,FIX,SGN,RND; + DEFINE TEST=IF ABS(R)>158 THEN ERROR(8)#; + A:=GET;R:=TOP;GO TO SFUN[A-18]; + SIF: TEST;R:=SIN(R);GO TO DC; + COF: TEST;R:=COS(R); GO TO DC; + TAF: TEST;R:=SIN(R)/COS(R); GO TO DC; + ATF: R:=ARCTAN(R); GO TO DC; + EXF: TEST;R:=EXP(R); GO TO DC; + LOF: IF R LEQ 0 THEN ERROR(2);R:=LN(R); GO TO DC; + ABF: R:=ABS(R); GO TO DC; + SQR: IF R LSS 0 THEN ERROR(3);R:=R*.5; GO TO DC; + ENF: R:=ENTIER(R);GO TO DC; + FIX: R:=ENTIER(R);IF R LSS 0 THEN R:=R+1;GO TO DC; + SGN: R:=IF R LSS 0 THEN -1 ELSE IF R GTR 0 THEN 1 ELSE 0; + GO TO DC; + RND: XRND:=XRND|2899;XRND:=XRND.[23:23]; + R:=XRND|2*(-23);GO TO DC; + DC: STACK(R) END; + COMMENT USER FUNCTIONS SECTION ; + UF: BEGIN INTEGER AS,SVSK,SVADDR; + ARRAY DUM[1:20,1:4],SVSTK,SVADR[0:20]; + K:=GET;AS:=CS;CS:=FUNC[K];IF CS=0 THEN BEGIN CS:=AS;ERROR(4) END; + B:=CO;CO:=SPOB[CS];C:=GET;FOR A:=1 STEP 1 UNTIL SUB[K] DO BEGIN + COMMENT SAVE VALUES OF FORMAL PARAMETERS AND STORE ACTUALS; + R:=TOP;C:=GET;C:=64|C+GET;DUM[A,1]:=C;DUM[A,2]:=STORE[C];STORE[C]:=R + END;SVADDR:=ADDR;SVSK:=STCK; + FOR A:=0 STEP 1 UNTIL 20 DO BEGIN SVSTK[A]:=STK[A];SVADR[A]:=ADR[A] + END; + COMMENT NOW EVALUATE FUNCTION ANO RESTORE FORMAL PARAMETERS; + R:=EVAL;FOR A:=1 STEP 1 UNTIL SUB[K] DO STORE[DUM[A,1]]:=DUM[A,2]; + FOR A:=0 STEP 1 UNTIL 20 DO BEGIN STK[A]:=SVSTK[A];ADR[A]:=SVADR[A] + END;ADDR:=SVADDR;STCK:=SVSK; + CS:=AS;CO:=B;STACK(R) END; + EQ: IF STRIN THEN BEGIN ADDR:=A:=ADR[STCK];STCK:=STCK-1; + B:=ADR[STCK];REPLACE POINTER(STRGS[B,*]) BY POINTER(STRGS[A,*]) + FOR 3 WORDS;TR4(B);GO TO SS END;R:=TOP;ADDR:=ADR[STCK]; + STORE[ADDR]:=STK[STCK]:=R;TR1(R);GO TO SS; + AD: R:=TOP;R:=R+TOP;STACK(R); + SU: R:=TOP;R:=-R+TOP;STACK(R); + MU: R:=TOP;R:=R|TOP;STACK(R); + DI: R:=TOP;R:=1/R|TOP;STACK(R); + EX: T:=TOP;R:=TOP;IF T NEQ ENTIER(T) AND R LSS 0 + THEN ERROR(15);STACK(R*T); + FIN: EVAL:=STK[1] END; + COMMENT + --- OUTP OUTPUTS CONTENTS OF PSEUDO-BUFFER ; + + PROCEDURE OUTP; + BEGIN IF MF>0 THEN ERROR(26);TR3; + WRITE(FL[OU],14,IOB[*]);REPLACE PIOB:=POUB:=POINTER(IOB[*]) BY + " " FOR 112;IF OU=1 THEN PIOB:=POUB:=POUB+20 END; + COMMENT + --- MORE FALSE IF END OF STATEMENT ; + + BOOLEAN PROCEDURE MORE; + BEGIN INTEGER A,B;A:=CO;B:=GET;MORE:=B NEQ 0;CO:=A END; + COMMENT + --- OUTNUM PLACES NUMBER IN PSEUDO-BUFFER ; + + PROCEDURE OUTNUM(A,F);VALUE A,F;REAL A;INTEGER F; + BEGIN CHA:=0;CP:=CP-1;WRITE(IOBE[*],NUM[F],A); % CARE: + SCAN APR:CPR FOR 16 UNTIL ="@"; + IF DELTA(CPR,APR) NEQ 16 THEN REPLACE APR BY "E" FOR 1; + IF DELTA(POUB,PIOB) GTR 60+F|4 THEN OUTP; + REPLACE PIOB:PIOB BY POINTER(IOBE[1]) FOR 14 UNTIL=48; + REPLACE PIOB:PIOB BY " " FOR 1 END; + COMMENT + --- QUO PLACES " IN OUTPUT BUFFER ; + DEFINE QUO=IF MF>0 THEN REPLACE PIOB:PIOB BY """#; + COMMENT + --- MATOP PROCESSES MOST MAT STATEMENTS ; + + PROCEDURE MATOP; + BEGIN INTEGER U,V,W,X,Y,Z,I,J; + COMMENT MAT STATEMENTS CONCERNED HAVE FORMAT + MAT LET = + MAT = + THE SECOND CHARACTER IN IS USED TO IDENTIFY ACTION TAKEN + THIS CAN BE * + - E O D R N % + (RECALL % IS END-STATEMENT CHARACTER) ; + LABEL DONE,ADSU,EQM,CONS,EX,EY;REAL PIVOT,AI; + INTEGER ARRAY IR[1:72];REAL ARRAY TEM[1:72]; + DEFINE AA(AA1,AA2)=STORE[ARR[K,0]+(AA1-1)|U+AA2-1]#; + CP:=GET;CHA:=0;K:=CHCONV(NCH);IF K=0 THEN ERROR(23); + IF NCH NEQ 61 THEN ERROR(23);A:=CHCONV(NCH);CHA:=NCH; + COMMENT SWITCH OCCURS HERE + * MATRIX MULTIPLICATION + IS * + HASH STORAGE IS USED TO AVOID TROUBLE WITH A=A*B ETC ; + ON("*") BEGIN B:=CHCONV(NCH); + U:=ARR[K,1]-1;V:=ARR[K,2]-1;W:=ARR[A,1]-1;X:=ARR[A,2]-1; + Y:=ARR[B,1]-1;Z:=ARR[B,2]-1;IF U NEQ W OR V NEQ Z OR X NEQ Y + THEN ERROR(23);IF MSTO+(U+1)|(V+1) GTR 1000 THEN ERROR(25); + FOR W:=0 STEP 1 UNTIL U DO FOR Z:=0 STEP 1 UNTIL V DO BEGIN R:=0; + FOR Y:=0 STEP 1 UNTIL X DO R:=R+STORE[ARR[A,0]+X|W+W+Y]| + STORE[ARR[B,0]+Y|V+Y+Z];STORE[MSTO+W|V+W+Z]:=R END; + FOR W:=0 STEP 1 UNTIL U DO FOR Z:=0 STEP 1 UNTIL V DO + STORE[ARR[K,0]+W|V+W+Z]:=STORE[MSTO+W|V+W+Z]; + GO TO DONE END; + COMMENT + MATRIX ADDITION + IS + ; + ON("+") BEGIN Z:=1;GO TO ADSU END; + COMMENT - MATRIX SUBTRACTION + IS - ; + ON("-") BEGIN Z:=-1;GO TO ADSU END; + COMMENT O ALL ONES + IS CON ; + ON("O") BEGIN Z:=Y:=1;GO TO CONS END; + COMMENT D IDENTITY MATRIX + IS IDN ; + ON("D") BEGIN IF ARR[K,1] NEQ ARR[K,2] THEN ERROR(23);Z:=1;Y:=0; + COMMENT E ZERO MATRIX + IS ZER ; + GO TO CONS END; ON("E") BEGIN Z:=Y:=0;GO TO CONS END; + COMMENT R TRANSPOSITION + IS TRN() + HASH STORAGE USED TO AVOID TROUBLE WITH A=TRN(A) ; + ON("R") BEGIN CHA:=NCH;CHA:=NCH;A:=CHCONV(NCH);IF A=0 THEN ERROR(23); + U:=ARR[K,1]-1;V:=ARR[K,2]-1;W:=ARR[A,1]-1;X:=ARR[A,2]-1; + IF U NEQ X OR V NEQ W THEN ERROR(23); + IF MSTO+(U+1)|(V+1) GTR 1000 THEN ERROR(25); + FOR U:=0 STEP 1 UNTIL X DO FOR V:=0 STEP 1 UNTIL W DO + STORE[MSTO+U|W+U+V]:=STORE[ARR[A,0]+V|X+V+U]; + FOR U:=0 STEP 1 UNTIL X DO FOR V:=0 STEP 1 UNTIL W DO + STORE[ARR[K,0]+U|W+U+V]:=STORE[MSTO+U|W+U+V]; + GO TO DONE END; + COMMENT N INVERSION + IS INV() ; + ON("N") BEGIN CHA:=NCH;CHA:=NCH;A:=CHCONV(NCH); + U:=ARR[K,1];IF U NEQ ARR[K,2] OR U NEQ ARR[A,1] OR U NEQ ARR[A,2] + THEN ERROR(23);FOR I:=0 STEP 1 UNTIL U-1 DO FOR J:=0 STEP 1 UNTIL U-1 + DO AA(I+1,J+1):=STORE[ARR[A,0]+I|U+J]; + FOR V:=1 STEP 1 UNTIL U DO BEGIN PIVOT:=0; + FOR I:=1 STEP 1 UNTIL U DO BEGIN IF V NEQ 1 THEN BEGIN + FOR X:=1 STEP 1 UNTIL V-1 DO IF I=IR[X] THEN GO TO EX END; + IF ABS(AA(I,V))GTR ABS(PIVOT) THEN BEGIN PIVOT:=AA(I,V);Y:=IR[V]:=I + END; + EX: END;IF ABS(PIVOT) LSS .0001 THEN ERROR(24); + FOR J:=1 STEP 1 UNTIL U DO AA(Y,J):=AA(Y,J)/PIVOT;AA(Y,V):=1/PIVOT; + FOR I:=1 STEP 1 UNTIL U DO IF I NEQ Y THEN BEGIN AI:=AA(I,V); + AA(I,V):=-AI/PIVOT;FOR J:=1 STEP 1 UNTIL U DO IF J NEQ V THEN + AA(I,J):=AA(I,J)-AI|AA(Y,J) END END; + FOR I:=1 STEP 1 UNTIL U DO + BEGIN FOR J:=1 STEP 1 UNTIL U DO TEM[J]:=AA(I,J); + FOR J:=1 STEP 1 UNTIL U DO AA(I,IR[J]):=TEM[J] END; + FOR J:=1 STEP 1 UNTIL U DO BEGIN FOR I:=1 STEP 1 UNTIL U DO + TEM[I]:=AA(IR[I],J);FOR I:=1 STEP 1 UNTIL U DO AA(I,J):=TEM[I] + END;GO TO DONE END; + % EQUALITY + COMMENT IS ; + ON("%") BEGIN B:=A;Z:=0; GO TO EQM END; + ERROR(23); + ADSU: B:=CHCONV(NCH);IF B=0 THEN ERROR(23); + IF ARR[A,1] NEQ ARR[B,1] OR ARR[A,2] NEQ ARR[A,2] THEN ERROR(23); + EQM: U:=ARR[K,1];V:=ARR[K,2];IF U NEQ ARR[A,1] + OR V NEQ ARR[A,2] THEN ERROR(23); + FOR I:=0 STEP 1 UNTIL U-1 DO FOR J:=0 STEP 1 UNTIL V-1 DO + AA(I+1,J+1):=STORE[ARR[A,0]+I|U+J]+Z|STORE[ARR[B,0]+I|U+J]; + GO TO DONE; + CONS: U:=ARR[K,I];FOR I:=1 STEP 1 UNTIL ARR[K,1] DO + FOR J:=1 STEP 1 UNTIL ARR[K,2] DO AA(I,J):=IF I=J THEN Z ELSE Y; + DONE: GO TO INCST END; + LABEL RPT,REM,DAT,EXS,LET,RLET,ONX, + INP,PRI,RPRI,XPRI,MAT,ENX,RREA,XREA,QDAT,FREA,RES,NDAT, + STRV,FOL,INTVR,INDEXR,DZER,EXPVR, + NM,TAB,COM,STR,EPRI,OUD,OUF, + IFF,GOT,GOX,GOS,RET,FOX,NEX,FD,DEF,REA,EREA,RAN,PAG; + SWITCH OPN:=LET,GOT,GOS,RET,INP,REA,EPRI,FOX,NEX,MAT, + DEF,DAT,RAN,PAG,RES,REM,ENX,ENX,IFF,ONX; + + SWITCH TYP:=XPRI,COM,NM,TAB,STR,INCST,STRV; + + COMMENT---------------------------------------------------------------- +----------------- EXECUTE BEGINS HERE -------------------- +-----------------------------------------------------------------------; + + INTOVR:=INTVR;EXPOVR:=EXPVR;ZERO:=DZER;INDEX:=INDEXR; + WRITE(TTY,MESS);RT:=TIME(2)+TIM;IF OU=1 THEN WRITE(TTY,DVO); + WRITE(FL[OU],SPC);NR:=IR:=RDAT:=RDTP:=NGOT:=0;TRACEON:=TLIN:=FALSE; + FORC:=SLVE:=0;XRND:=101;CS:=ACS-1; + POUB:=PIOB:=POINTER(IOB[*])+20|OU; + REPLACE POINTER(IOB[*]) BY " " FOR 112; + + % GET FILES IF NEEDED: + IF INFILTOG THEN BEGIN FILL FIL1 WITH IO[1],TIME(-1); + SEARCH(FIL1,ANSA[*]);IF ANSA[0] LEQ 0 THEN ERROR(28+ANSA[0]); + IF ANSA[3] NEQ 10 OR ANSA[4] NEQ 300 THEN ERROR(29) END; + IF OUTFILTOG THEN BEGIN FILL FIL2 WITH IO[2],TIME(-1); + SEARCH(FIL2,ANSA[*]);IF ANSA[0] NEQ -1 THEN BEGIN + WRITE(TTY,F13,IO[2].[41:36]); + IF IU=2 THEN U:=0 ELSE + READ(TTY,REP,U);IF U NEQ "YES" THEN ERROR(30) END END; + + COMMENT RETURN TO HERE AFTER EACH STATEMENT; + + REM:DAT:INCST: TR3;CS:=CS+1; + EXS: MF:=0; % FIRST SEE IF EXCESS TIME + IF TIME(2) GTR RT THEN BEGIN WRITE(TTY,BK);GO TO ENX END; + IF STYP[CS]>19 THEN BEGIN TRACEON:=STYP[CS]=20;GO INCST END; + IF TRACEON THEN TLIN:=TRUE; + + + U:=STYP[CS];CO:=SPOB[CS];GO TO OPN[U]; % NOW GO TO APPROPRIATE PLACE + % LET STATEMENT + LET: R:=EVAL;GO TO INCST; + % ON STATEMENT + ONX: U:=EVAL; + FOR V:=1 STEP 1 UNTIL 2|U-2 DO BEGIN S:=GET END;GO GOT; %(STET) + % IF STATEMENT + IFF: R:=EVAL;IF STRIN THEN BEGIN + COMMENT STRING IF ; + U:=GET; + REPLACE IPR:=POINTER(STRGS[-1,*]) BY POINTER(STRGS[ADDR,*]) FOR 24; + R:=EVAL;GO IF IPR=POINTER(STRGS[ADDR,*]) + FOR STRGS[-1,0]+8 EQV U=1 THEN GOT ELSE INCST END; + COMMENT REAL IF ; + U:=GET;R:=R-EVAL; + IF R GTR 0 AND U.[2:1]=1 THEN GO TO GOT ELSE + IF R LSS 0 AND U.[1:1]=1 THEN GO TO GOT ELSE + IF R = 0 AND U.[0:1]=1 THEN GO TO GOT;GO TO INCST; + % GOTO STATEMENT + GOT: U:=GET;U:=64|U+GET;IF U=0 THEN ERROR(6); + GOX: NGOT:=NGOT+1;TR2(U); + COMMENT MONITOR FOR EXCESS LOOPING; + IF NGOT=100 AND IU NEQ 2 THEN BEGIN WRITE(TTY,WRN);READ(TTY,REP,W); + IF W NEQ "YES" THEN GO TO STOP END; + CS:=U;GO EXS; + % GOSUB STATEMENT + GOS: SLVE:=SLVE+1;IF SLVE GTR 10 THEN ERROR(17); + SVE[SLVE]:=CS;GO GOT; + % RETURN STATEMENT + RET: IF SLVE=0 THEN ERROR(7); + CS:=SVE[SLVE];SLVE:=SLVE-1;GO TO INCST; + % FOR STATEMENT + FOX: FORC:=GET;R:=EVAL; + COMMENT FORX CONTROL INFO IS STORED AS FOLLOWS: + 1 2 3 4 + ADDR STEP FINAL FORLINE + A FOR LOOP IS EXECUTED ZERO TIMES IN THE RIGHT CIRCUMSTANCES; + + V:=FORX[FORC,1]:=ADDR;S:=FORX[FORC,3]:=EVAL; + T:=FORX[FORC,2]:=IF MORE THEN EVAL ELSE 1; + W:=FORX[FORC,4]:=CS;IF T=0 THEN ERROR(9); + IF T|R LEQ T|S THEN GO INCST; % ELSE SKIP LOOP + U:=GET;U:=GET;CS:=64|U+GET;GO TO INCST; + + % NEXT STATEMENT + % SPOB STORES (NEXTS LEVEL IN FORX)+16|FORLINE + NEX: U:=SPOB[CS].[3:4];V:=SPOB[CS].[41:38]; + IF V NEQ FORX[U,4] THEN ERROR(10);L:=FORX[U,1]; + T:=FORX[U,2];R:=STORE[L]+T; + IF T|R LEQ T|FORX[U,3] THEN BEGIN STORE[L]:=R;TR1(R);T:=FORX[U,4]; + TR2(T+1);CS:=T END ELSE FORX[U,4]:=0; + GO TO INCST; + % DEFINE STATEMENT + DEF: U:=GET;FUNC[U]:=CS;GO TO INCST; + % READ STATEMENT + REA: U:=0; + COMMENT THIS SECTION IS COMPLICATED BECAUSE OF SWITCHING + OF ATTENTION FROM READ STATEMENT TO DATA STATEMENT AND BACK ETC; + RREA: R:=EVAL;L:=ADDR;U:=CS;V:=CO; + IF RDTP=0 THEN GO TO QDAT;CO:=RDTP;CS:=RDAT; + XREA: IF STRIN THEN BEGIN R:=EVAL;CS:=U;IF NOT STRIN THEN + ERROR(20);REPLACE POINTER(STRGS[L,*])BY POINTER(STRGS[ADDR,*]) + FOR 3 WORDS;TR4(L) END ELSE BEGIN R:=EVAL;IF STRIN THEN ERROR(20); + STORE[L]:=R;CS:=U;TR1(R) END;RDTP:=IF MORE THEN CO ELSE 0;CO:=V; + IF MORE THEN GO TO RREA ELSE GO TO INCST; + COMMENT FIND ANOTHER DATA STATEMENT; + QDAT: FOR CS:=RDAT+1 STEP 1 UNTIL MS DO BEGIN + IF STYP[CS]=12 THEN GO TO FREA END; + CS:=U;ERROR(21); + FREA: RDAT:=CS;CO:=SPOB[CS];GO TO XREA; + % INPUT STATEMENT + % "STOP" AT START OF INPUT STREAM STOPS A RUN + INP: BEGIN LABEL RINP,EVINP,RPT,EXPON,DONE,FINP; + MF:=GET;IF MF=0 THEN BEGIN IF IU=2 THEN ERROR(5); + IF DELTA(POUB,PIOB) GTR 0 THEN BEGIN + REPLACE POINTER(IOBE[*]) BY POUB FOR 72;WRITE(TTY[STOP],9,IOBE[*]); + REPLACE PIOB:=POUB:=POINTER(IOB[*]) BY " " FOR 112;IF OU=1 THEN + PIOB:=POUB:=PIOB+20 END;READ(TTY,9,IOBE[*]); + READ(IOBE[*],REP,V);IF V="STO" THEN GO TO STOP END + ELSE BEGIN Z:=GET;Z:=64|Z+GET;READ(FIL1,10,IOBE[*])[OUD]; + READ(IOBE[*],SNUM,IR) END; + REPLACE POINTER(PROG[0,2]) BY POINTER(IOBE[1]) FOR 72;X:=0; + RINP: R:=EVAL;L:=ADDR;U:=CS;CS:=0;CP:=X;CHA:=0; + IF NCH="%" THEN BEGIN IF MF=0 THEN BEGIN WRITE(TTY,MNP[IF X=0 THEN 1 + ELSE 0],PROG[U,1]);CS:=U;GO TO EXS END ELSE BEGIN + READ(FIL1,9,IOBE[*])[OUD]; + REPLACE POINTER(PROG[0,2]) BY POINTER(IOBE[*]) FOR 72;CP:=1 END END; + COMMENT INPUT STRING MAY OR MAY NOT HAVE "" ; + EVINP: CP:=CP-1;CHA:=NCH;IF STRIN THEN BEGIN + ON(63) SCAN APR:APR:=CPR:=POINTER(PROG[0,2])+CP FOR 15 WHILE NEQ 63 + ELSE BEGIN CP:=CP-2;SCAN APR:APR:=CPR:=POINTER(PROG[0,2])+CP+1 FOR 15 + WHILE IN ALPHA END; + V:=DELTA(CPR,APR);IF V>14 THEN BEGIN CS:=U;ERROR(20) END; + STRGS[L,0]:=V;REPLACE POINTER(STRGS[L,1]) BY CPR FOR V; + CP:=CP+V+1;CHA:=NCH;CS:=U;TR4(L);GO FINP END; + T:=R:=Y:=0; + COMMENT INPUT NUMBER ; + ON(44) BEGIN T:=1;CHA:=NCH END; + RPT: ON(26) BEGIN Y:=1;CHA:=NCH END; + IF CHA GEQ 10 THEN GO TO EXPON;IF Y GTR 0 THEN + BEGIN R:=R+CHA|10*(-Y); + Y:=Y+1 END ELSE R:=R|10 +CHA;CHA:=NCH; GO TO RPT; + EXPON: IF CHA NEQ 21 THEN GO TO DONE;Y:=1;CHA:=NCH;Z:=0; + ON(44)BEGIN Y:=-1;CHA:=NCH END ELSE ON(16) CHA:=NCH; + IF CHA GEQ 10 THEN BEGIN CS:=U;ERROR(18) END;Z:=CHA;CHA:=NCH; + IF CHA LSS 10 THEN BEGIN Z:=Z|10+CHA;CHA:=NCH END; + R:=R|10*(Y|Z); + DONE: IF T=1 THEN R:=-R;DELIM:=72;STORE[L]:=R;CS:=U;TR1(R); + FINP: X:=CP;IF CHA NEQ 58 AND CHA NEQ "%" THEN ERROR(19); + IF MORE THEN GO TO RINP ELSE GO TO INCST END; + % RANDOMISE STATEMENT + RAN: XRND:=(2|TIME(1)+1).[23:23];GO TO INCST; + % RESTORE STATEMENT + RES: MF:=GET;IF MF=0 THEN RDTP:=RDAT:=0 ELSE REWIND(FIL1); + GO INCST; + % PRINT STATEMENT + EPRI: MF:=GET;IF MF>0 THEN BEGIN PBR:=PIOB; + TR3;Z:=GET;Z:=64|Z+GET; + POUB:=POINTER(IOF[*]);REPLACE PIOB:=POINTER(IOF[*]) BY " " FOR 72 END; + PRI: CHA:=GET;IF MF>0 AND CHA=5 THEN ERROR(26); + GO TO TYP[CHA+1]; + Z:=GET;Z:=64|X+GET; + COMMENT , IN PRINT MOVES TO NEXT 14-SPACE COLUMN. + + (SEMICOLON IN MIDDLE OF PRINT IS JUST DELIMITER); + COM: IF MF>0 THEN REPLACE PIOB:PIOB BY "," ELSE BEGIN + V:=DELTA(POUB,PIOB);IF V GTR 56 THEN BEGIN + OUTP;V:=0 END ELSE V:=14-(V MOD 14); + FOR U:=1 STEP 1 UNTIL V DO REPLACE PIOB:PIOB BY " " END; + GO TO PRI; + COMMENT PLACE STRING IN PSEUDO-BUFFER ; + STR: CP:=GET; + CPR:=POINTER(PROG[CS,2])+CP; + V:=72-DELTA(POUB,PIOB);W:=GET; + IF W GTR V THEN BEGIN REPLACE PIOB:PIOB BY CPR:CPR FOR V; + OUTP;W:=W-V END; + QUO;REPLACE PIOB:PIOB BY CPR:CPR FOR W;QUO; + GO TO PRI; + + COMMENT TAB OVERWRITES ON TELETYPE AND LINE-PRINTER + BUT REPLACES ON VIDEO UNIT. ; + + TAB: IF MF>0 THEN ERROR(26);U:=EVAL-1;U:=U MOD 72; + IF IU+OU NEQ 0 THEN BEGIN TR3;WRITE(FL[OU][NO],9,IOB[*]); + REPLACE POUB BY " " FOR 72 END;PIOB:=POUB+U; GO TO PRI; + STRV: R:=EVAL;QUO;REPLACE PIOB:PIOB BY POINTER(STRGS[ADDR,1]) + FOR STRGS[ADDR,0];QUO;GO TO PRI; + NM: OUTNUM(EVAL,0);GO TO PRI; + XPRI: IF MF>0 THEN BEGIN REPLACE PIOB BY ","; + NR:=NR+10;REPLACE POINTER(IOF[10]) BY NR FOR 8 DIGITS; + WRITE(FIL2,10,IOF[*])[OUF];PIOB:=PBR;POUB:=POINTER(IOB[*])+20|OU END + ELSE OUTP;GO TO INCST; + % PAGE STATEMENT + PAG: IF OU=1 THEN WRITE(LIN[PAGE]);GO TO INCST; + % MAT STATEMENT + % MAT 1=READ, 2=PRINT, 3=MATOP, 4=SCALAR MULTIPLE + MAT: BEGIN INTEGER E,F,G;LABEL QDAT,FREA,XREA,RREA; + L:=GET;IF L=1 THEN BEGIN E:=CS;L:=GET;U:=GET;V:=GET; + FOR W:=0 STEP 1 UNTIL U-1 DO FOR X:=0 STEP 1 UNTIL V-1 DO BEGIN + IF RDTP = 0 THEN GO TO QDAT;CO:=RDTP;CS:=RDAT; + XREA: STORE[ARR[L,0]+W|ARR[L,2]+X]:=EVAL; + RDTP:=IF MORE THEN CO ELSE 0;GO TO RREA; + QDAT: FOR CS:=RDAT + 1 STEP 1 UNTIL MS DO BEGIN IF STYP[CS] + =12 THEN GO TO FREA END;CS:=E;ERROR(21); + FREA: RDAT:=CS;CO:=SPOB[CS];GO TO XREA; + RREA: END;CS:=E;GO TO INCST END; + IF L=2 THEN BEGIN + IF DELTA(POUB,PIOB) GTR 0 THEN OUTP; + L:=GET;U:=GET;V:=GET;E:=GET;G:=14-E|7;FOR W:=0 STEP 1 UNTIL U-1 DO + BEGIN FOR X:=0 STEP 1 UNTIL V-1 DO BEGIN OUTNUM(STORE[ARR[L,0]+ + W|ARR[L,2]+X],E);PIOB:=POUB+G|((DELTA(POUB,PIOB)-1) DIV G +1) + END;OUTP END;GO TO INCST END; + IF L=3 THEN MATOP; + L:=GET;R:=EVAL;W:=GET; + IF ARR[L,1] NEQ ARR[W,1] OR ARR[L,2] NEQ ARR[W,2] THEN ERROR(23); + FOR U:=0 STEP 1 UNTIL ARR[L,1]-1 DO FOR V:=0 STEP 1 UNTIL ARR[L,2]-1 + DO STORE[ARR[L,0]+U|ARR[L,2]+V]:=R|STORE[ARR[W,0]+U|ARR[L,2]+V]; + GO TO INCST END; + % STOP OR END STATEMENT + ENX: TR3;IF DELTA(POUB,PIOB)>0 THEN OUTP; + LOCK(FIL1);LOCK(FIL2);GO TO STOP; + OUD: IF Z=0 THEN ERROR(21);TR2(Z);CS:=Z;GO EXS; + OUF: IF Z=0 THEN ERROR(26);TR2(Z);CS:=Z;GO EXS; + INTVR: ERROR(12);INDEXR: ERROR(13); + DZER: ERROR(14);EXPVR: ERROR(16) END; + STOP: WRITE(TTY,STP,"RUN ");GO TO SOURCEIN; + COMMENT + PROGRAM WRITTEN BY MALCOLM CROWE + LANGUAGE DETAILS DECIDED BY IAN MILLER AND JOHN FURLONG + MATRIX INVERSION CORRECTED BY ARTHUR MACDIVITT ; + + FINSH: END. +?END