for-debugging.scm 1.5 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162
  1. ; Part of Scheme 48 1.9. See file COPYING for notices and license.
  2. ; Authors: Richard Kelsey, Jonathan Rees, Mike Sperber
  3. ; --------------------
  4. ; Fake interrupt and exception system.
  5. ; This needs to be reconciled with alt/primitives.scm.
  6. (define (with-exceptions thunk)
  7. (with-handler
  8. (lambda (c punt)
  9. (cond ((and (condition? c)
  10. (procedure? (get-exception-handler)))
  11. (handle-exception-carefully c))
  12. ((interrupt-condition? c)
  13. (if (not (deal-with-interrupt c))
  14. (punt)))
  15. ;; ((vm-return? c)
  16. ;; (vm-return (cadr c)))
  17. (else
  18. (punt))))
  19. thunk))
  20. (define (handle-exception-carefully c)
  21. (display "(Exception: ") (write c) (display ")") (newline)
  22. (noting-exceptional-context c
  23. (lambda ()
  24. (raise-exception (exception-opcode c)
  25. (exception-arguments c)))))
  26. (define (noting-exceptional-context c thunk)
  27. (call-with-current-continuation
  28. (lambda (k)
  29. ;; Save for future inspection, just in case.
  30. (set! *exceptional-context* (cons c k))
  31. (thunk))))
  32. (define *exceptional-context* #f)
  33. (define (deal-with-interrupt c)
  34. (noting-exceptional-context c
  35. (lambda ()
  36. (maybe-handle-interrupt
  37. (if (and (pair? (cdr c)) (integer? (cadr c)))
  38. (cadr c)
  39. (enum interrupt keyboard))))))
  40. ; (define (poll-for-interrupts) ...)
  41. ; Get the whole thing started
  42. (define (?start-with-exceptions entry-point arg)
  43. (with-exceptions
  44. (lambda ()
  45. (?start entry-point arg))))
  46. (define (in struct form)
  47. (eval form (structure-package struct)))