Article

Program UTRCPGM

Roldao Silva
 *  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 **************************************** 

There are Comments. Add yours.

 
TIP: Want to include a code block in your comment? Use <pre> or <code> tags around the desired text. Ex: <code>insert code</code>

REGISTER or login:

Forgot Password?
By submitting you agree to receive email from TechTarget and its partners. If you reside outside of the United States, you consent to having your personal data transferred to and processed in the United States. Privacy
Sort by: OldestNewest

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: