Retro1.org codex

*DECK MREDUCE 
          IDENT  MREDUCE
          LIST   F
          ENTRY  MREDUCE
          EXT    ABORT
          EXT    MRELS
          EXT    XTRACE 
*IF DEF,IMS 
*#
*1DC MREDUCE
*     1. PROC NAME           AUTHOR              DATE 
*        MREDUCE             P.C.TAM             78/07/10 
* 
*     2. FUNCTIONAL DESCRIPTION.
*        REDUCE THE SIZE OF A BLOCK, AND RELEASE EXTRA SPACE
* 
*     3. METHOD USED. 
*        CHECK THE ORIGINAL BLOCK SIZE, AND THE REQUEST SIZE, 
*        ABORT WITH ERROR MESSAGE IF EITHER IS ZERO, OR IF OLD
*        SIZE IS LESS THAN NEW SIZE WHEN DEBUG IS ON. 
*        BUILD NEW HEADER, RELEASE EXTRA SPACE. 
* 
*     4. ENTRY PARAMETER. 
*        (A1) = ADDRESS OF THE ADDRESS OF BUFFER ADDRESS OF THE BUFFER
*               TO BE REDUCED 
*        (A1)+1 = ADDRESS OF THE ADDRESS OF THE REQUIRED SIZE 
* 
*     5. EXIT PARAMETER.
*        NONE.
* 
*     6. COMMON DECKS CALLED. 
*        CYBERDEFS INPARU FREETAB 
* 
*     7. ROUTINES CALLED. 
*        ABORT               ABORT NIP
*        MRELS               RELEASE BUFFER TO FREE POOL
*        XTRACE              TRACE CALLER 
* 
*     8. DAYFILE MESSAGES.
*        *MREDUCE CALL ERROR* - BUFFER SIZE IS SMALLER THAN 
*                               REQUESTED SIZE, OR BUFFER SIZE
*                               ZERO, OR REQUEST SIZE ZERO. 
* 
*        W A R N I N G - THIS ROUTINE IS LOADED WITH XPIP,
*                        XCHKPCR, SDELQTB TOGETHER IN ONE 
*                        OVERLAY.  THE SUM OF THEIR PROGRAM 
*                        LENGTHS SHOULD NOT EXCEED THE
*CALL OSIZE 
* 
*#
*ENDIF
 
*CALL MACDEF
*CALL CYBERDEFS 
*CALL INPARU
*CALL FREETAB 
 
 MREDUCE  SUBR   =           ENTRY/EXIT 
 
          IFEQ   DEBUG,1,6
          SX6    A1 
          SA6    TEMP 
          SX1    XMREC
          RJ     XTRACE 
          SA1    TEMP 
          SA1    X1 
 
          SB1    1
          SA2    X1          (X2)=BUFADDR 
          LOAD   A3,X2,FRBBS# (X3)=BUFFER HEADER WORD 
          SA4    A1+B1
          SA4    X4          (X4)=REQUEST SIZE
 
          IFEQ   DEBUG,1,1
          ZR     X4,RDZ      ERROR IF REQUEST SIZE IS ZERO
 
          LX3    -FRBBS?+FRBBS$-1 RIGHT JUSTIFY BLOCK SIZE
          SX5    X3          (X5)=BLOCK SIZE
 
          IFEQ   DEBUG,1,1
          ZR     X5,RDZ      ERROR IF BLOCK SIZE IS ZERO
 
          IX6    X5-X4       (X6)=BLOCK SIZE-REQUEST SIZE 
 
          IFEQ   DEBUG,1,1
          MI     X6,RDZ      ERROR IF BLOCK SIZE IS LE REQUEST SIZE 
 
          BX7    X3-X5
          LX6    FRBBS?-FRBBS$+1  BLOCK HEADER FOR RELEASING BLOCK
          BX7    X7+X4
          SB2    X2          (B2)=BUFADDR 
          LX7    FRBBS?-FRBBS$+1  BLOCK HEADER FOR BUFADDR BLOCK
          SB2    B2+X4       (B2)=ADDR OF RELEASING BUFFER
          SA7    X2          SET NEW HEADER FOR BUFADDR BLOCK 
          SA6    B2          SET HEADER FOR RELEASING BLOCK 
          SX6    B2 
          SA6    RLPM 
          SA1    RLPMD
          RJ     MRELS       RELEASING EXTRA SPACE
          EQ     MREDUCEX    RETURN 
 
 RDF2     IFEQ   DEBUG,1
 RDZ      BSS    0
          SA1    MSGDR
          RJ     ABORT       *----ABORT---* 
 
 MSGDR    VFD    60/MSGD
          BSSZ     1
          MX0    30      PROTECT LOWER BITS 
          BX7    X7*X0
 MSGD     DATA   L*MREDUCE CALL ERROR*
 XMREC    DATA   L*MREDU* 
 TEMP     BSS    1
 RDF2     ENDIF 
 
 RLPMD    VFD    60/RLPM
 RLPM     BSSZ   1
 
          END