/*
 * lisp debug version 0.8 a 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
 * 
 * You can reach me at : mmertens@akam.be
 */

/* 
 * There are 3 ways to start the interface 
 *
 * 1. 'interface' , the interface doesn't need a PID nr form the parent
 * 2. 'interface pid' , pid > 0 , pid is the PID of the parent , interface must send a signal to pid to
 *                      indicate processing
 * 3. 'interface -port' , port nummer to use , communication happens with port nr
 * 
 * 
 */

/* 
 * tkAppInit.c --
 *
 *	Provides a default version of the Tcl_AppInit procedure for
 *	use in wish and similar Tk-based applications.
 *
 * Copyright (c) 1993 The Regents of the University of California.
 * Copyright (c) 1994 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * SCCS: @(#) tkAppInit.c 1.22 96/05/29 09:47:08
 */

#include "tk.h"
#include "hash.h"
#include "errno.h"
#include <sys/types.h>
#include <sys/socket.h>
#include <sys/stat.h>
#include <fcntl.h>
#include <stdio.h>
#include <sys/un.h>
#include <unistd.h>
#include <search.h>  /* Routines to work with hash tables */
#include <netinet/in.h>
#include <arpa/inet.h>

/*
 * The following variable is a special hack that is needed in order for
 * Sun shared libraries to be used for Tcl.
 */

extern int matherr();
int *tclDummyMathPtr = (int *) matherr;


#include <varargs.h>
#include <tcl.h>
#include <stdio.h>
#include <stdlib.h>
#include <sys/types.h>
#include <string.h>
#include <limits.h>


/* 
 * Structures used by the debugger
 */


/*
 * Structure to hold info on debugpoints , used in binary tree
 */

typedef struct debugpoint
{
  char type; /* Type of breakpoint 8 bits , B1=breakpoint , B2=tempory breakpoint , B3=Conditional Breakpoint */
  char *exp; /* Conditional exp in conditional breakpoint */
  long executed; /* Contains the number of time the breakpoint is passed */
  char *source; /* Source the breakpoint is residing in */
  long begin;   /* Begin of the debugpoint */
  long end; /* End of the debugpoint */
} DEBUGPOINT;

HASH *H_DEBUGPOINT; /* Root of the debugpoint tree to hold informations about debugpoints */


typedef struct watchpoint
{
  char type; /* Type of watchpoint , 'V' is variable , 'E' is expression */
  char *exp; /* watchpoint variable or expression */
  char *source; /* Source where they are valid */
  long begin;
  long end;
} WATCHPOINT;
 
/*
 * Constants defined
 */ 

#define FILE_NAME_MAX 1025
#define MAX_LINE_LENGTH 100000
#define MAX_LINES 100000
#define MAX_STRING 1025
#define SIGUSR1 10


/* 
 * Linked list used 
 */

LIST *L_WATCHPOINTS=NULL;
LIST *L_SOURCES=NULL;

/* 
 * Global variables used by the main program
 */

static Tcl_Interp *interp;   /* Interpreter for this aplication */
static int PPID;             /* PPID */
static int server_sockfd,client_sockfd; /* Socket handlers client , server */
FILE *f_client_sockfd;                  /* f socket handler */
Tk_Window mainWindow;        /* Handle of the main Window */

/* 
 * Global variables used to hold the information need to converse between line.char and absolute position
 */

long LengthText;
long LineAbsolute[MAX_LINES];

/*
 * Global variables used for status and configuration information of the debugger
 */

int COMPILE_CODE; /* If true , debugged code must be compiled before loaded */
int SAVE_ON_EXIT; /* If true , settings of the debugger must be saved on exit */
int DISPLAY_PREVIOUS; /* If true the result of a previous call is visable in the debug window */

char CURRENT_SOURCE[FILE_NAME_MAX+1]; /* Current source , loaded in the debugger window */
char DEBUGPOINT_COLOR[MAX_STRING]="#ff0000";
char DEBUGPOINTIF_COLOR[MAX_STRING]="#808000";
char CURRENT_COLOR[MAX_STRING]="#00ffff";
char PROFILE_COLOR[MAX_STRING]="#ffff00";
char FONT[MAX_STRING]="-*-helvetica-medium-r-normal-*-120-*-*-*-*-*-*";

int STEP_MODE; /* If true we are stepping thru the source */
int STEP_OVER_MODE; /* IF true , STEP_MODE = 0 and we are stepping over */
long STEP_OVER_BEGIN=0; /* Begin position of the list we are stepping over in */
long STEP_OVER_END=0;  /* End position of the list we are stepping over in */
int IN_BREAKPOINT=0;   /* Indicate if we are in a breakpoint , this means that the lisp system is in a loop 
			  able to receive commands from the interface */
long CURRENT_BEGIN; /* Copy of the current begin point in a breakpoint */
long CURRENT_END;   /* Copy of the current end point in a breakpoint */
char CURRENT_IN_SOURCE[FILE_NAME_MAX+1]; /* Indicates the source of the last breakpoint */
int PROFILING=0;    /* Indicate profiling , 0 = not profiling , 1 = profiling */
int MAX_PROFILING_COUNT=0;  /* Max PROFILE_COUNT REACHED */
long EXECUTED=0; /* Used in profiling to define threshold value to highlight code */

char FIND_POS[15]; /* Current position in find operation */
int SEARCH_TYPE; /* Search type in find operation */

/*
 * Function prototypes (damn these C compilers)
 */

int Tcl_Invoke();


/*
 * Comparisation operator of debugpoints
 */

int c_debugpoint(const void *first,const void *second)
{
  DEBUGPOINT *one,*two;
  one=(DEBUGPOINT *) first;
  two=(DEBUGPOINT *) second;

  if (strcmp(one->source,two->source)==0)
    {
      /* Same source */
      if ((one->begin==two->begin) && (one->end==two->end))
	{
	  return 0;
	}
      else if ((one->begin==two->begin) && (one->end>two->end))
	{
	  return 1;
	}
      else if ((one->begin==two->begin) && (one->end<two->end))
	{
	  return -1;
	}
      else if (one->begin>two->begin)
	{
	  return 1;
	}
      else if (one->begin<two->begin)
	{
	  return -1;
	};
    }
  else
    {
      return strcmp(one->source,two->source);
    };
}

/* 
 * Read a string from the lisp system , first read length and then read rest
 */

void Read_String_Arg(char *string)
{
  long len;

  fscanf(f_client_sockfd,"%ld",&len);
  if (len>MAX_STRING-1) 
    len=MAX_STRING-1;
  fgetc(f_client_sockfd);
  fread(string,sizeof(char),len,f_client_sockfd);
  string[len]='\0';
}



/*
 * Read the source in the source windows and prepare the tables to convert between
 * line.char and absolute position
 */

void Read_Source (Tcl_Interp *interp,char FileName[])
{
  int i;
  FILE *h;
  unsigned char line[MAX_LINE_LENGTH+29];
  long length;

  length=0;
  LengthText=1;
  LineAbsolute[0]=0;
  if ((h=fopen(FileName,"r"))==NULL)
    {
      /* Problem open file for read , so skip reading the file" */
      fprintf(stderr,"Could not open source file");
      return;
    };
  Tcl_Eval(interp,".text.text configure -state normal");
  Tcl_Eval(interp,".text.text delete 1.0 end");

  while ((fgets(line,MAX_LINE_LENGTH,h)!=NULL) && (LengthText < MAX_LINES))
    {
      LineAbsolute[LengthText]=strlen(line)+length; 
      length=LineAbsolute[LengthText];
      LengthText=LengthText+1;
      /*  Tcl_Eval(interp,line);  */
      Tcl_Invoke(interp,".text.text","insert","end",line,NULL); 
    };

  fclose(h);
  Tcl_Eval(interp,".text.text configure -state disabled");
}
  
/*
 * Conversion of absolute position to x.y format
 */

void AbsoluteToIndex(long position,char *result)
{
  long i;
  long l,c;
  
  if (position<1)
    position=1;

  for (i=0;LineAbsolute[i]<position && i<LengthText;i++);
  if (i==LengthText)
    {
      result[0]='e';
      result[1]='n';
      result[2]='d';
      result[3]='\0'; /* We have reached the end of the text */
      return;
    };
  
  l=i;  /* Line in text , starts from 1 */;
  c=position-LineAbsolute[i-1]-1; /* Character on line starts from 0 */
  sprintf(result,"%ld.%ld",l,c);
}

long IndexToAbsolute(char *index)
{
  long l,c;
  
  if (sscanf(index,"%ld.%ld",&l,&c)!=2)
    /* Incorrect input */
    return -1;
 
  if (l>=LengthText)
    return LineAbsolute[LengthText-1]+c;
  return LineAbsolute[l-1]+c+1;
}

/* 
 * Code to modify the list of sources in the menu , should be called 
 * when L_SOURCES changes
 */

void Change_Source_Menu_Walk(char *key,char *source)
{
  char command[2*FILE_NAME_MAX+100];
  sprintf(command,".menu.source.source add command -label %s -command \"load-source %s\"",source,source);
  Tcl_Eval(interp,command);
}

void Change_Source_Menu()
{
  Tcl_Eval(interp,".menu.source.source delete 0 end");
  walk_list(L_SOURCES,Change_Source_Menu_Walk);
}

/*
 * Code to be executed when we leave a breakpoint 
 */
  
void Leave_Breakpoint()
{
  /* Stop highlighting and leave breakpoint */
  if (IN_BREAKPOINT!=0)
    {
      IN_BREAKPOINT=0;
      Tcl_Invoke(interp,".text.text","tag","delete","breakpoint",NULL);
      write(client_sockfd,"(DEBUGGER::end-debug-eventloop)\n",32);
    };
}

/*
 * Code to test if a conditional breakpoint has been set , only exectuted in breakpoint
 */

void check_if_breakpoint(char *exp)
{
  write(client_sockfd,"(DEBUGGER::if-breakpoint \"",26);
  write(client_sockfd,exp,strlen(exp));
  write(client_sockfd,"\")\n",3);
}

/*
 * Code to be executed when we display watchpoints
 */

void Display_Watchpoints_Walk(char *key,WATCHPOINT *p_watch)
{
  /* Insert watchpoints */
  Tcl_Invoke(interp,".result.text","insert","insert",p_watch->exp,NULL);
  Tcl_Invoke(interp,".result.text","insert","insert"," --> <Undefined>\n",NULL);
}

void Display_Watchpoints()
{
  /* Clear the field of all watchpoints */
  Tcl_Invoke(interp,".result.text","configure","-state","normal",NULL);
  Tcl_Invoke(interp,".result.text","delete","1.0","end",NULL);
  
  /* Fill in the field of watchpoints */
  walk_list(L_WATCHPOINTS,Display_Watchpoints_Walk);
  /* Disable the result window */
  Tcl_Invoke(interp,".result.text","configure","-state","disabled",NULL);
}
      
 
/*
 * Display watchpoints expressions and their result , my only be executed in a breakpoint
 */
void Display_Watchpoints_Result_Walk(char *key,WATCHPOINT *p_watch)
{
  char c[1];
  long length;

  write(client_sockfd," '(",3);
  if (p_watch->type == 'E' && (p_watch->begin > CURRENT_BEGIN || p_watch->end < CURRENT_END))
    {
      /* We may not calculate the value of the watchexpression and the result must be undefined */
      write(client_sockfd,"U",1);
    }
  else
    {
      c[0]=p_watch->type;
      write(client_sockfd,c,1);
    };
  write(client_sockfd," \"",2);
  length=strlen(p_watch->exp);
  write(client_sockfd,p_watch->exp,length);                               
  write(client_sockfd,"\")",2);
}

