如何於 RPG 中做到 Recursive Call 的功能？
Recursive Call Driver UTRCPGM
File : QRPGLESRC
Member: UTRCPGM
Type : RPGLE
Note : Recursive Call Driver
* Program UTRCPGM
*=====================================================================
* DATA STRUCTURES
*=====================================================================
D #cmd S 256A
D #Num_Pgm S 2S 0
*---------------------------------------------------------------------
* Program Name
*---------------------------------------------------------------------
D PgmDS DS
D #Char1 1 inz('@')
D #Chr_Pgm 2
D #1st_Name 7
*===============================================================
* Prototypes
*===============================================================
* OS/400 commands
*---------------------------------------------------------------------
D command PR EXTPGM('QCMDEXC')
D @cmd 256A OPTIONS(*VARSIZE)
D CONST
D @cmdlen 15P 5 CONST
*=====================================================================
* Program Parameters
*=====================================================================
C *ENTRY PLIST
C Parm @Program 10
C parm @Library 10
*=====================================================================
* Main Program
*=====================================================================
*---------------------------------------------------------------------
* If program name is not specified, ends program
*---------------------------------------------------------------------
C if @Program = *BLANKS
C eval *inlr = *ON
C else
*---------------------------------------------------------------------
* If program does not exist in library QTEMP, it must be the original
* program who's going to call itself for the first time
*---------------------------------------------------------------------
C exsr ChkObj
C if %ERROR
C eval #Num_Pgm = 0
C eval #1st_Name = %SUBST(@Program : 1 : 7)
C else
*---------------------------------------------------------------------
* If program exists in library QTEMP, it must be already a
* duplication of the original program; another copy has to be made
*---------------------------------------------------------------------
C eval #Chr_Pgm = %SUBST(@Program : 2 : 2)
C move #Chr_Pgm #Num_Pgm
C eval #Num_Pgm = #Num_Pgm + 1
C endif
C move #Num_Pgm #Chr_Pgm
C exsr ChkObj
C if %ERROR
C exsr CrtDupObj
C endif
*---------------------------------------------------------------------
* If program already exists in library QTEMP or if it has been
* sucessfully duplicated, returns name and location of that copy
* of the program
*---------------------------------------------------------------------
C if NOT %ERROR
C eval @Program = PgmDs
C eval @Library = 'QTEMP'
C endif
C endif
C return
*=====================================================================
* SUBROTINES
*=====================================================================
*****************************************************************
* Check the existence of the specified object
*****************************************************************
C ChkObj BEGSR
C eval #cmd = 'CHKOBJ OBJ(QTEMP/' +
C %TRIMR(PgmDS) + ') OBJTYPE(*PGM)'
C callp (e) command( #cmd : %LEN(%TRIMR(#cmd)) )
C ENDSR
*****************************************************************
* Create duplicate object
*****************************************************************
C CrtDupObj BEGSR
C eval #cmd = 'CRTDUPOBJ OBJ(' + %TRIM(@PROGRAM)
C ') FROMLIB(' + %TRIM(@LIBRARY)
C ') OBJTYPE(*PGM) TOLIB(QTEMP) NEWOBJ('
C %TRIM(PgmDS) + ')'
C callp (e) command( #cmd : %LEN(%TRIMR(#cmd)) )
C ENDSR
============================================================================
File : QRPGLESRC
Member: UTRKFACT
Type : RPGLE
Note : Factorial Demo
* Program UTRKFACT
*****************************************************************
*
* FACTORIAL MATHEMATICAL DEFINITION
*
* n! = 1 for n = 0
*
* n! = n (n - 1)! for n > 0
*
*****************************************************************
*=====================================================================
* Variables and Data Structures
*=====================================================================
D RecursCall S 21
*---------------------------------------------------------------------
* PROGRAM STATUS DATA STRUCTURE
*---------------------------------------------------------------------
D SDS
D $$Library 81 90
D $$Program 334 343
*=====================================================================
* Program Parameters
*=====================================================================
C *ENTRY plist
C parm @Argument 3 0
C parm @Factorial 30 0
C parm @Error 3 0
*=====================================================================
* Main Program
*=====================================================================
C eval @Error = 0
*---------------------------------------------------------------------
* 0! = 1 ; 1! = 1 x 0! = 1
*---------------------------------------------------------------------
C if @Argument <= 1
C eval @Factorial = 1
C else
*---------------------------------------------------------------------
* If new copy of this program could not be created, returns n
* else calculates n!
*---------------------------------------------------------------------
C call (e) 'UTRCPGM'
C parm $$Program @Program 10
C parm $$Library @Library 10
C if @Program = $$Program and @Library = $$Lib
C eval @Error = @Argument
C else
C exsr CalcFact
C endif
C endif
C eval *inlr = *ON
*---------------------------------------------------------------------
* Closes program
*---------------------------------------------------------------------
C call (e) 'UTRCPGM'
C parm *BLANKS @Program
C Parm @Library
*=====================================================================
* SUBROUTINES
*=====================================================================
*****************************************************************
* Calculates factorial of @Argument
*****************************************************************
C CalcFact BEGSR
*---------------------------------------------------------------------
* Calls newly created copy of this program to calculate (n - 1)!
*---------------------------------------------------------------------
C eval RecursCall = %TRIM(@Library) + '/'
C + %TRIM(@Program)
C eval @Argument2 = @Argument - 1
C call (e) RecursCall
C parm @Argument2 3 0
C parm *ZEROS @Factorial
C parm *ZEROS @Error
*---------------------------------------------------------------------
* If error occurred returns argument that originated the error
* else returns n!
*---------------------------------------------------------------------
C if %ERROR
C eval @Error = @Argument
C else
C if @Error = 0
C eval @Factorial = @Factorial * @Argument
C endif
C endif
C ENDSR
============================================================================
File : QRPGLESRC
Member: TESTRFACT
Type : RPGLE
Note : Test Factorial Demo
* PROGRAM TESTRFACT
**********************************************************************
*
* Calculates factorial of the number introduced by the user
*
* until he presses F3
*
**********************************************************************
*=====================================================================
* FILES
*=====================================================================
FTestDFact CF E WORKSTN
*=====================================================================
* Main Program
*=====================================================================
C exfmt (e) D$001
C dow NOT *in03
C exsr CalcFact
C exfmt (e) D$001
C enddo
C eval *inlr = *ON
*=====================================================================
* SUBROTINES
*=====================================================================
**********************************************************************
* Calculates factorial of n
**********************************************************************
C CalcFact BEGSR
C call (e) 'UTRKFACT'
C parm $Argument @Argument 3 0
C $Factorial parm *ZEROS @Factorial 30 0
C parm *ZEROS @Error 3 0
C eval *in60 = (@Error <> 0)
C ENDSR
============================================================================
File : QDDSSRC
Member: TESTDFACT
Type : DSPF
Note : Test Factorial Demo
* DISPLAY FILE TESTDFACT
A*================================================================
A DSPSIZ(24 80 *DS3)
A*================================================================
A* FACTORIAL WINDOW
A*================================================================
A R D$001
A*%%TS SD 20010821 192931 ROLDAO REL-V4R4M0 5769-PW1
A WINDOW(9 23 5 39 *NOMSGLIN)
A CA03(03 'Exit')
A BLINK
A FRCDTA
A OVERLAY
A PROTECT
A $ARGUMENT 2Y 0B 2 2RANGE(0 99)
A DSPATR(HI)
A EDTWRD('0 ')
A 2 5'! ='
A DSPATR(HI)
A $FACTORIAL 30Y 0O 2 9DSPATR(HI)
A EDTCDE(Z)
A 4 2'F3=Exit'
A 60 5 2'Error during calculations.'
A DSPATR(HI)
*================================================================
* JUST TO AVOID CLEARING THE SCREEN
*================================================================
A R DUMMY ASSUME
A 1 2' '
使用方法
1. CRTBNDRPG UTRCPGM
2. CRTBNDRPG UTRKFACT
3. CRTDSPF TESTDFACT
4. CRTBNDRPG TESTRFACT
5. CALL TESTRFACT
星期二, 10月 31, 2023
2001-08-30 如何於 RPG 中做到 Recursive Call 的功能？
訂閱：
張貼留言 (Atom)
沒有留言:
張貼留言