;;;;
;;;; utils.stk	-- Compiler Utilities
;;;;
;;;; Copyright © 2000-2007 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;;           Author: Erick Gallesio [eg@unice.fr]
;;;;    Creation date: 14-Mar-2001 13:57 (eg)
;;;; Last file update: 25-Jan-2007 19:09 (eg)
;;;;



(define (panic . l)
  (apply error 'panic (string-append "*** PANIC *** "  (car l)) (cdr l)))


(define (%path-without-cwd path)
  (let ((cwd (getcwd)))
    (if (eq? (string-index cwd path) 0)
	(substring path
		   (+  1 (string-length cwd))
		   (string-length path))
	path)))

;;; ----------------------------------------------------------------------
;;;	compiler-error ...
;;; ----------------------------------------------------------------------
(define (compiler-error where who fmt . l)
  (let* ((where (if (eq? where (void)) "" (format "~A: " where)))
	 (loc   (if (%epair? who)
		    (format "~A:~A: "
			    (%path-without-cwd (%epair-file who))
			    (%epair-line who))
		    "")))
    (if *compiler-port*
	;; Compiling a file
	(apply format
	       (current-error-port)
	       (format "~AError: ~A~A\n" loc where fmt)
	       l)
	;; Interactive compilation
	(apply error
	       (string-append where fmt)
	       l))))

;;; ----------------------------------------------------------------------
;;;	compiler-warning ...
;;; ----------------------------------------------------------------------
(define (compiler-warning where who fmt . l)
  (let* ((where (if (eq? where (void)) "" (format "~A: " where)))
	 (loc   (if (%epair? who)
		    (format "~A:~A: "
			    (%path-without-cwd (%epair-file who))
			    (%epair-line who))
		    "")))
    (if (or #t *compiler-port*)
	;; Compiling a file
	(apply format
	       (current-error-port)
	       (format "~Awarning: ~A~A\n" loc where fmt)
	       l)
	;; Interactive compilation
	(apply format
	       (current-error-port)
	       (format "**** Warning;\n~A~A\n" where fmt)
	       l))))

;;//(define (%compiler-message kind where fmt l)
;;//  ;; Write an Emacs compatible header
;;//  (when *compiler-port*
;;//    (format (current-error-port)
;;//	    "~A:~A: ~A "
;;//	    (port-file-name *compiler-port*)
;;//	    (port-current-line *compiler-port*)
;;//	    kind))
;;//
;;//  (let ((location (if (eq? where (void)) "" (format #f " ~A:" where))))
;;//    (apply format
;;//	   (current-error-port)
;;//	   (format #f "~A ~A\n" location fmt)
;;//	   l)))
;;//
;;//
;;//(define (compiler-warning where fmt . l)
;;//  (%compiler-message "warning" where fmt l))


(define symbol-bound?
  (let ((unbound (list 'unbound)))
    (lambda (symbol)
      (not (eq? (symbol-value* symbol (current-module) unbound) unbound)))))


(define (unquote . l)
  (error 'unquote "used outside of a quasiquote context"))

(define (unquote-splicing . l)
  (error 'unquote-splicing "used outside of a quasiquote context"))