;; *************************************************************************************** ;;
;; 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 environment variable of unix
;;
;; ********************************************************************************************





;; ****************************************************************************************
;; Load the tkl.o package to modify the definition of sigusr1-interrupt to work with interupts
;; This is needed for Linux because SIGIO is not working yet SIGHH
;; If you want to port this to another machine then you need to use the SIGIO code
;; like set-sigio-for-fd , to be signalled for input on a socket
;; *****************************************************************************************

(load "/usr/local/lib/gcl-2.2.2/gcl-tk/tkl.o")

;; *****************************************************************************************
;; Redefines system::sigusr1-interrupt
;; *****************************************************************************************

(defun system::sigusr1-interrupt (x)
  (cond (TK::*sigusr1*
         (setq TK::*sigusr1* :received))
	;; Added a new piece of code to read in commands send by debugger
	((debugger::check-input))
	;; End of addition
        (TK::*tk-connection*
         (let ((TK::*sigusr1* t))
           (TK::dformat "Received SIGUSR1. ~a"
                    (if (> (si::check-state-input
                            (TK::tk-connection-fd TK::*tk-connection*) 0) 0) ""
                      "No Data left there."))
           ;; we put 4 here to wait for a bit just in case
           ;; data comes
           (si::check-state-input
                            (TK::tk-connection-fd TK::*tk-connection*) 4 )
           (TK::read-and-act nil)))))                              

;; *****************************************************************************************
;; Package stuff
;; *****************************************************************************************

(in-package "DEBUGGER")

;; *****************************************************************************************
;; Process incoming data
;; *****************************************************************************************

(defun process-incoming ()
  (check-input))

;; ******************************************************************************************
;; Global variables used by GCL
;; ******************************************************************************************
;; ******************************************************************************************
;; C interface
;; ******************************************************************************************

;; Headers

(clines "#include <sys/types.h>")
(clines "#include <sys/socket.h>")
(clines "#include <signal.h>")
(clines "#include <stdio.h>")
(clines "#include <sys/un.h>")
(clines "#include <sys/time.h>")
(clines "#include <unistd.h>")
(clines "#include <fcntl.h>")

;; Global variables

(clines "static int sockfd;");

;; C-functions

(clines "void connect_to_server ()
            {
             int len;
             struct sockaddr_un address;
             int result;

             /* Create a socket */
             sockfd = socket(AF_UNIX,SOCK_STREAM,0);
             /* Name the socket */
             address.sun_family=AF_UNIX;
             strcpy(address.sun_path,\"/tmp/lispdebugger\");
             len = sizeof(address);
             /* Connect to socket */
             result = connect(sockfd,(struct sockaddr *)&address,len);
            }")


(clines "char read_byte_from_server ()
          {
           char ch;
           read(sockfd,&ch,1);
           return ch;
          }")

(clines "int check_input_from_server ()
           {
            struct timeval timeout;
            int result;
            fd_set inputs;

            timeout.tv_sec=0;
            timeout.tv_usec=1;

            FD_ZERO(&inputs);
            FD_SET(sockfd,&inputs);

            result=select(FD_SETSIZE,&inputs,(fd_set *)0,(fd_set *)0,&timeout);
            return result;
           }")

(clines "void write_byte_to_server (char ch)
           {
            write(sockfd,&ch,1);
           }")


(defentry connect-to-server () (void "connect_to_server"))

(defentry write-byte-to-server (char) (void "write_byte_to_server"))

(defentry read-byte-from-server () (char "read_byte_from_server"))

(defentry check-input-from-server () (int "check_input_from_server"))

(defentry getpid () (int "getpid"))


;; *******************************************************************************
;; Check the sstatus of the input socket , if something is waiting , read and
;; process the command and returns T , otherwise just returns NIL to let the
;; TCL/TK system do its work
;; *******************************************************************************

(defun check-input ()
  (cond ((zerop (check-input-from-server)) ;; No input from debugger , so the signal came from TCL/TK
	 NIL)
	(T
	 ;; We have a signal from the debugger , so input is waiting , read the bytes until we encounter a
	 ;; newline
	 (let ((str "")
	       (chr))
	   (setf str (with-output-to-string (h)
					    (loop
					      (setf chr (read-byte-from-server))
					      (when (char= chr #\newline)
						(return))
					      (princ chr h))))
	   (eval (read-from-string str NIL NIL)))
	 T)))


;; ********************************************************************************
;; Start the graphical interface of the debugger
;; ********************************************************************************

(defun start-interface ()
  "(start-interface) , starts interface for debugger and initialize pipes"
  ;; Stop existing interface if it exist
  (stop-interface)
  ;; Start the interface
  (system (format NIL "interface ~A&" (getpid)))
  ;; Wait until the program has started and is waiting for socket connection
  (loop (when (probe-file "/tmp/lispdebugger") (return)) (sleep 1))
  ;; Connect to socket of server
  (connect-to-server))

  
(defun stop-interface()
  (unwind-protect
      (progn
	(when (probe-file "/tmp/lispdebugger") (delete-file "/tmp/lispdebugger")))
    (end-debug-eventloop)
    )
  )



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

(defun send-command (command &rest arg-lst)
  (let ((str ""))
    (setf str (with-output-to-string (h)
				     (princ command h)
				     (mapc #'(lambda (arg)
					       (princ " " h)
					       (cond ((stringp arg)
						      (princ (length arg) h)
						      (princ " " h)
						      (princ arg h))
						     (T
						      (princ arg h))))
					   arg-lst)
				     (terpri h)))
    (do ((i 0 (1+ i)) (l (length str)))
	((>= i l))
      (write-byte-to-server (aref str i)))))




;; **************************************************************************
;; Get Unix system environment variable
;; **************************************************************************


(defun get-unix-env (env-var default)
  (cond ((SYSTEM:GETENV env-var))
	(t default)))


;; **************************************************************************
;; (safe-eval exp) evaluates exp returns (values result error) where error
;; is error if the evaluation gives an error
;; Example (safe-eval '(/ 4 2)) ==> 2,nil
;;         (safe-eval '(/ 4 0)) ==> undefined ,errormessage
;; **************************************************************************




(defun safe-eval (exp)
  (let ((*debug-io* (open "/dev/null" :direction :IO))
	(*ERROR-OUTPUT* (make-string-output-stream))
	(*BREAK-ENABLE* NIL)
	(result nil)
	(error nil))
    (multiple-value-setq (error result) (si::error-set exp))
    (setf error (get-output-stream-string *error-output*))
    (values result (if (string= error "") nil error))))
