R/idbg.R

In idbg: R debugger

###############################################################################
idbg <- function() {
  return(idbg.data)
}
###############################################################################
idbg.call_stack_top <- function(frame_id, func_name, pos)
{
  idbg.data$call_stack[[frame_id]] <- list(func_name, pos)
  length(idbg.data$call_stack) <- frame_id
}
###############################################################################
idbg.add_ifunc <- function(fname)
{
  if (! (fname %in% idbg.data$ifunc_names))
    idbg.data$ifunc_names <- c(idbg.data$ifunc_names, fname)
}
###############################################################################
idbg.gui_mode <- function(is_gui=NA)
{
  return(FALSE)
#  is_gui <- as.logical(is_gui)
#  if (is.na(is_gui))
#    return(idbg.data$gui)
#  idbg.data$gui <- is_gui
#  return(idbg.data$gui)
}
###############################################################################
idbg.bp <- function( func_name, line_number=NA, condition=TRUE)
{
  func_name <- as.character(substitute(func_name))
  return(idbg.set_breakpint( func_name, line_number, condition))
}
###############################################################################
idbg.run <- function( expr )
{
  e <- substitute(expr)
  if (is.call(e))
  {
    idbg.prepare_step(e);
    assign("break_frame", NA, envir=idbg())
    on.exit(idbg.data[["top_frame"]] <- 0)
    idbg.data[["top_frame"]] <- 3
    eval(e)
  }
}
###############################################################################
idbg.set_breakpint <- function( func_name, line_number=NA, condition=TRUE)
{
  func_name <- as.character(func_name)
  # unlock_existing_bindings not debugged well - disabled 
  f <- ifunc(func_name, FALSE, unlock_existing_bindings=FALSE)

  return(breakpoint.ifunc(f, line_number, condition))
}
###############################################################################
idbg.get_breakpoints <- function()
{
  
  breakpoints <- NULL
  for (fname in idbg()[["ifunc_names"]])
  { 
    f <-  idbg.match.ifunc(fname)
    if (is.null(f) || ! is.ifunc(f))
      next
    fbp <- list_breakpoints.ifunc(f)
    if (nrow(fbp))
      breakpoints <- rbind(breakpoints, data.frame("function_name"=fname,line=fbp$line, condition=fbp$condition, stringsAsFactors=FALSE))
  }
  return(breakpoints)
}
###############################################################################  
idbg.print_breakpoints <- function()
{  
  breakpoints <- idbg.get_breakpoints()
  for (line in capture.output(breakpoints))
    idbg.cat(line,"\n")
  idbg.cat("\n")
  #print(breakpoints)
}
###############################################################################
idbg.source <- function(fname)
{
  breakpoints <- idbg.get_breakpoints()
  source(fname)
  if (! is.null(breakpoints))
  {
    nbreakpoints<- nrow(breakpoints)
    for (i in seq_len(nbreakpoints))
    {
      idbg.set_breakpint(breakpoints$function_name[[i]], breakpoints$line[[i]])
    }
  }
}
###############################################################################
idbg.clear_all_breakpoints <- function()
{
  breakpoints <- idbg.get_breakpoints()
  if (! is.null(breakpoints))
  {
    nbreakpoints<- nrow(breakpoints)
    for (i in seq_len(nbreakpoints))
      idbg.set_breakpint(breakpoints$function_name[[i]], breakpoints$line[[i]], FALSE)
  }
}
###############################################################################
idbg.reset <- function()
{
    idbg.data[["break_frame"]] <- -1
    idbg.data[["call_stack"]] <- list()
    idbg.data[["debug_frame"]] <- -1
    # the frame of the topmoset debugged function. needed to hide the eval frame in case of idbg.run
    idbg.data[["top_frame"]] <- 0
    idbg.data[["ifunc_names"]] <- c()
    idbg.data[["gui"]] <- FALSE 	#suppressWarnings(library("tcltk", character.only =TRUE, logical.return=TRUE))
    idbg.data[["gui_toplevel"]] <- NULL
    idbg.data[["echo_on"]] <- FALSE
}
###############################################################################
idbg.interact <- function(pos, func_name)
{
  gui <- idbg.gui_mode(NA)
  if (gui && is.null(idbg()$gui_toplevel))
    idbg.gui()
  
  debug_loop = TRUE

  frame_id <- sys.nframe()
  
  idbg.call_stack_top(frame_id-1, func_name, pos)
  last_debug_frame <- idbg()$debug_frame
  assign("debug_frame", frame_id-1, envir=idbg())
  
  #get("call_stack", envir=idbg())[[frame_id-1]] <- list(func_name, pos)
  #length(idbg()$call_stack) <- frame_id-1


  func <- match.fun(func_name)
  breakpoints <- attr(func, "data")$breakpoints
  
  # eval the breakpoint at the parent - for conditional breakpoint support
  if (! eval.parent(parse(text=breakpoints[[pos]])))
  {
    
    # no breakpoint at this point
    # we may stop in two cases
    # 1. step in command assigned the break_frame and we got to that frame
    # 2. we returned from a debugged function to the caller
    if (! is.na(idbg()$break_frame) && frame_id-1 > idbg()$break_frame) # && last_debug_frame <= frame_id-1)
      return(NULL)
    #browser()
    assign("break_frame", -1, envir=idbg())
  }

# GUI not implemented in current version
#  if (gui)
#    idbg.gui.set_entry_text(func_name,list_source_extended.ifunc(func, pos), TRUE,TRUE)
#  else
    cat(list_source.ifunc(func_name, pos))


  while (debug_loop)
  {
    # GUI not implemented in current version
    #if (gui)
    #  line <- idb.gui.wait_for_usr_cmd()
    #else
      line <- readline("debug: ");
      
    if (idbg()$echo_on)
    {
      if (substr(line,1,1)=="#")
      {
        idbg.cat(line,"\n",sep="")  
        next
      }  
      else  
        idbg.cat("debug: ",line,"\n",sep="")  
    }  

    if (line == "")
      line <- "n"

    words = strsplit(line, "\ +")[[1]];
    if (length(words) == 0)
      next
    if (words[1] == "")
      words = words[2:length(words)];

    cmd = words[1];
    words = words[-1];
    if (cmd == "n")
    {
      assign("break_frame", sys.nframe() -1, envir=idbg())
      debug_loop <- FALSE
    }
    else
    if (cmd == "s")
    {
      addr <- attr(func, "data")$key2addr[[pos]]
      e <- body(func)
      has_error <- FALSE
      for (h in addr)
        if (h <= length(e))
          e <- e[[h]]
        else
        {
          has_error <- TRUE
          break
        }

      if (! has_error)
        idbg.prepare_step(e)
      assign("break_frame", NA, envir=idbg())
      debug_loop <- FALSE
    }
    else
    if (cmd == "c")
    {
      debug_loop <- FALSE
    }
    else
    if (cmd == "o")
    {
      assign("break_frame", sys.nframe()-2, envir=idbg())
      debug_loop <- FALSE
    }
    else
    if (cmd == "l")
    {
      q <- idbg()$call_stack[[idbg()$debug_frame]]
      lfunc <- q[[1]]
      # GUI not implemented in current version
      #if (gui)
      #  idbg.gui.set_entry_text(lfunc,list_source_extended.ifunc(lfunc, NA), TRUE,TRUE)
      #else
      {
        lpos <- q[[2]]
        if (length(words) == 0 )
          cat(list_source.ifunc(lfunc, lpos,show_pos_arrow=TRUE))
        else
        {        
          back <-  suppressWarnings(as.numeric(words[[1]]))
          if (is.na(back))
          {
            lfunc <- words[[1]]
            lpos <- 1
            back_arg <- 2
            show_pos_arrow <- FALSE
            ifunc(lfunc)
          }
          else
          {
            back_arg <- 1
            show_pos_arrow <- TRUE
          }  
          
          if (length(words) < back_arg)
            cat(list_source.ifunc(lfunc, lpos,show_pos_arrow=show_pos_arrow))
          else
          if (length(words) == back_arg)
            cat(list_source.ifunc(lfunc, lpos, words[[back_arg]], words[[back_arg]], show_pos_arrow=show_pos_arrow))
          else
          if (length(words) > back_arg)
            cat(list_source.ifunc(lfunc, lpos, words[[back_arg]], words[[back_arg+1]], show_pos_arrow=show_pos_arrow))
        }    
      }
    }
    else
    if (cmd == "f")
    {
      # f what [func_name]
      if (length(words) == 0)
        next
      q <- idbg()$call_stack[[idbg()$debug_frame]]
      lfunc <- q[[1]]
      if (length(words) > 1)
      {
        lfunc <- words[[2]]
      }  
      ifunc(lfunc)
      l <- list_source.ifunc(lfunc, NA,show_pos_arrow=FALSE, list_result=TRUE)
      for (i in grep(words[[1]], l))
        idbg.cat(l[[i]],"\n")
    }
    else
    if (cmd == "b")
    {
      if (length(words) == 0)
        idbg.print_breakpoints()
      else
      if (words[[1]]=="FALSE")
        idbg.clear_all_breakpoints()
      else
      {
        # if first argument is a number than break at current func otherwise it is a func name string
        bp_line <-  suppressWarnings(as.numeric(words[[1]]))
        bp_cond_arg <- 2
        if (is.na(bp_line))
        {
          # this must be a name of a function, break on the 1st line 
          bp_func_name <- words[[1]]
          if (length(words) > 1)
          {  
            bp_line <-  as.numeric(words[[2]])
            if (! is.na(bp_line))
              bp_cond_arg <- 3
          }
        } 
        else
        {
          # this is a line number to break in current proc
          bp_func_name <- func_name
        }

        if (length(words) >= bp_cond_arg)
          bp_condition <- do.call("paste", as.list(words[bp_cond_arg:length(words)]))
        else
          bp_condition <- TRUE
        idbg.set_breakpint(bp_func_name, bp_line, bp_condition) 
      }
      
      # GUI not implemented in current version
      #if (gui)
      #  idbg.gui.set_entry_text(func_name,list_source_extended.ifunc(func, pos), TRUE,TRUE)

    }
    else
    if (cmd == "w") 
    {
      # print the stack
      # todo - if the stack include non debugable functions (eg. apply) print data about them
      
      widx <- 0
      printed_widx <- 0
      for (q in idbg()$call_stack)
      {
        widx <- widx + 1
        if (widx <= idbg.data[["top_frame"]])
          next
        printed_widx <- printed_widx + 1  
        if (is.null(q) || is.null(idbg.match.ifunc(q[[1]])))
        {
          wchar <- " "
          idbg.cat(wchar, printed_widx, as.character(sys.call(widx)[[1]])," =>????",deparse(sys.call(widx+1)),"\n") 
        }  
        else
        {      
          if (widx == idbg()$debug_frame)
            wchar <- "*"
          else
            wchar <- " "
          idbg.cat(wchar, printed_widx, q[[1]]," ") 
          l <- list_source.ifunc(q[[1]], q[[2]], 0, 0)
          if (l == "")
            l <- "\n"
          idbg.cat(l)
        }
      }
    }
    else
    if (cmd == "u") 
    {
      # up in the stack
      if (idbg()$debug_frame-1 > idbg.data[["top_frame"]])
        assign("debug_frame", idbg()$debug_frame-1, envir=idbg())
    }
    else
    if (cmd == "d") 
    {
      # down in the stack
      if (idbg()$debug_frame+1 < frame_id)
        assign("debug_frame", idbg()$debug_frame+1, envir=idbg())
    }
    else
    if (cmd == "q")
    {
      idbg.reset()
      invokeRestart(findRestart("abort"))
    }
    else
    if (cmd == "h")
    {
      idbg.cat("h - help. print this message\n")
      idbg.cat("n - next. Empty line is the same as 'n'\n")
      idbg.cat("s - step into\n")
      idbg.cat("o - step out\n")
      idbg.cat("c - continue\n")
      idbg.cat("q - quit\n")
      idbg.cat("b - print breakpoints\n")
      idbg.cat("b FALSE - clear all breakpoints\n")
      idbg.cat("b <func_name> [FALSE] - set/unset a breakpoint at the first line of func_name\n")
      idbg.cat("b <line_number> [FALSE] - set/unset a breakpoint at the current function\n")
      idbg.cat("b <func_name> <line_number> [FALSE] - set/unset a breakpoint in func_name at line_number\n")
      idbg.cat("w - print the stack\n")
      idbg.cat("u - go up the stack\n")
      idbg.cat("d - go down the stack\n")
      idbg.cat("l [func_name] [nlines] - print nlines of source before and after current position\n")
      idbg.cat("l [func_name] [nlines_back] [nlines_forward] - print source around current position\n")
      idbg.cat("f string [func_name] - find string in function source\n")
      idbg.cat("x expr - execute expression\n")
      idbg.cat("expr - Any expression that doesn't match the above options will also be executed\n")
    }
    else
    {
      if (cmd == "x")
      {
        expr <- ""
        for (w in words)
          expr = paste(expr, w)
      }
      else
        expr <- line
      saved_error_option <- getOption("error")
      options(error=NULL)      
      e<- try(
        #print(eval.parent(parse(text=expr))),
        capture.output(eval(parse(text=expr),envir=sys.frame(idbg()$debug_frame))),
        silent = TRUE
      )
      options(error=saved_error_option)
      if (inherits(e, "try-error"))
        idbg.cat(geterrmessage())
      else
      {
        for (line in e)
          idbg.cat(line,"\n")
        idbg.cat("\n")
      }
      timestamp(expr,prefix="",suffix="",quiet =TRUE)
    }
  }
}
###############################################################################
idbg.match.func <- function(fname)
{
  found <- FALSE
  for (frame_id in seq(sys.nframe(),0))
  {
    envir <- sys.frame(frame_id)
    if (exists(fname, envir = envir, mode = "function", inherits = FALSE))
    {
      func <- get(fname, envir = envir, mode = "function", inherits = FALSE)
      return(func)
    }
  }
  
  # looking for the function in packages may be a problem.
  # there is no way to assign to the instrumented copy if the environement is locked
  # cannot change value of locked binding for 'fname'
  if (! found)
  {
    for (envir in search()[-1])
    {
      if (exists(fname, where = envir, mode = "function", inherits = FALSE))
      {
        func <- get(fname, pos = envir, mode = "function", inherits = FALSE)
        return(func)
      }
    }  
  }

  return(NULL)
}
###############################################################################
idbg.match.ifunc <- function(fname)    
{
  f <- idbg.match.func(fname)
  if (! is.null(f) && is.ifunc(f))
    return(f)

  return(NULL)
}
###############################################################################
idbg.prepare_step <- function(expr)
{
  expr_len <- length(expr)
  
  e <- expr[[1]]
  ifunc(as.character(expr[[1]]))
  if (expr_len > 1)
  {
    for (i in 2:expr_len) 
    { 
      if (class(expr[[i]]) == "call")
        idbg.prepare_step(expr[[i]])
    }
  }
}
###############################################################################
idbg.instrument_if <- function(if_expr, func_name, ienv)
{
  l <- list(if_expr[[1]], if_expr[[2]])
  ienv$addr <- c(ienv$addr, NA)

  for (idx in 3:4)
  {
    if (length(if_expr) >= idx)
    {
      ienv$addr[[length(ienv$addr)]] <- idx
      ikey <- ienv$key

      if (class(if_expr[[idx]]) == "{")
        l <- c(l, idbg.instrument_expr_list(if_expr[[idx]], func_name, ienv))
      else
        l <- c(l, idbg.instrument_expr_list(as.call(c(as.name("{"), if_expr[[idx]])), func_name, ienv))
    }
  }
  ienv$addr <- ienv$addr[-length(ienv$addr)]
  return(as.call(l))
}
###############################################################################
idbg.instrument_for <- function(for_expr, func_name, ienv)
{
  key <- ienv$key
  l <- list(for_expr[[1]], for_expr[[2]], for_expr[[3]])
  ienv$addr <- c(ienv$addr, 4)

  if (class(for_expr[[4]]) == "{")
    l <- c(l, idbg.instrument_expr_list(for_expr[[4]], func_name, ienv))
  else
    l <- c(l, idbg.instrument_expr_list(as.call(c(as.name("{"), for_expr[[4]])), func_name, ienv))
  ienv$addr <- ienv$addr[-length(ienv$addr)]
  return(as.call(l))
}
###############################################################################
idbg.instrument_while <- function(while_expr, func_name, ienv)
{
  key <- ienv$key
  l <- list(while_expr[[1]], while_expr[[2]])
  ienv$addr <- c(ienv$addr, 3)

  if (class(while_expr[[3]]) == "{")
    l <- c(l, idbg.instrument_expr_list(while_expr[[3]], func_name, ienv))
  else
    l <- c(l, idbg.instrument_expr_list(as.call(c(as.name("{"), while_expr[[3]])), func_name, ienv))
  return(as.call(l))
}
###############################################################################
idbg.instrument_repeat <- function(repeat_expr, func_name, ienv)
{
  key <- ienv$key
  l <- list(repeat_expr[[1]])
  ienv$addr <- c(ienv$addr, 2)

  if (class(repeat_expr[[2]]) == "{")
    l <- c(l, idbg.instrument_expr_list(repeat_expr[[2]], func_name, ienv))
  else
    l <- c(l, idbg.instrument_expr_list(as.call(c(as.name("{"), repeat_expr[[2]])), func_name, ienv))
  return(as.call(l))
}
###############################################################################
idbg.instrument_expr_list <- function(expr, func_name, ienv)
{
  expr_len <- length(expr)
  l<-list()
  ikey <- ienv$key

  if (expr_len > 0 && class(expr[[1]]) == "name" && expr[[1]] != "{")
  {
    return(idbg.instrument_expr_list(as.call(c(as.name("{"), expr)), func_name, ienv))
  }

  ienv$addr <- c(ienv$addr, NA)

  
  for (i in seq_len(expr_len)) 
  { 
    ienv$addr[[length(ienv$addr)]] <- 2*(i-1)+1
    e <- expr[[i]]
    #ikey<- paste(key,i,sep=".")

    if (class(e) == "{")
      e<- idbg.instrument_expr_list(e, func_name, ienv)
    else
    if (class(e) == "if")
      e<- idbg.instrument_if(e, func_name, ienv)
    else
    if (class(e) == "for")
      e<- idbg.instrument_for(e, func_name, ienv)
    else
    if (class(e) == "while")
      e<- idbg.instrument_while(e, func_name, ienv)
    else    
    if (class(e) == "repeat" || (is.call(e) && e[[1]] == "repeat"))
      e<- idbg.instrument_repeat(e, func_name, ienv)
      
        
    ienv$key <- ienv$key + 1
    
    ikey <- ienv$key
    l <- c(l, e, substitute(idbg.interact(i,name), list(i=ikey,name=func_name))) 
    
    # increase by two in order to get the addess of the line following the bp and not the command address
    ienv$addr[[length(ienv$addr)]] <- ienv$addr[[length(ienv$addr)]] + 2
    ienv$key2addr[[ikey]] <- ienv$addr
    

  }

  ienv$addr <- ienv$addr[-length(ienv$addr)]

  return(as.call(l))
}
###############################################################################
idbg.gen_source <- function(instrumented_body)
{
  s <- format(instrumented_body)

  bp_pos <- regexpr("idbg.interact\\([0-9]+", format(s))
  #bp_len <- attr(bp_pos, "match.length") - 3
  is_bp <- bp_pos != -1
  nbp <- sum(is_bp)
  #bp_key <- as.numeric(substr(s[is_bp], bp_pos[is_bp] + 3, bp_pos[is_bp] + 3+ bp_len[is_bp]-1))
  key2line <- which(c(FALSE, is_bp)) - seq_len(nbp)
  s <- s[! is_bp]
  return(list(src=s, key2line=key2line))
}
###############################################################################
ifunc <- function(fname, silent=TRUE, unlock_existing_bindings=FALSE)
{
  if (! is.character(fname))
    return(NULL)

  func <- idbg.match.func(fname)

  if (is.null(func))
  {
    if (! silent)
      idbg.cat("Function",fname, "not found\n")
    return(NULL)
  }  

  if (is.primitive(func))
  {
    if (! silent)
      idbg.cat("Can't debug primitive functions\n")
    return(func)
  }  
  
  if (is.ifunc(func))
    return(func)
  
  if (environmentIsLocked(environment(func)))  
  {
    if (! silent)
      idbg.cat("Can't debug functions in locked environments\n")
    return(NULL)
  }  

  ienv <- new.env()
  ienv$key <- 0
  ienv$addr <- c()
  ienv$key2addr <- list()

  l <- idbg.instrument_expr_list(body(func),fname,ienv)
  ret <- func
  body(ret) <- as.call(l)  
  attr(ret,"orig") <- func
  q <-idbg.gen_source(l)
  data <- new.env()
  attr(ret,"data") <- data
  data[["src"]] <- q$src
  data[["key2line"]] <- q$key2line
  data[["key2addr"]] <- ienv$key2addr
  data[["breakpoints"]] <- rep(FALSE,length(q$key2line))

  class(ret) <- c("ifunc", class(ret))
  
  idbg.add_ifunc(fname)
  
  is_locked <- bindingIsLocked(fname, environment(func))
  if (is_locked)
  {
    if (unlock_existing_bindings)
	  {
      unlockBinding(fname, environment(func))
      if (bindingIsLocked(fname, environment(func)))
      {
        if (! silent)
          idbg.cat("Can't unlock binding for",fname,"\n")
          
		    return(NULL)
      }  
	  }	
  	else
    {
	    return(NULL)
    }  
  }	  
    
  err<- try(
    assign(fname, ret, envir=environment(func)) 
  #  if (is.character(envir))
  #    assign(fname, ret, pos=envir)
  #  else	
  #    assign(fname, ret, envir=envir) 
  , silent = TRUE
  )
  if (is_locked)
    lockBinding(fname, environment(func))

  if (inherits(err, "try-error"))
  {
    if (! silent)
    {
      idbg.cat("Can't debug function", fname,"\n")
      idbg.cat(geterrmessage())
    }  
    return(NULL)
  }  
  
  return(ret)  
}
###############################################################################
is.ifunc <- function(x)
{
  return(inherits(x, "ifunc"))
}
###############################################################################
print.ifunc <- function(x)
{
  src <- attr(x, "data")$src
  cat(format(args(x))[[1]],"\n")
  for (line in src)
    cat(line,"\n")
}
###############################################################################
# to clear a breakpoint set expr to FALSE
# to toggle TRUR/FALSE set exor to NA
breakpoint.ifunc <- function(f, line_number, expr=TRUE)
{
  if (! is.ifunc(f) )
    return(FALSE)

  key2line <- attr(f, "data")$key2line
  if (length(key2line) == 0)
    return(FALSE)
  
  if (is.na(line_number))
    d <- 1
  else
    d <- which.min(abs(line_number - key2line))
  if (length(d) == 0)
    return(FALSE)
  d <- d[[1]]	

  if (is.na(expr))
    attr(f,"data")$breakpoints[[d]] <- ifelse( attr(f,"data")$breakpoints[[d]] == FALSE, TRUE, FALSE) 
  else
    attr(f,"data")$breakpoints[[d]] <- expr
  return(TRUE)
}
###############################################################################
line_breakpoint.ifunc <- function(f, line_number)
{
  if (! is.ifunc(f) )
    return(FALSE)

  key2line <- attr(f, "data")$key2line
  if (length(key2line) == 0)
    return(FALSE)
  
  d <- which(line_number - key2line==0)
  if (length(d) != 1)
    return(FALSE)
  return(attr(f,"data")$breakpoints[[d]])
}
###############################################################################
list_breakpoints.ifunc <- function(f)
{
  if (! is.ifunc(f))
    return(NULL)
  keys <- which(attr(f,"data")$breakpoints != FALSE)
  lines <- (attr(f, "data")$key2line)[keys]
  conditions <- attr(f,"data")$breakpoints[keys]
  return(data.frame(line=lines, condition=conditions, stringsAsFactors=FALSE))
}
###############################################################################
list_source.ifunc <- function(func, pos, back=10, forward=10, show_pos_arrow=TRUE, list_result=FALSE)
{
  back <- suppressWarnings(as.integer(back))
  forward <- suppressWarnings(as.integer(forward))

  if (is.na(back))
    back <- 10
  if (is.na(forward))
    forward <- 10

  if (is.character(func))
  {
    func_name <- func
    func <- idbg.match.func(func)
  }
  else
    func_name <- NA  

  if (list_result)
    txt_buffer <- c()
  else  
    txt_buffer <- ""
  if (is.ifunc(func))
  {  
    src <- attr(func, "data")$src
    if (! is.na(pos))
    {
      key2line <- attr(func, "data")$key2line
      pos <- key2line[[pos]]
      start <- pos - back
      end <- pos + forward
    } 
    else
    {
      pos <- 0
      start <- 1
      end <- length(src)
      show_pos_arrow <- FALSE
    }     
  
    if (start < 1 )
      start <- 1
    if (end > length(src))
      end <- length(src)

    if (start == 1)
    {
      line <- format(args(func))
      if (length(line) > 2)
        line <- paste(line[[1]],". . .")
      else  
        line <- line[[1]]
      if (! is.na(func_name))
        line <- sub("\\(",paste(func_name,"(",sep=""),line)
      line <- paste(line,"\n",sep="")  
      if (list_result)
        txt_buffer <- c(txt_buffer, line)
      else  
        txt_buffer <- line
    }    

    for (i in start:end ) 
    { 
      line <- sprintf("%04d %s",i,src[[i]])
      if (list_result)
        txt_buffer <- c(txt_buffer, line)
      else
      {      
        if (show_pos_arrow && i == pos)
          txt_buffer <-  paste(txt_buffer,"=>",sep="")
        else
          txt_buffer <-  paste(txt_buffer,"  ",sep="")
        txt_buffer <-  paste(txt_buffer,line,"\n",sep="")
      }  
    }
  }
  return(txt_buffer)
}
###############################################################################
list_source_extended.ifunc <- function(func, pos)
{
  if (is.character(func))
    func <- match.fun(func)
  
  if (!is.ifunc(func))
    return(NULL)
    
  src <- attr(func, "data")$src
  key2line <- attr(func, "data")$key2line
  
  start <- 1
  end <- length(src)

  
  # TODO:   set the format to be sprintf("%%0%dd %s" , ceiling(log10(end+1)))
  result <- data.frame(SRC=rep("", end+1), IP=FALSE, BP=FALSE, stringsAsFactors=FALSE)
  result$SRC[[1]] <- paste("     ", format(args(func))[[1]], sep="")
  result$SRC[2:(end+1)] <- sprintf("%04d %s",seq_len(end),src)
  if (! is.na(pos))
  {
    pos <- key2line[[pos]]
    result$IP[[pos+1]] <- TRUE
  }
  result$BP[attr(func, "data")$key2line +1] <- attr(func,"data")$breakpoints

  return(result)
}
###############################################################################
idbg.cat <- function(...)
{
  str1 <- do.call("paste", list(...))
  # GUI not implemented in current version
  #if (idbg.gui_mode())
  #  idb.gui.bottom.cat(str1)
  #else
  cat(str1)
}
###############################################################################
idbg.gui <- function()
{
#
#tt <- tktoplevel()
#tkwm.protocol(tt,"WM_DELETE_WINDOW", function()idbg.gui.close())
##tkbind(tt,"<Destroy>", function(W)cat("Bye\n"))
#
#tkbind( tt, "<KeyPress-F5>", function(K)idb.gui.key_press(K) )
#tkbind( tt, "<KeyPress-F6>", function(K)idb.gui.key_press(K) )
#tkbind( tt, "<KeyPress-F8>", function(K)idb.gui.key_press(K) )
#tkbind( tt, "<KeyPress-F9>", function(K)idb.gui.key_press(K) )
#
#idb.gui.send_cmd <<- function(cmd)
#{
#  if (cmd != "")
#    tcl("set", "idb_gui_user_cmd",cmd)
#}
#
#idbg.gui.close <- function()
#{
#  idb.gui.send_cmd("q") 
#  tkdestroy(tt)
#  assign("gui_toplevel", NULL, envir=idbg())
#}
#
#
#tt.menu <- tkmenu(tt, tearoff=0)
#
#tt.menu.file <-tkmenu(tt.menu, tearoff=0)
#tkadd(tt.menu, "cascade", label="File", menu=tt.menu.file, underline=0)
#tkadd(tt.menu.file, "command", label="Exit", command=function()idbg.gui.close())
#tkconfigure(tt,menu=tt.menu)
##$m add separator
#
#
#tt.pane <- ttkpanedwindow(tt,orient="vertical")
#tt.pane.top <- ttkframe(tt.pane)
#tt.pane.bottom <- ttkframe(tt.pane)
#
#
### Make the notebook and set up Ctrl+Tab traversal
#tt.pane.top.note <- ttknotebook(tt.pane.top)
#tkpack(tt.pane.top.note, fill="both", expand=1, padx=2, pady=3)
##ttk::notebook::enableTraversal $w.note
#
#idb.gui.left_click <<- function(note_entry.text,x,y, func_name)
#{
#  addr <- strsplit(as.character(tkindex(note_entry.text,paste("@",x,",",y,sep=""))),"\\.")
#  row <- as.numeric(addr[[1]][[1]])
#  col <- as.numeric(addr[[1]][[2]])
#
#  #cat("left click",x,y, row,col,"\n")
#  if (col ==0)
#    idbg.set_breakpint( func_name, row-1, NA)
#  idbg.gui.set_entry_bp(note_entry.text, row, line_breakpoint.ifunc(ifunc(func_name), row-1))
#}
#
#idb.gui.right_click <<- function(note_entry.text,x,y)
#{
#  row.col <- tkindex(w,paste("@",note_entry.text,",",y,sep=""))
#  cat("right click",x,y, as.character(tkindex(w,paste("@",note_entry.text,",",y,sep=""))),"\n")
#
#}
#
#
#idb.gui.wait_for_usr_cmd <<- function()
#{
#  tcl("set", "idb_gui_user_cmd","")
#  tkwait.variable("idb_gui_user_cmd")
#  cmd <- as.character(tclvalue("idb_gui_user_cmd"))
#  #cat("idb.gui.wait_for_usr_cmd: cmd='",cmd,"'\n",sep="")
#  return(cmd)
#}
#
#
#idb.gui.key_press <<- function(K)
#{
#  #cat("K='",K,"'\n",sep="")
#  switch(K,
#    F5={ cmd<- "s" },
#    F6={ cmd<- "n" },
#    F8={ cmd<- "o" },
#    F9={ cmd<- "c" }
#  )
#
#  idb.gui.send_cmd(cmd)
#}
#
#
#
#idb.gui.bottom.key_press <<- function(bottom.text, K)
#{
#  if (K == "space")
#    K <- " "
#  if (K == "Tab")
#    K <- "\t"
#
#  cat("K='",K,"'\n",sep="")  
#
#  pos <-strsplit(as.character(tkindex(bottom.text, "end")), "\\.")
#  last_char <- as.numeric(pos[[1]][[2]])
#  last_line <- as.numeric(pos[[1]][[1]])-1
#
#  if (nchar(K) == 1 || K == "Delete" || K == "BackSpace" || K == "Return" || K == "Control-x" || K == "Control-v" || K == "Shift-Insert")
#  {
#    # if we are not at the last line set the insert position to the end of text
#    pos <-strsplit(as.character(tkindex(bottom.text, "insert")), "\\.")
#    line <- as.numeric(pos[[1]][[1]])
#    cat("line=",line,"\n")
#    cat("last_line=",last_line,"\n")
#    if (line != last_line)
#    {
#      if (K == "Control-x" || K == "Control-v" || K == "Shift-Insert" || K == "BackSpace")
#      {
#        # clear the selection
#        v <-tktag.ranges(bottom.text, "sel")
#        nranges <- as.numeric(as.character(tcl("llength", v)))
#        for (i in (seq_len(nranges/2)-1)*2)
#        {
#          index1<-tcl("lindex", v,i)
#          index2<-tcl("lindex", v,i+1)
#
#          tktag.remove(bottom.text, "sel", index1, index2)
#        }
#      }
#      tkmark.set(bottom.text, "insert", "end")
#    } 
#    else
#    if (K == "BackSpace")
#    {
#      if (last_char == 0)
#        tkinsert(bottom.text, "end", "\n")
#    }
#    else
#    if (K == "Return")
#    {
#      # if enter is pressed while in the middle of the text right to the insert will me moved to next line
#      # avoid that by moving to the end of line anyway
#      tkmark.set(bottom.text, "insert", "end")
#    }
#  }
#  
#  if (K == "Return")
#  {
#    cmd <- as.character(tkget(bottom.text, sprintf("%d.0", last_line), "end"))
#    if (last_char == 0 && last_line > 0)
#    {
#      cat("last_char=",last_char,"\n")
#      cat("last_line=",last_line,"\n")
#      # if we just got an ENTER don't print an empty line -> remove the last enter (==last character)
#      cat("kkkkkkkkkkkkkkkkkkk\n")
#      tkinsert(bottom.text, "end", "n")
#      #tkdelete(bottom.text,sprintf("%d.end",last_line-1) )
#      #tkmark.set(bottom.text, "insert", sprintf("%d.end",last_line-1))
#    }
#
#    tcl("set", "idb_gui_user_cmd",cmd)
#  }
#}
#
#
#idbg.gui.get_tab <<- function(tab_name, b_create=FALSE, b_select=FALSE)
#{
#  ntabs <- as.integer(as.character(tkindex(tt.pane.top.note,"end")))
#  for (tabid in seq_len(ntabs)-1)
#  {
#    tab_text <- as.character(tcl(tt.pane.top.note, "tab",tabid,"-text"))  
#    if (tab_text == tab_name)
#    {
#      if (b_select)
#        tkselect(tt.pane.top.note, tkindex(tt.pane.top.note,tabid))
#
#      return(tabid)
#    }
#  } 
#  if (b_create)
#  {
#    note_entry <- ttkframe(tt.pane.top.note)
#    note_entry.vscrollbar <- tkscrollbar(note_entry,command=function(...)tkyview(note_entry.text,...)) 
#    note_entry.hscrollbar <- tkscrollbar(note_entry,command=function(...)tkxview(note_entry.text,...), orient="horiz") 
#    note_entry.text <- tktext(note_entry, setgrid=1, height=20, undo=1, autosep=1, wrap="none", state="disabled",exportselection=1, yscrollcommand=function(...)tkset(note_entry.vscrollbar,...), xscrollcommand=function(...)tkset(note_entry.hscrollbar,...))
#    tkpack(note_entry.vscrollbar,side="right",fill="y")
#    tkpack(note_entry.hscrollbar,side="bottom",expand="no",fill="both")
#    tkpack(note_entry.text, expand="yes", fill="both") 
#    tktag.configure(note_entry.text, "ip_color", foreground="#00aa00")
#    tktag.configure(note_entry.text, "bp_color", foreground="red")
#    tkadd(tt.pane.top.note, note_entry, text=tab_name, underline=0, padding=2)
#    tkbind( note_entry.text, "<Button-3>", function(x,y)idb.gui.right_click(note_entry.text,x, y, tab_name) )
#    tkbind( note_entry.text, "<Button-1>", function(x,y)idb.gui.left_click(note_entry.text, x, y, tab_name) )
#    tkbind( note_entry.text, "<KeyPress-F5>", function(K)idb.gui.key_press(K) )
#    tkbind( note_entry.text, "<KeyPress-F6>", function(K)idb.gui.key_press(K) )
#    tkbind( note_entry.text, "<KeyPress-F8>", function(K)idb.gui.key_press(K) )
#    tkbind( note_entry.text, "<KeyPress-F9>", function(K)idb.gui.key_press(K) )
#
#    if (b_select)
#      tkselect(tt.pane.top.note, tkindex(tt.pane.top.note,ntabs))
#    return(ntabs)
#  }
#
#  return(-1)
#}
#
#idbg.gui.create_tab <<- function(tab_name)
#{
#  idbg.gui.get_tab(tab_name, TRUE)
#}
#
#idbg.gui.get_tab_obj <<- function(tab_name, b_create=FALSE, b_select= FALSE)
#{
#  tabid <- idbg.gui.get_tab(tab_name, b_create, b_select)  
#  if (tabid == -1)
#    return(NULL)
#
#  tab_obj <- tcl("lindex",tcl(tt.pane.top.note, "tabs"),tabid)
#}
#
#idbg.gui.set_entry_text <<- function(tab_name, text_df, b_create=FALSE, b_select= FALSE, incremental=TRUE)
#{
#  obj <- idbg.gui.get_tab_obj(tab_name,FALSE, b_select)
#  update_source <- incremental && is.null(obj)
#  #cat("update_source=",update_source,"\n")
#  if (is.null(obj))
#    obj <- idbg.gui.get_tab_obj(tab_name,b_create, b_select)
#  if (is.null(obj))
#    return()
#
#  text_entry_obj <- tcl("lindex", tkpack.slaves(obj),2)
#  tkconfigure(text_entry_obj,state="normal")
#  
#  if (update_source)
#  {
#    tkdelete(text_entry_obj,"0.0","end")
#
#    n <- nrow(text_df)
#    for (i in seq_len(n))
#    {
#      if (text_df$BP[[i]])
#        tkinsert(text_entry_obj, "end", "O", "bp_color")
#      else
#        tkinsert(text_entry_obj, "end", " ")
#
#      if (text_df$IP[[i]])
#        tkinsert(text_entry_obj, "end", "->", "ip_color")
#      else
#        tkinsert(text_entry_obj, "end", "  ")
#        tkinsert(text_entry_obj, "end", paste(text_df$SRC[[i]],"\n",sep=""))
#    }
#  }
#  else
#  {
#    # just update the ip
#    v <-tktag.ranges(text_entry_obj, "ip_color")
#    nranges <- as.numeric(as.character(tcl("llength", v)))
#    for (i in (seq_len(nranges/2)-1)*2)
#    {
#      index1<-tcl("lindex", v,i)
#      index2<-tcl("lindex", v,i+1)
#
#      tktag.remove(text_entry_obj, "ip_color", index1, index2)
#      tcl(text_entry_obj, "replace", index1, index2, "  ")
#    }
#    ip_row <- which(text_df$IP)
#    tcl(text_entry_obj, "replace", paste(ip_row,1,sep="."), paste(ip_row,3,sep="."), "->", "ip_color")
#
#  }
#  tkconfigure(text_entry_obj,state="disabled")
#}
#
#
#
#idbg.gui.set_entry_bp <<- function(text_entry_obj, row, value)
#{
#  tkconfigure(text_entry_obj,state="normal")
#  
#  pos <- sprintf("%d.0",row)
#  tkdelete(text_entry_obj,pos)
#  if (is.logical(value) && value == FALSE)
#    tkinsert(text_entry_obj, pos, " ")
#  else
#    tkinsert(text_entry_obj, pos, "O", "bp_color")
#    
#  tkconfigure(text_entry_obj,state="disabled")
#}
#
#
#
#idbg.gui.create_tab("help")
#
##tkselect(tt.pane.top.note, tkindex(tt.pane.top.note,"2"))
##txt<-tkcget(tt.pane.top.note,"text")
##txt <- as.character(tcl(tt.pane.top.note, "tab","2","-text"))
##cat(txt,"\n")
#
#
#
#tt.pane.bottom.vscrollbar <- tkscrollbar(tt.pane.bottom,command=function(...)tkyview(tt.pane.bottom.text,...)) 
#tt.pane.bottom.hscrollbar <- tkscrollbar(tt.pane.bottom,command=function(...)tkxview(tt.pane.bottom.text,...), orient="horiz") 
#tt.pane.bottom.text <- tktext(tt.pane.bottom, setgrid=1, height=7, undo=1, autosep=1, wrap="none", exportselection=1, yscrollcommand=function(...)tkset(tt.pane.bottom.vscrollbar,...), xscrollcommand=function(...)tkset(tt.pane.bottom.hscrollbar,...))
#tktag.configure(tt.pane.bottom.text, "cat_color", foreground="blue")
#tkpack(tt.pane.bottom.vscrollbar,side="right",fill="y")
#tkpack(tt.pane.bottom.hscrollbar,side="bottom",expand="no", fill="both")
#tkpack(tt.pane.bottom.text, expand="yes", fill="both") 
#tkbind(tt.pane.bottom.text, "<Control-x>", function(K)idb.gui.bottom.key_press(tt.pane.bottom.text, "Control-x") )
#tkbind(tt.pane.bottom.text, "<Control-v>", function(K)idb.gui.bottom.key_press(tt.pane.bottom.text, "Control-v") )
#tkbind(tt.pane.bottom.text, "<Shift-Insert>", function(K)idb.gui.bottom.key_press(tt.pane.bottom.text, "Shift-Insert") )
#tkbind(tt.pane.bottom.text, "<KeyPress>", function(K)idb.gui.bottom.key_press(tt.pane.bottom.text, K) )
#
#
#tkadd(tt.pane, tt.pane.top)
#tkadd(tt.pane, tt.pane.bottom)
#
#
#tkpack(tt.pane,side="top",expand="yes",fill="both",pady=2,padx="2m")
#
#
#idb.gui.bottom.cat <<- function(str)
#{
#  tkinsert(tt.pane.bottom.text, "end", str, "cat_color")
#  tkyview(tt.pane.bottom.text, "moveto","1.0")
#}
#
#assign("gui_toplevel", tt, envir=idbg())
#
#return(invisible())
#
}


#.First.lib <- function(lib, pkg)
#{
#  #idbg.init()
#}
  
if (!exists("idbg.data") ) 
{
  idbg.data <- new.env() 
  idbg.reset()
}