;; *************************************************************************************** ;;
;; lisp debug v0.8  : source level debugger for lisp                                             ;;
;; Copyright (C) 1998 Marc Mertens                                                         ;;
;;                                                                                         ;;
;;     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            ;;
;;                                                                                         ;;
;; Contact me on mmertens@akam.be                                                          ;;
;; ********************************************************************************************
;;
;; The following functions must be defined to get a link to the interface of the debugger
;;
;; (process-incoming)  ;; Should read the commandos from the interface and process them
;; (send-command)      ;; Should send the commandos from the lisp system to the server
;; (start-interface)   ;; should start the interface
;; (stop-interface)    ;; Should stop the interface
;; (get-unix-env "var" "default") ;; Get unix environment var
;;
;; ********************************************************************************************

;; ****************************************************************************************
;; C interface to CMU LISP
;; ****************************************************************************************

(in-package "DEBUGGER")



(declaim (optimize (speed 3) (safety 0)) (extensions:optimize-interface (speed 3)))

;; ****************************************************************************************
;; Constants used by CMU LISP
;; ****************************************************************************************

(defconstant %%SIGUSR1%% 10)


;; ***************************************************************************************
;; Global variables used by CMU LISP
;; ***************************************************************************************

(defparameter **stream-in**  0)
(defparameter **stream-out** 0)
(defparameter **pid-interface** 0)
(defparameter **callback-handler** NIL)


;; ************************************************************************************** ;;
;; Function to start as a child the TCL/TK interface. The child is connected by two pipes ;;
;; (in/out) to the current lisp parent. The outgoing pipe is **pipe-out** , the ingoing   ;;
;; pipe is **pipe-in**        "ddddddd"                                                            ;;
;; "Test of quotes "
;; ************************************************************************************** ;;

(defun start-interface ()
  "(start-interface) , starts interface for debugger and initialize pipes"
  ;; Stop existing interface if it exist
  (stop-interface)
  ;; Start a process and connect to unix socket
  (let ((program (extensions::run-program "interface" NIL :wait NIL)))
    (loop (when (probe-file "/tmp/lispdebugger") (return)) (sleep 1))
    (let ((sockfd (extensions::connect-to-unix-socket "/tmp/lispdebugger")))
      (setf **stream-in** (extensions::make-fd-stream sockfd :input T :buffering :full))
      (setf **callback-handler** (extensions::add-fd-handler sockfd :input #'process-incoming))
      (setf **stream-out** (extensions::make-fd-stream sockfd :output T :buffering :none))
      (setf **pid-interface** (extensions::process-pid program)))))


;; ************************************************************************************** ;;
;; Close the in and out pipes and kill's the child                                        ;;
;; ************************************************************************************** ;;


(defun stop-interface ()
  "(stop-interface) , called to clean up the interface"
  (unwind-protect
      (progn
	(when **callback-handler** (system::remove-fd-handler **callback-handler**))
	(when (not (eql **stream-in** 0)) (close **stream-in**))
	(when (not (eql **stream-out** 0)) (close **stream-out**))
	(when (not (eql **pid-interface** 0)) (unix::unix-kill **pid-interface** %%SIGUSR1%%)))
    	(when (probe-file "/tmp/lispdebugger") (delete-file "/tmp/lispdebugger"))
    (setf **stream-in** 0)
    (setf **stream-out** 0)
    (setf **pid-interface** 0)
    (setf **callback-handle** NIL)
    (end-debug-eventloop)))



;; ***************************************************************************
;; The only moment , the user interface sends a command to LISP is when
;; loading a file in the debugger , initiated from the user interface , 
;; this is when process-incoming is called.
;; ***************************************************************************

(defun process-incoming (&optional fd)
  (if (streamp **stream-in**)
      (let ((command (read **stream-in** NIL NIL)))
	(if (null command)
	    (stop-interface)
	  (eval command)))
    (stop-interface)))



;; ***************************************************************************
;; Main interface to the lisp system
;; ***************************************************************************

(defun send-command (command &rest arg-lst)
  (when (streamp **stream-out**)
    (princ command **stream-out**)
    (mapc #'(lambda (arg)
	      (princ " " **stream-out**)
	      (cond ((stringp arg)
		     (princ (length arg) **stream-out**)
		     (princ " " **stream-out**)
		     (princ arg **stream-out**))
		    (T
		     (princ arg **stream-out**))))
	  arg-lst)
    (terpri **stream-out**)))


;; ***************************************************************************
;; Get unix environment variables
;; ***************************************************************************

(defun get-unix-env (var default)
  (cond ((rest (assoc (read-from-string (format nil ":~A" var)) USER::*ENVIRONMENT-LIST*)))
	(t default)))

  