Retro1.org codex

*DECK     NMI=RTE 
          IDENT  ROUTEM 
          TITLE  FILE ROUTING PROCESSOR 
*IF -DEF,EXCST
          COMMENT ROUTEM - FILE ROUTING/ENCSF FUNCTION
*ENDIF
*IF DEF,EXCST 
          COMMENT ROUTEM - FILE ROUTING/EXCST FUNCTION
*ENDIF
          ENTRY  ROUTEM 
 
 
          USE    /ROUTCOM/
LFN       BSS    1
CODE      BSS    1
TYPERT    BSS    1
 RTEOT    BSS    1           ORIGIN TYPE (BINARY) 
 RTESC    BSS    1           SVC CLASS (CHAR IF PRESENT)
          USE    *
 
 
          USE    /TERMCOM/
TCCNT     BSS    1
LCLBFR    BSS    65     BFR SPACE FOR BEGINIP / SAVE SPACE
          USE    *
 
**        ROUTEM
* 
*         PARAMETERS PASSED THRU COMMON:  
*                LFN (WORD 1) = NAME OF THE FILE TO BE ROUTED 
*                CODE (WORD 2)= ROUTE CODE (0=INPUT, 1=OUTPUT)
* 
*         RETURNED PARAMS:  
*                FETADDR = SYSTEM ASSIGNED JOB NAME 
*                CODE              = 0, SUCCESSFULL ROUTE OPERATION 
*                                  = 27, FNT FULL 
*                                  = 30, LOCAL FILE LIMIT 
*                                  = 33 DEFFERRED BATCH JOB LIMIT 
*         GENERAL COMMENTS: 
*                THE FILE TO BE ROUTED HAS TO RESIDE
*                ON A Q-DEVICE AND HAS TO CONTAIN A JOB.
*                THE USER NUMBER MUST HAVE BEEN VALIDATED 
*                PRIOR TO THE CALL TO THIS ROUTINE. 
*                AN INVALID USER NUMBER  IN A ROUTED JOB, WILL FORCE AN 
*                UNCONDITIONAL ABORT BY THE SYSTEM. 
* 
*                ROUTEM IS USED TO ROUTE THE NETWORK START-UP 
*                JOBS TO THE INPUT QUEUE AND START NIP
          EJECT 
PARAMS    BSSZ   7            ROUTE PARAMETER LIST
          BSSZ   8            EXTENDED PARAM LIST 
 
W1        VFD    14/0,3/5          FORMS CODE 
          VFD    7/0,12/2CIN       DISPOSITION CODE 
          VFD    6/0,1/1           RTRN SYS ASSIGNED JOBNAME
          VFD    4/0,1/1           RETURN ERROR CODE
          VFD    2/1               FORMS CODE FLAG
          VFD    5/0,1/1           DISP  CODE FLAG
          VFD    2/0,2/2           ROUTE TO CENTRAL SITE
 
W2        VFD    24/0 
          VFD    12/2HLP           LINE PRINTER 
          VFD    6/0
          VFD    18/22B            PRINT ANYWHERE 
 
OUN       VFD    42/0LSYSTEMX,18/0
          SPACE  4
