X-Git-Url: http://christophe.rhodes.io/gitweb/?p=swankr.git;a=blobdiff_plain;f=swank.R;h=3ab65ee02f1228d8b2c3423b41d33647f0fe4457;hp=bd7e093703fa4a4d5f9fc5ea7e1ad986853ad7fa;hb=8d84cee073ab58c2c858a6aac994a4f88d91ddb4;hpb=e35149b43e4da28f542c6bdf2decd802e84dd440 diff --git a/swank.R b/swank.R index bd7e093..3ab65ee 100644 --- a/swank.R +++ b/swank.R @@ -113,6 +113,7 @@ sldbLoop <- function(slimeConnection, sldbState, id) { } readPacket <- function(io) { + socketSelect(list(io)) header <- readChunk(io, 6) len <- strtoi(header, base=16) payload <- readChunk(io, len) @@ -244,12 +245,19 @@ writeSexpToString <- function(obj) { writeSexpToStringLoop(obj) } -printToString <- function(val) { +withOutputToString <- function(expr) { + call <- substitute(expr) f <- fifo("") - tryCatch({ sink(f); print(val); sink(); readLines(f) }, + sink(f) + tryCatch({ tryCatch(eval.parent(call), finally=sink()) + readLines(f) }, finally=close(f)) } +printToString <- function(val) { + withOutputToString(str(val, indent.str="", list.len=5, max.level=2)) +} + `swank:connection-info` <- function (slimeConnection, sldbState) { list(quote(`:pid`), Sys.getpid(), quote(`:package`), list(quote(`:name`), "R", quote(`:prompt`), "R> "), @@ -349,9 +357,8 @@ computeRestartsForEmacs <- function (sldbState) { if(is.null(srcfile)) { list(quote(`:error`), "no srcfile") } else { - filename <- get("filename", srcfile) list(quote(`:location`), - list(quote(`:file`), filename), + list(quote(`:file`), sprintf("%s/%s", srcfile$wd, srcfile$filename)), list(quote(`:line`), srcref[[1]], srcref[[2]]-1), FALSE) } @@ -394,28 +401,189 @@ computeRestartsForEmacs <- function (sldbState) { list(quote(`:compilation-result`), list(), TRUE, times[3]) } -`swank:interactive-eval` <- function(slimeConnection, sldbState, string) { +withRetryRestart <- function(description, expr) { + call <- substitute(expr) retry <- TRUE - value <- "" while(retry) { retry <- FALSE - withRestarts(value <- eval(parse(text=string), envir = globalenv()), - retry=list(description="retry SLIME interactive evaluation request", handler=function() retry <<- TRUE)) + withRestarts(eval.parent(call), + retry=list(description=description, + handler=function() retry <<- TRUE)) } +} + +`swank:interactive-eval` <- function(slimeConnection, sldbState, string) { + withRetryRestart("retry SLIME interactive evaluation request", + value <- eval(parse(text=string), envir=globalenv())) printToString(value) } `swank:eval-and-grab-output` <- function(slimeConnection, sldbState, string) { - retry <- TRUE - value <- "" - output <- NULL - f <- fifo("") - tryCatch({ - sink(f) - while(retry) { - retry <- FALSE - withRestarts(value <- eval(parse(text=string), envir = globalenv()), - retry=list(description="retry SLIME interactive evaluation request", handler=function() retry <<- TRUE))}}, - finally={sink(); output <- readLines(f); close(f)}) + withRetryRestart("retry SLIME interactive evaluation request", + { output <- + withOutputToString(value <- eval(parse(text=string), + envir=globalenv())) }) list(output, printToString(value)) } + +`swank:find-definitions-for-emacs` <- function(slimeConnection, sldbState, string) { + if(exists(string, envir = globalenv())) { + thing <- get(string, envir = globalenv()) + if(inherits(thing, "function")) { + body <- body(thing) + srcref <- attr(body, "srcref") + srcfile <- attr(body, "srcfile") + if(is.null(srcfile)) { + list() + } else { + filename <- get("filename", srcfile) + list(list(sprintf("function %s", string), + list(quote(`:location`), + list(quote(`:file`), sprintf("%s/%s", srcfile$wd, srcfile$filename)), + list(quote(`:line`), srcref[[2]][[1]], srcref[[2]][[2]]-1), + list()))) + } + } else { + list() + } + } else { + list() + } +} + +`swank:value-for-editing` <- function(slimeConnection, sldbState, string) { + paste(deparse(eval(parse(text=string), envir = globalenv()), control="all"), + collapse="\n", sep="") +} + +`swank:commit-edited-value` <- function(slimeConnection, sldbState, string, value) { + eval(parse(text=sprintf("%s <- %s", string, value)), envir = globalenv()) + TRUE +} + +resetInspector <- function(slimeConnection) { + assign("istate", list(), envir=slimeConnection) + assign("inspectorHistory", NULL, envir=slimeConnection) +} + +`swank:init-inspector` <- function(slimeConnection, sldbState, string) { + withRetryRestart("retry SLIME inspection request", + { resetInspector(slimeConnection) + value <- inspectObject(slimeConnection, eval(parse(text=string), envir=globalenv())) + }) + value +} + +inspectObject <- function(slimeConnection, object) { + previous <- slimeConnection$istate + slimeConnection$istate <- new.env() + slimeConnection$istate$object <- object + slimeConnection$istate$previous <- previous + slimeConnection$istate$content <- emacsInspect(object) + if(!(object %in% slimeConnection$inspectorHistory)) { + slimeConnection$inspectorHistory <- c(slimeConnection$inspectorHistory, object) + } + if(!is.null(slimeConnection$istate$previous)) { + slimeConnection$istate$previous$`next` <- slimeConnection$istate + } + istateToElisp(slimeConnection$istate) +} + +valuePart <- function(istate, object, string) { + list(quote(`:value`), + if(is.null(string)) paste(printToString(object),collapse=" ") else string, + assignIndexInParts(object, istate)) +} + +preparePart <- function(istate, part) { + if(is.character(part)) { + list(part) + } else { + switch(as.character(part[[1]]), + `:newline` = list("\n"), + `:value` = valuePart(istate, part[[2]], part[[3]]), + `:line` = list(printToString(part[[2]]), ": ", + valuePart(istate, part[[3]], NULL), "\n")) + } +} + +prepareRange <- function(istate, start, end) { + range <- istate$content[start+1:min(end+1, length(istate$content))] + ps <- NULL + for(part in range) { + ps <- c(ps, preparePart(istate, part)) + } + list(ps, if(length(ps)