%EXTERNALROUTINE SPLIT (%STRING(63) CMD)
!
!
!***************************************************
!*  SIMPLE PRECEDENCE LANGUAGE INTERACTIVE TESTER  *
!*                 S  P  L  I  T                   *
!*                                                 *
!*           NIGEL A CONLIFFE  JUNE 1974           *
!*                          OCTOBER 1975           *
!***************************************************
!
!
!
%CONSTSTRING (40) TITLE='S P L I T : V1 R4'
!
%RECORDFORMAT F1 (%STRING(20) NAME,%BYTEINTEGER TYPE)
%RECORDARRAY SYMTAB (-100:-1) (F1)  ;! SYMBOL TABLE
                                    ;! TYPE=0 FOR NON TERMINAL
                                    ;! TYPE=1 FOR TERMINAL
                                    ;! TYPE=2 FOR DISTINGUISHED SYMBOL
%INTEGERARRAY PS(1:1000)            ;! PHRASE STRUCTURE
%OWNBYTEINTEGERARRAY TMARKER (0:2)= ' ','''','!'
%OWNSTRING(3)%ARRAY RELSYM(0:7)='   ',' = ',' < ',' <=',' > ',' >=',
                                 ' ><','>=<'
%OWNINTEGERARRAY INDEX (-100:-1)=0(100)
%OWNINTEGERARRAY NEXT CELL(1:1000)=0(1000)
%INTEGERARRAY PHRASE   (1:1000)
%OWNBYTEINTEGERARRAY DEFINED (-100:-1)=0(100)
!
%OWNINTEGER F MATRIX=1, F FUNCTION =1,F PARSING=1,F PS=1
%STRING(63) INPUT,OUTPUT,PARMS,CURPARM
!** FLAGS FOR OPTION SETTINGS
%INTEGER NEGATE
!
%EXTERNALROUTINESPEC PROMPT (%STRING(19) S)
%EXTERNALROUTINESPEC DEFINE (%STRING(63) S)
%EXTERNALROUTINESPEC CLEAR  (%STRING(63) S)
%ROUTINESPEC SKIP LINE
%ROUTINESPEC READ SYM (%INTEGERNAME I)
%ROUTINESPEC SEARCH
%INTEGERFNSPEC GET VAL (%INTEGER A)
%ROUTINESPEC FAULT (%INTEGER I)
%ROUTINESPEC PUT (%INTEGER A,B)
%ROUTINESPEC WARSHALLS (%INTEGERARRAYNAME A,%INTEGER B,C)
%ROUTINESPEC FILL MATRICES (%INTEGERARRAYNAME A,B,C)
%ROUTINESPEC B MULT MATRIX (%INTEGERARRAYNAME A,B,C)
%ROUTINESPEC TRANSPOSE (%INTEGERARRAYNAME A,B,%INTEGER C)
%ROUTINESPEC GET PREC (%INTEGERARRAYNAME PREC)
!
%INTEGER SIZE,PSP,SYMBOL,FLAG,LIM
!
%OWNINTEGER LINE SIZE = 18         ;! NUMBER PREC MATRIX FNS / LINE
!
!  CHECK FOR VALID  PARAMETER
OUTPUT=''
INPUT=CMD %UNLESS CMD -> INPUT.('/').OUTPUT
PARMS='' %UNLESS OUTPUT -> OUTPUT.('/').PARMS
%IF INPUT='' %THEN INPUT='.TT'
%IF OUTPUT='' %THEN OUTPUT='.TT'
!
! SET PARAMETERS FROM PARAMETER FIELD
!
%WHILE PARMS#'' %CYCLE
   CURPARM=PARMS %AND PARMS='' %UNLESS PARMS-> %C
      CURPARM.(',').PARMS
   %IF CURPARM -> ('NO').CURPARM %THEN NEGATE=0 %ELSE NEGATE=1
   %IF CURPARM='MATRIX' %THEN FMATRIX=NEGATE
   %IF CURPARM='FUNCTION' %THEN FFUNCTION=NEGATE
   %IF CURPARM='PARSING' %THEN FPARSING=NEGATE
   %IF CURPARM='PS' %THEN F PS=NEGATE
%REPEAT
!
CLEAR('ST10,ST11')
DEFINE('ST10,'.INPUT)
DEFINE('ST11,'.OUTPUT)
SELECT OUTPUT(11)
!
SELECT INPUT (10)
PRINTSTRING('
'.TITLE.'


')
!
SIZE=-100 ; PSP=0 ; FLAG=0
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! READ IN PHRASE STRUCTURE TO ARRAYS/TABLES :-
! <PS> = LINEARIZATION OF PHRASE STRUCTURE
! <SYMTABL_NAME> = PHRASE NAME (TREATED AS UNIQUE SYMBOL)
! <SYMBOL_TYPE> = PHRASE TYPE 
!
!
NEXT SYM:
%IF PSP>1 %AND PS(PSP)>=0 %AND PS(PSP-1)>=0 %THEN %C
       FAULT(3)
  READSYM(SYMBOL)
  %IF SYMBOL='P' %THENSTART          ;! NEW PHRASE DEFINITION
    READSYM(SYMBOL) %UNTIL SYMBOL='<' ;! FIND START OF NAME
    PS(PSP)= -GET VAL('>')
   DEFINED(-PS(PSP))=1
    -> NEXT SYM ; %FINISH
  %IF SYMBOL='<' %THENSTART          ;! PHRASE NAME AS PART OF DEF
    PS(PSP)=GET VAL('>')
   PUT(PS(PSP),PSP) %IF  PS(PSP-1)>=0;! PHRASE STARTS ALT SO ENTER ON LIST
    -> NEXT SYM ; %FINISH
  %IF SYMBOL='''' %THENSTART         ;! LITERAL TEXT(TREAT AS SYMBOL)
    PS(PSP)=GET VAL ('''')
   PUT(PS(PSP),PSP) %IF  PS(PSP-1)>=0;!TERMINAL STARTS ALT SO ENTER ON LIST
   DEFINED(PS(PSP))=1
    -> NEXT SYM ; %FINISH
  %IF SYMBOL=',' %THENSTART  ;! END OF PHRASE ALTERNATIVE
    PSP=PSP+1
   PS(PSP)=0
   -> NEXT SYM ; %FINISH
%IF SYMBOL='E' %THENSTART      ;! END OF PS MARKER
   NEWLINE
   %IF PSP=0 %THEN PRINTSTRING ('? PHRASE STRUCTURE ?
') %AND %STOP
   PSP=PSP+1 ; PS(PSP)=0
   PSP=PSP+1 ; PS(PSP)=-2000  ;!***END OF PS MARKER
   SEARCH                     ;! FIND ANY DUPLICATE RHS
SIZE=SIZE-1
-> CONSTRUCT
  %FINISH
   %IF SYMBOL#NL %AND SYMBOL#' ' %AND SYMBOL #';' %AND SYMBOL#'=' %THENC 
   FAULT(7) %AND PRINTSTRING('
SYMBOL IS '.TOSTRING(SYMBOL)) %AND SKIP LINE
  -> NEXT SYM
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
CONSTRUCT:
%CYCLE LIM=-100,1,SIZE        ;!CHECK ALL PHRASES DEFINED
   %IF DEFINED(LIM)=0 %THEN PRINTSTRING('
P<'.SYMTAB(LIM)_NAME.'> NOT DEFINED
') %AND FLAG=1
%REPEAT
%STOP %IF FLAG=1
%BEGIN
   %ROUTINESPEC EVAL PREC FNS
   %ROUTINESPEC PARSE
   %ROUTINESPEC PRINT PREC MATRIX (%INTEGER L1,L2)
   %INTEGERARRAY F,G(-100:SIZE)  ;! PRECEDENCE FUNCTIONS
   %INTEGERARRAY PRECEDENCE (-100:SIZE,-100:SIZE)
   %INTEGER I,J
!
!
   GET PREC (PRECEDENCE)         ;!CALCULATE PRECEDENCE MATRIX
!
%IF FMATRIX=0 %THEN -> NOMATRIX   ;! OPTION NOMATRIX SELECTED
!
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
   PRINTSTRING('

PRECEDENCE MATRIX IS :

')                              ;! AND PRINT IT
%IF 100+SIZE <=LINE SIZE %THEN PRINT PREC MATRIX(-100,SIZE)%C
               %ELSE %START
   LIM=-100
NEXT PAGE:
   %IF SIZE <=LIM+LINESIZE %THEN PRINT PREC MATRIX(LIM,SIZE) %C
               %ELSESTART
      PRINT PREC MATRIX(LIM,LIM+LINESIZE)
      LIM=LIM+LINESIZE+1
      NEWLINES(4)
      -> NEXT PAGE
   %FINISH
%FINISH
!
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
!
!
NOMATRIX:
%STOP %IF FLAG=1                ;! ERROR IN PRECEDENCE MATRIX DETECTED
%IF FFUNCTION=0 %THEN -> NOFUNCTION  ;! OPTION NOFUNCTION SELECTED
!
!
EVAL PREC FNS
!
!
!
NOFUNCTION:
%IF FPARSING=0 %THEN %STOP ;! OPTION NOPARSING SELECTED
PROMPT ('LINE:'.TOSTRING(07))
SELECT INPUT (0)               ;! USER CONSOLE
!
   PARSE
!
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !! ! ! ! ! !!! ! !

%ROUTINE EVAL PREC FNS
!
!
%INTEGERARRAY MATRIX (1:2*(101+SIZE),1:2*(101+SIZE))
%INTEGER I,J
! PRODUCE PRECEDENCE FUNCTION EVALUATION MATRIX, NAMELY
!
!    (  0  GE  )
!    (         )
!    ( LET  0  )
!
! WHERE GE = GREATER THAN OR EQUAL MATRIX
!      LET = LESS THAN OR EQUAL MATRIX TRANSPOSED
!
!
!
%CYCLE I=-100,1,SIZE
   %CYCLE J=-100,1,SIZE
      MATRIX(I+101,J+101)=0
      MATRIX(I+101,J+202+SIZE)=0
      MATRIX(I+101,J+202+SIZE)=1 %IF PRECEDENCE(I,J)=4 %ORC
       PRECEDENCE(I,J)=1
      MATRIX(I+202+SIZE,J+202+SIZE)=0
      MATRIX(I+202+SIZE,J+101)=0
      MATRIX(I+202+SIZE,J+101)=1 %IF PRECEDENCE(J,I)=1 %ORC
      PRECEDENCE(J,I)=2
      MATRIX(I+101,I+101)=1
      MATRIX(I+202+SIZE,I+202+SIZE)=1
   %REPEAT
%REPEAT
WARSHALLS(MATRIX,1,2*(101+SIZE))  ;! CALCULATE TRANSITIVE CLOSURE
!
! EVALUATE PRECEDENCE FUNCTIONS IN <F> & <G>
! F(I) = SUM OF ALL '1' ON ROW I FOR I = 1,1,SIZE
! G(I) = SUM OF ALL '1' ON ROW I FOR I=SIZE+1,1,2*SIZE
!
!  WHERE SIZE IS DIMENSION OF PRECEDENCE FUNCTION ARRAY
!  <<SEE D.GRIES: COMPILER CONSTRUCTION FOR DIGITAL COMPUTERS>>
!
!
%CYCLE I=-100,1,SIZE
   F(I)=0 ; G(I)=0  ;!** CLEAR FUNCTION ARRAYS
   %CYCLE J=1,1,2*(SIZE+101)
      F(I)=F(I)+MATRIX(I+101,J)
      G(I)=G(I)+MATRIX(I+202+SIZE,J)
   %REPEAT
%REPEAT
!** CHECK FOR FUNCTION CONSISTENCY WITH PRECEDENCE MATRIX
!
%CYCLE I=-100,1,SIZE
   %CYCLE J=-100,1,SIZE
      %IF (PRECEDENCE(I,J)=1 %AND F(I)#G(J) ) %C
      %OR (PRECEDENCE(I,J)=2 %AND F(I)>=G(J)) %C
      %OR (PRECEDENCE(I,J)=4 %AND F(I)<=G(J)) %C
      %THEN PRINTSTRING('
*PRECEDENCE FUNCTIONS INCONSISTENT
') %AND -> PT
   %REPEAT
%REPEAT
                             ;! LIST PRECEDENCE FUNCTIONS ON OUTPUT
PT:
PRINTSTRING('

PRECEDENCE FUNCTIONS ARE :
    F    G
')
%CYCLE I=-100,1,SIZE
   WRITE(F(I),4) ; WRITE(G(I),4)  ; SPACE
   PRINTCH(TMARKER(SYMTAB(I)_TYPE))
   PRINTSTRING(SYMTAB(I)_NAME)
   PRINTCH(TMARKER(SYMTAB(I)_TYPE))
   NEWLINE
%REPEAT
%END
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!   PARSING ROUTINES
!
%ROUTINE PARSE
%INTEGERARRAY LINE (0:100)
%INTEGER PTR,LPTR,CELL
!
%ROUTINESPEC LEXICAL INPUT
%INTEGERFNSPEC VALUE (%INTEGER A)
%ROUTINESPEC REDUCE(%INTEGERNAME PTR)
SELECT OUTPUT(0)
NEW PHRASE:
LINE(0)=0
FLAG=0                              ;! CLEAR ERROR FLAG
LEXICAL INPUT                         ;!  READ LINE
!
PTR=0                             ;! RESET POINTER
LPTR=0
-> NEW PHRASE %IF FLAG#0
!
!
CONTINUE:
   -> LOOP %IF VALUE(PTR)=4
   PTR=PTR+1 ; LPTR=LPTR+1          ;! READ A SYMBOL
   LINE(PTR)=LINE(LPTR)
   -> CONTINUE
LOOP:
   REDUCE (PTR) ; -> NEW PHRASE %IF FLAG=1  ;! ERROR IN LINE DETECTED
   %IF LINE(LPTR)=0 %AND PTR=2 %THENSTART
      ! END OF LINE REACHED: PHRASE HAS REDUCED TO A SINGLE SYMBOL
      ! CHECK THAT THIS IS THE DISTINGUISHED SYMBOL OF THE GRAMMAR
      !
      REDUCE(PTR) %WHILE PTR=2 %AND SYMTAB(LINE(1))_TYPE#2 %AND FLAG=0
      FAULT(6) %IF SYMTAB(LINE(1))_TYPE # 2  ;! NOT DISTINGUISHED PHRASE
      -> NEW PHRASE %IF FLAG=1      ;! CHECK FOR ERROR IN PARSING
      !
      ! AT THIS POINT, 'LINE' HAS REDUCED TO DISTINGUISHED PHRASE
      !
      PRINTSTRING('P<'.SYMTAB(LINE(1))_NAME.'>
LINE REDUCES TO DISTINGUISHED PHRASE

')
      -> NEW PHRASE
   %FINISH
   -> CONTINUE
!
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
!
%ROUTINE LEXICAL INPUT
!
! THIS ROUTINE READS IN A SENTENCE FROM THE TELETYPE,
! REMOVES SPACES AND FILLS POINTERS IN ARRAY <LINE>
! TO THE PHRASE STRUCTURE ARRAY <PS>.
!
! ALSO , A CHECK FOR RUN TERMINATION IS PERFORMED
!
%BYTEINTEGERARRAY TEXT(1:72)         ;! LINE FROM .TT
!
%BYTEINTEGER SYM ; %INTEGER START,FINISH,I,BEST FIT,TPTR
%STRING(72)  S
!
LPTR=0
TPTR=0
NEXT SYM:
   READSYMBOL(SYM)
   %STOP %IF SYM=NL %AND TPTR=0      ;! END OF RUN = NULL LINE
   -> END OF LINE %IF SYM=NL         ;! LINE TERMINATED BY NL
   -> NEXT SYM %IF SYM=' '           ;! REMOVE SPACES
   TPTR=TPTR+1
   TEXT(TPTR)=SYM                    ;! AND FILL BUFFER WITH SYMBOL
   -> NEXT SYM
!
END OF LINE :
   START=1
NEXT PASS:
   BEST FIT=0                        ;! POINTER TO PS GIVING BEST
                                     ;! FITTING LITERAL IN <PS>
!
   %CYCLE I=-100,1,SIZE
      %IF SYMTAB(I)_TYPE#1 %OR LENGTH(SYMTAB(I)_NAME)>TPTR-START+1 %C
                            %THEN -> NEXT LITERAL
      S=''
      %CYCLE FINISH=1,1,LENGTH(SYMTAB(I)_NAME)
         S=S.TOSTRING(TEXT(FINISH+START-1))
      %REPEAT
      %IF S=SYMTAB(I)_NAME %THENSTART
         %IF BESTFIT=0 %OR LENGTH(SYMTAB(BESTFIT)_NAME) %C
                       <LENGTH(S) %THEN BEST FIT = I
      %FINISH
NEXT LITERAL:
   %REPEAT
   FAULT(4) %AND %RETURN %IF BEST FIT=0
   LPTR=LPTR+1
   LINE(LPTR)=BEST FIT                ;! REPLACE LITERAL WITH POINTER

   START=START+LENGTH(SYMTAB(BESTFIT)_NAME)
   -> NEXT PASS %UNLESS START > TPTR
LINE(LPTR+1)=0
!
%END
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
%INTEGERFN VALUE (%INTEGER PTR) ;! VALUE OF PRECEDENCE FN BETWEEN
                               ;!RIGHTMOST TWO ELEMENTS IN <LINE>
%RESULT=2 %IF PTR<=1
%RESULT=4 %IF LINE(PTR)=0
%RESULT= PRECEDENCE(LINE(PTR-1),LINE(PTR))
%END
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
%ROUTINE REDUCE (%INTEGERNAME F)
%INTEGER P,S,PSP
!
%RETURN %IF FLAG=1   ;! ERROR RECOVERY
%CYCLE P=0,1,F            ;! LIST ANALYSIS RECORD (=CONTENTS OF <LINE>)
   %IF P#0 %THEN PRINTSTRING (REL SYM (VALUE(P)))
   %IF LINE(P)=0 %THEN PRINTSYMBOL('#') %ELSE %C
   PRINTSTRING(SYMTAB(LINE(P))_NAME)
                              ;! '#' = END OF <LINE> MARKERS
%REPEAT ; NEWLINE
S=F-1
S=S-1 %WHILE VALUE(S)#2            ;!**HANDLE
PSP=2
   CELL=INDEX (LINE (S))
LIST SEEK:
   FAULT(5) %ANDRETURNIF CELL=0      ;!** END OF LIST FOUND--NO MATCH
   PSP=PHRASE(CELL)
   P=S                              ;! LINE POINTER TO START OF PHRASE
   P=P+1 %AND PSP=PSP+1 %UNTIL P=F %OR LINE(P)#PS(PSP)
   %IF P=F %AND PS(PSP)>=0 %THENSTART  ;! PHRASE FOUND IN PS
      PSP=PSP-1 %UNTIL PS(PSP)>0    ;! GET PHRASE NAME
      LINE(S)=-PS(PSP)              ;! AND SUBSTITUTE IN ANALYSIS REC
      F=S+1
      LINE(F)=LINE(LPTR)
      %RETURN
   %FINISH
   CELL=NEXT CELL(CELL)
   -> LIST SEEK                    ;! NO MATCH -- CONTINUE SEARCHING
%END
%END
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
%ROUTINE PRINT PREC MATRIX (%INTEGER L1,L2)
%INTEGER I,J
   %CYCLE I=-100,1,SIZE
      SPACES(9-LENGTH(SYMTAB(I)_NAME)) 
      PRINTCH(TMARKER(SYMTAB(I)_TYPE))   ;!FLAG TERMINALS WITH ''
      PRINTSTRING(SYMTAB(I)_NAME)
      PRINTCH(TMARKER(SYMTAB(I)_TYPE))
      %CYCLE J=L1,1,L2
      PRINTSTRING(REL SYM(PRECEDENCE(I,J)))
      %REPEAT
      NEWLINE
   %REPEAT
!
!*** PRINT PHRASE/LITERAL NAMES VERTICALLY BENEATH ARRAY
!
   SPACES(11)                      ;! POSITION PRINT HEAD
   %CYCLE I=L1,1,L2            ;! PRINT FIRST LETTER OF NAMES
      PRINTCH(TMARKER(SYMTAB(I)_TYPE)) ;!  FLAGGING TERMINALS ('') AND T
      PRINTCH(BYTEINTEGER(ADDR(SYMTAB(I)_NAME)+1))
      PRINTCH(TMARKER(SYMTAB(I)_TYPE)) ;! DISTINGUISHED SYMBOL (!!)
   %REPEAT
   J=2
NEXT ROW OF TEXT:
   SYMBOL=0                  ;! CLEAR PRINT MARKER
   NEWLINE ; SPACES(11)      ;! POSITION PRINT HEAD
   %CYCLE I=L1,1,L2
      SPACE
      %IF J<=LENGTH(SYMTAB(I)_NAME) %THEN PRINT CH(BYTEINTEGER %C
         (ADDR(SYMTAB(I)_NAME)+J)) %AND SYMBOL=1 %ELSE SPACE
      SPACE
   %REPEAT
   J=J+1                     ;! NEXT ROW OF TEXT
   -> NEXT ROW OF TEXT %UNLESS SYMBOL=0 ;!NO MORE TO PRINT
%END
%END
!
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
!
%ROUTINE SKIP LINE
%INTEGER INPUT
READSYMBOL(INPUT) %UNTIL INPUT=NL
NEWLINE
%END
!
!
%ROUTINE READ SYM (%INTEGERNAME I)
READSYMBOL(I)
PRINTSYMBOL(I) %UNLESS INPUT ='.TT' %OR FPS=0
%END
!

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!   PHRASE STRUCTURE MANIPULATION ROUTINES
%INTEGER %FN GET VAL (%INTEGER END)
%STRING(20) S
%INTEGER I,P
%BYTEINTEGER TYPE
%IF END='''' %THEN TYPE=1 %ELSE TYPE=0 ;! FLAG TERMINAL WITH '1'
%IF PSP=0 %THEN TYPE=2     ;! FIRST PHRASE NAME READ IN IS DIST. SYMBOL
S=''
1:READSYM(SYMBOL)
  %IF SYMBOL=END %THENSTART  ;! CHECK FOR TERMINATOR IN STRING
      %IF NEXT SYMBOL # END %THEN -> 2  ;! END OF LITERAL
      READSYM(SYMBOL)
   %FINISH           ;! OTHERWISE TREAT AS SINGLE OCCURENCE OF END SYMBO
  S=S.TOSTRING(SYMBOL)
  -> 1
!
2:%IF SIZE#-100 %THENSTART
    %CYCLE I=-100,1,SIZE-1     ;! SEARCH SYMBOL TABLE FOR ENTRY
      %IF S=SYMTAB(I)_NAME %AND (SYMTAB(I)_TYPE=TYPE %C
      %OR (SYMTAB(I)_TYPE=2>1 %AND TYPE=0)) %THEN P=I %AND -> 3
    %REPEAT
   %FINISH
  P=SIZE ; SYMTAB(SIZE)_NAME = S  ;! CREATE NEW ENTRY
   SYMTAB(SIZE)_TYPE=TYPE
  SIZE=SIZE+1
3:PSP=PSP+1
   SYMBOL=' '                 ;! CLEAR SYMBOL MARKER FOR ERROR TRAP
  %IF PSP>1000 %THEN FAULT (8) %ANDSTOP
  %RESULT=P
%END
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
%ROUTINE SEARCH
%INTEGER CELL1,CELL2,PSP1,PSP2
!
%CYCLE SYMBOL=-100,1,-1             ;! SEARCH PS FOR DUPLICATE RHS
   CELL1=INDEX(SYMBOL)              ;!FIRST CELL IN LIST
   -> NULL %IF CELL1=0              ;! LIST EMPTY
CONTINUE:
   CELL2=CELL1
SUBLIST:
   CELL2=NEXT CELL(CELL2)           ;! MOVE DOWM EACH SUBLIST
   -> NEXT SUB LIST %IF CELL2=0     ;!SUBLIST EMPTY
   PSP1=PHRASE(CELL1)               ;!NOW MATCH PHRASES IN PS
   PSP2=PHRASE(CELL2)
   PSP1=PSP1+1 %AND PSP2=PSP2+1 %WHILE PS(PSP1)=PS(PSP2) %C
                                %AND PS(PSP1)<0
   %IF PS(PSP1)>=0 %AND PS(PSP2)>=0 %THEN %START
                                    ;! TWO IDENTCAL PHRASES IN PS
      PSP1=PSP1-1 %UNTIL PS(PSP1)>0
      PSP2=PSP2-1 %UNTIL PS(PSP2)>0
      FAULT(2)
      PRINT STRING('
IN PHRASES :'.SYMTAB(-PS(PSP1))_NAME.':'.SYMTAB(-PS(PSP2))_NAME.'
')
   %FINISH
   -> SUB LIST                      ;! OTHERWISE CONTINUE SEARCH
NEXT SUB LIST:
   CELL1=NEXTCELL(CELL1)
   -> CONTINUE %UNLESS CELL1=0
NULL:
%REPEAT
%END
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
%ROUTINE FAULT (%INTEGER X)
%OWNBYTEINTEGERARRAY RFLAG(1:8)=0(8)
%OWNSTRING(25) %ARRAY ERROR (1:8)='MULTIPLE RELATION',
                                  'DUPLICATE RHS IN PS',
                                  'NULL ALTERNATIVE IN PS',
                                  'INVALID SPELLING',
                                  'PHRASE NOT IN PS',
                                  'NOT DISTINGUISHED PHRASE',
                                  'INVALID LINE IN PS',
                              'PS TOO BIG FOR SPLIT'
!
FLAG=1                            ;! SET ERROR FLAG
%RETURN %IF X < 4 %AND RFLAG(X)=1
RFLAG(X)=1
%IF X>=4 %THEN PRINTSTRING('
SYNTAX:') %ELSE PRINT STRING('

LANGUAGE NOT SIMPLE PRECEDENCE :')
PRINT STRING(ERROR (X).'
')
%END
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!   LIST MANIPULATION ROUTINE
!
%ROUTINE PUT (%INTEGER SYM,PSP)
!** THIS ROUTINE ADDS A POINTER TO ARRAY <PS> AT <PSP>
!** ON LINK LIST REFERENCED BY <INDEX(SYM)>
%OWNINTEGER FREE = 0
%INTEGER CELL
!
FREE=FREE+1  ; %STOP %IF FREE = 1001 ;!**LIST OFLO
!
%IF INDEX(SYM)=0 %THEN INDEX(SYM)=FREE %C
                 %AND  PHRASE(FREE)=PSP %C
                 %AND  %RETURN    ;!**FIRST OCCURENCE OF PHRASE
CELL=INDEX(SYM)                   ;!**GET FIRST POINTER
CELL=NEXT CELL(CELL) %WHILE CELL#0 %AND NEXT CELL(CELL)#0
                                  ;!FIND END OF INDEXED LIST
NEXT CELL(CELL)=FREE              ;!AND ADD NEW CELL TO END OF LIST
PHRASE(FREE)=PSP
%END

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!   MATRIX MANIPULATION ROUTINES
!
!
%ROUTINE WARSHALLS (%INTEGERARRAYNAME A,%INTEGER S,D)
!*** AFTER EXECUTION OF ROUTINE, ARRAY <A> CONTAINS
!*** THE TRANSITIVE CLOSURE OF <A>, USING WARSHALLS
!*** ALGORITHM
!
%INTEGER  I,J,K
!
%CYCLE I=S,1,D
   %CYCLE J=S,1,D
      %IF A(J,I)=1 %THENSTART
         %CYCLE K=S,1,D
            A(J,K)=A(J,K)!A(I,K)
         %REPEAT
      %FINISH
   %REPEAT
%REPEAT
!
%END
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !

%ROUTINE  FILL MATRICES (%INTEGERARRAYNAME FIRST,EQUAL,LAST)
!
%INTEGER PHRASE,P,Q
%CYCLE P=-100,1,SIZE
   %CYCLE Q = -100,1,SIZE
      FIRST(P,Q)=0 ; EQUAL(P,Q)=0 ; LAST(P,Q)=0
   %REPEAT
%REPEAT
!
P=0
UPD:P=P+1 ; %RETURN %IF PS(P)=-2000
    %IF PS(P)>=0 %THENSTART
      %IF P#1 %THEN LAST(PHRASE,PS(P-1))=LAST(PHRASE,PS(P-1))!1
      PHRASE=-PS(P) %IF PS(P)#0
     -> UPD
    %FINISH
    %IF PS(P)<0 %AND PS(P-1)<0 %THEN EQUAL(PS(P-1),PS(P))=%C
      EQUAL(PS(P-1),PS(P))!1
    %IF PS(P)<0 %AND PS(P-1)>=0 %THEN FIRST(PHRASE,PS(P))= %C
      FIRST(PHRASE,PS(P))!1
    -> UPD
%END
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
!
%ROUTINE B MULT MATRIX (%INTEGERARRAYNAME A,B,C)
!  C = A * B
!
%INTEGER I,J,K
%CYCLE  I=-100,1,SIZE
   %CYCLE J=-100,1,SIZE
      C(I,J)=0
      %CYCLE K=-100,1,SIZE
         C(I,J)=C(I,J)!(A(I,K)&B(K,J))
      %REPEAT
   %REPEAT
%REPEAT
!
%END
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
!

%ROUTINE TRANSPOSE (%INTEGERARRAYNAME A,B,%INTEGER S)
!
!  B = A!
!
%INTEGER I,J
%CYCLE I = -100,1,S
   %CYCLE J=-100,1,S
      B(I,J)=A(J,I)
   %REPEAT
%REPEAT
%END
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
!
%ROUTINE GET PREC (%INTEGERARRAYNAME PREC)
!
%INTEGERARRAY FIRST,LAST,TRANS,LESS,GTR(-100:SIZE,-100:SIZE)
!
%INTEGER I,J,K,L
!
!**(1): ANALYSE PHRASE STRUCTURE
     FILL MATRICES (FIRST,PREC,LAST)
!**(2): CALCULATE '<' RELATION
     WARSHALLS(FIRST,-100,SIZE) ; ! FIRST => FIRST+
     B MULT MATRIX(PREC,FIRST,LESS)       ;! LESS = (=)(FIRST+)
!**(3): CALCULATE '>' RELATION
     WARSHALLS (LAST,-100,SIZE)  ; ! LAST => LAST+
     TRANSPOSE(LAST,TRANS,SIZE)
     B MULT MATRIX(TRANS,PREC,LAST)      ;! LAST=>(TRANS(LAST+))(=)
     %CYCLE I=-100,1,SIZE
        FIRST(I,I)=1           ;! FIRST=FIRST ! I
     %REPEAT
     B MULT MATRIX (LAST,FIRST,GTR)
!**(4): NOW FILL IN PREC MATRIX WITH ALL PRECEDENCE CODES
!       CODE     MEANING
!        0      NO RELATION
!        1      R = S
!        2      R < S
!        4      R > S
!
     %CYCLE I=-100,1,SIZE
        %CYCLE J=-100,1,SIZE
   K=PREC(I,J)!LESS(I,J)<<1!GTR(I,J)<<2
   PREC(I,J)=K
   %UNLESS K<=2 %OR K=4 %THEN %START
     FAULT(1)
     NEWLINE
     L=TMARKER(SYMTAB(I)_TYPE)
     PRINTCH(L)
     PRINT STRING(SYMTAB(I)_NAME)
     PRINTCH(L)
     SPACE
     %IF K&2#0 %THEN PRINT SYMBOL('<')
     %IF K&1#0 %THEN PRINT SYMBOL('=')
     %IF K&4#0 %THEN PRINT SYMBOL('>')
     SPACE
     L=TMARKER(SYMTAB(J)_TYPE)
     PRINTCH(L)
     PRINT STRING(SYMTAB(J)_NAME)
     PRINTCH(L)
     %FINISH
        %REPEAT
     %REPEAT
%END
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
%END


%ENDOFFILE