ROUTEM    EQ     *+1
          MX6    0            CLEAR PARAMS AREA 
          SB1    1
          SA6    PARAMS+1 
          DUP    13,1 
          SA6    A6+B1
 
          SA2    LFN
          RJ     STRIP55
          SA6    A2 
 
          ZR     X2,GETJNAM   FILE NAME MISSING 
 
          SA2    CODE 
          SX3    1000B
          BX4    X2*X3
          NZ     X4,RSUB     IF NIP 
 
          MX0    42 
          SA1    LFN
          BX7    X1*X0             ISOLATE LFN
          SX4    4000B       SET
          BX7    X7+X4        FORCED ORIGIN FLAG
          SA7    PARAMS       IN WD-0 OF DSP BLOCK
 
          SA2    CODE              GET INPUT/OUTPUT QUEUE FLAG
          SX5    7B 
          BX2    X2*X5
          SB2    X2 
          SA3    W1+B2             PICK UP ROUTE PARAMETERS 
          BX6    X3 
          SA2    A2                GET CODE FOR SUBSYS FLAG 
          LX2    3                 CODE = XXXX XXXX XXXX XXXX XSXX
          BX7    X4*X2       ADD SUBSYSTEM FLAG 
          BX6    X6+X7        (IF PRESENT IN PARAM) 
          SA6    A7+B1        TO DSP CALL BLOCK / FET+1 
          BX0    X7          SAVE SUBSYSTEM FLAG IN X0
          NZ     X0,RT0       IF SUBSYSTEM
          SA1    RTEOT       PICK UP OT 
          NZ     X1,RT1       IF NOT SYOT 
 RT0      BSS    0
 
          SX5    100B         SET EXT PARAM BIT 
          BX6    X5+X6
          SA6    A6 
          SA3    OUN          SET OWNER USERNAME
          BX7    X3 
          SA7    PARAMS+10B 
          SX7    2
          SA7    A7-B1       / FET+7
          ZR     X0,RT1      IF NOT SUBSYSTEM 
 
          SA2    LFN          PUT LFN IN SUBSYSNAME 
          MX0    18 
          BX7    X0*X2
          LX7    18 
          SA7    A7-B1       / FET+6
          EQ     RT2
* 
 RT1      BSS    0
          SA1    RTEOT       PICK UP OT 
          LX1    1           PLACE
          SA2    A7           IN
          BX7    X1+X2        DSP 
          SA7    A7           CALL BLOCK / FET+0
          NZ     X1,RT2      IF NOT SYOT
          SA3    RTESC       WAS SC SPFD
          ZR     X3,RT2       NO
          LX3    36          SVC CLASS
          SA5    PARAMS+4     PARAMETER 
          BX7    X3+X5        TO DSP
          SA7    A5           CALL BLOCK / FET+4
          LX4    9           SET
          BX6    X6+X4        FORCED SC FLAG
          SA6    A6           IN DSP CALL BLOCK / FET+1 
RT2       BSS    0
* 
          SA1    PARAMS           SET STATUS MESSAGES 
          RJ     SMS1 
          SA5    TYPERT           IN TESTING MODE IF NON-ZERO 
          NZ     X5,RT3 
          ROUTE  PARAMS,R 
* 
RT3       BSS    0
          SA1    PARAMS 
          SX7    77B
          MX0    42 
          BX6    X0*X1
          SA6    LFN               RETURN SYSTEM ASSINGED JOB NAME
          AX1    12                POSITION ERROR CODE
          BX7    X7*X1
          SA7    CODE              ROUTE ERROR HAS BEEN ENCOUNTERED 
          SA1    PARAMS 
          RJ     SMS2              SEND ROUTE MESSAGE 
          EQ     ROUTEM 
 
GETJNAM   BSS    0
          SX6    88                TEMPORARY ERROR CODE FOR PASSING A 0 
*                                  LFN
          SA6    CODE 
          EQ     ROUTEM 
 
          EJECT 
 
 
STRIP55   EQ     *+1S17       ENTRY/EXIT
          MX0    60-6         VALUE IN X2 
          SX6    55B
          SB1    1
          SB4    10 
S55A      LX2    6
          BX3    -X0*X2 
          IX3    X3-X6        SEE IF BLANK
          NZ     X3,S55B
          BX2    X0*X2        SET TO 0 IF BLANK 
S55B      SB4    B4-B1
          NE     B4,B0,S55A 
          BX6    X2           MOVE TO X6 WHEN DONE
          EQ     STRIP55
          SPACE  4,8
FILL55    EQ     *+1S17       ENTRY/EXIT
          MX0    60-6         VALUE IN X1 
          SX6    55B
          SB1    1
          SB4    10 
F55A      LX1    6
          BX3    -X0*X1 
          NZ     X3,F55B
          BX1    X1+X6        ADD IN A BLANK
