ASMB,R,L,C,Z  ** ASSEMBLE FOR DS/1000 USAGE **
      IFN                                                  #
      HED FMTIO 
      NAM FMTIO,7  24998-16002 REV.1913 790129
      XIF                                                  #
      IFZ                                                  #
      HED DS/1000 I/O AND CONTROL FOR FRMTR *(C) HEWLETT-PACKARD CO. 1979*
      NAM RMTIO,7 91740-16037 REV 1913 790129   
      XIF                                                  #
      UNL                                                  #
      IFZ                                                  #
      LST                                                  #
*  ***************************************************************         #
*  * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS      *         #
*  * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED,       *         #
*  * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT*         #
*  * THE PRIOR WRITTEN CONSENT OF THE HEWLETT-PACKARD COMPANY.   *         #
*  ***************************************************************         #
*                                                                          #
*  NAME:   FMTIO  ('N' ASSEMBLY OPTION)    RMTIO  ('Z' ASSEMBLY OPTION)    #
*  SOURCE: 24998-18002                     24998-18002                     #
*  RELOC:  24998-16002                     91740-16037                     #
*  PGMR:   D.L.B./E.A.S./B.G.              C.C.H. (01-29-79)               #
*                                                                          #
*  ** SEE ENTRY POINT 'DNODE' FOR DS/1000 MODIFICATIONS 1-16-79 (CH) **    #
      UNL                                                  #
      XIF                                                  #
      LST                                                  #
* 
* THE FOLLOWING MODIFICATIONS HAVE BEEN MADE AS OF 042277:
* THE CARD READER BUG (REPORT 3668) HAS BEEN CORRECTED. 
* ADDITIONS WERE INCLUDED TO ALLOW THE USER TO DECLARE HIS OWN
* LARGE BUFFERS FOR USE BY THE FORMATTER. 
* THIS IS DONE BY CALLING LGBUF(ARRAY,LENGTH).       (EAS)
* BUG FIX 092677: FAILURE TO RESTORE B AFTER EXEC CALL IN .DIO. 
* CAUSED "SZB,RSS / JSB WAITO" TO FAIL (EXEC CALL IN SETLU).
* THIS CAUSED FAILURE ON DOS AND WOULD HAVE FOR RTE-LC. (EAS).
* THE FOLLOWING MODIFICATION WAS MADE AS OF 022778: 
* THE PROGRAM NAME IS FETCHED VIA "PNAME" SO THAT RTE-IV
* TYPE 4 PROGRAMS WORK.  (BG) 
      SPC 2 
      IFZ                                                  #
      ENT DNODE                                            #
      EXT D65MS,#NODE                                      #
      XIF                                                  #
      ENT .IOI.,.IOJ.,.IOR. 
      ENT .IIO.,.JIO.,.RIO.,.XIO.,.TIO. 
      ENT .IAR.,.JAR.,.RAR.,.XAR.,.TAR. 
      ENT .IAY.,.JAY.,.RAY.,.XAY.,.TAY. 
      ENT .DIO.,.BIO.,.DTA. 
      ENT NEWIO,OLDIO,CODE,ACODE,ITLOG,ISTAT,LGBUF
      EXT .FRMN,.LS2F,.INPN,.DTAN,FMT.E 
      EXT PNAME,REIO,EXEC,.SBT
* 
A     EQU 0 
B     EQU 1 
      SKP 
*  SPECIAL ENTRY POINTS:
* 
************************************************************************
*     ASSEMBLY                         FORTRAN (IV) 
* 
*      JSB CODE                        CALL CODE(ICHRS) 
*      DEF *+2                         READ (IBUF,*) A,B,C
*      DEF ICHRS
*      LDA IBUFR(,I)
*      CLB(,INB)
*      JSB .DIO.
*      DEF FORMT
*      DEF ENDLS
*       <ETC.>
*  WHERE: 
*    IBUFR = THE IN MEMORY BUFFER TO CONVERT TO BINARY
*    ICHRS = THE NUMBER OF ASCII CHARACTERS IN " IBUFR "
* 
*  NOTES: 
*    THE ENTRY POINT " CODE " IS NOW IN THE FORMATTER WHICH 
*    ALLOWS THE OPTIONAL PARAMETTER " ICHRS " TO BE PASSED
*    TO LIMIT THE SIZE OF THE BUFFER THAT THE FORMATTER WILL
*    READ.  IF " IBUFR " IS NOT PASSED, THEN THE FORMATTER WILL 
*    SEARCH ALL OF MEMORY, IF NECESSARY, TO SATISFY THE VARIABLE
*    LIST. (A,B,C)
      SKP 