void Display_Watchpoints_Result()
{
  /* Create the lisp function to call */
  write(client_sockfd,"(DEBUGGER::display-watch-expressions",36);
  /* Fill in the arguments */
  walk_list(L_WATCHPOINTS,Display_Watchpoints_Result_Walk);
  /* End the expression */
  write(client_sockfd,")\n",2);
  if (PPID != 0)
    {
      kill(PPID,SIGUSR1);  /* Send a signal to client , to indicate there is a command waiting */
    };
}
     
  
/*
 * Check if we have to reload the source in the source window
 */

void Change_Source()
{
  if (strcmp(CURRENT_SOURCE,CURRENT_IN_SOURCE)!=0)
    {
      /* We have to reload anouther source */
      strcpy(CURRENT_SOURCE,CURRENT_IN_SOURCE);
      Read_Source(interp,CURRENT_SOURCE);
    }
}


/*
 * From the current position of the insert point in de text select the innermost list
 */

void DebugSelectList(char s_start[])
{
  long nrHook;
  char s_pos[40],s_temp[40];
  char s_begin[40],s_end[40];
  nrHook=0;
  
  strcpy(s_pos,s_start);
  Tcl_Invoke(interp,".text.text","index",s_pos,NULL);
  if (interp->result[0]!='0' && interp->result[0]!='1' && interp->result[0]!='2' &&
      interp->result[0]!='3' && interp->result[0]!='4' && interp->result[0]!='5' &&
      interp->result[0]!='4' && interp->result[0]!='5' && interp->result[0]!='6' &&
      interp->result[0]!='7' && interp->result[0]!='8' && interp->result[0]!='9')
    /* Incorrect position given */
    return;

  /* Search for the beginning of a the innermost list */

  while (1==1)
    {
      Tcl_Invoke(interp,".text.text","search","-backwards","-regexp","[()]",s_pos,"1.0",NULL);
      if (interp->result[0]=='\0')
	{
	  return; /* No opening hook found */
	};
      strcpy(s_pos,interp->result);
      sprintf(s_temp,"%s linestart",s_pos);

      Tcl_Invoke(interp,".text.text","search","-backwards",";",s_pos,s_temp,NULL);
      if (interp->result[0]=='\0')
	{
	  /* We are not in a lisp comment */
	  Tcl_Invoke(interp,".text.text","get",s_pos,NULL);
	  if (interp->result[0]==')')
	    {
	      /* Encountered a closing hook */
	      nrHook=nrHook+1;
	      continue;
	    }
	  /* Encountered a opening hook */
	  else if (nrHook==0)
	    {
	      /* Found the innermost opening hook */
	      strcpy(s_begin,s_pos);
	      break;
	    }
	  else
	    /* Found just a opening hook */
	    {
	      nrHook=nrHook-1;
	      continue;
	    };
	}
      else
	{
	  /* We are in a lisp comment */
	  continue;
	};
    };
  /* Search for the end of the innermost list */
  nrHook=0;
  sprintf(s_pos,"%s + 1 chars",s_pos);
  while (1==1)
    {
      Tcl_Invoke(interp,".text.text","search","-forwards","-regexp","[();]",s_pos,"end",NULL);
      if (interp->result[0]=='\0')
	{
	  /* Didn't found a closing hook */
	  return;
	};
      strcpy(s_pos,interp->result);
      Tcl_Invoke(interp,".text.text","get",s_pos,NULL);
      if (interp->result[0]==';')
	/* Found a start of a comment */
	{
	  sprintf(s_pos,"%s lineend + 1 chars",s_pos);
	  continue;
	}
      else if (interp->result[0]=='(')
	{
	  /* Found a opening hook */
	  nrHook=nrHook+1;
	  sprintf(s_pos,"%s + 1 chars",s_pos);
	  continue;
	}
      else if (nrHook==0)
	{
	  /* Found the closing hook */
	  sprintf(s_end,"%s + 1 chars",s_pos);
	  break;
	}
      else
	{
	  /* Found just a closing hook */
	  nrHook=nrHook-1;
	  sprintf(s_pos,"%s + 1 chars",s_pos);
	  continue;
	};
    };
  /* Now select the text begin the begin and end field */
  
  Tcl_Invoke(interp,".text.text","tag","remove","sel","1.0","end",NULL);
  Tcl_Invoke(interp,".text.text","tag","add","sel",s_begin,s_end,NULL);
}

/*
 * Functions called from lisp
 */


/*
 * Highlight part of the source
 */

void highlight_source ()
{
  long begin,end;
  char s_begin[30],s_end[30];
  char type[MAX_STRING];
  char color[MAX_STRING];

  /* Read arguments */

  fscanf(f_client_sockfd,"%ld",&begin);
  fscanf(f_client_sockfd,"%ld",&end);
  Read_String_Arg(type);
  Read_String_Arg(color);
  fgetc(f_client_sockfd); /* Reads last return */

  /* Execute code */

  AbsoluteToIndex(begin,s_begin);
  AbsoluteToIndex(end,s_end);
  Tcl_Invoke(interp,".text.text","tag","add",type,s_begin,s_end,NULL);
  Tcl_Invoke(interp,".text.text","tag","configure",type,"-background",color,NULL);

  /* Return OK */
  /* write(client_sockfd,"t\n",2); */
}


/*
 * Sets a breakpoint of type type-breakpoint 
 */

int Set_Debug_Breakpoint(int type_breakpoint)
{
  long begin,end;
  char s_begin[30],s_end[30];
  DEBUGPOINT *p_debugpoint;
  char key[MAX_STRING+30];
  char *exp;
  
  
  Tcl_Invoke(interp,".text.text","index","sel.first",NULL);
  begin=IndexToAbsolute(interp->result);
  Tcl_Invoke(interp,".text.text","index","sel.last",NULL);
  end=IndexToAbsolute(interp->result);
  
  if ((begin < 0) || (end < 0))
    {
      /* No selection made , return */
      return TCL_OK;
    };
  
  /* Sets up the key of the entry in the binary tree */
  sprintf(key,"%ld%ld%s",begin,end,CURRENT_SOURCE);
  
  if ((p_debugpoint=(DEBUGPOINT *) search_hash(H_DEBUGPOINT,key))==NULL)
    {
      Tcl_Eval(interp,"tk_dialog .m Message \"No breakpoint possible at selected part\" {} -1 Ok");
    }
  else
    {
      AbsoluteToIndex(begin,s_begin);
      AbsoluteToIndex(end,s_end);

      /* Take action dependend on type of breakpoint */
      switch (type_breakpoint)
	{
	case 1:
	  if ((p_debugpoint->type & 128) == 128)
	    {
	      /* Breakpoint is set , so unset breakpoint */
	      Tcl_Invoke(interp,".text.text","tag","remove","debug",s_begin,s_end,NULL);

	      p_debugpoint->type=p_debugpoint->type & 127; /* Disable the breakpoint */
	    }
	  else
	    {
	      /* Breakpoint is not set , so set breakpoint */
	      Tcl_Invoke(interp,".text.text","tag","add","debug",s_begin,s_end,NULL);
	      Tcl_Invoke(interp,".text.text","tag","configure","debug","-foreground",DEBUGPOINT_COLOR,NULL);
	      p_debugpoint->type=p_debugpoint->type | 128; /* Enable the breakpoint */
	    };
	  break;
	case 2:
	  /* Set tempory breakpoint , independent of the existance of a tempory breakpoint */
	  p_debugpoint->type=p_debugpoint->type | 64; /* Enable the breakpoint */
	  break;
	case 3:
	  if ((p_debugpoint->type & 32) == 32)
	    {
	      /* Breakpoint is set , so unset breakpoint */
	      Tcl_Invoke(interp,".text.text","tag","remove","debugif",s_begin,s_end,NULL);
	      p_debugpoint->type=p_debugpoint->type & 31; /* Disable the breakpoint */
	      free(p_debugpoint->exp);
	    }
	  else
	    {
	      /* Breakpoint is not set , so set breakpoint */
	      Tcl_Invoke(interp,".command.text","get","1.0","end - 1 chars",NULL);
	      if (interp->result[0]=='\0')
		return TCL_OK; /* No expression , so no conditional breakpoint */
	      /* We met conditions of a conditional breakpoint */
	      Tcl_Invoke(interp,".text.text","tag","add","debugif",s_begin,s_end,NULL);
	      Tcl_Invoke(interp,".text.text","tag","configure","debugif","-foreground",DEBUGPOINTIF_COLOR,NULL);
	      p_debugpoint->type=p_debugpoint->type | 32; /* Enable the breakpoint */
	      Tcl_Invoke(interp,".command.text","get","1.0","end - 1 chars",NULL);
	      exp=malloc(sizeof(char)*(strlen(interp->result) +1));
	      strcpy(exp,interp->result);
	      p_debugpoint->exp=exp;
	    };
	  break;
	};
    };
  return TCL_OK;
};




/*
 * Called by the debugcode of lisp functions 
 */

void give_control_to_interface ()
{
  long begin,end;
  char s_begin[30],s_end[30];
  char source[MAX_STRING];
  char key[MAX_STRING+30];
  DEBUGPOINT *p_debugpoint;
  int stop_and_display; /* 0 = exit loop and delete highlight  , 1 = highlight and no exit loop  , 2 =  no exit loop */

  /* Indicate we are in a breakpoint */
  
  IN_BREAKPOINT=1;

  /* Read arguments */
  
  Read_String_Arg(source);
  fscanf(f_client_sockfd,"%ld",&begin);
  fscanf(f_client_sockfd,"%ld",&end);
  fgetc(f_client_sockfd); /* Reads last return */
  
  /* Communicate begin,end and source via global var to other functions , called in the interface */

  CURRENT_BEGIN=begin;
  CURRENT_END=end;
  strcpy(CURRENT_IN_SOURCE,source);

  stop_and_display=0;

  /* Figure out if we must stop and display the current line */
  if (STEP_MODE)
    {
      /* In step mode we must stop , highlight the debugwindow and wait for further instructions */
      stop_and_display=1;
    };
  if (STEP_OVER_MODE)
    {
      /* In step over mode we stop and highlight only if we are in the boundaries */
      if ((STEP_OVER_BEGIN <= begin) && (end <= STEP_OVER_END))
	{
	  stop_and_display=1;
	};
    };
  
  /* Check if breakpoint is set */
  sprintf(key,"%ld%ld%s",begin,end,source);
  if ((p_debugpoint=(DEBUGPOINT *) search_hash(H_DEBUGPOINT,key))!=NULL)
    {
      /* Update profile info if needed */
      if (PROFILING==1)
	{
	  p_debugpoint->executed=p_debugpoint->executed+1;
	  if (p_debugpoint->executed > MAX_PROFILING_COUNT)
	      MAX_PROFILING_COUNT=p_debugpoint->executed;
	};
      /* Check if the debugpoint is set */
      if ((p_debugpoint->type & 128) == 128)
	{
	  /* Breakpoint is set */
	  stop_and_display=1;
	}
      else if ((p_debugpoint->type & 64) == 64)
	{
	  /* Tempory breakpoint is set */
	  stop_and_display=1;
	  p_debugpoint->type=p_debugpoint->type & 63; /* Disable tempory breakpoint */
	}
      else if ((p_debugpoint->type & 32) == 32)
	{
	  /* Conditional breakpoint */
	  check_if_breakpoint(p_debugpoint->exp);
	  stop_and_display=2;
	};
    };

  
  /* We must stop and display a breakpoint , stopping is done automatically by loop in debugcode in lisp */
  if (stop_and_display==1)
    {
      /* Display results in result window */

      Display_Watchpoints_Result();

      /* Code to change source displayed if needed */
      
      Change_Source();

      /* Highlight code reached */
      AbsoluteToIndex(begin,s_begin);
      AbsoluteToIndex(end,s_end);
      
      Tcl_Invoke(interp,".text.text","tag","delete","breakpoint",NULL);
      Tcl_Invoke(interp,".text.text","tag","add","breakpoint",s_begin,s_end,NULL);
      Tcl_Invoke(interp,".text.text","yview","-pickplace",s_begin,NULL);
      Tcl_Invoke(interp,".text.text","tag","configure","breakpoint","-background",CURRENT_COLOR,NULL);
    }
  else if (stop_and_display==2)
    {
    }
  else
    {
      Leave_Breakpoint();
    };
}
  
