X-Git-Url: http://christophe.rhodes.io/gitweb/?p=swankr.git;a=blobdiff_plain;f=swank.R;h=99012ec57ec4bc7ed9b6d80010145476d40f108d;hp=0384004ac87866fdf79bc4b99d072f954fde17ae;hb=2a4f3c6ca11bb324919df918744092d1cb339f2d;hpb=d71a219019f099e6c8a3be18e5ace3f06faaeded diff --git a/swank.R b/swank.R index 0384004..99012ec 100644 --- a/swank.R +++ b/swank.R @@ -13,18 +13,30 @@ ### latest version of the GNU General Public Licence is available at ### . +### KLUDGE: this assumes that we're being sourced with chdir=TRUE. +### (If not, `swank:swank-require` will work under the circumstances +### that it used to work anyway -- i.e. the working directory is the +### swankr directory) +swankrPath <- getwd() + swank <- function(port=4005) { acceptConnections(port, FALSE) } startSwank <- function(portFile) { - acceptConnections(FALSE, portFile) + acceptConnections(4005, portFile) } acceptConnections <- function(port, portFile) { + if(portFile != FALSE) { + f <- file(portFile, open="w+") + cat(port, file=f) + close(f) + } + ## FIXME: maybe we should support dontClose here? s <- socketConnection(host="localhost", server=TRUE, port=port, open="r+b") on.exit(close(s)) - serve(s) + tryCatch(serve(s), endOfFile=function(c) NULL) } serve <- function(io) { @@ -51,7 +63,7 @@ dispatch <- function(slimeConnection, event, sldbState=NULL) { sendToEmacs <- function(slimeConnection, obj) { io <- slimeConnection$io payload <- writeSexpToString(obj) - writeChar(sprintf("%06x", nchar(payload)), io, eos=NULL) + writeChar(sprintf("%06x", nchar(payload, type="bytes")), io, eos=NULL) writeChar(payload, io, eos=NULL) flush(io) } @@ -134,6 +146,11 @@ readPacket <- function(io) { readChunk <- function(io, len) { buffer <- readChar(io, len) + if(length(buffer) == 0) { + condition <- simpleCondition("End of file on io") + class(condition) <- c("endOfFile", class(condition)) + signalCondition(condition) + } if(nchar(buffer) != len) { stop("short read in readChunk") } @@ -210,7 +227,14 @@ readSexpFromString <- function(string) { } else if(grepl("^[0-9]+\\.[0-9]+$", token)) { as.double(token) } else { - as.name(token) + name <- as.name(token) + if(name == quote(t)) { + TRUE + } else if(name == quote(nil)) { + FALSE + } else { + name + } } } readToken <- function() { @@ -269,6 +293,8 @@ printToString <- function(val) { `swank:connection-info` <- function (slimeConnection, sldbState) { list(quote(`:pid`), Sys.getpid(), quote(`:package`), list(quote(`:name`), "R", quote(`:prompt`), "R> "), + quote(`:version`), "2012-04-23", + quote(`:encoding`), list(quote(`:coding-systems`), list("utf-8-unix")), quote(`:lisp-implementation`), list(quote(`:type`), "R", quote(`:name`), "R", quote(`:version`), paste(R.version$major, R.version$minor, sep="."))) @@ -276,7 +302,7 @@ printToString <- function(val) { `swank:swank-require` <- function (slimeConnection, sldbState, contribs) { for(contrib in contribs) { - filename <- sprintf("%s.R", as.character(contrib)) + filename <- sprintf("%s/%s.R", swankrPath, as.character(contrib)) if(file.exists(filename)) { source(filename) } @@ -304,20 +330,35 @@ sendReplResult <- function(slimeConnection, value) { sendReplResultFunction <- sendReplResult `swank:listener-eval` <- function(slimeConnection, sldbState, string) { + ## O how ugly 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) + for(expr in parse(text=string)) { + expr <- expr + ## O maybe this is even uglier + lookedup <- do.call("bquote", list(expr)) + tmp <- withVisible(eval(lookedup, envir = globalenv())) + if(tmp$visible) { + sendReplResultFunction(slimeConnection, tmp$value) + } + } list() } `swank:autodoc` <- function(slimeConnection, sldbState, rawForm, ...) { - "No Arglist Information" + list("No Arglist Information", TRUE) } `swank:operator-arglist` <- function(slimeConnection, sldbState, op, package) { - list() + if(!exists(op, envir = globalenv())) { + return(list()) + } + funoid <- get(op, envir = globalenv()) + if(is.function(funoid)) { + args <- formals(funoid) + paste(sprintf("%s=%s", names(args), args), collapse=", ") + } else { + list() + } } `swank:throw-to-toplevel` <- function(slimeConnection, sldbState) { @@ -370,8 +411,16 @@ computeRestartsForEmacs <- function (sldbState) { if(is.null(srcfile)) { list(quote(`:error`), "no srcfile") } else { + filename <- get("filename", srcfile) + ## KLUDGE: what this means is "is the srcfile filename + ## absolute?" + if(substr(filename, 1, 1) == "/") { + file <- filename + } else { + file <- sprintf("%s/%s", srcfile$wd, filename) + } list(quote(`:location`), - list(quote(`:file`), sprintf("%s/%s", srcfile$wd, srcfile$filename)), + list(quote(`:file`), file), list(quote(`:line`), srcref[[1]], srcref[[2]]-1), FALSE) } @@ -391,24 +440,59 @@ computeRestartsForEmacs <- function (sldbState) { `swank:frame-locals-and-catch-tags` <- function(slimeConnection, sldbState, index) { frame <- sldbState$frames[[1+index]] objs <- ls(envir=frame) + if(identical(frame, globalenv())) { + objs <- c() + } list(lapply(objs, function(name) { list(quote(`:name`), name, quote(`:id`), 0, - quote(`:value`), printToString(eval(parse(text=name), envir=frame))) }), + quote(`:value`), + tryCatch({ + printToString(eval(parse(text=name), envir=frame)) + }, error=function(c) { + sprintf("error printing object") + }))}), list()) } `swank:simple-completions` <- function(slimeConnection, sldbState, prefix, package) { - ## fails multiply if prefix contains regexp metacharacters - matches <- apropos(sprintf("^%s", prefix), ignore.case=FALSE) + symbolFieldsCompletion <- function(object, rest) { + ## FIXME: this is hacky, ignoring several syntax issues (use of + ## and/or necessity for backquoting identifiers: e.g. fields + ## containing hyphens) + if((dollar <- regexpr("$", rest, fixed=TRUE)) == -1) { + matches <- grep(sprintf("^%s", literal2rx(rest)), names(object), value=TRUE) + matches <- sprintf("%s$%s", gsub("\\$[^$]*$", "", prefix), matches) + returnMatches(matches) + } else { + if(exists(substr(rest, 1, dollar-1), object)) { + symbolFieldsCompletion(get(substr(rest, 1, dollar-1), object), substr(rest, dollar+1, nchar(rest))) + } else { + returnMatches(character(0)) + } + } + } + returnMatches <- function(matches) { + nmatches <- length(matches) + if(nmatches == 0) { + list(list(), "") + } else { + longest <- matches[order(nchar(matches))][1] + while(length(grep(sprintf("^%s", literal2rx(longest)), matches)) < nmatches) { + longest <- substr(longest, 1, nchar(longest)-1) + } + list(as.list(matches), longest) + } + } + literal2rx <- function(string) { + ## list of ERE metacharacters from ?regexp + gsub("([.\\|()[{^$*+?])", "\\\\\\1", string) + } + matches <- apropos(sprintf("^%s", literal2rx(prefix)), ignore.case=FALSE) nmatches <- length(matches) - if(nmatches == 0) { - list(list(), "") + if((nmatches == 0) && ((dollar <- regexpr("$", prefix, fixed=TRUE)) > -1)) { + symbolFieldsCompletion(globalenv(), prefix) } else { - longest <- matches[order(nchar(matches))][1] - while(length(grep(sprintf("^%s", longest), matches)) < nmatches) { - longest <- substr(longest, 1, nchar(longest)-1) - } - list(as.list(matches), longest) + returnMatches(matches) } } @@ -464,17 +548,35 @@ withRetryRestart <- function(description, expr) { `swank:interactive-eval` <- function(slimeConnection, sldbState, string) { withRetryRestart("retry SLIME interactive evaluation request", - value <- eval(parse(text=string), envir=globalenv())) - prin1ToString(value) + tmp <- withVisible(eval(parse(text=string), envir=globalenv()))) + if(tmp$visible) { + prin1ToString(tmp$value) + } else { + "# invisible value" + } } `swank:eval-and-grab-output` <- function(slimeConnection, sldbState, string) { withRetryRestart("retry SLIME interactive evaluation request", { output <- - capture.output(value <- eval(parse(text=string), - envir=globalenv())) }) + capture.output(tmp <- withVisible(eval(parse(text=string), + envir=globalenv()))) }) output <- paste(output, sep="", collapse="\n") - list(output, prin1ToString(value)) + if(tmp$visible) { + list(output, prin1ToString(tmp$value)) + } else { + list(output, "# invisible value") + } +} + +`swank:interactive-eval-region` <- function(slimeConnection, sldbState, string) { + withRetryRestart("retry SLIME interactive evaluation request", + tmp <- withVisible(eval(parse(text=string), envir=globalenv()))) + if(tmp$visible) { + prin1ToString(tmp$value) + } else { + "# invisible value" + } } `swank:find-definitions-for-emacs` <- function(slimeConnection, sldbState, string) { @@ -533,12 +635,19 @@ resetInspector <- function(slimeConnection) { } inspectObject <- function(slimeConnection, object) { + vectorify <- function(x) { + if(is.vector(x)) { + x + } else { + list(x) + } + } 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)) { + if(!(vectorify(object) %in% slimeConnection$inspectorHistory)) { slimeConnection$inspectorHistory <- c(slimeConnection$inspectorHistory, object) } if(!is.null(slimeConnection$istate$previous)) { @@ -549,7 +658,7 @@ inspectObject <- function(slimeConnection, object) { valuePart <- function(istate, object, string) { list(quote(`:value`), - if(is.null(string)) printToString(object) else string, + if(is.null(string)) prin1ToString(object) else string, assignIndexInParts(object, istate)) } @@ -560,7 +669,7 @@ preparePart <- function(istate, part) { switch(as.character(part[[1]]), `:newline` = list("\n"), `:value` = valuePart(istate, part[[2]], part[[3]]), - `:line` = list(printToString(part[[2]]), ": ", + `:line` = list(prin1ToString(part[[2]]), ": ", valuePart(istate, part[[3]], NULL), "\n")) } } @@ -673,11 +782,21 @@ emacsInspect.numeric <- function(numeric) { } `swank:load-file` <- function(slimeConnection, sldbState, filename) { - source(filename, local=FALSE) + source(filename, local=FALSE, keep.source=TRUE) TRUE } `swank:compile-file-for-emacs` <- function(slimeConnection, sldbState, filename, loadp, ...) { - times <- system.time(parse(filename)) + times <- system.time(parse(filename, srcfile=srcfile(filename))) + if(loadp) { + ## KLUDGE: inelegant, but works. It might be more in the spirit + ## of things to keep the result of the parse above around to + ## evaluate. + `swank:load-file`(slimeConnection, sldbState, filename) + } list(quote(`:compilation-result`), list(), TRUE, times[3], substitute(loadp), filename) } + +`swank:quit-lisp` <- function(slimeConnection, sldbState) { + quit() +}