*         JSB ITLOG                       ICHRS = ITLOG(IXXXX)
*         DEF *+1 
*         STA ICHRS 
*  WHERE: 
*    ICHRS = THE NUMBER OF CHARACTORS READ OR WRITTEN BY THE FORMATTER
*      BY ITS LAST INPUT/OUTPUT REQUEST TO THE SYSTEM.  " ICHRS " VALUE 
*      WILL BE 0 TO 134 (120 OF BINARY) REGARDLESS OF THE SPECIFIED 
*      BUFFER SIZE IN THE READ OR WRITE STATEMENT.
*    IXXXX = THE SAME AS " ICHRS "
*********************************************************************** 
*         JSB ISTAT                       ISTUS = ISTAT(IXXXX)
*         DEF *+1 
*         STA ISTUS 
*  WHERE: 
*    ISTUS = THE STATUS WORD RETURNED FROM THE EXEC IN THE LAST 
*      INPUT/OUTPUT CALL THE FORMATTER DID. 
*    IXXXX = SAME AS " ISTUS "
************************************************************************
*         JSB LGBUF                       CALL LGBUF(IBUFF,LENTH) 
*         DEF *+3 
*         DEF IBUFF 
*         DEF LENTH 
*  WHERE: 
*    IBUFF = ADDRESS OF A USER BUFFER.
*    LENTH = LENGTH OF BUFFER, IN WORDS.  THIS BECOMES THE NEW MAXIMUM
*      RECORD LENGTH. 
*********************************************************************** 
*  FORTRAN EXAMPLES.
*** 
*      CALL EXEC (1,401B,IBUFR,-80) 
*      CALL ABREG(IA,ICHRS) 
*      CALL CODE(ICHRS) 
*      READ(IBUFR,*) A,B,C,D
*** 
*    5 READ (1,10) (IBUF(I),I=1,36) 
*   10 FORMAT (36A2)
*      IF (ITLOG(ICHRS)) 20,5,20
*   20 ISTRC = 1
*      CALL NAMR(IPBUF,IBUF,ICHRS,ISTRC)
* 
*  NOTE:  ICHRS CAN BE AS LARGE AS 134 IF 134 CHARACTERS ARE INPUT. 
*** 
*      READ (8,10) (IBUF(I),I=1,80) 
*   10 FORMAT (40A2)
*      IF (IAND(ISTAT(ISTUS),240B)) 99,20,99
*   20 CONTINUE 
*       --- 
*   99 CONTINUE (END OF FILE OR END TAPE DETECTED)
*** 
*      DIMENSION IBUFF(1000)
*       --- 
*      CALL LGBUF(IBUFF,1000) 
*      READ(8,10) (ARRAY(I),I=1,2000) 
*   10 FORMAT(2000A1) 
      HED COMMUNICATION WITH FRMTR. 
