;;; -*- Mode: LISP; Syntax: COMMON-LISP; Base: 10.; Package: XIT -*-
;;;_____________________________________________________________________________
;;;
;;;                       System: XACT
;;;                       Module: Code Generation
;;;                       Version: 1.0
;;;
;;; Copyright (c): Forschungsgruppe DRUID, Juergen Herczeg
;;;                Universitaet Stuttgart
;;;
;;; File: /usr/local/lisp/xit/xam/generate-code.lisp
;;; File Creation Date: 06/16/92 15:45:04
;;; Last Modification Time: 12/09/92 11:17:49
;;; Last Modification By: Juergen Herczeg
;;;
;;;
;;; Changes (worth to be mentioned):
;;; ================================
;;;
;;;_____________________________________________________________________________

(in-package :xit)

(defvar *default-code-path* (system-pathname :xam "../xact/code/"))

(defun get-code-file ()
  (declare (special *default-code-path*))
  (let ((file-name (prompt "Enter file name:           "
			   :default *default-code-path*)))
    (when file-name
      (let ((file (find-file file-name)))
	(setq *default-code-path* file-name)
	(unless file (notify (format nil "File ~A does not exist!" file-name)))
	file))))

(defun make-code-file ()
  (declare (special *default-code-path*))
  (let ((file-name (prompt "Enter file name:           "
			   :default *default-code-path*)))
    (when file-name
      (let ((file (make-pathname :defaults file-name
				 :type (car pmds::*current-lisp-file-types*))))
	(setq *default-code-path* file-name)
	(if (probe-file file)
	    (when (confirm (format nil "File ~A exists! Overwrite?" file-name))
	      file)
	  file)))))

(defmethod load-code ((parent composite))
  (let ((file (get-code-file)))
    (when file
      (while-busy nil (read-code file parent)))))
  
(defun read-code (file-name &optional parent)
  (declare (special *parent-window*))
  (let ((stream (open file-name :direction :input)))
    (eval (read stream nil)) ;; package
    (eval (read stream nil)) ;; parent
    (when parent (setq *parent-window* parent))
    (do ((expression (read stream nil) (read stream nil))) ;; code
	((null expression) (close stream))
      (eval expression))))

(defmethod print-form (object)
  object)

(defmethod print-form ((object list))
  (if (eq (car object) 'find-window) ;; sort of a hack!
      object
    `',object))

(defmethod print-form ((object symbol))
  (cond ((null object) nil)
	((eq object t) t)
	((keywordp object) object)
	(t `',object)))
  
(defmethod generate-instantiation-code ((self basic-contact)
					&key (parent '*parent-window*))
  (let* ((init-list (generate-init-list self))
	 (quoted-init-list
	  (mapcar
	   #'print-form
	   init-list)))
  `(make-window
    ',(generate-class-name self)
    :parent ,parent
    ,@quoted-init-list)))

(defmethod generate-instantiation-code ((self shadow-border) &key parent)
  ;;shadow-borders are automatically instantiated by shadow-borders-mixin
  nil)

(defmethod code-generation-sort-function ((window1 basic-contact)
				          (window2 basic-contact))
  nil)

(defmethod code-generation-sort-function ((window1 popup-window)
				          (window2 basic-contact))
  t)

(defmethod generate-and-write-code ((self basic-contact))
  (generate-and-write-code (list self)))

(defmethod generate-and-write-code ((objects list))
  (let ((file (make-code-file)))
    (when file
      (while-busy nil
	      (apply #'write-code
		     file
		     (delete nil
			(mapcar #'generate-instantiation-code
				(sort objects
				      #'code-generation-sort-function))))))))
  
(defun write-code (file &rest code)
  (let ((saved-print-case *print-case*)
	(saved-print-circle *print-circle*)
	(stream (open file
                      :direction :output 
                      :if-exists :supersede 
                      :if-does-not-exist :create)))
    (setq *print-case* :downcase)
    (setq *print-circle* nil)
    (format stream ";------------------------------------------------------------------------------~%")
    (format stream ";                          Code generated by XACT ~%")
    (format stream ";------------------------------------------------------------------------------~%")
    (format stream "(in-package :xit)~%~%")
    (format stream "(setq *parent-window* *toplevel*)~%~%")
    (dolist (expr code)
      (pprint expr stream)
      (format stream "~%"))
    (format stream "~%~%")
    (close stream)
    (setq *print-circle* saved-print-circle)
    (setq *print-case* saved-print-case)))

