EXTERNALROUTINESPEC DEFINE(STRING (255) S)
SYSTEMSTRINGFNSPEC ITOS(INTEGER N)
EXTERNALROUTINE COMPRESS(STRING (255) S)
!***********************************************************************
!* COMPRESSES A FILE OF ERROR MESSAGE INTO TWO CONSTARRAYS AND *
!* GENERATES A ROUTINE TO REGURGITATE THEM IN ENGLISH *
!***********************************************************************
CONSTINTEGER INSTRM = 1, CPSTRM = 2, LPSTRM = 3
CONSTINTEGER MAXWORD = 2000, MAXLETT = 1000
CONSTBYTEINTEGER SHIFT CHAR = 128
INTEGERARRAY WORD(1:MAXWORD)
INTEGERARRAY LETT(0:MAXLETT)
INTEGER I,J,N,NUM,NEXT,NMAX,NUMMAX
STRING (31) FILE1,FILE2,FILE3
STRING (71)TEMP,INPUT,WK1,WK2
STRING (71)FNSPEC MESS(INTEGER N)
ROUTINESPEC LIT(INTEGERNAME P,STRING (71) TXT1)
ROUTINESPEC CARDS OUT
CONSTBYTEINTEGERARRAY INTT(0:128)= 63(32),63(3),61,63,60, C
27,30,31,32,63(3),
28,59,29,63(17),
1,2,3,4,5,6,7,8,9,10,11,12,
13,14,15,16,17,18,19,20,
21,22,23,24,25,26,
63(6),
33,34,35,36,37,38,39,40,41,42,
43,44,45,46,47,48,49,50,51,52,
53,54,55,56,57,58,63(5),62
CONSTBYTEINTEGERARRAY OUTTT(0:73) ='?','A','B','C','D','E','F','G',
'H','I','J','K','L','M','N',
'O','P','Q','R','S','T','U',
'V','W','X','Y','Z','&','-',
'/','''','(',')',
'a','b','c','d','e','f','g',
'h','i','j','k','l','m','n',
'o','p','q','r','s','t','u',
'v','w','x','y','z','.','%',
'#','?','?',
'0','1','2','3','4','5','6',
'7','8','9'
UNLESS S->FILE1.(",").FILE2.(",").FILE3 THEN START
PRINTSTRING("PARAMS??")
NEWLINE
RETURN
FINISH
DEFINE(ITOS(INSTRM).",".FILE1)
SELECT INPUT(INSTRM)
DEFINE(ITOS(CPSTRM).",".FILE2)
DEFINE(ITOS(LPSTRM).",".FILE3)
SELECT OUTPUT(LPSTRM)
CYCLE I=1,1,MAXWORD
WORD(I)=0
REPEAT
LETT(0)=0
NEXT=1; NUM=1; NMAX=0
RMESS:READ(N); NMAX=N IF N>NMAX
IF N=0 THEN ->OUTPUT
J=1; WORD(NUM)=N; NUMMAX=NUM
RSYM:
I=NEXT SYMBOL
UNLESS I='"' THEN SKIP SYMBOL AND ->RSYM
READSTRING(INPUT)
WHILE INPUT->WK1.(" ").WK2 THEN INPUT=WK1." ".WK2
IF INPUT="" OR INPUT=" " THEN ->RMESS;! MISSING ERROR MESSAGE
NUM=NUM+1
IF NUM > MAXWORD THEN -> OVER
NEWLINE; WRITE(N,5)
WHILE INPUT->WK1.(" ").INPUT CYCLE
IF WK1#"" THEN START
LIT(I,WK1)
WORD(NUM)=I!X'8000'
NUM=NUM+1
IF NUM > MAXWORD THEN -> OVER
FINISH
REPEAT
IF INPUT # "" THEN START
LIT(I,INPUT)
WORD(NUM)=I!X'8000'
NUM=NUM+1
IF NUM > MAXWORD THEN -> OVER
FINISH
->RMESS
OUTPUT:
WORD(NUM)=0
NEWLINES(2)
CYCLE I=1,1,NMAX
TEMP=MESS(I)
IF TEMP#"" THEN START
NEWLINE; WRITE(I,5)
PRINTSTRING(" ".TEMP)
FINISH
REPEAT
CARDS OUT
SELECT OUTPUT(0)
PRINTSTRING("ROUTINE MESSAGE GENERATED")
NEWLINE
STOP
OVER: PRINTSTRING("OVERFLOW OF WORD TABLE")
NEWLINE; STOP
STRING (71)FN MESS(INTEGER N)
STRING (70)OMESS
INTEGER I,J,K,M,Q,S,UP
OMESS=""
CYCLE I=1,1,NUM-1
->FOUND IF N=WORD(I)
REPEAT
RESULT =""
FOUND:J=1
UP=0
CYCLE
K=WORD(I+J)
IF K&X'8000'=0 THEN EXIT
K=K!!X'8000'
OMESS=OMESS." " UNLESS J=1
UNTIL M&1=0 CYCLE
M=LETT(K); S=25
UNTIL S<0 CYCLE
Q=M>>S&63
IF Q=62 THEN UP=63 ELSE START
IF Q¬=0 THEN OMESS=OMESS.TOSTRING(OUTTT(Q+UP))
UP=0
FINISH
S=S-6
REPEAT
K=K+1
REPEAT
J=J+1
REPEAT
RESULT =OMESS
END
STRING (71)FN INSERT SHIFTS(STRING (71) TXT)
INTEGER I,C
STRING (71) WK
WK = ""
CYCLE I = 1,1,LENGTH(TXT)
C = CHARNO(TXT,I)
IF '0' <= C <= '9' THEN START
WK <- WK.TOSTRING(SHIFT CHAR).TOSTRING(C-'0'+'A')
FINISH ELSE WK <- WK.TOSTRING(C)
REPEAT
RESULT = WK
END
ROUTINE LIT(INTEGERNAME P,STRING (71) TXT)
INTEGER I,J,K,L,N,SH,CH
N=0; J=0
SH=25; L=0; CH=1
TXT = INSERT SHIFTS(TXT)
AGN: ->Q IF CH>LENGTH(TXT)
I=CHARNO(TXT,CH)
I=INTT(I)
CH=CH+1
N=N+1; J=J!I<<SH
SH=SH-6; ->AGN UNLESS SH<0
J=J!1 UNLESS CH>LENGTH(TXT)
K=NEXT+L
IF K > MAXLETT THEN -> OVER
LETT(K)=J
J=0; SH=25; L=L+1; ->AGN
Q: K=NEXT+L
IF K > MAXLETT THEN -> OVER
IF SH#25 THEN LETT(K)=J AND L=L+1
I=0
WHILE I<=NEXT-1 CYCLE
CYCLE J=0,1,L-1
->FAIL UNLESS LETT(I+J)=LETT(NEXT+J)
REPEAT
->FOUND
FAIL: I=I+1
REPEAT
P=NEXT; NEXT=NEXT+L
PRINTSTRING(" WORD ENTERED"); RETURN
FOUND:P=I; PRINTSTRING(" WORD FOUND "); RETURN
OVER: PRINTSTRING("OVERFLOW OF LETT TABLE")
NEWLINE; STOP
END
ROUTINE PHEX(INTEGER N)
INTEGER I, J
PRINTSTRING("X'")
CYCLE J=28,-4,0
I=N>>J&15
IF I>=10 THEN I=I+7
PRINT SYMBOL(I+'0')
REPEAT ; PRINTSTRING("'")
END
ROUTINE CARDS OUT
STRING (73)M
INTEGER I
SELECT OUTPUT(CPSTRM)
PRINTSTRING("!**START
%STRING(71)%FN MESSAGE(%INTEGER N)
!")
CYCLE I=1,1,71
PRINTSYMBOL('*')
REPEAT
PRINTSTRING("
!* *
!* Outputs an error message stored in a compressed format *
!* *
")
CYCLE I=1,1,NMAX
M=MESS(I)
IF M#"" THEN START
PRINTSTRING("!* ")
WRITE(I,3)
PRINTSTRING(" ".M)
SPACES(59-LENGTH(M))
PRINTSTRING("*
")
FINISH
REPEAT
PRINTSTRING("!")
CYCLE I=1,1,71
PRINT SYMBOL('*')
REPEAT
NEXT=NEXT-1
PRINTSTRING("
%CONSTBYTEINTEGERARRAY OUTTT(0:73)= '?','A','B','C','D','E','F','G',
'H','I','J','K','L','M','N',
'O','P','Q','R','S','T','U',")
PRINTSTRING("
'V','W','X','Y','Z','&','-',
'/','''','(',')',
'a','b','c','d','e','f','g',")
PRINTSTRING("
'h','i','j','k','l','m','n',
'o','p','q','r','s','t','u',
'v','w','x','y','z','.','%',")
PRINTSTRING("
'#','?','?',
'0','1','2','3','4','5','6',
'7','8','9'")
PRINTSTRING("
%CONSTINTEGER WORDMAX=")
WRITE(NUM,2)
PRINTSTRING(",DEFAULT="); WRITE(NUMMAX,2)
PRINTSTRING("
%CONSTHALFINTEGERARRAY WORD(0:WORDMAX)=0,%C")
NEWLINE; SPACES(9)
CYCLE I=1,1,NUM
WRITE(WORD(I),5); PRINTSTRING(",") UNLESS I=NUM
IF I&7=0 THEN START
NEWLINE; SPACES(9)
FINISH
REPEAT
PRINTSTRING("
%CONSTINTEGERARRAY LETT(0:")
WRITE(NEXT,2)
PRINTSTRING(")=0,%C")
NEWLINE; SPACES(8)
CYCLE I=1,1,NEXT
PHEX(LETT(I)); PRINTSTRING(",") UNLESS I=NEXT
IF I&3=0 THEN NEWLINE AND SPACES(8)
REPEAT
PRINTSTRING("
%INTEGER I,J,K,M,Q,S,UP
%STRING(70)OMESS
OMESS="" ""
%CYCLE I=1,1,WORDMAX-1
->FOUND %IF N=WORD(I)
%REPEAT
I=DEFAULT")
PRINTSTRING("
FOUND:
J=1
UP=0
%CYCLE
K=WORD(I+J)")
PRINTSTRING("
%IF K&X'8000'=0 %THEN %EXIT
K=K!!X'8000'
OMESS=OMESS."" "" %UNLESS J=1
%UNTIL M&1=0 %CYCLE
M=LETT(K); S=25
%UNTIL S<0 %CYCLE
Q=M>>S&63; ")
PRINTSTRING("
%IF Q=62 %THEN UP=63 %ELSE %START
%IF Q¬=0 %THEN OMESS=OMESS.TOSTRING(OUTTT(Q+UP))
UP=0
%FINISH
S=S-6
%REPEAT
K=K+1")
PRINTSTRING("
%REPEAT
J=J+1
%REPEAT
%RESULT=OMESS
%END
!**END
")
SELECT OUTPUT(LPSTRM)
END
END
ENDOFFILE