From bb575e68ce79a41338ed041afdcb0209a19bf175 Mon Sep 17 00:00:00 2001 From: Paul Kimpel Date: Sat, 5 Apr 2014 21:57:34 +0000 Subject: [PATCH] Apply sequence numbers to EULER and XBASIC Algol source files. Commit updated version of STQB64.BAS from James Fehlinger as of 2014-04-04. --- source/EULER/EULERIV.alg_m | 2336 +++++++++++++-------------- source/EULER/SYNTAX.alg_m | 907 ++++++----- source/XBASIC/STQB64.BAS | 2501 ++++++++++++++-------------- source/XBASIC/XBASIC.alg_m | 3136 ++++++++++++++++++------------------ 4 files changed, 4426 insertions(+), 4454 deletions(-) diff --git a/source/EULER/EULERIV.alg_m b/source/EULER/EULERIV.alg_m index 9131f5c..ed42907 100644 --- a/source/EULER/EULERIV.alg_m +++ b/source/EULER/EULERIV.alg_m @@ -1,1183 +1,1153 @@ -?COMPILE EULER/DISK WITH ALGOL -?ALGOL STACK = 5000 -?DATA CARD -$ CARD LIST SINGLE XREF -BEGIN COMMENT E U L E R IV S Y S T E M MARCH 1965; - FILE IN CARDFIL (1,10); FILE PRINFIL 1 (1,15); - INTEGER FT, LT; COMMENT INDEX OF FIRST AND LAST BASIC SYMBOL; - INTEGER LP; COMMENT LENGTH OF PRODUCTION TABLE; - ARRAY PROGRAM[0:1022]; - DEFINE AFIELD =[39:9]#, BFIELD =[9:30]#, CFIELD =[1:8]#; - LABEL EXIT; - FT ~ 45; LT ~ 119; LP ~ 465; COMMENT DATA GENERATED BY SY-PR.; - -BEGIN COMMENT E U L E R IV TRANSLATOR N.WIRTH; - DEFINE MARK =119#, IDSYM =63#, REFSYM =59#, LABSYM =62#; - DEFINE VALSYM =56#, CALLSYM =55#, UNDEF =0#, NEWSYM =60#; - DEFINE UNARYMINUS =116#, NUMSYM =68#, BOOLSYM =64#; - DEFINE LISTSYM =102#, SYMSYM =113#, FORSYM =61#; - DEFINE NAME =V[0]#; - INTEGER I,J,K,M,N,R,T,T1,SCALE; BOOLEAN ERRORFLAG; - INTEGER BN, ON; COMMENT BLOCK- AND ORDER-NUMBER; - INTEGER NP; COMMENT NAME LIST POINTER; - INTEGER MP; COMMENT MARK-POINTER OF NAME-LIST; - INTEGER PRP; COMMENT PROGRAM POINTER; - INTEGER WC, CC; COMMENT INPUT POINTERS; - ALPHA ARRAY READBUFFER, WRITEBUFFER [0:14]; - ALPHA ARRAY SYTB[0:LT]; COMMENT TABLE OF BASIC SYMBOLS; - INTEGER ARRAY F, G [0:LT]; COMMENT PRIORITY FUNCTIONS; - INTEGER ARRAY MTB[0:LT]; COMMENT SYNTAX MASTER TABLE; - INTEGER ARRAY PRTB[0:LP]; COMMENT PRODUCTION TABLE; - INTEGER ARRAY S[0:127]; COMMENT STACK; - REAL ARRAY V[0:127]; COMMENT VALUE STACK; - ALPHA ARRAY NL1[0:63]; COMMENT NAME LIST; - INTEGER ARRAY NL2, NL3, NL4 [0:63]; - LABEL A0,A1,A2,A3,A4,A5,A6,A7,A8,A9; - LABEL L0, L1131, NAMEFOUND, - L1,L2,L3,L4,L5,L6,L7,L8,L9,L10,L11,L12,L13,L14,L15,L16,L17,L18,L19, - L20,L21,L22,L23,L24,L25,L26,L27,L28,L29,L30,L31,L32,L33,L34, - L35,L36,L37,L38,L39,L40,L41,L42,L43,L44,L45,L46,L47,L48,L49,L50,L51, - L52,L53,L54,L55,L56,L57,L58,L59,L60,L61,L62,L63,L64,L65,L66,L67,L68, - L69,L70,L71,L72,L73,L74,L75,L76,L77,L78,L79,L80,L81,L82,L83,L84,L85, - L86,L87,L88,L89,L90,L91,L92,L93,L94,L95,L96,L97,L98,L99,L100,L101, - L102,L103,L104,L105,L106,L107,L108,L109,L110,L111,L112,L113,L114, - L115,L116,L117,L118,L119,L120; - SWITCH BRANCH ~ - L1,L2,L3,L4,L5,L6,L7,L8,L9,L10,L11,L12,L13,L14,L15,L16,L17,L18,L19, - L20,L21,L22,L23,L24,L25,L26,L27,L28,L29,L30,L31,L32,L33,L34, - L35,L36,L37,L38,L39,L40,L41,L42,L43,L44,L45,L46,L47,L48,L49,L50,L51, - L52,L53,L54,L55,L56,L57,L58,L59,L60,L61,L62,L63,L64,L65,L66,L67,L68, - L69,L70,L71,L72,L73,L74,L75,L76,L77,L78,L79,L80,L81,L82,L83,L84,L85, - L86,L87,L88,L89,L90,L91,L92,L93,L94,L95,L96,L97,L98,L99,L100,L101, - L102,L103,L104,L105,L106,L107,L108,L109,L110,L111,L112,L113,L114, - L115,L116,L117,L118,L119,L120; - -STREAM PROCEDURE ZERO(D); - BEGIN DI ~ D; DS ~ 8 LIT "0"; - END; -STREAM PROCEDURE CLEAR(D); - BEGIN DI ~ D; DS ~ 8 LIT " "; SI ~ D; DS ~ 14 WDS - END; -STREAM PROCEDURE MOVE(S,D); - BEGIN SI ~ S; DI ~ D; DS ~ WDS; - END; -BOOLEAN STREAM PROCEDURE EQUAL(X,Y); - BEGIN TALLY ~ 1; SI ~ X; DI ~ Y; IF 8 SC = DC THEN EQUAL ~ TALLY; - END; - -INTEGER PROCEDURE INSYMBOL; - COMMENT "INSYMBOL" READS THE NEXT EULER-SYMBOL FROM INPUT. - STRINGS OF LETTERS AND DIGITS ARE RECOGNIZED AS IDENTIFIERS, IF - THEY ARE NOT EQUAL TO AN EULER-IVWORD-DELIMITER. - A CHARACTER-SEQUENCE ENCLOSED IN " IS RECOGNIZED AS A SYMBOL; - BEGIN INTEGER I; LABEL A,B,C,D,E; -STREAM PROCEDURE TRCH(S,M,D,N); VALUE M,N; - BEGIN SI ~ S; SI ~ SI+M; DI ~ D; DI ~ DI+N; DS ~ CHR - END; -BOOLEAN STREAM PROCEDURE BLANK(S,N); VALUE N; - BEGIN TALLY ~ 1; SI ~ S; SI ~ SI+N; IF SC = " " THEN BLANK ~ TALLY - END; -STREAM PROCEDURE BLANKOUT(D); - BEGIN DI ~ D; DS ~ 8 LIT " "; - END; -BOOLEAN STREAM PROCEDURE QUOTE(S,N); VALUE N; - BEGIN TALLY ~ 1; SI ~ S; SI ~ SI+N; IF SC = """ THEN QUOTE ~ TALLY - END; -BOOLEAN STREAM PROCEDURE LETTER(S,N); VALUE N; - BEGIN TALLY ~ 1; SI ~ S; SI ~ SI+N; - IF SC = ALPHA THEN - BEGIN IF SC < "0" THEN LETTER ~ TALLY END - END; -BOOLEAN STREAM PROCEDURE LETTERORDIGIT(S,N); VALUE N; - BEGIN TALLY ~ 1; SI ~ S; SI ~ SI+N; - IF SC = ALPHA THEN LETTERORDIGIT ~ TALLY - END; -STREAM PROCEDURE EDIT(N,S,D); VALUE N; - BEGIN SI ~ LOC N; DI ~ D; DS ~ 3 DEC; - SI ~ S; DI ~ DI + 13; DS ~ 10 WDS - END; -PROCEDURE ADVANCE; - COMMENT ADVANCES THE INPUT POINTER BY 1 CHARACTER POSITION; - BEGIN IF CC = 7 THEN - BEGIN IF WC = 8 THEN - BEGIN READ (CARDFIL, 10, READBUFFER[*]) [EXIT]; - EDIT(PRP+1, READBUFFER[0], WRITEBUFFER[0]); - WRITE (PRINFIL, 15, WRITEBUFFER[*]); WC ~ 0 - END ELSE WC ~ WC+1; - CC ~ 0; - END - ELSE CC ~ CC+1; - END ADVANCE; - - BLANKOUT(NAME); -A: IF BLANK(READBUFFER[WC], CC) THEN - BEGIN ADVANCE; GO TO A END; - IF LETTER(READBUFFER[WC], CC) THEN - BEGIN FOR I ~ 0 STEP 1 UNTIL 7 DO - BEGIN TRCH(READBUFFER[WC], CC, NAME, I); ADVANCE; - IF NOT LETTERORDIGIT(READBUFFER[WC], CC) THEN GO TO C - END; -B: ADVANCE; - IF LETTERORDIGIT(READBUFFER[WC], CC) THEN GO TO B; -C: END - ELSE IF QUOTE(READBUFFER[WC], CC) THEN - BEGIN ADVANCE; ZERO(NAME); NAME ~ " "; -E: TRCH(READBUFFER[WC], CC, I, 7); ADVANCE; - IF I ! """ THEN - BEGIN NAME ~ I.[42:6] & NAME [18:24:24]; GO TO E END - ELSE I ~ SYMSYM; GO TO D - END - ELSE - BEGIN TRCH(READBUFFER[WC], CC, NAME, 0); ADVANCE - END; - FOR I ~ FT STEP 1 UNTIL LT DO - IF EQUAL(SYTB[I], NAME) THEN BEGIN ZERO(NAME); GO TO D END; - I ~ IDSYM; -D: INSYMBOL ~ I - END INSYMBOL; - -PROCEDURE P1(X); VALUE X; INTEGER X; - BEGIN PRP ~ PRP+1; PROGRAM[PRP] ~ X - END; -PROCEDURE P2(X,Y); VALUE X,Y; INTEGER X; REAL Y; - BEGIN PRP ~ PRP+1; PROGRAM[PRP] ~ X; PROGRAM[PRP].BFIELD ~ Y; - END; -PROCEDURE P3(X,Y,Z); VALUE X,Y,Z; INTEGER X,Y,Z; - BEGIN PRP ~ PRP+1; PROGRAM[PRP] ~ X; PROGRAM[PRP].BFIELD ~ Y; - PROGRAM[PRP].CFIELD ~ Z - END; -PROCEDURE FIXUP(I,X); VALUE I,X; INTEGER I,X; - PROGRAM[I].BFIELD ~ X; -PROCEDURE ERROR(N); VALUE N; INTEGER N; - BEGIN SWITCH FORMAT ERR ~ - ("UNDECLARED IDENTIFIER"), - ("NUMBER TOO LARGE"), - ("LABEL IS DEFINED TWICE"), - ("A LABEL IS NOT DECLARED"), - ("LABEL DECLARED BUT NOT DEFINED"), - ("PROGRAM SYNTACTICALLY INCORRECT"); - ERRORFLAG ~ TRUE; - WRITE (PRINFIL [NO], ERR[N]); WRITE (PRINFIL, , - WC|8 + CC + 1) - END ERROR; - -PROCEDURE PROGRAMDUMP; - BEGIN REAL T; INTEGER I; LABEL L; -STREAM PROCEDURE NUM(N,D); VALUE N; - BEGIN DI ~ D; SI ~ LOC N; DS ~ 3 DEC - END; - - READ (CARDFIL, , T) [L]; IF T ! "DUMP" THEN GO TO L; - WRITE (PRINFIL, ); - FOR I ~ 1 STEP 1 UNTIL PRP DO - BEGIN CLEAR(WRITEBUFFER[0]); - T ~ PROGRAM[I]; NUM(I, WRITEBUFFER[0]); - MOVE(SYTB[T.AFIELD], WRITEBUFFER[1]); - IF T.BFIELD ! 0 THEN NUM(T.BFIELD, WRITEBUFFER[2]); - IF T.CFIELD ! 0 THEN NUM(T.CFIELD, WRITEBUFFER[3]); - IF T.AFIELD = NUMSYM THEN - BEGIN I ~ I+1; - WRITE (PRINFIL [NO], , PROGRAM[I]) - END; - WRITE (PRINFIL, 15, WRITEBUFFER[*]); - END; -L: END PROGRAMDUMP; - - COMMENT INITIALISE THE SYMBOLTABLE, THE PRIORITY FUNCTIONS AND THE - PRODUCTION TABLES WITH DATA GENERATED BY THE SYNTAX-PROCESSOR; - FILL SYTB[*] WITH 0, - "PROGRAM ","BLOCK ","BLOKHEAD","BLOKBODY","LABDEF ","STAT ", - "STAT- ","EXPR ","EXPR- ","IFCLAUSE","TRUEPART","CATENA ", - "DISJ ","DISJHEAD","CONJ ","CONJ- ","CONJHEAD","NEGATION", - "RELATION","CHOICE ","CHOICE- ","SUM ","SUM- ","TERM ", - "TERM- ","FACTOR ","FACTOR- ","PRIMARY ","PROCDEF ","PROCHEAD", - "LIST* ","LISTHEAD","REFERENC","NUMBER ","REAL* ","INTEGER*", - "INTEGER-","DIGIT ","LOGVAL ","VAR ","VAR- ","VARDECL ", - "FORDECL ","LABDECL ","0 ","1 ","2 ","3 ", - "4 ","5 ","6 ","7 ","8 ","9 ", - ", ",". ","; ",": ","@ ","NEW ", - "FORMAL ","LABEL ","IDENT* ","[ ","] ","BEGIN ", - "END ","( ",") ","LQ ","RQ ","GOTO ", - "OUT ","~ ","IF ","THEN ","ELSE ","& ", - "OR ","AND ","NOT ","= ","! ","< ", - "{ ","} ","> ","MIN ","MAX ","+ ", - "- ","| ","/ ","% ","MOD ","* ", - "ABS ","LENGTH ","INTEGER ","REAL ","LOGICAL ","LIST ", - "TAIL ","IN ","ISB ","ISN ","ISR ","ISL ", - "ISLI ","ISY ","ISP ","ISU ","SYMBOL* ","UNDEFINE", - "TEN ","# ","TRUE ","FALSE ","$ "; - FILL F[*] WITH 0, - 1, 4, 19, 1, 2, 1, 2, 3, 4, 1, 4, 4, - 5, 5, 5, 6, 6, 6, 7, 7, 8, 9, 10, 11, - 11, 12, 12, 13, 13, 3, 13, 3, 13, 13, 13, 15, - 17, 19, 13, 13, 15, 1, 1, 1, 19, 19, 19, 19, - 19, 19, 19, 19, 19, 19, 19, 16, 21, 19, 13, 14, - 14, 14, 16, 3, 16, 21, 5, 19, 13, 19, 13, 12, - 4, 4, 3, 19, 19, 12, 19, 19, 7, 8, 8, 8, - 8, 8, 8, 9, 9, 10, 10, 11, 11, 11, 11, 12, - 12, 13, 12, 12, 12, 12, 12, 13, 13, 13, 13, 13, - 13, 13, 13, 13, 13, 13, 16, 16, 13, 13, 5; - FILL G[*] WITH 0, - 1, 5, 6, 6, 3, 1, 2, 3, 4, 5, 1, 5, - 5, 6, 6, 6, 7, 7, 7, 8, 9, 9, 10, 10, - 11, 11, 12, 12, 13, 13, 13, 14, 13, 13, 13, 16, - 17, 17, 13, 13, 14, 19, 3, 19, 18, 18, 18, 18, - 18, 18, 18, 18, 18, 18, 3, 15, 1, 16, 13, 20, - 4, 20, 14, 15, 3, 6, 1, 14, 3, 13, 3, 5, - 5, 13, 5, 3, 3, 4, 5, 6, 7, 7, 7, 7, - 7, 7, 7, 8, 8, 10, 10, 11, 11, 11, 11, 12, - 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, - 13, 13, 13, 13, 13, 13, 13, 16, 13, 13, 4; - FILL MTB[*] WITH 0, - 1, 2, 5, 16, 25, 29, 30, 33, 39, 42, 47, 48, - 55, 58, 62, 68, 71, 75, 81, 84, 111, 122, 125, 136, - 139, 158, 161, 168, 171, 174, 183, 186, 198, 201, 204, 216, - 223, 229, 232, 235, 245, 256, 257, 258, 259, 262, 265, 268, - 271, 274, 277, 280, 283, 286, 289, 290, 291, 292, 293, 297, - 301, 305, 309, 315, 320, 321, 324, 325, 328, 329, 332, 333, - 337, 341, 342, 347, 348, 349, 350, 351, 352, 356, 357, 358, - 359, 360, 361, 362, 363, 364, 368, 372, 373, 374, 375, 376, - 377, 381, 385, 389, 393, 397, 401, 405, 408, 412, 416, 420, - 424, 428, 432, 436, 440, 443, 446, 454, 455, 458, 461; - FILL PRTB[*] WITH 0, - 0,-103, 9, 0, 42, 57,-115, 3, 44, 57,-116, 3, - -117, 4, 0, 6, 57,-118, 4, 6, 67,-119, 2, 0, - 7,-110, 7, 0, 0,-112, 6, 0, 77,-101, 11,-111, - 7, 0,-109, 8, 0, 11, 9,-104, 9, 0, 0, 78, - 28, -99, 12,-108, 9, 0,-100, 12, 0, 13, -97, 13, - 0, 79, -96, 14, -98, 13, 0, -95, 15, 0, 16, -93, - 16, 0, 80, -92, 17, -94, 16, 0, -90, 18, 0, -83, - 19, 82, 20, -84, 19, 83, 20, -85, 19, 84, 20, -86, - 19, 85, 20, -87, 19, 86, 20, -88, 19, 87, 20, -89, - 19, 0, 88, 22, -80, 21, 89, 22, -81, 21, -82, 20, - 0, -79, 21, 0, 90, 24, -76, 23, 91, 24, -77, 23, - -78, 22, 0, -73, 23, 0, 92, 26, -68, 25, 93, 26, - -69, 25, 94, 26, -70, 25, 95, 26, -71, 25, -72, 24, - 0, -67, 25, 0, 96, 28, -65, 27, -66, 26, 0, -64, - 27, 0, -46, 28, 0, 43, 57, -35, 30, 8, 71, -37, - 29, 0, -44, 28, 0, 8, 55, -31, 32, 8, 69, -33, - 31, 69, -34, 31, 0, -43, 28, 0, -41, 28, 0, -25, - 34, 115, 36, -26, 34, 115, 116, 36, -27, 34, 0, 56, - 36, -23, 35, -24, 35, 0, 38, -21, 37, -22, 36, 0, - -20, 37, 0, -40, 28, 0, -38, 28, 31, -39, 28, 74, - 9,-105, 9, 0, 64, 8, 65, -5, 41, 56, -6, 41, - -7, 40, 0, 0, 0, 0, -10, 38, 0, -11, 38, 0, - -12, 38, 0, -13, 38, 0, -14, 38, 0, -15, 38, 0, - -16, 38, 0, -17, 38, 0, -18, 38, 0, -19, 38, 0, - 0, 0, 0, 0, 40, -30, 33, 0, 63, -1, 42, 0, - 63, -2, 43, 0, 63, -3, 44, 0, -4, 41, 58,-113, - 5, 0, 8, 65, -48, 28, 0, 0,-114, 3, 0, 0, - -32, 32, 0, 0, -36, 30, 0, 0, 28,-106, 9, 0, - 9,-107, 9, 0, 0, 8, 76,-102, 10, 0, 0, 0, - 0, 0, 0, 19, -91, 18, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 24, -74, 23, 0, 24, -75, 23, 0, 0, - 0, 0, 0, 0, 28, -58, 28, 0, 40, -59, 28, 0, - 28, -60, 28, 0, 28, -61, 28, 0, 28, -62, 28, 0, - 28, -63, 28, 0, 28, -45, 28, 0, -49, 28, 0, 40, - -50, 28, 0, 40, -51, 28, 0, 40, -52, 28, 0, 40, - -53, 28, 0, 40, -54, 28, 0, 40, -55, 28, 0, 40, - -56, 28, 0, 40, -57, 28, 0, -42, 28, 0, -47, 28, - 0, 36, -28, 34, 116, 36, -29, 34, 0, 0, -8, 39, - 0, -9, 39, 0, 2, 119,-120, 1, 0; - - WC ~ 8; CC ~ 7; CLEAR(WRITEBUFFER[0]); CLEAR(READBUFFER[0]); - S[0] ~ MARK; ERRORFLAG ~ FALSE; - I ~ J ~ BN ~ ON ~ NP ~ PRP ~ 0; - - COMMENT ALGORITHM FOR SYNTACTIC ANALYSIS: - COMPARE THE PRIORITIES OF THE SYMBOL R AND OF THE - SYMBOL ON TOP OF THE STACK S. IF S[J]...S[I] CONSTITUTE A RIGHT- - PART OF A PRODUCTION, THEN REPLACE THIS SEQUENCE BY THE - CORRESPONDING LEFT-PART AND BRANCH TO THE INTERPRETATION-RULE - BELONGING TO THE PERFORMED PRODUCTION; -A0: R ~ INSYMBOL; -A1: IF F[S[I]] > G[R] THEN GO TO A2; - IF R = MARK THEN GO TO A9; - I ~ J ~ I+1; S[I] ~ R; MOVE(NAME, V[I]); GO TO A0; -A2: IF F[S[J-1]] = G[S[J]] THEN BEGIN J ~ J-1; GO TO A2 END; - M ~ MTB[S[J]]; -A3: IF PRTB[M] = 0 THEN BEGIN ERROR(5); GO TO EXIT END; - N ~ J; -A4: N ~ N+1; - IF PRTB[M] < 0 THEN GO TO A8; - IF N { I THEN GO TO A7; -A5: M ~ M+1; - IF PRTB[M] } 0 THEN GO TO A5; -A6: M ~ M+2; GO TO A3; -A7: IF PRTB[M] ! S[N] THEN GO TO A5; - M ~ M+1; GO TO A4; -A8: IF N { I THEN GO TO A6; - GO TO BRANCH[-PRTB[M]]; -L0: S[J] ~ PRTB[M+1]; I ~ J; GO TO A1; - - COMMENT THE FOLLOWING ARE THE INTERPRETATION-RULES; -L1: -L2: P1(S[J]); NP ~ NP+1; MOVE(V[I], NL1[NP]); ZERO(V[I]); - NL2[NP] ~ BN; NL3[NP] ~ ON ~ ON+1; NL4[NP] ~ S[J]; GO TO L0; -L3: NP ~ NP+1; MOVE(V[I], NL1[NP]); ZERO(V[I]); - NL2[NP] ~ BN; NL3[NP] ~ NL4[NP] ~ UNDEF; GO TO L0; -L4: FOR T ~ NP STEP -1 UNTIL 1 DO - IF EQUAL(NL1[T], V[I]) THEN GO TO NAMEFOUND; - ERROR(0); GO TO L0; -NAMEFOUND: - IF NL4[T] = NEWSYM THEN - P3(REFSYM, NL3[T], NL2[T]) - ELSE IF NL4[T] = LABSYM THEN - P3(LABSYM, NL3[T], NL2[T]) - ELSE IF NL4[T] = FORSYM THEN - BEGIN P3(REFSYM, NL3[T], NL2[T]); P1(VALSYM) END - ELSE - BEGIN P3(LABSYM, NL3[T], NL2[T]); NL3[T] ~ PRP END; - GO TO L0; -L5: P1(S[I]); GO TO L0; -L6: P1(VALSYM); GO TO L0; -L10: -L9: V[J] ~ 0; GO TO L0; -L11: -L8: V[J] ~ 1; GO TO L0; -L12:V[J] ~ 2; GO TO L0; -L13:V[J] ~ 3; GO TO L0; -L14:V[J] ~ 4; GO TO L0; -L15:V[J] ~ 5; GO TO L0; -L16:V[J] ~ 6; GO TO L0; -L17:V[J] ~ 7; GO TO L0; -L18:V[J] ~ 8; GO TO L0; -L19:V[J] ~ 9; GO TO L0; -L20:SCALE ~ 1; GO TO L0; -L21:V[J] ~ V[J] | 10 + V[I]; SCALE ~ SCALE+1; - IF SCALE > 11 THEN ERROR(1); GO TO L0; -L23:V[J] ~ V[I] | 10 * (-SCALE) + V[J]; GO TO L0; -L26:V[J] ~ V[J] | 10 * V[I]; GO TO L0; -L27:V[J] ~ V[J] | .1 * V[I]; GO TO L0; -L28:V[J] ~ 10 * V[I]; GO TO L0; -L29:V[J] ~ .1 * V[I]; GO TO L0; -L31:V[J] ~ V[J]+1; GO TO L0; -L32:V[J] ~ 0; GO TO L0; -L33:P2(S[I], V[J]+1); GO TO L0; -L34:P2(S[I], V[J]); GO TO L0; -L36:BN ~ BN+1; ON ~ 0; P2(S[J], UNDEF); V[J] ~ PRP; - NP ~ NP+1; ZERO(NL1[NP]); NL2[NP] ~ MP; MP ~ NP; GO TO L0; -L37:P1(S[I]); FIXUP(V[J], PRP+1); NP ~ MP-1; MP ~ NL2[MP]; - BN ~ BN-1; GO TO L0; -L38:P1(VALSYM); GO TO L0; -L39:P1(CALLSYM); GO TO L0; -L40:P2(BOOLSYM, V[I]); GO TO L0; -L41:P1(NUMSYM); PRP ~ PRP+1; PROGRAM[PRP] ~ V[I]; GO TO L0; -L42:P2(S[I], V[I]); GO TO L0; -L75:P1(UNARYMINUS); GO TO L0; -L92: -L96: -L101: -L102:P2(S[I], UNDEF); V[J] ~ PRP; GO TO L0; -L93: -L97: FIXUP(V[J], PRP+1); GO TO L0; -L104:FIXUP(V[J], V[J+1]+1); FIXUP(V[J+1], PRP+1); GO TO L0; -L113:FOR T ~ NP STEP -1 UNTIL MP+1 DO - IF EQUAL(NL1[T], V[J]) THEN - BEGIN IF NL4[T] ! UNDEF THEN ERROR(2); - T1 ~ NL3[T]; NL3[T] ~ PRP+1; NL4[T] ~ LABSYM; ZERO(V[J]); -L1131: IF T1 ! UNDEF THEN - BEGIN T ~ PROGRAM[T1].BFIELD; FIXUP(T1, PRP+1); - T1 ~ T; GO TO L1131 - END; GO TO L0; - END; - ERROR(3); GO TO L0; -L114:BN ~ BN+1; ON ~ 0; P1(S[I]); - NP ~ NP+1; ZERO(NL1[NP]); NL2[NP] ~ MP; MP ~ NP; GO TO L0; -L118:P1(S[I]); GO TO L0; -L119:FOR T ~ MP+1 STEP 1 UNTIL NP DO IF NL4[T] = UNDEF THEN ERROR(4); - NP ~ MP-1; MP ~ NL2[MP]; P1(S[I]); BN ~ BN-1; GO TO L0; - -L45: -L47: -L49: -L50: -L51: -L52: -L53: -L54: -L55: -L56: -L57: -L58: -L59: -L60: -L61: -L62: -L63: -L91: -L106: -L107:P1(S[J]); GO TO L0; - -L65: -L68: -L69: -L70: -L71: -L76: -L77: -L80: -L81: -L84: -L85: -L86: -L87: -L88: -L89: -L99: -L105:P1(S[J+1]); GO TO L0; - -L7: -L22: -L24: -L25: -L30: -L35: -L43: -L44: -L46: -L48: -L64: -L66: -L67: -L72: -L73: -L74: -L78: -L79: -L82: -L83: -L90: -L94: -L95: -L98: -L100: -L103: -L108: -L109: -L110: -L111: -L112: -L115: -L116: -L117: -L120:GO TO L0; - -A9: P1(MARK); PROGRAMDUMP; IF ERRORFLAG THEN GO TO EXIT -END * ; - -BEGIN COMMENT E U L E R IV INTERPRETER MCKEEMAN & WIRTH; - REAL ARRAY S, SI, F, FI[0:1022]; COMMENT STACK; - INTEGER I1, I2, LVL, FORMALCOUNT; - INTEGER SP; COMMENT TOP-STACK POINTER; - INTEGER FP; COMMENT FREE STORAGE SPACE POINTER; - INTEGER MP; COMMENT BLOCK- OR PROCEDURE-MARK POINTER; - INTEGER PP; COMMENT PROGRAM POINTER; - LABEL ADD, SUB, MUL, DIVIDE, IDIV, REMAINDER, POWER, NEG, ABSV, - INTEGERIZE, REALL, LOGICAL, MIN, MAX, EQL, NEQ, LSS, LEQ, GEQ, GTR, - LENGTH, ISLOGICAL, ISNUMBER, ISREFERENCE, ISLABEL, ISSYMBOL, - ISLIST, ISPROCEDURE, ISUNDEFINED, LAND, LOR, LNOT, LEFTQUOTE, - RIGHTQUOTE, RIGHTPAREN, REFERENCE, PROCEDURECALL, VALUEOPERATOR, - GOTO, NEW, FORMAL, BEGINV, ENDV, STORE, THENV, ELSEV, NUMBER, LOGVAL, - LABELL, SUBSCRIPT, SEMICOLON, UNDEFIND, OUTPUT, INPUT, TAIL, - CATENATE, LISTT, SYMBOL, DONE, UNDEFINEDOPERATOR, NEXT, TRANSFER; - -COMMENT SI AND FI FIELD DEFINITIONS - 1-4 8-17 18-27 28-37 38-47 48-97 -NUMBER TYPE VALUE -BOOLEAN TYPE VALUE -SYMBOL TYPE VALUE -UNDEFINED TYPE -LIST TYPE LENGTH ADDRESS -REFERENCE TYPE MARK ADDRESS -LABEL TYPE MARK ADDRESS -BLOCKMARK TYPE DYNAMIC BLOCK NO. STATIC ADDRESS LIST; - - DEFINE TYPE=[1:4]#, - WCT=[28:10]#, - ADDRESS=[38:10]#, - STATIC=[28:10]#, - DYNAMIC=[8:10]#, - BLN=[18:10]#, - NSA=[18:10]#; COMMENT NEW STARTING ADDRESS FOR FREE; - DEFINE UNDEFINED=0#, - NUMBERTYPE=1#, - SYMBOLTYPE=2#, - BOOLEANTYPE=3#, - LABELTYPE=4#, - REFERENCETYPE=5#, - PROCEDURETYPE=6#, - LISTTYPE=7#, - BLOCKMARK=8#; - -STREAM PROCEDURE MOVE(F1, T1, W); - BEGIN LOCAL R1, R2; - SI ~ W; SI ~ SI + 6; - DI ~ LOC R1; DI ~ DI + 7; DS ~ CHR; - DI ~ LOC R2; DI ~ DI + 7; DS ~ CHR; - SI ~ F1; DI ~ T1; - R1(2(DS ~ 32 WDS)); DS ~ R2 WDS; - END; - -PROCEDURE DUMPOUT(XI, X); VALUE XI, X; REAL XI, X; - BEGIN INTEGER T, I; - -PROCEDURE LISTOUT(XI); VALUE XI; REAL XI; - BEGIN COMMENT RECURSIVE LIST OUTPUT; - INTEGER I, N; - SWITCH FORMAT LPAR ~ - ("("), (".("), ("..("),("...("), ("....("), (".....("), ("......("); - SWITCH FORMAT RPAR ~ - (")"), (".)"), ("..)"),("...)"), ("....)"), (".....)"), ("......)"); - WRITE (PRINFIL, , XI.ADDRESS); - WRITE (PRINFIL [NO], LPAR[LVL]); - LVL ~ LVL + 1; N ~ XI.ADDRESS + XI.WCT - 1; - FOR I ~ XI.ADDRESS STEP 1 UNTIL N DO DUMPOUT(FI[I], F[I]); - LVL ~ LVL - 1; WRITE (PRINFIL, RPAR[LVL]); - END LISTOUT; - - T ~ XI.TYPE; - IF T = UNDEFINED THEN - WRITE (PRINFIL, ) - ELSE IF T = NUMBERTYPE THEN - BEGIN - IF X ! ENTIER(X) THEN - WRITE (PRINFIL, , X) - ELSE - WRITE (PRINFIL, , X) - END - ELSE IF T = BOOLEANTYPE THEN -WRITE (PRINFIL, , BOOLEAN(X)) - ELSE IF T = LISTTYPE THEN LISTOUT(XI) - ELSE IF T = LABELTYPE THEN -WRITE (PRINFIL, , X) - END DUMPOUT; - -PROCEDURE ERROR(N); VALUE N; INTEGER N; - BEGIN INTEGER I; - SWITCH FORMAT ER ~ - ("ILLEGAL INSTRUCTION ENCOUNTERED"), - ("IMPROPER OPERAND TYPE"), - ("CANNOT DIVIDE BY 0"), - ("CALL OPERATOR DID NOT FIND A PROCEDURE"), - ("REFERENCE OR LABEL OUT OF SCOPE"), - ("OUT OF SCOPE ASSIGNMENT OF A LABEL OR A REFERENCE"), - ("SUBSCRIPT IS NOT A NUMBER"), - ("SUBSCRIPT NOT APPLIED TO A VARIABLE"), - ("SUBSCRIPTED VARIABLE IS NOT A LIST"), - ("SUBSCRIPT IS OUT OF BOUNDS"), - ("CANNOT TAKE TAIL OF A NULL LIST"), - ("STACK OVERFLOW"), - ("STACK OVERFLOW DURING GARBAGE COLLECTION"), - ("ASSIGNMENT TO A NON-VARIABLE ATTEMPTED"), - ("FREE STORAGE AREA IS TOO SMALL"); - WRITE (PRINFIL [DBL], ER[N]); -WRITE (PRINFIL, - , - SP, FP, PP, MP, PROGRAM[PP].AFIELD); - FOR I ~ 1 STEP 1 UNTIL SP DO - BEGIN WRITE(PRINFIL [NO], , I); - DUMPOUT(SI[I], S[I]) - END; - GO TO DONE - END ERROR; - -PROCEDURE FREE(NEED); VALUE NEED; INTEGER NEED; - COMMENT "FREE" IS A "GARBAGE COLLECTION" PROCEDURE. IT IS CALLED - WHEN FREE STORAGE F IS USED UP, AND MORE SPACE IS NEEDED. - GARBAGE COLLECTION TAKES THE FOLLOWING STEPS: - 1. ALL BLOCKMARKS, LIST DESCRIPTORS AND REFERENCES IN STACK - POINT TO VALID INFORMATION IN FREE STORAGE. LIKEWISE, ALL - LIST DESCRIPTORS AND REFERENCES THAT ARE POINTED TO ARE VALID, - ENTER INTO THE STACK ALL SUCH ENTITIES. - 2. THE GARBAGE COLLECTOR MUST KNOW IN WHICH ORDER TO COLLAPSE THE - FREE STORAGE. THUS SORT THE LIST BY FREE STORAGE ADDRESS. - 3. MOVE EACH BLOCK DOWN IF NECESSARY. - 4. NOW THE ADDRESSES ARE WRONG--MAKE ONE MORE PASS THROUGH THE - SORTED LIST TO UPDATE ALL ADDRESSES; - BEGIN OWN INTEGER G, H, I, J; OWN REAL T; - -INTEGER PROCEDURE FIND(W); VALUE W; REAL W; - BEGIN COMMENT BINARY SEARCH THROUGH ORDERED TABLE; - INTEGER T, N, B, KEY, K; - LABEL FOUND, BINARY; - T ~ G+1; B ~ SP + 1; - KEY ~ W.ADDRESS; -BINARY: N ~ (B+T) DIV 2; - K ~ SI[N].ADDRESS; - IF K = KEY THEN GO TO FOUND; - IF K < KEY THEN B ~ N ELSE T ~ N; - GO TO BINARY; -FOUND: FIND ~ SI[N].NSA - END FIND; - -PROCEDURE RESET(W, Z); REAL W, Z; - BEGIN INTEGER TY; - TY ~ W.TYPE; - IF TY = REFERENCETYPE OR TY = LISTTYPE THEN - W.ADDRESS ~ FIND(W) - ELSE IF TY = BLOCKMARK THEN - Z.ADDRESS ~ FIND(Z) - END RESET; - -PROCEDURE VALIDATE(P); VALUE P; REAL P; - BEGIN COMMENT TREE SEARCH FOR ACTIVE LIST STORAGE; - INTEGER I, U; - G ~ G + 1; - IF G > 1022 THEN ERROR(12); - SI[G] ~ P; - U ~ P.ADDRESS + P.WCT - 1; - IF P.TYPE = LISTTYPE THEN - FOR I ~ P.ADDRESS STEP 1 UNTIL U DO - IF FI[I].TYPE = LISTTYPE OR FI[I].TYPE = REFERENCETYPE THEN - VALIDATE(FI[I]); - END VALIDATION; - -PROCEDURE SORT(LB, UB); VALUE LB, UB; INTEGER LB, UB; - BEGIN COMMENT BINARY SORT; - INTEGER M; - -PROCEDURE MERGE(LB, M, UB); VALUE LB, M, UB; INTEGER LB, M, UB; - BEGIN INTEGER K,L,U,K1,K2; LABEL A, B; - K ~ UB - LB; - MOVE(SI[LB], S[LB], K); - L ~ K ~ LB; U ~ M; GO TO B; -A: K1 ~ S[L].ADDRESS; K2 ~ S[U].ADDRESS; - IF K1 < K2 OR (K1 = K2 AND S[L].TYPE = LISTTYPE) THEN - BEGIN SI[K] ~ S[L]; L ~ L+1 END - ELSE - BEGIN SI[K] ~ S[U]; U ~ U+1 END; - K ~ K + 1; -B: IF L = M THEN - ELSE IF U = UB THEN - BEGIN K ~ M-L; MOVE(S[L], SI[UB-K], K) END - ELSE - GO TO A - END MERGE; - - IF LB < UB THEN - BEGIN M ~ (LB+UB) DIV 2; - SORT(LB, M); SORT(M+1, UB); MERGE(LB, M+1, UB+1) - END - END SORT; - - INTEGER LLA, LLW; - G ~ SP; - FOR H ~ 1 STEP 1 UNTIL SP DO - BEGIN COMMENT LOCATE ALL ACTIVE LISTS AND REFERENCES; - IF SI[H].TYPE = LISTTYPE OR SI[H].TYPE = REFERENCETYPE THEN - VALIDATE(SI[H]) - ELSE IF SI[H].TYPE = BLOCKMARK THEN - VALIDATE(S[H]); - END - COMMENT SORT THEM IN ORDER OF INCREASING ADDRESS; - SORT(SP+1, G); - I ~ 1; COMMENT COLLAPSE THE FREE STORAGE; - FOR J ~ SP+1 STEP 1 UNTIL G DO - IF SI[J].TYPE = LISTTYPE THEN - BEGIN COMMENT IF G.C. OCCURS DURING "COPY" THEN WE MUST AVOID - THE CREATION OF DOUBLE LIST ENTRIES FROM DUPLICATED DESCRIPTORS; - IF SI[J] = SI[J+1] THEN SI[J+1].TYPE ~ UNDEFINED; - LLA ~ SI[J].ADDRESS; LLW ~ SI[J].WCT; - IF LLA ! I THEN - BEGIN - MOVE(F[LLA], F[I], LLW); - MOVE(FI[LLA], FI[I], LLW); - END; - SI[J].NSA ~ I; - I ~ I + LLW; - END - ELSE - SI[J].NSA ~ I - LLW + SI[J].ADDRESS - LLA; - FP ~ I; - - COMMENT RESET ALL AFFECTED ADDRESSES; - FOR I ~ 1 STEP 1 UNTIL SP DO RESET(SI[I], S[I]); - FOR I ~ 1 STEP 1 UNTIL FP-1 DO RESET(FI[I], F[I]); - IF FP + NEED > 1022 THEN ERROR(14); - END FREE; - -PROCEDURE MOVESEG(LD); REAL LD; - BEGIN COMMENT MOVE ONE LIST SEGMENT; - INTEGER W, X; - W ~ LD.WCT; - IF FP + W > 1022 THEN FREE(W); - X ~ LD.ADDRESS; - MOVE(F[X], F[FP], W); - MOVE(FI[X], FI[FP], W); - LD.ADDRESS ~ FP; - FP ~ FP + W; - END MOVE SEGMENT; - -PROCEDURE COPY(LD); REAL LD; - BEGIN INTEGER I, J; COMMENT RECURSIVE LIST COPY; - MOVESEG(LD); - J ~ LD.WCT - 1; - FOR I ~ 0 STEP 1 UNTIL J DO - IF FI[I+LD.ADDRESS].TYPE = LISTTYPE THEN COPY(FI[I+LD.ADDRESS]) - END COPY; - -PROCEDURE BOOLTEST; IF SI[SP].TYPE ! BOOLEANTYPE THEN ERROR(1); - -INTEGER PROCEDURE ROUND(X); VALUE X; REAL X; ROUND ~ X; - -PROCEDURE BARITH; - BEGIN - IF SI[SP].TYPE ! NUMBERTYPE OR SI[SP-1].TYPE ! NUMBERTYPE THEN - ERROR(1) - ELSE - SP ~ SP-1; - END BARITH; - -PROCEDURE FETCH; - BEGIN INTEGER I; - IF SI[SP].TYPE = REFERENCETYPE THEN - BEGIN I ~ SI[SP].ADDRESS; SI[SP] ~ FI[I]; S[SP] ~ F[I] END - END FETCH; - -INTEGER PROCEDURE MARKINDEX(BL); VALUE BL; INTEGER BL; - BEGIN COMMENT MARKINDEX IS THE INDEX OF THE MARK WITH BLOCKNUMBER BL; - LABEL U1; INTEGER I; - I ~ MP; -U1: IF SI[I].BLN > BL THEN - BEGIN I ~ SI[I].STATIC; GO TO U1 END; - IF SI[I].BLN < BL THEN ERROR(4); - MARKINDEX ~ I - END MARKINDEX; - -PROCEDURE LEVELCHECK(X, Y); VALUE Y; INTEGER Y; REAL X; - BEGIN INTEGER T, I, L, U; T ~ X.TYPE; - IF T = REFERENCETYPE OR T = LABELTYPE THEN - BEGIN IF X.STATIC > Y THEN ERROR(5) END - ELSE IF T = PROCEDURETYPE THEN - X.STATIC ~ Y - ELSE IF T = LISTTYPE THEN - BEGIN - L ~ X.ADDRESS; U ~ L + X.WCT - 1; - FOR I ~ L STEP 1 UNTIL U DO LEVELCHECK(FI[I], Y) - END - END LEVEL CHECK; - -PROCEDURE SPUP; IF SP } 1022 THEN ERROR(11) ELSE SP ~ SP + 1; - -PROCEDURE SETIS(V); VALUE V; INTEGER V; - BEGIN - FETCH; - S[SP] ~ REAL(SI[SP].TYPE = V); - SI[SP].TYPE ~ BOOLEANTYPE; - END SET IS; - - SWITCH EXECUTE ~ - PROCEDURECALL, VALUEOPERATOR, SEMICOLON, UNDEFINEDOPERATOR, - REFERENCE, NEW, FORMAL, LABELL, UNDEFINEDOPERATOR, LOGVAL, - SUBSCRIPT, BEGINV, ENDV, NUMBER, RIGHTPAREN, LEFTQUOTE, RIGHTQUOTE, - GOTO, OUTPUT, STORE, UNDEFINEDOPERATOR, THENV, ELSEV, CATENATE, - LOR, LAND, LNOT, EQL, NEQ, LSS, LEQ, GEQ, GTR, MIN, MAX, - ADD, SUB, MUL, DIVIDE, IDIV, REMAINDER, POWER, ABSV, LENGTH, - INTEGERIZE, REALL, LOGICAL, LISTT, TAIL, INPUT, - ISLOGICAL, ISNUMBER, ISREFERENCE, ISLABEL, ISLIST, ISSYMBOL, - ISPROCEDURE, ISUNDEFINED, SYMBOL, UNDEFIND, UNDEFINEDOPERATOR, NEG, - UNDEFINEDOPERATOR, UNDEFINEDOPERATOR, DONE; - - WRITE (PRINFIL [PAGE]); - SP ~ MP ~ PP ~ 0; FP ~ 1; LVL ~ 0; FT ~ FT+9; - -NEXT: - PP ~ PP+1; -TRANSFER: - GO TO EXECUTE[PROGRAM[PP].AFIELD - FT]; - -UNDEFINEDOPERATOR: - ERROR(0); -SEMICOLON: - SP ~ SP - 1; - GO TO NEXT; -UNDEFIND: - SPUP; - SI[SP].TYPE ~ UNDEFINED; - GO TO NEXT; -NUMBER: - PP ~ PP + 1; - SPUP; - SI[SP].TYPE ~ NUMBERTYPE; - S[SP] ~ PROGRAM[PP]; - GO TO NEXT; -SYMBOL: - SPUP; - SI[SP].TYPE ~ SYMBOLTYPE; - S[SP] ~ PROGRAM[PP].BFIELD; - GO TO NEXT; -LOGVAL: - SPUP; - SI[SP].TYPE ~ BOOLEANTYPE; - S[SP] ~ PROGRAM[PP].BFIELD; - GO TO NEXT; -REFERENCE: - SPUP; - SI[SP] ~ 0; - SI[SP].TYPE ~ REFERENCETYPE; - SI[SP].STATIC ~ I1 ~ MARKINDEX(PROGRAM[PP].CFIELD); - SI[SP].ADDRESS ~ S[I1].ADDRESS + PROGRAM[PP].BFIELD - 1; - GO TO NEXT; -LABELL: - SPUP; - SI[SP].TYPE ~ LABELTYPE; - SI[SP].STATIC ~ MARKINDEX(PROGRAM[PP].CFIELD); - SI[SP].ADDRESS ~ PROGRAM[PP].BFIELD; - GO TO NEXT; -CATENATE: - IF SI[SP].TYPE ! LISTTYPE OR SI[SP-1].TYPE ! LISTTYPE THEN ERROR(1); - IF SI[SP-1].ADDRESS + SI[SP-1].WCT ! SI[SP].ADDRESS THEN - BEGIN COMMENT MUST HAVE CONTIGUOUS LISTS; - MOVESEG(SI[SP-1]); - MOVESEG(SI[SP]); - END; - SP ~ SP - 1; - SI[SP].WCT ~ SI[SP].WCT + SI[SP+1].WCT; - GO TO NEXT; -LOR: - BOOLTEST; - IF NOT BOOLEAN(S[SP]) THEN - BEGIN - SP ~ SP - 1; - GO TO NEXT - END; - PP ~ PROGRAM[PP].BFIELD; - GO TO TRANSFER; -LAND: - BOOLTEST; - IF BOOLEAN(S[SP]) THEN - BEGIN - SP ~ SP - 1; - GO TO NEXT - END; - PP ~ PROGRAM[PP].BFIELD; - GO TO TRANSFER; -LNOT: - BOOLTEST; - S[SP] ~ REAL(NOT BOOLEAN(S[SP])); - GO TO NEXT; -LSS: - BARITH; - S[SP] ~ REAL(S[SP] < S[SP+1]); - SI[SP].TYPE ~ BOOLEANTYPE; - GO TO NEXT; -LEQ: - BARITH; - S[SP] ~ REAL(S[SP] { S[SP+1]); - SI[SP].TYPE ~ BOOLEANTYPE; - GO TO NEXT; -EQL: - BARITH; - S[SP] ~ REAL(S[SP] = S[SP+1]); - SI[SP].TYPE ~ BOOLEANTYPE; - GO TO NEXT; -NEQ: - BARITH; - S[SP] ~ REAL(S[SP] ! S[SP+1]); - SI[SP].TYPE ~ BOOLEANTYPE; - GO TO NEXT; -GEQ: - BARITH; - S[SP] ~ REAL(S[SP] } S[SP+1]); - SI[SP].TYPE ~ BOOLEANTYPE; - GO TO NEXT; -GTR: - BARITH; - S[SP] ~ REAL(S[SP] > S[SP+1]); - SI[SP].TYPE ~ BOOLEANTYPE; - GO TO NEXT; -MIN: - BARITH; - IF S[SP+1] < S[SP] THEN S[SP] ~ S[SP+1]; - GO TO NEXT; -MAX: - BARITH; - IF S[SP+1] > S[SP] THEN S[SP] ~ S[SP+1]; - GO TO NEXT; -ADD: - BARITH; - S[SP] ~ S[SP] + S[SP+1]; - GO TO NEXT; -SUB: - BARITH; - S[SP] ~ S[SP] - S[SP+1]; - GO TO NEXT; -NEG: - IF SI[SP].TYPE ! NUMBERTYPE THEN ERROR(1); - S[SP] ~ -S[SP]; - GO TO NEXT; -MUL: - BARITH; - S[SP] ~ S[SP] | S[SP+1]; - GO TO NEXT; -DIVIDE: - BARITH; - IF S[SP+1] = 0 THEN ERROR(2); - S[SP] ~ S[SP] / S[SP+1]; - GO TO NEXT; -IDIV: - BARITH; - IF ROUND(S[SP+1]) = 0 THEN ERROR(2); - S[SP] ~ ROUND(S[SP]) DIV ROUND(S[SP+1]); - GO TO NEXT; -REMAINDER: - BARITH; - IF S[SP+1] = 0 THEN ERROR(2); - S[SP] ~ S[SP] MOD S[SP+1]; - GO TO NEXT; -POWER: - BARITH; - S[SP] ~ S[SP] * S[SP+1]; - GO TO NEXT; -ABSV: - IF SI[SP].TYPE ! NUMBERTYPE THEN ERROR(1); - S[SP] ~ ABS(S[SP]); - GO TO NEXT; -REALL: - IF SI[SP].TYPE > BOOLEANTYPE THEN ERROR(1); - SI[SP].TYPE ~ NUMBERTYPE; - GO TO NEXT; -LOGICAL: - IF SI[SP].TYPE ! NUMBERTYPE THEN ERROR(1); - IF S[SP] = 0 OR S[SP] = 1 THEN - SI[SP].TYPE ~ BOOLEANTYPE - ELSE - SI[SP].TYPE ~ UNDEFINED; - GO TO NEXT; -LISTT: - IF SI[SP].TYPE ! NUMBERTYPE THEN ERROR(1); - I2 ~ S[SP]; - IF I2 + FP > 1022 THEN FREE(I2); - FOR I1 ~ FP STEP 1 UNTIL FP+I2-1 DO - FI[I1].TYPE ~ UNDEFINED; - SI[SP].TYPE ~ LISTTYPE; - SI[SP].WCT ~ I2; - SI[SP].ADDRESS ~ FP; - FP ~ FP + I2; - GO TO NEXT; - -ISLOGICAL: - SETIS(BOOLEANTYPE); - GO TO NEXT; -ISNUMBER: - SETIS(NUMBERTYPE); - GO TO NEXT; -ISREFERENCE: - SETIS(REFERENCETYPE); - GO TO NEXT; -ISLABEL: - SETIS(LABELTYPE); - GO TO NEXT; -ISLIST: - SETIS(LISTTYPE); - GO TO NEXT; -ISSYMBOL: - SETIS(SYMBOLTYPE); - GO TO NEXT; -ISPROCEDURE: - SETIS(PROCEDURETYPE); - GO TO NEXT; -ISUNDEFINED: - SETIS(UNDEFINED); - GO TO NEXT; - -TAIL: - IF SI[SP].TYPE ! LISTTYPE THEN ERROR(1); - IF SI[SP].WCT = 0 THEN ERROR(10); - SI[SP].WCT ~ SI[SP].WCT - 1; - SI[SP].ADDRESS ~ SI[SP].ADDRESS + 1; - GO TO NEXT; -THENV: - BOOLTEST; - SP ~ SP - 1; - IF BOOLEAN(S[SP+1]) THEN - GO TO NEXT; - PP ~ PROGRAM[PP].BFIELD; - GO TO TRANSFER; -ELSEV: - PP ~ PROGRAM[PP].BFIELD; - GO TO TRANSFER; -LENGTH: - FETCH; - IF SI[SP].TYPE ! LISTTYPE THEN ERROR(1); - SI[SP].TYPE ~ NUMBERTYPE; - S[SP] ~ SI[SP].WCT; - GO TO NEXT; -GOTO: - IF SI[SP].TYPE ! LABELTYPE THEN ERROR(1); - MP ~ SI[SP].STATIC; - COMMENT WE MUST RETURN TO THE BLOCK WHERE THE LABEL IS DEFINED; - PP ~ SI[SP].ADDRESS; - SP ~ MP; - GO TO TRANSFER; -FORMAL: - FORMALCOUNT ~ FORMALCOUNT + 1; - IF FORMALCOUNT { S[MP].WCT THEN - GO TO NEXT - ELSE - GO TO NEW; -NEW: - S[MP].WCT ~ S[MP].WCT + 1; - FI[FP].TYPE ~ UNDEFINED; - FP ~ FP + 1; - IF FP > 1022 THEN FREE(1); - GO TO NEXT; -STORE: - IF SI[SP-1].TYPE ! REFERENCETYPE THEN ERROR(13); - LEVELCHECK(SI[SP], SI[SP-1].STATIC); - SP ~ SP - 1; COMMENT NON-DESTRUCTIVE STORE; - I1 ~ SI[SP].ADDRESS; - S[SP] ~ F[I1] ~ S[SP+1]; - SI[SP] ~ FI[I1] ~ SI[SP+1]; - COMMENT THE NON-DESTRUCTIVE STORE IS NOT APPLICABLE TO LISTS; - IF SI[SP].TYPE = LISTTYPE THEN SI[SP].TYPE ~ UNDEFINED; - GO TO NEXT; -SUBSCRIPT: - IF SI[SP].TYPE ! NUMBERTYPE THEN ERROR(6); - SP ~ SP - 1; - IF SI[SP].TYPE ! REFERENCETYPE THEN ERROR(7); - I1 ~ SI[SP].STATIC; SI[SP] ~ FI[SI[SP].ADDRESS]; - IF SI[SP].TYPE ! LISTTYPE THEN ERROR(8); - IF S[SP+1] < 1 OR S[SP+1] > SI[SP].WCT THEN ERROR(9); - SI[SP].ADDRESS ~ SI[SP].ADDRESS + S[SP+1] - 1; - SI[SP].TYPE ~ REFERENCETYPE; COMMENT MUST CREATE A REFERENCE; - SI[SP].STATIC ~ I1; GO TO NEXT; -BEGINV: - SPUP; - SI[SP] ~ 0; - SI[SP].TYPE ~ BLOCKMARK; - SI[SP].BLN ~ SI[MP].BLN + 1; - SI[SP].DYNAMIC ~ MP; - SI[SP].STATIC ~ MP; - S[SP].TYPE ~ LISTTYPE; - S[SP].ADDRESS ~ FP; - S[SP].WCT ~ 0; COMMENT A NULL LIST; - MP ~ SP; - GO TO NEXT; -ENDV: - I1 ~ SI[MP].DYNAMIC; - LEVELCHECK(SI[SP], SI[MP].STATIC); - SI[MP] ~ SI[SP]; - S[MP] ~ S[SP]; - SP ~ MP; - MP ~ I1; - GO TO NEXT; -LEFTQUOTE: COMMENT PROCEDURE DECLARATION; - SPUP; - SI[SP].TYPE ~ PROCEDURETYPE; - SI[SP].ADDRESS ~ PP; - COMMENT THE PROCEDURE DESCRIPTOR MUST SAVE ITS OWN LEXICOGRAPHICAL - LEVEL AS WELL AS THE STACK MARKER FOR UPLEVEL ADDRESSED VARIABLES; - SI[SP].BLN ~ SI[MP].BLN + 1; - SI[SP].STATIC ~ MP; - PP ~ PROGRAM[PP].BFIELD; - GO TO TRANSFER; -RIGHTQUOTE: - PP ~ SI[MP].ADDRESS; COMMENT A PROCEDURE RETURN; - I1 ~ SI[MP].DYNAMIC; - LEVELCHECK(SI[SP], SI[MP].STATIC); - SI[MP] ~ SI[SP]; - S[MP] ~ S[SP]; - SP ~ MP; - MP ~ I1; - GO TO NEXT; -VALUEOPERATOR: - IF SI[SP].TYPE = LISTTYPE THEN - GO TO NEXT; - FETCH; - IF SI[SP].TYPE = PROCEDURETYPE THEN - BEGIN - FORMALCOUNT ~ 0; - I1 ~ SI[SP].ADDRESS; - SI[SP].TYPE ~ BLOCKMARK; - SI[SP].ADDRESS ~ PP; - SI[SP].DYNAMIC ~ MP; - S[SP].TYPE ~ LISTTYPE; - S[SP].WCT ~ 0; - MP ~ SP; - PP ~ I1; - END - ELSE IF SI[SP].TYPE = LISTTYPE THEN - COPY(SI[SP]); - GO TO NEXT; -PROCEDURECALL: - SP ~ SP - 1; - FETCH; - IF SI[SP].TYPE ! PROCEDURETYPE THEN ERROR(3); - FORMALCOUNT ~ 0; - I1 ~ SI[SP].ADDRESS; - SI[SP].TYPE ~ BLOCKMARK; - SI[SP].ADDRESS ~ PP; - SI[SP].DYNAMIC ~ MP; - S[SP] ~ SI[SP+1]; COMMENT THE LIST DESC. FOR PARAMETERS; - MP ~ SP; - PP ~ I1; - GO TO NEXT; -RIGHTPAREN: - I1 ~ PROGRAM[PP].BFIELD; - IF I1 + FP > 1022 THEN FREE(I1); - SP ~ SP - I1 + 1; - MOVE(S[SP], F[FP], I1); - MOVE(SI[SP], FI[FP], I1); - SI[SP].TYPE ~ LISTTYPE; - SI[SP].WCT ~ I1; - SI[SP].ADDRESS ~ FP; - FP ~ FP + I1; - GO TO NEXT; -INPUT: - SPUP; - READ (CARDFIL, /, S[SP]) [EXIT]; - SI[SP].TYPE ~ NUMBERTYPE; - GO TO NEXT; -OUTPUT: - DUMPOUT(SI[SP], S[SP]); - GO TO NEXT; -INTEGERIZE: - GO TO NEXT; -DONE: - END INTERPRETER; - -EXIT: -END. -?DATA CARDFIL -BEGIN NEW FOR; NEW MAKE; NEW T; NEW A; -FOR ~ LQ FORMAL CV; FORMAL LB; FORMAL STEP; - FORMAL UB; FORMAL S; -BEGIN - LABEL L; LABEL K; - CV ~ LB; - K: IF CV { UB THEN S ELSE GOTO L; - CV ~ CV + STEP; - GOTO K; - L: 0 -END RQ; - -MAKE ~ LQ FORMAL B; FORMAL X; -BEGIN NEW T; NEW I; NEW F; NEW L; - L ~ B; T ~ LIST L[1]; - F ~ IF LENGTH L ! 1 THEN MAKE(TAIL L, X) ELSE X; - FOR (@I, 1, 1, L[1], LQ T[I] ~ F RQ); - T -END RQ; - - A ~ (); - FOR (@T, 1, 1, 4, LQ BEGIN A ~ A & (T); - OUT MAKE(@A,T) END RQ) -END $ -DUMP -?END +$ CARD LIST SINGLE XREF 00000010 +BEGIN COMMENT E U L E R IV S Y S T E M MARCH 1965; 00010000 + FILE IN CARDFIL (1,10); FILE PRINFIL 1 (1,15); 00020000 + INTEGER FT, LT; COMMENT INDEX OF FIRST AND LAST BASIC SYMBOL; 00030000 + INTEGER LP; COMMENT LENGTH OF PRODUCTION TABLE; 00040000 + ARRAY PROGRAM[0:1022]; 00050000 + DEFINE AFIELD =[39:9]#, BFIELD =[9:30]#, CFIELD =[1:8]#; 00060000 + LABEL EXIT; 00070000 + FT ~ 45; LT ~ 119; LP ~ 465; COMMENT DATA GENERATED BY SY-PR.; 00080000 + 00090000 +BEGIN COMMENT E U L E R IV TRANSLATOR N.WIRTH; 00100000 + DEFINE MARK =119#, IDSYM =63#, REFSYM =59#, LABSYM =62#; 00110000 + DEFINE VALSYM =56#, CALLSYM =55#, UNDEF =0#, NEWSYM =60#; 00120000 + DEFINE UNARYMINUS =116#, NUMSYM =68#, BOOLSYM =64#; 00130000 + DEFINE LISTSYM =102#, SYMSYM =113#, FORSYM =61#; 00140000 + DEFINE NAME =V[0]#; 00150000 + INTEGER I,J,K,M,N,R,T,T1,SCALE; BOOLEAN ERRORFLAG; 00160000 + INTEGER BN, ON; COMMENT BLOCK- AND ORDER-NUMBER; 00170000 + INTEGER NP; COMMENT NAME LIST POINTER; 00180000 + INTEGER MP; COMMENT MARK-POINTER OF NAME-LIST; 00190000 + INTEGER PRP; COMMENT PROGRAM POINTER; 00200000 + INTEGER WC, CC; COMMENT INPUT POINTERS; 00210000 + ALPHA ARRAY READBUFFER, WRITEBUFFER [0:14]; 00220000 + ALPHA ARRAY SYTB[0:LT]; COMMENT TABLE OF BASIC SYMBOLS; 00230000 + INTEGER ARRAY F, G [0:LT]; COMMENT PRIORITY FUNCTIONS; 00240000 + INTEGER ARRAY MTB[0:LT]; COMMENT SYNTAX MASTER TABLE; 00250000 + INTEGER ARRAY PRTB[0:LP]; COMMENT PRODUCTION TABLE; 00260000 + INTEGER ARRAY S[0:127]; COMMENT STACK; 00270000 + REAL ARRAY V[0:127]; COMMENT VALUE STACK; 00280000 + ALPHA ARRAY NL1[0:63]; COMMENT NAME LIST; 00290000 + INTEGER ARRAY NL2, NL3, NL4 [0:63]; 00300000 + LABEL A0,A1,A2,A3,A4,A5,A6,A7,A8,A9; 00310000 + LABEL L0, L1131, NAMEFOUND, 00320000 + L1,L2,L3,L4,L5,L6,L7,L8,L9,L10,L11,L12,L13,L14,L15,L16,L17,L18,L19, 00330000 + L20,L21,L22,L23,L24,L25,L26,L27,L28,L29,L30,L31,L32,L33,L34, 00340000 + L35,L36,L37,L38,L39,L40,L41,L42,L43,L44,L45,L46,L47,L48,L49,L50,L51, 00350000 + L52,L53,L54,L55,L56,L57,L58,L59,L60,L61,L62,L63,L64,L65,L66,L67,L68, 00360000 + L69,L70,L71,L72,L73,L74,L75,L76,L77,L78,L79,L80,L81,L82,L83,L84,L85, 00370000 + L86,L87,L88,L89,L90,L91,L92,L93,L94,L95,L96,L97,L98,L99,L100,L101, 00380000 + L102,L103,L104,L105,L106,L107,L108,L109,L110,L111,L112,L113,L114, 00390000 + L115,L116,L117,L118,L119,L120; 00400000 + SWITCH BRANCH ~ 00410000 + L1,L2,L3,L4,L5,L6,L7,L8,L9,L10,L11,L12,L13,L14,L15,L16,L17,L18,L19, 00420000 + L20,L21,L22,L23,L24,L25,L26,L27,L28,L29,L30,L31,L32,L33,L34, 00430000 + L35,L36,L37,L38,L39,L40,L41,L42,L43,L44,L45,L46,L47,L48,L49,L50,L51, 00440000 + L52,L53,L54,L55,L56,L57,L58,L59,L60,L61,L62,L63,L64,L65,L66,L67,L68, 00450000 + L69,L70,L71,L72,L73,L74,L75,L76,L77,L78,L79,L80,L81,L82,L83,L84,L85, 00460000 + L86,L87,L88,L89,L90,L91,L92,L93,L94,L95,L96,L97,L98,L99,L100,L101, 00470000 + L102,L103,L104,L105,L106,L107,L108,L109,L110,L111,L112,L113,L114, 00480000 + L115,L116,L117,L118,L119,L120; 00490000 + 00500000 +STREAM PROCEDURE ZERO(D); 00510000 + BEGIN DI ~ D; DS ~ 8 LIT "0"; 00520000 + END; 00530000 +STREAM PROCEDURE CLEAR(D); 00540000 + BEGIN DI ~ D; DS ~ 8 LIT " "; SI ~ D; DS ~ 14 WDS 00550000 + END; 00560000 +STREAM PROCEDURE MOVE(S,D); 00570000 + BEGIN SI ~ S; DI ~ D; DS ~ WDS; 00580000 + END; 00590000 +BOOLEAN STREAM PROCEDURE EQUAL(X,Y); 00600000 + BEGIN TALLY ~ 1; SI ~ X; DI ~ Y; IF 8 SC = DC THEN EQUAL ~ TALLY; 00610000 + END; 00620000 + 00630000 +INTEGER PROCEDURE INSYMBOL; 00640000 + COMMENT "INSYMBOL" READS THE NEXT EULER-SYMBOL FROM INPUT. 00650000 + STRINGS OF LETTERS AND DIGITS ARE RECOGNIZED AS IDENTIFIERS, IF 00660000 + THEY ARE NOT EQUAL TO AN EULER-IVWORD-DELIMITER. 00670000 + A CHARACTER-SEQUENCE ENCLOSED IN " IS RECOGNIZED AS A SYMBOL; 00680000 + BEGIN INTEGER I; LABEL A,B,C,D,E; 00690000 +STREAM PROCEDURE TRCH(S,M,D,N); VALUE M,N; 00700000 + BEGIN SI ~ S; SI ~ SI+M; DI ~ D; DI ~ DI+N; DS ~ CHR 00710000 + END; 00720000 +BOOLEAN STREAM PROCEDURE BLANK(S,N); VALUE N; 00730000 + BEGIN TALLY ~ 1; SI ~ S; SI ~ SI+N; IF SC = " " THEN BLANK ~ TALLY 00740000 + END; 00750000 +STREAM PROCEDURE BLANKOUT(D); 00760000 + BEGIN DI ~ D; DS ~ 8 LIT " "; 00770000 + END; 00780000 +BOOLEAN STREAM PROCEDURE QUOTE(S,N); VALUE N; 00790000 + BEGIN TALLY ~ 1; SI ~ S; SI ~ SI+N; IF SC = """ THEN QUOTE ~ TALLY 00800000 + END; 00810000 +BOOLEAN STREAM PROCEDURE LETTER(S,N); VALUE N; 00820000 + BEGIN TALLY ~ 1; SI ~ S; SI ~ SI+N; 00830000 + IF SC = ALPHA THEN 00840000 + BEGIN IF SC < "0" THEN LETTER ~ TALLY END 00850000 + END; 00860000 +BOOLEAN STREAM PROCEDURE LETTERORDIGIT(S,N); VALUE N; 00870000 + BEGIN TALLY ~ 1; SI ~ S; SI ~ SI+N; 00880000 + IF SC = ALPHA THEN LETTERORDIGIT ~ TALLY 00890000 + END; 00900000 +STREAM PROCEDURE EDIT(N,S,D); VALUE N; 00910000 + BEGIN SI ~ LOC N; DI ~ D; DS ~ 3 DEC; 00920000 + SI ~ S; DI ~ DI + 13; DS ~ 10 WDS 00930000 + END; 00940000 +PROCEDURE ADVANCE; 00950000 + COMMENT ADVANCES THE INPUT POINTER BY 1 CHARACTER POSITION; 00960000 + BEGIN IF CC = 7 THEN 00970000 + BEGIN IF WC = 8 THEN 00980000 + BEGIN READ (CARDFIL, 10, READBUFFER[*]) [EXIT]; 00990000 + EDIT(PRP+1, READBUFFER[0], WRITEBUFFER[0]); 01000000 + WRITE (PRINFIL, 15, WRITEBUFFER[*]); WC ~ 0 01010000 + END ELSE WC ~ WC+1; 01020000 + CC ~ 0; 01030000 + END 01040000 + ELSE CC ~ CC+1; 01050000 + END ADVANCE; 01060000 + 01070000 + BLANKOUT(NAME); 01080000 +A: IF BLANK(READBUFFER[WC], CC) THEN 01090000 + BEGIN ADVANCE; GO TO A END; 01100000 + IF LETTER(READBUFFER[WC], CC) THEN 01110000 + BEGIN FOR I ~ 0 STEP 1 UNTIL 7 DO 01120000 + BEGIN TRCH(READBUFFER[WC], CC, NAME, I); ADVANCE; 01130000 + IF NOT LETTERORDIGIT(READBUFFER[WC], CC) THEN GO TO C 01140000 + END; 01150000 +B: ADVANCE; 01160000 + IF LETTERORDIGIT(READBUFFER[WC], CC) THEN GO TO B; 01170000 +C: END 01180000 + ELSE IF QUOTE(READBUFFER[WC], CC) THEN 01190000 + BEGIN ADVANCE; ZERO(NAME); NAME ~ " "; 01200000 +E: TRCH(READBUFFER[WC], CC, I, 7); ADVANCE; 01210000 + IF I ! """ THEN 01220000 + BEGIN NAME ~ I.[42:6] & NAME [18:24:24]; GO TO E END 01230000 + ELSE I ~ SYMSYM; GO TO D 01240000 + END 01250000 + ELSE 01260000 + BEGIN TRCH(READBUFFER[WC], CC, NAME, 0); ADVANCE 01270000 + END; 01280000 + FOR I ~ FT STEP 1 UNTIL LT DO 01290000 + IF EQUAL(SYTB[I], NAME) THEN BEGIN ZERO(NAME); GO TO D END; 01300000 + I ~ IDSYM; 01310000 +D: INSYMBOL ~ I 01320000 + END INSYMBOL; 01330000 + 01340000 +PROCEDURE P1(X); VALUE X; INTEGER X; 01350000 + BEGIN PRP ~ PRP+1; PROGRAM[PRP] ~ X 01360000 + END; 01370000 +PROCEDURE P2(X,Y); VALUE X,Y; INTEGER X; REAL Y; 01380000 + BEGIN PRP ~ PRP+1; PROGRAM[PRP] ~ X; PROGRAM[PRP].BFIELD ~ Y; 01390000 + END; 01400000 +PROCEDURE P3(X,Y,Z); VALUE X,Y,Z; INTEGER X,Y,Z; 01410000 + BEGIN PRP ~ PRP+1; PROGRAM[PRP] ~ X; PROGRAM[PRP].BFIELD ~ Y; 01420000 + PROGRAM[PRP].CFIELD ~ Z 01430000 + END; 01440000 +PROCEDURE FIXUP(I,X); VALUE I,X; INTEGER I,X; 01450000 + PROGRAM[I].BFIELD ~ X; 01460000 +PROCEDURE ERROR(N); VALUE N; INTEGER N; 01470000 + BEGIN SWITCH FORMAT ERR ~ 01480000 + ("UNDECLARED IDENTIFIER"), 01490000 + ("NUMBER TOO LARGE"), 01500000 + ("LABEL IS DEFINED TWICE"), 01510000 + ("A LABEL IS NOT DECLARED"), 01520000 + ("LABEL DECLARED BUT NOT DEFINED"), 01530000 + ("PROGRAM SYNTACTICALLY INCORRECT"); 01540000 + ERRORFLAG ~ TRUE; 01550000 + WRITE (PRINFIL [NO], ERR[N]); WRITE (PRINFIL, , 01560000 + WC|8 + CC + 1) 01570000 + END ERROR; 01580000 + 01590000 +PROCEDURE PROGRAMDUMP; 01600000 + BEGIN REAL T; INTEGER I; LABEL L; 01610000 +STREAM PROCEDURE NUM(N,D); VALUE N; 01620000 + BEGIN DI ~ D; SI ~ LOC N; DS ~ 3 DEC 01630000 + END; 01640000 + 01650000 + READ (CARDFIL, , T) [L]; IF T ! "DUMP" THEN GO TO L; 01660000 + WRITE (PRINFIL, ); 01670000 + FOR I ~ 1 STEP 1 UNTIL PRP DO 01680000 + BEGIN CLEAR(WRITEBUFFER[0]); 01690000 + T ~ PROGRAM[I]; NUM(I, WRITEBUFFER[0]); 01700000 + MOVE(SYTB[T.AFIELD], WRITEBUFFER[1]); 01710000 + IF T.BFIELD ! 0 THEN NUM(T.BFIELD, WRITEBUFFER[2]); 01720000 + IF T.CFIELD ! 0 THEN NUM(T.CFIELD, WRITEBUFFER[3]); 01730000 + IF T.AFIELD = NUMSYM THEN 01740000 + BEGIN I ~ I+1; 01750000 + WRITE (PRINFIL [NO], , PROGRAM[I]) 01760000 + END; 01770000 + WRITE (PRINFIL, 15, WRITEBUFFER[*]); 01780000 + END; 01790000 +L: END PROGRAMDUMP; 01800000 + 01810000 + COMMENT INITIALISE THE SYMBOLTABLE, THE PRIORITY FUNCTIONS AND THE 01820000 + PRODUCTION TABLES WITH DATA GENERATED BY THE SYNTAX-PROCESSOR; 01830000 + FILL SYTB[*] WITH 0, 01840000 + "PROGRAM ","BLOCK ","BLOKHEAD","BLOKBODY","LABDEF ","STAT ", 01850000 + "STAT- ","EXPR ","EXPR- ","IFCLAUSE","TRUEPART","CATENA ", 01860000 + "DISJ ","DISJHEAD","CONJ ","CONJ- ","CONJHEAD","NEGATION", 01870000 + "RELATION","CHOICE ","CHOICE- ","SUM ","SUM- ","TERM ", 01880000 + "TERM- ","FACTOR ","FACTOR- ","PRIMARY ","PROCDEF ","PROCHEAD", 01890000 + "LIST* ","LISTHEAD","REFERENC","NUMBER ","REAL* ","INTEGER*", 01900000 + "INTEGER-","DIGIT ","LOGVAL ","VAR ","VAR- ","VARDECL ", 01910000 + "FORDECL ","LABDECL ","0 ","1 ","2 ","3 ", 01920000 + "4 ","5 ","6 ","7 ","8 ","9 ", 01930000 + ", ",". ","; ",": ","@ ","NEW ", 01940000 + "FORMAL ","LABEL ","IDENT* ","[ ","] ","BEGIN ", 01950000 + "END ","( ",") ","LQ ","RQ ","GOTO ", 01960000 + "OUT ","~ ","IF ","THEN ","ELSE ","& ", 01970000 + "OR ","AND ","NOT ","= ","! ","< ", 01980000 + "{ ","} ","> ","MIN ","MAX ","+ ", 01990000 + "- ","| ","/ ","% ","MOD ","* ", 02000000 + "ABS ","LENGTH ","INTEGER ","REAL ","LOGICAL ","LIST ", 02010000 + "TAIL ","IN ","ISB ","ISN ","ISR ","ISL ", 02020000 + "ISLI ","ISY ","ISP ","ISU ","SYMBOL* ","UNDEFINE", 02030000 + "TEN ","# ","TRUE ","FALSE ","$ "; 02040000 + FILL F[*] WITH 0, 02050000 + 1, 4, 19, 1, 2, 1, 2, 3, 4, 1, 4, 4, 02060000 + 5, 5, 5, 6, 6, 6, 7, 7, 8, 9, 10, 11, 02070000 + 11, 12, 12, 13, 13, 3, 13, 3, 13, 13, 13, 15, 02080000 + 17, 19, 13, 13, 15, 1, 1, 1, 19, 19, 19, 19, 02090000 + 19, 19, 19, 19, 19, 19, 19, 16, 21, 19, 13, 14, 02100000 + 14, 14, 16, 3, 16, 21, 5, 19, 13, 19, 13, 12, 02110000 + 4, 4, 3, 19, 19, 12, 19, 19, 7, 8, 8, 8, 02120000 + 8, 8, 8, 9, 9, 10, 10, 11, 11, 11, 11, 12, 02130000 + 12, 13, 12, 12, 12, 12, 12, 13, 13, 13, 13, 13, 02140000 + 13, 13, 13, 13, 13, 13, 16, 16, 13, 13, 5; 02150000 + FILL G[*] WITH 0, 02160000 + 1, 5, 6, 6, 3, 1, 2, 3, 4, 5, 1, 5, 02170000 + 5, 6, 6, 6, 7, 7, 7, 8, 9, 9, 10, 10, 02180000 + 11, 11, 12, 12, 13, 13, 13, 14, 13, 13, 13, 16, 02190000 + 17, 17, 13, 13, 14, 19, 3, 19, 18, 18, 18, 18, 02200000 + 18, 18, 18, 18, 18, 18, 3, 15, 1, 16, 13, 20, 02210000 + 4, 20, 14, 15, 3, 6, 1, 14, 3, 13, 3, 5, 02220000 + 5, 13, 5, 3, 3, 4, 5, 6, 7, 7, 7, 7, 02230000 + 7, 7, 7, 8, 8, 10, 10, 11, 11, 11, 11, 12, 02240000 + 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 02250000 + 13, 13, 13, 13, 13, 13, 13, 16, 13, 13, 4; 02260000 + FILL MTB[*] WITH 0, 02270000 + 1, 2, 5, 16, 25, 29, 30, 33, 39, 42, 47, 48, 02280000 + 55, 58, 62, 68, 71, 75, 81, 84, 111, 122, 125, 136, 02290000 + 139, 158, 161, 168, 171, 174, 183, 186, 198, 201, 204, 216, 02300000 + 223, 229, 232, 235, 245, 256, 257, 258, 259, 262, 265, 268, 02310000 + 271, 274, 277, 280, 283, 286, 289, 290, 291, 292, 293, 297, 02320000 + 301, 305, 309, 315, 320, 321, 324, 325, 328, 329, 332, 333, 02330000 + 337, 341, 342, 347, 348, 349, 350, 351, 352, 356, 357, 358, 02340000 + 359, 360, 361, 362, 363, 364, 368, 372, 373, 374, 375, 376, 02350000 + 377, 381, 385, 389, 393, 397, 401, 405, 408, 412, 416, 420, 02360000 + 424, 428, 432, 436, 440, 443, 446, 454, 455, 458, 461; 02370000 + FILL PRTB[*] WITH 0, 02380000 + 0,-103, 9, 0, 42, 57,-115, 3, 44, 57,-116, 3, 02390000 + -117, 4, 0, 6, 57,-118, 4, 6, 67,-119, 2, 0, 02400000 + 7,-110, 7, 0, 0,-112, 6, 0, 77,-101, 11,-111, 02410000 + 7, 0,-109, 8, 0, 11, 9,-104, 9, 0, 0, 78, 02420000 + 28, -99, 12,-108, 9, 0,-100, 12, 0, 13, -97, 13, 02430000 + 0, 79, -96, 14, -98, 13, 0, -95, 15, 0, 16, -93, 02440000 + 16, 0, 80, -92, 17, -94, 16, 0, -90, 18, 0, -83, 02450000 + 19, 82, 20, -84, 19, 83, 20, -85, 19, 84, 20, -86, 02460000 + 19, 85, 20, -87, 19, 86, 20, -88, 19, 87, 20, -89, 02470000 + 19, 0, 88, 22, -80, 21, 89, 22, -81, 21, -82, 20, 02480000 + 0, -79, 21, 0, 90, 24, -76, 23, 91, 24, -77, 23, 02490000 + -78, 22, 0, -73, 23, 0, 92, 26, -68, 25, 93, 26, 02500000 + -69, 25, 94, 26, -70, 25, 95, 26, -71, 25, -72, 24, 02510000 + 0, -67, 25, 0, 96, 28, -65, 27, -66, 26, 0, -64, 02520000 + 27, 0, -46, 28, 0, 43, 57, -35, 30, 8, 71, -37, 02530000 + 29, 0, -44, 28, 0, 8, 55, -31, 32, 8, 69, -33, 02540000 + 31, 69, -34, 31, 0, -43, 28, 0, -41, 28, 0, -25, 02550000 + 34, 115, 36, -26, 34, 115, 116, 36, -27, 34, 0, 56, 02560000 + 36, -23, 35, -24, 35, 0, 38, -21, 37, -22, 36, 0, 02570000 + -20, 37, 0, -40, 28, 0, -38, 28, 31, -39, 28, 74, 02580000 + 9,-105, 9, 0, 64, 8, 65, -5, 41, 56, -6, 41, 02590000 + -7, 40, 0, 0, 0, 0, -10, 38, 0, -11, 38, 0, 02600000 + -12, 38, 0, -13, 38, 0, -14, 38, 0, -15, 38, 0, 02610000 + -16, 38, 0, -17, 38, 0, -18, 38, 0, -19, 38, 0, 02620000 + 0, 0, 0, 0, 40, -30, 33, 0, 63, -1, 42, 0, 02630000 + 63, -2, 43, 0, 63, -3, 44, 0, -4, 41, 58,-113, 02640000 + 5, 0, 8, 65, -48, 28, 0, 0,-114, 3, 0, 0, 02650000 + -32, 32, 0, 0, -36, 30, 0, 0, 28,-106, 9, 0, 02660000 + 9,-107, 9, 0, 0, 8, 76,-102, 10, 0, 0, 0, 02670000 + 0, 0, 0, 19, -91, 18, 0, 0, 0, 0, 0, 0, 02680000 + 0, 0, 0, 24, -74, 23, 0, 24, -75, 23, 0, 0, 02690000 + 0, 0, 0, 0, 28, -58, 28, 0, 40, -59, 28, 0, 02700000 + 28, -60, 28, 0, 28, -61, 28, 0, 28, -62, 28, 0, 02710000 + 28, -63, 28, 0, 28, -45, 28, 0, -49, 28, 0, 40, 02720000 + -50, 28, 0, 40, -51, 28, 0, 40, -52, 28, 0, 40, 02730000 + -53, 28, 0, 40, -54, 28, 0, 40, -55, 28, 0, 40, 02740000 + -56, 28, 0, 40, -57, 28, 0, -42, 28, 0, -47, 28, 02750000 + 0, 36, -28, 34, 116, 36, -29, 34, 0, 0, -8, 39, 02760000 + 0, -9, 39, 0, 2, 119,-120, 1, 0; 02770000 + 02780000 + WC ~ 8; CC ~ 7; CLEAR(WRITEBUFFER[0]); CLEAR(READBUFFER[0]); 02790000 + S[0] ~ MARK; ERRORFLAG ~ FALSE; 02800000 + I ~ J ~ BN ~ ON ~ NP ~ PRP ~ 0; 02810000 + 02820000 + COMMENT ALGORITHM FOR SYNTACTIC ANALYSIS: 02830000 + COMPARE THE PRIORITIES OF THE SYMBOL R AND OF THE 02840000 + SYMBOL ON TOP OF THE STACK S. IF S[J]...S[I] CONSTITUTE A RIGHT- 02850000 + PART OF A PRODUCTION, THEN REPLACE THIS SEQUENCE BY THE 02860000 + CORRESPONDING LEFT-PART AND BRANCH TO THE INTERPRETATION-RULE 02870000 + BELONGING TO THE PERFORMED PRODUCTION; 02880000 +A0: R ~ INSYMBOL; 02890000 +A1: IF F[S[I]] > G[R] THEN GO TO A2; 02900000 + IF R = MARK THEN GO TO A9; 02910000 + I ~ J ~ I+1; S[I] ~ R; MOVE(NAME, V[I]); GO TO A0; 02920000 +A2: IF F[S[J-1]] = G[S[J]] THEN BEGIN J ~ J-1; GO TO A2 END; 02930000 + M ~ MTB[S[J]]; 02940000 +A3: IF PRTB[M] = 0 THEN BEGIN ERROR(5); GO TO EXIT END; 02950000 + N ~ J; 02960000 +A4: N ~ N+1; 02970000 + IF PRTB[M] < 0 THEN GO TO A8; 02980000 + IF N { I THEN GO TO A7; 02990000 +A5: M ~ M+1; 03000000 + IF PRTB[M] } 0 THEN GO TO A5; 03010000 +A6: M ~ M+2; GO TO A3; 03020000 +A7: IF PRTB[M] ! S[N] THEN GO TO A5; 03030000 + M ~ M+1; GO TO A4; 03040000 +A8: IF N { I THEN GO TO A6; 03050000 + GO TO BRANCH[-PRTB[M]]; 03060000 +L0: S[J] ~ PRTB[M+1]; I ~ J; GO TO A1; 03070000 + 03080000 + COMMENT THE FOLLOWING ARE THE INTERPRETATION-RULES; 03090000 +L1: 03100000 +L2: P1(S[J]); NP ~ NP+1; MOVE(V[I], NL1[NP]); ZERO(V[I]); 03110000 + NL2[NP] ~ BN; NL3[NP] ~ ON ~ ON+1; NL4[NP] ~ S[J]; GO TO L0; 03120000 +L3: NP ~ NP+1; MOVE(V[I], NL1[NP]); ZERO(V[I]); 03130000 + NL2[NP] ~ BN; NL3[NP] ~ NL4[NP] ~ UNDEF; GO TO L0; 03140000 +L4: FOR T ~ NP STEP -1 UNTIL 1 DO 03150000 + IF EQUAL(NL1[T], V[I]) THEN GO TO NAMEFOUND; 03160000 + ERROR(0); GO TO L0; 03170000 +NAMEFOUND: 03180000 + IF NL4[T] = NEWSYM THEN 03190000 + P3(REFSYM, NL3[T], NL2[T]) 03200000 + ELSE IF NL4[T] = LABSYM THEN 03210000 + P3(LABSYM, NL3[T], NL2[T]) 03220000 + ELSE IF NL4[T] = FORSYM THEN 03230000 + BEGIN P3(REFSYM, NL3[T], NL2[T]); P1(VALSYM) END 03240000 + ELSE 03250000 + BEGIN P3(LABSYM, NL3[T], NL2[T]); NL3[T] ~ PRP END; 03260000 + GO TO L0; 03270000 +L5: P1(S[I]); GO TO L0; 03280000 +L6: P1(VALSYM); GO TO L0; 03290000 +L10: 03300000 +L9: V[J] ~ 0; GO TO L0; 03310000 +L11: 03320000 +L8: V[J] ~ 1; GO TO L0; 03330000 +L12:V[J] ~ 2; GO TO L0; 03340000 +L13:V[J] ~ 3; GO TO L0; 03350000 +L14:V[J] ~ 4; GO TO L0; 03360000 +L15:V[J] ~ 5; GO TO L0; 03370000 +L16:V[J] ~ 6; GO TO L0; 03380000 +L17:V[J] ~ 7; GO TO L0; 03390000 +L18:V[J] ~ 8; GO TO L0; 03400000 +L19:V[J] ~ 9; GO TO L0; 03410000 +L20:SCALE ~ 1; GO TO L0; 03420000 +L21:V[J] ~ V[J] | 10 + V[I]; SCALE ~ SCALE+1; 03430000 + IF SCALE > 11 THEN ERROR(1); GO TO L0; 03440000 +L23:V[J] ~ V[I] | 10 * (-SCALE) + V[J]; GO TO L0; 03450000 +L26:V[J] ~ V[J] | 10 * V[I]; GO TO L0; 03460000 +L27:V[J] ~ V[J] | .1 * V[I]; GO TO L0; 03470000 +L28:V[J] ~ 10 * V[I]; GO TO L0; 03480000 +L29:V[J] ~ .1 * V[I]; GO TO L0; 03490000 +L31:V[J] ~ V[J]+1; GO TO L0; 03500000 +L32:V[J] ~ 0; GO TO L0; 03510000 +L33:P2(S[I], V[J]+1); GO TO L0; 03520000 +L34:P2(S[I], V[J]); GO TO L0; 03530000 +L36:BN ~ BN+1; ON ~ 0; P2(S[J], UNDEF); V[J] ~ PRP; 03540000 + NP ~ NP+1; ZERO(NL1[NP]); NL2[NP] ~ MP; MP ~ NP; GO TO L0; 03550000 +L37:P1(S[I]); FIXUP(V[J], PRP+1); NP ~ MP-1; MP ~ NL2[MP]; 03560000 + BN ~ BN-1; GO TO L0; 03570000 +L38:P1(VALSYM); GO TO L0; 03580000 +L39:P1(CALLSYM); GO TO L0; 03590000 +L40:P2(BOOLSYM, V[I]); GO TO L0; 03600000 +L41:P1(NUMSYM); PRP ~ PRP+1; PROGRAM[PRP] ~ V[I]; GO TO L0; 03610000 +L42:P2(S[I], V[I]); GO TO L0; 03620000 +L75:P1(UNARYMINUS); GO TO L0; 03630000 +L92: 03640000 +L96: 03650000 +L101: 03660000 +L102:P2(S[I], UNDEF); V[J] ~ PRP; GO TO L0; 03670000 +L93: 03680000 +L97: FIXUP(V[J], PRP+1); GO TO L0; 03690000 +L104:FIXUP(V[J], V[J+1]+1); FIXUP(V[J+1], PRP+1); GO TO L0; 03700000 +L113:FOR T ~ NP STEP -1 UNTIL MP+1 DO 03710000 + IF EQUAL(NL1[T], V[J]) THEN 03720000 + BEGIN IF NL4[T] ! UNDEF THEN ERROR(2); 03730000 + T1 ~ NL3[T]; NL3[T] ~ PRP+1; NL4[T] ~ LABSYM; ZERO(V[J]); 03740000 +L1131: IF T1 ! UNDEF THEN 03750000 + BEGIN T ~ PROGRAM[T1].BFIELD; FIXUP(T1, PRP+1); 03760000 + T1 ~ T; GO TO L1131 03770000 + END; GO TO L0; 03780000 + END; 03790000 + ERROR(3); GO TO L0; 03800000 +L114:BN ~ BN+1; ON ~ 0; P1(S[I]); 03810000 + NP ~ NP+1; ZERO(NL1[NP]); NL2[NP] ~ MP; MP ~ NP; GO TO L0; 03820000 +L118:P1(S[I]); GO TO L0; 03830000 +L119:FOR T ~ MP+1 STEP 1 UNTIL NP DO IF NL4[T] = UNDEF THEN ERROR(4); 03840000 + NP ~ MP-1; MP ~ NL2[MP]; P1(S[I]); BN ~ BN-1; GO TO L0; 03850000 + 03860000 +L45: 03870000 +L47: 03880000 +L49: 03890000 +L50: 03900000 +L51: 03910000 +L52: 03920000 +L53: 03930000 +L54: 03940000 +L55: 03950000 +L56: 03960000 +L57: 03970000 +L58: 03980000 +L59: 03990000 +L60: 04000000 +L61: 04010000 +L62: 04020000 +L63: 04030000 +L91: 04040000 +L106: 04050000 +L107:P1(S[J]); GO TO L0; 04060000 + 04070000 +L65: 04080000 +L68: 04090000 +L69: 04100000 +L70: 04110000 +L71: 04120000 +L76: 04130000 +L77: 04140000 +L80: 04150000 +L81: 04160000 +L84: 04170000 +L85: 04180000 +L86: 04190000 +L87: 04200000 +L88: 04210000 +L89: 04220000 +L99: 04230000 +L105:P1(S[J+1]); GO TO L0; 04240000 + 04250000 +L7: 04260000 +L22: 04270000 +L24: 04280000 +L25: 04290000 +L30: 04300000 +L35: 04310000 +L43: 04320000 +L44: 04330000 +L46: 04340000 +L48: 04350000 +L64: 04360000 +L66: 04370000 +L67: 04380000 +L72: 04390000 +L73: 04400000 +L74: 04410000 +L78: 04420000 +L79: 04430000 +L82: 04440000 +L83: 04450000 +L90: 04460000 +L94: 04470000 +L95: 04480000 +L98: 04490000 +L100: 04500000 +L103: 04510000 +L108: 04520000 +L109: 04530000 +L110: 04540000 +L111: 04550000 +L112: 04560000 +L115: 04570000 +L116: 04580000 +L117: 04590000 +L120:GO TO L0; 04600000 + 04610000 +A9: P1(MARK); PROGRAMDUMP; IF ERRORFLAG THEN GO TO EXIT 04620000 +END * ; 04630000 + 50000000 +BEGIN COMMENT E U L E R IV INTERPRETER MCKEEMAN & WIRTH; 50010000 + REAL ARRAY S, SI, F, FI[0:1022]; COMMENT STACK; 50020000 + INTEGER I1, I2, LVL, FORMALCOUNT; 50030000 + INTEGER SP; COMMENT TOP-STACK POINTER; 50040000 + INTEGER FP; COMMENT FREE STORAGE SPACE POINTER; 50050000 + INTEGER MP; COMMENT BLOCK- OR PROCEDURE-MARK POINTER; 50060000 + INTEGER PP; COMMENT PROGRAM POINTER; 50070000 + LABEL ADD, SUB, MUL, DIVIDE, IDIV, REMAINDER, POWER, NEG, ABSV, 50080000 + INTEGERIZE, REALL, LOGICAL, MIN, MAX, EQL, NEQ, LSS, LEQ, GEQ, GTR, 50090000 + LENGTH, ISLOGICAL, ISNUMBER, ISREFERENCE, ISLABEL, ISSYMBOL, 50100000 + ISLIST, ISPROCEDURE, ISUNDEFINED, LAND, LOR, LNOT, LEFTQUOTE, 50110000 + RIGHTQUOTE, RIGHTPAREN, REFERENCE, PROCEDURECALL, VALUEOPERATOR, 50120000 + GOTO, NEW, FORMAL, BEGINV, ENDV, STORE, THENV, ELSEV, NUMBER, LOGVAL,50130000 + LABELL, SUBSCRIPT, SEMICOLON, UNDEFIND, OUTPUT, INPUT, TAIL, 50140000 + CATENATE, LISTT, SYMBOL, DONE, UNDEFINEDOPERATOR, NEXT, TRANSFER; 50150000 + 50160000 +COMMENT SI AND FI FIELD DEFINITIONS 50170000 + 1-4 8-17 18-27 28-37 38-47 48-97 50180000 +NUMBER TYPE VALUE 50190000 +BOOLEAN TYPE VALUE 50200000 +SYMBOL TYPE VALUE 50210000 +UNDEFINED TYPE 50220000 +LIST TYPE LENGTH ADDRESS 50230000 +REFERENCE TYPE MARK ADDRESS 50240000 +LABEL TYPE MARK ADDRESS 50250000 +BLOCKMARK TYPE DYNAMIC BLOCK NO. STATIC ADDRESS LIST; 50260000 + 50270000 + DEFINE TYPE=[1:4]#, 50280000 + WCT=[28:10]#, 50290000 + ADDRESS=[38:10]#, 50300000 + STATIC=[28:10]#, 50310000 + DYNAMIC=[8:10]#, 50320000 + BLN=[18:10]#, 50330000 + NSA=[18:10]#; COMMENT NEW STARTING ADDRESS FOR FREE; 50340000 + DEFINE UNDEFINED=0#, 50350000 + NUMBERTYPE=1#, 50360000 + SYMBOLTYPE=2#, 50370000 + BOOLEANTYPE=3#, 50380000 + LABELTYPE=4#, 50390000 + REFERENCETYPE=5#, 50400000 + PROCEDURETYPE=6#, 50410000 + LISTTYPE=7#, 50420000 + BLOCKMARK=8#; 50430000 + 50440000 +STREAM PROCEDURE MOVE(F1, T1, W); 50450000 + BEGIN LOCAL R1, R2; 50460000 + SI ~ W; SI ~ SI + 6; 50470000 + DI ~ LOC R1; DI ~ DI + 7; DS ~ CHR; 50480000 + DI ~ LOC R2; DI ~ DI + 7; DS ~ CHR; 50490000 + SI ~ F1; DI ~ T1; 50500000 + R1(2(DS ~ 32 WDS)); DS ~ R2 WDS; 50510000 + END; 50520000 + 50530000 +PROCEDURE DUMPOUT(XI, X); VALUE XI, X; REAL XI, X; 50540000 + BEGIN INTEGER T, I; 50550000 + 50560000 +PROCEDURE LISTOUT(XI); VALUE XI; REAL XI; 50570000 + BEGIN COMMENT RECURSIVE LIST OUTPUT; 50580000 + INTEGER I, N; 50590000 + SWITCH FORMAT LPAR ~ 50600000 + ("("), (".("), ("..("),("...("), ("....("), (".....("), ("......("); 50610000 + SWITCH FORMAT RPAR ~ 50620000 + (")"), (".)"), ("..)"),("...)"), ("....)"), (".....)"), ("......)"); 50630000 + WRITE (PRINFIL, , XI.ADDRESS); 50640000 + WRITE (PRINFIL [NO], LPAR[LVL]); 50650000 + LVL ~ LVL + 1; N ~ XI.ADDRESS + XI.WCT - 1; 50660000 + FOR I ~ XI.ADDRESS STEP 1 UNTIL N DO DUMPOUT(FI[I], F[I]); 50670000 + LVL ~ LVL - 1; WRITE (PRINFIL, RPAR[LVL]); 50680000 + END LISTOUT; 50690000 + 50700000 + T ~ XI.TYPE; 50710000 + IF T = UNDEFINED THEN 50720000 + WRITE (PRINFIL, ) 50730000 + ELSE IF T = NUMBERTYPE THEN 50740000 + BEGIN 50750000 + IF X ! ENTIER(X) THEN 50760000 + WRITE (PRINFIL, , X) 50770000 + ELSE 50780000 + WRITE (PRINFIL, , X) 50790000 + END 50800000 + ELSE IF T = BOOLEANTYPE THEN 50810000 +WRITE (PRINFIL, , BOOLEAN(X)) 50820000 + ELSE IF T = LISTTYPE THEN LISTOUT(XI) 50830000 + ELSE IF T = LABELTYPE THEN 50840000 +WRITE (PRINFIL, , X) 50990000 + END DUMPOUT; 51000000 + 51010000 +PROCEDURE ERROR(N); VALUE N; INTEGER N; 51020000 + BEGIN INTEGER I; 51030000 + SWITCH FORMAT ER ~ 51040000 + ("ILLEGAL INSTRUCTION ENCOUNTERED"), 51050000 + ("IMPROPER OPERAND TYPE"), 51060000 + ("CANNOT DIVIDE BY 0"), 51070000 + ("CALL OPERATOR DID NOT FIND A PROCEDURE"), 51080000 + ("REFERENCE OR LABEL OUT OF SCOPE"), 51090000 + ("OUT OF SCOPE ASSIGNMENT OF A LABEL OR A REFERENCE"), 51100000 + ("SUBSCRIPT IS NOT A NUMBER"), 51110000 + ("SUBSCRIPT NOT APPLIED TO A VARIABLE"), 51120000 + ("SUBSCRIPTED VARIABLE IS NOT A LIST"), 51130000 + ("SUBSCRIPT IS OUT OF BOUNDS"), 51140000 + ("CANNOT TAKE TAIL OF A NULL LIST"), 51150000 + ("STACK OVERFLOW"), 51160000 + ("STACK OVERFLOW DURING GARBAGE COLLECTION"), 51170000 + ("ASSIGNMENT TO A NON-VARIABLE ATTEMPTED"), 51180000 + ("FREE STORAGE AREA IS TOO SMALL"); 51190000 + WRITE (PRINFIL [DBL], ER[N]); 51200000 +WRITE (PRINFIL, 51210000 + , 51220000 + SP, FP, PP, MP, PROGRAM[PP].AFIELD); 51230000 + FOR I ~ 1 STEP 1 UNTIL SP DO 51240000 + BEGIN WRITE(PRINFIL [NO], , I); 51250000 + DUMPOUT(SI[I], S[I]) 51260000 + END; 51270000 + GO TO DONE 51280000 + END ERROR; 51290000 + 51300000 +PROCEDURE FREE(NEED); VALUE NEED; INTEGER NEED; 51310000 + COMMENT "FREE" IS A "GARBAGE COLLECTION" PROCEDURE. IT IS CALLED 51320000 + WHEN FREE STORAGE F IS USED UP, AND MORE SPACE IS NEEDED. 51330000 + GARBAGE COLLECTION TAKES THE FOLLOWING STEPS: 51340000 + 1. ALL BLOCKMARKS, LIST DESCRIPTORS AND REFERENCES IN STACK 51350000 + POINT TO VALID INFORMATION IN FREE STORAGE. LIKEWISE, ALL 51360000 + LIST DESCRIPTORS AND REFERENCES THAT ARE POINTED TO ARE VALID, 51370000 + ENTER INTO THE STACK ALL SUCH ENTITIES. 51380000 + 2. THE GARBAGE COLLECTOR MUST KNOW IN WHICH ORDER TO COLLAPSE THE 51390000 + FREE STORAGE. THUS SORT THE LIST BY FREE STORAGE ADDRESS. 51400000 + 3. MOVE EACH BLOCK DOWN IF NECESSARY. 51410000 + 4. NOW THE ADDRESSES ARE WRONG--MAKE ONE MORE PASS THROUGH THE 51420000 + SORTED LIST TO UPDATE ALL ADDRESSES; 51430000 + BEGIN OWN INTEGER G, H, I, J; OWN REAL T; 51440000 + 51450000 +INTEGER PROCEDURE FIND(W); VALUE W; REAL W; 51460000 + BEGIN COMMENT BINARY SEARCH THROUGH ORDERED TABLE; 51470000 + INTEGER T, N, B, KEY, K; 51480000 + LABEL FOUND, BINARY; 51490000 + T ~ G+1; B ~ SP + 1; 51500000 + KEY ~ W.ADDRESS; 51510000 +BINARY: N ~ (B+T) DIV 2; 51520000 + K ~ SI[N].ADDRESS; 51530000 + IF K = KEY THEN GO TO FOUND; 51540000 + IF K < KEY THEN B ~ N ELSE T ~ N; 51550000 + GO TO BINARY; 51560000 +FOUND: FIND ~ SI[N].NSA 51570000 + END FIND; 51580000 + 51590000 +PROCEDURE RESET(W, Z); REAL W, Z; 51600000 + BEGIN INTEGER TY; 51610000 + TY ~ W.TYPE; 51620000 + IF TY = REFERENCETYPE OR TY = LISTTYPE THEN 51630000 + W.ADDRESS ~ FIND(W) 51640000 + ELSE IF TY = BLOCKMARK THEN 51650000 + Z.ADDRESS ~ FIND(Z) 51660000 + END RESET; 51670000 + 51680000 +PROCEDURE VALIDATE(P); VALUE P; REAL P; 51690000 + BEGIN COMMENT TREE SEARCH FOR ACTIVE LIST STORAGE; 51700000 + INTEGER I, U; 51710000 + G ~ G + 1; 51720000 + IF G > 1022 THEN ERROR(12); 51730000 + SI[G] ~ P; 51740000 + U ~ P.ADDRESS + P.WCT - 1; 51750000 + IF P.TYPE = LISTTYPE THEN 51760000 + FOR I ~ P.ADDRESS STEP 1 UNTIL U DO 51770000 + IF FI[I].TYPE = LISTTYPE OR FI[I].TYPE = REFERENCETYPE THEN51780000 + VALIDATE(FI[I]); 51790000 + END VALIDATION; 51800000 + 51810000 +PROCEDURE SORT(LB, UB); VALUE LB, UB; INTEGER LB, UB; 51820000 + BEGIN COMMENT BINARY SORT; 51830000 + INTEGER M; 51840000 + 51850000 +PROCEDURE MERGE(LB, M, UB); VALUE LB, M, UB; INTEGER LB, M, UB; 51860000 + BEGIN INTEGER K,L,U,K1,K2; LABEL A, B; 51870000 + K ~ UB - LB; 51880000 + MOVE(SI[LB], S[LB], K); 51890000 + L ~ K ~ LB; U ~ M; GO TO B; 51900000 +A: K1 ~ S[L].ADDRESS; K2 ~ S[U].ADDRESS; 51910000 + IF K1 < K2 OR (K1 = K2 AND S[L].TYPE = LISTTYPE) THEN 51920000 + BEGIN SI[K] ~ S[L]; L ~ L+1 END 51930000 + ELSE 51940000 + BEGIN SI[K] ~ S[U]; U ~ U+1 END; 51950000 + K ~ K + 1; 51960000 +B: IF L = M THEN 51970000 + ELSE IF U = UB THEN 51980000 + BEGIN K ~ M-L; MOVE(S[L], SI[UB-K], K) END 51990000 + ELSE 52000000 + GO TO A 52010000 + END MERGE; 52020000 + 52030000 + IF LB < UB THEN 52040000 + BEGIN M ~ (LB+UB) DIV 2; 52050000 + SORT(LB, M); SORT(M+1, UB); MERGE(LB, M+1, UB+1) 52060000 + END 52070000 + END SORT; 52080000 + 52090000 + INTEGER LLA, LLW; 52100000 + G ~ SP; 52110000 + FOR H ~ 1 STEP 1 UNTIL SP DO 52120000 + BEGIN COMMENT LOCATE ALL ACTIVE LISTS AND REFERENCES; 52130000 + IF SI[H].TYPE = LISTTYPE OR SI[H].TYPE = REFERENCETYPE THEN 52140000 + VALIDATE(SI[H]) 52150000 + ELSE IF SI[H].TYPE = BLOCKMARK THEN 52160000 + VALIDATE(S[H]); 52170000 + END 52180000 + COMMENT SORT THEM IN ORDER OF INCREASING ADDRESS; 52190000 + SORT(SP+1, G); 52200000 + I ~ 1; COMMENT COLLAPSE THE FREE STORAGE; 52210000 + FOR J ~ SP+1 STEP 1 UNTIL G DO 52220000 + IF SI[J].TYPE = LISTTYPE THEN 52230000 + BEGIN COMMENT IF G.C. OCCURS DURING "COPY" THEN WE MUST AVOID52240000 + THE CREATION OF DOUBLE LIST ENTRIES FROM DUPLICATED DESCRIP52250000 + IF SI[J] = SI[J+1] THEN SI[J+1].TYPE ~ UNDEFINED; 52260000 + LLA ~ SI[J].ADDRESS; LLW ~ SI[J].WCT; 52270000 + IF LLA ! I THEN 52280000 + BEGIN 52290000 + MOVE(F[LLA], F[I], LLW); 52300000 + MOVE(FI[LLA], FI[I], LLW); 52310000 + END; 52320000 + SI[J].NSA ~ I; 52330000 + I ~ I + LLW; 52340000 + END 52350000 + ELSE 52360000 + SI[J].NSA ~ I - LLW + SI[J].ADDRESS - LLA; 52370000 + FP ~ I; 52380000 + 52390000 + COMMENT RESET ALL AFFECTED ADDRESSES; 52400000 + FOR I ~ 1 STEP 1 UNTIL SP DO RESET(SI[I], S[I]); 52410000 + FOR I ~ 1 STEP 1 UNTIL FP-1 DO RESET(FI[I], F[I]); 52420000 + IF FP + NEED > 1022 THEN ERROR(14); 52430000 + END FREE; 52440000 + 52450000 +PROCEDURE MOVESEG(LD); REAL LD; 52460000 + BEGIN COMMENT MOVE ONE LIST SEGMENT; 52470000 + INTEGER W, X; 52480000 + W ~ LD.WCT; 52490000 + IF FP + W > 1022 THEN FREE(W); 52500000 + X ~ LD.ADDRESS; 52510000 + MOVE(F[X], F[FP], W); 52520000 + MOVE(FI[X], FI[FP], W); 52530000 + LD.ADDRESS ~ FP; 52540000 + FP ~ FP + W; 52550000 + END MOVE SEGMENT; 52560000 + 52570000 +PROCEDURE COPY(LD); REAL LD; 52580000 + BEGIN INTEGER I, J; COMMENT RECURSIVE LIST COPY; 52590000 + MOVESEG(LD); 52600000 + J ~ LD.WCT - 1; 52610000 + FOR I ~ 0 STEP 1 UNTIL J DO 52620000 + IF FI[I+LD.ADDRESS].TYPE = LISTTYPE THEN COPY(FI[I+LD.ADDRESS])52630000 + END COPY; 52640000 + 52650000 +PROCEDURE BOOLTEST; IF SI[SP].TYPE ! BOOLEANTYPE THEN ERROR(1); 52660000 + 52670000 +INTEGER PROCEDURE ROUND(X); VALUE X; REAL X; ROUND ~ X; 52680000 + 52690000 +PROCEDURE BARITH; 52700000 + BEGIN 52710000 + IF SI[SP].TYPE ! NUMBERTYPE OR SI[SP-1].TYPE ! NUMBERTYPE THEN 52720000 + ERROR(1) 52730000 + ELSE 52740000 + SP ~ SP-1; 52750000 + END BARITH; 52760000 + 52770000 +PROCEDURE FETCH; 52780000 + BEGIN INTEGER I; 52790000 + IF SI[SP].TYPE = REFERENCETYPE THEN 52800000 + BEGIN I ~ SI[SP].ADDRESS; SI[SP] ~ FI[I]; S[SP] ~ F[I] END 52810000 + END FETCH; 52820000 + 52830000 +INTEGER PROCEDURE MARKINDEX(BL); VALUE BL; INTEGER BL; 52840000 + BEGIN COMMENT MARKINDEX IS THE INDEX OF THE MARK WITH BLOCKNUMBER BL;52850000 + LABEL U1; INTEGER I; 52860000 + I ~ MP; 52870000 +U1: IF SI[I].BLN > BL THEN 52880000 + BEGIN I ~ SI[I].STATIC; GO TO U1 END; 52890000 + IF SI[I].BLN < BL THEN ERROR(4); 52900000 + MARKINDEX ~ I 52910000 + END MARKINDEX; 52920000 + 52930000 +PROCEDURE LEVELCHECK(X, Y); VALUE Y; INTEGER Y; REAL X; 52940000 + BEGIN INTEGER T, I, L, U; T ~ X.TYPE; 52950000 + IF T = REFERENCETYPE OR T = LABELTYPE THEN 52960000 + BEGIN IF X.STATIC > Y THEN ERROR(5) END 52970000 + ELSE IF T = PROCEDURETYPE THEN 52980000 + X.STATIC ~ Y 52990000 + ELSE IF T = LISTTYPE THEN 53000000 + BEGIN 53010000 + L ~ X.ADDRESS; U ~ L + X.WCT - 1; 53020000 + FOR I ~ L STEP 1 UNTIL U DO LEVELCHECK(FI[I], Y) 53030000 + END 53040000 + END LEVEL CHECK; 53050000 + 53060000 +PROCEDURE SPUP; IF SP } 1022 THEN ERROR(11) ELSE SP ~ SP + 1; 53070000 + 53080000 +PROCEDURE SETIS(V); VALUE V; INTEGER V; 53090000 + BEGIN 53100000 + FETCH; 53110000 + S[SP] ~ REAL(SI[SP].TYPE = V); 53120000 + SI[SP].TYPE ~ BOOLEANTYPE; 53130000 + END SET IS; 53140000 + 53150000 + SWITCH EXECUTE ~ 53160000 + PROCEDURECALL, VALUEOPERATOR, SEMICOLON, UNDEFINEDOPERATOR, 53170000 + REFERENCE, NEW, FORMAL, LABELL, UNDEFINEDOPERATOR, LOGVAL, 53180000 + SUBSCRIPT, BEGINV, ENDV, NUMBER, RIGHTPAREN, LEFTQUOTE, RIGHTQUOTE,53190000 + GOTO, OUTPUT, STORE, UNDEFINEDOPERATOR, THENV, ELSEV, CATENATE, 53200000 + LOR, LAND, LNOT, EQL, NEQ, LSS, LEQ, GEQ, GTR, MIN, MAX, 53210000 + ADD, SUB, MUL, DIVIDE, IDIV, REMAINDER, POWER, ABSV, LENGTH, 53220000 + INTEGERIZE, REALL, LOGICAL, LISTT, TAIL, INPUT, 53230000 + ISLOGICAL, ISNUMBER, ISREFERENCE, ISLABEL, ISLIST, ISSYMBOL, 53240000 + ISPROCEDURE, ISUNDEFINED, SYMBOL, UNDEFIND, UNDEFINEDOPERATOR, NEG,53250000 + UNDEFINEDOPERATOR, UNDEFINEDOPERATOR, DONE; 53260000 + 53270000 + WRITE (PRINFIL [PAGE]); 53280000 + SP ~ MP ~ PP ~ 0; FP ~ 1; LVL ~ 0; FT ~ FT+9; 53290000 + 53300000 +NEXT: 53310000 + PP ~ PP+1; 53320000 +TRANSFER: 53330000 + GO TO EXECUTE[PROGRAM[PP].AFIELD - FT]; 53340000 + 53350000 +UNDEFINEDOPERATOR: 53360000 + ERROR(0); 53370000 +SEMICOLON: 53380000 + SP ~ SP - 1; 53390000 + GO TO NEXT; 53400000 +UNDEFIND: 53410000 + SPUP; 53420000 + SI[SP].TYPE ~ UNDEFINED; 53430000 + GO TO NEXT; 53440000 +NUMBER: 53450000 + PP ~ PP + 1; 53460000 + SPUP; 53470000 + SI[SP].TYPE ~ NUMBERTYPE; 53480000 + S[SP] ~ PROGRAM[PP]; 53490000 + GO TO NEXT; 53500000 +SYMBOL: 53510000 + SPUP; 53520000 + SI[SP].TYPE ~ SYMBOLTYPE; 53530000 + S[SP] ~ PROGRAM[PP].BFIELD; 53540000 + GO TO NEXT; 53550000 +LOGVAL: 53560000 + SPUP; 53570000 + SI[SP].TYPE ~ BOOLEANTYPE; 53580000 + S[SP] ~ PROGRAM[PP].BFIELD; 53590000 + GO TO NEXT; 53600000 +REFERENCE: 53610000 + SPUP; 53620000 + SI[SP] ~ 0; 53630000 + SI[SP].TYPE ~ REFERENCETYPE; 53640000 + SI[SP].STATIC ~ I1 ~ MARKINDEX(PROGRAM[PP].CFIELD); 53650000 + SI[SP].ADDRESS ~ S[I1].ADDRESS + PROGRAM[PP].BFIELD - 1; 53660000 + GO TO NEXT; 53670000 +LABELL: 53680000 + SPUP; 53690000 + SI[SP].TYPE ~ LABELTYPE; 53700000 + SI[SP].STATIC ~ MARKINDEX(PROGRAM[PP].CFIELD); 53710000 + SI[SP].ADDRESS ~ PROGRAM[PP].BFIELD; 53720000 + GO TO NEXT; 53730000 +CATENATE: 53740000 + IF SI[SP].TYPE ! LISTTYPE OR SI[SP-1].TYPE ! LISTTYPE THEN ERROR(1); 53750000 + IF SI[SP-1].ADDRESS + SI[SP-1].WCT ! SI[SP].ADDRESS THEN 53760000 + BEGIN COMMENT MUST HAVE CONTIGUOUS LISTS; 53770000 + MOVESEG(SI[SP-1]); 53780000 + MOVESEG(SI[SP]); 53790000 + END; 53800000 + SP ~ SP - 1; 53810000 + SI[SP].WCT ~ SI[SP].WCT + SI[SP+1].WCT; 53820000 + GO TO NEXT; 53830000 +LOR: 53840000 + BOOLTEST; 53850000 + IF NOT BOOLEAN(S[SP]) THEN 53860000 + BEGIN 53870000 + SP ~ SP - 1; 53880000 + GO TO NEXT 53890000 + END; 53900000 + PP ~ PROGRAM[PP].BFIELD; 53910000 + GO TO TRANSFER; 53920000 +LAND: 53930000 + BOOLTEST; 53940000 + IF BOOLEAN(S[SP]) THEN 53950000 + BEGIN 53960000 + SP ~ SP - 1; 53970000 + GO TO NEXT 53980000 + END; 53990000 + PP ~ PROGRAM[PP].BFIELD; 54000000 + GO TO TRANSFER; 54010000 +LNOT: 54020000 + BOOLTEST; 54030000 + S[SP] ~ REAL(NOT BOOLEAN(S[SP])); 54040000 + GO TO NEXT; 54050000 +LSS: 54060000 + BARITH; 54070000 + S[SP] ~ REAL(S[SP] < S[SP+1]); 54080000 + SI[SP].TYPE ~ BOOLEANTYPE; 54090000 + GO TO NEXT; 54100000 +LEQ: 54110000 + BARITH; 54120000 + S[SP] ~ REAL(S[SP] { S[SP+1]); 54130000 + SI[SP].TYPE ~ BOOLEANTYPE; 54140000 + GO TO NEXT; 54150000 +EQL: 54160000 + BARITH; 54170000 + S[SP] ~ REAL(S[SP] = S[SP+1]); 54180000 + SI[SP].TYPE ~ BOOLEANTYPE; 54190000 + GO TO NEXT; 54200000 +NEQ: 54210000 + BARITH; 54220000 + S[SP] ~ REAL(S[SP] ! S[SP+1]); 54230000 + SI[SP].TYPE ~ BOOLEANTYPE; 54240000 + GO TO NEXT; 54250000 +GEQ: 54260000 + BARITH; 54270000 + S[SP] ~ REAL(S[SP] } S[SP+1]); 54280000 + SI[SP].TYPE ~ BOOLEANTYPE; 54290000 + GO TO NEXT; 54300000 +GTR: 54310000 + BARITH; 54320000 + S[SP] ~ REAL(S[SP] > S[SP+1]); 54330000 + SI[SP].TYPE ~ BOOLEANTYPE; 54340000 + GO TO NEXT; 54350000 +MIN: 54360000 + BARITH; 54370000 + IF S[SP+1] < S[SP] THEN S[SP] ~ S[SP+1]; 54380000 + GO TO NEXT; 54390000 +MAX: 54400000 + BARITH; 54410000 + IF S[SP+1] > S[SP] THEN S[SP] ~ S[SP+1]; 54420000 + GO TO NEXT; 54430000 +ADD: 54440000 + BARITH; 54450000 + S[SP] ~ S[SP] + S[SP+1]; 54460000 + GO TO NEXT; 54470000 +SUB: 54480000 + BARITH; 54490000 + S[SP] ~ S[SP] - S[SP+1]; 54500000 + GO TO NEXT; 54510000 +NEG: 54520000 + IF SI[SP].TYPE ! NUMBERTYPE THEN ERROR(1); 54530000 + S[SP] ~ -S[SP]; 54540000 + GO TO NEXT; 54550000 +MUL: 54560000 + BARITH; 54570000 + S[SP] ~ S[SP] | S[SP+1]; 54580000 + GO TO NEXT; 54590000 +DIVIDE: 54600000 + BARITH; 54610000 + IF S[SP+1] = 0 THEN ERROR(2); 54620000 + S[SP] ~ S[SP] / S[SP+1]; 54630000 + GO TO NEXT; 54640000 +IDIV: 54650000 + BARITH; 54660000 + IF ROUND(S[SP+1]) = 0 THEN ERROR(2); 54670000 + S[SP] ~ ROUND(S[SP]) DIV ROUND(S[SP+1]); 54680000 + GO TO NEXT; 54690000 +REMAINDER: 54700000 + BARITH; 54710000 + IF S[SP+1] = 0 THEN ERROR(2); 54720000 + S[SP] ~ S[SP] MOD S[SP+1]; 54730000 + GO TO NEXT; 54740000 +POWER: 54750000 + BARITH; 54760000 + S[SP] ~ S[SP] * S[SP+1]; 54770000 + GO TO NEXT; 54780000 +ABSV: 54790000 + IF SI[SP].TYPE ! NUMBERTYPE THEN ERROR(1); 54800000 + S[SP] ~ ABS(S[SP]); 54810000 + GO TO NEXT; 54820000 +REALL: 54830000 + IF SI[SP].TYPE > BOOLEANTYPE THEN ERROR(1); 54840000 + SI[SP].TYPE ~ NUMBERTYPE; 54850000 + GO TO NEXT; 54860000 +LOGICAL: 54870000 + IF SI[SP].TYPE ! NUMBERTYPE THEN ERROR(1); 54880000 + IF S[SP] = 0 OR S[SP] = 1 THEN 54890000 + SI[SP].TYPE ~ BOOLEANTYPE 54900000 + ELSE 54910000 + SI[SP].TYPE ~ UNDEFINED; 54920000 + GO TO NEXT; 54930000 +LISTT: 54940000 + IF SI[SP].TYPE ! NUMBERTYPE THEN ERROR(1); 54950000 + I2 ~ S[SP]; 54960000 + IF I2 + FP > 1022 THEN FREE(I2); 54970000 + FOR I1 ~ FP STEP 1 UNTIL FP+I2-1 DO 54980000 + FI[I1].TYPE ~ UNDEFINED; 54990000 + SI[SP].TYPE ~ LISTTYPE; 55000000 + SI[SP].WCT ~ I2; 55010000 + SI[SP].ADDRESS ~ FP; 55020000 + FP ~ FP + I2; 55030000 + GO TO NEXT; 55040000 + 55050000 +ISLOGICAL: 55060000 + SETIS(BOOLEANTYPE); 55070000 + GO TO NEXT; 55080000 +ISNUMBER: 55090000 + SETIS(NUMBERTYPE); 55100000 + GO TO NEXT; 55110000 +ISREFERENCE: 55120000 + SETIS(REFERENCETYPE); 55130000 + GO TO NEXT; 55140000 +ISLABEL: 55150000 + SETIS(LABELTYPE); 55160000 + GO TO NEXT; 55170000 +ISLIST: 55180000 + SETIS(LISTTYPE); 55190000 + GO TO NEXT; 55200000 +ISSYMBOL: 55210000 + SETIS(SYMBOLTYPE); 55220000 + GO TO NEXT; 55230000 +ISPROCEDURE: 55240000 + SETIS(PROCEDURETYPE); 55250000 + GO TO NEXT; 55260000 +ISUNDEFINED: 55270000 + SETIS(UNDEFINED); 55280000 + GO TO NEXT; 55290000 + 55300000 +TAIL: 55310000 + IF SI[SP].TYPE ! LISTTYPE THEN ERROR(1); 55320000 + IF SI[SP].WCT = 0 THEN ERROR(10); 55330000 + SI[SP].WCT ~ SI[SP].WCT - 1; 55340000 + SI[SP].ADDRESS ~ SI[SP].ADDRESS + 1; 55350000 + GO TO NEXT; 55360000 +THENV: 55370000 + BOOLTEST; 55380000 + SP ~ SP - 1; 55390000 + IF BOOLEAN(S[SP+1]) THEN 55400000 + GO TO NEXT; 55410000 + PP ~ PROGRAM[PP].BFIELD; 55420000 + GO TO TRANSFER; 55430000 +ELSEV: 55440000 + PP ~ PROGRAM[PP].BFIELD; 55450000 + GO TO TRANSFER; 55460000 +LENGTH: 55470000 + FETCH; 55480000 + IF SI[SP].TYPE ! LISTTYPE THEN ERROR(1); 55490000 + SI[SP].TYPE ~ NUMBERTYPE; 55500000 + S[SP] ~ SI[SP].WCT; 55510000 + GO TO NEXT; 55520000 +GOTO: 55530000 + IF SI[SP].TYPE ! LABELTYPE THEN ERROR(1); 55540000 + MP ~ SI[SP].STATIC; 55550000 + COMMENT WE MUST RETURN TO THE BLOCK WHERE THE LABEL IS DEFINED; 55560000 + PP ~ SI[SP].ADDRESS; 55570000 + SP ~ MP; 55580000 + GO TO TRANSFER; 55590000 +FORMAL: 55600000 + FORMALCOUNT ~ FORMALCOUNT + 1; 55610000 + IF FORMALCOUNT { S[MP].WCT THEN 55620000 + GO TO NEXT 55630000 + ELSE 55640000 + GO TO NEW; 55650000 +NEW: 55660000 + S[MP].WCT ~ S[MP].WCT + 1; 55670000 + FI[FP].TYPE ~ UNDEFINED; 55680000 + FP ~ FP + 1; 55690000 + IF FP > 1022 THEN FREE(1); 55700000 + GO TO NEXT; 55710000 +STORE: 55720000 + IF SI[SP-1].TYPE ! REFERENCETYPE THEN ERROR(13); 55730000 + LEVELCHECK(SI[SP], SI[SP-1].STATIC); 55740000 + SP ~ SP - 1; COMMENT NON-DESTRUCTIVE STORE; 55750000 + I1 ~ SI[SP].ADDRESS; 55760000 + S[SP] ~ F[I1] ~ S[SP+1]; 55770000 + SI[SP] ~ FI[I1] ~ SI[SP+1]; 55780000 + COMMENT THE NON-DESTRUCTIVE STORE IS NOT APPLICABLE TO LISTS; 55790000 + IF SI[SP].TYPE = LISTTYPE THEN SI[SP].TYPE ~ UNDEFINED; 55800000 + GO TO NEXT; 55810000 +SUBSCRIPT: 55820000 + IF SI[SP].TYPE ! NUMBERTYPE THEN ERROR(6); 55830000 + SP ~ SP - 1; 55840000 + IF SI[SP].TYPE ! REFERENCETYPE THEN ERROR(7); 55850000 + I1 ~ SI[SP].STATIC; SI[SP] ~ FI[SI[SP].ADDRESS]; 55860000 + IF SI[SP].TYPE ! LISTTYPE THEN ERROR(8); 55870000 + IF S[SP+1] < 1 OR S[SP+1] > SI[SP].WCT THEN ERROR(9); 55880000 + SI[SP].ADDRESS ~ SI[SP].ADDRESS + S[SP+1] - 1; 55890000 + SI[SP].TYPE ~ REFERENCETYPE; COMMENT MUST CREATE A REFERENCE; 55900000 + SI[SP].STATIC ~ I1; GO TO NEXT; 55910000 +BEGINV: 55920000 + SPUP; 55930000 + SI[SP] ~ 0; 55940000 + SI[SP].TYPE ~ BLOCKMARK; 55950000 + SI[SP].BLN ~ SI[MP].BLN + 1; 55960000 + SI[SP].DYNAMIC ~ MP; 55970000 + SI[SP].STATIC ~ MP; 55980000 + S[SP].TYPE ~ LISTTYPE; 55990000 + S[SP].ADDRESS ~ FP; 56000000 + S[SP].WCT ~ 0; COMMENT A NULL LIST; 56010000 + MP ~ SP; 56020000 + GO TO NEXT; 56030000 +ENDV: 56040000 + I1 ~ SI[MP].DYNAMIC; 56050000 + LEVELCHECK(SI[SP], SI[MP].STATIC); 56060000 + SI[MP] ~ SI[SP]; 56070000 + S[MP] ~ S[SP]; 56080000 + SP ~ MP; 56090000 + MP ~ I1; 56100000 + GO TO NEXT; 56110000 +LEFTQUOTE: COMMENT PROCEDURE DECLARATION; 56120000 + SPUP; 56130000 + SI[SP].TYPE ~ PROCEDURETYPE; 56140000 + SI[SP].ADDRESS ~ PP; 56150000 + COMMENT THE PROCEDURE DESCRIPTOR MUST SAVE ITS OWN LEXICOGRAPHICAL 56160000 + LEVEL AS WELL AS THE STACK MARKER FOR UPLEVEL ADDRESSED VARIABLES; 56170000 + SI[SP].BLN ~ SI[MP].BLN + 1; 56180000 + SI[SP].STATIC ~ MP; 56190000 + PP ~ PROGRAM[PP].BFIELD; 56200000 + GO TO TRANSFER; 56210000 +RIGHTQUOTE: 56220000 + PP ~ SI[MP].ADDRESS; COMMENT A PROCEDURE RETURN; 56230000 + I1 ~ SI[MP].DYNAMIC; 56240000 + LEVELCHECK(SI[SP], SI[MP].STATIC); 56250000 + SI[MP] ~ SI[SP]; 56260000 + S[MP] ~ S[SP]; 56270000 + SP ~ MP; 56280000 + MP ~ I1; 56290000 + GO TO NEXT; 56300000 +VALUEOPERATOR: 56310000 + IF SI[SP].TYPE = LISTTYPE THEN 56320000 + GO TO NEXT; 56330000 + FETCH; 56340000 + IF SI[SP].TYPE = PROCEDURETYPE THEN 56350000 + BEGIN 56360000 + FORMALCOUNT ~ 0; 56370000 + I1 ~ SI[SP].ADDRESS; 56380000 + SI[SP].TYPE ~ BLOCKMARK; 56390000 + SI[SP].ADDRESS ~ PP; 56400000 + SI[SP].DYNAMIC ~ MP; 56410000 + S[SP].TYPE ~ LISTTYPE; 56420000 + S[SP].WCT ~ 0; 56430000 + MP ~ SP; 56440000 + PP ~ I1; 56450000 + END 56460000 + ELSE IF SI[SP].TYPE = LISTTYPE THEN 56470000 + COPY(SI[SP]); 56480000 + GO TO NEXT; 56490000 +PROCEDURECALL: 56500000 + SP ~ SP - 1; 56510000 + FETCH; 56520000 + IF SI[SP].TYPE ! PROCEDURETYPE THEN ERROR(3); 56530000 + FORMALCOUNT ~ 0; 56540000 + I1 ~ SI[SP].ADDRESS; 56550000 + SI[SP].TYPE ~ BLOCKMARK; 56560000 + SI[SP].ADDRESS ~ PP; 56570000 + SI[SP].DYNAMIC ~ MP; 56580000 + S[SP] ~ SI[SP+1]; COMMENT THE LIST DESC. FOR PARAMETERS; 56590000 + MP ~ SP; 56600000 + PP ~ I1; 56610000 + GO TO NEXT; 56620000 +RIGHTPAREN: 56630000 + I1 ~ PROGRAM[PP].BFIELD; 56640000 + IF I1 + FP > 1022 THEN FREE(I1); 56650000 + SP ~ SP - I1 + 1; 56660000 + MOVE(S[SP], F[FP], I1); 56670000 + MOVE(SI[SP], FI[FP], I1); 56680000 + SI[SP].TYPE ~ LISTTYPE; 56690000 + SI[SP].WCT ~ I1; 56700000 + SI[SP].ADDRESS ~ FP; 56710000 + FP ~ FP + I1; 56720000 + GO TO NEXT; 56730000 +INPUT: 56740000 + SPUP; 56750000 + READ (CARDFIL, /, S[SP]) [EXIT]; 56760000 + SI[SP].TYPE ~ NUMBERTYPE; 56770000 + GO TO NEXT; 56780000 +OUTPUT: 56790000 + DUMPOUT(SI[SP], S[SP]); 56800000 + GO TO NEXT; 56810000 +INTEGERIZE: 56820000 + GO TO NEXT; 56830000 +DONE: 56840000 + END INTERPRETER; 56850000 + 56860000 +EXIT: 56870000 +END. 99999900 diff --git a/source/EULER/SYNTAX.alg_m b/source/EULER/SYNTAX.alg_m index dd1a041..b22b975 100644 --- a/source/EULER/SYNTAX.alg_m +++ b/source/EULER/SYNTAX.alg_m @@ -1,454 +1,453 @@ -BEGIN COMMENT SYNTAX-PROCESSOR. NIKLAUS WIRTH DEC.1964; - DEFINE NSY =180#; COMMENT MAX. NO. OF SYMBOLS; - DEFINE NPR =180#; COMMENT MAX. NO. OF PRODUCTIONS; - DEFINE UPTO =STEP 1 UNTIL#; - DEFINE LS ="<"#, EQ ="="#, GR =">"#, NULL =" "#; - FILE IN CARDFIL (1,10); FILE PRINTFIL 1 (1,15); - FILE OUT PCH 0 (2,10); COMMENT PUNCH FILE; - INTEGER LT; COMMENT NUMBER OF LAST NONBASIC SYMBOL; - INTEGER K,M,N, MAX, OLDN; BOOLEAN ERRORFLAG; - ALPHA ARRAY READBUFFER[0:9], WRITEBUFFER[0:14]; - ALPHA ARRAY TEXT[0:11]; COMMENT AUXILIARY TEXT ARRAY; - ALPHA ARRAY SYTB[0:NSY]; COMMENT SYMBOLTABLE; - INTEGER ARRAY REF[0:NPR,0:5]; COMMENT SYNTAX REFERENCE TABLE; - LABEL START,EXIT; - LABEL A,B,C,E,F,G; - -STREAM PROCEDURE CLEAR(D,N); VALUE N; - BEGIN DI ~ D; DS ~ 8 LIT " "; SI ~ D; DS ~ N WDS - END; -STREAM PROCEDURE MARK(D,S); VALUE S; - BEGIN DI ~ D; SI ~ LOC S; SI ~ SI+7; DS ~ CHR - END; -BOOLEAN STREAM PROCEDURE FINIS(S); - BEGIN TALLY ~ 1; SI ~ S; IF SC = "*" THEN FINIS ~ TALLY - END; -STREAM PROCEDURE EDIT(S,D,N); - BEGIN DI ~ D; SI ~ N; DS ~ 3 DEC; SI ~ S; DS ~ 9 WDS; - END; -STREAM PROCEDURE MOVE(S,D); - BEGIN SI ~ S; DI ~ D; DS ~ WDS; - END; -STREAM PROCEDURE MOVETEXT(S,D,N); VALUE N; - BEGIN DI ~ D; SI ~ S; DS ~ N WDS; - END; -BOOLEAN STREAM PROCEDURE EQUAL(S,D); - BEGIN SI ~ S; DI ~ D; TALLY ~ 1; IF 8 SC = DC THEN EQUAL ~ TALLY; - END; -STREAM PROCEDURE SCAN(S,DD,N); - BEGIN LABEL A,B,C,D,E; - SI ~ S; DI ~ DD; DS ~ 48 LIT "0"; DI ~ DD; SI ~ SI+1; - IF SC = " " THEN DI ~ DI+8; - A: IF SC = " " THEN BEGIN SI ~ SI+1; GO TO A END; - IF SC > "9" THEN GO TO D; - 8 (IF SC = " " THEN BEGIN DS ~ LIT " "; GO TO E END; DS ~ CHR; E:); - B: IF SC ! " " THEN BEGIN SI ~ SI+1; GO TO B END; - C: SI ~ SI+1; GO TO A; - D: DI ~ N; SI ~ SI+5; DS ~ 3 OCT - END; -STREAM PROCEDURE EDITTEXT(S,D,N); VALUE N; - BEGIN SI ~ S; DI ~ D; DI ~ DI+10; N(DI ~ DI+2; DS ~ 8 CHR) - END; -STREAM PROCEDURE SETTEXT(A,B,C,D,E,Z); - BEGIN DI ~ Z; DI ~ DI+8; SI ~ A; DS ~ 3 DEC; SI ~ B; DS ~ WDS; - DI ~ DI+5; SI ~ C; DS ~ 3 DEC; DI ~ DI+3; SI ~ D; DS ~ 3 DEC; - DI ~ DI+3; SI ~ E; DS ~ 3 DEC; - END; -STREAM PROCEDURE PCHTX(S,D,N); VALUE N; - BEGIN SI ~ S; DI ~ D; DI ~ DI+4; - N(DS ~ LIT """; DS ~ 8 CHR; DS ~ LIT """; DS ~ LIT ","); - END; -PROCEDURE INPUT; - READ (CARDFIL, 10, READBUFFER[*]) [EXIT]; -PROCEDURE OUTPUT; - BEGIN WRITE (PRINTFIL, 15, WRITEBUFFER[*]); - CLEAR(WRITEBUFFER[0], 14); - END; -INTEGER PROCEDURE INX(X); REAL X; - BEGIN INTEGER I; LABEL F; - FOR I ~ 0 UPTO M DO - IF EQUAL(SYTB[I], X) THEN GO TO F; - WRITE (PRINTFIL, <"UNDEFINED SYMBOL">); - ERRORFLAG ~ TRUE; - F: INX ~ I; - END; - -START: - FOR N ~ 0 UPTO 5 DO - FOR M ~ 0 UPTO NPR DO REF[M,N] ~ 0; - M ~ N ~ MAX ~ OLDN ~ 0; ERRORFLAG ~ FALSE; - CLEAR(WRITEBUFFER[0],14); - COMMENT READ LIST OF SYMBOLS, ONE SYMBOL MUST APPEAR PER CARD, - STARTING IN COL.9 (8 CHARS. ARE SIGNIFICANT), THE LIST OF NON- - BASIC SYMBOLS IS FOLLOWED BY AN ENDCARD ("*" IN COL.1). THEN - FOLLOWS THE LIST OF BASIC SYMBOLS AND AGAIN AN ENDCARD; - WRITE (PRINTFIL, < "NONBASIC SYMBOLS:">); -A: INPUT; - IF FINIS(READBUFFER[0]) THEN GO TO E; - M ~ M+1; - MOVE(READBUFFER[1], SYTB[M]); - EDIT(READBUFFER[0], WRITEBUFFER[1], M); - OUTPUT; GO TO A; -E: WRITE (PRINTFIL, ); LT ~ M; -F: INPUT; - IF FINIS(READBUFFER[0]) THEN GO TO G; - M ~ M + 1; - MOVE(READBUFFER[1], SYTB[M]); - EDIT(READBUFFER[0], WRITEBUFFER[1], M); - OUTPUT; GO TO F; - - COMMENT READ THE LIST OF PRODUCTIONS, ONE PER CARD. THE LEFTPART - IS A NONBASIC SYMBOL STARTING IN COL.2. NO FORMAT IS PRESCRIBED - FOR THE RIGHT PART. ONE OR MORE BLANKS ACT AS SYMBOL SEPARATORS. - IF COL.2 IS BLANK, THE SAME LEFTPART AS IN THE PREVIOUS PRODUCTION - IS SUBSTITUTED. THE MAX. LENGTH OF A PRODUCTION IS 6 SYMBOLS; -G: WRITE (PRINTFIL, ); -B: INPUT; - IF FINIS(READBUFFER[0]) THEN GO TO C; - MOVETEXT(READBUFFER[0], WRITEBUFFER[1], 10); OUTPUT; - MARK(READBUFFER[9], 12); SCAN(READBUFFER[0],TEXT[0],N); - IF N { 0 OR N > NPR OR REF[N,0] ! 0 THEN - BEGIN WRITE (PRINTFIL, <"UNACCEPTABLE TAG">); - ERRORFLAG ~ TRUE; GO TO B - END; - IF N > MAX THEN MAX ~ N; - COMMENT THE SYNTAX IS STORED IN REF, EACH SYMBOL REPRESENTED BY - ITS INDEX IN THE SYMBOL-TABLE; - FOR K ~ 0 UPTO 5 DO REF[N,K] ~ INX(TEXT[K]); - IF REF[N,0] = 0 THEN REF[N,0] ~ REF[OLDN,0] ELSE - IF REF[N,0] > LT THEN - BEGIN WRITE (PRINTFIL, <"ILLEGAL PRODUCTION">); - ERRORFLAG ~ TRUE END; - OLDN ~ N; GO TO B; -C: IF ERRORFLAG THEN GO TO EXIT; - N ~ MAX; - COMMENT M IS THE LENGTH OF THE SYMBOL-TABLE, N OF THE REF-TABLE; - -BEGIN COMMENT BLOCK A; - INTEGER ARRAY H[0:M, 0:M]; COMMENT PRECEDENCE MATRIX; - INTEGER ARRAY F, G [0:M]; COMMENT PRECEDENCE FUNCTIONS; -BEGIN COMMENT BLOCK B1; - INTEGER ARRAY LINX, RINX [0:LT]; COMMENT LEFT / RIGHT INDICES; - INTEGER ARRAY LEFTLIST, RIGHTLIST[0:1022]; -BEGIN COMMENT BLOCK C1, BUILD LEFT- AND RIGHT-SYMBOL LISTS; - INTEGER I,J; - INTEGER SP, RSP; COMMENT STACK- AND RECURSTACK-POINTERS; - INTEGER LP, RP; COMMENT LEFT/RIGHT LIST POINTERS; - INTEGER ARRAY INSTACK[0:M]; - BOOLEAN ARRAY DONE, ACTIVE [0:LT]; - INTEGER ARRAY RECURSTACK, STACKMARK [0:LT+1]; - INTEGER ARRAY STACK[0:1022]; COMMENT HERE THE LISTS ARE BUILT; - -PROCEDURE PRINTLIST(LX,L); ARRAY LX, L [0]; - BEGIN INTEGER I,J,K; - FOR I ~ 1 UPTO LT DO IF DONE[I] THEN - BEGIN K ~ 0; MOVE(SYTB[I], WRITEBUFFER[0]); - FOR J ~ LX[I],J+1 WHILE L[J] ! 0 DO - BEGIN MOVE(SYTB[L[J]], TEXT[K]); K ~ K+1; - IF K } 10 THEN - BEGIN EDITTEXT(TEXT[0], WRITEBUFFER[0],10);OUTPUT; - K ~ 0; - END; - END; - IF K > 0 THEN - BEGIN EDITTEXT(TEXT[0], WRITEBUFFER[0], K); - OUTPUT END; - END - END; -PROCEDURE DUMPIT; - BEGIN INTEGER I,J; WRITE (PRINTFIL [PAGE]); - WRITE (PRINTFIL, ); - WRITE (PRINTFIL, <5I6>, FOR I ~ 1 UPTO LT DO - [I, DONE[I], ACTIVE[I], LINX[I], RINX[I]]); - WRITE (PRINTFIL, , SP); - WRITE (PRINTFIL, , - FOR I ~ 0 STEP 10 UNTIL SP DO - [I, FOR J ~ I UPTO I+9 DO STACK[J]]); - WRITE (PRINTFIL, ); - WRITE (PRINTFIL, <3I6>, FOR I ~ 1 UPTO RSP DO - [I, RECURSTACK[I], STACKMARK[I]]); - END; -PROCEDURE RESET(X); VALUE X; INTEGER X; - BEGIN INTEGER I; - FOR I ~ X UPTO RSP DO STACKMARK[I] ~ STACKMARK[X]; - END; -PROCEDURE PUTINTOSTACK(X); VALUE X; INTEGER X; - COMMENT X IS PUT INTO THE WORKSTACK. DUPLICATION IS AVOIDED!; - BEGIN IF INSTACK[X] = 0 THEN - BEGIN SP ~ SP+1; STACK[SP] ~ X; INSTACK[X] ~ SP END - ELSE IF INSTACK[X] < STACKMARK[RSP] THEN - BEGIN SP ~ SP+1; STACK[SP] ~ X; - STACK[INSTACK[X]] ~ 0; INSTACK[X] ~ SP; - END; - IF SP > 1020 THEN - BEGIN WRITE (PRINTFIL, ); - DUMPIT; GO TO EXIT END; - END; -PROCEDURE COPYLEFTSYMBOLS(X); VALUE X; INTEGER X; - COMMENT COPY THE LIST OF LEFTSYMBOLS OF X INTO THE STACK; - BEGIN FOR X ~ LINX[X], X+1 WHILE LEFTLIST[X] ! 0 DO - PUTINTOSTACK(LEFTLIST[X]); - END; -PROCEDURE COPYRIGHTSYMBOLS(X); VALUE X; INTEGER X; - COMMENT COPY THE LIST OF RIGHTSYMBOLS OF X INTO THE STACK; - BEGIN FOR X ~ RINX[X], X+1 WHILE RIGHTLIST[X] ! 0 DO - PUTINTOSTACK(RIGHTLIST[X]); - END; -PROCEDURE SAVELEFTSYMBOLS(X); VALUE X; INTEGER X; - COMMENT THE LEFTSYMBOLLISTS OF ALL SYMBOLS IN THE RECURSTACK - WITH INDEX > X HAVE BEEN BUILT AND MUST NOW BE REMOVED, THEY ARE - COPIED INTO "LEFTLIST" AND THE SYMBOLS ARE MARKED "DONE"; - BEGIN INTEGER I,J,U; LABEL L,EX; - L: IF STACKMARK[X] = STACKMARK[X+1] THEN - BEGIN X ~ X+1; IF X < RSP THEN GO TO L ELSE GO TO EX END; - STACKMARK[RSP+1] ~ SP+1; - FOR I ~ X+1 UPTO RSP DO - BEGIN LINX[RECURSTACK[I]] ~ LP+1; - ACTIVE[RECURSTACK[I]] ~ FALSE; DONE[RECURSTACK[I]] ~ TRUE; - FOR J ~ STACKMARK[I] UPTO STACKMARK[I+1]-1 DO - IF STACK[J] ! 0 THEN - BEGIN LP ~ LP+1; LEFTLIST[LP] ~ STACK[J]; - IF LP > 1020 THEN - BEGIN WRITE (PRINTFIL, ); - DUMPIT; - PRINTLIST(LINX, LEFTLIST); - GO TO EXIT - END; - END - END; - LP ~ LP+1; LEFTLIST[LP] ~ 0; - EX: RSP ~ X; - END; -PROCEDURE SAVERIGHTSYMBOLS(X); VALUE X; INTEGER X; - COMMENT ANALOG TO "SAVELEFTSYMBOLS"; - BEGIN INTEGER I,J; LABEL L,EX; - L: IF STACKMARK[X] = STACKMARK[X+1] THEN - BEGIN X ~ X+1; IF X < RSP THEN GO TO L ELSE GO TO EX END; - STACKMARK[RSP+1] ~ SP+1; - FOR I ~ X+1 UPTO RSP DO - BEGIN RINX[RECURSTACK[I]] ~ RP+1; - ACTIVE[RECURSTACK[I]] ~ FALSE; DONE[RECURSTACK[I]] ~ TRUE; - FOR J ~ STACKMARK[I] UPTO STACKMARK[I+1]-1 DO - IF STACK[J] ! 0 THEN - BEGIN RP ~ RP+1; RIGHTLIST[RP] ~ STACK[J]; - IF RP > 1020 THEN - BEGIN WRITE (PRINTFIL, ); - DUMPIT; - PRINTLIST(RINX,RIGHTLIST); GO TO EXIT - END; - END - END; - RP ~ RP+1; RIGHTLIST[RP] ~ 0; - EX: RSP ~ X; - END; -PROCEDURE BUILDLEFTLIST(X); VALUE X; INTEGER X; - COMMENT THE LEFTLIST OF THE SYMBOL X IS BUILT BY SCANNING THE - SYNTAX FOR PRODUCTIONS WITH LEFTPART = X. THE LEFTMOST SYMBOL IN - THE RIGHTPART IS THEN INSPECTED: IF IT IS NONBASIC AND NOT MARKED - DONE, ITS LEFTLIST IS BUILT FIRST. WHILE A SYMBOL IS BEING INSPECTED - IT IS MARKED ACTIVE; - BEGIN INTEGER I,R,OWNRSP; - ACTIVE[X] ~ TRUE; - RSP ~ OWNRSP ~ LINX[X] ~ RSP+1; - RECURSTACK[RSP] ~ X; STACKMARK[RSP] ~ SP+1; - FOR I ~ 1 UPTO N DO - IF REF[I,0] = X THEN - BEGIN IF OWNRSP < RSP THEN SAVELEFTSYMBOLS(OWNRSP); - R ~ REF[I,1]; PUTINTOSTACK(R); - IF R { LT THEN - BEGIN IF DONE[R] THEN COPYLEFTSYMBOLS(R) ELSE - IF ACTIVE[R] THEN RESET(LINX[R]) ELSE - BUILDLEFTLIST(R); - END - END; - END; -PROCEDURE BUILDRIGHTLIST(X); VALUE X; INTEGER X; - COMMENT ANALOG TO "BUILDLEFTLIST"; - BEGIN INTEGER I,R,OWNRSP; LABEL QQ; - ACTIVE[X] ~ TRUE; - RSP ~ OWNRSP ~ RINX[X] ~ RSP+1; - RECURSTACK[RSP] ~ X; STACKMARK[RSP] ~ SP+1; - FOR I ~ 1 UPTO N DO - IF REF[I,0] = X THEN - BEGIN IF OWNRSP < RSP THEN SAVERIGHTSYMBOLS(OWNRSP); - FOR R ~ 2,3,4,5 DO IF REF[I,R] = 0 THEN GO TO QQ; - QQ: R ~ REF[I,R-1]; PUTINTOSTACK(R); - IF R { LT THEN - BEGIN IF DONE[R] THEN COPYRIGHTSYMBOLS(R) ELSE - IF ACTIVE[R] THEN RESET(RINX[R]) ELSE - BUILDRIGHTLIST(R); - END - END - END; - - SP ~ RSP ~ LP ~ 0; - FOR I ~ 1 UPTO LT DO DONE[I] ~ FALSE; - FOR I ~ 1 UPTO LT DO IF NOT DONE[I] THEN - BEGIN SP ~ RSP ~ 0; - FOR J ~ 1 UPTO M DO INSTACK[J] ~ 0; - BUILDLEFTLIST(I); SAVELEFTSYMBOLS(0); - END; - WRITE (PRINTFIL [PAGE]); - WRITE (PRINTFIL, ); - PRINTLIST(LINX, LEFTLIST); - SP ~ RSP ~ RP ~ 0; - FOR I ~ 1 UPTO LT DO DONE[I] ~ FALSE; - FOR I ~ 1 UPTO LT DO IF NOT DONE[I] THEN - BEGIN SP ~ RSP ~ 0; - FOR J ~ 1 UPTO M DO INSTACK[J] ~ 0; - BUILDRIGHTLIST(I); SAVERIGHTSYMBOLS(0); - END; - WRITE (PRINTFIL [3]); - WRITE (PRINTFIL, ); - PRINTLIST(RINX, RIGHTLIST); -END BLOCK C1; - - -BEGIN COMMENT BLOCK C2, BUILD PRECEDENCE RELATIONS; - INTEGER J,K,P,Q,R,L,T; - LABEL NEXTPRODUCTION; -PROCEDURE ENTER(X,Y,S); VALUE X,Y,S; INTEGER X,Y,S; - COMMENT ENTER THE RELATION S INTO POSITION [X,Y]. CHECK FOR DOUBLE- - OCCUPATION OF THIS POSITION; - BEGIN T ~ H[X,Y]; IF T ! NULL AND T ! S THEN - BEGIN ERRORFLAG ~ TRUE; - WRITE (PRINTFIL, - <"PRECEDENCE VIOLATED BY ",2A1, - " FOR PAIR",2I4, - " BY PRODUCTION",I4>, T, S, X, Y, J); - END; - H[X,Y] ~ S; - END; - WRITE (PRINTFIL [PAGE]); - FOR K ~ 1 UPTO M DO - FOR J ~ 1 UPTO M DO H[K,J] ~ NULL; - FOR J ~ 1 UPTO N DO - BEGIN FOR K ~ 2,3,4,5 DO IF REF[J,K] ! 0 THEN - BEGIN P ~ REF[J,K-1]; Q ~ REF[J,K]; - ENTER(P,Q,EQ); - IF P { LT THEN - BEGIN FOR R ~ RINX[P],R+1 WHILE RIGHTLIST[R] ! 0 DO - ENTER(RIGHTLIST[R],Q,GR); - IF Q { LT THEN - FOR L ~ LINX[Q],L+1 WHILE LEFTLIST[L] ! 0 DO - BEGIN ENTER(P, LEFTLIST[L], LS); - FOR R ~ RINX[P],R+1 WHILE RIGHTLIST[R] ! 0 DO - ENTER(RIGHTLIST[R],LEFTLIST[L],GR) - END - END - ELSE IF Q { LT THEN - FOR L ~ LINX[Q],L+1 WHILE LEFTLIST[L] ! 0 DO - ENTER(P, LEFTLIST[L], LS); - END - ELSE GO TO NEXTPRODUCTION; - NEXTPRODUCTION: END J; - WRITE (PRINTFIL, , FOR J ~ 1 UPTO M DO J); - FOR K ~ 1 STEP 1 UNTIL M DO - WRITE (PRINTFIL, , FOR J ~ 1 UPTO M DO H[K,J]); -END BLOCK C2; -END BLOCK B1; - IF ERRORFLAG THEN GO TO EXIT; - WRITE (PRINTFIL, ); - - -BEGIN COMMENT BLOCK B2. BUILD F AND G PRECEDENCE FUNCTIONS; - INTEGER I, J, K,K1, N, FMIN, GMIN, T; -PROCEDURE THRU(I,J,X); VALUE I,J,X; INTEGER I,J,X; - BEGIN WRITE (PRINTFIL, - , I,J,X); - GO TO EXIT - END; -PROCEDURE FIXUPCOL(L,J,X); VALUE L,J,X; INTEGER L,J,X; FORWARD; -PROCEDURE FIXUPROW(I,L,X); VALUE I,L,X; INTEGER I,L,X; - BEGIN INTEGER J; F[I] ~ G[L] + X; - IF K1 = K THEN - BEGIN IF H[I,K]= EQ AND F[I] ! G[K] THEN THRU(I,K,0) ELSE - IF H[I,K]= LS AND F[I] } G[K] THEN THRU(I,K,0) - END; - FOR J ~ K1 STEP -1 UNTIL 1 DO - IF H[I,J]= EQ AND F[I] ! G[J] THEN FIXUPCOL(I,J,0) ELSE - IF H[I,J]= LS AND F[I] } G[J] THEN FIXUPCOL(I,J,1); - END; -PROCEDURE FIXUPCOL(L,J,X); VALUE L,J,X; INTEGER L,J,X; - BEGIN INTEGER I; G[J] ~ F[L] + X; - IF K1 ! K THEN - BEGIN IF H[K,J] = EQ AND F[K] ! G[J] THEN THRU(K,J,1) ELSE - IF H[K,J] = GR AND F[K] { G[J] THEN THRU(K,J,1) - END; - FOR I ~ K STEP -1 UNTIL 1 DO - IF H[I,J] = EQ AND F[I] ! G[J] THEN FIXUPROW(I,J,0) ELSE - IF H[I,J] = GR AND F[I] { G[J] THEN FIXUPROW(I,J,1); - END; - K1 ~ 0; - FOR K ~ 1 UPTO M DO - BEGIN FMIN ~ 1; - FOR J ~ 1 UPTO K1 DO - IF H[K,J] = EQ AND FMIN < G[J] THEN FMIN ~ G[J] ELSE - IF H[K,J] = GR AND FMIN { G[J] THEN FMIN ~ G[J]+1; - F[K] ~ FMIN; - FOR J ~ K1 STEP -1 UNTIL 1 DO - IF H[K,J] = EQ AND FMIN > G[J] THEN FIXUPCOL(K,J,0) ELSE - IF H[K,J] = LS AND FMIN } G[J] THEN FIXUPCOL(K,J,1); - K1 ~ K1+1; GMIN ~ 1; - FOR I ~ 1 UPTO K DO - IF H[I,K]= EQ AND F[I] > GMIN THEN GMIN ~ F[I] ELSE - IF H[I,K]= LS AND F[I] } GMIN THEN GMIN ~ F[I]+1; - G[K] ~ GMIN; - FOR I ~ K STEP -1 UNTIL 1 DO - IF H[I,K] = EQ AND F[I] < GMIN THEN FIXUPROW(I,K,0) ELSE - IF H[I,K] = GR AND F[I] { GMIN THEN FIXUPROW(I,K,1); - END K; -END BLOCK B2; - WRITE (PRINTFIL [PAGE]); - - -BEGIN COMMENT BLOCK B3. BUILD TABLES OF PRODUCTION REFERENCES; - INTEGER I,J,K,L; - INTEGER ARRAY MTB[0:M]; COMMENT MASTER TABLE; - INTEGER ARRAY PRTB[0:1022]; COMMENT PRODUCTION TABLE; - L ~ 0; - FOR I ~ 1 UPTO M DO - BEGIN MTB[I] ~ L+1; - FOR J ~ 1 UPTO N DO - IF REF[J,1] = I THEN - BEGIN FOR K ~ 2,3,4,5 DO - IF REF[J,K] ! 0 THEN - BEGIN L ~ L+1; PRTB[L] ~ REF[J,K] - END; - L ~ L+1; PRTB[L] ~ -J; L ~ L+1; - PRTB[L] ~ REF[J,0]; - END; - L ~ L+1; PRTB[L] ~ 0 - END; - COMMENT PRINT AND PUNCH THE RESULTS: - SYMBOLTABLE, PRECEDENCE FUNCTIONS, SYNTAX REFERENCE TABLES; - WRITE (PRINTFIL, ); - FOR I ~ 1 UPTO M DO - BEGIN SETTEXT(I,SYTB[I],F[I],G[I], MTB[I], WRITEBUFFER[0]); - OUTPUT - END; - WRITE (PRINTFIL, ); - FOR I ~ 0 STEP 10 UNTIL L DO - WRITE (PRINTFIL, , - FOR I ~ 0 STEP 10 UNTIL L DO - [I, FOR J ~ I UPTO I+9 DO PRTB[J]]); - WRITE (PRINTFIL, , TIME(0)); - WRITE (PCH, , - LT+1,M,L); - FOR I ~ 1 STEP 6 UNTIL M DO - BEGIN PCHTX(SYTB[I], WRITEBUFFER[0], - IF M-I } 6 THEN 6 ELSE M-I+1); - WRITE (PCH,10,WRITEBUFFER[*]); - CLEAR(WRITEBUFFER[0],9) - END; - WRITE (PCH, , FOR I ~ 1 UPTO M DO F[I]); - WRITE (PCH, , FOR I ~ 1 UPTO M DO G[I]); - WRITE (PCH, , FOR I ~ 1 UPTO M DO MTB[I]); - WRITE (PCH, , FOR I ~ 1 UPTO L DO PRTB[I]); -END BLOCK B3 -END BLOCK A; - -EXIT: -END. - +BEGIN COMMENT SYNTAX-PROCESSOR. NIKLAUS WIRTH DEC.1964; 00010000 + DEFINE NSY =180#; COMMENT MAX. NO. OF SYMBOLS; 00020000 + DEFINE NPR =180#; COMMENT MAX. NO. OF PRODUCTIONS; 00030000 + DEFINE UPTO =STEP 1 UNTIL#; 00040000 + DEFINE LS ="<"#, EQ ="="#, GR =">"#, NULL =" "#; 00050000 + FILE IN CARDFIL (1,10); FILE PRINTFIL 1 (1,15); 00060000 + FILE OUT PCH 0 (2,10); COMMENT PUNCH FILE; 00070000 + INTEGER LT; COMMENT NUMBER OF LAST NONBASIC SYMBOL; 00080000 + INTEGER K,M,N, MAX, OLDN; BOOLEAN ERRORFLAG; 00090000 + ALPHA ARRAY READBUFFER[0:9], WRITEBUFFER[0:14]; 00100000 + ALPHA ARRAY TEXT[0:11]; COMMENT AUXILIARY TEXT ARRAY; 00110000 + ALPHA ARRAY SYTB[0:NSY]; COMMENT SYMBOLTABLE; 00120000 + INTEGER ARRAY REF[0:NPR,0:5]; COMMENT SYNTAX REFERENCE TABLE; 00130000 + LABEL START,EXIT; 00140000 + LABEL A,B,C,E,F,G; 00150000 + 00160000 +STREAM PROCEDURE CLEAR(D,N); VALUE N; 00170000 + BEGIN DI ~ D; DS ~ 8 LIT " "; SI ~ D; DS ~ N WDS 00180000 + END; 00190000 +STREAM PROCEDURE MARK(D,S); VALUE S; 00200000 + BEGIN DI ~ D; SI ~ LOC S; SI ~ SI+7; DS ~ CHR 00210000 + END; 00220000 +BOOLEAN STREAM PROCEDURE FINIS(S); 00230000 + BEGIN TALLY ~ 1; SI ~ S; IF SC = "*" THEN FINIS ~ TALLY 00240000 + END; 00250000 +STREAM PROCEDURE EDIT(S,D,N); 00260000 + BEGIN DI ~ D; SI ~ N; DS ~ 3 DEC; SI ~ S; DS ~ 9 WDS; 00270000 + END; 00280000 +STREAM PROCEDURE MOVE(S,D); 00290000 + BEGIN SI ~ S; DI ~ D; DS ~ WDS; 00300000 + END; 00310000 +STREAM PROCEDURE MOVETEXT(S,D,N); VALUE N; 00320000 + BEGIN DI ~ D; SI ~ S; DS ~ N WDS; 00330000 + END; 00340000 +BOOLEAN STREAM PROCEDURE EQUAL(S,D); 00350000 + BEGIN SI ~ S; DI ~ D; TALLY ~ 1; IF 8 SC = DC THEN EQUAL ~ TALLY; 00360000 + END; 00370000 +STREAM PROCEDURE SCAN(S,DD,N); 00380000 + BEGIN LABEL A,B,C,D,E; 00390000 + SI ~ S; DI ~ DD; DS ~ 48 LIT "0"; DI ~ DD; SI ~ SI+1; 00400000 + IF SC = " " THEN DI ~ DI+8; 00410000 + A: IF SC = " " THEN BEGIN SI ~ SI+1; GO TO A END; 00420000 + IF SC > "9" THEN GO TO D; 00430000 + 8 (IF SC = " " THEN BEGIN DS ~ LIT " "; GO TO E END; DS ~ CHR; E:);00440000 + B: IF SC ! " " THEN BEGIN SI ~ SI+1; GO TO B END; 00450000 + C: SI ~ SI+1; GO TO A; 00460000 + D: DI ~ N; SI ~ SI+5; DS ~ 3 OCT 00470000 + END; 00480000 +STREAM PROCEDURE EDITTEXT(S,D,N); VALUE N; 00490000 + BEGIN SI ~ S; DI ~ D; DI ~ DI+10; N(DI ~ DI+2; DS ~ 8 CHR) 00500000 + END; 00510000 +STREAM PROCEDURE SETTEXT(A,B,C,D,E,Z); 00520000 + BEGIN DI ~ Z; DI ~ DI+8; SI ~ A; DS ~ 3 DEC; SI ~ B; DS ~ WDS; 00530000 + DI ~ DI+5; SI ~ C; DS ~ 3 DEC; DI ~ DI+3; SI ~ D; DS ~ 3 DEC; 00540000 + DI ~ DI+3; SI ~ E; DS ~ 3 DEC; 00550000 + END; 00560000 +STREAM PROCEDURE PCHTX(S,D,N); VALUE N; 00570000 + BEGIN SI ~ S; DI ~ D; DI ~ DI+4; 00580000 + N(DS ~ LIT """; DS ~ 8 CHR; DS ~ LIT """; DS ~ LIT ","); 00590000 + END; 00600000 +PROCEDURE INPUT; 00610000 + READ (CARDFIL, 10, READBUFFER[*]) [EXIT]; 00620000 +PROCEDURE OUTPUT; 00630000 + BEGIN WRITE (PRINTFIL, 15, WRITEBUFFER[*]); 00640000 + CLEAR(WRITEBUFFER[0], 14); 00650000 + END; 00660000 +INTEGER PROCEDURE INX(X); REAL X; 00670000 + BEGIN INTEGER I; LABEL F; 00680000 + FOR I ~ 0 UPTO M DO 00690000 + IF EQUAL(SYTB[I], X) THEN GO TO F; 00700000 + WRITE (PRINTFIL, <"UNDEFINED SYMBOL">); 00710000 + ERRORFLAG ~ TRUE; 00720000 + F: INX ~ I; 00730000 + END; 00740000 + 00750000 +START: 00760000 + FOR N ~ 0 UPTO 5 DO 00770000 + FOR M ~ 0 UPTO NPR DO REF[M,N] ~ 0; 00780000 + M ~ N ~ MAX ~ OLDN ~ 0; ERRORFLAG ~ FALSE; 00790000 + CLEAR(WRITEBUFFER[0],14); 00800000 + COMMENT READ LIST OF SYMBOLS, ONE SYMBOL MUST APPEAR PER CARD, 00810000 + STARTING IN COL.9 (8 CHARS. ARE SIGNIFICANT), THE LIST OF NON- 00820000 + BASIC SYMBOLS IS FOLLOWED BY AN ENDCARD ("*" IN COL.1). THEN 00830000 + FOLLOWS THE LIST OF BASIC SYMBOLS AND AGAIN AN ENDCARD; 00840000 + WRITE (PRINTFIL, < "NONBASIC SYMBOLS:">); 00850000 +A: INPUT; 00860000 + IF FINIS(READBUFFER[0]) THEN GO TO E; 00870000 + M ~ M+1; 00880000 + MOVE(READBUFFER[1], SYTB[M]); 00890000 + EDIT(READBUFFER[0], WRITEBUFFER[1], M); 00900000 + OUTPUT; GO TO A; 00910000 +E: WRITE (PRINTFIL, ); LT ~ M; 00920000 +F: INPUT; 00930000 + IF FINIS(READBUFFER[0]) THEN GO TO G; 00940000 + M ~ M + 1; 00950000 + MOVE(READBUFFER[1], SYTB[M]); 00960000 + EDIT(READBUFFER[0], WRITEBUFFER[1], M); 00970000 + OUTPUT; GO TO F; 00980000 + 00990000 + COMMENT READ THE LIST OF PRODUCTIONS, ONE PER CARD. THE LEFTPART 01000000 + IS A NONBASIC SYMBOL STARTING IN COL.2. NO FORMAT IS PRESCRIBED 01010000 + FOR THE RIGHT PART. ONE OR MORE BLANKS ACT AS SYMBOL SEPARATORS. 01020000 + IF COL.2 IS BLANK, THE SAME LEFTPART AS IN THE PREVIOUS PRODUCTION 01030000 + IS SUBSTITUTED. THE MAX. LENGTH OF A PRODUCTION IS 6 SYMBOLS; 01040000 +G: WRITE (PRINTFIL, ); 01050000 +B: INPUT; 01060000 + IF FINIS(READBUFFER[0]) THEN GO TO C; 01070000 + MOVETEXT(READBUFFER[0], WRITEBUFFER[1], 10); OUTPUT; 01080000 + MARK(READBUFFER[9], 12); SCAN(READBUFFER[0],TEXT[0],N); 01090000 + IF N { 0 OR N > NPR OR REF[N,0] ! 0 THEN 01100000 + BEGIN WRITE (PRINTFIL, <"UNACCEPTABLE TAG">); 01110000 + ERRORFLAG ~ TRUE; GO TO B 01120000 + END; 01130000 + IF N > MAX THEN MAX ~ N; 01140000 + COMMENT THE SYNTAX IS STORED IN REF, EACH SYMBOL REPRESENTED BY 01150000 + ITS INDEX IN THE SYMBOL-TABLE; 01160000 + FOR K ~ 0 UPTO 5 DO REF[N,K] ~ INX(TEXT[K]); 01170000 + IF REF[N,0] = 0 THEN REF[N,0] ~ REF[OLDN,0] ELSE 01180000 + IF REF[N,0] > LT THEN 01190000 + BEGIN WRITE (PRINTFIL, <"ILLEGAL PRODUCTION">); 01200000 + ERRORFLAG ~ TRUE END; 01210000 + OLDN ~ N; GO TO B; 01220000 +C: IF ERRORFLAG THEN GO TO EXIT; 01230000 + N ~ MAX; 01240000 + COMMENT M IS THE LENGTH OF THE SYMBOL-TABLE, N OF THE REF-TABLE; 01250000 + 01260000 +BEGIN COMMENT BLOCK A; 01270000 + INTEGER ARRAY H[0:M, 0:M]; COMMENT PRECEDENCE MATRIX; 01280000 + INTEGER ARRAY F, G [0:M]; COMMENT PRECEDENCE FUNCTIONS; 01290000 +BEGIN COMMENT BLOCK B1; 01300000 + INTEGER ARRAY LINX, RINX [0:LT]; COMMENT LEFT / RIGHT INDICES; 01310000 + INTEGER ARRAY LEFTLIST, RIGHTLIST[0:1022]; 01320000 +BEGIN COMMENT BLOCK C1, BUILD LEFT- AND RIGHT-SYMBOL LISTS; 01330000 + INTEGER I,J; 01340000 + INTEGER SP, RSP; COMMENT STACK- AND RECURSTACK-POINTERS; 01350000 + INTEGER LP, RP; COMMENT LEFT/RIGHT LIST POINTERS; 01360000 + INTEGER ARRAY INSTACK[0:M]; 01370000 + BOOLEAN ARRAY DONE, ACTIVE [0:LT]; 01380000 + INTEGER ARRAY RECURSTACK, STACKMARK [0:LT+1]; 01390000 + INTEGER ARRAY STACK[0:1022]; COMMENT HERE THE LISTS ARE BUILT; 01400000 + 01410000 +PROCEDURE PRINTLIST(LX,L); ARRAY LX, L [0]; 01420000 + BEGIN INTEGER I,J,K; 01430000 + FOR I ~ 1 UPTO LT DO IF DONE[I] THEN 01440000 + BEGIN K ~ 0; MOVE(SYTB[I], WRITEBUFFER[0]); 01450000 + FOR J ~ LX[I],J+1 WHILE L[J] ! 0 DO 01460000 + BEGIN MOVE(SYTB[L[J]], TEXT[K]); K ~ K+1; 01470000 + IF K } 10 THEN 01480000 + BEGIN EDITTEXT(TEXT[0], WRITEBUFFER[0],10);OUTPUT; 01490000 + K ~ 0; 01500000 + END; 01510000 + END; 01520000 + IF K > 0 THEN 01530000 + BEGIN EDITTEXT(TEXT[0], WRITEBUFFER[0], K); 01540000 + OUTPUT END; 01550000 + END 01560000 + END; 01570000 +PROCEDURE DUMPIT; 01580000 + BEGIN INTEGER I,J; WRITE (PRINTFIL [PAGE]); 01590000 + WRITE (PRINTFIL, ); 01600000 + WRITE (PRINTFIL, <5I6>, FOR I ~ 1 UPTO LT DO 01610000 + [I, DONE[I], ACTIVE[I], LINX[I], RINX[I]]); 01620000 + WRITE (PRINTFIL, , SP); 01630000 + WRITE (PRINTFIL, , 01640000 + FOR I ~ 0 STEP 10 UNTIL SP DO 01650000 + [I, FOR J ~ I UPTO I+9 DO STACK[J]]); 01660000 + WRITE (PRINTFIL, ); 01670000 + WRITE (PRINTFIL, <3I6>, FOR I ~ 1 UPTO RSP DO 01680000 + [I, RECURSTACK[I], STACKMARK[I]]); 01690000 + END; 01700000 +PROCEDURE RESET(X); VALUE X; INTEGER X; 01710000 + BEGIN INTEGER I; 01720000 + FOR I ~ X UPTO RSP DO STACKMARK[I] ~ STACKMARK[X]; 01730000 + END; 01740000 +PROCEDURE PUTINTOSTACK(X); VALUE X; INTEGER X; 01750000 + COMMENT X IS PUT INTO THE WORKSTACK. DUPLICATION IS AVOIDED!; 01760000 + BEGIN IF INSTACK[X] = 0 THEN 01770000 + BEGIN SP ~ SP+1; STACK[SP] ~ X; INSTACK[X] ~ SP END 01780000 + ELSE IF INSTACK[X] < STACKMARK[RSP] THEN 01790000 + BEGIN SP ~ SP+1; STACK[SP] ~ X; 01800000 + STACK[INSTACK[X]] ~ 0; INSTACK[X] ~ SP; 01810000 + END; 01820000 + IF SP > 1020 THEN 01830000 + BEGIN WRITE (PRINTFIL, ); 01840000 + DUMPIT; GO TO EXIT END; 01850000 + END; 01860000 +PROCEDURE COPYLEFTSYMBOLS(X); VALUE X; INTEGER X; 01870000 + COMMENT COPY THE LIST OF LEFTSYMBOLS OF X INTO THE STACK; 01880000 + BEGIN FOR X ~ LINX[X], X+1 WHILE LEFTLIST[X] ! 0 DO 01890000 + PUTINTOSTACK(LEFTLIST[X]); 01900000 + END; 01910000 +PROCEDURE COPYRIGHTSYMBOLS(X); VALUE X; INTEGER X; 01920000 + COMMENT COPY THE LIST OF RIGHTSYMBOLS OF X INTO THE STACK; 01930000 + BEGIN FOR X ~ RINX[X], X+1 WHILE RIGHTLIST[X] ! 0 DO 01940000 + PUTINTOSTACK(RIGHTLIST[X]); 01950000 + END; 01960000 +PROCEDURE SAVELEFTSYMBOLS(X); VALUE X; INTEGER X; 01970000 + COMMENT THE LEFTSYMBOLLISTS OF ALL SYMBOLS IN THE RECURSTACK 01980000 + WITH INDEX > X HAVE BEEN BUILT AND MUST NOW BE REMOVED, THEY ARE 01990000 + COPIED INTO "LEFTLIST" AND THE SYMBOLS ARE MARKED "DONE"; 02000000 + BEGIN INTEGER I,J,U; LABEL L,EX; 02010000 + L: IF STACKMARK[X] = STACKMARK[X+1] THEN 02020000 + BEGIN X ~ X+1; IF X < RSP THEN GO TO L ELSE GO TO EX END; 02030000 + STACKMARK[RSP+1] ~ SP+1; 02040000 + FOR I ~ X+1 UPTO RSP DO 02050000 + BEGIN LINX[RECURSTACK[I]] ~ LP+1; 02060000 + ACTIVE[RECURSTACK[I]] ~ FALSE; DONE[RECURSTACK[I]] ~ TRUE; 02070000 + FOR J ~ STACKMARK[I] UPTO STACKMARK[I+1]-1 DO 02080000 + IF STACK[J] ! 0 THEN 02090000 + BEGIN LP ~ LP+1; LEFTLIST[LP] ~ STACK[J]; 02100000 + IF LP > 1020 THEN 02110000 + BEGIN WRITE (PRINTFIL, ); 02120000 + DUMPIT; 02130000 + PRINTLIST(LINX, LEFTLIST); 02140000 + GO TO EXIT 02150000 + END; 02160000 + END 02170000 + END; 02180000 + LP ~ LP+1; LEFTLIST[LP] ~ 0; 02190000 + EX: RSP ~ X; 02200000 + END; 02210000 +PROCEDURE SAVERIGHTSYMBOLS(X); VALUE X; INTEGER X; 02220000 + COMMENT ANALOG TO "SAVELEFTSYMBOLS"; 02230000 + BEGIN INTEGER I,J; LABEL L,EX; 02240000 + L: IF STACKMARK[X] = STACKMARK[X+1] THEN 02250000 + BEGIN X ~ X+1; IF X < RSP THEN GO TO L ELSE GO TO EX END; 02260000 + STACKMARK[RSP+1] ~ SP+1; 02270000 + FOR I ~ X+1 UPTO RSP DO 02280000 + BEGIN RINX[RECURSTACK[I]] ~ RP+1; 02290000 + ACTIVE[RECURSTACK[I]] ~ FALSE; DONE[RECURSTACK[I]] ~ TRUE; 02300000 + FOR J ~ STACKMARK[I] UPTO STACKMARK[I+1]-1 DO 02310000 + IF STACK[J] ! 0 THEN 02320000 + BEGIN RP ~ RP+1; RIGHTLIST[RP] ~ STACK[J]; 02330000 + IF RP > 1020 THEN 02340000 + BEGIN WRITE (PRINTFIL, ); 02350000 + DUMPIT; 02360000 + PRINTLIST(RINX,RIGHTLIST); GO TO EXIT 02370000 + END; 02380000 + END 02390000 + END; 02400000 + RP ~ RP+1; RIGHTLIST[RP] ~ 0; 02410000 + EX: RSP ~ X; 02420000 + END; 02430000 +PROCEDURE BUILDLEFTLIST(X); VALUE X; INTEGER X; 02440000 + COMMENT THE LEFTLIST OF THE SYMBOL X IS BUILT BY SCANNING THE 02450000 + SYNTAX FOR PRODUCTIONS WITH LEFTPART = X. THE LEFTMOST SYMBOL IN 02460000 + THE RIGHTPART IS THEN INSPECTED: IF IT IS NONBASIC AND NOT MARKED 02470000 + DONE, ITS LEFTLIST IS BUILT FIRST. WHILE A SYMBOL IS BEING INSPECTED 02480000 + IT IS MARKED ACTIVE; 02490000 + BEGIN INTEGER I,R,OWNRSP; 02500000 + ACTIVE[X] ~ TRUE; 02510000 + RSP ~ OWNRSP ~ LINX[X] ~ RSP+1; 02520000 + RECURSTACK[RSP] ~ X; STACKMARK[RSP] ~ SP+1; 02530000 + FOR I ~ 1 UPTO N DO 02540000 + IF REF[I,0] = X THEN 02550000 + BEGIN IF OWNRSP < RSP THEN SAVELEFTSYMBOLS(OWNRSP); 02560000 + R ~ REF[I,1]; PUTINTOSTACK(R); 02570000 + IF R { LT THEN 02580000 + BEGIN IF DONE[R] THEN COPYLEFTSYMBOLS(R) ELSE 02590000 + IF ACTIVE[R] THEN RESET(LINX[R]) ELSE 02600000 + BUILDLEFTLIST(R); 02610000 + END 02620000 + END; 02630000 + END; 02640000 +PROCEDURE BUILDRIGHTLIST(X); VALUE X; INTEGER X; 02650000 + COMMENT ANALOG TO "BUILDLEFTLIST"; 02660000 + BEGIN INTEGER I,R,OWNRSP; LABEL QQ; 02670000 + ACTIVE[X] ~ TRUE; 02680000 + RSP ~ OWNRSP ~ RINX[X] ~ RSP+1; 02690000 + RECURSTACK[RSP] ~ X; STACKMARK[RSP] ~ SP+1; 02700000 + FOR I ~ 1 UPTO N DO 02710000 + IF REF[I,0] = X THEN 02720000 + BEGIN IF OWNRSP < RSP THEN SAVERIGHTSYMBOLS(OWNRSP); 02730000 + FOR R ~ 2,3,4,5 DO IF REF[I,R] = 0 THEN GO TO QQ; 02740000 + QQ: R ~ REF[I,R-1]; PUTINTOSTACK(R); 02750000 + IF R { LT THEN 02760000 + BEGIN IF DONE[R] THEN COPYRIGHTSYMBOLS(R) ELSE 02770000 + IF ACTIVE[R] THEN RESET(RINX[R]) ELSE 02780000 + BUILDRIGHTLIST(R); 02790000 + END 02800000 + END 02810000 + END; 02820000 + 02830000 + SP ~ RSP ~ LP ~ 0; 02840000 + FOR I ~ 1 UPTO LT DO DONE[I] ~ FALSE; 02850000 + FOR I ~ 1 UPTO LT DO IF NOT DONE[I] THEN 02860000 + BEGIN SP ~ RSP ~ 0; 02870000 + FOR J ~ 1 UPTO M DO INSTACK[J] ~ 0; 02880000 + BUILDLEFTLIST(I); SAVELEFTSYMBOLS(0); 02890000 + END; 02900000 + WRITE (PRINTFIL [PAGE]); 02910000 + WRITE (PRINTFIL, ); 02920000 + PRINTLIST(LINX, LEFTLIST); 02930000 + SP ~ RSP ~ RP ~ 0; 02940000 + FOR I ~ 1 UPTO LT DO DONE[I] ~ FALSE; 02950000 + FOR I ~ 1 UPTO LT DO IF NOT DONE[I] THEN 02960000 + BEGIN SP ~ RSP ~ 0; 02970000 + FOR J ~ 1 UPTO M DO INSTACK[J] ~ 0; 02980000 + BUILDRIGHTLIST(I); SAVERIGHTSYMBOLS(0); 02990000 + END; 03000000 + WRITE (PRINTFIL [3]); 03010000 + WRITE (PRINTFIL, ); 03020000 + PRINTLIST(RINX, RIGHTLIST); 03030000 +END BLOCK C1; 03040000 + 03050000 + 03060000 +BEGIN COMMENT BLOCK C2, BUILD PRECEDENCE RELATIONS; 03070000 + INTEGER J,K,P,Q,R,L,T; 03080000 + LABEL NEXTPRODUCTION; 03090000 +PROCEDURE ENTER(X,Y,S); VALUE X,Y,S; INTEGER X,Y,S; 03100000 + COMMENT ENTER THE RELATION S INTO POSITION [X,Y]. CHECK FOR DOUBLE- 03110000 + OCCUPATION OF THIS POSITION; 03120000 + BEGIN T ~ H[X,Y]; IF T ! NULL AND T ! S THEN 03130000 + BEGIN ERRORFLAG ~ TRUE; 03140000 + WRITE (PRINTFIL, 03150000 + <"PRECEDENCE VIOLATED BY ",2A1, 03160000 + " FOR PAIR",2I4, 03170000 + " BY PRODUCTION",I4>, T, S, X, Y, J); 03180000 + END; 03190000 + H[X,Y] ~ S; 03200000 + END; 03210000 + WRITE (PRINTFIL [PAGE]); 03220000 + FOR K ~ 1 UPTO M DO 03230000 + FOR J ~ 1 UPTO M DO H[K,J] ~ NULL; 03240000 + FOR J ~ 1 UPTO N DO 03250000 + BEGIN FOR K ~ 2,3,4,5 DO IF REF[J,K] ! 0 THEN 03260000 + BEGIN P ~ REF[J,K-1]; Q ~ REF[J,K]; 03270000 + ENTER(P,Q,EQ); 03280000 + IF P { LT THEN 03290000 + BEGIN FOR R ~ RINX[P],R+1 WHILE RIGHTLIST[R] ! 0 DO 03300000 + ENTER(RIGHTLIST[R],Q,GR); 03310000 + IF Q { LT THEN 03320000 + FOR L ~ LINX[Q],L+1 WHILE LEFTLIST[L] ! 0 DO 03330000 + BEGIN ENTER(P, LEFTLIST[L], LS); 03340000 + FOR R ~ RINX[P],R+1 WHILE RIGHTLIST[R] ! 0 DO 03350000 + ENTER(RIGHTLIST[R],LEFTLIST[L],GR) 03360000 + END 03370000 + END 03380000 + ELSE IF Q { LT THEN 03390000 + FOR L ~ LINX[Q],L+1 WHILE LEFTLIST[L] ! 0 DO 03400000 + ENTER(P, LEFTLIST[L], LS); 03410000 + END 03420000 + ELSE GO TO NEXTPRODUCTION; 03430000 + NEXTPRODUCTION: END J; 03440000 + WRITE (PRINTFIL, , FOR J ~ 1 UPTO M DO J); 03450000 + FOR K ~ 1 STEP 1 UNTIL M DO 03460000 + WRITE (PRINTFIL, , FOR J ~ 1 UPTO M DO H[K,J]); 03470000 +END BLOCK C2; 03480000 +END BLOCK B1; 03490000 + IF ERRORFLAG THEN GO TO EXIT; 03500000 + WRITE (PRINTFIL, ); 03510000 + 03520000 + 03530000 +BEGIN COMMENT BLOCK B2. BUILD F AND G PRECEDENCE FUNCTIONS; 03540000 + INTEGER I, J, K,K1, N, FMIN, GMIN, T; 03550000 +PROCEDURE THRU(I,J,X); VALUE I,J,X; INTEGER I,J,X; 03560000 + BEGIN WRITE (PRINTFIL, 03570000 + , I,J,X); 03580000 + GO TO EXIT 03590000 + END; 03600000 +PROCEDURE FIXUPCOL(L,J,X); VALUE L,J,X; INTEGER L,J,X; FORWARD; 03610000 +PROCEDURE FIXUPROW(I,L,X); VALUE I,L,X; INTEGER I,L,X; 03620000 + BEGIN INTEGER J; F[I] ~ G[L] + X; 03630000 + IF K1 = K THEN 03640000 + BEGIN IF H[I,K]= EQ AND F[I] ! G[K] THEN THRU(I,K,0) ELSE 03650000 + IF H[I,K]= LS AND F[I] } G[K] THEN THRU(I,K,0) 03660000 + END; 03670000 + FOR J ~ K1 STEP -1 UNTIL 1 DO 03680000 + IF H[I,J]= EQ AND F[I] ! G[J] THEN FIXUPCOL(I,J,0) ELSE 03690000 + IF H[I,J]= LS AND F[I] } G[J] THEN FIXUPCOL(I,J,1); 03700000 + END; 03710000 +PROCEDURE FIXUPCOL(L,J,X); VALUE L,J,X; INTEGER L,J,X; 03720000 + BEGIN INTEGER I; G[J] ~ F[L] + X; 03730000 + IF K1 ! K THEN 03740000 + BEGIN IF H[K,J] = EQ AND F[K] ! G[J] THEN THRU(K,J,1) ELSE 03750000 + IF H[K,J] = GR AND F[K] { G[J] THEN THRU(K,J,1) 03760000 + END; 03770000 + FOR I ~ K STEP -1 UNTIL 1 DO 03780000 + IF H[I,J] = EQ AND F[I] ! G[J] THEN FIXUPROW(I,J,0) ELSE 03790000 + IF H[I,J] = GR AND F[I] { G[J] THEN FIXUPROW(I,J,1); 03800000 + END; 03810000 + K1 ~ 0; 03820000 + FOR K ~ 1 UPTO M DO 03830000 + BEGIN FMIN ~ 1; 03840000 + FOR J ~ 1 UPTO K1 DO 03850000 + IF H[K,J] = EQ AND FMIN < G[J] THEN FMIN ~ G[J] ELSE 03860000 + IF H[K,J] = GR AND FMIN { G[J] THEN FMIN ~ G[J]+1; 03870000 + F[K] ~ FMIN; 03880000 + FOR J ~ K1 STEP -1 UNTIL 1 DO 03890000 + IF H[K,J] = EQ AND FMIN > G[J] THEN FIXUPCOL(K,J,0) ELSE 03900000 + IF H[K,J] = LS AND FMIN } G[J] THEN FIXUPCOL(K,J,1); 03910000 + K1 ~ K1+1; GMIN ~ 1; 03920000 + FOR I ~ 1 UPTO K DO 03930000 + IF H[I,K]= EQ AND F[I] > GMIN THEN GMIN ~ F[I] ELSE 03940000 + IF H[I,K]= LS AND F[I] } GMIN THEN GMIN ~ F[I]+1; 03950000 + G[K] ~ GMIN; 03960000 + FOR I ~ K STEP -1 UNTIL 1 DO 03970000 + IF H[I,K] = EQ AND F[I] < GMIN THEN FIXUPROW(I,K,0) ELSE 03980000 + IF H[I,K] = GR AND F[I] { GMIN THEN FIXUPROW(I,K,1); 03990000 + END K; 04000000 +END BLOCK B2; 04010000 + WRITE (PRINTFIL [PAGE]); 04020000 + 04030000 + 04040000 +BEGIN COMMENT BLOCK B3. BUILD TABLES OF PRODUCTION REFERENCES; 04050000 + INTEGER I,J,K,L; 04060000 + INTEGER ARRAY MTB[0:M]; COMMENT MASTER TABLE; 04070000 + INTEGER ARRAY PRTB[0:1022]; COMMENT PRODUCTION TABLE; 04080000 + L ~ 0; 04090000 + FOR I ~ 1 UPTO M DO 04100000 + BEGIN MTB[I] ~ L+1; 04110000 + FOR J ~ 1 UPTO N DO 04120000 + IF REF[J,1] = I THEN 04130000 + BEGIN FOR K ~ 2,3,4,5 DO 04140000 + IF REF[J,K] ! 0 THEN 04150000 + BEGIN L ~ L+1; PRTB[L] ~ REF[J,K] 04160000 + END; 04170000 + L ~ L+1; PRTB[L] ~ -J; L ~ L+1; 04180000 + PRTB[L] ~ REF[J,0]; 04190000 + END; 04200000 + L ~ L+1; PRTB[L] ~ 0 04210000 + END; 04220000 + COMMENT PRINT AND PUNCH THE RESULTS: 04230000 + SYMBOLTABLE, PRECEDENCE FUNCTIONS, SYNTAX REFERENCE TABLES; 04240000 + WRITE (PRINTFIL, ); 04260000 + FOR I ~ 1 UPTO M DO 04270000 + BEGIN SETTEXT(I,SYTB[I],F[I],G[I], MTB[I], WRITEBUFFER[0]); 04280000 + OUTPUT 04290000 + END; 04300000 + WRITE (PRINTFIL, ); 04310000 + FOR I ~ 0 STEP 10 UNTIL L DO 04320000 + WRITE (PRINTFIL, , 04330000 + FOR I ~ 0 STEP 10 UNTIL L DO 04340000 + [I, FOR J ~ I UPTO I+9 DO PRTB[J]]); 04350000 + WRITE (PRINTFIL, , TIME(0)); 04360000 + WRITE (PCH, , 04370000 + LT+1,M,L); 04380000 + FOR I ~ 1 STEP 6 UNTIL M DO 04390000 + BEGIN PCHTX(SYTB[I], WRITEBUFFER[0], 04400000 + IF M-I } 6 THEN 6 ELSE M-I+1); 04410000 + WRITE (PCH,10,WRITEBUFFER[*]); 04420000 + CLEAR(WRITEBUFFER[0],9) 04430000 + END; 04440000 + WRITE (PCH, , FOR I ~ 1 UPTO M DO F[I]); 04450000 + WRITE (PCH, , FOR I ~ 1 UPTO M DO G[I]); 04460000 + WRITE (PCH, , FOR I ~ 1 UPTO M DO MTB[I]); 04470000 + WRITE (PCH, , FOR I ~ 1 UPTO L DO PRTB[I]); 04480000 +END BLOCK B3 04490000 +END BLOCK A; 04500000 + 04510000 +EXIT: 04520000 +END. 99999900 diff --git a/source/XBASIC/STQB64.BAS b/source/XBASIC/STQB64.BAS index 02c8902..ccb52c0 100644 --- a/source/XBASIC/STQB64.BAS +++ b/source/XBASIC/STQB64.BAS @@ -1,1250 +1,1251 @@ -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 +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 REM RANDOMIZE TIMER +175 PRINT TAB(15); "* * * STAR TREK * * *" +180 PRINT +190 PRINT "DO YOU NEED INSTRUCTIONS (YES/NO)"; +200 REM DIM A$ +210 INPUT A$ +219 REM IF UCASE$(A$) = "YES" THEN GOSUB 10000 +220 IF A$ = "YES" THEN GOSUB 10000 +240 REM THE PROGRAM BEGINS HERE.... +242 REM DIM Q9$ +244 REM DIM R9$ +246 REM DIM S4$ +250 REM DIM Z$ +251 DIM Q$(72) +252 DIM R$(72) +253 DIM S$(72) +260 REM DIM G1$ +261 REM DIM G2$ +262 REM DIM G3$ +263 REM DIM G4$ +265 REM 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(8, 8) AS INTEGER +331 DIM C(9, 2) AS INTEGER +332 DIM K(3, 3) AS INTEGER +333 DIM N(3) AS INTEGER +334 DIM Z(8, 8) AS INTEGER +340 REM DIM O1$ +341 REM DIM C$ +350 REM DIM A1$ +351 REM DIM T$ +360 REM DIM D$ +361 REM 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(1) AS DOUBLE, A9(1) AS DOUBLE, W9(1) AS DOUBLE, D4(1) AS DOUBLE, D1(1) AS DOUBLE +372 DIM P7(1) AS DOUBLE +374 DIM A8(1) AS DOUBLE, X8(1) 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$(1) +1111 DIM X0$(1) +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$(1) +2074 DIM I9$(1) +2076 DIM J9$(1) +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$(1) +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$(1) + 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$(1) +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$(1) +7582 DIM N2$(1) +7584 DIM N$(1) +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$(1) +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$(1) +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$(1) +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 index 1bac9fd..9d8d971 100644 --- a/source/XBASIC/XBASIC.alg_m +++ b/source/XBASIC/XBASIC.alg_m @@ -1,1567 +1,1569 @@ -?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 + $ CARD LIST SINGLE XREF 00000100 + BEGIN 00000200 +COMMENT::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: 00000300 +::::: XBASIC -- A CONVERSATIONAL BASIC INTERPRETER ::::: 00000400 +::::: ::::: 00000500 +::::: MK XV 1.04: 1 DECEMBER 1975 ::::: 00000600 +::::: ::::: 00000700 +:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: 00000800 + 00000900 + XBASIC IS A BASIC INTERPRETER DEVELOPED FOR THE BURROUGHS RANGE 00001000 +OF COMPUTERS BY STAFF AT PAISLEY COLLEGE OF TECHNOLOGY. ITS PURPOSE 00001100 +IS TO PROVIDE FAST RESPONSE TO SIMPLE BASIC PROGRAMS UNDER TIME- 00001200 +SHARING. ACTUAL RUNNING OF PROGRAMS IS MUCH SLOWER FOR XBASIC, BUT 00001300 +EXPERIENCE SHOWS THAT MOST CLASS TIME IS SPENT ON INPUT AND COMPILE. 00001400 + 00001500 + XBASIC IS AN IMPLEMENTATION OF STANDARD BASIC, AND DIFFERS 00001600 +FROM BURROUGHS BASIC IN CERTAIN MATTERS OF DETAIL. THE COMMANDS 00001700 +ALLOWED IN XBASIC FORM A SUBSET OF THE COMMANDS AVAILABLE UNDER CANDE. 00001800 +FILES ARE EDITABLE UNDER CANDE. TRACE AND UNTRACE STATEMENTS 00001900 +CAN BE MADE AVAILABLE - SEE LINES 83300-83400 AND 107300-108700. 00002000 +XBASIC OUTPUT MAY BE DIVERTED FROM REMOTE TO PRINTER ("SEND"). 00002100 +VIDEO TERMINALS ARE SUPPORTED FOR EASY CORRECTION OF SOURCE PROGRAM. 00002200 +PROGRAMS ARE MONITORED FOR EXCESS LOOPING. 00002300 + 00002400 + TO USE XBASIC FROM THE BATCH TERMINAL, THE FOLLOWING 00002500 +CARDS SHOULD BE SUPPLIED: 00002600 + ? EXECUTE 0XBASIC/UTILITY 00002700 + ? COMMON=2 00002800 + ? DATA CRD 00002900 + (INSERT DECK HERE: USE TERMINAL FORMAT) 00003000 + ? END 00003100 + 00003200 +:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::; 00003300 +COMMENT 00003400 + THE BLOCK STRUCTURE FOR THE PROGRAM IS AS FOLLOWS: 00003500 + 00003600 + ------------- /------| 00003700 + 1 SOURCEIN: 1 / DOES | 00003800 + START-->--1 & EXECUTE 1--RUN->----< OBJECT >--YES--->---| 00003900 + 1 1 COMMANDS 1 | EXIST? / 1 00004000 + A ------------- |------| V 00004100 + 1 1 1 1 00004200 + 1 1 (YES) V (NO) 1 00004300 + 1 /------| 1 1 00004400 + 1 / ANY | ------------- 1 00004500 + 1 < SYNTAX >------<----1 COMPILE: 1 1 00004600 + 1 | ERRORS?/ 1 1 1 00004700 + 1 |------/ ------------- 1 00004800 + 1 1 1 00004900 + 1 V (NO) 1 00005000 + 1 1 1 00005100 + 1 ------------- 1 00005200 + |---<---1 EXECUTE: 1------------------<--------------/ 00005300 + ------------- 00005400 + 00005500 +:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::; 00005600 + 00005700 + INTEGER IU; % (COMMON) INPUT UNIT=0 VDU,1 TTY,2 CRD 00005800 + 00005900 + INTEGER ARRAY PROG[0:200,2:11], % SOURCE STRINGS 00006000 + SSEQ[0:200], % SEQUENCE NUMBERS 00006100 + STYP, % STATEMENT TYPES 00006200 + SPOB[1:200], % POINTERS TO OBJECTPROGRAM 00006300 + SUB[1:26], % INFO ON USER FUNCTIONS 00006400 + ARR[1:26,0:2], % ARRAYS 00006500 + STRAR[1:26,0:1], % STRING ARRAYS 00006600 + IOB[1:240],IOF[1:10], % I/O PSEUDOBUFFERS 00006700 + IOBE[1:14], % " " 00006800 + KEY[1:38], % COMPILE KEYWORDS 00006900 + FNM[1:3,1:2]; % FILENAMES FOR EXECUTE 00007000 + 00007100 + REAL ARRAY OBJ[0:999], % PSEUDO-OBJECTPROGRAM 00007200 + FORX[1:10,1:4], % INFO ON FOR STATEMENTS 00007300 + CONST[1:1000], % SOURCE PROGRAM CONSTANTS 00007400 + ANSA[0:9], % FOR DISK SEARCH 00007500 + IO[0:3]; % FILENAMES 00007600 + 00007700 + INTEGER MS, % NUMBER OF LINES OF PROGRAM 00007800 + ACS, % FIRST EXECUTABLE STATEMENT 00007900 + CS, % CURRENT STATEMENT NUMBER 00008000 + CHA, % CURRENT SOURCE CHARACTER 00008100 + CP, % POSITION OF CHA IN SOURCE 00008200 + LP, % SEE LOOK 00008300 + CO, % POSITION IN OBJ 00008400 + OU, % OUTPUT UNIT (0 REMOTE, 1 PRINTER) 00008500 + MSTO, % CURRENT TOP OF ARRAYS 00008600 + MSTR, % CURRENT TOP OF STRING ARRAYS 00008700 + NCON, % NUMBER OF CONSTANTS 00008800 + DELIM, % SEE NCH 00008900 + TIM, % MAX EXECUTION TIME (2 MIN USUALLY) 00009000 + LL, % CURRENT LINE NUMBER IN INPUT PAGE 00009100 + AREASIZE, % FOR EXECUTE OUTPUT FILE IF ANY 00009200 + BEG, % LIST COMMAND INITIAL LINE 00009300 + EN, % FINAL LINE 00009400 + NDEP, % ARITH STACK COUNTER 00009500 + ADDR, % CURRENT VARIABLE ADDRESS 00009600 + FORE,FORC, % HELP COMPILE FOR NESTS 00009700 + NF, % NUMBER OF EXECUTE FILES 00009800 + A,B,C,D,K; % HASH 00009900 + 00010000 + REAL R,S,T; % HASH 00010100 + 00010200 + BOOLEAN OBJECT, % "THERE IS AN ORJECTPROGRAM" 00010300 + STRIN, % "EXPRESSION IS A STRING" 00010400 + HDDR, % "PRINTER HEADER PRINTED" 00010500 + INFILTOG, % "PROGRAM NEEDS INPUT FILE" 00010600 + OUTFILTOG, % "PROGRAM NEEDS OUTPUT FILE" 00010700 + FIRSTOFF, % "HELLO" 00010800 + DANGER, % "NEW MATERIAL IN WORKFILE" 00010900 + VAR, % "EXPRESSION IS A VARIABLE" 00011000 + SY, % "PROGRAM CONTAINS SYNTAX ERRORS" 00011100 + EQOK, % "EXPRESSION MAY CONTAIN =" 00011200 + AA; % "SUCCESSIVE EXPNS TO PRINT" 00011300 + 00011400 + POINTER PINB, % START OF LINE IN IOB[*] 00011500 + PIOB, % CURRENT CHARACTER " 00011600 + PIBE, % LAST CHARACTER IN IOBE[1] 00011700 + POB, % FIRST CHARCTER IN OBJ[*] 00011800 + APR,BPR,CPR; % HASH 00011900 + 00012000 + FORMAT WHT ("ERR- ",A6," IS NOT A COMMAND IN XBASIC"), 00012100 + STP (/"END ",A6), 00012200 + SPC (/), 00012300 + WRN ("MORE THAN 100 GOTOS. IS YOUR PROGRAM ALL RIGHT?"), 00012400 + REP (A3), 00012500 + SYER ("SYNTAX ERRORS: CLEAR SCREEN AND TRANSMIT A SPACE"), 00012600 + SYR ("SYNTAX ERRORS:"), 00012700 + WT ("WAIT-"), 00012800 + MESS ("EXECUTING"), 00012900 + INTR ("ILLEGAL NUMBER"), 00013000 + LNGPRG("PROGRAM TOO LONG AT LINE ",I6), 00013100 + INVIT ("VDU ASSUMED - ELSE SAY TTY"), 00013200 + DVO ("OUTPUT IS BEING DIVERTED TO PRINTER"), 00013300 + BK ("EXECUTION STOPPED - EXCESS TIME."/ 00013400 + "FOR LONG PROGRAMS USE MAIN SYSTEM"), 00013500 + SNUM (X72,I8), 00013600 + F1 ("USE RENAME XXXXXX OR SAVE XXXXXX COMMAND"), 00013700 + F2 ("ERR? THIS WILL DELETE THE WORKFILE"), 00013800 + F3 ("OK- ",I3," RECORDS",A6,"D, LAST RECORD =",I7), 00013900 + F4 ("FILE ",A6," - ",A6,A1," BY XBASIC"), 00014000 + F5 ("YOUR WORKFILE IS AS AT LAST RUN COMMAND"), 00014100 + F6 (I6,X3,"DIM OR FILES STATEMENT OUT OF SEQUENCE"/ 00014200 + "ERR RUN"), 00014300 + F7 ("WORKFILE NOW EMPTY"), 00014400 + HD1 ("FURTHER OUTPUT WILL BE PRINTED WHEN YOU SIGN OFF"), 00014500 + HD3 (X40,"XBASIC MK XV",X8,"RUN ",A6,"DAY ", 00014600 + A2,"/",A2,"/",A2,/X54,"USER NO. ",A3,A4,/X52,20("*")//), 00014700 + 00014800 + F9 ("XBASIC IS RUNNING-"), 00014900 + F10 ("UNNAMED WORKFILE HAS",I4," RECORDS, LAST RECORD =",I6), 00015000 + F11 (A6," (WORKFILE) HAS",I4," RECORDS, LAST RECORD =",I6), 00015100 + F12 ("ERR- ILLEGAL PARAMETER"), 00015200 + F13 ("ARE PRESENT CONTENTS OF FILE ",A6," TO BE DESTROYED?"); 00015300 + 00015400 + SWITCH FORMAT NUM:=(U10),(U6),(X20,U10); 00015500 + SWITCH FORMAT MNP:=("NOT ENOUGH INPUT AT LINE",I6,X5,"TRY AGAIN"), 00015600 + ("BLANK INPUT AT LINE",I6,X5,"IGNORED"); 00015700 + 00015800 + FILE TTY 19(2,10);FILE IN CRD 2(2,10); FILE IN VDU 19(1,240); 00015900 + FILE OUT LIN 1(2,14);SWITCH FILE FN:=TTY,CRD;SWITCH FILE FL:=TTY,LIN; 00016000 + 00016100 + MONITOR INTOVR,EXPOVR,INDEX,FLAG,ZERO; 00016200 + 00016300 + LABEL SOURCEIN,COMPILE,EXECUTE,STOP,FINSH,ERR,INCST,PER,INER, 00016400 + TOOLONG; 00016500 + 00016600 + LABEL EXS,EQL,LET,CAR,ONX,RON,IFF,FEQ,GOT,GOS,RET,FOX,NEX, 00016700 + DEF,REA,RREA,INP,RAN,RES,PRI,RPRI,XPRI,DIM,ENX,REM,RFIL, 00016800 + INTVR,QUOTE,RDUM,DAT,RDAT,RDIM,PAG,MAT,IOMT,FLAGR,FIL,CGO; 00016900 + 00017000 + SWITCH OPN:=LET,GOT,GOS,RET,INP,REA,PRI,FOX,NEX,MAT, 00017100 + DEF,DAT,RAN,PAG,RES,REM,ENX,ENX,IFF,ONX; 00017200 + 00017300 + 00017400 + DEFINE ON(ON1)=IF CHA=ON1 THEN #; 00017500 + 00017600 + COMMENT::::::::::::::::GLOBAL PROCEDURES::::::::::::::::::::::::::: 00017700 + 00017800 + --- CHCONV CONVERTS CHA TO LETTER CODE 1-26 ; 00017900 + 00018000 + INTEGER PROCEDURE CHCONV(A);VALUE A; INTEGER A; 00018100 + BEGIN CHCONV:=0;IF A GTR 16 AND A LSS 26 THEN CHCONV:=A-16 ELSE 00018200 + IF A GTR 32 AND A LSS 42 THEN CHCONV:=A-23 ELSE 00018300 + IF A GTR 49 AND A LSS 58 THEN CHCONV:=A-31 END; 00018400 + COMMENT 00018500 + --- NCH PICKS NEXT CHARACTER FROM SOURCE STRING 00018600 + AND STORE IT IN CHA. BLANKS ARE SKIPPED. 00018700 + IF LAST CHAR- RETURN "%" AT DELIM. 00018800 + CP IS UPDATED. IOBE[*] IS USED AS HASH.; 00018900 + 00019000 + INTEGER PROCEDURE NCH; 00019100 + BEGIN INTEGER A;LABEL RPT; POINTER CPR; 00019200 + IOBE[1]:=0;A:=CP; 00019300 + RPT: IF A GEQ DELIM THEN CHA:=NCH:="%" ELSE BEGIN 00019400 + CPR:=POINTER(PROG[CS,2])+A; 00019500 + REPLACE PIBE BY CPR:CPR FOR 1;A:=A+1; 00019600 + IF IOBE[1]=48 THEN GO TO RPT;CHA:=NCH:=IOBE[1];CP:=A 00019700 + END END; 00019800 + COMMENT 00019900 + --- NMBR PICKS UP STATEMENT NUMBER ; 00020000 + INTEGER PROCEDURE NMBR(N);VALUE N;INTEGER N; 00020100 + BEGIN LABEL DONE,RNB,BLK,NST,SKB; 00020200 + DEFINE RD(RD1)=REPLACE BPR BY APR:APR FOR 1; 00020300 + IF DELTA(PINB,APR) GEQ RD1 THEN GO BLK;IF IOBE[1]#; 00020400 + CHA:=NMBR:=IOBE[1]:=0; 00020500 + NST: RD(N)=48 THEN GO NST;IF (CHA:=IOBE[1]) GEQ 10 THEN GO DONE; 00020600 + RNB: RD(72) LSS 10 THEN BEGIN CHA:=CHA|10+IOBE[1];GO RNB END; 00020700 + NMBR:=CHA;CHA:=IOBE[1];IF CHA NEQ 48 THEN GO DONE; 00020800 + SKB: RD(72)=48 THEN GO SKB;CHA:=IOBE[1];GO DONE; 00020900 + 00021000 + 00021100 + BLK: CHA:="%"; 00021200 + DONE: END; 00021300 + COMMENT 00021400 + --- FILECONTROL DEALS WITH SOURCE FILE OPERATIONS 00021500 + A=0 "MAKE"/"RENAME", 00021600 + 1 "SAVE", 2 "LOAD"/"COPY", 00021700 + 3 "REMOVE", 4 SAVE WORKFILE(AT "RUN") 00021800 + 5 LOAD WORKFILE(AT XBASIC ENTRY), 00021900 + 6 EXPLICIT REMOVE (AT "BYE",ETC) 00022000 + 7 EXPLICIT SAVE, 8 EXPLICIT LOAD; 00022100 + 00022200 + PROCEDURE FILECONTROL(A,C,D,L);VALUE A,C,D;INTEGER A;REAL C,D;LABEL L; 00022300 + % C AND D CARRY LABEL EQUATE FOR EXPLICIT OPERATIONS 00022400 + BEGIN INTEGER B,X,Y; 00022500 + PROCEDURE FILERR(E);VALUE E;INTEGER E; 00022600 + BEGIN SWITCH FORMAT ERR:=("ERR- ",A3,A4,"/",A3,A4,"- NOT ON DISK"), 00022700 + ("ERR- ",A3,A4,"/",A3,A4," - INVALID USER"), 00022800 + ("ERR- ",A3,A4,"/",A3,A4," - NON-STANDARD"), 00022900 + ("ERR- ",A3,A4,"/",A3,A4," - ILLEGAL NAME"), 00023000 + ("ERR- ",A3,A4,"/",A3,A4," - DUPLICATE NAME"), 00023100 + ("ERR- NO FILENAME"), 00023200 + ("ERR- WORKFILE"), 00023300 + ("ERR- WORKFILE IS EMPTY"); 00023400 + 00023500 + IF E>4 THEN WRITE(TTY,ERR[E]) ELSE WRITE(TTY,ERR[E], 00023600 + FOR X:=B,2 DO [IO[X].[41:18],IO[X].[23:24]]); 00023700 + IF B=0 THEN IO[0]:=0;IF A=1 AND E=3 THEN WRITE(TTY,F1); 00023800 + GO SOURCEIN END; 00023900 + LABEL SKIP,MK,SV,LD,RM,EF,SW,LW,EW; 00024000 + SWITCH OP:=MK,SV,LD,RM,SW,LW,RM,SV,LD; 00024100 + FILE DSK DISK "XBWKFL "(2,10,300,SAVE 7);% NB LABEL EQN ABOVE SKIP 00024200 + IF DANGER AND (C="CREATE" OR A=2 OR A=6) THEN BEGIN DANGER:=FALSE; 00024300 + WRITE(TTY,F2);GO SOURCEIN END; 00024400 + B:=IF A=0 THEN 0 ELSE 1;IF A>3 THEN BEGIN 00024500 + FILL DSK WITH C,D;IO[1]:=C;IO[2]:=D;GO SKIP END; 00024600 + IO[B]:=" "; % FILENAME 00024700 + SCAN APR:APR FOR 5 UNTIL NEQ " ";IF DELTA(PINB,APR)<12 THEN 00024800 + REPLACE POINTER(IO[B])+1 BY APR:APR FOR IF A<2 THEN 6 ELSE 7 00024900 + WHILE IN ALPHA; 00025000 + IF IO[B]=" " THEN BEGIN % ON SAVE SAVE WKFILE IF NO NAME 00025100 + IF A=1 AND IO[0] NEQ 0 THEN IO[1]:=IO[0] ELSE FILERR(5) END; 00025200 + IO[2]:=0;IF A GTR 1 THEN BEGIN % PROCESS "/USERCODE" IF PRESENT 00025300 + SCAN CPR:CPR:=APR FOR 10 WHILE NEQ "/";IF DELTA(PINB,CPR) LSS 15 THEN 00025400 + BEGIN IO[2]:=" "; 00025500 + REPLACE POINTER(IO[2])+1 BY APR:CPR+1 FOR 7 WHILE IN ALPHA END END; 00025600 + IF IO[2]=0 THEN IO[2]:=TIME(-1); 00025700 + IF IO[B]="XBWKFL " OR IO[B].[41:36] LSS "A00000" THEN FILERR(3); 00025800 + FILL DSK WITH IO[B],IO[2];DSK.SAVE:=7; 00025900 + SKIP: IF NOT FIRSTOFF THEN BEGIN X:=CHA;Y:=NMBR(72); 00026000 + IF Y NEQ 0 OR CHA NEQ "%" THEN GO PER;CHA:=X END; 00026100 + SEARCH(DSK,ANSA[*]);IF (A=5 OR A=6) AND ANSA[0]=-1 THEN GO L; 00026200 + IF A=0 AND ANSA[0] NEQ -1 THEN FILERR(4); 00026300 + IF A=1 AND IO[1] NEQ IO[0] AND ANSA[0] NEQ -1 THEN FILERR(4); 00026400 + IF A>1 AND A NEQ 4 THEN BEGIN IF ANSA[0] LEQ 0 THEN FILERR(ANSA[0]+1); 00026500 + IF ANSA[3] NEQ 10 OR ANSA[4] NEQ 300 THEN FILERR(2) END; 00026600 + IF CHA="MAKE00" THEN BEGIN MS:=0;OBJECT:=FALSE END; 00026700 + GO OP[A+1]; 00026800 + SV: IF IO[0]=0 THEN IO[0]:=IO[B]; % NAME WORKFILE 00026900 + IF MS=0 THEN FILERR(7);IF ANSA[0] NEQ -1 AND ANSA[0] NEQ 7 THEN 00027000 + FILERR(1);DSK.AREAS:=20;DSK.AREASIZE:=10; 00027100 + FOR CS:=1 STEP 1 UNTIL MS DO BEGIN % SAVE IT IN CANDE FORMAT 00027200 + REPLACE POINTER(IOBE[10]) BY SSEQ[CS] FOR 8 DIGITS; 00027300 + REPLACE POINTER(IOBE[*]) BY POINTER(PROG[CS,2]) FOR 9 WORDS; 00027400 + WRITE(DSK,10,IOBE[*]) END;LOCK(DSK);DANGER:=FALSE;GO MK; 00027500 + LD: FOR MS:=1 STEP 1 UNTIL 200 DO BEGIN % LOAD FROM 00027600 + READ(DSK,10,IOBE[*])[EF];READ(IOBE[*],SNUM,SSEQ[MS]); % CANDE FORMAT 00027700 + WRITE(PROG[MS,*],9,IOBE[*]);PROG[MS,11]:=SSEQ[MS] END; 00027800 + EF: MS:=MS-1;OBJECT:=FALSE;LOCK(DSK); 00027900 + WRITE(TTY,F3,MS,C,SSEQ[MS]); 00028000 + ON("LOAD00") IO[0]:=IF IO[2]=TIME(-1) THEN IO[1] ELSE 0;GO MK; 00028100 + RM: IF IO[B]=IO[0] AND A=3 THEN BEGIN IF MS=0 THEN 00028200 + IO[0]:=0 ELSE FILERR(6) END;IF ANSA[0] NEQ 7 THEN FILERR(1); 00028300 + WRITE(DSK,*,0);CLOSE(DSK,PURGE);GO MK; 00028400 + SW: DSK.AREAS:=20;DSK.AREASIZE:=11; 00028500 + IF MS=0 THEN FILERR(7); 00028600 + WRITE(DSK,*,IO[0]);FOR CS:=1 STEP 1 UNTIL MS DO 00028700 + WRITE(DSK,10,PROG[CS,*]);LOCK(DSK);DANGER:=FALSE;GO MK; 00028800 + LW: READ(DSK,*,IO[0]);FOR MS:=1 STEP 1 UNTIL 200 DO 00028900 + BEGIN READ(DSK,10,PROG[MS,*])[EW];SSEQ[MS]:=PROG[MS,11] END; 00029000 + EW: LOCK(DSK);MS:=MS-1;OBJECT:=FALSE;GO MK; 00029100 + MK: IF A<4 AND CHA NEQ "COPY00" THEN 00029200 + WRITE(TTY,F4,IO[B].[41:36],C,D); 00029300 + IF A=5 THEN WRITE(TTY,F5); 00029400 + IF CHA="COPY00" THEN WRITE(TTY,STP,"COPY "); 00029500 + GO L END; 00029600 + COMMENT 00029700 + --- SYNT DEALS WITH SYNTAX ERRORS ; 00029800 + 00029900 + PROCEDURE SYNT(A);VALUE A;REAL A; 00030000 + BEGIN IF SY THEN BEGIN IF IU=0 THEN BEGIN WRITE(TTY,SYER); 00030100 + READ(TTY[STOP]) END ELSE WRITE(TTY,SYR);SY:=FALSE END; 00030200 + REPLACE APR:=POINTER(IOBE[*]) BY " " FOR 72; 00030300 + WRITE(IOBE[*],NUM[0],SSEQ[CS]);SCAN APR:APR WHILE NEQ 48; 00030400 + IF IU=0 THEN BEGIN REPLACE APR:APR BY POINTER(PROG[CS,*]) FOR 72; 00030500 + APR:=POINTER(IOBE[*])+72; 00030600 + REPLACE APR:APR BY "!" FOR 1 END ELSE APR:=APR+3; 00030700 + REPLACE POB BY A FOR 8;REPLACE APR BY POB+1 FOR 7; 00030800 + OBJ[1]:=0;REPLACE POB+7 BY POINTER(IOBE[*])+79 FOR 1; 00030900 + IF IU GTR 0 THEN WRITE(TTY,9,IOBE[*]) ELSE IF OBJ[1]=48 THEN 00031000 + WRITE(TTY,10,IOBE[*]) ELSE WRITE(TTY[NO],10,IOBE[*]);GO TO ERR END; 00031100 + COMMENT 00031200 + --- NWC MODIFIES NCH FOR COMPILE ; 00031300 + 00031400 + INTEGER PROCEDURE NWC; 00031500 + BEGIN ON("%") SYNT("MISG OP");NWC:=NCH END; 00031600 + 00031700 + COMMENT 00031800 + --- PUT STORES CHARACTER IN OBJ ; 00031900 + 00032000 + PROCEDURE PUT(A);VALUE A;INTEGER A; 00032100 + BEGIN IF A>63 THEN SYNT("STR >63"); 00032200 + IOBE[1]:=A;REPLACE POB+CO BY PIBE FOR 1;CO:=CO+1; 00032300 + IF CO GEQ 8000 THEN GO TO TOOLONG;IF CO MOD 8=0 THEN CO:=CO+1 END; 00032400 + COMMENT 00032500 + --- RED MOVES BACK ONE SPACE IN OBJ; 00032600 + 00032700 + DEFINE RED=CO:=IF CO.[2:3]=1 THEN CO-2 ELSE CO-1#; 00032800 + 00032900 + COMMENT 00033000 + --- LOOK LOOKS AT A STRING IN SOURCE PROG ; 00033100 + 00033200 + INTEGER PROCEDURE LOOK(A);VALUE A;INTEGER A; 00033300 + BEGIN INTEGER B,C,D,E;E:=C:=CHA;B:=CP; 00033400 + FOR D:=1 STEP 1 UNTIL A-1 DO IF CHA NEQ "%" THEN C:=C|64+NWC; 00033500 + LOOK:=C;LP:=CP;CP:=B;CHA:=E END; 00033600 + COMMENT 00033700 + --- NUMB PICKS UP DIM AND MAT SIZES ; 00033800 + 00033900 + INTEGER PROCEDURE NUMB; 00034000 + BEGIN LABEL RP;INTEGER A; 00034100 + A:=0; 00034200 + RP: IF NWC LSS 10 THEN BEGIN A:=A|10+CHA;GO TO RP END; 00034300 + IF A=0 THEN SYNT("IL STMT"); 00034400 + NUMB:=A END; 00034500 + COMMENT 00034600 + --- ARITH(1) CONVERTS EXPNS TO REVERSE POLISH ; 00034700 + 00034800 + PROCEDURE ARITH(TT);VALUE TT;INTEGER TT; 00034900 + BEGIN INTEGER I,A,B,C,J,K,OP,STCK;BOOLEAN INMOK,VOK,STROK; 00035000 + LABEL S,SS,RPT,EXPON,DONE,FINEV,FORM1,FORM2,FORM3,FIN,RP; 00035100 + INTEGER ARRAY OPK[1:20]; 00035200 + 00035300 + COMMENT AN EXPRESSION CONSISTS OF A NUMBER OF PRIMARIES 00035400 + SEPARATED BY OPERATORS, POSSIBLY PRECEDED BY INITIAL - . 00035500 + PRIMARIES: OPERATORS: 00035600 + NUMBER + 00035700 + VARIABLE - 00035800 + ARRAY WITH SUBSCRIPT(S) * 00035900 + FUNCTION WITH PARAMETER(S) / 00036000 + STRING ** 00036100 + STRING VARIABLE = 00036200 + STRING ARRAY WITH SUBSCRIPT 00036300 + EXPRESSION IN BRACKETS 00036400 + 00036500 + EXPRESSION HAS TYPE REAL UNLESS STRING PRIMARY 00036600 + OCCURS: IF SO IT HAS TYPE STRING. A VARIABLE PRIMARY IS 00036700 + A PRIMARY OTHER THAN NUMBER, FUNCTION, OR STRING. 00036800 + IN OBJ AN EXPRESSION HAS FORM 00036900 + A OPS A OPS ... A OPS 0 00037000 + WHERE A IS A CHARACTER BETWEEN 1 AND 16 GIVING THE PRIMARY 00037100 + OR OPERATOR TYPE. OPS IS 0-2 CHARACTERS GIVING MORE INFORMATION00037200 + DEPENDING ON A. ; 00037300 + 00037400 + STRIN:=FALSE;NDEP:=NDEP+1;IF NDEP=10 THEN SYNT("SIMPLFY"); 00037500 + STCK:=OP:=0;INMOK:=VOK:=TRUE;STROK:=TT=0; 00037600 + 00037700 + COMMENT PRIMARIES: ; 00037800 + 00037900 + SS: CHA:=NWC; 00038000 + COMMENT BRACKETED EXPRESSION; 00038100 + S: ON(29) BEGIN ARITH(1);IF CHA NEQ 45 THEN SYNT("NO ) ,A"); 00038200 + RED;GO TO FORM1 END; 00038300 + COMMENT 1 NUMBER ; 00038400 + IF CHA LSS 10 OR CHA = 26 THEN BEGIN R:=I:=0; 00038500 + RPT: ON(26) BEGIN I:=1;CHA:=NWC END; 00038600 + IF CHA GEQ 10 THEN GO TO EXPON;IF I>0 THEN BEGIN R:=R+CHA|10*(-I); 00038700 + I:=I+1 END ELSE R:=R|10+CHA;CHA:=NWC; GO TO RPT; 00038800 + EXPON: IF CHA NEQ 21 THEN GO TO DONE;I:=1;CHA:=NWC;J:=0; 00038900 + ON(44) BEGIN I:=-1;CHA:=NWC END ELSE ON(16) CHA:=NWC;J:=CHA; 00039000 + IF CHA GEQ 10 THEN SYNT("NO EXPN");CHA:=NWC; 00039100 + IF CHA LSS 10 THEN BEGIN J:=J|10+CHA;CHA:=NWC END;R:=R|10*(I|J); 00039200 + DONE: PUT(1);NCON:=NCON+1;CONST[NCON]:=R; 00039300 + PUT(NCON.[11:6]);PUT(NCON.[5:6]);GO FORM2 END; 00039400 + COMMENT 8 INITIAL - ; 00039500 + ON(44) BEGIN IF NOT INMOK THEN SYNT ("MISPL -");PUT(8); 00039600 + GO TO FORM2 END; 00039700 + COMMENT 16 STRING ; 00039800 + ON(63) BEGIN IF NOT STROK THEN SYNT("ILL STR");PUT(16); 00039900 + SCAN CPR:APR:=POINTER(PROG[CS,2])+CP WHILE NEQ 63;A:=DELTA(APR,CPR); 00040000 + STRIN:=TRUE;IF A>14 THEN SYNT("LONGSTR");PUT(A);PUT(CP); 00040100 + CP:=CP+A+1;CHA:=NWC;VAR:=FALSE;GO TO FORM3 END; 00040200 + IF CHCONV(CHA)=0 THEN SYNT("ILL NUM"); 00040300 + B:=CHA;A:=LOOK(2) MOD 64;IF CHCONV(A) NEQ 0 THEN BEGIN 00040400 + A:=LOOK(3) MOD 4096;CHA:=B; 00040500 + IF A NEQ "ST" AND A NEQ "TH" AND A NEQ"TO" AND A NEQ "GO" THEN 00040600 + BEGIN LABEL EQL,FNQ,RDUM; 00040700 + COMMENT 5 STANDARD FNS; 00040800 + INTEGER B,AS,AP; 00040900 + B:=LOOK(3);CP:=LP; 00041000 + FOR A:=21 STEP 1 UNTIL 32 DO IF B=KEY[A] THEN GO TO EQL; 00041100 + GO TO FNQ; 00041200 + EQL: IF NWC NEQ 29 THEN SYNT("NO PARM");ARITH(1);RED; 00041300 + PUT(5);PUT(A-2); 00041400 + IF CHA NEQ 45 THEN SYNT("NO ) A");GO TO FORM1; 00041500 + COMMENT 4 USER FNS ; 00041600 + FNQ: K:=B DIV 64; IF K NEQ "FN" THEN SYNT("UNRC FN"); 00041700 + B:=CHCONV(B MOD 64);IF SUB[B]=0 THEN SYNT("UNDC FN"); 00041800 + IF NWC NEQ 29 THEN SYNT("NO PARM");A:=0; 00041900 + RDUM: A:=A+1;ARITH(1);RED;ON(58) GO TO RDUM; 00042000 + IF CHA NEQ 45 OR A NEQ SUB[B] THEN SYNT("PARAMTR"); 00042100 + CHA:=NWC;PUT(4);PUT(B);GO TO FORM2 END END; 00042200 + B:=CHCONV(B);IF B=0 THEN SYNT("INV VAR");CHA:=NWC; 00042300 + COMMENT 3 ARRAY ; 00042400 + ON(29) BEGIN IF ARR[B,1]=0 THEN SYNT("UNDC AR"); 00042500 + ARITH(1);RED;ON(58) BEGIN IF ARR[B,2]=0 THEN SYNT("SUBSCPT"); 00042600 + ARITH(1);RED END;IF CHA NEQ 45 THEN SYNT("SUBSCPT");STROK:=FALSE; 00042700 + PUT(3);PUT(B);CHA:=NWC END 00042800 + ELSE ON("$") BEGIN IF NOT STROK THEN SYNT("ILL STR"); 00042900 + COMMENT 15 STRING ARRAY; 00043000 + CHA:=NWC;ON(29)BEGIN IF STRAR[B,1]=0 THEN SYNT("UNDSTAR");ARITH(1); 00043100 + RED; 00043200 + IF CHA NEQ 45 THEN SYNT("NO ) ,5");PUT(15);CHA:=NWC END ELSE 00043300 + PUT(14);PUT(B);STRIN:=TRUE;VAR:=VOK;GO TO FORM3 END 00043400 + ELSE BEGIN PUT(2);PUT(B);IF CHA LSS 10 THEN BEGIN PUT(C:=CHA+1); 00043500 + COMMENT 14 STRING VBLE 00043600 + 2 VARIABLE ; 00043700 + CHA:=NCH END ELSE PUT(C:=0);IF STCK=0 THEN ADDR:=11|(B-1)+C; 00043800 + STROK:=FALSE END;VAR:=VOK;GO TO FORM3; 00043900 + FORM1: CHA:=NWC; 00044000 + FORM2: STROK:=VAR:=FALSE;IF STRIN THEN SYNT("ILL STR"); 00044100 + COMMENT 7-13 OPERATORS: 00044200 + DANGER: REVERSE POLISH SECTION ; 00044300 + FORM3: BEGIN LABEL RPT,TEST,BOP,XOP; 00044400 + STCK:=STCK+1;INMOK:=FALSE; 00044500 + RPT: I:=0;ON(16) I:=3 ELSE ON(44) I:=4 ELSE 00044600 + ON(43) BEGIN IF NWC=43 THEN I:=7 ELSE BEGIN CP:=CP-1;I:=5 END; 00044700 + END ELSE ON(49) I:=6 ELSE IF CHA=61 AND EQOK THEN BEGIN INMOK:=TRUE; 00044800 + IF NOT VAR THEN SYNT("ILL ASN");I:=1 END;VOK:=I LEQ 1; 00044900 + IF NOT VOK THEN BEGIN STROK:=FALSE;IF STRIN THEN SYNT("ILL STR") END; 00045000 + TEST: IF OP=0 THEN GO TO BOP; IF OP LSS 0 00045100 + THEN SYNT(" ARITH"); 00045200 + J:=OPK[OP];IF I|J NEQ 1 AND (I+1) DIV 2 LEQ (J+1) DIV 2 THEN BEGIN 00045300 + OP:=OP-1;GO TO XOP END; 00045400 + BOP: IF I=0 THEN GO TO FIN;OP:=OP+1;OPK[OP]:=1;GO TO SS; 00045500 + XOP: VAR:=FALSE;STCK:=STCK-1; 00045600 + PUT(J+6);IF STCK LEQ 0 THEN SYNT(" ARITH"); 00045700 + GO TO TEST END; 00045800 + COMMENT 6 END EXPN ; 00045900 + FIN: NDEP:=NDEP-1;IF STCK NEQ 1 THEN SYNT(" ARITH"); 00046000 + PUT(0) END; 00046100 + COMMENT 00046200 + --- SKIP SKIPS GIVEN STRING IF FOUND ; 00046300 + 00046400 + PROCEDURE SKIP(A,B);VALUE A,B;INTEGER A,B; 00046500 + BEGIN INTEGER C,D,E;E:=CP;C:=NWC; 00046600 + FOR D:=1 STEP 1 UNTIL A-1 DO IF CHA NEQ "%" THEN C:=C|64+NWC; 00046700 + IF C NEQ B THEN BEGIN CP:=E;CHA:=0 END END; 00046800 + COMMENT 00046900 + --- CHMAT CHECK USED IN MAT STATEMENT ; 00047000 + 00047100 + INTEGER PROCEDURE CHMAT(A);VALUE A;INTEGER A; 00047200 + BEGIN A:=CHCONV(A);IF A=0 THEN SYNT("ILL ARR"); 00047300 + IF ARR[A,1]=0 THEN SYNT("UNDC AR");IF ARR[A,2]=0 THEN 00047400 + SYNT(" TYPE");CHMAT:=A END; 00047500 + 00047600 + 00047700 + COMMENT ---- CFN FOR FILE INPUT ANO OUTPUT; 00047800 + 00047900 + PROCEDURE CFN; 00048000 + BEGIN LABEL L,M; 00048100 + CHA:=NWC;IF LOOK(4)="FILE" THEN BEGIN CP:=LP;D:=IF A=15 THEN 5 ELSE A; 00048200 + FOR C:=1 STEP 1 UNTIL NF DO BEGIN CHA:=NWC;B:=LOOK(FNM[2,C]); 00048300 + IF B=FNM[1,C] THEN BEGIN IF FNM[3,C]=0 THEN FNM[3,C]:=D ELSE IF D NEQ 00048400 + FNM[3,C] THEN SYNT("IN+OUT?");CP:=LP;PUT(A);IF D=5 THEN 00048500 + INFILTOG:=TRUE;IF A=7 THEN OUTFILTOG:=TRUE; 00048600 + IF NWC=":" THEN BEGIN A:=NUMB;FOR B:=ACS STEP 1 UNTIL MS DO 00048700 + IF A=SSEQ[B] THEN BEGIN PUT(B.[11:6]);PUT(B.[5:6]);GO ON(58) L ELSE M 00048800 + END;SYNT("UNDF GO") END;PUT(0);PUT(0);ON(58) GO L; 00048900 + GO TO M END ELSE BEGIN CP:=CP-1;CHA:=0 END END;SYNT("UNDC FL") END; 00049000 + PUT(0);ON("%") GO TO M;CP:=CP-1;CHA:=0;GO TO L; 00049100 + M: IF A=5 THEN SYNT("NOINPUT");PUT(0);GO TO INCST; 00049200 + L: END; 00049300 + 00049400 +COMMENT------------------------------------------------------- 00049500 +----------- XBASIC STARTS HERE ----------------- 00049600 +-------------------------------------------------------------; 00049700 + 00049800 + FIRSTOFF:=IU NEQ 2;IF IU=2 THEN TTY.TYPE:=1; 00049900 + PIBE:=POINTER(IOBE[1])+7; PINB:=POINTER(IOB[1]); 00050000 + DELIM:=72;TIM:=10800;LL:=-1; 00050100 + OBJECT:=HDDR:=FALSE;OU:=0; 00050200 + 00050300 + FILL KEY[*] WITH "LET","GOT","GOS","RET","INP", 00050400 + "REA","PRI","FOR","NFX","MAT","DEF","DAT", 00050500 + "RAN","PAG","RES","REM","STO","END","IF ","ON ","SIN","COS", 00050600 + "TAN","ATN","EXP","LOG","ABS","INT","SQR","FIX","SGN","RND", 00050700 + "EQ","LT","LE","GT","GE","NE"; 00050800 + 00050900 + COMMENT------------------------------------------------------ 00051000 +------------SOURCEIN: FOR INPUT OF SOURCE PROGRAM ------- 00051100 +------------ AND EXECUTION OF COMMANDS ------- 00051200 +-----------------------------------------------------------------; 00051300 + 00051400 + COMMENT: COMMANDS ALLOWED IN XBASIC 00051500 + 00051600 + HELLO SAME AS BYE 00051700 + BYE TERMINATES XBASIC. PRINTER OUTPUT IS SCHEDULED 00051800 + RUN EXECUTES PROGRAM IF FREE OF SYNTAX ERRORS 00051900 + SCR DELETES WORKFILE 00052000 + DELETE SAME AS SCR 00052100 + LIST LISTS ENTIRE WORKFILE 00052200 + LIST E WHERE E IS A NUMBER OF ELEMENTS OF FORM 00052300 + N OR M-N (M,N STATEMENT NUMBERS) 00052400 + SEPARATED BY COMMAS. LISTS PART OF PROGRAM 00052500 + MAKE NNNNNN INITIALISES AND NAMES WORKFILE 00052600 + SAVE SAVES WORKFILE IF NAMED 00052700 + SAVE NNNNNN SAVES WORKFILE IN NNNNNN. NAMES WORKFILE 00052800 + IF NOT ALREADY NAMED 00052900 + LOAD NNNNNN LOADS WORKFILE AND NAMES IT 00053000 + LOAD NNNNNN/UUUUUUU COPIES WORKFILE FROM NNNNNN/UUUUUUU 00053100 + WORKFILE BECOMES UNNAMED 00053200 + COPY NNNNNN COPIES NNNNNN INTO WORKFILE 00053300 + COPY NNNNNN/UUUUUUU SAME FOR NNNNNN/UUUUUUU 00053400 + REMOVE NNNNNN REMOVES FILE NNNNNN/USER NO. 00053500 + RENAME NNNNNN RENAMES WORKFILE 00053600 + PLOP RESETS WORKFILE TO LAST RUN STATUS 00053700 + WHATS OBTAINS WORKFILE STATUS 00053800 + TTY INPUT UNIT IS TTY 00053900 + VDU INPUT UNIT IS VDU 00054000 + SEND DIVERTS OUTPUT TO PRINTER 00054100 + NOSEND TERMINATES DIVERSION OF OUTPUT 00054200 + TIME N RESETS MAX EXECUTION TIME TO N MINUTES 00054300 +-------------------------------------------------------------; 00054400 + 00054500 + SOURCEIN: BEGIN LABEL SOURCEIN,EF,COPY,NEWL,SOURCE,RMOB, 00054600 + FST; 00054700 + 00054800 + INTOVR:=INER; 00054900 + IF FIRSTOFF THEN BEGIN FILECONTROL(5,"XBWKFL ",TIME(-1),FST); 00055000 + FST: IF IU=0 THEN WRITE(TTY,INVIT);FIRSTOFF:=FALSE END; 00055100 + IF LL=-1 THEN GO TO SOURCE; 00055200 + SOURCEIN: IF IU GTR 0 THEN GO TO SOURCE;PINB:=PINB+80; 00055300 + LL:=LL+1;IF LL LSS 24 THEN GO TO NEWL; 00055400 + SOURCE: LL:=0;IF IU GTR 0 THEN READ(FN[IU-1][STOP],10,IOB[*]) 00055500 + ELSE READ(VDU[STOP],240,IOB[*]); 00055600 + IF IU=2 THEN WRITE(TTY,10,IOB[*]); 00055700 + PINB:=POINTER(IOB[*]);IOBE[1]:=0; 00055800 + NEWL: C:=IF MS>0 THEN SSEQ[MS] ELSE 0;APR:=PINB;BPR:=PIBE; 00055900 + A:=NMBR(6);IF A=0 THEN BEGIN IF CHA="%" THEN GO TO SOURCEIN; 00056000 + COMMENT NONVOID INPUT WITH ZERO STATEMENT NO. MUST BE COMMAND; 00056100 + IOBE[1]:=0;REPLACE BPR-5 BY APR:CPR:=APR-1 FOR 1; 00056200 + REPLACE BPR-4 BY APR:APR FOR 5 WHILE IN ALPHA;CHA:=IOBE[1]; 00056300 + ON("RUN000") BEGIN IF OBJECT THEN BEGIN IF NMBR(72) NEQ 0 OR 00056400 + CHA NEQ "%" THEN GO PER;GO EXECUTE END 00056500 + ELSE IF IU=2 THEN GO COMPILE 00056600 + ELSE BEGIN WRITE(TTY,WT); 00056700 + FILECONTROL(4,"XBWKFL ",TIME(-1),COMPILE) END END; 00056800 + ON("DELETE" OR CHA="SCR000") BEGIN C:=NMBR(72); 00056900 + IF C NEQ 0 OR CHA NEQ "%" THEN GO PER;WRITE(TTY,F7); 00057000 + CS:=MS:=IO[0]:=0;DANGER:=OBJECT:=FALSE;GO SOURCEIN END; 00057100 + ON("LIST00") BEGIN 00057200 + 00057300 + COMMENT PROCESS LIST COMMAND; 00057400 + 00057500 + LABEL NEX,LEX; 00057600 + IF OU=1 THEN WRITE(TTY,DVO); 00057700 + WRITE(FL[OU],SPC); 00057800 + NEX: BEG:=NMBR(72);IF CHCONV(CHA) NEQ 0 THEN GO PER; 00057900 + EN:=ON("%" AND BEG=0) 1000000 ELSE ON(44) NMBR(72) ELSE BEG; 00058000 + IF CHCONV(CHA) NEQ 0 THEN GO PER; 00058100 + FOR A:=1 STEP 1 UNTIL MS DO IF SSEQ[A] LEQ EN 00058200 + AND SSEQ[A] GEQ BEG THEN BEGIN 00058300 + REPLACE POINTER(IOBE[1]) BY " " FOR 112; 00058400 + WRITE(IOBE[*],NUM[2|OU],SSEQ[A]); 00058500 + SCAN CPR:POINTER(IOBE[1])+20|OU FOR 20 WHILE NEQ 48; 00058600 + REPLACE CPR BY POINTER(PROG[A,2]) FOR 72;WRITE(FL[OU],14,IOBE[*]) 00058700 + END;ON(58) GO TO NEX;WRITE(TTY,STP,"LIST ");GO TO SOURCEIN END; 00058800 + ON("RENAME") FILECONTROL(0," NAMED"," ",SOURCEIN); 00058900 + ON("MAKE00") FILECONTROL(0,"CREATE","D",SOURCEIN); 00059000 + ON("SAVE00") FILECONTROL(1," SAVED"," ",SOURCEIN); 00059100 + 00059200 + ON("LOAD00") FILECONTROL(2," LOADE","D",SOURCEIN); 00059300 + ON("REMOVE") FILECONTROL(3,"REMOVE","D",SOURCEIN); 00059400 + ON("COPY00") FILECONTROL(2," COPIE",0,SOURCEIN); 00059500 + ON("BYE000" OR CHA="HELL00") BEGIN IF IU=2 THEN GO FINSH; 00059600 + FILECONTROL(6,"XBWKFL ",TIME(-1),FINSH) END; 00059700 + ON("SEND00") BEGIN OU:=1;IF NOT HDDR THEN BEGIN 00059800 + WRITE(LIN,HD3,TIME(6),TIME(5).[23:12],TIME(5).[35:12],TIME(5).[11:12], 00059900 + TIME(-1).[41:18],TIME(-1).[23:24]); 00060000 + HDDR:=TRUE END;WRITE(TTY,HD1);GO SOURCEIN END; 00060100 + ON("NOSEND") BEGIN OU:=0;WRITE(TTY,STP,"NOSEND");GO TO SOURCEIN END; 00060200 + ON("TTY000") BEGIN IU:=1;WRITE(TTY,STP,"SETTTY");GO TO SOURCE END; 00060300 + ON("VDU000") BEGIN IU:=0;WRITE(TTY,STP,"SETVDU");GO TO SOURCEIN END; 00060400 + ON("TIME00") BEGIN TIM:=3600|NMBR(10);WRITE(TTY,STP,"SETTIM"); 00060500 + GO TO SOURCEIN END; 00060600 + ON("PLOP00") FILECONTROL(5,0,0,SOURCEIN); 00060700 + ON("WHATSO") BEGIN WRITE(TTY,F9);IF IO[0]=0 THEN 00060800 + WRITE(TTY,F10,MS,SSEQ[MS]) ELSE 00060900 + WRITE(TTY,F11,IO[0].[41:36],MS,SSEQ[MS]); 00061000 + GO SOURCEIN END; 00061100 + % ILLEGAL COMMAND 00061200 + WRITE(TTY,WHT," "&CHA[35:35:6|DELTA(CPR,APR)]);GO SOURCEIN END; 00061300 + 00061400 + COMMENT PROCESS SOURCE STATEMENT; 00061500 + 00061600 + OBJECT:=FALSE;DANGER:=TRUE; 00061700 + 00061800 + COMMENT DELETE STATEMENT; 00061900 + 00062000 + ON("%") BEGIN CHA:=A;FOR A:=1 STEP 1 UNTIL MS DO 00062100 + ON(SSEQ[A]) BEGIN MS:=MS-1;FOR B:=A STEP 1 UNTIL MS DO 00062200 + BEGIN SSEQ[B]:=SSEQ[B+1];WRITE(PROG[B,*],10,PROG[B+1,*]) END END; 00062300 + GO TO SOURCEIN END; 00062400 + CHA:=A;APR:=APR-1; 00062500 + 00062600 + COMMENT ADD NEW LAST STATEMENT; 00062700 + 00062800 + IF CHA GTR C THEN BEGIN CS:=MS;MS:=A:=MS+1; 00062900 + IF MS GTR 200 THEN GO TOOLONG; 00063000 + GO TO COPY END; 00063100 + 00063200 + COMMENT REPLACE EARLIER STATEMENT; 00063300 + FOR A:=1 STEP 1 UNTIL MS DO ON(SSEQ[A]) GO TO COPY 00063400 + ELSE IF CHA LSS SSEQ[A] THEN BEGIN MS:=MS+1; 00063500 + 00063600 + COMMENT INSERT STATEMENT; 00063700 + 00063800 + IF MS GTR 200 THEN GO TO TOOLONG; 00063900 + FOR B:=MS STEP -1 UNTIL A+1 DO 00064000 + BEGIN SSEQ[B]:=SSEQ[B-1];WRITE(PROG[B,*],10,PROG[B-1,*]) END; 00064100 + GO TO COPY END; 00064200 + COPY: PROG[A,11]:=SSEQ[A]:=CHA; 00064300 + REPLACE BPR:CPR:=POINTER(PROG[A,2]) BY " " FOR 1; 00064400 + B:=DELTA(APR,PINB+80);IF B>71 THEN B:=71; 00064500 + REPLACE BPR:BPR BY APR FOR B WHILE NEQ "!"; 00064600 + REPLACE BPR BY " " FOR 72-DELTA(CPR,BPR);GO SOURCEIN END SOURCEIN; 00064700 + INER: WRITE(TTY,INTR);GO TO SOURCEIN; 00064800 + TOOLONG: WRITE(TTY,LNGPRG,SSEQ[CS]);GO TO SOURCEIN; 00064900 + PER: WRITE(TTY,F12);GO SOURCEIN; 00065000 + COMMENT---------------------------------------------------------- 00065100 +-------------------- END SOURCEIN --------------------------- 00065200 +------------------------------------------------------------------ 00065300 +----------- COMPILE: SEARCH FOR SYNTAX ERRORS --------- 00065400 +----------- AND MAKE PSEUDO-OBJECT CODE --------- 00065500 +--------------------------------------------------------------------; 00065600 + COMMENT 00065700 + SYNTAX ERROR MESSAGES: OUTPUT AFTER "RUN" 00065800 + WITH NEW FAULTY PROGRAM 00065900 + 00066000 + ARITH MISSING OPERATOR OR OPERAND IN ARITHMETIC 00066100 + EXPRESSION (SHOULD NOT OCCUR) 00066200 + FILES PROGRAM CAN HAVE ONLY ONE INPUT AND ONE OUTPUT 00066300 + FILE 00066400 + IL GOSB THIS STATEMENT HAS BEEN ILLEGALLY REFERENCED 00066500 + BY A GOSUB STATEMENT (IT IS IN A FOR LOOP) 00066600 + IL RELN AN ILLEGAL RELATION OF FORM X?? HAS BEEN 00066700 + FOUND IN AN IF STATEMENT 00066800 + ILL ARR ARRAY NAME EXPECTED BUT CHARACTER IS NOT 00066900 + A LETTER 00067000 + ILL ASN AN ASSIGNMENT IS ATTEMPTED BUT LEFT HAND SIDE 00067100 + IS NOT A VARIABLE 00067200 + ILL FN THE NAME OF A DEFINED FUNCTION MUST BE OF FORM 00067300 + FN LETTER. PARAMETER(S) MUST BE SUPPLIED. 00067400 + ILL FOR A FOR STATENENT IS ALREADY IN OPERATION 00067500 + FOR THIS VARIABLE 00067600 + ILL NEX NEXT MUST REFER TO AN UNSUBSCRIPTED REAL VBLE 00067700 + ILL NUM A PRIMARY IS MISSING OR ILLEGAL 00067800 + ILL STR A STRING PRIMARY HAS BEEN ENCOUNTERED IN 00067900 + A REAL EXPRESSION 00068000 + IL STMT ILLEGAL STATEMENT 00068100 + INV IF STRINGS CAN ONLY BE COMPARED FOR EQUALITY 00068200 + OR INEQUALITY 00068300 + INV PAR A FORMAL PARAMETER IN A DEF STATEMENT 00068400 + MUST BE A VARIABLE 00068500 + INV VAR A PRIMARY IS MISSING OR ILLEGAL. IN A READ 00068600 + STATEMENT EVERY EXPRESSION MUST CONSIST OF 00068700 + A SINGLE VARIABLE PRIMARY. 00068800 + IN+OUT? A FILE IS BEING USED FOR INPUT AND OUTPUT 00068900 + LONGSTR A STRING CONTAINS MORE THAN 14 CHARACTERS 00069000 + IN A STATEMENT OTHER THAN PRINT. 00069100 + MISG OP AN OPERAND ESSENTIAL TO THIS STATEMENT HAS 00069200 + BEEN OMITTED (END OF STATEMENT ERROR). 00069300 + MISP = MISPLACED OR MISSING = IN DEF STATEMENT 00069400 + MISPL - A - SIGN HAS BEEN PLACED ILLEGALLY IN AN 00069500 + EXPRESSION (E.G. A*-B). 00069600 + NAME PROBABLY CAUSED BY ILLEGAL FILENAME 00069700 + NESTING INCORRECTLY NESTED FOR AND NEXT STATEMENTS 00069800 + NO ) X MISSING PARENTHESES: X=A IN ARITH EXPRESSION 00069900 + NO ( X P IN FUNCTION PARAMETER 00070000 + S IN SUBSCRIPT 00070100 + F IN FILE DECLARATION 00070200 + NO EXPN E HAS BEEN FOUND IN A NUMBER BUT NO EXPONENT 00070300 + FOLLOWS 00070400 + NO FOR A NEXT STATEMENT HAS NO CORRESPONDING FOR 00070500 + NOINPUT INPUT STATEMENT MUST HAVE LIST OF VARIABLES 00070600 + NO NEXT A FOR STATEMENT EARLIER IN PROGRAM HAS NO NEXT 00070700 + NO PARM EVERY FUNCTION MUST HAVE PARAMETER(S) IN 00070800 + BRACKETS 00070900 + NO PROG THERE IS NO PROGRAM TO RUN 00071000 + NO RELN NO RELATION HAS BEEN FOUND IN AN IF STATEMENT 00071100 + NO SEPR CONSECUTIVE ARITH EXPRESSIONS IN PRINT 00071200 + STATEMENT MUST BE SEPARATED BY , OR SEMICOLON 00071300 + NO TO A FOR STATEMENT MUST HAVE A FINAL VALUE 00071400 + (FOR X=1 TO 10 ETC.) 00071500 + NOT END THE LAST STATEMENT MUST BE AN END STATEMENT 00071600 + NOTLAST THE END STATEMENT MUST BE THE LAST STATEMENT 00071700 + OVERFLW A NUMBER IS TOO LARGE 00071800 + QUOTES MISMATCHED STRING QUOTES 00071900 + REDC AR ARRAY TWICE DIMENSIONED 00072000 + REDC FN A FUNCTION HAS BEEN DEFINED MORE THAN ONCE 00072100 + SAMEFIL A FILE HAS BEEN DECLARED MORE THAN ONCE 00072200 + PARAMTR WRONG NUMBER OF PARAMETERS IN A FUNCTION CALL 00072300 + SIMPLFY AN EXPRESSION IS NESTED TO A DEPTH OF 10 OR 00072400 + MORE AND SHOULD RE BROKEN UP 00072500 + SIZE AN ARRAY DIMENSION IS GREATER THAN 64 OR 00072600 + (IN MAT STATEMENT) IS GREATER THAN THE DECLARED 00072700 + DIMENSION OF THE ARRAY 00072800 + STORAGE ARRAY STORAGE HAS BEEN EXCEEDED (700 WORDS OF 00072900 + TYPE REAL, 70 OF TYPE ALPHA) 00073000 + STR >63 ILLEGAL OBJECT CHARACTER (E.G. PRINT STRING 00073100 + HAS >63 CHARS OR STARTS LATER THAN COL 63) 00073200 + STR=STR A STRING CAN ONLY BE COMPARED WITH ANOTHER 00073300 + SUBSCPT AN ARRAY REFERENCE HAS THE WRONG NUMBER OF 00073400 + SUBSCRIPTS 00073500 + TOO MCH PROCESSING OF THE SOURCE STATEMENT HAS NOT 00073600 + USED UP ALL THE INFORMATION IN IT. (CAN BE 00073700 + CAUSED BY OMISSION OF AN OPERATOR IN AN 00073800 + EXPRESSION) 00073900 + TYPE AN ATTEMPT HAS BEEN MADE TO USE A MAT STATEMENT 00074000 + FOR A 1-DIMENSIONAL ARRAY 00074100 + UNDC AR AN ARRAY HAS BEEN REFERENCED BUT NOT DECLARED 00074200 + UNDC FL A FILE HAS BEEN REFERENCED BUT NOT DECLARED 00074300 + UNDC FN A FUNCTION OF TYPE FN* HAS BEEN REFERENCED BUT 00074400 + NOT DECLARED 00074500 + UNDF GO THERE IS NO STATEMENT IN THE PROGRAM WITH THE 00074600 + SEQUENCE NUMBER REFERENCED BY THIS STATEMENT 00074700 + UNDSTAR A STRING ARRAY HAS BEEN REFERENCED BUT NOT 00074800 + DECLARED 00074900 + UNRC FN A FUNCTION NAME OR KEYWORD HAS BEEN MISSPELLED 00075000 + OR MISPLACED 00075100 + 3 FILES NOT MORE THAN TWO FILES MAY BE DECLARED 00075200 + 11 FORS FOR STATEMENTS NESTED TOO DEEP 00075300 + :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::; 00075400 + 00075500 + COMPILE: 00075600 + 00075700 + COMMENT IN THE FOLLOWING COMMENTS, 00075800 + IS ANY EXPRESSION (POSSIBLY WITH =) 00075900 + IS ANY LETTER 00076000 + IS ANY VARIABLE PRIMARY 00076100 + IS ANY UNSIGNED INTEGER 00076200 + IS A STATEMENT NUMBER 00076300 + IS A FILENAME 00076350 + 00076400 + ALLOWED VARIANTS ARE LISTED BELOW. THREE LETTER 00076500 + ABBREVIATIONS OF INITIAL KEYWORDS ARE ALLOWED WHERE UNAMBIGUOUS.00076600 + SPACES ARE IGNORED EXCEPT INSIDE STRING QUOTES; 00076700 + 00076800 + INTOVR:=INTVR;INDEX:=QUOTE;FLAG:=FLAGR; 00076900 + MSTO:=287;MSTR:=27;INFILTOG:=OUTFILTOG:=FALSE; 00077000 + FOR A:=1 STEP 1 UNTIL 26 DO STRAR[A,1]:=ARR[A,1]:=ARR[A,2]:=SUB[A]:=0; 00077100 + IO[1]:=IO[2]:=FNM[2,1]:=FNM[2,2]:=FNM[3,1]:=FNM[3,2]:=AREASIZE:=0; 00077200 + NDEP:=CO:=1;POB:=POINTER(OBJ[*]); 00077300 + CS:=0;SY:=EQOK:=TRUE; 00077400 + IF MS =0 THEN SYNT("NO PROG"); 00077500 + FORE:=FORC:=NCON:=0;FOR A:=1 STEP 1 UNTIL 200 DO STYP[A]:=0; 00077600 + 00077700 + COMMENT FILES 00077800 + FILES ,.. 00077900 + WHERE IS (EXISTING FILE) 00078000 + OR () (FILE TO BE CREATED: N=MAX NO OF RECS) 00078100 + WHERE IS A CANDE FILENAME 00078200 + THERE CAN ONLY BE ONE FILES STATEMENT. IT MUST BE THE FIRST STATEMENT. 00078300 + THERE CAN BE AT MOST ONE INPUT FILE AND ONE OUTPUT FILE; 00078400 + 00078500 + FIL: ACS:=CS:=CS+1;CP:=CHA:=0;CHA:=NWC;B:=LOOK(3); 00078600 + IF B="REM" THEN GO FIL;IF B="FIL" THEN BEGIN CP:=LP;SKIP(2,"ES");A:=0; 00078700 + RFIL: A:=A+1;IF A>3 THEN SYNT("3 FILES"); 00078800 + CHA:=NWC;IO[A]:=" ";BPR:=POINTER(PROG[CS,2])+CP-1; 00078900 + SCAN APR:BPR FOR 6 WHILE IN ALPHA;FNM[2,A]:=B:=DELTA(BPR,APR); 00079000 + REPLACE POINTER(IO[A])+1 BY BPR FOR B;FNM[1,A]:=LOOK(B);CP:=LP; 00079100 + NF:=A;CHA:=NWC;ON("(") BEGIN AREASIZE:=NUMB/20+1;FNM[3,A]:=7; 00079200 + IF CHA NEQ ")" THEN SYNT("NO ) ,F");CHA:=NWC END;ON(",") GO TO RFIL; 00079300 + IF A=2 AND IO[1]=IO[2] THEN SYNT("SAMEFIL");IF CHA NEQ "%" THEN 00079400 + SYNT("TOO MCH") END ELSE CS:=0; 00079500 + IF ACS>MS THEN SYNT("NO PROG"); 00079600 + COMMENT DIM 00079700 + DIM (),... 00079800 + DIMENSION (),... 00079900 + WHERE IS OR $ 00080000 + IS OR , 00080100 + DIM STATEMENTS MUST PRECEDE ALL EXECUTABLE STATEMENTS 00080200 + STRING ARRAY MUST BE ONE-DIMENSIONAL. 00080300 + ALL DIMENSIONS MUST BE <64. 00080400 + 713 WORDS REAL AND 73 STRINGS ARE AVAILABLE FOR ARRAYS ; 00080500 + 00080600 + DIM: ACS:=CS:=CS+1;CP:=CHA:=0;CHA:=NWC; 00080700 + B:=LOOK(3);IF B="REM" THEN GO DIM; 00080800 + IF B="DIM" THEN BEGIN CP:=LP;SKIP(6,"ENSION"); 00080900 + RDIM: K:=CHCONV(NWC);IF K=0 THEN SYNT("ILL ARR"); 00081000 + IF NWC="$" THEN BEGIN STRAR[K,0]:=MSTR;IF NWC NEQ "(" THEN 00081100 + SYNT("NO ( ,S");A:=STRAR[K,1]:=NUMB;MSTR:=MSTR+A; 00081200 + IF CHA NEQ ")" THEN SYNT("NO ) ,S");IF NWC="," THEN GO TO RDIM; 00081300 + GO TO DIM END; ARR[K,0]:=MSTO;IF CHA NEQ "(" THEN SYNT("NO ( ,S"); 00081400 + IF ARR[K,1] NEQ 0 THEN SYNT("REDC AR"); 00081500 + B:=ARR[K,1]:=NUMB;IF B>64 THEN SYNT(" SIZE "); 00081600 + ON(",") BEGIN A:=ARR[K,2]:=NUMB;B:=B|A END; 00081700 + MSTO:=MSTO+B;IF MSTO GTR 1000 THEN SYNT("STORAGE"); 00081800 + IF CHA NEQ ")" THEN SYNT("NO ) ,S");IF NWC="," THEN GO TO RDIM; 00081900 + GO TO DIM END;IF ACS>MS THEN SYNT("NO PROG"); 00082000 + 00082100 + COMMENT PROGRAM COMPILATION BEGINS HERE ; 00082200 + 00082300 + FOR CS:=ACS STEP 1 UNTIL MS DO BEGIN 00082400 + COMMENT IF GOSUB ENTRY THEN FIX FOR LEVEL ; 00082500 + EXS: IF STYP[CS] NEQ 0 THEN BEGIN IF FORC NEQ FORE THEN 00082600 + SYNT("IL GOSB");FORE:=FORC:=STYP[CS] END; 00082700 + COMMENT IDENTITY STATEMENT TYPE ; 00082800 + NDEP:=CP:=CHA:=0;CHA:=NWC;B:=LOOK(3);EQOK:=TRUE; 00082900 + FOR A:=1 STEP 1 UNTIL 18 DO IF B=KEY[A] THEN GO TO EQL; 00083000 + IF B="DIM" OR B="FIL" THEN BEGIN WRITE(TTY,F6,SSEQ[CS]); 00083100 + GO SOURCEIN END; 00083200 +%IF B="TRA" THEN BEGIN STYP[CS]:=20;GO REM END; 00083300 +%IF B="UNT" THEN BEGIN STYP[CS]:=21;GO REM END; 00083400 + B:=B DIV 64; 00083500 + IF B="IF" THEN BEGIN LP:=LP-1;A:=19;GO TO EQL END; 00083600 + IF B="ON" THEN BEGIN LP:=LP-1;A:=20;GO TO EQL END; 00083700 + LP:=0;A:=1; 00083800 + EQL: CP:=LP;STYP[CS]:=A;SPOB[CS]:=CO; 00083900 + IF CS=MS AND A NEQ 18 THEN SYNT("NOT END");GO TO OPN[A]; 00084000 + COMMENT 1 LET 00084100 + LET 00084200 + 00084300 + WHERE E MAY BE A STRING ASSIGNMENT ; 00084400 + 00084500 + LET: ARITH(0);GO TO INCST; 00084600 + CAR: ARITH(1); GO TO INCST; 00084700 + COMMENT 20 ON 00084800 + ON GO TO ,... ; 00084900 + 00085000 + ONX: ARITH(1);SKIP(3,"OTO"); 00085100 + RON: A:=NUMB;FOR B:=ACS STEP 1 UNTIL MS DO IF A=SSEQ[B] 00085200 + THEN BEGIN PUT(B.[11:6]);PUT(B.[5:6]); 00085300 + IF STYP[CS]=3 AND STYP[B] IF THEN 00085900 + IF GO TO 00086000 + IS AN EXPRESSION WITHOUT = 00086100 + IS ONE OF THE FOLLOWING 00086200 + |EQ |GT |LT |GE |LE |NE 00086300 + = > < >= <= <> 00086400 + STRINGS CAN BE COMPARED ONLY FOR EQUALITY OR INEQUALITY; 00086500 + 00086600 + IFF: EQOK:=FALSE;ARITH(0);EQOK:=TRUE; 00086700 + C:=IF STRIN THEN 0 ELSE 1; 00086800 + B:=0;IF CHA=30 THEN BEGIN B:=B+2;CHA:=NWC END; 00086900 + IF CHA=14 THEN BEGIN B:=B+4;CHA:=NWC END;IF CHA=61 THEN B:=B+1 00087000 + ELSE CP:=CP-1;IF B=0 THEN CHA:=NWC ELSE GO TO FEQ; 00087100 + IF CHA NEQ "|" THEN SYNT("NO RELN");CHA:=NWC; 00087200 + A:=CHA|64+NWC;FOR B:=1 STEP 1 UNTIL 6 DO IF A=KEY[B+32] 00087300 + THEN GO TO FEQ;SYNT("IL RELN"); 00087400 + FEQ: PUT(B);ARITH(C);IF C=0 AND NOT STRIN THEN SYNT("STR=STR"); 00087500 + IF STRIN AND B NEQ 1 AND B NEQ 6 THEN SYNT("INV IF "); 00087600 + SKIP(3,"OTO");SKIP(3,"HEN");GO TO RON; 00087700 + COMMENT 2 GO TO 00087800 + GO TO ; 00087900 + 00088000 + GOT: SKIP(1,"0");GO TO RON; 00088100 + COMMENT 3 GOSUB 00088200 + GOSUB ; 00088300 + 00088400 + GOS: SKIP(2,"UB");GO TO RON; 00088500 + COMMENT 4 RETURN 00088600 + RETURN ; 00088700 + 00088800 + RET: SKIP(3,"URN");CHA:=NWC;GO TO INCST; 00088900 + COMMENT 8 FOR 00089000 + FOR TO STEP 00089100 + FOR TO ; 00089200 + 00089300 + COMMENT DURING COMPILE, FOR INFO IS STORED IN FORX AS FOLLOWS: 00089400 + 2 3 4 00089500 + OBJPOINTER TO STORE NEXTLINE FORLINE ADDR 00089600 + 00089700 + EACH FOR IS ASSIGNED A LEVEL (=FORC), WHICH 1S USED TO CHECK 00089800 + NESTING AND DURING EXECUTION. IN SUBROUTINES FORC IS INITIALISED 00089900 + TO MAX FORC OF CALLING (GOSUB) STATEMENT: THIS LEVEL 1S STORED 00090000 + TEMPORARILY IN STYP. OBJECT FORM OF FOR STATEMENT IS AS FOLLOWS: 00090100 + LEVEL ASSIGN FINAL INCREMENT NEXTLINE ; 00090200 + 00090300 + FOX: FORC:=FORC+1;PUT(FORC);IF FORC>10 THEN SYNT("11 FORS"); 00090400 + ARITH(1);FORX[FORC,4]:=ADDR+1;IF CHA NEQ "T" THEN SYNT(" NO TO"); 00090500 + SKIP(1,"0");FOR A:=1 STEP 1 UNTIL FORC-1 DO IF FORX[A,4]=ADDR THEN 00090600 + SYNT("ILL FOR");ARITH(1);IF CHA="S" THEN BEGIN SKIP(3,"TEP");ARITH(1) 00090700 + END ELSE PUT(0);FORX[FORC,2]:=CO;PUT(0);PUT(0);FORX[FORC,3]:=CS; 00090800 + GO INCST; 00090900 + COMMENT 9 NEXT 00091000 + NEXT 00091100 + WHERE IS A VARIABLE NAME ; 00091200 + 00091300 + NEX: SKIP(1,"T");B:=CHCONV(NWC)-1;IF B=-1 THEN SYNT("ILL NEX"); 00091400 + IF NWC LSS 10 THEN BEGIN B:=11|B+CHA+1;CHA:=NWC END ELSE B:=11|B; 00091500 + IF FORC=FORE THEN SYNT("NO FOR "); 00091600 + IF B+1 NEQ FORX[FORC,4] THEN SYNT("NESTING"); 00091700 + A:=CO;CO:=FORX[FORC,2];PUT(CS.[11:6]);PUT(CS.[5:6]); 00091800 + CO:=A;SPOB[CS]:=FORC+16|FORX[FORC,3];FORX[FORC,4]:=0;FORC:=FORC-1; 00091900 + GO INCST; 00092000 + COMMENT 11 DEF 00092100 + DEF FN(....)= 00092200 + FORMAL PARAMETERS MUST BE SINGLE LETTERS ; 00092300 + 00092400 + DEF: SKIP(3,"INE");SKIP(2,"FN");K:=CHCONV(NWC); 00092500 + IF K=0 OR NWC NEQ 29 THEN SYNT(" ILL FN");A:=0;PUT(K); 00092600 + IF SUB[K] NEQ 0 THEN SYNT("REDC FN"); 00092700 + RDUM: A:=A+1;B:=11|CHCONV(NWC)-11;IF B=-11 THEN SYNT("INV PAR"); 00092800 + CONST[NCON+A]:=B;IF NWC=58 THEN GO RDUM;IF CHA NEQ 45 THEN SYNT 00092900 + (" NO ) P");SUB[K]:=A;FOR B:=A STEP -1 UNTIL 1 DO BEGIN 00093000 + PUT((C:=CONST[NCON+B]).[11:6]);PUT(C.[5:6]) END; 00093100 + IF NWC NEQ "=" THEN SYNT("MISP = ");ARITH(1);SUB[K]:=A;GO TO INCST; 00093200 + COMMENT 6 READ 00093300 + READ ,... ; 00093400 + 00093500 + REA: SKIP(1,"D"); 00093600 + RREA: ARITH(0);IF NOT VAR THEN SYNT("INV VAR"); 00093700 + ON(58) GO TO RREA;PUT(0);GO TO INCST; 00093800 + COMMENT 5 INPUT 00093900 + INPUT ,... 00094000 + INPUT FILE ,,... 00094100 + WHERE IS THE FILENAME; 00094200 + INP: SKIP(2,"UT");CFN;GO TO RREA; 00094300 + COMMENT 13 RANDOMISE 00094400 + RANDOMISE 00094500 + RANDOMIZE ; 00094600 + RAN: SKIP(6,"DOMISE");SKIP(6,"DOMIZE");CHA:=NWC;GO TO INCST; 00094700 + COMMENT 15 RESTORE 00094800 + RESTORE 00094900 + RESTORE FILE 00094930 + WHERE IS THE INPUT FILE ; 00094960 + RES: SKIP(4,"TORE");CFN; GO TO INCST; 00095000 + COMMENT 7 PRINT 00095100 + PRINT

