home *** CD-ROM | disk | FTP | other *** search
/ Piper's Pit BBS/FTP: ibm 0010 - 0019 / ibm0010-0019 / ibm0010.tar / ibm0010 / CLIPB52.ZIP / SCHWARTZ.ZIP / EXAMPLE1.PRG < prev    next >
Encoding:
Text File  |  1990-06-06  |  2.5 KB  |  100 lines
  1. /*********************************************************************
  2. *
  3. * Name:        EXAMPLE1.prg
  4. * Description:  Error System Demo Program
  5. * Author:    Philip H. Schwartz
  6. * Audience:    Nantucket DEVCON '90
  7. * Written:      June 5, 1990
  8. * Compiler:    Clipper 5.0 V7.7 BETA
  9. * Comp Option:
  10. * Linker:       RTLink Version 1.3 (Clipper)
  11. * Library:    clipper, extend
  12. * Obj Module:   MYERR.obj
  13. * Link input:   rtlink fi example1,myerr out example1 li clipper,extend
  14. * Headers:    STD.ch, ERROR.ch
  15. * Copyright:    (c) 1990 Philip H. Schwartz
  16. * Rights:    All Commercial & Publishing Rights Reserved
  17. *
  18. *********************************************************************/
  19.  
  20. #include "ERROR.ch"
  21.  
  22. #define PROGRAM_VERSION            7.7
  23. #define COMPILE_DATE            90.167
  24.  
  25. LOCAL bSaveError,aErrors,nErrType
  26. PUBLIC sys_vers:=PROGRAM_VERSION,sys_exe:=COMPILE_DATE
  27.  
  28. aErrors:={"Variable does not exist",;
  29.           "Open error",;
  30.           "Argument error",;
  31.           "String overflow",;
  32.           "Internal out of memory (664)"}
  33.  
  34. bSaveError:=ERRORBLOCK()        // save default errorblock
  35. ERRORBLOCK({|e| MyError(e)})        // install alternate handler
  36.  
  37. CLS
  38. @ 1,0 TO 7,30 DOUBLE
  39. nErrType=1
  40. nErrType=ACHOICE(2,1,6,29,aErrors)
  41.  
  42. /* The last UDF() in the chain issues the errors so we can build up a 
  43.    Call Stack for illustrative purposes.                   */
  44. IF nErrType!=0
  45.   CLS
  46.   Craig(nErrType)
  47. ENDIF
  48.  
  49. ERRORBLOCK(bSaveError)            // always restore default errorblock
  50. RETURN
  51.  
  52. /* The following functions are declared STATIC since they
  53.    are only known to this PRG.                             */
  54. STATIC FUNCTION Craig
  55. PARAMETER nErr
  56. Ed(nErr)
  57. RETURN NIL
  58.  
  59. STATIC FUNCTION Ed
  60. PARAMETER nErr
  61. Rich(nErr)
  62. RETURN NIL
  63.  
  64. STATIC FUNCTION Rich
  65. PARAMETER nErr
  66. Savannah(nErr)
  67. RETURN NIL
  68.  
  69. STATIC FUNCTION Savannah
  70. PARAMETER nErr
  71. Phil(nErr)
  72. RETURN NIL
  73.  
  74. STATIC FUNCTION Phil
  75. LOCAL cString,x,i,aARR
  76. PARAMETER nErr
  77. DO CASE
  78. CASE nErr=1                // Error-Variable does not exist
  79.   ? x*unkn
  80. CASE nErr=2                // Error-Open error
  81.   USE nodbf
  82. CASE nErr=3                // Error-Argument error
  83.   x=2+"7"
  84. CASE nErr=4                // Error-String overflow
  85.   cString=REPLICATE("*",10000)
  86.   cString=cString+cString+cString+cString
  87.   cString=cString+cString+cString+cString
  88.   ? "Stringsize is ",LEN(cString)
  89.   ? "String is ",cString
  90.   INKEY(0)
  91. CASE nErr=5                // Error-Internal error
  92.   ? "Internal Errors are not trapped!"
  93.   aARR:=ARRAY(1000)
  94.   FOR i=1 TO 1000
  95.     aARR[i]=SPACE(1000)
  96.   NEXT
  97. ENDCASE
  98. RETURN NIL
  99. /*EOF*/
  100.