*                   FOLLOWING LOCATIONS REFERENCED IN FRMTR:
* 
ADX   BSS 1         ADDRESS VARIABLE. 
TYPE  BSS 1         TYPE
LENTH BSS 1         LENGTH (IN WORDS) 
SKIP  BSS 1         FLAG TO SKIP STORE IN .IOI./.IOJ./.IOR. 
FCR   BSS 1         POINTS TO CHARACTER IN FORMAT 
CCNT  BSS 1         COUNTS WORDS/CHARS IN BUFFER
CMAX  BSS 1         MAX VALUE OF CCNT AT TAB LEFT.
BCR   BSS 1 
IO    BSS 1         FLAG...=0 FOR OUTPUT, 1 FOR IN
SKIPL BSS 1         FLAG TO AVOID SPURIOUS RTN TO LIST. 
TSCAL BSS 1 
SCALE BSS 1         SCALE FACTOR
NEST  BSS 1         PAREN LVLS.  INIT -6, -5 IN FMT,
*                                    -4 TO -1 FOR NESTING.
CFLAG BSS 1 
BCRS  BSS 1         USED FOR REMEMBERING BCR
F2LSI BSS 1 
SWITH BSS 1 
RNEST BSS 1         NEST VALUE OF UNLIMITED GROUPS. 
ADRFD DEF RFSV      USED FOR INDEXING IN RFLD.
RF    BSS 1         FORMAT REPEAT FIELD COUNTER 
WSAVE BSS 1         HOLDS INITIAL W FOR REPEATS 
DSAVE BSS 1         HOLDS INITIAL D FOR REPEATS 
GFLAG BSS 1         = -1 IF G FIELD, +1 OTHERWISE.
.OBUF DEF BUFO
EORD  BSS 1         ALSO DTAI & ATMP. 
OFLAG DEC 0         =0,-1 FOR ASA/OLD FORMATS.
      HED CONSTANTS & LOCALS. 
*                   CONSTANTS.
* 
CNTRL BSS 1 
MIN6  DEC -6
MIN2  DEC -2
MIN1  DEC -1
....1 DEC 1 
....2 DEC 2 
....3 DEC 3 
....7 DEC 7 
...13 DEC 13
PAPER OCT 34000     TEST FOR PAPER TAPE.
O76K  OCT 76000 
O2000 OCT 2000
PBIT  OCT 200       SET BIT FOR IOC.
BASIC OCT 400 
.4000 OCT 4000      CHECK FOR TYPE CODE = 1X
ASC2B OCT 500 
SPCOL ABS 72B-40B   ":" - " " 
"B"   OCT 102 
"^0"  BYT 40,60     " 0"
"0"   OCT 60
BLANK OCT 40
MXPS  OCT 77777     MAX POS # 
DMXPS DEF MXPS
* 
*                   LOCALS. 
* 
FMTAD BSS 1         ADDR FORMAT 
TEMP1 BSS 2         TEMPORARY 
TEMP2 BSS 1              STORAGE
RFLD  BSS 5         REPEAT FIELD FOR GROUPS.
RFSV  BSS 5         INITIAL VALUE OF R-FIELD. 
LPRN  BSS 5         ADDRESS OF LEFT PAREN'S IN GROUP
UNIT  OCT 1         INPUT/OUTPUT UNIT 
ENDLS BSS 1         POINTS TO ENDOF CALLING SEQUENCE
ALNTH BSS 1              AND .IAR.
BFLAG BSS 1         =1 FOR BINARY I/O, 0 FOR DECIMAL
STXXX NOP 
BUFBN EQU 60
BUFLN EQU 67
BUFI BSS BUFLN
BUFO EQU BUFI 
BINRY ABS -BUFBN-BUFBN   BINARY RECORD LENGTH 
ASCRY ABS -BUFLN-BUFLN   FORMATTED RECORD LENGTH
CLEN  ABS -BUFLN-BUFLN
      HED ROUTINES TO PASS LIST ITEMS.
********************************************************************
* THIS SET OF ROUTINES IS USED TO PASS THE ADDRESS, TYPE AND       *
* LENGTH (IF ARRAY).   FOR EACH VARIABLE OR ARRAY OF TYPE:         *
* INTEGER (I), DOUBLE INTEGER (J), REAL/2-WD FLOATING (R),         *
* EXTENDED PRECISION/3-WD FLOATING (X) OR DOUBLE PRECISION/4-WD    *
* FLOATING (T), THERE IS A SINGLE CALL TO ONE OF THE FOLLOWING:    *
*    .IOZ., Z=I,J,R; .ZIO./.ZAR./.ZAY., Z=I,J,R,X,T.               *
* THERE IS INITIALLY A SINGLE CALL TO EITHER .DIO. OR .BIO.  .     *
********************************************************************
      SPC 3 
IOCHK NOP           A SWITCH ON THE VALUE OF IO. RE-
      STB TEMP2     SAVE B
      LDB IO        TURN TO P+1 FOR OUTPUT, P+2 FOR 
      SZB           INPUT.
      ISZ IOCHK 
      LDB TEMP2     RESTORE B 
      JMP IOCHK,I 
      SPC 3 
