'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_stringbyte = 1
d_loop = 1
dwhi d_loop = 1
$cut s_filename, sg_filenames, d_stringbyte, 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
$trb s_filedevice, s_filedevice
d_yesreadterm = 2
d_yesreadfile = 2
d_yesreadpfile = 2
d_yeschainfile = 2
d_yesreadksamfile = 2
d_yesreadpksamfile = 2
$ift s_filetype = "ID"
$ift s_filedevice = "$STDIN"
d_yesreadterm = 1
else
$lok d_any, sg_readfile, 1, s_filename
dift d_any > 0
$ift s_fileksam = "K"
d_yesreadksamfile = 1
else
d_yesreadfile = 1
endi
endi
$lok d_any, sg_readpfile, 1, s_filename
dift d_any > 0
$ift s_fileksam = "K"
d_yesreadpksamfile = 1
else
d_yesreadpfile = 1
endi
endi
endi
endi
$ift s_filetype = "UD"
$lok d_any, sg_readfile, 1, s_filename
dift d_any > 0
$ift s_fileksam = "K"
d_yesreadksamfile = 1
else
d_yesreadfile = 1
endi
endi
$lok d_any, sg_readpfile, 1, s_filename
dift d_any > 0
$ift s_fileksam = "K"
d_yesreadksamfile = 1
else
d_yesreadfile = 1
endi
endi
endi
$ift s_filetype = "IC"
$lok d_any, sg_chainfile, 1, s_filename
dift d_any > 0: d_yeschainfile = 1
endi
dift d_yesreadterm = 1
'read from $STDIN
sg_pass1 = "void sub_file_read_" + s_cfilename
$app sg_pass1, "(void) {"
sub_c_lineout
sg_pass1 = "tsub_blank(tsg_input, 79);"
sub_c_lineout
sg_pass1 = "fgets(tsg_input, 79, stdin);"
sub_c_lineout
sg_pass1 = "tsub_blank_escapes(tsg_input, 79);"
sub_c_lineout
sg_pass1 = "} /* sub_file_read_" + s_cfilename + " */"
sub_c_lineout
sub_c_blankline
'd_yesreadterm = 1
endi
dift d_yesreadfile = 1
'create subr to read from a file named s_cfilename
'this is an input demand or input update file
sg_pass1 = "void sub_file_read_" + s_cfilename
$app sg_pass1, "(void) {"
sub_c_lineout
sg_pass1 = "long n_length; long n_filebyte; long n_eor;"
sub_c_lineout
sub_c_blankline
'n_eor = length of end of record characters
'dg_operatingsystem:1=MPE,2=Unix/Linux,3=C90 only
dift dg_operatingsystem = 1
'MPE appears to have a LF at the end of records
sg_pass1 = "n_eor = 1;"
sub_c_lineout
endi
dift dg_operatingsystem = 2
'Unix/Linux as only LF at the end of records
sg_pass1 = "n_eor = 1;"
sub_c_lineout
endi
dift dg_operatingsystem = 3
'C90 only with CR and LF at the end of records
sg_pass1 = "n_eor = 2;"
sub_c_lineout
endi
'build name of the filebyte variable for below
s_filebytevar = "ng_filebyte_" + s_cfilename
'prepare the filebyte long var
sg_pass1 = "if(" + s_filebytevar + " < 0) "
$app sg_pass1, "n_filebyte = 0;"
sub_c_lineout
sg_pass1 = "else n_filebyte = " + s_filebytevar
$app sg_pass1, " + " + d_filereclong
$app sg_pass1, " + n_eor;"
sub_c_lineout
'long n_pos = 0;
'fseek(pfg_fixran_pdb, n_pos, SEEK_END);
'ng_record_last = ftell(pfg_fixran_pdb) / 114;
'fseek(pfg_fixran_pdb, n_pos, SEEK_SET);
'i_end = fread(sp_record, 1, 114, pfg_fixran_pdb);
'if(i_end != 114) {
'set the spot to where we want to read
sg_pass1 = "fseek(filep_" + s_cfilename
$app sg_pass1, ", n_filebyte, SEEK_SET);"
sub_c_lineout
'read the record
sg_pass1 = "n_length = fread(tsg_input, 1, "
$app sg_pass1, d_filereclong
$app sg_pass1, ", filep_" + s_cfilename + ");"
sub_c_lineout
'blank LF and on in the record
sg_pass1 = "tsub_blank_lf_and_after(tsg_input, "
$app sg_pass1, d_filereclong + ");"
sub_c_lineout
'debug read a record
arrb
$toi 1, "if(tig_cdebug == 1) {"
s_any = #printf("file=# + s_cfilename
$app s_any, # READ at=%ld, length=%ld\n", #
$app s_any, "n_filebyte, n_length);"
$toi 2, s_any
$toi 3, "tsub_cdebug(tsg_input);"
$toi 4, "}"
sub_c_arrayout
'did we read a record or not
sg_pass1 = "if(n_length > 0) {"
sub_c_lineout
'we read the record
sg_pass1 = "tig_eof = 2;"
sub_c_lineout
sg_pass1 = s_filebytevar + " = n_filebyte;"
sub_c_lineout
'no we did not read the record
sg_pass1 = "} else tig_eof = 1;"
sub_c_lineout
sg_pass1 = "} /* rsub_file_read_" + s_cfilename + " */"
sub_c_lineout
sub_c_blankline
'd_yesreadfile = 1
endi
dift d_yesreadpfile = 1
'create subr to readp from a file named s_cfilename
sg_pass1 = "void sub_file_readp_"
$app sg_pass1, s_cfilename + "(void) {"
sub_c_lineout
sg_pass1 = "long n_length = 0; long n_filebyte; "
$app sg_pass1, "long n_eor;"
sub_c_lineout
sub_c_blankline
'n_eor = length of end of record characters
'dg_operatingsystem:1=MPE,2=Unix/Linux,3=C90 only
dift dg_operatingsystem = 1
'MPE appears to have a LF at the end of records
sg_pass1 = "n_eor = 1;"
sub_c_lineout
endi
dift dg_operatingsystem = 2
'Unix/Linux as only LF at the end of records
sg_pass1 = "n_eor = 1;"
sub_c_lineout
endi
dift dg_operatingsystem = 3
'C90 only with CR and LF at the end of records
sg_pass1 = "n_eor = 2;"
sub_c_lineout
endi
'build name of the filebyte long since we use it a lot
s_filebytevar = "ng_filebyte_" + s_cfilename
'prepare the filebyte long var
sg_pass1 = "n_filebyte = " + s_filebytevar
$app sg_pass1, " - " + d_filereclong
$app sg_pass1, " - n_eor;"
sub_c_lineout
'long n_pos = 0;
'fseek(pfg_fixran_pdb, n_pos, SEEK_END);
'ng_record_last = ftell(pfg_fixran_pdb) / 114;
'fseek(pfg_fixran_pdb, n_pos, SEEK_SET);
'i_end = fread(sp_record, 1, 114, pfg_fixran_pdb);
'if(i_end != 114) {
'readp n_byte cannot be < 0
sg_pass1 = "if(n_filebyte >= 0) {"
sub_c_lineout
'set the spot to where we want to read
sg_pass1 = "fseek(filep_" + s_cfilename
$app sg_pass1, ", n_filebyte, SEEK_SET);"
sub_c_lineout
'read the record
sg_pass1 = "n_length = fread(tsg_input, 1, "
$app sg_pass1, d_filereclong
$app sg_pass1, ", filep_" + s_cfilename + ");"
sub_c_lineout
sg_pass1 = "}"
sub_c_lineout
'debug readp a record
arrb
$toi 1, "if(tig_cdebug == 1) {"
s_any = #printf("file=# + s_cfilename
$app s_any, # READP at=%ld, length=$ld\n", #
$app s_any, "n_filebyte, n_length);"
$toi 2, s_any
$toi 3, "tsub_cdebug(tsg_input);"
$toi 4, "}"
sub_c_arrayout
'did we read a record or not
sg_pass1 = "if(n_length > 0) {"
sub_c_lineout
'we read the record
sg_pass1 = "tig_eof = 2;"
sub_c_lineout
sg_pass1 = s_filebytevar + " = n_filebyte;"
sub_c_lineout
'no we did not read the record
sg_pass1 = "} else tig_eof = 1;"
sub_c_lineout
sg_pass1 = "} /* rsub_file_readp_" + s_cfilename + " */"
sub_c_lineout
sub_c_blankline
'd_yesreadpfile = 1
endi
dift d_yeschainfile = 1
'create subr to chain from a file named s_cfilename
sg_pass1 = "void sub_file_chain_" + s_cfilename
$app sg_pass1, "(long np_recnum) {"
sub_c_lineout
sg_pass1 = "long n_length = 0; long n_filebyte;"
$app sg_pass1, "n_eor;"
sub_c_lineout
sub_c_blankline
'n_eor = length of end of record characters
'dg_operatingsystem:1=MPE,2=Unix/Linux,3=C90 only
dift dg_operatingsystem = 1
'MPE appears to have a LF at the end of records
sg_pass1 = "n_eor = 1;"
sub_c_lineout
endi
dift dg_operatingsystem = 2
'Unix/Linux as only LF at the end of records
sg_pass1 = "n_eor = 1;"
sub_c_lineout
endi
dift dg_operatingsystem = 3
'C90 only with CR and LF at the end of records
sg_pass1 = "n_eor = 2;"
sub_c_lineout
endi
'get n_byte from np_recnum
sg_pass1 = "n_filebyte = (" + d_filereclong
$app sg_pass1, " + n_eor) * np_recnum;"
sub_c_lineout
'long n_pos = 0;
'fseek(pfg_fixran_pdb, n_pos, SEEK_END);
'ng_record_last = ftell(pfg_fixran_pdb) / 114;
'fseek(pfg_fixran_pdb, n_pos, SEEK_SET);
'i_end = fread(sp_record, 1, 114, pfg_fixran_pdb);
'if(i_end != 114) {
'set the spot to where we want to read
sg_pass1 = "fseek(filep_" + s_cfilename
$app sg_pass1, ", n_filebyte, SEEK_SET);"
sub_c_lineout
'read the record
sg_pass1 = "n_length = fread(tsg_input, 1, "
$app sg_pass1, d_filereclong
$app sg_pass1, ", filep_" + s_cfilename + ");"
sub_c_lineout
'debug chain a record
arrb
$toi 1, "if(tig_cdebug == 1) {"
s_any = #printf("file=# + s_cfilename
$app s_any, # CHAIN at=%ld, length=%ld\n", #
$app s_any, "n_filebyte, n_length);"
$toi 2, s_any
$toi 3, "tsub_cdebug(tsg_input);"
$toi 4, "}"
sub_c_arrayout
'did we read a record
sg_pass1 = "if(n_length > 0) tig_eof = 2;"
sub_c_lineout
sg_pass1 = "else tig_eof = 1;"
sub_c_lineout
sg_pass1 = "} /* rsub_file_chain_" + s_cfilename + " */"
sub_c_lineout
sub_c_blankline
'd_yeschainfile = 1
endi
dift d_yesreadksamfile = 1
'create subr to ksam read from a file named s_cfilename
'this is an input demand or input update file
sg_pass1 = "void sub_file_read_" + s_cfilename
$app sg_pass1, "(void) {"
sub_c_lineout
sg_pass1 = "long n_length; long n_filebyte; long n_eor;"
sub_c_lineout
sub_c_blankline
sg_pass1 = "/* HP intrinsic FREAD */"
sub_c_lineout
sg_pass1 = "n_length = FREAD(iksam_filenum_"
$app sg_pass1, s_cfilename + ", tsg_input, -"
$app sg_pass1, d_filereclong + ");"
sub_c_lineout
'if CCG then end of file and advance flag=false
sg_pass1 = "if(ccode() == CCG) {"
sub_c_lineout
sg_pass1 = "tig_eof = 1;"
sub_c_lineout
sg_pass1 = "iksam_advanceflag_" + s_cfilename + " = 2;"
sub_c_lineout
sg_pass1 = "}"
sub_c_lineout
sg_pass1 = "else {"
sub_c_lineout
sg_pass1 = "tig_eof = 2;"
sub_c_lineout
sg_pass1 = "iksam_advanceflag_" + s_cfilename + " = 1;"
sub_c_lineout
sg_pass1 = "}"
sub_c_lineout
'blank LF and on in the record
sg_pass1 = "tsub_blank_lf_and_after(tsg_input, "
$app sg_pass1, d_filereclong + ");"
sub_c_lineout
'debug read a record
arrb
$toi 1, "if(tig_cdebug == 1) {"
s_any = #printf("file=# + s_cfilename
$app s_any, # READ at=%ld, length=%ld\n", #
$app s_any, "n_filebyte, n_length);"
$toi 2, s_any
$toi 3, "tsub_cdebug(tsg_input);"
$toi 4, "}"
sub_c_arrayout
sg_pass1 = "} /* sub_file_read_" + s_cfilename
$app sg_pass1, sg_asterslash
sub_c_lineout
'd_yesreadksamfile = 1
endi
dift d_yesreadpksamfile = 1
'create subr to ksam readp from a file named s_cfilename
'this is an input demand or input update file
sg_pass1 = "void sub_file_readp_" + s_cfilename
$app sg_pass1, "(void) {"
sub_c_lineout
sg_pass1 = "long n_length; long n_filebyte; long n_eor;"
sub_c_lineout
sub_c_blankline
sg_pass1 = "/* HP intrinsic FSPACE */"
sub_c_lineout
'back one line or two depending on iksam_advanceflag
sg_pass1 = "if(iksam_advanceflag_" + s_cfilename
$app sg_pass1, " == 1) {"
sub_c_lineout
sg_pass1 = "FSPACE(iksam_filenum_"
$app sg_pass1, s_cfilename + ", -2);"
sub_c_lineout
sg_pass1 = "}"
sub_c_lineout
sg_pass1 = "else {"
sub_c_lineout
sg_pass1 = "FSPACE(iksam_filenum_"
$app sg_pass1, s_cfilename + ", -1);"
sub_c_lineout
sg_pass1 = "}"
sub_c_lineout
sg_pass1 = "/* HP intrinsic FREAD */"
sub_c_lineout
sg_pass1 = "n_length = FREAD(iksam_filenum_"
$app sg_pass1, s_cfilename + ", tsg_input, -"
$app sg_pass1, d_filereclong + ");"
sub_c_lineout
'if CCG then end of file and advance flag=false
sg_pass1 = "if(ccode() == CCG) {"
sub_c_lineout
sg_pass1 = "tig_eof = 1;"
sub_c_lineout
sg_pass1 = "iksam_advanceflag_" + s_cfilename + " = 2;"
sub_c_lineout
sg_pass1 = "}"
sub_c_lineout
sg_pass1 = "else {"
sub_c_lineout
sg_pass1 = "tig_eof = 2;"
sub_c_lineout
sg_pass1 = "iksam_advanceflag_" + s_cfilename + " = 1;"
sub_c_lineout
sg_pass1 = "}"
sub_c_lineout
'blank LF and on in the record
sg_pass1 = "tsub_blank_lf_and_after(tsg_input, "
$app sg_pass1, d_filereclong + ");"
sub_c_lineout
'debug read a record
arrb
$toi 1, "if(tig_cdebug == 1) {"
s_any = #printf("file=# + s_cfilename
$app s_any, # READ at=%ld, length=%ld\n", #
$app s_any, "n_filebyte, n_length);"
$toi 2, s_any
$toi 3, "tsub_cdebug(tsg_input);"
$toi 4, "}"
sub_c_arrayout
sg_pass1 = "} /* sub_file_readp_" + s_cfilename
$app sg_pass1, sg_asterslash
sub_c_lineout
'd_yesreadpksamfile = 1
endi
d_stringbyte = d_stringbyte + 9
$len d_any, sg_filenames
dift d_stringbyte > d_any: dinc d_loop
endw
$out sg_subroutine + " done"
ends sub_c_subroutine_read_files
subr sub_c_subroutine_write_files
'updated 2005/07/06, 2005/07/05, 2004/10/16
'make c subroutines to write tsg_output1 to 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 s_fileopenmode, s_cfilename, d_good, d_action
vari d_loop, d_byte, s_fromsubr, s_filebytevar
$sys sg_subroutine, 2
s_fromsubr = sg_subroutine
d_byte = 1
d_loop = 1
dwhi d_loop = 1
'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
$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
$trb s_filedevice, s_filedevice
d_action = 0
$ift s_filetype = "O "
d_action = 2
$ift s_filedevice = "$STDLST": d_action = 1
endi
$ift s_filetype = "UD": d_action = 3
dift d_action = 1
'write to screen
sg_pass1 = "void sub_file_write_" + s_cfilename
$app sg_pass1, "(void) {"
sub_c_lineout
sg_pass1 = "tsg_output1[79] = 0;"
sub_c_lineout
sg_pass1 = #printf("%s\n", tsg_output1);#
sub_c_lineout
sg_pass1 = "} /* sub_file_write_" + s_cfilename + " */"
sub_c_lineout
sub_c_blankline
endi
dift d_action = 2
'write to file for output files only
sg_pass1 = "void sub_file_write_" + s_cfilename
$app sg_pass1, "(void) {"
sub_c_lineout
sg_pass1 = "long n_length;"
sub_c_lineout
sub_c_blankline
'dg_operatingsystem:1=MPE,2=Unix/Linux,3=C90 only
dift dg_operatingsystem = 1
'MPE operating system
'put on line feed
sg_pass1 = "tsg_output1[" + d_filereclong + "] = 10;"
sub_c_lineout
d_filereclong = d_filereclong + 1
endi
dift dg_operatingsystem = 2
'Unix/Linux operating system
'put on line feed
sg_pass1 = "tsg_output1[" + d_filereclong + "] = 10;"
sub_c_lineout
d_filereclong = d_filereclong + 1
endi
dift dg_operatingsystem = 3
'C90 only operating system
'put on carriage return
sg_pass1 = "tsg_output1[" + d_filereclong + "] = 13;"
sub_c_lineout
'put on line feed
d_dot = d_filereclong + 1
sg_pass1 = "tsg_output1[" + d_dot + "] = 10;"
sub_c_lineout
d_filereclong = d_filereclong + 2
endi
'build name of the filebytelong for below
s_filebytevar = "ng_filebyte_" + s_cfilename
'long n_pos = 0;
'fseek(pfg_fixran_pdb, n_pos, SEEK_END);
'ng_record_last = ftell(pfg_fixran_pdb) / 114;
'fseek(pfg_fixran_pdb, n_pos, SEEK_SET);
'i_end = fread(sp_record, 1, 114, pfg_fixran_pdb);
'if(i_end != 114) {
'n_pos = (np_record - 1) * 114;
'fseek(pfg_fixran_pdb, n_pos, SEEK_SET);
'i_end = fwrite(sp_record, 1, 114, pfg_fixran_pdb);
'ig_error = 0;
'if(i_end < 114) ig_error++;
'set the file position to s_filebytevar
sg_pass1 = "fseek(filep_" + s_cfilename + ", "
$app sg_pass1, s_filebytevar + ", SEEK_SET);"
sub_c_lineout
'output the record
sg_pass1 = "n_length = fwrite(tsg_output1, 1, "
$app sg_pass1, d_filereclong
$app sg_pass1, ", filep_" + s_cfilename + ");"
sub_c_lineout
'debug excpt output
arrb
$toi 1, "if(tig_cdebug == 1) {"
s_any = #printf("file=# + s_cfilename
$app s_any, # EXCPT output at=%ld\n", #
$app s_any, s_filebytevar + ");"
$toi 2, s_any
$toi 3, "tsub_cdebug(tsg_input);"
$toi 4, "}"
sub_c_arrayout
'if wrong length set tig_eof to 1
sg_pass1 = "if(n_length == " + d_filereclong + ") "
$app sg_pass1, "tig_eof = 2; else tig_eof = 1;"
sub_c_lineout
'increase the s_filebytevar to the next record
sg_pass1 = s_filebytevar + " = " + s_filebytevar
$app sg_pass1, " + " + d_filereclong + ";"
sub_c_lineout
sg_pass1 = "} /* sub_file_write_" + s_cfilename + " */"
sub_c_lineout
sub_c_blankline
endi
dift d_action = 3
'write to file for update demand files only
sg_pass1 = "void sub_file_write_" + s_cfilename + "(void) {"
sub_c_lineout
sg_pass1 = "long n_length = 0;"
sub_c_lineout
sub_c_blankline
'dg_operatingsystem:1=MPE,2=Unix/Linux,3=C90 only
dift dg_operatingsystem = 1
'MPE operating system
'no record separator
endi
dift dg_operatingsystem = 2
'Unix/Linux operating system
'put on line feed
sg_pass1 = "tsg_output1[" + d_filereclong + "] = 10;"
sub_c_lineout
d_filereclong = d_filereclong + 1
endi
dift dg_operatingsystem = 3
'C90 only operating system
'put on carriage return
sg_pass1 = "tsg_output1[" + d_filereclong + "] = 13;"
sub_c_lineout
'put on line feed
d_dot = d_filereclong + 1
sg_pass1 = "tsg_output1[" + d_dot + "] = 10;"
sub_c_lineout
d_filereclong = d_filereclong + 2
endi
'build name in s_filebytevar for use below
s_filebytevar = "ng_filebyte_" + s_cfilename
'long n_pos = 0;
'fseek(pfg_fixran_pdb, n_pos, SEEK_END);
'ng_record_last = ftell(pfg_fixran_pdb) / 114;
'fseek(pfg_fixran_pdb, n_pos, SEEK_SET);
'i_end = fread(sp_record, 1, 114, pfg_fixran_pdb);
'if(i_end != 114) {
'n_pos = (np_record - 1) * 114;
'fseek(pfg_fixran_pdb, n_pos, SEEK_SET);
'i_end = fwrite(sp_record, 1, 114, pfg_fixran_pdb);
'ig_error = 0;
'if(i_end < 114) ig_error++;
'set the file position to s_filebytevar
sg_pass1 = "fseek(filep_" + s_cfilename + ", "
$app sg_pass1, s_filebytevar + ", SEEK_SET);"
sub_c_lineout
'output the record
sg_pass1 = "n_length = fwrite(tsg_output1, 1, "
$app sg_pass1, d_filereclong
$app sg_pass1, ", filep_" + s_cfilename + ");"
sub_c_lineout
'debug excpt output
arrb
$toi 1, "if(tig_cdebug == 1) {"
s_any = #printf("file=# + s_cfilename
$app s_any, # EXCPT output at=%ld\n", #
$app s_any, s_filebytevar + ");"
$toi 2, s_any
$toi 3, "tsub_cdebug(tsg_input);"
$toi 4, "}"
sub_c_arrayout
sg_pass1 = "if(n_length == " + d_filereclong + ") "
$app sg_pass1, "tig_eof = 2; else tig_eof = 1;"
sub_c_lineout
'for update demand files we do not increase the
'file byte number after outputting to them
sg_pass1 = "} /* sub_file_write_" + s_cfilename + " */"
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
$out sg_subroutine + " done"
ends sub_c_subroutine_write_files
subr sub_c_subroutine_close_files
'updated 2004/10/23
'make c subroutine fsub_close_files to close files
vari s_any, d_any, s_dot, d_dot, s_out
vari s_filename, s_filedevice, s_filetype
vari s_filefixed, s_fileksam
vari d_filereclong, d_action
vari d_filekeybeg, d_filekeylong, s_fileopenmode, d_good
vari d_loop, d_byte, s_cfilename, s_fromsubr
$sys sg_subroutine, 2
s_fromsubr = sg_subroutine
sub_c_blankline
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 = "IC": s_fileopenmode = "rb"
$ift s_filetype = "UD": s_fileopenmode = "r+b"
$ift s_filetype = "O ": s_fileopenmode = "wb"
$tlo s_cfilename, s_filename
$trb s_filedevice, s_filedevice
'skip closing if terminal I/O
d_action = 1
'$STDIN will use the standard C stream stdin
$ift s_filedevice = "$STDIN": d_action = 98
'$STDLST will use the standard C stream stdout
$ift s_filedevice = "$STDLST": d_action = 99
$ift s_fileksam = "K": d_action = 13
dift d_action = 1
sg_pass1 = "/* close file " + s_cfilename + " */"
sub_c_lineout
sg_pass1 = "fclose(filep_" + s_cfilename + ");"
sub_c_lineout
sub_c_blankline
endi
dift d_action = 13
sg_pass1 = "/* close ksam file " + s_cfilename + " */"
sub_c_lineout
sg_pass1 = "FCLOSE(iksam_filenum_" + s_cfilename
$app sg_pass1, ", 0, 0);"
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_close_files(void) */"
sub_c_lineout
sub_c_blankline
$out sg_subroutine + " done"
ends sub_c_subroutine_close_files
subr sub_c_prototypes_begsr
'updated 2003/11/18
vari s_any, d_any, s_dot, d_dot, s_out
vari s_record, d_loop, d_good, s_fromsubr
$sys s_fromsubr, 2
'cline 1 2 3 4 5 6
'123456789012345678901234567890123456789012345678901234567890
' .CSR 01 02 03FACTOR1 COMMDFACTOR2 RESULT 92H919293
sub_c_blankline
sg_pass1 = "/* rpg 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 <> "C": dinc d_good
$cut s_any, s_record, 28, 5
$ift s_any <> "BEGSR": dinc d_good
endi
dift d_good = 1
$cut s_dot, s_record, 18, 6
$tlo s_dot, s_dot
sg_pass1 = "void sub_begsr_" + s_dot + "(void);"
sub_c_lineout
endi
endw
ends sub_c_prototypes_begsr
subr sub_c_prototypes_excpt
'updated 2007/06/16, 2004/01/19
'prototypes of subroutines to perform excpt output
vari s_any, d_any, s_dot, d_dot, s_out
vari s_record, d_loop, d_good, s_excpt, s_allexcpts
vari s_fromsubr
$sys s_fromsubr, 2
'oline 1 2 3 4 5 6
'123456789012345678901234567890123456789012345678901234567890
' .OFILENAMEE 12 01 02 03OLINE
' .O E 01 02 03VARIABJB 132 "HEADING LINE "
sub_c_blankline
sg_pass1 = "/* rpg excpt subroutine prototypes */"
sub_c_lineout
s_allexcpts = sg_nothing
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 must have an output excpt tag line
$cut s_any, s_record, 6, 1
$ift s_any <> "O": dinc d_good
$cut s_any, s_record, 15, 1
$ift s_any <> "E": dinc d_good
$cut s_excpt, s_record, 32, 6
$isc d_any, s_excpt, " "
dift d_any = 1: dinc d_good
endi
dift d_good = 1
'have we already done this excpt
s_any = ":" + s_excpt + ","
$lok d_any, s_allexcpts, 1, s_any
dift d_any > 0: dinc d_good
endi
dift d_good = 1
$app s_allexcpts, ":" + s_excpt + ","
$tlo s_excpt, s_excpt
sg_pass1 = "void sub_excpt_" + s_excpt + "(void);"
sub_c_lineout
endi
endw
ends sub_c_prototypes_excpt
subr sub_c_initialize_strings
'updated 2004/12/27
'write c lines to initialize strings
vari s_any, d_any, s_dot, d_dot, s_out
vari d_loop, d_byte, d_length, d_count
vari s_string, d_strlength, d_index
vari s_varname, s_varsize, s_fromsubr
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
'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
arrb
$toi 1, "/* rpg string initialization */"
$toi 2, "void rsub_initialize_strings(void) {"
$toi 3, "int iz;"
d_index = 11
$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 % 100
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
$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
d_strlength = d_varindexct * d_varlongct
'skip if we have *BLANK or *ZEROS
$cut s_any, s_varname, 1, 1
$ift s_any = "*": d_vartype = 99999
dift d_vartype = 6
'alpha variable
$tlo s_dot, s_varname
s_string = "sg_" + s_dot
s_out = "for(iz = 0; iz < " + d_strlength
$app s_out, "; iz++) " + s_string + "[iz] = ' ';"
$toi d_index, s_out
dinc d_index
endi
dift d_vartype = 7
'alpha array
'do we have a table
$cut s_any, s_varname, 1, 3
$ift s_any = "TAB"
$cut s_any, s_varname, 1, 6
$lok d_dot, sg_rpgtabnames1, 1, s_any
$cut s_tabname, sg_rpgtabnames2, d_dot, 6
sg_pass1 = s_tabname
sub_variable_info_return
d_tablongct = dg_pass3
d_varlongct = d_varlongct + d_tablongct
endi
d_strlength = d_varindexct * d_varlongct
$tlo s_dot, s_varname
s_string = "sga_" + s_dot
s_out = "for(iz = 0; iz < " + d_strlength
$app s_out, "; iz++) " + s_string + "[iz] = ' ';"
$toi d_index, s_out
dinc d_index
endi
dift d_index > 1000
sub_c_arrayout
arrb
d_index = 1
endi
'they are 9 long with commas between
d_byte = d_byte + 10
dift d_byte > d_length: dinc d_loop
endw
$toi 901, "} /* rsub_initialize_strings */"
sub_c_arrayout
$out s_fromsubr + "=" + d_count
ends sub_c_initialize_strings
subr sub_c_initialize_arrays_from_bottom
'updated 2005/01/27, 2005/01/19, 2005/01/18, 2004/12/29
'make subroutine to initialize bottom strings
vari s_any, d_any, s_dot, d_dot, s_out
vari d_loop1, d_loop2, d_good, d_action
vari d_count, s_fromsubr, d_which, d_long
vari d_record, s_record, d_yesinarray, d_yesnumeric
vari s_rpgvarname, s_tlovarname, s_cvarname
vari d_vartype, d_varindexct, d_varlongct
vari d_vardecimalct, d_maxperlinect, d_perlinect
vari d_byte, d_element, s_data, d_index
vari s_rpgtabname, d_tablongct
$sys sg_subroutine, 2
s_fromsubr = sg_subroutine
dift dg_tdebug = 1
sg_pass1 = sg_subroutine
sub_return
endi
sg_pass1 = "void rsub_initialize_arrays_from_bottom(void) {"
sub_c_lineout
'the below strings are made in sub_rpg_valid_varsize_eline
'sg_bottomarray1, csv with array names 6 long
'sg_bottomarray2, csv with perlinect 6 long
'sg_rpgtabnames1, sg_rpgtabnames2
'find the arrays and initialize
d_which = 0
d_yesinarray = 2
d_byte = 1
d_record = 0
dg_filebyte = 1
d_loop1 = 1
dwhi d_loop1 = 1
d_good = 1
d_action = 99999
fsip s_record, sg_inpfile, dg_filebyte
dift dg_filebyte = 0
$out s_fromsubr + "=" + d_record
dg_record = 0
dinc d_good
dinc d_loop1
endi
dift d_good = 1
dinc d_record
'tell
d_any = d_record % 100
dift d_any = 0: $sho s_fromsubr + "=" + d_record
'does the record begin with **
$cut s_any, s_record, 1, 2
$isc d_any, s_any, "*"
dift d_any = 1
d_action = 1
d_yesinarray = 1
d_index = 1
else
dift d_yesinarray = 1
'use line to update numeric array
dift d_yesnumeric = 1: d_action = 2
'use line to update alpha array
dift d_yesnumeric <> 1: d_action = 3
endi
endi
endi
dift d_action = 1
'get the array name if any
dinc d_which
$par s_rpgvarname, sg_bottomarray1, ",", d_which
'do we have a new array to begin initializing
$tlo s_tlovarname, s_rpgvarname
$len d_any, s_tlovarname
dift d_any = 0
'no new array so we have an error
dinc d_yesinarray
d_action = 99999
dinc d_loop1
'we have unknown array
$out d_record + " " + s_record
$out "unknown array"
sub_variable_lookup
dg_error = 1
endi
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_action = 1
'we have an array name in s_rpgvarname,s_tlovarname
$par s_any, sg_bottomarray2, ",", d_which
$tod d_maxperlinect, s_any
'get rest of info about this array
sg_pass1 = s_tlovarname
sub_variable_info_return
d_vartype = dg_pass1
d_varindexct = dg_pass2
d_varlongct = dg_pass3
d_vardecimalct = dg_pass4
'do we have a table
'sg_rpgtabnames1, sg_rpgtabnames2
$cut s_any, s_rpgvarname, 1, 3
$ift s_any = "TAB"
$lok d_dot, sg_rpgtabnames1, 1, s_rpgvarname
dbad d_dot = 0
'we know it is there
$cut s_rpgtabname, sg_rpgtabnames2, d_dot, 6
'get rest of info about this tab2
sg_pass1 = s_rpgtabname
sub_variable_info_return
d_tablongct = dg_pass3
'add d_varlongct and d_tablongct
d_varlongct = d_varlongct + d_tablongct
endi
'prepare to use next lines to initialize
d_yesinarray = 1
d_byte = 0
d_element = 0
dift d_vartype = 2
'numeric array
s_cvarname = "dga_" + s_tlovarname
d_yesnumeric = 1
endi
dift d_vartype = 7
'alpha array
s_cvarname = "sga_" + s_tlovarname
d_yesnumeric = 2
endi
endi
dift d_action = 2
'use line to initialize the numeric array
d_byte = 1
d_perlinect = 0
d_loop2 = 1
dwhi d_loop2 = 1
'put data into s_data and then to array
$cut s_data, s_record, d_byte, d_varlongct
sg_pass1 = s_cvarname + "[" + d_index + "] = "
$app sg_pass1, s_data + ";"
sub_c_lineout
d_byte = d_byte + d_varlongct
dinc d_perlinect
dift d_perlinect >= d_maxperlinect: dinc d_loop2
dinc d_index
dift d_index >= d_varindexct: dinc d_loop2
endw
endi
dift d_action = 3
'use line to initialize the alpha array
d_byte = 1
d_perlinect = 0
d_loop2 = 1
dwhi d_loop2 = 1
'get the data and copy to the char array
$cut s_data, s_record, d_byte, d_varlongct
sg_pass1 = s_data
sub_right_trim_spaces_only
s_data = sg_pass1
$len d_long, s_data
d_dot = d_index - 1 * d_varlongct
'blank the element first
sg_pass1 = "tsub_blank(&" + s_cvarname + "[" + d_dot
$app sg_pass1, "], " + d_varlongct + ");"
sub_c_lineout
'copy in the data
sg_pass1 = "tsub_copy(&" + s_cvarname + "[" + d_dot
$app sg_pass1, #], "# + s_data + #", # + d_long
$app sg_pass1, ");"
sub_c_lineout
d_byte = d_byte + d_varlongct
dinc d_perlinect
dift d_perlinect >= d_maxperlinect: dinc d_loop2
dinc d_index
dift d_index > d_varindexct: dinc d_loop2
endw
endi
endw
sg_pass1 = "} /* rsub_initialize_arrays_from_bottom(void) */"
sub_c_lineout
ends sub_c_initialize_arrays_from_bottom
subr sub_c_subroutines_main
'updated 2004/11/06
vari s_any, d_any, s_dot, d_dot, s_out
dift dg_fullcdebug1 = 1
s_out = "tig_cdebug = 1;"
else
s_out = "tig_cdebug = 2;"
endi
'blank the string array
arrb
'main calls rsub_rpg_calculations which has non-subr rpg lines
$toi 1, "/* main subroutine */"
$toi 2, "int main(void) {"
$toi 3, "char cz[79];"
's_out either sets tig_cdebug to 1 or 2 see above
$toi 11, s_out
$toi 21, "tsub_translation_date();"
$toi 31, #if(tig_cdebug == 1) tsub_cdebug("begin program");#
$toi 101, "/* initialize strings */"
$toi 102, #if(tig_cdebug == 1) tsub_cdebug("rsub_initialize_strings");#
$toi 103, "rsub_initialize_strings();"
$toi 201, "/* initialize arrays from bottom */"
$toi 202, "if(tig_cdebug == 1)"
$toi 203, #tsub_cdebug("rsub_initialize_arrays_from_bottom");#
$toi 204, "rsub_initialize_arrays_from_bottom();"
$toi 301, "/* open all of the files */"
$toi 302, #if(tig_cdebug == 1) tsub_cdebug("fsub_open_files");#
$toi 303, "fsub_open_files();"
$toi 401, "/* rpg calculations */"
$toi 402, #if(tig_cdebug == 1) tsub_cdebug("rsub_rpg_calculations");#
$toi 403, "rsub_rpg_calculations();"
$toi 501, "/* close all of the files */"
$toi 502, #if(tig_cdebug == 1) tsub_cdebug("fsub_close_files");#
$toi 503, "fsub_close_files();"
$toi 621, "tsub_translation_date();"
$toi 622, #if(tig_cdebug == 1) tsub_cdebug("end of program");#
$toi 701, "/* return a number to the system */"
$toi 702, "return tig_cerror;"
$toi 801, "/* end of main subroutine */"
$toi 802, "} /* main */"
sub_c_arrayout
ends sub_c_subroutines_main
subr sub_c_prototypes_tsub
'updated 2005/01/13, 2004/12/07
vari s_any, d_any, s_dot, d_dot, s_out
'blank the string array
arrb
$toi 1, "/* tsub prototypes */"
'the t on tfni and tsub is for utility
'prototype tsub_cdebug
$toi 101, "/* prototype tsub_cdebug */"
$toi 102, "void tsub_cdebug(char *sp_1);"
'prototype tsub_numberruler
$toi 131, "/* prototype tsub_numberruler */"
$toi 132, "void tsub_numberruler(int ip_beg);"
'prototype tsub_out79
$toi 151, "/* prototype tsub_out79 */"
$toi 152, "void tsub_out79(char *sp_1);"
'prototype tsub_char_out79
$toi 161, "/* prototype tsub_char_out79 */"
$toi 162, "void tsub_char_out79(char sc1);"
'prototype tsub_cerror
$toi 171, "/* prototype for tsub_cerror */"
$toi 172, "void tsub_cerror(char *sp_1);"
'prototype tsub_runtime_error_exit_program
$toi 176, "/* prototype tsub_runtime_error_exit_program */"
$toi 177, "void tsub_runtime_error_exit_program(char *sp_1);"
'prototype tsub_index_range_cerror
$toi 181, "/* prototype tsub_index_range_cerror */"
$toi 182, "void tsub_index_range_cerror(double dp_1, int "
$toi 183, "ip_max, int ip_line);"
'prototype tfni_index
$toi 201, "/* prototype round double to integer for an index */"
$toi 202, "int tfni_index(double dp_1);"
'prototype tfnn_from_string
$toi 301, "/* prototype tfnn_from_string */"
$toi 302, "long tfnn_from_string(char *ps1, int ip_long);"
'prototype tfnn_string_of_numbers
$toi 351, "/* prototype tfnn_string_of_numbers */"
$toi 352, "long tfnn_string_of_numbers(char *sp_1);"
'prototype tfnd_round
$toi 401, "/* prototype round a double to a double */"
$toi 402, "double tfnd_round(double dp_1, int ip_decimals);"
'prototype tfnd_trunc
$toi 501, "/* prototype truncate a double to a double */"
$toi 502, "double tfnd_trunc(double dp_1, int ip_decimals, "
$toi 503, "int ip_add);"
'prototype tsub_copy
$toi 601, "/* prototype copy sp_2 to sp_1 for length ip_long */"
$toi 602, "void tsub_copy(char *sp_1, char *sp_2, int ip_long);"
'prototype tsub_acopy = array copy
$toi 701, "/* prototype array copy from sp_2 which is of */"
$toi 702, "/* length ip_long2 to begin at ip_beg2 to sp_1 */"
$toi 703, "/* which is of length ip_long1 to begin at ip_beg1 */"
$toi 704, "void tsub_acopy(char *sp_1, int ip_long1, int ip_beg1,"
$toi 705, "char *sp_2, int ip_long2, int ip_beg2);"
'prototype tsub_blank to blank char array
$toi 851, "void tsub_blank(char *sp_1, int ip_long);"
'prototype tsub_double_to_packed
$toi 901, "/* prototype of double to packed */"
$toi 902, "/* with length and decimals of double */"
$toi 903, "void tsub_double_to_packed(char *sp_1, "
$toi 904, "double dp_1, int ip_long, int ip_decimals);"
'prototype tsub_packed_to_double
$toi 951, "/* prototype of tsub_packed_to_double */"
$toi 952, "/* with length and decimals of double */"
$toi 953, "void tsub_packed_to_double(double *pdp_1, char *sp_1, "
$toi 954, "int ip_long, int ip_decimals, int ip_line);"
sub_c_arrayout
'prototype tfnd_time
$toi 101, "/* prototype of tfnd_time */"
$toi 102, "/* with 6=time, 12=time and date */"
$toi 103, "double tfnd_time(int ip_1);"
'prototype tsub_time2
$toi 201, "/* prototype of tsub_time2 */"
$toi 202, "void tsub_time2(char *sp_1, int ip_long);"
'prototype tsub_udate
$toi 301, "/* prototype of tsub_udate */"
$toi 302, "void tsub_udate(char *sp_1, char cp_1);"
'prototype tsub_zadd_array to do z-add to an array no index
$toi 351, "/* prototype of tsub_zadd_array to do z-add to array */"
$toi 352, "void tsub_zadd_array(double *pdp1, int ip1, double dp2);"
'prototype tsub_compare_numbers
$toi 401, "/* prototype of tsub_compare_numbers */"
$toi 402, "void tsub_compare_numbers(double dp_1, double dp_2,"
$toi 403, "int *ip_1, int *ip_2, int *ip_3);"
'prototype tsub_compare_strings
$toi 451, "/* prototype of tsub_compare_strings */"
$toi 451, "void tsub_compare_strings(char *sp_1, int ip_long1,"
$toi 453, "char *sp_2, int ip_long2,"
$toi 454, "int *ip_1, int *ip_2, int *ip_3);"
'prototype tfni_compare_strings
$toi 501, "/* prototype of tfni_compare_strings */"
$toi 502, "int tfni_compare_strings(char *sp_1, "
$toi 503, "char *sp_2, int ip_long2);"
'prototype compare string to char for length
$toi 601, "/* prototype tsub_comp_string_to_char */"
$toi 602, "void tsub_comp_string_to_char("
$toi 603, "char *sp_1, int ip_long, char cp_1,"
$toi 604, "int *ip_1, int *ip_2, int *ip_3);"
'prototype edit double to string
$toi 701, "/* prototype edit double to string */"
$toi 702, "void tsub_edit_double_to_string("
$toi 703, "char *sp_1, double dp_1, int ip_decimals, "
$toi 704, "char cp_edit, int *pip_long);"
'prototype for numeric sort array
$toi 801, "/* prototype numeric sorta */"
$toi 802, "void tsub_nsorta(double *dap_array, int ip_indexct);"
'prototype for alpha sort array
$toi 901, "/* prototype alpha sorta */"
$toi 902, "void tsub_asorta(char *sap_array, "
$toi 903, "int ip_indexct, int ip_longct);"
sub_c_arrayout
$toi 101, "/* blank escapes for length */"
$toi 102, "void tsub_blank_escapes(char *sp_1, int ip1);"
$toi 201, "/* blank line feed and after */"
$toi 202, "void tsub_blank_lf_and_after(char *sp_1, int ip1);"
$toi 301, "/* prototype tsub_move_right_into_array */"
$toi 302, "void tsub_move_right_into_array(char *sp_1, int ip_indexct1, "
$toi 303, "int ip_longct1, char* sp_2, int ip_longct2);"
$toi 401, "/* prototype tsub_translation_date */"
$toi 402, "void tsub_translation_date(void);"
$toi 501, "/* prototype tsub_upper_case */"
$toi 502, "void tsub_upper_case(char *sp1, int ip_long);"
sub_c_arrayout
ends sub_c_prototypes_tsub
subr sub_c_subroutines_tsub1
'updated 2005/01/14, 2005/01/13, 2005/01/11
vari s_any, d_any, s_dot, d_dot, s_out
'blank the string array
arrb
$toi 1, "/* tsub subroutines */"
'subroutine tsub_cdebug
$toi 101, "void tsub_cdebug(char *sp_1) {"
$toi 102, "int iy, iz; char cz[80];"
$toi 121, "if(sp_1[0] != 0) {"
$toi 122, "tsub_out79(sp_1);"
$toi 123, "}"
$toi 131, #tsub_out79("cdebug to turn off cdebug or return");#
$toi 132, "fgets(cz, 79, stdin);"
$toi 133, "tsub_upper_case(cz, 6);"
$toi 141, #iy = tfni_compare_strings(cz, "CDEBUG", 6);#
$toi 161, "if(iy == 0) {"
$toi 162, "if(tig_cdebug == 1) tig_cdebug++;"
$toi 163, "else tig_cdebug = 1;"
$toi 164, "}"
$toi 181, "} /* tsub_cdebug */"
'subroutine tsub_numberruler
$toi 201, "/* subroutine tsub_numberruler */"
$toi 202, "void tsub_numberruler(int ip_beg) {"
$toi 203, "char cz[160]; int iz;"
$toi 204, #char s_num[11] = "1234567890";#
$toi 221, "for(iz = 0; iz < 80; iz++) cz[iz] = '.';"
$toi 231, "for(iz = 0; iz < 10; iz++) {"
$toi 232, "tsub_copy(&cz[ip_beg + iz * 10], s_num, 10);"
$toi 233, "}"
$toi 281, "tsub_out79(cz);"
$toi 291, "} /* tsub_numberruler */"
sub_c_arrayout
'subroutine tsub_out79
$toi 201, "/* subroutine tsub_out79 */"
$toi 202, "void tsub_out79(char *sp_1) {"
$toi 203, "int iy, iz; char cz[80];"
$toi 211, "for(iy = 1, iz = 0; iz < 79; iz++) {"
$toi 212, "if(sp_1[iz] == 0) iy++;"
$toi 213, "if(iy == 1) {"
$toi 214, "cz[iz] = sp_1[iz];"
$toi 215, "if(cz[iz] < 32) cz[iz] = 32;"
$toi 216, "}"
$toi 217, "else cz[iz] = 32;"
$toi 231, "}"
$toi 241, "cz[79] = 0;"
$toi 242, "puts(cz);"
$toi 251, "} /* tsub_out79 */"
'subroutine tsub_char_out79
$toi 261, "/* subroutine tsub_char_out79 */"
$toi 262, "void tsub_char_out79(char sc1) {"
$toi 263, "char cz[80]; int iz;"
$toi 271, "for(iz = 0; iz < 80; iz++) cz[iz] = sc1;"
$toi 272, "tsub_out79(cz);"
$toi 279, "} /* tsub_char_out79 */"
'subroutine tsub_cerror
$toi 301, "void tsub_cerror(char *sp_1) {"
$toi 302, "/* for cerrors */"
$toi 321, "tsub_out79(sp_1);"
$toi 322, #tsub_cdebug("error");#
$toi 331, "tig_cerror = 1;"
$toi 391, "} /* tsub_cerror */"
'subroutine tsub_index_range_cerror
$toi 401, "/* subroutine tsub_index_range_cerror */"
$toi 402, "void tsub_index_range_cerror(double dp_1, "
$toi 403, "int ip_max, int ip_line) {"
$toi 411, "char cz[50]; int iz; int i_error = 2;"
$toi 421, "if(dp_1 > 32767 || dp_1 < 0.99) i_error = 1;"
$toi 422, "else {"
$toi 431, "iz = (int)floor(dp_1 + 0.51);"
$toi 432, "if(iz < 1 || iz > ip_max) i_error = 1;"
$toi 433, "}"
$toi 451, "if(i_error == 1) {"
$toi 452, #sprintf(cz, "line=%d has bad index=%lf", ip_line, dp_1);#
$toi 461, "tsub_runtime_error_exit_program(cz);"
$toi 491, "}"
$toi 499, "} /* tsub_index_range_cerror */"
'subroutine tsub_runtime_error_exit_program
$toi 501, "/* subroutine tsub_runtime_error_exit_program */"
$toi 502, "void tsub_runtime_error_exit_program(char *sp_1) {"
$toi 503, "char cz[80];"
$toi 511, "tsub_out79(sp_1);"
$toi 521, #tsub_out79("runtime error, program will now end");#
$toi 522, "fgets(cz, 79, stdin);"
$toi 531, "fsub_close_files();"
$toi 541, "exit(1);"
$toi 599, "} /* tsub_runtime_error_exit_program */"
sub_c_arrayout
'subroutine tfni_index
$toi 11, "int tfni_index(double dp_1) {"
$toi 12, "/* round double to integer */"
$toi 13, "int iz; double dz;"
$toi 21, "dz = floor(dp_1 + 0.51);"
$toi 22, "if(dz > 32767) iz = 32767;"
$toi 23, "else if(dz < -32767) iz = -32767;"
$toi 24, "else iz = (int)dz;"
$toi 25, "return iz;"
$toi 26, "} /* tfni_index */"
'subroutine tfnn_from_string
$toi 101, "long tfnn_from_string(char *ps1, int ip_long) {"
$toi 102, "/* subroutine string to long */"
$toi 103, "long n_result = 0; int i_char; int iz;"
$toi 104, "for(iz = 0; iz < ip_long; iz++) {"
$toi 105, "i_char = ps1[iz];"
$toi 106, "/* ignore non-numeric characters */"
$toi 107, "if(i_char >= 48 && i_char <= 57) {"
$toi 108, "n_result = n_result * 10 + i_char - 48;"
$toi 109, "}"
$toi 110, "}"
$toi 111, "return n_result;"
$toi 199, "} /* tfnn_from_string */"
'subroutine tfnn_string_of_numbers
$toi 201, "long tfnn_string_of_numbers(char *sp_1) {"
$toi 202, "/* subroutine string of numbers to long */"
$toi 203, "long n_result = 0; int i_char; int iz;"
$toi 211, "for(iz = 0; iz < 9; iz++) {"
$toi 212, "i_char = sp_1[iz];"
$toi 221, "/* stop at non-number */"
$toi 222, "if(i_char >= 48 && i_char <= 57) {"
$toi 223, "n_result = n_result * 10 + i_char - 48;"
$toi 224, "}"
$toi 231, "else iz = 100;"
$toi 251, "}"
$toi 291, "return n_result;"
$toi 299, "} /* tfnn_string_of_numbers */"
sub_c_arrayout
'subroutine tfnd_round
$toi 201, "double tfnd_round(double dp_1, int ip_decimals) {"
$toi 202, "/* round double by decimals */"
$toi 203, "double dz, d_fact; int iz;"
$toi 204, "d_fact = 1.0;"
$toi 205, "for(iz = 0; iz < ip_decimals; iz++) d_fact = d_fact * 10;"
$toi 206, "dz = floor(dp_1 * d_fact + 0.5) / d_fact;"
$toi 207, "return dz;"
$toi 208, "} /* tfnd_round */"
'subroutine tfnd_trunc
$toi 301, "double tfnd_trunc(double dp_1, int ip_decimals, "
$toi 302, "int ip_add) {"
$toi 303, "/* truncate double by decimals */"
$toi 304, "double dz, d_fact; int i_neg, iz;"
$toi 311, "dz = dp_1; i_neg = 2;"
$toi 312, "if(dz < 0.0) {"
$toi 313, "dz = -dz; i_neg = 1;"
$toi 314, "}"
$toi 331, "d_fact = 1.0;"
$toi 332, "for(iz = 0; iz < ip_decimals; iz++) "
$toi 333, "d_fact = d_fact * 10;"
$toi 341, "dz = dz * d_fact;"
$toi 342, "if(ip_add == 1) dz = dz + 0.001;"
$toi 343, "dz = floor(dz) / d_fact;"
$toi 344, "if(i_neg == 1) dz = -dz;"
$toi 391, "return dz;"
$toi 399, "} /* tfnd_trunc */"
'subroutine tsub_copy
$toi 401, "void tsub_copy(char *sp_1, char *sp_2, int ip_long) {"
$toi 402, "/* to copy from sp_2 to sp_1 for length ip_long */"
$toi 403, "int iz;"
$toi 404, "for(iz = 0; iz < ip_long; iz++) sp_1[iz] = sp_2[iz];"
$toi 405, "} /* tsub_copy */"
'subroutine tsub_acopy
$toi 501, "void tsub_acopy(char *sp_1, int ip_long1, int ip_beg1,"
$toi 502, "char *sp_2, int ip_long2, int ip_beg2){"
$toi 503, "/* array copy */"
$toi 504, "int i_error, i_count, iy, iz;"
$toi 505, "i_error = 2;"
$toi 506, "/* first index is 0, last index is long-1 */"
$toi 507, "if(ip_beg1 >= ip_long1) i_error = 1;"
$toi 508, "if(ip_beg2 >= ip_long2) i_error = 1;"
$toi 509, "if(ip_beg1 < 0 || ip_beg2 < 0) i_error = 1;"
$toi 510, "i_count = ip_long1 - ip_beg1;"
$toi 511, "iz = ip_long2 - ip_beg2;"
$toi 512, "if(i_count > iz) i_count = iz;"
$toi 513, "if(i_error != 1) {"
$toi 514, "for(iz = 0; iz < i_count; iz++)"
$toi 515, "sp_1[ip_beg1 + iz] = sp_2[ip_beg2 + iz];"
$toi 516, "}"
$toi 517, "} /* tsub_acopy */"
sub_c_arrayout
ends sub_c_subroutines_tsub1
subr sub_c_subroutines_tsub2
'updated 2005/01/17, 2004/09/18
vari s_any, d_any, s_dot, d_dot, s_out
'blank the string array
arrb
'subroutine tsub_blank to blank char array
$toi 201, "void tsub_blank(char *sp_1, int ip_long) {"
$toi 203, "/* subroutine blank char array for ip_long */"
$toi 206, "int iz;"
$toi 210, "for(iz = 0; iz < ip_long; iz++) sp_1[iz] = ' ';"
$toi 211, "} /* tsub_blank */"
sub_c_arrayout
arrb
'subroutine tsub_double_to_packed
$toi 201, "void tsub_double_to_packed(char *sp_1, "
$toi 202, "double dp_1, int ip_long, int ip_decimals) {"
$toi 203, "/* subroutine of double to packed */"
$toi 204, "/* with length and decimals of double */"
$toi 205, "char cz[40]; int iy, iz, i_neg; double dz;"
$toi 206, "dz = dp_1;"
$toi 207, "i_neg = 2;"
$toi 208, "if(dz < 0) {"
$toi 209, "dz = - dz;"
$toi 210, "i_neg = 1;"
$toi 211, "}"
$toi 212, "for(iz = 0; iz < ip_decimals; iz++) dz = dz * 10;"
$toi 213, "for(iz = 0; iz < 40; iz++) cz[iz] = ' ';"
$toi 214, "/* zero filled no decimal places decimal in cz[20] */"
$toi 215, #sprintf(cz, "%020.0lf", dz);#
$toi 221, "/* the far right digit is in cz[19] */"
$toi 222, "if(i_neg == 1) {"
$toi 223, "if(cz[19] >= '1' && cz[19] <= '9') cz[19] = cz[19] + 25;"
$toi 224, "else if(cz[19] == '0') cz[19] = '}';"
$toi 225, "}"
$toi 226, "iy = 20 - ip_long;"
$toi 227, "for(iz = 0; iz < ip_long; iz++, iy++) sp_1[iz] = cz[iy];"
$toi 228, "} /* tsub_double_to_packed */"
'subroutine tsub_packed_to_double
$toi 301, "void tsub_packed_to_double(double *pdp_1, char *sp_1, "
$toi 302, "int ip_long, int ip_decimals, int ip_line) {"
$toi 303, "/* subroutine of packed to double */"
$toi 304, "/* with length and decimals of double */"
$toi 305, "int ix, iy, iz; int i_good; char cz[80];"
$toi 306, "double dz = 0; int i_error = 0;"
$toi 321, "/* A-I is 1-9, J-R is 1-9, S-Z is 2-9 */"
$toi 322, "/* blank and { are zero, } is -zero */"
$toi 323, "/* A is 65, J is 74, S is 83 */"
$toi 324, "/* 0 is char 48 and 9 is char 57 */"
$toi 341, "/* get all but right most digit */"
$toi 342, "for(iz = 0; iz < (ip_long - 1); iz++) {"
$toi 343, "ix = sp_1[iz];"
$toi 361, "iy = 9999;"
$toi 362, "if(ix >= 48 && ix <= 57) iy = ix - 48;"
$toi 363, "else if(ix == 32) iy = 0;"
$toi 364, "else if(ix >= 65 && ix <= 73) iy = ix - 64;"
$toi 365, "else if(ix >= 74 && ix <= 82) iy = ix - 73;"
$toi 366, "else if(ix >= 83 && ix <= 90) iy = ix - 81;"
$toi 381, "if(iy != 9999) dz = dz * 10 + iy;"
$toi 382, "else i_error = 1;"
$toi 383, "}"
$toi 401, "/* get right most digit and validate */"
$toi 402, "iy = 9999;"
$toi 403, "ix = sp_1[ip_long - 1];"
$toi 421, "/* A=65,I=73,J=74,R=82,{=123,}=125 */"
$toi 422, "if(ix == 32) iy = 0;"
$toi 423, "else if(ix >= 48 && ix <= 57) iy = ix - 48;"
$toi 424, "else if(ix == 123) iy = 0;"
$toi 425, "else if(ix >= 65 && ix <= 73) iy = ix - 64;"
$toi 431, "else if(ix >= 74 && ix <= 82) {"
$toi 432, "iy = 73 - ix;"
$toi 433, "dz = -dz;"
$toi 434, "}"
$toi 441, "else if(ix == 125) {"
$toi 442, "iy = 0;"
$toi 443, "dz = - dz;"
$toi 444, "}"
$toi 451, "if(iy == 9999) i_error = 1;"
$toi 452, "else dz = dz * 10 + iy;"
$toi 461, "/* get decimal correct */"
$toi 462, "for(iz = 0; iz < ip_decimals; iz++) dz = dz / 10;"
$toi 481, "/* do we have an error */"
$toi 482, "if(i_error == 1) {"
$toi 483, "sp_1[ip_long] = 0;"
$toi 484, #sprintf(cz, "line=%d, not number='%s'\n", #
$toi 485, "ip_line, sp_1);"
$toi 486, "tsub_runtime_error_exit_program(cz);"
$toi 487, "}"
$toi 498, "*pdp_1 = dz;"
$toi 499, "} /* tsub_packed_to_double */"
sub_c_arrayout
ends sub_c_subroutines_tsub2
subr sub_c_subroutines_tsub3
'updated 2004/12/07
vari s_any, d_any, s_dot, d_dot, s_out
'blank the string array
arrb
'subroutine tfnd_time
$toi 301, "double tfnd_time(int ip_1) {"
$toi 302, "/* subroutine of tfnd_time */"
$toi 303, "/* with 6=time, 12=time and date */"
$toi 304, "time_t time_1; char sz[50]; char sy[50];"
$toi 305, "double d_result = 0; long n_month = 0; long nz = 0;"
'JanFebMarAprMayJunJulAugSepOctNovDec
'012345678901234567890123
'Wed Oct 30 05:02:00 1996
'sprintf(sz, "%s", ctime(&time_1));
$toi 311, "/* 012345678901234567890123 */"
$toi 312, "/* Wed Oct 30 05:02:00 1996 */"
$toi 313, "/* 050200103096 */"
$toi 314, "time_1 = time(NULL);"
$toi 315, "/* tig_operatingsystem:1=MPE,2=Unix/Linux,3=C90 only */"
$toi 316, "if(tig_operatingsystem == 1) time_1 = time_1 + 14400;"
$toi 317, #sprintf(sz, "%s", ctime(&time_1));#
$toi 321, "d_result = tfnn_from_string(&sz[11], 2);"
$toi 322, "d_result = d_result * 100.0 + tfnn_from_string(&sz[14], 2);"
$toi 323, "d_result = d_result * 100.0 + tfnn_from_string(&sz[17], 2);"
$toi 330, "if(ip_1 >= 12) {"
$toi 331, "nz = sz[4] + sz[5] + sz[6];"
$toi 332, "if(nz == 281) n_month = 1;"
$toi 333, "if(nz == 269) n_month = 2;"
$toi 334, "if(nz == 288) n_month = 3;"
$toi 335, "if(nz == 291) n_month = 4;"
$toi 336, "if(nz == 295) n_month = 5;"
$toi 337, "if(nz == 301) n_month = 6;"
$toi 338, "if(nz == 299) n_month = 7;"
$toi 339, "if(nz == 285) n_month = 8;"
$toi 340, "if(nz == 296) n_month = 9;"
$toi 341, "if(nz == 294) n_month = 10;"
$toi 342, "if(nz == 307) n_month = 11;"
$toi 343, "if(nz == 268) n_month = 12;"
$toi 351, "d_result = d_result * 100.0 + n_month;"
$toi 352, "d_result = d_result * 100.0 + tfnn_from_string(&sz[8], 2);"
$toi 353, "d_result = d_result * 100.0 + tfnn_from_string(&sz[22], 2);"
$toi 354, "}"
$toi 355, "return d_result;"
$toi 356, "} /* tfnd_time */"
'subroutine tsub_time2
$toi 401, "void tsub_time2(char *sp_1, int ip_long) {"
$toi 402, "/* subroutine of tsub_time2 */"
$toi 403, "/* 1 2 3 4 */"
$toi 404, "/* 01234567890123456789012345678901234567890 */"
$toi 405, "/* TUE. APR 4, 2000, 11:05 AM JULIAN:095 */"
$toi 406, "/* 012345678901234567890123 */"
$toi 407, "/* Wed Oct 30 05:02:00 1996 */"
$toi 411, "time_t time_1; char sz[50]; char sy[50]; int iz;"
$toi 412, "time_1 = time(NULL);"
$toi 421, "/* tig_operatingsystem:1=MPE,2=Unix/Linux,3=C90 only */"
$toi 422, "if(tig_operatingsystem == 1) time_1 = time_1 + 14400;"
$toi 431, #sprintf(sz, "%s", ctime(&time_1));#
$toi 432, "for(iz = 0; iz < 50; iz++) sy[iz] = ' ';"
$toi 433, "tsub_copy(sy, sz, 3);"
$toi 434, "sy[3] = '.';"
$toi 441, "tsub_copy(&sy[5], &sz[4], 6);"
$toi 442, "sy[11] = ',';"
$toi 451, "tsub_copy(&sy[13], &sz[20], 4);"
$toi 452, "sy[17] = ',';"
$toi 461, "tsub_copy(&sy[19], &sz[11], 5);"
$toi 462, "tsub_copy(sp_1, sy, ip_long);"
$toi 499, "} /* tsub_time2 */"
sub_c_arrayout
'subroutine tsub_udate
$toi 501, "/* subroutine of tsub_udate */"
$toi 502, "void tsub_udate(char *sp_1, char cp_1) {"
$toi 503, "/* UDATE into sp_1 using edit code cp_1 */"
$toi 504, "char sz[20]; double dz;"
$toi 511, "dz = tfnd_time(12);"
$toi 512, "dz = fmod(dz, 1000000.0);"
$toi 513, #sprintf(sz, "%08.1lf", dz);#
$toi 521, "tsub_copy(sp_1, sz, 6);"
$toi 522, "if(cp_1 == 'Y') {"
$toi 523, "sp_1[2] = '/'; sp_1[3] = sz[2]; sp_1[4] = sz[3];"
$toi 524, "sp_1[5] = '/'; sp_1[6] = sz[4]; sp_1[7] = sz[5];"
$toi 525, "}"
$toi 526, "} /* tsub_udate */"
'subroutine tsub_zadd_array z-add to array no index
$toi 601, "/* subroutine of tsub_zadd_array z-add to array no index */"
$toi 602, "void tsub_zadd_array(double *pdp1, int ip1, double dp2) {"
$toi 603, "int iz;"
$toi 611, "for(iz = 0; iz < ip1; iz++) pdp1[iz] = dp2;"
$toi 699, "} /* tsub_zadd_array */"
sub_c_arrayout
ends sub_c_subroutines_tsub3
subr sub_c_subroutines_tsub4
'updated 2005/01/04
vari s_any, d_any, s_dot, d_dot, s_out
'blank the string array
arrb
'subroutine tsub_compare_numbers
$toi 501, "void tsub_compare_numbers(double dp_1, double dp_2,"
$toi 502, "int *ip_1, int *ip_2, int *ip_3) {"
$toi 503, "/* subroutine tsub_compare_numbers */"
$toi 504, "/* set result indicators */"
$toi 505, "*ip_1 = 0; *ip_2 = 0; *ip_3 = 0;"
$toi 506, "if(dp_1 > dp_2) *ip_1 = 1;"
$toi 507, "if(dp_1 < dp_2) *ip_2 = 1;"
$toi 508, "if(dp_1 == dp_2) *ip_3 = 1;"
$toi 509, "} /* tsub_compare_numbers */"
'subroutine tfni_compare_strings
$toi 551, "/* subroutine of tfni_compare_strings */"
$toi 552, "int tfni_compare_strings(char *sp_1, char *sp_2, "
$toi 553, "int ip_long) {"
$toi 554, "int iy, iz;"
$toi 571, "iy = 0;"
$toi 572, "for(iz = 0; iy == 0 && iz < ip_long; iz++) {"
$toi 573, "if(sp_1[iz] < sp_2[iz]) iy--;"
$toi 574, "else if(sp_1[iz] > sp_2[iz]) iy++;"
$toi 575, "}"
$toi 589, "return iy;"
$toi 590, "} /* tfni_compare_strings */"
'subroutine tsub_compare_strings
$toi 601, "void tsub_compare_strings(char *sp_1, int ip_long1,"
$toi 602, "char *sp_2, int ip_long2,"
$toi 603, "int *ip_1, int *ip_2, int *ip_3) {"
$toi 611, "/* subroutine tsub_compare_strings */"
$toi 612, "/* set result indicators */"
$toi 613, "int iy, iz; int i_max;"
$toi 614, "*ip_1 = 0; *ip_2 = 0; *ip_3 = 0;"
$toi 621, "i_max = ip_long1;"
$toi 622, "if(i_max > ip_long2) i_max = ip_long2;"
$toi 631, "for(iy = -1, iz = 0; iy == -1 && iz < i_max; iz++) {"
$toi 632, "if(sp_1[iz] != sp_2[iz]) iy = iz;"
$toi 633, "}"
$toi 641, "if(iy == -1) {"
$toi 642, "if(ip_long1 == ip_long2) *ip_3 = 1;"
$toi 643, "if(ip_long1 > ip_long2) *ip_1 = 1;"
$toi 644, "if(ip_long1 < ip_long2) *ip_2 = 1;"
$toi 645, "}"
$toi 651, "else {"
$toi 652, "if(sp_1[iy] > sp_2[iy]) *ip_1 = 1;"
$toi 653, "else *ip_2 = 1;"
$toi 654, "}"
$toi 699, "} /* tsub_compare_strings */"
sub_c_arrayout
'subroutine compare string to char for length
$toi 601, "/* subroutine tsub_comp_string_to_char */"
$toi 602, "void tsub_comp_string_to_char("
$toi 603, "char *sp_1, int ip_long, char cp_1, "
$toi 604, "int *ip_1, int *ip_2, int *ip_3) {"
$toi 611, "int iy, iz;"
$toi 612, "iy = 0; iz = 0;"
$toi 613, "*ip_1 = 2; *ip_2 = 2; *ip_3 = 2;"
$toi 621, "for(; iz < ip_long && iy == 0; iz++) {"
$toi 622, "if(sp_1[iz] > cp_1) iy = 1;"
$toi 623, "else if(sp_1[iz] < cp_1) iy = -1;"
$toi 624, "}"
$toi 631, "if(iy == 1) *ip_1 = 1;"
$toi 632, "if(iy == -1) *ip_2 = 1;"
$toi 633, "if(iy == 0) *ip_3 = 1;"
$toi 642, "} /* tsub_comp_string_to_char */"
sub_c_arrayout
ends sub_c_subroutines_tsub4
subr sub_c_subroutines_tsub5
'updated 2006/07/12, 2006/06/29, 2006/06/28, 2005/01/06
vari s_any, d_any, s_dot, d_dot, s_out
'blank the string array
arrb
'subroutine edit double to string
$toi 701, "void tsub_edit_double_to_string("
$toi 702, "char *sp_1, double dp_1, int ip_decimals, "
$toi 703, "char cp_edit, int *pip_long) {"
$toi 704, "/* subroutine edit double to string */"
$toi 705, "/* *pip_long is the length of the number */"
$toi 721, "char s_format[20], ca_y[30], ca_z[30], cz;"
$toi 722, "int i_long, iw, ix, iy, iz;"
$toi 723, "double d_double; int i_neg = 2;"
$toi 724, "int i_yescommas = 2, i_yessign = 2, i_yeszero = 2;"
$toi 725, #char s_numbers[12] = "0123456789";#
'first column is no sign, second has sign
'1,000 & zero 1 J
'1,000 2 K
'zero 3 L
'neither 4 M
'also Y and Z
$toi 741, "if(cp_edit == '1' || cp_edit == '2' || cp_edit == 'J' "
$toi 742, "|| cp_edit == 'K') i_yescommas = 1;"
$toi 743, "if(cp_edit >= 'J' && cp_edit <= 'M') i_yessign = 1;"
$toi 744, "if(cp_edit == '1' || cp_edit == 'J' || cp_edit == '3' "
$toi 745, "|| cp_edit == 'L') i_yeszero = 1;"
$toi 761, "tsub_blank(sp_1, 30);"
$toi 762, "tsub_blank(ca_z, 30);"
$toi 763, "tsub_blank(ca_y, 30);"
$toi 764, "tsub_blank(s_format, 20);"
$toi 765, "i_long = *pip_long;"
'make format string in s_format
'0123456789
'%25.2lf
$toi 781, #tsub_copy(s_format, "%25.2lf", 7);#
$toi 782, "s_format[4] = s_numbers[ip_decimals];"
$toi 783, "s_format[7] = 0;"
'make number positive
$toi 801, "if(dp_1 < 0) {"
$toi 802, "d_double = - dp_1; i_neg = 1;"
$toi 803, "}"
$toi 804, "else {"
$toi 805, "d_double = dp_1; i_neg = 2;"
$toi 806, "}"
'put number in string add 1 to length for decimal
$toi 821, #/* sprintf(ca_z, "%25.2lf", d_double); */#
$toi 822, "sprintf(ca_z, s_format, d_double);"
$toi 823, "i_long++;"
$toi 824, "tsub_copy(ca_y, ca_z, 25);"
$toi 841, "/* add commas if needed to ca_y */"
$toi 842, "if(i_yescommas == 1) {"
$toi 843, "/* first digit left of the decimal is */"
$toi 844, "/* 23 - ip_decimals */"
$toi 845, "iw = 23 - ip_decimals;"
$toi 846, "if(ip_decimals == 0) iw = 24;"
$toi 861, "/* the positive number ends in 24 */"
$toi 862, "/* copy digits from ca_z to ca_y adding commas */"
$toi 863, "for(iy = 0, ix = iw, iz = iw; iz > 0; iz--, ix--) {"
$toi 864, "/* iy counts the digits */"
$toi 865, "cz = ca_z[iz];"
$toi 881, "if(cz >= '0' && cz <= '9') {"
$toi 882, "/* we have a digit */"
$toi 883, "iy++;"
$toi 884, "if(iy > 3) {"
$toi 885, "iy = 1;"
$toi 886, "ca_y[ix] = ',';"
$toi 887, "i_long++;"
$toi 888, "ix--;"
$toi 889, "}"
$toi 890, "ca_y[ix] = cz;"
$toi 891, "}"
$toi 892, "}"
$toi 893, "}"
'put sign on
$toi 921, "if(i_yessign == 1) {"
$toi 922, "if(i_neg == 1) ca_y[25] = '-';"
$toi 923, "else ca_y[25] = ' ';"
$toi 924, "i_long++;"
$toi 925, "tsub_copy(sp_1, ca_y, 26);"
$toi 927, "}"
'do not put sign on
$toi 941, "else {"
$toi 942, "sp_1[0] = ' ';"
$toi 944, "tsub_copy(&sp_1[1], ca_y, 26);"
$toi 945, "}"
'not zeros
$toi 961, "if(d_double == 0.00 && i_yeszero != 1) "
$toi 962, "tsub_blank(sp_1, 30);"
$toi 991, "*pip_long = i_long;"
$toi 999, "} /* tsub_edit_double_to_string */"
sub_c_arrayout
'subroutine for numeric sort array
$toi 101, "/* subroutine numeric sorta */"
$toi 102, "void tsub_nsorta(double *dap_array, int ip_indexct) {"
$toi 103, "int ix1, ix2, i_last; double dx1, dx2, dx3;"
$toi 104, "i_last = ip_indexct - 1;"
$toi 111, "for(ix1 = 0; ix1 < i_last; ix1++) {"
$toi 112, "dx1 = dap_array[ix1];"
$toi 113, "for(ix2 = ix1 + 1; ix2 <= i_last; ix2++) {"
$toi 114, "dx2 = dap_array[ix2];"
$toi 115, "if(dx1 > dx2) {"
$toi 116, "dap_array[ix2] = dx1;"
$toi 117, "dap_array[ix1] = dx2;"
$toi 118, "dx1 = dx2;"
$toi 121, "}"
$toi 122, "}"
$toi 123, "}"
$toi 131, "} /* tsub_nsorta */"
'subroutine for alpha sort array
$toi 201, "/* subroutine alpha sorta */"
$toi 202, "void tsub_asorta(char *sap_array, "
$toi 203, "int ip_indexct, int ip_longct) {"
$toi 204, "char *ps_1; char *ps_2; int i_index1, i_index2;"
$toi 205, "int i_byte1, i_byte2, i_last, iy, iz; char cz;"
$toi 211, "i_last = ip_indexct;"
$toi 212, "for(i_index1 = 1; i_index1 < i_last; i_index1++) {"
$toi 213, "i_byte1 = (i_index1 - 1) * ip_longct;"
$toi 214, "ps_1 = &sap_array[i_byte1];"
$toi 221, "i_index2 = i_index1 + 1;"
$toi 222, "for(; i_index2 <= i_last; i_index2++) {"
$toi 223, "i_byte2 = (i_index2 - 1) * ip_longct;"
$toi 224, "ps_2 = &sap_array[i_byte2];"
$toi 231, "iy = tfni_compare_strings(ps_1, ps_2, ip_longct);"
$toi 232, "if(iy > 0) {"
$toi 233, "/* switch strings */"
$toi 234, "for(iy = 0; iy < ip_longct; iy++) {"
$toi 235, "cz = sap_array[i_byte1 + iy];"
$toi 236, "sap_array[i_byte1 + iy] = sap_array[i_byte2 + iy];"
$toi 237, "sap_array[i_byte2 + iy] = cz;"
$toi 238, "}"
$toi 239, "}"
$toi 244, "}"
$toi 245, "}"
$toi 251, "} /* tsub_asorta */"
$toi 301, "/* blank escapes for length */"
$toi 302, "void tsub_blank_escapes(char *sp_1, int ip1) {"
$toi 303, "int iz;"
$toi 304, "for(iz = 0; iz < ip1; iz++) {"
$toi 305, "if(sp_1[iz] < 32) sp_1[iz] = ' ';"
$toi 306, "}"
$toi 311, "} /* tsub_blank_escapes */"
$toi 401, "/* blank LF and after */"
$toi 402, "void tsub_blank_lf_and_after(char *sp_1, int ip1) {"
$toi 403, "int iy, iz;"
$toi 411, "for(iy = 0, iz = 0; iz < ip1; iz++) {"
'$toi 412, #if(sp_1[iz] < 32) printf("char=%d\n", sp_1[iz]);#
$toi 413, "if(sp_1[iz] == 10) iy = 1;"
$toi 414, "if(iy == 1) sp_1[iz] = ' ';"
$toi 441, "}"
$toi 451, "} /* tsub_blank_lf_after */"
$toi 501, "/* subroutine tsub_move_right_into_array */"
$toi 502, "void tsub_move_right_into_array(char *sp_1, int ip_indexct1, "
$toi 503, "int ip_longct1, char *sp_2, int ip_longct2) {"
$toi 504, "int i_index, iy, iz;"
'$toi 506, #printf("%d, %d, %d\n", ip_indexct1, ip_longct1, ip_longct2);#
$toi 511, "if(ip_longct2 > ip_longct1) ip_longct2 = ip_longct1;"
$toi 521, "for(i_index = 1; i_index <= ip_indexct1; i_index++) {"
$toi 522, "iz = (i_index - 1) * ip_longct1;"
$toi 523, "iz = iz + ip_longct1 - ip_longct2;"
$toi 524, "for(iy = 0; iy < ip_longct2; iy++) sp_1[iz + iy] = sp_2[iy];"
$toi 571, "}"
$toi 581, "} /* tsub_move_right_into_array */"
$toi 601, "/* subroutine tsub_translation_date */"
$toi 602, "void tsub_translation_date(void) {"
$toi 621, "tsub_char_out79('-');"
'rpgtoc translation date
$dat s_any
$cut s_any, s_any, 1, 20
$app s_any, " " + sg_inpfile
$app s_any, " translated by rpgtoc.tea for "
dift dg_operatingsystem = 1: $app s_any, "MPE"
dift dg_operatingsystem = 2: $app s_any, "Linux"
dift dg_operatingsystem = 3: $app s_any, "C90"
s_any = #tsub_out79("# + s_any + #");#
$toi 661, s_any
$toi 671, "tsub_char_out79('-');"
$toi 680, "} /* tsub_translation_date */"
$toi 701, "/* subroutine tsub_upper_case */"
$toi 702, "void tsub_upper_case(char *sp1, int ip_long) {"
$toi 711, "int iz;"
$toi 721, "for(iz = 0; iz < ip_long; iz++) {"
$toi 731, "if(sp1[iz] >= 97 && sp1[iz] <= 122)"
$toi 732, "sp1[iz] = sp1[iz] - 32;"
$toi 751, "}"
$toi 780, "} /* tsub_upper_case */"
sub_c_arrayout
ends sub_c_subroutines_tsub5
'******************
'printf codes below
'%c one character
'%d integer
'%ld long
'%lf double
'%s string of char
'printf codes above
'******************
subr sub_c_prototypes_rpg_commands
'updated 2005/01/13, 2004/12/27
vari s_any, d_any, s_dot, d_dot, s_out
'blank the string array
arrb
$toi 101, "/* rpg command prototypes */"
$toi 201, "void rsub_rpg_calculations(void);"
$toi 301, "void rsub_initialize_strings(void);"
$toi 401, "void rsub_initialize_arrays_from_bottom(void);"
$toi 501, "void rsub_command_seton(int *ip_1,int *ip_2,int *ip_3);"
$toi 601, "void rsub_command_setof(int *ip_1,int *ip_2,int *ip_3);"
$toi 701, "double rfnd_math_result(double dp_num, "
$toi 702, "int ip_decimals, char c_half, int ip_add);"
$toi 801, "double rfnd_divide(double dp_1, double dp_2,"
$toi 802, "int ip_dec, char cp_half, int ip_line);"
$toi 851, "double rfnd_mvr_modulus(double dp_1, double dp_2,"
$toi 852, "int ip_dec, char cp_half, int ip_line);"
sub_c_arrayout
$toi 101, "double rfnd_add(double dp1, int ip1, double dp2, int ip2);"
$toi 201, "double rfnd_subtract(double dp1, int ip1, "
$toi 202, "double dp2, int ip2);"
$toi 301, "void rsub_testn(char *sp_1, int ip_long, int *ip1, "
$toi 302, "int *ip2, int *ip3);"
$toi 401, "int rfni_slokup(char *sp_lookin, int ip_indexct, "
$toi 402, "int ip_long, int ip_begindex, char *sp_lookfor);"
$toi 451, "int rfni_stablokup(char *sp_lookin, int ip_indexct, "
$toi 452, "int ip_long1, int ip_long2, char *sp_lookfor, "
$toi 453, "char *sp_putinto);"
$toi 501, "int rfni_nlokup(double *dp_lookin, int ip_indexct, "
$toi 502, "int ip_decimals, int ip_begindex, double dp_lookfor);"
$toi 601, "void rsub_command_biton(char *sp_to, char *sp_from, "
$toi 602, "int ip_long);"
$toi 701, "void rsub_command_bitof(char *sp_to, char *sp_from, "
$toi 702, " int ip_long);"
$toi 801, "double rfnd_xfoot(double *dp_1, int ip_indexct);"
sub_c_arrayout
$toi 101, "void rsub_putjw(char *sp_1, double dp_1, int *ip_2);"
$toi 201, "void rsub_fndjw(char *sp_1, double *dp_1, int *ip_2);"
sub_c_arrayout
ends sub_c_prototypes_rpg_commands
subr sub_c_subroutines_rpg_commands
'updated 2005/01/13, 2004/12/29
vari s_any, d_any, s_dot, d_dot, s_out
'blank the string array
arrb
'subroutine seton command
$toi 1, "/* seton command */"
$toi 2, "void rsub_command_seton(int *ip_1,int *ip_2,int *ip_3) {"
$toi 3, "*ip_1 = 1; *ip_2 = 1; *ip_3 = 1;"
$toi 4, "} /* rsub_command_seton */"
'subroutine setof command
$toi 101, "/* setof command */"
$toi 102, "void rsub_command_setof(int *ip_1,int *ip_2,int *ip_3) {"
$toi 103, "*ip_1 = 2; *ip_2 = 2; *ip_3 = 2;"
$toi 104, "} /* rsub_command_setof */"
'subroutine rfnd_math_result
$toi 201, "/* math result */"
$toi 202, "double rfnd_math_result(double dp_num, "
$toi 203, "int ip_decimals, char cp_half, int ip_add) {"
$toi 211, "double dz;"
$toi 212, "dz = dp_num;"
$toi 221, "if(cp_half == 'H') {"
$toi 222, "dz = tfnd_round(dp_num, ip_decimals);"
$toi 223, "}"
$toi 231, "else {"
$toi 232, "dz = tfnd_trunc(dp_num, ip_decimals, ip_add);"
$toi 233, "}"
$toi 241, "return dz;"
$toi 249, "} /* rfnd_math_result */"
'subroutine rfnd_divide
$toi 301, "double rfnd_divide(double dp_1, double dp_2,"
$toi 302, "int ip_dec, char cp_half, int ip_line) {"
$toi 303, "double dz = 0; char cz[50];"
$toi 311, "if(dp_2 == 0.0) {"
$toi 312, #sprintf(cz, "zero divide line=%d", ip_line);#
$toi 313, "tsub_runtime_error_exit_program(cz);"
$toi 331, "}"
$toi 351, "else {"
$toi 352, "if(cp_half == 'H') {"
$toi 353, "dz = tfnd_round(dp_1 / dp_2, ip_dec);"
$toi 354, "}"
$toi 361, "else {"
$toi 362, "dz = tfnd_trunc(dp_1 / dp_2, ip_dec, 0);"
$toi 363, "}"
$toi 364, "}"
$toi 395, "return dz;"
$toi 399, "} /* rfnd_divide */"
'subroutine rfnd_mvr_modulus
$toi 401, "double rfnd_mvr_modulus(double dp_1, double dp_2,"
$toi 402, "int ip_dec, char cp_half, int ip_line) {"
$toi 403, "double dz = 0; char cz[50];"
$toi 411, "if(dp_2 == 0.0) {"
$toi 412, #sprintf(cz, "zero mvr modulus line=%d", ip_line);#
$toi 413, "tsub_runtime_error_exit_program(cz);"
$toi 431, "}"
$toi 451, "else {"
$toi 452, "if(cp_half == 'H') {"
$toi 453, "dz = tfnd_round(fmod(dp_1, dp_2), ip_dec);"
$toi 454, "}"
$toi 461, "else {"
$toi 462, "dz = tfnd_trunc(fmod(dp_1, dp_2), ip_dec, 0);"
$toi 463, "}"
$toi 491, "}"
$toi 495, "return dz;"
$toi 499, "} /* rfnd_mvr_modulus */"
sub_c_arrayout
'subroutine rfnd_add to add two numbers
$toi 501, "double rfnd_add(double dp1, int ip1, "
$toi 502, "double dp2, int ip2){"
$toi 503, "double d_factor, d_total; int iy, iz;"
$toi 504, "iy = ip1; d_factor = 1;"
$toi 505, "if(ip2 > ip1) iy = ip2;"
$toi 506, "for(iz = 0; iz < iy; iz++) d_factor = d_factor * 10;"
$toi 507, "d_total = dp1 * d_factor + dp2 * d_factor;"
$toi 508, "d_total = floor(d_total + 0.5) / d_factor;"
$toi 509, "return d_total;"
$toi 510, "} /* rfnd_add */"
'subroutine rfnd_subtract to sub two numbers
$toi 601, "double rfnd_subtract(double dp1, int ip1, "
$toi 602, "double dp2, int ip2){"
$toi 603, "double d_factor, d_total; int iy, iz;"
$toi 604, "iy = ip1; d_factor = 1;"
$toi 605, "if(ip2 > ip1) iy = ip2;"
$toi 606, "for(iz = 0; iz < iy; iz++) d_factor = d_factor * 10;"
$toi 607, "d_total = dp1 * d_factor - dp2 * d_factor;"
$toi 608, "d_total = floor(d_total + 0.5) / d_factor;"
$toi 609, "return d_total;"
$toi 610, "} /* rfnd_subtract */"
'subroutine rsub_testn
$toi 701, "/* subroutine of rsub_testn */"
$toi 702, "void rsub_testn(char *sp_1, int ip_long, int *ip1, "
$toi 703, "int *ip2, int *ip3) {"
$toi 704, "int i_result, i_blanks, i_num, i_char, iy, iz;"
$toi 705, "i_blanks = 0; i_num = 0; iy = 0;"
'all numbers turn on high, the manuals are wrong about all blanks
'blanks and numbers turn on low
'blanks only turn on equal
$toi 706, "for(iz = 0; iz < ip_long; iz++) {"
$toi 707, "i_char = sp_1[iz];"
$toi 708, "if(i_char == 32 && iy ==0) i_blanks++;"
$toi 709, "else {"
$toi 710, "iy++;"
$toi 711, "if(i_char >= '0' && i_char <= '9') i_num++;"
$toi 712, "else if(iz == (ip_long - 1)) {"
$toi 713, "if(i_char >= 'A' && i_char <= 'R') i_num++;"
$toi 714, "if(i_char == '{' || i_char == '}') i_num++;"
$toi 715, "}"
$toi 716, "}"
$toi 717, "}"
$toi 721, "*ip1 = 2; *ip2 = 2; *ip3 = 2;"
$toi 731, "if(i_num == ip_long) *ip1 = 1;"
$toi 732, "if(i_blanks == ip_long) *ip3 = 1;"
$toi 741, "iz = i_blanks + i_num; iy = i_blanks * i_num;"
$toi 742, "if(iz == ip_long && iy > 0) *ip2 = 1;"
$toi 751, "} /* rsub_testn */"
'subroutine rfni_slokup
$toi 801, "/* subroutine rfni_slokup */"
$toi 802, "/* numeric parameters as in rpg */"
$toi 803, "int rfni_slokup(char *sp_lookin, int ip_indexct, "
$toi 804, "int ip_long, int ip_begindex, char *sp_lookfor) {"
$toi 805, "int i_result = 0; int i_index, i_byte, iy, iz;"
$toi 806, "i_index = ip_begindex;"
$toi 807, "for(; i_index <= ip_indexct; i_index++) {"
$toi 808, "i_byte = (i_index - 1) * ip_long;"
$toi 809, "for(iy = 1, iz = 0; iz < ip_long; iz++) {"
$toi 810, "if(sp_lookin[i_byte + iz] != sp_lookfor[iz]) iy++;"
$toi 811, "}"
$toi 812, "if(iy == 1) {"
$toi 813, "i_result = i_index;"
$toi 814, "i_index = ip_indexct + 1;"
$toi 815, "}"
$toi 816, "}"
$toi 817, "return i_result;"
$toi 818, "} /* rfni_slokup */"
'subroutine rsub_stablokup
$toi 851, "int rfni_stablokup(char *sp_lookin, int ip_indexct, "
$toi 852, "int ip_long1, int ip_long2, char *sp_lookfor, "
$toi 853, "char *sp_putinto) {"
$toi 861, "int i_result, i_loop, iw, ix, iy, iz;"
$toi 862, "i_result = 2; i_loop = 1; iz = 0;"
$toi 863, "iw = ip_long1 + ip_long2;"
$toi 866, "while(i_loop == 1) {"
$toi 867, "ix = tfni_compare_strings(&sp_lookin[iz * iw], sp_lookfor, "
$toi 868, "ip_long1);"
$toi 869, "if(ix == 0) {"
$toi 870, "i_result = 1; i_loop++;"
$toi 871, "iy = iz * iw + ip_long1;"
$toi 872, "}"
$toi 875, "iz++;"
$toi 876, "if(iz >= ip_indexct) i_loop++;"
$toi 877, "}"
$toi 881, "if(i_result == 1) tsub_copy(sp_putinto, &sp_lookin[iy], "
$toi 882, "ip_long2);"
$toi 889, "return i_result;"
$toi 890, "} /* rfni_stablokup */"
'subroutine rfni_nlokup
$toi 901, "/* subroutine rfni_nlokup */"
$toi 902, "/* numeric parameters as in rpg */"
$toi 903, "int rfni_nlokup(double *dpp_lookin, int ip_indexct, "
$toi 904, "int ip_decimals, int ip_begindex, double dp_lookfor) {"
$toi 911, "int i_result = 0; int i_index, i_cindex, iy, iz;"
$toi 912, "double d_lookfor, d_lookat;"
$toi 913, "d_lookfor = tfnd_trunc(dp_lookfor, ip_decimals, 0);"
$toi 914, "i_index = ip_begindex;"
$toi 921, "for(; i_index <= ip_indexct; i_index++) {"
$toi 922, "i_cindex = i_index - 1;"
$toi 923, "d_lookat = tfnd_trunc(dpp_lookin[i_cindex], "
$toi 924, "ip_decimals, 0);"
$toi 931, "if(d_lookfor == d_lookat) {"
$toi 932, "i_result = i_index;"
$toi 933, "i_index = ip_indexct + 1;"
$toi 941, "}"
$toi 951, "}"
$toi 961, "return i_result;"
$toi 999, "} /* rfni_nlokup */"
sub_c_arrayout
'subroutine rsub_command_bitof
$toi 101, "/* rsubroutine rsub_command_bitof */"
$toi 102, "void rsub_command_bitof(char *sp_to, char *sp_from,"
$toi 103, "int ip_long) {"
$toi 104, "int iz;"
'diagnostic
'$toi 107, "iz = sp_to[0];"
'$toi 108, #printf("bitof1=%d\n", iz);#
$toi 111, "for(iz = 0; iz < ip_long; iz++) {"
$toi 112, "if(sp_from[iz] == '7') sp_to[0] = sp_to[0] & ~1;"
$toi 113, "else if(sp_from[iz] == '6') sp_to[0] = sp_to[0] & ~2;"
$toi 114, "else if(sp_from[iz] == '5') sp_to[0] = sp_to[0] & ~4;"
$toi 115, "else if(sp_from[iz] == '4') sp_to[0] = sp_to[0] & ~8;"
$toi 116, "else if(sp_from[iz] == '3') sp_to[0] = sp_to[0] & ~16;"
$toi 117, "else if(sp_from[iz] == '2') sp_to[0] = sp_to[0] & ~32;"
$toi 118, "else if(sp_from[iz] == '1') sp_to[0] = sp_to[0] & ~64;"
$toi 119, "else if(sp_from[iz] == '0') sp_to[0] = sp_to[0] & ~128;"
$toi 121, "}"
'diagnostic
'$toi 181, "iz = sp_to[0];"
'$toi 182, #printf("bitof2=%d\n", iz);#
$toi 199, "} /* rsub_command_bitof */"
'subroutine rsub_command_biton
$toi 201, "/* rsubroutine rsub_command_biton */"
$toi 202, "void rsub_command_biton(char *sp_to, char *sp_from,"
$toi 203, "int ip_long) {"
$toi 204, "int iz;"
'diagnostic
'$toi 207, "iz = sp_to[0];"
'$toi 208, #printf("biton1=%d\n", iz);#
$toi 211, "for(iz = 0; iz < ip_long; iz++) {"
$toi 212, "if(sp_from[iz] == '7') sp_to[0] = sp_to[0] | 1;"
$toi 213, "else if(sp_from[iz] == '6') sp_to[0] = sp_to[0] | 2;"
$toi 214, "else if(sp_from[iz] == '5') sp_to[0] = sp_to[0] | 4;"
$toi 215, "else if(sp_from[iz] == '4') sp_to[0] = sp_to[0] | 8;"
$toi 216, "else if(sp_from[iz] == '3') sp_to[0] = sp_to[0] | 16;"
$toi 217, "else if(sp_from[iz] == '2') sp_to[0] = sp_to[0] | 32;"
$toi 218, "else if(sp_from[iz] == '1') sp_to[0] = sp_to[0] | 64;"
$toi 219, "else if(sp_from[iz] == '0') sp_to[0] = sp_to[0] | 128;"
$toi 221, "}"
'diagnostic
'$toi 281, "iz = sp_to[0];"
'$toi 282, #printf("biton2=%d\n", iz);#
$toi 299, "} /* rsub_command_biton */"
'subroutine rfnd_xfoot
$toi 301, "/* function rfnd_xfoot */"
$toi 302, "double rfnd_xfoot(double *dp_1, int ip_indexct) {"
$toi 303, "double d_total; int iz;"
$toi 311, "for(d_total = 0, iz = 0; iz < ip_indexct; iz++) {"
$toi 312, "d_total = d_total + dp_1[iz];"
$toi 313, "}"
$toi 349, "return d_total;"
$toi 350, "} /* rfnd_xfoot */"
sub_c_arrayout
'subroutine rsub_putjw
$toi 101, "/* subroutine to do putjw 0 to 65535*/"
$toi 102, "void rsub_putjw(char *sp_1, double dp_1, int *ip_2) {"
$toi 103, "double dz; long n_jcw; int iz; char cz[25];"
$toi 104, "int i_error = 2;"
$toi 111, "tsub_blank(cz, 25);"
$toi 112, "/* 01234567890123456789 */"
$toi 113, "/* SETJCW J234567=65535 */"
$toi 121, #tsub_copy(cz, "SETJCW ", 7);#
$toi 122, "tsub_copy(&cz[7], sp_1, 7);"
$toi 123, "tsub_blank_escapes(cz, 25);"
$toi 124, "cz[14] = '=';"
$toi 141, "dz = floor(dp_1 + 0.51);"
$toi 142, "if(dz > 65535) i_error = 1;"
$toi 143, "else if(dz < 0) i_error = 1;"
$toi 144, "else n_jcw = (long)dz;"
$toi 151, "if(i_error != 1) {"
$toi 152, #sprintf(&cz[15], "%ld", n_jcw);#
$toi 153, "iz = system(cz);"
$toi 154, "if(iz != 0) i_error = 1;"
$toi 155, "}"
$toi 162, "*ip_2 = 2;"
$toi 163, "if(i_error != 1) *ip_2 = 1;"
$toi 199, "} /* rsub_putjw */"
'subroutine rsub_fndjw
$toi 201, "/* subroutine to do fndjw */"
$toi 202, "void rsub_fndjw(char *sp_1, double *dp_1, int *ip_2) {"
$toi 203, "char *ps_1; int iz; char cz[10];"
$toi 211, "tsub_blank(cz, 10);"
$toi 212, "tsub_copy(cz, sp_1, 7);"
$toi 213, "cz[8] = 0;"
$toi 221, "*ip_2 = 2;"
$toi 222, "ps_1 = getenv(cz);"
$toi 231, "if(ps_1 != NULL) {"
$toi 251, "*dp_1 = tfnn_string_of_numbers(ps_1);"
$toi 252, "*ip_2 = 1;"
$toi 253, "}"
$toi 299, "} /* rsub_fndjw */"
sub_c_arrayout
ends sub_c_subroutines_rpg_commands
subr sub_crpg_prototypes
'updated 2004/08/05
arrb
'prototype rsub_crpg_movea
$toi 101, "void rsub_crpg_movea("
$toi 102, "char *sp_1, int ip_indexct1, int ip_longct1, int ip_beg1, "
$toi 103, "char *sp_2, int ip_indexct2, int ip_longct2, int ip_beg2);"
$toi 105, "/* movea from sp_2 to sp_1, rpg parms */"
sub_c_arrayout
'prototype rsub_crpg_movel
$toi 101, "void rsub_crpg_movel("
$toi 102, "char *sp_1, int ip_longct1, "
$toi 103, "char *sp_2, int ip_longct2);"
sub_c_arrayout
'prototype rsub_crpg_move_right
$toi 101, "void rsub_crpg_move_right("
$toi 102, "char *sp_1, int ip_longct1, "
$toi 103, "char *sp_2, int ip_longct2);"
sub_c_arrayout
'prototype rsub_crpg_movea_blankorzero
$toi 101, "void rsub_crpg_movea_blankorzero("
$toi 102, "char *sp_1, int ip_indexct, int ip_longct, "
$toi 103, "int ip_beg, char cp_1);"
$toi 104, "/* subroutine blank or zero to sp_1 of ip_indexct of */"
$toi 105, "/* ip_longct beginning at ip_beg using char cp_1 */"
sub_c_arrayout
ends sub_crpg_prototypes
subr sub_crpg_subroutines
'updated 2004/08/05
arrb
'subroutine rsub_crpg_movea
$toi 101, "void rsub_crpg_movea("
$toi 102, "char *sp_1, int ip_indexct1, int ip_longct1, int ip_beg1, "
$toi 103, "char *sp_2, int ip_indexct2, int ip_longct2, int ip_beg2"
$toi 104, ") {"
$toi 105, "/* movea from sp_2 to sp_1, parms are rpg */"
$toi 111, "int i_cbeg1, i_cbeg2, i_clong1, i_clong2;"
$toi 112, "int i_ctogoct1, i_ctogoct2;"
$toi 113, "int i_cbytect, i_error = 2, iz;"
$toi 141, "i_cbeg2 = (ip_beg2 - 1) * ip_longct2;"
$toi 142, "i_cbeg1 = (ip_beg1 - 1) * ip_longct1;"
$toi 151, "i_clong2 = ip_indexct2 * ip_longct2;"
$toi 152, "i_clong1 = ip_indexct1 * ip_longct1;"
$toi 161, "if(i_cbeg1 < 0 || i_cbeg1 >= i_clong1) i_error = 1;"
$toi 162, "if(i_cbeg2 < 0 || i_cbeg2 >= i_clong2) i_error = 1;"
$toi 171, "i_ctogoct2 = i_clong2 - i_cbeg2;"
$toi 172, "i_ctogoct1 = i_clong1 - i_cbeg1;"
$toi 173, "if(i_ctogoct2 < i_ctogoct1) i_cbytect = i_ctogoct2;"
$toi 174, "else i_cbytect = i_ctogoct1;"
$toi 182, "if(i_error == 1) {"
$toi 183, #tsub_cerror("bad index in MOVEA");#
$toi 184, "}"
$toi 191, "else {"
$toi 192, "for(iz = 0; iz < i_cbytect; iz++) {"
$toi 193, "sp_1[i_cbeg1 + iz] = sp_2[i_cbeg2 + iz];"
$toi 194, "}"
$toi 195, "}"
$toi 299, "} /* rsub_crpg_movea */"
sub_c_arrayout
'subroutine rsub_crpg_movel
$toi 101, "void rsub_crpg_movel("
$toi 102, "char *sp_1, int ip_longct1, "
$toi 103, "char *sp_2, int ip_longct2) {"
$toi 104, "/* movel from sp_2 to sp_1, parms are rpg */"
$toi 111, "int iy, iz;"
$toi 132, "if(ip_longct2 < ip_longct1) iy = ip_longct2;"
$toi 133, "else iy = ip_longct1;"
$toi 141, "for(iz = 0; iz < iy; iz++) sp_1[iz] = sp_2[iz];"
$toi 199, "} /* rsub_crpg_movel */"
sub_c_arrayout
'subroutine rsub_crpg_move_right
$toi 101, "void rsub_crpg_move_right("
$toi 102, "char *sp_1, int ip_longct1, "
$toi 103, "char *sp_2, int ip_longct2) {"
$toi 104, "/* move_right from sp_2 to sp_1 */"
$toi 111, "int iy, iz;"
$toi 131, "if(ip_longct2 < ip_longct1) iy = ip_longct2;"
$toi 132, "else iy = ip_longct1;"
$toi 141, "for(iz = 1; iz <= iy; iz++) {"
$toi 142, "sp_1[ip_longct1 - iz] = sp_2[ip_longct2 - iz];"
$toi 143, "}"
$toi 199, "} /* rsub_crpg_move_right */"
sub_c_arrayout
'subroutine rsub_crpg_movea_blankorzero
$toi 101, "void rsub_crpg_movea_blankorzero("
$toi 102, "char *sp_1, int ip_indexct, int ip_longct, "
$toi 103, "int ip_beg, char cp_1) {"
$toi 104, "/* subroutine blank or zero to sp_1 of ip_indexct of */"
$toi 105, "/* ip_longct beginning at ip_beg using char cp_1 */"
$toi 106, "/* rpg parameters */"
$toi 111, "int i_begbt, i_longtot, iz;"
$toi 121, "i_longtot = ip_indexct * ip_longct;"
$toi 122, "i_begbt = (ip_beg - 1) * ip_longct;"
$toi 131, "if(i_begbt < 0 || i_begbt >= i_longtot) {"
$toi 132, #tsub_cerror("bad index");#
$toi 133, "}"
$toi 134, "else {"
$toi 151, "for(iz = i_begbt; iz < i_longtot; iz++) "
$toi 152, "sp_1[iz] = cp_1;"
$toi 161, "}"
$toi 191, "} /* rsub_crpg_movea_blankorzero */"
sub_c_arrayout
ends sub_crpg_subroutines
subr sub_c_cline_fullcdebug_beg
'updated 2004/07/21
'write clines for cdebug of a program record
vari s_any, d_any, s_dot, d_dot, s_out
vari d_record, s_record, d_good, d_yeslines
vari s_factor1, s_command, s_factor2, s_result
vari s_var1, s_var2, d_type1, d_type2
vari d_indexct1, d_decimalct1, d_longct1
vari s_indicators1, s_indicators2
vari s_cfield, d_action, d_yesnumberruler
s_record = sg_pass1
d_record = dg_pass1
'cline 1 2 3 4 5 6
'123456789012345678901234567890123456789012345678901234567890
' .CSR 01 02 03FACTOR1 COMMDFACTOR2 RESULT 92H919293
$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
'is there anything to cdebug
d_yeslines = 2
d_yesnumberruler = 2
sg_pass1 = "if(tig_cdebug == 1) {"
sub_c_lineout
sg_pass1 = #tsub_out79("******************");#
sub_c_lineout
$ift s_command = "GOTO "
$trb s_any, s_record
$swp s_any, #"#, "'"
sg_pass1 = #tsub_out79("# + d_record + " " + s_any + #");#
sub_c_lineout
endi
'begin indicators
s_any = s_indicators1 + s_indicators2
$isc d_any, s_any, " "
dift d_any <> 1
d_yeslines = 1
'blank tsg_256a to show indicators
sg_pass1 = "tsub_blank(tsg_256a, 80);"
sub_c_lineout
$cut s_any, s_record, 10, 2
$isc d_any, s_any, " "
dift d_any <> 1
'99=on
sg_pass1 = #tsub_copy(&tsg_256a[0], "#
$app sg_pass1, s_any + "=on" + #", 5);#
sub_c_lineout
'99=off
sg_pass1 = "if(ig_" + s_any + " != 1) "
$app sg_pass1, #tsub_copy(&tsg_256a[3], "#
$app sg_pass1, "off" + #", 3);#
sub_c_lineout
endi
$cut s_any, s_record, 13, 2
$isc d_any, s_any, " "
dift d_any <> 1
'99=on
sg_pass1 = #tsub_copy(&tsg_256a[10], "#
$app sg_pass1, s_any + "=on" + #", 5);#
sub_c_lineout
'99=off
sg_pass1 = "if(ig_" + s_any + " != 1) "
$app sg_pass1, #tsub_copy(&tsg_256a[13], "#
$app sg_pass1, "off" + #", 3);#
sub_c_lineout
endi
$cut s_any, s_record, 16, 2
$isc d_any, s_any, " "
dift d_any <> 1
'99=on
sg_pass1 = #tsub_copy(&tsg_256a[20], "#
$app sg_pass1, s_any + "=on" + #", 5);#
sub_c_lineout
'99=off
sg_pass1 = "if(ig_" + s_any + " != 1) "
$app sg_pass1, #tsub_copy(&tsg_256a[23], "#
$app sg_pass1, "off" + #", 3);#
sub_c_lineout
endi
$cut s_any, s_record, 54, 2
$isc d_any, s_any, " "
dift d_any <> 1
'99=on
sg_pass1 = #tsub_copy(&tsg_256a[40], "#
$app sg_pass1, s_any + "=on" + #", 5);#
sub_c_lineout
'99=off
sg_pass1 = "if(ig_" + s_any + " != 1) "
$app sg_pass1, #tsub_copy(&tsg_256a[43], "#
$app sg_pass1, "off" + #", 3);#
sub_c_lineout
endi
$cut s_any, s_record, 56, 2
$isc d_any, s_any, " "
dift d_any <> 1
'99=on
sg_pass1 = #tsub_copy(&tsg_256a[50], "#
$app sg_pass1, s_any + "=on" + #", 5);#
sub_c_lineout
'99=off
sg_pass1 = "if(ig_" + s_any + " != 1) "
$app sg_pass1, #tsub_copy(&tsg_256a[53], "#
$app sg_pass1, "off" + #", 3);#
sub_c_lineout
endi
$cut s_any, s_record, 58, 2
$isc d_any, s_any, " "
dift d_any <> 1
'99=on
sg_pass1 = #tsub_copy(&tsg_256a[60], "#
$app sg_pass1, s_any + "=on" + #", 5);#
sub_c_lineout
'99=off
sg_pass1 = "if(ig_" + s_any + " != 1) "
$app sg_pass1, #tsub_copy(&tsg_256a[63], "#
$app sg_pass1, "off" + #", 3);#
sub_c_lineout
endi
sg_pass1 = "tsub_out79(tsg_256a);"
sub_c_lineout
endi
'indicators above
sg_pass1 = s_factor1
sub_c_cline_varfullcdebug
dift dg_pass1 = 1
d_yeslines = 1
d_yesnumberruler = 1
endi
sg_pass1 = s_factor2
sub_c_cline_varfullcdebug
dift dg_pass1 = 1
d_yeslines = 1
d_yesnumberruler = 1
endi
sg_pass1 = s_result
sub_c_cline_varfullcdebug
dift dg_pass1 = 1
d_yeslines = 1
d_yesnumberruler = 1
endi
dift d_yesnumberruler = 1
sg_pass1 = "tsub_numberruler(11);"
sub_c_lineout
endi
sg_pass1 = "} /* tig_cdebug ==1 */"
sub_c_lineout
ends sub_c_cline_fullcdebug_beg
subr sub_c_cline_fullcdebug_end
'updated 2004/08/31
'write clines for cdebug of a program record
vari s_any, d_any, s_dot, d_dot, s_out
vari d_record, s_record, d_good, d_yeslines
vari s_factor1, s_command, s_factor2, s_result
vari s_var1, s_var2, d_type1, d_type2
vari d_indexct1, d_decimalct1, d_longct1
vari s_indicators1, s_indicators2
vari s_cfield, d_action, d_yesnumberruler
vari s_allvarsizes
s_record = sg_pass1
d_record = dg_pass1
'cline 1 2 3 4 5 6
'123456789012345678901234567890123456789012345678901234567890
' .CSR 01 02 03FACTOR1 COMMDFACTOR2 RESULT 92H919293
$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
'is there anything to cdebug
s_allvarsizes = sg_nothing
d_yeslines = 2
d_yesnumberruler = 2
sg_pass1 = "if(tig_cdebug == 1) {"
sub_c_lineout
sg_pass1 = "tsub_char_out79('-');"
sub_c_lineout
'begin indicators and end indicators
s_any = s_indicators1 + s_indicators2
$isc d_any, s_any, " "
dift d_any <> 1
d_yeslines = 1
'blank tsg_256a to show indicators
sg_pass1 = "tsub_blank(tsg_256a, 80);"
sub_c_lineout
$cut s_any, s_record, 10, 2
$isc d_any, s_any, " "
dift d_any <> 1
'99=on
sg_pass1 = #tsub_copy(&tsg_256a[0], "#
$app sg_pass1, s_any + "=on" + #", 5);#
sub_c_lineout
'99=off
sg_pass1 = "if(ig_" + s_any + " != 1) "
$app sg_pass1, #tsub_copy(&tsg_256a[3], "#
$app sg_pass1, "off" + #", 3);#
sub_c_lineout
endi
$cut s_any, s_record, 13, 2
$isc d_any, s_any, " "
dift d_any <> 1
'99=on
sg_pass1 = #tsub_copy(&tsg_256a[10], "#
$app sg_pass1, s_any + "=on" + #", 5);#
sub_c_lineout
'99=off
sg_pass1 = "if(ig_" + s_any + " != 1) "
$app sg_pass1, #tsub_copy(&tsg_256a[13], "#
$app sg_pass1, "off" + #", 3);#
sub_c_lineout
endi
$cut s_any, s_record, 16, 2
$isc d_any, s_any, " "
dift d_any <> 1
'99=on
sg_pass1 = #tsub_copy(&tsg_256a[20], "#
$app sg_pass1, s_any + "=on" + #", 5);#
sub_c_lineout
'99=off
sg_pass1 = "if(ig_" + s_any + " != 1) "
$app sg_pass1, #tsub_copy(&tsg_256a[23], "#
$app sg_pass1, "off" + #", 3);#
sub_c_lineout
endi
$cut s_any, s_record, 54, 2
$isc d_any, s_any, " "
dift d_any <> 1
'99=on
sg_pass1 = #tsub_copy(&tsg_256a[40], "#
$app sg_pass1, s_any + "=on" + #", 5);#
sub_c_lineout
'99=off
sg_pass1 = "if(ig_" + s_any + " != 1) "
$app sg_pass1, #tsub_copy(&tsg_256a[43], "#
$app sg_pass1, "off" + #", 3);#
sub_c_lineout
endi
$cut s_any, s_record, 56, 2
$isc d_any, s_any, " "
dift d_any <> 1
'99=on
sg_pass1 = #tsub_copy(&tsg_256a[50], "#
$app sg_pass1, s_any + "=on" + #", 5);#
sub_c_lineout
'99=off
sg_pass1 = "if(ig_" + s_any + " != 1) "
$app sg_pass1, #tsub_copy(&tsg_256a[53], "#
$app sg_pass1, "off" + #", 3);#
sub_c_lineout
endi
$cut s_any, s_record, 58, 2
$isc d_any, s_any, " "
dift d_any <> 1
'99=on
sg_pass1 = #tsub_copy(&tsg_256a[60], "#
$app sg_pass1, s_any + "=on" + #", 5);#
sub_c_lineout
'99=off
sg_pass1 = "if(ig_" + s_any + " != 1) "
$app sg_pass1, #tsub_copy(&tsg_256a[63], "#
$app sg_pass1, "off" + #", 3);#
sub_c_lineout
endi
sg_pass1 = "tsub_out79(tsg_256a);"
sub_c_lineout
endi
'indicators above
sg_pass1 = s_factor1
sub_c_cline_varfullcdebug
dift dg_pass1 = 1
d_yeslines = 1
d_yesnumberruler = 1
$app s_allvarsizes, sg_pass1
endi
sg_pass1 = s_factor2
sub_c_cline_varfullcdebug
dift dg_pass1 = 1
d_yeslines = 1
d_yesnumberruler = 1
$app s_allvarsizes, " " + sg_pass1
endi
sg_pass1 = s_result
sub_c_cline_varfullcdebug
dift dg_pass1 = 1
d_yeslines = 1
d_yesnumberruler = 1
$app s_allvarsizes, " " + sg_pass1
endi
dift d_yesnumberruler = 1
sg_pass1 = "tsub_numberruler(11);"
sub_c_lineout
endi
dift d_yeslines = 1
'output all field varsizes
$trb s_allvarsizes, s_allvarsizes
$len d_any, s_allvarsizes
dift d_any > 0
sg_pass1 = #tsub_out79("# + s_allvarsizes + #");#
sub_c_lineout
endi
endi
$trb s_any, s_record
$swp s_any, #"#, "'"
sg_pass1 = #tsub_out79("# + d_record + " " + s_any + #");#
sub_c_lineout
dift d_yeslines = 1
sg_pass1 = #tsub_cdebug("");#
sub_c_lineout
endi
sg_pass1 = "} /* tig_cdebug ==1 */"
sub_c_lineout
ends sub_c_cline_fullcdebug_end
subr sub_c_cline_varfullcdebug
'updated 2006/11/01, 004/12/29
'write clines for cdebug of a program record
vari s_any, d_any, s_dot, d_dot, s_out
vari s_field, d_good, d_yeslines
vari s_var1, d_type1
vari d_indexct1, d_decimalct1, d_longct1
vari s_var2, d_type2
vari d_indexct2, d_decimalct2, d_longct2
vari s_cfield, d_action, d_end
vari s_varsize1, s_varsize2, s_expvarsizes
s_field = sg_pass1
'is there anything to cdebug
d_yeslines = 2
'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
'get info for
d_action = 0
$isc d_any, s_field, " "
dift d_any <> 1
'turn off errors in case of files or tags
dinc dg_showerror
sg_pass1 = s_field
sub_field_info_return
d_type1 = dg_pass1
d_type2 = dg_pass2
d_indexct1 = dg_pass3
d_longct1 = dg_pass4
d_decimalct1 = dg_pass5
d_longct2 = dg_pass6
d_decimalct2 = dg_pass7
s_var1 = sg_pass1
s_var2 = sg_pass2
s_cfield = sg_pass4
s_varsize1 = sg_pass5
s_varsize2 = sg_pass6
'we want to show errors
dg_showerror = 1
d_end = 80
$trb s_field, s_field
$app s_field, sg_20blanks
$cut s_field, s_field, 1, 10
'prep s_expvarsizes for export
'varsize=type of var,indexct,longct,decimals
s_expvarsizes = sg_nothing
$len d_any, s_varsize1
dift d_any = 9
s_expvarsizes = s_var1 + "=" + s_varsize1
$len d_any, s_varsize2
dift d_any = 9
$app s_expvarsizes, " " + s_var2
$app s_expvarsizes, "=" + s_varsize2
endi
endi
dift d_type1 = 12: d_action = 12
dift d_type1 = 13: d_action = 13
dift d_type1 = 14: d_action = 14
dift d_type1 = 22: d_action = 22
dift d_type1 = 23: d_action = 23
dift d_type1 = 24: d_action = 24
endi
dift d_action = 12
'numeric variable
d_yeslines = 1
sg_pass1 = #printf("# + s_field + "=%17."
$app sg_pass1, d_decimalct1 + "lf\n" + #", #
$app sg_pass1, s_cfield + ");"
sub_c_lineout
endi
dift d_action = 13
'numeric array with index
d_yeslines = 1
sg_pass1 = #printf("# + s_field + "=%17."
$app sg_pass1, d_decimalct1 + "lf\n" + #", #
$app sg_pass1, s_cfield + ");"
sub_c_lineout
dift d_type2 = 12
'numeric variable for index
$tlo s_dot, s_var2
$app s_var2, sg_20blanks
$cut s_var2, s_var2, 1, 10
$cup s_var2, s_var2
sg_pass1 = #printf("# + s_var2 + "=%17."
$app sg_pass1, d_decimalct2 + "lf\n" + #", #
$app sg_pass1, "dg_" + s_dot + ");"
sub_c_lineout
endi
endi
dift d_action = 14
'numeric array no index
d_yeslines = 1
sg_pass1 = #printf("# + s_field + ",1=%15."
$app sg_pass1, d_decimalct1 + "lf\n" + #", #
$app sg_pass1, s_cfield + "[0] );"
sub_c_lineout
dift d_indexct1 > 1
sg_pass1 = #printf("# + s_field + ",2=%15."
$app sg_pass1, d_decimalct1 + "lf\n" + #", #
$app sg_pass1, s_cfield + "[1] );"
sub_c_lineout
endi
dift d_indexct1 > 2
sg_pass1 = #printf("# + s_field + ",3=%15."
$app sg_pass1, d_decimalct1 + "lf\n" + #", #
$app sg_pass1, s_cfield + "[2] );"
sub_c_lineout
endi
endi
dift d_action = 22
'alpha variable
d_yeslines = 1
'blank tsg_256a to show indicators
sg_pass1 = "tsub_blank(tsg_256a, 80);"
sub_c_lineout
d_dot = d_longct1
dift d_dot > d_end: d_dot = d_end
sg_pass1 = "tsub_copy(tsg_256a, "
$app sg_pass1, s_cfield + ", " + d_dot + ");"
sub_c_lineout
dift d_longct1 > 1
'put = at end of string which is longer than 1
sg_pass1 = "tsg_256a[" + d_dot + "] = '=';"
sub_c_lineout
'put 0 at end of string which is longer than 1
dinc d_dot
sg_pass1 = "tsg_256a[" + d_dot + "] = 0;"
sub_c_lineout
else
'field is one long
sg_pass1 = "tig_z = tsg_256a[0];"
sub_c_lineout
sg_pass1 = "if(tig_z < 32) tsg_256a[0] = 32;"
sub_c_lineout
sg_pass1 = #sprintf(&tsg_256a[1], "= char number=%d", #
$app sg_pass1, "tig_z);"
sub_c_lineout
endi
sg_pass1 = #sprintf(tsg_256b, "# + s_field + #=%s\n", #
$app sg_pass1, "tsg_256a);"
sub_c_lineout
sg_pass1 = "tsub_out79(tsg_256b);"
sub_c_lineout
endi
dift d_action = 23
'indexed alpha array
d_yeslines = 1
'blank tsg_256a
sg_pass1 = "tsub_blank(tsg_256a, 80);"
sub_c_lineout
'how long in bytes to the end of the array
$tlo s_dot, s_var2
'd_type2=12 for numeric variable
dift d_type2 = 12: s_dot = "tfni_index(dg_" + s_dot + ")"
sg_pass1 = "tig_z = (" + d_indexct1 + " - " + s_dot
$app sg_pass1, " + 1) * " + d_longct1 + ";"
sub_c_lineout
sg_pass1 = "if(tig_z > " + d_end + ") tig_z = "
$app sg_pass1, d_end + ";"
sub_c_lineout
sg_pass1 = "tsub_copy(tsg_256a, &"
$app sg_pass1, s_cfield + ", tig_z);"
sub_c_lineout
sg_pass1 = "tsg_256a[tig_z] = 0;"
sub_c_lineout
sg_pass1 = #sprintf(tsg_256b, "# + s_field + #=%s=\n", #
$app sg_pass1, "tsg_256a);"
sub_c_lineout
sg_pass1 = "tsub_out79(tsg_256b);"
sub_c_lineout
'now output the whole alpha array
'blank tsg_256a
sg_pass1 = "tsub_blank(tsg_256a, 80);"
sub_c_lineout
d_dot = d_indexct1 * d_longct1
dift d_dot > d_end: d_dot = d_end
$tlo s_var1, s_var1
sg_pass1 = "tsub_copy(tsg_256a, sga_"
$app sg_pass1, s_var1 + ", " + d_dot + ");"
sub_c_lineout
sg_pass1 = "tsg_256a[" + d_dot + "] = 0;"
sub_c_lineout
s_dot = s_var1 + sg_20blanks
$cut s_dot, s_dot, 1, 10
$cup s_dot, s_dot
sg_pass1 = #sprintf(tsg_256b, "# + s_dot + #=%s=\n", #
$app sg_pass1, "tsg_256a);"
sub_c_lineout
sg_pass1 = "tsub_out79(tsg_256b);"
sub_c_lineout
dift d_type2 = 12
'numeric variable for index
$tlo s_dot, s_var2
$app s_var2, sg_20blanks
$cut s_var2, s_var2, 1, 10
$cup s_var2, s_var2
sg_pass1 = #printf("# + s_var2 + "=%17."
$app sg_pass1, d_decimalct2 + "lf\n" + #", #
$app sg_pass1, "dg_" + s_dot + ");"
sub_c_lineout
endi
endi
dift d_action = 24
'whole alpha arrays
d_yeslines = 1
'is this a table
$cut s_any, s_field, 1, 3
$ift s_any = "TAB"
's_field is a table so fix d_longct1
$cut s_any, s_field, 1, 6
$lok d_any, sg_rpgtabnames1, 1, s_any
$cut s_any, sg_rpgtabnames2, d_any, 6
sg_pass1 = s_any
sub_variable_info_return
d_dot = dg_pass3
d_longct1 = d_longct1 + d_dot
endi
'blank tsg_256a
sg_pass1 = "tsub_blank(tsg_256a, 80);"
sub_c_lineout
d_dot = d_indexct1 * d_longct1
dift d_dot > d_end: d_dot = d_end
sg_pass1 = "tsub_copy(tsg_256a, "
$app sg_pass1, s_cfield + ", " + d_dot + ");"
sub_c_lineout
sg_pass1 = "tsg_256a[" + d_dot + "] = 0;"
sub_c_lineout
sg_pass1 = #sprintf(tsg_256b, "# + s_field + #=%s=\n", #
$app sg_pass1, "tsg_256a);"
sub_c_lineout
sg_pass1 = "tsub_out79(tsg_256b);"
sub_c_lineout
endi
dg_pass1 = d_yeslines
sg_pass1 = s_expvarsizes
ends sub_c_cline_varfullcdebug
subr sub_c_numeric_field_prep
'updated 2005/04/03, 2005/01/13, 2005/01/02
'change rpg numfield to C with info for sub_c_cline_math
vari s_any, d_any, s_dot, d_dot, s_tap, s_out
vari d_process, d_action, d_error, s_error, d_comma
vari s_rpgfield, s_wrkfield, s_cfield
vari d_vartype, d_indexct, d_longct, d_decimalct
vari d_fieldtype, s_fieldtype
vari d_fieldindexct, d_fieldlongct, d_fielddecimalct
vari d_fieldindextype, s_fieldindexvar
vari s_var1, s_var2, s_size1, s_size2
vari s_sign, d_byte, d_length
'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_rpgfield is input
's_wrkfield is work
's_cfield is output
s_rpgfield = sg_pass1
s_cfield = sg_nothing
s_fieldindexvar = sg_nothing
d_fieldindextype = 0
s_sign = sg_nothing
'beg dg_errnumber,d_error,1500
d_error = 0
d_process = 1
d_action = 0
d_fieldtype = 0
d_fieldindexct = 0
d_fieldlongct = 0
d_fielddecimalct = 0
$trb s_wrkfield, s_rpgfield
$len d_any, s_wrkfield
dift d_any = 0
'we have nothing
d_fieldtype = 2
s_cfield = sg_nothing
dinc d_process
endi
dift d_process = 1
'put the sign in s_sign
$cut s_any, s_wrkfield, 1, 1
s_tap = "+-"
$lok d_any, s_tap, 1, s_any
dift d_any > 0
s_sign = s_any
$cut s_wrkfield, s_wrkfield, 2, 99999
endi
$isd d_any, s_wrkfield
dift d_any = 1
'we have a numeric literal
'take off leading zeros
sg_pass1 = s_wrkfield
sub_take_off_leading_zeros
s_wrkfield = sg_pass1
'make sure it looks like a double ie. 0.0
$lok d_any, s_wrkfield, 1, "."
dift d_any = 0: $app s_wrkfield, ".0"
$off s_any, s_wrkfield, 1
$ift s_any = ".": $app s_wrkfield, "0"
$cut s_any, s_wrkfield, 1, 1
$ift s_any = ".": s_wrkfield = "0" + s_wrkfield
d_fieldindexct = 0
'how many decimal positions
$len d_any, s_wrkfield
d_fieldlongct = d_any - 1
$lok d_dot, s_wrkfield, 1, "."
d_fielddecimalct = d_any - d_dot
d_fieldtype = 11
s_cfield = s_sign + s_wrkfield
dinc d_process
endi
endi
dift d_process = 1
'do we have an indexed variable
$lok d_comma, s_wrkfield, 1, ","
d_action = 1
dift d_comma > 0: d_action = 2
'd_action = 1 means variable not indexed
'd_action = 2 means indexed variable
endi
dift d_action = 1
'variable not indexed
s_var1 = s_rpgfield + sg_20blanks
$cut s_var1, s_var1, 1, 9
$lok d_byte, sg_rpgvarnames, 1, s_var1
dift d_byte = 0
'not found so error
s_error = s_rpgfield
d_error = 1501
d_action = 0
endi
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_action = 1
'variable not indexed
$cut s_size1, sg_rpgvarsizes, d_byte, 9
$cut s_any, s_size1, 1, 1
$tod d_vartype, s_any
'get the d_fieldindexct
$cut s_any, s_size1, 2, 4
$tod d_fieldindexct, s_any
'get the d_fieldlongct
$cut s_any, s_size1, 6, 3
$tod d_fieldlongct, s_any
'get the d_fielddecimalct
$cut s_any, s_size1, 9, 1
$tod d_fielddecimalct, s_any
dift d_vartype = 1
'numeric variable
d_fieldtype = 12
s_cfield = "dg_" + s_wrkfield
$tlo s_cfield, s_cfield
s_cfield = s_sign + s_cfield
endi
dift d_vartype = 2
'numeric array no index and has no sign
d_fieldtype = 14
s_cfield = "dga_" + s_wrkfield
$tlo s_cfield, s_cfield
endi
dift d_vartype > 2
d_error = 1502
s_error = s_rpgfield
endi
endi
'not indexed variable above
'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_action = 2
'indexed variable
$par s_var1, s_wrkfield, ",", 1
$par s_var2, s_wrkfield, ",", 2
$trb s_var1, s_var1
$trb s_var2, s_var2
'validate s_var1
$app s_var1, sg_20blanks
$cut s_var1, s_var1, 1, 9
$lok d_byte, sg_rpgvarnames, 1, s_var1
dift d_byte = 0
d_error = 1503
s_error = s_rpgfield
d_action = 0
endi
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_action = 2
'for indexed variable s_var1
$cut s_size1, sg_rpgvarsizes, d_byte, 9
$cut s_any, s_size1, 1, 1
$tod d_vartype, s_any
'get the d_fieldindexct
$cut s_any, s_size1, 2, 4
$tod d_fieldindexct, s_any
'get the d_fieldlongct
$cut s_any, s_size1, 6, 3
$tod d_fieldlongct, s_any
'get the d_fielddecimalct
$cut s_any, s_size1, 9, 1
$tod d_fielddecimalct, s_any
dift d_vartype = 2
'numeric array with index
d_fieldtype = 13
else
d_error = 1504
s_error = s_rpgfield
d_action = 0
endi
endi
dift d_action = 2
'is index s_var2 an integer
$trb s_var2, s_var2
$ist d_any, s_var2, "9"
dift d_any = 1
'index s_var2 is an integer
'take off leading zeros
$tod d_any, s_var2
s_var2 = d_any
$tlo s_var1, s_var1
s_cfield = "dga_" + s_var1 + "[" + s_var2
$app s_cfield, " - 1]"
s_cfield = s_sign + s_cfield
d_fieldindextype = 11
s_fieldindexvar = s_var2
d_action = 0
endi
endi
dift d_action = 2
'validate index s_var2 as a numeric variable
$app s_var2, sg_20blanks
$cut s_var2, s_var2, 1, 9
$lok d_byte, sg_rpgvarnames, 1, s_var2
dift d_byte = 0
d_error = 1505
s_error = s_rpgfield
endi
endi
dift d_action = 2
$cut s_size2, sg_rpgvarsizes, d_byte, 9
'index s_var2 must be a numeric var
$cut s_any, s_size2, 1, 1
$tod d_vartype, s_any
dift d_vartype = 1
's_var2 is a numeric variable
$tlo s_var1, s_var1
$tlo s_var2, s_var2
s_cfield = "dga_" + s_var1 + "[tfni_index(dg_"
$app s_cfield, s_var2 + ") - 1]"
s_cfield = s_sign + s_cfield
d_fieldindextype = 12
s_fieldindexvar = "dg_" + s_var2
else
d_error = 1506
s_error = s_rpgfield
endi
endi
dift d_error > 0
'end dg_errnumber,d_error,1500
dg_errnumber = d_error
d_fieldtype = 0
s_any = "sub_numfield_prep, bad field="
$app s_any, s_error
sg_pass1 = s_any
sub_error
endi
'd_fieldtype
'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_fieldtype
dg_pass2 = d_fieldindexct
dg_pass3 = d_fieldlongct
dg_pass4 = d_fielddecimalct
dg_pass5 = d_fieldindextype
sg_pass1 = s_cfield
sg_pass2 = s_fieldindexvar
ends sub_c_numeric_field_prep
subr sub_c_ifindicators
'updated 2004/02/19
'put c indicator if command in sg_ifindicators,dg_yesifindicators
vari s_any, d_any, s_dot, d_dot
vari s_inpstring, s_outstring
vari s_indicator, s_not, s_part, d_already
s_inpstring = sg_pass1
s_outstring = sg_nothing
d_already = 2
's_inpstring is : "N91 92N93"
$isc d_any, s_inpstring, " "
dift d_any <> 1
'indicator in 9/11 ie. ig_99 which is 1 or 2
$cut s_not, s_inpstring, 1, 1
$cut s_indicator, s_inpstring, 2, 2
$ist d_any, s_indicator, "9"
dift d_any = 1
'ig_99==1
s_part = "ig_" + s_indicator + "==1"
$ift s_not = "N": $rep s_part, 6, "!"
$app s_outstring, s_part
d_already = 1
endi
'indicator in 12/14 ie. ig_99 which is 1 or 2
$cut s_not, s_inpstring, 4, 1
$cut s_indicator, s_inpstring, 5, 2
$ist d_any, s_indicator, "9"
dift d_any = 1
'ig_99==1
s_part = "ig_" + s_indicator + "==1"
$ift s_not = "N": $rep s_part, 6, "!"
dift d_already = 1: $app s_outstring, " && "
$app s_outstring, s_part
d_already = 1
endi
'indicator in 15/17 ie. ig_99 which is 1 or 2
$cut s_not, s_inpstring, 7, 1
$cut s_indicator, s_inpstring, 8, 2
$ist d_any, s_indicator, "9"
dift d_any = 1
'ig_99==1
s_part = "ig_" + s_indicator + "==1"
$ift s_not = "N": $rep s_part, 6, "!"
dift d_already = 1: $app s_outstring, " && "
$app s_outstring, s_part
d_already = 1
endi
dift d_already = 1
s_outstring = "if(" + s_outstring + ") "
endi
endi
dg_yesifindicators = 2
$len d_any, s_outstring
dift d_any > 0: dg_yesifindicators = 1
sg_ifindicators = s_outstring
ends sub_c_ifindicators
subr sub_c_cline_commands
'updated 2005/04/03, 2004/11/04
vari s_any, d_any, s_dot, d_dot, s_tap, s_out
vari d_loop, d_good, d_count
vari d_record, s_record, d_rpgclines
vari s_6byte, s_7byte, s_8byte, d_command, s_filename
vari s_factor1, s_command, s_factor2, s_result
vari s_indicator4, s_indicator5, s_indicator6
vari d_fieldtype1, d_fieldtype2, d_fieldtype3
vari d_decimalct1, d_decimalct2, d_decimalct3, s_half
vari d_longct, s_fromsubr, d_yesifwrapper
$sys sg_subroutine, 2
s_fromsubr = sg_subroutine
dift dg_tdebug = 1
sg_pass1 = sg_subroutine
sub_return
endi
'turn on fullcdebug only if dg_fullcdebug1=1
'and C* CDEBUG ON until C* CDEBUG OFF
dg_fullcdebug2 = 2
sg_goodcommands = sg_nothing
sg_badcommands = sg_nothing
sg_csubrname = sg_nothing
dg_rpglinenumber = 0
d_rpgclines = 0
d_record = 0
dg_filebyte = 1
d_loop = 1
dwhi d_loop = 1
d_good = 1
dg_yeslinedone = 99999
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_rpglinenumber
dinc d_record
dinc dg_record
'tell
d_any = dg_record % 100
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
$cut s_6byte, s_record, 6, 1
$cut s_7byte, s_record, 7, 1
$cut s_8byte, s_record, 8, 1
$ift s_6byte <> "C"
'non cline so make into comment
dinc d_good
$trb s_any, s_record
sg_pass1 = sg_slashaster + d_record + " "
$app sg_pass1, s_any + sg_asterslash
sub_c_lineout
endi
'stop at output lines
$ift s_6byte = "O"
'd_rpgclines=1 means in rpg c-lines
dift d_rpgclines = 1
'end of c-lines
sg_pass1 = "}" + sg_csubrname
sub_c_lineout
d_rpgclines = 2
endi
$out s_fromsubr + "=" + dg_record
dinc d_good
dinc d_loop
endi
endi
dift d_good = 1
dift d_rpgclines = 0
sub_c_blankline
'd_rpgclines=0 means no previous calcs
'rsub_rpg_calculations is called by main
sg_pass1 = "void rsub_rpg_calculations(void) {"
sub_c_lineout
'save the name to put after the closing }
sg_csubrname = "/* rsub_rpg_calculations */"
'd_rpgclines=1 means in rpg c-calcs
d_rpgclines = 1
endi
endi
dift d_good = 1
'comment records preceded by blankline
$ift s_7byte = "*"
$cut s_any, s_record, 9, 99
$isc d_any, s_any, " "
dift d_any <> 1
sub_c_blankline
$trb s_any, s_record
sg_pass1 = sg_slashaster + d_record + " "
$app sg_pass1, s_any + sg_asterslash
sub_c_lineout
endi
dift dg_fullcdebug1 = 1
'6789012345678
'C* CDEBUG ON
'C* CDEBUG OFF
$cut s_any, s_record, 9, 6
$ift s_any = "CDEBUG"
$cut s_any, s_record, 16, 3
$ift s_any = "ON "
dg_fullcdebug2 = 1
endi
$ift s_any = "OFF"
dg_fullcdebug2 = 2
endi
endi
endi
dinc d_good
endi
endi
dift d_good = 1
dift d_rpgclines = 1
'd_rpgclines=1 means in rpg c-calcs
$ift s_7byte = "S"
'put end to subroutine of c-calcs
sg_pass1 = "}" + sg_csubrname
sub_c_lineout
'd_rpgclines=2 means in rpg csr-calcs
d_rpgclines = 2
endi
endi
endi
dift d_good = 1
'we have a cline to do
dg_yeslinedone = 2
'change indicators to sg_ifindicators,dg_yesifindicators
$cut s_any, s_record, 9, 9
sg_pass1 = s_any
sub_c_ifindicators
$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_indicator4, s_record, 54, 2
$cut s_indicator5, s_record, 56, 2
$cut s_indicator6, s_record, 58, 2
'make blank indicators 00
$swp s_indicator4, " ", "0"
$swp s_indicator5, " ", "0"
$swp s_indicator6, " ", "0"
'turn off showing errors
dinc dg_showerror
sg_pass1 = s_factor1
sub_field_info_return
d_fieldtype1 = dg_pass1
sg_pass1 = s_factor2
sub_field_info_return
d_fieldtype2 = dg_pass1
sg_pass1 = s_result
sub_field_info_return
d_fieldtype3 = dg_pass1
'turn on showing errors
dg_showerror = 1
'do we need fullcdebug
d_dot = 2
dift dg_fullcdebug2 = 1: d_dot = 1
$ift s_command = "BEGSR": dinc d_dot
$ift s_command = "ENDSR": dinc d_dot
$ift s_command = "TAG ": dinc d_dot
dift d_dot = 1
'add lines for fullcdebug
sg_pass1 = s_record
dg_pass1 = d_record
sub_c_cline_fullcdebug_beg
endi
endi
dift d_good = 1
'output the rpg record as a comment
sub_c_blankline
$trb s_any, s_record
sg_pass1 = sg_slashaster + d_record + " "
$app sg_pass1, s_any + sg_asterslash
sub_c_lineout
endi
'cline 1 2 3 4 5 6
'123456789012345678901234567890123456789012345678901234567890
' .CSR 01 02 03FACTOR1 COMMDFACTOR2 RESULT 92H919293
dift d_good = 1
$ift s_command = "BEGSR"
'command_begsr
$tlo s_dot, s_factor1
'save name for closing brace
sg_csubrname = "/* sub_begsr_" + s_dot + " */"
sg_pass1 = "void sub_begsr_" + s_dot + "() {"
sub_c_lineout
dinc d_good
dg_yeslinedone = 1
endi
$ift s_command = "ENDSR"
'command_endsr
'do we need an end of subr tag
$isc d_any, s_factor1, " "
dift d_any <> 1
$tlo s_any, s_factor1
sg_pass1 = s_any + ":;"
sub_c_lineout
endi
'end of a subr
sg_pass1 = "}" + sg_csubrname
sub_c_lineout
dinc d_good
dg_yeslinedone = 1
endi
$ift s_command = "EXCPT"
'command_excpt
dift dg_fullcdebug2 = 1
$tlo s_any, s_result
$ift s_any = "oterm"
sg_pass1 = "if(tig_cdebug == 1) {"
sub_c_lineout
sg_pass1 = #tsub_out79("oterm output below");#
sub_c_lineout
sg_pass1 = "tsub_numberruler(0);"
sub_c_lineout
sg_pass1 = "}"
sub_c_lineout
endi
endi
$tlo s_any, s_result
sg_pass1 = sg_ifindicators
$app sg_pass1, "sub_excpt_" + s_any + "();"
sub_c_lineout
dinc d_good
dg_yeslinedone = 1
endi
dift d_good = 1
'command_read,command_readp,command_chain
s_dot = "READ ,READP,CHAIN,"
$lok d_dot, s_dot, 1, s_command
dift d_dot > 0
sg_pass1 = s_record
sub_c_cline_file_read
dinc d_good
dg_yeslinedone = 1
endi
endi
$ift s_command = "SETLL"
'command_setll
sg_pass1 = s_record
sub_c_cline_lock_unlck_setll
dinc d_good
dg_yeslinedone = 1
endi
$ift s_command = "LOCK "
'command_lock
sg_pass1 = s_record
sub_c_cline_lock_unlck_setll
dinc d_good
dg_yeslinedone = 1
endi
$ift s_command = "UNLCK"
'command_unlck
sg_pass1 = s_record
sub_c_cline_lock_unlck_setll
dinc d_good
dg_yeslinedone = 1
endi
$ift s_command = "BITON"
'command_biton
sg_pass1 = s_record
sub_c_cline_biton_bitof
dinc d_good
endi
$ift s_command = "BITOF"
'command_biton
sg_pass1 = s_record
sub_c_cline_biton_bitof
dinc d_good
endi
$ift s_command = "GOTO "
'command_goto
$tlo s_dot, s_factor2
sg_pass1 = sg_ifindicators
$app sg_pass1, "goto " + s_dot + ";"
sub_c_lineout
dinc d_good
dg_yeslinedone = 1
endi
$ift s_command = "EXSR "
'command_exsr
$tlo s_any, s_factor2
sg_pass1 = sg_ifindicators
$app sg_pass1, "sub_begsr_" + s_any
$app sg_pass1, "();"
sub_c_lineout
dinc d_good
dg_yeslinedone = 1
endi
$ift s_command = "TAG "
'command_tag
$tlo s_any, s_factor1
sg_pass1 = s_any + ":;"
sub_c_lineout
dinc d_good
dg_yeslinedone = 1
endi
$ift s_command = "SETON"
'command_seton
sg_pass1 = sg_ifindicators
$app sg_pass1, "rsub_command_seton("
$app sg_pass1, "&ig_" + s_indicator4 + ","
$app sg_pass1, "&ig_" + s_indicator5 + ","
$app sg_pass1, "&ig_" + s_indicator6 + ");"
sub_c_lineout
dinc d_good
dg_yeslinedone = 1
endi
$ift s_command = "SETOF"
'command_setof
sg_pass1 = sg_ifindicators
$app sg_pass1, "rsub_command_setof("
$app sg_pass1, "&ig_" + s_indicator4 + ","
$app sg_pass1, "&ig_" + s_indicator5 + ","
$app sg_pass1, "&ig_" + s_indicator6 + ");"
sub_c_lineout
dinc d_good
dg_yeslinedone = 1
endi
endi
dift d_good = 1
'command_z-add,command_z-sub,command_add,
'command_sub,command_mult,command_div,
'command_mvr,command_time,command_sqrt,
'command_xfoot
s_tap = "Z-ADD,Z-SUB,ADD ,SUB ,MULT ,DIV ,"
$app s_tap, "MVR ,TIME ,SQRT ,XFOOT,"
$lok d_any, s_tap, 1, s_command
dift d_any > 0
sg_pass1 = s_record
sub_c_cline_math
dinc d_good
endi
endi
dift d_good = 1
$ift s_command = "MOVEA"
'command_movea
sg_pass1 = s_record
sub_c_cline_movea
dinc d_good
endi
$ift s_command = "MOVEL"
'command_movel
sg_pass1 = s_record
sub_c_cline_movel
dinc d_good
endi
$ift s_command = "MOVE "
'command_move_right
sg_pass1 = s_record
sub_c_cline_move_right
dinc d_good
endi
endi
dift d_good = 1
$ift s_command = "COMP "
'command_comp
sg_pass1 = s_record
sub_c_cline_comp
dinc d_good
endi
$ift s_command = "LOKUP"
'command_lokup
'21,22,23 is alpha in factor1
d_dot = 2
dift d_fieldtype1 = 21: d_dot = 1
dift d_fieldtype1 = 22: d_dot = 1
dift d_fieldtype1 = 23: d_dot = 1
dift d_dot = 1
'alpha lokup
sg_pass1 = s_record
sub_c_cline_slokup
else
'numeric lokup
sg_pass1 = s_record
sub_c_cline_nlokup
endi
dinc d_good
endi
$ift s_command = "SORTA"
'command_sorta
sg_pass1 = s_record
sub_c_cline_sorta
dinc d_good
endi
endi
dift d_good = 1
$ift s_command = "TESTN"
'command_testn
sg_pass1 = s_result
sub_field_info_return
d_longct = dg_pass4
$tlo s_result, s_result
sg_pass1 = sg_ifindicators
$app sg_pass1, "rsub_testn(sg_"
$app sg_pass1, s_result + ", " + d_longct
$app sg_pass1, ", &ig_" + s_indicator4
$app sg_pass1, ", &ig_" + s_indicator5
$app sg_pass1, ", &ig_" + s_indicator6 + ");"
sub_c_lineout
dinc d_good
dg_yeslinedone = 1
endi
$ift s_command = "TIME2"
'command_time2
' 1 2 3 4
'1234567890123456789012345678901234567890
'TUE. APR 4, 2000, 11:05 AM JULIAN:095
sg_pass1 = s_result
sub_field_info_return
d_longct = dg_pass4
dift d_longct > 40: d_longct = 40
$tlo s_result, s_result
sg_pass1 = sg_ifindicators + "tsub_time2(sg_"
$app sg_pass1, s_result + ", " + d_longct + ");"
sub_c_lineout
dinc d_good
dg_yeslinedone = 1
endi
endi
dift d_good = 1
'both below are in stdlib.h
'int setenv(const char *envname, const char *envval, int overwrite);
'int putenv(char *string);
$ift s_command = "PUTJW"
'command_setjcw
sg_pass1 = s_factor1
sub_c_numeric_field_prep
s_factor1 = sg_pass1
sg_pass1 = sg_ifindicators
$app sg_pass1, "rsub_putjw(" + s_factor2 + ", "
$app sg_pass1, s_factor1 + ", &ig_"
$app sg_pass1, s_indicator6 + ");"
sub_c_lineout
dinc d_good
dg_yeslinedone = 1
endi
$ift s_command = "FNDJW"
'command_fndjw
sg_pass1 = s_result
sub_c_numeric_field_prep
s_result = sg_pass1
sg_pass1 = sg_ifindicators
$app sg_pass1, "rsub_fndjw(" + s_factor2 + ", "
$app sg_pass1, "&" + s_result + ", "
$app sg_pass1, "&ig_" + s_indicator6 + ");"
sub_c_lineout
dinc d_good
dg_yeslinedone = 1
endi
endi
dift dg_yeslinedone = 1
'the command s_command was done
$lok d_any, sg_goodcommands, 1, s_command
dift d_any = 0: $app sg_goodcommands, s_command + ","
'do we want the fullcdebug stuff
d_dot = 2
dift dg_fullcdebug2 = 1: d_dot = 1
$ift s_command = "ENDSR": dinc d_dot
$ift s_command = "GOTO ": dinc d_dot
dift d_dot = 1
'add lines for fullcdebug
sg_pass1 = s_record
dg_pass1 = d_record
sub_c_cline_fullcdebug_end
endi
endi
dift dg_yeslinedone = 2
'the command s_command was not done
$trb s_any, s_record
$out "not done=" + d_record + " " + s_any
$lok d_any, sg_badcommands, 1, s_command
dift d_any = 0
$app sg_badcommands, s_command + ","
$inp s_any, "return"
endi
endi
endw
ends sub_c_cline_commands
subr sub_c_cline_file_read
'updated 2004/10/27
'do commands READ,READP,CHAIN
vari s_any, d_any, s_dot, d_dot, s_out
vari s_record, s_factor1, s_command, s_factor2, s_result
vari s_indicator4, s_indicator5, s_indicator6
vari s_filename, s_filedevice, s_filetype, d_filereclong
vari s_filefixed, s_fileksam
vari d_filekeybeg, d_filekeylong
vari s_recnum, s_cfilename, d_action
vari d_indexct1, d_longct1, d_decimalct1
s_record = sg_pass1
'change indicators to sg_ifindicators,dg_yesifindicators
$cut s_any, s_record, 9, 9
sg_pass1 = s_any
sub_c_ifindicators
$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_indicator4, s_record, 54, 2
$cut s_indicator5, s_record, 56, 2
$cut s_indicator6, s_record, 58, 2
'make blank indicators 00
$swp s_indicator4, " ", "0"
$swp s_indicator5, " ", "0"
$swp s_indicator6, " ", "0"
sg_pass1 = s_factor2
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
$trb s_filedevice, s_filedevice
$tlo s_cfilename, s_factor2
'do we need an ifindicators wrapper
dift dg_yesifindicators = 1
sg_pass1 = sg_ifindicators + "{"
sub_c_lineout
endi
d_action = 0
$ift s_command = "READ "
d_action = 2
$ift s_filedevice = "$STDIN": d_action = 1
$ift s_fileksam = "K": d_action = 13
endi
$ift s_command = "READP": d_action = 3
$ift s_command = "CHAIN": d_action = 4
s_recnum = "tng_recnum_" + s_cfilename
dift d_action = 1
'read the record from $STDIN
dift dg_fullcdebug2 = 1
sg_pass1 = "if(tig_cdebug == 1) {"
sub_c_lineout
sg_pass1 = #tsub_out79("terminal input below");#
sub_c_lineout
sg_pass1 = "}"
sub_c_lineout
endi
sg_pass1 = "sub_file_read_" + s_cfilename + "();"
sub_c_lineout
'move fields to input since not eof
sg_pass1 = "fsub_input_to_fields_" + s_cfilename + "();"
sub_c_lineout
'end the ifindicators wrapper
dift dg_yesifindicators = 1
sg_pass1 = "} /* ifindicators */"
sub_c_lineout
endi
dg_yeslinedone = 1
endi
dift d_action = 2
'read record from file
sg_pass1 = "sub_file_read_" + s_cfilename
$app sg_pass1, "();"
sub_c_lineout
'not eof
sg_pass1 = "if(tig_eof != 1) {"
sub_c_lineout
'move fields to input since not eof
sg_pass1 = "fsub_input_to_fields_" + s_cfilename + "();"
sub_c_lineout
'set the eof result indicator in 58/59
sg_pass1 = "ig_" + s_indicator6 + " = 2;"
sub_c_lineout
sg_pass1 = "}"
sub_c_lineout
'else we did not read a record
sg_pass1 = "else ig_" + s_indicator6
$app sg_pass1, " = 1;"
sub_c_lineout
'end the ifindicators wrapper
dift dg_yesifindicators = 1
sg_pass1 = "} /* ifindicators */"
sub_c_lineout
endi
dg_yeslinedone = 1
endi
dift d_action = 3
'readp record from file
sg_pass1 = "sub_file_readp_" + s_cfilename
$app sg_pass1, "();"
sub_c_lineout
'not eof
sg_pass1 = "if(tig_eof != 1) {"
sub_c_lineout
'move fields to input since not eof
sg_pass1 = "fsub_input_to_fields_" + s_cfilename + "();"
sub_c_lineout
'set the eof result indicator in 58/59
sg_pass1 = "ig_" + s_indicator6 + " = 2;"
sub_c_lineout
sg_pass1 = "}"
sub_c_lineout
'else we did not read a record
sg_pass1 = "else ig_" + s_indicator6
$app sg_pass1, " = 1;"
sub_c_lineout
'end the ifindicators wrapper
dift dg_yesifindicators = 1
sg_pass1 = "} /* ifindicators */"
sub_c_lineout
endi
dg_yeslinedone = 1
endi
dift d_action = 4
'chain record from file
sg_pass1 = s_factor1
sub_c_numeric_field_prep
s_factor1 = sg_pass1
d_indexct1 = dg_pass2
d_longct1 = dg_pass3
d_decimalct1 = dg_pass4
sg_pass1 = "sub_file_readp_" + s_cfilename
$app sg_pass1, "(tfni_index(" + s_factor1 + "));"
sub_c_lineout
'not eof
sg_pass1 = "if(tig_eof != 1) {"
sub_c_lineout
'move fields to input since not eof
sg_pass1 = "fsub_input_to_fields_" + s_cfilename + "();"
sub_c_lineout
'set the eof result indicator in 58/59
sg_pass1 = "ig_" + s_indicator6 + " = 2;"
sub_c_lineout
sg_pass1 = "}"
sub_c_lineout
'else we did not read a record
sg_pass1 = "else ig_" + s_indicator6
$app sg_pass1, " = 1;"
sub_c_lineout
'end the ifindicators wrapper
dift dg_yesifindicators = 1
sg_pass1 = "} /* ifindicators */"
sub_c_lineout
endi
dg_yeslinedone = 1
endi
dift d_action = 13
'read from KSAM file using HP intrinsic FREAD
'read record from file
sg_pass1 = "sub_file_read_" + s_cfilename
$app sg_pass1, "();"
sub_c_lineout
'not eof
sg_pass1 = "if(tig_eof != 1) {"
sub_c_lineout
'move fields to input since not eof
sg_pass1 = "fsub_input_to_fields_" + s_cfilename + "();"
sub_c_lineout
'set the eof result indicator in 58/59
sg_pass1 = "ig_" + s_indicator6 + " = 2;"
sub_c_lineout
sg_pass1 = "}"
sub_c_lineout
'else we did not read a record
sg_pass1 = "else ig_" + s_indicator6
$app sg_pass1, " = 1;"
sub_c_lineout
'end the ifindicators wrapper
dift dg_yesifindicators = 1
sg_pass1 = "} /* ifindicators */"
sub_c_lineout
endi
dg_yeslinedone = 1
endi
ends sub_c_cline_file_read
subr sub_c_cline_lock_unlck_setll
'updated 2005/01/09
'lock,unlck,setll
vari s_any, d_any, s_dot, d_dot, s_out
vari s_record, s_factor1, s_command, s_factor2, s_result
vari s_indicator4, s_indicator5, s_indicator6
vari s_filename, s_filedevice, s_filetype, d_filereclong
vari s_filefixed, s_fileksam
vari d_filekeybeg, d_filekeylong
vari s_recnum, s_cfilename, d_action
vari d_indexct1, d_longct1, d_decimalct1
vari d_type11, s_var11
s_record = sg_pass1
'change indicators to sg_ifindicators,dg_yesifindicators
$cut s_any, s_record, 9, 9
sg_pass1 = s_any
sub_c_ifindicators
$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_indicator4, s_record, 54, 2
$cut s_indicator5, s_record, 56, 2
$cut s_indicator6, s_record, 58, 2
'make blank indicators 00
$swp s_indicator4, " ", "0"
$swp s_indicator5, " ", "0"
$swp s_indicator6, " ", "0"
sg_pass1 = s_factor2
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
$trb s_filedevice, s_filedevice
$tlo s_cfilename, s_factor2
dift dg_yesifindicators = 1
'we need an ifindicators wrapper
sg_pass1 = sg_ifindicators + "{"
sub_c_lineout
endi
d_action = 0
$ift s_command = "SETLL"
'HP intrinsic FFINDBYKEY
'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
'get info for s_factor1
sg_pass1 = s_factor1
sub_field_info_return
d_type11 = dg_pass1
'd_type12 = dg_pass2
'd_indexct1 = dg_pass3
d_longct1 = dg_pass4
'd_decimalct1 = dg_pass5
s_var11 = sg_pass1
's_var12 = sg_pass2
's_cindex1 = sg_pass7
dift d_type11 = 21
'we have an alpha literal
sg_pass1 = "tsub_copy(tsg_256a, " + s_var11
$app sg_pass1, ", " + d_longct1 + ");"
sub_c_lineout
else
'we have an alpha variable
$clo s_any, s_var11
sg_pass1 = "tsub_copy(tsg_256a, sg_" + s_any
$app sg_pass1, ", " + d_longct1 + ");"
sub_c_lineout
endi
sg_pass1 = "/* HP intrinsic FFINDBYKEY */"
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
endi
$ift s_command = "LOCK "
'HP intrinsic FLOCK
sg_pass1 = "/* HP intrinsic FLOCK */"
sub_c_lineout
sg_pass1 = "FLOCK(iksam_filenum_" + s_cfilename
$app sg_pass1, ", 1);"
sub_c_lineout
sg_pass1 = "ig_" + s_indicator6 + " = 2;"
sub_c_lineout
sg_pass1 = "if(ccode() == CCE) ig_"
$app sg_pass1, s_indicator6 + " = 1;"
sub_c_lineout
endi
$ift s_command = "UNLCK"
'HP intrinsic UNFLOCK
sg_pass1 = "/* HP intrinsic FUNLOCK */"
sub_c_lineout
sg_pass1 = "FUNLOCK(iksam_filenum_" + s_cfilename + ");"
sub_c_lineout
sg_pass1 = "ig_" + s_indicator6 + " = 2;"
sub_c_lineout
sg_pass1 = "if(ccode() == CCE) ig_"
$app sg_pass1, s_indicator6 + " = 1;"
sub_c_lineout
endi
dift dg_yesifindicators = 1
'we need an ifindicators wrapper
sg_pass1 = "}"
sub_c_lineout
endi
ends sub_c_cline_lock_unlck_setll
subr sub_c_cline_math
'updated 2005/01/13, 2005/01/11
'do commands Z-ADD,Z-SUB,ADD,SUB,MULT,DIV,MVR,TIME,SQRT,XFOOT
vari s_any, d_any, s_dot, d_dot, s_out
vari d_record, s_record, d_good, d_action
vari s_rpgfield1, s_rpgcommand, s_rpgfield2, s_rpgfield3
vari s_cfield1, s_cfield2, s_cfield3
vari d_type1, d_type2, d_type3
vari d_indexct1, d_indexct2, d_indexct3
vari d_decimalct1, d_decimalct2, d_decimalct3, s_half
vari d_longct1, d_longct2, d_longct3
vari d_indextype1, d_indextype2, d_indextype3
vari s_indexvar1, s_indexvar2, s_indexvar3
s_record = sg_pass1
'cline 1 2 3 4 5 6
'123456789012345678901234567890123456789012345678901234567890
' .CSR 01 02 03FIELD1 COMMDFIELD2 FIELD3 92H919293
'we use field instead of factor,result for simplicity here
'the C if indicators are in sg_ifindicators
$cut s_rpgfield1, s_record, 18, 10
$cut s_rpgcommand, s_record, 28, 5
$cut s_rpgfield2, s_record, 33, 10
$cut s_rpgfield3, s_record, 43, 6
'get half adjust char
$cut s_half, s_record, 53, 1
sg_pass1 = s_rpgfield1
sub_c_numeric_field_prep
d_type1 = dg_pass1
d_indexct1 = dg_pass2
d_longct1 = dg_pass3
d_decimalct1 = dg_pass4
d_indextype1 = dg_pass5
s_cfield1 = sg_pass1
s_indexvar1 = sg_pass2
sg_pass1 = s_rpgfield2
sub_c_numeric_field_prep
d_type2 = dg_pass1
d_indexct2 = dg_pass2
d_longct2 = dg_pass3
d_decimalct2 = dg_pass4
d_indextype2 = dg_pass5
s_cfield2 = sg_pass1
s_indexvar2 = sg_pass2
sg_pass1 = s_rpgfield3
sub_c_numeric_field_prep
d_type3 = dg_pass1
d_indexct3 = dg_pass2
d_longct3 = dg_pass3
d_decimalct3 = dg_pass4
d_indextype3 = dg_pass5
s_cfield3 = sg_pass1
s_indexvar3 = sg_pass2
'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
$ift s_rpgcommand = "Z-ADD"
'zero add
dift d_indextype2 = 12
'validate numeric var index for s_cfield2
sg_pass1 = sg_ifindicators
$app sg_pass1, "tsub_index_range_cerror("
$app sg_pass1, s_indexvar2
$app sg_pass1, ", " + d_indexct2 + ", "
$app sg_pass1, dg_rpglinenumber + ");"
sub_c_lineout
endi
dift d_indextype3 = 12
'validate numeric var index for s_cfield3
sg_pass1 = sg_ifindicators
$app sg_pass1, "tsub_index_range_cerror("
$app sg_pass1, s_indexvar3
$app sg_pass1, ", " + d_indexct3 + ", "
$app sg_pass1, dg_rpglinenumber + ");"
sub_c_lineout
endi
'do we have d_type3=14 numeric array no index
d_action = 1
dift d_type3 = 14: d_action = 2
dift d_action = 1
's_cfield3 is numeric var or numeric array with index
sg_pass1 = sg_ifindicators
$app sg_pass1, s_cfield3
$app sg_pass1, " = rfnd_math_result("
$app sg_pass1, s_cfield2 + ", "
$app sg_pass1, d_decimalct3 + ", '" + s_half
$app sg_pass1, "', 1);"
sub_c_lineout
endi
dift d_action = 2
's_cfield3 is numeric array no index
sg_pass1 = sg_ifindicators
$app sg_pass1, "tsub_zadd_array(" + s_cfield3
$app sg_pass1, ", " + d_indexct3 + ", "
$app sg_pass1, s_cfield2 + ");"
sub_c_lineout
endi
dg_yeslinedone = 1
endi
$ift s_rpgcommand = "Z-SUB"
'zero subtract
dift d_indextype2 = 12
'validate numeric var index for s_cfield2
sg_pass1 = sg_ifindicators
$app sg_pass1, "tsub_index_range_cerror("
$app sg_pass1, s_indexvar2
$app sg_pass1, ", " + d_indexct2 + ", "
$app sg_pass1, dg_rpglinenumber + ");"
sub_c_lineout
endi
dift d_indextype3 = 12
'validate numeric var index for s_cfield3
sg_pass1 = sg_ifindicators
$app sg_pass1, "tsub_index_range_cerror("
$app sg_pass1, s_indexvar3
$app sg_pass1, ", " + d_indexct3 + ", "
$app sg_pass1, dg_rpglinenumber + ");"
sub_c_lineout
endi
'do we have d_type3=14 numeric array no index
d_action = 1
dift d_type3 = 14: d_action = 2
dift d_action = 1
's_cfield3 is numeric var or numeric array with index
sg_pass1 = sg_ifindicators
$app sg_pass1, s_cfield3
$app sg_pass1, " = -rfnd_math_result("
$app sg_pass1, s_cfield2 + ", "
$app sg_pass1, d_decimalct3 + ", '" + s_half
$app sg_pass1, "', 1);"
sub_c_lineout
endi
dift d_action = 2
's_cfield3 is numeric array no index
sg_pass1 = sg_ifindicators
$app sg_pass1, "tsub_zadd_array(" + s_cfield3
$app sg_pass1, ", " + d_indexct3 + ", -"
$app sg_pass1, s_cfield2 + ");"
endi
dg_yeslinedone = 1
endi
$ift s_rpgcommand = "ADD "
'addition
$len d_any, s_cfield1
dift d_any = 0
s_cfield1 = s_cfield3
d_decimalct1 = d_decimalct3
s_indexvar1 = s_indexvar3
d_indexct1 = d_indexct3
endi
dift d_indextype1 = 12
'validate numeric var index for s_cfield1
sg_pass1 = sg_ifindicators
$app sg_pass1, "tsub_index_range_cerror("
$app sg_pass1, s_indexvar1
$app sg_pass1, ", " + d_indexct1 + ", "
$app sg_pass1, dg_rpglinenumber + ");"
sub_c_lineout
endi
dift d_indextype2 = 12
'validate numeric var index for s_cfield2
sg_pass1 = sg_ifindicators
$app sg_pass1, "tsub_index_range_cerror("
$app sg_pass1, s_indexvar2
$app sg_pass1, ", " + d_indexct2 + ", "
$app sg_pass1, dg_rpglinenumber + ");"
sub_c_lineout
endi
dift d_indextype3 = 12
'validate numeric var index for s_cfield3
sg_pass1 = sg_ifindicators
$app sg_pass1, "tsub_index_range_cerror("
$app sg_pass1, s_indexvar3
$app sg_pass1, ", " + d_indexct3 + ", "
$app sg_pass1, dg_rpglinenumber + ");"
sub_c_lineout
endi
sg_pass1 = sg_ifindicators
$app sg_pass1, s_cfield3
$app sg_pass1, " = rfnd_math_result("
$app sg_pass1, s_cfield1 + " + " + s_cfield2
$app sg_pass1, ", " + d_decimalct3
$app sg_pass1, ", '" + s_half + "', 1);"
sub_c_lineout
dg_yeslinedone = 1
endi
$ift s_rpgcommand = "SUB "
'subtract
$len d_any, s_cfield1
dift d_any = 0
s_cfield1 = s_cfield3
d_decimalct1 = d_decimalct3
s_indexvar1 = s_indexvar3
d_indexct1 = d_indexct3
endi
dift d_indextype1 = 12
'validate numeric var index for s_cfield1
sg_pass1 = sg_ifindicators
$app sg_pass1, "tsub_index_range_cerror("
$app sg_pass1, s_indexvar1
$app sg_pass1, ", " + d_indexct1 + ", "
$app sg_pass1, dg_rpglinenumber + ");"
sub_c_lineout
endi
dift d_indextype2 = 12
'validate numeric var index for s_cfield2
sg_pass1 = sg_ifindicators
$app sg_pass1, "tsub_index_range_cerror("
$app sg_pass1, s_indexvar2
$app sg_pass1, ", " + d_indexct2 + ", "
$app sg_pass1, dg_rpglinenumber + ");"
sub_c_lineout
endi
dift d_indextype3 = 12
'validate numeric var index for s_cfield3
sg_pass1 = sg_ifindicators
$app sg_pass1, "tsub_index_range_cerror("
$app sg_pass1, s_indexvar3
$app sg_pass1, ", " + d_indexct3 + ", "
$app sg_pass1, dg_rpglinenumber + ");"
sub_c_lineout
endi
sg_pass1 = sg_ifindicators
$app sg_pass1, s_cfield3
$app sg_pass1, " = rfnd_math_result("
$app sg_pass1, s_cfield1 + " - " + s_cfield2
$app sg_pass1, ", " + d_decimalct3
$app sg_pass1, ", '" + s_half + "', 1);"
sub_c_lineout
dg_yeslinedone = 1
endi
$ift s_rpgcommand = "MULT "
'multiply
$len d_any, s_cfield1
dift d_any = 0
s_cfield1 = s_cfield3
d_decimalct1 = d_decimalct3
s_indexvar1 = s_indexvar3
d_indexct1 = d_indexct3
endi
dift d_indextype1 = 12
'validate numeric var index for s_cfield1
sg_pass1 = sg_ifindicators
$app sg_pass1, "tsub_index_range_cerror("
$app sg_pass1, s_indexvar1
$app sg_pass1, ", " + d_indexct1 + ", "
$app sg_pass1, dg_rpglinenumber + ");"
sub_c_lineout
endi
dift d_indextype2 = 12
'validate numeric var index for s_cfield2
sg_pass1 = sg_ifindicators
$app sg_pass1, "tsub_index_range_cerror("
$app sg_pass1, s_indexvar2
$app sg_pass1, ", " + d_indexct2 + ", "
$app sg_pass1, dg_rpglinenumber + ");"
sub_c_lineout
endi
dift d_indextype3 = 12
'validate numeric var index for s_cfield3
sg_pass1 = sg_ifindicators
$app sg_pass1, "tsub_index_range_cerror("
$app sg_pass1, s_indexvar3
$app sg_pass1, ", " + d_indexct3 + ", "
$app sg_pass1, dg_rpglinenumber + ");"
sub_c_lineout
endi
sg_pass1 = sg_ifindicators + s_cfield3
$app sg_pass1, " = rfnd_math_result("
$app sg_pass1, s_cfield1 + " * " + s_cfield2 + " ,"
$app sg_pass1, d_decimalct3 + ", '" + s_half
$app sg_pass1, "', 0);"
sub_c_lineout
dg_yeslinedone = 1
endi
$ift s_rpgcommand = "DIV "
'divide
$len d_any, s_cfield1
dift d_any = 0
s_cfield1 = s_cfield3
d_decimalct1 = d_decimalct3
s_indexvar1 = s_indexvar3
d_indexct1 = d_indexct3
endi
dift d_indextype1 = 12
'validate numeric var index for s_cfield1
sg_pass1 = sg_ifindicators
$app sg_pass1, "tsub_index_range_cerror("
$app sg_pass1, s_indexvar1
$app sg_pass1, ", " + d_indexct1 + ", "
$app sg_pass1, dg_rpglinenumber + ");"
sub_c_lineout
endi
dift d_indextype2 = 12
'validate numeric var index for s_cfield2
sg_pass1 = sg_ifindicators
$app sg_pass1, "tsub_index_range_cerror("
$app sg_pass1, s_indexvar2
$app sg_pass1, ", " + d_indexct2 + ", "
$app sg_pass1, dg_rpglinenumber + ");"
sub_c_lineout
endi
dift d_indextype3 = 12
'validate numeric var index for s_cfield3
sg_pass1 = sg_ifindicators
$app sg_pass1, "tsub_index_range_cerror("
$app sg_pass1, s_indexvar3
$app sg_pass1, ", " + d_indexct3 + ", "
$app sg_pass1, dg_rpglinenumber + ");"
sub_c_lineout
endi
'save s_cfield1,s_cfield2 in case of MVR next
sg_prevdividefactor1 = s_cfield1
sg_prevdividefactor2 = s_cfield2
sg_pass1 = sg_ifindicators
$app sg_pass1, s_cfield3 + " = rfnd_divide("
$app sg_pass1, s_cfield1 + ", " + s_cfield2 + ", "
$app sg_pass1, d_decimalct3 + ", '" + s_half + "', "
$app sg_pass1, dg_rpglinenumber + ");"
sub_c_lineout
dg_yeslinedone = 1
endi
$ift s_rpgcommand = "MVR "
'mvr or modulus
dift d_indextype3 = 12
'validate numeric var index for s_cfield3
sg_pass1 = sg_ifindicators
$app sg_pass1, "tsub_index_range_cerror("
$app sg_pass1, s_indexvar3
$app sg_pass1, ", " + d_indexct3 + ", "
$app sg_pass1, dg_rpglinenumber + ");"
sub_c_lineout
endi
sg_pass1 = sg_ifindicators
$app sg_pass1, s_cfield3 + " = rfnd_mvr_modulus("
$app sg_pass1, sg_prevdividefactor1 + ", "
$app sg_pass1, sg_prevdividefactor2 + ", "
$app sg_pass1, d_decimalct3 + ", '" + s_half + "', "
$app sg_pass1, dg_rpglinenumber + ");"
sub_c_lineout
dg_yeslinedone = 1
endi
$ift s_rpgcommand = "TIME "
'time
dift d_indextype3 = 12
'validate numeric var index for s_cfield3
sg_pass1 = sg_ifindicators
$app sg_pass1, "tsub_index_range_cerror("
$app sg_pass1, s_indexvar3
$app sg_pass1, ", " + d_indexct3 + ", "
$app sg_pass1, dg_rpglinenumber + ");"
sub_c_lineout
endi
d_any = 6
dift d_longct3 > 6: d_any = 12
sg_pass1 = sg_ifindicators
$app sg_pass1, s_cfield3 + " = tfnd_time( "
$app sg_pass1, d_any + ");"
sub_c_lineout
dg_yeslinedone = 1
endi
$ift s_rpgcommand = "SQRT "
'square root
dift d_indextype2 = 12
'validate numeric var index for s_cfield2
sg_pass1 = sg_ifindicators
$app sg_pass1, "tsub_index_range_cerror("
$app sg_pass1, s_indexvar2
$app sg_pass1, ", " + d_indexct2 + ", "
$app sg_pass1, dg_rpglinenumber + ");"
sub_c_lineout
endi
dift d_indextype3 = 12
'validate numeric var index for s_cfield3
sg_pass1 = sg_ifindicators
$app sg_pass1, "tsub_index_range_cerror("
$app sg_pass1, s_indexvar3
$app sg_pass1, ", " + d_indexct3 + ", "
$app sg_pass1, dg_rpglinenumber + ");"
sub_c_lineout
endi
sg_pass1 = sg_ifindicators
$app sg_pass1, s_cfield3
$app sg_pass1, " = rfnd_math_result(sqrt(fabs("
$app sg_pass1, s_cfield2 + ")), "
$app sg_pass1, d_decimalct3 + ", '" + s_half
$app sg_pass1, "', 0);"
sub_c_lineout
dg_yeslinedone = 1
endi
$ift s_rpgcommand = "XFOOT"
'cross foot
dift d_indextype3 = 12
'validate numeric var index for s_cfield3
sg_pass1 = sg_ifindicators
$app sg_pass1, "tsub_index_range_cerror("
$app sg_pass1, s_indexvar3
$app sg_pass1, ", " + d_indexct3 + ", "
$app sg_pass1, dg_rpglinenumber + ");"
sub_c_lineout
endi
sg_pass1 = sg_ifindicators
$app sg_pass1, s_cfield3
$app sg_pass1, " = rfnd_math_result(rfnd_xfoot("
$app sg_pass1, s_cfield2 + ", "
$app sg_pass1, d_indexct2 + "), "
$app sg_pass1, d_decimalct3
$app sg_pass1, ", '" + s_half + "', 1);"
sub_c_lineout
dg_yeslinedone = 1
endi
ends sub_c_cline_math
subr sub_c_cline_comp
'updated 2004/09/05
vari s_any, d_any, s_dot, d_dot, s_out
vari d_record, s_record, d_good, d_action, d_length
vari s_factor1, s_factor2
vari s_indicator1, s_indicator2, s_indicator3
vari d_type11, d_type12, d_indexct1, d_longct1, d_decimalct1
vari s_var11, s_var12
vari d_type21, d_type22, d_indexct2, d_longct2, d_decimalct2
vari s_var21, s_var22
vari s_cindex1, s_cindex2
vari s_pvar1, s_pvar2, s_plong1, s_plong2, s_pchar
s_record = sg_pass1
$cut s_factor1, s_record, 18, 10
$cut s_factor2, s_record, 33, 10
$cut s_indicator1, s_record, 54, 2
$cut s_indicator2, s_record, 56, 2
$cut s_indicator3, s_record, 58, 2
s_any = " "
s_dot = "00"
$ift s_indicator1 = s_any: s_indicator1 = s_dot
$ift s_indicator2 = s_any: s_indicator2 = s_dot
$ift s_indicator3 = s_any: s_indicator3 = s_dot
'cline 1 2 3 4 5 6
'123456789012345678901234567890123456789012345678901234567890
' .CSR 01 02 03FACTOR1 COMMDFACTOR2 RESULT 92H919293
'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
'get info for s_inpfield = factor1
sg_pass1 = s_factor1
sub_field_info_return
d_type11 = dg_pass1
d_type12 = dg_pass2
d_indexct1 = dg_pass3
d_longct1 = dg_pass4
d_decimalct1 = dg_pass5
s_var11 = sg_pass1
s_var12 = sg_pass2
s_cindex1 = sg_pass7
'get info for s_inpfield = factor2
sg_pass1 = s_factor2
sub_field_info_return
d_type21 = dg_pass1
d_type22 = dg_pass2
d_indexct2 = dg_pass3
d_longct2 = dg_pass4
d_decimalct2 = dg_pass5
s_var21 = sg_pass1
s_var22 = sg_pass2
s_cindex2 = sg_pass7
'd_action = 1 for numeric and 2 for alpha
d_action = 99999
'first numeric whose type is 11 to 13
d_dot = 0
dift d_type11 >= 11
dift d_type11 <= 13: dinc d_dot
endi
dift d_type21 >= 11
dift d_type21 <= 13: dinc d_dot
endi
dift d_dot = 2: d_action = 1
'now alpha variables types=6,7,21,22,23
d_dot = 0
'we do not put *BLANK or *ZEROS in field1
dift d_type11 = 21: dinc d_dot
dift d_type11 = 22: dinc d_dot
dift d_type11 = 23: dinc d_dot
dift d_type21 = 6: dinc d_dot
dift d_type21 = 7: dinc d_dot
dift d_type21 = 21: dinc d_dot
dift d_type21 = 22: dinc d_dot
dift d_type21 = 23: dinc d_dot
dift d_dot = 2: d_action = 2
'd_action = 1 for numeric and 2 for alpha
dift d_action = 1
'number compare
dift d_type12 = 12
'validate numeric var index for s_cfield1
sg_pass1 = sg_ifindicators
$app sg_pass1, "tsub_index_range_cerror("
$app sg_pass1, s_cindex1
$app sg_pass1, ", " + d_indexct1 + ", "
$app sg_pass1, dg_rpglinenumber + ");"
sub_c_lineout
endi
dift d_type22 = 12
'validate numeric var index for s_cfield2
sg_pass1 = sg_ifindicators
$app sg_pass1, "tsub_index_range_cerror("
$app sg_pass1, s_cindex2
$app sg_pass1, ", " + d_indexct2 + ", "
$app sg_pass1, dg_rpglinenumber + ");"
sub_c_lineout
endi
sg_pass1 = s_factor1
sub_c_numeric_field_prep
s_factor1 = sg_pass1
sg_pass1 = s_factor2
sub_c_numeric_field_prep
s_factor2 = sg_pass1
sg_pass1 = sg_ifindicators + "tsub_compare_numbers( "
$app sg_pass1, s_factor1 + " ," + s_factor2 + ", &ig_"
$app sg_pass1, s_indicator1 + ", &ig_" + s_indicator2
$app sg_pass1, ", &ig_" + s_indicator3 + ");"
sub_c_lineout
dg_yeslinedone = 1
endi
'd_action = 1 for numeric and 2 for alpha
dift d_action = 2
'string compare first factor
dift d_type11 = 21
'string literal
s_pvar1 = s_var11
s_plong1 = d_longct1
endi
dift d_type11 = 22
'string variable
s_pvar1 = "sg_" + s_var11
$clo s_pvar1, s_pvar1
s_plong1 = d_longct1
endi
dift d_type11 = 23
'string array with index
dift d_type12 = 12
'validate numeric var index for s_cfield1
sg_pass1 = sg_ifindicators
$app sg_pass1, "tsub_index_range_cerror("
$app sg_pass1, s_cindex1
$app sg_pass1, ", " + d_indexct1 + ", "
$app sg_pass1, dg_rpglinenumber + ");"
sub_c_lineout
endi
$trb s_any, s_var11
s_pvar1 = "&sga_" + s_any + "[tfni_index( "
'is s_var12 a numeric variable
$trb s_any, s_var12
dift d_type12 = 12: s_any = "dg_" + s_any
$app s_pvar1, s_any + " - 1) * "
$app s_pvar1, d_longct1 + "]"
$clo s_pvar1, s_pvar1
s_plong1 = d_longct1
endi
'string compare second factor
dift d_type21 = 6
'*BLANK
s_pchar = " "
'use length of s_pvar1
s_plong2 = d_longct1
d_action = 22
endi
dift d_type21 = 7
'*ZEROS
s_pchar = "0"
'use length of s_pvar1
s_plong2 = d_longct1
d_action = 22
endi
dift d_type21 = 21
'string literal
s_pvar2 = s_var21
s_plong2 = d_longct2
d_action = 21
endi
dift d_type21 = 22
'string variable
s_pvar2 = "sg_" + s_var21
$clo s_pvar2, s_pvar2
s_plong2 = d_longct2
d_action = 21
endi
dift d_type21 = 23
'string array with index
dift d_type22 = 12
'validate numeric var index for s_cfield2
sg_pass1 = sg_ifindicators
$app sg_pass1, "tsub_index_range_cerror("
$app sg_pass1, s_cindex2
$app sg_pass1, ", " + d_indexct2 + ", "
$app sg_pass1, dg_rpglinenumber + ");"
sub_c_lineout
endi
$trb s_any, s_var21
s_pvar2 = "&sga_" + s_any + "[tfni_index( "
'is s_var22 a numeric variable
$trb s_any, s_var22
dift d_type22 = 12: s_any = "dg_" + s_any
$app s_pvar2, s_any + " - 1) * "
$app s_pvar2, d_longct2 + "];"
$clo s_pvar2, s_pvar2
s_plong2 = d_longct2
d_action = 21
endi
endi
dift d_action = 21
'string compare without *BLANK or *ZEROS
sg_pass1 = sg_ifindicators
$app sg_pass1, "tsub_compare_strings("
$app sg_pass1, s_pvar1 + ", " + s_plong1 + ", "
$app sg_pass1, s_pvar2 + ", " + s_plong2
$app sg_pass1, ", &ig_" + s_indicator1
$app sg_pass1, ", &ig_" + s_indicator2
$app sg_pass1, ", &ig_" + s_indicator3 + ");"
sub_c_lineout
dg_yeslinedone = 1
endi
dift d_action = 22
'string compare with *BLANK or *ZEROS
sg_pass1 = sg_ifindicators
$app sg_pass1, "tsub_comp_string_to_char("
$app sg_pass1, s_pvar1 + ", " + s_plong1
$app sg_pass1, ", '" + s_pchar + "'"
$app sg_pass1, ", &ig_" + s_indicator1
$app sg_pass1, ", &ig_" + s_indicator2
$app sg_pass1, ", &ig_" + s_indicator3 + ");"
sub_c_lineout
dg_yeslinedone = 1
endi
ends sub_c_cline_comp
subr sub_c_cline_slokup
'updated 2004/12/28
'string lokup
vari s_any, d_any, s_dot, d_dot, s_out
vari d_record, s_record, d_good
vari s_field1, s_field2, s_indicator
vari d_type11, d_type12, s_var11, s_var12
vari d_type21, d_type22, s_var21, s_var22
vari d_longct1, d_indexct1, d_longct2, d_indexct2
vari s_cindex1, s_cindex2
vari s_pvar1, s_pvar2, s_pbegindex, s_preturnindex
vari d_plongct, d_pindexct
vari s_field3, d_tablongct3
s_record = sg_pass1
'cline 1 2 3 4 5 6
'123456789012345678901234567890123456789012345678901234567890
' .CSR 01 02 03FACTOR1 COMMDFACTOR2 RESULT 92H919293
$cut s_field1, s_record, 18, 10
$cut s_field2, s_record, 33, 10
$cut s_field3, s_record, 43, 6
$cut s_indicator, s_record, 58, 2
sg_pass1 = s_field1
sub_field_info_return
d_type11 = dg_pass1
d_type12 = dg_pass2
d_indexct1 = dg_pass3
d_longct1 = dg_pass4
$trb s_var11, sg_pass1
$trb s_var12, sg_pass2
s_cindex1 = sg_pass7
sg_pass1 = s_field2
sub_field_info_return
d_type21 = dg_pass1
d_type22 = dg_pass2
d_indexct2 = dg_pass3
d_longct2 = dg_pass4
$trb s_var21, sg_pass1
$trb s_var22, sg_pass2
s_cindex2 = sg_pass7
'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
'first do we have a table lookup
dift d_type21 = 24
$isc d_any, s_field3, " "
dift d_any <> 1: d_type21 = 25
endi
'prep the lookfor field
dift d_type11 = 21
'alpha literal
s_pvar1 = s_var11
endi
dift d_type11 = 22
'alpha variable
$tlo s_any, s_var11
s_pvar1 = "sg_" + s_any
endi
dift d_type11 = 23
'alpha array with index
dift d_type12 = 12
'validate numeric var index for s_field1
sg_pass1 = sg_ifindicators
$app sg_pass1, "tsub_index_range_cerror("
$app sg_pass1, s_cindex1
$app sg_pass1, ", " + d_indexct1 + ", "
$app sg_pass1, dg_rpglinenumber + ");"
sub_c_lineout
endi
'prep the index first
dift d_type12 = 12
'numeric var
$tlo s_any, s_var12
s_dot = "tfni_index(dg_" + s_any + ")"
else
'numeric literal
s_dot = s_var12
endi
s_dot = "(" + s_dot + " - 1) * " + d_longct1
$tlo s_any, s_var11
s_pvar1 = "&sga_" + s_any + "[" + s_dot + "]"
endi
'prep the lookin array
$tlo s_any, s_var21
s_pvar2 = "sga_" + s_any
d_plongct = d_longct2
d_pindexct = d_indexct2
dift d_type21 = 23
'alpha array with index
dift d_type22 = 12
'validate numeric var index for s_field2
sg_pass1 = sg_ifindicators
$app sg_pass1, "tsub_index_range_cerror("
$app sg_pass1, s_cindex2
$app sg_pass1, ", " + d_indexct2 + ", "
$app sg_pass1, dg_rpglinenumber + ");"
sub_c_lineout
endi
'index must be a numeric variable
$tlo s_any, s_var22
s_pbegindex = "tfni_index(dg_" + s_any + ")"
s_preturnindex = "dg_" + s_any
sg_pass1 = sg_ifindicators
$app sg_pass1, "tng_z = rfni_slokup("
$app sg_pass1, s_pvar2 + ", "
$app sg_pass1, d_pindexct + ", "
$app sg_pass1, d_plongct + ", "
$app sg_pass1, s_pbegindex + ", "
$app sg_pass1, s_pvar1 + ");"
sub_c_lineout
'index is numeric variable
sg_pass1 = sg_ifindicators
$app sg_pass1, s_preturnindex
$app sg_pass1, " = " + "tng_z;"
sub_c_lineout
s_any = "ig_" + s_indicator
'set the indicator
sg_pass1 = sg_ifindicators
$app sg_pass1, "if(tng_z > 0) " + s_any
$app sg_pass1, " = 1; else " + s_any + " = 2;"
sub_c_lineout
dg_yeslinedone = 1
endi
dift d_type21 = 24
'alpha array no index
sg_pass1 = sg_ifindicators
$app sg_pass1, "tng_z = rfni_slokup("
$app sg_pass1, s_pvar2 + ", "
$app sg_pass1, d_pindexct + ", "
$app sg_pass1, d_plongct + ", "
$app sg_pass1, "1, "
$app sg_pass1, s_pvar1 + ");"
sub_c_lineout
s_any = "ig_" + s_indicator
'set the indicator
sg_pass1 = sg_ifindicators
$app sg_pass1, "if(tng_z > 0) " + s_any
$app sg_pass1, " = 1; else " + s_any + " = 2;"
sub_c_lineout
dg_yeslinedone = 1
endi
dift d_type21 = 25
'table lookup
sg_pass1 = s_field3
sub_variable_info_return
d_tablongct3 = dg_pass3
$tlo s_field3, s_field3
sg_pass1 = sg_ifindicators
$app sg_pass1, "tng_z = rfni_stablokup("
$app sg_pass1, s_pvar2 + ", "
$app sg_pass1, d_pindexct + ", "
$app sg_pass1, d_plongct + ", "
$app sg_pass1, d_tablongct3 + ", "
$app sg_pass1, s_pvar1 + ", "
$app sg_pass1, "sg_" + s_field3 + ");"
sub_c_lineout
s_any = "ig_" + s_indicator
'set the indicator
sg_pass1 = sg_ifindicators
$app sg_pass1, "if(tng_z == 1) " + s_any
$app sg_pass1, " = 1; else " + s_any + " = 2;"
sub_c_lineout
dg_yeslinedone = 1
endi
'int rfni_slokup(char *sp_lookin, int ip_indexct,
'int ip_long, int ip_begindex, char *sp_lookfor);
'int rfni_stablokup(char *sp_lookin, int ip_indexct,
'int ip_long1, int ip_long2, char *sp_lookfor,
'char *sp_putinto);
ends sub_c_cline_slokup
subr sub_c_cline_nlokup
'updated 2004/09/05
'numeric lokup
vari s_any, d_any, s_dot, d_dot, s_out
vari d_record, s_record, d_good
vari s_field1, s_field2, s_indicator
vari d_type11, d_type12, s_var11, s_var12
vari d_type21, d_type22, s_var21, s_var22
vari d_longct1, d_indexct1, d_longct2, d_indexct2
vari s_cindex1, s_cindex2
vari s_pvar1, s_pvar2, s_pbegindex, s_preturnindex
vari d_plongct, d_pindexct
s_record = sg_pass1
$cut s_field1, s_record, 18, 10
$cut s_field2, s_record, 33, 10
$cut s_indicator, s_record, 58, 2
sg_pass1 = s_field1
sub_field_info_return
d_type11 = dg_pass1
d_type12 = dg_pass2
d_indexct1 = dg_pass3
d_longct1 = dg_pass4
$trb s_var11, sg_pass1
$trb s_var12, sg_pass2
s_cindex1 = sg_pass7
sg_pass1 = s_field2
sub_field_info_return
d_type21 = dg_pass1
d_type22 = dg_pass2
d_indexct2 = dg_pass3
d_longct2 = dg_pass4
$trb s_var21, sg_pass1
$trb s_var22, sg_pass2
s_cindex2 = sg_pass7
'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
'prep the lookfor field
dift d_type11 = 11
'numeric literal
s_pvar1 = s_var11
endi
dift d_type11 = 12
'numeric variable
$tlo s_any, s_var11
s_pvar1 = "dg_" + s_any
endi
dift d_type11 = 13
'numeric array with index
dift d_type12 = 12
'validate numeric var index for s_field1
sg_pass1 = sg_ifindicators
$app sg_pass1, "tsub_index_range_cerror("
$app sg_pass1, s_cindex1
$app sg_pass1, ", " + d_indexct1 + ", "
$app sg_pass1, dg_rpglinenumber + ");"
sub_c_lineout
endi
'prep the index first
dift d_type12 = 12
'numeric var index
$tlo s_any, s_var12
s_dot = "tfni_index(dg_" + s_any + ")"
else
'numeric literal index
s_dot = s_var12
endi
$tlo s_any, s_var11
s_pvar1 = "&dga_" + s_any + "[" + s_dot + " - 1]"
endi
'prep the lookin array
dift d_type21 = 13
'numeric array with index
dift d_type22 = 12
'validate numeric var index for s_field2
sg_pass1 = sg_ifindicators
$app sg_pass1, "tsub_index_range_cerror("
$app sg_pass1, s_cindex2
$app sg_pass1, ", " + d_indexct2 + ", "
$app sg_pass1, dg_rpglinenumber + ");"
sub_c_lineout
endi
$tlo s_any, s_var21
s_pvar2 = "dga_" + s_any
endi
dift d_type21 = 14
'numeric array no index
$tlo s_any, s_var21
s_pvar2 = "dga_" + s_any
endi
d_plongct = d_longct2
d_pindexct = d_indexct2
dift d_type21 = 13
'numeric array with index
'prep the begindex
dift d_type22 = 12
'index is numeric variable
$tlo s_any, s_var22
s_pbegindex = "tfni_index(dg_" + s_any + ")"
s_preturnindex = "dg_" + s_any
else
'index in numeric literal
s_pbegindex = s_var22
endi
sg_pass1 = sg_ifindicators + "tng_z = rfni_nlokup("
$app sg_pass1, s_pvar2 + ", "
$app sg_pass1, d_pindexct + ", "
$app sg_pass1, d_plongct + ", "
$app sg_pass1, s_pbegindex + ", "
$app sg_pass1, s_pvar1 + ");"
sub_c_lineout
'index is numeric variable
sg_pass1 = sg_ifindicators
$app sg_pass1, s_preturnindex
$app sg_pass1, " = " + "tng_z;"
sub_c_lineout
s_any = "ig_" + s_indicator
'set the indicator
sg_pass1 = sg_ifindicators
$app sg_pass1, "if(tng_z > 0) " + s_any
$app sg_pass1, " = 1; else " + s_any + " = 2;"
sub_c_lineout
dg_yeslinedone = 1
endi
dift d_type21 = 14
'numeric array no index
sg_pass1 = sg_ifindicators
$app sg_pass1, "tng_z = rfni_nlokup("
$app sg_pass1, s_pvar2 + ", "
$app sg_pass1, d_pindexct + ", "
$app sg_pass1, d_plongct + ", "
$app sg_pass1, "1, "
$app sg_pass1, s_pvar1 + ");"
sub_c_lineout
s_any = "ig_" + s_indicator
'set the indicator
sg_pass1 = sg_ifindicators
$app sg_pass1, "if(tng_z > 0) " + s_any
$app sg_pass1, " = 1; else " + s_any + " = 2;"
sub_c_lineout
dg_yeslinedone = 1
endi
'int rfni_slokup(char *sp_lookin, int ip_indexct,
'int ip_long, int ip_begindex, char *sp_lookfor);
ends sub_c_cline_nlokup
subr sub_c_cline_movea
'updated 2004/12/30
'make C lines for command MOVEA
vari s_any, d_any, s_dot, d_dot, s_out
vari d_record, s_record, d_good, d_action
vari s_command, s_field1, s_field2
vari d_type11, d_type12, s_var11, s_var12
vari d_type21, d_type22, s_var21, s_var22
vari d_longct1, d_indexct1, d_longct2, d_indexct2
vari s_pbeg1, s_pbeg2, d_plong1, d_plong2
vari s_cfield1, s_cfield2
vari s_cindex1, s_cindex2
vari s_pvar1, s_pvar2
s_record = sg_pass1
'cline 1 2 3 4 5 6
'123456789012345678901234567890123456789012345678901234567890
' .CSR 01 02 03FACTOR1 COMMDFACTOR2 RESULT 92H919293
'c if indicators are in sg_ifindicators
$cut s_command, s_record, 28, 5
$cut s_field1, s_record, 33, 10
$cut s_field2, s_record, 43, 6
's_field1 which is factor2 can be:
'*BLANK
'alpha literal
'alpha var
'alpha array with index
'alpha array
's_field2 which is the result can be
'alpha var
'alpha array with index
'alpha array
'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
'get info for s_field1 = factor2
sg_pass1 = s_field1
sub_field_info_return
d_type11 = dg_pass1
d_type12 = dg_pass2
d_indexct1 = dg_pass3
d_longct1 = dg_pass4
s_var11 = sg_pass1
s_var12 = sg_pass2
s_cfield1 = sg_pass4
s_cindex1 = sg_pass7
dift d_type11 = 21
'alpha literal
s_pvar1 = s_cfield1
s_pbeg1 = "1"
endi
dift d_type11 = 22
'alpha variable
s_pvar1 = s_cfield1
s_pbeg1 = "1"
endi
dift d_type11 = 23
'alpha array with index
dift d_type12 = 12
'validate numeric var index for s_field1
sg_pass1 = sg_ifindicators
$app sg_pass1, "tsub_index_range_cerror("
$app sg_pass1, s_cindex1
$app sg_pass1, ", " + d_indexct1 + ", "
$app sg_pass1, dg_rpglinenumber + ");"
sub_c_lineout
endi
$tlo s_var11, s_var11
s_pvar1 = "sga_" + s_var11
dift d_type12 = 11
'number literal index
s_pbeg1 = s_var12
else
'number variable index
$tlo s_any, s_var12
s_pbeg1 = "tfni_index( dg_" + s_any + ")"
endi
endi
dift d_type11 = 24
'alpha array no index
$tlo s_var11, s_var11
s_pvar1 = "sga_" + s_var11
s_pbeg1 = "1"
endi
sg_pass1 = s_field2
sub_field_info_return
d_type21 = dg_pass1
d_type22 = dg_pass2
d_indexct2 = dg_pass3
d_longct2 = dg_pass4
s_var21 = sg_pass1
s_var22 = sg_pass2
s_cfield2 = sg_pass4
s_cindex2 = sg_pass7
$tlo s_var21, s_var21
$tlo s_var22, s_var22
dift d_type21 = 22
'alpha variable
s_pvar2 = "sg_" + s_var21
s_pbeg2 = "1"
endi
dift d_type21 = 23
'alpha array with index
dift d_type22 = 12
'validate numeric var index for s_field2
sg_pass1 = sg_ifindicators
$app sg_pass1, "tsub_index_range_cerror("
$app sg_pass1, s_cindex2
$app sg_pass1, ", " + d_indexct2 + ", "
$app sg_pass1, dg_rpglinenumber + ");"
sub_c_lineout
endi
s_pvar2 = "sga_" + s_var21
dift d_type22 = 11
'number index take off leading zeros
s_pbeg2 = s_var22
else
'variable index
s_pbeg2 = "tfni_index( dg_" + s_var22 + ")"
endi
endi
dift d_type21 = 24
'alpha array no index
s_pvar2 = "sga_" + s_var21
s_pbeg2 = "1"
endi
d_good = 1
dift d_type11 = 6
'MOVEA *BLANK
sg_pass1 = sg_ifindicators
$app sg_pass1, "rsub_crpg_movea_blankorzero( "
$app sg_pass1, s_pvar2 + ", " + d_indexct2 + ", "
$app sg_pass1, d_longct2 + ", " + s_pbeg2
$app sg_pass1, ", ' ');"
sub_c_lineout
dinc d_good
dg_yeslinedone = 1
endi
dift d_type11 = 7
'MOVEA *ZEROS
sg_pass1 = sg_ifindicators
$app sg_pass1, "rsub_crpg_movea_blankorzero( "
$app sg_pass1, s_pvar2 + ", " + d_indexct2 + ", "
$app sg_pass1, d_longct2 + ", " + s_pbeg2
$app sg_pass1, ", '0');"
sub_c_lineout
dinc d_good
dg_yeslinedone = 1
endi
dift d_good = 1
'output to c for MOVEA
sg_pass1 = sg_ifindicators
$app sg_pass1, "rsub_crpg_movea("
$app sg_pass1, s_pvar2 + ", " + d_indexct2 + ", "
$app sg_pass1, d_longct2 + ", " + s_pbeg2 + ", "
$app sg_pass1, s_pvar1 + ", " + d_indexct1 + ", "
$app sg_pass1, d_longct1 + ", " + s_pbeg1 + ");"
sub_c_lineout
dg_yeslinedone = 1
endi
ends sub_c_cline_movea
subr sub_c_cline_movel
'updated 2004/09/18
'make C lines for command MOVEL
vari s_any, d_any, s_dot, d_dot, s_out
vari s_record, d_action
vari s_field1, d_type1, d_longct1, d_decimalct1, s_var1
vari s_field2, d_type2, d_longct2, d_decimalct2, s_var2
vari s_pbeg1, s_pbeg2, d_plong1, d_plong2
vari s_pvar1, s_pvar2
s_record = sg_pass1
'cline 1 2 3 4 5 6
'123456789012345678901234567890123456789012345678901234567890
' .CSR 01 02 03FACTOR1 COMMDFACTOR2 RESULT 92H919293
'c if indicators are in sg_ifindicators
$cut s_field1, s_record, 33, 10
$cut s_field2, s_record, 43, 6
's_field1 which is factor2 can be:
'*BLANK
'alpha literal
'alpha var
'alpha array with index
'alpha array
's_field2 which is the result can be
'alpha var
'alpha array with index
'alpha array
'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
'get info for s_field1 = factor2
sg_pass1 = s_field1
sub_field_info_return
d_type1 = dg_pass1
d_longct1 = dg_pass4
d_decimalct1 = dg_pass5
s_var1 = sg_pass1
dift d_type1 = 12
'numeric variable to tsg_256a
$tlo s_var1, s_var1
sg_pass1 = sg_ifindicators
$app sg_pass1, "tsub_double_to_packed(tsg_256a, "
$app sg_pass1, "dg_" + s_var1 + ", "
$app sg_pass1, d_longct1 + ", " + d_decimalct1 + ");"
sub_c_lineout
sg_pass1 = sg_ifindicators
$app sg_pass1, "tsgp_1 = tsg_256a;"
sub_c_lineout
endi
dift d_type1 = 21
'alpha literal to tsg_256a
sg_pass1 = sg_ifindicators
$app sg_pass1, "tsub_copy(tsg_256a, " + s_var1
$app sg_pass1, ", " + d_longct1 + ");"
sub_c_lineout
sg_pass1 = sg_ifindicators
$app sg_pass1, "tsgp_1 = tsg_256a;"
sub_c_lineout
endi
dift d_type1 = 22
'alpha variable
$tlo s_var1, s_var1
sg_pass1 = sg_ifindicators
$app sg_pass1, "tsgp_1 = sg_" + s_var1 + ";"
sub_c_lineout
endi
'get info for s_field2 = result field
sg_pass1 = s_field2
sub_field_info_return
d_type2 = dg_pass1
d_longct2 = dg_pass4
d_decimalct2 = dg_pass5
s_var2 = sg_pass1
$tlo s_var2, s_var2
d_action = 0
dift d_type2 = 12
'to a numeric variable
'put numeric variable in tsg_256b
sg_pass1 = sg_ifindicators
$app sg_pass1, "tsub_double_to_packed(tsg_256b, "
$app sg_pass1, "dg_" + s_var2 + ", "
$app sg_pass1, d_longct2 + ", " + d_decimalct2 + ");"
sub_c_lineout
'MOVEL
sg_pass1 = sg_ifindicators
$app sg_pass1, "rsub_crpg_movel(tsg_256b, "
$app sg_pass1, d_longct2 + ", tsgp_1, "
$app sg_pass1, d_longct1 + ");"
sub_c_lineout
'put tsg_256b into numeric variable
sg_pass1 = sg_ifindicators
$app sg_pass1, "tsub_packed_to_double(&dg_" + s_var2
$app sg_pass1, ", tsg_256b, " + d_longct2 + ", "
$app sg_pass1, d_decimalct2 + ", " + dg_rpglinenumber
$app sg_pass1, ");"
sub_c_lineout
dg_yeslinedone = 1
endi
dift d_type2 = 22
'to alpha variable
'MOVEL
sg_pass1 = sg_ifindicators
$app sg_pass1, "rsub_crpg_movel(sg_" + s_var2
$app sg_pass1, ", " + d_longct2 + ", tsgp_1, "
$app sg_pass1, d_longct1 + ");"
sub_c_lineout
dg_yeslinedone = 1
endi
ends sub_c_cline_movel
subr sub_c_cline_move_right
'updated 2004/09/18
'make C lines for command MOVE
vari s_any, d_any, s_dot, d_dot
vari s_record, d_action
vari s_field1, d_type1, d_indexct1
vari d_longct1, d_decimalct1, s_var1
vari s_field2, d_type2, d_indexct2
vari d_longct2, d_decimalct2, s_var2
s_record = sg_pass1
'cline 1 2 3 4 5 6
'123456789012345678901234567890123456789012345678901234567890
' .CSR 01 02 03FACTOR1 COMMDFACTOR2 RESULT 92H919293
'c if indicators are in sg_ifindicators
$cut s_field1, s_record, 33, 10
$cut s_field2, s_record, 43, 6
's_field1 which is factor2 can be:
'*BLANK=6
'*ZEROS=7
'numeric var=12
'alpha literal=21
'alpha var=22
's_field2 which is the result can be
'numeric var-12
'alpha var=22
'alpha array no index=24
'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
'get info for s_field1 = factor2
sg_pass1 = s_field1
sub_field_info_return
d_type1 = dg_pass1
d_indexct1 = dg_pass3
d_longct1 = dg_pass4
d_decimalct1 = dg_pass5
s_var1 = sg_pass1
dift d_type1 = 12
'numeric variable to tsg_256a
$tlo s_var1, s_var1
sg_pass1 = sg_ifindicators
$app sg_pass1, "tsub_double_to_packed(tsg_256a, "
$app sg_pass1, "dg_" + s_var1 + ", "
$app sg_pass1, d_longct1 + ", " + d_decimalct1 + ");"
sub_c_lineout
sg_pass1 = sg_ifindicators + "tsgp_1 = tsg_256a;"
sub_c_lineout
endi
dift d_type1 = 21
'alpha literal to tsg_256a
sg_pass1 = sg_ifindicators
$app sg_pass1, "tsub_copy(tsg_256a, " + s_var1
$app sg_pass1, ", " + d_longct1 + ");"
sub_c_lineout
sg_pass1 = sg_ifindicators
$app sg_pass1, "tsgp_1 = tsg_256a;"
sub_c_lineout
endi
dift d_type1 = 22
'alpha variable
$tlo s_var1, s_var1
sg_pass1 = sg_ifindicators
$app sg_pass1, "tsgp_1 = sg_" + s_var1 + ";"
sub_c_lineout
endi
'get info for s_field2 = result field
sg_pass1 = s_field2
sub_field_info_return
d_type2 = dg_pass1
d_indexct2 = dg_pass3
d_longct2 = dg_pass4
d_decimalct2 = dg_pass5
s_var2 = sg_pass1
$tlo s_var2, s_var2
d_action = 0
'6 is *BLANK
dift d_type1 = 6: d_action = 1
'7 is *ZEROS
dift d_type1 = 7: d_action = 2
dift d_action = 0
'to a numeric variable
dift d_type2 = 12: d_action = 3
'to an alpha variable
dift d_type2 = 22: d_action = 4
'to an alpha array no index
dift d_type2 = 24: d_action = 5
endi
dift d_action = 1
'MOVE *BLANK
sg_pass1 = sg_ifindicators
$app sg_pass1, "rsub_crpg_movea_blankorzero("
$app sg_pass1, "sg_" + s_var2 + ", " + d_indexct2 + ", "
$app sg_pass1, d_longct2 + ", 1, ' ');"
sub_c_lineout
dg_yeslinedone = 1
endi
dift d_action = 2
'MOVE *ZEROS
sg_pass1 = sg_ifindicators
$app sg_pass1, "rsub_crpg_movea_blankorzero("
$app sg_pass1, "sg_" + s_var2 + ", " + d_indexct2 + ", "
$app sg_pass1, d_longct2 + ", 1, '0');"
sub_c_lineout
dg_yeslinedone = 1
endi
dift d_action = 3
'to a numeric variable
'put numeric variable in tsg_256b
sg_pass1 = sg_ifindicators
$app sg_pass1, "tsub_double_to_packed(tsg_256b, "
$app sg_pass1, "dg_" + s_var2 + ", "
$app sg_pass1, d_longct2 + ", " + d_decimalct2 + ");"
sub_c_lineout
'move right
sg_pass1 = sg_ifindicators
$app sg_pass1, "rsub_crpg_move_right(tsg_256b, "
$app sg_pass1, d_longct2 + ", tsgp_1, "
$app sg_pass1, d_longct1 + ");"
sub_c_lineout
'put tsg_256b into numeric variable
sg_pass1 = sg_ifindicators
$app sg_pass1, "tsub_packed_to_double(&dg_" + s_var2
$app sg_pass1, ", tsg_256b, " + d_longct2 + ", "
$app sg_pass1, d_decimalct2 + ", " + dg_rpglinenumber
$app sg_pass1, ");"
sub_c_lineout
dg_yeslinedone = 1
endi
dift d_action = 4
'to alpha variable
'MOVE right
sg_pass1 = sg_ifindicators
$app sg_pass1, "rsub_crpg_move_right(sg_" + s_var2
$app sg_pass1, ", " + d_longct2 + ", tsgp_1, "
$app sg_pass1, d_longct1 + ");"
sub_c_lineout
dg_yeslinedone = 1
endi
dift d_action = 5
'move to array
sg_pass1 = sg_ifindicators
$app sg_pass1, "tsub_move_right_into_array(sga_" + s_var2
$app sg_pass1, ", " + d_indexct2 + ", " + d_longct2
$app sg_pass1, ", tsgp_1, " + d_longct1 + ");"
sub_c_lineout
dg_yeslinedone = 1
endi
ends sub_c_cline_move_right
subr sub_c_cline_biton_bitof
'updated 2004/08/29
'make C lines for command MOVE
vari s_any, d_any, s_dot, d_dot, s_out
vari s_record, d_good, d_numresult, s_command
vari s_field1, d_type1, d_longct1, d_decimalct1, s_var1
vari s_field2, d_type2, d_longct2, d_decimalct2, s_var2
vari s_pbeg1, s_pbeg2, d_plong1, d_plong2
vari s_pvar1, s_pvar2
s_record = sg_pass1
'cline 1 2 3 4 5 6
'123456789012345678901234567890123456789012345678901234567890
' .CSR 01 02 03FACTOR1 COMMDFACTOR2 RESULT 92H919293
'c if indicators are in sg_ifindicators
$cut s_command, s_record, 28, 5
$cut s_field1, s_record, 33, 10
$cut s_field2, s_record, 43, 6
's_field1 which is factor2 can be:
'alpha literal
'alpha var
's_field2 which is the result can be
'alpha var
'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
d_numresult = 2
'get info for s_field1 = factor2
sg_pass1 = s_field1
sub_field_info_return
d_type1 = dg_pass1
d_longct1 = dg_pass4
d_decimalct1 = dg_pass5
s_var1 = sg_pass1
$tlo s_var1, s_var1
dift d_type1 = 21
'alpha literal to tsg_256a
'copy the literal into tsg_256a
sg_pass1 = sg_ifindicators
$app sg_pass1, "tsub_copy(tsg_256a, " + s_var1
$app sg_pass1, ", " + d_longct1 + ");"
sub_c_lineout
'set pointer tsgp_1 to point to tsg_256a
sg_pass1 = sg_ifindicators
$app sg_pass1, "tsgp_1 = tsg_256a;"
sub_c_lineout
endi
dift d_type1 = 22
'alpha variable
'set pointer tsgp_1 to point to the alpha variable
sg_pass1 = sg_ifindicators
$app sg_pass1, "tsgp_1 = sg_" + s_var1 + ";"
sub_c_lineout
endi
'get info for s_field2 = result field
'must be alpha var one long
sg_pass1 = s_field2
sub_field_info_return
d_type2 = dg_pass1
d_longct2 = dg_pass4
d_decimalct2 = dg_pass5
s_var2 = sg_pass1
$tlo s_var2, s_var2
'must have alpha variable
'set the pointer tsgp_2 to point to the alpha variable
sg_pass1 = sg_ifindicators
$app sg_pass1, "tsgp_2 = sg_" + s_var2 + ";"
sub_c_lineout
'call the needed rsub
$ift s_command = "BITON"
sg_pass1 = sg_ifindicators
$app sg_pass1, "rsub_command_biton(tsgp_2, tsgp_1, "
$app sg_pass1, d_longct1 + ");"
sub_c_lineout
dg_yeslinedone = 1
else
'BITOF
sg_pass1 = sg_ifindicators
$app sg_pass1, "rsub_command_bitof(tsgp_2, tsgp_1, "
$app sg_pass1, d_longct1 + ");"
sub_c_lineout
dg_yeslinedone = 1
endi
ends sub_c_cline_biton_bitof
subr sub_c_cline_sorta
'updated 2004/09/06
vari s_any, d_any, s_dot, d_dot, s_out
vari s_record, s_factor2
vari d_vartype, d_indexct, d_longct, d_decimalct
s_record = sg_pass1
'cline 1 2 3 4 5 6
'123456789012345678901234567890123456789012345678901234567890
' .CSR 01 02 03FACTOR1 COMMDFACTOR2 RESULT 92H919293
$cut s_factor2, s_record, 33, 10
'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
sg_pass1 = s_factor2
sub_variable_info_return
d_vartype = dg_pass1
d_indexct = dg_pass2
d_longct = dg_pass3
d_decimalct = dg_pass4
$tlo s_factor2, s_factor2
dift d_vartype = 2
'numeric sort array
sg_pass1 = sg_ifindicators
$app sg_pass1, "tsub_nsorta(dga_" + s_factor2 + ", "
$app sg_pass1, d_indexct + ");"
sub_c_lineout
dg_yeslinedone = 1
endi
dift d_vartype = 7
'alpha sort array
sg_pass1 = sg_ifindicators
$app sg_pass1, "tsub_asorta(sga_" + s_factor2 + ", "
$app sg_pass1, d_indexct + ", " + d_longct + ");"
sub_c_lineout
dg_yeslinedone = 1
endi
ends sub_c_cline_sorta
subr sub_c_olines
'updated 2007/06/17, 2005/01/27, 2004/03/14
vari s_any, d_any, s_dot, d_dot, s_out
vari d_loop, d_good, d_count, s_fromsubr
vari d_record, s_record, d_olinebegin, d_filebyteold
vari s_6hold, s_6byte, s_7byte
vari s_excpttags, s_tag, d_tag
$sys sg_subroutine, 2
s_fromsubr = sg_subroutine
dift dg_tdebug = 1
sg_pass1 = sg_subroutine
sub_return
endi
'find where the olines begin=d_olinebegin
sg_csubrname = sg_nothing
d_filebyteold = 1
d_olinebegin = 1
s_excpttags = sg_nothing
dg_rpglinenumber = 0
d_record = 0
dg_filebyte = 1
d_loop = 1
dwhi d_loop = 1
d_filebyteold = dg_filebyte
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
dinc dg_rpglinenumber
'tell
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
$cut s_6byte, s_record, 6, 1
$cut s_7byte, s_record, 7, 1
$ift s_6byte = "O"
'make sure the O is for an oline
$ift s_6hold = "C"
d_olinebegin = d_filebyteold
endi
$ift s_7byte = "*": dinc d_good
else
dinc d_good
endi
s_6hold = s_6byte
endi
dift d_good = 1
'put new excpt tags in s_excpttags
$ift s_7byte <> " "
$cut s_tag, s_record, 32, 6
$lok d_any, s_excpttags, 1, s_tag
dift d_any = 0: $app s_excpttags, s_tag + ","
endi
endi
endw
'oline 1 2 3 4 5 6
'123456789012345678901234567890123456789012345678901234567890
' .OFILENAMEE 12 01 02 03OLINE
' .O 01 02 03VARIABJB 132 "HEADING LINE "
'go through excpt tags to create oline_subroutines
d_tag = 0
d_loop = 1
dwhi d_loop = 1
dinc d_tag
$par s_tag, s_excpttags, ",", d_tag
'did we get an excpttag
$trb s_tag, s_tag
$len d_any, s_tag
dift d_any > 0
$sho s_fromsubr + "=" + s_tag
dg_pass1 = d_olinebegin
sg_pass1 = s_tag
sub_c_oline_subroutines
else
$out s_fromsubr + " done"
dinc d_loop
endi
endw
ends sub_c_olines
subr sub_c_oline_subroutines
'updated 2007/06/20, 2007/06/18, 2007/06/17
'2007/06/15, 2006/07/12, 2005/07/06, 2005/07/05, 2005/01/11
'create subroutine for particular excpttag
vari s_any, d_any, s_dot, d_dot, s_out
vari d_loop, d_good, d_count, d_long
vari s_record, d_filebyte
vari s_6byte, s_7byte, d_action
vari s_fileout, s_filedevice, d_yesterminal
vari s_excpttag, s_tag, s_excptsubr
vari d_skipbefore, d_skipafter
vari s_indicators, s_oifindicators
vari s_variable, s_endbyte, s_literal
vari s_editcd, s_blankcd
vari d_yesinexcpttag, d_yessubrfilewrite, s_subrfilewrite
vari d_vartype1, d_vartype2, s_var1, s_var2
vari d_varindexct1, d_varlongct1, d_vardecimalct1
vari d_beg, d_end, s_index
'd_filebyte is beginning of output lines
's_excpttag is the excpttag to create sub for
d_filebyte = dg_pass1
s_excpttag = sg_pass1
sub_c_blankline
'output subroutine beginning
$tlo s_any, s_excpttag
s_excptsubr = "sub_excpt_" + s_any
sg_pass1 = "void " + s_excptsubr + "(void) {"
sub_c_lineout
sg_pass1 = "int i_long; int i_index;"
sub_c_lineout
'starting at d_filebyte create subroutine for s_excpttag
d_yesinexcpttag = 2
d_yesterminal = 2
d_loop = 1
dwhi d_loop = 1
d_good = 1
d_action = 0
d_yessubrfilewrite = 2
'sip in a record
fsip s_record, sg_inpfile, d_filebyte
dift d_filebyte = 0
'we are at the end of olines
dinc d_good
dinc d_loop
dift d_yesinexcpttag = 1: d_yessubrfilewrite = 1
dinc d_yesinexcpttag
endi
dift d_good = 1
'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
$cut s_6byte, s_record, 6, 1
$cut s_7byte, s_record, 7, 1
$ift s_6byte <> "O"
'we are at the end of the olines
dinc d_good
dinc d_loop
dift d_yesinexcpttag = 1: d_yessubrfilewrite = 1
dinc d_yesinexcpttag
endi
endi
dift d_good = 1
'have we an excpttag in s_record
$ist d_any, s_7byte, "A"
dift d_any = 1
'have we been in the wanted excpttag
dift d_yesinexcpttag = 1
'output tsg_output2 down below
d_yessubrfilewrite = 1
endi
'have we the wanted excpttag in this line
$cut s_tag, s_record, 32, 6
$trb s_tag, s_tag
$ift s_tag = s_excpttag
'begin building wanted excpttag
d_action = 100
d_yesinexcpttag = 1
else
'begin an unwanted excpttag
dinc d_yesinexcpttag
endi
dinc d_good
endi
dift d_yesinexcpttag <> 1: dinc d_good
endi
'oline 1 2 3 4 5 6
'123456789012345678901234567890123456789012345678901234567890
' .OFILENAMEE 12 01 02 03OLINE
' .O 01 02 03VARIABJB 132 "HEADING LINE "
dift d_good = 1
'we are in output of wanted excpttag
$ift s_7byte = "*"
'we have a comment oline
d_action = 20
dinc d_good
endi
endi
dift d_good = 1
'do we have a variable or literal output oline
$cut s_any, s_record, 32, 6
$isc d_any, s_any, " "
dift d_any = 1: d_action = 200
dift d_any <> 1: d_action = 300
endi
'do we have terminal output
d_any = 2
dift d_yessubrfilewrite = 1
dift d_yesterminal = 1: d_any = 1
endi
dift d_any = 1
'output to the term data is in tsg_output2
'the output subroutine outputs tsg_output1
'blank tsg_output1 no s_oifindicators here
sg_pass1 = "tsub_blank(tsg_output1, 2048);"
sub_c_lineout
'skip lines before if needed
d_any = 0
dwhi d_any < d_skipbefore
'call s_subrfilewrite to output tsg_output1
sg_pass1 = s_oifindicators + s_subrfilewrite
sub_c_lineout
dinc d_any
endw
'copy tsg_output2 to tsg_output1
sg_pass1 = s_oifindicators
$app sg_pass1, "tsub_copy(tsg_output1, tsg_output2, 2048);"
sub_c_lineout
'call the subroutine to output
sg_pass1 = s_oifindicators + s_subrfilewrite
sub_c_lineout
'blank tsg_output2 no s_oifindicators here
sg_pass1 = "tsub_blank(tsg_output2, 2048);"
sub_c_lineout
'blank tsg_output1 no s_oifindicators here
sg_pass1 = "tsub_blank(tsg_output1, 2048);"
sub_c_lineout
'skip lines after if needed
d_any = 1
dwhi d_any < d_skipafter
'call subr to output tsg_output1
sg_pass1 = s_oifindicators + s_subrfilewrite
sub_c_lineout
dinc d_any
endw
dinc d_yessubrfilewrite
endi
'do we have file output
d_any = 2
dift d_yessubrfilewrite = 1
dift d_yesterminal <> 1: d_any = 1
endi
dift d_any = 1
'output to the file data is in tsg_output2
'the output subroutine outputs tsg_output1
'copy tsg_output2 to tsg_output1
sg_pass1 = s_oifindicators
$app sg_pass1, "tsub_copy(tsg_output1, tsg_output2, 2048);"
sub_c_lineout
'call the subroutine to output to the file
sg_pass1 = s_oifindicators + s_subrfilewrite
sub_c_lineout
'blank tsg_output2 no s_ifindicators here
sg_pass1 = "tsub_blank(tsg_output2, 2048);"
sub_c_lineout
'blank tsg_output1 no s_oifindicators here
sg_pass1 = "tsub_blank(tsg_output1, 2048);"
sub_c_lineout
dinc d_yessubrfilewrite
endi
dift d_action = 20
'output the comment line in wanted excpttag
$cut s_any, s_record, 8, 99
$trb s_any, s_any
$len d_any, s_any
dift d_any > 0
sub_c_blankline
$trb s_any, s_record
sg_pass1 = sg_slashaster + s_any + sg_asterslash
sub_c_lineout
endi
endi
dift d_action > 20
dift d_action < 900
'output RPG line as comment line
'with blank line first
sub_c_blankline
$trb s_any, s_record
sg_pass1 = sg_slashaster + dg_rpglinenumber
$app sg_pass1, " " + s_any + sg_asterslash
sub_c_lineout
endi
endi
dift d_action = 100
'filename excpt tag oline
$cut s_fileout, s_record, 7, 8
$tlo s_fileout, s_fileout
'get file information
sg_pass1 = s_fileout
sub_rpg_file_info_return
s_filedevice = sg_pass1
'get d_skipbefore and d_skipafter
$cut s_any, s_record, 17, 1
$isd d_any, s_any
dift d_any <> 1: s_any = "0"
$tod d_skipbefore, s_any
$cut s_any, s_record, 18, 1
$isd d_any, s_any
dift d_any <> 1: s_any = "1"
$tod d_skipafter, s_any
'if s_filedevice<>"$STDLST " adjust skips
$ift s_filedevice <> "$STDLST "
d_skipbefore = 0
d_skipafter = 1
d_yesterminal = 1
else
d_yesterminal = 2
endi
'get excpt tag oline s_oifindicators
$cut s_indicators, s_record, 23, 9
sg_pass1 = s_indicators
sub_c_ifindicators
s_oifindicators = sg_ifindicators
s_subrfilewrite = "sub_file_write_" + s_fileout
$app s_subrfilewrite, "();"
'blank tsg_output2 no s_oifindicators here
sg_pass1 = "tsub_blank(tsg_output2, 2048);"
sub_c_lineout
endi
dift d_action = 200
'literal output oline
$cut s_indicators, s_record, 23, 9
sg_pass1 = s_indicators
sub_c_ifindicators
$cut s_endbyte, s_record, 40, 4
$cut s_literal, s_record, 45, 30
$trb s_literal, s_literal
$len d_long, s_literal
d_long = d_long - 2
$tod d_dot, s_endbyte
d_dot = d_dot - d_long
sg_pass1 = sg_ifindicators
$app sg_pass1, "tsub_copy(&tsg_output2[" + d_dot
$app sg_pass1, "], " + s_literal + ", "
$app sg_pass1, d_long + ");"
sub_c_lineout
endi
dift d_action = 300
'variable output oline
$cut s_indicators, s_record, 23, 9
sg_pass1 = s_indicators
sub_c_ifindicators
$cut s_variable, s_record, 32, 6
$cut s_editcd, s_record, 38, 1
$cut s_blankcd, s_record, 39, 1
$cut s_endbyte, s_record, 40, 4
$cut s_literal, s_record, 45, 30
$tod d_end, s_endbyte
'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
'what kind of variable have we
sg_pass1 = s_variable
sub_field_info_return
d_vartype1 = dg_pass1
d_vartype2 = dg_pass2
d_varindexct1 = dg_pass3
d_varlongct1 = dg_pass4
d_vardecimalct1 = dg_pass5
s_var1 = sg_pass1
s_var2 = sg_pass2
dift d_vartype1 = 8: d_action = 405
dift d_vartype1 = 12: d_action = 410
dift d_vartype1 = 13: d_action = 420
dift d_vartype1 = 22: d_action = 440
dift d_vartype1 = 23: d_action = 450
dift d_vartype1 = 24: d_action = 460
$tlo s_var1, s_var1
$tlo s_var2, s_var2
endi
dift d_action = 405
'UDATE
sg_pass1 = "tsub_udate(tsg_256a, '"
$app sg_pass1, s_editcd + "');"
sub_c_lineout
d_dot = d_end - 6
d_long = 6
$ift s_editcd = "Y"
d_dot = d_end - 8
d_long = 8
endi
sg_pass1 = sg_ifindicators
$app sg_pass1, "tsub_copy(&tsg_output2[" + d_dot
$app sg_pass1, "], tsg_256a, " + d_long + ");"
sub_c_lineout
endi
dift d_action = 410
'numeric variable
sg_pass1 = "i_long = " + d_varlongct1 + ";"
sub_c_lineout
sg_pass1 = sg_ifindicators
$app sg_pass1, "tsub_edit_double_to_string(tsg_256a, "
$app sg_pass1, "dg_" + s_var1 + ", " + d_vardecimalct1
$app sg_pass1, ", '" + s_editcd + "', &i_long);"
sub_c_lineout
sg_pass1 = sg_ifindicators
$app sg_pass1, "tsub_copy(&tsg_output2[" + d_end
$app sg_pass1, " - i_long], "
$app sg_pass1, "&tsg_256a[26 - i_long], i_long);"
sub_c_lineout
'do we need to blank the variable
$ift s_blankcd = "B"
sg_pass1 = sg_ifindicators + "dg_" + s_var1
$app sg_pass1, " = 0;"
sub_c_lineout
endi
endi
dift d_action = 420
'numeric array with index
sg_pass1 = "i_long = " + d_varlongct1 + ";"
sub_c_lineout
dift d_vartype2 = 11
'the index is numeric
sg_pass1 = "i_index = " + s_var2 + ";"
sub_c_lineout
else
'the index is a numeric variable
sg_pass1 = "i_index = tfni_index(dg_"
$app sg_pass1, s_var2 + ");"
sub_c_lineout
endi
'subtract one in going from RPG to C
sg_pass1 = "tdg_z = dga_" + s_var1 + "[i_index - 1];"
sub_c_lineout
sg_pass1 = sg_ifindicators
$app sg_pass1, "tsub_edit_double_to_string(tsg_256a, "
$app sg_pass1, "tdg_z, " + d_vardecimalct1
$app sg_pass1, ", '" + s_editcd + "', &i_long);"
sub_c_lineout
sg_pass1 = sg_ifindicators
$app sg_pass1, "tsub_copy(&tsg_output2[" + d_end
$app sg_pass1, " - i_long], "
$app sg_pass1, "&tsg_256a[26 - i_long], i_long);"
sub_c_lineout
'do we need to blank the variable
$ift s_blankcd = "B"
sg_pass1 = sg_ifindicators + "dga_" + s_var1
$app sg_pass1, "[i_index] = 0;"
sub_c_lineout
endi
endi
dift d_action = 440
'alpha variable
d_beg = d_end - d_varlongct1
sg_pass1 = sg_ifindicators + "tsub_copy("
$app sg_pass1, "&tsg_output2[tfni_index("
$app sg_pass1, d_beg + ")], "
$app sg_pass1, "sg_" + s_var1 + ", " + d_varlongct1
$app sg_pass1, ");"
sub_c_lineout
'do we need to blank the variable
$ift s_blankcd = "B"
sg_pass1 = sg_ifindicators + "tsub_blank("
$app sg_pass1, "sg_" + s_var1 + ", " + d_varlongct1
$app sg_pass1, ");"
sub_c_lineout
endi
endi
dift d_action = 450
'alpha array with index
'get the index into s_index
'is s_var2 a number or a variable
$ist d_any, s_var2, "9"
dift d_any = 1
s_index = s_var2
else
s_index = "tfni_index(dg_" + s_var2 + ")"
endi
s_index = "(" + s_index + " - 1)"
$app s_index, " * " + d_varlongct1
d_beg = d_end - d_varlongct1
sg_pass1 = sg_ifindicators + "tsub_copy("
$app sg_pass1, "&tsg_output2[tfni_index("
$app sg_pass1, d_beg + ")], "
$app sg_pass1, "&sga_" + s_var1 + "[" + s_index
$app sg_pass1, "], " + d_varlongct1 + ");"
sub_c_lineout
'do we need to blank the array
$ift s_blankcd = "B"
sg_pass1 = sg_ifindicators + "tsub_blank("
$app sg_pass1, "&sga_" + s_var1 + "[" + s_index
$app sg_pass1, "], " + d_varlongct1 + ");"
sub_c_lineout
endi
endi
dift d_action = 460
'alpha array no index
d_long = d_varlongct1 * d_varindexct1
d_beg = d_end - d_long
sg_pass1 = sg_ifindicators + "tsub_copy("
$app sg_pass1, "&tsg_output2[tfni_index("
$app sg_pass1, d_beg + ")], "
$app sg_pass1, "sga_" + s_var1 + ", " + d_long
$app sg_pass1, ");"
sub_c_lineout
'do we need to blank the array
$ift s_blankcd = "B"
sg_pass1 = sg_ifindicators + "tsub_blank("
$app sg_pass1, "sga_" + s_var1 + ", " + d_long
$app sg_pass1, ");"
sub_c_lineout
endi
endi
endw
'output the end of the subroutine
sg_pass1 = "} /* " + s_excptsubr + " */"
sub_c_lineout
'oline 1 2 3 4 5 6
'123456789012345678901234567890123456789012345678901234567890
' .OFILENAMEE 12 01 02 03OLINE
' .O 01 02 03VARIABJB 132 "HEADING LINE "
ends sub_c_oline_subroutines
subr sub_path_memory_lines
'updated 2007/11/12
'2006/09/25, 2006/09/04, 2006/08/29, 2006/04/23, 2005/10/08
vari s_out, s_path, d_memory, s_memory
vari d_lines, s_lines, s_date, s_version
$sys s_version, 3
$out s_version
$out sg_build
$sys s_path, 1
$out "Path: " + s_path
$dat s_date
$cut s_date, s_date, 1, 20
dsys d_memory, 1
dsys d_lines, 2
ded$ s_memory, d_memory, 0, 0
ded$ s_lines, d_lines, 0, 0
s_out = "memory=" + s_memory
$app s_out, ", lines=" + s_lines
$app s_out, ", date=" + s_date
$out s_out
ends sub_path_memory_lines
subr sub_speedquick
'updated 2008/02/23
vari d_any, d_dot, d_time
dsec d_time
d_dot = 10 ^ 6 * 2
d_any = 0
dwhi d_any < d_dot
dinc d_any
endw
dsec d_any
dg_pass1 = d_any - d_time
ends sub_speedquick
subr sub_speed_test
'updated 2007/11/12, 2007/07/11, 2005/10/08, 2004/02/14
'speed of computer
vari d_any, s_any, d_dot, s_dot
vari d_sec1, d_sec2, d_sec3, d_count, d_total
$ch$ s_dot, "-", 76
$out s_dot
$out "We are looping 50,000,000 times"
d_count = 0
d_total = 10000 * 5000
'loop fifty million times
dsec d_sec1
dwhi d_count < d_total
dinc d_count
endw
dsec d_sec2
d_sec3 = d_sec2 - d_sec1
$out "The time was " + d_sec3 + " seconds."
$out s_dot
sub_path_memory_lines
$out s_dot
$inp s_any, "return"
ends sub_speed_test
'end of rpgtoc.tea