Retro1.org codex

PROC FSEFORM;
BEGIN
 
 
#
***       FSEFORM -- STRING FORMATTING AND OUTPUT ROUTINES.
*
*         COPYRIGHT CONTROL DATA SYSTEMS INC.  1992.
#
 
  DEF LISTCON #0#;
 
*IFCALL SINGLE,COMFSGL
*IFCALL ONLY,COMFONL
*IFCALL MULTI,COMFMLT
*CALL COMFFSE
 
                             # COMMON DATA       #
 
 
CONTROL IFEQ MULTI,1;
  XREF ARRAY RENTSTK [1:MAXREENT];     # SUBROUTINE STACK  #
    BEGIN
    ITEM RSTK;
    END
  XREF ITEM RSTKPTR;
CONTROL FI;
PAGE                         # COMMON DATA, EXTERNALS      #
 
 
*CALL COMFDS1
*CALL COMFVD2
*CALL COMFDS2
*CALL COMFTAB
 
 
XREF
  BEGIN
*CALL COMFXSB
*CALL COMFXVT
*CALL COMFXTI
  END
 
 
XDEF
  BEGIN
*CALL COMFXFO
  END
PAGE PROC TTWRD;
  IOBEGIN(TTWRD)
#
**        TTWRD - TRANSMIT ONE-WORD ACCUMULATOR TO OUTPUT.
*
*         ENTRY  TTOWB - CONTAINS TEXT TO BE OUTPUT.
*                TTCDC - SHOWS CHARACTER COUNT IN TTOWB.
*
*         EXIT   BOTH PARAMETERS CLEARED.
*
*         CALLS  VDTWTO.
#
  VDTWTO(TTOWB);               # TRANSMIT WORD     #
  TTOWB = 0;                  # CLEAR WORD        #
  TTCBC = -1;                 # SHOW EMPTY        #
  IOEND
 
 
PROC TTSYNC;
  IOBEGIN(TTSYNC)
#
**        TTSYNS - CONDITIONALLY DRAIN ONE-WORD ACCUMULATOR.
*
*         ENTRY  TTCBC - CHARACTER COUNT IN TTOWB.
*
*         EXIT   TTCBC CLEAR, OUTPUT POSSIBLY TRANSMITTED.
*
*         CALLS  TTCHR, TTWRD.
#
  IF TTCBC GQ 0 THEN         # DRAIN PREVIOUS    #
    BEGIN
    CONTROL IFEQ SINGLE,1;
      IF NOT TTYOUTPUT THEN GOTO TTSYNC2;
    CONTROL FI;
    IF TTCBC LAN 1 EQ 0 THEN TTCHR(O"00");
    TTCHR(O"00");                    # CONTROL BYTE 0013B #
    TTCHR(O"13");
TTSYNC2:
    IF TTCBC EQ 9 THEN TTWRD;
    TTWRD;
    END
  IOEND                        # OF TTSYNC         #
 
 
PROC TTINIT;
  BEGIN
#
**        TTINIT - INITIALIZE ONE-WORD ACCUMULATOR.
*
*         EXIT   TTCBC, TTOCB, TTOWB - CLEARED.
#
  TTOWB=0;
  TTOCB=0;
  TTCBC=-1;
  END                         # OF TTINIT         #
PAGE PROC TTCHL(A);          # CHAR (LEFT)       #
  IOBEGIN(TTCHL)
#
**        TTCHL - FORMAT ONE CHARACTER FROM LEFT OF PARM.
*
*         ENTRY  A - WORD WITH CHARACTER IN TOP OF WORD.
*                SCREENMODE - WHETHER TO USE VIRTERM OR TTWRD.
*
*         CALLS  VDTCHR, TTWRD.
*
*         USES   TTOCB, TTCBC, TTOWB.
#
  ITEM A;
  ITEM B;
  IF SCREENMODE THEN
    BEGIN
    B=C<0,1>A;
    B=XLTDSPXP[B];
    VDTCHR(B);
    END
  ELSE
    BEGIN
    TTOCB = A;                  # HOLD CHAR         #
    IF TTCBC EQ 9 THEN TTWRD;   # FULL WORD         #
    TTCBC = TTCBC + 1;          # INCREMENT POINTER #
    C<TTCBC>TTOWB = C<0>TTOCB;  # CHAR TO WORD      #
    END
  IOEND
 
