X-Git-Url: http://christophe.rhodes.io/gitweb/?p=swankr.git;a=blobdiff_plain;f=swank.R;h=22dd53286c467fc02abb8a162e942fb04f10c5d8;hp=578d61c75a83f45f2a82081d9a09d89dc10d243e;hb=de8519735fa924b327c5720d9e8efc2dadc834c4;hpb=7683b39edd19ab103e711753bffbba3632cc70eb

diff --git a/swank.R b/swank.R
index 578d61c..22dd532 100644
--- a/swank.R
+++ b/swank.R
@@ -59,12 +59,32 @@ sendToEmacs <- function(slimeConnection, obj) {
   cat(sprintf("%06x", nchar(payload)), payload, sep="")
 }
 
+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(slimeConnection), 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)
@@ -93,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)
@@ -224,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> "),
@@ -239,6 +267,12 @@ printToString <- function(val) {
 }
 
 `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()
 }
 
@@ -246,10 +280,22 @@ printToString <- function(val) {
   list("R", "R")
 }
 
+sendReplResult <- function(slimeConnection, value) {
+  string <- printToString(value)
+  sendToEmacs(slimeConnection,
+              list(quote(`:write-string`),
+                   paste(string, collapse="\n"),
+                   quote(`:repl-result`)))
+}
+
+sendReplResultFunction <- sendReplResult
+
 `swank:listener-eval` <- function(slimeConnection, sldbState, string) {
-  val <- eval(parse(text=string), envir = globalenv())
-  string <- printToString(val)
-  sendToEmacs(slimeConnection, list(quote(`:write-string`), paste(string, collapse="\n"), quote(`:repl-result`)))
+  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()
 }
 
@@ -311,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)
   }
@@ -356,28 +401,62 @@ 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
+}