;; *************************************************************************************** ;;
;; 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                                                          ;;
;; *************************************************************************************** ;;
;; New improved version of the lisp debugger , here the TCL/TK code is put in C to improve ;;
;; performance.
;; *************************************************************************************** ;;
;; 
;; The code is to be devided in 4 sections 
;;
;; Section 1 : Interface code to the c program which represent the GUI
;; Section 2 : Code to transform a source in a source with debugged code added 
;; Section 3 : Code to process a syntax file , to generate the transforming functions needed
;;             in section 2
;; Section 4 : Code used during the actual debugging process
;; *************************************************************************************** ;;

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

(when (not (find-package "DEBUGGER")) (make-package "DEBUGGER"))
(in-package "DEBUGGER")

;; *************************************************************************************** ;;
;; Optimize commands for the compiler                                                      ;;
;; *************************************************************************************** ;;

#+:CMU
(declaim (optimize (speed 3) (safety 0)) (extensions:optimize-interface (speed 3)))
#+gcl
(declaim (optimize (speed 3) (safety 0)))
#+CLISP
(declaim (optimize (speed 3) (safety 0)))



;; ##################################################
;; ##################################################
;; ##################################################
;; ###### SECTION 1 #################################
;; ##################################################
;; ##################################################
;; ##################################################


;; *************************************************************************************
;; Lisp dependend link to user interface , you can send commands to the user interface
;; using (send-command command-nr arg1 .... argn)
;; Commands from the userinterface to lisp (load source in debugger) is handled in
;; lisp depended way
;; *************************************************************************************

#+:CMU
(load "cmu.x86f")
#+gcl
(load "gcl.o")
#+CLISP
(load "clisp.fas")
#+:allegro-cl-master
(load "acl5.fasl")

#+:CMU
;; (when (probe-file "debugcode.x86f") (load "debugcode.x86f"))
#+gcl
;; (when (probe-file "debugcode.o") (load "debugcode.o"))
#+CLISP
;; (when (probe-file "debugcode.fas") (load "debugcode.fas"))
#+:allegro-cl-master
;; (when (probe-file "debugcode.fasl") (load "debugcode.fasl"))


;; ************************************************************************************** ;;
;; Global control variables                                                               ;;
;; ************************************************************************************** ;;

(defparameter **end-debug-eventloop** nil) ;; If T end the eventloop in th debug-point 
(defparameter **current-env** nil) ;; The current environment set in the debug-point
(defparameter **time** nil) ;; The time used for timetravelling
(defparameter **alternate-time** -1) ;; The alternate time
(defparameter **now** 0)  ;; The now in timetraveling
(defparameter **end-of-time** 0) ;; The end of time in timetraveling


;; ************************************************************************************** ;;
;; Constants used during parsing
;; ************************************************************************************** ;;


;; *********************************************************
;; System independend function to interact with interface ;;
;; *********************************************************
;;                                                        ;;
;; Here comes the real code to the debugger               ;; 
;;                                                        ;;
;; *********************************************************


#-:allegro-cl-master
(defun debug ()
  ;; Prepeare time travilling to hold a max of 100 commands
  (let ((config (format nil "~A.lispdebug.lisp" (namestring (user-homedir-pathname))))
	(lispdebug (get-unix-env "LISPDEBUG" "/usr/local/lib/lispdebug")))
    (prepare-time 100)
    ;; Load the conversion functions of the debugger
#+:CMU
    (load (format nil "~A/debugcode.x86f" lispdebug))
#+gcl
    (load (format nil "~A/debugcode.o" lispdebug))
#+CLISP
    (load (format nil "~A/debugcode.fas" lispdebug))
#+:allegro-cl-master
    (load (format nil "~A/debugcode.fasl" lispdebug))
    ;; Start the graphical interface
    (start-interface)
    (when (probe-file config)
      (load config))))

#+:allegro-cl-master
(defun deb ()
  ;; Prepeare time travilling to hold a max of 100 commands
  (let ((config (format nil "~A.lispdebug.lisp" (namestring (user-homedir-pathname))))
	(lispdebug (get-unix-env "LISPDEBUG" "/usr/local/lib/lispdebug")))
    (prepare-time 100)
    ;; Load the conversion functions of the debugger
#+:CMU
    (load (format nil "~A/debugcode.x86f" lispdebug))
#+gcl
    (load (format nil "~A/debugcode.o" lispdebug))
#+CLISP
    (load (format nil "~A/debugcode.fas" lispdebug))
#+allegro-cl-master
    (load (format nil "~A/debugcode.fasl" lispdebug))
    ;; Start the graphical interface
    (start-interface)
    (when (probe-file config)
      (load config))))



(defconstant **c-highlight-source** 0)
(defconstant **c-display-message** 1)
(defconstant **c-highlight-error** 2)
(defconstant **c-set-possible-breakpoint** 3)
(defconstant **c-give-control-to-interface** 4)
(defconstant **c-display-result-in-interface** 5)
(defconstant **c-display-exp-in-interface** 6)
(defconstant **c-if-breakpoint** 7)
(defconstant **c-display-time-env** 8)
(defconstant **c-setting** 9)



;; *********************************************************
;; Functions which call to interface                      ;;
;; *********************************************************

;; *********************************************************
;; Highlight part of a source in a certain color         ;;
;; *********************************************************

(defun highlight-source (begin end type color)
  (send-command **c-highlight-source** begin end type color))


;; *********************************************************
;; Send a message in a message box                        ;;
;; *********************************************************

(defun message (message)
  (send-command **c-display-message** message))

;; *********************************************************
;; Highlight line of error in the source                  ;;
;; *********************************************************

(defun highlight-error (begin)
  (send-command **c-highlight-error** begin))


;; *********************************************************
;; Set possible breakpoints in interface                  ;;
;; *********************************************************

(defun set-possible-breakpoint (source begin end)
  (send-command **c-set-possible-breakpoint** source begin end))


;; *****************************************************************;;
;; Give control to the interface because we reached breakpoint code ;;
;; **************************************************************** ;;

(defun give-control-to-interface (source begin end)
  (send-command **c-give-control-to-interface** source begin end))

;; ********************************************************************** ;;
;; Send the values of watch expressions to be displayed in the interface  ;;
;; ***********************************************************************;;

