SUBROUTINE CALLPROC(PROC,NAME,FILENAME,FILEHANDLE,LABEL) * * S/R - KRJ - PROC interpreter * Public Domain: written by Keith Johnson 2004 * COMMON /PROCBUFF/ IBUF(2),OBUF(2),FREC(10),FHAN(10),SREG(11) COMMON /PROCPNTR/ IPTR,OPTR,ACTI,ACTO * IBUF and OBUF are the Input and Output buffers * There is one input buffer pointer, IPTR * and two output buffer pointers, OPTR<1> and OPTR<2> * The active buffers are signified by ACTI and ACTO * FREC are the file buffers, and FHAN the file variables * (10 being the fast buffer) * SREG are the select list buffers * Check if we need to initialise the buffers, although * this should have been done in the calling program. IF NOT(ASSIGNED(IBUF(1))) THEN MAT IBUF = ''; MAT OBUF = '' MAT FREC = ''; MAT FHAN = ''; MAT SREG = '' END * Set the pointers and the active buffers - should TOP be above this? IPTR = 1 ACTI = 1 OPTR = DCOUNT(OBUF(1),@AM) IF OPTR < 1 THEN OPTR = 1 ACTO = 1 OPTR<2> = DCOUNT(OBUF(2),@AM) IF OPTR<2> < 1 THEN OPTR<2> = 1 TOP: BRAC = '' ; KETS = '' MORE = '' REGS = '%#&!' HINT = @FALSE MSG1 = "Continue? 'N'o or 'Y'es/'G'o, or 'S'kip " IF PROC<1>[1,3] NE 'PQN' THEN CRT NAME:' is not a PQN proc' CRT 'PROC<1> = ':PROC<1> INPUT WAIT RETURN END PSUB = '' PRINTER ON * Get all the program pointers in a pre-pass * EMMS - the lines starting M for B and F commands * GOES - the numeric statement labels * TOES - the lines the labels are on EMMS = ''; GOES = ''; TOES = '' LAST = DCOUNT(PROC,@AM) FOR HERE = 2 TO LAST PINE = TRIM(PROC) WORD = FIELD(PINE,' ',1) BEGIN CASE CASE WORD MATCHES '1N0N' GOES<-1> = WORD TOES<-1> = HERE CASE WORD = 'M' EMMS<-1> = HERE END CASE NEXT HERE HERE = 1 IF LABEL MATCHES '1N0N' THEN LOCATE(LABEL,GOES;POSN) ELSE CRT LABEL:' is not in PROC ':NAME GO BAD.LINE END HERE = TOES-1 LABEL = '' END LOOP HERE += 1 UNTIL HERE > LAST DO PINE = TRIMF(PROC) IF HINT THEN CRT PINE WORD = FIELD(PINE,' ',1) IF WORD = 'M' OR WORD MATCHES '1N0N' THEN PINE = PINE[LEN(WORD)+1,LEN(PINE)] END GOSUB PROCESS.PROC.LINE REPEAT RETURN PROCESS.PROC.LINE: PINE = TRIMF(PINE) ROOM = LEN(PINE) FIRST = PINE[1,1] POSN = INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ',FIRST,1) BEGIN CASE CASE POSN GT 0 ON POSN GOSUB A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y,Z CASE FIRST = '+' ; GOSUB PLUS.COMMAND CASE FIRST = '-' ; GOSUB MINUS.COMMAND CASE FIRST = '(' ; GOSUB CHAIN.COMMAND CASE FIRST = '[' ; GOSUB CALL.COMMAND CASE 1 GO BAD.LINE END CASE RETURN * These are generic error presentations BAD.FILENO: CRT 'BAD FILE BUFFER NUMBER' GO BAD.LINE BAD.COMD: CRT 'COMMAND NOT FOUND' BAD.LINE: CRT 'Bad PROC line - ':HERE:' ':PROC INPUT WAIT * This is to force output and turn the printer off BACK: PRINTER CLOSE PRINTER OFF * This consumes the RETURN stack so that control * passes back to the calling program. * The ONLY use I have EVER found for RETURN TO! CALLER: RETURN TO CALLER ************************************************************** * The PROC instructions ************************************************************** A: * Copy a field from the Input Buffer to the Output Buffer * * Of form A[c][p][,m] or A([n|n,m|,m]) * Where c is an optional surround character * p is the number of the field in the Input Buffer * n is the start column in the Input Buffer * m specifies the maximum string length WORD = PINE[2,ROOM] GOSUB EVAL.A.COMMAND IPTR = NEW.IPTR * ACTO # 1 means STON IF ACTO # 1 THEN OBUF(2) := TEMP OPTR<2> = DCOUNT(OBUF(2),@AM) END ELSE OBUF(1)> := TEMP RETURN B: BEGIN CASE CASE PINE = 'B' * Back up the input buffer pointer TEMP = IPTR - 1 IF TEMP LE 0 THEN TEMP = 1 IPTR = TEMP CASE PINE = 'BO' * Back up the output buffer pointer TEMP = OPTR - 1 IF TEMP LE 0 THEN TEMP = 1 OPTR = TEMP CASE 1 ; GO BAD.COMD END CASE RETURN C: * A comment - No action required RETURN D: BEGIN CASE * Add a few wrinkles - DB, DF, and DS * Maybe it's just that I can't stop "helping", but these are * useful for debugging (well, DB is, the rest is me being clever) * Pure serendipity - DB = DeBug, getit? * DB to show all the buffers CASE PINE = 'DB' CRT 'IPTR = ':IPTR TEMP = ' ':@AM:' ' ; TEMP = '*' CRT TEMP<1>:'PIB = ':IBUF(1) CRT TEMP<2>:'SIB = ':IBUF(2) CRT 'OPTR<1>,OPTR<2> = ':OPTR<1>,OPTR<2> TEMP = ' ':@AM:' ' ; TEMP = '*' CRT TEMP<1>:'POB = ':OBUF(1) CRT TEMP<2>:'SOB = ':OBUF(2) * DF to display fast file buffer CASE PINE = 'DF' TEMP = FREC(10) CRT 'FAST FILE BUFFER - ID = "':TEMP<1>:'"' DEL TEMP<1> CRT TEMP * DF n to display file buffer n CASE PINE[1,2] = 'DF' NUMB = OCONV(PINE,'MCN')[1,1] + 0 IF NUMB THEN CRT 'FILE BUFFER ':NUMB: END ELSE NUMB = 10 CRT 'FAST FILE BUFFER': END TEMP = FREC(NUMB) CRT ' - ID = "':TEMP<1>:'"' DEL TEMP<1> CRT TEMP * DS n to display Select Register n CASE PINE[1,2] = 'DS' NUMB = OCONV(PINE,'MCN')[1,1] + 0 IF NUMB ELSE NUMB = 1 CRT 'SELECT LIST REGISTER ':NUMB CRT SREG(NUMB) * Display the input buffer CASE 1 PINE = TRIM(PINE[2,ROOM]) IF PINE[LEN(PINE),1] = '+' THEN PINE = PINE[1,LEN(PINE)-1] STAY = @TRUE END ELSE STAY = @FALSE PVAR = FIELD(PINE,',',1) MVAR = OCONV(FIELD(PINE,',',2),'MCN')+0 IF MVAR LE 0 THEN MVAR = 999999 WORD = PVAR GOSUB SCAN.WORD IF WORD = '' THEN CRT 'AIB = ':IBUF(ACTI)[1,MVAR]: END ELSE CRT 'AIB<':WORD:'> = ':IBUF(ACTI)[1,MVAR]: IF STAY ELSE CRT END CASE CRT 'Press ': INPUT WAIT RETURN E: * Non-existent GO BAD.COMD RETURN F: PINE = TRIM(PINE) BEGIN CASE CASE PINE = 'F' * Move the input buffer pointer forward IPTR += 1 CASE PINE[1,2] = 'F;' * Stack Arithmetic JAIL = PINE ; WALL = ';' ; SPOT = 1 GOSUB GET.NEXT.WORD ; * Consume F F = '' LOOP GOSUB GET.NEXT.WORD UNTIL WORD = '' DO BEGIN CASE CASE WORD = '+' T = F<1>+F<2>; DEL F<1>; F<1> = T CASE WORD = '-' T = F<2>-F<1>; DEL F<1>; F<1> = T CASE WORD = '/' T = F<2>/F<1>; DEL F<1>; F<1> = T CASE WORD = '*' T = F<1>*F<2>; DEL F<1>; F<1> = T CASE WORD = 'R' T = REM(F<2>,F<1>); DEL F<1>; F<1> = T CASE WORD = '{' T = F<1>; F<1> = F<2>; F<2> = T CASE WORD = '?P' IBUF(1) = F<1> CASE WORD[1,1] = '?' AND INDEX(REGS,WORD[2,1],1) WORD = WORD[2,ROOM] GOSUB EVAL.REF BEGIN CASE CASE BYTE = '%' IBUF(ACTI) = F<1> CASE BYTE = '#' OBUF(2) = F<1> CASE BYTE = '&' IF MORE THEN FREC(THAT) = F<1> END ELSE FREC(THAT) = F<1> CASE BYTE = '!' SREG(THAT) = F END CASE CASE INDEX(REGS,WORD[1,1],1) > 1 GOSUB EVAL.REF INS WORD BEFORE F<1> CASE 1 CRT '*ERROR IN STACK AT ':WORD GO BAD.LINE END CASE REPEAT * F-CLEAR command CASE PINE[1,3] = 'F-C' WORD = FIELD(PINE,' ',2) ; GOSUB SCAN.WORD ; FILENO = WORD IF NOT(FILENO MATCHES '1N') AND FILENO THEN GO BAD.FILENO FREC(PINE) = '' * F-DELETE command CASE PINE[1,3] = 'F-D' WORD = FIELD(PINE,' ',2) ; GOSUB SCAN.WORD ; FILENO = WORD IF NOT(FILENO MATCHES '1N') AND FILENO THEN GO BAD.FILENO ID = FREC(PINE)<1> DELETE FHAN(PINE),ID * F-FREE command CASE PINE[1,3] = 'F-F' WORD = FIELD(PINE,' ',2) ; GOSUB SCAN.WORD ; FILENO = WORD WORD = FIELD(PINE,' ',3) ; GOSUB SCAN.WORD ; ID = WORD IF INDEX(REGS,ID[1,1],1) THEN WORD = ID ; GOSUB EVAL.REF ; ID = WORD END BEGIN CASE CASE FILENO = '' AND ID = '' RELEASE CASE FILENO MATCHES '1N' AND FILENO IF ID NE '' THEN RELEASE FHAN(FILENO),ID END ELSE RELEASE FHAN(FILENO) CASE FILENO = '0' IF ID NE '' THEN RELEASE FHAN(10),ID END ELSE RELEASE FHAN(10) CASE ID = '' RELEASE FHAN(10),FILENO CASE 1 GO BAD.COMD END CASE * F-OPEN command CASE PINE[1,3] = 'F-O' WORD = FIELD(PINE,' ',2) ; GOSUB SCAN.WORD ; FILENO = WORD IF NOT(FILENO MATCHES '1N') AND FILENO THEN GO BAD.FILENO WORD = PINE ; GOSUB SCAN.WORD OPEN WORD TO FHAN(FILENO) THEN HERE += 1 ELSE NULL * F-READ command CASE PINE[1,3] = 'F-R' WORD = FIELD(PINE,' ',2) ; GOSUB SCAN.WORD ; FILENO = WORD IF NOT(FILENO MATCHES '1N') AND FILENO THEN GO BAD.FILENO WORD = FIELD(PINE,' ',3) ; GOSUB SCAN.WORD ; ID = WORD READ JUNK FROM FHAN(FILENO),ID THEN JUNK = INSERT(JUNK,0,0,0,ID) FREC(FILENO) = JUNK HERE += 1 END * F-UREAD command CASE PINE[1,3] = 'F-U' WORD = FIELD(PINE,' ',2) ; GOSUB SCAN.WORD ; FILENO = WORD WORD = FIELD(PINE,' ',3) ; GOSUB SCAN.WORD ; ID = WORD READU JUNK FROM FHAN(FILENO),ID THEN JUNK = INSERT(JUNK,0,0,0,ID) FREC(FILENO) = JUNK HERE += 1 END * F-WRITE command CASE PINE[1,3] = 'F-W' WORD = FIELD(PINE,' ',2) ; GOSUB SCAN.WORD ; FILENO = WORD IF NOT(FILENO MATCHES '1N') AND FILENO THEN GO BAD.FILENO ID = FREC(FILENO)<1> JUNK = FREC(FILENO) ; JUNK = DELETE(JUNK,1) WRITE JUNK ON FHAN(FILENO),ID CASE PINE[1,2] = 'FB' LOCK = PINE[3,1] = 'U' PINE = FIELD(PINE,')',1) PINE = FIELD(PINE,'(',2) PINE = TRIM(PINE) JAIL = PINE ; WALL = ' ' ; SPOT = 1 DICT = '' GOSUB GET.NEXT.WORD IF WORD = 'DICT' THEN DICT = WORD ; GOSUB GET.NEXT.WORD GOSUB SCAN.WORD FNAM = WORD GOSUB GET.NEXT.WORD GOSUB SCAN.WORD ID = WORD IF FNAM = '' OR ID = '' THEN GO BAD.COMD OPEN DICT,FNAM TO FHAN(10) ELSE RETURN IF LOCK THEN READU JUNK FROM FHAN(10),ID ELSE RETURN END ELSE READ JUNK FROM FHAN(10),ID ELSE RETURN END INS ID BEFORE JUNK<1> FREC(10) = JUNK HERE += 1 CASE 1 ; GO BAD.COMD END CASE RETURN G: BEGIN CASE CASE PINE[1,5] = 'GOSUB' PINE = TRIM(PINE[6,ROOM]) IF PINE MATCHES '1N0N' THEN LOCATE(PINE,GOES;POSN) ELSE GO BAD.LINE INS HERE BEFORE PSUB<1> HERE = TOES - 1 END ELSE CRT '*ERROR IN GOSUB ':PINE GO BAD.LINE END CASE 1 IF PINE[1,4] = 'GOTO' THEN PINE = 'G':PINE[5,ROOM] IF PINE[1,2] = 'GO' THEN PINE = 'G':PINE[3,ROOM] PINE = TRIM(PINE[2,ROOM]) IF PINE[1,1] = 'A' THEN WORD = PINE GOSUB EVAL.A.COMMAND PINE = WORD END BEGIN CASE CASE PINE = 'F' LOCATE(HERE,EMMS;POSN;'AR') THEN POSN += 1 ELSE NULL IF EMMS = '' THEN GO BAD.LINE HERE = EMMS - 1 CASE PINE = 'B' LOCATE(HERE,EMMS;POSN;'AR') ELSE NULL IF POSN LE 1 THEN GO BAD.LINE HERE = EMMS CASE PINE MATCHES '1N0N' LOCATE(PINE,GOES;POSN) ELSE GO BAD.LINE HERE = TOES - 1 CASE 1 GO BAD.COMD END CASE END CASE RETURN H: PINE = PINE[2,ROOM] IF PINE[1,1] = ' ' THEN PINE = PINE[2,ROOM] OBUF(ACTO) := @AM END TRAIL = '' IF PINE[LEN(PINE),1] = ' ' THEN TRAIL = ' ' WORD = TRIM(PINE) IF INDEX(REGS,WORD[1,1],1) THEN GOSUB EVAL.REF WORD := TRAIL CONVERT ' ' TO @AM IN WORD OBUF(ACTO) := WORD OPTR = DCOUNT(OBUF(ACTO),@AM) IF OPTR < 1 THEN OPTR = 1 RETURN I: BEGIN CASE * I haven't tested for pattern matching. CASE PINE[1,2] = 'IF' IF PINE[1,3] = 'N' THEN IFN = @TRUE ELSE IFN = @FALSE JAIL = PINE ; WALL = ' '; SPOT = 1 GOSUB GET.NEXT.WORD ; * Consume command GOSUB GET.NEXT.WORD ; * Get the condition * For strict logic test, there may be reversed logic IF WORD = '#' THEN REVERSE = @TRUE GOSUB GET.NEXT.WORD END ELSE REVERSE = @FALSE COND = WORD PINE = TRIMF(JAIL[SPOT,ROOM]) ; * Save the next command GOSUB GET.NEXT.WORD ; * Get the operation... maybe IF LEN(WORD) = 1 AND INDEX('<>[]=#',WORD,1) THEN OP = WORD GOSUB GET.NEXT.WORD ; * Get the comparison string COMP = WORD PINE = TRIMF(JAIL[SPOT,ROOM]) ; * The next command changed END ELSE OP = '' ; COMP = '' BEGIN CASE CASE COND = 'E' WORD = @SYSTEM.RETURN.CODE CASE COND = 'S' OR COND MATCHES '"S"1N' NUMB = COND[2,1] IF NUMB:'*' = '0*' THEN NUMB = 10 IF NUMB THEN WORD = SREG(NUMB) NE '' END ELSE WORD = @SELECTED NE 0 CASE COND[1,1] = 'A' WORD = COND ; GOSUB EVAL.A.COMMAND ; COND = WORD CASE INDEX(REGS,COND[1,1],1) WORD = COND ; GOSUB EVAL.REF ; COND = WORD CASE 1 WORD = COND END CASE * Strictly logical test only IF OP = '' THEN TEST = NOT(WORD) IF REVERSE ELSE TEST = NOT(TEST) IF TEST THEN GO PROCESS.PROC.LINE RETURN END * The IFN flag means that we take only the leading numeric part IF IFN THEN IFN = 1 LOOP WHILE WORD[IFN,1] MATCHES '1N' DO IFN += 1 REPEAT WORD = WORD[1,IFN-1] END IF INDEX('<>[]',OP,1) THEN BEGIN CASE CASE OP = '>' IF WORD > COMP THEN GO PROCESS.PROC.LINE CASE OP = '<' IF WORD < COMP THEN GO PROCESS.PROC.LINE CASE OP = ']' IF WORD GE COMP THEN GO PROCESS.PROC.LINE CASE WORD = '[' IF WORD LE COMP THEN GO PROCESS.PROC.LINE END CASE END * IFN doesn't count after this - I think * Non multi-valued comparison IF NOT(INDEX(COMP,@VM,1)) THEN BEGIN CASE CASE OP = '=' IF COND = COMP THEN GO PROCESS.PROC.LINE CASE OP = '#' IF COND # COMP THEN GO PROCESS.PROC.LINE END CASE RETURN END * GO or GOSUB to a multi-value destination PINE = TRIMF(PINE) IF INDEX(PINE,@VM,1) AND PINE[1,2] = 'GO' AND OP = '=' THEN WORD = FIELD(PINE,' ',1) PINE = TRIMF(PINE[LEN(WORD)+1,ROOM]) LOCATE(COND,COMP,1;POSN) THEN PINE = WORD:' ':PINE<1,POSN> GO PROCESS.PROC.LINE END RETURN END * Multi-valued command IF OP = '=' THEN LOCATE(COND,COMP,1;POSN) THEN GO PROCESS.PROC.LINE END ELSE LOCATE(COND,COMP,1;POSN) ELSE GO PROCESS.PROC.LINE END CASE TRIM(PINE) = 'IH\' IBUF(ACTI) = '' CASE TRIM(PINE) = 'IH \' INS '' BEFORE IBUF(ACTI) CASE PINE[1,2] = 'IH' OR PINE[1,3] = 'IBH' TEST = PINE[2,1] IF TEST = 'B' THEN PINE = PINE[4,ROOM] END ELSE PINE = PINE[3,ROOM] WORD = TRIM(PINE) ICNV = FIELD(WORD,';',2) WORD = FIELD(WORD,';',1) OCNV = FIELD(WORD,':',2) WORD = FIELD(WORD,':',1) IF WORD[1,1] NE '' THEN IF INDEX(REGS,WORD[1,1],1) THEN GOSUB EVAL.REF END TEMP = WORD IF ICNV NE '' THEN TEMP = ICONV(TEMP,ICNV) IF OCNV NE '' THEN TEMP = OCONV(TEMP,OCNV) IF TEST<1> NE 'B' THEN TEMP = TRIM(TEMP) CONVERT ' ' TO @AM IN TEMP END IBUF(ACTI) = TEMP IPTR = 1 CASE PINE[1,2] = 'IN' OR PINE[1,2] = 'IS' PINE = TRIM(PINE[3,ROOM])[1,1] IF PINE NE '' THEN PROMPT PINE INPUT TEMP TEMP = TRIM(TEMP) CONVERT ' ' TO @AM IN TEMP IBUF(ACTI) = TEMP IPTR = 1 CASE PINE[1,3] = 'IBN' OR PINE[1,3] = 'IBS' PINE = TRIM(PINE[3,ROOM])[1,1] IF PINE NE '' THEN PROMPT PINE INPUT TEMP *?* CONVERT ' ' TO @AM IN TEMP IBUF(ACTI) = TEMP IPTR = 1 CASE PINE[1,2] = 'IP' OR PINE[1,3] = 'IBP' TEST = PINE[2,1] IF TEST = 'B' THEN PINE = PINE[4,ROOM] END ELSE PINE = PINE[3,ROOM] WORD = TRIM(PINE) IF WORD[1,1] NE '' THEN IF INDEX(REGS,WORD[1,1],1) ELSE PROMPT WORD[1,1] WORD = TRIM(WORD[2,ROOM]) END IF WORD[1,1] NE '' THEN IF INDEX(REGS,WORD[1,1],1) THEN GOSUB EVAL.REF TEST<2> = WORD[1,1] END END INPUT TEMP IF TEST<1> = 'P' THEN TEMP = TRIM(TEMP) CONVERT ' ' TO @AM IN TEMP END BYTE = TEST<2> BEGIN CASE CASE BYTE = '%' IBUF(ACTI) = TEMP CASE BYTE = '#' OBUF(2) = TEMP CASE BYTE = '&' IF MORE THEN FREC(THAT) = TEMP END ELSE FREC(THAT) = TEMP CASE BYTE = '!' SREG(THAT) = TEMP CASE 1 IBUF(ACTI) = TEMP IPTR = 1 END CASE CASE PINE[1,2] = 'IT' CRT 'Tape command DEFINITELY not catered for' GO BAD.COMD CASE 1 ; GO BAD.COMD END CASE RETURN J: * Non-existent GO BAD.COMD RETURN K: * Non-existent GO BAD.COMD RETURN L: BEGIN CASE CASE PINE[1,2] = 'LN' PRINTER OFF CASE PINE[1,2] = 'LC' PRINTER CLOSE CASE PINE[1,2] = 'LE' PAGE CASE PINE[1,4] = 'LHDR' HEAD = '' PINE = PINE[5,ROOM] ROOM = LEN(PINE) JAIL = PINE ; WALL = ',' ; SPOT = 1 LOOP UNTIL SPOT GE ROOM GOSUB GET.NEXT.WORD BEGIN CASE CASE WORD = 'P' ; HEAD := "'P'" CASE WORD = 'T' ; HEAD := "'T'" CASE WORD = 'Z' ; NULL ; * cannot do this CASE WORD[1,1] = '(' ; NULL ; * cannot do this CASE INDEX(REGS,WORD[1,1],1) ICNV = FIELD(WORD,';',2) WORD = FIELD(WORD,';',1) OCNV = FIELD(WORD,':',2) WORD = FIELD(WORD,':',1) GOSUB EVAL.REF IF ICNV NE '' THEN WORD = ICONV(WORD,ICNV) IF OCNV NE '' THEN WORD = OCONV(WORD,OCNV) HEAD := WORD CASE WORD MATCHES '1N0N' ; HEAD := "'":STR('L',WORD):"'" CASE 1 CONVERT '"' TO '' IN WORD CONVERT "'" TO '' IN WORD HEAD := WORD END CASE REPEAT HEADING HEAD CASE 1 PINE = TRIMF(PINE[2,ROOM]) ROOM = LEN(PINE) ; WALL = ',' ; SPOT = 1 STAY = @FALSE LOOP UNTIL SPOT GE ROOM GOSUB GET.NEXT.WORD BEGIN CASE CASE WORD = '+' ; STAY = @TRUE CASE WORD[1,1] = '(' ; NULL ; * cannot do this CASE INDEX(REGS,WORD[1,1],1) ICNV = FIELD(WORD,';',2) WORD = FIELD(WORD,';',1) OCNV = FIELD(WORD,':',2) WORD = FIELD(WORD,':',1) GOSUB EVAL.REF IF ICNV NE '' THEN WORD = ICONV(WORD,ICNV) IF OCNV NE '' THEN WORD = OCONV(WORD,OCNV) PRINT WORD: CASE 1 CONVERT '"' TO '' IN WORD CONVERT "'" TO '' IN WORD PRINT WORD: END CASE REPEAT IF STAY ELSE PRINT END CASE RETURN M: BEGIN CASE CASE PINE = 'M' NULL CASE PINE[1,2] = 'M ' PINE = TRIMF(PINE[3,ROOM]) IF PINE NE '' THEN GO PROCESS.PROC.LINE * I have lumped in MV with MVA and MVB - I know it's different, * but I find the manual really confusing and I don't use PROCs. CASE PINE[1,2] = 'MV' * CASE PINE[1,3] = 'MVA' OR PINE[1,3] = 'MVD'' SORT = PINE[3,1]:'L' IF SORT = 'L' THEN SORT = '' JAIL = PINE[4,ROOM] ; WALL = ' ' ; SPOT = 1 GOSUB GET.NEXT.WORD ; DEST = WORD GOSUB GET.NEXT.WORD ; SORS = WORD IF SORS = '' OR DEST = '' THEN GO BAD.LINE IF INDEX(REGS,SORS[1,1],1) THEN WORD = SORS ; GOSUB EVAL.REF ; SORS = WORD END IF NOT(INDEX(REGS,DEST[1,1],1)) THEN GO BAD.LINE WORD = DEST ; GOSUB EVAL.REF CRT 'WORD = ':WORD IF SORT = '' THEN LOCATE(SORS,WORD,1;POSN) ELSE WORD<1,-1> = SORS END ELSE LOCATE(SORS,WORD,1;POSN;SORT) ELSE INS SORS BEFORE WORD<1,POSN> END END BEGIN CASE CASE BYTE = '%' IBUF(ACTI) = WORD CASE BYTE = '#' OBUF(2) = WORD CASE BYTE = '&' IF MORE THEN FREC(THAT) = WORD END ELSE FREC(THAT) = WORD CASE BYTE = '!' SREG(THAT) = WORD END CASE CASE 1 ; GO BAD.COMD END CASE RETURN N: * Non-existent GO BAD.COMD RETURN O: PINE = PINE[2,ROOM] IF PINE[LEN(PINE),1] = '+' THEN PINE = PINE[1,LEN(PINE)-1] STAY = @TRUE END ELSE STAY = @FALSE CRT PINE: IF STAY ELSE CRT RETURN P: OB1 = CONVERT(@AM,' ',OBUF(1)) OB2 = CONVERT(@AM,' ',OBUF(2)) WAIT = '' IF INDEX(PINE,'P',2) OR INDEX(PINE,'W',1) THEN CRT 'POB = ':OB1 CRT 'SOB = ':OB2 IF INDEX(PINE,'W',1) THEN CRT MSG1: INPUT WAIT END IF INDEX(PINE,'W',1) THEN LOOP IF WAIT = 'N' THEN PINE = 'RO' ; GOSUB R ; STOP IF WAIT = 'S' THEN PINE = 'RO' ; GO R UNTIL WAIT = '' OR WAIT = 'Y' OR WAIT = 'G' DO CRT '1-ary = ':OB1 CRT '2-ary = ':OB2 CRT MSG1: INPUT WAIT REPEAT END IF OB2 NE '' AND OB2[LEN(OB2),1] NE '<' THEN CRT 'SECONDARY OUTPUT BUFFER HAS NO TERMINATING CARRIAGE RETURN' GO BAD.LINE END * ProVerb manual says to remove redundant carriage returns * I think it arguable myself, but that's the documentation OB2 = TRIM(OB2,'<','R') CONVERT '<' TO @AM IN OB2 TEMP = INDEX(PINE,'L',1) IF TEMP THEN TEMP = PINE[TEMP+1,ROOM] IF NOT(TEMP MATCHES '1N0N') THEN CRT 'BAD LOCK'; GO BAD.LINE IF TEMP GT 63 THEN CRT 'LOCK OUT OF RANGE'; GO BAD.LINE LOCK TEMP END XXNO = DCOUNT(OB2,@AM) FOR XX = 1 TO XXNO DATA OB2 NEXT XX IF INDEX(PINE,'H',1) THEN EXECUTE OB1 CAPTURING JUNK RETURNING ERRMSG END ELSE EXECUTE OB1 RETURNING ERRMSG END IF TEMP THEN UNLOCK TEMP PINE = 'RO' ; GO R RETURN Q: PINE = PINE[2,ROOM] IF PINE # '' THEN CRT PINE LABELX = 'X' GO BACK R: BEGIN CASE CASE PINE[1,2] = 'RI' * Clear the secondary input buffer IBUF(2) = '' * Make the primary input buffer the active one ACTI = 1 * Clear the primary input buffer TEMP = OCONV(PINE,'MCN') + 0 BEGIN CASE CASE PINE[3,1] = '(' IBUF(1) = IBUF(1)[1,TEMP-1] CASE TEMP IPTR = TEMP LOOP WHILE DCOUNT(IBUF(1),@AM) GT TEMP DO DEL IBUF(1) REPEAT CASE 1 IBUF(1) = '' IPTR = 1 END CASE CASE PINE[1,2] = 'RO' * Clear both output buffers OBUF(1) = '' ; OPTR = 1 OBUF(2) = '' ; OPTR<2> = 1 * Make the primary input buffer the active one ACTO = 1 CASE PINE[1,3] = 'RTN' JAIL = PINE[4,ROOM]; WALL = ' '; SPOT = 1; GOSUB GET.NEXT.WORD IF WORD MATCHES '1N0N' THEN LABEL = WORD + 0 GO BACK CASE PINE[1,4] = 'RSUB' IF PSUB = '' THEN CRT 'RSUB without GOSUB' GO BAD.LINE END HERE = PSUB<1> DEL PSUB<1> CASE 1 ; GO BAD.COMD END CASE RETURN S: BEGIN CASE CASE PINE[1,4] = 'STOF' ACTO = 1 CASE PINE[1,4] = 'STON' ACTO = 2 CASE PINE[1,2] = 'SP' ACTI = 1 CASE PINE[1,2] = 'SS' ACTI = 2 CASE 1 * Sp,Sr,S(n) PINE = PINE[2,ROOM] BEGIN CASE CASE PINE MATCH '0N' IPTR = PINE CASE INDEX(REGS,PINE[1,1],1) WORD = PINE GOSUB EVAL.REF IF NUM(WORD) AND WORD > 0 THEN IPTR = WORD END ELSE GO BAD.LINE CASE PINE[1,1] = '(' CRT 'S(n) IS NOT SUPPORTED' GO BAD.COMD CASE 1 ; GO BAD.COMD END CASE END CASE RETURN T: IF PINE[1,2] = 'TR' THEN PINE = TRIM(PINE[3,ROOM]) BEGIN CASE CASE PINE[1,2] = 'ON' ; HINT = @TRUE CASE PINE[1,2] = 'OF' ; HINT = @FALSE CASE PINE = '' ; HINT = NOT(HINT) CASE 1 ; GO BAD.LINE END CASE END * Anything else is a terminal output PINE = TRIMF(PINE[2,ROOM]) LOOP ROOM = LEN(PINE) WHILE PINE[ROOM,1] = ',' DO HERE += 1 PINE := PROC REPEAT JAIL = PINE ; WALL = ',' ; SPOT = 1 TCOMS = '' ; WORD = '' XXCNT = 0 LOOP BRAC = '(' ; KETS = ')' GOSUB GET.NEXT.WORD WHILE WORD GT '' DO TCOMS<-1> = WORD XXCNT += 1 REPEAT STAY = @FALSE FLIP = 0 ; FLOP = 0 FOR XX = 1 TO XXCNT TCOM = TCOMS BEGIN CASE CASE TCOM[1,1] = '"' OR TCOM[1,1] = "'" TCOM = TCOM[2,LEN(TCOM)-2] CRT TCOM: CASE TCOM[1,1] = '(' WORD = TCOM[2,LEN(TCOM)-2] BEGIN CASE CASE WORD MATCHES '1N0N' ; CRT @(WORD): CASE WORD MATCHES '"-"1N0N' ; CRT @(WORD): CASE WORD MATCHES '1N0N","1N0N' COL = FIELD(WORD,',',1) ROW = FIELD(WORD,',',2) CRT @(COL,ROW): END CASE CASE TCOM = '+' IF XXCNT = N THEN STAY = @TRUE CASE TCOM = 'B' CRT CHAR(7): CASE TCOM = 'C' CRT @(-1): CASE TCOM = 'D' ; NAP 300 CASE TCOM[1,1] = 'I' WORD = TRIM(TCOM[2,LEN(TCOM)]) IF WORD MATCHES '1N0N' THEN CRT CHAR(WORD): CASE TCOM = 'L' IF FLIP GT 0 THEN FLIP -= 1 N = FLOP END CASE TCOM[1,1] = 'S' WORD = TCOM[2,LEN(TCOM)] GOSUB SCAN.WORD CRT SPACE(WORD): CASE TCOM[1,1] = 'T' FLIP = 2 FLOP = N CASE TCOM[1,1] = 'U' CRT @(-10): CASE TCOM[1,1] = 'X' * I'm not sure this is what was meant WORD = TCOM[2,LEN(TCOM)] GOSUB SCAN.WORD WORD = FMT(WORD,'R%2') CRT OCONV(WORD,'MCX'): CASE 1 WORD = TCOM GOSUB SCAN.WORD CRT WORD: END CASE NEXT XX IF STAY ELSE CRT RETURN U: PINE = PINE[2,ROOM] JAIL = PINE ; WALL = ' '; SPOT = 1 THIS = NAME CALL @WORD(RESULT,THIS,STATUS,'O') ****** I don't know how this should be handled * There is a difference in documentation between QM & Universe as * to what the user exit programs look like from the BASIC side. * The ProVerb manual doesn't mention a RESULT variable, instead * it looks like the buffers are updated within the program. * This is true in D3 documentation too, but that looks like the * program can access the next line of input somehow - and then * skip over it when it wants to. * RETURN V: * Non-existent GO BAD.COMD RETURN W: * Non-existent GO BAD.COMD RETURN X: PINE = PINE[2,ROOM] IF PINE # '' THEN CRT PINE GO BACK STOP Y: * Non-existent GO BAD.COMD RETURN Z: * Non-existent GO BAD.COMD RETURN PLUS.COMMAND: TEMP = IBUF(ACTI) IF NOT(TEMP MATCHES '1N0N') THEN TEMP = 0 PINE = PINE[2,ROOM] JAIL = PINE ; WALL = ' '; SPOT = 1 ; GOSUB GET.NEXT.WORD WORD = TRIM(WORD,'+','F') IF NOT(WORD MATCHES '1N0N') THEN WORD = 0 IBUF(ACTI) = TEMP + WORD RETURN MINUS.COMMAND: TEMP = IBUF(ACTI) IF NOT(TEMP MATCHES '1N0N') THEN TEMP = 0 PINE = PINE[2,ROOM] JAIL = PINE ; WALL = ' '; SPOT = 1 ; GOSUB GET.NEXT.WORD WORD = TRIM(WORD,'+','F') IF NOT(WORD MATCHES '1N0N') THEN WORD = 0 IBUF(ACTI) = TEMP - WORD RETURN CHAIN.COMMAND: GOSUB GET.PROCX PROC = PROCX NAME = NAMEX FILENAME = FILENAMEX FILEHANDLE = FILEHANDLEX LABEL = LABELX PRINTER OFF GO TOP CALL.COMMAND: GOSUB GET.PROCX PRINTER OFF CALL CALLPROC(PROCX,NAMEX,FILENAMEX,FILEHANDLEX,LABELX) IF LABELX = 'X' THEN LABEL = 'X'; GO BACK IF NUM(LABEL) THEN HERE += LABEL LABEL = '' RETURN GET.PROCX: PINE = PINE[2,ROOM] ROOM = LEN(PINE) IF PINE[ROOM,1] = ')' THEN PINE = PINE[1,ROOM-1] IF PINE[ROOM,1] = ']' THEN PINE = PINE[1,ROOM-1] JAIL = PINE ; WALL = ' ' ; SPOT = 1 GOSUB GET.NEXT.WORD DICT = '' IF WORD = 'DICT' THEN DICT = WORD ; GOSUB GET.NEXT.WORD LABELX = '' FNAM = WORD IF FNAM = '' THEN GO BAD.LINE FILENAMEX = DICT:'*':FNAM GOSUB GET.NEXT.WORD NAMEX = WORD IF NAMEX = '' THEN NAMEX = IBUF(ACTI) GOSUB GET.NEXT.WORD LABELX = WORD IF DICT:'*':FNAM = FILENAME THEN FILEHANDLEX = FILEHANDLE END ELSE OPEN DICT,FNAM TO FILEHANDLEX ELSE CRT DICT:' ':FNAM:' CANNOT BE OPENED' GO BAD.LINE END FILENAMEX = DICT:'*':FNAM END READ PROCX FROM FILEHANDLEX, NAMEX ELSE CRT 'CANNOT READ "':NAMEX:'" FROM ':DICT:' ':FNAM GO BAD.LINE END RETURN SCAN.WORD: * Figure out a word BEGIN CASE CASE WORD MATCHES '1N0N' * Is it a number? RETURN CASE INDEX(REGS,WORD[1,1],1) * Is it a reference? GOSUB EVAL.REF CASE 1 END CASE RETURN EVAL.REF: MORE = '' DOOM = LEN(WORD) TEMP = WORD[DOOM,1] THAT = TEMP DOOM -= 1 FOR MARK = DOOM TO 1 STEP -1 IF MARK GT 1 THEN THAT = TEMP IF NOT(TEMP MATCHES '0N') THEN GO REF.FAILED BYTE = WORD[MARK,1] BEGIN CASE CASE BYTE = '%' * Active Input Buffer TEMP = IBUF(ACTI) CASE BYTE = '#' * Secondary Output Buffer TEMP = OBUF(2) CASE BYTE = '&' * File Buffer OR Fast Buffer IF MORE NE '' THEN IF NOT(MORE MATCHES '1N') AND FILENO THEN GO BAD.FILENO TEMP = FREC(TEMP) MORE = '' END ELSE TEMP = FREC(10) CASE BYTE = '!' * Select Register TEMP = SREG(TEMP) CASE BYTE MATCH '1N' * Building a number TEMP = BYTE:TEMP CASE BYTE = '.' * Field from File Buffer MORE = TEMP MARK -= 1 TEMP = WORD[MARK,1] CASE 1 * Problem GO REF.FAILED END CASE NEXT MARK WORD = TEMP RETURN REF.FAILED: CRT 'INDIRECT REFERENCE FAILED ': CRT WORD CRT STR(' ',MARK-1):'^' GO BAD.LINE RETURN GET.NEXT.WORD: * Get the next word from the sentence JAIL WORD = '' ; CITE = '' TIED = @FALSE TIES = 0 DONE = @FALSE DOOM = LEN(JAIL) QT = '"\':"'" ! The "bang" commented out lines mean that opening or closing quotes ! or brackets will force an end-of-word. I'm not sure this is desired. LOOP BYTE = JAIL[SPOT,1] BEGIN CASE CASE SPOT > DOOM DONE = @TRUE CASE CITE = '' AND TIES = 0 AND BYTE = BRAC IF WORD = '' THEN TIES += 1 TIED = @TRUE END ELSE ! DONE = @TRUE END CASE TIES > 0 IF BYTE = BRAC THEN TIES += 1 IF BYTE = KETS THEN TIES -= 1 ! IF TIES = 0 THEN ! DONE = @TRUE ; SPOT += 1 ; WORD := BYTE ! END END CASE CITE = '' AND INDEX(QT,BYTE,1) IF WORD = '' THEN CITE = BYTE END ELSE ! DONE = @TRUE END CASE BYTE = CITE ! DONE = @TRUE SPOT += 1 WORD := BYTE CASE CITE = '' AND BYTE = WALL IF WORD = '' THEN BYTE = '' END ELSE DONE = @TRUE END END CASE UNTIL DONE DO SPOT += 1 WORD := BYTE REPEAT BRAC = '' ; KETS = '' RETURN EVAL.A.COMMAND: * I am unsure whether the Input Buffer Pointer should be changed * within this GOSUB - I have assumed it isn't AMID = ' ' IF WORD[2,1] = '(' THEN WORD = FIELD(WORD[2,ROOM],')',1) PVAR = IPTR NVAR = OCONV(FIELD(WORD,',',1),'MCN')+0 MVAR = OCONV(FIELD(WORD,',',2),'MCN')+0 END ELSE IF NOT(WORD[1,1] MATCHES '1N') AND WORD[1,1] NE ',' THEN AMID = WORD[1,1] WORD = WORD[2,ROOM] END PVAR = OCONV(FIELD(WORD,',',1),'MCN')+0 NVAR = 1 MVAR = OCONV(FIELD(WORD,',',2),'MCN')+0 END IF NVAR LE 0 THEN NVAR = 1 IF MVAR LE 0 THEN MVAR = 99999999 TEMP = PVAR IF TEMP LE 0 THEN TEMP = IPTR NEW.IPTR = TEMP * ACTO = 1 means STOFF, else STON IF ACTO = 1 THEN TEMP = IBUF(ACTI)[NVAR,MVAR] TEMP = AMID:TEMP:AMID END ELSE TEMP = INDEX(IBUF(ACTI),@AM,NEW.IPTR) + NVAR TEMP = IBUF(ACTI)[TEMP,MVAR] END RETURN