+### This program is free software; you can redistribute it and/or
+### modify it under the terms of the GNU General Public Licence as
+### published by the Free Software Foundation; either version 2 of the
+### Licence, 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 Licence for more details.
+###
+### A copy of version 2 of the GNU General Public Licence is available
+### at <http://www.gnu.org/licenses/old-licenses/gpl-2.0.txt>; the
+### latest version of the GNU General Public Licence is available at
+### <http://www.gnu.org/licenses/gpl.txt>.
+
swank <- function(port=4005) {
acceptConnections(port, FALSE)
}
}
mainLoop <- function(io) {
+ slimeConnection <- new.env()
+ slimeConnection$io <- io
while(TRUE) {
- withRestarts(tryCatch(dispatch(io, readPacket(io)),
+ withRestarts(tryCatch(dispatch(slimeConnection, readPacket(io)),
swankTopLevel=function(c) NULL),
abort="return to SLIME's toplevel")
}
}
-dispatch <- function(io, event, sldbState=NULL) {
+dispatch <- function(slimeConnection, event, sldbState=NULL) {
str(event)
kind <- event[[1]]
if(kind == quote(`:emacs-rex`)) {
- do.call("emacsRex", c(list(io), list(sldbState), event[-1]))
+ do.call("emacsRex", c(list(slimeConnection), list(sldbState), event[-1]))
}
}
-sendToEmacs <- function(io, obj) {
+sendToEmacs <- function(slimeConnection, obj) {
+ io <- slimeConnection$io
str(obj)
payload <- writeSexpToString(obj)
writeChar(sprintf("%06x", nchar(payload)), io, eos=NULL)
cat(sprintf("%06x", nchar(payload)), payload, sep="")
}
-emacsRex <- function(io, sldbState, form, pkg, thread, id, level=0) {
+callify <- function(form) {
+ ## we implement here the conversion from Lisp S-expression (or list)
+ ## expressions of code into our own, swankr, calling convention,
+ ## with slimeConnection and sldbState as first and second arguments.
+ ## as.call() gets us part of the way, but we need to walk the list
+ ## recursively to mimic CL:EVAL; we need to avoid converting R
+ ## special operators which we are punning (only `quote`, for now)
+ ## into this calling convention.
+ if(is.list(form)) {
+ if(form[[1]] == quote(quote)) {
+ as.call(form)
+ } else {
+ as.call(c(list(form[[1]], quote(slimeConnection), quote(sldbState)), lapply(form[-1], callify)))
+ }
+ } else {
+ form
+ }
+}
+
+emacsRex <- function(slimeConnection, sldbState, form, pkg, thread, id, level=0) {
ok <- FALSE
value <- NULL
tryCatch({
withCallingHandlers({
- value <- do.call(eval(form[[1]]), c(list(io), list(sldbState), form[-1]))
+ call <- callify(form)
+ value <- eval(call)
ok <- TRUE
}, error=function(c) {
newSldbState <- makeSldbState(c, if(is.null(sldbState)) 0 else sldbState$level+1, id)
- withRestarts(sldbLoop(io, newSldbState, id), abort=paste("return to sldb level", newSldbState$level)) })},
- finally=sendToEmacs(io, list(quote(`:return`), if(ok) list(quote(`:ok`), value) else list(quote(`:abort`)), id)))
+ withRestarts(sldbLoop(slimeConnection, newSldbState, id), abort=paste("return to sldb level", newSldbState$level)) })},
+ finally=sendToEmacs(slimeConnection, list(quote(`:return`), if(ok) list(quote(`:ok`), value) else list(quote(`:abort`)), id)))
}
makeSldbState <- function(condition, level, id) {
ret
}
-sldbLoop <- function(io, sldbState, id) {
+sldbLoop <- function(slimeConnection, sldbState, id) {
tryCatch({
- sendToEmacs(io, c(list(quote(`:debug`), id, sldbState$level), `swank:debugger-info-for-emacs`(io, sldbState)))
- sendToEmacs(io, list(quote(`:debug-activate`), id, sldbState$level, FALSE))
+ io <- slimeConnection$io
+ sendToEmacs(slimeConnection, c(list(quote(`:debug`), id, sldbState$level), `swank:debugger-info-for-emacs`(slimeConnection, sldbState)))
+ sendToEmacs(slimeConnection, list(quote(`:debug-activate`), id, sldbState$level, FALSE))
while(TRUE) {
- dispatch(io, readPacket(io), sldbState)
+ dispatch(slimeConnection, readPacket(io), sldbState)
}
- }, finally=sendToEmacs(io, c(list(quote(`:debug-return`), id, sldbState$level, FALSE))))
+ }, finally=sendToEmacs(slimeConnection, c(list(quote(`:debug-return`), id, sldbState$level, FALSE))))
}
readPacket <- function(io) {
+ socketSelect(list(io))
header <- readChunk(io, 6)
len <- strtoi(header, base=16)
payload <- readChunk(io, len)
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))
}
-`swank:connection-info` <- function (io, sldbState) {
+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> "),
quote(`:lisp-implementation`), list(quote(`:type`), "R",
quote(`:version`), paste(R.version$major, R.version$minor, sep=".")))
}
-`swank:swank-require` <- function (io, sldbState, contribs) {
+`swank:swank-require` <- function (slimeConnection, sldbState, contribs) {
+ for(contrib in contribs) {
+ filename <- sprintf("%s.R", as.character(contrib))
+ if(file.exists(filename)) {
+ source(filename, verbose=TRUE)
+ }
+ }
list()
}
-`swank:create-repl` <- function(io, sldbState, env, ...) {
+`swank:create-repl` <- function(slimeConnection, sldbState, env, ...) {
list("R", "R")
}
-`swank:listener-eval` <- function(io, sldbState, string) {
- val <- eval(parse(text=string), envir = globalenv())
- string <- printToString(val)
- list(quote(`:values`), paste(string, collapse="\n"))
+makeReplResult <- function(value) {
+ string <- printToString(value)
+ list(quote(`:write-string`), paste(string, collapse="\n"),
+ quote(`:repl-result`))
+}
+
+makeReplResultFunction <- makeReplResult
+
+sendReplResult <- function(slimeConnection, value) {
+ result <- makeReplResultFunction(value)
+ sendToEmacs(slimeConnection, result)
+}
+
+sendReplResultFunction <- sendReplResult
+
+`swank:listener-eval` <- function(slimeConnection, sldbState, string) {
+ string <- gsub("#\\.\\(swank:lookup-presented-object-or-lose([^)]*)\\)", ".(`swank:lookup-presented-object-or-lose`(slimeConnection, sldbState,\\1))", string)
+ expr <- parse(text=string)[[1]]
+ lookedup <- do.call("bquote", list(expr))
+ value <- eval(lookedup, envir = globalenv())
+ sendReplResultFunction(slimeConnection, value)
+ list()
}
-`swank:autodoc` <- function(io, sldbState, rawForm, ...) {
+`swank:autodoc` <- function(slimeConnection, sldbState, rawForm, ...) {
"No Arglist Information"
}
-`swank:operator-arglist` <- function(io, sldbState, op, package) {
+`swank:operator-arglist` <- function(slimeConnection, sldbState, op, package) {
list()
}
-`swank:throw-to-toplevel` <- function(io, sldbState) {
+`swank:throw-to-toplevel` <- function(slimeConnection, sldbState) {
condition <- simpleCondition("Throw to toplevel")
class(condition) <- c("swankTopLevel", class(condition))
signalCondition(condition)
}
-`swank:backtrace` <- function(io, sldbState, from=0, to=NULL) {
+`swank:backtrace` <- function(slimeConnection, sldbState, from=0, to=NULL) {
calls <- sldbState$calls
if(is.null(to)) to <- length(calls)
from <- from+1
})
}
-`swank:debugger-info-for-emacs` <- function(io, sldbState, from=0, to=NULL) {
+`swank:debugger-info-for-emacs` <- function(slimeConnection, sldbState, from=0, to=NULL) {
list(list(as.character(sldbState$condition), sprintf(" [%s]", class(sldbState$condition)[[1]]), FALSE),
computeRestartsForEmacs(sldbState),
- `swank:backtrace`(io, sldbState, from, to),
+ `swank:backtrace`(slimeConnection, sldbState, from, to),
list(sldbState$id))
}
-`swank:invoke-nth-restart-for-emacs` <- function(io, sldbState, level, n) {
+`swank:invoke-nth-restart-for-emacs` <- function(slimeConnection, sldbState, level, n) {
if(sldbState$level == level) {
invokeRestart(sldbState$restarts[[n+1]])
}
}
-`swank:frame-source-location` <- function(io, sldbState, n) {
+`swank:frame-source-location` <- function(slimeConnection, sldbState, n) {
call <- sldbState$calls[[n+1]]
srcref <- attr(call, "srcref")
srcfile <- attr(srcref, "srcfile")
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)
}
}
-`swank:buffer-first-change` <- function(io, sldbState, filename) {
+`swank:buffer-first-change` <- function(slimeConnection, sldbState, filename) {
FALSE
}
-`swank:frame-locals-and-catch-tags` <- function(io, sldbState, index) {
+`swank:eval-string-in-frame` <- function(slimeConnection, sldbState, string, index) {
+ frame <- sldbState$frames[[1+index]]
+ withRetryRestart("retry SLIME interactive evaluation request",
+ value <- eval(parse(text=string), envir=frame))
+ printToString(value)
+}
+
+`swank:frame-locals-and-catch-tags` <- function(slimeConnection, sldbState, index) {
str(sldbState$frames)
frame <- sldbState$frames[[1+index]]
objs <- ls(envir=frame)
list())
}
-`swank:simple-completions` <- function(io, sldbState, prefix, package) {
+`swank:simple-completions` <- function(slimeConnection, sldbState, prefix, package) {
## fails multiply if prefix contains regexp metacharacters
matches <- apropos(sprintf("^%s", prefix), ignore.case=FALSE)
nmatches <- length(matches)
}
}
-`swank:compile-string-for-emacs` <- function(io, sldbState, string, buffer, position, filename, policy) {
+`swank:compile-string-for-emacs` <- function(slimeConnection, sldbState, string, buffer, position, filename, policy) {
# FIXME: I think in parse() here we can use srcref to associate
# buffer/filename/position to the objects. Or something.
withRestarts({ times <- system.time(eval(parse(text=string), envir = globalenv())) },
list(quote(`:compilation-result`), list(), TRUE, times[3])
}
-`swank:interactive-eval` <- function(io, 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(io, 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)})
+`swank:eval-and-grab-output` <- function(slimeConnection, sldbState, string) {
+ 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)<end-start) { start+length(ps) } else { end+1000 },
+ start, end)
+}
+
+assignIndexInParts <- function(object, istate) {
+ ret <- 1+length(istate$parts)
+ istate$parts <- c(istate$parts, list(object))
+ ret
+}
+
+istateToElisp <- function(istate) {
+ list(quote(`:title`), deparse(istate$object, control="all", nlines=1),
+ quote(`:id`), assignIndexInParts(istate$object, istate),
+ quote(`:content`), prepareRange(istate, 0, 500))
+}
+
+emacsInspect <- function(object) {
+ UseMethod("emacsInspect")
+}
+
+emacsInspect.default <- function(thing) {
+ c(list(paste("a ", class(thing)[[1]], sep=""), list(quote(`:newline`))))
+}
+
+emacsInspect.list <- function(list) {
+ c(list("a list", list(quote(`:newline`))),
+ mapply(function(name, value) { list(list(quote(`:line`), name, value)) },
+ names(list), list))
+}
+
+emacsInspect.numeric <- function(numeric) {
+ c(list("a numeric", list(quote(`:newline`))),
+ mapply(function(name, value) { list(list(quote(`:line`), name, value)) },
+ (1:length(numeric)), numeric))
+}
+
+`swank:quit-inspector` <- function(slimeConnection, sldbState) {
+ resetInspector(slimeConnection)
+ FALSE
+}
+
+`swank:inspector-nth-part` <- function(slimeConnection, sldbState, index) {
+ slimeConnection$istate$parts[[index]]
+}
+
+`swank:inspect-nth-part` <- function(slimeConnection, sldbState, index) {
+ object <- `swank:inspector-nth-part`(slimeConnection, sldbState, index)
+ inspectObject(slimeConnection, object)
+}
+
+`swank:inspector-pop` <- function(slimeConnection, sldbState) {
+ if(!is.null(slimeConnection$istate$previous)) {
+ slimeConnection$istate <- slimeConnection$istate$previous
+ istateToElisp(slimeConnection$istate)
+ } else {
+ FALSE
+ }
+}
+
+`swank:inspector-next` <- function(slimeConnection, sldbState) {
+ if(!is.null(slimeConnection$istate$`next`)) {
+ slimeConnection$istate <- slimeConnection$istate$`next`
+ istateToElisp(slimeConnection$istate)
+ } else {
+ FALSE
+ }
+}
+
+`swank:inspector-eval` <- function(slimeConnection, sldbState, string) {
+ expr <- parse(text=string)[[1]]
+ object <- slimeConnection$istate$object
+ if(inherits(object, "list")|inherits(object, "environment")) {
+ substituted <- substituteDirect(expr, object)
+ eval(substituted, envir=globalenv())
+ } else {
+ eval(expr, envir=globalenv())
+ }
+}
+
+`swank:inspect-current-condition` <- function(slimeConnection, sldbState) {
+ resetInspector(slimeConnection)
+ inspectObject(slimeConnection, sldbState$condition)
+}
+
+`swank:inspect-frame-var` <- function(slimeConnection, sldbState, frame, var) {
+ resetInspector(slimeConnection)
+ frame <- sldbState$frames[[1+frame]]
+ name <- ls(envir=frame)[[1+var]]
+ object <- get(name, envir=frame)
+ inspectObject(slimeConnection, object)
+}