;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: OPAL; Base: 10 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;         The Garnet User Interface Development Environment.      ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This code was written as part of the Garnet project at          ;;;
;;; Carnegie Mellon University, and has been placed in the public   ;;;
;;; domain.  If you are using this code or any part of Garnet,      ;;;
;;; please contact garnet@cs.cmu.edu to be put on the mailing list. ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; CHANGE LOG:
;;;
;;; 10/03/93 amickish - Added Extract-Image-Args so that opal:Make-Image can
;;;            take arbitrary arguments
;;; 09/30/93 amickish - Added Bruno Haible's industrial-strength DIRECTORY-P.
;;; 09/22/93 amickish - In opal:make-image, (1) ignored gc for LispWorks
;;;            and CLISP, (2) only copied readtable for Allegro
;;; 09/20/93 amickish - Called system:os-wait for Allegro in opal:shell-exec
;;; 09/06/93 amickish - Changed opal:directory-p's command-string to use
;;;            TEST -d; Changed shell for opal:shell-exec to /bin/sh
;;; 09/03/93 Bruno Haible - Added #+clisp switches
;;; 08/17/93 amickish - Removed redundant "csh" from directory-p; added
;;;            lispworks switches for opal:make-image
;;; 08/15/93 rajan - Added directory-p
;;; 08/13/93 amickish - When saving Allegro image, *do* read init file;
;;;            copied *readtable* into user::Garnet-Readtable and used
;;;            value in excl:*cl-default-special-bindings*
;;; 05/04/93 amickish - Removed "total" GC for Lucid in opal:make-image
;;; 04/22/93 amickish - Added Get-Garnet-Bitmap
;;; 04/20/93 amickish - Added GC option to make-image
;;; 03/30/93 amickish - Added RETURN-FROM in make-image to jump out of save
;;;            function in CMUCL when restarting
;;; 03/05/93 amickish - Created with shell-exec and make-image