PROC TTCHR(A);
  IOBEGIN(TTCHR)
#
**        TTCHR - FORMAT CHARACTER FROM RIGHT OF WORD.
*
*         ENTRY  A - WORD WITH CHARACTER IN RIGHT END.
*
*         CALLS  TTCHL.
#
  ITEM A,B;
  C<0,1>B=C<9,1>A;
  TTCHL(B);
  IOEND                       # OF TTCHR          #
PAGE PROC TTST(A,B);
  IOBEGIN(TTST)
#
**        TTST - FORMAT STRING OF SPECIFIED LENGTH.
*
*         ENTRY  A - STRING OF 6-BIT CHARACTERS.
*                B - LENGTH OF STRING.
*
*         CALLS  TTCHL.
*
*         USES   P<STR>, STL, S2.
#
  ITEM A C (240), B;
  P&lt;STR> = LOC(A);            # SAVE PARMS        #
  STL = B - 1;
  FOR S2=0 STEP 1 UNTIL STL DO TTCHL(C&lt;S2>ST);    # COPY STRING #
  IOEND
 
 
PROC TTSTR(A);
  IOBEGIN(TTSTR)
#
**        TTSTR - FORMAT STRING TERMINATED BY $
*
*         ENTRY  A - STRING.
*
*         CALLS  TTST, TTBRK.
*
*         USES   S1.
#
  ITEM A C (240);
  S1 = 0;
  WHYLE S1 LS 80 AND C&lt;S1>A NQ "$" DO S1 = S1+1; # FIND END OF STR #
  IF S1 EQ 80 THEN
    BEGIN                      # ERROR             #
    TTST("NO $ IN TTSTR STRING",20);
    TTBRK;
    END
  ELSE TTST(A,S1);            # WRITE THE STRING  #
  IOEND
 
 
PROC TTLCSTR(A);
  IOBEGIN(TTLCSTR)
#
**        TTLCSTR - TTSTR WITH CONVERT TO LOWER-CASE ON SCREEN.
*
*         ENTRY  A - UPPER-CASE STRING WITH $ TERMINATOR.
*
*         CALLS  VDTCHR, MORTAL.
*
*         USES   S1, P<STR>.
#
  ITEM A C(240);
  ITEM B I;
  IF NOT SCREENMODE THEN MORTAL(" SCREEN MODE REQUIRED.$");
  S1 = 0;
  P&lt;STR> = LOC(A);
  WHYLE C&lt;S1>ST NQ "$" DO
    BEGIN
    B = C&lt;S1>ST;
    IF B GQ "A" AND B LQ "Z" THEN VDTCHR(XLTDSPXP[B]+O"40");
    ELSE VDTCHR(XLTDSPXP[B]);
    S1 = S1 + 1;
    END
  IOEND              #   OF TTLCSTR   #
 
 
PAGE PROC TTBRK;
  IOBEGIN(TTBRK)
#
**        TTBRK - FORMAT END-OF-LINE.
*
*         ENTRY  TTCBC, SCREENMODE - CONTROL NEED TO DO ANYTHING.
*
*         CALLS  TTCHL, TTWRD.
#
  IF TTCBC GQ 0 AND NOT SCREENMODE THEN  # NON-TRIVIAL       #
    BEGIN
    IF C&lt;TTCBC>TTOWB EQ 0 THEN TTCHL(" ");  # BLANK AFTER COLON #
    IF TTCBC EQ 8 THEN TTCHL(" ");      # NO 66-BIT EOL     #
    IF TTCBC GQ 8 THEN TTWRD;   # NEED EXTRA WORD #
    TTWRD;                      # DUMP THE EOL      #
    END
  IOEND
 
 
PROC TTLIN(A);               # TTSTR + TTBRK     #
  IOBEGIN(TTLIN)
