!!!! 18/4/79
! GPM -- DIRTY VERSION FOR INTERDATA IMP
!
CONSTSTRING (8) VERSION = "GPM 1.09"
!-------------------------------------------------!
! I/O STREAMS: !
! ----------- !
! INPUT 2: MACRO DEFN. FILE !
! INPUT 1: SOURCE TEXT TO BE EXPANDED !
! !
! OUTPUT 0: REPORT STREAM FOR ERROR MESSAGES !
! OUTPUT 1: EXPANDED VERSION OF SOURCE TEXT. !
! OUTPUT 2: DUMP FILE FOR MACRO DEFINITIONS. !
!-------------------------------------------------!
! ****THE DUMP FACILITY FOR UNLOADING ALL CURRENT MACRO DEFINITIONS
! IS NOT SUPPORTED MEANTIME****
!
CONSTINTEGER CUT OFF = 50; ! ... STOP AFTER THIS MANY ERRORS
CONSTINTEGER DUPLICATE = 1; ! DUPLICATE ERROR MESSAGES IN OUTPUT 1
!
!
!
! PRIMARY INPUT: SOURCE TEXT TO BE EXPANDED
! PRIMARY OUTPUT: RESULTING OUTPUT TEXT
! MACRO DEFNS: MACRO DEFN. FILE READ BEFORE PRIMARY INPUT.
! DUMP FILE: DUMP OF MACRO ENVIRONMENT DEFINED.
! THE LAST TWO ARE OPTIONAL: IF NO DEFN. FILE IS DEFINED THAT
! STAGE WILL BE SKIPPED: IF A DUMP FILE IS DEFINED, MACROS
! DEFINED AT '$*END*' OF THE PRIMARY INPUT WILL BE DUMPED ONTO
! IT IN A FORM IN WHICH THEY CAN BE RE-READ AS A 'MACRO FILE'
! NOTE THAT BOTH THE MACRO FILE AND THE PRIMARY INPUT MUST
! END WITH '$*END*' - ALSO THAT DEFNS AND/OR CALLS CAN BE
! PUT IN EITHER INPUT FILE, THE SEPARATION BEING MERELY A MATTER
! OF CONVENIENCE.
!
! A COMMAND('DELIMS') HAS BEEN ADDED TO PERMIT THE VARIOUS
! SPECIAL CHARACTERS TO BE CHANGED. NOTE THAT USED IN CONJUNCTION
! WITH THE 'DUMP' FACILITY, THIS CAN PRODUCE ABSOLUTE RUBBISH.
!
BEGIN ; ! ...MAIN PROGRAM LEVEL
INTEGER STKLIMIT; CONSTINTEGER STKMAX = 32767; ! ...16 BITS!
BEGIN
STKLIMIT = (FREE SPACE - 1000)>>1
STKLIMIT = STKMAX IF STKLIMIT > STKMAX
END
SHORTINTEGERARRAY ST(0:STKLIMIT)
! DEFINE I/O STREAMS -- NOTE THAT THE DUMP FACILITY CAN BE
! DISABLED BY SETTING 'DUMP' TO A NEGATIVE VALUE.
CONSTINTEGER DEFN FILE=2, SOURCE=1, REPORT=0, OUT=1, DUMP=-1
CONSTINTEGER FF=12; ! FORM-FEED CHARACTER
OWNINTEGER ERROR = 0
OWNSHORTINTEGER INSTRM
SHORTINTEGER LBR, RBR; ! ... LEFT/RIGHT BRACKET
OWNINTEGER A,R,W,X,K
OWNINTEGER D1,D2,D3,W1
OWNINTEGER Q = 1; CONSTINTEGER MARKER = -1
SWITCH MACHINE MACRO(1:8); ! DEF,VAL,UPDATE,BIN,DEC,BAR,*END*,DELIMS
OWNSHORTINTEGER LAST OUT=NL; ! LAST OUTPUT CHARACTER
OWNSHORTINTEGER SP=0; ! NO. OF SPACES PENDING
OWNINTEGER S = 56,E = 50; CONSTBYTEINTEGER MSTHEAD = 50
CONSTSHORTINTEGERARRAY MST(0:55) =
-1,6,'*','E','N','D','*',-8,
0,7,'D','E','L','I','M','S',-7,
8,4,'D','E','F',-1,
17,4,'V','A','L',-2,
23,7,'U','P','D','A','T','E',-3,
29,4,'B','I','N',-4,
38,4,'D','E','C',-5,
44,4,'B','A','R',-6
OWNINTEGER H=0, P=0, F=0, C=0
OWNBYTEINTEGERARRAY SYMTYPE(-1:127)
SWITCH SW(1:7)
!
!
BEGIN ; ! SET DEFAULT WARNING CHARACTERS INTO 'SYMTYPE'
SYMTYPE(K) = 0 FOR K = -1,1,127
SYMTYPE('$') = 1; ! ...FN
SYMTYPE(',') = 2; ! ...NEXT ITEM
SYMTYPE(';') = 3; ! ...APPLY
SYMTYPE('¬') = 4; ! ...LOAD ARG
SYMTYPE(MARKER) = 5; ! ...END FN
SYMTYPE('[') = 6; ! ...PROTECT
SYMTYPE(']') = 7; ! ...EXIT
LBR = '['; ! ...DEFAULT LEFT BRACKET
RBR = ']'; ! ...DEFAULT RIGHT BRACKET
END
!
!
!
!============= MOUSES SPECIFIC=====================
PREDICATE NULL INPUT(INTEGER N)
INTEGER K; STRING (255)NAME S
K = 3+(N-1)*2
S == STRING(COMREG(K))
TRUE IF S = ".N" OR S = ""
FALSE
END
!================================================
!
SELECT OUTPUT(REPORT); PRINT SYMBOL(FF); NEWLINE
PRINT STRING(VERSION." Stack size =")
WRITE(STKLIMIT+1,1); PRINT STRING(" cells")
NEWLINES(2)
IF STKLIMIT < S+100 START ; ! ... AD HOCKERY
PRINT STRING("***** MORE STORE REQ'D *****"); NEWLINE
SIGNAL 0,2
FINISH
! INITIALISE STACK WITH NAMES OF 'MACHINE MACROS'
ST(K) = MST(K) FOR K = 0,1,S-1
INSTRM = DEFN FILE; INSTRM = SOURCE IF NULL INPUT(INSTRM)
SELECT INPUT(INSTRM); SELECT OUTPUT(OUT)
-> START
!
!
ROUTINESPEC LOAD
ROUTINE MONITOR(INTEGER N)
SWITCH M(0 : 15); INTEGER W1,R
ERROR = ERROR+1
IF DUPLICATE # 0 THEN START
NEWLINE IF LAST OUT # NL
PRINT STRING(" ** ERROR"); WRITE(ERROR,1); PRINT STRING(" **")
NEWLINE; LAST OUT = NL; SP = 0
SELECT OUTPUT(REPORT)
FINISH
PRINT STRING("
*ERROR"); WRITE(ERROR,1); PRINT SYMBOL(':')
-> M(N)
!
ROUTINE ITEM(INTEGER X)
INTEGER APR,HPR,K,J
APR = A; HPR = H
H = 0
J = ST(X)-1; J = S-X-1 IF ST(X) = 0
IF J > 0 THEN START
CYCLE K = 1,1,J
A = ST(X+K); LOAD
REPEAT
FINISH
PRINT STRING("... (INCOMPLETE)") IF ST(X) = 0
A = APR; H = HPR
END
!
M(0):
PRINT STRING("
*** STACK OVERFLOW - GPM CANNOT PROCEED ***
")
STOP
!
M(1):
PRINT STRING("UNMATCHED SEMI-COLON IN DEFINITION OF ")
ITEM(P+2)
PRINT STRING("
IF THIS HAD BEEN QUOTED THE RESULT WOULD BE
")
-> RETURN
!
M(2):
PRINT STRING("UNQUOTED TILDE IN ARGUMENT LIST OF "); ITEM(F+2)
PRINT STRING("
IF THIS HAD BEEN QUOTED THE RESULT WOULD BE")
-> RETURN
!
M(3):
PRINT STRING("IMPOSSIBLE ARGUMENT NUMBER IN DEFINITION OF ")
ITEM(P+2)
-> M11
!
M(4):
PRINT STRING("NO ARGUMENT ")
D1 = H; H = 0
LOAD
PRINT STRING(" IN CALL FOR "); ITEM(P+2)
H = D1
-> RETURN
!
M(5):
PRINT STRING("TERMINATOR IN ")
IF C = 0 THEN START
PRINT STRING("INPUT STREAM. PROBABLY MACHINE ERROR. ")
-> M11
FINISH
PRINT STRING("ARGUMENT LIST FOR "); ITEM(F+2)
PRINT STRING("
PROBABLY DUE TO A SEMI-COLON MISSING FROM THE DEFINITION OF ")
ITEM(P+2)
PRINT STRING("
IF A FINAL SEMI-COLON IS ADDED THE RESULT IS
")
-> RETURN
!
M(7):
PRINT STRING("UNDEFINED NAME "); ITEM(W)
-> M11
!
M(8):
PRINT STRING("UNMATCHED ']'. PROBABLY YOUR ERROR.")
-> M11
!
M(9):
PRINT STRING("UPDATE ARGUMENT TOO LONG FOR "); ITEM(P+9)
-> M11
!
M(10):
PRINT STRING("NON-DIGIT IN NUMBER ")
-> M11
!
M(12):
PRINT STRING("BAR - FAULTY OPERATOR SPECIFICATION")
-> M11
!
M(13):
PRINT STRING("BAR - ZERO DIVISOR SET TO ONE")
NEWLINE
-> RETURN
!
M(14):
PRINT STRING("UNMATCHED ']' -- GPM TERMINATES")
NEWLINE
-> RETURN
M(15):
PRINT STRING("'DELIMS' ARGUMENT FAULTY "); ITEM(P+9)
NEWLINE
-> RETURN
M(11):
M11:
W = 36
PRINT STRING("
CURRENT MACROS ARE:")
WHILE P # 0 OR F # 0 CYCLE
IF P > F THEN START
W1 = P+2
P = ST(P)
PRINT STRING("
ALREADY ENTERED ")
FINISH ELSE START
W1 = F+2
F = ST(F)
PRINT STRING("
NOT YET ENTERED ")
FINISH
CYCLE R = 1,1,W
ITEM(W1); EXIT IF ST(W1) = 0
W1 = W1+ST(W1); EXIT IF ST(W1) = MARKER
IF W # 1 THEN START
PRINT STRING("
ARG"); WRITE(R,0); PRINT STRING(" ")
FINISH
REPEAT
W = 1
REPEAT
PRINT STRING("
END OF MONITOR PRINTING
")
A = '?'; H = 0; LOAD
RETURN:
SIGNAL 0,2 IF ERROR = CUT OFF OR N = 15
SELECT OUTPUT(OUT) IF DUPLICATE # 0
END ; ! ... OF MONITOR ROUTINE
!-------------------------------------------------!
! THIS ROUTINE EDITS OUTPUT TO: !
! (1) REMOVE MULTIPLE NEWLINES. !
! (2) REMOVE TRAILING SPACES. !
! (3) INSERT ONE SPACE AT THE END OF EACH LINE !
! TO KEEP CAL R04 ET AL HAPPY. !
!-------------------------------------------------!
ROUTINE LOAD
IF H # 0 THEN ST(S) = A AND S = S+1 ELSE START
IF A # NL START
IF A = ' ' THEN SP = SP+1 ELSE START
SPACES(SP) AND SP=0 UNLESS SP=0
PRINT SYMBOL(A); LAST OUT = A
FINISH
ELSE
SP = 0
SPACE AND NEWLINE AND LAST OUT = NL UNLESS LAST OUT = NL
FINISH
FINISH
END
ROUTINE NEXT CH
IF C = 0 THEN READ SYMBOL(A) ELSE A = ST(C) AND C = C+1
END
ROUTINE FIND(INTEGER X)
INTEGER R
A = E; W = X; K = 0
WHILE A >= 0 CYCLE
CYCLE R = 0,1,ST(W)-1
-> L1 IF ST(W+R) # ST(A+R+1)
REPEAT
W = A+1+ST(W)
RETURN
L1: A = ST(A)
REPEAT
MONITOR(7); K = 1
END
!
!
!*** MAIN LOOP ***
! 'STRIP' IS FOR ERROR RECOVERY
!
STRIP:
-> END FN IF P > F
START:
MONITOR(0) IF S > STKLIMIT; ! STACK OVERFLOW?
NEXT CH
K = SYMTYPE(A); -> SW(K) IF K # 0
! THE ABOVE LINE REPLACES THE TEST-AND-BRANCH SEQUENCE BELOW
! PURELY FOR EFFICIENCY REASONS -- LOGICALLY THERE IS NO CHANGE.
! Q = Q+1 %AND -> Q2 %IF A = '['
! -> FN %IF A = '$'
! -> NEXT ITEM %IF A = ','
! -> APPLY %IF A = SEMI-COLON
! -> LOAD ARG %IF A = '¬'
! -> END FN %IF A = MARKER
! -> EXIT %IF A = ']'
COPY:
LOAD
! SCAN:
-> START IF Q = 1
Q2:NEXT CH
Q = Q+1 AND -> COPY IF A = LBR; ! ...LEFT BRACKET
-> COPY IF A # RBR; ! ...RIGHT BRACKET
Q = Q-1; -> START IF Q = 1
-> COPY
!
! [ ... PROTECT FROM EVALUATION
SW(6):
Q = Q+1
-> Q2
!
SW(1):
! FN:
ST(S) = H; ST(S+1) = F; F = S+1
ST(S+2) = 0; ST(S+3) = 0; H = S+3
S = S+4
-> START
!
SW(2):
! NEXT ITEM:
-> COPY IF H = 0
ST(H) = S-H-ST(H); ST(S) = 0
H = S; S = S+1
-> START
!
SW(3):
APPLY:
MONITOR(1) AND -> COPY IF P > F
-> COPY IF H = 0
D1 = ST(F); D2 = ST(F-1)
ST(H) = S-H; ST(S) = MARKER
ST(F-1) = S-F+2
ST(F) = P
ST(F+1) = C
P = F; F = D1; H = D2; S = S+1
ST(H) = ST(H)+ST(P-1) IF H # 0
FIND(P+2); -> STRIP IF K # 0
-> MACHINE MACRO(-ST(W)) IF ST(W) < 0
C = W+1
-> START
!
SW(4):
! LOAD ARG:
IF P = 0 THEN START
-> COPY IF H = 0
MONITOR(2); -> COPY
FINISH
NEXT CH
W = P+2
IF '0' <= A <= '9' THEN W1 = A-'0' ELSE START
IF 'A' <= A <= 'Z' THEN W1 = A-'A'+10 ELSE START
W1 = -1; MONITOR(3); -> STRIP
FINISH
FINISH
WHILE W1 # 0 CYCLE
W = W+ST(W)
MONITOR(4) AND -> STRIP IF ST(W) = MARKER
W1 = W1-1
REPEAT
A = ST(W+R) AND LOAD FOR R = 1,1,ST(W)-1
-> START
!
SW(5):
END FN:
IF F > P THEN START
MONITOR(5); -> STRIP IF C = 0
C = C-1; -> APPLY
FINISH
ST(S) = E; A = S
WHILE ST(A) >= P-1+ST(P-1) CYCLE
D1 = ST(A)
ST(A) = D1-ST(P-1)
A = D1
REPEAT
W = ST(A)
W = ST(W) WHILE W > P-1
ST(A) = W; E = ST(S)
IF H # 0 THEN START
IF H > P THEN H = H-ST(P-1) ELSE ST(H) = ST(H)-ST(P-1)
FINISH
A = P-1; W = P-1+ST(P-1)
S = S-ST(P-1); C = ST(P+1); P = ST(P)
WHILE A # S CYCLE
ST(A) = ST(W); A = A+1; W = W+1
REPEAT
-> START
!
SW(7):
EXIT:
MONITOR(14) AND -> STOP IF C = 0 = H; ! ...TOO MANY ']'
MONITOR(8); -> STRIP
!
!*** BUILT-IN MACRO'S FOLLOW ***
!DEF
MACHINE MACRO(1):
ST(H) = ST(H)-ST(P-1) IF H # 0
ST(P-1) = E; E = P-1
W = P; P = ST(P)
ST(W) = ST(W+6) AND W = W+1 WHILE W+6 # S
S = W
-> START
!
! VAL
MACHINE MACRO(2):
FIND(P+6); -> STRIP IF K # 0
WHILE ST(W+1) # MARKER CYCLE
A = ST(W+1); W = W+1; LOAD
REPEAT
-> END FN
!
! UPDATE
MACHINE MACRO(3):
FIND(P+9); -> STRIP IF K # 0
A = P+9+ST(P+9)
MONITOR(9) AND -> STRIP IF ST(A) > ST(W)
ST(W+R) = ST(A+R) FOR R = 1,1,ST(A)
-> END FN
!
! BIN
MACHINE MACRO(4):
W = 0; A = P+7
MONITOR(4) AND -> STRIP IF ST(P+6) = MARKER
A = P+8 UNLESS '+' # ST(P+7) # '-'
WHILE ST(A) # MARKER CYCLE
X = ST(A)-'0'
MONITOR(10) AND -> STRIP˙ UNLESS 0 <= X <= 9
W = 10*W+X; A = A+1
REPEAT
W = -W IF ST(P+7) = '-'
MONITOR(4) AND -> STRIP IF A = P+7;! MISSING PARAMETER
ST(S) = W; S = S+1
-> END FN
!
! DEC
MACHINE MACRO(5):
W = ST(P+7)
MONITOR(4) AND -> STRIP IF ST(P+6) = MARKER
IF W < 0 THEN START
W = -W; A = '-'; LOAD
FINISH
W1 = 1; W1 = 10*W1 WHILE 10*W1 <= W
CYCLE
D1 = W//W1; D2 = W-D1*W1
D1 = D1+'0'; D3 = W1//10
A = D1; W = D2; W1 = D3
LOAD
exit if w1 < 1
REPEAT
-> END FN
!
! BAR
MACHINE MACRO(6):
IF ST(P+6) = MARKER OR ST(P+8) = MARKER C
OR ST(P+10) = MARKER THEN MONITOR(4) AND -> STRIP
R = ST(P+7); W = ST(P+9); A = ST(P+11)
IF R = '+' OR R = '-' THEN START
IF R = '+' THEN A = W+A ELSE A = W-A
ELSE
IF R # '*' AND R # '/' AND R # 'R' C
THEN MONITOR(12) AND -> STRIP
IF R = '*' THEN A = W*A ELSE START
MONITOR(13) AND A = 1 IF A = 0
A = W//A IF R = '/'
A = W-A*(W//A) IF R = 'R'
FINISH
FINISH
LOAD
-> END FN
!
! DELIMS
MACHINE MACRO(7):
MONITOR(15) IF ST(P+9) # 7 OR ST(P+16) # MARKER
FOR W = P+9+1,1,P+16-1 CYCLE
FOR K = W+1,1,P+16 CYCLE ; ! ...CHECKS AGAINST 'MARKER'
MONITOR(15) IF ST(W) = ST(K) OR ST(W)<0 OR ST(W)>127
REPEAT
REPEAT
BEGIN
CONSTBYTEINTEGERARRAY M(1:6) = 1,2,3,4,6,7
SYMTYPE(K) = 0 FOR K = 0,1,127
SYMTYPE(ST(P+9+K)) = M(K) FOR K = 1,1,6
LBR = ST(P+9+5); ! ...LEFT BRACKET
RBR = ST(P+9+6); ! ...RIGHT BRACKET
END
-> END FN
!
!
STOP: ! FORCE TERMINATION
INSTRM = SOURCE
!
!*END*
MACHINE MACRO(8): ! '*END*'
IF INSTRM = DEFN FILE THEN START ; ! READING MACRO DEFN FILE?
CLOSE INPUT
INSTRM = SOURCE; SELECT INPUT(INSTRM)
-> END FN
FINISH
!
!-------------------------------------------------!
! N.B. !
! THIS FEATURE USED IN CONJUNCTION WITH !
! 'DELIMS' AS CURRENTLY IMPLEMENTED CAN !
! CAUSE ABSOLUTE CHAOS. !
!-------------------------------------------------!
ROUTINE DUMP TEXT
! ASSUMES 'W' POINTS TO LENGTH CELL
INTEGER END
R = 0; END = ST(W)-1
R = R+1 AND PRINT SYMBOL(ST(W+R)) WHILE R # END
END
IF DUMP >= 0 THEN START
SELECT OUTPUT(DUMP)
W = E; K = STK LIMIT+1
WHILE W # MSTHEAD CYCLE
K = K-1; ST(K) = W; W = ST(W)
REPEAT
WHILE K <= STK LIMIT CYCLE
W = ST(K)+1
PRINT STRING("
$DEF,"); DUMP TEXT; PRINT STRING(",[")
W = W+ST(W); ! START OF DEFN BODY
DUMP TEXT; PRINT STRING("];"); NEWLINE
K = K+1
REPEAT
PRINT STRING("
$*END*;
")
FINISH
!
!
SELECT OUTPUT(REPORT)
IF ERROR = 0 C
THEN PRINT STRING("
No monitor entries - output O.K.
") C
ELSE START
PRINT STRING("
****"); WRITE(ERROR,1)
PRINT STRING(" MONITOR ENTRIES - OUTPUT FAULTY
")
FINISH
WRITE(S,7); PRINT STRING(" out of"); WRITE(STKLIMIT+1,1)
PRINT STRING(" cells are occupied.")
NEWLINES(2)
SIGNAL 0,1 UNLESS ERROR = 0; ! ...TELL NEXT OUTERMOST LEVEL
ENDOFPROGRAM