EXTERNALINTEGERARRAY A(1:255)
! INITIALISATION FOR I/O ROUTINES
EXTERNALBYTEINTEGERARRAY NAMED(1:1024)=10,'R','E','A','D','S','Y','M',
  'B','O','L',10,'N','E','X','T','S','Y','M','B','O','L',10,'S','K',
  'I','P','S','Y','M','B','O','L',11,'P','R','I','N','T','S','Y','M',
  'B','O','L',5,'S','P','A','C','E',6,'S','P','A','C','E','S',7,'N',
  'E','W','L','I','N','E',8,'N','E','W','L','I','N','E','S',7,'N','E',
  'W','P','A','G','E',4,'R','E','A','D',5,'W','R','I','T','E',0(930)
EXTERNALINTEGERARRAY NAMEDLINK(0:255)=0,76,0(12),89,0(54),84,0(118),
  52,0(11),1,12,23,34,0(4),67,0(23),46,0(5),59,0(17)
EXTERNALINTEGERARRAY TAGLINK(0:255)=0,13,0(12),16,0(54),14,0(118),8,
  0(11),1,3,4,5,0(4),11,0(23),7,0(5),10,0(17)
EXTERNALINTEGERARRAY TAG(1:512)=X'40100001',X'01010002',X'41000002',
  X'40000003',X'40100004',X'01010002',X'40000005',X'40100006',
  X'01010002',X'40000007',X'40100008',X'01010002',X'40000009',
  X'4010000A',X'11010002',X'4020000B',X'01010002',X'01010003',0(494)
EXTERNALINTEGERARRAY LINK(1:512)=2,0,0,0,6,0,0,9,0,0,12,0,0,
  15,0,17,18,0,0(494)