(in-package "OPAL" :use '("LISP" "KR"))

(export '(shell-exec make-image get-garnet-bitmap directory-p))

(defvar garnet-image-date NIL)

(defun shell-exec (command)
  (let ((the-stream
	 #+allegro
	 (excl:run-shell-command command :wait NIL :output :stream
				 :error-output :stream)
	 #+lucid
	 (lcl:run-program "/bin/sh" :arguments (list "-c" command)
			  :wait NIL :output :stream :error-output :stream)
	 #+cmu
	 (ext:process-output (ext:run-program "/bin/sh" (list "-c" command)
					      :wait NIL :output :stream))
	 #+lispworks
	 (foreign::open-pipe command :shell-type "/bin/sh" :buffered t)
	 #+clisp
	 (make-pipe-input-stream (string command))
	 #-(or allegro lucid cmu lispworks clisp)
	 (error "Don't know how to execute shell functions in this lisp")
	 )
        (output-string (make-array '(0)
			:element-type 'string-char
			:fill-pointer 0 :adjustable T)))
    (do ((next-char (read-char the-stream NIL :eof)
                    (read-char the-stream NIL :eof)))
        ((eq next-char :eof) #+clisp (close the-stream)
	                     #+allegro (system:os-wait))
      (vector-push-extend next-char output-string))
    output-string))


(defun garnet-restart-function ()
  (format t "*** Restarting image created with opal:make-image ***~%")
  (if (boundp 'garnet-image-date)
      (format t "*** Image creation date: ~A ***~%" garnet-image-date))
  (opal:reconnect-garnet)
  )


(defun Extract-Image-Args (args)
  (let ((quit NIL)
	(gc T)
	(verbose T)
	(extra-args NIL))
    (do* ((args-aux args (cddr args-aux))
	  (arg1 (first args-aux) (first args-aux))
	  (arg2 (second args-aux) (second args-aux)))
	 ((null args-aux))
      (case arg1
	(:quit (setf quit arg2))
	(:verbose (setf verbose arg2))
	(:gc (setf gc arg2))
	(T (setf extra-args (append extra-args (list arg1 arg2))))))
    (values quit gc verbose extra-args)))


(defun make-image (filename &rest args)
  #-(or cmu allegro lucid lispworks clisp)
    (error "Don't know how to automatically save an image for this lisp.
Please consult your lisp's user manual for instructions.~%")

  #+clisp (declare (compile))
  
  (multiple-value-bind (quit gc verbose extra-args)
      (Extract-Image-Args args)
  ;; When the image is restarted, we want *readtable* to be restored to its
  ;; current value, instead of being reinitialized to the default.  This will
  ;; keep the #k<> and #f() reader macros active in the saved image.
  #+allegro
  (progn  
    (if verbose (format t "~%Copying readtable..."))
    (copy-readtable *readtable* user::Garnet-Readtable)
    (setf (cdr (assoc '*readtable* excl:*cl-default-special-bindings*))
          'user::Garnet-Readtable)
    (if verbose (format t "copied.~%")))

  (if verbose (format t "Disconnecting Garnet..."))
  (opal:disconnect-garnet)
  (if verbose (format t "disconnected.~%"))

  (setf garnet-image-date (inter::time-to-string))

  ;; LispWorks and CLISP GC are done below, during the save
  #+(or allegro lucid cmu)
  (when gc
    (if verbose (format t "Garbage collecting..."))
    #+allegro (excl:gc T)
    #+cmu     (ext:gc T)
    ; There is no equivalent of "total" garbage collection in Lucid
    #+lucid   (lcl:gc)
    (if verbose (format t "collected.~%")))
  
  (if verbose (format t "Saving image..."))
  #+allegro
  (apply #'excl:dumplisp :name filename
	                 :restart-function #'garnet-restart-function
			 :checkpoint NIL
			 :read-init-file T
			 extra-args)
  #+lucid
  (apply #'lcl:disksave filename
	                :restart-function #'garnet-restart-function
			extra-args)
  #+cmu
  (apply #'ext:save-lisp filename
	                 :init-function #'(lambda ()
					    (garnet-restart-function)
					    #-cmu17
					    (return-from make-image T)
					    #+cmu17
					    (cl::%top-level))
			 extra-args)
  #+lispworks
  (apply #'system:save-image filename
	                     :gc gc
			     :restart-function #'garnet-restart-function
			     extra-args)
  #+CLISP
  (let* ((old-driver *driver*)
	 (*driver* #'(lambda ()
		       (setq *driver* old-driver)
		       (garnet-restart-function)
		       (funcall *driver*))))
    (apply #'saveinitmem extra-args)
    (rename-file "lispinit.mem" filename))
  
  (if verbose (format t "saved.~%"))

  (cond
    (quit
     (if verbose (format t "Quitting lisp...~%"))
     #+allegro (excl:exit)
     #+lucid (lcl:quit)
     #+cmu (ext:quit)
     #+lispworks (system:bye)
     #+clisp (exit)
     )
    (t
     (if verbose (format t "Reconnecting Garnet..."))
     (opal:reconnect-garnet)
     (if verbose (format t "reconnected.~%"))
     ))
  ))


(defun Get-Garnet-Bitmap (bitmapname)
  (opal:read-image (merge-pathnames bitmapname
				    user::Garnet-Bitmap-PathName)))



;;; If the -d test is true, shell-exec returns "1".  Otherwise, it returns "".
;;; This syntax works for all kinds of Unix shells: sh, csh, ksh, tcsh, ...
;;;
(defun directory-p (pathname)
  #+clisp
  ;; 1. Needn't call a shell if we can do the test ourselves.
  ;; 2. In case pathname contains Latin-1 characters. clisp is 8 bit clean,
  ;;    while most Unix shells aren't.
  (gu:probe-directory pathname)

  #-clisp
  ;; command-string is the string that's going to be executed.
  (let ((command-string
	 (concatenate 'string "test -d " pathname " && echo 1")))
    (unless (equal "" (shell-exec command-string))
	    T)))


;; This is an industrial-strength version of opal:directory-p.  The difference
;; is that extra work is done to ensure that single and double quotes are
;; passed to the shell correctly.  Since it does more work, only use this
;; version if you find you really need it.  This code was contributed by
;; Bruno Haible.
#+comment
(defun directory-p (pathname)
  ;; Must quote the pathname since Unix shells interpret characters like
  ;; #\Space, #\', #\<, #\>, #\$ etc. in a special way. This kind of quoting
  ;; should work unless the pathname contains #\Newline and we call csh.
  (flet ((shell-quote (string) ; surround a string by single quotes
	   (let ((qchar nil) ; last quote character: nil or #\' or #\"
		 (qstring (make-array 10 :element-type 'string-char
				      :adjustable t :fill-pointer 0)))
	     (map nil #'(lambda (c)
			  (let ((q (if (eql c #\') #\" #\')))
			    (unless (eql qchar q)
			      (when qchar (vector-push-extend qchar qstring))
			      (vector-push-extend (setq qchar q) qstring))
			    (vector-push-extend c qstring)))
		  string)
	     (when qchar (vector-push-extend qchar qstring))
	     qstring)))
    ;; command-string is the string that's going to be executed.
    (let ((command-string
	   (concatenate 'string "test -d " (shell-quote pathname) " && echo 1")))
      (unless (equal "" (shell-exec command-string))
	T))))