/*
 * Called by lisp system to display the result of watch expressions , and watch variables
 */

void display_result_in_interface()
{
  long i,nr_args;
  char watch_exp[MAX_STRING];
  char watch_value[MAX_STRING];
  
  /* Clear the field of all watchpoints */
  Tcl_Invoke(interp,".result.text","configure","-state","normal",NULL);
  Tcl_Invoke(interp,".result.text","delete","1.0","end",NULL);
  /* Reads the arguments */
  fscanf(f_client_sockfd,"%ld",&nr_args);
  /* Reads the exp and value */
  for (i=1;i<=nr_args;i++)
    {
      Read_String_Arg(watch_exp);
      Read_String_Arg(watch_value);
      Tcl_Invoke(interp,".result.text","insert","insert",watch_exp,NULL);
      Tcl_Invoke(interp,".result.text","insert","insert"," --> ",NULL);
      Tcl_Invoke(interp,".result.text","insert","insert",watch_value,NULL);
      Tcl_Invoke(interp,".result.text","insert","insert","\n",NULL);
    };
  fgetc(f_client_sockfd); /* Reads last return */
  Tcl_Invoke(interp,".result.text","configure","-state","disabled",NULL);
}

/*
 * Called by LISP to display the result of evaluating a expression in a result window
 */

void display_exp_in_interface()
{
  char exp[MAX_STRING],result[MAX_STRING];

  /* Read the arguments */
  
  Read_String_Arg(exp);
  Read_String_Arg(result);
  fgetc(f_client_sockfd); /* Reads last return */
  
  /* Display the result */
  Tcl_Invoke(interp,".result.text","configure","-state","normal",NULL);

  Tcl_Invoke(interp,".result.text","insert","insert",exp,NULL);
  Tcl_Invoke(interp,".result.text","insert","insert"," --> ",NULL);
  Tcl_Invoke(interp,".result.text","insert","insert",result,NULL);
  Tcl_Invoke(interp,".result.text","insert","insert","\n",NULL);
  
  Tcl_Invoke(interp,".result.text","configure","-state","disabled",NULL);
}

/*
 * Called by LISP to invoke a real breakpoint
 */

void if_breakpoint()
{
  char s_begin[30],s_end[30];

  
  /* Display results in result window */
  Display_Watchpoints_Result();
  /* Code to change source displayed if needed */
  Change_Source();
  /* Highlight code reached */
  AbsoluteToIndex(CURRENT_BEGIN,s_begin);
  AbsoluteToIndex(CURRENT_END,s_end);
  
  Tcl_Invoke(interp,".text.text","tag","delete","breakpoint",NULL);
  Tcl_Invoke(interp,".text.text","tag","add","breakpoint",s_begin,s_end,NULL);
  Tcl_Invoke(interp,".text.text","yview","-pickplace",s_begin,NULL);
  Tcl_Invoke(interp,".text.text","tag","configure","breakpoint","-background",CURRENT_COLOR,NULL);

  fgetc(f_client_sockfd); /* Reads last return */
}

/*
 * Called by lisp to display the current environment in time 
 */

void display_time_env ()
{
  long begin,end;
  char s_begin[15],s_end[15];
  
  fscanf(f_client_sockfd,"%ld",&begin);
  fscanf(f_client_sockfd,"%ld",&end);
  Read_String_Arg(CURRENT_IN_SOURCE);
  fgetc(f_client_sockfd); /* Reads return character */

  /* Display the envrionment */

  CURRENT_BEGIN=begin;
  CURRENT_END=end;
  Display_Watchpoints_Result();
  Change_Source();
  AbsoluteToIndex(begin,s_begin);
  AbsoluteToIndex(end,s_end);
  Tcl_Invoke(interp,".text.text","tag","delete","breakpoint",NULL);
  Tcl_Invoke(interp,".text.text","tag","add","breakpoint",s_begin,s_end,NULL);
  Tcl_Invoke(interp,".text.text","yview","-pickplace",s_begin,NULL);
  Tcl_Invoke(interp,".text.text","tag","configure","breakpoint","-background",CURRENT_COLOR,NULL);
}  

/*
 * Establish the settings of the debugger
 */

void setting()
{
  char var[MAX_STRING];
  int nr;
  
  Read_String_Arg(var);
  if (strcmp(var,"COMPILE_CODE")==0)
    {
      fscanf(f_client_sockfd,"%ld",&nr);
      fgetc(f_client_sockfd);
      COMPILE_CODE=nr;
      Tcl_UpdateLinkedVar(interp,"**compile-code**");
    }
  else if (strcmp(var,"DISPLAY_PREVIOUS")==0)
    {
      fscanf(f_client_sockfd,"%ld",&nr);
      fgetc(f_client_sockfd);
      DISPLAY_PREVIOUS=nr;
      Tcl_UpdateLinkedVar(interp,"**display-previous**");
      /* set the setting for the lisp system */
      if (DISPLAY_PREVIOUS)
	{
	  write(client_sockfd,"(setf DEBUGGER::**display-previous** t)\n",40);
	}
      else
	{
	  write(client_sockfd,"(setf DEBUGGER::**display-previous** nil)\n",42);
	};
      if (PPID != 0 && IN_BREAKPOINT==0)
	{
	  kill(PPID,SIGUSR1);  /* Send a signal to client , to indicate there is a command waiting */
	};
    }
  else if (strcmp(var,"SAVE_ON_EXIT")==0)
    {
      fscanf(f_client_sockfd,"%ld",&nr);
      fgetc(f_client_sockfd);
      SAVE_ON_EXIT=nr;
      Tcl_UpdateLinkedVar(interp,"**save-on-exit**");    
    }
  else if (strcmp(var,"DEBUGPOINT_COLOR")==0)
    {
      Read_String_Arg(var);
      fgetc(f_client_sockfd);
      strcpy(DEBUGPOINT_COLOR,var);
    }
  else if (strcmp(var,"DEBUGPOINTIF_COLOR")==0)
    {
      Read_String_Arg(var);
      fgetc(f_client_sockfd);
      strcpy(DEBUGPOINTIF_COLOR,var);
    }
  else if (strcmp(var,"CURRENT_COLOR")==0)
    {
      Read_String_Arg(var);
      fgetc(f_client_sockfd);
      strcpy(CURRENT_COLOR,var);
    }
  else if (strcmp(var,"PROFILE_COLOR")==0)
    {
      Read_String_Arg(var);
      fgetc(f_client_sockfd);
      strcpy(PROFILE_COLOR,var);
    }
  else if (strcmp(var,"FONT")==0)
    {
      Read_String_Arg(var);
      fgetc(f_client_sockfd);
      strcpy(FONT,var);
    }
  else
    {
      Tcl_Eval(interp,"tk_dialog .m Message \"Unknown setting encountered ,check .lispdebug\" {} -1 Ok");
    };
}


/*
 * Store a possible breakpoint,watchpoint in the tree of breakpoints
 */

void set_possible_breakpoint()
{
  long begin,end;
  char source[MAX_STRING];
  char *key,skey[MAX_STRING+30];
  DEBUGPOINT *p_debugpoint,*p;

  /* Reads arguments */
  
  Read_String_Arg(source);
  fscanf(f_client_sockfd,"%ld",&begin);
  fscanf(f_client_sockfd,"%ld",&end);
  fgetc(f_client_sockfd); /* Reads last return */

  /* Execute code */
  
  /* Handle item for tree  */
  p_debugpoint=malloc(sizeof(DEBUGPOINT));
  p_debugpoint->source=malloc((strlen(source)+1)*sizeof(char));
  strcpy(p_debugpoint->source,source);
  p_debugpoint->begin=begin;
  p_debugpoint->end=end;
  p_debugpoint->type=0;
  p_debugpoint->executed=0;

  /* Make key */
  sprintf(skey,"%ld%ld%s",begin,end,source);
  key=malloc(sizeof(char)*(strlen(skey)+1));
  strcpy(key,skey);

  /* Insert in hashtable if needed */
  
  insert_hash(H_DEBUGPOINT,key,(void *) p_debugpoint);

}


/*
 * Display a message bok with a Ok button for the lisp system
 */

void display_message ()
{
 char message[MAX_STRING];
 char command[MAX_STRING+50];
 static long n = 1;
 static long i;

 n=n+1; /* Modify counter of errormessage */
 
 /* Reads arguments */

 Read_String_Arg(message);
 fgetc(f_client_sockfd);  /* Reads last return */

 /* Filter out " characters because they cause the format of the message to be wrong */

 for (i=0;message[i]!='\0';i++)
   if (message[i]==34)
     message[i]=39;

 /* Process arguments */

 sprintf(command,"tk_dialog .m%ld Message \"%s\" {} -1 Ok",n,message);

 Tcl_Eval(interp,command);

 /* Return Ok */
 
 /* write(client_sockfd,"t\n",2); */
}


void highlight_error ()
{
  long begin;
  char s_begin[30];

  /* Read arguments */

  fscanf(f_client_sockfd,"%ld",&begin);
  fgetc(f_client_sockfd); /* Reads last return */

  /* Execute code */

  AbsoluteToIndex(begin,s_begin);
  Tcl_Invoke(interp,".text.text","tag","add","error",s_begin,"lineend",NULL);
  Tcl_Invoke(interp,".text.text","tag","configure","error","-background","red",NULL);

  /* Return OK */

  /* write(client_sockfd,"t\n",2); */
}

/* 
 * Functions called via TCL/TK
 */

/*
 * Select a list in the source
 */

int Select_List(ClientData data,Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[])
{
  long x,y;
  char s_pos[30];

  Tcl_GetLongFromObj(interp,objv[1],&x);
  Tcl_GetLongFromObj(interp,objv[2],&y);
  
  sprintf(s_pos,"@%ld,%ld",x,y);
  DebugSelectList(s_pos);
  return TCL_OK;
}

/*
 * Select a list in the source
 */

int Select_Word(ClientData data,Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[])
{
  long x,y;
  char s_begin[30];
  char s_end[30];

  Tcl_GetLongFromObj(interp,objv[1],&x);
  Tcl_GetLongFromObj(interp,objv[2],&y);
  
  sprintf(s_begin,"@%ld,%ld wordstart",x,y);
  sprintf(s_end,"@%ld,%ld wordend",x,y);

  Tcl_Invoke(interp,".text.text","tag","add","sel",s_begin,s_end,NULL);
  
  return TCL_OK;
}

/*
 * Select a whole function
 */

int Select_Function(ClientData data,Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[])
{
  long x,y;
  char s_pos[30];
  char s_temp[30];

  Tcl_GetLongFromObj(interp,objv[1],&x);
  Tcl_GetLongFromObj(interp,objv[2],&y);
  
  sprintf(s_pos,"@%ld,%ld",x,y);

  while (1==1)
    {
      Tcl_Invoke(interp,".text.text","search","-backwards","-regexp","[dD][eE][fF][uU][nN]",s_pos,"1.0",NULL);
      if (interp->result[0]=='\0')
	{
	  /* Didn't find a result */
	  return TCL_OK;
	};
      strcpy(s_pos,interp->result);
      sprintf(s_temp,"%s linestart",s_pos);
      Tcl_Invoke(interp,".text.text","search","-backwards",";",s_pos,s_temp,NULL);
      if (interp->result[0]!='\0')
	{
	  /* Found a comment , so skip comment */
	  sprintf(s_pos,"%s - 1 chars",s_pos);
	  continue;
	}
      else
	{
	  /* Found a defun not in a comment */
	  DebugSelectList(s_pos);
	  return TCL_OK;
	};
    };
  return TCL_OK;
}

/* 
 * Select a color for highlighting the code current executing 
 */

int Debug_Color_Break(ClientData data,Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[])
{
  Tcl_Invoke(interp,"tk_chooseColor",NULL);
  if (interp->result[0]=='\0')
    {
      return TCL_OK;
    }
  else
    {
      strcpy(CURRENT_COLOR,interp->result);
      return TCL_OK;
    };
}

/* 
 * Select a color for the breakpoints
 */

int Debug_Color_Breakpoint(ClientData data,Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[])
{
  Tcl_Invoke(interp,"tk_chooseColor",NULL);
  if (interp->result[0]=='\0')
    {
      return TCL_OK;
    }
  else
    {
      strcpy(DEBUGPOINT_COLOR,interp->result);
      Tcl_Invoke(interp,".text.text","tag","configure","debug","-foreground",DEBUGPOINT_COLOR,NULL);
      return TCL_OK;
    };
}

/* 
 * Select a color for the conditional breakpoints 
 */

int Debug_Color_Breakpointif(ClientData data,Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[])
{
  Tcl_Invoke(interp,"tk_chooseColor",NULL);
  if (interp->result[0]=='\0')
    {
      return TCL_OK;
    }
  else
    {
      strcpy(DEBUGPOINTIF_COLOR,interp->result);
      Tcl_Invoke(interp,".text.text","tag","configure","debugif","-foreground",DEBUGPOINTIF_COLOR,NULL);
      return TCL_OK;
    };
}


/* 
 * Select a color for the conditional breakpoints 
 */

int Debug_Color_Profile(ClientData data,Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[])
{
  Tcl_Invoke(interp,"tk_chooseColor",NULL);
  if (interp->result[0]=='\0')
    {
      return TCL_OK;
    }
  else
    {
      strcpy(PROFILE_COLOR,interp->result);
      Tcl_Invoke(interp,".text.text","tag","configure","profile","-background",PROFILE_COLOR,NULL);
      return TCL_OK;
    };
}

/*
 * Select a line in the font selection list 
 */

int Choose_Font_Select_Line(ClientData data,Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[])
{
  long x,y;
  char s_begin[30],s_end[30];
  char font[MAX_STRING];

  Tcl_GetLongFromObj(interp,objv[1],&x);
  Tcl_GetLongFromObj(interp,objv[2],&y);
  
  sprintf(s_begin,"@%ld,%ld linestart",x,y);
  sprintf(s_end,"@%ld,%ld lineend",x,y);
  Tcl_Invoke(interp,".font.list.list","get",s_begin,s_end,NULL);
  strcpy(font,interp->result);
  
  Tcl_Invoke(interp,".font.list.list","tag","remove","sel","1.0","end",NULL);
  Tcl_Invoke(interp,".font.list.list","tag","add","sel",s_begin,s_end,NULL);
  
  Tcl_Invoke(interp,".font.text.text","configure","-font",font,NULL);
  
  return TCL_OK;
}

/*
 * Process confirmation of choosend font
 */

int Choose_Font_Ok(ClientData data,Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[])
{
  /* Find selected font */
  Tcl_Invoke(interp,".font.list.list","get","sel.first","sel.last",NULL);
  strcpy(FONT,interp->result);
  /* Change font */
  Tcl_Invoke(interp,".text.text","configure","-font",FONT,NULL);
  Tcl_Invoke(interp,".result.text","configure","-font",FONT,NULL);
  Tcl_Invoke(interp,".command.text","configure","-font",FONT,NULL);
  /* Cancel font window */
  Tcl_Invoke(interp,"destroy",".font",NULL);
  /* End */
  return TCL_OK;
}

/*
 * Process the cancel button in the selectfont screen
 */

int Choose_Font_Cancel(ClientData data,Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[])
{
  /* Cancel font window */
  Tcl_Invoke(interp,"destroy",".font",NULL);
  /* End */
  return TCL_OK;
}

/* 
 * Select a font for the debugger
 */

int Debug_Font(ClientData data,Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[])
{
  FILE *fp;
  char line[MAX_STRING];

  /* First create a listbox */
  Tcl_Eval(interp,"toplevel .font");
  Tcl_Eval(interp,"grab .font");
  Tcl_Eval(interp,"frame .font.button");
  Tcl_Eval(interp,"frame .font.list");
  Tcl_Eval(interp,"frame .font.text");
  Tcl_Eval(interp,"pack .font.button .font.list .font.text -side top");
  Tcl_Eval(interp,"button .font.button.ok -text Ok -command choose-font-ok -state disabled");
  Tcl_Eval(interp,"button .font.button.cancel -text Cancel -command choose-font-cancel -state disabled");
  Tcl_Eval(interp,"pack .font.button.ok .font.button.cancel -side left");
  Tcl_Eval(interp,"scrollbar .font.list.scroll -command \".font.list.list yview\"");
  Tcl_Eval(interp,"text .font.list.list -yscrollcommand \".font.list.scroll set\"");
  Tcl_Eval(interp,"pack .font.list.list -in .font.list -side left");
  Tcl_Eval(interp,"pack .font.list.scroll -in .font.list -side left -expand yes -fill both");
  Tcl_Eval(interp,"text .font.text.text -height 4 -width 40");
  Tcl_Eval(interp,"pack .font.text.text");
  Tcl_Eval(interp,"bind .font.list.list <ButtonRelease-1> {choose-font-select-line %x %y}");
  /* Create the referenced commandos */
  Tcl_CreateObjCommand(interp,"choose-font-select-line",Choose_Font_Select_Line,(ClientData) 0 , (Tcl_CmdDeleteProc *) 0);
  Tcl_CreateObjCommand(interp,"choose-font-ok",Choose_Font_Ok,(ClientData) 0 , (Tcl_CmdDeleteProc *) 0);
  Tcl_CreateObjCommand(interp,"choose-font-cancel",Choose_Font_Cancel,(ClientData) 0 , (Tcl_CmdDeleteProc *) 0);
  /* Configure the example text */
  Tcl_Invoke(interp,".font.text.text","insert","end","abcdefghijklmnopqrstuvwxyz\nABCDEFGHIJKLMNOPQRSTUVWXYZ\n01234567890\n!@#$%^&*()_",NULL);
  Tcl_Invoke(interp,".font.text.text","tag","add","font","1.0","end",NULL);
  /* Get a list of available components */
  fp=popen("xlsfonts|sort -u","r");
  /* insert fonts in their font in the list */
  while (fgets(line,MAX_STRING-1,fp)!=NULL)
    {
      Tcl_Invoke(interp,".font.list.list","insert","insert",line,NULL);
    };
  fclose(fp);
  Tcl_Invoke(interp,".font.list.list","configure","-state","disabled",NULL);
  Tcl_Invoke(interp,".font.button.ok","configure","-state","normal",NULL);
  Tcl_Invoke(interp,".font.button.cancel","configure","-state","normal",NULL);
  return TCL_OK;
}

/* 
 * Process of changing of displaying the previous result
 */

int Debug_Display_Previous_Call(ClientData data,Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[])
{
  if (DISPLAY_PREVIOUS)
    {
      write(client_sockfd,"(setf DEBUGGER::**display-previous** t)\n",40);
    }
  else
    {
      write(client_sockfd,"(setf DEBUGGER::**display-previous** nil)\n",42);
    };
  if (PPID != 0 && IN_BREAKPOINT==0)
    {
      kill(PPID,SIGUSR1);  /* Send a signal to client , to indicate there is a command waiting */
    };
  return TCL_OK;
}

/*
 * Paste of code in the debugging system
 */

int Debug_Paste(ClientData data,Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[])
{
  static long nr=0;
  char filename[FILE_NAME_MAX];
  int fd;
  char s_pos[30];
  /* First clear the source window and the current source */
  Tcl_Invoke(interp,".text.text","configure","-state","normal",NULL);

  Tcl_Invoke(interp,".text.text","delete","1.0","end",NULL);
  CURRENT_SOURCE[0]='\0';
  /* Now paste the contents in the source window */

  /* Tcl_Invoke(interp,"tk_textPaste",".text.text",NULL); */
  Tcl_Eval(interp,"tk_textPaste .text.text");
  /* Use this information now to write to a diskfile */
  sprintf(filename,"/usr/tmp/lisp-debugger-paste%ld.lisp",nr);
  nr=nr+1;
  
  fd=open(filename,O_WRONLY | O_CREAT | O_TRUNC,S_IRWXU);
  if (fd == -1)
    {
      Tcl_Eval(interp,"tk_dialog .m Message \"Can't create tempory file\" {} -1 Ok");
      return TCL_OK;
    };
  Tcl_Invoke(interp,".text.text","get","1.0","end",NULL);
  write(fd,interp->result,sizeof(char)*strlen(interp->result));
  close(fd);
  Tcl_Invoke(interp,".text.text","configure","-state","disabled",NULL);

  /* Send a command to the lisp system to handle the file */
  /* This should be the only place that the user interface is commanding the lisp system directly */

  write(client_sockfd,"(DEBUGGER::debug-open-file \"",28);
  write(client_sockfd,filename,strlen(filename));
  write(client_sockfd,"\"",1);
  if (COMPILE_CODE)
    write(client_sockfd," T ",3);
  write(client_sockfd,")\n",2);

  if (PPID != 0)
    {
      kill(PPID,SIGUSR1);  /* Send a signal to client , to indicate there is a command waiting */
    };

  /* In the maintime read the file in the text area */

  Read_Source(interp,filename);

  /* Set the current source name */
  
  strcpy(CURRENT_SOURCE,filename);
  
  return TCL_OK;
}

/*
 * Start profiling code 
 */

/* 
 * For profiling code , punt nr executed on 0 , called by twalk
 */

void Debug_Start_Profile_Walk(char *key,void *data)
{
  DEBUGPOINT *p_debugpoint;

  p_debugpoint=(DEBUGPOINT *) data;
  p_debugpoint->executed=0;
}

/*
 * Start the profiling code 
 */
int Debug_Start_Profile(ClientData data,Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[])
{
  Tcl_Eval(interp,"scale .text.scale -from 0 -to 10 -command debug-show-profile-scale");
  Tcl_Eval(interp,"pack .text.scale");
  /* Initialise the profiling */
  MAX_PROFILING_COUNT=0;
  PROFILING=1;
  walk_hash(H_DEBUGPOINT,Debug_Start_Profile_Walk);
  return TCL_OK;
}

/*
 * Stop profiling code
 */

int Debug_Stop_Profile(ClientData data,Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[])
{
  PROFILING=0;
  Tcl_Eval(interp,"destroy .text.scale");
  Tcl_Invoke(interp,".text.text","tag","delete","profile",NULL);
  return TCL_OK;
}

/*
 * Show profile information
 */


/*
 * Function to traverse the tree for Debug_Show_Profile_Sclae_Walk
 */

void Debug_Show_Profile_Scale_Add(char *key,void *data)
{
  DEBUGPOINT *p_debugpoint;
  char s_begin[15],s_end[15];

  p_debugpoint=(DEBUGPOINT *) data;
  if (strcmp(p_debugpoint->source,CURRENT_SOURCE)==0 && p_debugpoint->executed >= EXECUTED)
    {
      AbsoluteToIndex(p_debugpoint->begin,s_begin);
      AbsoluteToIndex(p_debugpoint->end,s_end);
      Tcl_Invoke(interp,".text.text","tag","add","profile",s_begin,s_end,NULL);
    };
}

void Debug_Show_Profile_Scale_Remove(char *key,void *data)
{
  DEBUGPOINT *p_debugpoint;
  char s_begin[15],s_end[15];

  p_debugpoint=(DEBUGPOINT *) data;
  if (strcmp(p_debugpoint->source,CURRENT_SOURCE)==0 && p_debugpoint->executed < EXECUTED)
    {
      AbsoluteToIndex(p_debugpoint->begin,s_begin);
      AbsoluteToIndex(p_debugpoint->end,s_end);
      Tcl_Invoke(interp,".text.text","tag","remove","profile",s_begin,s_end,NULL);
    };
}	  
      
/*
 * Main function to show profile information
 */

int Debug_Show_Profile_Scale(ClientData data,Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[])
{
  char s_begin[15];

  /* Set maximum scale */
  if (MAX_PROFILING_COUNT > 10)
    {
      sprintf(s_begin,"%ld",MAX_PROFILING_COUNT);
      Tcl_Invoke(interp,".text.scale","configure","-to",s_begin,NULL);
    }
  else
    {
       Tcl_Invoke(interp,".text.scale","configure","-to","10",NULL);
    };
  /* Get the scale */ 
  Tcl_Invoke(interp,".text.scale","get",NULL);
  sscanf(interp->result,"%ld",&EXECUTED);

  /* Mark the part of the source to be highlighted */
  walk_hash(H_DEBUGPOINT,Debug_Show_Profile_Scale_Add);
  /* Mark the part of the source to be not highlighted */
  walk_hash(H_DEBUGPOINT,Debug_Show_Profile_Scale_Remove);
  /* Highlight marked code */
  Tcl_Invoke(interp,".text.text","tag","configure","profile","-background",PROFILE_COLOR,NULL);

  return TCL_OK;
}


/*
 *   Go back in time
 */

int Debug_Back(ClientData data,Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[])
{
  write(client_sockfd,"(DEBUGGER::step-back-in-time)\n",30);
  if (PPID != 0)
    {
      kill(PPID,SIGUSR1);  /* Send a signal to client , to indicate there is a command waiting */
    };
  return TCL_OK;
}

/* 
 * Go forwards in time
 */

int Debug_Forward(ClientData data,Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[])
{
  write(client_sockfd,"(DEBUGGER::step-forward-in-time)\n",33);
  if (PPID != 0)
    {
      kill(PPID,SIGUSR1);  /* Send a signal to client , to indicate there is a command waiting */
    };
  return TCL_OK;
}

/*
 * Step through the code of a function
 */


int Debug_Step(ClientData data,Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[])
{
  STEP_MODE=1;
  /* Initialise STEP_OVER part */
  STEP_OVER_MODE=0;
  STEP_OVER_BEGIN=0;
  STEP_OVER_END=0;
  Leave_Breakpoint();
  return TCL_OK;
}

/*
 * Steps through the source , showing only the top level layer
 */

int Debug_Step_Over(ClientData data,Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[])
{
  long begin,end;
  char s_pos[30];

  /* Disable step mode */
  STEP_MODE=0;
  STEP_OVER_MODE=1;
  /* Check if we are still stepping over in an existing list */
  if (STEP_OVER_END==0)
    {
      /* This is a new stepping over try*/
      /* Get the innermost's list containing highlighted text */
      Tcl_Invoke(interp,".text.text","index","breakpoint.first - 1 chars",NULL);
      DebugSelectList(interp->result);
      Tcl_Invoke(interp,".text.text","index","sel.first",NULL);
      begin=IndexToAbsolute(interp->result);
      Tcl_Invoke(interp,".text.text","index","sel.last",NULL);
      end=IndexToAbsolute(interp->result);
      if ((begin < 0) || (end < 0))
	{
	  /* Try stepping in the highlighted text */
	  Tcl_Invoke(interp,".text.text","index","breakpoint.first",NULL);
	  begin=IndexToAbsolute(interp->result);
	  Tcl_Invoke(interp,".text.text","index","breakpoint.last",NULL);
	  end=IndexToAbsolute(interp->result);
	  if ((begin < 0) || (end < 0))
	    {
	      Tcl_Eval(interp,"tk_dialog .m Message \"No stepover possible\" {} -1 Ok");
	      return TCL_OK;
	    }
	  STEP_OVER_BEGIN=begin;
	  STEP_OVER_END=end;
	}
      else
	{
	  STEP_OVER_BEGIN=begin;
	  STEP_OVER_END=end;
	};
    }
  else
    {
      /* This is an existing stepping over step , check if we have reached the end of the list */
      Tcl_Invoke(interp,".text.text","search","-forwards",")","breakpoint.last + 1 chars",NULL);
      end=IndexToAbsolute(interp->result);
      if (end < 0)
	{
	  /* Stop stepping */
	  STEP_OVER_MODE=0;
	  STEP_MODE=0;
	  STEP_OVER_BEGIN=0;
	  STEP_OVER_END=0;
	}
      else if (end >= STEP_OVER_END)
	{
	  /* Stop stepping */
	  STEP_OVER_MODE=0;
	  STEP_MODE=0;
	  STEP_OVER_BEGIN=0;
	  STEP_OVER_END=0;
	};
    };
  Leave_Breakpoint();
  return TCL_OK;
}
/*
 * Set a tempory breakpoint and continue processing untill the next breakpoint
 */

int Debug_Next(ClientData data,Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[])
{
  /* Set a tempory breakpoint , for selected part */
  
  STEP_OVER_MODE=0;
  STEP_MODE=0;
  STEP_OVER_BEGIN=0;
  STEP_OVER_END=0;
  Set_Debug_Breakpoint(2);
  Leave_Breakpoint();
  return TCL_OK;
};

/*
 * Continue processing until the next breakpoint
 */

int Debug_Continue(ClientData data,Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[])
{
  STEP_OVER_MODE=0;
  STEP_MODE=0;
  STEP_OVER_BEGIN=0;
  STEP_OVER_END=0;
  Leave_Breakpoint();
  return TCL_OK;
};


/* 
 * Sets a watchpoint on a variable
 */

int Debug_Watch(ClientData data,Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[])
{
  long begin,end,length_string;
  char *string;
  WATCHPOINT *p_watch;
  
  /* Copy the variable to a string variable */
  Tcl_Invoke(interp,".text.text","get","sel.first","sel.last",NULL);
  length_string=strlen(interp->result)+1;
  string=malloc(length_string*sizeof(char));
  strcpy(string,interp->result);

  /* Allocate memory for a watchpoint and fill in the information */
  p_watch=malloc(sizeof(WATCHPOINT));
  p_watch->type='V';
  p_watch->begin=0;
  p_watch->end=0;
  p_watch->exp=string;
  length_string=strlen(CURRENT_SOURCE)+1;
  string=malloc(length_string*sizeof(char));
  strcpy(string,CURRENT_SOURCE);
  p_watch->source=string;

  /* Cons the watchpoint to the begin of the list */
  L_WATCHPOINTS=cons(p_watch->exp,p_watch,L_WATCHPOINTS);

  if (IN_BREAKPOINT)
    {
      Display_Watchpoints_Result();
    }
  else
    {
      Display_Watchpoints();
    };
  
  return TCL_OK;
}


/* 
 * Sets a watchpoint on a expression , may only be executed in the context of a range
 */

int Debug_Watch_Exp(ClientData data,Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[])
{
  long begin,end;
  char *exp,*source;
  WATCHPOINT *p_watch;
  
  /* Get begin and end of of selection */
  Tcl_Invoke(interp,".text.text","index","sel.first",NULL);
  begin=IndexToAbsolute(interp->result);
  Tcl_Invoke(interp,".text.text","index","sel.last",NULL);
  end=IndexToAbsolute(interp->result);
  
  /* Get the expression to be evaluated from the command window */
  Tcl_Invoke(interp,".command.text","get","1.0","end - 1 chars",NULL);
  exp=malloc(sizeof(char)*(strlen(interp->result)+1));
  strcpy(exp,interp->result);
  
  /* Allocate memory to save source */
  source=malloc(sizeof(char)*(strlen(CURRENT_SOURCE)+1));
  strcpy(source,CURRENT_SOURCE);
  
  /* Allocate memory for a watchpoint and fill in the information */
  p_watch=malloc(sizeof(WATCHPOINT));
  p_watch->type='E';
  p_watch->begin=begin;
  p_watch->end=end;
  p_watch->exp=exp;
  p_watch->source=source;
  
  /* cons to the beginning of the list */
  L_WATCHPOINTS=cons(p_watch->exp,p_watch,L_WATCHPOINTS);
  
  /* Display the result of setting the watchpoint */
  if (IN_BREAKPOINT)
    {
      Display_Watchpoints_Result();
    }
  else 
    {
      Display_Watchpoints();
    };
  return TCL_OK;
}
  

/*
 * Unwatch a watchpoint 
 */

int Debug_Unwatch(ClientData data,Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[])
{
  char s_end[30];
  char exp[MAX_STRING];
  
  /* Check for existance of selection */
  Tcl_Invoke(interp,".result.text","tag","ranges","sel",NULL);
  if (interp->result[0]=='\0')
    /* No selection , so no result */
    return TCL_OK;
  
  /* Search for first blanco from begin selection , meaning end of name */
  Tcl_Invoke(interp,".result.text","search"," --> ","sel.first","sel.last",NULL);
  if (interp->result[0]=='\0')
    {
      /* Nothing found , wrong selection */
      return TCL_OK;
    }
  else
    {
      /* Get the name of the exp in the watchpoint */
      strcpy(s_end,interp->result);
      Tcl_Invoke(interp,".result.text","get","sel.first",s_end,NULL);
      strcpy(exp,interp->result);

      /* Delete the watchpoints */
      L_WATCHPOINTS=delete_all(exp,L_WATCHPOINTS);
    };
  /* Display now the new list */
  if (IN_BREAKPOINT)
    {
      Display_Watchpoints_Result();
    }
  else 
    {
      Display_Watchpoints();
    };
  return TCL_OK;
}
	 
      

/*
 * Evaluate a expression and display the result
 */

int Debug_Eval(ClientData data,Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[])
{
  /* Get the expressions to be evaluated */
  Tcl_Invoke(interp,".command.text","get","1.0","end -1 chars",NULL);
  /* Ask the client to display the expression */
  write(client_sockfd,"(DEBUGGER::display-result-exp \"",31);
  write(client_sockfd,interp->result,sizeof(char)*strlen(interp->result));
  write(client_sockfd,"\")\n",3);
  if (PPID != 0)
    {
      kill(PPID,SIGUSR1);  /* Send a signal to client , to indicate there is a command waiting */
    };
  return TCL_OK;
}

  
/*
 * Sets a new breakpoint in the debugger
 * 1 = permanent breakpoint
 * 2 = tempory breakpoint
 * 3 = conditional breakpoint
 */

int Debug_Breakpoint(ClientData data,Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[])
{
  Set_Debug_Breakpoint(1);
  return TCL_OK;
}

/* 
 * Sets a conditional breakpoint 
 */

int Debug_Breakif(ClientData data,Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[])
{
  Set_Debug_Breakpoint(3);
  return TCL_OK;
}


/* 
 * Load a new source in the debugger 
 */

int Debug_Open(ClientData data,Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[])
{
  char SelectedFile[FILE_NAME_MAX+1];
  char *key,*dat; 

  /* The way CLOS is implemented in CLISP makes that the debug code is called during the load fase */
  /* To avoid stopping the load we must do a continue */

  STEP_OVER_MODE=0;
  STEP_MODE=0;
  STEP_OVER_BEGIN=0;
  STEP_OVER_END=0;

  Tcl_Eval(interp,"tk_getOpenFile -filetypes {{lisp {.lsp}} {lisp {.lisp}}} -title \"Select a file\" -parent .");
  if (interp->result[0]=='\0')
    return TCL_OK; /* Cancel action to select file */

  strncpy(SelectedFile,interp->result,FILE_NAME_MAX);
  SelectedFile[FILE_NAME_MAX]='\0';
  
  /* Send a command to the lisp system to handle the file */
  /* This should be the only place that the user interface is commanding the lisp system directly */

  write(client_sockfd,"(DEBUGGER::debug-open-file \"",28);
  write(client_sockfd,SelectedFile,strlen(SelectedFile));
  write(client_sockfd,"\"",1);
  if (COMPILE_CODE)
    write(client_sockfd," t ",3);
  write(client_sockfd,")\n",2);

  if (PPID != 0)
    {
      kill(PPID,SIGUSR1);  /* Send a signal to client , to indicate there is a command waiting */
    };

  /* In the maintime read the file in the text area */

  Read_Source(interp,SelectedFile);

  /* Set the current source name */
  
  strcpy(CURRENT_SOURCE,SelectedFile);

  /* Register the source name , in a list of sources beeing debugged */
  if (search(SelectedFile,L_SOURCES)==NULL)
    {
      key=malloc((strlen(SelectedFile)+1)*sizeof(char));
      strcpy(key,SelectedFile);
      dat=malloc((strlen(SelectedFile)+1)*sizeof(char));
      strcpy(dat,SelectedFile);
      L_SOURCES=cons(key,dat,L_SOURCES);
    };

  /* Modify the sources menu , to display the new source */
  
  Change_Source_Menu();

  /* End of function */
  return TCL_OK;
}

/* 
 * FUnction used as test to delete a item in the hash table if the source is equal to CURRENT_SOURCE 
 */

int Is_Current(char *key,void *data)
{
  DEBUGPOINT *p_debugpoint;
  p_debugpoint=(DEBUGPOINT *) data;
  if (strcmp(p_debugpoint->source,CURRENT_SOURCE)==0)
    {
      return 1;
    }
  else
    {
      return 0;
    };
}

/*
 * Close the current source
 */

int Debug_Close(ClientData data,Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[])
{
  if (CURRENT_SOURCE[0]=='\0')
    return TCL_OK;
  /* Load original source in the lisp system */
  write(client_sockfd,"(load \"",7);
  write(client_sockfd,CURRENT_SOURCE,strlen(CURRENT_SOURCE));
  write(client_sockfd,"\")\n",3);
  if (PPID != 0)
    {
      kill(PPID,SIGUSR1);  /* Send a signal to client , to indicate there is a command waiting */
    };
  /* Remove breakpoint info of source */
  delete_hash_condition(H_DEBUGPOINT,Is_Current);
  /* Clear the source window */
  Tcl_Invoke(interp,".text.text","configure","-state","normal",NULL);
  Tcl_Invoke(interp,".text.text","delete","1.0","end",NULL);
  Tcl_Invoke(interp,".text.text","configure","-state","normal",NULL);
  /* Remove the CURRENT_SOURCE from source list */
  L_SOURCES=delete_all(CURRENT_SOURCE,L_SOURCES);
  /* If there is still a source in the L_SOURCES list , display the first one and make this current */
  if (L_SOURCES!=NULL)
    {
      strcpy(CURRENT_SOURCE,L_SOURCES->key);
      Read_Source(interp,CURRENT_SOURCE);
    }
  else
    {
      /* Set CURRENT SOURCE on NULL */
      CURRENT_SOURCE[0]='\0';
    };

  /* Modify the sources menu , to display the new source */
  
  Change_Source_Menu();
  return TCL_OK;

}

/*
 * Save the settings of the debugger
 */

void Save_Setting()
{
  int fd;
  char string[300],*file;

  sprintf(string,"%s/.lispdebug.lisp",getenv("HOME"));
  fd=open(string,O_WRONLY | O_CREAT | O_TRUNC,S_IRWXU);
  if (fd == -1)
    {
      Tcl_Eval(interp,"tk_dialog .m Message \"Can't create personal configuration file\" {} -1 Ok");
    };

  sprintf(string,"(DEBUGGER::setting \"COMPILE_CODE\" %ld)\n",COMPILE_CODE);
  write(fd,string,strlen(string));
  sprintf(string,"(DEBUGGER::setting \"SAVE_ON_EXIT\" %ld)\n",SAVE_ON_EXIT);
  write(fd,string,strlen(string));
  sprintf(string,"(DEBUGGER::setting \"DISPLAY_PREVIOUS\" %ld)\n",DISPLAY_PREVIOUS);
  write(fd,string,strlen(string));
  sprintf(string,"(DEBUGGER::setting \"DEBUGPOINT_COLOR\" \"%s\")\n",DEBUGPOINT_COLOR);
  write(fd,string,strlen(string));
  sprintf(string,"(DEBUGGER::setting \"DEBUGPOINTIF_COLOR\" \"%s\")\n",DEBUGPOINTIF_COLOR);
  write(fd,string,strlen(string));
  sprintf(string,"(DEBUGGER::setting \"CURRENT_COLOR\" \"%s\")\n",CURRENT_COLOR);
  write(fd,string,strlen(string));
  sprintf(string,"(DEBUGGER::setting \"PROFILE_COLOR\" \"%s\")\n",PROFILE_COLOR);
  write(fd,string,strlen(string));
  sprintf(string,"(DEBUGGER::setting \"FONT\" \"%s\")\n",FONT);
  write(fd,string,strlen(string));
  close(fd);

}

int Debug_Save_Setting(ClientData data,Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[])
{
  Save_Setting();
  return TCL_OK;
}

/*
 * Find next and previous entries
 */

int Find_Next(ClientData data,Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[])
{
  char end[30];

  Tcl_Invoke(interp,".find.entry.find","get",NULL);
  switch (SEARCH_TYPE)
    {
    case 1:
      Tcl_Invoke(interp,".text.text","search","-exact",interp->result,FIND_POS,NULL);
      break;
    case 2:
      Tcl_Invoke(interp,".text.text","search","-nocase",interp->result,FIND_POS,NULL);
      break;
    case 3:
      Tcl_Invoke(interp,".text.text","search","-regexp",interp->result,FIND_POS,NULL);
      break;
    };
  if (interp->result[0]!='\0')
    {
      /* Find occurence , mark beginning */
      strcpy(FIND_POS,interp->result);
      sprintf(end,"%s + 1 chars",FIND_POS);
      Tcl_Invoke(interp,".text.text","tag","delete","find",NULL);
      Tcl_Invoke(interp,".text.text","tag","add","find",FIND_POS,end,NULL);
      Tcl_Invoke(interp,".text.text","tag","configure","find","-background","red",NULL);
      Tcl_Invoke(interp,".text.text","see",FIND_POS,NULL);
      strcpy(FIND_POS,end);
    }
  else
    {
      /* Found nothing , display error */
      Tcl_Eval(interp,"tk_dialog .m Message \"Found no occurence of the string\" {} -1 Ok");
    };

  return TCL_OK;
}

int Find_Previous(ClientData data,Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[])
{
  char end[30];

  Tcl_Invoke(interp,".find.entry.find","get",NULL);
  switch (SEARCH_TYPE)
    {
    case 1:
      Tcl_Invoke(interp,".text.text","search","-backward","-exact",interp->result,FIND_POS,NULL);
      break;
    case 2:
      Tcl_Invoke(interp,".text.text","search","-backward","-nocase",interp->result,FIND_POS,NULL);
      break;
    case 3:
      Tcl_Invoke(interp,".text.text","search","-backward","-regexp",interp->result,FIND_POS,NULL);
      break;
    };
  if (interp->result[0]!='\0')
    {
      /* Find occurence , mark beginning */
      strcpy(FIND_POS,interp->result);
      sprintf(end,"%s + 1 chars",FIND_POS);
      Tcl_Invoke(interp,".text.text","tag","delete","find",NULL);
      Tcl_Invoke(interp,".text.text","tag","add","find",FIND_POS,end,NULL);
      Tcl_Invoke(interp,".text.text","tag","configure","find","-background","red",NULL);
      Tcl_Invoke(interp,".text.text","see",FIND_POS,NULL);
    }
  else
    {
      /* Found nothing , display error */
      Tcl_Eval(interp,"tk_dialog .m Message \"Found no occurence of the string\" {} -1 Ok");
    };

  return TCL_OK;
}

/*
 * Change the source displayed in a window because the user aksed it
 */

int Load_Source(ClientData data,Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[])
{
  strcpy(CURRENT_SOURCE,Tcl_GetStringFromObj(objv[1],NULL));
  Read_Source(interp,CURRENT_SOURCE);
}
  

/*
 * Find in the source window to a specific text
 */
int Debug_Find(ClientData data,Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[])
{
  /* Display the find window */

  SEARCH_TYPE=2;

  Tcl_Eval(interp,"toplevel .find");
  Tcl_Eval(interp,"frame .find.entry");
  Tcl_Eval(interp,"frame .find.radio");
  Tcl_Eval(interp,"frame .find.button");
  Tcl_Eval(interp,"pack .find.entry .find.radio .find.button -fill both -expand true");
  Tcl_Eval(interp,"label .find.entry.lb -text \"Find : \"");
  Tcl_Eval(interp,"entry .find.entry.find");
  Tcl_Eval(interp,"pack .find.entry.lb .find.entry.find -fill both -side left -expand true");
  Tcl_Eval(interp,"radiobutton .find.radio.case -text Case -value 1 -variable **search-type**");
  Tcl_Eval(interp,"radiobutton .find.radio.nocase -text \"No case\" -value 2 -variable **search-type**");
  Tcl_Eval(interp,"radiobutton .find.radio.regular -text \"Regular expression\" -value 3 -variable **search-type**");
  Tcl_Eval(interp,"pack .find.radio.case .find.radio.nocase .find.radio.regular -fill both -side left");
  Tcl_Eval(interp,"button .find.button.next -text Next -command find-next");
  Tcl_Eval(interp,"button .find.button.previous -text Previous -command find-previous");
  Tcl_Eval(interp,"pack .find.button.next .find.button.previous -side left");

  /* Initialise find position */
  strcpy(FIND_POS,"1.0");

  return TCL_OK;
    
}


/* Function that gets called during the destroy of the top level window , should stop program */
void QuitProgramWalk(char *key,char *source)
{ 
  /* Load the original sources back in the lisp system */
  write(client_sockfd,"(load \"",7);
  write(client_sockfd,source,strlen(source));
  write(client_sockfd,"\")\n",3);
  if (PPID != 0)
    {
      kill(PPID,SIGUSR1);  /* Send a signal to client , to indicate there is a command waiting */
    };
}
  
int QuitProgram(ClientData data,Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[])

{ 
  /* Load the orignal sources back */
  walk_list(L_SOURCES,QuitProgramWalk);
  
  /* Delete all tempfiles */

  system("rm /usr/tmp/lisp-debugger*.lisp 2> /dev/null");

  /* IF asked save settings */
  if (SAVE_ON_EXIT)
    Save_Setting();

  /* Instruct the client to stop the interface */
  write(client_sockfd,"(DEBUGGER::stop-interface)\n",27);
  if (PPID != 0)
    {
      kill(PPID,SIGUSR1);  /* Send a signal to client , to indicate there is a command waiting */
    };

  /* Close the connection with client , block if no unreceived data */
  close(client_sockfd);
  close(server_sockfd);
  exit(0);
  return TCL_OK;
}

/* 
 * Replacement of the Tk_Main function of the TK system , we don't need
 * a command prompt
 *
 */


void TkMain (appInitProc)
     Tcl_AppInitProc *appInitProc;
{
  interp = Tcl_CreateInterp();

  /*
   * Invoke the application-specific initilization
   */
  if ((*appInitProc) (interp) != TCL_OK)
    {
      TkpDisplayWarning(interp->result,"Application initialization failed");
    }
  /* 
   * Loop infinitely waiting for commands to execute . When there
   * are no windows left TK_MainLoop returns and we exit.
   */
  
  /* Tk_MainLoop(); */
  
  while (1==1)
    {
      while (Tk_DoOneEvent(TK_ALL_EVENTS));
    };

  Tcl_DeleteInterp(interp);
  Tcl_Exit(0);
}
    
/*
 * lisp_command_handler , handles the command send by the lisp system
 */

void lisp_command_handler(ClientData data,int mask)
{
  int function_no;
  /* 
   * Commands from the lisp system is in the form "function-nr [args]*" , 
   * the number and type of the args is determined by the function itself 
   */
  fscanf(f_client_sockfd,"%d",&function_no);
  switch (function_no)
    {
    case 0:
      highlight_source();
      break;
    case 1:
      display_message();
      break;
    case 2:
      highlight_error();
      break;
    case 3:
      set_possible_breakpoint();
      break;
    case 4:
      give_control_to_interface();
      break;
    case 5:
      display_result_in_interface();
      break;
    case 6:
      display_exp_in_interface();
      break;
    case 7:
      if_breakpoint();
      break;
    case 8:
      display_time_env();
      break;
    case 9:
      setting();
      break;
    default:
      fprintf(stderr,"Undefined function called from lisp\n");
      break;
    };
}
      
  
/* 
 * ---------------------------------------------------------------------
 * Create the debugger form layout
 * ---------------------------------------------------------------------
 */

int CreateDebugWindow_Init (interp)
     Tcl_Interp *interp;
{

  /* Link of variables used here */
  
  Tcl_LinkVar(interp,"**compile-code**",(char *) &COMPILE_CODE,TCL_LINK_BOOLEAN);
  Tcl_LinkVar(interp,"**save-on-exit**",(char *) &SAVE_ON_EXIT,TCL_LINK_BOOLEAN);
  Tcl_LinkVar(interp,"**display-previous**",(char *) &DISPLAY_PREVIOUS,TCL_LINK_BOOLEAN);
  Tcl_LinkVar(interp,"**search-type**",(char *) &SEARCH_TYPE,TCL_LINK_INT);

  /* TCL-TK Code */
  
  /*  Create the frames needed */
  Tcl_Eval(interp,"frame .menu");
  Tcl_Eval(interp,"frame .button1");
  Tcl_Eval(interp,"frame .button2");
  Tcl_Eval(interp,"frame .text");
  Tcl_Eval(interp,"frame .command");
  Tcl_Eval(interp,"frame .result");
  Tcl_Eval(interp,"pack .menu -expand yes -fill both");
  Tcl_Eval(interp,"pack .button1 -expand yes -fill both");
  Tcl_Eval(interp,"pack .button2 -expand yes -fill both");
  Tcl_Eval(interp,"pack .text -expand yes -fill both");
  Tcl_Eval(interp,"pack .result -expand yes -fill both");
  Tcl_Eval(interp,"pack .command -expand yes -fill both");
  /* Create the different widgets */
  Tcl_Eval(interp,"menubutton .menu.file -text File -underline 0 -menu .menu.file.file");
  Tcl_Eval(interp,"menubutton .menu.source -text Source -underline 0 -menu .menu.source.source");
  Tcl_Eval(interp,"menubutton .menu.edit -text Edit -underline 0 -menu .menu.edit.edit");
  Tcl_Eval(interp,"menubutton .menu.options -text Options -underline 0 -menu .menu.options.options");
  Tcl_Eval(interp,"menubutton .menu.tools -text Tools -underline 0 -menu .menu.tools.tools");
  Tcl_Eval(interp,"menu .menu.file.file -tearoff 0");
  Tcl_Eval(interp,"menu .menu.source.source -tearoff 1");
  Tcl_Eval(interp,"menu .menu.edit.edit -tearoff 0");
  Tcl_Eval(interp,"menu .menu.options.options -tearoff 0");
  Tcl_Eval(interp,"menu .menu.tools.tools -tearoff 0");
  Tcl_Eval(interp,".menu.file.file add command -label Open -command debug-open");
  Tcl_Eval(interp,".menu.file.file add command -label Close -command debug-close");
  Tcl_Eval(interp,".menu.file.file add separator");
  Tcl_Eval(interp,".menu.file.file add command -label Exit -command quit_program");
  Tcl_Eval(interp,".menu.edit.edit add command -label Paste -command debug-paste");
  Tcl_Eval(interp,".menu.edit.edit add command -label Find -command debug-find");
  Tcl_Eval(interp,".menu.options.options add command -label \"Color Break\" -command debug-color-break");
  Tcl_Eval(interp,".menu.options.options add command -label \"Color BreakPoint\" -command debug-color-breakpoint");
  Tcl_Eval(interp,".menu.options.options add command -label \"Color Breakpoint If\" -command debug-color-breakpointif");
  Tcl_Eval(interp,".menu.options.options add command -label \"Color Profiling\" -command debug-color-profile");
  Tcl_Eval(interp,".menu.options.options add separator");
  Tcl_Eval(interp,".menu.options.options add command -label Font -command debug-font");
  Tcl_Eval(interp,".menu.options.options add separator");
  Tcl_Eval(interp,".menu.options.options add check -label \"Compile debugged code\" -variable **compile-code**");
  Tcl_Eval(interp,".menu.options.options add separator");
  Tcl_Eval(interp,".menu.options.options add check -label \"Display result last call\" -variable **display-previous** -command debug-display-previous-call");
  Tcl_Eval(interp,".menu.options.options add command -label \"Save options\" -command debug-save-setting");
  Tcl_Eval(interp,".menu.options.options add separator");
  Tcl_Eval(interp,".menu.options.options add check -label \"Save on exit\" -variable **save-on-exit**");
  Tcl_Eval(interp,".menu.tools.tools add command -label \"Start profiling\" -command debug-start-profile");
  Tcl_Eval(interp,".menu.tools.tools add command -label \"Stop profiling\" -command debug-stop-profile");
  Tcl_Eval(interp,"pack .menu.file .menu.source .menu.edit .menu.options .menu.tools -side left");
  /* Definitions of buttons */
  Tcl_Eval(interp,"button .button1.step -text Step -width 10 -command debug-step");
  Tcl_Eval(interp,"button .button1.stepover -text \"Step over\" -width 10 -command debug-step-over");
  Tcl_Eval(interp,"button .button1.next -text Next -width 10 -command debug-next");
  Tcl_Eval(interp,"button .button1.continue -text Continue -width 10 -command debug-continue");
  Tcl_Eval(interp,"button .button1.breakpoint -text Breakpoint -width 10 -command debug-breakpoint");
  Tcl_Eval(interp,"button .button1.breakif -text \"Break If\" -width 10 -command debug-breakif");
  Tcl_Eval(interp,"button .button2.watch -text Watch -width 10 -command debug-watch");
  Tcl_Eval(interp,"button .button2.watchexp -text \"Watch exp\" -width 10 -command debug-watch-exp");
  Tcl_Eval(interp,"button .button2.unwatch -text UnWatch -width 10 -command debug-unwatch");
  Tcl_Eval(interp,"button .button2.eval -text Eval -width 10 -command debug-eval");
  Tcl_Eval(interp,"button .button2.back -text Back -width 10 -command debug-back");
  Tcl_Eval(interp,"button .button2.forward -text Forward -width 10 -command debug-forward");
  Tcl_Eval(interp,"pack .button1.step .button1.stepover .button1.next .button1.continue .button1.breakpoint .button1.breakif -side left");
  Tcl_Eval(interp,"pack .button2.watch .button2.watchexp .button2.unwatch .button2.eval .button2.back .button2.forward -side left");
  /* Define scrollbars for the 3 main windows and the text windows themself */
  Tcl_Eval(interp,"scrollbar .text.xtext -command \".text.text xview\" -orient horizontal");
  Tcl_Eval(interp,"scrollbar .text.ytext -command \".text.text yview\"");
  Tcl_Eval(interp,"text .text.text -xscrollcommand \".text.xtext set\" -yscrollcommand \".text.ytext set\" -state disabled");
  Tcl_Eval(interp,"pack .text.xtext -side bottom -fill x");
  Tcl_Eval(interp,"pack .text.text -side left -expand yes -fill both");
  Tcl_Eval(interp,"pack .text.ytext -side left -fill y");

  Tcl_Eval(interp,"scrollbar .command.xtext -command \".command.text xview\" -orient horizontal");
  Tcl_Eval(interp,"scrollbar .command.ytext -command \".command.text yview\"");
  Tcl_Eval(interp,"text .command.text -xscrollcommand \".command.xtext set\" -yscrollcommand \".command.ytext set\" -state normal -height 3");
  Tcl_Eval(interp,"pack .command.xtext -side bottom -fill x");
  Tcl_Eval(interp,"pack .command.text -side left -expand yes -fill both");
  Tcl_Eval(interp,"pack .command.ytext -side left -fill y");

  Tcl_Eval(interp,"scrollbar .result.xtext -command \".result.text xview\" -orient horizontal");
  Tcl_Eval(interp,"scrollbar .result.ytext -command \".result.text yview\"");
  Tcl_Eval(interp,"text .result.text -xscrollcommand \".result.xtext set\" -yscrollcommand \".result.ytext set\" -state disabled -height 3");
  Tcl_Eval(interp,"pack .result.xtext -side bottom -fill x");
  Tcl_Eval(interp,"pack .result.text -side left -expand yes -fill both");
  Tcl_Eval(interp,"pack .result.ytext -side left -fill y");

  /* Change font */
  Tcl_Invoke(interp,".text.text","configure","-font",FONT,NULL);
  Tcl_Invoke(interp,".result.text","configure","-font",FONT,NULL);
  Tcl_Invoke(interp,".command.text","configure","-font",FONT,NULL);

  /* Set default color for selection */

  Tcl_Invoke(interp,".text.text","tag","configure","-background","grey",NULL);

  /* Create of bindings to commands  */

  Tcl_Eval(interp,"bind .text.text <Double-ButtonRelease-1> {select-list %x %y}");
  Tcl_Eval(interp,"bind .text.text <ButtonRelease-1> {select-word %x %y}");
  Tcl_Eval(interp,"bind .text.text <ButtonPress-2> {select-function %x %y}");
  /* Create of commands defined here */
  Tcl_CreateObjCommand(interp,"debug-open",Debug_Open,(ClientData) 0 , (Tcl_CmdDeleteProc *) 0);
  Tcl_CreateObjCommand(interp,"debug-breakpoint",Debug_Breakpoint,(ClientData) 0 ,(Tcl_CmdDeleteProc *) 0);
  Tcl_CreateObjCommand(interp,"debug-breakif",Debug_Breakif,(ClientData) 0, (Tcl_CmdDeleteProc *) 0);
  Tcl_CreateObjCommand(interp,"debug-step",Debug_Step,(ClientData) 0 , (Tcl_CmdDeleteProc *) 0);
  Tcl_CreateObjCommand(interp,"debug-step-over",Debug_Step_Over,(ClientData) 0 , (Tcl_CmdDeleteProc *) 0);
  Tcl_CreateObjCommand(interp,"debug-next",Debug_Next,(ClientData) 0 , (Tcl_CmdDeleteProc *) 0);
  Tcl_CreateObjCommand(interp,"debug-continue",Debug_Continue,(ClientData) 0 , (Tcl_CmdDeleteProc *) 0);
  Tcl_CreateObjCommand(interp,"debug-watch",Debug_Watch,(ClientData) 0 , (Tcl_CmdDeleteProc *) 0);
  Tcl_CreateObjCommand(interp,"debug-watch-exp",Debug_Watch_Exp,(ClientData) 0, (Tcl_CmdDeleteProc *) 0);
  Tcl_CreateObjCommand(interp,"debug-unwatch",Debug_Unwatch, (ClientData) 0, (Tcl_CmdDeleteProc *) 0);
  Tcl_CreateObjCommand(interp,"debug-eval",Debug_Eval,(ClientData) 0, (Tcl_CmdDeleteProc *) 0);
  Tcl_CreateObjCommand(interp,"select-list",Select_List,(ClientData) 0, (Tcl_CmdDeleteProc *) 0);
  Tcl_CreateObjCommand(interp,"select-word",Select_Word,(ClientData) 0, (Tcl_CmdDeleteProc *) 0);
  Tcl_CreateObjCommand(interp,"select-function",Select_Function,(ClientData) 0, (Tcl_CmdDeleteProc *) 0);
  Tcl_CreateObjCommand(interp,"debug-color-break",Debug_Color_Break, (ClientData) 0, (Tcl_CmdDeleteProc *) 0);
  Tcl_CreateObjCommand(interp,"debug-color-breakpoint",Debug_Color_Breakpoint, (ClientData) 0, (Tcl_CmdDeleteProc *) 0);
  Tcl_CreateObjCommand(interp,"debug-color-breakpointif",Debug_Color_Breakpointif, (ClientData) 0, (Tcl_CmdDeleteProc *) 0);
  Tcl_CreateObjCommand(interp,"debug-color-profile",Debug_Color_Profile, (ClientData) 0, (Tcl_CmdDeleteProc *) 0);
  Tcl_CreateObjCommand(interp,"debug-font",Debug_Font, (ClientData) 0, (Tcl_CmdDeleteProc *) 0);
  Tcl_CreateObjCommand(interp,"debug-display-previous-call",Debug_Display_Previous_Call, (ClientData) 0, (Tcl_CmdDeleteProc *) 0);
  Tcl_CreateObjCommand(interp,"debug-paste",Debug_Paste, (ClientData) 0, (Tcl_CmdDeleteProc *) 0);
  Tcl_CreateObjCommand(interp,"debug-start-profile",Debug_Start_Profile, (ClientData) 0, (Tcl_CmdDeleteProc *) 0);
  Tcl_CreateObjCommand(interp,"debug-stop-profile",Debug_Stop_Profile, (ClientData) 0, (Tcl_CmdDeleteProc *) 0);
  Tcl_CreateObjCommand(interp,"debug-show-profile-scale",Debug_Show_Profile_Scale, (ClientData) 0, (Tcl_CmdDeleteProc *) 0);
  Tcl_CreateObjCommand(interp,"debug-back",Debug_Back, (ClientData) 0, (Tcl_CmdDeleteProc *) 0);
  Tcl_CreateObjCommand(interp,"debug-forward",Debug_Forward, (ClientData) 0, (Tcl_CmdDeleteProc *) 0);
  Tcl_CreateObjCommand(interp,"debug-close",Debug_Close, (ClientData) 0, (Tcl_CmdDeleteProc *) 0);
  Tcl_CreateObjCommand(interp,"debug-save-setting",Debug_Save_Setting, (ClientData) 0, (Tcl_CmdDeleteProc *) 0);
  Tcl_CreateObjCommand(interp,"debug-find",Debug_Find, (ClientData) 0, (Tcl_CmdDeleteProc *) 0);
  Tcl_CreateObjCommand(interp,"find-next",Find_Next,(ClientData) 0 , (Tcl_CmdDeleteProc *) 0);
  Tcl_CreateObjCommand(interp,"find-previous",Find_Previous,(ClientData) 0 , (Tcl_CmdDeleteProc *) 0);
  Tcl_CreateObjCommand(interp,"load-source",Load_Source,(ClientData) 0 , (Tcl_CmdDeleteProc *) 0);

  return 0;
}
/*
 *----------------------------------------------------------------------
 *
 * main --
 *
 *	This is the main program for the application.
 *
 * Results:
 *	None: Tk_Main never returns here, so this procedure never
 *	returns either.
 *
 * Side effects:
 *	Whatever the application does.
 *
 *----------------------------------------------------------------------
 */