BCHEK NOP           RETURNS TO P+1 IF BINARY, ELSE 2
      STB TEMP2 
      LDB BFLAG 
      SZB,RSS 
      ISZ BCHEK 
      LDB TEMP2 
      JMP BCHEK,I 
      SPC 2 
*                   ROUTINE TO INITIALIZE .ZIO. / .ZAR. / .ZAY. 
* 
CTYPE NOP 
      ADB MIN2      ACTUAL ENTRY POINT ADDR.
      LDA B,I       COPY ENTRY POINT. 
      STA .TIO. 
      CMB           COMPUTE OFFSET FROM FIRST ONE.
      ADB CTYPE,I 
      CMB 
      BRS           TYPE = OFFSET / 2 
      STB TYPE
      SZB           TYPE = 0
      CPB ....1     OR 1 ?
      INB           YES, LENTH IS ONE LARGER (ELSE EQUAL) 
      STB LENTH 
      ISZ CTYPE     EXIT
      JMP CTYPE,I 
      SKP 
*     .IOI. / .IOJ. / .IOR. 
* 
*     CALLING SEQUENCE: 
* 
*                   <OUTPUT: DATA IN A OR A&B>
*                   JSB ROUTINE 
*                   <INPUT: DATA IN A OR A&B> 
      SPC 2 
.IOI. NOP           STORE ARG & CALL .IIO.
      STA TEMP1 
      JSB .IIO. 
      DEF TEMP1 
      LDA TEMP1 
      LDB SKIP      IF FREE-FIELD & NULL, SKIP STORE. 
      SZB 
      ISZ .IOI. 
      JMP .IOI.,I 
* 
.IOJ. NOP           STORE ARG & CALL .JIO.
      STA TEMP1 
      STB TEMP1+1 
      JSB .JIO. 
      DEF TEMP1 
      LDA .IOJ.     SAVE A LITTLE SPACE HERE. 
      STA .IOR. 
      JMP IOR1
* 
.IOR. NOP           STORE ARG & CALL .RIO.
      STA TEMP1 
      STB TEMP1+1 
      JSB .RIO. 
      DEF TEMP1 
IOR1  LDA TEMP1 
      LDB TEMP1+1 
      ISZ SKIP      IF FREE-FIELD & NULL, SKIP STORE. 
      JMP .IOR.,I 
      ISZ .IOR. 
      ISZ .IOR. 
      JMP .IOR.,I 
      SKP 
*     .IIO. / .JIO. / .RIO. / .XIO. / .TIO. 
* 
*     CALLING SEQUENCE: 
* 
*                   JSB ROUTINE 
*                   DEF <VARIABLE>
      SPC 2 
.IIO. NOP 
      JSB TIO 
.JIO. NOP 
      JSB TIO 
.RIO. NOP 
      JSB TIO 
.XIO. NOP 
      JSB TIO 
.TIO. NOP 
      JSB TIO 
      SPC 1 
TIO   NOP 
      LDB TIO       COMPUTE TYPE, LENTH.
      JSB CTYPE 
      DEF .IIO. 
      LDB A,I       B = BASE ADDR.
      ISZ .TIO. 
      CLA,INA       A = # ELEMENTS = 1. 
      JMP TAY1
      SKP 
*     .IAR./.JAR./.RAR./.XAR./.TAR.   .IAY./.JAY./.RAY./.XAY./.TAY. 
* 
*     CALLING SEQUENCES:
* 
*             LDA <# ELEMENTS>                JSB ROUTINE 
*             LDB <BASE ADDR>                 DEF <BASE ADDR> 
*             JSB ROUTINE                     DEC <# ELEMENTS>
* 
*     INDIRECTION IS ALLOWED ON BOTH VALUES (THE # OF ELEMENTS
*     IS TREATED AS AN ADDRESS).
      SPC 3 
.IAR. NOP 
      JSB TAR 
.JAR. NOP 
      JSB TAR 
.RAR. NOP 
      JSB TAR 
.XAR. NOP 
      JSB TAR 
.TAR. NOP 
      JSB TAR 