#
**        TTLIN - COMBINED TTSTR AND TTBRK.
*
*         ENTRY  A - PARAMETER TO PASS ON TO TTSTR.
*
*         CALLS  TTSTR, TTBRK.
#
  ARRAY A;;
  TTSTR(A);                   # OUTPUT STRING     #
  TTBRK;                      # END LINE          #
  IOEND
 
 
PROC GETNUM(A,B);
  BEGIN
#
**        GETNUM - FORMAT NUMBER BY RADIX.
*
*         ENTRY  A - BINARY INTEGER TO ENCODE.
*                B - RADIX (BASE).
*
*         EXIT   NUMS1 - CONTAINS FORMATTED NUMBER.
*                S1, S2 - RESIDUAL VALUES LEFT FOR PUTNUM USAGE.
*
*         MACROS MOD.
*
*         USES   S1,S2.
#
  ITEM A,B;
  S1=ABS(A);
  S2 = -1;                  # COUNT DIGITS      #
  WHYLE S1 GQ B DO          # NOT DONE YET      #
    BEGIN
    S2 = S2 + 1;            # BUMP POINTER      #
    C&lt;S2>NUMS1 = MOD(S1,B) + O"33";   # GET A DIGIT       #
    S1 = S1/B;              # REDUCE NUMBER     #
    END
  END
 
 
PROC PUTNUM;                 # WRITE SET UP NUM  #
  IOBEGIN(PUTNUM)
#
**        PUTNUM - TRANSMIT NUMS1 AS BUILT BY GETNUM.
*
*         ENTRY  NUMS1 - ENCODED NUMBER IN GETNUM FORMAT.
*                S1, S2 - AS LEFT BY GETNUM.
*
*         EXIT   S2 - DESTROYED.
*
*         CALLS  TTCHL, TTCHR.
#
  TTCHR(S1+O"33");          # FIRST DIGIT       #
  FOR S2=S2 STEP -1 UNTIL 0 DO TTCHL(C&lt;S2>NUMS1);  # REST OF DIGITS #
  IOEND
PAGE PROC TTNUM(A,B);        # NUMBER A IN RADIX B         #
  IOBEGIN(TTNUM)
#
**        TTNUM - EXTERNAL INTERFACE TO ENCODE NUMBERS.
*
*         ENTRY  A - INTEGER TO ENCODE AND TRANSMIT.
*                B - RADIX.
*
*         CALLS  GETNUM, TTCHL, PUTNUM.
#
  ITEM A,B;
  GETNUM(A,B);              # SET UP S1,S2,NUMS1          #
  IF A LS 0 THEN TTCHL("-");          # MINUS SIGN        #
  PUTNUM;                   # AND WRITE NUMBER  #
  IOEND
 
 
PROC TTDEC(A);               # NUMBER A IN DECIMAL         #
  IOBEGIN(TTDEC)
#
**        TTDEC - ENCODE INTEGER IN DECIMAL.
*
*         ENTRY  A - INTEGER.
*
*         CALLS  TTNUM.
#
  TTNUM(A,10);
  IOEND
 
 
PROC TTLPAD(A,N,C);          # LEFT PAD DECIMAL NUM        #
  IOBEGIN(TTLPAD)
#
**        TTLPAD - LEFT PADDED ENCODE AND TRANSMIT OF INTEGER.
*
*         ENTRY  A - INTEGER.
*                N - FIELD WIDTH.
*                C - PADDING CHARACTER.
*
*         CALLS  GETNUM, PUTNUM, TTCHL.
*
*         USES   S2, S3, S4.
#
  ITEM A,N,C;
  IF A GQ 0 THEN              # DON'T DO NEGATIVE #
    BEGIN
    GETNUM(A,10);             # S2=WIDTH-1        #
    S3 = N - S2 - 3;          # S3=PAD WIDTH-1    #
    S4 = C;                   # PAD CHARACTER     #
    FOR S3=S3 STEP -1 UNTIL 0 DO TTCHL(S4);       # WRITE PADDING #
    PUTNUM;                   # WRITE NUMBER      #
    END
  IOEND
 
 
 
END TERM