;;; CMPWT  Output routines.
;;;
;; 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)

(eval-when (compile eval)
  (require 'FASDMACROS "../cmpnew/fasdmacros.lsp")


(defmacro data-vector () `(car *data*))
(defmacro data-inits () `(second *data*))
(defmacro data-package-ops () `(third *data*))

)

(defun wt-comment (message &optional (symbol nil))
  (princ "
/*	" *compiler-output1*)
  (princ message *compiler-output1*)
  (when symbol
        (let ((s (symbol-name symbol)))
             (declare (string s))
             (dotimes** (n (length s))
                        (let ((c (schar s n)))
                             (declare (character c))
                             (unless (char= c #\/)
                                     (princ c *compiler-output1*))))))
  (princ "	*/
" *compiler-output1*)
  nil
  )

(defun wt1 (form)
  (cond ((or (stringp form) (integerp form) (characterp form))
         (princ form *compiler-output1*))
        ((or (typep form 'long-float)
             (typep form 'short-float))
         (format *compiler-output1* "~10,,,,,,'eG" form))
        (t (wt-loc form)))
  nil)

(defun wt-h1 (form)
  (cond ((consp form)
         (let ((fun (get (car form) 'wt)))
              (if fun
                  (apply fun (cdr form))
                  (cmpiler-error "The location ~s is undefined." form))))
        (t (princ form *compiler-output2*)))
  nil)

(defvar *fasd-data*)

(defun push-data-incf (x)
  (vector-push-extend (cons (si::hash-equal x -1000) x) (data-vector))
  (incf *next-vv*))

(defun wt-data1 (expr)
  (let ((*print-radix* nil)
        (*print-base* 10)
        (*print-circle* t)
        (*print-pretty* nil)
        (*print-level* nil)
        (*print-length* nil)
        (*print-case* :downcase)
        (*print-gensym* t)
        (*print-array* t)
	;;This forces the printer to add the float type in the .data file.
	(*READ-DEFAULT-FLOAT-FORMAT* t) 
        (si::*print-package* t)
        (si::*print-structure* t))
    (terpri *compiler-output-data*)
    (prin1 expr *compiler-output-data*)))

(defun verify-data-vector(vec &aux v)
  (dotimes (i (length vec))
	   (setq v (aref vec i))
	   (let ((has (si::hash-equal (cdr v) -1000)))
	     (cond ((not (eql (car v) has))
		    (cmpwarn "A form or constant:~% ~s ~%has changed during the eval compile procedure!.~%  The changed form will be the one put in the compiled file" (cdr v)))))
	   (setf (aref vec i) (cdr v)))
  vec
  )

(defun add-init (x &optional endp)
  (let ((tem (cons (si::hash-equal x -1000) x)))
    (setf (data-inits)
		    (if endp
			(nconc (data-inits) (list tem))
		      (cons tem (data-inits) )))
    x))

(defun wt-data-file ()
  (verify-data-vector (data-vector))
  (let* ((vec (coerce (nreverse (data-inits)) 'vector)))
    (verify-data-vector vec)
    (setf (aref (data-vector) (- (length (data-vector)) 1))
	  (cons 'si::%init vec))
    (setf (data-package-ops) (nreverse (data-package-ops)))
    (cond (*fasd-data*
	   (wt-fasd-data-file))
	  (t
	   (format *compiler-output-data* "       ~%#(")
	   (dolist (v (data-package-ops))
		   (format *compiler-output-data* "#! ")
		   (wt-data1 v))
	   (wt-data1 (data-vector))
	   (format *compiler-output-data* "~%)~%")
	   ))))

(defun wt-fasd-data-file ( &aux (x (data-vector)) tem)
;  (si::find-sharing-top (data-package-ops) (fasd-table (car *fasd-data*)))
  (si::find-sharing-top x (fasd-table (car *fasd-data*)))
  (cond ((setq tem  (data-package-ops))
	 (dolist (v tem)
	 (put-op d_eval_skip  *compiler-output-data*)
	 (si::write-fasd-top v (car *fasd-data*)))))
  (si::write-fasd-top x (car *fasd-data*))
;  (sloop::sloop for (k v) in-table (fasd-table (car *fasd-data*))
;		when (>= v 0) do (print (list k v)))
  (si::close-fasd (car *fasd-data*)))
(defun wt-data-begin ())
(defun wt-data-end ())
(defun wt-data-package-operation (x)
  (push x (data-package-ops)))

(defmacro wt (&rest forms &aux (fl nil))
  (dolist** (form forms (cons 'progn (reverse (cons nil fl))))
    (if (stringp form)
        (push `(princ ,form *compiler-output1*) fl)
        (push `(wt1 ,form) fl))))

(defmacro wt-h (&rest forms &aux (fl nil))
  (cond ((endp forms) '(princ "
" *compiler-output2*))
        ((stringp (car forms))
         (dolist** (form (cdr forms)
                         (list* 'progn `(princ ,(concatenate 'string "
" (car forms)) *compiler-output2*) (reverse (cons nil fl))))
                   (if (stringp form)
                       (push `(princ ,form *compiler-output2*) fl)
                       (push `(wt-h1 ,form) fl))))
        (t (dolist** (form forms
                           (list* 'progn '(princ "
" *compiler-output2*) (reverse (cons nil fl))))
                     (if (stringp form)
                         (push `(princ ,form *compiler-output2*) fl)
                         (push `(wt-h1 ,form) fl))))))

(defmacro wt-nl (&rest forms &aux (fl nil))
  (cond ((endp forms) '(princ "
	" *compiler-output1*))
        ((stringp (car forms))
         (dolist** (form (cdr forms)
                         (list* 'progn `(princ ,(concatenate 'string "
	" (car forms)) *compiler-output1*) (reverse (cons nil fl))))
                   (if (stringp form)
                       (push `(princ ,form *compiler-output1*) fl)
                       (push `(wt1 ,form) fl))))
        (t (dolist** (form forms
                           (list* 'progn '(princ "
	" *compiler-output1*) (reverse (cons nil fl))))
                     (if (stringp form)
                         (push `(princ ,form *compiler-output1*) fl)
                         (push `(wt1 ,form) fl))))))

(defmacro wt-nl1 (&rest forms &aux (fl nil))
  (cond ((endp forms) '(princ "
" *compiler-output1*))
        ((stringp (car forms))
         (dolist** (form (cdr forms)
                         (list* 'progn `(princ ,(concatenate 'string "
" (car forms)) *compiler-output1*) (reverse (cons nil fl))))
                   (if (stringp form)
                       (push `(princ ,form *compiler-output1*) fl)
                       (push `(wt1 ,form) fl))))
        (t (dolist** (form forms
                           (list* 'progn '(princ "
" *compiler-output1*) (reverse (cons nil fl))))
                     (if (stringp form)
                         (push `(princ ,form *compiler-output1*) fl)
                         (push `(wt1 ,form) fl))))))