F55B      SB4    B4-B1
          NE     B4,B0,F55A 
          BX6    X1           MOVE TO X6 WHEN DONE
          EQ     FILL55 
 
 
 MVED     MACRO  VAL,EDFLD,BITS 
          SA1    VAL
          RJ     =XCOD= 
          SA2    EDFLD
          MX0    60-BITS
          BX2    X0*X2
          BX6    -X0*X6 
          BX6    X6+X2
          SA6    A2 
          ENDM
 
 
SMS1      EQ     *+1S17 
          MX0    60-18
          SA2    A1           FET+0 
          BX1    X0*X1
          MX0    6
+         LX1    6
          BX3    X0*X1             RIGHT JUSTIFY NAME 
          NZ     X3,* 
          RJ     FILL55 
          SA6    RTMSG        STARTING FILE NAME
          MX0    60-18
          BX6    -X0*X2 
          SA6    F0A
          SA2    A1+B1       FET+1
          MX0    60-21
          BX6    -X0*X2 
          SA6    F1A
          SA2    A2+3        FET+4
          MX0    60-12
          LX2    24 
          BX6    -X0*X2 
          SA6    F4A
          SA2    A2+2        FET+6
          MX0    60-18
          BX6    -X0*X2 
          SA6    F6A
          SA2    A2+B1       FET+7
          BX6    -X0*X2 
          SA6    F7A
          EQ     SMS1 
          SPACE  4,8
SMS2      EQ     *+1S17 
          MX0    60-18
          SA2    A1           FET+0 
          BX1    X0*X1        RETURNED SYSTEM NAME
          RJ     FILL55 
          SA6    RTMSG+3
          SX6    77B               12 BIT ERROR CODE
          LX2    60-12
          BX6    X6*X2
          SA6    F0B
 
          MVED   F0B,RTMS3+2,36 
 
          MESSAGE RTMSG,0,RECALL
          SA5    TYPERT 
          ZR     X5,SMS2B         TESTING IF NON-ZERO 
SMS2A     BSS    0
          MVED   F0A,RTMS2+0,36 
          MVED   F1A,RTMS2+1,42 
          MVED   F4A,RTMS2+2,24 
          MVED   F6A,RTMS2+3,36 
          MVED   F7A,RTMS2+4,36 
          MESSAGE RTMS2,0,RECALL
SMS2B     BSS    0
          SA5    F0B               CHECK ERROR CODE 
          ZR     X5,SMS2C 
          MESSAGE RTMS3,0,RECALL
SMS2C     BSS    0
          EQ     SMS2 
 
 
**        COPYNRF 
* 
 
COPYNRF   EQ     *+1S17 
          SB1    1
          OPEN   NRF1,WRITE,R    CREATE FILE NRF1 
          REWIND BEGINIP        REWIND FILE NIP 
          SKIPF  BEGINIP,1      SKIP 1 RECORD 
          READ   BEGINIP,1      READ 1 LOGICAL RECORD 
 CPYNRF1  BSS    0
          READW  BEGINIP,WBUF,WBUFL 
          NG     X1,COPF     IF EOF OR EOI ENCOUNTERED
          ZR     X1,CPYNRF2  IF FULL BUFFER 
          WRITEW NRF1,WBUF,X1-WBUF    COPY RECORD IN WBUF TO NRF1 
          WRITER NRF1,R      WRITE END-OF-RECORD
          REWIND NRF1 
          OPEN   NRF2,WRITE,R    CREATE FILE NRF2 
          READ   BEGINIP,1      READ 1 LOGICAL RECORD 
 CPYNRF3  BSS    0
          READW  BEGINIP,WBUF,WBUFL 
          NG     X1,COPF     IF EOF OR EOI ENCOUNTERED
          ZR     X1,CPYNRF4  IF FULL BUFFER 
          WRITEW NRF2,WBUF,X1-WBUF   COPY RECORD IN WBUF TO NRF2
          WRITER NRF2,R      WRITE END-OF-RECORD
          REWIND NRF2 
COPF      REWIND BEGINIP
          EQ     COPYNRF
* 
 CPYNRF2  BSS    0
          WRITEW NRF1,WBUF,WBUFL
          EQ     CPYNRF1