* 
TAR   NOP 
      STB ADX       SAVE A,B. 
      STA ALNTH 
      LDB TAR       SET TYPE, LENTH.
      JSB CTYPE 
      DEF .IAR. 
      LDB ADX       B = BASE ADDR.
      LDA ALNTH     A = # ELEMENTS. 
      JMP TAY1
      SPC 2 
.IAY. NOP 
      JSB TAY 
.JAY. NOP 
      JSB TAY 
.RAY. NOP 
      JSB TAY 
.XAY. NOP 
      JSB TAY 
.TAY. NOP 
      JSB TAY 
* 
TAY   NOP 
      LDB TAY       SET TYPE, LENTH.
      JSB CTYPE 
      DEF .IAY. 
      LDB A,I       B = BASE ADDR.
      ISZ .TIO. 
      LDA .TIO.,I   A = # ELEMENTS. 
      ISZ .TIO. 
      JMP TAY1
      SKP 
*                   AT THIS POINT: TYPE, LENTH & RETURN ADDR ARE
*                   SET UP, AND:  B=BASE ADDR, A=# ELEMENTS.
      SPC 2 
      LDB B,I       REMOVE INDIRECTS FROM BASE ADDR.
TAY1  RBL,CLE,SLB,ERB 
      JMP *-2 
      STB ADX 
      JMP *+2       REMOVE "INDIRECTS" ON LENGTH
      LDA A,I 
      RAL,CLE,SLA,ERA 
      JMP *-2 
      JSB BCHEK     BINARY ?
      JMP TAY3      YES.
      CMA,INA,SZA,RSS  - # ELEMENTS.
      JMP .TIO.,I   IF NONE.
      STA ALNTH 
TAY2  JSB LST2J     GO CONVERT. 
      LDA ADX       BUMP TO NEXT ELEMENT. 
      ADA LENTH 
      STA ADX 
      ISZ ALNTH     DONE ?
      JMP TAY2      NO, DO ANOTHER. 
      JMP .TIO.,I   YES, EXIT.
* 
*                   BINARY ARRAY I/O. 
* 
TAY3  MPY LENTH     A = TOTAL LENGTH. 
      CMA,INA,SZA,RSS SET UP COUNT. 
      JMP .TIO.,I   IF ZERO.
      STA ALNTH 
TAY4  ISZ CCNT      TEST FOR END OF BUFFER. 
      JMP TAY5      NO. 
      JSB DTA       YES, DO I/O.
      JMP TAY4      AND TRY AGAIN.
TAY5  ISZ BCR       BUMP BUFFER POINTER.
      LDA ADX,I     FOR OUTPUT. 
      JSB IOCHK     WHICH ? 
      STA BCR,I     OUTPUT. 
      LDA BCR,I     INPUT.
      JSB IOCHK     WHICH ? 
      JMP *+2       OUTPUT - DONE.
      STA ADX,I     INPUT - STORE IN VARIABLE.
      ISZ ADX       TO NEXT ELEMENT.
      ISZ ALNTH     DONE ?
      JMP TAY4      NO, DO AGAIN. 
      JMP .TIO.,I   EXIT. 
      HED CODE - ENCODE/DECODE. 