EXTERNALINTEGER NAMEDP=95
EXTERNALINTEGER TAGASL=19
EXTERNALINTEGER EXPROPT=0
EXTERNALINTEGER CONDOPT=0
EXTERNALINTEGER TAGSOPT=0
!-----------------------------------------------------------------------
EXTERNALROUTINESPEC DEFINE(STRING(63) S)
EXTERNALROUTINESPEC STATEMENT(INTEGER STATEMENTP)
EXTERNALSTRING(255)FNSPEC STRINT(INTEGER N,P)
EXTERNALROUTINESPEC FAULT(STRING(63) MESS)
EXTERNALROUTINESPEC DUMP(STRING(7) OPN,REG,BASE,INTEGER DISP)
EXTERNALSTRING(255)FNSPEC NAME(INTEGER IDENT)
!-----------------------------------------------------------------------
EXTERNALROUTINE SKIMP(STRING(63) S)
ROUTINESPEC READPS
ROUTINESPEC READ STATEMENT
ROUTINESPEC RPSYM(INTEGERNAME L)
INTEGERFNSPEC FINDK(STRINGNAME K)
INTEGERFNSPEC COMPARE(INTEGER P)
RECORDFORMAT KDF(BYTEINTEGER L,N,A,B)
RECORDARRAY KD(1:255)(KDF)
STRING(15)ARRAY PN(256:319)
INTEGERARRAY PP(256:319)
INTEGERARRAY PS(1:512)
INTEGERARRAY T,TT(1:256)
INTEGER TP,AP,TTP,TTPP,I,PSFLAG
STRING(63) SOURCE,OBJECT,OPTIONS,OPTION
OWNINTEGER LEXOPT=0
OWNINTEGER ANALOPT=0
  UNLESS S->SOURCE.(",").OBJECT THEN FAULT("PARAMETERS ?") AND STOP
  IF OBJECT->OBJECT.(",").OPTIONS THEN START
    UNTIL OPTIONS="" CYCLE
      UNLESS OPTIONS->OPTION.(",").OPTIONS THEN OPTION=OPTIONS C
        AND OPTIONS=""
      IF OPTION->("NO").OPTION THEN I=0 ELSE I=1
      IF OPTION="LEX" THEN LEXOPT=I
      IF OPTION="ANAL" THEN ANALOPT=I
      IF OPTION="EXPR" THEN EXPROPT=I
      IF OPTION="COND" THEN CONDOPT=I
      IF OPTION="TAGS" THEN TAGSOPT=I
    REPEAT
  FINISH
  READPS
  DEFINE("STREAM02,".OBJECT)
  SELECT OUTPUT(2)
  SET MARGINS(2,1,72)
  PRINT STRING("

                   SKIMP COMPILER MKII

SOURCE: ".SOURCE."
OBJECT: ".OBJECT."
OPTIONS: ")
  IF LEXOPT=1 THEN PRINT STRING("LEX ")
  IF ANALOPT=1 THEN PRINT STRING("ANAL ")
  IF EXPROPT=1 THEN PRINT STRING("EXPR ")
  IF CONDOPT=1 THEN PRINT STRING("COND ")
  IF TAGSOPT=1 THEN PRINT STRING("TAGS ")
  NEWLINE
  IF PSFLAG#0 THEN FAULT("PHRASE STRUCTURE FAULTY") AND STOP
  DEFINE("STREAM01,".SOURCE)
  SELECT INPUT(1)
  ! SET UP TAGS AVAILABLE SPACE LIST
  CYCLE I=TAGASL,1,511
    LINK(I)=I+1
  REPEAT
  CYCLE    ; ! FOR EACH STATEMENT
    READ STATEMENT
    TTP=TP-1
    TP=1
    AP=1
    IF COMPARE(258)=0 OR TP#TTP THEN FAULT("SYNTAX ?") ELSE START
      IF ANALOPT=1 THEN START
        NEWLINE
        CYCLE I=1,1,AP-1    ; ! PRINT ANALYSIS RECORD
          IF A(I)<0 THEN PRINT STRING("  (".STRINT(I,1)."/". C
            PN(A(I)<<1>>17).")") AND A(I)=A(I)&X'FFFF'
          PRINT STRING("  ".STRINT(A(I),1))
        REPEAT
        NEWLINES(2)
      FINISH ELSE START
        CYCLE I=1,1,AP-1    ; ! REMOVE PHRASE NUMBERS
          IF A(I)<0 THEN A(I)=A(I)&X'FFFF'
        REPEAT
      FINISH
      STATEMENT(1)    ;! GENERATE CODE FOR STATEMENT
    FINISH
  REPEAT
!-----------------------------------------------------------------------
ROUTINE READPS
! READ PHRASE STRUCTURE FROM FILE 'SKIMPPS' AND REDUCE IT
STRING(31)ARRAY KA(1:128)
INTEGERARRAY KNA(1:128)
STRING(31) K
INTEGER KAP,KDASL,KN,I,L,PSP,PNP,ALT
INTEGERNAME NP
ROUTINESPEC INSERT(STRING(15) K)
ROUTINESPEC EXTRACT(INTEGER I,STRING(15) K)
ROUTINESPEC ASSIGN(INTEGER I)
INTEGERFNSPEC NEWKD
ROUTINESPEC RETURNKD(INTEGER I)
ROUTINESPEC RETURNLIST(INTEGER I)
INTEGERFNSPEC PHRASE
ROUTINESPEC LITERAL
ROUTINESPEC KEYWORD
  DEFINE("STREAM03,SKIMPPS")
  SELECT INPUT(3)
  DEFINE("STREAM04,SKIMPPSL")
  SELECT OUTPUT(4)
  PRINT STRING("

PHRASE STRUCTURE

")
  ! SCAN FILE TO BUILD KEYWORD DICTIONARY
  KAP=1
  CYCLE
    RPSYM(L)
    IF L='$' THEN EXIT
    IF L='"' THEN START
      K=""
      CYCLE
        RPSYM(L)
        IF L='"' THEN EXIT
        IF 'A'<=L<='Z' THEN K=K.TOSTRING(L)
      REPEAT
      KA(KAP)=K
      KAP=KAP+1
    FINISH
  REPEAT
  CYCLE I=1,1,26
    KD(I)=0
  REPEAT
  CYCLE I=27,1,254
    KD(I)_B=I+1
  REPEAT
  KDASL=27
  I=1
  UNTIL I=KAP THEN INSERT(KA(I)) AND I=I+1
  KN=128
  CYCLE I=1,1,26
    IF KD(I)_L#0 THEN ASSIGN(I)
  REPEAT
  KAP=1
  CYCLE I=1,1,26
    IF KD(I)_L#0 THEN EXTRACT(I,"")
  REPEAT
  PRINT STRING("

KEYWORDS

")
  CYCLE I=1,1,KAP-1
    PRINT STRING(STRINT(KNA(I),3)."  ".KA(I)."
")
  REPEAT
  ! REREAD FILE AND REDUCE PHRASE STRUCTURE
  SELECT INPUT(0)
  CLOSE STREAM(3)
  SELECT INPUT(3)
  PN(256)="NAME"
  PP(256)=0
  PN(257)="CONST"
  PP(257)=0
  PNP=258
  PSP=1
  CYCLE    ; ! FOR EACH PHRASE DEFINITION
    READ SYMBOL(L)
    IF L='$' THEN EXIT
    IF L='<' THEN START    ;   ! START OF PHRASE DEFINITION
      PP(PHRASE)=PSP
      CYCLE    ; ! FOR EACH ALTERNATIVE
        ALT=PSP
        NP==PS(PSP+1)
        NP=0    ;! NUMBER OF PHRASES
        PSP=PSP+2
        CYCLE    ; ! FOR EACH ITEM
          READ SYMBOL(L)
          IF L='<' THEN PS(PSP)=PHRASE AND PSP=PSP+1 AND NP=NP+1
          IF L='''' THEN LITERAL
          IF L='"' THEN KEYWORD
          IF L=',' OR L=';' THEN EXIT
        REPEAT
        PS(ALT)=PSP
        IF L=';' THEN EXIT
      REPEAT
      PS(PSP)=0
      PSP=PSP+1
    FINISH
  REPEAT
  PSFLAG=0
  CYCLE I=258,1,PNP-1
    IF PP(I)=0 THEN FAULT("<".PN(I)."> NOT DEFINED") AND PSFLAG=1
  REPEAT
  PRINT STRING("

PHRASES

")
  CYCLE I=256,1,PNP-1
    PRINT STRING(STRINT(I,3).STRINT(PP(I),6)."   ".PN(I)."
")
  REPEAT
  PRINT STRING("

REDUCED PHRASE STRUCTURE

")
  CYCLE I=1,1,PSP-1
    IF (I-1)&15=0 THEN PRINT STRING("
".STRINT(I,3)."   ")
   WRITE(PS(I),3)
  REPEAT
  NEWLINES(2)
  RETURN
!-----------------------------------------------------------------------
ROUTINE INSERT(STRING(15) K)
! SEARCH FOR AND INSERT KEYWORD INTO DICTIONARY
INTEGER I,J,L
  L=CHARNO(K,1)
  K->(TOSTRING(L)).K
  I=L-'A'+1
  IF KD(I)_L#0 THEN START
SEARCH:IF K="" THEN START
      IF KD(I)_A#0 THEN EXTRACT(KD(I)_A,"") AND C
        RETURNLIST(KD(I)_A) AND KD(I)_A=0
      RETURN
    FINISH
    IF KD(I)_A=0 THEN INSERT(K) AND RETURN
    L=CHARNO(K,1)
    K->(TOSTRING(L)).K
    I=KD(I)_A
    CYCLE
      IF KD(I)_L=L THEN ->SEARCH
      IF KD(I)_B=0 THEN EXIT
      I=KD(I)_B
    REPEAT
    J=I
    I=NEWKD
    KD(J)_B=I
  FINISH
  ! INSERT REMAINDER OF LETTERS
  CYCLE
    KD(I)_L=L
    IF K="" THEN RETURN
    L=CHARNO(K,1)
    K->(TOSTRING(L)).K
    J=I
    I=NEWKD
    KD(J)_A=I
  REPEAT
END
!-----------------------------------------------------------------------
ROUTINE EXTRACT(INTEGER I,STRING(15) K)
STRING(15) KK
  IF I=0 THEN RETURN
  KK=K.TOSTRING(KD(I)_L)
  IF KD(I)_A=0 THEN KA(KAP)=KK AND KNA(KAP)=KD(I)_N AND KAP=KAP+1C
    ELSE EXTRACT(KD(I)_A,KK)
  EXTRACT(KD(I)_B,K)
END
!-----------------------------------------------------------------------
ROUTINE ASSIGN(INTEGER I)
  IF I=0 THEN RETURN
  IF KD(I)_A=0 THEN KD(I)_N=KN AND KN=KN+1 ELSE ASSIGN(KD(I)_A)
  ASSIGN(KD(I)_B)
END
!-----------------------------------------------------------------------
INTEGERFN NEWKD
INTEGER I
  IF KDASL=0 THEN PRINT STRING("KD ASL EMPTY") AND STOP
  I=KDASL
  KDASL=KD(I)_B
  KD(I)=0
  RESULT=I
END
!-----------------------------------------------------------------------
ROUTINE RETURNKD(INTEGER I)
  KD(I)_B=KDASL
  KDASL=I
END
!-----------------------------------------------------------------------
ROUTINE RETURNLIST(INTEGER I)
  IF I=0 THEN RETURN
  RETURNLIST(KD(I)_A)
  RETURNLIST(KD(I)_B)
  RETURNKD(I)
END
!-----------------------------------------------------------------------
INTEGERFN PHRASE
STRING(15) P
INTEGER I,L
  P=""
  CYCLE
    READ SYMBOL(L)
    IF L='>' THEN EXIT ELSE P=P.TOSTRING(L)
  REPEAT
  CYCLE I=256,1,PNP-1
    IF PN(I)=P THEN RESULT=I
  REPEAT
  PN(PNP)=P
  PP(PNP)=0
  PNP=PNP+1
  RESULT=PNP-1
END
!-----------------------------------------------------------------------
ROUTINE LITERAL
INTEGER L
  CYCLE
    READ SYMBOL(L)
    IF L='''' THEN RETURN ELSE PS(PSP)=L AND PSP=PSP+1
  REPEAT
END
!-----------------------------------------------------------------------
ROUTINE KEYWORD
STRING(31) K
INTEGER L
  K=""
  CYCLE
    READ SYMBOL(L)
    IF L='"' THEN EXIT
    IF 'A'<=L<='Z' THEN K=K.TOSTRING(L)
  REPEAT
  PS(PSP)=FINDK(K) AND PSP=PSP+1 UNTIL K=""
END
END
!-----------------------------------------------------------------------
ROUTINE READ STATEMENT
ROUTINESPEC STORE(INTEGER L)
ROUTINESPEC KEYWORD
ROUTINESPEC NAME
ROUTINESPEC CONST
INTEGER I,L,KSH
  ! LINE RECONSTRUCT PHASE
  NEWLINES(3)
  TTP=1
  KSH=0
  CYCLE    ; ! FOR EACH CHARACTER
    RPSYM(L)
    IF L='%' THEN KSH=128 ELSE START
      UNLESS 'A'<=L<='Z' THEN KSH=0
      IF L#' ' THEN START    ;   ! DISCARD SPACES
        IF L='!' AND TTP=1 THEN START
          RPSYM(L) UNTIL L=';' OR L=NL    ;  ! DISCARD COMMENTS
        FINISH ELSE START
          STORE(L)
          IF L='''' THEN START
            UNTIL L='''' CYCLE
              RPSYM(L)
              STORE(L)
            REPEAT
          FINISH ELSE START
            IF L=';' OR L=NL THEN START
              IF TTP=2 THEN TTP=1 ELSE START
                IF L=';' THEN NEWLINE AND EXIT
                IF TT(TTP-2)='C'+128 THEN TTP=TTP-2 ELSE EXIT
              FINISH
            FINISH
          FINISH
        FINISH
      FINISH
    FINISH
  REPEAT
  ! LEXICAL PHASE
  TP=1
  TTPP=1
  UNTIL TTPP=TTP CYCLE    ;  ! FOR EACH LEXICAL ITEM
    I=TT(TTPP)
    IF I>=128 THEN KEYWORD ELSE START
      IF 'A'<=I<='Z' THEN NAME ELSE START
        IF '0'<=I<='9' OR I='''' THEN CONST ELSE C
          T(TP)=I AND TP=TP+1 AND TTPP=TTPP+1
      FINISH
    FINISH
  REPEAT
  IF LEXOPT=1 THEN START
    NEWLINE
    CYCLE TTPP=1,1,TP-2
      PRINT STRING("   ".STRINT(T(TTPP),1))
    REPEAT
    NEWLINE
  FINISH
  RETURN
!-----------------------------------------------------------------------
ROUTINE STORE(INTEGER L)
  IF TTP>256 THEN FAULT("STATEMENT TOO LONG") AND STOP
  TT(TTP)=L+KSH
  TTP=TTP+1
END
!-----------------------------------------------------------------------
ROUTINE KEYWORD
STRING(255) K
INTEGER I
  K=""
  WHILE TT(TTPP)>128 THEN K=K.TOSTRING(TT(TTPP)-128) AND TTPP=TTPP+1
  UNTIL K="" OR I=0 THEN I=FINDK(K) AND T(TP)=I AND TP=TP+1
END
!-----------------------------------------------------------------------
ROUTINE NAME
STRINGNAME SNAME
INTEGER I,L,HASH
  SNAME==STRING(ADDR(NAMED(NAMEDP)))
  HASH=0
  SNAME=""
  L=TT(TTPP)
  UNTIL L<'0' OR '9'<L<'A' OR L>'Z' THEN CYCLE
    IF NAMEDP+LENGTH(SNAME)>=1022 THEN FAULT("NAME DICTIONARY FULL")C
      AND STOP
    IF LENGTH(SNAME)=255 THEN FAULT("NAME TOO LONG") AND STOP
    SNAME=SNAME.TOSTRING(L)
    HASH=HASH<<8!L
    TTPP=TTPP+1
    L=TT(TTPP)
  REPEAT
  HASH=HASH-HASH//251*251
  I=HASH
  CYCLE    ; ! SCAN DICTIONARY
    IF NAMEDLINK(I)=0 THEN NAMEDLINK(I)=NAMEDP AND C
       NAMEDP=NAMEDP+LENGTH(SNAME)+1 AND EXIT    ;  ! INSERT NAME
    IF SNAME=STRING(ADDR(NAMED(NAMEDLINK(I)))) THEN EXIT
    I=(I+1)&255
    IF I=HASH THEN FAULT("NAME DICTIONARY FULL") AND STOP
  REPEAT
  T(TP)=256    ;! <NAME>
  T(TP+1)=I    ;! IDENT
  TP=TP+2
END
!-----------------------------------------------------------------------
ROUTINE CONST
INTEGER L,VALUE,FLAG,COUNT,MAXBY10,MAXLD
  VALUE=0
  FLAG=0
  IF TT(TTPP)='''' THEN START
    COUNT=0
    CYCLE
      TTPP=TTPP+1
      IF TT(TTPP)='''' THEN START
        TTPP=TTPP+1
        IF TT(TTPP)#'''' THEN EXIT
      FINISH
      VALUE=VALUE<<8!TT(TTPP)
      COUNT=COUNT+1
    REPEAT
    UNLESS 1<=COUNT<=4 THEN FLAG=1
  FINISH ELSE START
    MAXBY10=X'7FFFFFFF'//10
    MAXLD=X'7FFFFFFF'-MAXBY10*10
    L=TT(TTPP)
    UNTIL L<'0' OR L>'9' CYCLE
      IF VALUE>MAXBY10 OR (VALUE=MAXBY10 AND L>MAXLD) THEN FLAG=1 C
        ELSE VALUE=VALUE*10+L-'0'
      TTPP=TTPP+1
      L=TT(TTPP)
    REPEAT
  FINISH
  T(TP)=257    ;! <CONST>
  IF FLAG#0 THEN FAULT("CONSTANT INVALID") AND VALUE=0
  T(TP+1)=VALUE
  TP=TP+2
END
END
!-----------------------------------------------------------------------
ROUTINE RPSYM(INTEGERNAME L)
  READ SYMBOL(L)
  PRINT SYMBOL(L)
END
!-----------------------------------------------------------------------
INTEGERFN FINDK(STRINGNAME K)
! LOOK KEYWORD UP IN DICTIONARY
INTEGER I,L
  L=CHARNO(K,1)
  K->(TOSTRING(L)).K
  I=L-'A'+1
  IF KD(I)_L=0 THEN RESULT=0
SEARCH:IF K="" OR KD(I)_A=0 THEN RESULT=KD(I)_N
  L=CHARNO(K,1)
  K->(TOSTRING(L)).K
  I=KD(I)_A
  CYCLE
    IF KD(I)_L=L THEN ->SEARCH
    IF KD(I)_B=0 THEN RESULT=0
    I=KD(I)_B
  REPEAT
END
!-----------------------------------------------------------------------
INTEGERFN COMPARE(INTEGER P)
INTEGER APP,TPP,ALT,ALTEND,PSP,PSI
  A(AP)=P<<16!X'80000001'       ;! PHRASE NUMBER & ALTERNATIVE 1
  IF P<=257 THEN START       ;   ! <NAME> OR <CONST>
    IF P=T(TP) THEN START    ;   ! SUCCESS
      A(AP+1)=T(TP+1)
      AP=AP+2
      TP=TP+2
      RESULT=1
    FINISH ELSE RESULT=0
  FINISH
  TPP=TP       ;! PRESERVE TEXT POINTER
  APP=AP       ;! PRESERVE ANALYSIS RECORD POINTER
  PSP=PP(P)    ;! START OF PHRASE DEFINITION
  CYCLE       ; ! FOR EACH ALTERNATIVE
    ALT=AP+1
    ALTEND=PS(PSP)
    AP=ALT+PS(PSP+1)    ;! LEAVE GAP FOR FORWARD POINTERS
    IF AP>255 THEN FAULT("ANALYSIS RECORD TOO LONG") AND STOP
    PSP=PSP+2
    CYCLE    ; ! FOR EACH ITEM
      IF PSP=ALTEND THEN RESULT=1    ;   ! SUCCESS
      PSI=PS(PSP)
      IF PSI>=256 THEN START         ;   ! PHRASE
        A(ALT)=AP                       ;! FORWARD POINTER
        IF COMPARE(PSI)=0 THEN EXIT
        ALT=ALT+1
      FINISH ELSE START              ;   ! LITERAL OR KEYWORD
        IF PSI#T(TP) THEN EXIT
        TP=TP+1
      FINISH
      PSP=PSP+1
    REPEAT
    IF PS(ALTEND)=0 THEN RESULT=0    ;   ! FAILURE
    PSP=ALTEND
    TP=TPP           ;! BACKTRACK TEXT POINTER
    AP=APP           ;! BACKTRACK ANALYSIS RECORD POINTER
    A(AP)=A(AP)+1    ;! NEXT ALTERNATIVE NUMBER
  REPEAT
END
END
ENDOFFILE