*** Top of Data *** CMPRSTXT CSECT CMPRSTXT AMODE 31 CMPRSTXT RMODE 24 ********************************************************************** *** THIS PROGRAM WILL COMPRESS MULTIPLE SPACES IN A TEXT FILE. ********************************************************************** DSKIP EQU SKIP-CMPRSTXT DISPLACEMENT OF SKIP DSAVE EQU SAVEAREA-CMPRSTXT DISPLACEMENT OF SAVEAREA * B DSKIP(,R15) SKIP ID SECTION DC AL1(*-SAVEAREA) MODULE ID LENGTH DC CL3'ID ' ID LITERAL DC CL8'CMPRSTXT' MODULE NAME DC CL1' ' SPACE DC CL8'ASSEMBLY' ASSEMBLY DATE DC CL6' DATE=' LITERAL DC CL8'&SYSDATE' MODULE ASSEMBLY DATE DC CL6' TIME=' TIME LITERAL DC CL5'&SYSTIME' MODULE ASSEMBLY TIME DC CL2' ' SPACE SAVEAREA DS 18F REGISTER SAVE AREA * SKIP DS 0H STM R14,R12,12(R13) SAVE CALLER'S REGISTERS LA R12,DSAVE(,R15) R12 = TEMP SAVE AREA PTR ST R12,8(,R13) SET FORWARD SAVE AREA PTR ST R13,4(,R12) SET BACKWARD SAVE AREA PTR LR R13,R12 R13 = SAVE AREA PTR USING SAVEAREA,R13 R13 = BASE REGISTER * ST R1,PARMLSTP SAVE PARAM LIST PTR LM R4,R5,0(R1) GET CALL PARAMS L R4,0(R4) R4 = TEXT LEN USING TEXTAREA,R5 R5 = TEXT PTR LA R11,0(R4,R5) R11 = 1 POS AFTER LAST BYTE LR R10,R11 R10 = PTR TO BCTR R10,0 LAST BYTE OF TEXT * USING OUTAREA,R9 R9 = OUTPUT PTR LR R9,R5 POSITION OUTPUT PTR BCTR R9,0 TO JUST BEFORE TEXT AREA MVI FSTRSW,C'Y' SET THE FIRST-TIME SWITCH * NBFIND DS 0H ***** FIND THE NEXT NON-BLANK CHARACTER ***** C R4,=F'256' CHECK REM TEXT LEN FOR TRT MAX BH NBSETL TOO BIG LR R7,R4 R7 TRT LEN BCTR R7,0 = TEXT REMAIN LEN - 1 B NBTEST NBSETL LA R7,255 R7 TRT LEN = 256 - 1 NBTEST EX R7,TRTNONB EXECUTE TRT FOR NON-BLANK BZ NBFAIL NON-BLANK NOT FOUND CLI FSTRSW,C'Y' IS THIS THE FIRST STRING? BE NBSKIPFS IF YES, NO LEADING SPACE LA R9,1(R9) BUMP THE OUTPUT PTR MVI OUTAREA,X'40' INSERT THE LEADING SPACE NBSKIPFS MVI FSTRSW,C'N' TURN OFF THE FIRST STRING SWITCH LR R5,R1 RESET SCAN BEG ADDR LR R4,R11 RESET REMAINING SR R4,R5 TEXT LEN B STGET GO TO THE GET STRING ROUTINE * NBFAIL DS 0H ***** NO NON-BLANK CHAR FOUND ***** LA R7,1(,R7) BUMP R7 BACK TO ACTUAL SCAN LEN AR R5,R7 RESET SCAN BEG ADDR CR R5,R10 CHECK FOR BNL ENDTEXT NO TEXT LEFT SR R4,R7 RESET REMAINING TEXT LEN B NBFIND KEEP LOOKING * STGET DS 0H ***** GET A CHARACTER STRING ***** C R4,=F'256' CHECK REM TEXT LEN FOR TRT MAX BH STSETL TOO BIG LR R7,R4 R7 TRT LEN BCTR R7,0 = TEXT REMAIN LEN - 1 B STTEST STSETL LA R7,255 R7 TRT LEN = 256 - 1 STTEST EX R7,TRTBLNK EXECUTE TRT FOR BLANK BZ STFAIL BLANK NOT FOUND CR R1,R5 CHECK FOR BLANK IN FIRST BYTE BE STCHKLST LR R8,R1 R8 = LEN OF STRING SR R8,R5 = R1 - R5 BCTR R8,0 REDUCE LEN FOR EX OF MVC LA R9,1(R9) BUMP THE OUTPUT PTR EX R8,MVCOUT EXECUTE MVC TO COPY THE STRING AR R9,R8 ADVANCE THE OUTPUT PTR STCHKLST CR R1,R10 CHECK FOR BLANK IN LAST BYTE BNL ENDTEXT LA R1,1(,R1) BUMP R1 PAST THE BLANK LR R5,R1 RESET SCAN BEG ADDR LR R4,R11 RESET REMAINING SR R4,R5 TEXT LEN B NBFIND FIND BEGINNING OF NEXT STRING * STFAIL DS 0H ***** NO BLANK CHAR FOUND ***** LA R9,1(R9) BUMP THE OUTPUT PTR EX R7,MVCOUT EXECUTE MVC TO COPY THE STRING AR R9,R7 ADVANCE THE OUTPUT PTR LA R7,1(,R7) BUMP R7 UP TO ACTUAL SCAN LEN AR R5,R7 RESET SCAN BEG ADDR CR R5,R10 CHECK FOR BNL ENDTEXT MORE TEXT LEFT SR R4,R7 RESET REMAINING TEXT LEN B STGET GET THE REST OF THE STRING * ENDTEXT DS 0H L R1,PARMLSTP RESTORE PARAM LIST PTR LM R4,R5,0(R1) RELOAD CALL PARAMS SR R9,R5 R9 = COMPRESSED LA R9,1(,R9) TEXT LEN ST R9,0(R4) PASS BACK COMPRESSED TEXT LEN RETURN DS 0H L R13,4(,R13) RESTORE CALLER'S SAVE AREA PTR LM R14,R12,12(R13) RESTORE CALLER'S REGISTERS XR R15,R15 ZERO COND CODE BR R14 RETURN TO CALLER * ******** MODELS OF EXECUTED INSTRUCTIONS * TRTBLNK TRT TEXTAREA(0),NBTAB TRTNONB TRT TEXTAREA(0),BLTAB MVCOUT MVC OUTAREA(0),TEXTAREA * PARMLSTP DS F FSTRSW DS CL1 * BLTAB DC 65XL1'00' TRT TABLE FOR BLANKS DC 191XL1'FF' * NBTAB DC 65XL1'FF' TRT TABLE FOR NON-BLANKS DC 191XL1'00' * TEXTAREA DSECT 0CL1 OUTAREA DSECT 0CL1 * ********************************************************************** R0 EQU 0 R1 EQU 1 R2 EQU 2 R3 EQU 3 R4 EQU 4 R5 EQU 5 R6 EQU 6 R7 EQU 7 R8 EQU 8 R9 EQU 9 R10 EQU 10 R11 EQU 11 R12 EQU 12 R13 EQU 13 R14 EQU 14 R15 EQU 15 * END *** Bottom of Data ***

Copyright © 2009 The Stevens Computing Services Company, Inc.  All rights reserved.