%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+1%C
    %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