.
.         BUFFER SOURCE
.
.
.         (C)  Copyright 1972-1978  John Walker
.
.         This software is in the public domain
.
          AXR$
          DEFUNCT$
          FANG
          PURE      CODE
.
.         WORKS LIKE INPUT EXCEPT THAT THE FCT HAS A POINTER
.         TO A DATA TYPED PARAMETER IN IOFN RATHER THAN A
.         FILE NAME.  EMITS IOCOUNT BUFFERS, THE LAST OF WHICH
.         WILL HAVE IBLAST SET.  THE 'M' OPTION MAKES IT EMIT
.         A FINAL EOF STATUS BUFFER.
.
.         LX,U      X10,<FCT>
.         LMJ       A2,SOURCE
.         <RETURN>
.
SOURCE*   FORK      SORCESU             ESTABLISH A SOURCE ACTIVITY
          J         0,A2                RETURN
.
SORCESU   LA,U      A10                 CLEAR BLOCKS TRANSMITTED
          LA        A11,IOOPT,X10       LOAD I/O OPTION
          LX        X9,IOFN,X10         LOAD ADDRESS OF DATA PARAMETER
.
SORCEL    LA        A0,PBVAL,X9         LOAD LENGTH OF DATA
          AA,U      A0,IBDATA           ADD LENGTH OF BLOCK BUFFER
          BGET      .                   ALLOCATE A BLOCK BUFFER
          LA,U      A1,IBDATA,A0        LOAD ADDRESS OF DATA AREA
          LXI,U     A1,1                SET UP INCREMENT
          LA,U      A2,PBSS,X9          GET ADDRESS OF PROTOTYPE DATA
          LXI,U     A2,1                GET SOURCE INCREMENT
          LR        R1,PBVAL,X9         LOAD LENGTH OF DATA SUPPLIED
          SR        R1,IBLEN,A0         SET LENGTH IN BLOCK BUFFER
          BT        A1,,*A2             MOVE DATA TO BLOCK BUFFER
          SZ        IBSTAT,A0           SET READ STATUS NORMAL
          SX        X10,IBIOP,A0        SET BACKPOINTER TO SOURCE FCT
          SA        A10,IBBLKN,A0       SET BLOCK NUMBER IN FCT
          SZ        IBAFC,A0            CLEAR ABNORMAL FRAME COUNT
          SZ        IBLAST,A0           CLEAR LAST BLOCK FLAG
          AA,U      A10,1               INCREMENT BLOCK NUMBER
          TG        A10,IOCOUNT,X10     ENOUGH BLOCKS WRITTEN ?
BSEND     SNONZ     IBLAST,A0           YES.  SET LAST FLAG IN THIS BLOCK
          LA        A2,IBLAST,A0        LOAD LAST FLAG
          LA,U      A1,IBQ,A0           LOAD HEAD WORDS ADDRESS
          TNE,U     A11,'M'             IS THE 'M' OPTION ON ?
          JNZ       A2,SLASTE           YES.  IF LAST BLOCK CLOSE OUT
          PUT       IOBB,X10            PUT ON BOUNDED BUFFER
          JZ        A2,SORCEL           LOOP UNTIL LAST BLOCK PASSED
          EXIT      .                   ALL DONE
.
.         'M' OPTION CLOSEOUT
.
SLASTE    SZ        IBLAST,A1           MARK THIS ONE NOT LAST
          PUT       IOBB,X10            TRANSMIT BUFFER
          BGET      IBDATA              ALLOCATE AN EOF STATUS BUFFER
          LA,U      A1,1                LOAD EOF STATUS
          SA        A1,IBSTAT,A0        PUT STATUS IN BUFFER
          LA,U      A11                 CLEAR I/O OPTION
          J         BSEND               TRANSMIT THE LAST BUFFER
          END