PageRenderTime 43ms CodeModel.GetById 15ms RepoModel.GetById 1ms app.codeStats 0ms

/src/Lib/Common/error.sch

http://github.com/spurious/larceny-mirror
Unknown | 241 lines | 214 code | 27 blank | 0 comment | 0 complexity | 80f3af2d2c489ed74b60eca22f589485 MD5 | raw file
Possible License(s): BSD-3-Clause, LGPL-2.1
  1. ; Copyright 1998 Lars T Hansen. -*- indent-tabs-mode: nil -*-
  2. ;
  3. ; $Id$
  4. ;
  5. ; Larceny library -- higher-level error system.
  6. ($$trace "error")
  7. ; R6RS-style programs should never enter Larceny's debugger,
  8. ; because Larceny's R6RS modes are designed for batch-mode
  9. ; execution by people who don't know anything about Scheme.
  10. ; Programmers should use ERR5RS mode instead of R6RS modes.
  11. (define (unhandled-exception-error x)
  12. (let ((emode (cdr (assq 'execution-mode (system-features)))))
  13. (case emode
  14. ((dargo spanky)
  15. (let ((out (current-error-port)))
  16. (newline out)
  17. (display "Error: no handler for exception " out)
  18. (write x out)
  19. (newline out)
  20. (if (condition? x)
  21. (display-condition x out))
  22. (newline out)
  23. (display "Terminating program execution." out)
  24. (newline out)
  25. (exit 1)))
  26. (else
  27. ((error-handler) x)))))
  28. ; Heuristically recognizes both R6RS-style and Larceny's old-style
  29. ; arguments.
  30. ;
  31. ; The R6RS exception mechanism is used if and only if
  32. ; the program is executing in an R6RS mode, or
  33. ; a custom exception handler is currently installed,
  34. ; and the arguments are acceptable to the R6RS.
  35. (define (use-r6rs-mechanism? who msg)
  36. (let ((emode (cdr (assq 'execution-mode (system-features)))))
  37. (or (memq emode '(dargo spanky))
  38. (and (custom-exception-handlers?)
  39. (or (symbol? who) (string? who) (eq? who #f))
  40. (string? msg)))))
  41. (define (error . args)
  42. (if (and (pair? args) (pair? (cdr args)))
  43. (let ((who (car args))
  44. (msg (cadr args))
  45. (irritants (cddr args))
  46. (handler (error-handler)))
  47. (define (separated irritants)
  48. (if (null? irritants)
  49. '()
  50. (cons " "
  51. (cons (car irritants) (separated (cdr irritants))))))
  52. (if (string? msg)
  53. (cond ((use-r6rs-mechanism? who msg)
  54. (raise-r6rs-exception (make-error) who msg irritants))
  55. ((or (symbol? who) (string? who))
  56. (apply handler who msg (separated irritants)))
  57. ((eq? who #f)
  58. (apply handler msg (separated irritants)))
  59. (else
  60. ; old-style
  61. (apply handler '() args)))
  62. (apply handler '() args)))
  63. (apply (error-handler) '() args)))
  64. (define (assertion-violation who msg . irritants)
  65. (if (or #t (use-r6rs-mechanism? who msg)) ; FIXME
  66. (raise-r6rs-exception (make-assertion-violation) who msg irritants)
  67. (apply error who msg irritants)))
  68. (define (reset)
  69. ((reset-handler)))
  70. ; To be replaced by exception system.
  71. (define (call-without-errors thunk . rest)
  72. (let ((fail (if (null? rest) #f (car rest))))
  73. (call-with-current-continuation
  74. (lambda (k)
  75. (call-with-error-handler (lambda (who . args) (k fail)) thunk)))))
  76. ; Old code: clients should use PARAMETERIZE instead.
  77. (define (call-with-error-handler handler thunk)
  78. (let ((old-handler (error-handler)))
  79. (dynamic-wind
  80. (lambda () (error-handler handler))
  81. thunk
  82. (lambda () (error-handler old-handler)))))
  83. ; Old code: clients should use PARAMETERIZE instead.
  84. (define (call-with-reset-handler handler thunk)
  85. (let ((old-handler (reset-handler)))
  86. (dynamic-wind
  87. (lambda () (reset-handler handler))
  88. thunk
  89. (lambda () (reset-handler old-handler)))))
  90. ; DECODE-ERROR takes a list (describing an error) and optionally
  91. ; a port to print on (defaults to the current error port) and
  92. ; prints a human-readable error message to the port based on the
  93. ; information in the error.
  94. ;
  95. ; The error is a list. The first element is a key, the rest depend on the
  96. ; key. There are three cases, depending on the key:
  97. ; - a number: The error is a primitive error. There will be three
  98. ; additional values, the contents of RESULT, SECOND, and
  99. ; THIRD.
  100. ; - null: The key is to be ignored, and the following elements are
  101. ; to be interpreted as though they were arguments passed
  102. ; to the error procedure.
  103. ; - otherwise: The elements are to be interpreted as though they were
  104. ; arguments passed to the error procedure.
  105. ;
  106. ; There is also a special subcase of the third case above:
  107. ; If the key is a condition, and there are no other elements
  108. ; of the list, then the condition is assumed to describe an
  109. ; unhandled exception that has been raised.
  110. (define (decode-error the-error . rest)
  111. (let ((who (car the-error))
  112. (port (if (null? rest) (current-error-port) (car rest))))
  113. (cond ((and (number? who)
  114. (list? the-error)
  115. (= 4 (length the-error)))
  116. (decode-system-error who
  117. (cadr the-error)
  118. (caddr the-error)
  119. (cadddr the-error)
  120. port))
  121. (else
  122. (newline port)
  123. (display "Error: " port)
  124. (cond ((and (condition? who) (null? (cdr the-error)))
  125. (display "unhandled condition:" port)
  126. (newline port)
  127. (display-condition who port))
  128. ((not (null? who))
  129. (display who port)
  130. (display ": " port)))
  131. (for-each (lambda (x) (display x port)) (cdr the-error))
  132. (newline port)
  133. (flush-output-port port)))))
  134. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  135. ;
  136. ; Transition to R6RS conditions and exception mechanism.
  137. ;
  138. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  139. ; FIXME: This is an awful hack to connect two exception systems
  140. ; via the messages produced by Larceny.
  141. (define (decode-and-raise-r6rs-exception the-error)
  142. (let* ((out (open-output-string))
  143. (msg (begin (decode-error the-error out)
  144. (get-output-string out)))
  145. (larceny-system-prefix "\nError: ")
  146. (n (string-length larceny-system-prefix))
  147. (larceny-style?
  148. (and (< n (string-length msg))
  149. (string=? larceny-system-prefix (substring msg 0 n))))
  150. (msg (if larceny-style?
  151. (substring msg n (string-length msg))
  152. msg))
  153. (chars (if larceny-style? (string->list msg) '()))
  154. (colon (memq #\: chars))
  155. (who (if colon
  156. (substring msg 0 (- (string-length msg) (length colon)))
  157. #f))
  158. (msg (if colon (list->string (cdr colon)) msg))
  159. (c0 (make-assertion-violation))
  160. (c1 (make-message-condition msg)))
  161. (raise
  162. (if who
  163. (condition c0 (make-who-condition who) c1)
  164. (condition c0 c1)))))
  165. (define (raise-r6rs-exception c0 who msg irritants)
  166. (let ((c1 (cond ((or (symbol? who) (string? who))
  167. (make-who-condition who))
  168. ((eq? who #f)
  169. #f)
  170. (else
  171. (condition
  172. (make-violation)
  173. (make-who-condition 'make-who-condition)
  174. (make-irritants-condition (list who))))))
  175. (c2 (cond ((string? msg)
  176. (make-message-condition msg))
  177. (else
  178. (condition
  179. (make-assertion-violation)
  180. (make-who-condition 'make-message-condition)
  181. (make-irritants-condition (list msg))))))
  182. (c3 (make-irritants-condition irritants)))
  183. (raise
  184. (if who
  185. (condition c0 c1 c2 c3)
  186. (condition c0 c2 c3)))))
  187. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  188. ;
  189. ; Warns of deprecated features.
  190. ;
  191. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  192. (define issue-deprecated-warnings?
  193. (make-parameter "issue-deprecated-warnings?" #t))
  194. (define (issue-warning-deprecated name-of-deprecated-misfeature)
  195. (if (not (memq name-of-deprecated-misfeature already-warned))
  196. (begin
  197. (set! already-warned
  198. (cons name-of-deprecated-misfeature already-warned))
  199. (if (issue-deprecated-warnings?)
  200. (let ((out (current-error-port)))
  201. (display "WARNING: " out)
  202. (display name-of-deprecated-misfeature out)
  203. (newline out)
  204. (display " is deprecated in Larceny. See" out)
  205. (newline out)
  206. (display " " out)
  207. (display url:deprecated out)
  208. (newline out))))))
  209. (define url:deprecated
  210. "http://larceny.ccs.neu.edu/larceny-trac/wiki/DeprecatedFeatures")
  211. ; List of deprecated features for which a warning has already
  212. ; been issued.
  213. (define already-warned '())
  214. ; eof