Trailing-Edge
-
PDP-10 Archives
-
BB-D480F-SB_FORTRAN10_V10
-
forfmt.mac
There are 11 other files named forfmt.mac in the archive. Click here to see a list.
SEARCH MTHPRM,FORPRM
TV FORFMT FORMAT PROCESSOR,10(4146)
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1981, 1985
;ALL RIGHTS RESERVED.
;
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
;ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH THE
;INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER
;COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
;OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE SOFTWARE IS HEREBY
;TRANSFERRED.
;THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE
;AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT
;CORPORATION.
;DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
;SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.
COMMENT \
***** Begin Revision History *****
1100 JLC New
1164 CKS 27-Oct-80
Prevent TL from going off left end of record
1207 JLC 19-Dec-80
Prevent %%GETIO from substituting REAL for COMPLEX for
list-directed I/O
1215 JLC 6-Jan-81
SFDEL was dropping off the end into dollar format. Inserted a
POPJ. Edit revhist actually inserted 9-Feb-81, was lost.
1230 JLC 20-Jan-81
Increased size of repeat count to 9 bits, decreased size of
exponent field to 3 bits.
1306 DAW 26-Feb-81
New arg list format from %SAVE
1321 DAW 6-Mar-81
More changes for extended addressing support.
1324 EDS 9-Mar-81 Q20-01396
Add an encoding address for DOLLAR ($) and COLON (:) format
so that ($10A5) is not treated as ($10,A5). These should
use the same encoding as SLASH (/) format.
1334 DAW 12-Mar-81
Use new macros $BLDBP, $LODBP, $STRBP to clean up the code.
1416 JLC 10-Apr-81
Q format must use IRBUF.
1464 DAW 12-May-81
Error messages.
1467 CKS 18-May-81
Change EXTADD to I.EXT, change TITLE to FORFMT to correspond to
file name
1473 CKS 21-May-81
Error message fixes.
1521 JLC 26-Jun-81
Fix formatted EOF processing: in input loop, check if pending
EOF. If so, toss rest of I/O list.
1532 DAW 14-Jul-81
OPEN rewrite: Base level 1
1535 JLC 14-Jul-81
Remove EOF handling from here, now handled in %DOIO.
1552 DMN 21-Jul-81
Performance enhancements.
1562 DMN 28-Jul-81
Performance enhancements.
1566 JLC 29-Jul-81
Add error diagnostics for digits with no formats, any repeat
count for $,/,Q, etc.
1575 JLC 05-Aug-81
Edit 1566 was too all-inclusive, made repeat count of left
paren break. Fix by making left paren not a delimiter,
then check in left paren routine for previous format.
1600 DAW 11-Aug-81
Allow "X" to mean "1X" (as it used to!)
1605 JLC 12-Aug-81
Fix ambiguous (A419X) to be error. Fix T to be a delimiter.
1615 DAW 19-Aug-81
Get rid of two word BP option.
1622 JLC 21-Aug-81
Fix Q format encoding, was accumulating digits after it.
Fix no-comma syntax, compile prev format if leftover
format char.
1625 DAW 21-Aug-81
Get rid of "DF".
1705 JLC 11-Sep-81
Fixed serious T-format bug. Now send %SPOS position desired
for next character (minimum 1) so that ORVIR in %OBYTE will
never have zero for a positioning command.
1730 JLC 18-Sep-81
Another bug fix for T-format. Sped up format encoding by
eliminating FMTSS and using a local stack instead.
1775 JLC 9-Oct-81
Fix X format. Was being truncated to 8 bits.
2033 JLC 15-Nov-81
Make "Data in IO list but not in format" go to %ABORT.
Fix A free format.
***** Begin Version 6A *****
2045 EGM 18-Mar-82
Allow error ARC (Ambiguous repeat count in FORMAT) to continue.
***** Begin Version 7 *****
3006 AHM/JLC 29-Oct-81
When storing the indefinite repeat pointer (%FMRPT) in LPRENC,
use an XMOVEI to generate a global address.
3012 JLC 5-Nov-81
Changes for new arg copier - A.FMS is an address of the
size of the format.
3014 JLC 5-Nov-81
Added flag (SKPFLG) to stop skipping for delimiters
with free-format A. Simplified %%GETIO.
3023 JLC 15-Nov-81
Make fatal error msg "Data in IO list but not in format" go
to %ABORT.
3031 JLC 11-Dec-81
Modify format encoder to get format size from word before format
if there is no size in the arg block (i.e., if the address containing
the value is zero).
3035 JLC 5-Feb-82
Rework of arg passing mechanism. Coroutine now isolated to this
module.
3056 JLC 23-Mar-82
Implement 2-word encoded formats, along with encoding in a fixed
area (expandable) and allocating separately. Implemented range-
checking, and format/type checking (warning if minor conflict,
hard error if character variable and other than A or G format).
3061 JLC 25-Mar-82
Catch Hollerith and quoted string input to character formats -
now illegal. Make sure the encoded list pntr can't overflow
on left parens.
3064 JLC 26-Mar-82
Implement new range-checking mechanism, simple one just would
not do.
3065 JLC 26-Mar-82
Fix format encoder to drop relative addresses in links and
indefinite repeat pointer, as the encoded format is moved
after it is encoded.
3077 JLC 5-Apr-82
Fix format encoder to do all calculations involving indefinite
repeat and links as relative addresses - recursive calls across
format buffer expansions caused bad links.
3122 JLC 28-May-82
Output warning message for Hollerith and quoted string input.
3131 JLC 11-Jun-82
Fix Iw.m, was accumulating default value instead of clearing
it upon getting period.
3136 JLC 26-Jun-82
Give user value of bad variable for format/variable mismatch.
Do some entry code optimization. Make ENC.LR available for
alphabetic I/O optimization.
3175 JLC 8-Sep-82
Fix SAVFMT, was not initializing FMT.BG.
3202 JLC 26-Oct-82
Fix SAVFMT/CLRFMT so they don't use the descriptor address
for hashing, since it can be a Q-temp.
3225 JLC 24-Nov-82
Change SIXVRT so it converts tabs to spaces.
3231 JLC 14-Dec-82
Fix type mismatch check so it catches TP%LIT going to
other than alphabetic
3250 JLC 7-Jan-83
Pay attention to number of args in SAVFMT.
***** End V7 Development *****
3266 JLC 11-Feb-83
Allows FOROTS to be protected execute-only on TOPS-10.
3426 TGS 23-Apr-84 SPR:20-20087
When diagnosing repeat count overlow at DIGENC, the wrong AC
was being used to index off the state table.
3457 TGS 3-Jan-85 SPR:20-20501
Using O-format with character variables is not allowed. Add a
better format/variable mismatch test for this case.
***** Begin Version 10 *****
4000 JLC 22-Feb-83
Fix execute-only bug on -10. Enhance performance a bit.
4001 JLC 23-Feb-83
Fix overlay program bug.
4004 JLC 24-Feb-83
Fix bug in performance enhancements.
4005 JLC 28-Feb-83
More code enhancements.
4010 JLC 19-Apr-83
Clear temp flags for formatted I/O here instead of in FORIO.
4020 PLB 23-Jun-83
Use global IOPDL if running in a non-zero section.
4023 JLC 29-Jun-83
Use global constants for BZ and SP format, rather than flags
in FLAGS.
4027 JLC 6-Jul-83
Reinsert line to clear IO.ADR at FMTEXC. We have not yet
removed the coroutine!
4044 JLC 19-Sep-83
Added new function to deallocate all encoded formats and the
format encoding area. Added new flag to avoid saving encoded
formats.
4047 JLC 5-Oct-83
Minor performance enhancements.
4051 JLC 6-Oct-83
Fix edit 4047. Make colon format legal again.
4052 JLC 12-Oct-83
Record format data type in %FMTSV. Code changes for formatted
I/O performance enhancement.
4054 JLC 25-Oct-83
Fix code change in edit 4052, was getting format size
incorrectly.
4066 JLC 11-Jan-84
Preparations for RMS.
4105 JLC 28-Feb-84
Modify the calling sequence for error calls.
4111 JLC 16-Mar-84
Modify the calling sequence for error calls again.
4122 JLC 2-May-84
Fix a bug in %DEFMT, assumed there was always a %FAREA.
4131 JLC 12-Jun-84
Add memory full non-skip return to %GTBLK and %MVBLK calls.
4146 MRB 11-Sep-84
Insert code to perform compatibility flagging for the "G"
format specifier.
***** End V10 Development *****
***** End Revision History *****
\
ENTRY %IFSET,%OFSET,%DEFMT
ENTRY %FMTSV,%FMTCL,%IFORM,%OFORM
EXTERN %FLIDX,%OBYTE,%IBYTE,%IBYTC,%SETAV ;[4146]
EXTERN %RIPOS,%ROPOS,%SIPOS,%SOPOS,%CIPOS,%COPOS,%MVBLK
EXTERN %ALPHI,%ALPHO,%DIRT,%DOUBT,%ERIN,%EOUT,%FLIRT,%FLOUT
EXTERN %LINT,%LOUT,%GRIN,%GROUT,%INTI,%INTO,%RIGHI,%RIGHO
EXTERN %GLINT,%GLOUT,%GINTI,%GINTO,%GOCTI,%GOCTO
EXTERN %OCTI,%OCTO,%HEXI,%HEXO,%SIZTB,%UNFXD
EXTERN %GTBLK,%FREBL,%SAVE4,%IBACK,%OVNUM,%OVPRG
EXTERN %ABORT,%POPJ,%POPJ1
EXTERN FMT.LS,%FAREA,%FTSLB,%SPFLG,%BZFLG,%SVFMT
EXTERN A.FMT,A.FMS
INTERN %SCLFC,USR.AD,USR.SZ,ENC.WD,ENC.W2,ENC.LR
INTERN FMT.BG,FMT.BP,FMT.SZ
INTERN %FWVAL,%DWVAL,%XPVAL
;ENCODED FORMAT BLOCK PARAMS
%FMTNX==0 ;NEXT ENCODED FORMAT ADDR
%FMTAD==1 ;ACTUAL ADDR OF FORMAT STATEMENT
%FMTOV==2 ;OVERLAY NUMBER
%FMTYP==3 ;FORMAT TYPE
%FMTRP==4 ;INDEFINITE REPEAT PNTR
%FMTEN==5 ;FIRST WORD OF ENCODED FORMAT
DATFLG==1,,0 ;DATA READ OR WRITTEN
FDFLG==2,,0 ;FORMAT DELIMITER
REGFLG==4,,0 ;REGISTER FORMAT CHARACTER
IGNFLG==10,,0 ;IGNORE CHARACTER
IOLFLG==20,,0 ;I/O LIST ENTRY NEEDED
SKPFLG==40,,0 ;CALL SFDEL AFTER FREE-FORMAT INPUT
CNCFLG==100,,0 ;COMPILE FORMAT IMMEDIATELY, NO WIDTH CHECK
DRFLG==FDFLG+REGFLG ;DELIMITER+REGISTER
DRIFLG==DRFLG+IOLFLG ;DELIMITER+REGISTER+I/O LIST ENTRY
DTIFLG==DATFLG+REGFLG+IOLFLG ;DATA+REGISTER+I/O LIST ENTRY
DTISFL==DTIFLG+SKPFLG ;DATA+REGISTER+I/O LIST ENTRY+CALL SFDEL
SEGMENT DATA
;FOR RECUSIVE I/O (I/O WITHIN I/O), THESE SHOULD BE
;DDB BLOCK VARIABLES - USED DURING EXECUTION
FMT.LK: BLOCK 1 ;PNTR TO ENCODED LEFT PAREN
%SCLFC: BLOCK 1 ;SCALE FACTOR
ENC.AD: BLOCK 1 ;ADDRESS OF CURRENT ENCODED FORMAT
ENC.PT: BLOCK 1 ;FORMAT LIST POINTER
ENC.LR: BLOCK 1 ;LOCAL REPEAT COUNT
;LOCAL VARIABLES - USED BY THE FORMAT ENCODER AND/OR AS TEMPS
;BY THE FORMAT EXECUTION
FMFRST: BLOCK 1 ;RELATIVE ADDR OF 1ST LEFT PAREN
FASIZE: BLOCK 1 ;FORMAT AREA SIZE
FMTSTA: BLOCK 1 ;ENCODING STATE
SAV.EF: BLOCK 1 ;ADDR OF LOC TO SAVE ADDR OF ENCODED FORMAT
RPT.PT: BLOCK 1 ;INDEFINITE REPEAT POINTER
FMT.BG: BLOCK 1 ;BYTE POINTER TO BEGINNING OF FORMAT
FMT.BP: BLOCK 1 ;FORMAT BYTE POINTER
FMT.IU: BLOCK 1 ;I/O LIST ENTRY USED FLAG
NUM.AD: BLOCK 1 ;DIGIT ACCUMULATOR PNTR
ENC.WD: BLOCK 2 ;ENCODED FORMAT WORDS
ENC.W2=ENC.WD+1
USR.AD: BLOCK 2 ;ACTUAL FORMAT ADDRESS, OVERLAY NUMBER
USR.OV=USR.AD+1 ;OVERLAY NUMBER
USR.SZ: BLOCK 1 ;SIZE OF FORMAT IN CHARACTERS
FMT.CC: BLOCK 1 ;CURRENT FORMAT CHAR
FMT.PC: BLOCK 1 ;PREVIOUS CHAR
FMT.SZ: BLOCK 1 ;SIZE OF FORMAT IN CHARS
FMT.DB: ;ENCODING DATABASE - CLEARED BY FMTINT
GTDGFL: BLOCK 1 ;GOT DIGIT FLAG
FMT.SG: BLOCK 1 ;SIGN
FMT.CH: BLOCK 1 ;FORMAT CHARACTER (SIXBIT)
;THE NEXT FOUR MUST BE IN ORDER, AS THEY ARE REFERENCED BY STATE TABLE
FMTACC:
FMT.RP: BLOCK 1 ;REPEAT COUNT
FMT.FW: BLOCK 1 ;FORMAT WIDTH
FMT.DW: BLOCK 1 ;DECIMAL WIDTH
FMT.EW: BLOCK 1 ;EXPONENT WIDTH
FMT.EN==.-1 ;END OF ENCODING DATABASE
;BROKEN-OUT FORMAT WIDTHS (GLOBAL)
%FWVAL: BLOCK 1 ;FIELD WIDTH
%DWVAL: BLOCK 1 ;DECIMAL WIDTH
%XPVAL: BLOCK 1 ;EXPONENT WIDTH
SEGMENT CODE
;BYTE POINTERS TO FORMAT ATTRIBUTES (WIDTH, DECIMAL WIDTH, ETC.)
W.PNTR:
WIDPNT: POINT 18,ENC.W2,35 ;TOTAL WIDTH OF FORMAT ELEMENT
FWMAX==777777
RPTPNT: POINT 18,ENC.WD,35 ;REPEAT COUNT
RPTMAX==777777
D.PNTR:
DECPNT: POINT 6,ENC.WD,11 ;DECIMAL WIDTH
DWMAX==77
X.PNTR:
EWPNT: POINT 4,ENC.WD,5 ;EXPONENT WIDTH
EWMAX==17 ;AVOID BIT 0 SO IT WON'T BE NEGATIVE
;AS NEGATIVE MEANS PAREN REPEAT
CODPNT: POINT 6,ENC.WD,17 ;FORMAT CODE (SIXBIT CHAR)
;THE FOLLOWING TABLE CONTAINS INFORMATION ON HOW TO TREAT
;EACH CHARACTER FOUND IN A FORMAT STATEMENT. THE
;TABLE IS ARRANGED SO THAT THE CHARACTER (TRANSLATED TO SIXBIT)
;CAN BE USED AS AN INDEX INTO THE TABLE. THE LEFT HALF OF EACH
;WORD CONTAINS THE FLAGS ASSOCIATED WITH THE CHARACTER (FOR INSTANCE,
;THE LEFT HALF OF THE ENTRY FOR 'A' HAS DTIFLG, WHICH IS A COMPOSITE
;OF FLAGS WHICH DIRECT THE FORMAT ENCODER TO REGISTER THE FORMAT,
;THAT IS, IT IS A "MAIN" FORMAT CHARACTER,
;AND THAT THIS FORMAT CHARACTER HAS AN ITEM OF DATA ASSOCIATED WITH IT).
;THE RIGHT HALF OF EACH ENTRY IS THE ADDRESS OF ANOTHER TABLE ENTRY
;WHICH CONTAINS THE ADDRESS OF ANY SPECIAL
;CODE TO EXECUTE FOR THE PROCESSING OF THE FORMAT CHARACTER.
FMT.CT: IGNFLG ;SPACE
0 ;!
0 ;"
0 ;#
DRFLG+DOLFMT ;$
0 ;%
0 ;&
DRFLG+SQFMT ;'
LPRFMT ;(
FDFLG+RPRFMT ;)
0 ;*
IGNFLG ;+
FDFLG ;COMMA
MINFMT ;-
PERFMT ;.
DRFLG+SLHFMT ;/
DIGFMT ;0
DIGFMT ;1
DIGFMT ;2
DIGFMT ;3
DIGFMT ;4
DIGFMT ;5
DIGFMT ;6
DIGFMT ;7
DIGFMT ;8
DIGFMT ;9
DRIFLG+CNCFLG ;:
0 ;;
0 ;<
0 ;=
0 ;>
0 ;?
0 ;@
DTIFLG+AFMT ;A
DRFLG+BFMT ;B
0 ;C
DTISFL+DFMT ;D
DTISFL+EFMT ;E
DTISFL+FFMT ;F
DTIFLG+GFMT ;G
REGFLG+HFMT ;H
DTISFL+IFMT ;I
0 ;J
0 ;K
DTISFL+LFMT ;L
0 ;M
0 ;N
DTISFL+OFMT ;O
REGFLG+PFMT ;P
DRIFLG+QFMT ;Q
DTISFL+RFMT ;R
DRFLG+SFMT ;S
DRFLG+TFMT ;T
0 ;U
0 ;V
0 ;W
REGFLG+XFMT ;X
0 ;Y
DTISFL+ZFMT ;Z
0 ;[
0 ;\
0 ;]
0 ;^
0 ;_
;THIS IS THE STATE TABLE. THERE ARE 4 STATES:
;
RPSTA==0 ;COLLECTING A REPEAT COUNT
FWSTA==1 ;COLLECTING A FORMAT WIDTH
DWSTA==2 ;COLLECTING A DECIMAL WIDTH
EWSTA==3 ;COLLECTING AN EXPONENT WIDTH
RPNOK==1
FWNOK==2
DWNOK==4
EWNOK==10
RPZOK==20
FWZOK==40
DWZOK==100
EWZOK==200
RPBOK==400
FWBOK==1000
DWBOK==2000
EWBOK==4000
STAMAX: RPTMAX
FWMAX
DWMAX
EWMAX
STANEG: RPNOK
FWNOK
DWNOK
EWNOK
STAZER: RPZOK
FWZOK
DWZOK
EWZOK
STABLK: RPBOK
FWBOK
DWBOK
EWBOK
STAERR: $ACALL IRC
$ACALL IFW
$ACALL IFW
$ACALL IFW
;THERE ARE TWO STEPS INVOLVED HERE, FORMAT ENCODING AND FORMAT
;EXECUTION. FORMAT ENCODING INVOLVES CODING EACH "MAIN" FORMAT
;CHARACTER (SUCH AS A,E,I, ETC.) INTO A WORD (OR 2) CONTAINING
;THE FORMAT WIDTH, REPEAT COUNT, DECIMAL WIDTH, ETC. THIS ENCODING
;IS DONE BECAUSE STRAIGHT INTERPRETIVE EXECUTION OF FORMAT
;STATEMENTS IS SLOW AND AWKWARD (ESPECIALLY WITH INDEFINITE REPEAT).
;ONCE A FORMAT STATEMENT IS ENCODED, THE ENCODED VERSION IS SAVED
;FOR LATER USE. THERE IS SOME OVERHEAD SEARCHING FOR THE
;ENCODED VERSION, BUT THIS IS CUT DOWN BY HAVING FMTN DIFFERENT LINKED
;LISTS WHERE IT CAN RESIDE. (DIVIDING BY FMTN GIVES
;WHICH LIST TO SEARCH). FORMATS IN ARRAYS ARE ALSO ENCODED, BUT
;UNDER NORMAL CIRCUMSTANCES THE ENCODED VERSIONS ARE NOT SAVED;
;THE USER MAY FORCE FOROTS TO KEEP THEM, HOWEVER, WITH
;A SPECIAL SUBROUTINE CALL (FMTSAV).
;IN ORDER TO FACILITATE THE PROCESSING OF PARENS IN THE FORMAT
;STATEMENT, THE CODE FOR PROCESSING IS FULLY RECURSIVE. A PAREN
;IS ENCODED WITH AN ASSOCIATED COUNT AND A LINK
;TO THE ENCODED ENTRIES AFTER THE ASSOCIATED RIGHT PAREN. A
;RIGHT PAREN IS ENCODED AS A ZERO ENTRY. THIS STRUCTURE FACILITATES
;A SIMPLE RECURSIVE PROCEDURE FOR EXECUTION OF THE FORMAT
;AND ALSO FACILITATES THE PROCESSING OF INDEFINITE REPEAT. ITS
;DISADVANTAGE IS THAT THE STACK LENGTH RESTRICTS THE NUMBER
;OF IMBEDDED PARENS.
;THERE ARE SEVERAL PATHOLOGICAL CASES OF INTEREST.
;IF THE USER SPECIFIES A FORMAT IN AN ARRAY, S/HE MAY LEAVE OFF
;ONE OR BOTH PARENS. IF THE LEFT PAREN IS MISSING, AND THERE ARE
;NO LEFT PARENS IN THE REST OF THE FORMAT STATEMENT, THE ENCODER
;WILL NEVER BE CALLED RECURSIVELY; WHETHER OR NOT THE FORMAT ENDS
;WITH A RIGHT PAREN, AN "END PAREN" ENTRY (A ZERO WORD) WILL
;BE PLACED AT THE END OF THE ENCODED FORMAT, AND WILL THUS
;EXECUTE CORRECTLY. IF THERE ARE LEFT PARENS IMBEDDED IN THE FORMAT,
;THE ENCODER WILL BE CALLED CORRECTLY, RECURSIVELY. THE ENCODER
;WILL CONTINUE BEYOND THE MATCHING RIGHT PARENS UNTIL IT ENCOUNTERS
;EITHER AN UNMATCHED RIGHT PAREN OR THE END OF THE FORMAT; IN THIS CASE
;IT WILL ALSO EXECUTE CORRECTLY, AS IF THERE HAD BEEN A BEGINNING
;LEFT PAREN.
;INDEFINITE REPEAT IS HANDLED BY SAVING A POINTER TO THE LAST ENCODED
;LEFT PAREN IN THE FORMAT STATEMENT MATCHING THE
;NEXT TO LAST RIGHT PAREN (WHICH MAY BE THE INITIAL LEFT
;LEFT PAREN, OR IMPLIED LEFT PAREN IF THE USER FORGOT IT...). THUS,
;IN ACCORDANCE WITH THE ANSI-66 AND ANSI-77 STANDARDS, THE LOOP
;USED IS THE ONE PRECEDING THE FINAL RIGHT PAREN, OR THE ENTIRE
;FORMAT STATEMENT IF THERE IS NO INTERNAL LOOP.
;AN ENCODED FORMAT IS AS FOLLOWS:
;
;WORD DESCRIPTION
;
; 0 ADDR OF NEXT ENCODED FORMAT IN THIS LIST
; 1 ADDR OR BYTE POINTER OF ACTUAL FORMAT
; 2 OVERLAY NUMBER
; 3 INDEFINITE REPEAT POINTER
; 4 ENCODED WORD 1
; 5 ENCODED WORD 2
; . .
; . .
;
;THERE ARE MANY SUCH LINKED LISTS OF ENCODED FORMATS, THE NUMBER
;DETERMINED BY THE FORPRM PARAMETER FMTN, WHICH SERVES AS A
;HASHING NUMBER - THE USER'S FORMAT ADDRESS IS DIVIDED BY THIS
;NUMBER, AND THE REMAINDER IS USED AS AN INDEX INTO THE ENCODED
;FORMAT LIST OF LISTS (FMT.LS). EACH ENTRY IN FMT.LS POINTS
;TO THE BEGINNING OF A LINKED LIST OF ENCODED FORMATS.
;
;PROVISION HAS BEEN MADE FOR THE USER TO SPECIFY THAT A FORMAT
;IN AN ARRAY SHOULD BE ENCODED AND STORED (UNDER NORMAL CIRCUMSTANCES
;THE ENCODED FORMAT FROM AN ARRAY IS THROWN AWAY). THIS FEATURE IS
;PROVIDED VIA TWO SPECIAL CALLS - FMTSAV & FMTCLR:
;
; CALL FMTSAV (array name, number of array elements)
;
; THIS CALL CALLS THE FORMAT ENCODER AND FORCES IT
; TO SAVE THE ENCODED FORMAT. IF THIS ROUTINE IS
; CALLED WITH AN ARRAY WHICH HAS ALREADY BEEN
; ENCODED, THE OLD ENCODING WILL BE THROWN AWAY
; AND A NEW ONE CREATED.
;
; CALL FMTCLR (array name)
;
; THIS CALL THROWS AWAY THE ENCODED FORMAT BY
; DEALLOCATING THE CORE AND RELINKING THE
; OTHER ENCODED FORMATS IN THE LIST.
;
;THE IMPLEMENTATION OF THESE SUBROUTINES MAKES IT NECESSARY TO
;SEARCH THE LISTS OF ENCODED FORMATS WHETHER OR NOT THE FORMAT IS
;IN AN ARRAY. HOWEVER, SINCE THE LISTS HAVE BEEN HASH-CODED, THIS
;SHOULD NOT SLOW PROCESSING SIGNIFICANTLY.
;%IFSET AND %OFSET ARE THE FORMAT CALLS FROM FOROTS. WE FIRST SEARCH FOR
;THE FORMAT IN THE LIST OF ENCODED FORMATS. IF IT EXISTS,
;WE GO ON TO FORMAT EXECUTION. OTHERWISE, WE ENCODE IT AND THEN
;EXECUTE IT.
%IFSET: XMOVEI T1,%IFORM ;SETUP FOR FORMAT EXECUTION
MOVEM T1,IOSUB(D)
XMOVEI T1,%SETAV ;SETUP FOR FIN CALL
MOVEM T1,IOFIN(D)
XMOVEI T1,DATIN ;SETUP FOR INPUT
MOVEM T1,DATENT
SETZM %BZFLG ;ASSUME BLANK=NULL
LOAD T1,BLNK(U) ;UNLESS SET OTHERWISE IN DDB
CAIN T1,BL.ZERO ;BLANK=ZERO?
SETOM %BZFLG ;YES. SET FLAG
JRST COMSET
%OFSET: XMOVEI T1,%OFORM ;SETUP FOR FORMAT EXECUTION
MOVEM T1,IOSUB(D)
XMOVEI T1,DATOUT ;SETUP FOR OUTPUT
MOVEM T1,DATENT
SETZM %SPFLG ;NO PLUS SIGN UNTIL FORMAT SAYS SO
SETZM %FTSLB ;ALLOW LEADING BLANKS ON OUTPUT
COMSET: MOVX T1,D%CLR ;CLEAR TEMP FLAGS
ANDCAM T1,FLAGS(D)
XMOVEI T1,@A.FMT ;GET ADDRESS OF FORMAT
SKIPE T2,%OVPRG ;OVERLAY PROGRAM?
PUSHJ P,%OVNUM ;YES. GET LINK NUMBER
DMOVEM T1,USR.AD ;SAVE THEM
LDB T2,[POINTR A.FMT,ARGTYP] ;GET ARG TYPE
MOVEM T2,T.FMT ;SAVE IT FOR LATER
CAIE T2,TP%CHR ;TYPE CHARACTER?
JRST FNCHR ;NO
SKIPN T3,A.FMS ;ANY SIZE SPECIFIED?
SKIPA T3,1(T1) ;NO. GET IT FROM DESCRIPTOR
MOVE T3,@T3 ;YES. GET IT
MOVEM T3,USR.SZ ;SAVE IT
MOVE T3,(T1) ;GET THE ACTUAL BP
MOVEM T3,FMT.BG ;SAVE IT
JRST GOTSIZ
FNCHR: SKIPN T3,A.FMS ;ANY SIZE SPECIFIED?
SKIPA T3,-1(T1) ;NO. GET IT FROM FORMAT ITSELF
MOVE T3,@T3 ;YES. GET IT
IMULI T3,5 ;GET # CHARS
MOVEM T3,USR.SZ ;SAVE IT
$BLDBP T1 ;Make 7-bit byte ptr.
MOVEM T1,FMT.BG ;SAVE IT
GOTSIZ: PUSHJ P,FMTSRH ;SEARCH FOR ENCODED FORMAT
MOVEM T1,ENC.AD ;SAVE THE ADDR FOUND
JUMPN T1,FMTEXC ;GO EXECUTE IF ALREADY ENCODED
PUSHJ P,FMTENC ;ENCODE THE FORMAT
SKIPN %SVFMT ;DID USER TELL US NOT TO SAVE FORMATS?
JRST FMTEXC ;YES. DON'T SAVE IT
MOVE T1,T.FMT ;GET FORMAT TYPE
CAIN T1,TP%LBL ;LABEL?
PUSHJ P,BLTFMT ;YES. SAVE IT SOMEWHERE
JRST FMTEXC ;EXECUTE IT
BLTFMT: XMOVEI T1,1(P4) ;GET TOP+1 OF ENCODED FORMAT
SUB T1,ENC.AD ;GET # WORDS IN IT
PUSHJ P,%GTBLK ;GET A BLOCK THAT SIZE
$ECALL MFU,%ABORT ;[4131] CAN'T
MOVEM T1,@SAV.EF ;SAVE ITS ADDRESS AND LINK IT
HRRI T2,(T1) ;PREPARE FOR MOVING IT
HRL T2,ENC.AD
XMOVEI P4,(P4) ;GET TOP, EXTENDED
SUB P4,ENC.AD ;GET # WORDS-1
ADDI P4,(T1) ;GET LAST ADDRESS
BLT T2,(P4) ;TRANSFER IT
POPJ P,
;ROUTINE TO DEALLOCATE ALL ENCODED FORMATS AND THE FORMAT ENCODING AREA.
%DEFMT: SKIPE T1,%FAREA ;IF WE ALLOCATED FORMAT ENCODING AREA
PUSHJ P,%FREBLK ;DEALLOCATE IT
XMOVEI T1,FMT.LS ;GET ADDRESS OF LINKED LISTS
MOVEM T1,FMTPTR ;SAVE FOR LOOP
MOVEI T1,FMTN ;GET COUNT
MOVEM T1,FMTCNT ;SAVE FOR LOOP
DFLP1: MOVE T1,@FMTPTR ;GET ADDRESS OF 1ST ENTRY
MOVEM T1,FMTADR ;SAVE IT
DFLP2: SKIPN T1,FMTADR ;GET ADDRESS OF ENTRY
JRST DFEN2 ;END OF LIST. GO TO NEXT ENTRY
MOVE T2,%FMTNX(T1) ;GET ADDRESS OF NEXT ENTRY
MOVEM T2,FMTADR ;SAVE IT
PUSHJ P,%FREBLK ;DEALLOCATE THE BLOCK
JRST DFLP2 ;LOOP UNTIL NONE LEFT IN THIS LIST
DFEN2: AOS FMTPTR ;INCREMENT LIST POINTER
SOSLE FMTCNT ;DECR COUNT
JRST DFLP1 ;LOOP
POPJ P,
%ADR==0 ;USER ARRAY ADDRESS
%SIZ==1 ;USER ARRAY SIZE (IN ARRAY ELEMENTS)
;THIS IS THE FAMOUS ARRAY FORMAT ENCODER. IT ALLOWS THE USER
;TO HAVE FOROTS SAVE AWAY THE ENCODED VERSION OF THE FORMAT IN AN ARRAY.
;IF IT HAS ALREADY BEEN ENCODED, THE OLD ENCODING IS THROWN AWAY
;AND THE NEW ONE IS INSERTED AT THE END OF THE APPROPRIATE LINKED
;ENCODED FORMAT LIST.
%FMTSV: XMOVEI T1,@%ADR(L) ;GET ARRAY ADDR
PUSHJ P,%OVNUM ;GET LINK NUMBER ALSO
DMOVEM T1,USR.AD ;SAVE THEM
LDB T2,[POINTR %ADR(L),ARGTYP];GET ARRAY TYPE
MOVEM T2,T.FMT ;SAVE FOR LATER
CAIE T2,TP%CHR ;TYPE CHARACTER?
JRST SVNCHR ;NO
MOVE T3,(T1) ;GET ACTUAL BYTE PNTR
MOVEM T3,USR.AD ;SAVE IT AS USER ADDRESS
HLRE T3,-1(L) ;GET ARG COUNT
AOJE T3,NOCSZ ;IF ONLY 1, NO ARRAY SIZE
SKIPN T3,@%SIZ(L) ;ANY SIZE SPECIFIED?
NOCSZ: SKIPA T3,1(T1) ;NO. GET IT FROM DESCRIPTOR
IMUL T3,1(T1) ;YES. MULTIPLY BY ENTRY SIZE
MOVEM T3,USR.SZ ;SAVE IT
MOVE T3,(T1) ;GET THE ACTUAL BP
MOVEM T3,FMT.BG ;SAVE IT
JRST SVGOT
SVNCHR: HLRE T3,-1(L) ;GET ARG COUNT
AOJE T3,%POPJ ;IF NONE, CALL IS A NOP
SKIPG T3,@%SIZ(L) ;ANY SIZE SPECIFIED?
POPJ P, ;ERROR SOMEDAY, NOP FOR NOW
IMUL T3,%SIZTB(T2) ;GET # WORDS
IMULI T3,5 ;GET # CHARS
MOVEM T3,USR.SZ ;SAVE IT
$BLDBP T1 ;Make 7-bit byte ptr.
MOVEM T1,FMT.BG ;SAVE IT
SVGOT: PUSHJ P,FMTSRH ;SEARCH FOR THE FORMAT
JUMPE T1,GOENC ;IF NOT FOUND, GO ENCODE IT
PUSHJ P,FMTDEL ;FOUND. DELETE IT
PUSHJ P,FMTSR1 ;SEARCH AGAIN
JUMPN T1,[$SNH] ;BETTER NOT BE THERE AGAIN!
GOENC: PUSHJ P,FMTENC ;ENCODE THE FORMAT
PJRST BLTFMT ;SAVE IT AWAY
;AND THIS IS THE FAMOUS ENCODED FORMAT DEALLOCATOR, WHICH
;IS HERE MAINLY FOR SYMMETRY (OR FOR THE USER WHO REALLY CARES
;ABOUT THE EXTRA FEW WORDS OF CORE ALLOCATED FOR THE ENCODED
;FORMAT).
%FMTCL: XMOVEI T1,@%ADR(L) ;GET ARRAY ADDR
PUSHJ P,%OVNUM ;AND OVERLAY NUMBER
LDB T3,[POINTR %ADR(L),ARGTYP] ;GET ARGUMENT TYPE
CAIN T3,TP%CHR ;CHARACTER?
MOVE T1,(T1) ;YES. GET ENTIRE BYTE POINTER
DMOVEM T1,USR.AD ;SAVE FOR SEARCH
PUSHJ P,FMTSRH ;SEARCH FOR THE FORMAT
JUMPE T1,%POPJ ;NOT FOUND. JUST LEAVE
; PJRST FMTDEL ;DELETE IT
;SUBROUTINE TO DELETE AN ENCODED FORMAT FROM A LINKED LIST.
;T1 POINTS TO THE ENCODED FORMAT TO BE DELETED, SAV.EF POINTS
;TO THE PREVIOUS ENCODED FORMAT.
FMTDEL: MOVE T2,(T1) ;GET ADDR OF NEXT FORMAT
MOVEM T2,@SAV.EF ;RELINK THE LIST
PJRST %FREBL ;FREE THE ALLOCATED CORE
;THIS IS THE FORMAT ENCODER SETUP. THE FORMAT IS ENCODED INTO A
;FIXED AREA OF MEMORY (%FAREA); WHEN THE FORMAT HAS BEEN SUCCESSFULLY
;ENCODED, IT IS MOVED TO AN AREA PRECISELY THE RIGHT SIZE.
;IF, DURING ENCODING, THE FIXED AREA DOES NOT HAVE ENOUGH ROOM,
;IT IS COPIED TO AN AREA TWICE AS LARGE AND THE OLD ONE IS
;DEALLOCATED.
FMTENC: SKIPE T1,%FAREA ;DO WE HAVE AN ENCODE AREA YET?
JRST GOTFA ;YES
MOVEI T1,IFMTSZ ;NO. GET ONE
MOVEM T1,FASIZE ;SAVE ITS SIZE
PUSHJ P,%GTBLK
$ECALL MFU,%ABORT ;[4131] CAN'T
MOVEM T1,%FAREA ;SAVE IT
GOTFA: MOVEM T1,ENC.AD ;SAVE IT
SETZM FMT.PC ;CLEAR PREV CHAR
MOVE T1,USR.SZ ;GET SIZE OF FORMAT STRING
MOVEM T1,FMT.SZ ;SAVE THE SIZE
MOVN P4,FASIZE ;GET NEG SIZE OF FORMAT AREA
HRLI P4,(P4) ;IN LEFT HALF
HRR P4,ENC.AD ;CREATE A FORMAT PNTR
SUBI P4,1 ;MAKE IT A PUSH PNTR
PUSH P4,[0] ;CLEAR "NEXT LINK" ADDR
PUSH P4,USR.AD ;SAVE THE ENCODED FORMAT ADDR
PUSH P4,USR.OV ;SAVE OVERLAY NUMBER
PUSH P4,T.FMT ;SAVE FORMAT TYPE
PUSH P4,[0] ;CLEAR INDEF RPT PNTR
XMOVEI T1,1(P4) ;GET RELATIVE ADDR OF 1ST ENCODED WORD
SUB T1,ENC.AD
MOVEM T1,FMT.LK ;SAVE IT
MOVEM T1,FMFRST ;AND AGAIN
MOVEM T1,RPT.PT ;INIT INDEF RPT PNTR
MOVE T1,FMT.BG ;GET FORMAT POINTER
MOVEM T1,FMT.BP ;Store ptr to beginning of format
PUSHJ P,FMTPRC ;PROCESS FORMAT
MOVE T1,ENC.AD ;GET BLOCK ADDR
MOVE T2,RPT.PT ;GET INDEF RPT PNTR
MOVEM T2,%FMTRP(T1) ;SAVE IT IN BLOCK
POPJ P,
;FMTINT - INITIALIZE THE FORMAT PARAMETERS. THE DIGIT COLLECTOR
;IS SET UP TO POINT TO THE REPEAT COUNT, THE SIGN IS
;SET TO +, AND THE TEMP FMT DATABASE IS CLEARED.
FMTINT: SETZM FMT.DB ;CLEAR 1ST DATABASE WORD
MOVE T1,[FMT.DB,,FMT.DB+1] ;CLEAR REST WITH BLT
BLT T1,FMT.EN
MOVEI T1,1 ;SET SIGN TO 1
MOVEM T1,FMT.SG
SETZM FMTSTA ;SET STATE TO "GETTING REPEAT"
SETZM ENC.WD ;CLEAR THE ENCODED WORDS
SETZM ENC.W2
POPJ P,
;FMTPRC - THIS IS THE FORMAT PROCESSOR OR ENCODER. EACH CHARACTER
;(OTHER THAN IN QUOTED STRINGS AND HOLLERITH CONSTANTS) ARE CONVERTED
;TO SIXBIT. THE RESULTING VALUE IS USED AS AN INDEX INTO A TABLE
;GIVING A SET OF FLAGS (LEFT HALF) AND POSSIBLY AN ADDRESS OF
;A WORD WHICH MAY HAVE THE ADDRESS OF A SPECIAL PROCESSING ROUTINE
;FOR THAT CHARACTER. FOR INSTANCE, THE TABLE ENTRY FOR LEFT PAREN
;HAS FDFLG IN THE LEFT HALF, WHICH INDICATES THAT ANY PREVIOUS DATA
;ENCOUNTERED SHOULD BE ENCODED INTO A FORMAT WORD AND REGISTERED INTO
;THE ENCODED FORMAT. IT HAS THE ADDRESS "RPRFMT" IN THE RIGHT HALF.
;"RPRFMT" IS THE OFFSET OF THE LEFT PAREN ENCODING SUBROUTINE - LPRENC.
;IF "REGFLG" IS ON IN THE LEFT HALF OF THE TABLE ENTRY, IT MEANS THAT
;THE CHARACTER IS A "MAIN" FORMAT CHARACTER, THAT IS, IT WILL EVENTUALLY
;BE ENCODED AS A WORD IN THE ENCODED FORMAT AFTER
;ITS WIDTH, DECIMAL WIDTH, EXPONENT WIDTH, AND REPEAT COUNT ARE COLLECTED.
FMTPRC: PUSHJ P,FMTINT ;INIT DATABASE
FMTLP: SKIPG FMT.SZ ;ANYTHING LEFT?
JRST REGRP ;NO. FAKE A RIGHT PAREN
PUSHJ P,GTFCHR ;GET A CHAR
JUMPE T1,FMTLP ;SKIP NULLS
PUSHJ P,SIXVRT ;CONVERT TO SIXBIT
MOVEI P1,(T1) ;COPY IT
MOVEM P1,FMT.CC ;SAVE AS CURRENT CHAR
SKIPN FMT.CT(P1) ;ANY STUFF?
$ACALL ILF ;ILLEGAL CHAR IN FORMAT
PUSHJ P,ETEST ;SPECIAL TEST FOR E-FORMAT
MOVE P3,FMT.CT(P1) ;GET FLAGS
TXNE P3,FDFLG ;DELIMITER?
PUSHJ P,FMTCMP ;YES. COMPILE PREV FORMAT
TXNN P3,REGFLG ;REGISTER THE CHAR?
JRST NOREG ;NO
SKIPE FMT.FW ;IS THE FORMAT WIDTH ZERO?
$ECALL ARC ;[2045] NO, AMBIGUOUS REPEAT COUNT
SKIPE FMT.CH ;ANY LEFTOVER FORMAT CHAR?
PUSHJ P,FMTCMP ;YES. COMPILE PREV FORMAT
MOVEM P1,FMT.CH ;SAVE THE CHAR AWAY
TXNN P3,FDFLG ;WAS IT A DELIMITER?
PUSHJ P,CHKWID ;NO. ACCUMULATE REPEAT, CHECK IT
AOS FMTSTA ;POINT TO COLLECTING FIELD WIDTH
SETZM GTDGFL ;CLEAR "GOT DIGIT" FLAG
NOREG: TXNN P3,CNCFLG ;WANT TO COMPILE IT NOW?
JRST NOCNC ;NO
PUSHJ P,FMTNC ;YES. GO COMPILE IT
JRST FMTLP ;BACK FOR MORE
NOCNC: HRRZ P3,FMT.CT(P1) ;GET TABLE ADDR
JUMPE P3,FMTLP ;BACK IF NO DISPATCHES
GOCNC: HRRZ T1,ENCTAB(P3) ;GET ADDR OF DISPATCH
JUMPE T1,FMTLP ;BACK IF NO ADDR
PUSHJ P,(T1) ;IF ADDR, DO IT
JRST FMTLP ;BACK FOR MORE
POPJ P, ;RECURSIVE RETURN
REGRP: PUSHJ P,FMTCMP ;COMPILE ANY INCOMPLETE FORMAT
PUSHJ P,RPRENC ;FAKE A RIGHT PAREN
JFCL ;ALWAYS SKIP RETURNS
POPJ P,
ETEST: CAIE P1,'E' ;IS IT AN 'E'?
POPJ P, ;NO. LEAVE
MOVE T2,FMT.CH ;GET THE FORMAT CHAR
CAIE T2,'D' ;YES. IS IT A "D"
CAIN T2,'E' ;OR AN 'E'?
JRST ASMEXW ;YES. SET FOR EXPONENT WIDTH
CAIE T2,'G' ;SAME FOR 'G'
POPJ P, ;NO. LEAVE
ASMEXW: PUSHJ P,CHKWID ;CHECK WIDTH
AOS T1,FMTSTA ;INCREMENT STATE
CAIE T1,EWSTA ;SHOULD NOW BE COLLECTING EXPONENT WIDTH
$ACALL IFW
SETZM GTDGFL ;CLEAR "GOT DIGIT" FLAG
EXPLP: SETZ P1, ;MAKE THE CHAR A SPACE
SKIPN FMT.SZ ;ANY CHARS LEFT?
JRST FMTCMP ;NO. COMPILE THE FORMAT
PUSHJ P,GTFCHR ;YES. GET ONE
PUSHJ P,SIXVRT ;CONVERT TO SIXBIT
MOVEI P1,(T1) ;COPY THE CHAR
CAIG P1,'9' ;IS IT A DIGIT?
CAIGE P1,'0'
JRST FMTCMP ;NO. GO USE AS NEXT CHAR
PUSHJ P,DIGENC ;YES. ACCUMULATE IT
JRST EXPLP ;AND GO BACK FOR MORE
;FMTSRH - SEARCHES FOR AN ENCODED FORMAT IN ONE OF THE
;LINKED LISTS (ADDR IN SAV.EF) MATCHING THE SPECIFIED
;USER'S FORMAT (ADDR IN USR.AD). RETURNS THE ADDR OF THE
;ENCODED FORMAT IN T1 IF FOUND, 0 IF NOT FOUND. ALSO, SAV.EF
;IS LEFT WITH THE ADDR OF THE FORMAT PREVIOUS TO
;ONE FOUND, OR THE ADDR OF THE LAST ENCODED FORMAT
;IN THE LINKED LIST, IF NOT FOUND. [NOTE: THE ORDER OF WHEN THE
;ADDRESS OF THE FORMAT IS SAVED IN SAV.EF (AFTER THE COMPARE
;AND EXIT) IS CRUCIAL FOR THE PROPER OPERATION OF FMTDEL,
;WHICH NEEDS THE ADDRESS PREVIOUS TO THE ONE MATCHED
;FOR RELINKING THE LIST.]
FMTSRH: MOVM T1,USR.AD ;GET FORMAT ADDR
IDIVI T1,FMTN ;HASH CODE...CHOOSE LIST
XMOVEI T1,FMT.LS(T2) ;GET ADDR OF PNTR TO BEG ENTRY
MOVEM T1,SAV.EF ;SAVE IT
FMTSR1: MOVE T1,SAV.EF ;GET ENC ADDR PNTR
DMOVE T2,USR.AD ;AND UNENCODED ADDR
FSLP1: SKIPN T1,%FMTNX(T1) ;GET NEXT ADDR, RETURN IF NO MORE
POPJ P,
CAMN T2,%FMTAD(T1) ;ADDRESSES EQUAL?
JRST CHKOV ;YES. GO CHECK OVERLAY NUMBER
MOVEM T1,SAV.EF ;NO. SAVE NEW ADDR
JRST FSLP1 ;AND TRY AGAIN
CHKOV: CAMN T3,%FMTOV(T1) ;OVERLAY NUMBERS EQUAL?
POPJ P, ;YES. MATCH
MOVEM T1,SAV.EF ;NO. SAVE NEW ADDR
JRST FSLP1 ;AND TRY AGAIN
;FORMAT COMPILATION - THROWS TOGETHER THE VARIOUS PARAMETERS
;ASSEMBLED SO FAR FOR A FORMAT CODE AND ASSEMBLES IT INTO
;AN ENCODED FORMAT WORD. SPECIAL HANDLING IS USED FOR THE
;CURRENT CHARACTER BEING "E" - THE ANSI-77 STANDARD
;ALLOWS THIS CHARACTER TO BE USED FOR BOTH E FORMAT AND
;FOR THE EXPONENT PART OF SCIENTIFIC NOTATION. THEREFORE
;IF THE CURRENT CHARACTER IS "E", WE CHECK IF THE FORMAT ABOUT
;TO BE COMPILED IS D,E,F OR G. IF SO, WE DEFER COMPILATION
;UNTIL COLLECTING THE EXPONENT WIDTH.
XENC: MOVEI T1,1 ;Incase "X" by itself
SKIPN FMT.RP
MOVEM T1,FMT.RP ;"X" = "1X" (DEC extension)
JRST FMTNC ;DON'T CHECK WIDTH AGAIN
FMTCMP: SKIPE T1,FMT.CH ;ANY FORMAT CHAR YET?
JRST FMTOK ;YES.
SKIPE FMT.RP ;NO. IS REPEAT COUNT ZERO?
$ACALL IRC ;NO. ILLEGAL REPEAT COUNT
POPJ P, ;YES. JUST IGNORE THE WHOLE THING
FMTOK: PUSHJ P,CHKWID ;CHECK ACCUMULATED WIDTH
FMTNC: SKIPE T1,FMT.FW ;GET FORMAT WIDTH
DPB T1,WIDPNT ;RECORD IT
SKIPE T1,FMT.DW ;GET DECIMAL WIDTH
DPB T1,DECPNT
SKIPE T1,FMT.EW ;AND EXPONENT WIDTH
DPB T1,EWPNT
SKIPE T1,FMT.RP ;AND REPEAT COUNT
DPB T1,RPTPNT
MOVE T1,FMT.CH ;AND FORMAT CODE
DPB T1,CODPNT
PUSH P4,ENC.WD ;STORE WORDS ON STACK
PUSH P4,ENC.W2
PUSHJ P,STKCHK ;CHECK IF ENOUGH ROOM ON THE STACK
JRST FMTINT ;INITIALIZE THE DATABASE
;HERE WE HAVE RUN OUT OF ROOM IN THE CURRENTLY ASSIGNED FORMAT
;ENCODING AREA. SO WE CALL %MVBLK TO ALLOCATE A NEW ONE TWICE
;AS LARGE, MOVE THE DATA OVER, SET THE PUSH PNTR (P4) APPROPRIATELY,
;AND TOSS THE OLD AREA.
STKCHK: CAMG P4,[-4,,0] ;LEAVE AT LEAST 4
POPJ P, ;THAT'S ENOUGH FOR NOW
MOVE T1,%FAREA ;GET THE OLD ADDR
MOVE T2,FASIZE ;GET THE OLD SIZE
MOVEI T3,(T2) ;COPY IT
LSH T3,1 ;DOUBLE IT
PUSHJ P,%MVBLK ;GET NEW ONE, BLT, TOSS OLD ONE
$ECALL MFU,%ABORT ;[4131] CAN'T
MOVEM T1,ENC.AD ;SAVE FOR CURRENT ENCODING
EXCH T1,%FAREA ;SAVE NEW ADDR, GET OLD ONE
SUB T1,%FAREA ;GET OLD-NEW
SUB P4,T1 ;FIXUP RH OF PUSH PNTR
EXCH T3,FASIZE ;SAVE NEW SIZE, GET OLD SIZE
SUB T3,FASIZE ;GET OLD-NEW
HRLZI T3,(T3) ;IN LEFT HALF
ADD P4,T3 ;FIXUP LH OF PUSH PNTR
POPJ P,
CHKWID: MOVE T1,FMT.CH ;GET THE FORMAT CHARACTER
HRRZ T1,FMT.CT(T1) ;GET FORMAT INDEX
MOVE T1,CHKTAB(T1) ;GET THE FLAG CHECK TABLE
MOVE T2,FMTSTA ;GET THE CURRENT STATE
SKIPL T3,FMT.SG ;ANY SIGN?
JRST NCKNEG ;NO. DON'T CHECK NEGATIVE LEGAL
IMULM T3,FMTACC(T2) ;ACCUMULATE IT
TDNN T1,STANEG(T2) ;CHECK IF NEGATIVE OK
JRST STAERR(T2)
NCKNEG: MOVM T3,FMTACC(T2) ;GET THE ACCUMULATED WIDTH
CAMLE T3,STAMAX(T2) ;WITHIN RANGE?
JRST STAERR(T2) ;NO
JUMPN T3,%POPJ ;NON-ZERO NEEDS NO MORE CHECKING
SKIPN GTDGFL ;ZERO. DID WE GET ANY DIGITS?
JRST CKBLNK ;NO. GO CHECK IF BLANK IS OK
TDNN T1,STAZER(T2) ;CHECK IF ZERO OK
JRST STAERR(T2) ;N.G.
POPJ P,
CKBLNK: TDNN T1,STABLK(T2) ;IS BLANK OK?
JRST STAERR(T2) ;NO
POPJ P,
;SIXVRT - CONVERTS ASCII CHARACTERS FROM THE FORMAT STATEMENT
;TO SIXBIT.
SIXVRT: CAILE T1,140 ;LOWER CASE?
SUBI T1,40 ;YES. CONVERT TO UPPER
SUBI T1,40 ;CONVERT TO SIXBIT
JUMPG T1,%POPJ ;OK
SETZ T1, ;NEGATIVE - TREAT AS SPACE
POPJ P,
;RIGHT PAREN ENCODER - A RIGHT PAREN IS TRANSLATED INTO A ZERO
;WORD DROPPED ONTO THE STACK, FOLLOWED BY THE
;RELATIVE ADDRESS OF THE MATCHING LEFT PAREN.
;SINCE THE FORMAT ENCODER IS RECURSIVE,
;THE RETURN FROM THIS SUBROUTINE IS ALWAYS A SKIP RETURN TO SPECIFY
;A RECURSIVE RETURN
RPRENC: PUSH P4,[0] ;DROP A ZERO ON THE STACK
PUSH P4,FMT.LK ;AND ADDR OF CURRENT LEFT PAREN
PJRST %POPJ1 ;AND SKIP RETURN
;THIS ROUTINE IS CALLED BY I,O, AND Z FORMATS. THE ANSI STANDARD
;SPECIFIES THAT A FORMAT SUCH AS "I5.0" MEANS THAT NO DIGITS ARE
;PRINTED IF THE VALUE OF THE VARIABLE IS ZERO. THE DEFAULT FOR
;A FORMAT SUCH AS "I5" IS AT LEAST ONE DIGIT PRINTED. THUS THIS
;ROUTINE MUST BE CALLED TO SET THE DEFAULT NUMBER OF CHARACTERS
;PRINTED TO 1; WHEN A PERIOD IS ENCOUNTERED IT IS RESET TO ZERO
;TO PROPERLY COLLECT THE DIGITS.
MENC: MOVEI T1,1 ;SET DEFAULT FOR I,O,Z TO 1
MOVEM T1,FMT.DW ;FOR DECIMAL WIDTH
POPJ P,
;PERIOD ENCODING - UPON ENCOUNTERING A PERIOD, THE DECIMAL WIDTH
;(POSSIBLY SET TO NON-ZERO DEFAULT) IS CLEARED, AND THE DIGIT
;COLLECTER IS SET TO POINT TO THE DECIMAL WIDTH
PERENC: PUSHJ P,CHKWID ;CHECK ACCUMULATED WIDTH
AOS T1,FMTSTA ;INCREMENT STATE
CAIE T1,DWSTA ;SHOULD BE NOW COLLECTING DECIMAL WIDTH
$ACALL IFW ;NOT. BAD FORMAT
SETZM GTDGFL ;CLEAR "GOT DIGIT" FLAG
SETZM FMT.DW ;CLEAR PREVIOUS (DEFAULT) DEC WID
POPJ P,
;DIGENC - THE DIGIT ENCODER. NUM.AD POINTS TO THE CURRENT
;DIGIT COLLECTOR.
DIGENC: MOVE T2,FMTSTA ;GET CURRENT STATE
MOVE T1,FMTACC(T2) ;GET ACC NUM
CAML T1,[^D1000000000] ;[3426] PREVENT OVERFLOW
JRST STAERR(T2) ;[3426] GIVE ILLEGAL WIDTH MESSAGE
IMULI T1,12 ;MUL BY 10
ADDI T1,-20(P1) ;ADD IT IN
MOVEM T1,FMTACC(T2) ;SAVE IT AGAIN
SETOM GTDGFL ;SET "GOT DIGIT" FLAG
POPJ P,
;LPRENC - THE LEFT PAREN ENCODER. A LEFT PAREN IS
;ENCODED AS A WORD CONTAINING THE NEGATIVE OF ITS REPEAT COUNT,
;AND A ZERO WORD. THE LEFT PAREN
;INITIATES A RECURSIVE CALL TO THE FORMAT ENCODER, AND THE LINK
;IS ESTABLISHED AFTER THE RETURN FROM THIS RECURSIVE CALL.
;UPON RETURNING, WE MUST DO SOMETHING WHICH LOOKS RATHER CURIOUS - WE SAVE
;THE CURRENT LINK (THAT IS, LEFT PAREN) POINTER IN THE INDEFINITE REPEAT
;POINTER, UNLESS WE ARE AT THE TOP LEVEL. THIS HAS THE EFFECT OF POINTING
;TO THE LEFT PAREN WHICH MATCHES THE NEXT TO LAST RIGHT PAREN (WE AVOID
;RESETTING IT TO THE OUTERMOST PAREN (THE INITIAL SETTING) BY NOT SAVING
;THE NO-LINK ENTRY.
;IF, AFTER RETURNING, THE SAVED FORMAT LIST ADDRESS IS THE
;BEGINNING OF THE FORMAT LIST, WE HAVE REACHED THE END OF
;THE FORMAT, SO THE LINK IS SET TO ZERO. IN THIS CASE,
;WE ALSO SKIP RETURN, TO INDICATE A RECURSIVE
;RETURN, AND THUS THE END OF ENCODING.
LPRENC: SKIPE T1,FMT.CH ;ANY PREVIOUS FORMAT CHARACTER?
PUSHJ P,FMTCMP ;YES. PROCESS IT
PUSH P,FMT.LK ;SAVE ADDR OF CURRENT LEFT PAREN
XMOVEI T1,1(P4) ;GET REL ADDR OF PAREN WORD
SUB T1,ENC.AD
MOVEM T1,FMT.LK ;SAVE IT
SKIPN T1,FMT.RP ;GET LATEST REPEAT COUNT
MOVEI T1,1 ;ASSUME COUNT OF 1 IF 0
MOVN T1,T1 ;NEGATE IT
PUSH P4,T1 ;SAVE ON STACK
PUSH P4,[0] ;PUT A ZERO WORD ON THE STACK ALSO
PUSHJ P,STKCHK ;CHECK IF ENOUGH ROOM ON THE STACK
PUSHJ P,FMTPRC ;RECURSIVE CALL
MOVE T1,FMT.LK ;GET CURRENT LEFT PAREN ADDR
POP P,FMT.LK ;RESTORE PREVIOUS LEFT PAREN ADDR
CAMN T1,FMFRST ;IF LINK ADDR IS START ADDR
JRST %POPJ1 ;WE'RE DONE
MOVEM T1,RPT.PT ;SAVE LOOP ADDR FOR INDEF RPT
POPJ P,
;BENC - THE B FORMAT ENCODER - BN FORMAT IS ENCODED AS A 'B' FOR
;THE FORMAT CHARACTER AND "N" FOR THE WIDTH. BZ IS ENCODED WITH
;A "Z" FOR THE FORMAT WIDTH.
BENC: PUSHJ P,GTFCHR ;GET FORMAT CHAR
CAIE T1,"N" ;N OR Z?
CAIN T1,"Z"
JRST GOTNZ ;YES, OK
$ACALL ILF ;ILLEGAL CHAR IN FORMAT
GOTNZ: MOVEM T1,FMT.FW ;SAVE AS WIDTH FIELD
PJRST FMTNC ;COMPILE IT
;A MINUS IN THE FORMAT MERELY NEGATES THE SIGN.
MINENC: MOVNS T1,FMT.SG ;NEGATE THE SIGN
JUMPL T1,%POPJ ;OK IF NOW NEGATIVE
$ACALL ILF ;ILLEGAL IF NOW POSITIVE
;SENC - FOR S,SS, &SP FORMATS. AN "S" OR "P" ARE ENCODED
;INTO THE WIDTH POSITION OF THE FORMAT WORD.
SENC: PUSHJ P,GTFCHR ;GET A FORMAT CHAR
CAIE T1,"S" ;IS IT AN S
CAIN T1,"P" ;IS IT A P
JRST MATPS ;YES
MOVEM T1,FMT.PC ;NO. SAVE AS PREVIOUS CHAR
MOVEI T1,"S" ;DEFAULT IS AN S
MATPS: MOVEM T1,FMT.FW ;SAVE AS WIDTH
PJRST FMTNC ;COMPILE IT
;HOLLERITH ENCODING - WE ARE ALLOWING ANY CHARACTERS WHATSOEVER
;IN HOLLERITH AND QUOTED STRINGS, SO WE USE THE ACTUAL BYTE
;PNTR INTO THE FORMAT STATEMENT TO RETRIEVE THE CHARS RATHER
;THAN THE SUBROUTINE GTFCHR. THE FORMAT WORD IS COMPILED AND THE
;BYTE POINTER IS SAVED AS A SECOND WORD IN THE FORMAT LIST.
HENC: SKIPG T1,FMT.RP ;GET THE REPEAT COUNT
; IOERR (IHC,,,?,Illegal Hollerith constant,,%ABORT)
$ACALL IHC
CAMLE T1,FMT.SZ ;BEYOND THE FORMAT SIZE?
MOVE T1,FMT.SZ ;YES. FOR NOW, TRUNCATE IT
MOVNI T2,(T1) ;GET NEGATIVE
ADDM T2,FMT.SZ ;DECREMENT THE LEFTOVER SIZE
ADJBP T1,FMT.BP ;CREATE NEW BYTE POINTER
EXCH T1,FMT.BP ;POINTING AFTER THE CONSTANT
MOVEM T1,ENC.W2 ;SAVE THE OLD ONE
PJRST FMTNC ;COMPILE THE FORMAT
;SIMILAR TO HOLLERITH. IF A SINGLE QUOTE IS NOT
;FOLLOWED BY ANOTHER, IT IS THE END OF THE QUOTED STRING;
;HOWEVER, WE HAVE ALREADY RETRIEVED THE CHARACTER, SO WE HAVE TO
;SAVE IT FOR LATER.
SQENC: SETZM FMT.RP ;CLEAR REPEAT COUNT
MOVE T1,FMT.BP ;GET THE BYTE PNTR
MOVEM T1,ENC.W2 ;SAVE FOR ENCODING
SQLP1: SOSGE FMT.SZ ;ANY CHARS LEFT?
JRST SQEDON ;NO. CLOSE THE QUOTE
ILDB T1,FMT.BP ;NON-CHECKING SCAN
CAIE T1,"'" ;SINGLE QUOTE?
JRST NOTSQ ;NOPE
SOSGE FMT.SZ ;ANY CHARS LEFT?
JRST SQEDON ;NO. CLOSE THE QUOTE
ILDB T1,FMT.BP ;GET THE NEXT CHAR
CAIE T1,"'" ;ANOTHER QUOTE?
JRST SQEDON ;NO. STOP
AOS FMT.RP ;YES. COUNT BOTH OF THEM
NOTSQ: AOS FMT.RP ;NO. INCR THE COUNT
JRST SQLP1 ;AND TRY FOR MORE
SQEDON: MOVEM T1,FMT.PC ;NO. SAVE AS PREVIOUS CHAR
PJRST FMTNC ;COMPILE THE FORMAT
;T FORMAT - THE ANSI STANDARD HAS CREATED 2 MORE CONFUSING FORMATS -
;TR AND TL (TAB RIGHT AND TAB LEFT). SINCE WE ONLY HAVE A SIXBIT
;CHARACTER POSITION FOR THE FORMAT CHAR, WE STORE THE "R" OR "L"
;IN THE DECIMAL WIDTH PORTION OF THE FORMAT WORD.
TENC: PUSHJ P,GTFCHR ;GET NEXT CHAR
CAIE T1,"L" ;L OR R
CAIN T1,"R"
JRST GOTLR ;YES
MOVEM T1,FMT.PC ;NO. SAVE THE CHAR FOR LATER
POPJ P,
GOTLR: PUSHJ P,SIXVRT ;CONVERT TO SIXBIT
MOVEM T1,FMT.DW ;SAVE AS DECIMAL WIDTH
POPJ P,
;THIS IS THE LIST OF EXECUTION/ENCODING ADDRESSES.
;THERE ARE 6 TABLES OF ADDRESSES OR TRANSFER VECTORS.
;THE FIRST ENTRY IN EACH ENTRY OF FMTTAB IS THE OFFSET INTO
;EACH TABLE FOR THAT FORMAT. THE SECOND IS THE INPUT EXECUTION
;ADDRESS, THE THIRD IS THE OUTPUT EXECUTION ADDRESS, AND THE FOURTH
;IS THE ENCODING ADDRESS. THE FIFTH IS A MASK
;WHICH IS USED TO CHECK THE FORMAT AGAINST THE VARIABLE
;TYPE FOR A MISMATCH. THE SIXTH IS A RANGE CHECK FLAG WORD.
;THE WARNING MASK IS ASSEMBLED AS FOLLOWS: BIT 0 REPRESENTS VARIABLE
;TYPE 0 (UNKNOWN), BIT 1 REPRESENTS TYPE 1 (LOGICAL), ETC. THE BIT
;IS SET IF THE VARIABLE TYPE CONFLICTS WITH THE FORMAT IN QUESTION.
;FOR EXAMPLE, F-FORMAT CONFLICTS WITH
;INTEGER (2), DOUBLE INTEGER (11), AND CHARACTER (15).
FWARN==1B<TP%INT>+1B<TP%DPI>+1B<TP%CHR>+1B<TP%LIT>
IWARN==1B<TP%SPR>+1B<TP%DPR>+1B<TP%DPX>+1B<TP%CPX>+1B<TP%CHR>+1B<TP%LIT>
QWARN==IWARN
OWARN==1B<TP%CHR>+1B<TP%LIT> ;[3457]
;THE RANGE CHECKING FLAG WORD CONTAINS ONE OF 12 BITS, 3 EACH
;OF 4 STATES (REPEAT COUNT, FORMAT WIDTH, DECIMAL WIDTH
;EXPONENT WIDTH) TO CHECK FOR NEGATIVE OK, ZERO OK, AND
;NO DIGITS SPECIFIED OK.
REFLAG==RPBOK+FWBOK+DWZOK+DWBOK
AFLAG==RPBOK+FWBOK
PFLAG==RPZOK+RPNOK
XFLAG==RPBOK
DEFINE FMTTAB
<
FMTENT (JNKFMT,NOEXEC,NOEXEC,0)
FMTENT (SLHFMT,@IOREC(D),@IOREC(D),FMTNC)
FMTENT (DOLFMT,NOCR,NOCR,FMTNC)
FMTENT (MINFMT,NOEXEC,NOEXEC,MINENC)
FMTENT (DIGFMT,NOEXEC,NOEXEC,DIGENC)
FMTENT (LPRFMT,NOEXEC,NOEXEC,LPRENC)
FMTENT (RPRFMT,NOEXEC,NOEXEC,RPRENC)
FMTENT (PERFMT,NOEXEC,NOEXEC,PERENC)
FMTENT (SQFMT,SQIN,SQOUT,SQENC)
FMTENT (AFMT,%ALPHI,%ALPHO,0,0,AFLAG)
FMTENT (BFMT,BNZ,BNZ,BENC)
FMTENT (DFMT,%DIRT,%DOUBT,0,FWARN,REFLAG)
FMTENT (EFMT,%ERIN,%EOUT,0,FWARN,REFLAG)
FMTENT (FFMT,%FLIRT,%FLOUT,0,FWARN,REFLAG)
FMTENT (GFMT,GIN,GOUT,0,0,REFLAG)
FMTENT (HFMT,HIN,HOUT,HENC)
FMTENT (IFMT,%INTI,%INTO,MENC,IWARN,REFLAG)
FMTENT (LFMT,%LINT,%LOUT,0,0,REFLAG)
FMTENT (OFMT,%OCTI,%OCTO,0,OWARN,REFLAG) ;[3457]
FMTENT (PFMT,PFACT,PFACT,FMTNC,0,PFLAG)
FMTENT (QFMT,QIN,QOUT,FMTNC,QWARN)
FMTENT (RFMT,%RIGHI,%RIGHO,0,0,REFLAG)
FMTENT (SFMT,SSP,SSP,SENC)
FMTENT (TFMT,TIN,TOUT,TENC)
FMTENT (XFMT,XIN,XOUT,XENC,0,XFLAG)
FMTENT (ZFMT,%HEXI,%HEXO,0,0,REFLAG)
GENT (GNONE,%GINTI,%GINTO,0) ;NO TYPE GIVEN
GENT (GLOGIC,%GLINT,%GLOUT,0) ;LOGICAL
GENT (GINTEG,%GINTI,%GINTO,0) ;INTEGER
GENT (G3,NOEXEC,NOEXEC,0) ;UNDEFINED
GENT (GREAL,%GRIN,%GROUT,0) ;REAL
GENT (G5,NOEXEC,NOEXEC,0) ;UNDEFINED
GENT (GOCTAL,%GOCTI,%GOCTO,0) ;OCTAL
GENT (GLABEL,NOEXEC,NOEXEC,0) ;LABEL
GENT (GDREAL,%GRIN,%GROUT,0) ;DOUBLE REAL
GENT (GDINT,%GINTI,%GINTO,0) ;DOUBLE INTEGER
GENT (GDOCT,%OCTI,%OCTO,0) ;DOUBLE OCTAL
GENT (GDGFL,%GRIN,%GROUT,0) ;EXTENDED DOUBLE REAL
GENT (GCPX,%GRIN,%GROUT,0) ;COMPLEX
GENT (GALPHA,%ALPHI,%ALPHO,0) ;FORTRAN CHARACTER
GENT (G16,NOEXEC,NOEXEC,0) ;BASIC STRING
GENT (G17,NOEXEC,NOEXEC,0) ;ASCIZ
>
FMTN==0
DEFINE FMTENT(A,B,C,D,E,F)
<A==FMTN
FMTN==FMTN+1>
DEFINE GENT(A,B,C,D,E,F)
<A==FMTN
FMTN==FMTN+1>
FMTTAB
DEFINE FMTENT(A,B,C,D,E,F)
<IFIW B>
DEFINE GENT(A,B,C,D,E,F)
<IFIW B>
INTAB: FMTTAB
DEFINE FMTENT(A,B,C,D,E,F)
<IFIW C>
DEFINE GENT(A,B,C,D,E,F)
<IFIW C>
OUTAB: FMTTAB
DEFINE FMTENT(A,B,C,D,E,F)
<D>
DEFINE GENT(A,B,C,D,E,F)
<>
ENCTAB: FMTTAB
DEFINE FMTENT(A,B,C,D,E,F)
< IFNB <E>,<E>
IFB <E>,<0>
>
DEFINE GENT(A,B,C,D,E,F)
<>
WRNTAB: FMTTAB
DEFINE FMTENT(A,B,C,D,E,F)
< IFNB <F>,<F>
IFB <F>,<0>
>
DEFINE GENT(A,B,C,D,E,F)
<>
CHKTAB: FMTTAB
;G-FORMAT CONVERSION ROUTINE ADDRESS TABLE.
;LH=INPUT, RH=OUTPUT
GTAB: SKPFLG+GNONE ;NO TYPE GIVEN
SKPFLG+GLOGIC ;LOGICAL
SKPFLG+GINTEG ;INTEGER
G3 ;UNDEFINED
SKPFLG+GREAL ;REAL
G5 ;UNDEFINED
SKPFLG+GOCTAL ;OCTAL
GLABEL ;LABEL
SKPFLG+GDREAL ;DOUBLE REAL
SKPFLG+GDINT ;DOUBLE INTEGER
SKPFLG+GDOCT ;DOUBLE OCTAL
SKPFLG+GDGFL ;EXTENDED DOUBLE REAL
SKPFLG+GCPX ;COMPLEX
GALPHA ;FORTRAN CHARACTER
G16 ;BASIC STRING
G17 ;ASCIZ
NOEXEC: $ACALL UDT ;UNDEFINED DATA TYPE
;EXEPRC - THE ENCODED FORMAT EXECUTIONER (SIMILAR TO
;LORD HIGH EXECUTIONER). THIS IS A TOTALLY RECURSIVE EXECUTION SEQUENCE.
;STARTING AT THE GIVEN FORMAT LIST POINTER, ENCODED WORDS ARE
;LOADED, AND DEPENDING ON THE FORMAT CODE, A DATA ITEM MAY BE RETRIEVED,
;AND THEN THE PROPER SUBROUTINE IS CALLED. A LEFT PAREN IS ENCODED AS
;AS A NEGATIVE WORD (NEGATIVE REPEAT COUNT),
;AND A WORD RESERVED FOR THE CURRENT (UPDATED) REPEAT COUNT.
;A RIGHT PAREN IS ENCODED AS A ZERO WORD FOLLOWED BY ITS
;RESPECTIVE LEFT PAREN RELATIVE ADDRESS. THUS THE LAST RIGHT PAREN HAS THE
;RELATIVE BEGINNING OF THE ENCODED FORMAT (%FMTEN) AS ITS 2ND
;WORD. WHEN A NEGATIVE ENTRY (AN ENCODED LEFT PAREN)
;IS ENCOUNTERED, THE EXECUTION SEQUENCE IS CALLED RECURSIVELY.
FMTEXC: SETZM %SCLFC ;CLEAR SCALE FACTOR
SETZM FMT.IU ;CLEAR I/O LIST USED FLAG
SETZM IO.ADR ;WE HAVE NO I/O ADDR YET!
MOVE T1,ENC.AD ;GET ENCODED FORMAT ADDR
ADDI T1,%FMTEN ;POINT TO 1ST FMT WORD
MOVEM T1,ENC.PT ;SAVE IN LIST PNTR
EXEPRC: DMOVE T1,@ENC.PT ;GET FORMAT ENTRY
JUMPG T1,EXENRM ;NORMAL EXECUTION
JUMPE T1,EXENLP ;HIT END OF LIST
MOVEI T2,2 ;INCR TO NEXT ITEM
ADDB T2,ENC.PT
MOVMM T1,-1(T2) ;SAVE POSITIVE REPEAT COUNT
JRST EXEPRC ;GO ON
;T2 NOW HAS THE RELATIVE ADDRESS OF THE LEFT PAREN
EXENLP: CAIN T2,%FMTEN ;END OF FORMAT?
JRST EXEND ;YES.
ADD T2,ENC.AD ;NO. GET ADDRESS OF LEFT PAREN
SOSG 1(T2) ;DECR REPEAT COUNT
MOVE T2,ENC.PT ;EXHAUSTED. GET CURRENT ADDRESS
ADDI T2,2 ;POINT TO NEXT ITEM
MOVEM T2,ENC.PT ;SAVE POINTER
JRST EXEPRC ;START AGAIN
EXEND: SETZM IO.ENT ;SET NO FORMAT
SKIPN IO.ADR ;YES. I/O ADDR ALREADY?
POPJ P, ;NO. GO GET ONE OR NEVER RETURN
EXRPT: SKIPN FMT.IU ;DATA USED BY LAST SCAN?
$ACALL DLF ;Data in IO list but not in format
MOVEI T1,SLHFMT ;EXECUTE EOL FOR EACH REPEAT
MOVEM T1,IO.ENT
PUSHJ P,@DATENT ;READ OR WRITE A RECORD
MOVE T1,ENC.AD ;GET ENCODED FORMAT ADDR
MOVE T2,%FMTRP(T1) ;GET INDEF RPT PNTR
ADD T2,ENC.AD ;MAKE RELATIVE ABSOLUTE
MOVEM T2,ENC.PT ;FOR FORMAT LIST POINTER
SETZM FMT.IU ;CLEAR I/O LIST ENTRY USED FLAG
JRST EXEPRC ;BACK TO LOOP
EXENRM: DMOVEM T1,ENC.WD ;SAVE FOR CODE RETRIEVAL
LDB T1,CODPNT ;GET FORMAT CHAR
MOVE T1,FMT.CT(T1) ;GET TABLE ENTRY
MOVEM T1,IO.ENT ;Save flags and table entry for later
TXNN T1,IOLFLG ;DO WE NEED I/O LIST ENTRY?
JRST NODATA ;NO. GO DO INPUT OR OUTPUT
LDB T1,RPTPNT ;GET NEW REPEAT COUNT
MOVEM T1,ENC.LR ;SAVE IT
DATLP: SKIPN IO.ADR ;DO WE HAVE ADDR ALREADY?
POPJ P, ;LEAVE TO GET I/O ADDR!
;ENTER HERE FROM IOLST CALL WITH I/O ADDRESS IN IO.ADR
EXENT: HRRZ T1,IO.ENT ;GET FORMAT INDEX
JUMPE T1,NXTFMT ;IF NO FORMAT, GO GET ONE
SETOM FMT.IU ;SET I/O LIST ENTRY USED FLAG
SKIPN T2,WRNTAB(T1) ;ANY FATAL OR WARNING TYPE MISMATCH?
JRST FVOK ;NO. ANYTHING GOES
MOVE T3,IO.TYP ;GET DATA TYPE
LSH T2,(T3) ;MOVE THE WARNING BITS
JUMPGE T2,FVOK ;NG IF BIT 0 = 1
CAIN T3,TP%CHR ;BUT TYPE CHAR CONFLICTS ARE FATAL
$ACALL FVF ;FORMAT/VARIABLE MISMATCH FATAL
$ECALL FVM ;ISSUE WARNING
FVOK:
DATLP1: PUSHJ P,@DATENT ;GO DO INPUT OR OUTPUT
SKIPN T1,IO.INC ;ADD OFFSET TO I/O ADDR
JRST NOINC ;NO INCREMENT
XCT IO.INS ;DO THE INCREMENT INSTRUCTION
MOVEM T1,IO.ADR ;SAVE NEW PNTR
NOINC: SOSG ENC.LR ;DECR LOCAL REPEAT COUNT
JRST NEWFMT ;GO ON TO NEXT FMT, BUT DECR IO.NUM
SOSLE IO.NUM ;DECR LOCAL DATA COUNT
JRST DATLP1 ;STILL SOME DATA
POPJ P, ;NO MORE. LEAVE TO GET MORE
NEWFMT: SOSG IO.NUM ;DECR LOCAL DATA COUNT
SETZM IO.ADR ;CLEAR I/O ADDR IF NONE LEFT
MOVEI T1,2 ;ON TO NEXT FORMAT PAIR
ADDM T1,ENC.PT
JRST EXEPRC ;AND BACK FOR MORE FORMAT
NODATA: PUSHJ P,@DATENT ;DO INPUT OR OUTPUT
MOVEI T1,2 ;ON TO NEXT FORMAT
ADDM T1,ENC.PT
JRST EXEPRC
NXTFMT: SKIPN @ENC.PT ;ARE WE AT END OF FORMAT?
JRST EXRPT ;YES. GO USE INDEFINITE REPEAT
MOVEI T1,2 ;NO. GO ON TO NEXT ITEM
ADDM T1,ENC.PT
JRST EXEPRC
DATOUT: LDB T1,W.PNTR ;GET FIELD WIDTH
MOVEM T1,%FWVAL ;SAVE IT
LDB T1,D.PNTR ;GET DECIMAL WIDTH
MOVEM T1,%DWVAL ;SAVE IT
LDB T1,X.PNTR
MOVEM T1,%XPVAL ;SAVE IT
HRRZ T1,IO.ENT ;GET ENTRY INDEX
JRST @OUTAB(T1) ;DO IT
DATIN: LDB T1,W.PNTR ;GET FIELD WIDTH
MOVEM T1,%FWVAL ;SAVE IT
LDB T1,D.PNTR ;GET DECIMAL WIDTH
MOVEM T1,%DWVAL ;SAVE IT
LDB T1,X.PNTR
MOVEM T1,%XPVAL ;SAVE IT
HRRZ T1,IO.ENT ;GET ENTRY INDEX
PUSHJ P,@INTAB(T1) ;DO IT
SKIPE %FWVAL ;FREE FORMAT?
POPJ P, ;NO. LEAVE
MOVE T1,IO.ENT ;Get flags and table entry
TXNE T1,SKPFLG ;SCAN FOR NEXT DELIMITER
PUSHJ P,SFDEL ;YES. SCAN FOR NEXT DELIM
POPJ P,
;G-FORMAT I/O. USES THE DATA TYPE TO FIGURE OUT WHAT TO DO
GIN: MOVE T1,IO.TYP ;GET VARIABLE TYPE
CAIN T1,TP%CHR ;[4146]IS IT A CHARACTER VARIABLE TYPE?
CALL GFLAG ;[4146] YES; FLAGGER IT!
MOVE T1,GTAB(T1) ;GET I/O CONV ADDRESS
MOVEM T1,GENTRY ;SETUP FOR I/O
MOVEI T1,(T1) ;GET JUST INDEX INTO TABLE
PUSHJ P,@INTAB(T1) ;DO IT
LDB T1,WIDPNT ;FREE FORMAT?
JUMPN T1,%POPJ ;NO.
MOVE T1,GENTRY ;Get flags and table entry
TXNE T1,SKPFLG ;SCAN FOR NEXT DELIMITER
PUSHJ P,SFDEL ;YES. SCAN FOR NEXT DELIM
POPJ P,
GOUT: MOVE T1,IO.TYP ;GET VARIABLE TYPE
CAIN T1,TP%CHR ;[4146]IS IT A CHARACTER VARIABLE TYPE?
CALL GFLAG ;[4146] YES; FLAGGER IT!
MOVE T1,GTAB(T1) ;GET I/O CONV ADDRESS
MOVEI T1,(T1) ;GET JUST INDEX INTO TABLE
JRST @OUTAB(T1) ;DO IT
;+
; Check to see if Compatibility Flagging is ON ! {If it is}
; then issue a warning message "G format used with Character I/O".
;-
GFLAG: MOVEI T2,VAXIDX+ANSIDX;[4146]Flag this as an incompatibility for both
TDNE T2,%FLIDX ;[4146]Any flags the same?
$ECALL CFG ;[4146]Yes. Display the error message
POPJ P, ;[4146]End of Routine GFLAG
;
;SCAN FOR A DELIMITER - FOR "FREE-FORMAT" INPUT,
;WE HAVE TO SCAN UNTIL WE REACH A "DELIMITER" FOR THIS TYPE
;OF INPUT, TO AVOID GETTING FAKE NULL VALUES FOR SUCH THINGS
;AS <DATA><SPACES><COMMA><SPACES><DATA>. THE DELIMITERS FOR
;FREE-FORMAT ARE ANY NON-BLANK CHARACTERS AND END-OF-LINE.
;IF THE NON-BLANK CHARACTER IS NOT A COMMA, THE BYTE POINTER
;IS BACKED UP VIA A CALL TO %IBACK SO THAT THE NEXT CALL
;TO %IBYTE WILL GET IT.
SFDEL: PUSHJ P,%IBYTC ;GET CURRENT CHAR
JRST DELGOT ;SKIP NEW CHAR
SFDLP1: PUSHJ P,%IBYTE ;GET NEXT CHAR
DELGOT: SKIPGE IRCNT(D) ;END OF RECORD?
POPJ P, ;YES
CAIE T1," " ;SKIP SPACES AND TABS
CAIN T1," "
JRST SFDLP1
CAIE T1,"," ;LEAVE ON COMMA
JRST %IBACK ;ELSE PUSH THE POINTER BACK
POPJ P,
;DOLLAR SIGN EXECUTION (SOUNDS LIKE SOCIALISM OR SOMETHING)...
;CALL SPECIAL ROUTINE ON OUTPUT WHICH OUTPUTS
;THE RECORD WITHOUT A CARRIAGE RETURN FOR OUTPUT.
;RIGHT NOW, JUST SET THE FLAG FOR THIS, AND SET
;THE RECORD POSITION IF A VIRTUAL ONE EXISTS (THAT IS,
;IF AN X OR T FORMAT WAS DONE IMMEDIATELY BEFORE THE $),
;SO THAT THE SPACES AT THE END WILL ACTUALLY APPEAR.
NOCR: MOVX T0,D%STCR ;Suppress trailing CR
IORM T0,FLAGS(D)
POPJ P,
;BNZ - BN AND BZ FORMAT
;IF THE LETTER AFTER THE B WAS A "Z", TURN ON THE
;BZ FORMAT FLAG, WHICH FORCES BLANKS TO BE INTERPRETED
;AS ZEROES FOR FIXED FORMAT FIELDS. OTHERWISE TURN OFF
;THE BZ FORMAT FLAG
BNZ: LDB T1,WIDPNT ;GET ARG
SETZM %BZFLG ;ASSUME "N"
CAIN T1,"Z"
SETOM %BZFLG ;WAS "Z". SET FLAG
POPJ P,
;H-FORMAT - THE BYTE POINTER TO THE HOLLERITH STRING HAS
;BEEN STORED IN THE NEXT ENTRY IN THE FORMAT LIST. THE
;NUMBER OF CHARACTERS IS IN THE REPEAT FIELD.
HOUT: LDB T2,RPTPNT ;GET # CHARS
MOVE T3,ENC.W2 ;Get byte ptr
HOUTLP: ILDB T1,T3 ;GET CHAR
PUSHJ P,%OBYTE ;OUTPUT IT
SOJG T2,HOUTLP ;BACK FOR MORE
POPJ P,
;Q FORMAT - FOR INPUT, RETURNS THE NUMBER OF CHARS LEFT IN THE RECORD
;INTO THE SPECIFIED VARIABLE (INTEGER!). FOR OUTPUT, RETURNS THE NUMBER
;OF CHARACTERS WRITTEN IN THE RECORD.
QIN: SKIPGE T1,IRCNT(D) ;GET # CHARS LEFT
SETZ T1, ;PAST END OF RECORD, RETURN 0
MOVEM T1,@IO.ADR ;PUT INTO USER'S VARIABLE
POPJ P,
QOUT: MOVE T1,ORSIZ(D) ;GET OUTPUT BUFFER LENGTH
SUB T1,ORCNT(D) ;GET CURRENT POSITION (0=COL 1)
CAMG T1,ORLEN(D) ;.GT. LAST RECORDED LENGTH
MOVE T1,ORLEN(D) ;NO. RETURN THE LENGTH
POPJ P,
;P FORMAT - SETS THE SCALE FACTOR. THE SCALE FACTOR
;HAS BEEN STORED AS IF IT WERE A REPEAT COUNT, SO WE
;HAVE TO DO SOME CONTORTIONS IN ORDER TO EXTEND THE SIGN
PFACT: HRRE T1,ENC.WD ;EXTEND REPEAT COUNT
MOVEM T1,%SCLFC ;SAVE IT
POPJ P,
;SSP - HANDLES S,SP, AND SS FORMATS.
;THE DEC IMPLEMENTATION OF THIS FORMAT MEANS THAT S FORMAT
;MEANS SS, SINCE WE DO NOT OUTPUT A PLUS SIGN
;UNDER NORMAL CIRCUMSTANCES. SO THERE IS A SINGLE FLAG, WHICH JUST
;SAYS WHETHER OR NOT TO FORCE A PLUS SIGN (AND THEN ONLY IF IT WILL
;FIT!), CORRESPONDING TO SP AND SS.
SSP: LDB T1,WIDPNT ;GET THE CODE
SETZM %SPFLG ;ASSUME NOT "P"
CAIN T1,"P" ;IS IT P?
SETOM %SPFLG ;YES. SET FLAG
POPJ P,
;T FORMAT - POSITIONS RECORD POINTER.
;ARGUMENT IS IN WIDTH FIELD
TIN: LDB T2,DECPNT ;GET L OR R
JUMPN T2,ILRPOS ;GO PROCESS THEM IF THERE
LDB T1,WIDPNT ;GET VALUE
PJRST %SIPOS ;POSITION PNTR/COUNT
ILRPOS: LDB T1,WIDPNT ;GET FORMAT ARG
CAIN T2,'L' ;IS IT TAB LEFT?
MOVNI T1,(T1) ;YES. NEGATE TAB
PJRST %CIPOS ;GO CHANGE POSITION
TOUT: LDB T2,DECPNT ;GET L OR R
JUMPN T2,OLRPOS ;GO PROCESS THEM IF THERE
LDB T1,WIDPNT ;GET VALUE
PJRST %SOPOS ;GO SET POSITION
OLRPOS: LDB T1,WIDPNT ;GET FORMAT ARG
CAIN T2,'L' ;IS IT TAB LEFT?
MOVNI T1,(T1) ;YES. NEGATE TAB
PJRST %COPOS ;GO CHANGE POSITION
;X FORMAT - SIMILAR TO T FORMAT, BUT WITH REPEAT COUNT INSTEAD
;OF WIDTH FOR ITS VALUE
XIN: LDB T1,RPTPNT ;GET ARG OF X-FORMAT
PJRST %CIPOS ;GO CHANGE POSITION
XOUT: LDB T1,RPTPNT ;GET ARG OF X-FORMAT
PJRST %COPOS ;GO CHANGE POSITION
;SINGLE QUOTE OUTPUT - LIKE HOLLERITH, THE BYTE POINTER IS STORED
;AS THE NEXT (1 OR 2) WORD ON THE FORMAT LIST, AND THE CHARACTER COUNT IS
;STORED AS THE WIDTH. UNLIKE HOLLERITH, DOUBLE APOSTROPHES MUST BE
;TURNED INTO SINGLE APOSTROPHES.
SQOUT: LDB T2,RPTPNT ;GET THE # CHARS
JUMPE T2,SQODON ;DONE IF NO CHARS
MOVE T3,ENC.W2 ;Get the byte ptr.
SQOLP: ILDB T1,T3 ;GET CHAR
CAIE T1,"'" ;IS IT A QUOTE?
JRST PUTNSQ ;NO. GO OUTPUT IT
SOJLE T2,SQODON ;DECR AND LEAVE IF NO MORE
IBP T3 ;INCR PAST THE NEXT CHAR
PUTNSQ: PUSHJ P,%OBYTE ;AND PRINT CHAR
SOJG T2,SQOLP ;BACK FOR MORE
SQODON: POPJ P,
;SINGLE QUOTE INPUT - ALLOWS THE USER TO OVERWRITE A QUOTED STRING
;IN THE FORMAT STATEMENT. DISALLOWED BY THE ANSI STANDARD, BUT WE
;DO IT ANYWAY.
;HOLLERITH INPUT - A STUPID WAY TO WRITE PROGRAMS, BUT ELLIOT
;ORGANICK USES IT AS AN EXAMPLE IN HIS INTRO TO FORTRAN! THE NUMBER
;OF CHARACTERS SPECIFIED IN THE FIELD ARE READ FROM THE INPUT RECORD
;AND WRITTEN INTO THE ORIGINAL FORMAT STATEMENT.
;BOTH OF THESE ARE LIKELY TO BE MADE ILLEGAL SOMEDAY, SO
;WE OUTPUT A WARNING. IT IS STRICTLY ILLEGAL FOR CHARACTER
;CONSTANTS SPECIFIED AS FORMATS, AND THEREFORE PRODUCES A
;FATAL ERROR.
SQIN:
HIN: MOVE T1,ENC.AD ;GET ENCODED ADDR
MOVE T1,%FMTYP(T1) ;GET THE FORMAT TYPE
CAIN T1,TP%CHR ;TYPE CHARACTER?
$ACALL RIC ;YES. CAN'T READ INTO IT
$ECALL RIF ;NO. JUST ISSUE WARNING
LDB T2,RPTPNT ;GET # CHARS TO INPUT
MOVE T3,ENC.W2 ;Get the byte ptr
HINLP: PUSHJ P,%IBYTE ;GET A CHAR
IDPB T1,T3 ;DEPOSIT INTO FORMAT
SOJG T2,HINLP ;BACK FOR MORE
POPJ P,
;GTFCHR - GET THE NEXT CHARACTER IN THE FORMAT.
;EXCEPT FOR H-FORMAT AND QUOTED STRINGS, WE DO NOT WANT
;NULL CHARACTERS FROM THE FORMAT STATEMENT. ADDITIONALLY,
;PROVISION HAS BEEN MADE IF WE READ TOO FAR WE SAVE THE
;CHARACTER READ AS THE "PREVIOUS CHAR" AND RETRIEVE IT THE
;NEXT TIME GTFCHR IS CALLED.
GTFCHR: SKIPE T1,FMT.PC ;Is there a previous char?
JRST PREVCH ;Yes, go clear it
NOPREV: SOSGE FMT.SZ ;ANY CHARS LEFT?
POPJ P, ;NO. RETURN WITH NULL
ILDB T1,FMT.BP ;GET A CHAR
JUMPE T1,NOPREV ;SKIP NULLS
CAILE T1,140 ;LOWER CASE?
SUBI T1,40 ;YES. CONVERT TO UPPER
POPJ P,
PREVCH: SETZM FMT.PC ;IF ONE, NOW CLEAR IT
POPJ P, ;SO WE WON'T GET IT AGAIN
%IFORM:
%OFORM: MOVE T1,IO.TYP ;GET DATA TYPE
CAIE T1,TP%CPX ;COMPLEX?
JRST EXENT ;NO. ENTER DATA LOOP
CPXSUB: MOVEI T1,TP%SPR ;SUBSTITUTE REAL
MOVEM T1,IO.TYP ;FOR THE DATA TYPE
MOVE T1,[ADD T1,IO.ADR] ;SETUP INCR INST
MOVEM T1,IO.INS
MOVE T1,IO.SIZ ;GET DATA SIZE
CAME T1,IO.INC ;SAME AS INCREMENT?
JRST CMPCPX ;NO. COMPLICATED COMPLEX
IMULM T1,IO.NUM ;YES. JUST MULTIPLY NUMBER ELEMENTS
MOVEI T1,1 ;AND SUBSTITUTE 1 FOR SIZE
MOVEM T1,IO.SIZ
MOVEM T1,IO.INC ;AND FOR INCREMENT
JRST EXENT ;ENTER DATA LOOP
CMPCPX: MOVE T1,IO.NUM ;GET # ELEMENTS
CAIN T1,1 ;ONLY ONE ELEMENT?
JRST CPXONE ;YES.
MOVEM T1,FIONUM ;NO. SAVE LOCALLY
MOVEI T1,1 ;SUBSTITUTE 1 FOR SIZE
MOVEM T1,IO.SIZ
EXCH T1,IO.INC ;AND FOR INCREMENT
MOVEM T1,FIOINC ;AND SAVE REAL INCREMENT LOCALLY
MOVE T1,IO.ADR ;SAVE DATA ADDRESS LOCALLY
MOVEM T1,FIOADR ;AS THE DATA LOOP CLEARS IT
CPXLP: MOVEI T1,2 ;SUBSTITUTE 2 FOR
MOVEM T1,IO.NUM ;NUMBER OF ELEMENTS
PUSHJ P,EXENT ;DROP BACK TO FMTEXC
MOVE T1,FIOINC ;INCR THE DATA PNTR
ADDB T1,FIOADR
MOVEM T1,IO.ADR ;SETUP THE DATA ADDRESS AGAIN
SOSLE FIONUM ;DECR THE COMPLEX ENTRY COUNT
JRST CPXLP ;BACK FOR MORE
POPJ P, ;DONE
CPXONE: MOVEI T1,1 ;SET INCREMENT TO 1
MOVEM T1,IO.INC
MOVEM T1,IO.SIZ ;AS WELL AS SIZE
MOVEI T1,2 ;AND SETUP FOR 2 ELEMENTS
MOVEM T1,IO.NUM
PJRST EXENT ;GO DO I/O
SEGMENT DATA
T.FMT: BLOCK 1 ;FORMAT ARG TYPE
FMTADR: BLOCK 1 ;ADDRESS OF ENTRY IN ENCODED LINKED LIST
FMTPTR: BLOCK 1 ;ENCODED LIST POINTER
FMTCNT: BLOCK 1 ;COUNT OF ENCODED LIST ENTRIES
IO.ADR:: BLOCK 1
IO.TYP:: BLOCK 1
IO.NUM:: BLOCK 1 ;NUMBER OF ELEMENTS
IO.INC:: BLOCK 1
IO.SIZ:: BLOCK 1 ;SIZE OF VARIABLE
IO.INS:: BLOCK 1 ;INCREMENT INSTRUCTION
FIONUM: BLOCK 1 ;LOCAL DATA COUNT
FIOINC: BLOCK 1 ;LOCAL INCREMENT
FIOADR: BLOCK 1 ;LOCAL ADDRESS
IO.ENT: BLOCK 1 ;Save flags and table address in EXENRM
DATENT: BLOCK 1 ;INST TO EXECUTE AFTER %GETIO CALL
GENTRY: BLOCK 1 ;FLAGS AND INDEX FOR G-FORMAT
SEGMENT CODE
END