!* MODIFIED 02/05/78
!*
!*IO; %SYSTEMINTEGERMAPSPEC COMREG(%INTEGER I)
!*IO; %SYSTEMROUTINESPEC SSMESS(%INTEGER N)
!*
!*IO;%SYSTEMROUTINESPEC OPEH USER ERROR(%INTEGER ERRNO,ACT,LANG,LEVELS)
OWNINTEGER FMTAD
OWNINTEGER INLENGTH
OWNINTEGER ITEMPTR
!*
ROUTINE MOVE(INTEGER LENGTH, FROM, TO)
INTEGER I
RETURNIF LENGTH <= 0
I = X'18000000'!LENGTH
*LSS_FROM
*LUH_I
*LDTB_I
*LDA_TO
*MV_L =DR
END ; !OF MOVE
!*
!*
ROUTINE ETOI(INTEGER AD, L)
INTEGER I, J, K
I = COMREG(11)
RETURNIF L <= 0
J = X'18000100'
K = X'18000000'!L
*LSS_I
*LUH_J
*LDTB_K
*LDA_AD
*TTR_L =DR
END ; ! ETOI
!*
ROUTINE ITOE(INTEGER AD, L)
INTEGER I, J, K
I = COMREG(12)
RETURNIF L <= 0
J = X'18000100'
K = X'18000000'!L
*LSS_I
*LUH_J
*LDTB_K
*LDA_AD
*TTR_L =DR
END ; ! ITOE
!*
SYSTEMROUTINE PRINT FORMAT
BYTEINTEGERARRAYNAME FORMAT
BYTEINTEGERARRAYFORMAT AF(0:INLENGTH)
FORMAT==ARRAY(FMTAD,AF)
INTEGER END, START, FIN, LOOP, I, J
END=-1
START=0
FIN=0
LOOP=INLENGTH//120
IF INLENGTH-LOOP*120#0 THEN LOOP=LOOP+1
CYCLE I=1, 1, LOOP
NEWLINE
IF I*120<INLENGTH THEN END=END+120 ELSE END=INLENGTH-1 AND FIN=1
CYCLE J=START, 1, END
PRINTSYMBOL(FORMAT(J))
REPEAT
IF START<=ITEMPTR<=END THENSTART
NEWLINE
SPACES(ITEMPTR-START)
PRINTSYMBOL('!')
NEWLINES(2)
FINISH
IF FIN#1 THEN START=START+120 ELSE RETURN
REPEAT
END
SYSTEMINTEGERFN FORMATCD(INTEGER FORMATAD, ARYADR, INLEN, OUTLEN, C
INOUT, TYPE, SYS4, INTEGERNAME TABLEN)
!>>%INTEGERFN
! FORMATCD(%INTEGER FORMATAD,A
!RYADR,TEXTAD,INLEN,OUTLEN, %C
!>>
! INOUT,TYPE,SYS4,%INTEGERNAME
! TABLEN,TEXTLEN)
SWITCH SW(0:51)
INTEGER PTR, CODE, COUNT, BRACK, FLAG, NUMBER, I, CHAR, C
NXTCHAR, INDEX, CNT, ERR, WORD, FIRST, ADRF,SPARE,BOTHZERO
INTEGER OUTPTR, FMTPTR, TEXTPTR, HOLLEN, QUOTE CNT
INTEGERARRAY LOOP(0:8)
BYTEINTEGERARRAY COPYFMT(0:INLEN)
BYTEINTEGERARRAYNAME FORMAT
BYTEINTEGERARRAYFORMAT AF(0:INLEN)
INTEGERARRAYNAME FMT
INTEGERARRAYFORMAT FMTF(0:OUTLEN//4)
BYTEINTEGERARRAY HOLL(0:500)
FORMAT==ARRAY(FORMATAD, AF)
FMT==ARRAY(ARYADR, FMTF)
!*IO; %IF TYPE=1 %THEN FORMAT==ARRAY(ADDR(COPYFMT(0)), AF)
!*
!*
INTEGERFN ERROR(INTEGER NO)
! 102 'NO RIGHT BRACKET',
! 101 'NO LEFT BRACKET',
! 103 'NEGATIVE SIGN
! INCORRECT',
! 104 'INVALID FORMAT',
! 105 'DECIMAL FIELD
! GREATER THAN WIDTH',
! 106 'FORMAT WIDTH OF 0
! INCORRECT',
! 107 'REPETITCOMPN FACTOR
! INVALID',
! 108 'NULL LITERAL INVALID'
! 109 'INTEGER FIELD TOO LARGE'
! 110 'NO WIDTH FIELD ALLOWED'
!*IO; %IF COMREG(42)=1 %THENSTART;! OPEH MODE
!*IO; PRINTSTRING('CURRENT FORMAT')
!*IO; NEWLINE
!*IO; OPEH USER ERROR(NO,2,2,0)
!*IO; %FINISHELSESTART
!*IO;SELECTOUTPUT(107)
!*IO; SSMESS(NO)
!*IO; %FINISH
!*COMP ER=NO
!*COMP LFAULT
PRINT FORMAT
RESULT =-1
END
ROUTINE GETNUM(INTEGERNAME FLAG, NUMBER, ERR)
INTEGER I
NUMBER=-1
ERR=0
BACK: IF FMTPTR=INLEN THEN ERR=102 ANDRETURN
IF FORMAT(FMTPTR)=' ' THEN FMTPTR=FMTPTR+1 AND C
ITEMPTR=ITEMPTR+1 AND ->BACK
FLAG=FORMAT(FMTPTR)-39
UNLESS 9<=FLAG<=18 THEN FMTPTR=FMTPTR+1 ANDRETURN
!FLAG=0 ' '' '
!FLAG=1 '('
!FLAG=2 ')'
! FLAG=4 '+'
!FLAG=5 ','
!FLAG=6 '-'
!FLAG=7 '.'
! FLAG=8 '/'
!FLAG=9 - 18 DIGITS
! FLAG= 26 - 51 LETTERS
NUMBER=0
CYCLE I=0, 1, 20
IF FORMAT(FMTPTR)=' ' THEN -> NEXT ITEM
UNLESS X'30'<=FORMAT(FMTPTR)<=X'39' THENEXIT
NUMBER=NUMBER*10+FORMAT(FMTPTR)-'0'
IF FMTPTR=INLEN AND FORMAT(FMTPTR-1)#X'29' THEN C
ERR=102 ANDRETURN
NEXT ITEM: FMTPTR=FMTPTR+1
REPEAT
END
INLENGTH=INLEN
!*IO; %IF TYPE=0 %THEN FMTAD=FORMATAD %ELSE FMTAD=ADDR(COPYFMT(0))
CODE=-1; ! SET IF A FORMAT CODE IS
! RECOGNISED
COUNT=-1; ! SET IF WE HAVE A NUMBER
PTR=0; ! POINTER TO OUTPUT ARRAY
BRACK=0; ! BRACKET COUNT
QUOTECNT=0
FMTPTR=0
BOTHZERO=0
OUTPTR=0
TEXTPTR=0; ! POINTER TO HOLLERITH TEXT
!BRACKET CHECK
ITEMPTR=FMTPTR
CYCLE I=0, 1, OUTLEN//4-1
FMT(I)=0
REPEAT
!*IO; %IF TYPE=1 %THEN MOVE(INLEN, FORMATAD, ADDR(COPYFMT(0)))
!*IO; %IF TYPE=1 %THEN ETOI(ADDR(COPYFMT(0)), INLEN)
REMSPACE:IF FORMAT(FMTPTR)=' ' THEN FMTPTR=FMTPTR+1 AND ->REMSPACE
IF FORMAT(FMTPTR)='(' THEN FMTPTR=FMTPTR+1 AND C
BRACK=BRACK+1 ELSE ->ERR101
ITEMPTR=FMTPTR
GETITEM:GETNUM(FLAG, NUMBER, ERR)
IF ERR>100 THEN -> ERR
IF CODE>0 THENSTART
IF NUMBER<0 THEN -> CONT
IF SYS4#0 AND NUMBER=0 THEN FMT(PTR)=FMT(PTR)!X'4A000000' C
!(CODE+39) %AND -> SET
IF NUMBER>0 THEN FMT(PTR)=FMT(PTR)!NUMBER!(CODE+39)<<24 C
ELSE ERR=106 AND -> ERR
SET:PTR=PTR+1
CODE=-1
COUNT=-1
->GETITEM
FINISH
CONT: IF NUMBER>=0 THEN COUNT=NUMBER AND ->GETITEM
IF 9<=FLAG<=25 THEN ->SW(3)
IF FLAG<0 THEN ->ERR104
IF FLAG>51 THEN ->ERR104 ELSE ->SW(FLAG)
SW(0): !HOLLERITH,QUOTE
QUOTE CNT= 0
CYCLE I=0, 1, 499
IF FMTPTR=INLEN THEN ->ERR102
CHAR=FORMAT(FMTPTR)
FMTPTR=FMTPTR+1
IF CHAR='''' THENSTART
IF FMTPTR=INLEN THEN ->ERR102
NXTCHAR=FORMAT(FMTPTR)
IF NXTCHAR='''' THEN FMTPTR=FMTPTR+1 C
AND QUOTE CNT= QUOTE CNT + 1 C
ELSE ->OUT
FINISH
IF INOUT<=0 THEN ->REP ELSE HOLL(I+1)=CHAR
REP: REPEAT
OUT: IF I=0 THEN ->ERR108
!*IO;%IF I>1 %THENSTART
!*IO; %IF INOUT<=0 %THEN FMT(PTR)=X'48000000' %ELSE FMT(PTR)=X'4D000000'
!*IO; %FINISH
!*COMP %IF I>1 %THEN FMT(PTR)=X'48000000'
!*IO; %IF I=1 %THENSTART
!*IO; %IF INOUT<=0 %THENSTART
!*IO; FMT(PTR)=X'48000001'
!*IO; PTR=PTR+1
!*IO; FMT(PTR)=FORMATAD+FMTPTR-2
!*IO; %FINISHELSESTART
!*IO; FMT(PTR)=X'43000000'!HOLL(1)
!*IO; %IF TYPE=1 %THEN ITOE(ADDR(FMT(PTR))+3,1)
!*IO; %FINISH
!*IO; %FINISH
!*COMP %IF I=1 %THEN FMT(PTR)=X'43000000'!HOLL(1)
!*COMP %IF TYPE=1 %AND I=1 %THEN ITOE(ADDR(FMT(PTR))+3,1)
IF I#1 THENSTART
IF INOUT<=0 THENSTART
IF (FMTPTR-ITEMPTR-2)>255 THEN ->ERR109
FMT(PTR)=FMT(PTR)!(FMTPTR-ITEMPTR-2)
FINISHELSESTART
IF I>255 THEN ->ERR109
FMT(PTR)=FMT(PTR)!I
FINISH
FINISH
PTR=PTR+1
IF I#1 THEN HOLLEN=I AND CNT=I+1 AND ->HOLLER
->GETITEM
SW(1): !LEFT BRACKET
BRACK=BRACK+1
IF CODE>=0 THENRESULT =ERROR(107)
IF COUNT<0 THEN FMT(PTR)=X'42000001' AND ->SETCNT
IF COUNT=0 THEN ->ERR107
IF COUNT<=255 THEN FMT(PTR)=X'42000000'!COUNT ELSE ->ERR109
SETCNT:COUNT=-1
PTR=PTR+1
LOOP(BRACK)=PTR<<2
->GETITEM
SW(2): !RIGHT BRACKET
IF BRACK=1 THEN ->END
IF COUNT=0 THEN ->ERR106
IF COUNT>0 THENSTART
! %IF COUNT>255 %THEN ->ERR109
FMT(PTR)=FMT(PTR)!COUNT
COUNT=-1
FINISH
IF CODE>0 THENSTART
FMT(PTR)=FMT(PTR)!((CODE+39)<<24)
PTR=PTR+1
CODE=-1
FINISH
!%IF LOOP(BRACK)>255 %THEN ->ERR109
FMT(PTR)=X'4B000000'!LOOP(BRACK)
LOOP(BRACK)=0
BRACK=BRACK-1
PTR=PTR+1
->GETITEM
SW(4): !PLUS SIGN
->GETITEM
SW(6): !MINUS SIGN
GETNUM(FLAG, NUMBER, ERR)
IF ERR>100 THEN ->ERR
UNLESS NUMBER>=0 THEN ->ERR103
COUNT=-NUMBER
GETNUM(FLAG, NUMBER, ERR)
IF ERR>100 THEN ->ERR
IF FLAG=41 THEN ->SW41 ELSE ->ERR103
->GETITEM
SW(7): !DECIMAL POINT
UNLESS CODE=32 THEN ->ERR104
POINT:IF SYS4=0 AND COUNT=0 THEN ->ERR106
IF COUNT>255 THEN ->ERR109
FMT(PTR)=FMT(PTR)!COUNT
GETNUM(FLAG, NUMBER, ERR)
IF ERR>100 THEN ->ERR
IF NUMBER<0 THEN ->ERR104
IF NUMBER=0 AND COUNT=0 AND SYS4#0 THENSTART
FMT(PTR)=FMT(PTR)!X'4A000000'
COUNT=-1
BOTHZERO=-1
->RETURN
FINISH
IF NUMBER>COUNT THEN ->ERR105 ELSE COUNT=-1
IF NUMBER>255 THEN ->ERR109
FMT(PTR)=FMT(PTR)!(NUMBER<<16)
RETURN:IF CODE>=0 THEN ->SW(CODE) ELSE ->ERR104
SW(8):SW(5): !A NEW RECORD OR A COMMA
IF COUNT=0 THENRESULT =ERROR(106)
ITEMPTR=FMTPTR; ! POINTS TO CURRENT ITEM
IF COUNT>0 THENSTART
IF COUNT>255 THEN ->ERR109
FMT(PTR)=FMT(PTR)!COUNT
COUNT=-1
FINISH
IF CODE>=0 THENSTART
FMT(PTR)=FMT(PTR)!((CODE+39)<<24)
PTR=PTR+1
CODE=-1
FINISH
IF FLAG=5 THEN ->GETITEM; ! COMMA
FMT(PTR)=X'4E000000'; !NEW RECORD
PTR=PTR+1
->GETITEM
SW(45): !T FORMAT
IF COUNT>=0 THEN ->ERR107
GETNUM(FLAG, NUMBER, ERR)
IF ERR>100 THEN ->ERR
IF NUMBER<0 THEN ->ERR104
IF NUMBER=0 THEN ->ERR106
IF NUMBER>255 THEN ->ERR109
FMT(PTR)=X'54000000'!NUMBER
PTR=PTR+1
CODE=-1
->GETITEM
SW(26):SW(29):SW(30):SW(31):SW(32):SW(34):SW(37):SW(42):SW(51):
!A,D,E,F,G,I,L,Q,Z FORMATS
IF CODE>=0 THEN ->WRCODE
IF COUNT=0 THEN ->ERR107
IF COUNT>1 THENSTART
IF COUNT>255 THEN ->ERR109
FMT(PTR)=(0!COUNT)<<8
COUNT=-1
FINISH
CODE=FLAG
IF 29<=CODE<=32 OR CODE=42 THENSTART
GETNUM(FLAG, NUMBER, ERR)
IF ERR>100 THEN ->ERR
IF SYS4#0 THEN COUNT=NUMBER ELSE START
IF NUMBER>=0 THEN COUNT=NUMBER ELSE ->ERR104
FINISH
GETNUM(FLAG, NUMBER, ERR)
IF ERR>100 THEN ->ERR
IF FLAG#7 AND CODE=32 THEN FMTPTR=FMTPTR-1 AND ->GETITEM
! ALLOW INTEGER G
IF FLAG=7 THEN ->POINT ELSE ->ERR104
FINISH
->GETITEM
WRCODE:IF BOTHZERO=1 THEN FMT(PTR)=FMT(PTR)!(CODE+39) ANDC
BOTHZERO=0 ELSE FMT(PTR)=FMT(PTR)!(CODE+39)<<24
PTR=PTR+1
CODE=-1
->GETITEM
SW(49): !X FORMAT
IF COUNT<0 THEN ->ERR104
IF COUNT=0 THEN ->ERR106
IF COUNT>255 THEN ->ERR109
FMT(PTR)=X'58000000'!COUNT
COUNT=-1
CODE=-1
PTR=PTR+1
->GETITEM
SW(50): !Y FORMAT
IF SYS4#0 THENSTART
IF COUNT<0 THEN ->ERR104
IF COUNT=0 THEN -> ERR106
IF COUNT>255 THEN -> ERR109
FMT(PTR)=X'59000000'!COUNT
COUNT=-1
CODE=-1
PTR=PTR+1
->GETITEM
FINISHELSE ->ERR104
SW41:
SW(41): !P FORMAT
IF COUNT>0 THENSTART
IF COUNT>255 THEN ->ERR109
FMT(PTR)=X'50000000'!COUNT
FINISHELSESTART
COUNT=-COUNT
IF COUNT>255 THEN ->ERR109
FMT(PTR)=X'4F000000'!COUNT
FINISH
PTR=PTR+1
COUNT=-1
CODE=-1
->GETITEM
SW(33): !H FORMAT
IF COUNT<0 THEN ->ERR104
IF COUNT=0 THEN ->ERR106
CNT=COUNT
!*IO; %IF COUNT=1 %THENSTART
!*IO; %IF INOUT<=0 %THENSTART
!*IO; FMT(PTR)=X'48000001'
!*IO; PTR=PTR+1
!*IO; FMT(PTR)=FORMATAD+FMTPTR
!*IO; %FINISHELSESTART
!*IO; FMT(PTR)=X'43000000'!FORMAT(FMTPTR)
!*IO; %IF TYPE=1 %THEN ITOE(ADDR(FMT(PTR))+3, 1)
!*IO; %FINISH
!*IO; PTR=PTR+1
!*IO; FMTPTR=FMTPTR+1
!*IO; COUNT=-1
!*IO; CODE=-1
!*IO; ->GETITEM
!*IO; %FINISH
!*COMP %IF COUNT=1 %THENSTART
!*COMP FMT(PTR)=X'43000000'!FORMAT(FMTPTR)
!*COMP %IF TYPE=1 %THEN ITOE(ADDR(FMT(PTR))+3,1)
!*COMP PTR=PTR+1
!*COMP FMTPTR=FMTPTR+1
!*COMP COUNT=-1
!*COMP CODE=-1
!*COMP ->GETITEM
!*COMP %FINISH
IF COUNT>255 THEN ->ERR109
!*COMP FMT(PTR)=X'48000000'!COUNT
!*IO; %IF INOUT<=0 %THEN FMT(PTR)=X'48000000'!COUNT
!*IO; %IF INOUT>0 %THEN FMT(PTR)=X'4D000000'!COUNT
PTR=PTR+1
HOLLEN=COUNT
CYCLE I=0, 1, COUNT-1
IF FMTPTR=INLEN THEN ->ERR102
HOLL(I+1)=FORMAT(FMTPTR)
FMTPTR=FMTPTR+1
REPEAT
ITEMPTR=FMTPTR
COUNT=-1
HOLLER:
IF INOUT<=0 THEN FMT(PTR)=FORMATAD+FMTPTR-CNT-QUOTE CNT ELSESTART
!*IO; ADRF=ADDR(FMT(PTR))
!*IO; %CYCLE I=0, 1, HOLLEN-1
!*IO; BYTEINTEGER(ADRF+I)=HOLL(1+I)
!*IO; %REPEAT
!*IO; I=HOLLEN//4
!*IO; %IF HOLLEN-4*I#0 %THEN PTR=PTR+I+1 %ELSE PTR=PTR+I
!*IO; %IF TYPE=1 %THEN ITOE(ADRF, HOLLEN)
!*IO; ->GETITEM
!*
!*COMP INTEGER(ARYADR+PTR*4)=TEXTPTR
!*COMP MOVE(HOLLEN,ADDR(HOLL(1)),TEXTAD+TEXTPTR)
!*COMP TEXTPTR=TEXTPTR+HOLLEN
FINISH
PTR=PTR+1
->GETITEM
END:IF COUNT=0 THEN ->ERR106
IF COUNT>0 THENSTART
IF COUNT>255 THEN ->ERR109
FMT(PTR)=FMT(PTR)!COUNT
COUNT=-1
FINISH
IF CODE>=0 THENSTART
FMT(PTR)=FMT(PTR)!((CODE+39)<<24)
CODE=-1
PTR=PTR+1
FINISH
FMT(PTR)=X'53000000'
TABLEN=(PTR+1)<<2
!*COMP TEXTLEN=(TEXTPTR+3)&X'FFFC'
!*COMP %IF TYPE=1 %AND TEXTPTR#0 %THENSTART
!*COMP ITOE(TEXTAD,TEXTPTR)
!*COMP %FINISH
RESULT =0
SW(3):SW(19):SW(27):SW(28):SW(35):SW(36):SW(38):SW(39):SW(40):
SW(43):SW(44):SW(46):SW(47):SW(48):
->ERR104
!*
ERR:RESULT =ERROR(ERR)
ERR101:ERR=101; ->ERR
ERR102:ERR=102; ->ERR
ERR103:ERR=103; ->ERR
ERR104:ERR=104; ->ERR
ERR105:ERR=105; ->ERR
ERR106:ERR=106; ->ERR
ERR107:ERR=107; ->ERR
ERR108:ERR=108; ->ERR
ERR109:ERR=109; ->ERR
ERR110:ERR=110; -> ERR
END
!*
ENDOFFILE