!!!!  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