* 
 CPYNRF4  BSS    0
          WRITEW NRF2,WBUF,WBUFL
          EQ     CPYNRF3
 
RTMSG     DIS    ,*   FILNAME ROUTED, JOB NAME - XXXXXXXXXX*
 RTMS2    DIS    ,*  0=AAAAAA 1=BBBBBBB    4=CCCC  6=DDDDDD  7=EEEEEE*
RTMS3     DIS    ,* ERROR IN ROUTE FCN. EC=XXXXXXB* 
F0A       VFD    60/0 
F1A       VFD    60/0 
F7A       VFD    60/0 
F0B       VFD    60/0 
 F4A      BSS    1
 F6A      BSS    1
 
 
NBUFL     EQU    65 
PBUFL     EQU    65 
WBUFL     EQU    65 
          BSS    0
NRF1      FILEB  NBUF,NBUFL,(FET=6) 
          BSS    0
NRF2      FILEB  PBUF,PBUFL,(FET=6) 
NBUF      BSS    NBUFL
PBUF      BSS    PBUFL
WBUF      BSSZ   WBUFL
          EJECT 
*IF -DEF,EXCST
**        RSUB
*         WE GET HERE WHEN NIP IS TO BE EXECUTED.  IN THIS
*         CASE, WE HAVE WRAPPED UP ALL PROCESSING AND WILL
*         TRANSFER CONTROL TO NIPS JOB CONTROL, NEVER TO
*         RETURN. 
* 
 
RSUB      BSS    0                ENTRY 
          SA1    BEGINIP
          MX0    42 
          BX1    -X0*X1 
          SA2    LFN
          BX6    X1+X2
          SA6    A1 
 
          SA1    BEGINIP
          RJ     SMS1 
 
          RJ     COPYNRF     COPY NRF1/NRF2 
          SA5    TYPERT           IN TESTING MODE IF NON-ZERO 
          NZ     X5,RS2           JUST RETURN IF TESTING
 
          ENCSF  BEGINIP
          PSCSF  BEGINIP
 
          ENDRUN
 
RS2       BSS    0
          SA1    BEGINIP
          RJ     SMS2 
          EQ     ROUTEM 
 
BEGINIP   FILEB  LCLBFR,65,(FET=8)
RESTORE   VFD    60/0 
          SPACE  4
*ENDIF
*IF DEF,EXCST 
**        RSUB
*         WE GET HERE WHEN NIP IS TO BE EXECUTED.  IN THIS
*         CASE, WE HAVE WRAPPED UP ALL PROCESSING AND WILL
*         TRANSFER CONTROL TO NIPS JOB CONTROL, NEVER TO
*         RETURN. 
* 
 
RSUB      BSS    0            ENTRY/NO EXIT 
          SA1    BEGINIP+1
          MX0    6            SET CTL CARD BUFFER 
          BX5    X0*X1        SAVE PERIOD (.) 
          SA1    BEGINIP      ISOLATE (BEGIN,,) 
          MX0    42 
          BX4    X0*X1
          SA1    LFN          GET FIRST 3 CHAR OF LFN 
          MX0    18 
          BX3    X0*X1
          LX3    18           MUST BE AT LEAST 3 CHAR (NIP+++)
          BX6    X3+X4
          SA6    BEGINIP      SAVE (BEGIN,,NIP) 
          BX1    -X0*X1       CLEAR OUT (NIP) 
          LX1    18           READJUST AND ADD IN PERIOD
          SB1    1
          SB4    10 
          MX0    6
RS1       BX2    X0*X1
          ZR     X2,RS3 
          LX1    6
          SB4    B4-B1
          NE     B0,B4,RS1
RS3       BX6    X1+X5        PUT IN THE PERIOD (.) 
RS5       LX6    6
          SB4    B4-B1
          NE     B0,B4,RS5
          SA6    A6+B1
 
          EXCST  BEGINIP
 
          EQ     ROUTEM 
 
BEGINIP   DIS    ,*BEGIN,,NIP.* 
          SPACE  4
*ENDIF
          END