;; *************************************************************************************** ;;
;; 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 sytemvariable
;;
;; ********************************************************************************************

;; ********************************************************************************************
;; PAckage stuff
;; ********************************************************************************************

(in-package "DEBUGGER")

;; *******************************************************************************************
;; Global variables used in this link
;; *******************************************************************************************

(defparameter **socket-stream** 0)
(defparameter **save-socket-stream** 0)
(defparameter **save-standard-input** 0)
(defparameter **generic-stream** 0)

(if (not (generic-stream-p *standard-input*))
    (setf **save-standard-input** *standard-input*))


;; *****************************************************************************************
;; Create a generic stream to be used instead of the *standard-input* , this allows
;; us to listen to the socket to our interface using spare moments in the read-eval-print
;; toplevel loop
;; *****************************************************************************************

(defclass top () ())

(setf **generic-stream** (make-generic-stream (make-instance 'top)))

(defmethod generic-stream-read-char ((c top))
  (loop
    (when (listen **save-standard-input**)
      ;; When there is something on standard input ,
      ;; give it to the toplevel loop
      (return (read-char **save-standard-input**)))
    (process-incoming)))

(defmethod generic-stream-read-byte ((c top))
  (loop
    (when (listen **save-standard-input**)
      ;; When there is something on standard inpu
      ;; give it to the toplevel loop
      (return (read-byte **save-standard-input**)))
    (process-incoming)))
    
(defmethod generic-stream-listen ((c top))
  (cond ((listen **save-standard-input**)
	 ;; If there is something on standard input , give it to the toplevel loop
	 0)
	(T
	 (process-incoming)
	 1)))

(defmethod generic-stream-write-char ((c top) ch)
  (write-char ch **save-standard-input**))

(defmethod generic-stream-write-byte ((c top) by)
  (write-byte by **save-standard-input**))

(defmethod generic-stream-write-string ((c top) string start len)
  (write-string string **save-standard-input** :start start :end (+ start len)))

(defmethod generic-stream-clear-input ((c top))
  (clear-input **save-standard-input**))

(defmethod generic-stream-clear-output ((c top))
  (clear-output **save-standard-input**))

(defmethod generic-stream-finish-output ((c top))
  (finish-output **save-standard-input**))

(defmethod generic-stream-force-output ((c top))
  (force-output **save-standard-input**))

(defmethod generic-stream-close ((c top))
  (close **save-standard-input**))

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

(defun process-incoming ()
  (if (streamp **socket-stream**)
      (when (listen **socket-stream**)
	(let ((str "")
	      (chr))
	  (setf str (with-output-to-string (h)
					   (loop
					     (setf chr (read-char **socket-stream**))
					      (when (char= chr #\newline)
						(return))
					      (princ chr h))))
	   (eval (read-from-string str NIL NIL))))
    (stop-interface)))

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

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

(defun start-interface ()
  (when (streamp **save-socket-stream**) (close **save-socket-stream**)) ;; can't close socket in stop-interface so has to do it here
  (sleep 1)
  (shell "interface -9007&") ;; Start the interface program which creates a socket on 9007
  (sleep 1)
  (setf **save-socket-stream** (setf **socket-stream** (socket-connect 9007))) ;; Connecto to socket 9007
  ;; sets standard input to a generic stream ,
  ;; which allows us to listen to input from the socket
  (setf *standard-input* **generic-stream**)
  )

;; *******************************************************************************************
;; Stop the interface
;; *******************************************************************************************

(defun stop-interface ()
  (setf **socket-stream** 0)
  (setf *standard-input* **save-standard-input**)
  (end-debug-eventloop))


;; ******************************************************************************************
;; Some missing functions in CLISP
;; ******************************************************************************************

(setf (symbol-function 'special-operator-p) #'special-form-p)


;; ******************************************************************************************
;; Get unix system environment variable
;; ******************************************************************************************

(defun get-unix-env (var default)
  (cond ((system::getenv var))
	(t default)))

  