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+1B+1B+1B IWARN==1B+1B+1B+1B+1B+1B QWARN==IWARN OWARN==1B+1B ;[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) DEFINE GENT(A,B,C,D,E,F) FMTTAB DEFINE FMTENT(A,B,C,D,E,F) DEFINE GENT(A,B,C,D,E,F) INTAB: FMTTAB DEFINE FMTENT(A,B,C,D,E,F) DEFINE GENT(A,B,C,D,E,F) OUTAB: FMTTAB DEFINE FMTENT(A,B,C,D,E,F) DEFINE GENT(A,B,C,D,E,F) <> ENCTAB: FMTTAB DEFINE FMTENT(A,B,C,D,E,F) < IFNB , IFB ,<0> > DEFINE GENT(A,B,C,D,E,F) <> WRNTAB: FMTTAB DEFINE FMTENT(A,B,C,D,E,F) < IFNB , IFB ,<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 . 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