;==============================================================================

; file: "_errors.scm"

; Copyright (C) 1994-1998 by Marc Feeley, All Rights Reserved.

(##include "header.scm")

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

; 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-list name . args)
  (##runtime-error "LIST expected" name args))

(define (##trap-list* name . args)
  (##runtime-error* "LIST expected" 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-open-pipe name . args)
  (##runtime-error "Can't open pipe" name args))

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

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

(define (##trap-load* err-msg name . args)
  (##runtime-error*
    (if err-msg
      (##string-append "Can't load file (" err-msg ")")
      "Can't load file")
    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-will name . args)
  (##runtime-error "WILL expected" name args))

(define (##trap-check-will* name . args)
  (##runtime-error* "WILL 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-keyword name . args)
  (##runtime-error "KEYWORD expected" name args))

(define (##trap-check-keyword* name . args)
  (##runtime-error* "KEYWORD 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-u8vector name . args)
  (##runtime-error "U8VECTOR expected" name args))

(define (##trap-check-u8vector* name . args)
  (##runtime-error* "U8VECTOR expected" name args))

(define (##trap-check-u16vector name . args)
  (##runtime-error "U16VECTOR expected" name args))

(define (##trap-check-u16vector* name . args)
  (##runtime-error* "U16VECTOR expected" name args))

(define (##trap-check-u32vector name . args)
  (##runtime-error "U32VECTOR expected" name args))

(define (##trap-check-u32vector* name . args)
  (##runtime-error* "U32VECTOR expected" name args))

(define (##trap-check-f32vector name . args)
  (##runtime-error "F32VECTOR expected" name args))

(define (##trap-check-f32vector* name . args)
  (##runtime-error* "F32VECTOR expected" name args))

(define (##trap-check-f64vector name . args)
  (##runtime-error "F64VECTOR expected" name args))

(define (##trap-check-f64vector* name . args)
  (##runtime-error* "F64VECTOR 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-interp-procedure* name . args)
  (##runtime-error* "Interpreted 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-readtable name . args)
  (##runtime-error "READTABLE expected" name args))

(define (##trap-check-readtable* name . args)
  (##runtime-error* "READTABLE expected" name args))

(define (##trap-check-number name . args)
  (##runtime-error "NUMBER 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-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-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-inexact-real name . args)
  (##runtime-error "Inexact REAL expected" name args))

(define (##trap-check-inexact-real* name . args)
  (##runtime-error* "Inexact REAL 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-divide-by-zero* name . args)
  (##runtime-error* "Division by zero" name args))

(define (##trim-absent lst)
  (if (##pair? lst)
    (if (##eq? (##car lst) (absent-obj))
      '()
      (begin
        (let loop ((curr lst) (next (##cdr lst)))
          (if (##pair? next)
            (if (##eq? (##car next) (absent-obj))
              (##set-cdr! curr '())
              (loop next (##cdr next)))))
        lst))
    '()))

(define (##runtime-error err-msg name args)
  (##signal '##signal.runtime-error err-msg name (##trim-absent args)))

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

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

  (##signal '##signal.runtime-error err-msg name (##trim-absent (fix args))))

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

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

    (##exit 1)

    (cond ((##eq? s '##signal.io-error)
           (##handle-simple-error
             #f
             #f
             (##car args)
             (##cdr args)
             '()))

          ((##eq? s '##signal.read-error)
           (##handle-simple-error
             'read
             (##make-locat (##port-name (##car args))
                           (##cadr args))
             (##caddr args)
             (##cdddr args)
             '()))

          ((##eq? s '##signal.unbound-dynamic-var)
           (##handle-simple-error
             #f
             #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)
             (##trim-absent (##cadr args))
             "Wrong number of arguments passed to procedure"
             '()))

          ((##eq? s '##signal.unknown-keyword-arg)
           (##handle-call-error
             (##car args)
             (##cadr args)
             "Unknown keyword argument passed to procedure"
             '()))

          ((##eq? s '##signal.keyword-expected)
           (##handle-call-error
             (##car args)
             (##cadr args)
             "Keyword argument expected"
             '()))

          ((##eq? s '##signal.clam-conv-error)
           (let ((arg-num (##fixnum.modulo (##car args) 128)))
             (if (##fixnum.= arg-num 0)
               (##handle-call-error
                 (##cadr args)
                 (##caddr args)
                 "'c-lambda' data representation conversion error on result"
                 '())
               (##handle-call-error
                 (##cadr args)
                 (##caddr args)
                 "'c-lambda' data representation conversion error on argument"
                 (##list arg-num)))))

          ((##eq? s '##signal.cdef-conv-error)
           (##handle-call-error;****************
             (##cadr args)
             '()
             "'c-define' data representation conversion error on argument"
             (##list (##fixnum.modulo (##car args) 128))))

          ((##eq? s '##signal.multiple-c-return)
           (##handle-simple-error
             #f
             #f
             "Attempt to return to a C function that has already returned"
             '()
             '()))

          ((##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
             #f
             "Heap overflow"
             '()
             '()))

          ((##eq? s '##signal.stack-overflow)
           (##handle-simple-error
             #f
             #f
             "Stack overflow"
             '()
             '()))

          ((##eq? s '##signal.promise-already-determined)
           (##handle-simple-error
             #f
             #f
             "Promise 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
             #f
             #f
             "Global variable table overflow"
             '()
             '()))

          ((##eq? s '##signal.syntax-error)
           (let* ((src (##car args))
                  (locat (##source-locat src)))
             (##handle-simple-error
               #f
               locat
               (##cadr args)
               (##cddr args)
               (if locat '() (##list (##desourcify src))))))

          (else
           (##write-string "*** ERROR -- Signal not caught, " ##stderr)
           (##write s ##stderr ##main-readtable #f)
           (##write-string " " ##stderr)
           (##write args ##stderr ##main-readtable #f)
           (##newline ##stderr)
           (##exit 1)))))

(define (##handle-simple-error proc locat err-msg err-infos pps)
  (##sequentially (lambda ()
    (##identify-error
     "ERROR"
     proc
     locat
     err-msg
     err-infos
     pps)
    (##pop-repl))))

(define (##handle-interpreter-error $code rte err-msg err-infos pps)
  (##call-with-current-continuation
    (lambda (cont) (##sequentially (lambda ()
      (##identify-error
       "ERROR"
       (##extract-container $code rte)
       (##frame-locat (##continuation->first-frame cont))
       err-msg
       err-infos
       pps)
      (##debug-repl cont #t))))))

(define (##handle-call-error proc args err-msg err-infos)
  (##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
       "ERROR"
       #f
       (##frame-locat (##continuation->first-frame cont))
       err-msg
       err-infos
       '())

      (let ((out (##repl-out))
            (rt (##repl-readtable)))
        (let ((call (##cons (if (##procedure? proc)
                              (##procedure-name proc)
                              proc)
                            (add-quotes args)))
              (width (##port-width out)))
          (let ((str (##object->string call rt width (if-forces #t #f))))
            (if (##fixnum.< (##string-length str) width)
              (##write-string str out)
              (begin
                (##write-string "(" out)
                (##write-string (##object->string
                                 (##car call)
                                 rt
                                 (##fixnum.- width 1)
                                 (if-forces #t #f))
                                out)
                (##newline out)

                (let loop ((l (##cdr call)))
                  (if (##pair? l)
                    (begin
                      (##write-string "  " out)
                      (##write-string (##object->string
                                       (##car l)
                                       rt
                                       (##fixnum.- width 2)
                                       (if-forces #t #f))
                                      out)
                      (##newline out)
                      (loop (##cdr l)))))

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

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

(define (##identify-error kind proc locat err-msg err-infos pps)
  (let ((out (##repl-out))
        (rt (##repl-readtable)))
    (##write-string "*** " out)
    (##write-string kind out)
    (if (or proc locat)
      (##write-string " IN " out))
    (if proc
      (##display (if (##procedure? proc)
                   (##procedure-name proc)
                   proc)
                 out
                 rt
                 #f))
    (if locat
      (begin
        (if proc
          (##write-string ", " out))
        (##display-locat locat #t out rt)))
    (if err-msg
      (begin
        (##write-string " -- " out)
        (##display err-msg out rt #f)
        (let loop1 ((l err-infos))
          (if (##pair? l)
            (begin
              (##write-string " " out)
              (##write (##car l) out rt #f)
              (loop1 (##cdr l)))))))
    (##newline out)
    (let loop2 ((l pps))
      (if (##pair? l)
        (begin
          (##pretty-print (##car l) out rt)
          (loop2 (##cdr l)))))))

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

(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-let (##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)))

(define (##cleanup-on-signal thunk1 thunk2)
  (let ((parent-signal-catcher
          (##dynamic-ref '##signal-catcher ##default-signal-catcher)))
    (##catch-all (lambda (s args)
                   (thunk2)
                   (parent-signal-catcher s args))
                 thunk1)))

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

; Exceptions raised by low level runtime system

(##declare (not interrupts-enabled))

(define (##exception.global-jump gv . args)
  (let ((val (##global-var-ref gv)))
    (force-vars (val)
      (if (##procedure? val)
        (##apply val args)
        (if (##unbound? val)
          (##signal '##signal.global-unbound-operator gv args)
          (##signal '##signal.global-non-procedure-operator gv args))))))

(define (##exception.non-proc-jump proc . args)
  (force-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.unknown-keyword-arg proc . args)
  (##signal '##signal.unknown-keyword-arg proc args))

(define (##exception.keyword-expected proc . args)
  (##signal '##signal.keyword-expected proc args))

(define (##exception.clam-conv-error err-code proc . args)
  (##signal '##signal.clam-conv-error err-code proc args))

(define (##exception.cdef-conv-error err-code proc)
  (##signal '##signal.cdef-conv-error err-code proc))

(define (##exception.multiple-c-return)
  (##signal '##signal.multiple-c-return))

(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.promise-already-determined)
  (##signal '##signal.promise-already-determined))

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