diff --git a/doc/user_guide/zCOBOL/write_clauses.md b/doc/user_guide/zCOBOL/write_clauses.md new file mode 100644 index 000000000..6077c8b5d --- /dev/null +++ b/doc/user_guide/zCOBOL/write_clauses.md @@ -0,0 +1,260 @@ +# Clauses of the Cobol WRITE verb + +The information in this document was derived from the IBM Language Reference manual +for Enterprise Cobol 6.5. IBM document code `SC27-8713-03` + +The `WRITE` verb as defined in the Cobol language supports: +- `BEFORE ADVANCING` +- `AFTER ADVANCING` +- `AT END-OF-PAGE` +- `NOT AT END-OF-PAGE` +- `INVALID KEY` +- `NOT INVALID KEY` + +The `BEFORE ADVANCING` and `AFTER ADVANCING` clauses are mutually exclusive on a single `WRITE` +statement. Each `WRITE` statement for any file can use either `BEFORE ADVANCING` or `AFTER ADVANCING` +or omit the `ADVANCING` clause altogether. Thus, from a file perspective, `ADVANCING` clauses can +be a mixture of `BEFORE` and `AFTER` with omitted `ADVANCING` clauses defaulting to `AFTER 1`. + +The other four clauses are not mutually exclusive, so at most 5 of the 6 defined clauses may be present +on any given `WRITE` statement. + +> [!NOTE] +> 1. The `BEFORE`/`AFTER` `ADVANCING` clauses interact with the `LINAGE` clause on the `FD` definition +> for the file being written. +> 2. When no `LINAGE` is defined, advancing a `PAGE` is considered to be the same as 1 line. + +Limitations / Questions: +- According to IBM, the `ADVANCING` options can be used only on QSAM files. + - Question 1: in z390 both QSAM and BSAM are supported. Do we also want to supprt VSAM-ESDS? +- According to IBM, the `INVALID KEY` clause applies, when applied to a sequential file or + line sequential file, applies to exceeding file size limits only. + - Question 2: in z390 we have no implementation yet. Do we want to include the option to flag error + when a VSAM-ESDS is written such that an overlying Unique AIX detects a duplicate key? +- IBM does not mention any exceptions, yet it seems to make sense to suppress default spacing + of `AFTER 1 LINE` when no `ADVANCING` clause is specified on the first `WRITE` operation to the file. + - Question 3a: Do we want to suppress the `AFTER 1 LINE` if the first `WRITE` does not specify an `ADVANCING` clause? + - Question 3b: Also, a comparable problem arises when a `BEFORE PAGE` is followed by an `WRITE` without `ADVANCING` clause. + How do we resolve that? + +## FD LINAGE clause details + +The FD allows a LINAGE clause with the following 4 elements: +- `LINAGE` + - Specifies the total nr of lines on each page + - including top margin, bottom margin, and footing area + - causes the `LINAGE-COUNTER` special register to be created for the file +- `WITH FOOTING AT` + - Specifies the first line of the footing area within the page body (i.e. disregarding top margin) + - The default is the last line of the page body +- `LINES AT TOP` + - unprintable lines at top of page + - the default is zero +- `LINES AT BOTTOM` + - unprintable lines at bottom of page + - the default is zero + +Graphically: +``` + |---------------------------------|------------------- + | | ^ + | Lines At Top (top margin) | | + | | | + |---------------------------------|----- | + | | ^ | + | | | | + | | | | + | | | | + | | | | + | | | Page Body | Logical Page Depth + | | | | + | | | | + | | | | + | | | | + | | | | + | | | | + |------ with footing value--------| | | + | | | | + | Footing Area | | | + | | V | + |---------------------------------|----- | + | | | + | Lines At Bottom (bottom margin) | | + | | V + |---------------------------------|------------------- +``` + +> [!NOTE] +> 1. Lines can be written into the footing area, but doing so causes an end-of-page condition to be raised. +> 2. An end-of-page condition is handled **after** the record has been written. +> 3. When an attempt is made to write a record beyond the page body an automatic page overflow condition is raised. +> 4. An automatic page overflow condition is handled **before** the record is written. + +### Oddities to be resolved + +On page 193, under the "LINAGE clause" heading the manual states: +> The LINAGE clause specifies the depth of a logical page in number of lines. Optionally, it also specifies +> the line number at which the footing area begins and the top and bottom margins of the logical page. (The +> logical page and the physical page cannot be of the same dimension.) + +It says: LINAGE specifies "depth of a logical page". According to the associated figure (on page 194) +this comprises the full logical page: lines-at-top + page-body + lines-at-bottom. + +In the next paragraph, however, it says: +> The number of lines that can be written or spaced on this logical page. The area of the page that these +> lines represent is called the page body. The value must be greater than zero. + +So the first sentence speaks of "logical page" which probably intends to be equivalent to the "logical page depth" +as shown in the figure (on page 194). This implies that the LINAGE value **includes** the top and bottom margins. +This is in agreement with the statement in the preceding paragraph cited above. + +However, the second sentence equates the LINAGE value specifically to the "page body". Which would **exclude** +the top and bottom margins. + +Finally, the fist paragraph following the figure on page 194 states: +> The logical page dimension specified in the LINAGE clause is the sum of all values specified in each +> phrase except the FOOTING phrase. + +This, again, defines the LINAGE value as **including** the top and bottom margins. + +In z390 we will implement the LINAGE value as being the logical page depth, that is: +**including** not only the page body, but also the top and bottom margins. + +## Different types of control characters + +### ANSI or ASA control characters + +On the mainframe, typically, ASA control characters are used. +The ASA control character is written **before** the first printable character of each record. +The ASA control characters are defined as follows: + +| Code | Meaning | +|-------|-----------------------------------| +| space | Space 1 line before printing | +| `0` | Space 2 lines before printing | +| `-` | Space 3 lines before printing | +| `+` | Space 0 lines before printing | +| `1` | Skip to next page before printing | + +The ASA control character indicates spacing to be applied **before** printing a record. +Therefore, it is the natural equivalent of the Cobol `WRITE` verb with `AFTER ADVANCING` clause. + +When a Cobol program issues a `WRITE` verb with `BEFORE ADVANCING` clause, +the requested spacing must be kept pending in order to be expressed on the next record's control character. + +### Windows / Linux control characters + +On Windows and Linux, typically, Ascii control characters are used. +The Ascii control characters are written **after** the last printable character of each record. +The Ascii control characters are defined as follows: + +| Code | Meaning | Effect | +|------|-----------------|----------------------------------| +| CR | Carriage Return | Move print head to column 1 | +| LF | Line Feed | Space 1 line after printing | +| FF | From Feed | Skip to next page after printing | + +- On Windows, two control characters are normally used: CR-LF or CR-FF. +- Linux and MacOs, a single control character is normally used: LF or FF. + +The Ascii control characters indicate spacing to be applied **after** printing a record. +Therefore, it is the natural equivalent of the Cobol `WRITE` verb with `BEFORE ADVANCING` clause. + +When a Cobol program issues a `WRITE` verb with `AFTER ADVANCING` clause, +the record to be written must be kept pending in order to be terminated with the next record's spacing, +if the next `WRITE` has a `AFTER ADVANCING` clause. + +Under normal Windows/Linux conventions, there is no option to specify `ADVANCE 0 LINES`. +We could use CR or CR-CR to implement that, but I'm not sure that's a good plan. + +Question 4: Do we want to support `ADVANCE 0 LINES`? If yes, how can we encode that in the file being written? + +## Other complexities + +### Selecting the correct form of ADVANCING control + +When the program is being compiled, the compiler is unable to tell what the run-time requirements will be: +- ASA can be enabled by specifying an `A` in the `RECFM` parameter on the DD statement or host variable + specifying the exact file to be written. +- To enable Windows- or Unix-style output z390 employs the `T` on the `RECFM` parameter, but there is as yet + no provision to select Windows-style of Unix-style line endings, other than checking the host OS at run-time. + +Question 5: It is unclear whether the control characters - whether ASA or Ascii - are defined in the record lay-out. +If they are, there is no option to dynamically switch at run-time, and an abend is due when an `OPEN` is attempted +for the file, specifying an incorrect type of printing control characters. + +Question 6: Can we derive meaningful information form the `TARGET-COMPUTER` paragraph? +It seems this paragraph is mostly left unspecified in the NIST test suite. I doubt we would want to +create a zCobol-specific extension. + +### ADVANCING without LINAGE + +When `LINAGE` is not specified on the `FD` no page information is available. Using the `PAGE` keyword on the +`ADVANCING` clause, in this case, defaults to simply advancing 1 line. + +On the other hand, a sequential or line sequential file without `LINAGE` may or may not have to support +`ADVANCING` clauses on applicable `WRITE` statements. For files without a `LINAGE` declaration, whether or not +`ADVANCING` logic needs to be generated on `WRITE` statements is known only after the entire `PROCEDURE DIVISION` +has been assembled. + +Question 7: do we need to be able to support defaulted `ADVANCING` control on files that have no `LINAGE` clause +on their `FD` yet do have the `ADVANCING` option on some, but not all, of their `WRITE` operations? + +Question 8: if Yes, then how can we implement `ADVANCING` logic on `WRITE` statements that occur **before** +the compiler knows that `ADVANCING` logic is needed? In other words: if the first `WRITE` to a file without a +`LINAGE` clause on its `FD` contains no `ADVANCING` clause, then no `ADVANCING` support appears to be needed. +Yet when a subsequent `WRITE` to the same file does specify an `ADVANCING` clause, then how do we modify the +earlier expansion of the `WRITE` macro to change from not having `ADVANCING` support to actually having +`ADVANCING` support? + +Potential solution: do not perform the write in-line. Instead, perform an out-of-line subroutine which is +generated at the end of the `PROCEDURE DIVISION`. + +### Record and Block formats + +- For `RECFM=V*` the `RDW` needs to be built before writing the record; for `RECFM=F*` no `RDW` applies. +- For files using `LBI` (Large Block Interface) a different layout of `RDW` or `BDW` is required. + - RDW/BDW = LL00 with high bit off supports up to 32K + - RDW/BDW = LLLL with high bit on supports up to 2GB +- For `RECFM=*T*` Ebcdic-Ascii translation is needed. + +Question 9: which of these actions are performed by the z390 access methods, and which need to be +implemented as application code in the compiled program? + +## Generalized solution + +The compiler must either know all the specifics of the file to be written in order to generate the +required logic. Or the compiler can be built to create generic code that is capable of adapting to the +specifics of the file to be written, whatever those specifics may be at run-time. + +Finally, as a trade-off, the compiler might require some details - but not all - to be known at compile-time. +The remaining details can then still be picked up when the file is opened. + +Question 10: How generic do we want to make the generated code for writing sequential and line sequential files? + +### DCB and ADVANCING support + +- When the DCB is generated, we add a couple of fields for the four `LINAGE` values: + - LINAGE + - FOOTING + - TOP + - BOTTOM +- We need to add the following fields for `ADVANCING` support: + - LINAGE_COUNTER + - ADVANCE_FLAGS + - ADVANCING_ENABLED + - FIRST_RECORD_WRITTEN + - BUFFER_HAS_RECORD + - PENDING_PAGE + - PENDING_NEWLINES + - RECORD_BUFFER_PTR +- The flag field which indicates whether or not `ADVANCING` support is enabled defaults to yes + if the `FD` has a `LINAGE` clause, otherwise the default is no. +- If any `WRITE` is detected that uses an `ADVANCING` clause, the flag is turned on during `OPEN` processing. + + + + + + + diff --git a/zcobol/cpy/ZC_WS.CPY b/zcobol/cpy/ZC_WS.CPY index 1f1422576..3c9b39c32 100644 --- a/zcobol/cpy/ZC_WS.CPY +++ b/zcobol/cpy/ZC_WS.CPY @@ -50,6 +50,7 @@ .* 04/25/12 RPI 1211 add TMP_PIC_DEC for scaling ZC_CALC .* 05/05/12 RPI 1211 add &BASE_MIN_RANGE to ensure block base coverage .* 05/12/26 #789 Allow variable length in reference modification +.* 05/23/26 #808 WRITE statement not handling AFTER/BEFORE .********************************************************************* .* .* PGM NAME AND ZCOBOL VERSION CHECKED BY ZC390NUC IN ZC390LIB.390 @@ -106,6 +107,11 @@ GBLC &FILE_LRECL1(100) MIN REC SIZE (DEF CHAR) GBLC &FILE_LRECL2(100) MAX REC SIZE (DEF CHAR) GBLC &FILE_DEPENDING(100) VAR LRECL FLD FOR FILE + GBLC &FILE_LINAGE(100) Linage nr of LINES or field name #808 + GBLC &FILE_FOOTING(100) Linage FOOTING value or field name #808 + GBLC &FILE_TOP(100) Linage TOP value or field name #808 + GBLC &FILE_BOTTOM(100) Linage BOTTOM value or field name #808 + GBLB &FILE_ADVANCING(100) ADVANCING option used/supported #808 .* .* WS BASE REGISTERS (GEN_ID sys init, GEN_BASE dynamic,PERIOD reset) .* diff --git a/zcobol/mac/ADVANCING.MAC b/zcobol/mac/ADVANCING.MAC new file mode 100644 index 000000000..2d3696ec9 --- /dev/null +++ b/zcobol/mac/ADVANCING.MAC @@ -0,0 +1,161 @@ + MACRO +.********************************************************************* +.* z390 - Mainframe assembler emulator and run-time engine +.* Copyright (C) 2021 z390 Assembler LLC +.* +.* This file is part of z390. +.* +.* z390 is free software; you can redistribute it and/or modify +.* it under the terms of the GNU General Public License as published by +.* the Free Software Foundation; either version 2 of the License, or +.* (at your option) any later version. +.* z390 is distributed in the hope that it will be useful, +.* but WITHOUT ANY WARRANTY; without even the implied warranty of +.* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +.* GNU General Public License for more details. +.* +.* You should have received a copy of the GNU General Public License +.* along with this program; if not, see https://www.gnu.org/licenses. +.********************************************************************* +.* Author - Abe Kornelis * +.* Date - 05/25/2026 * +.* * +.* Purpose of this macro: * +.* - Analyze subparameters on the ADVANCING clause of a WRITE verb * +.* - issue error if needed * +.* - generate code to implement the advancing option specified * +.* * +.* Input parameters: * +.* - No parameters are used * +.* - GBLA &FILE_IX must be set to the appropriate value for the file * +.* to be written * +.* * +.* Note: * +.* - BEFORE/AFTER can be ignored because the point where this macro * +.* is invoked already caters to the advancing relative to the * +.* actual WRITE of the record data. * +.* * +.********************************************************************* +.* 25/15/26 #808 WRITE not recognizing BEFORE / AFTER clauses +.********************************************************************* + ADVANCING , + COPY ZC_WS + :&FILE_ADVANCING(&FILE_IX) SETB 1 Set advancing support +.* +.* Analyze all the parameters to figure out what needs to be done + LCLB &ERROR Error detected + LCLB &BEFORE BEFORE specified + LCLB &AFTER AFTER specified + LCLB &LINES LINE or LINES specified + LCLB &PAGE PAGE specified + LCLC &LINESPEC Nr or variable name + LCLA &LINECT Actual linecount +.* +.* First parm could be BEFORE/AFTER or omitted +&I SETA 1 Point first parm + AIF ('&SYSLIST(&I)' EQ 'BEFORE') + :&BEFORE SETB 1 Mark BEFORE clause + :&I SETA (&I+1) point next parm + AELSEIF ('&SYSLIST(&I)' EQ 'AFTER') + :&AFTER SETB 1 Mark AFTER clause + :&I SETA (&I+1) point next parm + AEND +.* +.* Next parm could be ADVANCING, or omitted + AIF ('&SYSLIST(&I)' EQ 'ADVANCING') + :&I SETA (&I+1) ignore; point next parm + AEND +.* +.* Next parm could be PAGE, or the line count + AIF ('&SYSLIST(&I)' EQ 'PAGE') + :&PAGE SETB 1 Mark PAGE keyword + :&I SETA (&I+1) point next parm + AELSE , Must be a line count or var + :&LINESPEC SETC '&SYSLIST(&I)' + :&I SETA (&I+1) point next parm + AEND +.* +.* Next parm could be LINE or LINES + AIF ('&SYSLIST(&I)' EQ 'LINE') + :&LINES SETB 1 Mark LINE/LINES clause + :&I SETA (&I+1) point next parm + AELSEIF ('&SYSLIST(&I)' EQ 'LINES') + :&LINES SETB 1 Mark LINE/LINES clause + :&I SETA (&I+1) point next parm + AEND +.* +.* Any remaining parms to be reported as error + AWHILE (&I LE N'&SYSLIST) + MNOTE 8,'&SYSLIST(&I) is not supported on ADVANCING clau* + se of WRITE statement' + :&ERROR SETB 1 Mark error + :&I SETA (&I+1) Point next parm + AEND +.* +.* Errors for conflicting options and apply defaults + AIF (&BEFORE AND &AFTER) + MNOTE 8,'Conflicting BEFORE/AFTER keywords on ADVANCING * + clause of WRITE statement' + :&ERROR SETB 1 Mark error + AEND + AIF (&PAGE AND &LINES) + MNOTE 8,'Conflicting PAGE/LINE/LINES keywords on ADVANCI* + NG clause of WRITE statement' + :&ERROR SETB 1 Mark error + AEND +.* +.* Apply defaults AFTER and LINE if needed + AIF (NOT &BEFORE AND NOT &AFTER) + :&AFTER SETB 1 AFTER is default + AEND + AIF (NOT &PAGE AND NOT &LINES) + :&LINES SETB 1 LINE/LINES is default + AEND +.* +.* For LINE/LINES a quantity must be specified + AIF (&LINES AND '&LINESPEC' EQ '') + MNOTE 8,'Nr of LINES to missing on ADVANCING clause of W* + RITE statement' + :&ERROR SETB 1 Mark error + AEND + AIF (&LINES) + :&LINECT SETA (D2A('&LINESPEC')) + AIF (&LINECT LT 0) + MNOTE 8,'Cannot ADVANCE negative number of lines' + :&ERROR SETB 1 Mark error + AEND + AEND +.* +.* Error out for options not yet supported + AIF ('&FILE_LINAGE(&FILE_IX)' NE '') + MNOTE 8,'ADVANCING for file with LINAGE not supported ye* + t' + :&ERROR SETB 1 Mark error + AEND + AIF (&BEFORE) + MNOTE 8,'BEFORE ADVANCING supported yet' + :&ERROR SETB 1 Mark error + AEND + AIF (&PAGE) + MNOTE 8,'AFTER ADVANCING PAGE not yet supported' + :&ERROR SETB 1 Mark error + AEND + AIF (&LINES AND '&LINESPEC'(1,1) LT '0') + MNOTE 8,'AFTER ADVANCING not yet supported' + :&ERROR SETB 1 Mark error + AEND + AIF (&LINES AND &LINECT EQ 0) + MNOTE 8,'AFTER ADVANCING 0 LINES not yet supported' + :&ERROR SETB 1 Mark error + AEND + AIF (&ERROR) If any error occurred + MEXIT we're done error reporting + AEND +.* +.* AFTER ADVANCING 1 LINE is normal behaviour - no action needed + AIF (&AFTER AND &LINES AND &LINECT EQ 1) + MEXIT We're okay! + AEND +.* +.* + MEND diff --git a/zcobol/mac/FD.MAC b/zcobol/mac/FD.MAC index 762e5e6cb..1d0d05e35 100644 --- a/zcobol/mac/FD.MAC +++ b/zcobol/mac/FD.MAC @@ -23,6 +23,7 @@ .* 04/07/08 initial coding for global FD definition .* 10/06/08 ZSTRMAC .* 2023/05/12 &FILE_xxx(&PARM_IX) -> &FILE_xxx(&FILE_IX) +.* 05/23/26 #808 WRITE statement not handling AFTER/BEFORE .********************************************************************* .* Generate file definition using file data from SELECT in ZC_FD.CPY .********************************************************************* @@ -141,6 +142,126 @@ AIF ('&SYSLIST(&PARM_IX)' EQ 'OMITTED') :&PARM_IX SETA &PARM_IX+1 AEND + AELSEIF ('&SYSLIST(&PARM_IX)' EQ 'LINAGE') #808 +.* Handle LINAGE clause #808 + :&PARM_IX SETA &PARM_IX+1 #808 + AIF ('&SYSLIST(&PARM_IX)' EQ 'IS') #808 + :&PARM_IX SETA &PARM_IX+1 #808 + AEND #808 + :&FILE_LINAGE(&FILE_IX) SETC '&SYSLIST(&PARM_IX)' #808 + :&FILE_ADVANCING(&FILE_IX) SETB '1' Set advancing support #808 + :&PARM_IX SETA &PARM_IX+1 #808 + AIF ('&SYSLIST(&PARM_IX)' EQ 'LINES') #808 + :&PARM_IX SETA &PARM_IX+1 #808 + AEND #808 + AIF ('&FILE_LINAGE(&FILE_IX)' EQ '') #808 + MNOTE 8,'LINAGE clause witout value' #808 + AEND #808 + AIF ('&FILE_ORG(&FILE_IX)' NE 'LSEQ' AND '&FILE_ORG(&FILE*#808 + _IX)' NE 'QSAM') #808 + MNOTE 8,'LINAGE clause not allowed for file with ORGANIZ*#808 + ATON &FILE_ORG(&FILE_IX)' #808 + AEND #808 +.* Check for FOOTING sub-clause #808 + :&HAVE_FOOTING SETB 0 #808 + AIF ('&SYSLIST(&PARM_IX)' EQ 'FOOTING') #808 + :&HAVE_FOOTING SETB 1 #808 + AEND #808 + AIF ('&SYSLIST(&PARM_IX)' EQ 'WITH' AND '&SYSLIST(&PARM_I*#808 + X+1)' EQ 'FOOTING') #808 + :&HAVE_FOOTING SETB 1 #808 + AEND #808 + AIF (&HAVE_FOOTING) #808 + AIF ('&SYSLIST(&PARM_IX)' EQ 'WITH') #808 + :&PARM_IX SETA &PARM_IX+1 #808 + AEND #808 + AIF ('&SYSLIST(&PARM_IX)' EQ 'FOOTING') #808 + :&PARM_IX SETA &PARM_IX+1 #808 + AEND #808 + AIF ('&SYSLIST(&PARM_IX)' EQ 'AT') #808 + :&PARM_IX SETA &PARM_IX+1 #808 + AEND #808 + :&FILE_FOOTING(&FILE_IX) SETC '&SYSLIST(&PARM_IX)' #808 + :&PARM_IX SETA &PARM_IX+1 #808 + AIF ('&SYSLIST(&PARM_IX)' EQ 'LINES') #808 + :&PARM_IX SETA &PARM_IX+1 #808 + AEND #808 + AIF ('&FILE_FOOTING(&FILE_IX)' EQ '') #808 + MNOTE 8,'LINAGE FOOTING clause witout value' #808 + AEND #808 + AEND #808 +.* Check for TOP sub-clause #808 + :&HAVE_TOP SETB 0 #808 + AIF ('&SYSLIST(&PARM_IX)' EQ 'TOP') #808 + :&HAVE_TOP SETB 1 #808 + AEND #808 + AIF ('&SYSLIST(&PARM_IX)' EQ 'LINES' AND '&SYSLIST(&PARM_*#808 + IX+1)' EQ 'TOP') #808 + :&HAVE_TOP SETB 1 #808 + AEND #808 + AIF ('&SYSLIST(&PARM_IX)' EQ 'AT' AND '&SYSLIST(&PARM_IX+*#808 + 1)' EQ 'TOP') #808 + :&HAVE_TOP SETB 1 #808 + AEND #808 + AIF ('&SYSLIST(&PARM_IX)' EQ 'LINES' AND '&SYSLIST(&PARM_*#808 + IX+1)' EQ 'AT' AND '&SYSLIST(&PARM_IX+2)' EQ 'TOP') #808 + :&HAVE_TOP SETB 1 #808 + AEND #808 + AIF (&HAVE_TOP) #808 + AIF ('&SYSLIST(&PARM_IX)' EQ 'LINES') #808 + :&PARM_IX SETA &PARM_IX+1 #808 + AEND #808 + AIF ('&SYSLIST(&PARM_IX)' EQ 'AT') #808 + :&PARM_IX SETA &PARM_IX+1 #808 + AEND #808 + AIF ('&SYSLIST(&PARM_IX)' EQ 'TOP') #808 + :&PARM_IX SETA &PARM_IX+1 #808 + AEND #808 + :&FILE_TOP(&FILE_IX) SETC '&SYSLIST(&PARM_IX)' #808 + :&PARM_IX SETA &PARM_IX+1 #808 + AIF ('&SYSLIST(&PARM_IX)' EQ 'LINES') #808 + :&PARM_IX SETA &PARM_IX+1 #808 + AEND #808 + AIF ('&FILE_TOP(&FILE_IX)' EQ '') #808 + MNOTE 8,'LINAGE TOP clause witout value' #808 + AEND #808 + AEND #808 +.* Check for BOTTOM sub-clause #808 + :&HAVE_BOTTOM SETB 0 #808 + AIF ('&SYSLIST(&PARM_IX)' EQ 'BOTTOM') #808 + :&HAVE_BOTTOM SETB 1 #808 + AEND #808 + AIF ('&SYSLIST(&PARM_IX)' EQ 'LINES' AND '&SYSLIST(&PARM_*#808 + IX+1)' EQ 'BOTTOM') #808 + :&HAVE_BOTTOM SETB 1 #808 + AEND #808 + AIF ('&SYSLIST(&PARM_IX)' EQ 'AT' AND '&SYSLIST(&PARM_IX+*#808 + 1)' EQ 'BOTTOM') #808 + :&HAVE_BOTTOM SETB 1 #808 + AEND #808 + AIF ('&SYSLIST(&PARM_IX)' EQ 'LINES' AND '&SYSLIST(&PARM_*#808 + IX+1)' EQ 'AT' AND '&SYSLIST(&PARM_IX+2)' EQ 'BOTTOM') #808 + :&HAVE_BOTTOM SETB 1 #808 + AEND #808 + AIF (&HAVE_BOTTOM) #808 + AIF ('&SYSLIST(&PARM_IX)' EQ 'LINES') #808 + :&PARM_IX SETA &PARM_IX+1 #808 + AEND #808 + AIF ('&SYSLIST(&PARM_IX)' EQ 'AT') #808 + :&PARM_IX SETA &PARM_IX+1 #808 + AEND #808 + AIF ('&SYSLIST(&PARM_IX)' EQ 'BOTTOM') #808 + :&PARM_IX SETA &PARM_IX+1 #808 + AEND #808 + :&FILE_BOTTOM(&FILE_IX) SETC '&SYSLIST(&PARM_IX)' #808 + :&PARM_IX SETA &PARM_IX+1 #808 + AIF ('&SYSLIST(&PARM_IX)' EQ 'LINES') #808 + :&PARM_IX SETA &PARM_IX+1 #808 + AEND #808 + AIF ('&FILE_BOTTOM(&FILE_IX)' EQ '') #808 + MNOTE 8,'LINAGE BOTTOM clause witout value' #808 + AEND #808 + AEND #808 AELSE MNOTE 8,'FD OPTION NOT SUPPORTED - &SYSLIST(&PARM_IX)' :&PARM_IX SETA N'&SYSLIST+1 diff --git a/zcobol/mac/GEN_WS.MAC b/zcobol/mac/GEN_WS.MAC index 2d8382d17..d3422979c 100644 --- a/zcobol/mac/GEN_WS.MAC +++ b/zcobol/mac/GEN_WS.MAC @@ -40,6 +40,7 @@ .* 04/05/11 RPI 1139 SETA INDEX ARG IN QUOTES FOR HLASM COMP. .* 01/26/12 RPI 1181 correct literal values with _ vs - .* 02/16/12 RPI 1181 don't issue error for 0 length FILLER +.* 05/17/26 #808 WRITE not recognizing BEFORE / AFTER clauses ********************************************************************* GEN_WS COPY ZC_WS @@ -62,6 +63,7 @@ ZC_WSLOC LOCTR :&GRP_VAL SETC '' :&GRP_LVL SETA 0 :&I SETA 1 + :&ZC_ALL_BLANKS_LRECL SETA 0 Size of all blanks record area #808 AWHILE (&I LE &SYM_TOT) ACTR 1000 .* @@ -164,6 +166,15 @@ ZC_WS_LOC_&I EQU *-ZC_WS CHECK &SYM_NAME(&I) WS LOC AEND :&I SETA &I+1 AEND +.* #808 +.* Add all-blanks buffer to support WRITE with ADVANCING clause #808 +.* For files with Fixed-record lengths the RDW must be skipped #808 +.* #808 + AIF (&ZC_ALL_BLANKS_LRECL NE 0) #808 +ZC_ALL_BLNKS_RECORD_LENGTH DS XL4(0) Record Descriptor Word #808 +ZC_ALL_BLNKS_RECORD_SPACES DS CL(&ZC_ALL_BLANKS_LRECL)' ' #808 +ZC_ALL_BLNKS_RECORD_CNTRL DS CL2' ' 1 or 2 control chars #808 + AEND #808 MEXIT .* .* GEN WS DC @@ -370,6 +381,19 @@ ZC_WS_LOC_&I EQU *-ZC_WS CHECK &SYM_NAME(&I) WS LOC :&DDNAME SETC 'DDNAME=&FILE_DDNAME(&FILE_IX)' AEND AIF ('&FILE_ORG(&FILE_IX)' EQ 'LSEQ') +.* #808 +.* GEN DCB mapping (only once) #808 +.* #808 + AIF (NOT &DCBD) RPI 1048 FIX FWD REF TO DCBLEN + :&DCBD SETB 1 RPI 1048 + DCBD , RPI 1048 + AEND RPI 1048 +.* #808 +.* Determine max of minimum record lengths over all files #808 +.* This is needed to allocate a blanks area to support ADVANCING clause #808 + AIF (&FILE_LRECL1 GT &ZC_ALL_BLANKS_LRECL) #808 + :&ZC_ALL_BLANKS_LRECL SETA &FILE_LRECL1 #808 + AEND #808 .* .* GEN DCB FOR LINE SEQUENTIAL (FT/VT) .* @@ -380,11 +404,11 @@ ZC_WS_LOC_&I EQU *-ZC_WS CHECK &SYM_NAME(&I) WS LOC :&RECFM SETC 'FT' :&LRECL SETA &FILE_LRECL2(&FILE_IX) AEND - AIF (NOT &DCBD) RPI 1048 FIX FWD REF TO DCBLEN - :&DCBD SETB 1 RPI 1048 - DCBD , RPI 1048 - AEND RPI 1048 &FILE_NAME(&FILE_IX) DCB DSORG=PS,RECFM=&RECFM,BLKSIZE=&LRECL,&DDNAME +.* If LINAGE clause present on FD add room for counters #808 + AIF ('&FILE_LINAGE(&FILE_IX)' NE '') #808 + DC 4H'0' 4 unnamed halfwords: LINAGE,FOOTING, TOP, BOTTOM #808 + AEND #808 AELSEIF ('&FILE_ORG(&FILE_IX)' EQ 'QSAM') .* .* GEN DCB FOR SEQUENTIAL (F/V) @@ -396,11 +420,12 @@ ZC_WS_LOC_&I EQU *-ZC_WS CHECK &SYM_NAME(&I) WS LOC :&RECFM SETC 'F' :&LRECL SETA &FILE_LRECL2(&FILE_IX) AEND - AIF (NOT &DCBD) RPI 1048 FIX FWD REF TO DCBLEN - :&DCBD SETB 1 RPI 1048 - DCBD , RPI 1048 - AEND RPI 1048 + mnote 8,'**!! LRECL=&LRECL' &FILE_NAME(&FILE_IX) DCB DSORG=PS,RECFM=&RECFM,BLKSIZE=&LRECL,&DDNAME +.* If LINAGE clause present on FD add room for counters #808 + AIF ('&FILE_LINAGE(&FILE_IX)' NE '') #808 + DC 4H'0' 4 unnamed halfwords: LINAGE,FOOTING, TOP, BOTTOM #808 + AEND #808 AELSEIF ('&FILE_ORG(&FILE_IX)' EQ 'KSDS') .* .* GEN ACB FOR INDEXED @@ -418,10 +443,6 @@ ZC_WS_LOC_&I EQU *-ZC_WS CHECK &SYM_NAME(&I) WS LOC AEND AEND AEND - AIF (NOT &DCBD) RPI 1048 FIX FWD REF TO DCBLEN - :&DCBD SETB 1 RPI 1048 - DCBD , RPI 1048 - AEND RPI 1048 &FILE_NAME(&FILE_IX) DCB DSORG=PS,RECFM=&RECFM,BLKSIZE=&LRECL,&DDNAME AELSEIF ('&FILE_ORG(&FILE_IX)' EQ 'RRDS') .* @@ -440,10 +461,6 @@ ZC_WS_LOC_&I EQU *-ZC_WS CHECK &SYM_NAME(&I) WS LOC AEND AEND AEND - AIF (NOT &DCBD) RPI 1048 FIX FWD REF TO DCBLEN - :&DCBD SETB 1 RPI 1048 - DCBD , RPI 1048 - AEND RPI 1048 &FILE_NAME(&FILE_IX) DCB DSORG=PS,RECFM=&RECFM,BLKSIZE=&LRECL,&DDNAME AELSE MNOTE 8,'GEN_WS UNKNOWN FILE ORG - &FILE_ORG(&FILE_IX)' diff --git a/zcobol/mac/WRITE.MAC b/zcobol/mac/WRITE.MAC index fa47ceb6f..b4960d1d6 100644 --- a/zcobol/mac/WRITE.MAC +++ b/zcobol/mac/WRITE.MAC @@ -25,19 +25,12 @@ .* 10/06/08 ZSTRMAC .* 07/09/09 RPI 1065 move FILE_IX from SYM_REF to SYM_FD for groups .* 03/14/12 RPI 1182 COPY ALL OF PARMS FOR FROM FIELD FOR USE IN MOVE +.* 05/15/26 #808 WRITE not recognizing BEFORE / AFTER clauses .********************************************************************* WRITE &RECORD COPY ZC_WS :&NP SETA N'&SYSLIST - AIF (&NP GE 3 AND '&SYSLIST(2)' EQ 'FROM') - :&PARMS SETC '&SYSLIST(3)' RPI 1182 - :&I SETA 4 RPI 1182 - AWHILE (&I LE &NP) RPI 1182 - :&PARMS SETC '&PARMS,&SYSLIST(&I)' RPI 1182 - :&I SETA &I+1 RPI 1182 - AEND - MOVE &PARMS,TO,&RECORD - AEND +.* Find record and file pointer #808 ZC_SYM_FIND &RECORD AIF (&SYM_IX EQ 0) MNOTE 8,'WRITE RECORD NOT FOUND - &RECORD' @@ -48,6 +41,117 @@ MNOTE 8,'WRITE RECORD NOT A FILE RECORD - &RECORD' MEXIT AEND +.* Analyze all subclauses / phrases #808 + :&FROM SETC '' Init FROM field list #808 + :&ADV SETC '' Init ADVANCING parameters #808 + :&AFTER SETB 0 Before/After indicator #808 + :&EOP SETC '' Init END-OF-PAGE parms #808 + :&NEOP SETC '' Init NOT END-OF-PAGE parameters #808 + :&INV SETC '' Init INVALID-KEY parms #808 + :&NINV SETC '' Init NOT INVALID-KEY parms #808 + :&ENDW SETC '' INIT END-WRITE parameters #808 + :&PTR SETA 1 Parm 1 = record name #808 + :&CV SETC '' Current Variable name #808 + AWHILE (&PTR LT &NP) Scan starting at sysparm(2) #808 + :&PTR SETA (&PTR + 1) point next entry #808 + :&CUR SETC '&SYSLIST(&PTR)' get parameter #808 + :&NXT SETC '&SYSLIST(&PTR+1)' next parameter #808 + :&KWD SETB 0 not a keyword #808 + AIF ('&CUR' EQ 'FROM') #808 + :&KWD SETB 1 Mark keyword found #808 + :&CV SETC 'FROM' Set target variable #808 + :&(&CV) SETC '&CUR' init FROM field #808 + AEND #808 + AIF ('&CUR' EQ 'BEFORE' OR '&CUR' EQ 'AFTER') #808 + :&KWD SETB 1 Mark keyword found #808 + :&CV SETC 'ADV' Set target variable #808 + :&(&CV) SETC '&CUR' init ADV field #808 + :&AFTER SETB ('&CUR' EQ 'AFTER') Before/After? #808 + AEND #808 + AIF ('&CUR' EQ 'ADVANCING') #808 + :&KWD SETB 1 Mark keyword found #808 + AIF ('&ADV' EQ '') No BEFORE/AFTER found #808 + :&CV SETC 'ADV' Set target variable #808 + :&(&CV) SETC '&CUR' init ADV field #808 + :&AFTER SETB (1) After 1 is default #808 + AEND #808 + AEND #808 + AIF ('&CUR' EQ 'AT' OR '&CUR' EQ 'EOP' OR '&CUR' EQX#808 + 'END-OF-PAGE') #808 + :&KWD SETB 1 Mark keyword found #808 + :&CV SETC 'EOP' Set target variable #808 + :&(&CV) SETC '&CUR' init EOP field #808 + AEND #808 + AIF ('&CUR' EQ 'INVALID') #808 + :&KWD SETB 1 Mark keyword found #808 + :&CV SETC 'INV' Set target variable #808 + :&(&CV) SETC '&CUR' init INV field #808 + AEND #808 + AIF ('&CUR' EQ 'END-WRITE') #808 + :&KWD SETB 1 Mark keyword found #808 + :&CV SETC 'ENDW' Set target variable #808 + :&(&CV) SETC '&SYSLIST(&PTR)' init ENDW #808 + AEND #808 +.* NOT can be NOT INVALID or NOT [AT] {EOP|END-OF-PAGE} #808 + AIF ('&CUR' EQ 'NOT') #808 + :&KWD SETB 1 Mark keyword found #808 + AIF ('&NXT' EQ 'INVALID') NOT INVALID KEY #808 + :&CV SETC 'NINV' Set target variable #808 + :&(&CV) SETC '&SYSLIST(&PTR)' init NINV #808 + :&(&CV) SETC '&(&CV)'.',&NXT) #808 + :&PTR SETA (&PTR + 1) Consume 1 parm xtra #808 + AELSE NOT AT EOP #808 + :&CV SETC 'NEOP' Set target variable #808 + :&(&CV) SETC '&SYSLIST(&PTR)' init NEOP #808 + :&(&CV) SETC '&(&CV)'.',&NXT)' #808 + :&PTR SETA (&PTR + 1) Consume 1 parm xtra #808 +.* If it's AT, then also consume the next keyword #808 + AIF ('&NXT' EQ 'AT') #808 + :&NXT SETC '&SYSLIST(&PTR+1)' #808 + :&(&CV) SETC '&(&CV)'.',&NXT)' #808 + :&PTR SETA (&PTR + 1) Consume it #808 + AEND #808 + AEND #808 + AEND #808 + AIF (NOT &KWD) Not a relevant keyword #808 + :&(&CV) SETC '&(&CV)'.',&CUR' add to current var #808 + AEND Keyword check #808 + AEND Parameter loop #808 +.* AFTER ADVANCING #808 + AIF ('&ADV' NE '' AND &AFTER) Advance after? #808 + ADVANCING &ADV #808 + AEND #808 +.* FROM clause #808 + AIF ('&FROM' NE '') #808 + :&FROM SETC '&FROM'(6,*) drop 'FROM,' #808 + MOVE &FROM,TO,&RECORD #808 + AEND #808 +.* Actual WRITE #808 GEN_WRITE &RECORD - MEXIT +.* BEFORE ADVANCING #808 + AIF ('&ADV' NE '' AND NOT &AFTER) Advance before? #808 + ADVANCING &ADV #808 + AEND #808 +.* AT END-OF-PAGE #808 + AIF ('&EOP' NE '') AT EOP clause ? #808 + MNOTE 8,'AT END-OF-PAGE not yet implemented: &EOP' #808 + AEND #808 +.* NOT AT END-OF-PAGE #808 + AIF ('&NEOP' NE '') NOT AT EOP clause ? #808 + MNOTE 8,'NOT AT END-OF-PAGE not yet implemented: &NEOP' #808 + AEND #808 +.* INVALID KEY #808 + AIF ('&INV' NE '') INVALID KEY clause ? #808 + MNOTE 8,'INVALID KEY not yet implemented: &INV' #808 + AEND #808 +.* NOT INVALID KEY #808 + AIF ('&NINV' NE '') NOT INVALID KEY clause ? #808 + MNOTE 8,'NOT INVALID KEY not yet implemented: &NINV' #808 + AEND #808 +.* END-WRITE #808 + AIF ('&ENDW' NE '') END-WRITE clause ? #808 + AIF ('&ENDW' NE 'END-WRITE') this is valid and ignorable #808 + MNOTE 8,'END-WRITE suboperands not allowed' #808 + AEND #808 + AEND #808 MEND diff --git a/zcobol/mac/WS.MAC b/zcobol/mac/WS.MAC index c214e2f8c..3786395f8 100644 --- a/zcobol/mac/WS.MAC +++ b/zcobol/mac/WS.MAC @@ -58,7 +58,8 @@ .* 11/26/10 RPI 1138 CORRECT SYM_PIC_DEC FOR DISPLAY PICTURE Z.99 ETC. .* 04/05/11 RPI 1139 FIX SETA STRING FOR HLASM COMP .* 02/16/12 RPI 1181 FIX TO HANDLE PIC X(8). WITH PERIOD FOLLOWING. -.* 25-10-22 AFK #578 zCobol compiles get "actr limit exceeded" errors +.* 10/25/22 AFK #578 zCobol compiles get "actr limit exceeded" errors +.* 05/25/26 AFK #808 WRITE statement not handling AFTER/BEFORE .********************************************************************* .* .* WS level,name,clauses in any order (PIC,VALUE,USAGE supported) @@ -281,6 +282,9 @@ :&SYM_LEN(&SYM_TOT) SETA &WS_PAD :&SYM_DUP(&SYM_TOT) SETA 1 SYM FIELD OCCURANCES :&SYM_PIC_TYPE(&SYM_TOT) SETC 'X' SYM PIC TYPE DEF DSP +.* Add full picture string to avoid dup factor of 0 being generated #808 +.* in GEN_WS.MAC (intended for group items only) #808 + :&SYM_PIC(&SYM_TOT) SETC 'X(&WS_PAD)' Full picture string #808 AEND .* .* STORE SINGLE OR MULTIPLE 88 CONDITION VALUES FOR PRIOR WS ITEM @@ -423,6 +427,10 @@ :&SYM_DUP(&SYM_TOT) SETA 1 :&SYM_PIC_TYPE(&SYM_TOT) SETC 'X' :&WS_LOC SETA &WS_LOC+&ZC_DCB_LEN +.* If LINAGE clause present on FD add room for counters #808 + AIF ('&FILE_LINAGE(&FILE_IX)' NE '') #808 + :&WS_LOC SETA &WS_LOC+8 4 hidden unnamed halfwords: #808 + AEND LINAGE,FOOTING, TOP, BOTTOM #808 AEND .* .* SCAN FOR CLAUSES AND SET NAME TO FILLER IF NO NAME FIELD