;		       Copyright (C) 1992 by Marc Feeley -- all rights reserved

;; "_errors.scm"

(##include "header.scm")

;------------------------------------------------------------------------------

; Exceptions raised by low level runtime system

(define (##exception.global-jump ind . args)
  (let ((val (##global-var-ref ind)))
    (touch-vars (val)
      (if (##procedure? val)
        (##apply val args)
        (let ((name (##index->global-var-name ind)))
          (if (##unbound? val)
            (##signal '##SIGNAL.GLOBAL-UNBOUND-OPERATOR name args)
            (##signal '##SIGNAL.GLOBAL-NON-PROCEDURE-OPERATOR name args)))))))

(define (##exception.non-proc-jump proc . args)
  (touch-vars (proc)
    (if (##procedure? proc)
      (##apply proc args)
      (##signal '##SIGNAL.NON-PROCEDURE-JUMP proc args))))

(define (##exception.wrong-nb-arg proc . args)
  (##signal '##SIGNAL.WRONG-NB-ARG proc args))

(define (##exception.apply-arg-limit proc args)
  (##signal '##SIGNAL.APPLY-ARG-LIMIT proc args))

(define (##exception.heap-overflow)
  (##signal '##SIGNAL.HEAP-OVERFLOW))

(define (##exception.stack-overflow)
  (##signal '##SIGNAL.STACK-OVERFLOW))

(define (##exception.placeholder-already-determined)
  (##signal '##SIGNAL.PLACEHOLDER-ALREADY-DETERMINED))

(define (##exception.read-not-ready val)
  (let ((proc ##read-not-ready)) (if (##procedure? proc) (proc val) -1)))

(define (##exception.write-not-ready val)
  (let ((proc ##write-not-ready)) (if (##procedure? proc) (proc val) -1)))

(define (##exception.timer-interrupt)
  (let ((proc ##timer-interrupt)) (if (##procedure? proc) (proc))))

(define (##exception.user-interrupt)
  (let ((proc ##user-interrupt)) (if (##procedure? proc) (proc))))

(define (##exception.gc-finalize arg)
  (let ((proc ##gc-finalize)) (if (##procedure? proc) (proc)))
  arg)

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

; Traps from the runtime system.

(define (##trap-list-lengths name . args)
  (##runtime-error "Lists are not of equal length" name args))

(define (##trap-list-lengths* name . args)
  (##runtime-error* "Lists are not of equal length" name args))

(define (##trap-open-file name . args)
  (##runtime-error "Can't open file" name args))

(define (##trap-open-file* name . args)
  (##runtime-error* "Can't open file" name args))

(define (##trap-load msg name . args)
  (##runtime-error
    (if msg (##string-append "Can't load file " msg) "Can't load file")
    name args))

(define (##trap-load* msg name . args)
  (##runtime-error*
    (if msg (##string-append "Can't load file " msg) "Can't load file")
    name args))

(define (##trap-no-transcript name . args)
  (##runtime-error "No transcript underway" name args))

(define (##trap-no-transcript* name . args)
  (##runtime-error* "No transcript underway" name args))

(define (##trap-check-pair name . args)
  (##runtime-error "PAIR expected" name args))

(define (##trap-check-pair* name . args)
  (##runtime-error* "PAIR expected" name args))

(define (##trap-check-char name . args)
  (##runtime-error "CHARACTER expected" name args))

(define (##trap-check-char* name . args)
  (##runtime-error* "CHARACTER expected" name args))

(define (##trap-check-symbol name . args)
  (##runtime-error "SYMBOL expected" name args))

(define (##trap-check-symbol* name . args)
  (##runtime-error* "SYMBOL expected" name args))

(define (##trap-check-string name . args)
  (##runtime-error "STRING expected" name args))

(define (##trap-check-string* name . args)
  (##runtime-error* "STRING expected" name args))

(define (##trap-check-vector name . args)
  (##runtime-error "VECTOR expected" name args))

(define (##trap-check-vector* name . args)
  (##runtime-error* "VECTOR expected" name args))

(define (##trap-check-procedure name . args)
  (##runtime-error "PROCEDURE expected" name args))

(define (##trap-check-procedure* name . args)
  (##runtime-error* "PROCEDURE expected" name args))

(define (##trap-check-input-port name . args)
  (##runtime-error "INPUT PORT expected" name args))

(define (##trap-check-input-port* name . args)
  (##runtime-error* "INPUT PORT expected" name args))

(define (##trap-check-output-port name . args)
  (##runtime-error "OUTPUT PORT expected" name args))

(define (##trap-check-output-port* name . args)
  (##runtime-error* "OUTPUT PORT expected" name args))

(define (##trap-check-open-port name . args)
  (##runtime-error "Open PORT expected" name args))

(define (##trap-check-open-port* name . args)
  (##runtime-error* "Open PORT expected" name args))

(define (##trap-check-number name . args)
  (##runtime-error "NUMBER expected" name args))

(define (##trap-check-real name . args)
  (##runtime-error "REAL expected" name args))

(define (##trap-check-rational name . args)
  (##runtime-error "RATIONAL expected" name args))

(define (##trap-check-integer name . args)
  (##runtime-error "INTEGER expected" name args))

(define (##trap-check-exact-int name . args)
  (##runtime-error "Exact INTEGER expected" name args))

(define (##trap-check-exact-int* name . args)
  (##runtime-error* "Exact INTEGER expected" name args))

(define (##trap-check-range name . args)
  (##runtime-error "Out of range" name args))

(define (##trap-check-range* name . args)
  (##runtime-error* "Out of range" name args))

(define (##trap-divide-by-zero name . args)
  (##runtime-error "Division by zero" name args))

(define (##trap-unimplemented name . args)
  (##runtime-error "Unimplemented procedure" name args))

(define (##runtime-error msg name args)
  (##signal '##SIGNAL.RUNTIME-ERROR msg name args))

(define (##runtime-error* msg name args)

  (define (fix l)
    (if (##pair? (##cdr l)) (##cons (##car l) (fix (##cdr l))) (##car l)))

  (##signal '##SIGNAL.RUNTIME-ERROR msg name (fix args)))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (##default-signal-catcher s args)
  (if (##unbound? ##stderr)

    (##quit)

    (cond ((##eq? s '##SIGNAL.IO-ERROR)
           (##handle-simple-error
             #f
             (##car args)
             (##cdr args)
             '()))

          ((##eq? s '##SIGNAL.READ-ERROR)
           (##handle-simple-error
             'read
             (##car args)
             (##cdr args)
             '()))

          ((##eq? s '##SIGNAL.UNBOUND-DYNAMIC-VAR)
           (##handle-simple-error
             #f
             "Unbound dynamic variable:"
             (##list (##car args))
            '()))

          ((##eq? s '##SIGNAL.GLOBAL-UNBOUND)
           (##handle-interpreter-error
             (##car args)
             (##cadr args)
             "Unbound variable:"
             (##list (##decomp (##car args)))
             '()))

          ((##eq? s '##SIGNAL.GLOBAL-UNBOUND-OPERATOR)
           (##handle-call-error
             (##car args)
             (##cadr args)
             "Unbound global variable in operator position"))

          ((##eq? s '##SIGNAL.GLOBAL-NON-PROCEDURE-OPERATOR)
           (##handle-call-error
             (##car args)
             (##cadr args)
             "Global variable in operator position is not a PROCEDURE"))

          ((##eq? s '##SIGNAL.NON-PROCEDURE-JUMP)
           (##handle-call-error
             (let ((x (##car args)))
               (if (##self-eval? x) x (##list 'QUOTE x)))
             (##cadr args)
             "Operator is not a PROCEDURE"))

          ((##eq? s '##SIGNAL.NON-PROCEDURE-OPERATOR)
           (##handle-interpreter-error
             (##car args)
             (##cadr args)
             "Operator is not a PROCEDURE"
             '()
             (##list (##decomp (##car args)))))

          ((##eq? s '##SIGNAL.NON-PROCEDURE-SEND)
           (##handle-interpreter-error
             (##car args)
             (##cadr args)
             "PROCEDURE expected after '=>':"
             '()
             (##list (##decomp (##car args)))))

          ((##eq? s '##SIGNAL.WRONG-NB-ARG)
           (##handle-call-error
             (##car args)
             (##cadr args)
             "Wrong number of arguments passed to procedure"))

          ((##eq? s '##SIGNAL.APPLY-ARG-LIMIT)
           (##handle-call-error
             (##car args)
             (##cadr args)
             "Argument count to APPLY exceeds implementation limit"))

          ((##eq? s '##SIGNAL.HEAP-OVERFLOW)
           (##handle-simple-error
             #f
             "Heap overflow"
             '()
             '()))

          ((##eq? s '##SIGNAL.STACK-OVERFLOW)
           (##handle-simple-error
             #f
             "Stack overflow"
             '()
             '()))

          ((##eq? s '##SIGNAL.PLACEHOLDER-ALREADY-DETERMINED)
           (##handle-simple-error
             #f
             "Placeholder already determined"
             '()
             '()))

          ((##eq? s '##SIGNAL.RUNTIME-ERROR)
           (##handle-call-error
             (##cadr args)
             (##caddr args)
             (##car args)))

          ((##eq? s '##SIGNAL.GLOBAL-ENV-OVERFLOW)
           (##handle-simple-error
             '[COMPILATION]
             "Global variable table overflow"
             '()
             '()))

          ((##eq? s '##SIGNAL.SYNTAX-ERROR)
           (##handle-simple-error
             '[COMPILATION]
             (##cadr args)
             (##cddr args)
             (##list (##car args))))

          (else
           (##write-string "*** ERROR -- Signal not caught, " ##stderr)
           (##write s ##stderr #f)
           (##write-string " " ##stderr)
           (##write args ##stderr #f)
           (##newline ##stderr)
           (##quit)))))

(define (##handle-simple-error proc msg args pps)
  (##sequentially (lambda ()
    (##identify-error proc msg args pps)
    (##pop-repl))))

(define (##handle-interpreter-error code rte msg args pps)
  (##subproblem-apply0 code rte
    (lambda ()
      (##call-with-current-continuation (lambda (cont) (##sequentially (lambda ()
        (##identify-error (##extract-proc code rte) msg args pps)
        (##debug-repl cont))))))))

(define (##handle-call-error proc args msg)
  (##call-with-current-continuation (lambda (cont) (##sequentially (lambda ()

    (define (add-quotes l)
      (if (##pair? l)
        (let ((x (##car l)))
          (##cons (if (##self-eval? x) x (##list 'QUOTE x))
                  (add-quotes (##cdr l))))
        '()))

    (##identify-error #f msg '() '())

    (let ((out (##repl-out)))
      (let ((call (##cons (if (##procedure? proc)
                            (##procedure-name proc)
                            proc)
                          (add-quotes args))))
        (let ((str (##object->string call 79 (if-touches #t #f))))
          (if (##fixnum.< (##string-length str) 79)
            (##write-string str out)
            (begin
              (##write-string "(" out)
              (##write-string (##object->string (##car call) 78 (if-touches #t #f))
                              out)
              (##newline out)

              (let loop ((l (##cdr call)))
                (if (##pair? l)
                  (begin
                    (##write-string "  " out)
                    (##write-string (##object->string (##car l) 77 (if-touches #t #f))
                                    out)
                    (##newline out)
                    (loop (##cdr l)))))

              (##write-string ")" out)))

          (##newline out)
          (##debug-repl cont)))))))))

(define (##identify-error proc msg args pps)
  (let ((out (##repl-out)))
    (##write-string "*** ERROR" out)
    (if proc
      (begin
        (##write-string " IN " out)
        (##write (if (##procedure? proc)
                   (##procedure-name proc)
                   proc)
                 out
                 #f)))
    (##write-string " -- " out)
    (##display msg out #f)
    (let loop1 ((l args))
      (if (##pair? l)
        (begin
          (##write-string " " out)
          (##write (##car l) out #f)
          (loop1 (##cdr l)))
        (begin
          (##newline out)
          (let loop2 ((l pps))
            (if (##pair? l)
              (begin
                (##pretty-print (##car l) out 79)
                (loop2 (##cdr l))))))))))

(define ##user-interrupt #f)

(set! ##user-interrupt
  (lambda ()
    (##call-with-current-continuation (lambda (cont) (##sequentially (lambda ()
      (let ((out (##repl-out)))
        (##newline out)
        (##write-string "*** INTERRUPT" out)
        (##newline out)
        (##debug-repl cont))))))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (##signal sig . args)
  (let ((signal-catcher
          (##dynamic-ref '##SIGNAL-CATCHER ##default-signal-catcher)))
    (signal-catcher sig args)))

(define (##catch-all signal-catcher thunk)
  (##dynamic-bind (##list (##cons '##SIGNAL-CATCHER signal-catcher)) thunk))

(define (##catch-signal sig signal-catcher thunk)
  (let ((parent-signal-catcher
          (##dynamic-ref '##SIGNAL-CATCHER ##default-signal-catcher)))
    (##catch-all (lambda (s args)
                   (if (##eq? s sig)
                     (signal-catcher s args)
                     (parent-signal-catcher s args)))
                 thunk)))

;------------------------------------------------------------------------------