*  THE FOLLOWING CODE WAS ADDED FOR THE "CALL CODE" PROBLEM 
*  CALLING: 
*           JSB CODE                  JSB CODE
*           DEF *+1                   DEF *+2 
*           LDA IBUFR(,I)             DEF TLOG   +CHARS 
*           CLB(,INB)      - OR -     LDA IBUFR(,I) 
*           JSB .DIO.                 CLB(,INB) 
*           DEF FORMT                 JSB .DIO. 
*           DEF ENDLS                 DEF FORMT 
*             ETC.                    DEF ENDLS 
*                                      ETC. 
******************************************
CODE  NOP           SPECIAL ENTRY FOR INTERNAL CONVERSION 
ACODE EQU CODE      DO THE ALGOL THING
******************************************* 
      LDB CODE,I    GET RETURN ADDRESS + LDA BUFFR(,I)
      ISZ CODE      BUMP TO FIND OUT IF TLOG
      LDA CODE,I    GET POSSIBLE PRAM ADDRESS 
      CPB CODE      CHECK IF PASSED PARM
      LDA DMXPS     NO, GET DEF MAX POS #.
      LDA A,I       GET TLOG IN CHARS OR MAX POS #. 
      CMA           MAKE -TLOG-1 OR MAX NEG #.
      STA CCNT      SAVE AS BUFFER LEN
      STA CMAX
      STB BFLAG     SAVE RETURN ADDRESS 
      LDA B,I       LOAD: "LDA IBUFR(,I)".
      AND O2000     MASK TO FIND IF 
      CLE,SZA       CURRENT OF BASE PAGE? 
      LDA B         CURRENT, GET PAGE BITS
      XOR B,I       LOAD IF BASE, MIRGE IF CURRENT
      AND O76K      MASK OFF PAGE IF BASE,
      XOR B,I       MIRGE IN IF CURRENT 
      RSS           NOW TRACK DOWN ANY
      LDA A,I       INDIRECT ADDRESSES
      RAL,CLE,SLA,ERA INDIRECT? 
      JMP *-2       YES, DO IT AGAIN
      RAL           DOUBLE IT AND 
      ADA MIN1      SUBTRACT ONE
      STA BCR       SAVE THE BUFFER ADDRESS 
      ADB ....3     POINT TO THE P+1 OF JSB .DIO. 
      STB CODE      SAVE IN CONVENENT PLACE 
      JMP BFLAG,I   RETURN TO EXECUTE LDA IBUFF,CLB,JSB .DIO. 
      HED .DIO. & .BIO. - INITIALIZATION. 
