Thursday, March 14, 2019

PC/370 Assembler Object Code Translator

I had the great fortune to begin my career as an Assembler Programmer/Consultant at a large IBM MVS/370 mainframe data center. Designing & developing applications at the machine code level was invaluable in sharpening my skills. Here I'll provide a brief glimpse into the "ancient" 370 Assembler realm along with a fun PC/370 Object Code Translator I described in my initial blog post. This is it below - the animated GIF shows how instructions (in object code) are evaluated one-by-one by pressing the <Enter Key>. The program is loaded into memory & then it "translates itself" starting with offset x"0000". Each opcode is evaluated & the correct source code translation is displayed before bumping to the next opcode. When I shared this on an Assembler 370 Usenet Group there were several professors that asked if they could use this as an instructional aid in their classrooms - some as far as Bangalore.

The program is extremely precise in it's design & coding - the only blunder was the misspelling of "Translater" in the footing line of the distributed object code!




Below is a small pamphlet known as the "Yellow Card" - I still have mine tucked safely away. It's jam-packed with everything you need. With all the 2:00am core dumps I worked on it didn't take me long to know this pamphlet inside & out. Working on other programmer's abends made me extremely committed to developing neat, concise & efficient code that is virtually bug-free... my trademark.



Here's a closer look at the "Yellow Card". This section displays the 370 Instruction Set from x'00' thru x'FF' with pertinent information such as the source code mnemonic, instruction format, etc...



The machine formats describe how many bytes the instruction takes & the required operands, bit masks, registers & addresses. The machine instructions take up 2, 4 or 6 bytes.



I originally created my Object Code Translator in CICS (1991) then modified it to run on a Windows 486 PC (1996) using PC/370 (an ASM/370 Emulator written by Donald Higgins & eventually sold to Micro Focus - renamed as MF/370). It's just a fun exercise created in my spare time - having a neat, well-thought out programming style enables me to build complex applications very rapidly.

The major difference between the PC/370 (left) & CICS (right) versions are the screen & keyboard controls. The mainframe uses a dumb terminal that relays activity once all data entry is complete & a control key is pressed. The PC is more interactive with 100% control given to the programmer with every press of a key. CICS has special commands to SEND & RECEIVE maps/data/actions while in PC/370 I need to explicitly code the routines for keyboard handling & video screen display.


