/macros/cobol2v.vdm
Unknown | 2726 lines | 2649 code | 77 blank | 0 comment | 0 complexity | 701ea5b424e9118f22a40753892e63f1 MD5 | raw file
Large files files are truncated, but you can click here to view the full file
- // COBOL2V.VDM - Process COBOL copybook, converting to Greenview's
- // "code colbeg,colend" format.
- //
- // Written by: Thomas C. Burt, Greenview Data, Inc.
- // Last change: 07/26/2007
- //
- // Can now (10/31/2003) handle UniSys streaming nibbles that
- // ignore byte boundaries; types 'm', 'mh' and 'mx'.
- //
- // Will also now optionally treat "COMP" as Packed-No-Zone.
- //
- // Requires: VEDIT PLUS 6.11.2E dated 11-05-2003 or later for NIBBLES or
- // VEDIT PLUS 6.03 dated 06-01-2002 or later, otherwise.
- //
- // Can be run stand-alone or as a submacro to EBCDIC-n.VDM.
- //
- // Usage (stand alone):
- //
- // vpw [-y] -x COBOL2V copybook.cbk [-a layout.lay] [-u options]
- //
- // -y causes COBOL2V.VDM to exit to DOS when running in
- // stand-alone-mode, saving all files. Otherwise, the
- // newly generated .lay file is displayed in visual mode.
- //
- // -a changes the destination filename to something other
- // than the source filename.
- //
- // -u options
- //
- // DBASE uses ".dbf" as the output extent for filenames
- // in the .LAY output file;
- // generates "// col (INDEX)" at the end of each
- // record and extracted data section ("out" or "rb");
- // generates a cross reference .XRF file. E.g.,
- //
- // "vpw -x cobol2v cobol.cbk -a gv.lay -u DBASE"
- //
- // produces both "gv.lay" and "gv.xrf".
- //
- // SQL Generates ..._SQL_CRE.IMP file of SQL types & lengths.
- //
- // DOS (default): emit <cr><lf> at the end of each
- // output line. Uses ".asc" as the output extent.
- //
- // UNIX: emit <lf> at the end of each output line.
- //
- // MAC: emit <cr> at the end of each output line.
- //
- // cc=col_num to set starting column for comment field.
- //
- // comp=level for default "COMP." level (normally 4 for
- // Big Endian (IBM) binary).
- //
- // NORELAY - don't run RELAY.VDM even in "stand-alone" mode.
- //
- // ISHORT - Insert short field names into comment section past
- // "col" when DBASE is operative.
- //
- // NAMES - Generate .nam file with COBOL field names.
- // Names are quoted and comma delimited.
- // A newline is generated at the start of each record;
- // i.e., at each "c=0" specification in the source file.
- // To be properly included during data conversion by
- // the EBCDIC-x conversion package, each line must later
- // be extracted into its own separate ".nam" file.
- //
- // NIBBLES - Packing BCD digits across byte boundaries.
- // When used, COMP fields are considered to be
- // nibbles (usually BCD, with or without a sign
- // nibble), packed streamwise from the left.
- //
- // PNZ - all "COMP" fields are treated as Packed-No-Zone
- // instead of being treated as binary data.
- // Archaic; use "comp=6" instead.
- //
- // In stand alone mode, the entire active file is presumed
- // to be COBOL copybook statements. The only extra statements
- // are blank lines, VEDIT comments, "c=0[,R]" and, perhaps,
- // "p=" and "q=" lines.
- //
- // The "c=0[,R]" line is used to indicate the start of a new
- // record type; 'R' is a unique letter for identifying
- // the record type. It generates a 'tx "R.ext"' line and, for
- // "-u DBASE", is used in generating the cross reference
- // "short" field name.
- //
- // When being driven by EBCDIC-n.VDM, "p=" and "q=" brackets
- // are required around any copybook statements.
- //
- // Usage as a submacro to EBCDIC-n.VDM:
- // Set #64 = 0x200 to strip comments from the copybook.
- // = 0x202 to comment out the copybook.
- // (The copybook is always commented out when
- // run stand-alone).
- // Set #65 = base register. Registers (base+10 - base+18)
- // are used herein, saving/restoring user's
- // contents.
- //
- // When run as a submacro, the "p=" and "q=" brackets must
- // be used around each section of COBOL statements.
- //
- // Use "c=0[,R]" to indicate the start of a new record type. The 'R' will
- // be used to form a proto-filename: 'tx "R.ASC"', e.g.
- // The "c=0[,R]" line will be replaced by a proto record specification:
- // "t 1,0xff,0xF1 // Record type #1: EBCDIC '1' in col 1"
- // "l=reclen"
- //
- // Note: Comments out all REDEFINES clauses/paragraphs. The user will
- // probably need to edit the resulting output file or edit the
- // source file and rerun COBOL2V on the edited source file.
- //
- // Handles multiple, even nested, OCCURS DEPENDING ON clauses.
- //
- // Handles: [COMP[-n]] [S][9[9...][(n)]] [V 9[9...][(n)]] [COMP[-n]]
- // [COMP[-n]] [9[9...][(n)]] [V 9[9...][(n)]]- [COMP[-n]]
- // where n={1,2,3,4,6}
- // ={Float,Double,BCD,binary,PNZ}.
- // where BCD = Binary Coded Decimal = Packed Decimal
- // PNZ = Packed-No-Zone = signless BCD
- // X[X...][(n)], where 'n' = # bytes.
- // B[B...][(n)], "
- // C[C...][(n)], "
- // D[D...][(n)], "
- // F[F...][(n)], "
- // H[H...][(n)], "
- // Y[Y...][(n)], "
- //
- // 'B' is binary (including 1-byte binary).
- // 'C' is for a custom field.
- // 'D' deletes the field.
- // 'F' fills the field with spaces.
- // 'H' is hexadecimal.
- // 'Y' is DATE (for SQL).
- //
- // Note: 'B', 'C', 'D', 'F', 'H' and 'Y' are special Greenview only codes.
- // These codes must be edited into the COBOL copybook, replacing
- // ambiguous 'X' picture statements.
- //
- // Note: 'Y' is converted to 'e' for the .lay file but generates a DATE
- // field type and length for the SQL .imp file.
- //
- // Note: "COMP." is binary (Big Endian) unless the "-u comp=level" parameter is used.
- //
- // Note: When the "-u NIBBLES" parameter is used for UniSys' streaming nibbles,
- // COMP's are assumed to be BCD or PNZ with or without a leading sign nibble.
- //
- // Note: The archaic "-u PNZ" is still valid but the alternative "-u comp=6" is preferred.
- //
- // COMP-1 is floating point.
- // COMP-2 is double precision.
- // COMP-3 is packed decimal.
- // COMP-4 is IBM binary (Big Endian).
- // COMP-5 is HardWare ordered binary (NYI).
- // COMP-6 is Packed-No-Zone (PNZ).
- //
- // The COBOL specification for binary is PIC [S]9(n) COMP, where normal
- // values for 'n' are 4, 8 and 18 for 2-, 4- and 8-byte binaries.
- // This macro supports all binary sizes upto 8 bytes.
- // It generates ",=len;" where "len" = # digits for picture clauses
- // other than the defaults. It generates the "raw" option for
- // binaries whose picture clauses specify that values may be larger
- // than "all spaces".
- //
- // It outputs 'u' into the options field for unsigned numbers.
- //
- // Note: input field width for BCD pictures S9(n)v9... COMP-3 =
- // Int(( Total(9's) / 2 )) + 1
- //
- //////////////////////////////////////////////////////////////////////////
- // //
- // Cross Reference File //
- // //
- //////////////////////////////////////////////////////////////////////////
- //
- // When the "-u DBASE" input option is used in stand-alone mode,
- // a cross reference file will be generated consisting of
- // "r[s]n" "cobol-statement-name" pairs.
- //
- // 'r' is a letter denoting the record name as specified by the "c=0,r"
- // line or {A,B,C,...} if 'r' is not specified.
- //
- // 's' = {A,B,C,...} is a letter generated for records containing more than
- // 250 fields. Such records are automatically split into 250-field sections.
- // 'out "rs.DBF"' ... 'out' brackets are emitted into the .lay file.
- // The opening bracket will be moved forward if it would otherwise appear
- // in the middle of an "OCCURS" clause.
- //
- // 'n' is the field index, starting from one. It continues incrementing even
- // when records are automatically split into sections. It is reset by each
- // "c=0" line.
- //
- // Each line in the cross reference file consists of 12 spaces, the
- // automatically generated "short" name and the full COBOL copybook name
- // which starts in column 30.
- //
- // The filename will have the same name as the current .lay output filename
- // with extension ".xrf".
- //
- //////////////////////////////////////////////////////////////////////////////
- //
- // Text Marker Usage
- //
- // Marker(8)-> (moving) start of the COBOL block.
- // Marker(9)-> past end of the COBOL block.
- // Marker(7)
- // Marker(6)-> "." terminating current COBOL line.
- // Marker(5)-> BOL of current COBOL statement.
- //
- //////////////////////////////////////////////////////////////////////////////
- //
- // Numerical Register Usage
- //
- // Note: Preserves Numerical Registers 6-8, 64-66, 75,76, 90-92, 99 and 105
- // for EBCDIC-x.VDM.
- //
- // #1 For last usable column + 1 (Set to 73 in Main Processing Loop)
- // #2 COMP level (0=no,1-6,0xFF=default)
- // (1=Float,2=Double,3=BCD,4=IBM binary,5=HW dependent binary,6=PNZ)
- // Note: COMP-5 not yet implemented...
- // "COMP." defaults to "COMP-4." (Big Endian (IBM) binary)
- // #21 Flag/buffer-ID for cross reference output file
- // #22 Running-stand-alone flag
- // #23 Field counter
- // #24 Record counter
- // #25 Record Name (1 letter)
- // #26 Record size
- // #27 Details record counter (OCCURS DEPENDING ON)
- // #28 File type: {DOS,UNIX,MAC,DBASE}
- // #29 Starting column for comments
- // #30 NORELAY flag
- // #32 ISHORT flag to insert short names into comment field
- // #33 Level-2 flag (single record, no OCCURS DEPENDING ON)
- // #34 NAMES flag to generate COBOL field names in .nam file
- // #35 NIBBLES flag for streaming BCD across byte boundaries
- // #36 Record size augmentation in half-bytes when NIBBLES
- // #37 Default "COMP" level; normally "4" (binary).
- // #38 SQL output_flag/buffer_id.
- // #90 ID of register this macro is running in.
- // #92 current (copybook) edit buffer ID
- //
- //////////////////////////////////////////////////////////////////////////////
- //
- // Text register usage (caller's text registers pushed and popped).
- //
- // 10 Work register converting "+len" to "bc,ec" format at end.
- // 10-14 Regular expressions (OCCURS processing submacros).
- // 15 "Next_Peer_Field" locating submacro of OCCURS submacro.
- // 16 OCCURS processing submacro.
- // 17 REDEFINES processing (comment out the paragraph).
- //
- // Text registers not pushed and popped:
- // 0-2 Temporary
- // 55 Determine block markers Marker(8) and Marker(9); run RELAY.VDM
- // 56 .lay code generator (code +len [vn]) and cross referencer
- // 99 Life-indicating message register
- //
- //////////////////////////////////////////////////////////////////////////////
- //
- // Abbreviations:
- //
- // '^' is beginning of a line
- // 'v' is the edit position
- // '.' is anything
- // '01' is an example of a clause level
- //
- // BOS Beginning Of Statement: "^v...... 01 Clause_Name"
- // BOCL Beginning of clause level: "^....... v01"
- // EOCL End of clause level: "^....... 01v"
- // BOCN Beginning of clause name: "^....... 01 vClause_Name"
- // EOCN End of clause name: "^....... 01 Clause_Namev"
- //
- //////////////////////////////////////////////////////////////////////////////
- //
- // Initialization.
- //
- // if (wstat($)<0){wr($,5,bottom)};ws($);bs(1,attach);ws($);update() ?
- //
- // Just return if "p=,q=" brackets missing while being driven by EBCDIC-n.VDM.
- //
- if (#64&0x200) { // When running as a submacro...
- if (Search("|<p=",BEGIN+NOERR)==0){return}
- }
-
- Num_Push(6,8)
- Num_Push(64,66)
- Num_Push(75,76)
- Num_Push(90,92)
- Num_Push(99,99)
- Num_Push(105,105)
-
- if ((#64&0x200)==0) { // When running stand-alone...
- #65 = Reg_Free // Get base register
- } // Otherwise, #65 is already defined
- Reg_Push(#65+10,#65+18) // Save caller's text registers
- Config(U_AUTO_CFG,0)
- Config(F_AUTO_SAVE,0)
- Config(E_EXP_TAB,1,LOCAL) // Tabs complicate COBOL processing
- Config(E_RETAB_BK,0,LOCAL)
- Config(E_RETAB_FILL,0,LOCAL)
- Config(S_E_MORE,0) // Disable CRT scroll-lock
-
- #90 = Macro_Num
- //
- //////////////////////////////////////////////////////////////////////////////
- //
- // Setup submacros in T-Regs[15 - 17].
- //
- //
- // T-Reg[15] - NEXT_PEER_FIELD submacro.
- // Goto start of next statement whose level is less than or equal
- // to that in #0; goto Marker(9) if no such field.
- //
- // Enter: #0 = statement level.
- // #1 = Maximum usable data column.
- // Marker(9).
- //
- // Uses numreg[10] for search/replace options; usage is consistent
- // with that of the calling macro.
- //
- Reg_Set(#65+15,`
- #10 = COLSET+REGEXP+MAX+ADVANCE+NOERR
- repeat( all ) {
- if (Search_Block("\$+\@(#65+12)[0-9]",Cur_Pos,Marker(9),#10,1,#1-1)==0){
- GM(9) // I don't know why 71 instead of 72
- }
- if (Cur_Pos >= Marker(9)) {
- GM(9)
- break
- }
- char(-1)
- if (Num_Eval(SUPPRESS)<=#0){
- BOL
- break
- }
- Line(1,errbreak)
- }
- return
- `) // T-Reg[15] - NEXT_PEER_FIELD submacro
-
- //////////////////////////////////////////////////////////////////////////////
- //
- // T-Reg[16] - OCCURS processing submacro.
- // Process: OCCURS n TIMES [INDEXED BY...] clauses by duplication.
- // OCCURS [ m TO ] n [TIMES] DEPENDING ON x.
- //
- // Enter: #1 = Maximum usable data column
- // Marker(8)-> start of COBOL specs.
- // Marker(9)-> past end of COBOL specs.
- //
- // "OCCURS n [TIMES] [INDEXED BY ... ]."
- // Duplicate the paragraph 'n' times, appending '-m' (m=1,n) to names.
- // Comment out the "OCCURS" statement.
- //
- // "OCCURS ... DEPENDING ON x"
- // Generate 'rcx', 'rb' and 're' code lines for each occurrence.
- //
- //////////////////////////////////////////////////////////////////////////////
- //
- // Numreg usage in T-Reg[16] (caller's values saved by push/pop).
- //
- // 0 Paragraph level (T-Reg[15] also)
- // 2-7,12 Duplicating paragraphs
- // 3 OCCURS count
- // 9 Edit Buffer Number
- // 10 OPTIONS for search/replace (T-Reg[15] also)
- // 11 Work Buffer Number
- // 12 a.s.
- // 27 Index of current "DEPENDING ON" clause, from 0
- //
- //////////////////////////////////////////////////////////////////////////////
- //
- // Marker usage:
- //
- // Marker(1)-> BOS of "occurs ... depending on ...".
- // Marker(2)-> BOS defined in the "depending on" clause, if any.
- // Marker(3)-> BOS of "occurs" paragraph.
- // Marker(4)-> past " occurs ".
- // Marker(5)-> past statement terminating "."
- // Marker(6)-> one position ahead of the body (sub-clauses) to the <lf>
- // following Marker(5). (When such body exists; i.e., no
- // PIC clause preceding the OCCURS clause)
- // Marker(7)-> past "occurs" paragraph.
- // Marker(8)-> start of COBOL specs (entry).
- // Marker(9)-> past end of COBOL specs (entry).
- //
- //////////////////////////////////////////////////////////////////////////////
- //
- Reg_Set(#65+16,`
- Num_Push(0,12)
- #11 = Buf_Free(EXTRA) // Get ID of available work buffer
- GM(8) // Start at beginning of COBOL specs
- repeat( all ){
- //
- // Set Marker(4) past next " occurs ".
- //
- #10 = COLSET+REGEXP+MAX+ADVANCE+ERRBREAK
- sb("\@(#65+11).* occurs ",cp,Marker(9),#10,1,#1)
- Set_Marker(4,Cur_Pos)
- //
- // Set Marker(5) past statement terminating "."
- //
- bol
- #10 = COLSET+REGEXP+MAX+ADVANCE
- sb("\@(#65+11).*\.",curpos,Marker(9),#10,1,#1)
- Set_Marker(5,Cur_Pos)
-
- ///////////////////////////////////////////////////////////////////////////
- // //
- // DEPENDING ON //
- // //
- ///////////////////////////////////////////////////////////////////////////
- //
- // Set Marker(1)-> BOS
- // Generate 'rb ##27[ "Znr.DBF,Znr"]'<newline>.
- // Set Marker(2)-> BOS defined in "depending on" clause.
- // Generate "rc ##27"<newline>.
- // Go to end of paragraph by finding start of the next
- // paragraph at this or lower-numbered level. Don't include
- // commented lines at the end of the paragraph.
- // Generate "re"<newline>
- // Advance to next line.
- // Loop
- //
-
- GM(4)
- if (sb("|bdepending",cp,Marker(5),ADVANCE+NOERR)) {
- match("|W",ADVANCE)
- if (cn>#1||AtEOL){
- sb("^......\s+",cp,Marker(5),#10,1,#1)
- }
- if (match("on",ADVANCE)==0){
- match("|W",ADVANCE)
- if (cn>#1||AtEOL){
- sb("^......\s+",cp,Marker(5),#10,1,#1)
- }
- Set_Marker(0,Cur_Pos)
- //
- // Goto BOS - set Marker(4) and generate 'rb ##27[ "Znr.DBF",Znr]'<newline>.
- //
- gm(4)
- #10 = COLSET+REGEXP+MAX+REVERSE
- sb("\$+\@(#65+13)",Marker(8),cp,#10,1,#1)
- #27++
- Ins_Text('rb #')
- Num_Ins(#27,LEFT+NOCR)
- if (#21>0){
- Ins_Text(' "Z')
- Num_Ins(#27,LEFT+NOCR)
- Ins_Char(#25)
- Ins_Text('.dbf",Z')
- Num_Ins(#27,LEFT+NOCR)
- Ins_Char(#25)
- }
- Ins_Newline()
- Set_Marker(1,Cur_Pos)
- c(7)
- #0 = Num_Eval(SUPPRESS)
- //
- // Goto EOS and copy counter's name into T-Reg[0].
- //
- GM(0)
- s("|{|b,.}")
- rcb(0,Marker(0),Cur_Pos)
- //
- // Goto start of next clause and generate "re"<newline>
- //
- call(#65+15) // NEXT_PEER_FIELD
- Ins_Text("re")
- Ins_Newline()
- //
- // Find the counter's definition.
- //
- GM(8)
- s("|b|@(0)|{|b,.}")
- //
- // Set Marker(2) and generate "rc ##27"<newline>.
- //
- BOL
- Ins_Text("rc #")
- Num_Ins(#27,LEFT)
- Set_Marker(2,Cur_Pos)
- GM(0)
- line(1,errbreak)
- continue
- }}
-
- ///////////////////////////////////////////////////////////////////////////
- // //
- // OCCURS n [TIMES]. //
- // //
- ///////////////////////////////////////////////////////////////////////////
- //
- // Set #3 = "dup" count.
- //
- gm(4)
- sb("|d",Cur_Pos,Marker(5),colset,7,#1)
- #3 = NumEval()
- //
- // Set #0 = paragraph level.
- //
- gm(4)
- #10 = COLSET+REGEXP+MAX+ADVANCE+REVERSE
- sb("\$+\@(#65+13)",Marker(8),cp,#10,1,#1)
- s(" ",reverse)
- #0 = Num_Eval(SUPPRESS)
- //
- // Set Marker(3)-> beginning of this line, the BOS.
- //
- Set_Marker(3,BOL_Pos)
- //
- // Handle case of single statement (with PIC clause) being duplicated.
- // Create subparagraph instance of the statement less the "occurs" clause.
- //
- GM(3)
- if (sb("|bPIC|[TURE]|W|F",Cur_Pos,Marker(5),ADVANCE+COLSET+NOERR,7,#1)) {
- //
- // Copy the statement into T-Reg[0] and advance to following line.
- //
- GM(5)
- Line(1)
- RCB(0,Marker(3),Cur_Pos)
- //
- // Move the statement into work buffer.
- //
- #9 = bn
- bs(#11)
- bof()
- dc(all)
- ri(0,BEGIN)
- //
- // Remove any comment lines.
- // Convert rest into simple string.
- //
- while (!At_EOF) {
- Del_Char(6)
- if (Match(" ")) {
- Del_Line(1)
- continue
- } else {
- EOL
- if ((#2 = Cur_Pos - BOL_Pos - 66) > 0 ) {
- Del_Char(-#2)
- }
- Line(1,ERRBREAK)
- }
- }
- Replace("|L"," ",ALL+BEGIN+NOERR)
- //
- // Delete the "OCCURS..." clause.
- //
- Search(" occurs ",BEGIN+ADVANCE)
- #2 = Cur_Pos - 8
- Search("|d|s")
- Char(1)
- If (Search(" TIMES|S",ADVANCE+NOERR)) {
- Char(-1)
- }
- if (Search(" INDEXED|WBY|W",ADVANCE+NOERR)) {
- Search("|{ ,.}")
- }
- Del_Block(#2,Cur_Pos)
- //
- // Increment the statement level by one.
- // (Since this statement has a PIC clause, it has no subparagraphs).
- //
- BOF
- Match("|W",ADVANCE)
- #2 = Num_Eval(SUPPRESS) + 1
- #4 = Chars_Matched
- #5 = Cur_Pos
- Del_Char(#4)
- Ins_Char(' ',COUNT,#4) // Additional indentation
- Num_Ins(#2,LEFT+NOCR)
- Set_Marker(0,Cur_Pos) // 1st marker set in this edit buffer
- #6 = Cur_Pos - #5 - #4
- If (#6<#4) {
- GP(#5+#4)
- Ins_Char('0',COUNT,#4-#6)
- }
- //
- // Remove excess spaces.
- // Better too tight than grossly expansive.
- //
- GM(0)
- Match("|W",ADVANCE)
- Replace("|W"," ",ALL+NOERR)
- //
- // Restore the string to COBOL format.
- //
- BOF
- Ins_Char(' ',COUNT,6)
- Replace("|w|>"," ",NOERR)
- Ins_Newline(1)
- Char(-Newline_Chars)
- if (Cur_Pos > #1-5) { // Need room for "-m", (m=1,999)
- Search(" PIC|[TURE] ",BEGIN)
- Char(1)
- Ins_Newline(1)
- Ins_Char(' ',COUNT,6+#5+#4+6)
- }
- BOF
- while (!At_EOF) {
- EOL
- #2 = Cur_Pos - BOL_Pos
- if (#2 < #1 ) {
- Ins_Char(' ',COUNT,#1 - #2)
- }
- Line(1,ERRBREAK)
- }
- //
- // Move the reformatted statement into T-Reg[0].
- // Switch back to the main edit buffer and insert it.
- //
- rcb(0,0,EOB_Pos,DELETE)
- bs(#9)
- Reg_Ins(0)
- }
- //
- // Set Marker(6) two positions ahead of the paragraph's body.
- // (Guaranteed now to have one).
- //
- gm(5)
- Line(1,errbreak)
- Set_Marker(6,Cur_Pos-2)
- //
- // Set Marker(7) to end of paragraph by finding start of the next
- // paragraph at this or lower-numbered level. Don't include commented
- // lines at the end of the paragraph.
- //
- call(#65+15) // NEXT_PEER_FIELD
- Set_Marker(7,Cur_Pos)
- #10 = REGEXP+MAX+NOERR
- repeat( all ) {
- line(-1)
- if (Match("^......[^\s]",#10)==0) {
- Set_Marker(7,Cur_Pos)
- } else {
- if (( Match("^......[\s]+",#10)==0) && Chars_Matched >= #1 ) {
- Set_Marker(7,Cur_Pos)
- } else {
- break
- }}
- }
- //
- // Move the paragraph body (Marker(6)+2,Marker(7)) to T-Reg[0].
- //
- RCB(0,Marker(6)+2,Marker(7),DELETE+NORESTORE)
- //
- // Strip out commented lines.
- //
- #9 = bn
- bs(#11)
- bof()
- dc(all)
- ri(0)
- #10 = BEGIN+ALL+REGEXP+MAX+NOERR
- rb("^......[^\s].*\N","",0,fsize,#10)
- //
- // Strip out level 88's (VALUE clauses).
- //
- bof
- #10 = REGEXP+MAX+NOERR
- while (sb("^......[\s]+88\s",cp,fsize,#10)) {
- #101 = BOL_Pos
- s(".") // Comments gone; hope no quoted '.'s
- l()
- db(#101,cp)
- }
- RCB(1,0,FSIZE)
- bq(OK)
- bs(#9)
- //
- // Insert it #3 times, appending "-m" to each field name, m=1,#3.
- // Note: Uses numeric registers 2-7,12.
- // Restores T-Reg[0] from T-Reg[1] at bottom of loop.
- //
- #4 = 1
- repeat( #3 ) {
- gm(7)
- #7 = Cur_Pos
- Reg_Ins(0,BEGIN)
- #10 = COLSET+REGEXP+MAX+ADVANCE+NOERR
- while(sb("\$+\@(#65+12)[0-9]",cp,Marker(7)-2,#10,1,#1-1)) { // BOCL
- char(-1)
- if (numeval(ADVANCE+SUPPRESS)==88){continue}
- match("[\s]+[^\s\t.]+",REGEXP+MAX+ADVANCE)
- if (Cur_Pos - BOL_POS >= #1){continue}
- #5 = #12 = Cur_Pos
- ic('-')
- num_ins(#4,left+nocr)
- #5 = #6 = #2 = Cur_Pos - #5
- if (Cur_Char == '.'){c}
- while( #5-- ) {
- if ( Cur_Char != ' ' ) {
- break
- }
- Del_Char()
- #6--
- }
- //
- // Restore space.
- // Check for more space at end of line.
- //
- if (Cur_Char != ' ') {
- Ins_Char(' ')
- #6++
- Goto_Col(#1+1+#6)
- while( #6-- ) {
- if ( Cur_Char(-1) != ' ' ) {
- Del_Block( Cur_Pos, EOL_Pos )
- if (cn<#1){
- break
- }
- Goto_Pos(#12)
- Del_Char(#2)
- break
- }
- Del_Char(-1)
- }
- }
- }
- if (#4 != 1) {
- Block_Fill(' ',#7,Marker(7)-2,COLSET,1,6)
- Del_Block(#7,Marker(7)-2,COLSET,#1+1,90)
- }
- //
- // Handle any DEPENDING ON var(n).
- // I.e., where "var" is defined within an OCCURS clause.
- //
- GP(#7)
- while(sb("\$+\@(#65+11).*DEPENDING",cp,Marker(7)-2,#10,1,#1-1)) {
- sb(" ON ",cp,Marker(7)-2,COLSET+ADVANCE+NOERR,7,#1-1)
- char(-1)
- sb(" |A",cp,Marker(7)-2,COLSET+ADVANCE,7,#1-1)
- #7 = cp - 1
- Search("|{ ,.}")
- Save_Pos()
- rcb(0,#7,cp)
- gm(8)
- if (sb("\$+\@(#65+11).*\@(0)\h28",cp,Marker(7)-2,#10,1,#1-1)){
- Restore_Pos()
- Ins_Char(0x28)
- ni(#4,LEFT+NOCR)
- Ins_Char(0x29)
- match(".",advance)
- if (cn>70){
- dl(1)
- in(1)
- gp(#7)
- in(1)
- ic(' ',count,20)
- }
- } else {
- Restore_Pos()
- }
- }
- //
- #4++
- Reg_Set(0,@1)
- }
- //
- // Comment out the "occurs" statement.
- //
- gm(3)
- Replace_Block("\@(#65+11)","*******",cp,Marker(5),REGEXP+ALL)
- //
- // Now go to the original paragraph body in case of nested "occurs".
- //
- GP(Marker(6)+2)
-
- } // (all)
-
- Num_Pop(0,12)
-
- `) // T-Reg[16] - OCCURS submacro
-
- //////////////////////////////////////////////////////////////////////////////
- //
- // T-Reg[17] - REDEFINES processing submacro.
- // Comment out all REDEFINES paragraphs with '.'.
- // Enter: Marker(8)-> start of COBOL statements.
- // Marker(9)-> past end.
- // #1 = Rightmost usable data column.
- //
- // Note: standard comment is '*' in column 7. Using '.' will identify
- // statements commented out by this macro.
- //
- //////////////////////////////////////////////////////////////////////////////
- //
- // Numreg usage:
- //
- // 0,2 Temporary
- // 9 - 16 Equivalent-compressed-data processing
- // 101 Search options
- //
- //////////////////////////////////////////////////////////////////////////////
- //
- // Marker usage:
- //
- // Marker(5)-> start of REDEFINES statement.
- // Marker(6)-> past " REDEFINES".
- // Marker(7)-> past REDEFINES block.
- //
- // Marker(3)-> start of original definition statement.
- // Marker(4)-> past end of original definition block.
- //
- Reg_Set(#65+17,`
- GM(8)
- repeat ( all ) {
- //
- // Set marker(6) past next " REDEFINES".
- //
- #101 = COLSET+REGEXP+MAX+ADVANCE+ERRBREAK
- sb("\@(#65+11).* REDEFINES ",Cur_Pos,Marker(9),#101,1,#1)
- Set_Marker(6,Cur_Pos)
- //
- // Set marker(5) to BOS.
- // Set #0 = level.
- //
- #101 = COLSET+REGEXP+MAX+ADVANCE+REVERSE
- sb("\$+\@(#65+13)",Marker(8),cp,#101,1,#1)
- s(" ",reverse)
- #0 = Num_Eval(SUPPRESS)
- BOL
- Set_Marker(5,Cur_Pos) // Start of "REDEFINES" line
- //
- // Set marker(7) to end of this paragraph by finding start
- // of the next peer or lower indexed statement.
- //
- line(1,noerr)
- call(#65+15) // NEXT_PEER_FIELD
- SM(7,Cur_Pos)
- //
- // Comment out each line in the marked section.
- //
- GM(5)
- Replace_Block(" ",".",Cur_Pos,Marker(7)-1,COLSET+NOERR+ALL,7,7)
- //
- GM(7)
-
- } // Commenting out REDFINES paragraphs.
-
- `) // T-Reg[17] - REDEFINES submacro
-
- //////////////////////////////////////////////////////////////////////////////
- //
- // T-Reg[55] - Determine block markers Marker(8) and Marker(9) vis a vis
- // p=,q=, and c=0[,R].
- // Set "l=reclen" for previous record type.
- // Generate record name tx R.asc or R.dbf,R if at c=0,R.
- // Generate prototype "t 1,0xFF,0xF1" line.
- //
- // Set Marker[8]-> start of COBOL block.
- // Set Marker[9]-> past COBOL block.
- // Delete any bounding "p=" and "q=" records.
- //
- //////////////////////////////////////////////////////////////////////////////
-
- Reg_Set(55,`
- GM(9)
- //
- // When running stand-alone:
- //
- if (#22) { // Stand alone...
- call("COBBEG") // Find/process start of COBOL block
- call("COBEND") // Find/process end of COBOL block
- return
- //
- // When running as a submacro to EBCDIC-n.VDM:
- //
- } else {
- Set_Marker(8,Cur_Pos)
- Search("|<|{p=,q=}",NOERR)
- if (Error_Match){
- EOF()
- Set_Marker(8,Cur_Pos) // Marker(8) at EOF
- Set_Marker(9,Cur_Pos) // Marker(9) at EOF
- return
- }
- //
- // Process p=[.].
- //
- if (Match_Item==1) {
- BOL()
- Del_Line(1) // Delete the "p=" line
- while(Match("|<c=")==0){
- Line(1,NOERR)
- }
- Set_Marker(8,Cur_Pos) // Marker(8) at beginning of block
- Search("|<|{c=,q=}",NOERR)
- if (Error_Match){
- Set_Marker(9,File_Size)
- Return
- }
- Set_Marker(9,Cur_Pos)
- if (Match_Item==2){
- Del_Line()
- }
- Return
- }
- //
- // Process q=
- //
- Del_Line(1)
- Set_Marker(9,Cur_Pos) // Marker(9) at end of block
- GM(8)
- While(Match("|<c=")==0){
- Line(1,NOERR)
- }
- Set_Marker(8,Cur_Pos)
- return
-
- } // end else running as submacro to EBCDIC-x.VDM
-
- // [55] main routine ends
-
- //
- // RECLEN - Create "l=reclen" lines for preceding record, if any.
- // Enter: #26 = length of preceding record less 'm' digits.
- // #36 = # 'm' digits and signs in record when NIBBLES.
- // Retrn: #26 = #36 = 0.
- //
- :RECLEN:
- Save_Pos()
- if (#26>0) {
- BOL()
- if ( Search("|<t ",REVERSE+NOERR)) {
- Line()
- Ins_Text("l=")
- Num_Ins(#26+#36/2+remainder,LEFT)
- }
- }
- #26 = #36 = 0
- Restore_Pos()
- return
-
- // RECLEN ends
-
- //
- // RECORD - Generate record extraction name and proto definition if at c=0,R:
- // 'tx "file_only.ASC"' normally or "R.DBF",R for DBASE and
- // "t 1,0xFF,0xF1 // Proto Record Type - EBCDIC 1 in column 1"
- // Append newline char(s) to any .nam file.
- // Enter: #23 = field counter.
- // #24 = record counter, from 0.
- // #27 = detail record counter.
- // #29 = Starting column for comments.
- // Marker[7]-> column index (from 0)
- // Retrn: #23 = 0.
- // #24 = (#23>0) ? #24++ : #24.
- // #25 = record name = 'A' + #24.
- // #27 = 0.
- //{
- :RECORD:
- #27 = 0
- if (#23!=0){ // Increment record counter
- #24++
- }
- #25 = #24 + 'A' // Record Name
- #23=0 // Field counter
- GM(7)
- Num_Eval(ADVANCE)
- Match("|W",ADVANCE)
- //
- // Generate 'tx "file_only.asc"', perhaps.
- //
- if (cc==','){
- c
- Match("|W",ADVANCE)
- if (Match("|A")==0){
- #25 = Cur_Char
- BOL()
- Ins_Text('tx "')
- if ( #21 ) {
- Ins_Char(#25)
- Ins_Text(".dbf")
- } else {
- rs(0,File_Only)
- Reg_Ins(0)
- Ins_Text(".asc")
- }
- Ins_Char('"')
- if ( #21 ) {
- Ins_Char(',')
- Ins_Char(#25)
- }
- Ins_Newline()
- }
- } else {
- BOL()
- }
- //
- // Generate prototypical record identifier:
- // "t 1,0xFF,0xF1 // comment"
- //
- Ins_Text("t 1,0xFF,0xF1")
- Ins_Indent(#29)
- Ins_Text("// Proto Record Type - EBCDIC 1 in column 1")
- Ins_Newline()
- Del_Line()
- //
- // Finish .nam line
- //
- Call(#90,"ENDNAME")
- return
-
- // RECORD ends}
-
- //
- // COBBEG - Return Marker(8) = CurPos at start of next COBOL block.
- // if "c=0[,R]", generate:
- // l=reclen // for previous record
- // t 1,0xff,0xf1 // for current record; preceded by
- // tx "R.ext"[,R] // if ",R" option; "ext" = {ASC,DBF}
- // Delete any bounding "p=" and "c=0" records.
- //{
- :COBBEG:
- //
- // Just return Marker(8) = CurPos when no blocking info.
- //
- Set_Marker(8,Cur_Pos)
- if (!Search("|<|{p,q,c}=",NOERR)){
- GM(8) // No, ensure CurPos unchanged
- return // Just return Marker(8) = CurPos
- }
-
- //
- // q=
- //
- if (mi==2){ // Can there be a valid "q=" at this point?
- GM(8)
- return
- }
-
- //
- //
- //
- while (Match("|<|{p=,c=}",ADVANCE)==0){
- //
- // p=.
- //
- if (Match_Item==1){
- BOL()
- Del_Line(1) // Delete the "p=[.]" line
- //
- // c=0[,R]
- //
- } else {
- Set_Marker(7,Cur_Pos) // Set marker(7) for RECORD()
- call("RECLEN") // Set "l=reclen" for previous record
- call("RECORD") // Generate "tx R.ext"[,R] and "t ..."
- }
- Set_Marker(8,Cur_Pos)
- }
- return
-
- // COBBEG ends}
-
- //
- // COBEND - Set Marker(9) to end of current COBOL block.
- //{
- :COBEND:
- GM(8)
- Set_Marker(9,CurPos)
- Search("|<|{p,q,c}=",NOERR) // p= or c=0 or q= ?
- //
- // If no block marking info, just return Marker(9) = File_Size.
- //
- if (Error_Match){
- GM(8)
- Set_Marker(9,File_Size)
- return
- }
- //
- // Otherwise, return Marker(9) at the next blocking indicator.
- // Also, delete any "q=" line.
- //
- Set_Marker(9,Cur_Pos)
- if (mi==2){
- Del_Line()
- }
- return
-
- // COBEND ends}
-
- `) // T-Reg[55] - Block Marking Submacro with Marker(8) & Marker(9)
-
- //////////////////////////////////////////////////////////////////////////////
- //
- // T-Reg[56] - Encoder - generate "code +size[,=len;] [u] [{v,.}n]".
- // Call XREF to perhaps generate an entry in .xrf file.
- // Call DOSQL to perhaps add name to _SQL_CRE.IMP file.
- // Call REDOSQL to perhaps add type info to an entry in _SQL_CRE.IMP file.
- // Enter short field name into comment section if -u ISHORT.
- // Copy quoted-and-comma-delimited COBOL field name to .nam if -u NAMES.
- // Enter: #1 = Maximum usable data column.
- // #26 = record length, less any 'm' digits and signs.
- // #28 = Output record type {0,1,2,3} for {DOS,UNIX,MAC,DBASE}
- // #32 = ISHORT flag.
- // #35 = NIBBLES flag.
- // #36 = # 'm' digits and signs when NIBBLES.
- // #37 = default "COMP" level.
- // #38 = SQL output buffer id/flag
- //
- // Marker(8)-> start of COBOL statements.
- // Marker(9)-> past end.
- // Retrn: #26 and #36 updated.
- // #81 = # digits before decimal point.
- // Marker[5] -> start of statement.
- // Marker[6] -> EOS past '.'
- //
- // Note: uses #2 - #9 internally; pushes and pops them.
- // #2 = current COMP level (0=none,1-6,0xFF=default)
- // #3 = # digits past decimal point
- // #4 = signed # flag
- // #5 = temporary
- // #6 = # bytes in data field
- // #7 = Adjusted COMP level (0,1-6,7) where '7' implies streaming nibbles
- // #8 = # digits = #81 + #3.
- // #9 = flag that '{v,.}[n]' encountered.
- //
- //////////////////////////////////////////////////////////////////////////////
-
- Reg_Set(56,`
- Num_Push(2,9) // Be safe
- //
- // Convert PACKED-DECIMAL's to COMP-3's.
- //
- Save_Pos()
- while(replace(" PACKED-DECIMAL|[|w]."," COMP-3.",NOERR)){
- Ins_Char(' ',count,chars_matched-8)
- }
- Restore_Pos()
- //
- // Convert BINARY's to COMP's.
- //
- Save_Pos()
- BoF()
- while(replace(" BINARY|[|w]."," COMP.",NOERR)){
- Ins_Char(' ',count,chars_matched-6)
- }
- Restore_Pos()
- //
- // Convert PIC A's to PIC X's.
- //
- Save_Pos()
- BoF()
- while(replace(" PIC|[ture]|wA"," PIC X",NOERR)){
- #2 = Chars_Matched
- if (Match("A",ALL|ADVANCE)==0){
- Del_Char(-Chars_Matched)
- Ins_Char('X',COUNT,Chars_Matched)
- }
- search(".",ADVANCE)
- Ins_Char(' ',count,#2-6)
- }
- Restore_Pos()
- //
- #15 = ((#64 & 2)==2) // Preprocessing-only flag
- repeat( all ) {
- #2 = 0 // No COMP encountered yet
- //
- // Search current block for next " PIC x", where x = {C,B,D,F,H,Y,S,V,X,9,-,+,.}.
- // Set Marker(6) -> EOS (past '.').
- //
- sb("^...... .*[\s\t](picture|pic)[\s\t]+[cbdfhysvxCBDFHYSVX9-+.]",Marker(8),Marker(9),REGEXP+MAX+ADVANCE+ERRBREAK)
- Char(-1)
- //
- // Find terminating period.
- // While allowing PIC 9.9. !!!
- //
- Save_Pos()
- if (sb(".|{|>,|!9}",cp,eolpos,COLSET+NOERR,8,#1)==0) { // Kludge on kludge
- sb("^...... .*\.",eolpos,Marker(9),COLSET+REGEXP+MAX,1,#1)
- }
- Set_Marker(6,Cur_Pos)
- //
- // Set Marker(5) to BOS
- //
- #0 = REGEXP+MAX+ADVANCE+REVERSE
- sb("^...... [\s\t]*[0-9]",Marker(8),Cur_Pos,#0)
- BOL()
- Set_Marker(5,Cur_Pos)
- //
- // Create cross reference entry in .xrf, if specified.
- //
- call("XREF")
- //
- // Create entry in _SQL_CRE.imp, if specified.
- //
- call("DoSQL")
- //
- // Append quoted-and-comma-delimited COBOL fieldname to .nam, maybe
- //
- call("NameIt")
- //
- //
- // Check for SIGN LEADING/TRAILING SEPARATE.
- //
- GM(5)
- #0 = COLSET+REGEXP+MAX+ADVANCE+NOERR
- #4 = 0 // Reset signed number flag
- if (sb("^...... .* SIGN ",cp,Marker(6),#0,1,#1)) {
- BoL
- sb("^...... .* {LEADING|TRAILING} ",cp,Marker(6),#0,1,#1)
- c(-9)
- match("|{ L,T}")
- if (mi==1) {
- #3 = 'l'
- } else {
- #3 = 't'
- }
- #4++ // Flag that LEADING/TRAILING found
- }
- //
- // Process any "COMP[-level]."
- // Normally the default (specified by #37) is "4" = Big Endian Binary
- //
- GM(5)
- #0 = COLSET+REGEXP+MAX+ADVANCE+NOERR
- if (sb("^...... .* (COMPUTATIONAL|COMP)[\s\.-]",cp,Marker(6),#0,1,#1)) {
- if (cc(-1)=='-') { // #2 = {1,2,3,4,[5],6}
- #2 = NumEval(SUPPRESS)
- } else {
- #2 = 0xFF // Default value; use #37
- }
- }
- //
- // Comment-out upto the "PIC" line or delete upto the "PIC" data.
- //
- Restore_Pos() // Just at start of PIC's data
- if ( #15 ) { // if just preprocessing...
- Set_Marker(7,Cur_Pos) // Save pos @ {s or x or v or 9 or - or + or .}, x={B,C,D,F,H,Y,X}
- GM(8)
- while ( Cur_Pos < Marker(7) ) {
- Ins_Indent(#29)
- InsText("// ")
- //
- // Output 11 blanks for short-name alignment if ISHORT.
- //
- if (#32){
- Ins_Char(' ',COUNT+ADVANCE,11)
- }
- line(1)
- }
- GM(7) // Restore pos @ {s or x or v or 9 or - or + or .}
- Set_Marker(7,BOL_Pos) // Marker(7)-> BOL
- } else { // when fully processing...
- Del_Block(Marker(8),Cur_Pos) // Delete back to Marker(8)
- Set_Marker(7,Cur_Pos)
- }
-
- ///////////////////////////////////////////////////////////////////////
- // //
- // Set #0 = LowerCased(CurChar) = one of {s,x,v,9,-,+,.,b,c,d,f,h,y} //
- // #2 > 0 ==> packing of some sort... //
- // #2 = 1 to 6 for COMP-1,...,COMP-6 or 0xFF for default (use #37). //
- // #37 set for UniSys' streaming nibbles. //
- // //
- ///////////////////////////////////////////////////////////////////////
-
- #0 = Cur_Char | 0x20 // #0 = 'x' | 'v' | 's' | '9' | '-' | '+' | '.' |
- // 'b' | 'c' | 'd' | 'f' | 'h' | 'y'
- if (#0=='d'){ #0 = '@' } // Break conflict between "Delete" and BCD
- if (#0=='y'){ #0 = '#' } // Break conflict between "Date" and SIGN SEPARATE
-
- //////////////////////////////////////////////////////////
- // //
- // Most numerics, including GreenView codes. //
- // //
- //////////////////////////////////////////////////////////
-
- if ( #0=='s' || #0=='+' || #0=='-' || #0=='b' || #0=='c' || #0=='h' || #2>0 ) {
- // signed or binary or custom or hex or COMP-n?
- if (#0=='s' || #0=='+' || #0=='-'){ // signed number
- #4++ // Set flag
- if (#15) { // if just preprocessing...
- Char(1)
- } else {
- Del_Char(1)
- }
- }
- //
- // Set #0 to proper Greenview code.
- // I.e., #0 = a,b,c,d,e,f,h,l,m,u,x,y,z.
- // Needed temporarily for generating proper gvc in column 1.
- // Needed later for handling numeric options.
- //
- Save_Pos()
- //
- // COMP's and SIGN LEADING/TRAILING SEPARATE.
- //
- if ( #0 != 'b' && #0 != 'h' && #0 != 'c' && #0 != '#' ) {
- #7 = #2
- if (#7==0xFF){
- if (#35) { // Streaming nibbles
- #7 = 7
- } else {
- #7 = #37 // Default packing
- }
- }
- if (#7==1||#7==2){
- #0 = 'l'
- } else { if (#7==3) {
- #0 = 'd'
- } else { if (#7==4) {
- #0 = 'b'
- } else { if (#7==6) {
- #0 = 'n'
- } else { if (#7==7) {
- #0 = 'm'
- } else { if (#0=='+'||#0=='-') { // Sign leading separate
- #0 = 'y'
- #3 = 'l'
- } else {
- if (#4==2){ // SIGN SEPARATE
- #0 = 'y'
- } else {
- #0 = 'z'
- }
- }}}}}}
- }
- GM(7)
- Ins_Char(#0)
- if (#0=='y'){ // yol or yot
- Ins_Char('o')
- Ins_Char(#3)
- Del_Char(2*#15) // Delete spaces, perhaps
- }
- Ins_Char(' ')
- Del_Char(2*#15) // Delete spaces, perhaps
- Restore_Pos()
-
- //////////////////////////////////////////////////
- // //
- // Unsigned number ([v,.]9), perhaps. //
- // //
- //////////////////////////////////////////////////
-
- } else { if ( #0=='v' || #0=='.' || #0=='9' ) {
- Save_Pos()
- GM(7)
- Ins_Text("u ")
- Del_Char(2*#15) // Delete spaces, perhaps
- Restore_Pos()
- if (#0=='.'){
- Ebc_Settings(InPoint,1) // Explicit decimal point
- }
- #0 = 'u' // Unsigned number
-
- //////////////////////////////////////////////////////////
- // //
- // Else simple nonnumeric (X), X={@,#,F,X}. //
- // //
- //////////////////////////////////////////////////////////
-
- } else {
- Save_Pos()
- GM(7)
- if (#0=='@'){
- #0='x' // Delete (eXcise)
- //
- // Remove any COBOL field name from .nam file.
- //
- if (#34){
- File_Open("|(FILE_ONLY).nam",OK+NOMSG)
- Search('|{|<",|,"}',REVERSE)
- Del_Block(Cur_Pos,File_Size)
- Buf_Switch(#92)
- }
- //
- // Remove any COBOL field name from _SQL_CRE.imp file.
- //
- if (#38){
- Buf_Switch(#38)
- Del_Line(-1)
- Buf_Switch(#92)
- }
- } else { if ( #0 != 'f' && #0 != '#' ){
- #0='e'
- }}
- if (#0=='#'){ // Date?
- Ins_Char('e')
- } else {
- Ins_Char(#0) // {e,f,x}
- }
- Ins_Char(' ')
- Del_Char(2*#15) // Delete spaces, perhaps
- Restore_Pos()
- }}
-
- //
- // Set #81 = # digits/bytes before any decimal point.
- //
- if (Cur_Char(1)==0x28){ // CurChar + 1 == LParen?
- if (#15) { // if just preprocessing...
- Char(2)
- #81 = NumEval(SUPPRESS+ADVANCE) // #81 = 'n'
- Char(1) // Advance past RParen
- } else {
- Del_Char(2) // Delete "x(" or "9("
- #81 = NumEval(SUPPRESS) // #81 = 'n'
- Del_Char(Chars_Matched+1) // Delete "n)" ) for balance
- }
- } else {
- Match("[bcdfhxBCDFHX9]*",REGEXP+MAX+ADVANCE)
- #81 = Chars_Matched // #81 = 'n'
- if (!#15) { // if not just preprocessing
- Del_Char(-Chars_Matched) // Delete all "X..." or "9..."
- }
- }
- //
- // Finish converting to our "code +size [{v,.}n]" format.
- // Compute #3 = # digits past decimal point.
- // #8 = # digits, including before & after decimal point.
- // #9 = {'v' | '.'} ? 1 : 0.
- // EbcSettings(Inpoint) = '.' ? 1 : itself.
- //
- Save_Pos()
- GM(7)
- Ins_Char('+')
- Del_Char(1*#15) // Delete spaces, perhaps
- Restore_Pos()
- #3 = #8 = #9 = 0 // No digits past decimal point, yet
- Ebc_Settings(In_Point,0) // No explicit source decimal point, so far
- if (Match('|{v,.9}')==0) { // Process '{v,.}9...' portion
- #9 = 1 // Flag that 'v' or '.' encountered
- if (CurChar=='.'){
- Ebc_Settings(InPoint,1) // Flag that '.' encountered
- }
- if (#15) { // if just preprocessing...
- Char(1)
- } else {
- Del_Char(1)
- }
- if (Cur_Char(1)==0x28) { // CurChar + 1 == LParen?
- if (#15) { // if just preprocessing...
- Char(2)
- #3 = NumEval(SUPPRESS+ADVANCE) // #3 = 'n'
- Char(1) // Advance past RParen
- } else {
- Del_Char(2) // Delete "9("
- #3 = NumEval(SUPPRESS) // #3 = 'n'
- Del_Char(Chars_Matched+1) // Delete "n)"
- }
- } else {
- Match("9*",regexp+max)
- #3 = Chars_Matched // #3 = # digits past "."
- }
- }
- #8 = #81 + #3 // #8 = # digits
- //
- // Compute #6 = # bytes in data field or compute #36 = # digits and signs for NIBBLES.
- //
- GM(7)
- if ( #0=='b' || #0=='d' || #0=='l' || #0=='m' || #0=='n' ) {
- if (#0=='b') {
- if (#8==1) {
- #6 = 1
- } else {
- if (#8<5) {
- #6 = 2
- } else { if (#8<10) {
- #6 = 4
- } else {
- #6 = 8
- }}}
- } else { if (#0=='d') {
- #6 = ( #8 / 2 ) + 1
- } else { if (#0=='n') {
- #6 = ( #8 / 2 ) + remainder
- } else { if (#0=='l') {
- if (#2==1) {
- #6 = 4 // short Float
- } else {
- #6 = 8 // long Float (double precision)
- }
- } else { // 'm'
- #6 = 0
- }}}}
- } else { if ( #0 == 'y' ) {
- #6 = #8 + 1 // Add sign back in for "+9" and "-9"
- } else {
- #6 = #8 // One-to-one for 'c', 'e', 'f', & 'u'
- }}
- //
- // Adjust for explicit decimal point in PIC clause.
- //
- #6 += EbcSettings(InPoint)
- //
- // Update record length.
- //
- if (#0=='m'){
- #6 = #8+#4 // #6 = # 'm' digits plus any sign
- #36 += #6
- } else {
- #26 += #6 // Update record length
- }
- //
- // Insert field size.
- //
- #5 = Cur_Pos
- Num_Ins(#6,LEFT+NOCR)
- Del_Char((Cur_Pos-#5)*#15) // Delete spaces, perhaps
- //
- // For binaries, include ",=ndigits;", perhaps.
- // Enter: #3 = # digits past decimal point.
- // #8 = total # digits.
- // #4 = signed-number flag.
- // #9 = 'v' encountered flag.
- //
- if (#0=='b'){
- #5 = Cur_Pos
- if ( #8 != 2 && #8 != 4 && #8 != 8 && #8 != 18 ){
- Ins_Text(",=")
- Num_Ins(#8,LEFT+NOCR)
- Ins_Text(";")
- }
- Del_Char((Cur_Pos-#5)*#15) // Delete spaces, perhaps
- }
- //
- // For Floats, Doubles and packed decimals with even # digits, include ",=n;"
- //
- if (#0=='l'||(#0=='d'&&!(#8&1))){
- #5 = Cur_Pos
- Ins_Text(",=")
- Num_Ins(#8,LEFT+NOCR)
- Ins_Text(";")
- Del_Char((Cur_Pos-#5)*#15) // Delete spaces, perhaps
- }
- //
- // For PNZ's with odd # digits, include ",=n;"
- //
- if (#0=='n' && (#8&1)){
- #5 = Cur_Pos
- Ins_Text(",=")
- Num_Ins(#8,LEFT+NOCR)
- Ins_Text(";")
- Del_Char((Cur_Pos-#5)*#15) // Delete spaces, perhaps
- }
- //
- // Include any "unsigned" option.
- //
- if ((#4==0)&&(#0=='b'||#0=='d'||#0=='l'||#0=='m')){
- #5 = Cur_Pos
- Ins_Text(" u")
- Del_Char((Cur_Pos-#5)*#15) // Delete spaces, perhaps
- }
- //
- // Explicit decimal point, perhaps.
- //
- if (#9>0 && (#64&4)) { // Explicit decimal point
- #5=Cur_Pos
- if (EbcSettings(InPoint)){
- Ins_Text(" .")
- } else {
- Ins_Text(" v")
- }
- Num_Ins(#3,LEFT+NOCR)
- Del_Char((Cur_Pos-#5)*#15) // Delete spaces, perhaps
- }
- if (!(#15)) { // If fully processing...
- Del_Block(Cur_Pos,EOL_Pos) // Delete remainder of the line
- }
- Line(1)
- Set_Marker(8,Cur_Pos)
- //
- // Ensure code is generated at the statement beginning when commenting out.
- //
- Num_Push(0,0)
- if (#15) {
- Line(-1)
- Search("//")
- #0 = Cur_Col
- rcb(0,BOL_Pos,Cur_Pos,DELETE)
- Ins_Char(' ',COUNT,#0-1)
- EOL()
- Search("//[\s\t]+[0-9]+[\s\t]+[A-Z0-9']",REVERSE+REGEXP)
- Del_Block(BOL_Pos,Cur_Pos)
- Reg_Ins(0)
- if (#32){
- match("// ",ADVANCE)
- match("|B",count+advance,6)
- if (EOLPos-CurPos>RSIZE(1)){
- Reg_Ins(1,OVERWRITE)
- } else {
- Reg_Ins(1)
- }
- if (Match("|b")!=0){
- InsChar(' ')
- }
- }
- }
- //
- // Append data type, length to _SQL_CRE.IMP, perhaps.
- //
- Num_Pop(0,0)
- if (#0!='x'){
- call("RedoSQL")
- }
- GM(8)
- }
- Num_Pop(2,9)
- //
- // Comment out or delete anything upto Marker(9).
- //
- if (#15) {
- while ( Cur_Pos < Marker(9) ) {
- Ins_Indent(#29)
- InsText("// ")
- line(1)
- }
- } else {
- Del_Block(Marker(8),Marker(9))
- }
- return
- //
- // XREF - Create entry in .xrf file if specified.
- // Enter: Marker(5)-> BOS
- // Marker(6)-> past "." at EOS
- // #21 > 0 ? create entry in Buf_Num(#21).
- // #27 = detail record type counter.
- //
- // Each entry in the file consists of 12 blank spaces, a generated
- // short name, blank spaces upto column 30 and the COBOL copybook
- // name for the current field. If the current record is a detail
- // record, "Zn" is prepended to the record name, where 'n' is {1,2,...}.
- // (There may be upto 40 detail record types per main record type).
- //
- // The short name is of the form rn where 'r'= {A,B,...} is the
- // record name and 'n' = {1,2,...} is the field number.
- //
- // The initial 12 spaces can be used later to create a nickname.
- // Column 29 could be used to indicate that the field is being
- // deleted from the translated data.
- //
- :XREF:
- if (!#21){return}
- call("COBNAM") // Copy COBOL field name into T-Reg[0]
- Buf_Switch(#21)
- Ins_Char(' ',COUNT,12)
- #23++
- #4 = Cur_Pos
- Ins_Char(#25)
- Num_Ins(#23,LEFT+NOCR)
- #5 = Cur_Pos
- ii(30)
- Reg_Ins(0)
- rcb(1,#4,#5)
- Ins_Newline()
- Buf_Switch(#92)
- return
- // XREF ends
-
- //
- // NameIt - Append quoted-and-comma-delimited COBOL field name to .nam, if specified.
- // Enter: #34 ? doit : return
- // Marker(5) at BOS
- // Marker(6) at EOS
- //
- :NameIt:
- if (#34){
- call("COBNAM") // T-Reg[0] = COBOL field name
- File_Open("|(FILE_ONLY).nam",OK+NOMSG)
- If (!At_BOL){
- Ins_Char(',')
- }
- Ins_Char('"')
- Reg_Ins(0)
- Ins_Char('"')
- Buf_Switch(#92)
- }
- return
- // NameIt ends
-
- //
- // DoSQL - Append COBOL field name to _SQL_CRE.imp, if specified.
- // Replace all '-' with '_'.
- // Enter: #38 ? doit : return
- // Marker(5) at BOS.
- // Marker(6) at EOS.
- //
- :DoSQL:
- if (#38){
- call("COBNAM") // T-Reg[0] = COBOL field name
- Buf_Switch(#38)
- Reg_Ins(0)
- Ins_Newline(1)
- L(-1)
- Replace("-","_",ALL|NOERR)
- L(1,NOERR)
- Buf_Switch(#92)
- }
- return
- // DoSQL ends
-
- //
- // RedoSQL - Append data type, length to _SQL_CRE.imp, if specified.
- // Enter: #38 ? doit : return.
- // #38 = Buffer_ID for ..._SQL_CRE.IMP.
- //
- // #0 = Greenview field code or '#'.
- // #0 == '#' ? SQL type -> DATETIME (MS SQL).
- //
- // #2 = current COMP level (0=none,1-6,0xFF=default)
- // #3 = # digits past decimal point
- // #4 = signed # flag
- // #5 = temporary
- // #6 = # bytes in data field
- // #7 = Adjusted COMP level (0,1-6,7) where '7' implies streaming nibbles
- // #8 = # digits = #81 + #3.
- // #9 = flag that '{v,.}[n]' encountered.
- //
- // Marker(5) at BOS.
- // Marker(6) at EOS.
- //
- // Note: Originally programmed for MySQL (AB); changed to work with
- // MS DTS SQL Server. (I know nothing! SGT Shultz).
- //
- :RedoSQL:
- if (#38){
- Buf_Switch(#38)
- Char(-Newline_Chars)
- Ins_Indent(15)
- if (cc(-1)!=' '){
- Ins_Char(' ')
- }
- //
- // Text
- //
- if (#0=='e'||#0=='f'){
- Ins_Text("CHAR")
- Ins_Char(0x28) // Left Paren
- Num_Ins(#8,LEFT|NOCR)
- Ins_Char(0x29) // Right Paren
-
- //
- // Date
- //
- } else { if (#0=='#'){
- // Ins_Text("DATE")
- Ins_Text("DATETIME")
-
- //
- // Custom Date
- //
- } else { if (#0=='c'){
- // Ins_Text("DATE")
- Ins_Text("DATETIME")
-
-
- //
- // Numeric.
- //
- } else {
- //
- // Fixed Decimal Point (text).
- //
- if (#9) {
- Ins_Text("DECIMAL")
- Ins_Char(0x28) // Left Paren
- Num_Ins(#8,LEFT|NOCR)
- Ins_Char(',')
- Num_Ins(#3,LEFT|NOCR)
- Ins_Char(0x29) // Right Paren
- //
- // TINYINT (8 bits).
- //
- } else { if (#8<3) {
- Ins_Text("TINYINT")
- //
- // SMALLINT (16 bits).
- //
- } else { if (#8<5) {
- Ins_Text("SMALLINT")
- //
- // MEDIUMINT (24 bits).
- // Now, same as INT.
- //
- }…
Large files files are truncated, but you can click here to view the full file