;*=====================================================================*/
;*    serrano/prgm/project/bigloo/runtime/Llib/error.scm               */
;*    -------------------------------------------------------------    */
;*    Author      :  Manuel Serrano                                    */
;*    Creation    :  Fri Jan 20 08:19:23 1995                          */
;*    Last change :  Fri Nov 14 21:43:42 2003 (serrano)                */
;*    -------------------------------------------------------------    */
;*    The error machinery                                              */
;*    -------------------------------------------------------------    */
;*    The error functionnality can be used even if this module is      */
;*    not initialized. This feature allows a correct printing for      */
;*    the errors occuring during the initialization time.              */
;*=====================================================================*/
 
;*---------------------------------------------------------------------*/
;*    The module                                                       */
;*---------------------------------------------------------------------*/
(module __error

   (use     __type
	    __bigloo
	    __os
	    __foreign
	    __binary
 	    __structure
	    __dsssl
	    __object
	    __tvector
	    __socket
	    __process
	    __custom
	    __unicode
	    __ucs2
	    
	    __pp_circle
	    
	    __reader

	    __rgc
	    
	    __r4_vectors_6_8
	    __r4_numbers_6_5_fixnum
	    __r4_numbers_6_5_flonum
	    __r4_equivalence_6_2
	    __r4_booleans_6_1
	    __r4_pairs_and_lists_6_3
	    __r4_characters_6_6
	    __r4_symbols_6_4
	    __r4_strings_6_7
	    __r4_ports_6_10_1
	    __r4_control_features_6_9
	    __r4_output_6_10_3
	    
	    __evenv)

   (import  __r4_input_6_10_2)

   (extern  (include "signal.h")
	    
	    (export the_failure "the_failure")
	    (export the_c_failure "the_c_failure")
	    
	    (c-dump-trace-stack::obj (::output-port ::int) "dump_trace_stack")
	    (macro c-push-trace::obj (::obj) "PUSH_TRACE")
	    (macro c-pop-trace::obj () "POP_TRACE")
	    (macro c-get-error-handler::obj () "GET_ERROR_HANDLER")
	    (macro c-set-error-handler!::void (::obj) "SET_ERROR_HANDLER")
	    (macro sigfpe::int "SIGFPE")
	    (macro sigill::int "SIGILL")
	    (macro sigbus::int "SIGBUS")
	    (macro sigsegv::int "SIGSEGV")
	    (macro c-find-runtime-type::string (::obj) "FOREIGN_TYPE_NAME"))

   (java    (class foreign
	       (method static c-dump-trace-stack::obj (::output-port ::int)
		       "dump_trace_stack")
	       (method static c-push-trace::obj (::obj)
		       "PUSH_TRACE")
	       (method static c-pop-trace::obj ()
		       "POP_TRACE")
 	       (method static c-find-runtime-type::string (::obj)
		       "FOREIGN_TYPE_NAME")
	       (method static c-get-error-handler::obj ()
		       "GET_ERROR_HANDLER")
	       (method static c-set-error-handler!::void (::obj)
		       "SET_ERROR_HANDLER")
	       (field static sigfpe::int "SIGFPE")
	       (field static sigill::int "SIGILL")
	       (field static sigbus::int "SIGBUS")
	       (field static sigsegv::int "SIGSEGV")))

   (export  (exit::magic . obj)
	    (inline error::obj ::obj ::obj ::obj)
	    (warning . args)
	    (warning/location::obj ::obj ::obj . obj)
	    (warning/c-location::obj ::string ::long . obj)
	    (error/location::obj ::obj ::obj ::obj ::obj ::obj)
	    (error/c-location::obj ::obj ::obj ::obj ::string ::long)
	    (debug-error/location::obj ::obj ::obj ::obj ::obj ::obj)
	    (error/location-file::obj ::obj ::obj)
	    (notify-error ::obj ::obj ::obj)
	    (notify-interrupt ::int)
	    (add-error-handler! ::obj ::obj)
	    (remove-error-handler!)
	    (current-error-handler)
	    (the_failure::magic ::obj ::obj ::obj)
	    (the_c_failure::magic ::string ::string ::obj)
	    (find-runtime-type::bstring  ::obj)
	    *error-notifier*
	    *interrupt-notifier*
	    *trace-stack-depth*
	    *debug*
	    *warning*
	    (module-init-error ::string ::string)
	    (bigloo-type-error-msg::bstring  ::bstring ::bstring ::bstring)
	    (bigloo-type-error::obj ::obj ::obj ::obj)
	    (bigloo-type-error/location::obj ::obj ::obj ::obj ::obj ::obj))

   (option  (set! *compiler-debug* 0)
	    (set! *optim-O-macro?* #f)
	    (set! *unsafe-type*    #t)
	    (set! *unsafe-arity*   #t)
	    (set! *unsafe-range*   #t)))

;*---------------------------------------------------------------------*/
;*    *debug* ...                                                      */
;*---------------------------------------------------------------------*/
(define *debug* 0)

;*---------------------------------------------------------------------*/
;*    *warning* ...                                                    */
;*---------------------------------------------------------------------*/
(define *warning* #t)

;*---------------------------------------------------------------------*/
;*    *trace-stack-depth* ...                                          */
;*---------------------------------------------------------------------*/
(define *trace-stack-depth*
   (let ((env-value (getenv "BIGLOOSTACKDEPTH")))
      (if (string? env-value)
	  (string->integer env-value)
	  10)))

;*---------------------------------------------------------------------*/
;*    exit ...                                                         */
;*---------------------------------------------------------------------*/
(define (exit . n)
   (let ((val (cond
		 ((null? n)
		  0)
		 ((not (fixnum? (car n)))
		  0)
		 (else
		  (car n)))))
      (bigloo-exit val)
      val))

;*---------------------------------------------------------------------*/
;*    dump-trace-stack ...                                             */
;*---------------------------------------------------------------------*/
(define-inline (dump-trace-stack)
   (let ((depth (if (fixnum? *trace-stack-depth*)
		    *trace-stack-depth*
		    10)))
      (c-dump-trace-stack (current-error-port) depth)))
					       
;*---------------------------------------------------------------------*/
;*    add-error-handler! ...                                           */
;*---------------------------------------------------------------------*/
(define (add-error-handler! handler escape)
   (c-set-error-handler! (cons (cons handler escape) (c-get-error-handler)))
   #unspecified)

;*---------------------------------------------------------------------*/
;*    remove-error-handler! ...                                        */
;*---------------------------------------------------------------------*/
(define (remove-error-handler!)
   (let ((error-handler (c-get-error-handler)))
      (if (pair? error-handler)
	  (begin
	     (c-set-error-handler! (cdr error-handler))
	     error-handler)
	  (begin
	     (notify-error "remove-error-handler! (this is an internal error)"
			   "Can't remove handler"
			   "error handler stack empty")
	     (%exit 1)))))

;*---------------------------------------------------------------------*/
;*    current-error-handler ...                                        */
;*---------------------------------------------------------------------*/
(define (current-error-handler)
   (let ((hdl (c-get-error-handler)))
      (if (not (pair? hdl))
	  default-error-handler
	  (let ((handler (car (car hdl))))
	     (if (and (procedure? handler) (=fx (procedure-arity handler) 4))
		 handler
		 (begin
		    (incorrect-error-handler handler)
		    (%exit 1)))))))

;*---------------------------------------------------------------------*/
;*    error ...                                                        */
;*---------------------------------------------------------------------*/
(define-inline (error proc message object)
   (failure proc message object))
   
;*---------------------------------------------------------------------*/
;*    warning ...                                                      */
;*---------------------------------------------------------------------*/
(define (warning . args)
   (if *warning*
       (begin
	  (flush-output-port (current-output-port))
	  (newline (current-error-port))
	  (display "*** WARNING:bigloo:" (current-error-port))
	  (if (not (null? args))
	      (begin
		 (display-circle (car args) (current-error-port))
		 (newline (current-error-port))
		 (for-each (lambda (a)
			      (display-circle a (current-error-port)))
			   (cdr args))))
	  (newline (current-error-port))
	  (flush-output-port (current-error-port)))))

;*---------------------------------------------------------------------*/
;*    warning/location ...                                             */
;*---------------------------------------------------------------------*/
(define (warning/location fname location . args)
   (if *warning*
       (cond
	  ((string=? fname "[string]")
	   (apply warning args))
	  ((string=? fname "[stdin]")
	   (apply warning args))
	  (else
	   (warning/location-file fname location args)))))

;*---------------------------------------------------------------------*/
;*    warning/c-location ...                                           */
;*    -------------------------------------------------------------    */
;*    This function implements a cast for its first two arguments.     */
;*    It impliclty casts the fname and location from C values to       */
;*    Bigloo values.                                                   */
;*---------------------------------------------------------------------*/
(define (warning/c-location fname location . args)
   (apply warning/location (cons fname (cons location args))))
			    
;*---------------------------------------------------------------------*/
;*    the_failure ...                                                  */
;*---------------------------------------------------------------------*/
(define (the_failure proc message object)
   (reader-reset!)
   (let ((error-handler (c-get-error-handler)))
      (if (not (pair? error-handler))
	  (default-error-handler proc message object)
	  (let ((handler (car (car error-handler)))
		(escape  (cdr (car error-handler))))
	     (if (and (procedure? handler) (=fx (procedure-arity handler) 4))
		 (handler escape proc message object)
		 (incorrect-error-handler handler))))))

;*---------------------------------------------------------------------*/
;*    the_c_failure ...                                                */
;*---------------------------------------------------------------------*/
(define (the_c_failure proc message object)
   (the_failure proc message object))

;*---------------------------------------------------------------------*/
;*    notify-dump-trace-stack ...                                      */
;*---------------------------------------------------------------------*/
(define (notify-dump-trace-stack)
   (if (or (and (fixnum? *debug*) (>fx *debug* 0))
	   (string? (getenv "BIGLOOSTACKDEPTH")))
       (dump-trace-stack)))
   
;*---------------------------------------------------------------------*/
;*    notify-interrupt ...                                             */
;*---------------------------------------------------------------------*/
(define (notify-interrupt sig)
   ((if (procedure? *interrupt-notifier*)
 	*interrupt-notifier*
 	default-interrupt-notifier)
    sig))

;*---------------------------------------------------------------------*/
;*    *interrupt-notifier* ...                                         */
;*---------------------------------------------------------------------*/
(define *interrupt-notifier* #unspecified)

;*---------------------------------------------------------------------*/
;*    default-interrupt-notifier ...                                   */
;*---------------------------------------------------------------------*/
(define (default-interrupt-notifier sig)
   (let ((port (current-error-port)))
      (newline port)
      (fprint port "*** INTERRUPT:bigloo:")
      (flush-output-port port)))

;*---------------------------------------------------------------------*/
;*    notify-error ...                                                 */
;*---------------------------------------------------------------------*/
(define (notify-error proc mes obj)
   (if (procedure? *error-notifier*)
       (*error-notifier* proc mes obj)
       (let ((port (current-error-port)))
	  (flush-output-port (current-output-port))
	  (newline port)
	  (display "*** ERROR:bigloo:" port)
	  (display-circle proc port)
	  (display #":\n" port)
	  (display-circle mes port)
	  (display " -- " port)
	  (display-circle obj port)
	  (newline port)
	  (notify-dump-trace-stack)
	  (flush-output-port port))))

;*---------------------------------------------------------------------*/
;*    bigloo-type-error-msg ...                                        */
;*---------------------------------------------------------------------*/
(define (bigloo-type-error-msg prefix from to)
   (string-append prefix " `" from "' expected, `" to "' provided"))

;*---------------------------------------------------------------------*/
;*    *error-notifier* ...                                             */
;*---------------------------------------------------------------------*/
(define *error-notifier* #unspecified)

;*---------------------------------------------------------------------*/
;*    default-error-handler ...                                        */
;*---------------------------------------------------------------------*/
(define (default-error-handler proc mes obj)
   (notify-error proc mes obj)
   -1)

;*---------------------------------------------------------------------*/
;*    incorrect-error-handler ...                                      */
;*---------------------------------------------------------------------*/
(define (incorrect-error-handler handler)
   (default-error-handler "error" "Not an error handler" handler))

;*---------------------------------------------------------------------*/
;*    sigfpe-error-handler ...                                         */
;*---------------------------------------------------------------------*/
(define (sigfpe-error-handler n)
   (error "arithmetic procedure" "`floating point' exception" "reached"))

;*---------------------------------------------------------------------*/
;*    sigill-error-handler ...                                         */
;*---------------------------------------------------------------------*/
(define (sigill-error-handler n)
   (error "bigloo" "`illegal instruction' exception" "reached"))

;*---------------------------------------------------------------------*/
;*    sigbus-error-handler ...                                         */
;*---------------------------------------------------------------------*/
(define (sigbus-error-handler n)
   (error "bigloo" "`bus error' exception" "reached"))

;*---------------------------------------------------------------------*/
;*    sigsegv-error-handler ...                                        */
;*---------------------------------------------------------------------*/
(define (sigsegv-error-handler n)
   (error "bigloo" "`segmentation violation' exception" "reached"))

;*---------------------------------------------------------------------*/
;*    On installe le ratrappage des exceptions                         */
;*---------------------------------------------------------------------*/
(signal sigfpe  sigfpe-error-handler)
(signal sigill  sigill-error-handler)
(signal sigbus  sigbus-error-handler)
(signal sigsegv sigsegv-error-handler)

;*---------------------------------------------------------------------*/
;*    error/location ...                                               */
;*    -------------------------------------------------------------    */
;*    We print error message understable by emacs. We                  */
;*    print them in the following format:                              */
;*      `File "foobar.scm", lines 8, character 20: blah blah'          */
;*---------------------------------------------------------------------*/
(define (error/location proc message object fname location)
   (cond
      ((not (string? fname))
       (error proc message object))
      ((not (fixnum? location))
       (error proc message object))
      ((string=? fname "[string]")
       (error proc message object))
      ((string=? fname "[stdin]")
       (error proc message object))
      ((string=? fname "[string]")
       (error proc message object))
      (else
       (set! *error-notifier* (error/location-file fname location))
       (error proc message object))))

;*---------------------------------------------------------------------*/
;*    error/c-location ...                                             */
;*    -------------------------------------------------------------    */
;*    This function implements a cast for its last two arguments.      */
;*    It impliclty casts the fname and location from C values to       */
;*    Bigloo values.                                                   */
;*---------------------------------------------------------------------*/
(define (error/c-location proc message object fname location)
   (error/location proc message object fname location))

;*---------------------------------------------------------------------*/
;*    debug-error/location ...                                         */
;*    -------------------------------------------------------------    */
;*    This function is mainly used by the compiler in -g2 mode. The    */
;*    idea of this function is to launch an error/location only        */
;*    if the error notifier is the default notifier. That is this      */
;*    function does not hide smart error handlers.                     */
;*---------------------------------------------------------------------*/
(define (debug-error/location proc message object fname location)
   (if (procedure? *error-notifier*)
       (error proc message object)
       (error/location proc message object fname location)))
   
;*---------------------------------------------------------------------*/
;*    uncygdrive ...                                                   */
;*    -------------------------------------------------------------    */
;*    This function is used on the Win32 port to get rid of the fake   */
;*    directory introduced by Cygwin.                                  */
;*---------------------------------------------------------------------*/
(define (uncygdrive::bstring str::bstring)
   (if (substring=? "/cygdrive/" str 10)
       (if (and (>fx (string-length str) 12)
                (char-alphabetic? (string-ref str 10))
                (char=? (string-ref str 11) #\/))
           (string-append (string (string-ref str 10) #\: #\/)
                          (substring str 12 (string-length str)))
           str)
       str))

;*---------------------------------------------------------------------*/
;*    error/location-file ...                                          */
;*---------------------------------------------------------------------*/
(define (error/location-file file-name location)
   ;; we compute the message to print the location
   (if (string=? (os-class) "win32")
       (begin
          (set! file-name (uncygdrive file-name))
          (let ((file-name-length (string-length file-name)))
             (let loop ((i 0))
                (if (<fx i file-name-length)
                    (begin
                       (if (eq? (string-ref file-name i) #\/)
                           (string-set! file-name i #\\))
                       (loop (+fx i 1))))))))
   (let ((port (open-input-file file-name)))
      (if (not (input-port? port))
	  ;; we are enable to re-open the file, we just print a
	  ;; standard error
	  #f
	  ;; we readlines until we reach location
	  (let loop ((line-string (read-line port))
		     (line-num    1)
		     (old-pos     0))
	     (if (eof-object? line-string)
		 (begin
		    ;; an error we don't know how to print
		    (close-input-port port)
		    (lambda (proc msg obj)
		       (set! *error-notifier* #f)
		       (notify-error proc msg obj)))
		 (if (>=fx (input-port-position port) location)
		     (begin
			(close-input-port port)
			(make-location-notifier file-name
						line-num
						location
						line-string
						(-fx location old-pos)))
		     (let ((old-pos (input-port-position port)))
			(loop (read-line port) 
			      (+fx line-num 1)
			      old-pos))))))))

;*---------------------------------------------------------------------*/
;*    make-location-notifier ...                                       */
;*---------------------------------------------------------------------*/
(define (make-location-notifier fname line char string marker)
   (lambda (proc msg obj)
      ;; we first re-install default notifier
      (set! *error-notifier* #f)
      (let ((port (current-error-port)))
	 ;; we flush error-port
	 (flush-output-port port)
	 (newline port)
	 (let* ((space-string (if (>fx marker 0)
				  (make-string (-fx marker 1) #\space)
				  ""))
		(l (string-length string))
		(n-marker (if (>=fx marker l)
			      (if (=fx l 0)
				  0
				  (-fx l 1))
			      marker)))
	    ;; we ajust tabulation in space string.
	    (fix-tabulation! n-marker string space-string)
	    ;; we now print the error message
	    (print-cursor fname line char string space-string)
	    ;; we display the error message
	    (display "# *** ERROR:bigloo:" port)
	    (display-circle proc port)
	    (newline port)
	    (display "# " port)
	    (display-circle msg port)
	    (display " -- " port)
	    (display-circle obj port)
	    (newline port)
	    (notify-dump-trace-stack)
	    ;; we are now done, we flush
	    (flush-output-port (current-error-port))))))

;*---------------------------------------------------------------------*/
;*    warning/location-file ...                                        */
;*---------------------------------------------------------------------*/
(define (warning/location-file file-name location args)
   ;; we compute the message to print the location
   (let ((port (open-input-file file-name)))
      (if (not (input-port? port))
	  ;; we are enable to re-open the file, we just print a
	  ;; standard warning
	  (apply warning args)
	  ;; we readlines until we reach location
	  (let loop ((line-string (read-line port))
		     (line-num    1)
		     (old-pos     0))
	     (if (eof-object? line-string)
		 (begin
		    ;; an error we don't know how to print
		    (close-input-port port)
		    (apply warning args))
		 (if (>=fx (input-port-position port) location)
		     (begin
			(close-input-port port)
			(do-warn/location file-name
					  line-num
					  location
					  line-string
					  (-fx location old-pos)
					  args))
		     (let ((old-pos (input-port-position port)))
			(loop (read-line port)
			      (+fx line-num 1)
			      old-pos))))))))

;*---------------------------------------------------------------------*/
;*    do-warn/location ...                                             */
;*---------------------------------------------------------------------*/
(define (do-warn/location fname line char string marker args)
   (flush-output-port (current-output-port))
   (newline (current-error-port))
   (let ((old-length   (get-write-length))
	 (space-string (if (>fx marker 0)
			   (make-string (-fx marker 1) #\space)
			   ""))
	 (n-marker (if (>=fx marker (string-length string))
		       (-fx marker 1)
		       marker)))
      ;; we ajust tabulation in space string.
      (fix-tabulation! n-marker string space-string)
      ;; we now print the warning message
      (print-cursor fname line char string space-string)
      ;; we display the warning message
      (display "# *** WARNING:bigloo:" (current-error-port))
      (if (not (null? args))
	  (let ((port (current-error-port)))
	     (display-circle (car args) port)
	     (newline port)
	     (for-each (lambda (a)
			  (display-circle a (current-error-port)))
		       (cdr args))))
      (newline (current-error-port))
      (flush-output-port (current-error-port))))

;*---------------------------------------------------------------------*/
;*    fix-tabulation! ...                                              */
;*---------------------------------------------------------------------*/
(define (fix-tabulation! marker src dst)
   (let loop ((read (-fx marker 1)))
      (cond
	 ((=fx read -1)
	  'done)
	 ((char=? (string-ref src read) #\tab)
	  (string-set! dst read #\tab)
	  (loop (-fx read 1)))
	 (else
	  (loop (-fx read 1))))))

;*---------------------------------------------------------------------*/
;*    print-cursor ...                                                 */
;*---------------------------------------------------------------------*/
(define (print-cursor fname line char string space-string)
   (fprint (current-error-port)
	   "File \"" (nice-fname fname) "\", line " line ", character "
	   char ":"
	   #\Newline
	   "#" string #\Newline
	   "#"
	   space-string
	   "^"))

;*---------------------------------------------------------------------*/
;*    nice-fname ...                                                   */
;*    -------------------------------------------------------------    */
;*    We remove the current path to fname                              */
;*---------------------------------------------------------------------*/
(define (nice-fname fname)
   (let ((pwd   (pwd))
	 (dname (dirname fname)))
      (if (or (not (string? pwd))
	      (string=? dname ".")
	      (not (char=? (string-ref fname 0) #\/)))
	  fname
	  ;; we compute the two path lists
	  (let ((original-cmp-path (path->list dname)))
	     (let loop ((cmp-path original-cmp-path)
			(cur-path (path->list pwd)))
		(cond
		   ((null? cmp-path)
		    (if (null? cur-path)
			(basename fname)
			;; we have to complete with ../
			(let loop ((len (length cur-path))
				   (res (basename fname)))
			   (if (=fx len 0)
			       res
			       (loop (-fx len 1) (string-append "../" res))))))
		   ((null? cur-path)
		    (let loop ((path (reverse! cmp-path))
			       (res  (basename fname)))
		       (if (null? path)
			   res
			   (loop (cdr path)
				 (string-append (car path) "/" res)))))
		   ((string=? (car cur-path) (car cmp-path))
		    (loop (cdr cmp-path) (cdr cur-path)))
		   (else
		    (let loop ((path (reverse cmp-path))
			       (res  (basename fname)))
		       (if (null? path)
			   (if (eq? cmp-path original-cmp-path)
			       (string-append "/" res)
			       (let loop ((len (length cur-path))
					  (res res))
				  (if (=fx len 0)
				      res
				      (loop (-fx len 1)
					    (string-append "../" res)))))
			   (loop (cdr path)
				 (string-append (car path) "/" res)))))))))))

;*---------------------------------------------------------------------*/
;*    path->list ...                                                   */
;*---------------------------------------------------------------------*/
(define (path->list path)
   (let ((len  (let ((len (string-length path)))
		  (if (char=? (string-ref path (-fx len 1)) #\/)
		      (-fx len 1)
		      len)))
	 (init (if (char=? (string-ref path 0) #\/) 1 0)))
      (if (string=? path "/")
	  '()
	  (let loop ((read init)
		     (prev init)
		     (list '()))
	     (cond
		((=fx read len)
		 (reverse! (cons (substring path prev read) list)))
		((char=? (string-ref path read) #\/)
		 (loop (+fx read 1)
		       (+fx read 1)
		       (cons (substring path prev read) list)))
		(else
		 (loop (+fx read 1) prev list)))))))

;*---------------------------------------------------------------------*/
;*    find-runtime-type ...                                            */
;*    -------------------------------------------------------------    */
;*    This function tries to determine the type of an object in        */
;*    order to produce better type error messages.                     */
;*---------------------------------------------------------------------*/
(define (find-runtime-type obj)
   (cond
      ((fixnum? obj)
       "bint")
      ((flonum? obj)
       "real")
      ((string? obj)
       "bstring")
      ((symbol? obj)
       "symbol")
      ((keyword? obj)
       "keyword")
      ((char? obj)
       "bchar")
      ((boolean? obj)
       "bbool")
      ((null? obj)
       "bnil")
      ((epair? obj)
       "epair")
      ((pair? obj)
       "pair")
      ((class? obj)
       "class")
      ((vector? obj)
       "vector")
      ((tvector? obj)
       "tvector")
      ((struct? obj)
       "struct")
      ((procedure? obj)
       "procedure")
      ((input-port? obj)
       "input-port")
      ((output-port? obj)
       "output-port")
      ((binary-port? obj)
       "binary-port")
      ((cell? obj)
       "cell")
      ((foreign? obj)
       (string-append "foreign:" (symbol->string (foreign-id obj))))
      ((cnst? obj)
       "bcnst")
      ((socket? obj)
       "socket")
      ((process? obj)
       "process")
      ((custom? obj)
       "custom")
      ((opaque? obj)
       "opaque")
      ((object? obj)
       (let ((class  (object-class obj)))
	  ;; here we are very chicken here because want to ensure that
	  ;; this function is always correct, even if the system is not
	  ;; totally (or not correctly) intialized.
	  (if (class? class)
	      (let ((sym (class-name class)))
		 (if (symbol? sym)
		     (symbol->string sym)
		     "_"))
	      "_")))
      ((ucs2-string? obj)
       "ucs2string")
      ((ucs2? obj)
       "ucs2")
      ((elong? obj)
       "elong")
      ((llong? obj)
       "llong")
      (else
       (c-find-runtime-type obj))))

;*---------------------------------------------------------------------*/
;*    module-init-error ...                                            */
;*---------------------------------------------------------------------*/
(define (module-init-error current::string from::string)
   (fprint (current-error-port)
	   #"*** ERROR:" current ":Inconsistent module initialization\n"
	   "Module `" current "' is inconsistently initialized by module `" from "'.\n"
	   "At least of the two modules must be recompiled (see also -unsafev option).")
   (%exit -1))

;*---------------------------------------------------------------------*/
;*    bigloo-type-error ...                                            */
;*---------------------------------------------------------------------*/
(define (bigloo-type-error proc type obj)
   (error proc
	  (bigloo-type-error-msg "Type" type (find-runtime-type obj))
	  obj))

;*---------------------------------------------------------------------*/
;*    bigloo-type-error/location ...                                   */
;*---------------------------------------------------------------------*/
(define (bigloo-type-error/location proc type obj fname location)
   (error/location proc
		   (bigloo-type-error-msg "Type" type (find-runtime-type obj))
		   obj
		   fname
		   location))
