home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 10 / 10.iso / l / l320 / 2.img / EXAMPLES / DISPNDP.F < prev    next >
Encoding:
Text File  |  1989-09-19  |  5.0 KB  |  144 lines
  1.  
  2. C ********************  display_ndp ***************************
  3. C The following function displays the numeric and 
  4. C environment registers of the NDP in use. If the
  5. C program is running on a system with both an 80x87
  6. C and an mW1167 coprocessor, the function will choose
  7. C the correct action depending on the compiler options
  8. C used. In case of an error, the function returns NO,
  9. C otherwise it returns YES.
  10. C
  11.       INTEGER FUNCTION DISPLAY_NDP()
  12.  
  13.       INTEGER IM,DM,ZM,OM,UM,PM,OUM,DCM
  14.       PARAMETER(IM=1,DM=2,ZM=4,OM=8,UM=16,PM=32,OUM=64,DCM=128)
  15.  
  16.       INTEGER YES,NO
  17.       PARAMETER (YES=1,NO=0)
  18.  
  19. C The following section is specific for the 80287 and
  20. C 80387. To use it, just uncomment the code part and
  21. C comment out code in sections specific to the mW1167
  22. C The placement of the Control Word, Status Word, and Tag
  23. C Word in the buffer differ between the 80287 and the 80387.
  24.       INTEGER*4 BUFF(27)
  25.       INTEGER*2 WBUFF(54)
  26.       INTEGER*1 BBUFF(108)
  27.       EQUIVALENCE (BUFF, WBUFF, BBUFF)
  28.       COMMON BUFF
  29. C The following are to be used as subscripts into the
  30. C WBUFF array. To use them, just uncomment the PARAMETER
  31. C statement for the coprocessor you intend to use.
  32.       INTEGER CW,SW,TW
  33. C The following statement is specific for the 80287
  34. C      PARAMETER (CW=1,SW=2,TW=3)
  35. C The following statement is specific for the 80387
  36.       PARAMETER (CW=1,SW=3,TW=5)
  37. C end of 80287 and 80387 specific section
  38.  
  39. C The following section is specific for the mW1167
  40. C To use it, just uncomment the code part and
  41. C comment out code in sections specific to the
  42. C 80387 and 80287
  43. C In the following arrays, the genuine data items begin
  44. C at subscript 1. Any subscript lower than that is padding
  45. C so as to align all genuine data items on the same boundary
  46. C      INTEGER*4 BUFF (-1:32)
  47. C      INTEGER*2 WBUFF (-1:2)
  48. C      REAL*4   R4BUFF (-1:32)
  49. C      REAL*8   R8BUFF (0:16)
  50. C      EQUIVALENCE (BUFF, WBUFF, R4BUFF, R8BUFF)
  51. C end of mW1167 specific section
  52.  
  53.       INTEGER I, J
  54. C Top of Stack Register
  55.       INTEGER*2 TOS_REG
  56. C Rearranged Tag Word, Temporary Tag Word
  57.       INTEGER*2 NEW_TW, TMP_TW, K
  58.       INTEGER*1 ITEMP
  59.  
  60. C Receives results from TEMP_DBL
  61.       REAL*8 TD
  62. C converts temporary real to real*8
  63.       REAL*8 TEMP_DBL
  64.  
  65. C The following section is specific for the 80287
  66. C and 80387. To use it, just uncomment the code part
  67. C and comment out code in sections specific to the
  68. C mW1167
  69.       WRITE (*,1000)
  70.  1000 FORMAT (1X)
  71.       WRITE (*,1010) 'Control word:         ',WBUFF(CW)
  72.  1010 FORMAT (1X,A,Z8)
  73.       WRITE (*,1010) 'Status word:          ',WBUFF(SW)
  74.       WRITE (*,1010) 'Tag word:             ',WBUFF(TW)
  75.       WRITE (*,1010) 'IP offset:            ',BUFF(4)
  76.       WRITE (*,1010) 'CS selector:          ',WBUFF(9)
  77.       WRITE (*,1010) 'Data operand offset:  ',BUFF(6)
  78.       WRITE (*,1010) 'Operand selector:     ',WBUFF(13)
  79.  
  80. C Which numeric register is Top of Stack ? 
  81.       TOS_REG = RSHIFT (WBUFF(SW), 11)
  82.       TOS_REG = IAND (TOS_REG, 7)
  83.  
  84. C The following if-else block rearranges the bit pattern
  85. C of the Tag Word, if necessary, to correctly associate bit
  86. C pairs representing physical numeric registers 0-7 with
  87. C relative stack registers ST(0)-ST(7).
  88.       IF (TOS_REG .NE. 0) THEN
  89.           NEW_TW = RSHIFT (WBUFF(TW), (TOS_REG * 2))
  90.           TMP_TW = LSHIFT (WBUFF(TW), (16 - (TOS_REG * 2)))
  91.           NEW_TW = IOR (NEW_TW, TMP_TW)
  92.       ELSE
  93.           NEW_TW = WBUFF(TW)
  94.       ENDIF
  95.  
  96.       WRITE (*,1020) 'Registers:'
  97.  1020 FORMAT (1X,A)
  98.       DO 1030, I = 29,99,10
  99.         WRITE (*,1040) 'ST',((I-29)/10),' = '         
  100.         DO 1050, J = 0,9
  101.           ITEMP = RSHIFT (BBUFF(I+9-J),4)
  102.           ITEMP = IAND (ITEMP,15)
  103.           WRITE (*,1060) ITEMP
  104.           ITEMP = IAND (BBUFF(I+9-J),15)
  105.           WRITE (*,1060) ITEMP
  106.  1050   CONTINUE
  107.         K = RSHIFT (NEW_TW, (2*((I-29)/10)))
  108.         K = IAND (K, 3)
  109.         IF ((K .EQ. 0) .OR. (K .EQ. 1)) THEN
  110.           TD = TEMP_DBL(BBUFF(I))
  111.           WRITE (*,1070) TD
  112.         ELSE IF (K .EQ. 2) THEN
  113.           WRITE (*,1020) '   Infinity,NAN,or denormal'
  114.         ELSE
  115.           WRITE (*,1020) '   Empty register'
  116.         ENDIF
  117.  1030 CONTINUE
  118.  1040 FORMAT (1X,A,I1,A,$)
  119.  1060 FORMAT (1X,Z1,$)
  120.  1070 FORMAT (4X,D20.14)
  121. C end of code specific to the 80387 and 80287
  122.  
  123. C The following section is specific for the mW1167
  124. C To use it, just uncomment the code part and
  125. C comment out code in sections specific to the
  126. C 80387 and 80287
  127. C      WRITE (*,1000)
  128. C 1000 FORMAT (1X)
  129. C      WRITE (*,1010) 'Control word:         ',WBUFF(1)
  130. C 1010 FORMAT (1X,A,Z4)
  131. C      WRITE (*,1010) 'Status word:          ',WBUFF(2)
  132. C      DO 1020, I = 0,15
  133. C        WRITE (*,1030) BUFF(2*I+1),BUFF(2*I+2),R4BUFF(2*I+1),
  134. C     _      R4BUFF(2*I+1),R8BUFF(I+1)
  135. C 1020 CONTINUE
  136. C 1030 FORMAT (1X,Z8,1X,Z8,1X,E10.4,8X,E10.4,8X,D16.8)
  137. C      WRITE (*,1000)
  138. C end of code specific to the mW1167
  139.  
  140.       WRITE (*,1000)
  141.       DISPLAY_NDP = YES
  142.       END
  143. C ********************  end of display_ndp ************************
  144.