/* File: GENFRAME.QRPGLESRC Generator for /free /end-free entries */ /* Copyright (C) 2004 Dieter Bender */ /* */ /* This program is free software; you can redistribute it and/or modify */ /* it under the terms of the GNU General Public License as published by */ /* the Free Software Foundation. */ /* */ /* This program is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU General Public License for more details. */ /* */ /* You should have received a copy of the GNU General Public License */ /* along with this program; if not, write to the Free Software */ /* Foundation, Inc., 59 Temple Place, */ /* Suite 330, Boston, MA 02111-1307 USA */ /* You might find a version at http://www.gnu.org */ /************************************************************************/ H copyright('Dieter Bender 02/2004 ') * compile with D*B OVRDBF SOURCE QRPGLESRC D*B+ OVRSCOPE(*JOB) D*B CRTPF QTEMP/GENSRC D*B+ RCDLEN(100) D*B CRTRPGMOD GENFRAME D*B+ DBGVIEW(*SOURCE) D*B+ REPLACE(*YES) D*B CRTPGM GENFRAME D*B+ BNDDIR(QC2LE) D*B+ ACTGRP(GENFRAME) D*B DLTOVR *ALL LVL(*JOB) FSource IF F 112 DISK USROPN FGenSrc O F 100 DISK USROPN DlineIn E DS EXTNAME(QRPGLESRC) /*--- import Prototypes /COPY QRPGLEH,SYSTEM /COPY QRPGLEH,QMHSNDPM /COPY QRPGLEH,GENFRAME /*--- local Prototypes D Work PR d readLine pr n d genProcedure pr d genProcHeader pr d genProcBody pr d init pr d exit pr d writeLine pr d line 100a value d writeH pr d genCompile pr d genCopy pr d genDefs pr d genInitP pr /*--- Constants D TRUE C *ON D FALSE C *OFF d UP C 'DPR' d LO C 'dpr' * lines d preCompStart c ' D- d *B' d preCompCont c ' D- d *B+' d slashFree c ' /free' d slashEndFree c ' /end-free' d lineEnd c '---------------------------------*/' d separator c ' /*----------------------------' d protoExport c ' /*--- Prototypes Export -' d protoImport c ' /*--- Prototypes Import -' d protoLocal c ' /*--- local Prototypes -' d constants c ' /*--- Constants -' d statefullVar c ' /*--- statefull Variables -' /*--- statefull Variables D line s 128A D error s N INZ(FALSE) d ProtoType s n INZ(FALSE) d protoName s 16a d protoRetType s 17a d hasResult s n INZ(FALSE) /*--- Main Interface D GENFRAME PI D FileName 10A CONST D Library 10A CONST D Member 10A CONST /*--- very unimportant procedure main ------------------------*/ /free Work(); return; /end-free /*============================================================*/ P Work B /*------------------------------------------------------------*/ /free init(); writeH(); genCompile(); genCopy(); genDefs(); dow readLine and not error; genProcedure(); enddo; genInitP(); exit(); return; /end-free P Work E /*============================================================*/ P readLine B D readLine PI n /*------------------------------------------------------------*/ /free dou %xlate(UP : LO : %subst(SRCDTA : 6 : 1)) = 'd'; read Source lineIn; if %eof; if protoType; genProcBody(); endif; return FALSE; endif; enddo; line = SRCDTA; return TRUE; /end-free P readLine E /*============================================================*/ P genProcedure B D genProcedure PI D type s 2a /*------------------------------------------------------------*/ /free type = %xlate(UP : LO : %subst(line : 24 : 2)); select; when type = 'pr'; if protoType; genProcBody(); endif; protoType = TRUE; genProcHeader(); when type = ' '; if protoType; writeLine(line); endif; other; if protoType; genProcBody(); endif; protoType = FALSE; endsl; /end-free P genProcedure e /*============================================================*/ P genProcHeader B D genProcHeader PI d startProc ds qualified d 6 6 inz('p') d name 7 23 d 24 25 inz('b ') d 44 49 inz('export') d piLine ds qualified d 6 6 inz('d') d name 7 23 d 24 25 inz('pi') d type 26 43 /*------------------------------------------------------------*/ /free protoName = %subst(line : 7 : 16); protoRetType = %subst(line : 26 : 17); startProc.name = protoName; piLine.name = protoName; piLine.type = protoRetType; if piLine.type <> *BLANK; hasResult = TRUE; else; hasResult = FALSE; endif; writeLine(startProc); writeLine(piLine); /end-free P genProcHeader E /*============================================================*/ P genProcBody B D genProcBody PI d endProc ds qualified d 6 6 inz('p') d name 7 23 d 24 25 inz('e ') d result ds qualified d 6 6 inz('d') d 7 23 inz(' result') d 24 25 inz('s ') d type 26 43 /*------------------------------------------------------------*/ /free endProc.name = protoName; if hasResult; result.type = protoRetType; writeLine(result); endif; writeLine(slashFree); writeLine(' if not initFlag;'); writeLine(' init();'); writeLine(' endif;'); if hasResult; writeLine(' return result;'); endif; writeLine(slashEndFree); writeLine(endProc); writeLine(separator + lineEnd); /end-free P genProcBody e /*============================================================*/ P writeH B D writeH PI d nomain s 100a INZ(' h nomain') /*------------------------------------------------------------*/ /free writeLine(nomain); writeLine(' h copyright(''Dieter Bender ' + %char(%date()) + ''')'); /end-free P writeH E /*============================================================*/ P genCompile B D genCompile PI /*------------------------------------------------------------*/ /free writeLine( preCompStart + ' CRTRPGMOD ' + Member); writeLine( preCompCont + ' DBGVIEW(*SOURCE)'); writeLine( preCompStart + ' CRTSRVPGM ' + Member); writeLine( preCompCont + ' EXPORT(*ALL)'); writeLine( preCompCont + ' ACTGRP(*CALLER)'); /end-free P genCompile E /*============================================================*/ P genCopy B D genCopy PI d slashC c ' /COPY ' d initPr c ' d init pr' /*------------------------------------------------------------*/ /free writeLine(protoExport + lineEnd); writeLine(slashC + 'QRPGLEH,' + Member); writeLine(protoImport + lineEnd); writeLine(protoLocal + lineEnd); writeLine(initPr); /end-free P genCopy E /*============================================================*/ P genDefs B D genDefs PI d defTrue c ' d TRUE c- d *ON ' d defFalse c ' d FALSE c- d *OFF' d initFlag c ' d initFlag s- d n inz(FALSE)' /*------------------------------------------------------------*/ /free writeLine(constants + lineEnd); writeLine(defTrue); writeLine(defFalse); writeLine(stateFullVar + lineEnd); writeLine(initFlag); writeLine(separator + lineEnd); /end-free P genDefs E /*============================================================*/ P genInitP B d genInitP PI d beginP c ' P init b' d declP c ' d init pi' d endP c ' P init e' /*------------------------------------------------------------*/ /free writeLine(beginP); writeLine(declP); writeLine(separator + lineEnd); writeLine(slashFree); writeLine(' initFlag = TRUE;'); writeLine(slashEndFree); writeLine(endP); /end-free P genInitP E /*============================================================*/ P writeLine B D writeLine PI d line 100a value DlineOut DS d dataOut 100a /*------------------------------------------------------------*/ /free lineOut = line; write GenSrc lineOut; /end-free P writeLine E /*============================================================*/ P init B D init PI /*------------------------------------------------------------*/ /free system('OVRDBF Source ' + %trim(Library) + '/' + %trim(FileName) + ' ' + %trim(Member) + ' LVLCHK(*NO)' + ' OVRSCOPE(*JOB)'); open Source; system('CRTPF ' + 'QTEMP/GENSRC ' + 'RCDLEN(100) ' + 'MBR(*FILE)'); system('CLRPFM ' + 'QTEMP/GENSRC '); system('OVRDBF GENSRC ' + 'QTEMP/GENSRC ' + ' LVLCHK(*NO)' + ' OVRSCOPE(*JOB)'); open GenSrc; /end-free P init E /*============================================================*/ P exit B D exit PI /*------------------------------------------------------------*/ /free close Source; close GenSrc; system('CPYF ' + 'QTEMP/GENSRC ' + %trim(Library) + '/' + %trim('QRPGLESRC') + ' ' + 'TOMBR(' + %trim(Member) + ') ' + 'FMTOPT(*CVTSRC) ' + 'MBROPT(*REPLACE)'); system('CHGPFM ' + %trim(Library) + '/' + %trim('QRPGLESRC') + ' ' + %trim(Member) + ' ' + 'SRCTYPE(RPGLE)'); system('DLTOVR *ALL LVL(*JOB)'); if not error; return; else; SendSysMsg( 'CPF9898' : 'QCPFMSG ' + '*LIBL ' : 'Problems GenFrame' : 25 : '*ESCAPE ' : '*PGMBDY ' : 1 : QMHSNDPM_MSGKEY : QMHSNDPM_MSGERR ); endif; /end-free P exit E