;;; CMPUTIL  Miscellaneous Functions.
;;;
;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa

;; This file is part of GNU Common Lisp, herein referred to as GCL
;;
;; GCL is free software; you can redistribute it and/or modify it under
;;  the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; 
;; GCL 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 Library General Public 
;; License for more details.
;; 
;; You should have received a copy of the GNU Library General Public License 
;; along with GCL; see the file COPYING.  If not, write to the Free Software
;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.


(in-package 'compiler)

(export '(*suppress-compiler-warnings*
          *suppress-compiler-notes*
          *compiler-break-enable*))

(defmacro safe-compile (&rest forms) `(when *safe-compile* ,@forms))

(defvar *current-form* '|compiler preprocess|)
(defvar *first-error* t)
(defvar *error-count* 0)

(defconstant *cmperr-tag* (cons nil nil))

(defun cmperr (string &rest args &aux (*print-case* :upcase))
  (print-current-form)
  (format t "~&;;; ")
  (apply #'format t string args)
  (incf *error-count*)
  (throw *cmperr-tag* '*cmperr-tag*))

(defmacro cmpck (condition string &rest args)
  `(if ,condition (cmperr ,string ,@args)))

(defun too-many-args (name upper-bound n &aux (*print-case* :upcase))
  (print-current-form)
  (format t
          ";;; ~S requires at most ~R argument~:p, ~
          but ~R ~:*~[were~;was~:;were~] supplied.~%"
          name
          upper-bound
          n)
  (incf *error-count*)
  (throw *cmperr-tag* '*cmperr-tag*))

(defun too-few-args (name lower-bound n &aux (*print-case* :upcase))
  (print-current-form)
  (format t
          ";;; ~S requires at least ~R argument~:p, ~
          but only ~R ~:*~[were~;was~:;were~] supplied.~%"
          name
          lower-bound
          n)
  (incf *error-count*)
  (throw *cmperr-tag* '*cmperr-tag*))

(defvar *suppress-compiler-warnings* nil)

(defun cmpwarn (string &rest args &aux (*print-case* :upcase))
  (unless *suppress-compiler-warnings*
    (print-current-form)
    (format t ";; Warning: ")
    (apply #'format t string args)
    (terpri))
  nil)

(defvar *suppress-compiler-notes* nil)

(defun cmpnote (string &rest args &aux (*print-case* :upcase))
  (unless *suppress-compiler-notes* 
    (terpri)
    (format t ";; Note: ")
    (apply #'format t string args))
  nil)

(defun print-current-form ()
  (when *first-error*
        (setq *first-error* nil)
        (fresh-line)
        (cond
         ((and (consp *current-form*)
               (eq (car *current-form*) 'si:|#,|))
          (format t "; #,~s is being compiled.~%" (cdr *current-form*)))
         (t
          (let ((*print-length* 2)
                (*print-level* 2))
               (format t "; ~s is being compiled.~%" *current-form*)))))
  nil)

(defun undefined-variable (sym &aux (*print-case* :upcase))
  (print-current-form)
  (format t
          ";; The variable ~s is undefined.~%~
           ;; The compiler will assume this variable is a global.~%"
          sym)
  nil)

(defun baboon (&aux (*print-case* :upcase))
  (print-current-form)
  (format t ";;; A bug was found in the compiler.  Contact Taiichi.~%")
  (incf *error-count*)
  (break)
;  (throw *cmperr-tag* '*cmperr-tag*)
)

;;; Internal Macros with type declarations

(defmacro dolist* ((v l &optional (val nil)) . body)
  (let ((temp (gensym)))
  `(do* ((,temp ,l (cdr ,temp)) (,v (car ,temp) (car ,temp)))
	((endp ,temp) ,val)
	(declare (object ,v))
	,@body)))

(defmacro dolist** ((v l &optional (val nil)) . body)
  (let ((temp (gensym)))
  `(do* ((,temp ,l (cdr ,temp)) (,v (car ,temp) (car ,temp)))
	((endp ,temp) ,val)
	(declare (object ,temp ,v))
	,@body)))

(defmacro dotimes* ((v n &optional (val nil)) . body)
  (let ((temp (gensym)))
   `(do* ((,temp ,n) (,v 0 (1+ ,v)))
	 ((>= ,v ,temp) ,val)
	 (declare (fixnum ,v))
	 ,@body)))

(defmacro dotimes** ((v n &optional (val nil)) . body)
  (let ((temp (gensym)))
   `(do* ((,temp ,n) (,v 0 (1+ ,v)))
	 ((>= ,v ,temp) ,val)
	 (declare (fixnum ,temp ,v))
	 ,@body)))

(defun cmp-eval (form)
  (let ((x (multiple-value-list (cmp-toplevel-eval `(eval ',form)))))
    (if (car x)
        (let ((*print-case* :upcase))
          (incf *error-count*)
          (print-current-form)
          (format t
                  ";;; The form ~s was not evaluated successfully.~%~
                  ;;; You are recommended to compile again.~%"
                  form)
          nil)
        (values-list (cdr x)))))


;(si::putprop 'setf 'c1setf 'c1special)

;;The PLACE may be a local macro, so we must take care to expand it
;;before trying to call the macro form of setf, or an error will

;(defun c1setf (args &aux fd)
;  (cond ((and
;	   (consp (car args))
;	   (symbolp (caar args))
;	   (setq fd (cmp-macro-function (caar args))))
;	 (c1expr `(setf ,(cmp-expand-macro fd (caar args) (cdar args))
;			,@ (cdr args))))
;	(t       
;         (c1expr (cmp-expand-macro (macro-function 'setf)
;				   'setf
;				   args)))))

(defun cmp-macroexpand (form &aux env)
  ;;Obtain the local macro environment for expansion.
  (dolist (v *funs*)
	  (if (consp v) (push (list (car v) 'macro (cadr v)) env)))
  (if env (setq env (list nil (nreverse env) nil)))
  (let ((x (multiple-value-list
	     (cmp-toplevel-eval `(macroexpand ',form ',env)))))
    (if (car x)
        (let ((*print-case* :upcase))
          (incf *error-count*)
          (print-current-form)
          (format t
                  ";;; The macro form ~s was not expanded successfully.~%"
                  form)
          `(error "Macro-expansion of ~s failed at compile time." ',form))
        (cadr x))))

(defun cmp-macroexpand-1 (form &aux env)
  (dolist (v *funs*)
	  (if (consp v) (push (list (car v) 'macro (cadr v)) env))) 
  (let ((x (multiple-value-list (cmp-toplevel-eval `(macroexpand-1 ',form
								   ',env)))))
    (if (car x)
        (let ((*print-case* :upcase))
          (incf *error-count*)
          (print-current-form)
          (format t
                  ";;; The macro form ~s was not expanded successfully.~%"
                  form)
          `(error "Macro-expansion of ~s failed at compile time." ',form))
        (cadr x))))

(defun cmp-expand-macro (fd fname args &aux env)
  (dolist (v *funs*)
	  (if (consp v) (push (list (car v) 'macro (cadr v)) env)))
  (and *record-call-info* (add-macro-callee fname))
  (if env (setq env (list nil (nreverse env) nil)))
  (let ((x (multiple-value-list
            (cmp-toplevel-eval
             `(funcall *macroexpand-hook* ',fd ',(cons fname args) ',env)))))
    (if (car x)
        (let ((*print-case* :upcase))
          (incf *error-count*)
          (print-current-form)
          (format t
            ";;; The macro form (~s ...) was not expanded successfully.~%"
            fname)
          `(error "Macro-expansion of ~s failed at compile time."
                  ',(cons fname args)))
        (cadr x))))

(defvar *compiler-break-enable* nil)

(defun cmp-toplevel-eval (form)
   (let* ((si::*ihs-base* si::*ihs-top*)
          (si::*ihs-top* (1- (si::ihs-top)))
          (*break-enable* *compiler-break-enable*)
          (si::*break-hidden-packages*
           (cons (find-package 'compiler)
                 si::*break-hidden-packages*)))
         (si:error-set form)))

(dolist (v '(si::cdefn lfun inline-safe inline-unsafe
		       inline-always c1conditional c2 c1 c1+ co1
		       si::structure-access co1special
		       top-level-macro t3 t2 t1 package-operation))
	   (si::putprop v t 'compiler-prop ))

(defun  compiler-def-hook (symbol code) symbol code nil)

(defun compiler-clear-compiler-properties (symbol code)
  code
  (let ((v (symbol-plist symbol)) w)
    (tagbody
      top
      (setq w (car v))
      (cond ((and (symbolp w)
		  (get w 'compiler-prop))

	     (setq v (cddr v))
	     (remprop symbol w))
	    (t (setq v (cddr v))))
      (or (null v) (go top)))
    (compiler-def-hook symbol code)
    ))

;hi