*************************** 
.DIO. NOP *         THE INITIAL CALL TO THE I/O ROU-
*                         *         TINES FOR FORMATTED INPUT/
***************************         OUTPUT. 
      STA UNIT
      STB IO
      LDA .DIO.     CHECK IF CALL CODE BEFORE 
      CPA CODE      MUST BE SAME
      JMP INTCN     YES, CALL CODE CONVERSION 
      LDA UNIT      SET FUNCTION BITS 
      JSB SETLU 
      STA CNTRL 
      LDA UNIT      NO, PROCESS AS BEFORE 
      CCE,SZA       CHECK FOR UNIT=0.  (E=1)
      JMP DIO1      NO-IO TRANSFER. 
      ERA           INTERNAL CONVERSION. (A=MAX NEG #)
      STA CCNT      SET CCNT = MAX NEG #. 
      STA CMAX
      LDB .DIO.,I   B = BUFFER ADDR.
      LDA B,I       VERIFY ABOVE FENCE. 
      STA B,I 
      RBL           FORM BYTE ADDR - 1: BCR.
      ADB MIN1
      STB BCR 
      ISZ .DIO. 
INTCN CLA,RSS       CALL CODE INTERNAL CONVERSION 
DIO1  CLA,RSS 
      STA UNIT
      STA BFLAG 
      STA SKIP
      STA SKIPL 
      STA TSCAL    INITIAL SCALE FACTOR = 0 
      STA SCALE    CLEAR SCALE FACTOR FOR FREE INPT 
      STA SWITH 
      LDA ASCRY 
      STA CLEN      RECORD SIZE 
      LDA MIN6
      STA NEST      OUTSIDE LEVEL 0 PARENS. 
      CCA 
      STA CFLAG     FREE-FIELD COMMAS.
      SKP 
*                   COPY FORMAT AND END-OF-LIST ADDRESSES.
* 
      LDA .DIO.     GET FORMAT ADDRESS
      LDA A,I       GET DOWN TO NEXT LEVEL
      RAL,CLE,SLA,ERA    TEST FOR INDIRECT (1 LEVEL)
      JMP *-2       SEARCH FOR EVER IF NEED BE
      STA FMTAD     SAVE FORMAT ADDRESS 
      LDB A,I       VERIFY ABOVE FENCE. 
      STB A,I 
      RAL           CONVERT TO A CHARACTER
      CMA,INA,SZA       ADDRESS 
      CMA 
      STA FCR 
      ISZ .DIO.      GET THE END-OF LIST
      LDA .DIO.,I        ADDRESS
      STA ENDLS 
      LDB A,I       VERIFY ABOVE FENCE. 
      STB A,I 
* 
*                   IF FORMATTED OUTPUT, WAIT FOR PREV. OUTPUT & GO.
*                   IF INPUT, READ RECORD.  IF FORMATTED, GO. 
* 
      ISZ .DIO.       SET UP
      LDA .DIO.          THE RETURN 
      STA LST2J      ADDRESS
      JSB IOCHK     IF OUTPUT,
      JSB WAITO     WAIT. 
      JSB IOCHK 
      JMP FORMT     GO. 
      JSB DTA       INPUT.  READ A RECORD.
      LDA FCR       FORMATTED ? 
      SZA 
      JMP FORMT     YES, GO.
* 
*                   FREE-FIELD INPUT. 
* 
NXTON JSB F2LST     LIST DEFINITION 
IOTST LDB UNIT      CHECK IF INTERNAL CONVERSION
      LDA CCNT      IF CCNT = 0,
      SZA           CHECK IF SLASH WAS ENCOUNTERED
      JMP NSLSH     NO
      SZB,RSS       SLASH, BUT INTERNAL CONVERSION? 
      JMP ENDLS,I   YES RETURN, UNSATISFYING LIST 
      JSB DTA         SO READ NEXT RECORD 
NSLSH JSB .INPN     ENTER FRMTR TO CONVERT DATA 
      DEF ADX 
      LDA SWITH 
      CPA ....7     IF SWITH = 7, GO TO END OF LIST 
      JMP ENDLS,I 
      SZA 
      JMP NXTON     STORE ELEMENT 
      JMP IOTST     MUST  BE SLASH
      SKP 
*************************** 
.BIO. NOP *        THE INITIAL CALL TO THE I/O ROU- 
*                         *          TINES FOR NON-FORMATTED
***************************            INPUT/OUTPUT 
      STA UNIT
      STB IO
      JSB SETLU     CONFIGURE THE LU CONTROL WORD 
      XOR ASC2B     MAKE IT BINARY
      STA CNTRL     AND PUT IT AWAY 
      CLA,INA 
      STA BFLAG 
      LDA BINRY 
      STA CLEN      RECORD SIZE 
      LDB IO        TEST FOR I/O DIRECTION
      SZB 
      JMP BIO1      IF INPUT. 
      JSB WAITO     OUTPUT, WAIT. 
      JMP .BIO.,I 
BIO1  JSB DTA       INPUT, READ.
      JMP .BIO.,I 
      SPC 3 
***************************         SET NEW FORMAT DEFS.
NEWIO NOP *         CALLING SEQUENCE: 
*                                     JSB NEWIO 
***************************           DEF *+1 
      CLA 
      STA OFLAG 
      ISZ NEWIO 
      JMP NEWIO,I 
      SPC 3 
***************************         SET OLD FORMAT DEFS.
OLDIO NOP *         CALLING SEQUENCE: 
*                                     JSB OLDIO 
***************************           DEF *+1 
      CCA 
      STA OFLAG 
      ISZ OLDIO 
      JMP OLDIO,I 
      HED LINKAGE TO "FRMTR". 
*                   MAIN LOOP. CALL FRMTR & ACCEPT REQUESTS:
*                     SWITH<6: PRODUCE ERROR MSG & QUIT.
*                     SWITH=6: GET A LIST ITEM. 
*                     SWITH=8: DO I/O.
* 
FORMT JSB .FRMN     ENTER FRMTR TO PROCESS LIST 
      DEF ADX 
TSTSW LDA MIN6
      ADA SWITH 
      SSA 
      JMP ERROR     SWITCH < 6 = ERROR. 
      SZA,RSS 
      JMP NRML      SWITCH=6=F2LST
      JSB DTA       SWITCH=8
      JSB .DTAN     ENTER FRMTR AFTER DATA I/O
      DEF ADX 
      JMP TSTSW 
NRML  JSB F2LST 
      JSB .LS2F     CONTINUE LIST PROCESS 
      DEF ADX 
      JMP TSTSW 
      SPC 3 
*                 COROUTINE MECHANISM FOR LIST ITEMS: 
*                     THE CONVERSION ROUTINES IN FRMTR AND THE LIST-ITEM
*                   HANDLERS IN FMTIO ACT AS COROUTINES.  THE LINKAGE IS
*                   PERFORMED BY LST2J AND F2LST.  WHEN FRMTR IS READY
*                   FOR A LIST ITEM, IT RETURNS TO THE FREE-FIELD OR
*                   FORMATTED LOOP IN FMTIO, WHICH CALLS F2LST. 
*                   F2LST RETURNS THRU LST2J TO THE PREVIOUSLY CALLED 
*                   ITEM HANDLER, WHICH RETURNS TO THE CALLER.  THE 
*                   CALLER CALLS ANOTHER ITEM HANDLER, WHICH CALLS LST2J
*                   (SAVING ITS RETURN POINT).  LST2J RETURNS THRU F2LST
*                   TO THE CONVERSION LOOP, WHICH "RETURNS" TO FRMTR BY 
*                   CALLING THE APPROPRIATE ENTRY POINT.
*                     SINCE FORMATTED I/O CALLS FRMTR FIRST, FORMATTED
*                   I/O IS DRIVEN BY THE FORMAT.  SINCE FREE-FIELD
*                   I/O RETURNS FOR A LIST ITEM FIRST, FREE-FIELD 
*                   INPUT IS DRIVEN THE THE LIST. 
      SPC 1 
LST2J NOP 
      LDA ADX,I     VERIFY DATA ABOVE FENCE.
      STA ADX,I 
      JMP F2LST,I 
      SPC 1 
F2LST NOP 
      LDA BCR 
      STA BCRS
      ISZ SKIPL     PROCESSING FINAL RIGHT PAREN ?
      JMP LST2J,I   NO, RETURN TO .IOI. & FRIENDS.
      JMP F2LST,I   YES, RETURN TO FORMAT PROCESSOR.
      HED I/O ROUTINES. 
DTA   NOP           PERFORMS A COMPLETE I/O OPERA-
      JSB .DTA.       TION. 
      JSB IOCHK 
      JMP *+3 
      JSB WAITI     INPUT WAIT
      JMP DTA,I 
      JSB WAITO     OUTPUT WAIT 
      JMP DTA,I 
      SPC 2 
.DTA. NOP 
      LDA UNIT      SET UP STATUS CONTROL 
      SZA,RSS       IF UNIT=0,
      JMP .DTA.,I     IGNORE CALL.
      JSB IOCHK     NOW TEST FOR INPUT OR OUTPUT. 
      JMP DTAO
* INPUT SECTION * 
      JSB IOCIN     PERFORM IOC CALL. 
      JMP .DTA.,I   RETURN
* OUTPUT SECTION *
DTAO  LDB CCNT      GET NUMBER OF CHARACTERS/WORDS. 
      JSB BCHEK     BINARY ?
      JMP DTAO2     YES.
      CMB,CLE,INB   -CCNT 
      ADB CMAX      CMAX-CCNT (E=0 IFF B<0) 
      LDB CCNT      NORMALLY USE CCNT.
      SEZ           CMAX > CCNT ? 
      LDB CMAX      YES, USE IT.
      CMB           # CHARS UNUSED. 
      ADB CLEN      CHAR COUNT. 
      STB OUTBL     STORE AS # OF CHARS. OUTPUT.
      CMB,SLB,INB   B=# CHARS.  EVEN ?
      JMP DTAO1     YES, IS O.K.
      ADB BUFOA     NO. FORM ADDR CHAR AFTER LAST.
      ADB BUFOA 
      LDA BLANK     STORE A BLANK AFTER LAST CHAR.
      JSB .SBT
DTAO1 JSB IOCOU     PERFORM IOC CALL
      JMP .DTA.,I   RETURN
DTAO2 SZB           BINARY RECORD CONTINUATION ?
      CMB           NO. B = # WORDS NOT USED. 
      BLS           B = # CHARS NOT USED. 
      ADB CLEN      B = -(# CHARS USED) 
      STB OUTBL 
      CMB,INB       B = REC LENGTH
      BLF,BLF       POSITION AS HIGH CHARACTER
      RBR           IN WORDS. 
      LDA CNTRL 
      ALF,ALF       ROTATE P-BIT TO SIGN
      SSA           IF NOT ZERO, STORE AS 
      STB .IBUF,I    FIRST CHARACTER IN BUFFER. 
      JMP DTAO1 
          