int main(argc, argv)
     int argc;			/* Number of command-line arguments. */
     char **argv;		/* Values of command-line arguments. */
{
  int server_len,client_len;
  struct sockaddr_un server_address;
  struct sockaddr_un client_address;
  struct sockaddr_in i_server_address;
  struct sockaddr_in i_client_address;
  int port,on;

  /* Process arguments */

  if (argc!=1 && argc!=2)
    {
      fprintf(stderr,"interface started with wrong number of arguments\n");
      exit -1;
    };

  if (argc==2)
    {
      sscanf(argv[1],"%d",&PPID);
    }
  else
    {
      PPID=0;
    };

  /* Check if PID is port nr or pid */
  if (PPID<0)
    {
      port=-PPID;
      PPID=0;
    }
  else
    {
      port=0;
    };
     
  /* Initialise tree of breakpoints */
  
  H_DEBUGPOINT=create_hash(5000);

  /* Set up sockets */

  /* Remove any old trace of sockets */
  unlink("/tmp/lispdebugger");
  /* Create socket and name it */
  if (port==0)
    {
      server_sockfd = socket(AF_UNIX,SOCK_STREAM,0);
      server_address.sun_family=AF_UNIX;
      strcpy(server_address.sun_path,"/tmp/lispdebugger");
      server_len=sizeof(server_address);
      bind(server_sockfd,(struct sockaddr *)&server_address,server_len);
    }
  else
    {
      /* Create a socket */
      server_sockfd = socket(AF_INET,SOCK_STREAM,0);
      /* Set a socket options to reuse socket */
      on=1;
      if (setsockopt(server_sockfd,SOL_SOCKET,SO_REUSEADDR,&on,sizeof(int))==-1)
	{
	  fprintf(stderr,"Failed to set option because of error %ld\n",errno);
	  fflush(stderr);
	  exit(0);
	};
      /* Set address */
      i_server_address.sin_family = AF_INET;
      i_server_address.sin_addr.s_addr = htonl(INADDR_ANY);
      i_server_address.sin_port = htons((ushort) port);
      server_len=sizeof(server_address);
      if (bind(server_sockfd,(struct sockaddr *)&i_server_address,server_len)<0)
	{
	  fprintf(stderr,"Failed to bind because of error %ld\n",errno);
	  fflush(stderr);
	  exit(0);
	};
    };
  /* create a connection queue and wait for client */
  listen(server_sockfd,1);
  client_sockfd=accept(server_sockfd,(struct sockaddr *)&client_address,&client_len);
  f_client_sockfd=fdopen(client_sockfd,"r");
  
  TkMain(Tcl_AppInit);


  return 0;			/* Needed only to prevent compiler warning. */
}


/*
 *----------------------------------------------------------------------
 *
 * Tcl_AppInit --
 *
 *	This procedure performs application-specific initialization.
 *	Most applications, especially those that incorporate additional
 *	packages, will have their own version of this procedure.
 *
 * Results:
 *	Returns a standard Tcl completion code, and leaves an error
 *	message in interp->result if an error occurs.
 *
 * Side effects:
 *	Depends on the startup script.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_AppInit(interp)
    Tcl_Interp *interp;		/* Interpreter for application. */
{
    if (Tcl_Init(interp) == TCL_ERROR) {
	return TCL_ERROR;
    }
    if (Tk_Init(interp) == TCL_ERROR) {
	return TCL_ERROR;
    }
    Tcl_StaticPackage(interp, "Tk", Tk_Init, Tk_SafeInit);


    /*
     * Call the init procedures for included packages.  Each call should
     * look like this:
     *
     * if (Mod_Init(interp) == TCL_ERROR) {
     *     return TCL_ERROR;
     * }
     *
     * where "Mod" is the name of the module.
     */

    /* Specify a function to be executed it the top level window is destroyed */
    
    Tcl_Eval(interp,"wm protocol . WM_DELETE_WINDOW quit_program");
    Tcl_CreateObjCommand(interp,"quit_program",QuitProgram,(ClientData) 0 , (Tcl_CmdDeleteProc *) 0);

    /* Create the debugger form , and display it */

    if (CreateDebugWindow_Init(interp) == TCL_ERROR) {
      return TCL_ERROR;
    };

    /* Register a function to read the commands from lisp on the incoming pipe */

    Tcl_CreateFileHandler(client_sockfd,TCL_READABLE,lisp_command_handler,(ClientData) 0);
    
    return TCL_OK;
			 
			  
    /*
     * Call Tcl_CreateCommand for application-specific commands, if
     * they weren't already created by the init procedures called above.
     */

    /*
     * Specify a user-specific startup file to invoke if the application
     * is run interactively.  Typically the startup file is "~/.apprc"
     * where "app" is the name of the application.  If this line is deleted
     * then no user-specific startup file will be run under any conditions.
     */

    /*  Tcl_SetVar(interp, "tcl_rcFileName", "~/.wishrc", TCL_GLOBAL_ONLY);
    return TCL_OK;
    */
}
