Program UTRCPGM

Program UTRCPGM

 *  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                                               
****************** End of data **************************************** 

*************** Beginning of data *************************************
                                                                       
 * 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                                               
****************** End of data **************************************** 

*************** Beginning of data *************************************
                                                                       
 * 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                                              
****************** End of data ****************************************


*************** Beginning of data *************************************
                                                                       
 * 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' '                             
****************** End of data **************************************** 

Dig deeper on iSeries programming commands

0 comments

Oldest 

Forgot Password?

No problem! Submit your e-mail address below. We'll send you an email containing your password.

Your password has been sent to:

-ADS BY GOOGLE

SearchEnterpriseLinux

SearchDataCenter

Close