'Teapro program rpgtoc.tea to translate RPG to C
'rpgtoc.tea begun on 17-MAR-2003.
'This program is written in the programming language Teapro
'which utilizes the OpenTea technology and which
'runs on the Teapro interpreter teapro.exe for
'Windows 95 and later.
'There is no warranty of any kind on this program.
'This program is only intended to work with a very small subset
'of what is commonly known as RPG II.
'In today's world, we need computer software that actually works.
vari dg_pass1, dg_pass2, dg_pass3, dg_pass4, dg_pass5
vari dg_pass6, dg_pass7
vari sg_pass1, sg_pass2, sg_pass3, sg_pass4, sg_pass5
vari sg_pass6, sg_pass7
vari sg_inpfile, sg_outfile, dg_process, dg_indent
vari sg_nothing, sg_20blanks, sg_20zeros, sg_queue
vari dg_record, sg_record, dg_rpglinenumber
vari dg_filebyte, sg_subroutine, sg_build
vari dg_progkind, sg_progkind
vari dg_error, dg_errnumber, dg_showerror
vari dg_tdebug, dg_operatingsystem
vari dg_fullcdebug1, dg_fullcdebug2
vari sg_badcommands, sg_goodcommands
vari sg_filenames, sg_filedevs, sg_fileinfos, sg_filekeys
vari sg_rpgvarnames, sg_rpgvarsizes
vari sg_bottomarray1, sg_bottomarray2
vari sg_rpgtabnames1, sg_rpgtabnames2
vari sg_indicatset, sg_indicatuse
vari sg_readfile, sg_readpfile, sg_chainfile
vari sg_slashaster, sg_asterslash, sg_csubrname
vari dg_clinecount, dg_ccommentcount
vari sg_prevdividefactor1, sg_prevdividefactor2
vari sg_ifindicators, dg_yesifindicators
vari dg_yeslinedone
sub_main
endp
subr sub_main
'updated 2008/02/25, 2007/11/12
'2007/07/17, 2006/09/25, 2006/09/15, 2006/04/25
'2005/10/07, 2005/04/03, 2005/02/26, 2005/02/24, 2004/11/06
vari d_any, s_any, d_dot, s_dot, s_out
vari d_loop, d_good, d_number, s_aster
vari d_seconds1, d_seconds2
$sys sg_subroutine, 2
dift dg_tdebug = 1
sg_pass1 = sg_subroutine
sub_return
endi
$ch$ s_aster, "*", 70
d_loop = 1
dwhi d_loop = 1
d_good = 1
$out s_aster
sg_build = "Program: rpgtoc.tea, build=516, 2008/02/25"
$out sg_build
$out "Written in Teapro utilizing the OpenTea technology"
$out "Written to be run on teapro.exe"
$out "This program was begun on 2003/03/17"
$out "This program, rpgtoc.tea, in in the public domain."
$out "This program is without warranty of any kind."
dsec d_any
ded$ s_out, d_any, 0, 0
$out "seconds=" + s_out
$out s_out
$dat s_out
$out s_out
$sys s_out, 1
$out s_out
$out s_aster
sub_path_memory_lines
sub_initialize
'dg_operatingsystem:1=MPE,2=Unix,3=C90
$out s_aster
dg_operatingsystem = 0
sub_speedquick
$out "1=MPE operating system"
$out "2=Unix/Linux operating system"
$out "3=C90 only"
$out "99=sub_speed_test " + dg_pass1
$inp s_any, "choose, * to end"
$ift s_any = "99": sub_speed_test
$isd d_any, s_any
dift d_any = 1: $tod dg_operatingsystem, s_any
dift d_any <> 1: dinc d_good
$ift s_any = "*": dinc d_good
dift d_good = 1
$out s_aster
dg_tdebug = 2
$inp s_any, "1=Teapro debug mode = tdebug mode"
$ift s_any = "1": dg_tdebug = 1
$ift s_any = "*": dinc d_good
endi
dift d_good = 1
$out s_aster
'fullcdebug is activated by C* CDEBUG ON
'and turned off by C* CDEBUG OFF if
'dg_fullcdebug1=1
dg_fullcdebug1 = 2
dg_fullcdebug2 = 2
$inp s_any, "1=Add fullcdebug1 lines to program"
$ift s_any = "1": dg_fullcdebug1 = 1
$ift s_any = "*": dinc d_good
'dg_fullcdebug1=1 also sets tig_cdebug=1 at begin
endi
dift d_good = 1
$inp s_dot, "enter filename of program to translate"
$ift s_dot = "*": dinc d_good
endi
dift d_good = 1
$tup sg_inpfile, s_dot
$lok d_dot, sg_inpfile, 1, "."
dift d_dot > 2
ddec d_dot
$cut s_any, sg_inpfile, 1, d_dot
sg_outfile = s_any + ".CPP"
else
sg_outfile = sg_inpfile + ".CPP"
endi
endi
dift d_good = 1
flen d_any, sg_outfile
dift d_any >= 0
$inp s_any, "1=purge old file=" + sg_outfile
$ift s_any = "1"
fdel d_any, sg_outfile
else
dinc d_good
endi
endi
endi
dift d_good = 1
$out s_aster
dg_process = 1
dsec d_seconds1
'validate the rpg program
dift dg_process = 1: sub_rpg_validate
'create program in C
dift dg_process = 1: sub_c_create
dsec d_seconds2
dift dg_process <> 1
$inp s_any, "a serious error occurred"
endi
dsys d_any, 2
ded$ s_any, d_any, 0, 0
$out "lines of Teapro done=" + s_any
'output file information
finp s_any, sg_outfile
$len d_any, s_any
$hsh d_dot, s_any
s_any = "file=" + sg_outfile + " length=" + d_any
$app s_any, " hash=" + d_dot
$out s_any
d_any = d_seconds2 - d_seconds1
$out "seconds=" + d_any + ", progkind=" + sg_progkind
sub_path_memory_lines
$out "use CCPK to compile this"
$inp s_any, "return, * to end"
$ift s_any = "*": dinc d_good
endi
dift d_good <> 1: dinc d_loop
endw
ends sub_main
subr sub_initialize
'updated 2004/10/07
$trb sg_nothing, " "
$ch$ sg_20blanks, " ", 20
$ch$ sg_20zeros, "0", 20
dg_progkind = 0
sg_progkind = sg_nothing
dg_indent = 0
sg_slashaster = "/* "
sg_asterslash = " */"
sg_queue = sg_nothing
arrb
arrz
ends sub_initialize
subr sub_rpg_validate
'updated 2006/11/01, 2006/04/25, 2005/04/03, 2004/12/23
vari s_any, d_any, s_dot, d_dot, s_tap
'fline 1 eline 2 iline 3 cline 4 oline 5 6
'123456789012345678901234567890123456789012345678901234567890
' .FTERMIN ID F 80 $STDIN
' .FTERMOUT O F 80 $STDLST
' .E ZZ 1 80 1 2
' .IFILEINP AA
' .I 10 20 VARIAB
' .CSR 01 02 03FACTOR1 COMMDFACTOR2 RESULT 92H919293
' .OFILENAMEE 12 01 02 03OLINE
' .O E 01 02 03VARIABJB 132 "HEADING LINE "
$sys sg_subroutine, 2
dift dg_tdebug = 1
sg_pass1 = sg_subroutine
sub_return
endi
'begin rpgtoc.log file
fdel d_any, "rpgtoc.log"
s_dot = "input file=" + sg_inpfile
$dat s_any
$app s_dot, " " + s_any
s_tap = "rpgtoc.log"
fapp d_any, s_tap, s_dot
dg_errnumber = 0
dg_error = 2
dg_showerror = 1
'dg_process was set to 1 before this subr was called
'rpg valid initialize
dift dg_process = 1: sub_rpg_valid_initialize
'rpg valid byte 6 continuity
dift dg_process = 1: sub_rpg_valid_continuity
'rpg filenames and filesizes
dift dg_process = 1: sub_rpg_valid_files
'rpg gotos, tags, exsrs, begsr, endsr, excpts
dift dg_process = 1: sub_rpg_valid_tags
'rpg valid variables get size from lines
dift dg_process = 1: sub_rpg_valid_varsize_lines
'rpg valid variables sizes stored in
'sg_rpgvarnames, sg_rpgvarsizes
dift dg_process = 1: sub_rpg_valid_varsize_strings
'rpg valid variables in all lines
dift dg_process = 1: sub_rpg_valid_var_all
'rpg valid indicators
dift dg_process = 1: sub_rpg_valid_indicators
'rpg valid format
dift dg_process = 1: sub_rpg_valid_format
ends sub_rpg_validate
subr sub_rpg_valid_initialize
'updated 2005/01/01
'initialize for the rpg validation
$sys sg_subroutine, 2
dift dg_tdebug = 1
sg_pass1 = sg_subroutine
sub_return
endi
sg_filenames = sg_nothing
sg_filedevs = sg_nothing
sg_fileinfos = sg_nothing
sg_filekeys = sg_nothing
'strings of filenames with read,readp,chain
sg_readfile = sg_nothing
sg_readpfile = sg_nothing
sg_chainfile = sg_nothing
sg_rpgvarnames = "*BLANK ,*ZEROS ,"
sg_rpgvarsizes = "600009990,600009990,"
sg_bottomarray1 = sg_nothing
sg_bottomarray2 = sg_nothing
sg_rpgtabnames1 = sg_nothing
sg_rpgtabnames2 = sg_nothing
sg_indicatset = sg_nothing
sg_indicatuse = sg_nothing
sg_badcommands = sg_nothing
sg_goodcommands = sg_nothing
sg_prevdividefactor1 = sg_nothing
sg_prevdividefactor2 = sg_nothing
ends sub_rpg_valid_initialize
subr sub_rpg_valid_continuity
'updated 2006/08/14, 2003/11/18
'validate rpg program record types HFEICSO
vari s_any, d_any, s_dot, d_dot, s_out
vari d_loop, d_filebyte, s_newrecord, d_good, d_count
vari s_oldrecord, s_allcodes, s_oldcode, s_newcode
vari d_hcount, d_fcount, d_ecount, d_icount
vari d_ccount, d_scount, d_ocount
vari d_old, d_new, s_fromsubr, d_error
$sys sg_subroutine, 2
s_fromsubr = sg_subroutine
dift dg_tdebug = 1
sg_pass1 = sg_subroutine
sub_return
endi
s_allcodes = "HFEICSO"
s_oldrecord = "12345H"
d_error = 2
d_hcount = 0
d_fcount = 0
d_ecount = 0
d_icount = 0
d_ccount = 0
d_scount = 0
d_ocount = 0
dg_record = 0
d_loop = 1
dwhi d_loop = 1
d_good = 1
'read a record skipping comment records
sg_pass1 = s_fromsubr
sub_rpg_read_record
s_newrecord = sg_pass1
dift dg_record = 0
dinc d_good
dinc d_loop
endi
dift d_good = 1
'we have a non-comment record to examine in s_newrecord
'get previous 6code in s_oldcode,d_old
$cut s_oldcode, s_oldrecord, 6, 1
$ift s_oldcode = "C"
$cut s_any, s_oldrecord, 7, 1
$ift s_any = "S": s_oldcode = "S"
endi
$lok d_old, s_allcodes, 1, s_oldcode
dift d_old < 1: d_error = 1
'get new 6code in s_newcode,d_new
$cut s_newcode, s_newrecord, 6, 1
$ift s_newcode = "C"
$cut s_any, s_newrecord, 7, 1
$ift s_any = "S": s_newcode = "S"
endi
$lok d_new, s_allcodes, 1, s_newcode
dift d_new < 1: d_error = 1
dift d_old > d_new: d_error = 1
dift d_error = 1
sg_pass1 = "6code continuity error"
sub_error
dinc d_loop
endi
'HFEICSO
$ift s_newcode = "H": dinc d_hcount
$ift s_newcode = "F": dinc d_fcount
$ift s_newcode = "E": dinc d_ecount
$ift s_newcode = "I": dinc d_icount
$ift s_newcode = "C": dinc d_ccount
$ift s_newcode = "S": dinc d_scount
$ift s_newcode = "O": dinc d_ocount
s_oldrecord = s_newrecord
endi
endw
'HFEICSO
$out "H lines=" + d_hcount
$out "F lines=" + d_fcount
$out "E lines=" + d_ecount
$out "I lines=" + d_icount
$out "C lines=" + d_ccount
$out "S lines=" + d_scount
$out "O lines=" + d_ocount
d_any = d_hcount + d_fcount + d_ecount + d_icount
d_any = d_any + d_ccount + d_scount + d_ocount
$out "total =" + d_any
$sys sg_subroutine, 2
dift dg_tdebug = 1
sg_pass1 = sg_subroutine
sub_return
endi
ends sub_rpg_valid_continuity
subr sub_rpg_valid_files
'updated 2004/10/07
'get sg_filenames,sg_filedevs,sg_fileinfos,sg_filekeys
vari s_any, d_any, s_dot, d_dot, s_out
vari d_loop1, d_loop2, d_filebyte, s_record, d_good
vari s_6byte, d_filect, s_fromsubr
$sys sg_subroutine, 2
s_fromsubr = sg_subroutine
dift dg_tdebug = 1
sg_pass1 = sg_subroutine
sub_return
endi
'sg_filenames
'12345678
'aaaaaaaa=filename
'sg_filedevs
'aaaaaaaa=filedev
'sg_fileinfos
'12345678
'aabbbbcd
'aa=file type: ID,UD,IC,O
'bbbb=file record length
'c=file is F=fixed or V=variable
'd=file is F=flat or K=KSAM
'sg_filekeys
'12345678
'aaaabbbb
'aaaa=file key begin
'bbbb=file key length
d_filect = 0
dg_record = 0
d_loop1 = 1
dwhi d_loop1 = 1
d_good = 1
sg_pass1 = s_fromsubr
sub_rpg_read_record
s_record = sg_pass1
dift dg_record = 0
dinc d_good
dinc d_loop1
endi
dift d_good = 1
'get the code in byte 6
$cut s_6byte, s_record, 6, 1
$ift s_6byte = "F"
$cut s_any, s_record, 7, 1
$ift s_any <> " "
dinc d_filect
sg_pass1 = s_record
sub_rpg_valid_files_fline
endi
endi
$ift s_6byte = "I"
sg_pass1 = s_record
sub_rpg_valid_files_iline
endi
$ift s_6byte = "C"
sg_pass1 = s_record
sub_rpg_valid_files_cline
endi
$ift s_6byte = "O"
sg_pass1 = s_record
sub_rpg_valid_files_oline
endi
$cut s_any, s_record, 7, 1
$ift s_any = "*": dinc d_good
endi
endw
$out "file ct=" + d_filect
$sys sg_subroutine, 2
dift dg_tdebug = 1
sg_pass1 = sg_subroutine
sub_return
endi
ends sub_rpg_valid_files
subr sub_rpg_valid_files_fline
'updated 2005/04/03, 2004/10/07
'fline into sg_filenames,sg_filedevs,sg_fileinfos,sg_filekey
vari s_any, d_any, s_dot, d_dot, s_tap, s_out
vari s_record, s_filename, s_filetype, s_filedevice
vari s_reclong, s_keybeg, s_keylong, s_filefixed, s_fileksam
vari d_filereclong, d_filekeybeg, d_filekeylong
vari d_error, s_error
'sg_filenames
'12345678
'aaaaaaaa=filename
'sg_filedevs
'aaaaaaaa=filedev
'sg_fileinfos
'12345678
'aabbbbcd
'aa=file type: ID,UD,IC,O
'bbbb=file record length
'c=file is F=fixed or V=variable
'd=file is F=flat or K=KSAM
'sg_filekeys
'12345678
'aaaabbbb
'aaaa=file key begin
'bbbb=file key length
'fline 1 2 3 4 5 6
'123456789012345678901234567890123456789012345678901234567890
' FKRMASTR UD F 1024R09AI 5 DISC
' FZRMASTR IC F 1024R ID 5 DISC
' .FTERMIN ID F 80 $STDIN
' .FTERMOUT O F 80 $STDLST
'column 28 is R or L for KSAM and R for chain
'column 31 is A for KSAM and I for chain
'column 32 is I for KSAM amd D pr C for chain
s_record = sg_pass1
'beg dg_errnumber,d_error,1000
d_error = 0
s_error = sg_nothing
'get the file name
$cut s_filename, s_record, 7, 8
'get the file type
$cut s_filetype, s_record, 15, 2
'get the s_filefixed
$cut s_filefixed, s_record, 19, 1
'get the s_fileksam K or F for flat
$cut s_any, s_record, 31, 1
s_fileksam = "F"
$ift s_any = "A": s_fileksam = "K"
'get the device
$cut s_filedevice, s_record, 40, 8
'get the record length
$cut s_reclong, s_record, 24, 4
'get the keybeg
$cut s_keybeg, s_record, 35, 4
'get the keylong
$cut s_keylong, s_record, 29, 2
'dg_progkind values
'10=input demand
'20=input chain
'30=update demand
'40=input ksam
'50=update ksam
'60=screen
$ift s_filetype = "ID"
dift dg_progkind < 10
dg_progkind = 10
sg_progkind = "input demand"
endi
endi
$ift s_filetype = "IC"
dift dg_progkind < 20
dg_progkind = 20
sg_progkind = "input chain"
endi
endi
$ift s_filetype = "UD"
dift dg_progkind < 30
dg_progkind = 30
sg_progkind = "update demand"
endi
endi
$ift s_fileksam = "K"
$ift s_filetype = "ID"
dift dg_progkind < 40
dg_progkind = 40
sg_progkind = "ksam input demand"
endi
endi
$ift s_filetype = "UD"
dift dg_progkind < 50
dg_progkind = 50
sg_progkind = "ksam update demand"
endi
endi
endi
$ift s_filefixed = "V"
dift dg_progkind < 60
dg_progkind = 60
sg_progkind = "vplus"
endi
endi
'sg_filenames
'12345678
'aaaaaaaa=filename
'sg_filedevs
'aaaaaaaa=filedev
'sg_fileinfos
'12345678
'aabbbbcd
'aa=file type: ID,UD,IC,O
'bbbb=file record length
'c=file is F=fixed or V=variable
'd=file is F=flat or K=KSAM
'sg_filekeys
'12345678
'aaaabbbb
'aaaa=file key begin
'bbbb=file key length
'sg_filenames
'is name proper name
sg_pass1 = s_filename
sub_rpg_valid_identifier
$lok d_any, sg_filenames, 1, s_filename
dift d_any > 0
s_error = "dup filename=" + s_filename
d_error = 1001
endi
$app sg_filenames, s_filename + ","
'sg_filedevs
$app sg_filedevs, s_filedevice + ","
'sg_fileinfos
$cut s_filetype, s_filetype, 1, 2
s_tap = "ID,UD,IC,O ,"
$lok d_any, s_tap, 1, s_filetype
dift d_any = 0
s_error = "bad file type=" + s_record
d_error = 1002
endi
'make record length s_reclong 4 long
$trl s_reclong, s_reclong
s_reclong = sg_20zeros + s_reclong
$off s_reclong, s_reclong, 4
'is record length s_reclong numeric and > 1
$isd d_dot, s_reclong
dift d_dot = 1
$tod d_filereclong, s_reclong
dift d_filereclong < 1: dinc d_dot
endi
dift d_dot <> 1
s_error = "bad rec length=" + s_record
d_error = 1003
endi
'put fileinfos together
'X means not used here
$app sg_fileinfos, s_filetype + s_reclong
$app sg_fileinfos, s_filefixed + s_fileksam + ","
'key s_keybeg
$trl s_keybeg, s_keybeg
s_keybeg = sg_20zeros + s_keybeg
$off s_keybeg, s_keybeg, 4
$isd d_dot, s_keybeg
dift d_dot = 1
$tod d_filekeybeg, s_keybeg
dift d_filekeybeg < 0: dinc d_dot
endi
dift d_dot <> 1
s_error = "bad keybeg=" + s_record
d_error = 1004
endi
'key length s_keylong
$trl s_keylong, s_keylong
s_keylong = sg_20zeros + s_keylong
$off s_keylong, s_keylong, 4
$isd d_dot, s_keylong
dift d_dot = 1
$tod d_filekeylong, s_keylong
dift d_filekeylong < 0: dinc d_dot
endi
dift d_dot <> 1
s_error = "bad keybeg=" + s_record
d_error = 1005
endi
s_dot = s_keybeg + s_keylong
$isd d_any, s_dot
dift d_any <> 1
s_error = "bad key info=" + s_dot
d_error = 1006
endi
$app sg_filekeys, s_keybeg + s_keylong + ","
'validate d_filereclong, d_filekeybeg, d_filekeylong
d_any = d_filekeybeg + d_filekeylong - 1
dift d_any > d_filereclong
s_error = "bad key pos=" + s_record
d_error = 1007
endi
dift dg_tdebug = 1
s_any = "file=" + s_filename
$app s_any, ",dev=" + s_filedevice
$app s_any, ",type=" + s_filetype
$out s_any
s_any = ",filefixed=" + s_filefixed
$app s_any, ",fileksam=" + s_fileksam
$app s_any, ",reclong=" + d_filereclong
$app s_any, ",keybeg=" + d_filekeybeg
$app s_any, ",keylong=" + d_filekeylong
$out s_any
endi
dift d_error > 0
'end dg_errnumber,d_error,1000
dg_errnumber = d_error
sg_pass1 = "file_error: " + s_error
sub_error
endi
ends sub_rpg_valid_files_fline
subr sub_rpg_valid_files_iline
'updated 2004/12/29
'iline into sg_filenames,sg_filedevs,sg_fileinfos,sg_filekey
vari s_any, d_any, s_dot, d_dot, s_tap, s_out
vari s_record, s_filename, d_varbeg, d_varend, d_error
vari s_filedevice, s_filetype
vari s_filefixed, s_fileksam
vari d_filereclong, d_filekeybeg, d_filekeylong
'sg_filenames
'12345678
'aaaaaaaa=filename
'sg_filedevs
'aaaaaaaa=filedev
'sg_fileinfos
'12345678
'aabbbbcd
'aa=file type: ID,UD,IC,O
'bbbb=file record length
'c=file is F=fixed or V=variable
'd=file is F=flat or K=KSAM
'sg_filekeys
'12345678
'aaaabbbb
'aaaa=file key begin
'bbbb=file key length
'iline 1 2 3 4 5 6
'123456789012345678901234567890123456789012345678901234567890
' .IFILEINP AA
' .I 10 20 VARIAB
s_record = sg_pass1
'beg dg_errnumber,d_error,1200
d_error = 0
'which type of iline do we have
$cut s_filename, s_record, 7, 8
$ch$ s_any, " ", 8
$ift s_any = s_filename
'we have a variable definition iline
'get d_varbeg and d_varend
$cut s_any, s_record, 44, 4
$isd d_any, s_any
dift d_any <> 1: s_any = "0"
$tod d_varbeg, s_any
$cut s_any, s_record, 48, 4
$isd d_any, s_any
dift d_any <> 1: s_any = "0"
$tod d_varend, s_any
'get the record length from the array
itod d_filereclong, 1
'validate d_varbeg and d_varend
dift d_varbeg < 1: d_error = 1201
dift d_varend < d_varbeg: d_error = 1202
dift d_varend > d_filereclong: d_error = 1203
else
'we have a filename iline get file information
sg_pass1 = s_filename
sub_rpg_file_info_return
s_filedevice = sg_pass1
s_filetype = sg_pass2
s_filefixed = sg_pass3
s_fileksam = sg_pass4
d_filereclong = dg_pass2
d_filekeybeg = dg_pass3
d_filekeylong = dg_pass4
'save d_filereclong for the variable definition lines
dtoi 1, d_filereclong
s_tap = "ID,UD,IC"
$lok d_any, s_tap, 1, s_filetype
dift d_any = 0: d_error = 1204
endi
'do we have an error
dift d_error > 0
'end dg_errnumber,d_error,1200
dg_errnumber = d_error
sg_pass1 = "bad input"
sub_error
endi
ends sub_rpg_valid_files_iline
subr sub_rpg_valid_files_cline
'updated 2005/04/03, 2004/10/24
'cline into sg_filenames,sg_fileinfos,sg_filekey
vari s_any, d_any, s_dot, d_dot, s_tap, s_out
vari s_record, s_filename, s_command, s_all
vari s_filedevice, s_filetype, d_filereclong
vari s_filefixed, s_fileksam
vari d_filekeybeg, d_filekeylong
'cline 1 2 3 4 5 6
'123456789012345678901234567890123456789012345678901234567890
' .CSR 01 02 03FACTOR1 COMMDFACTOR2 RESULT 92H919293
s_record = sg_pass1
s_all = "READ ,READP,CHAIN,SETLL,LOCK ,UNLCK,"
$cut s_command, s_record, 28, 5
$lok d_any, s_all, 1, s_command
dift d_any > 0
'we have a filename cline get file information
$cut s_filename, s_record, 33, 8
sg_pass1 = s_filename
sub_rpg_file_info_return
s_filedevice = sg_pass1
s_filetype = sg_pass2
s_filefixed = sg_pass3
s_fileksam = sg_pass4
d_filereclong = dg_pass2
d_filekeybeg = dg_pass3
d_filekeylong = dg_pass4
's_filetype must be ID,UD,IC
s_tap = "ID,UD,IC,"
$lok d_any, s_tap, 1, s_filetype
dift d_any = 0
sg_pass1 = "not ID,UD,IC"
sub_error
endi
$ift s_command = "READ "
$lok d_any, sg_readfile, 1, s_filename
dift d_any = 0: $app sg_readfile, s_filename + ","
s_tap = "ID,UD"
$lok d_any, s_tap, 1, s_filetype
dift d_any = 0
sg_pass1 = "not ID,UD"
sub_error
endi
endi
$ift s_command = "READP"
$lok d_any, sg_readpfile, 1, s_filename
dift d_any = 0: $app sg_readpfile, s_filename + ","
s_tap = "ID,UD"
$lok d_any, s_tap, 1, s_filetype
dift d_any = 0
sg_pass1 = "not ID,UD"
sub_error
endi
endi
$ift s_command = "CHAIN"
$lok d_any, sg_chainfile, 1, s_filename
dift d_any = 0: $app sg_chainfile, s_filename + ","
$ift s_filetype <> "IC"
sg_pass1 = "not IC"
sub_error
endi
endi
$ift s_command = "SETLL"
$ift s_fileksam <> "K"
sg_pass1 = "not KSAM"
sub_error
endi
endi
$ift s_command = "LOCK "
$ift s_fileksam <> "K"
sg_pass1 = "not KSAM"
sub_error
endi
endi
$ift s_command = "UNLCK"
$ift s_fileksam <> "K"
sg_pass1 = "not KSAM"
sub_error
endi
endi
endi
ends sub_rpg_valid_files_cline
subr sub_rpg_valid_files_oline
'updated 2005/04/03, 2003/10/16
'oline into sg_filenames,sg_fileinfos,sg_filekey
vari s_any, d_any, s_dot, d_dot, s_tap, s_out
vari s_record, s_filename, s_command, s_all
vari s_filedevice, s_filetype
vari s_filefixed, s_fileksam
vari d_filereclong, d_filekeybeg, d_filekeylong
' .OFILENAMEE 12 01 02 03OLINE
' .O E 01 02 03VARIABJB 132 "HEADING LINE "
s_record = sg_pass1
$cut s_filename, s_record, 7, 8
$ch$ s_any, " ", 8
$ift s_filename <> s_any
'we have a filename oline get file information
sg_pass1 = s_filename
sub_rpg_file_info_return
s_filedevice = sg_pass1
s_filetype = sg_pass2
s_filefixed = sg_pass3
s_fileksam = sg_pass4
d_filereclong = dg_pass2
d_filekeybeg = dg_pass3
d_filekeylong = dg_pass4
's_filetype must be ID or UD for an oline
s_tap = "UD,O "
$lok d_any, s_tap, 1, s_filetype
dift d_any = 0
sg_pass1 = "not ID or UD"
sub_error
endi
endi
ends sub_rpg_valid_files_oline
subr sub_rpg_file_info_return
'updated 2004/10/07
'return file info from sg_filenames,sg_filedevs,sg_fileinfos
vari s_any, d_any, s_dot, d_dot, s_out
vari s_filename, s_filetype, s_filedevice, d_filereclong
vari d_filekeybeg, d_filekeylong, s_filefixed, s_fileksam
vari s_infos, s_keys, d_byte
'sg_filenames
'12345678
'aaaaaaaa=filename
'sg_filedevs
'aaaaaaaa=filedev
'sg_fileinfos
'12345678
'aabbbbcd
'aa=file type: ID,UD,IC,O
'bbbb=file record length
'c=file is F=fixed or V=variable
'd=file is F=flat or K=KSAM
'sg_filekeys
'12345678
'aaaabbbb
'aaaa=file key begin
'bbbb=file key length
s_filename = sg_pass1
s_filedevice = sg_nothing
s_filetype = sg_nothing
s_filefixed = sg_nothing
s_fileksam = sg_nothing
d_filereclong = 0
d_filekeybeg = 0
d_filekeylong = 0
'make name 8 long uppercase
$app s_filename, sg_20blanks
$cut s_filename, s_filename, 1, 8
$cup s_filename, s_filename
$lok d_byte, sg_filenames, 1, s_filename
dift d_byte = 0
sg_pass1 = "no info file name=" + s_filename
sub_error
else
'get from sg_filedevs
$cut s_filedevice, sg_filedevs, d_byte, 8
'get from sg_fileinfos
$cut s_infos, sg_fileinfos, d_byte, 8
$cut s_filetype, s_infos, 1, 2
'record length d_filereclong
$cut s_any, s_infos, 3, 4
$tod d_filereclong, s_any
'get s_filefixed
$cut s_filefixed, s_infos, 7, 1
'get s_fileksam
$cut s_fileksam, s_infos, 8, 1
'get from sg_filekeys
$cut s_keys, sg_filekeys, d_byte, 8
$cut s_any, s_keys, 1, 4
$tod d_filekeybeg, s_any
$cut s_any, s_keys, 5, 4
$tod d_filekeylong, s_any
'dg_tdebug
dift dg_tdebug = 1
s_out = "file=" + s_filename + ", dev=" + s_filedevice
$app s_out, ",type=" + s_filetype
$app s_out, ",fixed=" + s_filefixed
$app s_out, ",ksam=" + s_fileksam
$out s_out
s_out = ",reclong=" + d_filereclong
$app s_out, ",keybeg=" + d_filekeybeg
$app s_out, ",keylong=" + d_filekeylong
$out s_out
endi
endi
sg_pass1 = s_filedevice
sg_pass2 = s_filetype
sg_pass3 = s_filefixed
sg_pass4 = s_fileksam
dg_pass2 = d_filereclong
dg_pass3 = d_filekeybeg
dg_pass4 = d_filekeylong
ends sub_rpg_file_info_return
subr sub_rpg_valid_identifier
'updated 2004/04/07
'identifier validate for filenames and variable names
vari s_any, d_any, s_dot, d_dot, s_out
vari s_chars, s_identifier, d_long, d_error
s_identifier = sg_pass1
s_chars = "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"
'beg dg_errnumber,d_error,1100
d_error = 0
$trr s_identifier, s_identifier
$len d_long, s_identifier
d_dot = 1
dwhi d_dot <= d_long
$cut s_dot, s_identifier, d_dot, 1
$lok d_any, s_chars, 1, s_dot
dift d_any = 0: d_error = 1101
'the first char must be a letter
dift d_dot = 1
dift d_any > 26: d_error = 1102
endi
dinc d_dot
endw
dift d_error > 0
'end dg_errnumber,d_error,1100
dg_errnumber = d_error
sg_pass1 = "bad identifier=" + s_identifier
sub_error
endi
ends sub_rpg_valid_identifier
subr sub_rpg_valid_tags
'updated 2005/01/15, 2003/11/18
'validate tag,goto,begsr,endsr
vari s_any, d_any, s_dot, d_dot, s_out
vari d_loop1, d_loop2, d_filebyte, s_record, d_good
vari s_tag7, s_goto7, s_exsr7, s_begsr7, s_alltagbegsr7
vari s_cexcpt7, s_oexcpt7
vari d_tag, d_goto, d_exsr, d_begsr, d_cexcpt, d_oexcpt
vari s_comm, s_fact1, s_fact2, s_result
vari s_blank6, d_big, s_fromsubr
vari d_insubroutine, s_insubroutine
$sys sg_subroutine, 2
s_fromsubr = sg_subroutine
dift dg_tdebug = 1
sg_pass1 = sg_subroutine
sub_return
endi
'cline 1 2 3 4 5 6
'123456789012345678901234567890123456789012345678901234567890
' .CSR 01 02 03FACTOR1 COMMDFACTOR2 RESULT 92H919293
s_tag7 = sg_nothing
s_goto7 = sg_nothing
s_exsr7 = sg_nothing
s_begsr7 = sg_nothing
s_alltagbegsr7 = sg_nothing
s_cexcpt7 = sg_nothing
s_oexcpt7 = sg_nothing
d_tag = 0
d_goto = 0
d_exsr = 0
d_begsr = 0
d_cexcpt = 0
d_oexcpt = 0
d_insubroutine = 2
s_insubroutine = sg_nothing
$ch$ s_blank6, " ", 6
dpow d_big, 10, 9
dg_record = 0
d_loop1 = 1
dwhi d_loop1 = 1
d_good = 1
sg_pass1 = s_fromsubr
sub_rpg_read_record
s_record = sg_pass1
dift dg_record = 0
dinc d_good
dinc d_loop1
endi
dift d_good = 1
$cut s_any, s_record, 6, 1
$ift s_any = "O"
'get excpt tags in output into s_oexcpt7
$cut s_any, s_record, 15, 1
$ift s_any = "E"
$cut s_dot, s_record, 32, 6
$isc d_any, s_dot, " "
dift d_any = 1
dg_errnumber = 1600
sg_pass1 = "excpt no tag"
sub_error
else
$lok d_any, s_oexcpt7, 1, s_dot
dift d_any = 0
dinc d_oexcpt
$app s_oexcpt7, s_dot + ","
endi
endi
endi
endi
$cut s_any, s_record, 6, 1
$ift s_any <> "C": dinc d_good
$cut s_any, s_record, 7, 1
$ift s_any = "*": dinc d_good
endi
dift d_good = 1
'only clines below
$cut s_fact1, s_record, 18, 6
$cut s_comm, s_record, 28, 5
$cut s_fact2, s_record, 33, 6
$cut s_result, s_record, 43, 6
$ift s_comm = "TAG "
'validate the name
sg_pass1 = s_fact1
sub_rpg_valid_identifier
$ift s_fact1 = s_blank6
dg_errnumber = 1601
sg_pass1 = "blank TAG"
sub_error
else
'have we this tag already
$lok d_any, s_alltagbegsr7, 1, s_fact1
dift d_any > 0
dg_errnumber = 1602
sg_pass1 = "dup TAG=" + s_fact1
sub_error
endi
dinc d_tag
$app s_tag7, s_fact1 + ","
$app s_alltagbegsr7, s_fact1 + ","
endi
endi
$ift s_comm = "GOTO "
$ift s_fact2 = s_blank6
dg_errnumber = 1603
sg_pass1 = "blank GOTO"
sub_error
else
dinc d_goto
$app s_goto7, s_fact2 + ","
endi
endi
$ift s_comm = "EXSR "
$ift s_fact2 = s_blank6
dg_errnumber = 1604
sg_pass1 = "blank EXSR"
sub_error
else
dinc d_exsr
$app s_exsr7, s_fact2 + ","
endi
endi
$ift s_comm = "BEGSR"
'validate the name
sg_pass1 = s_fact1
sub_rpg_valid_identifier
$ift s_fact1 = s_blank6
dg_errnumber = 1605
sg_pass1 = "blank BEGSR"
sub_error
else
'have we this begsr already
$lok d_any, s_alltagbegsr7, 1, s_fact1
dift d_any > 0
dg_errnumber = 1606
sg_pass1 = "duplicate TAGBEGSR"
sub_error
endi
dinc d_begsr
$app s_begsr7, s_fact1 + ","
$app s_alltagbegsr7, s_fact1 + ","
endi
dift d_insubroutine = 1
'we are already in s_insubroutine
dg_errnumber = 1607
sg_pass1 = "already in " + s_insubroutine
sub_error
endi
'we are now in subroutine s_fact1
d_insubroutine = 1
s_insubroutine = s_fact1
'find each GOTO in s_tag7
d_loop2 = 1
$len d_any, s_goto7
dift d_any < 7: dinc d_loop2
dwhi d_loop2 = 1
$cut s_dot, s_goto7, 1, 7
$cut s_goto7, s_goto7, 8, d_big
$lok d_dot, s_tag7, 1, s_dot
dift d_dot = 0
dg_errnumber = 1608
sg_pass1 = "bad GOTO=" + s_dot
sub_error
endi
$len d_any, s_goto7
dift d_any < 7: dinc d_loop2
endw
s_goto7 = sg_nothing
s_tag7 = sg_nothing
endi
$ift s_comm = "ENDSR"
'validate the name
sg_pass1 = s_fact1
sub_rpg_valid_identifier
$ift s_fact1 <> s_blank6
'have we this tagbegsr already
$lok d_any, s_alltagbegsr7, 1, s_fact1
dift d_any > 0
dg_errnumber = 1609
sg_pass1 = "dup TAGBEGSR=" + s_fact1
sub_error
endi
dinc d_goto
$app s_tag7, s_fact1 + ","
$app s_alltagbegsr7, s_fact1 + ","
endi
dift d_insubroutine <> 1
'we are not in any subroutine
dg_errnumber = 1610
sg_pass1 = "not in a subroutine"
sub_error
endi
'we are now not in a subroutine
d_insubroutine = 2
s_insubroutine = sg_nothing
'find each s_goto7 in s_tag7
d_loop2 = 1
$len d_any, s_goto7
dift d_any < 7: dinc d_loop2
dwhi d_loop2 = 1
$cut s_dot, s_goto7, 1, 7
$cut s_goto7, s_goto7, 8, d_big
$lok d_dot, s_tag7, 1, s_dot
dift d_dot = 0
dg_errnumber = 1611
sg_pass1 = "bad GOTO=" + s_dot
sub_error
endi
$len d_any, s_goto7
dift d_any < 7: dinc d_loop2
endw
s_goto7 = sg_nothing
s_tag7 = sg_nothing
endi
$ift s_comm = "EXCPT"
$trb s_any, s_result
$len d_any, s_any
dift d_any > 0
dinc d_cexcpt
$app s_cexcpt7, s_result + ","
endi
endi
endi
endw
'find each EXSR in s_exsr7 in s_begsr7
d_loop2 = 1
$len d_any, s_exsr7
$len d_dot, s_begsr7
d_any = d_any + d_dot
dift d_any = 0: dinc d_loop2
dwhi d_loop2 = 1
$cut s_dot, s_exsr7, 1, 7
$cut s_exsr7, s_exsr7, 8, d_big
$lok d_dot, s_begsr7, 1, s_dot
dift d_dot = 0
dg_errnumber = 1612
sg_pass1 = "bad EXSR='" + s_dot + "'"
sub_error
endi
$len d_any, s_exsr7
dift d_any < 7: dinc d_loop2
endw
'match s_oexcpt7 with s_cexcpt7
s_dot = s_oexcpt7
d_loop2 = 1
dwhi d_loop2 = 1
$cut s_any, s_dot, 1, 7
$cut s_dot, s_dot, 8, d_big
$lok d_any, s_cexcpt7, 1, s_any
dift d_any = 0
dg_errnumber = 1613
sg_pass1 = "bad oline excpt tag='" + s_any + "'"
sub_error
endi
$len d_any, s_dot
dift d_any < 7: dinc d_loop2
endw
'match s_cexcpt7 with s_oexcpt7
s_dot = s_cexcpt7
d_loop2 = 1
dwhi d_loop2 = 1
$cut s_any, s_dot, 1, 7
$cut s_dot, s_dot, 8, d_big
$lok d_any, s_oexcpt7, 1, s_any
dift d_any = 0
dg_errnumber = 1614
sg_pass1 = "bad excpt cline tag='" + s_any + "'"
sub_error
endi
$len d_any, s_dot
dift d_any < 7: dinc d_loop2
endw
$out "ct goto=" + d_goto
$out "ct tag=" + d_tag
$out "ct cexcpt=" + d_cexcpt
$out "ct oexcpt=" + d_oexcpt
$out "ct exsr=" + d_exsr
$out "ct begsr=" + d_begsr
$sys sg_subroutine, 2
dift dg_tdebug = 1
sg_pass1 = sg_subroutine
sub_return
endi
ends sub_rpg_valid_tags
subr sub_rpg_valid_varsize_lines
'updated 2004/06/21
'rpg validate var size by reading through the lines
vari s_any, d_any, s_dot, d_dot, s_out
vari d_loop, d_filebyte, s_record, d_good, d_count
vari s_6code, s_varname, s_varsize, s_fromsubr
$sys sg_subroutine, 2
s_fromsubr = sg_subroutine
dift dg_tdebug = 1
sg_pass1 = sg_subroutine
sub_return
endi
d_count = 0
dg_record = 0
d_loop = 1
dwhi d_loop = 1
d_good = 1
sg_pass1 = s_fromsubr
sub_rpg_read_record
s_record = sg_pass1
dift dg_record = 0
dinc d_good
dinc d_loop
endi
s_6code = "X"
dift d_good = 1
$cut s_6code, s_record, 6, 1
$cut s_any, s_record, 7, 1
$ift s_any = "*": s_6code = "X"
endi
$ift s_6code = "E"
sg_pass1 = s_record
sub_rpg_valid_varsize_eline
endi
$ift s_6code = "I"
sg_pass1 = s_record
sub_rpg_valid_varsize_iline
endi
'fline 1 eline 2 iline 3 4 5 6
'123456789012345678901234567890123456789012345678901234567890
' .FTERMIN ID F 80 $STDIN
' .FTERMOUT O F 80 $STDLST
' .E ZZ 1 80 1 2
' .IFILEINP AA
' .I 10 20 VARIAB
'cline 1 oline 2 3 4 5 6
'123456789012345678901234567890123456789012345678901234567890
' .CSR 01 02 03FACTOR1 COMMDFACTOR2 RESULT 92H919293
' .OFILENAMEE 12 01 02 03OLINE
' .O E 01 02 03VARIABJB 132 "HEADING LINE "
' var size = 99998887, 9999=how many, 888=length, 7=decimals
$ift s_6code = "C"
sg_pass1 = s_record
sub_rpg_valid_varsize_cline
endi
endw
$sys sg_subroutine, 2
dift dg_tdebug = 1
sg_pass1 = sg_subroutine
sub_return
endi
ends sub_rpg_valid_varsize_lines
subr sub_rpg_valid_varsize_eline
'updated 2006/10/31, 2004/12/27
'var in eline
vari s_any, d_any, s_dot, d_dot, s_out, d_error
vari s_varname, s_varindexct, s_varlongct, s_vardecimalct
vari s_varsize, s_perlinect
vari s_tabname, s_tablongct, s_tabdecimalct
vari d_good, s_comm, s_line
'eline 1 2 3 4 5
'123456789012345678901234567890123456789012345678901234567890
' .E ZZ 1 80 1 2
' .E TAB1 1 80 1 2 TAB2 6 4
'123456789 sg_rpgvarnames 9 long
'abbbbcccd sg_rpgvarsizes 9 long
'a = d_vartype: 1=numeric,2=numeric array,6=alpha,7=alpha array
'bbbb = d_varindexct: index count
'ccc = d_varlongct: length max=256
'd = d_vardecimalct: decimals
s_line = sg_pass1
's_line is 70 long
'beg dg_errnumber,d_error,3100
d_error = 0
$cut s_varname, s_line, 27, 6
$cut s_perlinect, s_line, 33, 3
$cut s_varindexct, s_line, 36, 4
$cut s_varlongct, s_line, 40, 3
$cut s_vardecimalct, s_line, 44, 1
$cut s_tabname, s_line, 46, 6
$cut s_tablongct, s_line, 52, 3
$cut s_tabdecimalct, s_line, 55, 2
'sg_bottomarray1,sg_bottomarray2 are used for bottom arrays
$isc d_any, s_perlinect, " "
dift d_any <> 1
'store in sg_bottomarray1, sg_bottomarray2 for bottom arrays
'sg_bottomarray1, csv with array names 6 long
'sg_bottomarray2, csv with perlinect 6 long
$app sg_bottomarray1, s_varname + ","
$app sg_bottomarray2, " " + s_perlinect + ","
endi
'123456789 sg_rpgvarnames 9 long
'abbbbcccd sg_rpgvarsizes 9 long
'a = d_vartype: 1=numeric,2=numeric array,6=alpha,7=alpha array
'bbbb = d_varindexct: index count
'ccc = d_varlongct: length max=256
'd = d_vardecimalct: decimals
'do we have an alpha array
$ift s_vardecimalct = " "
s_varsize = "7" + s_varindexct + s_varlongct + s_vardecimalct
else
s_varsize = "2" + s_varindexct + s_varlongct + s_vardecimalct
endi
'store in sg_rpgvarnames,sg_rpgvarsizes
sg_pass1 = s_varname
sg_pass2 = s_varsize
sg_pass3 = "E"
sub_rpg_variable_info_collect
'do we have a table1, table2
$cut s_any, s_varname, 1, 3
$ift s_any = "TAB"
'table2 must also start with TAB
$cut s_any, s_tabname, 1, 3
$ift s_any <> "TAB": d_error = 3101
'cannot have numeric table1
$isc d_any, s_vardecimalct, " "
dift d_any <> 1: d_error = 3102
'cannot have numeric table2
$isc d_any, s_tabdecimalct, " "
dift d_any <> 1: d_error = 3103
'cannot already have these names already
$lok d_any, sg_rpgtabnames1, 1, s_varname
dift d_any > 0: d_error = 3104
$lok d_any, sg_rpgtabnames2, 1, s_tabname
dift d_any > 0: d_error = 3105
'store in sg_rpgtabnames1,sg_rpgtabnames2 to connect them
$app sg_rpgtabnames1, s_varname + ","
$app sg_rpgtabnames2, s_tabname + ","
'123456789 sg_rpgvarnames 9 long
'abbbbcccd sg_rpgvarsizes 9 long
'a = d_vartype: 1=numeric,2=numeric array,6=alpha,7=alpha array
'bbbb = d_varindexct: index count
'ccc = d_varlongct: length max=256
'd = d_vardecimalct: decimals
s_varsize = "60001" + s_tablongct + " "
'store table2 in sg_rpgvarnames,sg_rpgvarsizes
sg_pass1 = s_tabname
sg_pass2 = s_varsize
sg_pass3 = "E"
sub_rpg_variable_info_collect
endi
dift d_error > 0
'end dg_errnumber,d_error,3100
dg_errnumber = d_error
sg_pass1 = "E line error"
sub_error
endi
ends sub_rpg_valid_varsize_eline
subr sub_rpg_valid_varsize_iline
'updated 2006/10/31, 2003/09/30
'variables from ilines
vari s_any, d_any, s_dot, d_dot, s_out
vari s_line, s_varname, s_varsize
vari d_beg, d_end
vari d_process, d_good
vari s_vartype, s_varindexct, s_varlongct, s_vardecimalct
'iline 1 2 3 4 5 6
'123456789012345678901234567890123456789012345678901234567890
' .IFILEINP AA
' .I 10 20 VARIAB
'123456789 sg_rpgvarnames 9 long
'abbbbcccd sg_rpgvarsizes 9 long
'a = d_vartype: 1=numeric,2=numeric array,6=alpha,7=alpha array
'bbbb = d_varindexct: index count
'ccc = d_varlongct: length max=256
'd = d_vardecimalct: decimals
s_line = sg_pass1
d_process = 1
'do we have a variable definition line
$cut s_any, s_line, 7, 8
$ch$ s_dot, " ", 8
$ift s_any <> s_dot: dinc d_process
dift d_process = 1
$cut s_varname, s_line, 53, 6
'was this s_varname done earlier on an eline
s_any = s_varname + sg_20blanks
$cut s_any, s_any, 1, 9
$lok d_any, sg_rpgvarnames, 1, s_any
dift d_any > 0: dinc d_process
endi
dift d_process = 1
s_varindexct = "0001"
'get s_varlongct
$cut s_any, s_line, 44, 4
$tod d_beg, s_any
$cut s_any, s_line, 48, 4
$tod d_end, s_any
d_dot = d_end - d_beg + 1
s_varlongct = d_dot
s_varlongct = sg_20blanks + s_varlongct
$off s_varlongct, s_varlongct, 3
'get s_vardecimalct
$cut s_vardecimalct, s_line, 52, 1
'numeric variable = 1
s_vartype = "1"
$ift s_vardecimalct = " "
'alpha variable = 6
s_vartype = "6"
s_vardecimalct = "0"
endi
s_varsize = s_vartype + s_varindexct + s_varlongct
$app s_varsize, s_vardecimalct
'zero fill
$swp s_varsize, " ", "0"
'store in sg_rpgvarnames,sg_rpgvarsizes
sg_pass1 = s_varname
sg_pass2 = s_varsize
sg_pass3 = "I"
sub_rpg_variable_info_collect
endi
ends sub_rpg_valid_varsize_iline
subr sub_rpg_valid_varsize_cline
'updated 2005/04/03, 2003/06/05
'get varsize in cline variables
vari s_any, d_any, s_dot, d_dot, s_tap, s_out
vari s_record, s_varname, s_varsize
vari d_process, d_good, s_command
vari s_vartype, s_varindexct, s_varlongct, s_vardecimalct
'cline 1 2 3 4 5 6
'123456789012345678901234567890123456789012345678901234567890
' .CSR 01 02 03FACTOR1 COMMDFACTOR2 RESULT 92H919293
'123456789 sg_rpgvarnames 9 long
'abbbbcccd sg_rpgvarsizes 9 long
'a = d_vartype: 1=numeric,2=numeric array,6=alpha,7=alpha array
'bbbb = d_varindexct: index count
'ccc = d_varlongct: length
'd = d_vardecimalct: decimals
s_record = sg_pass1
's_record is 70 long
d_process = 1
$cut s_varname, s_record, 43, 6
$cut s_varlongct, s_record, 49, 3
$cut s_vardecimalct, s_record, 52, 1
$cut s_command, s_record, 28, 5
'skip if certain commands
s_tap = "EXCPT,TAG ,GOTO ,BEGSR,ENDSR,"
$lok d_dot, s_tap, 1, s_command
dift d_dot > 0: dinc d_process
'skip if empty field
$ch$ s_any, " ", 6
$ift s_varname = s_any: dinc d_process
'skip if containing a comma
$lok d_any, s_varname, 1, ","
dift d_any > 0: dinc d_process
'skip if no s_varlongct
$ch$ s_any, " ", 3
$ift s_varlongct = s_any: dinc d_process
dift d_process = 1
'123456789 sg_rpgvarnames 9 long
'abbbbcccd sg_rpgvarsizes 9 long
'a = d_vartype: 1=numeric,2=numeric array,6=alpha,7=alpha array
'bbbb = d_varindexct: index count
'ccc = d_varlongct: length
'd = d_vardecimalct: decimals
'do we have a numeric field=1 or alpha=6
s_vartype = "1"
$ift s_vardecimalct = " ": s_vartype = "6"
'put s_varsize together
s_varindexct = "0001"
s_varsize = s_vartype + s_varindexct + s_varlongct
$app s_varsize, s_vardecimalct
'zero fill
$swp s_varsize, " ", "0"
'store in sg_rpgvarnames,sg_rpgvarsizes
sg_pass1 = s_varname
sg_pass2 = s_varsize
sg_pass3 = "C"
sub_rpg_variable_info_collect
endi
ends sub_rpg_valid_varsize_cline
subr sub_rpg_valid_var_all
'updated 2003/11/18
'rpg validate var all
vari s_any, d_any, s_dot, d_dot, s_out
vari d_loop, d_filebyte, s_record, d_good, d_count
vari s_6code, s_varname, s_varsize, s_fromsubr
$sys sg_subroutine, 2
s_fromsubr = sg_subroutine
dift dg_tdebug = 1
sg_pass1 = sg_subroutine
sub_return
endi
d_count = 0
dg_record = 0
d_loop = 1
dwhi d_loop = 1
d_good = 1
sg_pass1 = s_fromsubr
sub_rpg_read_record
s_record = sg_pass1
dift dg_record = 0
dinc d_good
dinc d_loop
endi
dift d_good = 1
'get code in byte 6
$cut s_6code, s_record, 6, 1
'skip if not C or O
d_any = 2
$ift s_6code = "C": d_any = 1
$ift s_6code = "O": d_any = 1
dift d_any <> 1: dinc d_good
endi
dift d_good <> 1: s_6code = "X"
$ift s_6code = "C"
sg_pass1 = s_record
sub_rpg_valid_var_all_cline
endi
$ift s_6code = "O"
sg_pass1 = s_record
sub_rpg_valid_var_all_oline
endi
endw
'fline 1 eline 2 iline 3 4 5 6
'123456789012345678901234567890123456789012345678901234567890
' .FTERMIN ID F 80 $STDIN
' .FTERMOUT O F 80 $STDLST
' .E ZZ 1 80 1 2
' .IFILEINP AA
' .I 10 20 VARIAB
'cline 1 oline 2 3 4 5 6
'123456789012345678901234567890123456789012345678901234567890
' .CSR 01 02 03FACTOR1 COMMDFACTOR2 RESULT 92H919293
' .OFILENAMEE 12 01 02 03OLINE
' .O E 01 02 03VARIABJB 132 "HEADING LINE "
' var size = 99998887, 9999=how many, 888=length, 7=decimals
$sys sg_subroutine, 2
dift dg_tdebug = 1
sg_pass1 = sg_subroutine
sub_return
endi
ends sub_rpg_valid_var_all
subr sub_rpg_valid_var_all_cline
'updated 2004/12/31
'rpg validate all variables in c-line
vari s_any, d_any, s_dot, d_dot, s_out
vari s_record, d_process, d_good
vari s_comm, s_field, s_var1, s_var2
'cline 1 2 3 4 5 6
'123456789012345678901234567890123456789012345678901234567890
' .CSR 01 02 03FACTOR1 COMMDFACTOR2 RESULT 92H919293
s_record = sg_pass1
d_process = 1
s_dot = "ADD ,BITOF,BITON,COMP ,DIV ,FNDJW,"
$app s_dot, "LOKUP,MOVE ,MOVEA,MOVEL,MULT ,MVR ,"
$app s_dot, "PUTJW,SETOF,SETON,SORTA,SQRT ,SUB ,"
$app s_dot, "TESTN,TIME ,TIME2,XFOOT,Z-ADD,Z-SUB,"
'others
'TAG,GOTO,EXSR,BEGSR,ENDSR,READ,READP,CHAIN
'LOCK,UNLCK,SETLL,EXCPT
$cut s_comm, s_record, 28, 5
$lok d_any, s_dot, 1, s_comm
dift d_any = 0: dinc d_process
dift d_process = 1
'validate the variable and get the type
$cut s_field, s_record, 18, 10
'cannot have *BLANK in field1
$trr s_any, s_field
$ift s_any = "*BLANK"
sg_pass1 = "*BLANK in field1"
sub_error
endi
sg_pass1 = s_field
sub_field_info_return
'not interested in actual fields from above
'validate the variable and get the type
$cut s_field, s_record, 33, 10
sg_pass1 = s_field
sub_field_info_return
'not interested in actual fields from above
'validate the variable and get the type
$cut s_field, s_record, 43, 6
sg_pass1 = s_field
sub_field_info_return
'not interested in actual fields from above
endi
ends sub_rpg_valid_var_all_cline
subr sub_rpg_valid_var_all_oline
'updated 2005/04/03, 2003/04/09
'validate variables in o-line
vari s_any, d_any, s_dot, d_dot, s_tap, s_out
vari s_record, d_good, d_process, s_field
'oline 1 2 3 4 5 6
'123456789012345678901234567890123456789012345678901234567890
' .O 01 02 03VARIABJB 132 "HEADING LINE "
s_record = sg_pass1
d_process = 1
$cut s_any, s_record, 7, 9
$trb s_any, s_any
$len d_any, s_any
dift d_any > 0: dinc d_process
dift d_process = 1
$cut s_field, s_record, 32, 6
s_tap = "PAGE ,UDATE ,"
$lok d_any, s_tap, 1, s_field
dift d_any > 0: dinc d_process
endi
dift d_process = 1
'validate the variable and get the type
sg_pass1 = s_field
sub_field_info_return
'not interested in actual fields from above
endi
ends sub_rpg_valid_var_all_oline
subr sub_variable_info_return
'updated 2005/04/09, 2005/04/08, 2003/11/25
'from sg_rpgvarnames and sg_rpgvarsizes return variable info
vari s_any, d_any, s_dot, d_dot, s_out
vari d_vartype, d_varindexct, d_varlongct, d_vardecimalct
vari s_varname, s_varsize
'123456789 sg_rpgvarnames 9 long
'abbbbcccd sg_rpgvarsizes 9 long
'a = d_vartype: 1=numeric,2=numeric array,6=alpha,7=alpha array
'bbbb = d_varindexct: index count
'ccc = d_varlongct: length
'd = d_vardecimalct: decimals
s_varname = sg_pass1
dift dg_tdebug = 1
$sys s_any, 2
$out s_any
$out "sg_pass1='" + s_varname + "'"
sub_return
endi
$app s_varname, sg_20blanks
$cut s_varname, s_varname, 1, 9
$cup s_varname, s_varname
d_vartype = 0
d_varindexct = 0
d_varlongct = 0
d_vardecimalct = 0
'find s_varname in sg_rpgvarnames
$lok d_dot, sg_rpgvarnames, 1, s_varname
dift d_dot > 0
$cut s_varsize, sg_rpgvarsizes, d_dot, 9
$ch$ s_any, "9", 9
$isp d_any, s_varsize, s_any
dift d_any = 1
'variable type
$cut s_any, s_varsize, 1, 1
$tod d_vartype, s_any
'index count
$cut s_any, s_varsize, 2, 4
$tod d_varindexct, s_any
'long count
$cut s_any, s_varsize, 6, 3
$tod d_varlongct, s_any
'decimal count
$cut s_any, s_varsize, 9, 1
$tod d_vardecimalct, s_any
else
sg_pass1 = s_varname + " is " + s_varsize
sub_error
endi
endi
dift dg_tdebug = 1
s_any = "vartype=" + d_vartype
$app s_any, ", varindexct=" + d_varindexct
$app s_any, ", varlongct=" + d_varlongct
$app s_any, ", vardecimalct=" + d_vardecimalct
sg_pass1 = s_any
sub_return
endi
dg_pass1 = d_vartype
dg_pass2 = d_varindexct
dg_pass3 = d_varlongct
dg_pass4 = d_vardecimalct
sg_pass1 = s_varsize
ends sub_variable_info_return
subr sub_variable_lookup
'updated 2006/11/01, 2006/04/25, 2003/11/24
vari s_any, d_any, s_dot, d_dot, s_out
vari d_loop, s_varname, s_varsize, s_vartype
vari d_vartype, d_indexct, d_longct, d_decimalct
d_loop = dg_process
dwhi d_loop = 1
$inp s_varname, "enter variable name or return"
$ift s_varname = "*": s_varname = sg_nothing
$ift s_varname = sg_nothing
dinc d_loop
else
'123456789 sg_rpgvarnames 9 long
'abbbbcccd sg_rpgvarsizes 9 long
'a = d_vartype: 1=numeric,2=numeric array,6=alpha,7=alpha array
'bbbb = d_varindexct: index count
'ccc = d_varlongct: length max=256
'd = d_vardecimalct: decimals
sg_pass1 = s_varname
sub_variable_info_return
d_vartype = dg_pass1
d_indexct = dg_pass2
d_longct = dg_pass3
d_decimalct = dg_pass4
s_varsize = sg_pass1
s_vartype = "none"
dift d_vartype = 1: s_vartype = "numeric variable"
dift d_vartype = 2: s_vartype = "numeric array"
dift d_vartype = 6: s_vartype = "alpha variable"
dift d_vartype = 7: s_vartype = "alpha array"
$out s_vartype
s_out = "vartype=" + d_vartype
$app s_out, ", indexct=" + d_indexct
$app s_out, ", longct=" + d_longct
$app s_out, ", decimalct=" + d_decimalct
$app s_out, ", size=" + s_varsize
$out s_out
endi
endw
ends sub_variable_lookup
subr sub_field_info_return
'updated 2005/04/08, 2005/01/02
'validate the variable and get type and return parts
vari s_any, d_any, s_dot, d_dot, s_out, d_action
vari d_process, d_error, d_byte
vari s_expfieldtype, d_comma
vari s_testfield, s_var1, s_var2
vari d_vartype1, d_indexct1, d_longct1, d_decimalct1
vari d_vartype2, d_indexct2, d_longct2, d_decimalct2
vari d_expfieldtype1, d_expfieldtype2
vari s_expfieldvar1, s_expfieldvar2
vari s_expcfield, s_expcindex
vari s_lowtestfield1, s_lowtestfield2
vari s_expvarsize1, s_expvarsize2
'd_fieldtype
'1=bad field
'2=blank
'6=*BLANK
'7=*ZEROS
'8=UDATE
'11=numeric literal
'12=numeric var
'13=numeric array with index
'14=numeric array no index
'21=alpha literal
'22=alpha var
'23=alpha array with index
'24=alpha array no index
s_testfield = sg_pass1
dift dg_tdebug = 1
$sys s_any, 2
$out s_any
$out "sg_pass1='" + s_testfield + "'"
sub_return
endi
$trb s_testfield, s_testfield
'beg dg_errnumber,d_error,3200
d_error = 0
d_process = 1
d_action = 0
'initialize out fields
d_expfieldtype1 = 2
d_expfieldtype2 = 2
s_expfieldvar1 = sg_nothing
s_expfieldvar2 = sg_nothing
s_expfieldtype = "none"
s_expcfield = sg_nothing
s_expcindex = sg_nothing
s_expvarsize1 = sg_nothing
s_expvarsize2 = sg_nothing
d_indexct1 = 0
d_longct1 = 0
d_decimalct1 = 0
d_longct2 = 0
d_decimalct2 = 0
'do we have nothing, s_testfield has been trimmed
$len d_any, s_testfield
dift d_any = 0
d_expfieldtype1 = 2
s_expfieldtype = "blank"
dinc d_process
endi
'do we have *BLANK
$ift s_testfield = "*BLANK"
d_expfieldtype1 = 6
s_expfieldtype = s_testfield
dinc d_process
endi
'do we have *ZEROS
$ift s_testfield = "*ZEROS"
d_expfieldtype1 = 7
s_expfieldtype = s_testfield
dinc d_process
endi
'do we have UDATE
$ift s_testfield = "UDATE"
d_expfieldtype1 = 8
s_expfieldtype = s_testfield
dinc d_process
endi
dift d_process = 1
'do we have a string literal
$cut s_any, s_testfield, 1, 1
$ift s_any = #"#
$off s_any, s_testfield, 1
$ift s_any = #"#
'get d_longct1
$len d_any, s_testfield
d_longct1 = d_any - 2
d_indexct1 = 1
s_expfieldvar1 = s_testfield
d_expfieldtype1 = 21
s_expfieldtype = "string literal"
s_expcfield = s_testfield
dinc d_process
else
d_error = 3201
dinc d_process
endi
endi
endi
dift d_process = 1
'do we have a numeric literal
$isd d_any, s_testfield
dift d_any = 1
'take off leading zeros
sg_pass1 = s_testfield
sub_take_off_leading_zeros
s_testfield = sg_pass1
'we cannot have a comma
$lok d_any, s_testfield, 1, ","
dift d_any > 0
d_error = 3203
else
'get d_decimalct
$lok d_dot, s_testfield, 1, "."
$len d_any, s_testfield
dift d_dot > 0
d_decimalct1 = d_any - d_dot
else
d_decimalct1 = 0
endi
s_expfieldvar1 = s_testfield
d_expfieldtype1 = 11
s_expfieldtype = "numeric literal"
s_expcfield = s_testfield
dinc d_process
endi
endi
endi
dift d_process = 1
'do we have an index
$lok d_comma, s_testfield, 1, ","
dift d_comma = 0: d_action = 1
endi
dift d_action = 1
'no index
sg_pass1 = s_testfield
sub_variable_info_return
d_vartype1 = dg_pass1
d_indexct1 = dg_pass2
d_longct1 = dg_pass3
d_decimalct1 = dg_pass4
s_expvarsize1 = sg_pass1
s_var1 = s_testfield
$clo s_lowtestfield1, s_testfield
'123456789 sg_rpgvarnames 9 long
'abbbbcccd sg_rpgvarsizes 9 long
'a = d_vartype: 1=numeric,2=numeric array,6=alpha,7=alpha array
'bbbb = d_varindexct: index count
'ccc = d_varlongct: length
'd = d_vardecimalct: decimals
dift d_vartype1 = 0
d_error = 3204
else
dift d_vartype1 = 1
'numeric variable
s_expfieldvar1 = s_testfield
d_expfieldtype1 = 12
s_expfieldtype = "numeric variable"
s_expcfield = "dg_" + s_lowtestfield1
endi
dift d_vartype1 = 2
'numeric array with no index
s_expfieldvar1 = s_testfield
d_expfieldtype1 = 14
s_expfieldtype = "numeric array"
s_expcfield = "dga_" + s_lowtestfield1
endi
dift d_vartype1 = 6
'alpha variable
s_expfieldvar1 = s_testfield
d_expfieldtype1 = 22
s_expfieldtype = "alpha variable"
s_expcfield = "sg_" + s_lowtestfield1
endi
dift d_vartype1 = 7
'alpha array
s_expfieldvar1 = s_testfield
d_expfieldtype1 = 24
s_expfieldtype = "alpha array"
s_expcfield = "sga_" + s_lowtestfield1
endi
endi
dinc d_process
endi
'123456789 sg_rpgvarnames 9 long
'abbbbcccd sg_rpgvarsizes 9 long
'a = d_vartype: 1=numeric,2=numeric array,6=alpha,7=alpha array
'bbbb = d_varindexct: index count
'ccc = d_varlongct: length
'd = d_vardecimalct: decimals
dift d_process = 1
'we have an index comma at d_comma
$par s_var1, s_testfield, ",", 1
$par s_var2, s_testfield, ",", 2
$tlo s_lowtestfield1, s_var1
$tlo s_lowtestfield2, s_var2
'validate s_var1
sg_pass1 = s_var1
sub_variable_info_return
d_vartype1 = dg_pass1
d_indexct1 = dg_pass2
d_longct1 = dg_pass3
d_decimalct1 = dg_pass4
s_expvarsize1 = sg_pass1
'd_vartype1 can only be 2 or 7
d_any = d_vartype1
dift d_any = 7: d_any = 2
dift d_any <> 2
d_error = 3205
dinc d_process
endi
endi
dift d_process = 1
'for s_var1 remembering we have an index
dift d_vartype1 = 2
'numeric array with index
s_expfieldvar1 = s_lowtestfield1
d_expfieldtype1 = 13
s_expfieldtype = "numeric array with index"
'put the index on later
s_expcfield = "dga_" + s_lowtestfield1
endi
dift d_vartype1 = 7
'alpha array with index
$trb s_expfieldvar1, s_var1
d_expfieldtype1 = 23
s_expfieldtype = "alpha array with index"
'put the index on later
s_expcfield = "sga_" + s_lowtestfield1
endi
endi
dift d_process = 1
'is index s_lowtestfield2 a numeric literal
$ist d_any, s_lowtestfield2, "9"
dift d_any = 1
'get rid of leading zeros
$tod d_dot, s_lowtestfield2
s_lowtestfield2 = d_dot
'validate the number as an index
d_any = 2
dift d_dot < 1: d_any = 1
dift d_dot > d_indexct1: d_any = 1
dift d_any = 1: d_error = 3207
s_expfieldvar2 = s_lowtestfield2
d_expfieldtype2 = 11
$app s_expfieldtype, " literal index"
dift d_vartype1 = 2
'numeric array, put on the numeric literal index
$app s_expcfield, "[" + s_lowtestfield2 + " - 1]"
endi
dift d_vartype1 = 7
'alpha array, put on the numeric literal index
$app s_expcfield, "[(" + s_lowtestfield2
$app s_expcfield, " - 1) * " + d_longct1 + "]"
endi
dinc d_process
endi
endi
dift d_process = 1
'validate s_lowtestfield2 as a numeric variable
sg_pass1 = s_lowtestfield2
sub_variable_info_return
d_vartype2 = dg_pass1
d_indexct2 = dg_pass2
d_longct2 = dg_pass3
d_decimalct2 = dg_pass4
s_expvarsize2 = sg_pass1
'do we have an error
d_dot = 2
dift d_vartype2 <> 1: d_dot = 1
dift d_indexct2 <> 1: d_dot = 1
dift d_decimalct2 <> 0: d_dot = 1
dift d_dot = 1
d_error = 3208
else
s_expfieldvar2 = s_lowtestfield2
d_expfieldtype2 = 12
$app s_expfieldtype, " variable index"
s_expcindex = "dg_" + s_lowtestfield2
dift d_vartype1 = 2
'numeric array, put on the numeric variable index
$app s_expcfield, "[tfni_index(dg_"
$app s_expcfield, s_lowtestfield2 + ") - 1]"
endi
dift d_vartype1 = 7
'alpha array, put on the numeric variable index
$app s_expcfield, "[(tfni_index(dg_"
$app s_expcfield, s_lowtestfield2 + ") - 1) * "
$app s_expcfield, d_longct1 + "]"
endi
endi
endi
dift d_error > 0
'end dg_errnumber,d_error,3200
dg_errnumber = d_error
'out d_expfieldtype1 = 0
'out d_expfieldtype2 = 0
s_any = "sub_field_info_return, bad field="
$app s_any, s_testfield
sg_pass1 = s_any
sub_error
endi
dift dg_tdebug = 1
$out "s_testfield=" + s_testfield
sg_pass1 = "s_expcfield=" + s_expcfield
sub_return
endi
'd_expfieldtype1
'1=error
'2=blank
'6=*BLANK
'7=*ZEROS
'8=UDATE
'11=number
'12=numeric var
'13=numeric array with index
'14=numeric array no index
'21=alpha literal
'22=alpha var
'23=alpha array with index
'24=alpha array no index
dg_pass1 = d_expfieldtype1
dg_pass2 = d_expfieldtype2
dg_pass3 = d_indexct1
dg_pass4 = d_longct1
dg_pass5 = d_decimalct1
dg_pass6 = d_longct2
dg_pass7 = d_decimalct2
sg_pass1 = s_expfieldvar1
sg_pass2 = s_expfieldvar2
sg_pass3 = s_expfieldtype
sg_pass4 = s_expcfield
sg_pass5 = s_expvarsize1
sg_pass6 = s_expvarsize2
sg_pass7 = s_expcindex
ends sub_field_info_return
subr sub_rpg_variable_info_collect
'updated 2006/11/01, 2006/10/31, 2005/04/07, 2004/08/05
'save var info in sg_rpgvarnames,sg_rpgvarsizes
'var in sg_pass1, size in sg_pass2, line code in sg_pass3
vari s_any, d_any, s_dot, d_dot, s_out
vari s_varname, s_varsize, d_byte, d_good
vari s_oldname, s_oldsize, s_linecode, s_error
vari d_vartype, d_varindexct, d_varlongct, d_vardecimalct
'123456789 sg_rpgvarnames 9 long
'abbbbcccd sg_rpgvarsizes 9 long
'a = d_vartype: 1=numeric,2=numeric array,6=alpha,7=alpha array
'bbbb = d_varindexct: index count
'ccc = d_varlongct: length
'd = d_vardecimalct: decimals
s_varname = sg_pass1
s_varsize = sg_pass2
s_linecode = sg_pass3
$sys sg_subroutine, 2
dift dg_tdebug = 1
s_out = "s_varname=" + s_varname
$app s_out, ", s_varsize=" + s_varsize
$app s_out, ", s_linecode=" + s_linecode
$out s_out
sg_pass1 = sg_subroutine
sub_return
endi
d_good = 1
'is s_varname a valid name
sg_pass1 = s_varname
sub_rpg_valid_identifier
dift dg_error = 1
s_error = "bad identifier"
dinc d_good
endi
's_varname is 6 long
's_varsize is 9 long
's_linecode is 1 long
'make sure both are 9 long
$app s_varname, sg_20blanks
$cut s_varname, s_varname, 1, 9
$app s_varsize, sg_20blanks
$cut s_varsize, s_varsize, 1, 9
'upper case s_varname, zero filled s_varsize
$cup s_varname, s_varname
$swp s_varsize, " ", "0"
$ch$ s_any, "9", 9
$isp d_any, s_varsize, s_any
dift d_any <> 1
s_error = "s_varsize not numeric"
dinc d_good
endi
'123456789 sg_rpgvarnames 9 long
'abbbbcccd sg_rpgvarsizes 9 long
'a = d_vartype: 1=numeric,2=numeric array,6=alpha,7=alpha array
'bbbb = d_varindexct: index count
'ccc = d_varlongct: length max=256
'd = d_vardecimalct: decimals
dift d_good = 1
$cut s_any, s_varsize, 1, 1
$tod d_vartype, s_any
$cut s_any, s_varsize, 2, 4
$tod d_varindexct, s_any
$cut s_any, s_varsize, 6, 3
$tod d_varlongct, s_any
$cut s_any, s_varsize, 9, 1
$tod d_vardecimalct, s_any
'max d_varlongct is 256
dift d_varlongct > 256
s_error = "d_varlongct > 256"
dinc d_good
endi
'do we have s_varname already
$lok d_byte, sg_rpgvarnames, 1, s_varname
endi
dift d_good <> 1: d_byte = -1
dift d_byte > 0
'we have s_varname already get s_oldname,s_oldsizes
$cut s_oldname, sg_rpgvarnames, d_byte, 9
$cut s_oldsize, sg_rpgvarsizes, d_byte, 9
'is s_oldsize made up of just spaces put in s_varsize
$isc d_any, s_oldsize, " "
dift d_any = 1
'we need to put s_varsize in for s_varname
dift dg_tdebug = 1
s_out = "old var=" + s_oldname
$app s_out, ", size=" + s_oldsize
$out s_out
s_out = "new var=" + s_varname
$app s_out, ", size=" + s_varsize
$out s_out
endi
$rep sg_rpgvarsizes, d_byte, s_varsize
else
'123456789 sg_rpgvarnames 9 long
'abbbbcccd sg_rpgvarsizes 9 long
'a = d_vartype: 1=numeric,2=numeric array,6=alpha,7=alpha array
'bbbb = d_varindexct: index count
'ccc = d_varlongct: length max=256
'd = d_vardecimalct: decimals
'we have an earlier s_oldsize
$ift s_linecode = "I"
'if previous an array we do not need s_varsize
$cut s_any, s_oldsize, 1, 1
$ift s_any = "7": $ch$ s_varsize, " ", 9
endi
'if s_varsize not blanks
$isc d_any, s_varsize, " "
dift d_any <> 1
$ift s_oldsize <> s_varsize
s_out = "old var=" + s_oldname
$app s_out, ", size=" + s_oldsize
$out s_out
s_out = "new var=" + s_varname
$app s_out, ", size=" + s_varsize
$out s_out
sg_pass1 = "redefined variable"
sub_error
endi
endi
endi
endi
dift d_byte = 0
'we do not have s_varname, so store in strings
$app sg_rpgvarnames, s_varname + ","
$app sg_rpgvarsizes, s_varsize + ","
endi
dift d_good <> 1
$out s_error
sg_pass1 = "bad var=" + s_varname
$app sg_pass1, ", varsize=" + s_varsize
sub_error
endi
ends sub_rpg_variable_info_collect
subr sub_rpg_valid_indicators
'updated 2004/04/02
'rpg validate indicators
vari s_any, d_any, s_dot, d_dot, s_out
vari d_loop, d_filebyte, s_record, d_good, d_count
vari s_6code, d_byte, d_long
vari s_clinecommand, s_fromsubr
vari s_commands1, s_commands2
$sys sg_subroutine, 2
s_fromsubr = sg_subroutine
dift dg_tdebug = 1
sg_pass1 = sg_subroutine
sub_return
endi
's_commands1 must have set in 54/60
s_commands1 = "SETON,SETOF,COMP ,"
's_commands2 must have set in 58/59
s_commands2 = "LOKUP,FNDJW,SETJW,READ ,READP,"
$app s_commands2, "LOCK ,UNLCK,"
d_count = 0
dg_record = 0
d_loop = 1
dwhi d_loop = 1
d_good = 1
sg_pass1 = s_fromsubr
sub_rpg_read_record
s_record = sg_pass1
dift dg_record = 0
s_6code = "X"
dinc d_good
dinc d_loop
endi
dift d_good = 1
'get code in byte 6
$cut s_6code, s_record, 6, 1
'skip if not C or O
d_any = 2
$ift s_6code = "C": d_any = 1
$ift s_6code = "O": d_any = 1
dift d_any <> 1: s_6code = "X"
endi
$ift s_6code = "C"
'calculation indicators
'cline 1 2 3 4 5 6
'123456789012345678901234567890123456789012345678901234567890
' .CSR 01 02 03FACTOR1 COMMDFACTOR2 RESULT 92H919293
'do the use indicators
$cut sg_pass1, s_record, 9, 3
dg_pass1 = 3
sub_rpg_valid_indicators_proc
$cut sg_pass1, s_record, 12, 3
dg_pass1 = 3
sub_rpg_valid_indicators_proc
$cut sg_pass1, s_record, 15, 3
dg_pass1 = 3
sub_rpg_valid_indicators_proc
'do the set indicators
$cut sg_pass1, s_record, 54, 2
dg_pass1 = 3
sub_rpg_valid_indicators_proc
$cut sg_pass1, s_record, 56, 2
dg_pass1 = 3
sub_rpg_valid_indicators_proc
$cut sg_pass1, s_record, 58, 2
dg_pass1 = 3
sub_rpg_valid_indicators_proc
$cut s_clinecommand, s_record, 28, 5
'CHAIN,
$ift s_clinecommand = "CHAIN"
$cut s_any, s_record, 54, 2
$ist d_any, s_any, "9"
dift d_any <> 1
sg_pass1 = "error=CHAIN"
sub_error
endi
endi
'SETON,SETOF,COMP ,
$lok d_any, s_commands1, 1, s_clinecommand
dift d_any > 0
$cut s_any, s_record, 54, 6
$isc d_any, s_any, " "
dift d_any = 1
sg_pass1 = "error=" + s_commands1
sub_error
endi
endi
'LOKUP,FNDJW,SETJW,READ ,READP,LOCK ,UNLCK,
$lok d_any, s_commands2, 1, s_clinecommand
dift d_any > 0
$cut s_any, s_record, 58, 2
$ist d_any, s_any, "9"
dift d_any <> 1
sg_pass1 = "error=" + s_commands2
sub_error
endi
endi
endi
$ift s_6code = "O"
'output indicators
'oline 1 2 3 4 5 6
'123456789012345678901234567890123456789012345678901234567890
' .O 01 02 03VARIABJB 132 "HEADING LINE "
$cut sg_pass1, s_record, 23, 3
dg_pass1 = 3
sub_rpg_valid_indicators_proc
$cut sg_pass1, s_record, 26, 3
dg_pass1 = 3
sub_rpg_valid_indicators_proc
$cut sg_pass1, s_record, 29, 3
dg_pass1 = 3
sub_rpg_valid_indicators_proc
endi
endw
'make sure all indicators used are set somewhere
$len d_long, sg_indicatuse
d_byte = 1
dwhi d_byte < d_long
$cut s_dot, sg_indicatuse, d_byte, 1
$lok d_dot, sg_indicatset, 1, s_dot
dift d_dot = 0: $out "undefined indicator=" + s_dot
d_byte = d_byte + 3
endw
'indicator LR should be set somewhere ig_LR which is 1 or 2
$lok d_any, sg_indicatset, 1, "LR"
dift d_any = 0: $out "no LR indicator set"
dift dg_tdebug = 1
'show the indicators
$sor s_dot, sg_indicatuse, 3
d_dot = 1
dwhi d_dot <= d_long
$cut s_any, s_dot, d_dot, 72
$out s_any
d_dot = d_dot + 72
endw
endi
d_any = d_long \ 3
$out "indicators set/used=" + d_any
$sys sg_subroutine, 2
dift dg_tdebug = 1
sg_pass1 = sg_subroutine
sub_return
endi
ends sub_rpg_valid_indicators
subr sub_rpg_valid_indicators_proc
'updated 2004/03/30
'validate indicators in sg_pass1
'sg_pass1 is 2 or 3 long
'dg_pass1=1 means indicator, 2=none, 3=maybe
vari s_any, d_any, s_dot, d_dot, s_tap, s_out
vari s_indicat, s_num, d_long, d_error, d_yesnomaybe
s_indicat = sg_pass1
d_yesnomaybe = dg_pass1
'beg dg_errnumber,d_error,1300
d_error = 0
$trb s_any, s_indicat
$len d_long, s_any
dift d_yesnomaybe = 1
'yes we must have an indicator
dift d_long <> 2
dift d_long <> 3: d_error = 1301
endi
endi
dift d_yesnomaybe = 2
'no we must not have an indicator
dift d_long <> 0: d_error = 1302
endi
dift d_yesnomaybe = 3
'maybe we have an indicator
d_any = 2
dift d_long = 0: d_any = 1
dift d_long = 2: d_any = 1
dift d_long = 3: d_any = 1
dift d_any <> 1: d_error = 1303
endi
dift d_error > 0: d_long = 0
dift d_long > 0
$len d_long, s_indicat
dift d_long = 3
'we have a use indicator
$cut s_any, s_indicat, 1, 1
s_tap = " N"
$lok d_any, s_tap, 1, s_any
dift d_any = 0: d_error = 1304
$cut s_num, s_indicat, 2, 2
$ist d_any, s_num, "9"
dift d_any <> 1: d_error = 1305
dift d_error = 0
$lok d_dot, sg_indicatuse, 1, s_num
dift d_dot = 0: $app sg_indicatuse, s_num + ","
endi
endi
dift d_long = 2
'we have a set indicator
$ist d_any, s_indicat, "9"
dift d_any <> 1
$ift s_indicat <> "LR": d_error = 1306
endi
dift d_error = 0
$lok d_dot, sg_indicatuse, 1, s_indicat
dift d_dot = 0
$app sg_indicatset, s_indicat + ","
endi
endi
endi
endi
dift d_error > 0
'end dg_errnumber,d_error,1300
dg_errnumber = d_error
dift d_yesnomaybe = 1
sg_pass1 = "bad or missing indicator=" + s_indicat
sub_error
endi
dift d_yesnomaybe = 2
sg_pass1 = "bad or improper indicator=" + s_indicat
sub_error
endi
dift d_yesnomaybe = 3
sg_pass1 = "bad or improper indicator=" + s_indicat
sub_error
endi
endi
ends sub_rpg_valid_indicators_proc
subr sub_rpg_valid_varsize_strings
'updated 2003/11/30
'validate global variables in sg_rpgvarnames,sg_rpgvarsizes
'to see if each varname has a valid varsize
vari s_any, d_any, s_dot, d_dot, s_out
vari s_varname, s_varsize, d_byte, d_loop, d_long
vari d_varnumct, d_varalphact, d_arraynumct, d_arrayalphact
vari s_fromsubr, d_count, d_vartype, d_varindexct
$sys sg_subroutine, 2
s_fromsubr = sg_subroutine
dift dg_tdebug = 1
sg_pass1 = sg_subroutine
sub_return
endi
d_varnumct = 0
d_varalphact = 0
d_arraynumct = 0
d_arrayalphact = 0
$len d_long, sg_rpgvarsizes
d_count = 0
d_byte = 1
d_loop = 1
dwhi d_loop = 1
$sho s_fromsubr + "=" + d_count
$cut s_varsize, sg_rpgvarsizes, d_byte, 9
$trb s_any, s_varsize
'test for length=9
$len d_any, s_any
dift d_any <> 9: d_any = 0
'test for numeric
$ch$ s_dot, "9", 9
dift d_any = 9: $isp d_any, s_any, s_dot
dift d_any <> 1
$cut s_varname, sg_rpgvarnames, d_byte, 9
sg_pass1 = "undefined='" + s_varname
$app sg_pass1, "', size='" + s_varsize + "'"
sub_error
else
'123456789 sg_rpgvarnames 9 long
'abbbbcccd sg_rpgvarsizes 9 long
'a = d_vartype: 1=numeric,2=numeric array,6=alpha,7=alpha array
'bbbb = d_varindexct: index count
'ccc = d_varlongct: length
'd = d_vardecimalct: decimals
'counts
dinc d_count
$cut s_any, s_varsize, 1, 1
$tod d_vartype, s_any
dift d_vartype = 1: dinc d_varnumct
dift d_vartype = 2: dinc d_arraynumct
dift d_vartype = 6: dinc d_varalphact
dift d_vartype = 7: dinc d_arrayalphact
endi
'9 long with commas between
d_byte = d_byte + 10
dift d_byte > d_long: dinc d_loop
endw
$out s_fromsubr + "=" + d_count
$out "ct varnumeric =" + d_varnumct
$out "ct varalpha =" + d_varalphact
$out "ct arraynumeric=" + d_arraynumct
$out "ct arrayalpha =" + d_arrayalphact
$sys sg_subroutine, 2
dift dg_tdebug = 1
sg_pass1 = sg_subroutine
sub_return
endi
ends sub_rpg_valid_varsize_strings
subr sub_rpg_valid_format
'updated 2004/12/23
'validate formats of rpg lines
'we have fileinfo, variable info, indicator info already
vari s_any, d_any, s_dot, d_dot, s_out
vari s_record, d_loop, d_good, s_code, s_fromsubr
$sys sg_subroutine, 2
s_fromsubr = sg_subroutine
dift dg_tdebug = 1
sg_pass1 = sg_subroutine
sub_return
endi
dg_record = 0
d_loop = 1
dwhi d_loop = 1
d_good = 1
sg_pass1 = s_fromsubr
sub_rpg_read_record
s_record = sg_pass1
dift dg_record = 0
dinc d_good
dinc d_loop
endi
dift d_good = 1
'we have records to examine
$cut s_code, s_record, 6, 1
$ift s_code = "C"
sg_pass1 = s_record
sub_rpg_valid_format_cline
endi
$ift s_code = "O"
sg_pass1 = s_record
sub_rpg_valid_format_oline
endi
endi
endw
$sys sg_subroutine, 2
dift dg_tdebug = 1
sg_pass1 = sg_subroutine
sub_return
endi
ends sub_rpg_valid_format
subr sub_rpg_valid_format_cline
'updated 2005/04/03, 2005/01/18, 2004/12/23
'validate the format of a cline
vari s_any, d_any, s_dot, d_dot, s_tap, s_out
vari s_record, d_process, d_good, d_error, s_code
vari s_indicators1, s_factor1, s_command, s_factor2
vari s_result, s_indicators2
vari d_fieldtype1, d_fieldtype2, d_fieldtype3
vari s_fieldtype1, s_fieldtype2, s_fieldtype3
vari s_fieldlett1, s_fieldlett2, s_fieldlett3
vari d_indextype1, d_indextype2, d_indextype3
vari d_indexct1, d_indexct2, d_indexct3
vari d_longct1, d_longct2, d_longct3
vari s_blanks6, s_alpha
s_record = sg_pass1
$sys sg_subroutine, 2
'cline 1 2 3 4 5 6
'123456789012345678901234567890123456789012345678901234567890
' .CSR 01 02 03FACTOR1 COMMDFACTOR2 RESULT 92H919293
'beg dg_errnumber,d_error,3000
d_error = 0
d_process = 1
$ch$ s_blanks6, " ", 6
s_alpha = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
'get the parts
$cut s_code, s_record, 6, 3
$cut s_indicators1, s_record, 9, 9
$cut s_factor1, s_record, 18, 10
$cut s_command, s_record, 28, 5
$cut s_factor2, s_record, 33, 10
$cut s_result, s_record, 43, 6
$cut s_indicators2, s_record, 54, 6
'validate s_code
s_any = s_code + ","
s_tap = "C ,CSR,"
$lok d_any, s_tap, 1, s_any
dift d_any = 0
d_error = 3001
dinc d_process
endi
'skip next if certain commands that only have
'file names or tags not fields
s_tap = "TAG ,GOTO ,EXSR ,BEGSR,ENDSR,EXCPT,"
$app s_tap, "READ ,READP,LOCK ,UNLCK"
$lok d_dot, s_tap, 1, s_command
dift d_dot > 0: dinc d_process
'blank the file names which are validated elsewhere
$ift s_command = "SETLL": $ch$ s_factor2, " ", 10
$ift s_command = "CHAIN": $ch$ s_factor2, " ", 10
'd_fieldtype
'1=error A
'2=blank B
'6=*BLANK F
'7=*ZEROS G
'8=UDATE
'11=numeric literal K
'12=numeric var L
'13=numeric array with index M
'14=numeric array no index N
'21=alpha literal U
'22=alpha var V
'23=alpha array with index W
'24=alpha array no index X
dift d_process = 1
'what types are the three variables
sg_pass1 = s_factor1
sub_field_info_return
d_fieldtype1 = dg_pass1
d_indextype1 = dg_pass2
d_indexct1 = dg_pass3
d_longct1 = dg_pass4
s_fieldtype1 = sg_pass3
$cut s_fieldlett1, s_alpha, d_fieldtype1, 1
sg_pass1 = s_factor2
sub_field_info_return
d_fieldtype2 = dg_pass1
d_indextype2 = dg_pass2
d_indexct2 = dg_pass3
d_longct2 = dg_pass4
s_fieldtype2 = sg_pass3
$cut s_fieldlett2, s_alpha, d_fieldtype2, 1
sg_pass1 = s_result
sub_field_info_return
d_fieldtype3 = dg_pass1
d_indextype3 = dg_pass2
d_indexct3 = dg_pass3
d_longct3 = dg_pass4
s_fieldtype3 = sg_pass3
$cut s_fieldlett3, s_alpha, d_fieldtype3, 1
'dg_tdebug
dift dg_tdebug = 1
$out s_record
s_any = s_fieldtype1 + "," + s_fieldtype2
$app s_any, "," + s_fieldtype3
$inp s_any, s_any
endi
endi
'd_fieldtype
'1=error A
'2=blank B
'6=*BLANK F
'7=*ZEROS G
'8=UDATE
'11=numeric literal K
'12=numeric var L
'13=numeric array with index M
'14=numeric array no index N
'21=alpha literal U
'22=alpha var V
'23=alpha array with index W
'24=alpha array no index X
'd_kind=1 numeric
'd_kind=2 alpha
dift d_process = 1
'valid_seton,valid_setof
s_tap = "SETON,SETOF"
$lok d_dot, s_tap, 1, s_command
dift d_dot > 0
d_any = d_fieldtype1 + d_fieldtype2 + d_fieldtype3
dift d_any <> 6: d_error = 3002
dinc d_process
endi
endi
dift d_process = 1
'do we have a math command
'valid_add,valid_sub,valid_mult,valid_div
s_tap = "ADD ,SUB ,MULT ,DIV ,"
$lok d_dot, s_tap, 1, s_command
dift d_dot > 0
'blank,numeric literal,numeric,numeric array & index
s_tap = "BKLM"
$lok d_any, s_tap, 1, s_fieldlett1
dift d_any = 0: d_error = 3003
'numeric literal,numeric,numeric array & index
s_tap = "KLM"
$lok d_any, s_tap, 1, s_fieldlett2
dift d_any = 0: d_error = 3004
'numeric,numeric array & index
s_tap = "LM"
$lok d_any, s_tap, 1, s_fieldlett3
dift d_any = 0: d_error = 3005
'cannot have result indicators
$ift s_indicators2 <> s_blanks6: d_error = 3006
dinc d_process
endi
endi
dift d_process = 1
'do we have a numeric result only command
'valid_mvr,valid_time
s_tap = "MVR ,TIME ,"
$lok d_dot, s_tap, 1, s_command
dift d_dot > 0
'blank only
$ift s_fieldlett1 <> "B": d_error = 3007
'blank only
$ift s_fieldlett2 <> "B": d_error = 3008
'numeric,numeric array & index
s_tap = "LM"
$lok d_any, s_tap, 1, s_fieldlett3
dift d_any = 0: d_error = 3009
'cannot have result indicators
$ift s_indicators2 <> s_blanks6: d_error = 3010
dinc d_process
endi
endi
dift d_process = 1
'do we have a math command
'valid_z-add,valid_z-sub
s_tap = "Z-ADD,Z-SUB,"
$lok d_dot, s_tap, 1, s_command
dift d_dot > 0
'blank
$ift s_fieldlett1 <> "B": d_error = 3011
'numeric literal,numeric,numeric array & index
s_tap = "KLM"
$lok d_any, s_tap, 1, s_fieldlett2
dift d_any = 0: d_error = 3012
'numeric,numeric array & index,numeric array no index
s_tap = "LMN"
$lok d_any, s_tap, 1, s_fieldlett3
dift d_any = 0: d_error = 3013
'cannot have result indicators
$ift s_indicators2 <> s_blanks6: d_error = 3014
dinc d_process
endi
'valid_sqrt
$ift s_command = "SQRT "
'blank
$ift s_fieldlett1 <> "B": d_error = 3015
'numeric literal,numeric,numeric array & index
s_tap = "KLM"
$lok d_any, s_tap, 1, s_fieldlett2
dift d_any = 0: d_error = 3016
'numeric,numeric array & index
s_tap = "LM"
$lok d_any, s_tap, 1, s_fieldlett3
dift d_any = 0: d_error = 3017
'cannot have result indicators
$ift s_indicators2 <> s_blanks6: d_error = 3018
dinc d_process
endi
$ift s_command = "XFOOT"
'valid_xfoot
$ift s_fieldlett1 <> "B": d_error = 3019
'numeric array no index
$ift s_fieldlett2 <> "N": d_error = 3020
'numeric variable only
$ift s_fieldlett3 <> "L": d_error = 3021
'cannot have result indicators
$ift s_indicators2 <> s_blanks6: d_error = 3022
dinc d_process
endi
endi
'd_fieldtype
'1=error A
'2=blank B
'6=*BLANK F
'7=*ZEROS G
'8=UDATE
'11=numeric literal K
'12=numeric var L
'13=numeric array with index M
'14=numeric array no index N
'21=alpha literal U
'22=alpha var V
'23=alpha array with index W
'24=alpha array no index X
dift d_process = 1
'do we have a move command
s_tap = "MOVE ,MOVEL,MOVEA"
$lok d_dot, s_tap, 1, s_command
dift d_dot > 0
's_fieldlett1 = "B" means blank
$ift s_fieldlett1 <> "B": d_error = 3023
dift d_dot = 1
'valid_MOVE_right
s_tap = "FGLUV"
$lok d_any, s_tap, 1, s_fieldlett2
dift d_any = 0: d_error = 3024
s_tap = "LVX"
$lok d_any, s_tap, 1, s_fieldlett3
dift d_any = 0: d_error = 3025
$ift s_fieldlett3 = "X"
'can only do move into byte array
dift d_longct3 <> 1: d_error = 3026
endi
$ift s_fieldlett3 = "L"
'can not move *BLANK,*ZEROS into numeric
$ift s_fieldlett2 = "F": d_error = 3027
$ift s_fieldlett2 = "G": d_error = 3028
endi
endi
dift d_dot = 7
'valid_MOVEL
s_tap = "LUV"
$lok d_any, s_tap, 1, s_fieldlett2
dift d_any = 0: d_error = 3029
s_tap = "LV"
$lok d_any, s_tap, 1, s_fieldlett3
dift d_any = 0: d_error = 3030
endi
dift d_dot = 13
'valid_MOVEA
s_tap = "FGUVWX"
$lok d_any, s_tap, 1, s_fieldlett2
dift d_any = 0: d_error = 3031
s_tap = "VWX"
$lok d_any, s_tap, 1, s_fieldlett3
dift d_any = 0: d_error = 3032
endi
dinc d_process
endi
endi
'd_fieldtype, s_fieldlett
'1=error A
'2=blank B
'6=*BLANK F
'7=*ZEROS G
'8=UDATE
'11=numeric literal K
'12=numeric var L
'13=numeric array with index M
'14=numeric array no index N
'21=alpha literal U
'22=alpha var V
'23=alpha array with index W
'24=alpha array no index X
dift d_process = 1
$ift s_command = "COMP "
'valid_comp
's_fieldlett3 must be B
$ift s_fieldlett3 <> "B": d_error = 3033
'do we have a numeric compare
d_good = 2
s_tap = "KLM"
$lok d_dot, s_tap, 1, s_fieldlett1
$lok d_any, s_tap, 1, s_fieldlett2
dift d_dot > 0
dift d_any > 0: d_good = 1
endi
'do we have an alpha compare
s_tap = "FGUVW"
$lok d_dot, s_tap, 1, s_fieldlett1
$lok d_any, s_tap, 1, s_fieldlett2
'cannot both be *BLANK=F
dift d_dot = 1
dift d_any = 1: d_error = 3034
endi
dift d_dot > 0
dift d_any > 0
'if either is *BLANK then lengths are same
$ift s_fieldlett1 = "F": d_longct1 = d_longct2
$ift s_fieldlett2 = "F": d_longct2 = d_longct1
'alpha must have the same length
dift d_longct1 = d_longct2: d_good = 1
endi
endi
dift d_good <> 1: d_error = 3035
dinc d_process
endi
endi
dift d_process = 1
$ift s_command = "LOKUP"
'valid_lokup
'field1=alpha literal,variable,array with index
s_tap = "UVW"
$lok d_dot, s_tap, 1, s_fieldlett1
dift d_dot > 0
'alpha lokup
'field2=array with index,array no index
s_tap = "WX"
$lok d_dot, s_tap, 1, s_fieldlett2
dift d_dot = 0: d_error = 3036
'lengths must be the same
dift d_longct1 <> d_longct2: d_error = 3037
$ift s_fieldlett2 = "W"
'array index must be a numeric variable
dift d_indextype2 <> 12: d_error = 3038
'field3 must be blank
$ift s_fieldlett3 <> "B": d_error = 3039
else
'no index for field2
'do we have a table look up
$cut s_any, s_factor2, 1, 3
$ift s_any = "TAB"
'table look up
$cut s_any, s_result, 1, 3
$ift s_any <> "TAB": d_error = 3040
'are these table fields connected
$cut s_any, s_factor2, 1, 6
$lok d_any, sg_rpgtabnames1, 1, s_any
$cut s_dot, sg_rpgtabnames2, d_any, 6
$ift s_dot <> s_result: d_error = 3041
else
'not table, field3 must be blank
$ift s_fieldlett3 <> "B": d_error = 3042
endi
endi
else
'numeric lokup
'numeric literal,variable,array with index
s_tap = "KLM"
$lok d_dot, s_tap, 1, s_fieldlett1
dift d_dot = 0: d_error = 3043
'numeric array,array with index
s_tap = "MN"
$lok d_dot, s_tap, 1, s_fieldlett2
dift d_dot = 0: d_error = 3044
$ift s_fieldlett2 = "M"
'array index must be a numeric variable
dift d_indextype2 <> 12: d_error = 3045
endi
$ift s_fieldlett3 <> "B": d_error = 3046
endi
'must have indicator in 58
$off s_any, s_indicators2, 2
$isd d_any, s_any
dift d_any <> 1: d_error = 3047
dinc d_process
endi
endi
dift d_process = 1
$ift s_command = "PUTJW"
'valid_putjw
s_tap = "KLM"
$lok d_dot, s_tap, 1, s_fieldlett1
dift d_dot = 0: d_error = 3048
$ift s_fieldlett2 <> "U": d_error = 3049
$ift s_fieldlett3 <> "B": d_error = 3050
$off s_any, s_indicators2, 2
$isd d_any, s_any
dift d_any <> 1: d_error = 3051
dinc d_process
endi
$ift s_command = "FNDJW"
'valid_fndjw
$ift s_fieldlett1 <> "B": d_error = 3052
$ift s_fieldlett2 <> "U": d_error = 3053
s_tap = "LM"
$lok d_dot, s_tap, 1, s_fieldlett3
dift d_dot = 0: d_error = 3054
$off s_any, s_indicators2, 2
$isd d_any, s_any
dift d_any <> 1: d_error = 3055
dinc d_process
endi
$ift s_command = "TESTN"
'valid_testn
$ift s_fieldlett1 <> "B": d_error = 3056
$ift s_fieldlett2 <> "B": d_error = 3057
'must be alpha var
$ift s_fieldlett3 <> "V": d_error = 3058
$trb s_any, s_indicators2
$isd d_any, s_any
dift d_any <> 1: d_error = 3059
dinc d_process
endi
$ift s_command = "TIME "
'valid_time
$ift s_fieldlett1 <> "B": d_error = 3060
$ift s_fieldlett2 <> "B": d_error = 3061
s_tap = "LM"
$lok d_dot, s_tap, 1, s_fieldlett3
dift d_dot = 0: d_error = 3062
$isc d_any, s_indicators2, " "
dift d_any <> 1: d_error = 3063
dinc d_process
endi
$ift s_command = "TIME2"
'valid_time2
$ift s_fieldlett1 <> "B": d_error = 3064
$trr s_any, s_factor2
$ift s_any <> "1": d_error = 3065
$ift s_fieldlett3 <> "V": d_error = 3066
$isc d_any, s_indicators2, " "
dift d_any <> 1: d_error = 3067
dinc d_process
endi
$ift s_command = "SORTA"
'valid_sorta
$ift s_fieldlett1 <> "B": d_error = 3068
'only alpha or numeric array with no index
s_tap = "NX"
$lok d_any, s_tap, 1, s_fieldlett2
dift d_any = 0: d_error = 3069
$ift s_fieldlett3 <> "B": d_error = 3070
$isc d_any, s_indicators2, " "
dift d_any <> 1: d_error = 3071
dinc d_process
endi
endi
dift d_process = 1
s_tap = "BITOF,BITON"
$lok d_any, s_tap, 1, s_command
dift d_any > 0
'valid_biton,valid_bitof
$ift s_fieldlett1 <> "B": d_error = 3072
$ift s_fieldlett2 <> "U"
$ift s_fieldlett2 <> "V": d_error = 3073
endi
$ift s_fieldlett3 <> "V": d_error = 3074
$isc d_any, s_indicators2, " "
dift d_any <> 1: d_error = 3075
dinc d_process
endi
endi
dift d_process = 1
$ift s_command = "SETLL"
'valid_setll
'factor1 must be alpha
s_tap = "UVW"
$lok d_dot, s_tap, 1, s_fieldlett1
dift d_dot = 0: d_error = 3076
dinc d_process
endi
$ift s_command = "CHAIN"
'valid_chain
'factor1 must be numeric
s_tap = "KL"
$lok d_dot, s_tap, 1, s_fieldlett1
dift d_dot = 0: d_error = 3077
dinc d_process
endi
endi
'command not found
dift d_process = 1: d_error = 3099
dift d_error > 0
s_out = "1" + "=" + s_fieldlett1 + "=" + s_fieldtype1
$app s_out, ",long=" + d_longct1
$out s_out
s_out = "2" + "=" + s_fieldlett2 + "=" + s_fieldtype2
$app s_out, ",long=" + d_longct2
$out s_out
s_out = "3" + "=" + s_fieldlett3 + "=" + s_fieldtype3
$app s_out, ",long=" + d_longct3
$out s_out
'end dg_errnumber,d_error,3000
dg_errnumber = d_error
sg_pass1 = "bad rpg_valid_format"
sub_error
endi
ends sub_rpg_valid_format_cline
subr sub_rpg_valid_format_oline
'updated 2005/01/09
vari s_any, d_any, s_dot, d_dot
vari s_record, d_process, d_error, d_floatingdollar
vari s_field1, s_field2, d_field1, d_field2
'oline 1 2 3 4 5 6
'123456789012345678901234567890123456789012345678901234567890
' .OFILENAMEE 12 01 02 03OLINE
' .O E 01 02 03VARIABJB 132 "HEADING LINE "
s_record = sg_pass1
'beg dg_errnumber,d_error,1400
d_error = 0
d_process = 1
d_floatingdollar = 2
'skip if file name begins in 7
$cut s_any, s_record, 7, 8
$isc d_any, s_any, " "
dift d_any <> 1: dinc d_process
dift d_process = 1
$cut s_field1, s_record, 32, 6
$cut s_field2, s_record, 45, 26
'do we have a floating dollar literal
$trb s_any, s_field2
$ift s_any = #"$"#: d_floatingdollar = 1
$isc d_field1, s_field1, " "
$isc d_field2, s_field2, " "
'only one can be 1
dift d_field1 = 1
'field1 is blank
dift d_field2 = 1
'field2 is also blank
d_error = 1401
dinc d_process
endi
else
'field1 is not blank
dift d_field2 <> 1
'if both d_floatingdollar must be 1
dift d_floatingdollar <> 1
d_error = 1402
dinc d_process
endi
endi
endi
endi
dift d_process = 1
dift d_field2 <> 1
'validate literal field in output
$trr s_field2, s_field2
$off s_any, s_field2, 1
$ift s_any <> #"#: d_error = 1403
$cut s_any, s_field2, 1, 1
$ift s_any <> #"#: d_error = 1404
dift d_floatingdollar <> 1: dinc d_process
endi
endi
'd_fieldtype
'1=error A
'2=blank B
'6=*BLANK
'7=*ZEROS
'8=UDATE
'11=numeric literal K
'12=numeric var L
'13=numeric array with index M
'14=numeric array no index N
'21=alpha literal U
'22=alpha var V
'23=alpha array with index W
'24=alpha array no index X
dift d_process = 1
$trb s_field1, s_field1
$ift s_field1 = "UDATE"
dinc d_process
dift d_floatingdollar = 1: d_error = 1405
endi
endi
dift d_process = 1
'what type is s_field1
sg_pass1 = s_field1
sub_field_info_return
d_field1 = dg_pass1
d_dot = 0
dift d_field1 = 12: d_dot = 1
dift d_field1 = 13: d_dot = 1
dift d_dot <> 1
'field1 is not numeric
dift d_floatingdollar = 1: d_error = 1406
endi
endi
dift d_error > 0
'end dg_errnumber,d_error,1400
dg_errnumber = d_error
sg_pass1 = "bad rpg_valid_format"
sub_error
endi
ends sub_rpg_valid_format_oline
subr sub_rpg_read_record
'updated 2005/01/15, 2003/11/18
'read record at dg_filebyte from sg_inpfile into sg_record
'to begin set dg_record = 0
'this sets dg_record = 0 when none read or at bottome arrays
vari s_any, d_any, s_dot, d_dot, s_out
vari d_loop, d_good, d_count, s_record, s_fromsubr
s_fromsubr = sg_pass1
dift dg_record = 0: dg_filebyte = 1
d_loop = 1
dwhi d_loop = 1
d_good = 1
fsip s_record, sg_inpfile, dg_filebyte
dift dg_filebyte = 0
$out s_fromsubr + "=" + dg_record
dg_record = 0
dinc d_good
dinc d_loop
endi
dift d_good = 1
dinc dg_record
dg_rpglinenumber = dg_record
d_any = dg_record % 1000
dift d_any = 0: $sho s_fromsubr + "=" + dg_record
'make sure the record is 80 long
$ch$ s_any, " ", 80
$app s_record, s_any
$cut s_record, s_record, 1, 80
'store the line in the queue
sg_pass1 = dg_record + " " + s_record
sub_queue
'end if at bottom arrays
$cut s_any, s_record, 1, 1
$ift s_any = "*"
$out s_fromsubr + "=" + dg_record
dg_record = 0
dinc d_good
dinc d_loop
endi
'drop out if not comment record
$cut s_any, s_record, 7, 1
$ift s_any <> "*": dinc d_loop
endi
endw
sg_pass1 = s_record
ends sub_rpg_read_record
subr sub_csv_out
'updated 2003/11/18
'output to term elements of csv record
vari s_any, d_any, s_dot, d_dot, s_out
vari s_csv, d_loop, d_count, s_fromsubr
s_csv = sg_pass1
$sys s_fromsubr, 2
d_count = 0
s_out = sg_nothing
d_loop = 1
dwhi d_loop = 1
$lok d_any, s_csv, 1, ","
dift d_any > 0
$cut s_any, s_csv, 1, d_any
$app s_out, s_any
dinc d_any
$cut s_csv, s_csv, d_any, 99999
dinc d_count
else
$len d_any, s_csv
dift d_any > 0: dinc d_count
$app s_out, s_csv
s_csv = sg_nothing
endi
$len d_any, s_out
dift d_any > 60
$out s_out
s_out = sg_nothing
endi
$len d_any, s_csv
dift d_any = 0
$len d_any, s_out
dift d_any > 0: $out s_out
dinc d_loop
endi
endw
$out s_fromsubr + "=" + d_count
ends sub_csv_out
subr sub_queue
'updated 2005/04/03, 2003/09/19
'queue the program lines to be able to show if error
vari s_any, d_any, s_dot, d_dot, s_out
vari s_line
s_line = sg_pass1
$len d_any, s_line
dift d_any = 0
'show lines in queue array 1/10
d_dot = 1
dwhi d_dot <= 1000
$cut s_out, sg_queue, d_dot, 80
$out s_out
d_dot = d_dot + 80
endw
else
'add s_line to queue sg_queue
$ch$ s_any, " ", 90
$app s_line, s_any
$cut s_line, s_line, 1, 80
$app sg_queue, s_line
$len d_any, sg_queue
dift d_any > 900: $cut sg_queue, sg_queue, 81, 99999
endi
ends sub_queue
subr sub_return
'updated 2003/06/21
vari s_any, d_any, s_dot, d_dot, s_out
$out sg_pass1
$inp s_any, "tdebug toggles tdebug, * to end"
$ift s_any = "*": dinc dg_process
$ift s_any = "tdebug"
dift dg_tdebug = 1
dinc dg_tdebug
else
dg_tdebug = 1
endi
endi
ends sub_return
subr sub_error
'updated 2006/11/01, 2006/04/25, 2005/04/03, 2004/12/23
vari s_any, d_any, s_dot, d_dot, s_out
vari s_error
dift dg_showerror = 1
s_error = sg_pass1
'show the last ten lines
sg_pass1 = sg_nothing
sub_queue
$out s_error
s_out = "in subroutine=" + sg_subroutine
$app s_out, ", record=" + dg_record
$app s_out, ", errnumber=" + dg_errnumber
$out s_out
fapp d_any, "rpgtoc.log", s_out
dg_error = 1
sub_variable_lookup
dinc dg_process
endi
ends sub_error
subr sub_c_lineout
'updated 2007/06/17, 2005/07/06, 2005/07/01, 2005/04/29, 2004/02/22
vari s_any, d_any, s_dot, d_dot, s_out, d_out
vari d_delta, s_crlf, s_char10
s_out = sg_pass1
dch$ s_char10, 10, 1
dch$ s_crlf, 13, 1
$app s_crlf, s_char10
$trb s_out, s_out
$len d_any, s_out
dift d_any > 0
$cut s_any, s_out, 1, 2
$ift s_any = "/*"
dinc dg_ccommentcount
else
dinc dg_clinecount
endi
endi
'begin dg_indent stuff
'do we have a begin block { or an end block }
d_delta = 0
$cut s_any, s_out, 1, 1
$ift s_any = "}": dg_indent = dg_indent - 4
$off s_any, s_out, 1
$ift s_any = "{": d_delta = 4
dift dg_indent < 0: dg_indent = 0
$ch$ s_any, " ", dg_indent
s_out = s_any + s_out
$trr s_out, s_out
dg_indent = dg_indent + d_delta
dift dg_indent < 0: dg_indent = 0
'end of dg_indent stuff
flen d_out, sg_outfile
dinc d_out
'dg_operatingsystem:1=MPE,2=Unix,3=C90
dift dg_operatingsystem = 1
$app s_out, s_crlf
else
$app s_out, s_char10
endi
fwri d_any, sg_outfile, d_out, s_out
dift d_any = 0
$len d_any, s_out
$out "rec long=" + d_any
$out s_out
$out "above record not written to file"
$out "file=" + sg_outfile + " byte=" + d_out
$inp s_any, "program must end"
endp
endi
ends sub_c_lineout
subr sub_c_blankline
'updated 2003/09/18
sg_pass1 = sg_nothing
sub_c_lineout
ends sub_c_blankline
subr sub_c_arrayout
'updated 2004/03/04
'output to sg_outfile from array
vari s_any, d_any, s_dot, d_dot, s_out
vari d_index, d_loop, d_yespreviousblank
d_yespreviousblank = 2
d_index = 1
d_loop = 1
dwhi d_loop = 1
ito$ s_out, d_index
$trb s_out, s_out
$len d_any, s_out
dift d_any > 0
'non-blank element
sg_pass1 = s_out
sub_c_lineout
dinc d_yespreviousblank
else
'blank element
dift d_yespreviousblank <> 1: sub_c_blankline
d_yespreviousblank = 1
endi
dinc d_index
dift d_index > 2000: dinc d_loop
endw
'blank the string array
arrb
ends sub_c_arrayout
subr sub_take_off_leading_zeros
'updated 2005/01/02
'change -001.7 to -1.7
vari s_any, d_any, s_dot, d_dot
vari s_number, s_sign
s_number = sg_pass1
$trb s_number, s_number
'put the sign in s_sign
$cut s_any, s_number, 1, 1
s_sign = sg_nothing
d_any = 2
$ift s_any = "-": d_any = 1
$ift s_any = "+": d_any = 1
dift d_any = 1
s_sign = s_any
$cut s_number, s_number, 2, 9999
endi
'no take off leading zeros
d_dot = 1
dwhi d_dot = 1
$cut s_any, s_number, 1, 1
$ift s_any = "0"
$cut s_number, s_number, 2, 9999
else
dinc d_dot
endi
endw
sg_pass1 = s_sign + s_number
ends sub_take_off_leading_zeros
subr sub_right_trim_spaces_only
'updated 2005/01/19
vari s_any, d_any, s_dot, d_dot, s_out
vari s_string
s_string = sg_pass1
$len d_dot, s_string
dwhi d_dot > 0
$off s_dot, s_string, 1
$ift s_dot = " "
ddec d_dot
$cut s_string, s_string, 1, d_dot
else
d_dot = - 9999
endi
endw
sg_pass1 = s_string
ends sub_right_trim_spaces_only
subr sub_c_create
'updated 2004/08/09
'create the c program
vari s_any, d_any, s_dot, d_dot, s_out
$sys sg_subroutine, 2
dift dg_tdebug = 1
sg_pass1 = sg_subroutine
sub_return
endi
'delete the output c file
fdel d_any, sg_outfile
dg_clinecount = 0
dg_ccommentcount = 0
'headers
sub_c_headers
'global variable declarations
sub_c_global_c_variables
sub_c_global_rpg_variables
sub_c_global_rpg_indicators
sub_c_global_file_variables
'prototypes
sub_c_prototypes_open_read_write_close_files
sub_c_prototypes_input
sub_c_prototypes_begsr
sub_c_prototypes_excpt
sub_c_prototypes_tsub
sub_c_prototypes_rpg_commands
sub_crpg_prototypes
'make main subroutine
sub_c_subroutines_main
'make input subroutines
sub_c_subroutines_input
'make open files subroutine
sub_c_subroutine_open_files
sub_c_subroutine_read_files
sub_c_subroutine_write_files
sub_c_subroutine_close_files
'make subroutine to initialize strings
sub_c_initialize_strings
'make subroutine to initialize at bottom strings
sub_c_initialize_arrays_from_bottom
'utility t funtions/subs
sub_c_subroutines_tsub1
sub_c_subroutines_tsub2
sub_c_subroutines_tsub3
sub_c_subroutines_tsub4
sub_c_subroutines_tsub5
'rpg command subroutines
sub_c_subroutines_rpg_commands
sub_crpg_subroutines
'rpg program subroutines
sub_c_cline_commands
'rpg program output
sub_c_olines
$out "bad commands:"
$sor sg_pass1, sg_badcommands, 6
sub_csv_out
$out "good commands:"
$sor sg_pass1, sg_goodcommands, 6
sub_csv_out
'output ending line of program
sg_pass1 = sg_slashaster + "program = " + sg_inpfile
$dat s_dot
$app sg_pass1, ", " + s_dot + sg_asterslash
sub_c_lineout
'output to term some info
s_any = "program=" + sg_outfile
$app s_any, ", c lines=" + dg_clinecount
$app s_any, ", c comments=" + dg_ccommentcount
$out s_any
ends sub_c_create
subr sub_c_headers
'updated 2005/04/09, 2004/12/30
'output c program header records to sg_outfile
vari s_any, d_any, s_dot, d_dot, s_out
dift dg_tdebug = 1
$sys s_any, 2
sg_pass1 = s_any
sub_return
endi
'dg_progkind values
'10=input demand
'20=input chain
'30=update demand
'40=input ksam
'50=update ksam
'60=screen
'blank the array
arrb
s_out = sg_slashaster + "program = " + sg_inpfile
$dat s_dot
$app s_out, ", " + s_dot + sg_asterslash
$toi 101, s_out
'dg_operatingsystem:1=MPE,2=Unix/Linux,3=C90 only
s_out = "/* for the MPE operating system */"
dift dg_operatingsystem = 2
s_out = "/* for the Unix/Linux operating system */"
endi
dift dg_operatingsystem = 3
s_out = "/* for the C90 only operating system */"
endi
$toi 111, s_out
$toi 121, "/* headers */"
$toi 122, "#include "
$toi 123, "#include "
$toi 124, "#include "
$toi 125, "#include "
$toi 126, "#include "
dift dg_operatingsystem = 1
'HP MPE
$toi 150, "#include "
dift dg_progkind >= 40
'HP intrinsics for ksam, manual 32650-90886.pdf
$toi 161, "/* HP intrinsics */"
$toi 162, "#pragma intrinsic FCLOSE, FFINDN, FLOCK"
$toi 163, "#pragma intrinsic FREAD, FFINDBYKEY, FREMOVE"
$toi 164, "#pragma intrinsic FUNLOCK, FUPDATE, FWRITE"
$toi 165, "#pragma intrinsic HPCICOMMAND, HPFOPEN"
$toi 166, "#pragma intrinsic FSPACE"
endi
endi
dift dg_operatingsystem = 2
'Unix/Linux
$toi 150, "#include "
endi
sub_c_arrayout
ends sub_c_headers
subr sub_c_global_c_variables
'updated 2005/04/09, 2004/12/29
vari s_any, d_any, s_dot, d_dot, s_out
dift dg_tdebug = 1
$sys sg_pass1, 2
sub_return
endi
arrb
$toi 1, "/* global c variables */"
$toi 2, "int tig_cdebug = 2;"
$toi 3, "int tig_cerror = 2;"
$toi 4, "int tig_eof = 2;"
$toi 5, "int tig_x, tig_y, tig_z;"
$toi 6, "long tng_x, tng_y, tng_z;"
$toi 7, "long tng_index1, tng_index2;"
$toi 8, "double tdg_x, tdg_y, tdg_z;"
$toi 101, "/* global char arrays */"
$toi 102, "char tsg_256a[256];"
$toi 103, "char tsg_256b[256];"
$toi 104, "char tsg_input[2048];"
$toi 105, "char tsg_output1[2048];"
$toi 106, "char tsg_output2[2048];"
'dg_operatingsystem:1=MPE,2=Unix/Linux,3=C90 only
s_any = "int tig_operatingsystem = "
$app s_any, dg_operatingsystem + ";"
$toi 111, s_any
'global char pointers
$toi 201, "char *tsgp_1, *tsgp_2;"
sub_c_arrayout
ends sub_c_global_c_variables
subr sub_c_global_rpg_variables
'updated 2003/12/27
vari s_any, d_any, s_dot, d_dot, s_out
vari d_loop, d_byte, d_length
vari s_varname, s_varsize, s_fromsubr, d_count
vari d_vartype, d_varindexct, d_varlongct, d_vardecimalct
vari s_tabname, d_tablongct
$sys sg_subroutine, 2
s_fromsubr = sg_subroutine
dift dg_tdebug = 1
sg_pass1 = sg_subroutine
sub_return
endi
sub_c_blankline
sg_pass1 = "/* rpg variable declarations */"
sub_c_lineout
'123456789 sg_rpgvarnames 9 long
'abbbbcccd sg_rpgvarsizes 9 long
'a = d_vartype: 1=numeric,2=numeric array,6=alpha,7=alpha array
'bbbb = d_varindexct: index count
'ccc = d_varlongct: length
'd = d_vardecimalct: decimals
$len d_length, sg_rpgvarnames
d_count = 0
d_byte = 1
d_loop = 1
dwhi d_loop = 1
dinc d_count
d_any = d_count % 10
dift d_any = 0: $sho s_fromsubr + "=" + d_count
'get variable data from sg_rpgvarnames, sg_rpgvarsizes
$cut s_varname, sg_rpgvarnames, d_byte, 9
$cut s_varsize, sg_rpgvarsizes, d_byte, 9
'make comment line with info
sg_pass1 = sg_slashaster + s_varname + "=" + s_varsize
$app sg_pass1, sg_asterslash
sub_c_lineout
$cut s_any, s_varsize, 1, 1
$tod d_vartype, s_any
$cut s_any, s_varsize, 2, 4
$tod d_varindexct, s_any
$cut s_any, s_varsize, 6, 3
$tod d_varlongct, s_any
$cut s_any, s_varsize, 9, 1
$tod d_vardecimalct, s_any
'skip if we have *BLANK or *ZEROS
$cut s_any, s_varname, 1, 1
$ift s_any = "*": d_vartype = 99999
dift d_vartype = 1
'numeric type
$trb s_dot, s_varname
sg_pass1 = "double DG_" + s_dot + "=0;"
$clo sg_pass1, sg_pass1
sub_c_lineout
endi
dift d_vartype = 2
'numeric array
$trb s_dot, s_varname
sg_pass1 = "double DGA_" + s_dot + "[" + d_varindexct
$app sg_pass1, "];"
$clo sg_pass1, sg_pass1
sub_c_lineout
endi
dift d_vartype = 6
'alpha variable
$trb s_dot, s_varname
sg_pass1 = "char SG_" + s_dot + "[" + d_varlongct
$app sg_pass1, "];"
$clo sg_pass1, sg_pass1
sub_c_lineout
endi
dift d_vartype = 7
'alpha array
'do we have a table
$cut s_any, s_varname, 1, 3
$ift s_any = "TAB"
'sg_rpgtabnames1,sg_rpgtabnames2
$cut s_any, s_varname, 1, 6
$lok d_dot, sg_rpgtabnames1, 1, s_any
$cut s_tabname, sg_rpgtabnames2, d_dot, 6
'get rest of info about this tab2
sg_pass1 = s_tabname
sub_variable_info_return
d_tablongct = dg_pass3
'add d_varlongct and d_tablongct
d_varlongct = d_varlongct + d_tablongct
endi
sg_pass1 = "/* array " + s_varname
$app sg_pass1, " index=" + d_varindexct
$app sg_pass1, " long=" + d_varlongct + " */"
$clo sg_pass1, sg_pass1
sub_c_lineout
$trb s_dot, s_varname
d_any = d_varindexct * d_varlongct
sg_pass1 = "char SGA_" + s_dot + "[" + d_any + "];"
$clo sg_pass1, sg_pass1
sub_c_lineout
endi
'they are 9 long with commas between
d_byte = d_byte + 10
dift d_byte > d_length: dinc d_loop
endw
$out s_fromsubr + "=" + d_count
ends sub_c_global_rpg_variables
subr sub_c_global_rpg_indicators
'updated 2003/10/25
vari s_any, d_any, s_dot, d_dot, s_out
vari d_count
sub_c_blankline
sg_pass1 = "/* rpg indicator integer declarations */"
sub_c_lineout
'we do have a 00 indicator is not used
d_count = 1
d_dot = 0
dwhi d_dot < 100
s_dot = "0" + d_dot
$off s_dot, s_dot, 2
dift d_count = 1
sg_pass1 = "int ig_" + s_dot
else
$app sg_pass1, ", ig_" + s_dot
endi
dinc d_count
dift d_count > 8
$app sg_pass1, ";"
sub_c_lineout
d_count = 1
endi
dinc d_dot
endw
$app sg_pass1, ";"
sub_c_lineout
sg_pass1 = "int ig_LR;"
sub_c_lineout
ends sub_c_global_rpg_indicators
subr sub_c_global_file_variables
'updated 2005/01/08
'define file pointers and file byte location longs
vari s_any, d_any, s_dot, d_dot, s_out
vari s_filename, s_filedevice, s_filetype, d_filereclong
vari s_filefixed, s_fileksam, d_action
vari d_filekeybeg, d_filekeylong
vari d_loop, d_good, d_which, s_fromsubr, s_cfilename
$sys s_fromsubr, 2
'sg_filenames
'12345678
'aaaaaaaa=filename
'sg_filedevs
'aaaaaaaa=filedev
'sg_fileinfos
'12345678
'aabbbbcd
'aa=file type: ID,UD,IC,O
'bbbb=file record length
'c=file is F=fixed or V=variable
'd=file is F=flat or K=KSAM
'sg_filekeys
'12345678
'aaaabbbb
'aaaa=file key begin
'bbbb=file key length
sub_c_blankline
sg_pass1 = "/* file accesspointers and integers */"
sub_c_lineout
d_which = 1
d_loop = 1
dwhi d_loop = 1
$par s_filename, sg_filenames, ",", d_which
$trb s_any, s_filename
$len d_any, s_any
dift d_any = 0
dinc d_loop
else
$sho s_fromsubr + " " + s_filename
sg_pass1 = s_filename
sub_rpg_file_info_return
s_filedevice = sg_pass1
s_filetype = sg_pass2
s_filefixed = sg_pass3
s_fileksam = sg_pass4
d_filereclong = dg_pass2
d_filekeybeg = dg_pass3
d_filekeylong = dg_pass4
'skip if terminal I/O
d_action = 1
$trb s_filedevice, s_filedevice
'$STDIN will use the standard stdin
$ift s_filedevice = "$STDIN": d_action = 98
'$STDLST will use the standard stdout
$ift s_filedevice = "$STDLST": d_action = 99
$ift s_filefixed = "V": d_action = 12
$ift s_fileksam = "K": d_action = 13
dift d_action = 1
$tlo s_cfilename, s_filename
sg_pass1 = "FILE *filep_" + s_cfilename + ";"
sub_c_lineout
endi
dift d_action = 13
$tlo s_cfilename, s_filename
sg_pass1 = "int iksam_filenum_" + s_cfilename + ";"
sub_c_lineout
sg_pass1 = "int iksam_mode_" + s_cfilename
$app sg_pass1, " = 1;"
sub_c_lineout
sg_pass1 = "int iksam_advanceflag_" + s_cfilename
$app sg_pass1, " = 2;"
sub_c_lineout
endi
endi
dinc d_which
endw
sub_c_blankline
sg_pass1 = "/* filebyte location longs */"
sub_c_lineout
d_which = 1
d_loop = 1
dwhi d_loop = 1
$par s_filename, sg_filenames, ",", d_which
$trb s_any, s_filename
$len d_any, s_any
dift d_any = 0
dinc d_loop
else
$sho s_fromsubr + " " + s_filename
sg_pass1 = s_filename
sub_rpg_file_info_return
s_filedevice = sg_pass1
s_filetype = sg_pass2
s_filefixed = sg_pass3
s_fileksam = sg_pass4
d_filereclong = dg_pass2
d_filekeybeg = dg_pass3
d_filekeylong = dg_pass4
'skip if terminal I/O
d_good = 1
$trb s_filedevice, s_filedevice
'$STDIN will use the standard stdin
$ift s_filedevice = "$STDIN": dinc d_good
'$STDLST will use the standard stdout
$ift s_filedevice = "$STDLST": dinc d_good
dift d_good = 1
'ID,UD,O we must keep track of the filebyte
'IC we do not need to do so
$tlo s_cfilename, s_filename
$ift s_filetype = "ID"
sg_pass1 = "long ng_filebyte_" + s_cfilename
$app sg_pass1, " = -1;"
sub_c_lineout
endi
$ift s_filetype = "UD"
sg_pass1 = "long ng_filebyte_" + s_cfilename
$app sg_pass1, " = -1;"
sub_c_lineout
endi
$ift s_filetype = "O "
sg_pass1 = "long ng_filebyte_" + s_cfilename
$app sg_pass1, " = 0;"
sub_c_lineout
endi
endi
endi
dinc d_which
endw
$out s_fromsubr
ends sub_c_global_file_variables
subr sub_c_prototypes_input
'updated 2003/10/25
vari s_any, d_any, s_dot, d_dot, s_out
vari s_record, d_loop, d_good, s_filename, s_fromsubr
$sys s_fromsubr, 2
'iline 1 2 3 4 5 6
'123456789012345678901234567890123456789012345678901234567890
' .IFILEINP AA
' .I 10 20 VARIAB
sub_c_blankline
sg_pass1 = "/* rpg input subroutine prototypes */"
sub_c_lineout
dg_record = 0
d_loop = 1
dwhi d_loop = 1
d_good = 1
sg_pass1 = s_fromsubr
sub_rpg_read_record
s_record = sg_pass1
dift dg_record = 0
dinc d_good
dinc d_loop
endi
dift d_good = 1
$cut s_any, s_record, 6, 1
$ift s_any <> "I": dinc d_good
$cut s_filename, s_record, 7, 8
$isc d_any, s_filename, " "
dift d_any = 1: dinc d_good
$lok d_dot, sg_filenames, 1, s_filename
dift d_dot = 0: dinc d_good
endi
dift d_good = 1
$tlo s_filename, s_filename
sg_pass1 = "void fsub_input_to_fields_"
$app sg_pass1, s_filename + "(void);"
sub_c_lineout
endi
endw
ends sub_c_prototypes_input
subr sub_c_subroutines_input
'updated 2005/01/14, 2004/12/29
'make c subroutines to put input tsg_input into variables
vari s_any, d_any, s_dot, d_dot, s_out
vari d_record, s_record, d_loop, d_good, s_filename
vari d_part1, d_part2, d_filecount, s_subrname
vari s_fromsubr, d_beg
vari s_varname, s_beg, s_end, s_decimals
vari d_vartype, d_indexct, d_longct, d_decimalct
$sys s_fromsubr, 2
'for file input the input will be in tsg_input
'iline 1 2 3 4 5 6
'123456789012345678901234567890123456789012345678901234567890
' .IFILEINP AA
' .I 10 202VARIAB
sub_c_blankline
sg_pass1 = "/* input subroutines */"
sub_c_lineout
dg_rpglinenumber = 0
d_filecount = 0
d_record = 0
dg_filebyte = 1
d_loop = 1
dwhi d_loop = 1
'for filename input line set d_part1=1
d_part1 = 2
'for variable input line set d_part2=1
d_part2 = 2
d_good = 1
'we need comment lines too so use fsip
'to get every rpg file record
fsip s_record, sg_inpfile, dg_filebyte
dift dg_filebyte = 0
$out s_fromsubr + "=" + d_record
dinc d_good
dinc d_loop
endi
dift d_good = 1
dinc dg_rpglinenumber
$cut s_any, s_record, 1, 1
$ift s_any = "*"
dinc d_good
dinc d_loop
endi
endi
dift d_good = 1
dinc d_record
'tell
d_any = d_record % 1000
dift d_any = 0: $sho s_fromsubr + "=" + d_record
'make sure the record is 80 long
$ch$ s_any, " ", 80
$app s_record, s_any
$cut s_record, s_record, 1, 80
$cut s_any, s_record, 6, 1
$ift s_any <> "I": dinc d_good
endi
dift d_good = 1
$cut s_any, s_record, 7, 1
$ift s_any = "*"
'comment line
$cut s_any, s_record, 8, 20
$isc d_any, s_any, " "
dift d_any <> 1
$trb s_any, s_record
sg_pass1 = "/* " + s_any + " */"
sub_c_lineout
endi
dinc d_good
endi
endi
dift d_good = 1
sub_c_blankline
'output this input line as a comment
$trb s_any, s_record
sg_pass1 = "/* " + s_any + " */"
sub_c_lineout
endi
dift d_good = 1
'for filename input line set d_part1=1
'for variable input line set d_part2=1
$cut s_filename, s_record, 7, 8
$isc d_any, s_filename, " "
dift d_any <> 1
d_part1 = 1
else
d_part2 = 1
endi
endi
dift d_part1 = 1
$lok d_dot, sg_filenames, 1, s_filename
dift d_dot = 0: dinc d_part1
endi
dift d_part1 = 1
$sho s_fromsubr + " " + s_filename
'we have an iline with a filename
'are we ending a previous input
dift d_filecount > 0
sg_pass1 = "} /* " + s_subrname + " */"
sub_c_lineout
endi
sub_c_blankline
$tlo s_filename, s_filename
s_subrname = "fsub_input_to_fields_" + s_filename
sg_pass1 = "void " + s_subrname + "(void) {"
sub_c_lineout
dinc d_filecount
endi
dift d_part2 = 1
'variable input lines
'iline 1 2 3 4 5 6
'123456789012345678901234567890123456789012345678901234567890
' .IFILEINP AA
' .I 10 202VARIAB
$cut s_beg, s_record, 44, 4
$cut s_end, s_record, 48, 4
$cut s_decimals, s_record, 52, 1
$cut s_varname, s_record, 53, 6
$tlo s_varname, s_varname
$trb s_beg, s_beg
$trb s_end, s_end
'get info for s_varname
sg_pass1 = s_varname
sub_variable_info_return
d_vartype = dg_pass1
d_indexct = dg_pass2
d_longct = dg_pass3
d_decimalct = dg_pass4
$tod d_beg, s_beg
'tsg_input begins at 0 rather than 1
ddec d_beg
'123456789 sg_rpgvarnames 9 long
'abbbbcccd sg_rpgvarsizes 9 long
'a = d_vartype: 1=numeric,2=numeric array,6=alpha,7=alpha array
'bbbb = d_varindexct: index count
'ccc = d_varlongct: length
'd = d_vardecimalct: decimals
'everything has been verified so use
'info from sub_variable_info_return
'for file input the input will be in tsg_input
dift d_vartype = 6
'alpha variable
sg_pass1 = "tsub_copy(sg_" + s_varname
$app sg_pass1, ", &tsg_input[" + d_beg + "], "
$app sg_pass1, d_longct + ");"
sub_c_lineout
endi
dift d_vartype = 7
'alpha array
sg_pass1 = "tsub_copy(sga_" + s_varname
$app sg_pass1, ", &tsg_input[" + d_beg + "], "
d_any = d_longct * d_indexct
$app sg_pass1, d_any + ");"
sub_c_lineout
endi
dift d_vartype = 1
'numeric variable
sg_pass1 = "tsub_packed_to_double(&dg_" + s_varname
$app sg_pass1, ", &tsg_input[" + d_beg + "], "
$app sg_pass1, d_longct + ", " + s_decimals
$app sg_pass1, ", " + dg_rpglinenumber + ");"
sub_c_lineout
endi
endi
endw
'are we ending a previous input
dift d_filecount > 0
sg_pass1 = "} /* " + s_subrname + " */"
sub_c_lineout
endi
ends sub_c_subroutines_input
subr sub_c_prototypes_open_read_write_close_files
'updated 2004/12/30
'make c prototypes to open,read,write,close files
vari s_any, d_any, s_dot, d_dot, s_out
vari s_filename, s_filedevice, s_filetype, d_filereclong
vari s_filefixed, s_fileksam
vari d_filekeybeg, d_filekeylong, s_fileopenmode
vari d_loop, d_byte, s_fromsubr, s_cfilename
$sys sg_subroutine, 2
s_fromsubr = sg_subroutine
sub_c_blankline
sg_pass1 = "/* file subroutine prototypes */"
sub_c_lineout
sg_pass1 = "void fsub_open_files(void);"
sub_c_lineout
sg_pass1 = "void fsub_close_files(void);"
sub_c_lineout
'sg_filenames
'12345678
'aaaaaaaa=filename
'sg_filedevs
'aaaaaaaa=filedev
'sg_fileinfos
'12345678
'aabbbbcd
'aa=file type: ID,UD,IC,O
'bbbb=file record length
'c=file is F=fixed or V=variable
'd=file is F=flat or K=KSAM
'sg_filekeys
'12345678
'aaaabbbb
'aaaa=file key begin
'bbbb=file key length
d_byte = 1
d_loop = 1
dwhi d_loop = 1
$cut s_filename, sg_filenames, d_byte, 8
$sho s_fromsubr + " " + s_filename
sg_pass1 = s_filename
sub_rpg_file_info_return
s_filedevice = sg_pass1
s_filetype = sg_pass2
s_filefixed = sg_pass3
s_fileksam = sg_pass4
d_filereclong = dg_pass2
d_filekeybeg = dg_pass3
d_filekeylong = dg_pass4
$ift s_filetype = "ID": s_fileopenmode = "rb"
$ift s_filetype = "UD": s_fileopenmode = "r+b"
$ift s_filetype = "IC": s_fileopenmode = "rb"
$ift s_filetype = "O ": s_fileopenmode = "wb"
$tlo s_cfilename, s_filename
$ift s_filetype = "ID"
'if read on this file make proto subr to do so
$lok d_any, sg_readfile, 1, s_filename
dift d_any > 0
sg_pass1 = "void sub_file_read_" + s_cfilename
$app sg_pass1, "(void);"
sub_c_lineout
endi
'if readp on this file make proto subr to do so
$lok d_any, sg_readpfile, 1, s_filename
dift d_any > 0
sg_pass1 = "void sub_file_readp_" + s_cfilename
$app sg_pass1, "(void);"
sub_c_lineout
endi
endi
$ift s_filetype = "UD"
'if read on this file make proto subr to do so
$lok d_any, sg_readfile, 1, s_filename
dift d_any > 0
sg_pass1 = "void sub_file_read_" + s_cfilename
$app sg_pass1, "(void);"
sub_c_lineout
endi
'if readp on this file make proto subr to do so
$lok d_any, sg_readpfile, 1, s_filename
dift d_any > 0
sg_pass1 = "void sub_file_readp_" + s_cfilename
$app sg_pass1, "(void);"
sub_c_lineout
endi
'make proto subr to do write on this file
sg_pass1 = "void sub_file_write_" + s_cfilename
$app sg_pass1, "(void);"
sub_c_lineout
endi
$ift s_filetype = "IC"
'if chain in this file make proto subr to do so
$lok d_any, sg_chainfile, 1, s_filename
dift d_any > 0
sg_pass1 = "void sub_file_chain_read_" + s_cfilename
$app sg_pass1, "(long np_recnum);"
sub_c_lineout
endi
endi
$ift s_filetype = "O "
'make proto subr to do output for output only file
sg_pass1 = "void sub_file_write_" + s_cfilename
$app sg_pass1, "(void);"
sub_c_lineout
endi
d_byte = d_byte + 9
$len d_any, sg_filenames
dift d_byte > d_any: dinc d_loop
endw
$out sg_subroutine + " done"
ends sub_c_prototypes_open_read_write_close_files
subr sub_c_subroutine_open_files
'updated 2007/06/27, 2007/06/16, 2005/01/09
'make c subroutine fsub_open_files to open files
vari s_any, d_any, s_dot, d_dot, s_out
vari s_filename, s_filedevice, s_filetype, d_filereclong
vari s_filefixed, s_fileksam, d_action
vari d_filekeybeg, d_filekeylong, s_fileopenmode
vari d_loop, d_byte, d_good, s_cfilename, s_fromsubr
$sys sg_subroutine, 2
s_fromsubr = sg_subroutine
sub_c_blankline
sg_pass1 = "void fsub_open_files(void) {"
sub_c_lineout
sg_pass1 = "char cz[80]; long n_status;"
sub_c_lineout
sg_pass1 = "long n_old, n_update, n_lock, n_shr;"
sub_c_lineout
'sg_filenames
'12345678
'aaaaaaaa=filename
'sg_filedevs
'aaaaaaaa=filedev
'sg_fileinfos
'12345678
'aabbbbcd
'aa=file type: ID,UD,IC,O
'bbbb=file record length
'c=file is F=fixed or V=variable
'd=file is F=flat or K=KSAM
'sg_filekeys
'12345678
'aaaabbbb
'aaaa=file key begin
'bbbb=file key length
d_byte = 1
d_loop = 1
dwhi d_loop = 1
$cut s_filename, sg_filenames, d_byte, 8
$sho s_fromsubr + " " + s_filename
sg_pass1 = s_filename
sub_rpg_file_info_return
s_filedevice = sg_pass1
s_filetype = sg_pass2
s_filefixed = sg_pass3
s_fileksam = sg_pass4
d_filereclong = dg_pass2
d_filekeybeg = dg_pass3
d_filekeylong = dg_pass4
$ift s_filetype = "ID": s_fileopenmode = "rb"
$ift s_filetype = "UD": s_fileopenmode = "r+b"
$ift s_filetype = "IC": s_fileopenmode = "rb"
$ift s_filetype = "O ": s_fileopenmode = "wb"
$tlo s_cfilename, s_filename
'skip if terminal I/O since stdin,stdout are open
d_action = 1
$trb s_filedevice, s_filedevice
'$STDIN will use the standard stdin
$ift s_filedevice = "$STDIN": d_action = 8
'$STDLST will use the standard stdout
$ift s_filedevice = "$STDLST": d_action = 9
$ift s_filefixed = "V"
'VPLUS will have V in s_filefixed
'dg_operatingsystem:1=MPE,2=Unix/Linux,3=C90 only
dift dg_operatingsystem = 1: d_action = 12
endi
$ift s_fileksam = "K"
'KSAM will have K in s_fileksam
'dg_operatingsystem:1=MPE,2=Unix/Linux,3=C90 only
dift dg_operatingsystem = 1: d_action = 13
endi
dift d_action = 1
sg_pass1 = "/* open file " + s_cfilename + " */"
sub_c_lineout
sg_pass1 = "filep_" + s_cfilename + # = fopen("#
$app sg_pass1, s_cfilename + #", "#
$app sg_pass1, s_fileopenmode + #");#
sub_c_lineout
sg_pass1 = "if(filep_" + s_cfilename + " == NULL) {"
sub_c_lineout
sg_pass1 = "/* file open error */"
sub_c_lineout
sg_pass1 = #sprintf(cz, "file not opened=# + s_cfilename
$app sg_pass1, ", mode=" + s_fileopenmode + #");#
sub_c_lineout
sg_pass1 = "tsub_cerror(cz);"
sub_c_lineout
sg_pass1 = "} /* file open error */"
sub_c_lineout
sub_c_blankline
endi
dift d_action = 13
'open_file KSAM on MPE
'dg_operatingsystem:1=MPE,2=Unix/Linux,3=C90 only
'static void open_file(void) {
'/* Open file for shared update access with locking */
'int status;
'const int old=1, update=5, lock=1, shr=3;
'HPFOPEN(&filenum, &status,
'2, "-" FILENAME "-",
'3, &old,
'5, &dollarnull
'11, &update,
'12, &lock,
'13, &shr);
'assert(!status);
'}
sg_pass1 = "/* open file " + s_cfilename + " */"
sub_c_lineout
sg_pass1 = "n_old=1; n_update=5; n_lock=1; n_shr=3;"
sub_c_lineout
$ift s_filetype = "ID"
'n_update=0 means input demand
sg_pass1 = "n_update = 0;"
sub_c_lineout
else
'n_update=5 means update demand
sg_pass1 = "n_update = 5;"
sub_c_lineout
endi
sg_pass1 = "/* HP intrinsic HPFOPEN */"
sub_c_lineout
sg_pass1 = "HPFOPEN(&iksam_filenum_" + s_cfilename + ", "
$app sg_pass1, "&n_status, "
$app sg_pass1, #2, "-" "# + s_cfilename + #" "-", #
$app sg_pass1, "3, &n_old, "
$app sg_pass1, "11, &n_update, "
$app sg_pass1, "12, &n_lock, "
$app sg_pass1, "13, &n_shr);"
sub_c_lineout
'ksam file open error
'n_status=13107343 is for $null
sg_pass1 = "if(n_status != 0 && n_status != 13107343) {"
sub_c_lineout
sg_pass1 = "/* ksam file open error */"
sub_c_lineout
sg_pass1 = #sprintf(cz, "kfile not opened=# + s_cfilename
$app sg_pass1, ", mode=" + s_fileopenmode + #");#
sub_c_lineout
sg_pass1 = "tsub_cerror(cz);"
sub_c_lineout
sg_pass1 = "} /* file open error */"
sub_c_lineout
'$null files give an error that we do not
'want for ksam lookup files
dift dg_fullcdebug1 = 1
'n_status=0 means file was opened
sg_pass1 = "if(n_status != 0) {"
sub_c_lineout
sg_pass1 = "/* file open error */"
sub_c_lineout
sg_pass1 = #sprintf(cz, "kfile not opened=#
$app sg_pass1, s_cfilename
$app sg_pass1, ", mode=" + s_fileopenmode + #");#
sub_c_lineout
sg_pass1 = "tsub_cerror(cz);"
sub_c_lineout
sg_pass1 = "} /* file open error */"
sub_c_lineout
endi
'if file opened do a blank setll
sg_pass1 = "if(n_status == 0) {"
sub_c_lineout
sg_pass1 = "/* HP intrinsic FFINDBYKEY */"
sub_c_lineout
'we have a blank literal
sg_pass1 = "tsub_blank(tsg_256a, 256);"
sub_c_lineout
'FFINDBYKEY(filenum,value,location,length,relop)
'value=key
'relop=2 means find record >= key
sg_pass1 = "FFINDBYKEY(iksam_filenum_" + s_cfilename
$app sg_pass1, ", tsg_256a, " + d_filekeybeg
$app sg_pass1, ", " + d_filekeylong + ", 2);"
sub_c_lineout
'if ccode()=CCG then end of file or before beginning
'set iksam_mode_ to 2 if beyond end or before beginning
'set iksam_mode_ to 1 if good setll>=key
sg_pass1 = "if(ccode() == CCG) iksam_mode_"
$app sg_pass1, s_cfilename + " = 2;"
sub_c_lineout
sg_pass1 = "else iksam_mode_"
$app sg_pass1, s_cfilename + " = 1;"
sub_c_lineout
'set iksam_advanceflag to false=2
sg_pass1 = "iksam_advanceflag_" + s_cfilename
$app sg_pass1, " = 2;"
sub_c_lineout
sg_pass1 = "}"
sub_c_lineout
sub_c_blankline
endi
d_byte = d_byte + 9
$len d_any, sg_filenames
dift d_byte > d_any: dinc d_loop
endw
sg_pass1 = "} /* void fsub_open_files(void) */"
sub_c_lineout
sub_c_blankline
$out sg_subroutine + " done"
ends sub_c_subroutine_open_files
subr sub_c_subroutine_read_files
'updated 2005/01/10
'make c subroutines to read tsg_input from the files
vari s_any, d_any, s_dot, d_dot, s_out
vari s_filename, s_filedevice, s_filetype, d_filereclong
vari s_filefixed, s_fileksam
vari d_filekeybeg, d_filekeylong
vari d_loop, d_stringbyte, s_fromsubr
vari s_filebytevar, s_fileopenmode, s_cfilename
vari d_yesreadterm, d_yesreadfile, d_yesreadpfile
vari d_yeschainfile, d_yesreadksamfile, d_yesreadpksamfile
$sys sg_subroutine, 2
s_fromsubr = sg_subroutine
'fline 1 2 3 4 5 6
'123456789012345678901234567890123456789012345678901234567890
' .FTERMIN ID F 80 $STDIN
' .FTERMOUT O F 80 $STDLST
'sg_filenames
'12345678
'aaaaaaaa=filename
'sg_filedevs
'aaaaaaaa=filedev
'sg_fileinfos
'12345678
'aabbbbcd
'aa=file type: ID,UD,IC,O
'bbbb=file record length
'c=file is F=fixed or V=variable
'd=file is F=flat or K=KSAM
'sg_filekeys
'12345678
'aaaabbbb
'aaaa=file key begin
'bbbb=file key length
'loop through filenames in sg_filenames
d_stringbyt