swank.R

   1 swank <- function(port=4005) {
   2   acceptConnections(port, FALSE)
   3 }
   4
   5 startSwank <- function(portFile) {
   6   acceptConnections(FALSE, portFile)
   7 }
   8
   9 acceptConnections <- function(port, portFile) {
  10   s <- socketConnection(host="localhost", server=TRUE, port=port, open="r+b")
  11   on.exit(close(s))
  12   serve(s)
  13 }
  14
  15 serve <- function(io) {
  16   mainLoop(io)
  17 }
  18
  19 mainLoop <- function(io) {
  20   dispatch <- function(event) {
  21     str(event)
  22     kind <- event[[1]]
  23     if(kind == quote(`:emacs-rex`)) {
  24       do.call("emacsRex", event[-1])
  25     }
  26   }
  27   sendToEmacs <- function(obj) {
  28     payload <- writeSexpToString(obj)
  29     writeChar(sprintf("%06x", nchar(payload)), io, eos=NULL)
  30     writeChar(payload, io, eos=NULL)
  31     flush(io)
  32     cat(sprintf("%06x", nchar(payload)), payload, sep="")
  33   }
  34   emacsRex <- function(form, pkg, thread, id) {
  35     value <- do.call(eval(form[[1]]), form[-1])
  36     sendToEmacs(list(quote(`:return`), list(quote(`:ok`), value), id))
  37   }
  38
  39   while(TRUE) {
  40     tryCatch(dispatch(readPacket(io)),
  41              swankTopLevel=NULL)
  42   }
  43 }
  44
  45 readPacket <- function(io) {
  46   header <- readChunk(io, 6)
  47   len <- strtoi(header, base=16)
  48   payload <- readChunk(io, len)
  49   readSexpFromString(payload)
  50 }
  51
  52 readChunk <- function(io, len) {
  53   buffer <- readChar(io, len)
  54   if(nchar(buffer) != len) {
  55     stop("short read in readChunk")
  56   }
  57   buffer
  58 }
  59
  60 readSexpFromString <- function(string) {
  61   pos <- 1
  62   read <- function() {
  63     skipWhitespace()
  64     char <- substr(string, pos, pos)
  65     switch(char,
  66            "("=readList(),
  67            "\""=readString(),
  68            "'"=readQuote(),
  69            {
  70              if(pos > nchar(string))
  71                stop("EOF during read")
  72              obj <- readNumberOrSymbol()
  73              if(obj == quote(`.`)) {
  74                stop("Consing dot not implemented")
  75              }
  76              obj
  77            })
  78   }
  79   skipWhitespace <- function() {
  80     while(substr(string, pos, pos) %in% c(" ", "\t", "\n")) {
  81       pos <<- pos + 1
  82     }
  83   }
  84   readList <- function() {
  85     ret <- list()
  86     pos <<- pos + 1
  87     while(TRUE) {
  88       skipWhitespace()
  89       char <- substr(string, pos, pos)
  90       if(char == ")") {
  91         pos <<- pos + 1
  92         break
  93       } else {
  94         obj <- read()
  95         if(length(obj) == 1 && obj == quote(`.`)) {
  96           stop("Consing dot not implemented")
  97         }
  98         ret <- c(ret, list(obj))
  99       }
 100     }
 101     ret
 102   }
 103   readString <- function() {
 104     ret <- ""
 105     addChar <- function(c) { ret <<- paste(ret, c, sep="") }
 106     while(TRUE) {
 107       pos <<- pos + 1
 108       char <- substr(string, pos, pos)
 109       switch(char,
 110              "\""={ pos <<- pos + 1; break },
 111              "\\"={ pos <<- pos + 1
 112                     char2 <- substr(string, pos, pos)
 113                     switch(char2,
 114                            "\""=addChar(char2),
 115                            "\\"=addChar(char2),
 116                            stop("Unrecognized escape character")) },
 117              addChar(char))
 118     }
 119     ret
 120   }
 121   readNumberOrSymbol <- function() {
 122     token <- readToken()
 123     if(nchar(token)==0) {
 124       stop("End of file reading token")
 125     } else if(grepl("^[0-9]+$", token)) {
 126       strtoi(token)
 127     } else if(grepl("^[0-9]+\\.[0-9]+$", token)) {
 128       as.double(token)
 129     } else {
 130       as.name(token)
 131     }
 132   }
 133   readToken <- function() {
 134     token <- ""
 135     while(TRUE) {
 136       char <- substr(string, pos, pos)
 137       if(char == "") {
 138         break;
 139       } else if(char %in% c(" ", "\n", "\t", "(", ")", "\"", "'")) {
 140         break;
 141       } else {
 142         token <- paste(token, char, sep="")
 143         pos <<- pos + 1
 144       }
 145     }
 146     token
 147   }
 148   read()
 149 }
 150
 151 writeSexpToString <- function(obj) {
 152   writeSexpToStringLoop <- function(obj) {
 153     switch(typeof(obj),
 154            "character"={ string <- paste(string, "\"", gsub("([\"\\])", "\\\\\\1", obj), "\"", sep="") },
 155            "list"={ string <- paste(string, "(", sep="")
 156                     max <- length(obj)
 157                     if(max > 0) {
 158                       for(i in 1:max) {
 159                         string <- paste(string, writeSexpToString(obj[[i]]), sep="")
 160                         if(i != max) {
 161                           string <- paste(string, " ", sep="")
 162                         }
 163                       }
 164                     }
 165                     string <- paste(string, ")", sep="") },
 166            "symbol"={ string <- paste(string, as.character(obj), sep="") },
 167            "logical"={ if(obj) { paste(string, "t", sep="") } else { paste(string, "nil", sep="") }},
 168            "double"={ string <- paste(string, as.character(obj), sep="") },
 169            "integer"={ string <- paste(string, as.character(obj), sep="") },
 170            stop(paste("can't write object ", obj, sep="")))
 171     string
 172   }
 173   string <- ""
 174   writeSexpToStringLoop(obj)
 175 }
 176
 177 `swank:connection-info` <- function () {
 178   list(quote(`:pid`), Sys.getpid(),
 179        quote(`:package`), list(quote(`:name`), "R", quote(`:prompt`), "R> "),
 180        quote(`:lisp-implementation`), list(quote(`:type`), "R",
 181                                            quote(`:name`), "R",
 182                                            quote(`:version`), paste(R.version$major, R.version$minor, sep=".")))
 183 }
 184
 185 `swank:swank-require` <- function (contribs) {
 186   list()
 187 }
 188
 189 `swank:create-repl` <- function(env, ...) {
 190   list("R", "R")
 191 }
 192
 193 `swank:listener-eval` <- function(string) {
 194   val <- eval(parse(text=string))
 195   f <- fifo("")
 196   sink(f)
 197   print(val)
 198   sink()
 199   lines <- readLines(f)
 200   list(quote(`:values`), paste(lines, collapse="\n"))
 201 }
 202
 203 `swank:autodoc` <- function(rawForm, ...) {
 204   "No Arglist Information"
 205 }
 206
 207 `swank:throw-to-toplevel` <- function() {
 208   condition <- simpleError("Throw to toplevel")
 209   class(condition) <- c("swankTopLevel", class(condition))
 210   signalCondition(condition)
 211 }