(defun display-result-in-interface (&rest arg-lst)
  (push **c-display-result-in-interface** arg-lst)
  (apply #'send-command arg-lst))

;; ******************************************************************************* ;;
;; Send the result of evaluating an expression to be displayed in the interface    ;;
;; ******************************************************************************* ;;

(defun display-exp-in-interface (exp result)
  (send-command **c-display-exp-in-interface** exp result))

;; ********************************************************************************
;; Do the interface parts side of a breakpoint
;; ********************************************************************************

(defun call-if-breakpoint ()
  (send-command **c-if-breakpoint**))

;; ********************************************************************************
;; Display the environment in another time
;; ********************************************************************************

(defun display-time-env (begin end source)
  (send-command **c-display-time-env** begin end source))


;; ********************************************************************************
;; Change the settings of the debugger
;; ********************************************************************************

(defun setting (var value)
  (send-command **c-setting** var value))


;; ##################################################
;; ##################################################
;; ##################################################
;; ###### SECTION 2 #################################
;; ##################################################
;; ##################################################
;; ##################################################


;; ############################################################################################
;; ############################################################################################
;; #####  READ THE SOURCE INTO A LIST , AND KEEP POSITION INFORMATION IN A HASHTABLE       #### 
;; #####                                                                                   ####
;; ############################################################################################
;; ############################################################################################

;; *********************************************************************************************
;; * read the source and returns a list containig source in reverse and a position hashtable
;; *********************************************************************************************

(defun read-source (source)
  (parse-source (source-to-string source) (make-hash-table :test #'eq)))

;; *********************************************************************************************
;; Read the whole source in memory (as one big string)
;; *********************************************************************************************

(defun source-to-string (source)
  (let  ((h-source (open source :direction :input :if-does-not-exist nil)) ;; Open the source
	 (line ""))
    (when (null h-source)
      (message (format nil "Can't open ~A"))
      (return-from source-to-string ""))
    ;; Read to a string and returns the string
    (with-output-to-string (h-str)
			   (loop (when (null (setf line (read-line h-source nil nil)))
				   (close h-source)
				   (return))
			     (write-line line h-str)))))



;; ***********************************************************************************************
;; Parse the source and produces a list of what was in the source in addition for each list in  **
;; the source a association with a position is saved in the position hashtable                  **
;; ***********************************************************************************************


(defun parse-source (source position)
  (declare (string source) (hash-table position))
  (let ((i 0)                    ;; index in string source
	(l (length source))      ;; length source , we must have i < l , i+1 is the real position starting from 1
	(el nil)                 ;; element of source
	(result nil)             ;; result of the parsing
	(begin 0))               ;; begin position of hook
    (declare (fixnum i l begin))
    (loop
      (setf i (skip-white source i l))  ;; Skip white spaces and comments
      (when (>= i l)  ;; End of source reached , return results
	(return (values result position)))   
      (case (char source i)
	(#\( ;; Found opening hook
	 (setf begin (1+ i))
	 (multiple-value-setq (el i) (parse-source-list source (1+ i) l position))
	 (push el result)
	 (setf (gethash el position) (cons begin i)))
	(#\) ;; Found closing hook without opening hook
	 (message "Found closing hook without opening hook,substituting opening hook")
	 (highlight-error (1+ i))
	 (push '() result))
	(#\"  ;; Found string
	 (multiple-value-setq (el i) (read-from-string source nil nil :start i))
	 (push el result))
	(#\#  ;; Found hashing code
	 (incf i)
	 (when (>= i l) ;; Unexpected end of the source reached
	   (message "Unexpected end of the source reached")
	   (highlight-error l)
	   (return (values result position)))
	 (case (char source i)
	   (#\'  ;; we have #'
	    (incf i)
	    (when (>= i l) ;; Unexpected end of the source reached
	      (message "Unexpected end of the source reached")
	      (highlight-error l)
	      (return (values result position)))
	    (case (char source i)
	      (#\( ;; We have #'(
	       (setf begin (1+ i))
	       (multiple-value-setq (el i) (parse-source-list source (1+ i) l position))
	       (setf (gethash el position) (cons begin i))
	       (setf el (list 'user::function el))
	       (setf (gethash el position) (cons begin i))
	       (push el result))
	      (t
	       (multiple-value-setq (el i) (read-from-string source nil nil :start (- i 2)))
	       (push el result)
	       (decf i))))
	   (#\+  ;; We have #+ , an option added if the next argument is true
	    (setf i (parse-source-add-option source (1+ i) l)))
	   (#\- ;; We have #- , an option subtracted if the next argument is true
	    (setf i (parse-source-remove-option source (1+ i) l)))
	   (t
	    (multiple-value-setq (el i) (read-from-string source nil nil :start (1- i)))
	    (push el result))))
	(t (multiple-value-setq (el i) (read-from-string source nil nil :start i))
	   (push el result))))))


;; ******************************************************************************************
;; Parses source , and skips over comments and white spaces                                ;;
;; ******************************************************************************************

(defun skip-white (source i l)
  (declare (string source) (fixnum i l))
  (loop
    (when (>= i l) (return l))
    (case (char source i)
      (#\;
       (loop (when (or (>= i l) (char= (char source i) #\Linefeed)) (return)) (incf i))
       (incf i))
      (#\Space
       (incf i))
      (#\Linefeed
       (incf i))
      (#\Return
       (incf i))
      (#\tab
       (incf i))
      (t (if (>= i l) (return l) (return i))))))



	 
	 
;; ***************************************************************************************
;; Parses option fields                                                                 **
;; ***************************************************************************************

(defun parse-source-add-option (source i l)
  (declare (string source) (fixnum i l))
  (when (>= i l) (return-from parse-source-add-option l))
  (let ((exp nil))
    (multiple-value-setq (exp i) (read-from-string source nil nil :start i))
    (when (>= i l) (return-from parse-source-add-option l))
    (cond ((read-from-string (format nil "#+~S t nil" exp))
	   i)
	  (t
	   (multiple-value-setq (exp i) (read-from-string source nil nil :start i))
	   i))))


(defun parse-source-remove-option (source i l)
  (declare (string source) (fixnum i l))
  (when (>= i l) (return-from parse-source-remove-option l))
  (let ((exp nil))
    (multiple-value-setq (exp i) (read-from-string source nil nil :start i))
    (when (>= i l) (return-from parse-source-remove-option l))
    (cond ((read-from-string (format nil "#-~S t nil" exp))
	   i)
	  (t
	   (multiple-value-setq (exp i) (read-from-string source nil nil :start i))
	   i))))

;; ****************************************************************************************
;; Read in the next list
;; ****************************************************************************************

(defun parse-source-list (source i l position)
  (declare (string source) (fixnum i l) (hash-table position))
  (let ((el nil)                 ;; element of source
	(result nil)             ;; result of the parsing
	(begin 0))               ;; begin position of hook
    (declare (fixnum begin))
    (loop
      (when (>= i l)  ;; End of source reached, without a closing hook
	(message "Missing closing hook")
	(highlight-error (1+ l))
	(return (values (reverse result) l)))   
      (case (char source i)
	(#\( ;; Found opening hook
	 (setf begin (1+ i))
	 (multiple-value-setq (el i) (parse-source-list source (1+ i) l position))
	 (push el result)
	 (setf (gethash el position) (cons begin i)))
	(#\) ;; Found closing hook , return
	 (return (values (reverse result) (1+ i))))
	(#\"  ;; Found string
	 (multiple-value-setq (el i) (read-from-string source nil nil :start i))
	 (push el result))
	(#\#  ;; Found hashing code
	 (incf i)
	 (when (>= i l) ;; Unexpected end of the source reached
	   (message "Unexpected end of the source reached")
	   (highlight-error l)
	   (return (values (reverse result) l)))
	 (case (char source i)
	   (#\'  ;; we have #'
	    (incf i)
	    (when (>= i l) ;; Unexpected end of the source reached
	      (message "Unexpected end of the source reached")
	      (highlight-error l)
	      (return (values (reverse result) l)))
	    (case (char source i)
	      (#\( ;; We have #'(
	       (setf begin (1+ i))
	       (multiple-value-setq (el i) (parse-source-list source (1+ i) l position))
	       (setf (gethash el position) (cons begin i))
	       (setf el (list 'user::function el))
	       (setf (gethash el position) (cons begin i))
	       (push el result))
	      (t
	       (multiple-value-setq (el i) (read-from-string source nil nil :start (- i 2)))
	       (push el result))))
	   (#\+  ;; We have #+ , an option added if the next argument is true
	    (setf i (parse-source-add-option source (1+ i) l)))
	   (#\- ;; We have #- , an option subtracted if the next argument is true
	    (setf i (parse-source-remove-option source (1+ i) l)))
	   (t
	    (multiple-value-setq (el i) (read-from-string source nil nil :start (1- i)))
	    (push el result))))
	(t
	 (multiple-value-setq (el i) (read-from-string source nil nil :start i))
	 (push el result)))
      (setf i (skip-white source i l)))))
  




;; *********************************************************************************************
;; Read in a source , generate a new source where the debugging code is added and read in
;; this new code
;; *********************************************************************************************


(defun debug-open-file (filename &optional (compile nil))
  (let ((position (make-hash-table :test #'eq))
	(def-lst nil)
	(tmpsource (format nil "/usr/tmp/lisp-debugger-~A" (gensym))))
    (setf def-lst (parse-source (source-to-string filename) position))
    (with-open-file (h (format nil "~A.lisp" tmpsource) :direction :output)
		    (mapcar #'(lambda (exp)
				(write (add-debugging-code exp position filename)
				       :stream h :escape t :radix nil :base 10 :pretty t
				       :level nil :length nil :gensym nil :array t)
				(terpri h))
			    (reverse def-lst)))
    (cond (compile
	   (compile-file (format nil "~A.lisp" tmpsource) :output-file tmpsource)
	   (load tmpsource))
	  (t
	   (load (format nil "~A.lisp" tmpsource))))
    (message "Debugging code added")))



;; ##################################################
;; ##################################################
;; ##################################################
;; ###### SECTION 3 #################################
;; ##################################################
;; ##################################################
;; ##################################################

;; ******************************************************************************
;; ******************************************************************************
;; Code to generate new code , which transforms a source in a source with 
;; debugcode added 
;; ******************************************************************************
;; ******************************************************************************

;; ************************************************************************************************************
;; Parse a text file of and generate a list of definitions
;;
;; Syntax ::
;;
;; def :==: symbol -- = --- ( -- def-exp ... def-exp -- ) --- "Subdefinition"
;;     :==: --- ( --- symbol def-exp ... def-exp --- ) ---    "Definition"
;;     :==: "symbol"                                          "Do in package to symbol"
;; def-exp :==: symbol                                        "Symbol , piece of text"
;;         :==: _symbol                                       "Represents any lisp expression"
;;         :==: ^symbol                                       "Represents a variable of type 1 ,used in do* , let* ..."
;;         :==: ~symbol                                       "Represents a variable of type 2 used in do , let , defun + @"
;;         :==: #symbol                                       "Represents any lisp expression where debug code must be added"
;;         :==: @                                             "Represents begin usage of variable of type 2 , and add of debugpoint"
;;         :==: $                                             "Represents begin usage of variable of type 2
;;         :==: "symbol"                                      "Represents a string"
;;         :==: --- [ --- def-exp .... def-exp --- ] ---      "Optional expressions"
;;         :==: --- [ --- def-exp .... def-exp --- ] --- * -- "Expressions" occuring zero or more times"
;;         :==: --- { --- def-exp | ... | def-exp --- } ---   "Different possible expressions"
;;         :==: -- { -- def-exp | ... | def-exp -- } -- * --  "zero or more possible expressions"
;; **********************************************************************************************
;; Using the meaning of the previous definitions we must translate the code as follows :
;; **********************************************************************************************
;; symbol ---> symbol
;; _symbol ---> **var**
;; ^symbol ---> **variable1**
;; ~symbol ---> **variable2**
;; #symbol ---> **debug**
;; "symbol" ---> **string**
;; @       ---> **debug-first**
;; [ def-exp ... def-exp ] ---> (**try** -- ....)
;; [ def-exp ... def-exp ] ---> (**try** -- ....)
;; [ def-exp ... def-exp ] * ---> (**repeat** ....)
;; { def-exp } ---> translated def-exp
;; { def-exp } * ---> tranlated def-exp + (**repeat** tranlated def-exp)
;; { def-exp | ... def-exp } ---> (**or** translated exp ....)
;; { def-exp | ... def-exp } * --> (**repeat** (**or** ...))
;; ************************************************************************************************

;; *****************************************
;; Parameters used to indicate certain 
;; symbols
;; *****************************************

(defparameter **variable1** (gensym))
(defparameter **variable2** (gensym))
(defparameter **function** (gensym))
(defparameter **var** (gensym))
(defparameter **debug** (gensym))
(defparameter **debug-first** (gensym))
(defparameter **use-var** (gensym))
(defparameter **or** (gensym))
(defparameter **try** (gensym))
(defparameter **repeat** (gensym))
(defparameter **string** (gensym))


;; *****************************************
;; Show error in definition 
;; *****************************************

(defun parse-message (message str i)
  (message (format nil "~A <<<~A>>> ~A" 
		   (subseq str (max (- i 200) 0) i)
		   message 
		   (subseq str (min (length str) (+ i 1)) (min (length str) (+ i 200))))))


;; *****************************************
;; Parse of a string containing syntax 
;; definitions 
;; *****************************************


(defun parse-definition-start (source subdef)
  (parse-definition source 0 (length source) subdef))

(defun parse-definition (source i l subdef)
  (declare (string source) (fixnum i l))
  (let ((result nil)
	(def nil))
    (loop
      (setf i (skip-white source i l))
      (when (>= i l) (return (reverse result)))
      (case (char source i)
	(#\"
	 (setf i (parse-definition-package source (1+ i) l)))
	(#\(
	 (multiple-value-setq (def i) (parse-definition-list source (1+ i) l))
	 (push def result))
	(t
	 (setf i (parse-definition-subdef source i l subdef)))))))


(defun parse-definition-package (source i l)
  (declare (string source) (fixnum i l))
  (let ((symbol ""))
    (declare (string symbol))
    (multiple-value-setq (symbol i) (parse-definition-string source i l))
    (when (not (string= symbol ""))
      (when (not (find-package symbol)) (make-package symbol))
      (in-package symbol))
    i))

(defun parse-definition-string (source i l)
  (declare (string source) (fixnum i l))
  (values (with-output-to-string (h)
				 (loop (cond ((>= i l)
					      (message "Missing \"")
					      (throw 'error nil)
					      (return))
					     ((char= (char source i) #\")
					      (return))
					     ((is-break-char (char source i))
					      (message "Invalid char found in string")
					      (throw 'error i)
					      (return))
					     (t
					      (princ (char source i) h)
					      (incf i)))))
	  (1+ i)))


(defun is-break-char (c)
  (or (char= c #\=)
      (char= c #\()
      (char= c #\))
      (char= c #\")
      (char= c #\_)
      (char= c #\^)
      (char= c #\~)
      (char= c #\#)
      (char= c #\$)
      (char= c #\@)
      (char= c #\[)
      (char= c #\])
      (char= c #\{)
      (char= c #\})
      (char= c #\|)
      (char= c #\;)
      (char= c #\space)
      (char= c #\return)
      (char= c #\tab)
      (char= c #\newline)))


(defun parse-definition-subdef (source i l subdef)
  (declare (string source) (fixnum i l))
  (let ((symbol nil)
	(def nil))
    (multiple-value-setq (symbol i) (parse-definition-symbol source i l))
    (when (gethash symbol subdef)
      (message "Subdefinition exist already")
      (throw 'error i))
    (setf i (skip-white source i l))
    (when (or (>= i l) (not (char= (char source i) #\=)))
      (message "Missing =")
      (throw 'error i))
    (setf i (skip-white source (1+ i) l))
    (multiple-value-setq (def i) (parse-definition-exp source  i l))
    (setf (gethash symbol subdef) def)
    i))


(defun parse-definition-symbol (source i l)
  (when (is-break-char (char source i))  ;; Avoid looping on breakchar
    (loop
      (cond ((or (>= i l) (not (is-break-char (char source i))))
	     (return))
	    (t
	     (incf i)))))
  (setf i (skip-white source i l))
  (values
   (read-from-string
    (with-output-to-string (h)
			   (loop
			     (cond ((>= i l) (return))
				   ((is-break-char (char source i))
				    (return))
				   (t
				    (princ (char source i) h)))
			     (incf i))))
   i))
			    

(defun parse-definition-list (source i l)
  (declare (string source) (fixnum i l))
  (let ((exp nil)
	(result nil))
    (loop
      (setf i (skip-white source i l))
      (when (>= i l)
	(message "Missing )")
	(throw 'error nil))
      (case (char source i)
	(#\( ;; another list is encountered
	 (multiple-value-setq (exp i) (parse-definition-list source (1+ i) l))
	 (push exp result))
	(#\) ;; End of list encountered
	 (return (values (reverse result) (1+ i))))
	(t (multiple-value-setq (exp i) (parse-definition-exp source i l))
	   (push exp result))))))



(defun parse-definition-exp (source i l)
  (declare (string source) (fixnum i l))
  (let ((exp nil))
    (when (>= i  l) (return-from parse-definition-exp (values nil i)))
    (case (char source i)
      (#\(
       (parse-definition-list source (1+ i) l))
      (#\)
       (message "Unexpeced ) encountered")
       (throw 'error i))
      (#\_  ;; **var**
       (multiple-value-setq (exp i) (parse-definition-symbol source (1+ i) l))
       (values **var** i))
      (#\^ ;; **variable1**
       (multiple-value-setq (exp i) (parse-definition-symbol source (1+ i) l))
       (values **variable1** i))
      (#\~ ;; **variable2**
       (multiple-value-setq (exp i) (parse-definition-symbol source (1+ i) l))
       (values **variable2** i))
      (#\# ;; **debug**
       (multiple-value-setq (exp i) (parse-definition-symbol source (1+ i) l))
       (values **debug** i))
      (#\"
       (multiple-value-setq (exp i) (parse-definition-string source (1+ i) l))
       (values **string** i))
      (#\@ ;; **debug-first**
       (values **debug-first** (1+ i)))
      (#\$ ;; use-var**)
       (values **use-var** (1+ i)))
      (#\[
       (parse-definition-try source (1+ i) l))
      (#\]
       (message "Unexpected ] found")
       (throw 'error i))
      (#\{
       (parse-definition-or source (1+ i) l))
      (#\}
       (message "Unexpected } found")
       (throw 'error i))
      (#\|
       (parse-definition-exp source (+ i 1) l))
      (#\*
       (parse-definition-exp source (+ i 1) l))
      (t
       (parse-definition-symbol source i l)))))




(defun parse-definition-try (source i l)
  (declare (string source) (fixnum i l))
  (let ((exp nil)
	(result nil))
    (loop
      (setf i (skip-white source i l))
      (when (>= i l)
	(message "] missing")
	(throw 'error nil))
      (case (char source i)
	(#\[
	 (multiple-value-setq (exp i) (parse-definition-try source (1+ i) l))
	 (push exp result))
	(#\]
	 (setf i (skip-white source (1+ i) l))
	 (cond ((or (>= i l) (not (char= (char source i) #\*)))
		(return (values (cons **try** (reverse result)) i)))
	       (t
		(return (values (cons **repeat** (reverse result)) (1+ i))))))
	(t
	 (multiple-value-setq (exp i) (parse-definition-exp source i l))
	 (push exp result))))))

      

(defun parse-definition-or (source i l)
  (declare (string source) (fixnum i l))
  (let ((exp nil)
	(result nil))
    (loop
      (setf i (skip-white source i l))
      (when (>= i l)
	(message "} missing")
	(throw 'error nil))
      (case (char source i)
;;	(#\{
;;	 (multiple-value-setq (exp i) (parse-definition-or source (1+ i) l))
;;	 (push (list exp) result))
	(#\}
	 (setf i (skip-white source (1+ i) l))
	 (cond ((or (>= i l) (not (char= (char source i) #\*)))
		(return (values (cons **or** (reverse result)) i)))
	       (t
		(if (endp (rest result))
		    (return (values (cons **repeat** (first result)) (1+ i)))
		  (return (values (list **repeat** (cons **or** (reverse result))) (1+ i)))))))
	(t
	 (multiple-value-setq (exp i) (parse-definition-or-choice source i l))
	 (when (not (null exp))
	   (push exp result)))))))


(defun parse-definition-or-choice (source i l)
  (declare (string source) (fixnum i l))
  (let ((result nil)
	(exp nil))
  (loop
    (setf i (skip-white source i l))
    (when (>= i l)
      (return (values (reverse result) i)))
    (case (char source i)
      (#\}
       (return (values (reverse result) i)))
      (#\|
       (return (values (reverse result) (1+ i))))
      (t
       (multiple-value-setq (exp i) (parse-definition-exp source i l))
       (push exp result))))))




;; *******************************************************************************
;; Code to analyse the structure of a expression and generate a new expression
;; *******************************************************************************
;;
;; The principe is as follows :
;;
;; 1. We start with a fle containing syntax expressions , defining lisp expressions ,and 
;;    indicating how debug code must be added
;; 2. This file is parsed , generating code in a intermediate language , defining lisp expressions
;; 3. This intermediate code is transformed in real lisp functions which transform a 
;;    lisp expression in a lispexpression whith debugging code added
;; **********************************************************************************


;; **********************************************************************************
;; First we define functions who generate lisp functions of the following type
;; (lambda (exp acc rem) ...) ---> exp',acc' 
;; Where : exp,acc is transformed in exp',acc' by the code of the function 
;;         If in the code an error is encoutered a throw to nomatch is done.
;;
;; Remark : We may always asume that exp and acc are list's 
;;          If rem is not nil , a continuation call of the form (funcall (first rem) exp' acc' (rest rem))
;;          is done 
;; **********************************************************************************


;; **********************************************************************************
;; (db-constant 'a) ==> f with
;; (f '(a | r) acc nil) ==> r , (a | acc),nil
;; **********************************************************************************

(defun db-constant (constant)
  #'(lambda (exp acc rem)
      (cond ((endp exp) 
	     (throw 'nomatch nil))
            ((eql (first exp) constant)
	     (cond ((endp rem)
		    (values (rest exp) (cons (first exp) acc)))
		   (t
		    (funcall (first rem) (rest exp) (cons (first exp) acc) (rest rem)))))
	    (t
	     (throw 'nomatch nil)))))

;; 
;; Tests
;;
;; (setf f (db-constant 'a))
;; (funcall f '(a b c) nil nil)
;; (funcall f '(a n c) nil (list (db-constant 'n)))
;; (funcall f '(b c a) nil nil)
;;


;; *********************************************************************************
;; (db-sequence f1) ==> f with 
;; (f exp acc rem) ==> (f1 exp acc rem)
;; (db-sequence f1 ... fn) ==> f with
;; (f exp acc rem) == (f1 exp acc ((f2 ...fn | rem)
;; Remark : (db-sequence) is an illegal call
;; *********************************************************************************

(defun db-sequence (&rest fun-lst)
  #'(lambda (exp acc rem)
      (cond ((endp (rest fun-lst))
	     (funcall (first fun-lst) exp acc rem))
	    (t
	     (funcall (first fun-lst) exp acc (append (rest fun-lst) rem))))))

;; (setf f (db-sequence (db-constant 'a) (db-constant 'b)))
;; (funcall f '(a b) nil nil)
;; (funcall f '(a b c) nil (list (db-constant 'c)))
;; (funcall f '(a c) nil nil)



;; **********************************************************************************
;; (db-try try rst) ==> f where we try the following , until we have no throw (if 
;; possible)
;; 1.  (rst exp acc rem) ==> exp' ,acc'
;; 2.  (try exp acc (rst | rem)) ==> exp' ,acc'
;; *********************************************************************************

(defun db-try (try rst)
  #'(lambda (exp acc rem)
      (let ((n-exp nil)
	    (n-acc nil)
	    (save nil))
	(cond ((catch 'nomatch
		 (setf save (db-c-get))
		 (multiple-value-setq (n-exp n-acc) (funcall rst exp acc rem))
		 t)
	       (values n-exp n-acc))
	      (t
	       (db-c-put save)
	       (funcall try exp acc (cons rst rem)))))))

;; (setf f (db-try (db-constant 'a) (db-constant 'b)))
;; (funcall f '(b) nil nil)
;; (funcall f '(a b) nil nil)
;; (funcall f '(a b c) nil nil)
;; (funcall f '(c b) nil nil)
;; (funcall f '(a c) nil nil)


;; *********************************************************************************
;; (db-repeat try rst) ==> f where we try the following , until we have no throw 
;; (if possible)
;; 1. (rst exp acc rem) ==> exp',acc'
;; 2. (try exp acc (rst | rem))
;; 3. (try exp acc (try | (rst |rem))
;;      ...
;; *********************************************************************************


(defun db-repeat (try rst)
  #'(lambda (exp acc rem)
      (let ((tst nil)
	    (passed nil)
	    (n-exp nil)
	    (n-acc nil)
	    (save nil))
	;; Function to inidicate it is called in lexical var passed
	;; Used to avoid infinite looping
	(setf tst #'(lambda (e a r)
		      (setf passed t)
		      (cond ((endp r) (values e a))
			    (t (funcall (first r) e a (rest r))))))
	(setf save (db-c-get))
	(cond ((catch 'nomatch
		 (multiple-value-setq (n-exp n-acc) (funcall rst exp acc rem))
		 t)
	       (values n-exp n-acc))
	      (t
	       (setf rem (cons tst (cons rst rem)))
	       (loop
		 (db-c-put save)
		 (setf passed nil)
		 (cond ((catch 'nomatch
			  (multiple-value-setq (n-exp n-acc) (funcall try exp acc rem))
			t)
			(return (values n-exp n-acc)))
		       ((null passed)
			(throw 'nomatch nil))
		       (t (setf rem (cons try rem))))))))))

;;
;; (setf f (db-repeat (db-constant 'a) (db-constant 'b)))
;;
;; (funcall f '(b) nil nil)
;; (funcall f '(a b) nil nil)
;; (funcall f '(a a b) nil nil)
;; (funcall f '(a a a b) nil nil)
;; (funcall f '(a c) nil nil)
;; (funcall f '(c) nil nil)
;; 
;; (setf f (db-repeat (db-sequence (db-repeat (db-constant 'a) #'db-c-nothing) (db-constant 'b)) (db-constant 'c)))
;; (funcall f '(c) nil nil)
;; (funcall f '(b c) nil nil)
;; (funcall f '(a b c) nil nil)
;; (funcall f '(a a b c) nil nil)
;; (funcall f '(a a b a a b c) nil nil)
;; (funcall f '(a a b a a b d) nil nil)
;;


;; ************************************************************************************
;; (db-repeat-simple try rst) ==> f where we try the following
;; 1. (rst exp acc rem) ==> exp',acc'
;; 2. (try exp acc nil) ==> exp',acc' , ... , (try exp' acc') ==> exp',acc'
;;    (rst exp' acc' rst) ==> exp',acc' 
;; 
;; This is a optimilized version of db-repeat , which gives the same results as 
;; db-repeat if try does not contain db-repeat,db-try or db-try-simple
;; ************************************************************************************

(defun db-repeat-simple (try rst)
  #'(lambda (exp acc rem)
      (let ((n-exp nil)
	    (n-acc nil)
	    (save nil))
	(loop
	  (cond ((catch 'nomatch
		   (setf save (db-c-get))
		   (multiple-value-setq (n-exp n-acc) (funcall rst exp acc rem))
		   t)
		 (return (values n-exp n-acc)))
		(t
		 (db-c-put save)
		 (cond ((catch 'nomatch
			  (multiple-value-setq (exp acc) (funcall try exp acc nil))
			  t))
		       (t
			(throw 'nomatch nil)))))))))

;;
;; (setf f (db-repeat-simple (db-or (list (db-constant 'a) (db-constant 'b)) #'db-c-nothing) (db-sequence (db-constant 'c) #'db-c-end)))
;; (funcall f '(c) nil nil)
;; (funcall f '(a c) nil nil)
;; (funcall f '(b c) nil nil)
;; (funcall f '(a b c) nil nil)
;; (funcall f '(a b b c) nil nil)
;;


	       



		     
;; *********************************************************************************
;; (db-or '(f1 ... fn) fun) ==> f with
;;
;; (f exp acc rem) ==> exp',acc' with exp',acc' the result of the first non 
;; throwing possibilities
;;
;; 1. (f1 exp acc (fun | rem))
;;         ....
;; n. (f1 exp acc *fun | rem))
;; *********************************************************************************


(defun db-or (or-lst fun)
  #'(lambda (exp acc rem)
      (let ((n-exp nil)
	    (n-acc nil)
	    (n-or-lst or-lst)
	    (save (db-c-get)))
	(loop
	  (db-c-put save)
	  (cond ((endp n-or-lst)
		 (throw 'nomatch nil))
		((catch 'nomatch 
		   (multiple-value-setq (n-exp n-acc) (funcall (first n-or-lst) exp acc (cons fun rem)))
		   t)
		 (return (values n-exp n-acc)))
		(t
		 (pop n-or-lst)))))))

;;
;; (setf f (db-or (list (db-constant 'x) (db-constant 'y) (db-constant 'z)) (db-sequence (db-constant 'b) (db-constant 'c))))
;; (funcall f '(x b c) nil nil)
;; (funcall f '(y b c) nil nil)
;; (funcall f '(z b c) nil nil)
;;
      
;; **********************************************************************************
;; (db-list fun) ==> f with
;; (f exp acc rem) ==> exp , acc where we have 
;; (db-c-push (rest exp) ((reverse res) | acc) (#'db-c-pop | #'db-c-end-list | rem))
;; and we have res generated by 
;; (fun (first exp) nil (#'db-c-end))
;; **********************************************************************************


(defun db-list (fun)
  #'(lambda (exp acc rem)
      (let ((n-exp nil)
	    (n-acc nil))
	(cond ((not (listp (first exp)))
	       (throw 'nomatch nil))
	      ((catch 'nomatch
		 (db-c-push (first exp))
		 (multiple-value-setq (n-exp n-acc) (funcall fun (first exp) nil (list #'db-c-end)))
		 t)
	       (db-c-pop)
	       (cond ((endp rem)
		      (values (rest exp) (cons (reverse n-acc) acc)))
		     (t
		      (funcall (first rem) (rest exp) (cons (reverse n-acc) acc) (rest rem)))))
	      (t 
	       (db-c-pop)
	       (throw 'nomatch nil))))))

;;
;; (setf f (db-list (db-sequence (db-constant 'a) (db-constant 'b))))
;;
;; (funcall f '((a b) c) nil nil)
;; (funcall f '((a b c) c) nil nil)
;;


;; **********************************************************************************
;; (db-call fun) ==> f
;; (f exp acc rem) ==> 'exp ,' (reverse acc) with (fun exp acc rem) ==> exp',acc'
;; **********************************************************************************

;;(defun db-call (fun)
;;  #'(lambda (exp acc rem)
;;      (let ((n-exp nil)
;;	    (n-acc nil))
;;	(cond ((catch 'nomatch
;;		 (multiple-value-setq (n-exp n-acc) (funcall fun exp acc rem))
;;		 t)
;;	       (values n-exp (reverse n-acc)))
;;	      (t
;;	       (throw 'nomatch nil))))))
;;

;; **********************************************************************************
;; (db-call-exp fun) ==> f of the form (lambda (exp) ...) ==> exp'
;; (f exp) ==> 'exp , with (funcall fun exp nil nil) === e,v and 'exp=reverse(v) 
;;             nil is returned in case of a throw
;; **********************************************************************************

(defun db-call-exp (fun)
  #'(lambda (exp)
      (let ((n-exp nil)
	    (n-acc nil))
	(cond ((catch 'nomatch
		 (db-c-push exp)
		 (multiple-value-setq (n-exp n-acc) (funcall fun exp nil (list #'db-c-end)))
		 t)
	       (db-c-pop)
	       (reverse n-acc))
	      (t
	       (db-c-pop)
	       nil)))))

;; **********************************************************************************
;; Already generated functions
;; **********************************************************************************


;; **********************************************************************************
;; Called when we want to add debug code 
;; **********************************************************************************

(defun db-c-debug (exp acc rem)
  (cond ((endp exp)
	 (throw 'nomatch nil))
	((endp rem)
	 (values (rest exp) (cons (add-debug-point (first exp) (db-c-variable) (db-c-position) (db-c-source)) acc)))
	(t
	 (funcall (first rem)
		  (rest exp)
		  (cons (add-debug-point (first exp) (db-c-variable) (db-c-position) (db-c-source)) acc)
		  (rest rem)))))


;; **********************************************************************************
;; Checks if we have detected the end of a exp after dooing what is in remaining
;; **********************************************************************************

(defun db-c-end (exp acc rem)
  (cond ((endp rem)
	 (if (endp exp)
	     (values nil acc)
	   (throw 'nomatch nil)))
	(t
	 (funcall (first rem) exp acc (cons #'db-c-end (rest rem))))))

;; (funcall #'db-c-end nil nil nil)
;; (funcall #'db-c-end '(a) nil nil)
;; (funcall #'db-c-end '(a) nil (list (db-constant 'a)))


;; **********************************************************************************
;; Do nothing , except calling the continuation code
;; **********************************************************************************

(defun db-c-nothing (exp acc rem)
  (cond ((endp rem)
	 (values exp acc))
	(t
	 (funcall (first rem) exp acc (rest rem)))))


;; **********************************************************************************
;; (db-c-var exp acc nil) ==> 
;;
;; 1. throw , if exp is endp
;; 2. (rest exp), (cons (first exp) acc)
;; **********************************************************************************

(defun db-c-var (exp acc rem)
  (cond ((endp exp)
	 (throw 'nomatch nil))
	((endp rem)
	 (values (rest exp) (cons (first exp) acc)))
	(t
	 (funcall (first rem) (rest exp) (cons (first exp) acc) (rest rem)))))

;; **********************************************************************************
;; (db-c-string exp acc nil) ==> 
;;
;; 1. throw , if exp is endp or (first exp) is not a string
;; 2. (rest exp), (cons (first exp) acc)
;; **********************************************************************************

(defun db-c-string (exp acc rem)
  (cond ((endp exp)
	 (throw 'nomatch nil))
	((not (stringp (first exp)))
	 (throw 'nomatch nil))
	((endp rem)
	 (values (rest exp) (cons (first exp) acc)))
	(t
	 (funcall (first rem) (rest exp) (cons (first exp) acc) (rest rem)))))


;; **********************************************************************************
;; Functions to handle lexical definitions of variables in a function
;; **********************************************************************************

(let ((expression-stack nil)
      (variable-stack nil)
      (variable-2-stack nil)
      (variable-1 nil)
      (variable-2 nil)
      (variable nil)
      (source nil)
      (expression nil)
      (position nil))
  (defun db-c-get ()
    (list expression-stack variable-stack variable-2-stack variable-1 variable-2 variable expression))
  (defun db-c-put (lst)
    (setf expression-stack (pop lst))
    (setf variable-stack (pop lst))
    (setf variable-2-stack (pop lst))
    (setf variable-1 (pop lst))
    (setf variable-2 (pop lst))
    (setf variable (pop lst))
    (setf expression (pop lst)))
  ;; Sets position and expression info
  (defun db-c-set (src pos)
    (setf position pos)
    (setf source src))
  (defun db-c-clear ()
    (setf variable-stack nil)
    (setf expression-stack nil)
    (setf variable-2-stack nil)
    (setf variable-1 nil)
    (setf variable-2 nil)
    (setf variable nil))
  ;; Gets position info
  (defun db-c-position ()
    position)
  ;; Gets source info
  (defun db-c-source ()
    source)
  ;; Gets expression info
  (defun db-c-expression ()
    expression)
  ;; Gets variable info
  (defun db-c-variable ()
    variable)
  ;; Push expression on stack
  (defun db-c-set-exp (exp)
    (setf expression exp))
  ;; push variable info on the stack , to be used in the begin of a list
  ;;(defun db-c-push (exp acc rem)
  ;;  (push (list variable-1 variable-2 variable) stack)
  ;;  (cond ((endp rem)
  ;;	   (values exp acc rem))
  ;;	  (t 
  ;;	   (funcall (first rem) exp acc (rest rem)))))
  
  (defun db-c-push (exp)
    (push expression expression-stack)
    (setf expression exp)
    (push variable variable-stack)
    (push variable-2 variable-2-stack)
    (setf variable-2 nil)
    (setf variable-1 nil))
  ;; pop variable infor from the stacjk , to be used on the end of a list
  ;;(defun db-c-pop (exp acc rem)
  ;;  (setf variable-1 (first (first stack)))
  ;;  (setf variable-2 (second (first stack)))
  ;;  (pop stack)
  ;;  (cond ((endp rem)
  ;;	   (values exp acc rem))
  ;;	  (t
  ;;	   (funcall (first rem) exp acc (rest rem)))))
  (defun db-c-pop ()
    (setf variable-2 (union variable-2 (pop variable-2-stack)))
    (setf variable (pop variable-stack))
    (setf variable (union variable-1 variable))
    (when variable-stack
      (setf variable-stack (cons (union variable-1 (first variable-stack)) (rest variable-stack))))
    (setf variable-1 nil)
    (setf expression (pop expression-stack)))
  ;; activate variables at a chosen moment + add debugging code 
  (defun db-c-use-var (exp acc rem)
    (setf variable (union variable-2 variable))
    (setf variable-2 nil)
    (cond ((endp rem)
	   (values exp (cons (add-debug-point-first (db-c-expression) (db-c-variable) (db-c-position) (db-c-source)) acc) rem))
	  (t
	   (funcall (first rem) exp (cons (add-debug-point-first (db-c-expression) (db-c-variable) (db-c-position) (db-c-source)) acc) (rest rem)))))
  ;; activate variables at a chosen moment + add debugging code
  (defun db-c-use-var-1 (exp acc rem)
    (setf variable (union variable-2 variable))
    (setf variable-2 nil)
    (cond ((endp rem)
	   (values exp acc rem))
	  (t
	   (funcall (first rem) exp acc (rest rem)))))
  ;; Append (first exp) to variable-1
  (defun db-c-variable-1 (exp acc rem)
    (cond ((endp exp)
	   (throw 'nomatch nil))
	  ((listp (first exp))
	   (throw 'nomatch nil))
	  ((endp rem)
	   (pushnew (first exp) variable-1)
	   (values (rest exp) (cons (first exp) acc)))
	  (t
	   (pushnew (first exp) variable-1)
	   (funcall (first rem) (rest exp) (cons (first exp) acc) (rest rem)))))
  ;; Append (first exp) to variable-2
  (defun db-c-variable-2 (exp acc rem)
    (cond ((endp exp)
	   (throw 'nomatch nil))
	  ((listp (first exp))
	   (throw 'nomatch nil))
	  ((endp rem)
	   (pushnew (first exp) variable-2)
	   (values (rest exp) (cons (first exp) acc)))
	  (t
	   (pushnew (first exp) variable-2)
	   (funcall (first rem) (rest exp) (cons (first exp) acc) (rest rem)))))
  )
    


;; ************************************************************************************
;; Translation of parsed version of the syntaxfile using the previous defined 
;; code generators
;; ************************************************************************************
;;
;; After parsing of the syntax file we have expressions like :
;;
;;
;; definition :==: -- (  -- definition-exp ... definition-exp -- ) --
;; definition-exp :==: definition
;; definition-exp :==: **string**
;; definition-exp :==: symbol
;; definition-exp :==: **var**
;; definition-exp :==: **variable1**  (variable defined in let* , do* ...
;; definition-exp :==: **variable2**  (variable defined in let , do ...
;; definition-exp :==: **debug**
;; definition-exp :==: (**function** symbol)
;; definition-exp :==: **debug-first** pseudo code added , to indicate **variable2**
;;                     becomes active and first call of master expression
;; definition-exp :==: **use-var** pseudo code added , to indicate **variable2** becomes active
;; definition-exp :==: -- ( -- **try** -- definition-exp ... definition-exp -- ) --
;; definition-exp :==: -- ( -- **repeat** -- definition-exp -- ) --
;; definition-exp :==: -- ( -- **or** -- definition-exp ... definition-exp --- ) ---
;;
;; ************************************************************************************
;; 
;; Transformation transform this code in the following way
;;
;; (tr **string** nil) ==> (#'db-c-string)
;; (tr **string** r)   ==> (#'db-c-string | (tr (first r) (rest r)))
;; (tr symbol nil)  ==> ((db-constant 'symbol))
;; (tr symbol r)    ==> ((db-constant 'symbol) | (tr (first r) (rest r)))
;; (tr **var** nil) ==> (#'db-c-var)
;; (tr **var** r)   ==> (#'db-c-var | (tr (first r) (rest r)))
;; (tr **variable1** nil) ==> (#'db-c-variable1)
;; (tr **variable1** r)   ==> (#'db-c-variable1 | (tr (first r) (rest r)))
;; (tr **variable2** nil) ==> (#'db-c-variable2)
;; (tr **variable2** r)   ==> (#'db-c-variable2 | (tr (first r) (rest r)))
;; (tr **debug** nil) ==> (#'db-c-debug)
;; (tr **debug** r)   ==> (#'db-c-debug | (tr (first r) (rest r)))
;; (tr **debug-first** nil) ==> (#'db-c-use-var)
;; (tr **debug-first** r)   ==> (#'db-c-use-var | (tr (first r) (rest r)))
;; (tr **debug-use** nil) ==> (#'db-c-use-var-naked)
;; (tr **debug-use** r)   ==> (#'db-c-use-var-naked | (tr (first r) (rest r)))
;; (tr (a1 ... an) nil) ==> ((db-list (tr-sequence (tr a1 (a2 .. an)))))
;; (tr (a1 ... an) r)   ==> ((db-list (tr-sequence (tr a1 (a2 ...an)))) | (tr (first r) (rest r)))
;; (tr (**function** symbol) nil) ==> ((function symbol))
;; (tr (**function** symbol) r)   ==> ((function symbol) | (tr (first r) (rest r)))
;; (tr (**repeat** a1 ...an) nil)    ==> ((db-repeat (tr-sequence (tr a1 (a2 ..an))) #'db-c-nothing)) (1)
;;                                   ==> ((db-repeat-simple (tr-sequence (tr a1 (a2 .. an))) #'db-c-nothing)) (2)
;; (tr (**repeat** a1 ...an) r)    ==> ((db-repeat (tr-sequence (tr a1 (a2 ..an))) (tr-sequence (tr (first r) (rest r))))) (1)
;;                                 ==> ((db-repeat-simple (tr-sequence (tr a1 (a2 .. an))) (tr-sequence (tr (first r) (rest r))))) (2)
;; (tr (**try** a1 .. an) nil) ==> ((db-try (tr-sequence (tr a1 (tr a2 ..an))) #'db-c-nothing))
;; (tr (**try** a1 ...an) r)   ==> ((db-try (tr-sequence (tr a1 (tr a2 ..an))) (tr-sequence (tr (first r) (rest r))))
;; (tr (**or** l1 ... ln) nil) ==> ((db-or ((tr-sequence (tr l1 nil)) ... (tr-sequence ln nil))) #'db-c-nothing))
;; (tr (**or** l1 ... ln) nil) ==> ((db-or ((tr-sequence (tr (first l1) (rest l1))) ... (tr-sequence (tr (first ln) (rest ln))))
;;                                         (tr-sequence (tr (first r) (rest r)))))
;;
;; (tr-sequence (a)) ==> a
;; (tr-sequence (a1 ... an)) ==> (db-sequence a1 ... an)
;;
;; (1) (tr-simple (a1 ...an)) is T
;; (2) (tr-simple (a1 ...an)) is NIL
;;
;; (tr-simple (**repeat** ...)) ==> nil
;; (tr-simple (**try** ...)) ==> nil
;; (tr-simple (a1 ... an)) ==> (every #'tr-simple (a1 ... an))
;; (tr-simple x) ==> T
;;
;; ******************************************************************************************************************************************
;; Previous transformation function is used to generate the following functions
;; ******************************************************************************************************************************************
;; function to represent a named syntax rule 
;;
;; (tr-named-rule-1 name syntax-exp) ==> (setf (symbol-function 'name) (tr-sequence (tr (first syntax-exp) (rest syntax-exp))))
;; (tr-nemae-rule-2 name syntax-exp) ==> (defun name (exp acc rem)
;;                                          (funcall (tr-sequence (tr (first syntax-exp) (rest syntax-exp))) exp acc rem))
;;
;; function to represent a non named syntax rule
;;
;; (tr-rule name syntax-exp) ==> (setf (symbol-function 'name) (db-call-exp (tr-seqeunce (tr (first syntax-exp) (rest syntax-exp)))))
;; ******************************************************************************************************************************************


(defun tr-simple (lst)
  (cond ((listp lst)
	 (cond ((eq (first lst) **repeat**)
		nil)
	       ((eq (first lst) **try**)
		nil)
	       (t
		(every #'tr-simple lst))))
	(t t)))


(defun tr-sequence (lst)
  (cond ((endp (rest lst))
	 (first lst))
	(t (cons 'db-sequence lst))))


(defun tr (frst rst)
  (cond ((listp frst)
	 (cond ((eq (first frst) **function**)
		(tr-function frst rst))
	       ((eq (first frst) **repeat**)
		(tr-repeat frst rst))
	       ((eq (first frst) **try**)
		(tr-try frst rst))
	       ((eq (first frst) **or**)
		(tr-or frst rst))
	       (t
		(tr-list frst rst))))
	((eq frst **string**)
	 (tr-string frst rst))
	((eq frst **var**)
	 (tr-var frst rst))
	((eq frst **variable1**)
	 (tr-variable-1 frst rst))
	((eq frst **variable2**)
	 (tr-variable-2 frst rst))
	((eq frst **debug**)
	 (tr-debug frst rst))
	((eq frst **debug-first**)
	 (tr-first-debug frst rst))
	((eq frst **use-var**)
	 (tr-first-use-var frst rst))
	(t
	 (tr-symbol frst rst))))



(defun tr-string (frst rst)
  (cond ((endp rst)
	 (list (list 'function 'db-c-string)))
	(t 
	 (cons (list 'function 'db-c-string)
	       (tr (first rst) (rest rst))))))


(defun tr-symbol (frst rst)
  (cond ((endp rst)
	 (list (list 'db-constant (list 'quote frst))))
	(t 
	 (cons (list 'db-constant (list 'quote frst))
	       (tr (first rst) (rest rst))))))


(defun tr-var (frst rst)
  (cond ((endp rst)
	 (list (list 'function 'db-c-var)))
	(t 
	 (cons (list 'function 'db-c-var)
	       (tr (first rst) (rest rst))))))


(defun tr-variable-1 (frst rst)
  (cond ((endp rst)
	 (list (list 'function 'db-c-variable-1)))
	(t 
	 (cons (list 'function 'db-c-variable-1)
	       (tr (first rst) (rest rst))))))


(defun tr-variable-2 (frst rst)
  (cond ((endp rst)
	 (list (list 'function 'db-c-variable-2)))
	(t 
	 (cons (list 'function 'db-c-variable-2)
	       (tr (first rst) (rest rst))))))


(defun tr-debug (frst rst)
  (cond ((endp rst)
	 (list (list 'function 'db-c-debug)))
	(t 
	 (cons (list 'function 'db-c-debug)
	       (tr (first rst) (rest rst))))))


(defun tr-first-debug (frst rst)
  (cond ((endp rst)
	 (list (list 'function 'db-c-use-var)))
	(t 
	 (cons (list 'function 'db-c-use-var)
	       (tr (first rst) (rest rst))))))

(defun tr-first-use-var (frst rst)
  (cond ((endp rst)
	 (list (list 'function 'db-c-use-var-1)))
	(t 
	 (cons (list 'function 'db-c-use-var-1)
	       (tr (first rst) (rest rst))))))


(defun tr-list (frst rst)
  (cond ((endp rst)
	 (list (list 'db-list (tr-sequence (tr (first frst) (rest frst))))))
	(t
	 (cons (list 'db-list (tr-sequence (tr (first frst) (rest frst))))
	       (tr (first rst) (rest rst))))))


(defun tr-function (frst rst)
  (cond ((endp rst)
	 (list (list 'function (second frst))))
	(t 
	 (cons (list 'function (second frst))
	       (tr (first rst) (rest rst))))))


(defun tr-repeat (frst rst)
  (cond ((endp rst)
	 (if (tr-simple (rest frst))
	     (list (list 'db-repeat-simple 
			 (tr-sequence (tr (first (rest frst)) (rest (rest frst))))
			 (list 'function 'db-c-nothing)))
	   (list (list 'db-repeat 
		       (tr-sequence (tr (first (rest frst)) (rest (rest frst))))
		       (list 'function 'db-c-nothing)))))
	(t
	 (if (tr-simple (rest frst))
	     (list (list 'db-repeat-simple
			 (tr-sequence (tr (first (rest frst)) (rest (rest frst))))
			 (tr-sequence (tr (first rst) (rest rst)))))
	   (list (list 'db-repeat
		       (tr-sequence (tr (first (rest frst)) (rest (rest frst))))
		       (tr-sequence (tr (first rst) (rest rst)))))))))


(defun tr-try (frst rst)
  (cond ((endp rst)
	 (list (list 'db-try 
		     (tr-sequence (tr (first (rest frst)) (rest (rest frst))))
		     (list 'function 'db-c-nothing))))
	(t
	 (list (list 'db-try
		     (tr-sequence (tr (first (rest frst)) (rest (rest frst))))
		     (tr-sequence (tr (first rst) (rest rst))))))))


(defun tr-or (frst rst)
  (cond ((endp (rest (rest frst)))
	 ;; Is or of one single test , transform it to a sequence
	 (cond ((endp rst)
		(list (tr-sequence (tr (first (second frst)) (rest (second frst))))))
	       (t
		(list (tr-sequence (tr (first (second frst)) (append (rest (second frst)) rst)))))))
        ((endp rst)
	 (list (list 'db-or 
		     (cons 'list (mapcar #'(lambda (l) (tr-sequence (tr (first l) (rest l)))) (rest frst)))
		     (list 'function 'db-c-nothing))))
	(t
	 (list (list 'db-or
		     (cons 'list (mapcar #'(lambda (l) (tr-sequence (tr (first l) (rest l)))) (rest frst)))
		     (tr-sequence (tr (first rst) (rest rst))))))))


(defun tr-named-rule-1 (name syntax-exp)
  (list 'setf
	(list 'symbol-function (list 'quote name))
	(tr-sequence (tr syntax-exp nil))))

(defun tr-named-rule-2 (name syntax-exp)
  (list 'defun name (list 'e 'a 'r)
	(list 'funcall (tr-sequence (tr syntax-exp nil)) 'e 'a 'r)))
	


(defun tr-rule (name syntax-exp)
  (list 'setf
	(list 'symbol-function (list 'quote name))
	(list 'db-call-exp (tr-sequence (tr (first syntax-exp) (rest syntax-exp))))))


;; ********************************************************************************************************************
;; Check if a named definition depends on another named definition 
;; ********************************************************************************************************************

(defun depends-on (def1 def2 def-exp)
  (let ((checked (make-hash-table)))
    (depends-on-1 (gethash def1 def-exp) def1 def2 def-exp checked)))

(defun depends-on-1 (def1-exp def1 def2 def-exp checked)
  (cond ((listp def1-exp)
	 (some #'(lambda (exp) (depends-on-1 exp def1 def2 def-exp checked)) def1-exp))
	((eq def1-exp def2) t)
	((eq def1-exp def1)
	 (if (eq def1 def2) t nil))
	((gethash def1-exp def-exp)
	 (cond ((gethash def1-exp checked)
		(if (eq def1-exp def2) t nil))
	       (t
		(setf (gethash def1-exp checked) t)
		(depends-on-1 (gethash def1-exp def-exp) def1 def2 def-exp checked))))
	(t nil)))

;; *******************************************************************************************************************
;; Generates a sorted list of named definitions , so that a definition comes after the ones it dependends on
;; *******************************************************************************************************************

(defun sort-by-dependence (def-exp)
  (let ((lst nil))
    (maphash #'(lambda (x y) (push x lst)) def-exp)
    (sort-by-dependence-1 lst def-exp)))

(defun sort-by-dependence-1 (lst def-exp)
  ;; We can't use sort because depends-on is not an order relation
  (let ((depend nil)
	(depend-not nil))
    (cond ((endp lst) lst)
	  ((endp (rest lst)) lst)
	  (t
	   (multiple-value-setq (depend depend-not) (sort-by-dependence-split (first lst) (rest lst) def-exp depend depend-not))
	   (append (sort-by-dependence-1 depend def-exp) (cons (first lst) (sort-by-dependence-1 depend-not def-exp)))))))

(defun sort-by-dependence-split (def lst def-exp depend depend-not)
  (cond ((endp lst) (values depend depend-not))
	((depends-on def (first lst) def-exp)
	 (sort-by-dependence-split def (rest lst) def-exp (cons (first lst) depend) depend-not))
	(t
	 (sort-by-dependence-split def (rest lst) def-exp depend (cons (first lst) depend-not)))))
  
;; ********************************************************************************************************************
;; Now we can put finally everything together and start thinking on realy parsing the syntax source file
;; and generating the debuggenerating code
;; ********************************************************************************************************************



;; *************************************************************************************
;; Process the parsed syntax definitions , changing the references to named syntax
;; definitions to (**function** name)
;; *************************************************************************************


(defun process-parsed-def (def subdef)
  (cond ((listp def)
	 (mapcar #'(lambda (d) (process-parsed-def d subdef)) def))
	((gethash def subdef)
	 (list **function** def))
	(t def)))

;; *****************************************************************************************************
;; Generate code to transform expressions in debugging expressions
;; *****************************************************************************************************
;;
;; the generated code should be of the form , given a list of elements of the form ((n1 f1) .... (nm fn))
;;
;; (defun add-code-exp (exp free position source)
;;    (cond ((null exp) nil)
;;          ((and (listp exp) (atom (first exp)) (not (null exp)))
;;           (let ((operator (first exp)))
;;             (case operator
;;               ('n1 (f1 exp))
;;               ...
;;               ('nm (fm exp))
;;               ('user::function (add-code-function exp free position source))
;;               (t
;;                (cond ((not (symbolp operator)) exp)
;;                      ((macro-function operator)
;;                       (add-code-exp-macro exp free position source))
;;                      ((not (special-operator-p operator)) 
;;                       (add-code-exp-function exp free position source))
;;                      (t exp)))))
;;          (t exp))
;; *******************************************************************************************************

(defun generate-add-code-exp (n-f-lst)
  (let ((case-lst (list (list 'user::function (list 'add-code-function 'exp 'free 'position 'source))
		        (list 't
			      (list 'cond
				    (list (list 'not (list 'symbolp 'operator))
					  'exp)
				    (list (list 'macro-function 'operator)
					  (list 'add-code-exp-macro 'exp 'free 'position 'source))
				    (list (list 'not (list 'special-operator-p 'operator))
					  (list 'add-code-exp-function 'exp 'free 'position 'source))
				    (list 't 'exp))))))
    (mapc #'(lambda (n-f) (push (list (list 'quote (first n-f))
				      (list (rest n-f) 'exp))
				case-lst))
	  n-f-lst)
    (setf case-lst
	  (cons 'case
		(cons 'operator
		      case-lst)))
    (list 'defun 'add-code-exp (list 'exp 'free 'position 'source)
	  (list 'cond
		(list (list 'null 'exp) 'nil)
		(list (list 'and (list 'listp 'exp) (list 'atom (list 'first 'exp)) (list 'not (list 'null 'exp)))
		      (list 'let (list (list 'operator (list 'first 'exp)))
			    case-lst))))))


;; ***********************************************************************************
;; Special case for the function special-operator
;; ***********************************************************************************

(defun add-code-function (exp free position source)
  (cond ((listp (second exp))
	 (list 'function (add-code-exp (second exp) free position source)))
	(t exp)))

;; ************************************************************************************
;; Process the syntax definition file 
;; ************************************************************************************

(defun process-definition-file (definition-file &optional (destination "debugcode"))
  (declare (string definition-file))
  ;; Allow for failing of transformation , to jum out of the system
  (catch 'error
    (let ((subdef (make-hash-table))  ;; Hash table for named definitions
	  (tmpsource (format nil "~A.lisp" destination))   ;; Source to generate tempcode in
	  (definition nil) ;; Holds transformed definition
	  (name nil) ;; name of function
	  (n-f-lst nil)) ;; list of names of syntax definitions
      (declare (string tmpsource))
      ;; Read the syntax defintion file and parse it
      (setf definition (parse-definition-start (source-to-string definition-file) subdef))
      ;; Write out the code that implement the syntax definitions in lisp code
      (with-open-file
	  (h tmpsource :direction :output :if-exists :supersede)
	;; First write out the named syntax definitions 
	(mapc #'(lambda (def)
		  (cond ((depends-on def def subdef)
			 ;; We have recursive code so we use the recursive version of transformation
			 (write (tr-named-rule-2 def (process-parsed-def (gethash def subdef) subdef))
				:stream h :escape t :radix nil :base 10 :pretty t
				:level nil :length nil :gensym nil :array t)
			 (terpri h))
			(t
			 ;; We have non recursive code so we use the non recursive version of transformation
			 (write (tr-named-rule-1 def (process-parsed-def (gethash def subdef) subdef))
				:stream h :escape t :radix nil :base 10 :pretty t
				:level nil :length nil :gensym nil :array t)
			 (terpri h))))
	 (sort-by-dependence subdef))
	;; Next we write out the unnamed syntax definitions
	(mapc #'(lambda (def)
		  (cond ((or (not (listp def)) (not (atom (first def))))
			 (message "Definition found which is not a list")
			 (throw 'error nil))
			(t
		       ;; Write the definition code
		       (setf name (read-from-string (format nil "d-~A" (first def))))
		       (push (cons (first def) name) n-f-lst)
		       (write (tr-rule name (process-parsed-def def subdef))
			      :stream h :escape t :radix nil :base 10 :pretty t
			      :level nil :length nil :gensym nil :array t)
		       (terpri h))))
	    definition)
      ;; Generate the add-code-exp fucntion based on first names in list and generated code
      (write (generate-add-code-exp n-f-lst)
	     :stream h :escape t :radix nil :base 10 :pretty nil
	     :level nil :length nil :gensym nil :array t))
      ;; Compile the generated file
       (compile-file tmpsource)
    ;; Load the compiled file in memory
    #+:CMU
    (load (format nil "~A.x86f" destination))
    #+gcl
    (load (format nil "~A.o" destination))
    #+CLISP
    (load (format nil "~A.fas" destination))
    #+:allegro-cl-master
    (load (format nil "~A.fasl" destination))
    )))


;; *************************************************************************************
;; *************************************************************************************
;; Code called during instrumentation (is transforming source in debugged source)
;; *************************************************************************************
;; *************************************************************************************


;; *************************************************************************************
;; add-code to an expression 
;; *************************************************************************************

(defun add-code (exp free position source)
;;  (db-c-set-exp exp)
  (cond ((null exp) exp) ;; Case of nil expressions
	((add-code-exp exp free position source))
	(t
	 (message (format nil "Unable to analyse know structure , exp : ~A" exp))
	 (when (gethash exp position)
	   (highlight-error (first (gethash exp position))))
	 exp)))

;; *******************************************************************************************************
;; Add debugging code to a function call
;; *******************************************************************************************************

(defun add-code-exp-function (exp free position source)
  (cons (first exp) (mapcar #'(lambda (arg)
				(add-debug-point arg free position source))
			    (rest exp))))

;; *****************************************************************************************************
;; Add debugging code to a macro call if this is possible
;; *****************************************************************************************************

(defun add-code-exp-macro (exp free position source)
  (add-code-exp (macroexpand-1 exp) free position source))

;; *************************************************************************************
;; Do the work of adding debug code 
;; *************************************************************************************

(defun add-debug-point (exp variables position source)
  (let ((b-e (gethash exp position)))
    (cond ((and b-e (listp exp) (not (null exp))) ;; Breakpoint must have source info and must be a functioncall
	   (set-possible-breakpoint source (first b-e) (1+ (rest b-e)))
	   (list 'progn
		 (list 'debug-point
		       (list 'quote source)               ;; Source name
		       (first b-e)     ;; begin-pos in source , number if defined else nil
		       (if b-e (1+ (rest  b-e)) nil)     ;; end-pos in source , number if defined else nil
		       (cons 'list (mapcar #'(lambda (var) (list 'cons (list 'quote var) var)) variables)))
		 (list 'ds exp (add-code exp variables position source))))
	  (t exp))))

;; **************************************************************************************
;; Do the work of adding the first breakpoint code
;; **************************************************************************************

(defun add-debug-point-first (exp variables position source)
  (let ((b-e (gethash exp position)))
    (when b-e (set-possible-breakpoint source (first b-e) (1+ (rest b-e))))
    (list 'progn (list 'debug-point
		       (list 'quote source)
		       (first b-e)
		       (if b-e (1+ (rest b-e)) nil)
		       (cons 'list (mapcar #'(lambda (var) (list 'cons (list 'quote var) var)) variables)))
	  nil)))

;; **************************************************************************************
;; Does the work of transforming a piece of code in debugged code , is called by 
;; debug-open-file
;; **************************************************************************************

(defun add-debugging-code (exp position source)
  (db-c-set source position)
;;  (db-c-set-exp exp)
  (db-c-clear)
  (cond ((null exp) exp) ;; Case of nil expression
	((add-code-exp exp nil position source))
	(t 
	 (message (format nil "Unable to analyse know structure , exp : ~A" exp))
	 (when (gethash exp position)
	   (highlight-error (first (gethash exp position))))
	 exp)))



;; ##################################################
;; ##################################################
;; ##################################################
;; ###### SECTION 4 #################################
;; ##################################################
;; ##################################################
;; ##################################################

;; **************************************************************************************
;; **************************************************************************************
;; Code , used during the debugging operation itself
;; **************************************************************************************
;; **************************************************************************************

;; ****************************************************************
;; Global vars used in debugging section
;; ****************************************************************

(defparameter **current-env** nil)
(defparameter **end-debug-eventloop** nil)
(defparameter **previous-call** nil)
(defparameter **previous-value** nil)
(defparameter **time** nil)
(defparameter **display-previous** nil)


;; *****************************************************************
;; Save the result of a function call
;; *****************************************************************

(defmacro ds (exp vls)
  (let ((val (gensym)))
    `(let ((,val (multiple-value-list ,vls)))
	   (push  ,val **previous-value**)
	   (push (quote ,exp) **previous-call**)
	   (apply #'values ,val))))



;; ******************************************************************
;; End the eventloop in a debug point , allowing further processing *
;; ******************************************************************

(defun end-debug-eventloop ()
  (setf **current-env** nil)
  (setf **alternate-time** -1)
  (setf **end-debug-eventloop** t))


;; *********************************************************************
;; Lisp function called in a debug point                               *
;; *********************************************************************

(defun debug-point (lisp-source begin end env)
  (setf **end-debug-eventloop** nil)
  (setf **current-env** env)
  (save-time env begin end lisp-source)
  (give-control-to-interface lisp-source begin end)
  (loop
    (cond (**end-debug-eventloop**
	   (return))
	  (t
	   (process-incoming))))) ;; Process commands from debugger


;; *******************************************************************************
;; Lisp function to be called from the interface to display the watch expressions
;; and watch variables
;; *******************************************************************************


(defun display-watch-expressions (&rest arg-lst)
  (let ((type-exp-lst (reverse arg-lst))
	(result nil)
	(i 0))
    (declare (fixnum i))
    ;; Display previous result if it exist and if allowed
    (when **display-previous**
      (mapc #'(lambda (exp value)
		(incf i)
		(if (endp value)
		    (push (princ-to-string (first value)) result)
		  (push (princ-to-string (cons 'values value)) result))
		(push (format nil "[~A]" exp) result))
	    **previous-call**
	    **previous-value**))
    (setf **previous-call** nil)
    (setf **previous-value** nil)
    ;; Display of watch expressions
    (mapc #'(lambda (type-exp)
	      (incf i)
	      (cond ((eq (first type-exp) 'user::V)
		     (push (display-watch-var (second type-exp)) result)
		     (push (second type-exp) result))
		    ((eq (first type-exp) 'user::U)
		     (push "Undefined" result)
		     (push (second type-exp) result))
		    ((eq (first type-exp) 'user::E)
		     (push (display-watch-exp (second type-exp)) result)
		     (push (second type-exp) result))
		    (t
		     (push "Undefined" result)
		     (push "Unknown" result))))
	  type-exp-lst)
    (push i result)
    (apply #'display-result-in-interface result)))
    

;; **************************************************************************************
;; Find the value of a lisp variable                                                   **
;; **************************************************************************************


(defun display-watch-var (var-name)
  (declare (string var-name))
  (when (or (eq (char var-name 0) #\()
	    (eq (char var-name 0) #\)))
    (return-from display-watch-var "Undefined"))
  (let ((symbol (read-from-string var-name nil nil))
	(value nil))
    (cond ((setf value (assoc symbol **current-env**))
	   (princ-to-string (rest value)))
	  ((boundp symbol)
	   (princ-to-string (symbol-value symbol)))
	  (t
	   "Undefined"))))


	  
;; **************************************************************************************
;; Find the value of a lisp expression                                                 **
;; **************************************************************************************


(defun display-watch-exp (exp-string)
  (let ((error nil)
	(exp nil)
	(lst-result))
    (multiple-value-setq (lst-result error) (ignore-errors (multiple-value-list (read-from-string exp-string))))
    (when error
      (message (princ-to-string error))
      (return-from display-watch-exp "Undefined"))
    (setf exp (first lst-result))
    (setf exp (list 'let
		    (mapcar #'(lambda (var-value) (list (first var-value) (rest var-value))) **current-env**)
		    exp))
    (multiple-value-setq (lst-result error) (ignore-errors (multiple-value-list (eval exp))))
    (when error
      (message (princ-to-string error))
      (return-from display-watch-exp "Undefined"))
    (if (endp (rest lst-result))
	(princ-to-string (first lst-result))
      (princ-to-string (cons 'values lst-result)))))

#+gcl
(defun display-watch-exp (exp-string)
  (let ((error nil)
	(exp nil)
	(result))
    (multiple-value-setq (result error) (safe-eval `(read-from-string ,exp-string)))
    (when error
      (message (princ-to-string error))
      (return-from display-watch-exp "Undefined"))
    (setf exp (list 'let
		    (mapcar #'(lambda (var-value) (list (first var-value) (rest var-value))) **current-env**)
		    result))
    (multiple-value-setq (result error) (safe-eval exp))
    (when error
      (message (princ-to-string error))
      (return-from display-watch-exp "Undefined"))
    (princ-to-string result)))




;; **************************************************************************************
;; Evaluate a expression and display watch points
;; **************************************************************************************

(defun display-result-exp (exp)
  (display-exp-in-interface exp (display-watch-exp exp)))


;; **************************************************************************************
;; Check if we must stay in the debugloop because of a conditional breakpoint
;; **************************************************************************************


(defun if-breakpoint (exp)
  (let ((result (string-upcase (display-watch-exp exp))))
    (if (or (string= result "NIL") (string= result "UNDEFINED"))
	(end-debug-eventloop)
      (call-if-breakpoint))))




;; *************************************************************************************
;; Keep track of environments in time
;; *************************************************************************************

;; ************************************************************************************
;; Create array to store different environments to do timetraveling
;; ************************************************************************************

(defun prepare-time (length)
  (declare (fixnum length))
  (setf **time** (make-array length :initial-element nil))
  (setf **now** 0)
  (setf **end-of-time** (1- length)))

;; *************************************************************************************
;; Store current environment in time
;; *************************************************************************************

(defun save-time (env begin end source)
  (setf (aref **time** **now**) (list env begin end source))
  (setf **now** (next-time **now**)))


;; *************************************************************************************
;; Go forwards in time , negative time means we want to jump to just after the current time
;; *************************************************************************************

(defun next-time (time)
  (cond ((< time 0) (prev-time **now**))
	((= time **end-of-time**)
	 0)
	(t (1+ time))))

;; *************************************************************************************
;; Go backwards in time , negative time means we want to jump to the current time
;; *************************************************************************************

(defun prev-time (time)
  (cond ((< time 0) (prev-time (prev-time **now**)))
	((zerop time)
	 **end-of-time**)
	(t (- time 1))))

;; *************************************************************************************
;; Step back in time
;; *************************************************************************************

(defun step-back-in-time ()
  (setf **alternate-time** (prev-time **alternate-time**))
  (let ((time **alternate-time**))
    (loop
      (when (not (null (aref **time** **alternate-time**)))
	    (return))
      (setf **alternate-time** (prev-time **alternate-time**))
      (when (= time **alternate-time**)
	(message "No history kept")
	(return-from step-back-in-time)))
    (when (= **now** **alternate-time**)
      (message "You are at the current breakpoint"))
    (setf **current-env** (first (aref **time** **alternate-time**)))
    (apply #'display-time-env (rest (aref **time** **alternate-time**)))))


;; ************************************************************************************
;; Step forward in time
;; ************************************************************************************

(defun step-forward-in-time ()
  (setf **alternate-time** (next-time **alternate-time**))
  (let ((time **alternate-time**))
    (loop
      (when (not (null (aref **time** **alternate-time**)))
	(return))
      (setf **alternate-time** (next-time **alternate-time**))
      (when (= time **alternate-time**)
	(message "No History kept")
	(return-from step-forward-in-time)))
    (when (= **now** **alternate-time**)
      (message "You are at the current breakpoint"))
    (setf **current-env** (first (aref **time** **alternate-time**)))
    (apply #'display-time-env (rest (aref **time** **alternate-time**)))))



;; **********************************************************************************
;; Export of debug and prepare-time to normal lisp environment
;; **********************************************************************************

#+:allegro-cl-master
(in-package "user")
#+:allegro-cl-master
(shadowing-import 'DEBUGGER::deb "user")

#-:allegro-cl-master
(in-package "USER")
#-:allegro-cl-master
(shadowing-import 'DEBUGGER::debug "USER")