00095200 + PRINT FILE ,,... 00095300 + WHERE IS A FILENAME 00095400 + WHERE

IS A NUMBER OF ELEMENTS OF FORM 00095500 + "" 4 00095600 + , 2 OR 6, 1 00095700 + ; COMMENT 2 OR 6 00095800 + , 1 (1,5 IF TRAILS00095900 + ; COMMENT 5 IF TRAILS 00096000 + TAB() 3 00096100 + WHERE IS ANY STRING 00096200 + WHERE IS "" OR ; 00096300 + 00096400 + PRI: SKIP(2,"NT");CFN;CHA:=NWC;AA:=FALSE; 00096500 + RPRI: ON("%") BEGIN PUT(0);GO TO INCST END; 00096600 + ON(58) BEGIN PUT(1);AA:=FALSE; 00096700 + IF NWC="%" THEN BEGIN PUT(5); GO TO INCST END 00096800 + ELSE GO TO RPRI END; 00096900 + ON(";" OR CHA=":") BEGIN AA:=FALSE;IF NWC="%" THEN BEGIN PUT(5); 00097000 + GO INCST END;GO TO RPRI END; 00097100 + ON(63) BEGIN AA:=FALSE;PUT(4);PUT(CP);CPR:=POINTER(PROG[CS,2])+CP; 00097200 + SCAN APR:CPR UNTIL=63;B:=DELTA(CPR,APR);PUT(B); 00097300 + CP:=CP+B+1;CHA:=NWC;GO TO RPRI END; 00097400 + IF LOOK(4)="TAB(" THEN BEGIN AA:=FALSE;PUT(3);CP:=LP;ARITH(1); 00097500 + IF CHA NEQ 45 THEN SYNT("NO ) P");CHA:=NWC;GO TO RPRI END; 00097600 + CP:=CP-1;IF AA THEN SYNT("NO SEPR");AA:=TRUE; 00097700 + B:=CO;PUT(2);ARITH(0);IF STRIN THEN 00097800 + REPLACE POB+B BY "6" FOR 1;GO TO RPRI; 00097900 + COMMENT 14 PAGE 00098000 + PAGE ; 00098100 + PAG: SKIP(1,"E");CHA:=NWC;GO TO INCST; 00098200 + COMMENT 10 MAT 00098300 + MAT READ 1 00098400 + MAT READ (,) 1 00098500 + MAT PRINT 2 00098600 + MAT PRINT (,) 2 00098700 + MAT LET =()* 4 00098800 + MAT =()* 4 00098900 + MAT LET = 3 00099000 + MAT = 3 00099100 + WHERE IS AS DESCRIBED IN EXECUTE(PROCEDURE MATOP) ; 00099200 + MAT: CHA:=NWC;A:=LOOK(4);IF A="READ" THEN BEGIN PUT(1);CP:=LP; 00099300 + GO TO IOMT END;IF A="PRIN" THEN BEGIN PUT(2);CP:=LP;SKIP(1,"T"); 00099400 + GO TO IOMT END;CP:=CP-1;SKIP(3,"LET");A:=CP;B:=CHMAT(NWC);CHA:=NWC; 00099500 + IF NWC=29 THEN BEGIN PUT(4);PUT(B);ARITH(1);CHA:=NWC;PUT(CHMAT(NWC)); 00099600 + END ELSE BEGIN PUT(3);PUT(A) END;GO TO REM; 00099700 + IOMT: K:=CHMAT(NWC);PUT(K);IF NWC=29 THEN BEGIN 00099800 + FOR B:=1,2 DO BEGIN A:=NUMB;IF A LSS 0 OR A GTR ARR[K,B] THEN 00099900 + SYNT(" SIZE");PUT(A) END;CHA:=NWC; 00100000 + END ELSE BEGIN PUT(ARR[K,1]);PUT(ARR[K,2]) END; 00100100 + PUT(ON(";") 1 ELSE 0);ON(";") CHA:=NWC;GO TO INCST; 00100200 + COMMENT 12 DATA 00100300 + DATA ,... ; 00100400 + DAT: SKIP(1,"A"); 00100500 + RDAT: ARITH(0);ON(58) GO TO RDAT;PUT(0);GO INCST; 00100600 + COMMENT 17 STOP 00100700 + STOP 00100800 + 18 END 00100900 + END ; 00101000 + ENX: IF CS NEQ MS AND A=18 THEN SYNT("NOTLAST");CHA:=NWC; 00101100 + IF A=17 THEN CHA:=NWC; 00101200 + INCST: IF CHA NEQ "%" THEN SYNT("TOO MCH"); 00101300 + COMMENT 16 REM 00101400 + REM 00101500 + WHERE IS ANYTHING ; 00101600 + REM:ERR: END; 00101700 + 00101800 + % SORT OUT FILES IF 2 TO BE USED 00101900 + CS:=MS;IF NF=2 AND FNM[3,1]=FNM[3,2] THEN SYNT(" FILES "); 00102000 + IF FNM[3,1]=7 THEN BEGIN IO[3]:=IO[1];IO[1]:=IO[2]; 00102100 + IO[2]:=IO[3] END; 00102200 + IF NOT SY THEN BEGIN WRITE(TTY,STP,"ERRORS");GO TO SOURCEIN END; 00102300 + OBJECT:=TRUE;GO TO EXECUTE; 00102400 + 00102500 + INTVR: SYNT("OVERFLW"); QUOTE: SYNT(" QUOTES"); 00102600 + FLAGR: SYNT("NAME "); 00102700 + 00102800 + 00102900 + COMMENT----------------------------------------------------------------00103000 +-------------- END COMPILE ------------------------00103100 +------------------------------------------------------------------------00103200 +-------------- EXECUTE: EXECUTION OF --------------------00103300 +-------------- USERS PROGRAM --------------------00103400 +-----------------------------------------------------------------------;00103500 + EXECUTE: BEGIN 00103600 + 00103700 + FILE IN FIL1 DISK " "(2,10,300); 00103800 + FILE OUT FIL2 DISK[20:AREASIZE] " "(2,10,300,SAVE 7); 00103900 + 00104000 + INTEGER ARRAY SVE[1:10], % HOLDS GOSUB CALLS 00104100 + FUNC[1:26], % DEFINES 00104200 + STRGS[-1:100,0:2], % STRINGS 00104300 + IOB[1:14], % I/O PSEUDOBUFFER 00104400 + IOF[1:10], % " 00104500 + ADR[0:20]; % ADDRESS STCK FOR EVAL 00104600 + 00104700 + ARRAY STORE[0:1000], % HOLDS VARIABLE VALUES ETC 00104800 + STK[0:20]; % VALUE STACK FOR EVAL 00104900 + 00105000 + INTEGER XRND, % PSEUDO-RANDOM NUMBER INDEX 00105100 + CO, % CURRENT POSITION IN OBJ[*] 00105200 + RDAT, % DATA STATEMENT 00105300 + NGOT, % GO COUNTER 00105400 + SLVE, % GOSUB COUNTER 00105500 + RDTP, % POSITION IN DATA STATEMENT 00105600 + MSTO, % TOP OF STORE[*] 00105700 + MSTR, % TOP OF STRGS[*, ] 00105800 + IR, % INPUT FILE SEQUENCE NO 00105850 + NR, % OUTPUT FILE COUNTER 00105900 + RT, % RUN TERMINATION TIME 00106000 + MF, % FILE (0=TTY,OTHERWISE DISK) 00106100 + STCK, % STACK POINTER FOR EVAL 00106200 + A,B,C,D,I,J,K,L,U,V,W,X,Y,Z,AS; 00106300 + 00106400 + REAL R,S,T; % HASH 00106500 + 00106600 + POINTER PIOB, % CURRENT POSITION IN IOB[*] 00106700 + POUB, % INITIAL 00106800 + PBR,IPR; 00106900 + 00107000 + LABEL INCST; 00107100 + 00107200 + % TRACE PACKAGE 00107300 +%FORMAT T1(I6,X2,A3,X5,"VALUE ASSIGNED= "U),T2(I6,X2,A3,X5," TO STMT " 00107400 +% ,I6),T3(I6,X2,A3); 00107500 + BOOLEAN TRACEON,TLIN;%POINTER ITR; 00107600 +%PROCEDURE DSTR(A);VALUE A;INTEGER A; 00107700 +%BEGIN WRITE(IOF[*],T3,SSEQ[CS],IF TLIN THEN KEY[STYP[CS]] ELSE " "); 00107800 +%REPLACE ITR:POINTER(IOF[*])+14 BY "STRING ASSIGNED=";REPLACE ITR:ITR 00107900 +%BY """ FOR 1;REPLACE ITR:ITR BY POINTER(STRGS[A,1]) FOR STRGS[A,0]; 00108000 +%REPLACE ITR BY """ FOR 1;WRITE(FL[OU],9,IOF[*]);TLIN:=FALSE END; 00108100 + DEFINE TR0(TR01,TR02)=#,%IF TR01 THEN BEGIN WRITE(FL[OU],TR02,SSEQ[CS],00108200 + % IF TLIN THEN KEY[STYP[CS]] ELSE " "#, 00108300 + TR1(TR11)=#, %=TR0(TRACEON,T1),TR11);TLIN:=FALSE END#, 00108400 + TR2(TR21)=#, %=TR0(TRACEON,T2),SSEQ[TR21]);TLIN:=FALSE END#, 00108500 + TR3 =#, %=TR0(TLIN,T3));TLIN:=FALSE END#, 00108600 + TR4(TR41)=#; %=IF TRACEON THEN DSTR(TR41)#; 00108700 + 00108800 + % PROCEDURES FOR EXECUTE: 00108900 + 00109000 + COMMENT 00109100 + --- GET GETS NEXT CHARACTER FROM OBJ ; 00109200 + 00109300 + DEFINE GET=0&OBJ[CO.[46:44]][5:47-CO.[2:3]|6:6];CO:=CO+1; 00109400 + IF CO.[2:3]=0 THEN CO:=CO+1#; 00109500 + COMMENT 00109600 + --- ERROR DEALS WITH EXECUTION TIME ERRORS; 00109700 + 00109800 + PROCEDURE ERROR(A);VALUE A;INTEGER A; 00109900 + BEGIN SWITCH FORMAT ERR:=("ERR0",I6), % SHOULD NOT OCCUR.. %0 00110000 + ("SUBSCRIPT OUT OF BOUNDS AT LINE ",I6), %1 00110100 + ("LOG OF NEGATIVE OR ZERO NUMBER AT LINE ",I6), %2 00110200 + ("SQR OF NEGATIVE NUMBER AT LINE ",I6), %3 00110300 + ("UNDEFINED FUNCTION AT LINE ",I6), %4 00110400 + ("INPUT STATEMENT ATTEMPTED IN BATCH MODE AT LINE",I6), 00110500 + ("GO TO UNDEFINED STATEMENT NUMBER AT LINE ",I6), %6 00110600 + ("RETURN WITHOUT GOSUB AT LINE ",I6), %7 00110700 + ("ARGUMENT FOR SIN,COS,TAN OR EXP EXCEEDS 158 AT LINE",I6), %8 00110800 + ("INCREMENT UNDEFINED OR ZERO AT LINE ",I6), %9 00110900 + ("NEXT WITHOUT FOR AT LINE ",I6), %10 00111000 + ("STORAGE EXCEEDED AT LINE ",I6), %11 00111100 + ("INTEGER OVERFLOW AT LINE ",I6), %12 00111200 + ("INVALID ADDRESS AT LINE ",I6), %13 00111300 + ("DIVIDE BY ZERO AT LINE ",I6), %14 00111400 + ("ILLEGAL EXPONENTIATION AT LINE ",I6), %15 00111500 + ("FLOATING-POINT OVERFLOW AT LINE ",I6), %16 00111600 + ("GOSUBS NESTED TOO DEEP (MORE THAN 10) AT LINE ",I6), %17 00111700 + ("ILLEGAL EXPONENT ON INPUT AT LINE ",I6), %18 00111800 + ("MISPLACED STRING IN INPUT AT LINE ",I6), %19 00111900 + ("INPUT STRING TOO LONG AT LINE ",I6), %20 00112000 + ("OUT OF DATA AT LINE ",I6),("ERR22",I6), % ERR22 SHOULDNT OCCUR 21,22 00112100 + ("ILLEGAL MATRIX OPERATION AT LINE ",I6), %23 00112200 + ("INVERSE OF ILL-CONDITIONED MATRIX AT LINE ",I6), %24 00112300 + ("INSUFFICIENT SPARE STORAGE FOR MAT OP AT LINE ",I6), %25 00112400 + ("ILLEGAL FILE OPERATION AT LINE ",I6), %26 00112500 + ("INPUT FILE NOT ON DISK AT LINE",I6), %27 00112600 + ("INPUT FILE - INVALID USER AT LINE",I6), %28 00112700 + ("INPUT FILE IS NON-STANDARD AT LINE",I6), %29 00112800 + ("OUTPUT FILE - DUPLICATE NAME AT LINE",I6); %30 00112900 + COMMENT LAST MESSAGE HERE IS NO. 30 ; 00113000 + FORMAT DUR("THE FOLLOWING LINE WAS AWAITING OUTPUT:"), 00113100 + FILAT(A6," FILE SEQUENCE NO.",I8); 00113130 + WRITE(TTY,ERR[A],SSEQ[CS]); 00113150 + IF INFILTOG THEN WRITE(TTY,FILAT," INPUT",IR); 00113170 + IF OUTFILTOG THEN WRITE(TTY,FILAT,"OUTPUT",NR); 00113200 + IF DELTA(POUB,PIOB) GTR 0 THEN BEGIN WRITE(TTY,DUR); 00113300 + WRITE(TTY,9,IOB[*]) END; 00113400 + LOCK(FIL1);LOCK(FIL2);GO TO STOP END; 00113500 + 00113600 + COMMENT --- EVAL EVALUATES ARITHMETIC EXPRESSION 00113700 + (REVERSE POLISH DECODER) ; 00113800 + 00113900 + REAL PROCEDURE EVAL; 00114000 + BEGIN 00114100 + LABEL EQ,DONE,EXPON,RPT,SS,S,NUM,VR,AR,SF,UF,AD,SU,MU,DI,EX,FIN, 00114200 + INM,STRGA,STRGC,STRGV; 00114300 + SWITCH TYP:=FIN,NUM,VR,AR,UF,SF,FIN,EQ,INM,AD,SU,MU,DI,EX,STRGV, 00114400 + STRGA,STRGC; 00114500 + DEFINE TOP=STK[STCK];STCK:=STCK-1#; 00114600 + DEFINE STACK(STACK1)=STCK:=STCK+1;STK[STCK]:=STACK1;GO TO SS#; 00114700 + COMMENT ADDR RETURNS RESULT ADDRESS (IN STORE IF REAL, STRGS 00114800 + IF STRING). INTERMEDIATE RESULTS AND ADDRESSES ARE STACKED 00114900 + IN STK AND ADR RESECTIVELY. ; 00115000 + STRIN:=FALSE;STCK:=0; 00115100 + SS: ADR[STCK]:=ADDR;CHA:=GET;GO TO TYP[CHA+1]; 00115200 + NUM: A:=GET;A:=A|64+GET;STACK(CONST[A]); 00115300 + STRGV: ADDR:=GET;STRIN:=TRUE;STACK(0); 00115400 + STRGA: K:=GET;A:=TOP;IF A LEQ 0 OR A GTR STRAR[K,1] 00115500 + THEN ERROR(1);ADDR:=STRAR[K,0]+A;STRIN:=TRUE;STACK(0); 00115600 + STRGC: A:=GET;K:=GET;REPLACE POINTER(STRGS[0,1])BY POINTER 00115700 + (PROG[CS,2])+K FOR A;STRGS[0,0]:=A;STRIN:=TRUE;ADDR:=0;STACK(0); 00115800 + INM: STACK(0); 00115900 + VR: K:=GET;K:=K-1;ADDR:=11|K+GET;STACK(STORE[ADDR]); 00116000 + AR: K:=GET;A:=B:=TOP;IF ARR[K,2] NEQ 0 THEN BEGIN 00116100 + A:=TOP;IF B LEQ 0 OR B GTR ARR[K,2] THEN ERROR(1) END; 00116200 + IF A LEQ 0 OR A GTR ARR[K,1] THEN ERROR(1); 00116300 + ADDR:=ARR[K,0]+(A-1)|ARR[K,2]+B-1;STACK(STORE[ADDR]); 00116400 + SF: 00116500 + BEGIN LABEL SQR,SIF,COF,TAF,ATF,EXF,LOF,ABF,ENF,FNQ,DC, 00116600 + FIX,SGN,RND; 00116700 + SWITCH SFUN:=SIF,COF,TAF,ATF,EXF,LOF,ABF,ENF,SQR,FIX,SGN,RND; 00116800 + DEFINE TEST=IF ABS(R)>158 THEN ERROR(8)#; 00116900 + A:=GET;R:=TOP;GO TO SFUN[A-18]; 00117000 + SIF: TEST;R:=SIN(R);GO TO DC; 00117100 + COF: TEST;R:=COS(R); GO TO DC; 00117200 + TAF: TEST;R:=SIN(R)/COS(R); GO TO DC; 00117300 + ATF: R:=ARCTAN(R); GO TO DC; 00117400 + EXF: TEST;R:=EXP(R); GO TO DC; 00117500 + LOF: IF R LEQ 0 THEN ERROR(2);R:=LN(R); GO TO DC; 00117600 + ABF: R:=ABS(R); GO TO DC; 00117700 + SQR: IF R LSS 0 THEN ERROR(3);R:=R*.5; GO TO DC; 00117800 + ENF: R:=ENTIER(R);GO TO DC; 00117900 + FIX: R:=ENTIER(R);IF R LSS 0 THEN R:=R+1;GO TO DC; 00118000 + SGN: R:=IF R LSS 0 THEN -1 ELSE IF R GTR 0 THEN 1 ELSE 0; 00118100 + GO TO DC; 00118200 + RND: XRND:=XRND|2899;XRND:=XRND.[23:23]; 00118300 + R:=XRND|2*(-23);GO TO DC; 00118400 + DC: STACK(R) END; 00118500 + COMMENT USER FUNCTIONS SECTION ; 00118600 + UF: BEGIN INTEGER AS,SVSK,SVADDR; 00118700 + ARRAY DUM[1:20,1:4],SVSTK,SVADR[0:20]; 00118800 + K:=GET;AS:=CS;CS:=FUNC[K];IF CS=0 THEN BEGIN CS:=AS;ERROR(4) END; 00118900 + B:=CO;CO:=SPOB[CS];C:=GET;FOR A:=1 STEP 1 UNTIL SUB[K] DO BEGIN 00119000 + COMMENT SAVE VALUES OF FORMAL PARAMETERS AND STORE ACTUALS; 00119100 + R:=TOP;C:=GET;C:=64|C+GET;DUM[A,1]:=C;DUM[A,2]:=STORE[C];STORE[C]:=R 00119200 + END;SVADDR:=ADDR;SVSK:=STCK; 00119300 + FOR A:=0 STEP 1 UNTIL 20 DO BEGIN SVSTK[A]:=STK[A];SVADR[A]:=ADR[A] 00119400 + END; 00119500 + COMMENT NOW EVALUATE FUNCTION ANO RESTORE FORMAL PARAMETERS; 00119600 + R:=EVAL;FOR A:=1 STEP 1 UNTIL SUB[K] DO STORE[DUM[A,1]]:=DUM[A,2]; 00119700 + FOR A:=0 STEP 1 UNTIL 20 DO BEGIN STK[A]:=SVSTK[A];ADR[A]:=SVADR[A] 00119800 + END;ADDR:=SVADDR;STCK:=SVSK; 00119900 + CS:=AS;CO:=B;STACK(R) END; 00120000 + EQ: IF STRIN THEN BEGIN ADDR:=A:=ADR[STCK];STCK:=STCK-1; 00120100 + B:=ADR[STCK];REPLACE POINTER(STRGS[B,*]) BY POINTER(STRGS[A,*]) 00120200 + FOR 3 WORDS;TR4(B);GO TO SS END;R:=TOP;ADDR:=ADR[STCK]; 00120300 + STORE[ADDR]:=STK[STCK]:=R;TR1(R);GO TO SS; 00120400 + AD: R:=TOP;R:=R+TOP;STACK(R); 00120500 + SU: R:=TOP;R:=-R+TOP;STACK(R); 00120600 + MU: R:=TOP;R:=R|TOP;STACK(R); 00120700 + DI: R:=TOP;R:=1/R|TOP;STACK(R); 00120800 + EX: T:=TOP;R:=TOP;IF T NEQ ENTIER(T) AND R LSS 0 00120900 + THEN ERROR(15);STACK(R*T); 00121000 + FIN: EVAL:=STK[1] END; 00121100 + COMMENT 00121200 + --- OUTP OUTPUTS CONTENTS OF PSEUDO-BUFFER ; 00121300 + 00121400 + PROCEDURE OUTP; 00121500 + BEGIN IF MF>0 THEN ERROR(26);TR3; 00121600 + WRITE(FL[OU],14,IOB[*]);REPLACE PIOB:=POUB:=POINTER(IOB[*]) BY 00121700 + " " FOR 112;IF OU=1 THEN PIOB:=POUB:=POUB+20 END; 00121800 + COMMENT 00121900 + --- MORE FALSE IF END OF STATEMENT ; 00122000 + 00122100 + BOOLEAN PROCEDURE MORE; 00122200 + BEGIN INTEGER A,B;A:=CO;B:=GET;MORE:=B NEQ 0;CO:=A END; 00122300 + COMMENT 00122400 + --- OUTNUM PLACES NUMBER IN PSEUDO-BUFFER ; 00122500 + 00122600 + PROCEDURE OUTNUM(A,F);VALUE A,F;REAL A;INTEGER F; 00122700 + BEGIN CHA:=0;CP:=CP-1;WRITE(IOBE[*],NUM[F],A); % CARE: 00122800 + SCAN APR:CPR FOR 16 UNTIL ="@"; 00123200 + IF DELTA(CPR,APR) NEQ 16 THEN REPLACE APR BY "E" FOR 1; 00123300 + IF DELTA(POUB,PIOB) GTR 60+F|4 THEN OUTP; 00123400 + REPLACE PIOB:PIOB BY POINTER(IOBE[1]) FOR 14 UNTIL=48; 00123500 + REPLACE PIOB:PIOB BY " " FOR 1 END; 00123600 + COMMENT 00123700 + --- QUO PLACES " IN OUTPUT BUFFER ; 00123800 + DEFINE QUO=IF MF>0 THEN REPLACE PIOB:PIOB BY """#; 00123900 + COMMENT 00124000 + --- MATOP PROCESSES MOST MAT STATEMENTS ; 00124100 + 00124200 + PROCEDURE MATOP; 00124300 + BEGIN INTEGER U,V,W,X,Y,Z,I,J; 00124400 + COMMENT MAT STATEMENTS CONCERNED HAVE FORMAT 00124500 + MAT LET = 00124600 + MAT = 00124700 + THE SECOND CHARACTER IN IS USED TO IDENTIFY ACTION TAKEN 00124800 + THIS CAN BE * + - E O D R N % 00124900 + (RECALL % IS END-STATEMENT CHARACTER) ; 00125000 + LABEL DONE,ADSU,EQM,CONS,EX,EY;REAL PIVOT,AI; 00125100 + INTEGER ARRAY IR[1:72];REAL ARRAY TEM[1:72]; 00125200 + DEFINE AA(AA1,AA2)=STORE[ARR[K,0]+(AA1-1)|U+AA2-1]#; 00125300 + CP:=GET;CHA:=0;K:=CHCONV(NCH);IF K=0 THEN ERROR(23); 00125400 + IF NCH NEQ 61 THEN ERROR(23);A:=CHCONV(NCH);CHA:=NCH; 00125500 + COMMENT SWITCH OCCURS HERE 00125600 + * MATRIX MULTIPLICATION 00125700 + IS * 00125800 + HASH STORAGE IS USED TO AVOID TROUBLE WITH A=A*B ETC ; 00125900 + ON("*") BEGIN B:=CHCONV(NCH); 00126000 + U:=ARR[K,1]-1;V:=ARR[K,2]-1;W:=ARR[A,1]-1;X:=ARR[A,2]-1; 00126100 + Y:=ARR[B,1]-1;Z:=ARR[B,2]-1;IF U NEQ W OR V NEQ Z OR X NEQ Y 00126200 + THEN ERROR(23);IF MSTO+(U+1)|(V+1) GTR 1000 THEN ERROR(25); 00126300 + FOR W:=0 STEP 1 UNTIL U DO FOR Z:=0 STEP 1 UNTIL V DO BEGIN R:=0; 00126400 + FOR Y:=0 STEP 1 UNTIL X DO R:=R+STORE[ARR[A,0]+X|W+W+Y]| 00126500 + STORE[ARR[B,0]+Y|V+Y+Z];STORE[MSTO+W|V+W+Z]:=R END; 00126600 + FOR W:=0 STEP 1 UNTIL U DO FOR Z:=0 STEP 1 UNTIL V DO 00126700 + STORE[ARR[K,0]+W|V+W+Z]:=STORE[MSTO+W|V+W+Z]; 00126800 + GO TO DONE END; 00126900 + COMMENT + MATRIX ADDITION 00127000 + IS + ; 00127100 + ON("+") BEGIN Z:=1;GO TO ADSU END; 00127200 + COMMENT - MATRIX SUBTRACTION 00127300 + IS - ; 00127400 + ON("-") BEGIN Z:=-1;GO TO ADSU END; 00127500 + COMMENT O ALL ONES 00127600 + IS CON ; 00127700 + ON("O") BEGIN Z:=Y:=1;GO TO CONS END; 00127800 + COMMENT D IDENTITY MATRIX 00127900 + IS IDN ; 00128000 + ON("D") BEGIN IF ARR[K,1] NEQ ARR[K,2] THEN ERROR(23);Z:=1;Y:=0; 00128100 + COMMENT E ZERO MATRIX 00128200 + IS ZER ; 00128300 + GO TO CONS END; ON("E") BEGIN Z:=Y:=0;GO TO CONS END; 00128400 + COMMENT R TRANSPOSITION 00128500 + IS TRN() 00128600 + HASH STORAGE USED TO AVOID TROUBLE WITH A=TRN(A) ; 00128700 + ON("R") BEGIN CHA:=NCH;CHA:=NCH;A:=CHCONV(NCH);IF A=0 THEN ERROR(23); 00128800 + U:=ARR[K,1]-1;V:=ARR[K,2]-1;W:=ARR[A,1]-1;X:=ARR[A,2]-1; 00128900 + IF U NEQ X OR V NEQ W THEN ERROR(23); 00129000 + IF MSTO+(U+1)|(V+1) GTR 1000 THEN ERROR(25); 00129100 + FOR U:=0 STEP 1 UNTIL X DO FOR V:=0 STEP 1 UNTIL W DO 00129200 + STORE[MSTO+U|W+U+V]:=STORE[ARR[A,0]+V|X+V+U]; 00129300 + FOR U:=0 STEP 1 UNTIL X DO FOR V:=0 STEP 1 UNTIL W DO 00129400 + STORE[ARR[K,0]+U|W+U+V]:=STORE[MSTO+U|W+U+V]; 00129500 + GO TO DONE END; 00129600 + COMMENT N INVERSION 00129700 + IS INV() ; 00129800 + ON("N") BEGIN CHA:=NCH;CHA:=NCH;A:=CHCONV(NCH); 00129900 + U:=ARR[K,1];IF U NEQ ARR[K,2] OR U NEQ ARR[A,1] OR U NEQ ARR[A,2] 00130000 + THEN ERROR(23);FOR I:=0 STEP 1 UNTIL U-1 DO FOR J:=0 STEP 1 UNTIL U-1 00130100 + DO AA(I+1,J+1):=STORE[ARR[A,0]+I|U+J]; 00130200 + FOR V:=1 STEP 1 UNTIL U DO BEGIN PIVOT:=0; 00130300 + FOR I:=1 STEP 1 UNTIL U DO BEGIN IF V NEQ 1 THEN BEGIN 00130400 + FOR X:=1 STEP 1 UNTIL V-1 DO IF I=IR[X] THEN GO TO EX END; 00130500 + IF ABS(AA(I,V))GTR ABS(PIVOT) THEN BEGIN PIVOT:=AA(I,V);Y:=IR[V]:=I 00130600 + END; 00130700 + EX: END;IF ABS(PIVOT) LSS .0001 THEN ERROR(24); 00130800 + FOR J:=1 STEP 1 UNTIL U DO AA(Y,J):=AA(Y,J)/PIVOT;AA(Y,V):=1/PIVOT; 00130900 + FOR I:=1 STEP 1 UNTIL U DO IF I NEQ Y THEN BEGIN AI:=AA(I,V); 00131000 + AA(I,V):=-AI/PIVOT;FOR J:=1 STEP 1 UNTIL U DO IF J NEQ V THEN 00131100 + AA(I,J):=AA(I,J)-AI|AA(Y,J) END END; 00131200 + FOR I:=1 STEP 1 UNTIL U DO 00131300 + BEGIN FOR J:=1 STEP 1 UNTIL U DO TEM[J]:=AA(I,J); 00131400 + FOR J:=1 STEP 1 UNTIL U DO AA(I,IR[J]):=TEM[J] END; 00131500 + FOR J:=1 STEP 1 UNTIL U DO BEGIN FOR I:=1 STEP 1 UNTIL U DO 00131600 + TEM[I]:=AA(IR[I],J);FOR I:=1 STEP 1 UNTIL U DO AA(I,J):=TEM[I] 00131700 + END;GO TO DONE END; 00131800 + % EQUALITY 00131900 + COMMENT IS ; 00132000 + ON("%") BEGIN B:=A;Z:=0; GO TO EQM END; 00132100 + ERROR(23); 00132200 + ADSU: B:=CHCONV(NCH);IF B=0 THEN ERROR(23); 00132300 + IF ARR[A,1] NEQ ARR[B,1] OR ARR[A,2] NEQ ARR[A,2] THEN ERROR(23); 00132400 + EQM: U:=ARR[K,1];V:=ARR[K,2];IF U NEQ ARR[A,1] 00132500 + OR V NEQ ARR[A,2] THEN ERROR(23); 00132600 + FOR I:=0 STEP 1 UNTIL U-1 DO FOR J:=0 STEP 1 UNTIL V-1 DO 00132700 + AA(I+1,J+1):=STORE[ARR[A,0]+I|U+J]+Z|STORE[ARR[B,0]+I|U+J]; 00132800 + GO TO DONE; 00132900 + CONS: U:=ARR[K,I];FOR I:=1 STEP 1 UNTIL ARR[K,1] DO 00133000 + FOR J:=1 STEP 1 UNTIL ARR[K,2] DO AA(I,J):=IF I=J THEN Z ELSE Y; 00133100 + DONE: GO TO INCST END; 00133200 + LABEL RPT,REM,DAT,EXS,LET,RLET,ONX, 00133300 + INP,PRI,RPRI,XPRI,MAT,ENX,RREA,XREA,QDAT,FREA,RES,NDAT, 00133400 + STRV,FOL,INTVR,INDEXR,DZER,EXPVR, 00133500 + NM,TAB,COM,STR,EPRI,OUD,OUF, 00133600 + IFF,GOT,GOX,GOS,RET,FOX,NEX,FD,DEF,REA,EREA,RAN,PAG; 00133700 + SWITCH OPN:=LET,GOT,GOS,RET,INP,REA,EPRI,FOX,NEX,MAT, 00133800 + DEF,DAT,RAN,PAG,RES,REM,ENX,ENX,IFF,ONX; 00133900 + 00134000 + SWITCH TYP:=XPRI,COM,NM,TAB,STR,INCST,STRV; 00134100 + 00134200 + COMMENT----------------------------------------------------------------00134300 +----------------- EXECUTE BEGINS HERE --------------------00134400 +-----------------------------------------------------------------------;00134500 + 00134600 + INTOVR:=INTVR;EXPOVR:=EXPVR;ZERO:=DZER;INDEX:=INDEXR; 00134700 + WRITE(TTY,MESS);RT:=TIME(2)+TIM;IF OU=1 THEN WRITE(TTY,DVO); 00134800 + WRITE(FL[OU],SPC);NR:=IR:=RDAT:=RDTP:=NGOT:=0;TRACEON:=TLIN:=FALSE; 00134900 + FORC:=SLVE:=0;XRND:=101;CS:=ACS-1; 00135000 + POUB:=PIOB:=POINTER(IOB[*])+20|OU; 00135100 + REPLACE POINTER(IOB[*]) BY " " FOR 112; 00135200 + 00135300 + % GET FILES IF NEEDED: 00135400 + IF INFILTOG THEN BEGIN FILL FIL1 WITH IO[1],TIME(-1); 00135500 + SEARCH(FIL1,ANSA[*]);IF ANSA[0] LEQ 0 THEN ERROR(28+ANSA[0]); 00135600 + IF ANSA[3] NEQ 10 OR ANSA[4] NEQ 300 THEN ERROR(29) END; 00135700 + IF OUTFILTOG THEN BEGIN FILL FIL2 WITH IO[2],TIME(-1); 00135800 + SEARCH(FIL2,ANSA[*]);IF ANSA[0] NEQ -1 THEN BEGIN 00135900 + WRITE(TTY,F13,IO[2].[41:36]); 00136000 + IF IU=2 THEN U:=0 ELSE 00136100 + READ(TTY,REP,U);IF U NEQ "YES" THEN ERROR(30) END END; 00136200 + 00136300 + COMMENT RETURN TO HERE AFTER EACH STATEMENT; 00136400 + 00136500 + REM:DAT:INCST: TR3;CS:=CS+1; 00136600 + EXS: MF:=0; % FIRST SEE IF EXCESS TIME 00136700 + IF TIME(2) GTR RT THEN BEGIN WRITE(TTY,BK);GO TO ENX END; 00136800 + IF STYP[CS]>19 THEN BEGIN TRACEON:=STYP[CS]=20;GO INCST END; 00136900 + IF TRACEON THEN TLIN:=TRUE; 00137000 + 00137100 + 00137200 + U:=STYP[CS];CO:=SPOB[CS];GO TO OPN[U]; % NOW GO TO APPROPRIATE PLACE 00137300 + % LET STATEMENT 00137400 + LET: R:=EVAL;GO TO INCST; 00137500 + % ON STATEMENT 00137600 + ONX: U:=EVAL; 00137700 + FOR V:=1 STEP 1 UNTIL 2|U-2 DO BEGIN S:=GET END;GO GOT; %(STET) 00137800 + % IF STATEMENT 00137900 + IFF: R:=EVAL;IF STRIN THEN BEGIN 00138000 + COMMENT STRING IF ; 00138100 + U:=GET; 00138200 + REPLACE IPR:=POINTER(STRGS[-1,*]) BY POINTER(STRGS[ADDR,*]) FOR 24; 00138300 + R:=EVAL;GO IF IPR=POINTER(STRGS[ADDR,*]) 00138400 + FOR STRGS[-1,0]+8 EQV U=1 THEN GOT ELSE INCST END; 00138500 + COMMENT REAL IF ; 00138600 + U:=GET;R:=R-EVAL; 00138700 + IF R GTR 0 AND U.[2:1]=1 THEN GO TO GOT ELSE 00138800 + IF R LSS 0 AND U.[1:1]=1 THEN GO TO GOT ELSE 00138900 + IF R = 0 AND U.[0:1]=1 THEN GO TO GOT;GO TO INCST; 00139000 + % GOTO STATEMENT 00139100 + GOT: U:=GET;U:=64|U+GET;IF U=0 THEN ERROR(6); 00139200 + GOX: NGOT:=NGOT+1;TR2(U); 00139300 + COMMENT MONITOR FOR EXCESS LOOPING; 00139400 + IF NGOT=100 AND IU NEQ 2 THEN BEGIN WRITE(TTY,WRN);READ(TTY,REP,W); 00139500 + IF W NEQ "YES" THEN GO TO STOP END; 00139600 + CS:=U;GO EXS; 00139700 + % GOSUB STATEMENT 00139800 + GOS: SLVE:=SLVE+1;IF SLVE GTR 10 THEN ERROR(17); 00139900 + SVE[SLVE]:=CS;GO GOT; 00140000 + % RETURN STATEMENT 00140100 + RET: IF SLVE=0 THEN ERROR(7); 00140200 + CS:=SVE[SLVE];SLVE:=SLVE-1;GO TO INCST; 00140300 + % FOR STATEMENT 00140400 + FOX: FORC:=GET;R:=EVAL; 00140500 + 00140600 + COMMENT FORX CONTROL INFO IS STORED AS FOLLOWS: 00140700 + 1 2 3 4 00140800 + ADDR STEP FINAL FORLINE 00140900 + A FOR LOOP IS EXECUTED ZERO TIMES IN THE RIGHT CIRCUMSTANCES; 00141000 + 00141100 + V:=FORX[FORC,1]:=ADDR;S:=FORX[FORC,3]:=EVAL; 00141200 + T:=FORX[FORC,2]:=IF MORE THEN EVAL ELSE 1; 00141300 + W:=FORX[FORC,4]:=CS;IF T=0 THEN ERROR(9); 00141400 + IF T|R LEQ T|S THEN GO INCST; % ELSE SKIP LOOP 00141500 + U:=GET;U:=GET;CS:=64|U+GET;GO TO INCST; 00141600 + 00141700 + % NEXT STATEMENT 00141800 + % SPOB STORES (NEXTS LEVEL IN FORX)+16|FORLINE 00141900 + NEX: U:=SPOB[CS].[3:4];V:=SPOB[CS].[41:38]; 00142000 + IF V NEQ FORX[U,4] THEN ERROR(10);L:=FORX[U,1]; 00142100 + T:=FORX[U,2];R:=STORE[L]+T; 00142200 + IF T|R LEQ T|FORX[U,3] THEN BEGIN STORE[L]:=R;TR1(R);T:=FORX[U,4]; 00142300 + TR2(T+1);CS:=T END ELSE FORX[U,4]:=0; 00142400 + GO TO INCST; 00142500 + % DEFINE STATEMENT 00142600 + DEF: U:=GET;FUNC[U]:=CS;GO TO INCST; 00142700 + % READ STATEMENT 00142800 + REA: U:=0; 00142900 + COMMENT THIS SECTION IS COMPLICATED BECAUSE OF SWITCHING 00143000 + OF ATTENTION FROM READ STATEMENT TO DATA STATEMENT AND BACK ETC; 00143100 + RREA: R:=EVAL;L:=ADDR;U:=CS;V:=CO; 00143200 + IF RDTP=0 THEN GO TO QDAT;CO:=RDTP;CS:=RDAT; 00143300 + XREA: IF STRIN THEN BEGIN R:=EVAL;CS:=U;IF NOT STRIN THEN 00143400 + ERROR(20);REPLACE POINTER(STRGS[L,*])BY POINTER(STRGS[ADDR,*]) 00143500 + FOR 3 WORDS;TR4(L) END ELSE BEGIN R:=EVAL;IF STRIN THEN ERROR(20); 00143600 + STORE[L]:=R;CS:=U;TR1(R) END;RDTP:=IF MORE THEN CO ELSE 0;CO:=V; 00143700 + IF MORE THEN GO TO RREA ELSE GO TO INCST; 00143800 + COMMENT FIND ANOTHER DATA STATEMENT; 00143900 + QDAT: FOR CS:=RDAT+1 STEP 1 UNTIL MS DO BEGIN 00144000 + IF STYP[CS]=12 THEN GO TO FREA END; 00144100 + CS:=U;ERROR(21); 00144200 + FREA: RDAT:=CS;CO:=SPOB[CS];GO TO XREA; 00144300 + % INPUT STATEMENT 00144400 + % "STOP" AT START OF INPUT STREAM STOPS A RUN 00144500 + INP: BEGIN LABEL RINP,EVINP,RPT,EXPON,DONE,FINP; 00144600 + MF:=GET;IF MF=0 THEN BEGIN IF IU=2 THEN ERROR(5); 00144700 + IF DELTA(POUB,PIOB) GTR 0 THEN BEGIN 00144800 + REPLACE POINTER(IOBE[*]) BY POUB FOR 72;WRITE(TTY[STOP],9,IOBE[*]); 00144900 + REPLACE PIOB:=POUB:=POINTER(IOB[*]) BY " " FOR 112;IF OU=1 THEN 00145000 + PIOB:=POUB:=PIOB+20 END;READ(TTY,9,IOBE[*]); 00145100 + READ(IOBE[*],REP,V);IF V="STO" THEN GO TO STOP END 00145200 + ELSE BEGIN Z:=GET;Z:=64|Z+GET;READ(FIL1,10,IOBE[*])[OUD]; 00145300 + READ(IOBE[*],SNUM,IR) END; 00145350 + REPLACE POINTER(PROG[0,2]) BY POINTER(IOBE[1]) FOR 72;X:=0; 00145400 + RINP: R:=EVAL;L:=ADDR;U:=CS;CS:=0;CP:=X;CHA:=0; 00145500 + IF NCH="%" THEN BEGIN IF MF=0 THEN BEGIN WRITE(TTY,MNP[IF X=0 THEN 1 00145600 + ELSE 0],PROG[U,1]);CS:=U;GO TO EXS END ELSE BEGIN 00145700 + READ(FIL1,9,IOBE[*])[OUD]; 00145800 + REPLACE POINTER(PROG[0,2]) BY POINTER(IOBE[*]) FOR 72;CP:=1 END END; 00145900 + COMMENT INPUT STRING MAY OR MAY NOT HAVE "" ; 00146000 + EVINP: CP:=CP-1;CHA:=NCH;IF STRIN THEN BEGIN 00146100 + ON(63) SCAN APR:APR:=CPR:=POINTER(PROG[0,2])+CP FOR 15 WHILE NEQ 63 00146200 + ELSE BEGIN CP:=CP-2;SCAN APR:APR:=CPR:=POINTER(PROG[0,2])+CP+1 FOR 15 00146300 + WHILE IN ALPHA END; 00146400 + V:=DELTA(CPR,APR);IF V>14 THEN BEGIN CS:=U;ERROR(20) END; 00146500 + STRGS[L,0]:=V;REPLACE POINTER(STRGS[L,1]) BY CPR FOR V; 00146600 + CP:=CP+V+1;CHA:=NCH;CS:=U;TR4(L);GO FINP END; 00146700 + T:=R:=Y:=0; 00146800 + COMMENT INPUT NUMBER ; 00146900 + ON(44) BEGIN T:=1;CHA:=NCH END; 00147000 + RPT: ON(26) BEGIN Y:=1;CHA:=NCH END; 00147100 + IF CHA GEQ 10 THEN GO TO EXPON;IF Y GTR 0 THEN 00147200 + BEGIN R:=R+CHA|10*(-Y); 00147300 + Y:=Y+1 END ELSE R:=R|10 +CHA;CHA:=NCH; GO TO RPT; 00147400 + EXPON: IF CHA NEQ 21 THEN GO TO DONE;Y:=1;CHA:=NCH;Z:=0; 00147500 + ON(44)BEGIN Y:=-1;CHA:=NCH END ELSE ON(16) CHA:=NCH; 00147600 + IF CHA GEQ 10 THEN BEGIN CS:=U;ERROR(18) END;Z:=CHA;CHA:=NCH; 00147700 + IF CHA LSS 10 THEN BEGIN Z:=Z|10+CHA;CHA:=NCH END; 00147800 + R:=R|10*(Y|Z); 00147900 + DONE: IF T=1 THEN R:=-R;DELIM:=72;STORE[L]:=R;CS:=U;TR1(R); 00148000 + FINP: X:=CP;IF CHA NEQ 58 AND CHA NEQ "%" THEN ERROR(19); 00148100 + IF MORE THEN GO TO RINP ELSE GO TO INCST END; 00148200 + % RANDOMISE STATEMENT 00148300 + RAN: XRND:=(2|TIME(1)+1).[23:23];GO TO INCST; 00148400 + % RESTORE STATEMENT 00148500 + RES: MF:=GET;IF MF=0 THEN RDTP:=RDAT:=0 ELSE REWIND(FIL1); 00148600 + GO INCST; 00148700 + % PRINT STATEMENT 00148800 + EPRI: MF:=GET;IF MF>0 THEN BEGIN PBR:=PIOB; 00148900 + TR3;Z:=GET;Z:=64|Z+GET; 00149000 + POUB:=POINTER(IOF[*]);REPLACE PIOB:=POINTER(IOF[*]) BY " " FOR 72 END; 00149100 + PRI: CHA:=GET;IF MF>0 AND CHA=5 THEN ERROR(26); 00149200 + GO TO TYP[CHA+1]; 00149300 + Z:=GET;Z:=64|X+GET; 00149400 + COMMENT , IN PRINT MOVES TO NEXT 14-SPACE COLUMN. 00149500 + 00149600 + (SEMICOLON IN MIDDLE OF PRINT IS JUST DELIMITER); 00149700 + COM: IF MF>0 THEN REPLACE PIOB:PIOB BY "," ELSE BEGIN 00149800 + V:=DELTA(POUB,PIOB);IF V GTR 56 THEN BEGIN 00149900 + OUTP;V:=0 END ELSE V:=14-(V MOD 14); 00150000 + FOR U:=1 STEP 1 UNTIL V DO REPLACE PIOB:PIOB BY " " END; 00150100 + GO TO PRI; 00150200 + COMMENT PLACE STRING IN PSEUDO-BUFFER ; 00150300 + STR: CP:=GET; 00150400 + CPR:=POINTER(PROG[CS,2])+CP; 00150500 + V:=72-DELTA(POUB,PIOB);W:=GET; 00150600 + IF W GTR V THEN BEGIN REPLACE PIOB:PIOB BY CPR:CPR FOR V; 00150700 + OUTP;W:=W-V END; 00150800 + QUO;REPLACE PIOB:PIOB BY CPR:CPR FOR W;QUO; 00150900 + GO TO PRI; 00151000 + 00151100 + COMMENT TAB OVERWRITES ON TELETYPE AND LINE-PRINTER 00151200 + BUT REPLACES ON VIDEO UNIT. ; 00151300 + 00151400 + TAB: IF MF>0 THEN ERROR(26);U:=EVAL-1;U:=U MOD 72; 00151500 + IF IU+OU NEQ 0 THEN BEGIN TR3;WRITE(FL[OU][NO],9,IOB[*]); 00151600 + REPLACE POUB BY " " FOR 72 END;PIOB:=POUB+U; GO TO PRI; 00151700 + STRV: R:=EVAL;QUO;REPLACE PIOB:PIOB BY POINTER(STRGS[ADDR,1]) 00151800 + FOR STRGS[ADDR,0];QUO;GO TO PRI; 00151900 + NM: OUTNUM(EVAL,0);GO TO PRI; 00152000 + XPRI: IF MF>0 THEN BEGIN REPLACE PIOB BY ","; 00152100 + NR:=NR+10;REPLACE POINTER(IOF[10]) BY NR FOR 8 DIGITS; 00152200 + WRITE(FIL2,10,IOF[*])[OUF];PIOB:=PBR;POUB:=POINTER(IOB[*])+20|OU END 00152300 + ELSE OUTP;GO TO INCST; 00152400 + % PAGE STATEMENT 00152500 + PAG: IF OU=1 THEN WRITE(LIN[PAGE]);GO TO INCST; 00152600 + % MAT STATEMENT 00152700 + % MAT 1=READ, 2=PRINT, 3=MATOP, 4=SCALAR MULTIPLE 00152800 + MAT: BEGIN INTEGER E,F,G;LABEL QDAT,FREA,XREA,RREA; 00152900 + L:=GET;IF L=1 THEN BEGIN E:=CS;L:=GET;U:=GET;V:=GET; 00153000 + FOR W:=0 STEP 1 UNTIL U-1 DO FOR X:=0 STEP 1 UNTIL V-1 DO BEGIN 00153100 + IF RDTP = 0 THEN GO TO QDAT;CO:=RDTP;CS:=RDAT; 00153200 + XREA: STORE[ARR[L,0]+W|ARR[L,2]+X]:=EVAL; 00153300 + RDTP:=IF MORE THEN CO ELSE 0;GO TO RREA; 00153400 + QDAT: FOR CS:=RDAT + 1 STEP 1 UNTIL MS DO BEGIN IF STYP[CS] 00153500 + =12 THEN GO TO FREA END;CS:=E;ERROR(21); 00153600 + FREA: RDAT:=CS;CO:=SPOB[CS];GO TO XREA; 00153700 + RREA: END;CS:=E;GO TO INCST END; 00153800 + IF L=2 THEN BEGIN 00153900 + IF DELTA(POUB,PIOB) GTR 0 THEN OUTP; 00154000 + L:=GET;U:=GET;V:=GET;E:=GET;G:=14-E|7;FOR W:=0 STEP 1 UNTIL U-1 DO 00154100 + BEGIN FOR X:=0 STEP 1 UNTIL V-1 DO BEGIN OUTNUM(STORE[ARR[L,0]+ 00154200 + W|ARR[L,2]+X],E);PIOB:=POUB+G|((DELTA(POUB,PIOB)-1) DIV G +1) 00154300 + END;OUTP END;GO TO INCST END; 00154400 + IF L=3 THEN MATOP; 00154500 + L:=GET;R:=EVAL;W:=GET; 00154600 + IF ARR[L,1] NEQ ARR[W,1] OR ARR[L,2] NEQ ARR[W,2] THEN ERROR(23); 00154700 + FOR U:=0 STEP 1 UNTIL ARR[L,1]-1 DO FOR V:=0 STEP 1 UNTIL ARR[L,2]-1 00154800 + DO STORE[ARR[L,0]+U|ARR[L,2]+V]:=R|STORE[ARR[W,0]+U|ARR[L,2]+V]; 00154900 + GO TO INCST END; 00155000 + % STOP OR END STATEMENT 00155100 + ENX: TR3;IF DELTA(POUB,PIOB)>0 THEN OUTP; 00155200 + LOCK(FIL1);LOCK(FIL2);GO TO STOP; 00155300 + OUD: IF Z=0 THEN ERROR(21);TR2(Z);CS:=Z;GO EXS; 00155400 + OUF: IF Z=0 THEN ERROR(26);TR2(Z);CS:=Z;GO EXS; 00155500 + INTVR: ERROR(12);INDEXR: ERROR(13); 00155600 + DZER: ERROR(14);EXPVR: ERROR(16) END; 00155700 + STOP: WRITE(TTY,STP,"RUN ");GO TO SOURCEIN; 00155800 + COMMENT 00155900 + PROGRAM WRITTEN BY MALCOLM CROWE 00156000 + LANGUAGE DETAILS DECIDED BY IAN MILLER AND JOHN FURLONG 00156100 + MATRIX INVERSION CORRECTED BY ARTHUR MACDIVITT ; 00156200 + 00156300 + FINSH: END. 00156400