home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / CPM / LANGUAGS / FORTRAN / CPMLIB.ARK / TEST.FOR < prev   
Text File  |  1982-01-12  |  5KB  |  157 lines
  1. C
  2. C     Program to TEST the functions supported in CPMLIB.
  3. C
  4. C     Version 1.0
  5. C     January 12, 1982
  6. C
  7. C     Author:     William R. Brandoni
  8. C
  9. C     Language:   Microsoft FORTRAN-80
  10. C
  11. C
  12. C     To use this program:
  13. C     (assuming drive A: is the system + FORTRAN drive and
  14. C      drive B: contains all of the CPMLIB files)
  15. C     1) Compile using F80
  16. C     2) Link using L80, as follows:
  17. C            A>L80 B:TEST,B:CPMLIB/S,FORLIB/S,B:TEST/N/E
  18. C     3) Run the TEST program
  19. C
  20. C
  21.       IMPLICIT LOGICAL*1 ( A-H, O-Z )
  22.       DIMENSION ARRAY(80)
  23.       DIMENSION FILNAM(25)
  24.       DIMENSION FILNM2(25)
  25. C         The array FUNCT should be dimensioned as follows:
  26. C         1st dimension (6) = max. number of characters in function names
  27. C         2nd dimension (5) = value of variable NFUNC
  28.       DIMENSION FUNCT(6, 5)
  29. C
  30.       DATA FUNCT / 'I','N','C','H','R',' ',
  31.      A             'I','N','K','E','Y',' ',
  32.      B             'E','R','A','S','E',' ',
  33.      C             'R','E','N','A','M','E',
  34.      D             'E','X','I','S','T',' '/
  35. C         The variable NFUNC should be the number of functions
  36. C         searched for in the program.
  37.       DATA NFUNC /  5  /
  38. C         The variable NTEST is the maximum number of characters
  39. C         tested in the function search.
  40.       DATA NTEST /  3  /
  41.       DATA YES   / 'Y' /
  42.       DATA ZERO  /  0  /
  43. C
  44. C                             Get the command line tail
  45. C                             (tests the GETCMD routine)
  46. C                             and see what other routine is
  47. C                             to be tested.
  48. C
  49.       CALL GETCMD ( ARRAY )
  50. C
  51. C         See what command is desired
  52. C
  53.       NBYTES = ARRAY(1)
  54.       IF ( NBYTES .GT. 0 ) GOTO 20
  55.       WRITE ( 3, 9000 )
  56.       GOTO 8950
  57. C
  58.    20 NLONG = NBYTES
  59.       IF ( NLONG .GT. NTEST ) NLONG = NTEST
  60.       DO 50 J = 1, NFUNC
  61.       KFUNC = J
  62.       K2    = 0
  63.       DO 40 K = 1, NLONG
  64.       K1 = K + 1
  65.       IF ( ARRAY(K1) .EQ. FUNCT(K,J) ) K2 = K2 + 1
  66.    40 CONTINUE
  67.       IF ( K2 .EQ. NLONG ) GOTO 60
  68.    50 CONTINUE
  69.       WRITE ( 3, 9100 )
  70.       GOTO 8900
  71.    60 GOTO ( 100, 200, 300, 400, 500 ), KFUNC
  72. C
  73. C     INCHR routine
  74. C
  75.   100 CONTINUE
  76.       WRITE ( 3, 9980 )
  77.       READ  ( 3, 9995 ) NOPT
  78.       WRITE ( 3, 9200 )
  79.       CALL INCHR ( NOPT, A )
  80.       WRITE ( 3, 9210 ) A, A
  81.       GOTO 8900
  82. C
  83. C     INKEY routine
  84. C
  85.   200 CONTINUE
  86.       WRITE ( 3, 9980 )
  87.       READ  ( 3, 9995 ) NOPT
  88.       WRITE ( 3, 9200 )
  89.       CALL INKEY ( NOPT, A )
  90.       WRITE ( 3, 9210 ) A, A
  91.       GOTO 8900
  92. C
  93. C     ERASE routine
  94. C
  95.   300 CONTINUE
  96.       WRITE ( 3, 9985 )
  97.       READ  ( 3, 9995 ) NDRIVE
  98.       WRITE ( 3, 9300 )
  99.       READ  ( 3, 9990 ) (FILNAM(J), J = 1, 25 )
  100.       CALL ERASE ( NDRIVE, FILNAM, 25 )
  101.       GOTO 8900
  102. C
  103. C     RENAME routine
  104. C
  105.   400 CONTINUE
  106.       WRITE ( 3, 9985 )
  107.       READ  ( 3, 9995 ) NDRIVE
  108.       WRITE ( 3, 9400 )
  109.       READ  ( 3, 9990 ) (FILNAM(J), J = 1, 25 )
  110.       WRITE ( 3, 9410 )
  111.       READ  ( 3, 9990 ) (FILNM2(J), J = 1, 25 )
  112.       CALL RENAME ( NDRIVE, FILNAM, FILNM2, 25, 25 )
  113.       GOTO 8900
  114. C
  115. C     EXIST routine
  116. C
  117.   500 CONTINUE
  118.       WRITE ( 3, 9985 )
  119.       READ  ( 3, 9995 ) NDRIVE
  120.       WRITE ( 3, 9500 )
  121.       READ  ( 3, 9990 ) (FILNAM(J), J = 1, 25 )
  122.       CALL EXIST ( NDRIVE, FILNAM, 25, IOK )
  123.       IF ( IOK .EQ. 1 ) WRITE ( 3, 9510 )
  124.       IF ( IOK .EQ. 0 ) WRITE ( 3, 9520 )
  125.       GOTO 8900
  126. C
  127. C     All done
  128. C
  129.  8900 CONTINUE
  130.       WRITE ( 3, 9989 )
  131.       CALL INCHR ( 2, ANS )
  132.       IF ( ANS .EQ. YES ) GOTO 60
  133.  8950 CONTINUE
  134. C
  135. C     Formats
  136. C
  137.  9000 FORMAT(//,' To test a function, type the function name',/,
  138.      A          ' after the program name on the command line.',//,
  139.      B          ' For example:',/,
  140.      C          '               A>TEST ERASE',//,
  141.      D          ' will test the erase function.',//)
  142.  9100 FORMAT(/,' Invalid function name.' )
  143.  9200 FORMAT(/,' Touch any key .... ')
  144.  9210 FORMAT(/,' The key was ASCII ', I3, ' which is graphic ', A1 )
  145.  9300 FORMAT(/,' Enter name of file to erase ... ')
  146.  9400 FORMAT(/,' Enter old name of file ... ')
  147.  9410 FORMAT(/,' Enter new name of file ... ')
  148.  9500 FORMAT(/,' Enter name of file to test ... ')
  149.  9510 FORMAT(/,' ... FILE EXISTS ...')
  150.  9520 FORMAT(/,' ... FILE DOES NOT EXIST ...')
  151.  9980 FORMAT(/,' Option ... ')
  152.  9985 FORMAT(/,' Drive ( 0, 1, 2, etc.) ... ')
  153.  9989 FORMAT(//,' Another try (y/n) ... ')
  154.  9990 FORMAT(25A1)
  155.  9995 FORMAT(I5)
  156.        END
  157.