Below shows key handling for PC/370 (left) & CICS (right). I coded the routine KBGET to retrieve keystrokes which are then evaluated (using a copybook of key values I created - @K#ESC, @K#F1, etc...). CICS maps the keys in the HANDLE  AID command prior to issuing a RECEIVE MAP (ENTER, PF1, etc.) & control is passed to the corresponding address upon return to the program.


This is the routine that constructs the screen output. PC/370 allows a more versatile display with colors (the CICS version was a dull green monochrome).


***********************************************************************
*        BUILD DUMP FORMATTED SCREEN DISPLAY                          *
***********************************************************************
         CNOP  0,4                           SUBROUTINE ALIGNMENT
BUILD    EQU   *
         ST    6,BUILD@                      SAVE RETURN ADDRESS
*
         LA    4,MAP1I                       POINT TO MAP1 AREA
         LH    5,=Y(L'MAP1I)                 LOAD MAP1 LENGTH
         LA    6,=C' '                       POINT TO HEX00
         LH    7,=Y(1)                       LOAD LENGTH OF 1
         ICM   7,B'1000',=C' '               PAD CHAR = LOW-VALUES
         MVCL  4,6                           CLEAR MAP1 AREA (ORIG)
*
         MVC   ARG,OFFARG                    MOVE OFFARG BYTE 1
         BAL   6,XLATE                       TRANSLATE ARGUMENT
         MVC   M1OFFO(1),ARGZ                MOVE ARGUMENT ZONE
         MVC   M1OFFO+1(1),ARGN              MOVE ARGUMENT NUMERIC
         MVC   ARG,OFFARG+1                  MOVE OFFARG BYTE 2
         BAL   6,XLATE                       TRANSLATE ARGUMENT
         MVC   M1OFFO+2(1),ARGZ              MOVE ARGUMENT ZONE
         MVC   M1OFFO+3(1),ARGN              MOVE ARGUMENT NUMERIC
*
         MVC   ARG,LEN                       MOVE LENGTH BYTE 1
         BAL   6,XLATE                       TRANSLATE ARGUMENT
         MVC   M1LENO(1),ARGZ                MOVE ARGUMENT ZONE
         MVC   M1LENO+1(1),ARGN              MOVE ARGUMENT NUMERIC
         MVC   ARG,LEN+1                     MOVE LENGTH BYTE 2
         BAL   6,XLATE                       TRANSLATE ARGUMENT
         MVC   M1LENO+2(1),ARGZ              MOVE ARGUMENT ZONE
         MVC   M1LENO+3(1),ARGN              MOVE ARGUMENT NUMERIC
*
         LA    6,16                          SET LOOP COUNTER
         LA    7,M1LND                       POINT TO MAP LINE 1
         ST    7,MAPADDR                     SAVE MAP LINE ADDRESS
BCLEAR   EQU   *
         MVI   3(7),C' '                     MOVE SPACE TO 1ST BYTE
         MVC   4(78,7),3(7)                  PROPAGATE THRU LINE
         BCT   6,BCLEAR                      LOOP TIL ALL CLEAR
*
         LH    6,OFFSET                      LOAD OFFSET VALUE
         LH    7,LEN                         LOAD MODULE LENGTH
         CVD   6,DISP                        CONVERT TO DECIMAL
         ZAP   PLO,DISP+5(3)                 XFER TO LO POSITION
         ZAP   PHI,PLO                       INIT HI TO LO COUNTER
         SR    7,6                           SUB OFFSET FROM LENGTH
         STH   7,REM                         STORE REMAINING LENGTH
         L     7,PTR                         POINT TO LOAD MODULE
         AR    7,6                           ADD OFFSET VALUE
         ST    7,STARTPT                     SAVE STARTING POINT
         LH    6,REM                         LOAD REMAINING LENGTH
         ZAP   LINES,=P'0'                   INIT LINE COUNTER
BLOOP    EQU   *
         AP    LINES,=P'1'                   ADD +1 TO LINE COUNTER
         ZAP   PLO,PHI                       SET NEW LO TO PREV HI
         AP    PLO,=P'1'                     INCREMENT LO BY +1
         CH    6,=H'16'                      COMPARE REMAINING TO 16
         BL    BLOW                          LOW - ALTERNATE ROUTINE
         LH    5,=H'16'                      SET LOOP COUNTER = 16
         SH    6,=H'16'                      DECREMENT LENGTH CTR
         B     BSTH                          STORE NEW LENGTH
BLOW     EQU   *
         LR    5,6                           SET LOOP CTR = REM.LEN
         SR    6,6                           REMAINING LENGTH = 0
BSTH     EQU   *
         STH   6,REM                         SAVE REMAINING LENGTH
         L     3,MAPADDR                     POINT TO NEXT MAP LINE
         LA    3,3(,3)                       BUMP PAST LENGTH/ATTRIB.
         CVB   6,DISP                        CONVERT DISPLACEMENT
         STH   6,HALF                        STORE DISP IN HALF-WORD
         MVC   ARG,HALF                      MOVE OFFSET BYTE 1
         BAL   6,XLATE                       TRANSLATE ARGUMENT
         MVC   0(1,3),ARGZ                   MOVE ARGUMENT ZONE
         MVC   1(1,3),ARGN                   MOVE ARGUMENT NUMERIC
         MVC   ARG,HALF+1                    MOVE OFFSET BYTE 2
         BAL   6,XLATE                       TRANSLATE ARGUMENT
         MVC   2(1,3),ARGZ                   MOVE ARGUMENT ZONE
         MVC   3(1,3),ARGN                   MOVE ARGUMENT NUMERIC
         LA    3,9(,3)                       POINT TO HEX DUMP AREA
         LA    4,40(,3)                      POINT TO CHARACTER AREA
BDUMP    EQU   *
         MVC   ARG,0(7)                      MOVE LOAD MODULE BYTE
         BAL   6,XLATE                       TRANSLATE ARGUMENT
         MVC   0(1,3),ARGZ                   MOVE ZONE      PORTION
         MVC   1(1,3),ARGN                   MOVE NUMERIC   PORTION
         MVC   0(1,4),ARGT                   MOVE CHARACTER PORTION
         LA    4,1(,4)                       BUMP MAP LINE (CHAR-FMT)
         LA    3,2(,3)                       BUMP MAP LINE (HEX-FMT)
         LA    7,1(,7)                       BUMP LOAD MODULE PTR
         AP    PHI,=P'1'                     ADD +1 TO HI POSITION
         CVB   6,DISP                        CONVERT DISP TO BINARY
         STH   6,HALF                        STORE IN HALF-WORD
         TM    HALF+1,X'01'                  SKIP SPACE EVERY 4 HEX
         BNO   BSKIP                         NOT 4TH - SKIP THIS
         TM    HALF+1,X'02'                  SKIP SPACE EVERY 4 HEX
         BNO   BSKIP                         NOT 4TH - SKIP THIS
         LA    3,1(,3)                       SKIP EXTRA SPACE PLEASE
BSKIP    EQU   *
         AP    DISP,=P'1'                    ADD +1 TO DISPLACEMENT
         BCT   5,BDUMP                       LOOP TIL LINE FINISHED
*
         L     3,MAPADDR                     RELOAD MAP LINE ADDRESS
         LA    3,71(,3)                      POINT TO LO/HI AREA
         UNPK  0(5,3),PLO                    UNPACK LO POSITION
         OI    4(3),X'F0'                    MAKE LAST DIGIT CHAR.
         CP    PLO,PHI                       IS LO EQUAL TO HI ???
         BNL   *+18                          YES - THEN DON'T PUT HI!!
         MVI   5(3),C'-'                     NO  - MOVE DASH
         UNPK  6(5,3),PHI                    UNPACK HI POSITION
         OI    10(3),X'F0'                   MAKE LAST DIGIT CHAR.
*
         L     3,MAPADDR                     LOAD MAP LINE ADDR AGAIN
         LA    3,82(,3)                      BUMP TO NEXT POSITION
         ST    3,MAPADDR                     SAVE NEW FMTARR ADDRESS
         CP    LINES,=P'16'                  MAP AREA FILLED ???
         BNL   BUILDX                        YES - EXIT PLEASE
         LH    6,REM                         LOAD REMAINING LENGTH
         CH    6,=H'0'                       GREATER THAN ZERO ???
         BH    BLOOP                         YES - MORE LINES TO FILL
BUILDX   EQU   *
         L     6,BUILD@                      RESTORE LINK REGISTER
         BR    6                             BRANCH ON LINK REGISTER
***********************************************************************
         EJECT



This routine searches for the current opcode & builds the instruction based on the associated format:

***********************************************************************
*        TRANSLATE OBJECT CODE TO SOURCE CODE                         *
***********************************************************************
         CNOP  0,4                           SUBROUTINE ALIGNMENT
OPXLAT   EQU   *
         ST    6,OPXLAT@                     SAVE RETURN ADDRESS
*
         MVC   M1XLTO,BLANKS                 CLEAR XLATE LINE
         LH    6,OFFARG                      LOAD OFFSET ARGUMENT
         L     7,PTR                         LOAD MODULE ADDRESS
         AR    7,6                           POINT TO OP-CODE OFFSET
*
         LA    6,OPTABLE                     POINT TO OPCODE TABLE
OPXLOOP  EQU   *
         CLI   0(6),X'FF'                    END OF TABLE ???
         BE    OPXFND                        YES - USE DUMMY ENTRY
         CLC   0(1,6),0(7)                   TABLE OPCODE MATCH ???
         BE    OPXFND                        YES - CONTINUE PLEASE
         LA    6,12(,6)                      BUMP TABLE ENTRY
         B     OPXLOOP                       TEST NEXT TABLE ENTRY
OPXFND   EQU   *
         MVC   OPENTRY,0(6)                  MOVE TABLE ENTRY
         XC    HALF,HALF                     CLEAR HALF-WORD AREA
         MVC   HALF+1(1),OPLEN               MOVE INSTRUCTION LENGTH
         LH    6,OFFARG                      LOAD INSTRUCTION OFFSET
         AH    6,HALF                        ADD  INSTRUCTION LENGTH
         CH    6,LEN                         OFFSET MORE THAN LENGTH??
         BNH   *+16                          NO  - CONTINUE PLEASE
         MVC   OPENTRY,OPTABLEX              MOVE TABLE ENTRY (DUMMY)
         MVC   HALF+1(1),OPLEN               MOVE INSTRUCTION LENGTH
*
         SR    3,3                           INIT INSTRUCTION LENGTH
         LH    3,HALF                        LOAD INSTRUCTION LENGTH
         SRA   3,1                           DIVIDE LENGTH BY 2
         LA    4,M1XLTO                      POINT TO MAP AREA
         LR    5,7                           POINT TO INSTRUCTION
OPXOBJ   EQU   *
         MVC   ARG,0(5)                      MOVE 1ST BYTE TO ARGUMENT
         BAL   6,XLATE                       TRANSLATE ARGUMENT
         MVC   0(1,4),ARGZ                   MOVE ARGUMENT ZONE
         MVC   1(1,4),ARGN                   MOVE ARGUMENT NUMERIC
         MVC   ARG,1(5)                      MOVE 2ND BYTE TO ARGUMENT
         BAL   6,XLATE                       TRANSLATE ARGUMENT
         MVC   2(1,4),ARGZ                   MOVE ARGUMENT ZONE
         MVC   3(1,4),ARGN                   MOVE ARGUMENT NUMERIC
         LA    4,5(,4)                       BUMP MAP POINTER
         LA    5,2(,5)                       BUMP OBJ POINTER
         BCT   3,OPXOBJ                      PRINT INSTRUCTION OBJECT
*
         MVC   M1XLTO+23(6),OPMNE            MOVE MNEMONIC TO MAP
         LA    5,M1XLTO+34                   POINT TO OPERAND MAP AREA
         L     4,OPRTN                       LOAD FORMAT ROUTINE ADDR
         BALR  6,4                           GOTO FORMAT ROUTINE NOW...
OPXLATX  EQU   *
         L     6,OPXLAT@                     RESTORE LINK REGISTER
         BR    6                             BRANCH ON LINK REGISTER
***********************************************************************
         EJECT


Below is a small portion of the opcode table named "OPTABLE". It contains the opcode, instruction length in bytes, source code mnemonic & machine code format (actually the address of the machine code format routine).

***********************************************************************
*        OP-CODE TABLE                                                *
***********************************************************************
         CNOP  0,4                           FULL-WORD ALIGNMENT
OPTABLE  EQU   *
         DC    X'04',AL1(2),CL6'SPM   ',A(RR1)
         DC    X'05',AL1(2),CL6'BALR  ',A(RR1)
         DC    X'06',AL1(2),CL6'BCTR  ',A(RR1)
         DC    X'07',AL1(2),CL6'BCR   ',A(RR2)
         DC    X'0A',AL1(2),CL6'SVC   ',A(RR3)
         DC    X'0B',AL1(2),CL6'BSM   ',A(RR1)
         DC    X'0C',AL1(2),CL6'BASSM ',A(RR1)
         DC    X'0D',AL1(2),CL6'BASR  ',A(RR1)
         DC    X'0E',AL1(2),CL6'MVCL  ',A(RR1)

...
<SNIP>
...
         DC    X'F1',AL1(6),CL6'MVO   ',A(SSA)
         DC    X'F2',AL1(6),CL6'PACK  ',A(SSA)
         DC    X'F3',AL1(6),CL6'UNPK  ',A(SSA)
         DC    X'F8',AL1(6),CL6'ZAP   ',A(SSA)
         DC    X'F9',AL1(6),CL6'CP    ',A(SSA)
         DC    X'FA',AL1(6),CL6'AP    ',A(SSA)
         DC    X'FB',AL1(6),CL6'SP    ',A(SSA)
         DC    X'FC',AL1(6),CL6'MP    ',A(SSA)
         DC    X'FD',AL1(6),CL6'DP    ',A(SSA)
OPTABLEX EQU   *
         DC    X'FF',AL1(2),CL6'***   ',A(OPXLATX)
***********************************************************************
         EJECT


And here's a sample of a machine code format routine. This one is RR2 format which is typically a Register-to-Register instruction but in this case it's more of a Bitmask-to-Register format - that's why I deemed it RR2.

***********************************************************************
*        RR2   FORMAT:                       B'1111',R1               *
***********************************************************************
         CNOP  0,4                           FULL-WORD ALIGNMENT
RR2      EQU   *
         ST    6,SAVE@                       SAVE RETURN ADDRESS
*
         MVC   M1XLTO+17(3),=C'RR2'          MOVE FORMAT TO MAP
*
         MVO   RR(3),1(1,7)                  ISOLATE MASK1
         BAL   6,FMTBITS                     CONVERT/MOVE TO MAP
         MVI   0(5),C','                     MOVE COMMA TO MAP
         LA    5,1(,5)                       BUMP MAP 1 POSITION
         XC    RR,RR                         CLEAR REGISTER AREA
         MVC   RR+1(1),1(7)                  MOVE REG1/REG2
         NI    RR+1,X'0F'                    ISOLATE REG2
         BAL   6,FMTR                        CONVERT/MOVE TO MAP
*
         L     6,SAVE@                       RESTORE LINK REGISTER
         BR    6                             BRANCH ON LINK REGISTER
***********************************************************************
         EJECT


This was an interesting & fun exercise... a complex technical challenge that was quickly brought to life without the slightest problem. I miss the good old Assembler days...

WinBatch - Hyper-Extreme Numeric to Literal Translation Overkill

Here's a fun little WinBatch exercise that converts a numeric value to a literal English translation. The GUI is designed to simulate a paycheck. When you enter an amount & press the XLATE button the literal nomenclature is presented. The system date & LDAP name (based on the current userid) is also filled in on the check. I added the verbage "*** For Entertainment ONLY ***" to discourage anyone from printing the simulated check & trying to cash it. You will not get away with it...

The reason this blog post has "Hyper-", "Extreme" & "Overkill" in the title is due to the level of precision to the left of the decimal point. It would be a fair expectation, at least for a check, to translate to millions or even billions... or trillions (to write a check to resolve the national debt). But I figured why stop there... quadrillion, quintillion, sextillion... not even close... How about "Vigintillion"? 10^63 seems extreme enough... at least for now. With hyperinflation looming across the globe - particularly those societies devastated by socialism - I may have to revisit this...

Winbatch provides a slick little GUI Dialog Builder that allows you to design your page - edit/text boxes, buttons, checkboxes, images, etc. Below is the layout of the simulated check.

 
The GUI input is used to formulate the precise code for the page - the code can then be utilized in the main Winbatch program.



Now to test the "Simulated Check". Below I entered a simple amount of 10546.53 - a fairly modest first attempt. The verbage "Ten-Thousand Five-Hundred Forty-Six and 53/100" is displayed.



Time to get a little crazy with testing... $1,989,745,123.02 makes a nice payday!




Here's an extreme version that blows out the text box completely! I prefixed the result on the page with [***TOO BIG***] to indicate that the result is... too big.


An error box is triggered explaining the issue & contains the full literal translation... this example is the maximum translation I accounted for...



The full literal translation is also pasted to the clipboard to use any way you seem fit:

Nine Hundred Ninety-Nine Vigintillion Nine Hundred Ninety-Nine Novemdecillion Nine Hundred Ninety-Nine Octodecillion Nine Hundred Ninety-Nine Septendecillion Nine Hundred Ninety-Nine Sexdecillion Nine Hundred Ninety-Nine Quindecillion Nine Hundred Ninety-Nine Quatuordecillion Nine Hundred Ninety-Nine Tredecillion Nine Hundred Ninety-Nine Duodecillion Nine Hundred Ninety-Nine Undecillion Nine Hundred Ninety-Nine Decillion Nine Hundred Ninety-Nine Nonillion Nine Hundred Ninety-Nine Octillion Nine Hundred Ninety-Nine Septillion Nine Hundred Ninety-Nine Sextillion Nine Hundred Ninety-Nine Quintillion Nine Hundred Ninety-Nine Quadrillion Nine Hundred Ninety-Nine Trillion Nine Hundred Ninety-Nine Billion Nine Hundred Ninety-Nine Million Nine Hundred Ninety-Nine Thousand Nine Hundred Ninety-Nine and 99/100

Here's a glimpse into the WinBatch code - the main routine handles the page input - the entered amount & the button pressed. It then calls my translation function TDFUN_Num_To_Lit().

;**********************************************************************
;*       Display Dialog Box                                           *
;**********************************************************************

IntControl(4,0,0,0,0)

gosub TDInit

sw                        = @YES

while sw                 == @YES           ; CANCEL Button exits loop

   ButtonPushed           = Dialog("TD")

   Select ButtonPushed

      Case 1

         TDlit            = TDFUN_Num_To_Lit(TDpay)
         TDamt            = TDpay
         TDlen            = StrLen(TDlit)

         ClipPut(TDlit)

         if TDlen         > 256
            Message("Literal String Exceeds Panel Capacity (256B)",TDlit)
            TDlit         = StrCat("[***TOO BIG***] ",TDlit)
         endif
         break

      Case 2

         gosub TDhelp
         break

   EndSelect

endwhile

Exit

;**********************************************************************


And here is the TDFUN_Num_To_Lit() function... one of the most fun aspects of programming is dealing with arrays, indexes, pointers, segments & loops. This example has all of that...

;**********************************************************************
;*       NUMBER-TO-LITERAL FUNCTION                                   *
;**********************************************************************
;*                                                                    *
;*        INPUT: I_num      - Numeric Value                           *
;*       FORMAT: O_lit      - Literal Interpretation                  *
;*                                                                    *
;**********************************************************************

#DefineFunction TDFUN_Num_To_Lit(I_num)

O_lit                = ""

if ~ IsDefined(NLmtx)

   NLmtx             = ArrDimension(28)

;  Direct Indexing Literals

   NLmtx[1]          = "One"
   NLmtx[2]          = "Two"
   NLmtx[3]          = "Three"
   NLmtx[4]          = "Four"
   NLmtx[5]          = "Five"
   NLmtx[6]          = "Six"
   NLmtx[7]          = "Seven"
   NLmtx[8]          = "Eight"
   NLmtx[9]          = "Nine"
   NLmtx[10]         = "Ten"
   NLmtx[11]         = "Eleven"
   NLmtx[12]         = "Twelve"
   NLmtx[13]         = "Thirteen"
   NLmtx[14]         = "Fourteen"
   NLmtx[15]         = "Fifteen"
   NLmtx[16]         = "Sixteen"
   NLmtx[17]         = "Seventeen"
   NLmtx[18]         = "Eighteen"
   NLmtx[19]         = "Nineteen"
   NLmtx[20]         = "Twenty"

;  Combination Indexing Literals
   NLmtx[21]         = "Thirty"
   NLmtx[22]         = "Forty"
   NLmtx[23]         = "Fifty"
   NLmtx[24]         = "Sixty"
   NLmtx[25]         = "Seventy"
   NLmtx[26]         = "Eighty"
   NLmtx[27]         = "Ninety"

   NLmax             = 27

endif

;   Set Level Parameters (Element String, Length, Occurs)
L_str                = ""
L_str                = StrCat(L_str,"~Vigintillion~$$$$$$")  ; 10^63
L_str                = StrCat(L_str,"~Novemdecillion~$$$$")  ; 10^60
L_str                = StrCat(L_str,"~Octodecillion~$$$$$")  ; 10^57
L_str                = StrCat(L_str,"~Septendecillion~$$$")  ; 10^54
L_str                = StrCat(L_str,"~Sexdecillion~$$$$$$")  ; 10^51
L_str                = StrCat(L_str,"~Quindecillion~$$$$$")  ; 10^48
L_str                = StrCat(L_str,"~Quatuordecillion~$$")  ; 10^45
L_str                = StrCat(L_str,"~Tredecillion~$$$$$$")  ; 10^42
L_str                = StrCat(L_str,"~Duodecillion~$$$$$$")  ; 10^39
L_str                = StrCat(L_str,"~Undecillion~$$$$$$$")  ; 10^36
L_str                = StrCat(L_str,"~Decillion~$$$$$$$$$")  ; 10^33
L_str                = StrCat(L_str,"~Nonillion~$$$$$$$$$")  ; 10^30
L_str                = StrCat(L_str,"~Octillion~$$$$$$$$$")  ; 10^27
L_str                = StrCat(L_str,"~Septillion~$$$$$$$$")  ; 10^24
L_str                = StrCat(L_str,"~Sextillion~$$$$$$$$")  ; 10^21
L_str                = StrCat(L_str,"~Quintillion~$$$$$$$")  ; 10^18
L_str                = StrCat(L_str,"~Quadrillion~$$$$$$$")  ; 10^15
L_str                = StrCat(L_str,"~Trillion~$$$$$$$$$$")  ; 10^12
L_str                = StrCat(L_str,"~Billion~$$$$$$$$$$$")  ; 10^9
L_str                = StrCat(L_str,"~Million~$$$$$$$$$$$")  ; 10^6
L_str                = StrCat(L_str,"~Thousand~$$$$$$$$$$")  ; 10^3
L_str                = StrCat(L_str,"$$$$$$$$$$$$$$$$$$$$")  ; Hundred
L_str                = StrCat(L_str,"$$$$$$$$$$$$$$$$$$$$")  ; Cents

L_str                = StrReplace(L_str, "$", " ")
L_pos                = 1
L_len                = 20
L_occ                = StrLen(L_str) / L_len

L_tot                = (L_occ * 3)
L_int                = (L_occ * 3)   - 3
L_dec                = (L_occ * 3)   - 1

;   Format Numeric String
ptr                  = StrIndex(I_num,".",1,@FWDSCAN)
if ptr              == 0
   I_num             = StrCat(I_num, ".")
   ptr               = StrLen(I_num)
endif
I_num                = StrCat(I_num,"00")
ptr                  = ptr + 2
I_num                = StrSub(I_num, 1, ptr)
I_num                = StrFixLeft(I_num, "0", L_tot)
W_num                = I_num
W_int                = StrSub(I_num,    1, L_int)
W_dec                = StrSub(I_num,L_dec,     2)

pos                  = 1
lev                  = 1

O_lit                = ""

while lev           <= (L_occ - 1)

   seg               = StrSub(W_num, pos, 3)

   if  seg           > '000'

       str           = StrTrim(StrSub(L_str, L_pos, L_len))
       str           = StrReplace(str, "~", " ")

       segHi         = StrSub(seg, 1, 1)
       segLo         = StrSub(seg, 2, 2)

       hi            = %segHi%
       lo            = %segLo%

       if  hi        > 0
           NLtxt     = NLmtx[hi]
           O_lit     = StrCat(O_lit, NLtxt, " Hundred")
           if  lo    > 0
               O_lit = StrCat(O_lit," ")
           endif
       endif

       ;   Combination Indexing
       if  lo        > 20
           adj       = Abs(lo/10) + 18
           NLtxt     = NLmtx[adj]
           O_lit     = StrCat(O_lit, NLtxt)
           lo        = lo mod 10
           if lo     > 0
              O_lit  = StrCat(O_lit,"-")
           endif
       endif

       ;   Direct Indexing
       if  lo        > 0
           NLtxt     = NLmtx[lo]
           O_lit     = StrCat(O_lit,NLtxt)
       endif

       O_lit         = StrCat(O_lit,str)

   endif

   lev               = lev   + 1
   pos               = pos   + 3
   L_pos             = L_pos + L_len

endwhile

if O_lit            == ""
   O_lit             = "Zero"
endif

;   Now process the cents portion
if  W_dec           <> '00'
    O_lit            = StrCat(O_lit," and ",W_dec, "/100")
endif

Return O_lit

#EndFunction

;**********************************************************************


I hope you enjoyed this post... and once again, please do not try to cash the simulated check output! This is your final warning...

Monday, March 11, 2019

SQL*Engine - Dynamic SQL Script Processor - Part 1

From my LinkedIn Projects: Designed/Developed Powerful Multi-Purpose SQL-Based Scripting Language. Conditional Step Driven Logic, Variable Substitution, Error Handling, Commit/Rollback, Math/String/Binary Functions, Script Library Support, Reporting, Step Status/Row Count Summary & more. Also, Process Scheduler Integrated, Audit Inquiry Page, Custom File Watcher/Auto-Script Archiving - Frequently used for Production Administration/SQL Updates/Etc. - Safer & more reliable than standard SQL scripting (due to conditional step execution).

SQL*Engine is a custom scripting language I developed that is powered by a single SQR source module named XX_TDSQL.SQR. The language itself is best described as a cross between SQL*Plus, Application Engine & JCL (Job Control Language). Originally developed in 1999 I've been adding considerable functionality - the latest being full integration with PeopleSoft Process Scheduler, Automatic Script Detection/Security/Execution/Archiving & a Script Result Audit Page (as well as full reporting history).

Below is a sample of the SQL*Engine Audit Page - Each step is displayed in the scroll bar with the resolved SQL along with the associated results - Step Name, Status, Counts, Timings & Condition (if applicable). This particular example is deleting run control records from 5 different tables. The full set of expected results must match the actual counts for the COMMIT to be performed - otherwise a ROLLBACK is issued.


Below is the raw executable script - XXSQI_RC_DELETE.SQX - the OPRID "PSBATCH" & RUN_CONTROL_ID pattern "AP_XXACH_R2_%" are assigned to dynamic variables &&OPRID and &&RUNCONTROL which will be utilized in each DELETE statement. Variables are also set for 5 expected results & initialized for the related SQL results. Notice the steps are given an optional "Step Name". The steps are named as follows:
  • @STEP=DELETE_XX_RUN_CNTL_AP
  • @STEP=DELETE_PRCSRUNCNTLDIST
  • @STEP=DELETE_PRCSRUNCNTLEOPT
  • @STEP=DELETE_PRCSRUNCNTLDTL
  • @STEP=DELETE_PRCSRUNCNTL
  • @STEP=COMPARE_COUNTS - Sets the Comparison Result
  • @STEP=COMMIT - Conditional depending on COMPARE_COUNTS results [@COND=SOME.COMPARE_COUNTS]
  • @STEP=ROLLBACK - Conditional - Executes Rollback if Commit is skipped [@COND=SKIP.COMMIT]

*****************************************************************
*                                                               *
*    MODULE: XXSQI_RC_DELETE.SQX                                *
*    AUTHOR: TONY DELIA.                                        *
*      DATE: 10/28/2015.                                        *
*      DESC: SQL*ENGINE SCRIPT - RUN CONTROL DELETE.            *
*                                                               *
*****************************************************************
*  STANDARD SQL*ENGINE DIRECTIVES                               *
*****************************************************************
@ON_ERROR=CONTINUE
@DELIMITER=|
@TIMING=ON
@SAFETY=ON
@SPOOL=OFF
*****************************************************************
*  PROGRAM VARIABLES                                            *
*****************************************************************
@HDR_REF=CRM_1210301
@HDR_DESCR=Delete Run Controls AP_XXACH_R2_<BU>
*****************************************************************
*  SET OPRID/RUNCONTROL VARIABLES                               *
*****************************************************************
@SET=&&OPRID=PSBATCH
@SET=&&RUNCONTROL=AP_XXACH_R2_%
*****************************************************************
*  SET EXPECTED RESULTS / INITIALIZE COUNTS TO ZERO             *
*****************************************************************
@SET=&&EXP_A=47
@SET=&&EXP_B=361
@SET=&&EXP_C=44
@SET=&&EXP_D=47
@SET=&&EXP_E=47
@SET=&&CTR_A=0
@SET=&&CTR_B=0
@SET=&&CTR_C=0
@SET=&&CTR_D=0
@SET=&&CTR_E=0
*****************************************************************
*  A - DELETE XX_RUN_CNTL_AP                                    *
*****************************************************************
@STEP=DELETE_XX_RUN_CNTL_AP
delete
  from ps_xx_run_cntl_ap
 where oprid             = '&&OPRID'
   and run_cntl_id    like '&&RUNCONTROL'
/
@SET=&&CTR_A=@ROWS
*****************************************************************
*  B - DELETE PRCSRUNCNTLDIST                                   *
*****************************************************************
@STEP=DELETE_PRCSRUNCNTLDIST
delete
  from ps_prcsruncntldist
 where oprid             = '&&OPRID'
   and runcntlid      like '&&RUNCONTROL'
/
@SET=&&CTR_B=@ROWS
*****************************************************************
*  C - DELETE PRCSRUNCNTLEOPT                                   *
*****************************************************************
@STEP=DELETE_PRCSRUNCNTLEOPT
delete
  from ps_prcsruncntleopt
 where oprid             = '&&OPRID'
   and runcntlid      like '&&RUNCONTROL'
/
@SET=&&CTR_C=@ROWS
*****************************************************************
*  D - DELETE PRCSRUNCNTLDTL                                    *
*****************************************************************
@STEP=DELETE_PRCSRUNCNTLDTL
delete
  from ps_prcsruncntldtl
 where oprid             = '&&OPRID'
   and runcntlid      like '&&RUNCONTROL'
/
@SET=&&CTR_D=@ROWS
*****************************************************************
*  E - DELETE PRCSRUNCNTL                                       *
*****************************************************************
@STEP=DELETE_PRCSRUNCNTL
delete
  from ps_prcsruncntl
 where oprid             = '&&OPRID'
   and run_cntl_id    like '&&RUNCONTROL'
/
@SET=&&CTR_E=@ROWS
*****************************************************************
*  COMPARE ROW COUNTS VS. EXPECTED                              *
*****************************************************************
@STEP=COMPARE_COUNTS
@COUNT=PSCLOCK
 WHERE TO_NUMBER('&&EXP_A') = TO_NUMBER('&&CTR_A')
   AND TO_NUMBER('&&EXP_B') = TO_NUMBER('&&CTR_B')
   AND TO_NUMBER('&&EXP_C') = TO_NUMBER('&&CTR_C')
   AND TO_NUMBER('&&EXP_D') = TO_NUMBER('&&CTR_D')
   AND TO_NUMBER('&&EXP_E') = TO_NUMBER('&&CTR_E')
/
*****************************************************************
*   COMMIT                                                      *
*****************************************************************
@STEP=COMMIT
@COND=SOME.COMPARE_COUNTS
commit
/
*****************************************************************
*   ROLLBACK                                                    *
*****************************************************************
@STEP=ROLLBACK
@COND=SKIP.COMMIT
rollback
/
*****************************************************************
*  END OF SQL*ENGINE SCRIPT                                     *
*****************************************************************


After each SQL Execution (/) the assigned variable is set with the Row Count (@ROWS). For example @SET=&&CTR_A=@ROWS populates the &&CTR_A variable with the result of the first delete step (DELETE_XX_RUN_CNTL_AP) - 47 rows (See Audit Page for Step 1).

SQL*Engine assigns results to each step - the STEP Status will be set to PASS, SKIP or FAIL while the Row Status will be set to SOME or ZERO (or blank in the event of SKIP/FAIL). These step status values may be used to control subsequent SQL execution. In this example the COMPARE_COUNTS step has produced the expected results for each step. The SELECT COUNT construct (@COUNT) sets the Row Status to SOME (the Step Status is set to PASS).

The COMMIT step is performed depending on the condition setting - @COND=SOME.COMPARE_COUNTS - The condition matches & commit is executed.

The ROLLBACK step has the condition of @COND=SKIP.COMMIT - the COMMIT step wasn't skipped - it has a step status of PASS - so the ROLLBACK step is not executed (set to SKIP).

Report Snippets:

The generated report displays the resolved SQL statements, directives, variable assignments, messages, begin/end/elapsed times & more...



 A closer look at how the SQL*Engine directives control the flow of the process...


At the end of the report, a summary of each step is presented with the results & pertinent information.


This was a very simple application but a good example of how SQL*Engine works. This is a slick, high quality utility so I'll be posting more brief articles about this.



Custom nVision Report Book Manager - "Single-Click" Execution

From my LinkedIn Projects: nVision/Report Book Manager – Created “Single-Click” Report Book Execution Tool for Month End Close. Unlimited Report Books containing hundreds of report/scopes managed, queued & executed automatically. Up to 3 processing threads managed (NT1/NT2) & report books queued "until all have completed". Each instance execution relays a status email to users showing which books have completed, are processing and/or still pending. I created this upon discovering the finance team was spending nights running reports manually one after another. *To be clear, PeopleSoft does not provide this functionality - it only allows a single report book to be scheduled at a "predetermined static time".




I created the XXRBKMGR process to maximize the efficiency of our Month End GL Close Reporting. We have approximately 250 nVision Report Templates that generate over 2,500 individual xls report files. To alleviate running each report manually the obvious first step is to group them into report books. Now we have 25 report books - run controls SP_RB_GRP01 thru SP_RB_GRP25. They are divided & sequenced based on how long the reports run & the priority of availability. As mentioned in the introduction, PeopleSoft does allow you to schedule a report book at a specific date/time - but there is no flexibility. Month End close is typically a stress filled exercise that requires last minute postings & possible time extensions - there is NO static schedule for running the close. Furthermore, a mindless static schedule could potentially take up threads that would interfere with normal nightly batch processing - queuing jobs indiscriminately can have adverse effects. Also, when a report book ends another one isn't queued up to run when the thread is available - it sticks to the schedule.

 Sample Report Book Definition:


The dilemna is multi-faceted:

  • The GL Closing is not on a predetermined schedule but rather a verbal command to begin once all postings & last minute adjustments have been made.
  • Report Books must be processed by a limited group of threads so they don't effect the nightly batch. Long running nVision reports can potentially consume all processing threads & bring production to a halt.
  • For increased efficiency load balancing must occur between our NT1/NT2 servers - a real-time assessment must be made to assign the server effectively.
  • When a report book completes there is no time to waste - the next book must be quickly queued for execution. An idle thread translates to delays in final report delivery.
  • Run Control dates for all report books must be maintained on a monthly basis.
  • Periodic Status Notifications showing the report books that have Completed, are Running & still Pending would be useful.

The Solution:


That's it - execute XXRBKMGR.SQR - a "Single-Click" to handle everything... Automatic queuing, notifications, parameter settings, load balancing, etc...

Once XXRBKMGR is initially invoked it will requeue itself automatically every X minutes (currently set to 30) as long as there are report books running and/or pending. When all are complete the process ends.

Notification Samples:

The first occurrence of  XXRBKMGR produces this email - it launched report books 6, 10 & 7 with the other 22 still pending. The numbers represent report book SP_RB_GRP<xx>.

 Now all Report Books have completed. This is the ***FINAL*** notification.



XXRBKMGR report sample - Accessed via Process Monitor or click the URL provided in the email:

*Notice Report Book SP_RB_GRP08 is still running & accounted for in this example.


Here's some code snippets... it's a very tight streamlined process.

!**********************************************************************
!*                                                                    *
!*       MODULE: XXRBKMGR.SQR                                         *
!*       AUTHOR: TONY DELIA.                                          *
!*         DATE: 03/17/2016.                                          *
!*       SYSTEM: NSS/ADVANCE PUBLICATIONS - PSOFT 8.8 FINANCIALS.     *
!*         DESC: NVISION REPORTBOOK MANAGER.                          *
!*                                                                    *
!**********************************************************************
!*                                                                    *
!*       TABLES: ps_xx_run_cntl_gl   - Select                         *
!*               ps_xx_rb_map        - Select                         *
!*               ps_xx_rb_hdr        - Select, Update, Insert         *
!*               ps_xx_rb_run        - Select, Update, Insert         *
!*               psprcsrqst          - Select                         *
!*               psnvsbook           - Select, Update                 *
!*               psnvsbookrequst     - Select                         *
!*               ps_nvs_report       - Select, Update                 *
!*               psserverstat        - Select                         *
!*                                                                    *
!**********************************************************************


The number of threads & the time increment between recurring XXRBKMGR executions are defined here:

#define RB_THREADS       3   ! Maximum Open Threads
#define RB_MINS         30   ! ReportBook Manager Increment


Below is the core logic for evaluating Complete, Running & Pending items and, if needed, will queue another report book with the proper load balancing. I'm acutely aware that this sample is a "teaser" - the RUN_Init function does all the heavy lifting. I created this years ago (XX_RUN.SQC) to load Process Requests for SQR, Application Engine, COBOL, Crystal Reports, nVision Report Books, etc.

  evaluate $A_process_status

     when = 'P'

        if #THREADS                < {RB_THREADS}

           if  #PRI_ctr            < 2
               let $B_server       = $SVR_pri
               let #PRI_ctr        = #PRI_ctr + 1
           else
               let $B_server       = $SVR_alt
           end-if

           let $RCX_svr            = $B_server

           let $RUN_type           = '7'
           let $RUN_prcs           = 'RPTBOOK'
           let $RUN_oprid          = $A_oprid
           let $RUN_cntl           = $A_run_cntl_id

           do RUN_Init($RUN_type, $RUN_prcs, $RUN_oprid, $RUN_cntl, #RUN_pi)

           let $A_process_status   = 'R'
           let #A_process_instance = #RUN_pi
           let #A_process_inst_stg = #prcs_process_instance

           do Update_XX_RB_RUN

           let #THREADS            = #THREADS + 1
          
        end-if

        break

     when = 'R'

        let #A_active              = instr('*5*6*7*16*', $B_runstatus, 1)

        if  #A_active              > 0

            let #THREADS           = #THREADS + 1

            if  $B_server          = $SVR_pri
                let #PRI_ctr       = #PRI_ctr + 1
            end-if

        else

            let $A_process_status  = 'C'

            do Update_XX_RB_RUN

        end-if

   end-evaluate


Below is a snippet of the dynamic requeuing of XXRBKMGR - as long as there are Running or Pending report books it will queue itself in 30 minutes {RB_MINS}. There's the RUN_Init() teaser again... extremely powerful & useful utility I created. It's used extensively here at NSS/ACSI for a variety of applications.

let #PR_ctr              = #P_ctr + #R_ctr

if  #PR_ctr              > 0

    let $RCX_dttm        = DateToStr(DateAdd(DateNow(),'minute',{RB_MINS}),'YYYYMMDD_HH24:MI')
    let $SAV_dttm        = $RCX_dttm

    let $RCX_svr         = 'PSUNX'

    let $RUN_type        = '1'
    let $RUN_name        = 'XXRBKMGR'
    let $RUN_id          = 'PSBATCH'
    let $RUN_cntl        = $prcs_run_cntl_id
    if  $RUN_cntl        = ''
        let $RUN_cntl    = 'SP_RPTBOOK_MGR'
    end-if

    do RUN_Init($RUN_type, $RUN_name, $RUN_id, $RUN_cntl, #RUN_pi)

    show ' '
    show 'PI#: ' #RUN_pi edit 99999999 '  RC: ' $RUN_cntl '  Date/Time: ' $SAV_dttm
    show ' '

else

    let $HDR_status      = 'C'

    do Update_Report_Books_POST

end-if

do Update_XX_RB_HDR

do Send_Email



Once all reporting is complete & thoroughly reviewed by the GL team I have another process, written in PowerShell, that uploads the reports to SharePoint (another "Single-Click" solution).

This concludes my Custom Report Book Manager post... I hope you found it interesting.

Sunday, March 10, 2019

PC/370 Assembler Creation - Stars & Stripes Forever

While perusing through my archives I came across a fun PC/370 Assembler program I created. PC/370 is a freeware application (developed by Donald Higgins) that allows you to write IBM 370 Mainframe Assembler programs on the PC (particularly 286 thru 486 models - Windows 10 requires the free DOSBox shell application to run). Mainframe supervisor calls are emulated by DOS interrupts to handle keyboard, video, I/O, etc. - CPU 370 registers are mapped to the DOS registers, flags & stack pointers along with the appropriate supervisor to interrupt codes.

This is a patriotic example of keyboard/video screen handling. I admit this is embarrassingly inaccurate - it was a very quick lunch break exercise & I didn't have time to map out 50 stars & 13 stripes. Nonetheless, the program demonstrates the formation of blue, red & white blocks along with blinking stars activated by pressing the F1 key. Source code to follow. Take note of the style, neatness & efficiency of the code. It doesn't matter if I'm coding for a client project or creating a quick demo - every line must be professional, concise & worthy of presentation - always...

Sample GIF of the TDFLAG program with toggling stars:


The TDFLAG.ALC program begins with the standard IBM linkage conventions - the PC/370 application ensures the required elements are set properly from the operating system. R15 contains the program entry point address, R14 contains the return address (back to the O/S) & R13 is pointed to the external 18 fullword save area of the O/S.


         TITLE 'TDFLAG   - PC/370 4.2 DISPLAY FLAG // DELIA'
***********************************************************************
*                                                                     *
*        MODULE:  TDFLAG.                                             *
*        AUTHOR:  TONY DELIA.                                         *
*          DATE:  10/18/96.                                           *
*          DESC:  DISPLAY FLAG.                                       *
*          NOTE:  PC/370 RELEASE 4.2                                  *
*                                                                     *
***********************************************************************
         EJECT
***********************************************************************
*        T  D  F  L  A  G           P  R  O  G  R  A  M               *
***********************************************************************
TDFLAG   START 0                             START PROGRAM
         STM   14,12,12(13)                  SAVE REGISTERS
         LR    12,15                         LOAD PROGRAM ENTRY POINT
         USING TDFLAG+0*4096,12              BASE REGISTER 1
         L     11,BASE2                      LOAD BASE REGISTER 2
         USING TDFLAG+1*4096,11              TELL ASSEMBLER ABOUT BASE2
         L     10,BASE3                      LOAD BASE REGISTER 3
         USING TDFLAG+2*4096,10              TELL ASSEMBLER ABOUT BASE3
         ST    13,SAVE+4                     SAVE EXTERNAL SAVE ADDRESS
         LR    14,13                         XFER ADDRESS TO TEMP R14
         LA    13,SAVE                       LOAD INTERNAL SAVE ADDRESS
         ST    13,8(14)                      SAVE IN EXTERNAL SAVE AREA
         B     GO                            BRANCH TO PROCESSING RTN
***********************************************************************
RETURN   EQU   *                             TIME TO RETURN
         L     13,SAVE+4                     RESTORE REGISTER 13
         LM    14,12,12(13)                  RESTORE REMAINING REGS
         SR    15,15                         CLEAR RETURN CODE
         BR    14                            BRANCH TO CALLING PROGRAM
***********************************************************************
SAVE     DC    18F'0'                        S A V E   A R E A
***********************************************************************
BASE2    DC    A(TDFLAG+1*4096)              BASE2 DISPLACEMENT
BASE3    DC    A(TDFLAG+2*4096)              BASE2 DISPLACEMENT
***********************************************************************
GO       EQU   *                             BEGIN PROCESSING ...
***********************************************************************
         EJECT


The main procedure reads a table that defines the areas of blue, red & white along with the positions of the stars. It also accepts & interrogates keyboard input. If the F1 key is pressed it will toggle the stars blinking on or off... if any other key is pressed the program is stopped.

***********************************************************************
*        MAINLINE PROCEDURE                                           *
***********************************************************************
         PRINT NOGEN
         SVC   @TRACE                        ISSUE SUPERVISOR CALL
         DC    CL4'IOF '                     KEYBOARD INTERRUPT OFF
*
         MVI   VBITS,@BKWH                   SET BACKGROUND/FOREGROUND
         BAL   6,VRESET                      CHANGE SCREEN ATTRIBUTES
*
         LA    5,FLAG                        LOAD TABLE ADDRESS
LOOP     EQU   *
         CLI   0(5),X'FF'                    END OF TABLE ???
         BE    LOOPX                         YES - EXIT PLEASE
*
         MVC   VXYS,0(5)                     MOVE CURSOR POSITION
         BAL   6,VXYSET                      SET CURSOR POSITION
         MVC   VPUTL,4(5)                    MOVE LINE LENGTH
         MVC   VBITS,6(5)                    SET BACKGROUND/FOREGROUND
*
         TM    7(5),X'01'                    ANY STARS ???
         BNO   *+10                          NO  - CONTINUE PLEASE
         OC    VBITS,BLINK                   YES - SET BLINK/TOGGLE
*
         BAL   6,VPUT                        WRITE DUMMY LINE
*
         TM    7(5),X'01'                    ANY STARS ???
         BNO   BUMP                          NO  - CONTINUE PLEASE
*
         MVC   VXYS,0(5)                     MOVE CURSOR POSITION
         BAL   6,VXYSET                      SET CURSOR POSITION
*
         LA    2,STAR1                       LOAD STAR 1 ADDRESS
         TM    7(5),X'02'                    STAR LINE 2 ???
         BNO   *+8                           NO  - CONTINUE PLEASE
         LA    2,STAR2                       LOAD STAR 2 ADDRESS
*
         SVC   @WTO                          ISSUE SUPERVISOR CALL
BUMP     EQU   *
         LA    5,8(,5)                       BUMP TABLE POINTER
         B     LOOP                          TEST NEXT TABLE ENTRY
LOOPX    EQU   *
         MVC   VXYS,=AL1(0,0,23,30)          MOVE CURSOR POSITION
         BAL   6,VXYSET                      SET CURSOR POSITION
         MVC   VPUTL,=Y(L'F1MSG)             MOVE LINE LENGTH
         MVI   VBITS,@BKWT                   SET BACKGROUND/FOREGROUND
         BAL   6,VPUT                        WRITE DUMMY LINE
         LA    2,F1MSG                       LOAD MESSAGE ADDRESS
         SVC   @WTO                          ISSUE SUPERVISOR CALL
         BAL   6,KBGET                       READ KEYBOARD INPUT
         MVC   KEY,KBCHR                     STORE KEYSTROKE
         CLI   KEY,@K#F1                     KEY = F1 ???
         BNE   RETURN                        NO  - EXIT PROGRAM
         XC    BLINK,TOGGLE                  ISOLATE UNIQUE BITS
         XC    TOGGLE,BLINK                  REPLACE TOGGLE W/BLINK
         XC    BLINK,TOGGLE                  REPLACE BLINK W/TOGGLE
         LA    5,FLAG                        LOAD TABLE ADDRESS
         B     LOOP                          START OVER AGAIN...
***********************************************************************
BLINK    DC    XL1'00'                       BLINK ATTRIBUTE SETTING
TOGGLE   DC    XL1'80'                       TOGGLE BLINK SETTING
***********************************************************************
         EJECT


I created various copybooks that contain routines for different purposes - this program uses the ones for video & keyboard along with the equate values for keystrokes, colors & supervisor/interrupt calls. The table named "FLAG" contains the block definitions for the blue, red & white areas as well as the bit settings to indicate stars.

***********************************************************************
*        WORKING STORAGE                                              *
***********************************************************************
KEY      DC    CL1' '                        KEY STROKE (@RDKEY)
***********************************************************************
         LTORG                               LITERAL POOL
***********************************************************************
@YES     EQU   C'Y'                          YES
@NO      EQU   C'N'                          NO
@ESC     EQU   27                            ESCAPE KEY
@CR      EQU   13                            CARRIAGE RETURN
@LF      EQU   10                            LINE FEED
@KEYLO   EQU   32                            ASCII KEY - LO VALUE
@KEYHI   EQU   126                           ASCII KEY - HI VALUE
***********************************************************************
*        COPYBOOKS                                                    *
***********************************************************************
         COPY  CPY/TDVID.CPY                 COPYBOOK - VIDEO UTILITY
         COPY  CPY/TDKBD.CPY                 COPYBOOK - KEYBOARD INPUT
         COPY  CPY/TDKEY.CPY                 COPYBOOK - KEYSTROKES
         COPY  CPY/TDCLR.CPY                 COPYBOOK - COLORS
         COPY  CPY/TDSVC.CPY                 COPYBOOK - SUPERVISOR
***********************************************************************
F1MSG    DC    C'Press F1 to Toggle Blinking Stars... $'
***********************************************************************
STAR1    DC    C'  *   *   *   *   *  $'
STAR2    DC    C'    *   *   *   *    $'
***********************************************************************
FLAG     DS    0F
         DC    AL1(0,0,3,2),AL2(67),AL1(@RDWH,0)
         DC    AL1(0,0,5,2),AL2(67),AL1(@RDWH,0)
         DC    AL1(0,0,7,2),AL2(67),AL1(@RDWH,0)
         DC    AL1(0,0,9,2),AL2(67),AL1(@RDWH,0)
         DC    AL1(0,0,11,2),AL2(67),AL1(@RDWH,0)
         DC    AL1(0,0,13,2),AL2(67),AL1(@RDWH,0)
         DC    AL1(0,0,15,2),AL2(67),AL1(@RDWH,0)
         DC    AL1(0,0,17,2),AL2(67),AL1(@RDWH,0)
         DC    AL1(0,0,19,2),AL2(67),AL1(@RDWH,0)
         DC    AL1(0,0,21,2),AL2(67),AL1(@RDWH,0)
*
         DC    AL1(0,0,4,2),AL2(67),AL1(@WHWH,0)
         DC    AL1(0,0,6,2),AL2(67),AL1(@WHWH,0)
         DC    AL1(0,0,8,2),AL2(67),AL1(@WHWH,0)
         DC    AL1(0,0,10,2),AL2(67),AL1(@WHWH,0)
         DC    AL1(0,0,12,2),AL2(67),AL1(@WHWH,0)
         DC    AL1(0,0,14,2),AL2(67),AL1(@WHWH,0)
         DC    AL1(0,0,16,2),AL2(67),AL1(@WHWH,0)
         DC    AL1(0,0,18,2),AL2(67),AL1(@WHWH,0)
         DC    AL1(0,0,20,2),AL2(67),AL1(@WHWH,0)
*
         DC    AL1(0,0,3,2),AL2(21),AL1(@BLWH,0)
         DC    AL1(0,0,4,2),AL2(21),AL1(@BLWH,1)
         DC    AL1(0,0,5,2),AL2(21),AL1(@BLWH,3)
         DC    AL1(0,0,6,2),AL2(21),AL1(@BLWH,1)
         DC    AL1(0,0,7,2),AL2(21),AL1(@BLWH,3)
         DC    AL1(0,0,8,2),AL2(21),AL1(@BLWH,1)
         DC    AL1(0,0,9,2),AL2(21),AL1(@BLWH,3)
         DC    AL1(0,0,10,2),AL2(21),AL1(@BLWH,1)
         DC    AL1(0,0,11,2),AL2(21),AL1(@BLWH,3)
         DC    AL1(0,0,12,2),AL2(21),AL1(@BLWH,0)
*
         DC    X'FF'
***********************************************************************
         END   TDFLAG



I hope you enjoyed this post... it's somewhat of a relic from the past but clearly demonstrates precision coding, efficiency & fun.

FYI - Old Glory as it should be presented - 50 stars/13 stripes: