*----------------------------------------------------------- *- OBJETIVO: IDENTAR UN PROGRAMA RPG ILE *- ® mosterio *----------------------------------------------------------- HDATFMT(*EUR) TIMFMT(*HMS) *----------------------------------------------------------- FQRPGLESRC UP A F 112 DISK *----------------------------------------------------------- DBEG S 13 DIM(11) D CTDATA DELS S 13 DIM(11) D CTDATA DFIN S 13 DIM(11) D CTDATA DCCL S 13 DIM(11) D CTDATA DSEL S 13 DIM(11) D CTDATA DPIL S 5 DIM(50) DPILE S 5 DIM(50) DK S 2 0 INZ(11) *-------------------- D up C CONST('ABCDEFGHIJKLMNOPQRSTUVWXYZ') D lo C CONST('abcdefghijklmnopqrstuvwxyz') D s1 S 1A inz D s2 S 2A inz D s3 S 3A inz *-------------------- D DS D NIDO 1 14 D ATRHI 1 1 D J 2 3 *-------------------- IQRPGLESRC ZA 01 I 1 112 TODO I 18 18 TIPLIN I 19 19 COMENT I 38 42 INSTRU I 38 39 I@ I 41 42 I$ I 38 41 INS2 I 37 39 INS4 *--------------------------------------------------------------- *----> Parámetros de Entrada C* *ENTRY PLIST C* PARM ERR 1 * C IF *IN(77) = *OFF C* MOVE '0' ERR C MOVE *ZEROS I 2 0 C CLEAR VAR2 2 C CLEAR VAR3 3 C EVAL *IN(98) = *OFF C EVAL *IN(77) = *ON C EnDiF *---------------------------------------------------------------- *-- Inicio del Programa C EVAL *IN(01) = *OFF /free i@ = %xlate(lo:up:i@); i$ = %xlate(lo:up:i$); instru = %xlate(lo:up:instru); /end-free C IF (TIPLIN = 'C' or TIPLIN = 'c') OR C TIPLIN = '*' AND *IN(88) = *ON OR C TIPLIN = ' ' AND COMENT = '*' AND C *IN(88) = *ON OR TIPLIN = ' ' AND C COMENT = '/' AND *IN(88) = *ON C EVAL NIDO = *BLANKS C IF (TIPLIN = 'C' or TIPLIN = 'c') C EVAL *IN(88) = *ON C ENDIF C IF COMENT = '*' OR COMENT = '/' C EXSR SBR004 C ELSE C SELECT C WHEN i@ = 'IF' OR i@ = 'DO' OR C (INS2 = 'CASE') or INSTRU = 'SELEC' C EXSR SBR001 C WHEN INSTRU = 'ELSE ' C EXSR SBR002 C WHEN (I@ = 'EN') and (i$<>'SR') C EXSR SBR003 C WHEN i@ = 'WH' OR i@ = 'OT' C EXSR SBR005 C OTHER C EXSR SBR004 C ENDSL C ENDIF * C EVAL *IN(01) = *ON C IF *IN(98) = *ON C* EVAL ERR = '1' C SETON LR C ENDIF C END C*lR IF I >= 1 C*LR EVAL ERR = '1' C*LR ENDIF *-- Fin del Programa *--------------------------------------------------------------* C SBR001 BEGSR C IF VAR3 = 'CAS' AND INS2 = 'CASE' C EXSR SBR004 C ELSE C MOVE '1' SW 1 C ADD 1 I C MOVEL INSTRU PIL(I) C BITON '26' ATRHI C BITOFF '013457' ATRHI C IF I < 11 C MOVE BEG(I) NIDO C ELSE C MOVE BEG(K) NIDO C MOVE I J C ENDIF C MOVEL INSTRU VAR2 C MOVEL INSTRU VAR3 C ENDIF C ENDSR *--------------------------------------------------------------** C SBR002 BEGSR C MOVEL '0' SW 1 /free var2 = %xlate(lo:up:var2); pile(I)=%xlate(lo:up:pile(I)); /end-free C IF (VAR2 = 'IF') and (PILE(I) <> 'ELSE') C BITON '26' ATRHI C BITOFF '013457' ATRHI C IF I < 11 C MOVE ELS(I) NIDO C ELSE C MOVE ELS(K) NIDO C MOVE I J C ENDIF C MOVEL INSTRU PILE(I) C ELSE C MOVE *ALL'2' NIDO C EVAL *IN(98) = *ON C END C ENDSR *--------------------------------------------------------------** C SBR003 BEGSR C MOVEL '0' SW /free var2 = %xlate(lo:up:var2); pile(I)=%xlate(lo:up:pile(I)); instru=%xlate(lo:up:Instru); /end-free C SELECT C WHEN I = 0 C EVAL NIDO = *ALL'3' C EVAL *IN(98) = *ON C OTHER C IF (VAR2 = 'IF') and C (INSTRU = 'END ' OR INSTRU = 'ENDIF') C OR C (VAR2 = 'CA') and (INsTRU = 'ENDCS') or C (VAR2 = 'DO') and C (INSTRU = 'END ' OR INSTRU = 'ENDDO') or C VAR3 = 'CAS' AND INSTRU = 'END ' OR C (PIL(I) = 'SELEC' or PIL(I) = 'WHEN ' OR C PIL(I) = 'WHENE' OR PIL(I) = 'WHENN' OR C PIL(I) = 'OTHER') and (INSTRU = 'ENDSL') * C IF PILE(I) = 'ELSE' C EVAL PILE(I) = *BLANKS C ENDIF * C EVAL PIL(I) = *BLANKS C BITON '26' ATRHI C BITOFF '013457' ATRHI C IF I < 11 C MOVE FIN(I) NIDO C ELSE C MOVE FIN(K) NIDO C MOVE I J C ENDIF C EVAL I = I - 1 C IF I<> 0 C MOVEL PIL(I) VAR2 C MOVEL PIL(I) VAR3 C ELSE C EVAL VAR2 = *BLANKS C EVAL VAR3 = *BLANKS C ENDIF C ELSE C EVAL NIDO = *ALL'3' C EVAL *IN(98) = *ON C END C ENDSL C ENDSR *--------------------------------------------------------- C SBR004 BEGSR /free ins4 = %xlate(lo:up:ins4); instru=%xlate(lo:up:Instru); /end-free C IF INS4 = ' WH' and COMENT = ' ' C EVAL SW = '1' C ENDIF * C SELECT C WHEN I = 0 C EVAL NIDO = *BLANKS C OTHER C IF INSTRU = 'BEGSR' C EVAL NIDO = *ALL'4' C EVAL *IN(98) = *ON C ELSE C BITON '26' ATRHI C BITOFF '013457' ATRHI C IF I < 11 C MOVE CCL(I) NIDO C ELSE C MOVE CCL(K) NIDO C MOVE I J C END C END C ENDSL * C IF INS4 <> ' WH' And C TIPLIN <> ' ' AND C COMENT <> '*' AND C COMENT <> '/' C EVAL SW = '0' C END * C ENDSR *-------------------------------------------------- C SBR005 BEGSR /free instru=%xlate(lo:up:Instru); /end-free C MOVEL INSTRU PIL(I) C BITON '26' ATRHI C BITOFF '013457' ATRHI C IF I < 11 C MOVE SEL(I) NIDO C ELSE C MOVE SEL(K) NIDO C MOVE I J C ENDIF C MOVEL INSTRU VAR2 C MOVEL INSTRU VAR3 * C ENDSR *----------------------------------------------- OQRPGLESRC D 01 O ATRHI 105 O NIDO 106 *----------------------------------------------- ** PRINCIPIO P----------01 P---------02| P--------03|| P-------04||| P------05|||| P-----06||||| P----07|||||| P---08||||||| P--09|||||||| P-10||||||||| P11|||||||||| ** SI NO X..........01 X.........02| X........03|| X.......04||| X......05|||| X.....06||||| X....07|||||| X...08||||||| X..09|||||||| X.10||||||||| X11|||||||||| ** FIN F----------01 F---------02| F--------03|| F-------04||| F------05|||| F-----06||||| F----07|||||| F---08||||||| F--09|||||||| F-10||||||||| F11|||||||||| ** DENTRO DEL CICLO | || ||| |||| ||||| |||||| ||||||| |||||||| ||||||||| |||||||||| ||||||||||| ** DENTRO DEL SELECT w----------01 w---------02| w--------03|| w-------04||| w------05|||| w-----06||||| w----07|||||| w---08||||||| w--09|||||||| w-10||||||||| w11|||||||||| ******************** Fine dati