home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / S / ERRHAND.S < prev    next >
Encoding:
Text File  |  1993-10-24  |  4.4 KB  |  111 lines
  1. ; ERRHAND.S
  2. ;************************************************************************
  3. ;*                                    *
  4. ;*        PC Scheme/Geneva 4.00 Scheme code            *
  5. ;*                                    *
  6. ;* (c) 1985-1988 by Texas Instruments, Inc. See COPYRIGHT.TXT        *
  7. ;* (c) 1992 by L. Bartholdi & M. Vuilleumier, University of Geneva    *
  8. ;*                                    *
  9. ;*----------------------------------------------------------------------*
  10. ;*                                    *
  11. ;*            IO Error handlers                *
  12. ;*                                    *
  13. ;*----------------------------------------------------------------------*
  14. ;*                                    *
  15. ;* Created by: David Bartley        Date: Oct 1985            *
  16. ;* Revision history:                            *
  17. ;* - 18 Jun 92:    Renaissance (Borland Compilers, ...)            *
  18. ;* - 09 Jan 93: Generalized method; now support all IO primitives    *
  19. ;*                                    *
  20. ;*                    ``In nomine omnipotentii dei''    *
  21. ;************************************************************************
  22. ;
  23. ; The following code is an example of an error handler for I/O errors. The
  24. ; function open-input-file attempts to open filename for input. Note that 
  25. ; a continuation is saved in the fluid variable my%ioerr before the call to 
  26. ; open-input-file. Upon return from the open, the variable port is 
  27. ; interrogated to determine the status- To retry the operation with the same 
  28. ; filename, retry the operation with a different filename, or return the port
  29. ; object. 
  30. ;
  31.  
  32. (define (io-error-handler proc)
  33.   (named-lambda (this-proc . args)
  34.     (let ((port (call/cc
  35.                   (fluid-lambda (my%ioerr) 
  36.                     (apply proc args)))))
  37.       (cond ((eq? port 'retry) (apply this-proc args))
  38.             ((string? port)    (apply this-proc port))
  39.             (else              port)))))
  40.  
  41. (syntax (handle-io-errors proc)
  42.     (set! (access proc user-global-environment)
  43.           (io-error-handler (access proc user-global-environment))))
  44.  
  45. (begin
  46.   (handle-io-errors open-input-file)
  47.   (handle-io-errors open-binary-input-file)
  48.   (handle-io-errors open-output-file)
  49.   (handle-io-errors open-binary-output-file)
  50.   (handle-io-errors open-extend-file)
  51.   (handle-io-errors load))
  52.  
  53. ;          
  54. ; *USER-ERROR-HANDLER* has been designed to trap on all I/O errors, pop up a 
  55. ; window to indicate the error, and illicit a response from the user. The 
  56. ; result is then returned via the continuation bound to the fluid variable 
  57. ; my%ioerr. The system error handler is called for all other errors.
  58. ;
  59. ; See the User's Guide for a discussion on user error handling and a list of 
  60. ; all I/O errors.
  61. ;
  62.  
  63. (set! (access *user-error-handler* user-global-environment)
  64.       (lambda (error-num error-msg irritant sys-error-handler)
  65.         (if (and (fluid-bound? my%ioerr)
  66.          (number? error-num)
  67.                  (>= error-num 1)
  68.                  (<= error-num 88))
  69.             (let ((win (make-window error-msg #T))
  70.                   (result '())
  71.           (csize (window-get-size 'console)))
  72.               (window-set-position! win (- (quotient (car csize) 2) 3) 
  73.                     (- (quotient (cdr csize) 2) 20))
  74.               (window-set-size! win 6 40)
  75.               (window-set-cursor! win 2 5)
  76.           (window-set-attribute! win 'border-attributes 28)
  77.           (window-set-attribute! win 'text-attributes 30)
  78.               (window-popup win)
  79.               (case error-num
  80.                 ((2 3)                           ;file/path not found
  81.                  (display "File/Path not found : " win)
  82.          (newline win)
  83.                  (display irritant win)
  84.                  (newline win)
  85.                  (newline win)
  86.                  (display "Enter new pathame (return to exit)" win)
  87.          (newline win)
  88.                  (set! result (read-line win))
  89.                  (if (string=? result "")
  90.                      (set! result '())))
  91.                 ((21)                           ;drive not ready
  92.                  (display "Drive not ready - Retry (y/n) ?" win)
  93.                  (set! result 
  94.                        (if (char=? (char-upcase (read-char win)) #\Y)
  95.                            'retry
  96.                            '())))
  97.                 (else
  98.                   (display "Extended Dos I/O Error - " win)
  99.                   (newline win)
  100.                   (display irritant win) 
  101.                   (newline win)
  102.                   (newline win)
  103.                   (char-upcase (read-char win))
  104.                   (set! result '())))
  105.  
  106.               (window-popup-delete win)
  107.           ((fluid my%ioerr) result))
  108.     ;else
  109.             (sys-error-handler))))
  110.  
  111.