swank.R

   1 ### This program is free software; you can redistribute it and/or
   2 ### modify it under the terms of the GNU General Public Licence as
   3 ### published by the Free Software Foundation; either version 2 of the
   4 ### Licence, or (at your option) any later version.
   5 ###
   6 ### This program is distributed in the hope that it will be useful,
   7 ### but WITHOUT ANY WARRANTY; without even the implied warranty of
   8 ### MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   9 ### GNU General Public Licence for more details.
  10 ###
  11 ### A copy of version 2 of the GNU General Public Licence is available
  12 ### at <http://www.gnu.org/licenses/old-licenses/gpl-2.0.txt>; the
  13 ### latest version of the GNU General Public Licence is available at
  14 ### <http://www.gnu.org/licenses/gpl.txt>.
  15
  16 swank <- function(port=4005) {
  17   acceptConnections(port, FALSE)
  18 }
  19
  20 startSwank <- function(portFile) {
  21   acceptConnections(4005, portFile)
  22 }
  23
  24 acceptConnections <- function(port, portFile) {
  25   if(portFile != FALSE) {
  26     f <- file(portFile, open="w+")
  27     cat(port, file=f)
  28     close(f)
  29   }
  30   s <- socketConnection(host="localhost", server=TRUE, port=port, open="r+b")
  31   on.exit(close(s))
  32   serve(s)
  33 }
  34
  35 serve <- function(io) {
  36   mainLoop(io)
  37 }
  38
  39 mainLoop <- function(io) {
  40   slimeConnection <- new.env()
  41   slimeConnection$io <- io
  42   while(TRUE) {
  43     withRestarts(tryCatch(dispatch(slimeConnection, readPacket(io)),
  44                           swankTopLevel=function(c) NULL),
  45                  abort="return to SLIME's toplevel")
  46   }
  47 }
  48
  49 dispatch <- function(slimeConnection, event, sldbState=NULL) {
  50   kind <- event[[1]]
  51   if(kind == quote(`:emacs-rex`)) {
  52     do.call("emacsRex", c(list(slimeConnection), list(sldbState), event[-1]))
  53   }
  54 }
  55
  56 sendToEmacs <- function(slimeConnection, obj) {
  57   io <- slimeConnection$io
  58   payload <- writeSexpToString(obj)
  59   writeChar(sprintf("%06x", nchar(payload)), io, eos=NULL)
  60   writeChar(payload, io, eos=NULL)
  61   flush(io)
  62 }
  63
  64 callify <- function(form) {
  65   ## we implement here the conversion from Lisp S-expression (or list)
  66   ## expressions of code into our own, swankr, calling convention,
  67   ## with slimeConnection and sldbState as first and second arguments.
  68   ## as.call() gets us part of the way, but we need to walk the list
  69   ## recursively to mimic CL:EVAL; we need to avoid converting R
  70   ## special operators which we are punning (only `quote`, for now)
  71   ## into this calling convention.
  72   if(is.list(form)) {
  73     if(form[[1]] == quote(quote)) {
  74       as.call(form)
  75     } else {
  76       as.call(c(list(form[[1]], quote(slimeConnection), quote(sldbState)), lapply(form[-1], callify)))
  77     }
  78   } else {
  79     form
  80   }
  81 }
  82
  83 emacsRex <- function(slimeConnection, sldbState, form, pkg, thread, id, level=0) {
  84   ok <- FALSE
  85   value <- NULL
  86   conn <- textConnection(NULL, open="w")
  87   condition <- NULL
  88   tryCatch({
  89     withCallingHandlers({
  90       call <- callify(form)
  91       capture.output(value <- eval(call), file=conn)
  92       string <- paste(textConnectionValue(conn), sep="", collapse="\n")
  93       if(nchar(string) > 0) {
  94         sendToEmacs(slimeConnection, list(quote(`:write-string`), string))
  95         sendToEmacs(slimeConnection, list(quote(`:write-string`), "\n"))
  96       }
  97       close(conn)
  98       ok <- TRUE
  99     }, error=function(c) {
 100       condition <<- c
 101       string <- paste(textConnectionValue(conn), sep="", collapse="\n")
 102       if(nchar(string) > 0) {
 103         sendToEmacs(slimeConnection, list(quote(`:write-string`), string))
 104         sendToEmacs(slimeConnection, list(quote(`:write-string`), "\n"))
 105       }
 106       close(conn)
 107       newSldbState <- makeSldbState(c, if(is.null(sldbState)) 0 else sldbState$level+1, id)
 108       withRestarts(sldbLoop(slimeConnection, newSldbState, id), abort=paste("return to sldb level", newSldbState$level)) })},
 109     finally=sendToEmacs(slimeConnection, list(quote(`:return`), if(ok) list(quote(`:ok`), value) else list(quote(`:abort`), as.character(condition)), id)))
 110 }
 111
 112 makeSldbState <- function(condition, level, id) {
 113   calls <- rev(sys.calls())[-1]
 114   frames <- rev(sys.frames())[-1]
 115   restarts <- rev(computeRestarts(condition))[-1]
 116   ret <- list(condition=condition, level=level, id=id, restarts=restarts, calls=calls, frames=frames)
 117   class(ret) <- c("sldbState", class(ret))
 118   ret
 119 }
 120
 121 sldbLoop <- function(slimeConnection, sldbState, id) {
 122   tryCatch({
 123     io <- slimeConnection$io
 124     sendToEmacs(slimeConnection, c(list(quote(`:debug`), id, sldbState$level), `swank:debugger-info-for-emacs`(slimeConnection, sldbState)))
 125     sendToEmacs(slimeConnection, list(quote(`:debug-activate`), id, sldbState$level, FALSE))
 126     while(TRUE) {
 127       dispatch(slimeConnection, readPacket(io), sldbState)
 128     }
 129   }, finally=sendToEmacs(slimeConnection, c(list(quote(`:debug-return`), id, sldbState$level, FALSE))))
 130 }
 131
 132 readPacket <- function(io) {
 133   socketSelect(list(io))
 134   header <- readChunk(io, 6)
 135   len <- strtoi(header, base=16)
 136   payload <- readChunk(io, len)
 137   readSexpFromString(payload)
 138 }
 139
 140 readChunk <- function(io, len) {
 141   buffer <- readChar(io, len)
 142   if(nchar(buffer) != len) {
 143     stop("short read in readChunk")
 144   }
 145   buffer
 146 }
 147
 148 readSexpFromString <- function(string) {
 149   pos <- 1
 150   read <- function() {
 151     skipWhitespace()
 152     char <- substr(string, pos, pos)
 153     switch(char,
 154            "("=readList(),
 155            "\""=readString(),
 156            "'"=readQuote(),
 157            {
 158              if(pos > nchar(string))
 159                stop("EOF during read")
 160              obj <- readNumberOrSymbol()
 161              if(obj == quote(`.`)) {
 162                stop("Consing dot not implemented")
 163              }
 164              obj
 165            })
 166   }
 167   skipWhitespace <- function() {
 168     while(substr(string, pos, pos) %in% c(" ", "\t", "\n")) {
 169       pos <<- pos + 1
 170     }
 171   }
 172   readList <- function() {
 173     ret <- list()
 174     pos <<- pos + 1
 175     while(TRUE) {
 176       skipWhitespace()
 177       char <- substr(string, pos, pos)
 178       if(char == ")") {
 179         pos <<- pos + 1
 180         break
 181       } else {
 182         obj <- read()
 183         if(length(obj) == 1 && obj == quote(`.`)) {
 184           stop("Consing dot not implemented")
 185         }
 186         ret <- c(ret, list(obj))
 187       }
 188     }
 189     ret
 190   }
 191   readString <- function() {
 192     ret <- ""
 193     addChar <- function(c) { ret <<- paste(ret, c, sep="") }
 194     while(TRUE) {
 195       pos <<- pos + 1
 196       char <- substr(string, pos, pos)
 197       switch(char,
 198              "\""={ pos <<- pos + 1; break },
 199              "\\"={ pos <<- pos + 1
 200                     char2 <- substr(string, pos, pos)
 201                     switch(char2,
 202                            "\""=addChar(char2),
 203                            "\\"=addChar(char2),
 204                            stop("Unrecognized escape character")) },
 205              addChar(char))
 206     }
 207     ret
 208   }
 209   readNumberOrSymbol <- function() {
 210     token <- readToken()
 211     if(nchar(token)==0) {
 212       stop("End of file reading token")
 213     } else if(grepl("^[0-9]+$", token)) {
 214       strtoi(token)
 215     } else if(grepl("^[0-9]+\\.[0-9]+$", token)) {
 216       as.double(token)
 217     } else {
 218       name <- as.name(token)
 219       if(name == quote(t)) {
 220         TRUE
 221       } else if(name == quote(nil)) {
 222         FALSE
 223       } else {
 224         name
 225       }
 226     }
 227   }
 228   readToken <- function() {
 229     token <- ""
 230     while(TRUE) {
 231       char <- substr(string, pos, pos)
 232       if(char == "") {
 233         break;
 234       } else if(char %in% c(" ", "\n", "\t", "(", ")", "\"", "'")) {
 235         break;
 236       } else {
 237         token <- paste(token, char, sep="")
 238         pos <<- pos + 1
 239       }
 240     }
 241     token
 242   }
 243   read()
 244 }
 245
 246 writeSexpToString <- function(obj) {
 247   writeSexpToStringLoop <- function(obj) {
 248     switch(typeof(obj),
 249            "character"={ string <- paste(string, "\"", gsub("([\"\\])", "\\\\\\1", obj), "\"", sep="") },
 250            "list"={ string <- paste(string, "(", sep="")
 251                     max <- length(obj)
 252                     if(max > 0) {
 253                       for(i in 1:max) {
 254                         string <- paste(string, writeSexpToString(obj[[i]]), sep="")
 255                         if(i != max) {
 256                           string <- paste(string, " ", sep="")
 257                         }
 258                       }
 259                     }
 260                     string <- paste(string, ")", sep="") },
 261            "symbol"={ string <- paste(string, as.character(obj), sep="") },
 262            "logical"={ string <- if(obj) { paste(string, "t", sep="") } else { paste(string, "nil", sep="") }},
 263            "double"={ string <- paste(string, as.character(obj), sep="") },
 264            "integer"={ string <- paste(string, as.character(obj), sep="") },
 265            stop(paste("can't write object ", obj, sep="")))
 266     string
 267   }
 268   string <- ""
 269   writeSexpToStringLoop(obj)
 270 }
 271
 272 prin1ToString <- function(val) {
 273   paste(deparse(val, backtick=TRUE, control=c("delayPromises", "keepNA")),
 274         sep="", collapse="\n")
 275 }
 276
 277 printToString <- function(val) {
 278   paste(capture.output(print(val)), sep="", collapse="\n")
 279 }
 280
 281 `swank:connection-info` <- function (slimeConnection, sldbState) {
 282   list(quote(`:pid`), Sys.getpid(),
 283        quote(`:package`), list(quote(`:name`), "R", quote(`:prompt`), "R> "),
 284        quote(`:lisp-implementation`), list(quote(`:type`), "R",
 285                                            quote(`:name`), "R",
 286                                            quote(`:version`), paste(R.version$major, R.version$minor, sep=".")))
 287 }
 288
 289 `swank:swank-require` <- function (slimeConnection, sldbState, contribs) {
 290   for(contrib in contribs) {
 291     filename <- sprintf("%s.R", as.character(contrib))
 292     if(file.exists(filename)) {
 293       source(filename)
 294     }
 295   }
 296   list()
 297 }
 298
 299 `swank:create-repl` <- function(slimeConnection, sldbState, env, ...) {
 300   list("R", "R")
 301 }
 302
 303 makeReplResult <- function(value) {
 304   string <- printToString(value)
 305   list(quote(`:write-string`), string,
 306        quote(`:repl-result`))
 307 }
 308
 309 makeReplResultFunction <- makeReplResult
 310
 311 sendReplResult <- function(slimeConnection, value) {
 312   result <- makeReplResultFunction(value)
 313   sendToEmacs(slimeConnection, result)
 314 }
 315
 316 sendReplResultFunction <- sendReplResult
 317
 318 `swank:listener-eval` <- function(slimeConnection, sldbState, string) {
 319   ## O how ugly
 320   string <- gsub("#\\.\\(swank:lookup-presented-object-or-lose([^)]*)\\)", ".(`swank:lookup-presented-object-or-lose`(slimeConnection, sldbState,\\1))", string)
 321   expr <- parse(text=string)[[1]]
 322   ## O maybe this is even uglier
 323   lookedup <- do.call("bquote", list(expr))
 324   value <- eval(lookedup, envir = globalenv())
 325   sendReplResultFunction(slimeConnection, value)
 326   list()
 327 }
 328
 329 `swank:autodoc` <- function(slimeConnection, sldbState, rawForm, ...) {
 330   "No Arglist Information"
 331 }
 332
 333 `swank:operator-arglist` <- function(slimeConnection, sldbState, op, package) {
 334   list()
 335 }
 336
 337 `swank:throw-to-toplevel` <- function(slimeConnection, sldbState) {
 338   condition <- simpleCondition("Throw to toplevel")
 339   class(condition) <- c("swankTopLevel", class(condition))
 340   signalCondition(condition)
 341 }
 342
 343 `swank:backtrace` <- function(slimeConnection, sldbState, from=0, to=NULL) {
 344   calls <- sldbState$calls
 345   if(is.null(to)) to <- length(calls)
 346   from <- from+1
 347   calls <- lapply(calls[from:to],
 348                   { frameNumber <- from-1;
 349                     function (x) {
 350                       ret <- list(frameNumber, paste(format(x), sep="", collapse=" "))
 351                       frameNumber <<- 1+frameNumber
 352                       ret
 353                     }
 354                   })
 355 }
 356
 357 computeRestartsForEmacs <- function (sldbState) {
 358   lapply(sldbState$restarts,
 359          function(x) {
 360            ## this is all a little bit internalsy
 361            restartName <- x[[1]][[1]]
 362            description <- restartDescription(x)
 363            list(restartName, if(is.null(description)) restartName else description)
 364          })
 365 }
 366
 367 `swank:debugger-info-for-emacs` <- function(slimeConnection, sldbState, from=0, to=NULL) {
 368   list(list(as.character(sldbState$condition), sprintf("  [%s]", class(sldbState$condition)[[1]]), FALSE),
 369        computeRestartsForEmacs(sldbState),
 370        `swank:backtrace`(slimeConnection, sldbState, from, to),
 371        list(sldbState$id))
 372 }
 373
 374 `swank:invoke-nth-restart-for-emacs` <- function(slimeConnection, sldbState, level, n) {
 375   if(sldbState$level == level) {
 376     invokeRestart(sldbState$restarts[[n+1]])
 377   }
 378 }
 379
 380 `swank:frame-source-location` <- function(slimeConnection, sldbState, n) {
 381   call <- sldbState$calls[[n+1]]
 382   srcref <- attr(call, "srcref")
 383   srcfile <- attr(srcref, "srcfile")
 384   if(is.null(srcfile)) {
 385     list(quote(`:error`), "no srcfile")
 386   } else {
 387     filename <- get("filename", srcfile)
 388     ## KLUDGE: what this means is "is the srcfile filename
 389     ## absolute?"
 390     if(substr(filename, 1, 1) == "/") {
 391       file <- filename
 392     } else {
 393       file <- sprintf("%s/%s", srcfile$wd, filename)
 394     }
 395     list(quote(`:location`),
 396          list(quote(`:file`), file),
 397          list(quote(`:line`), srcref[[1]], srcref[[2]]-1),
 398          FALSE)
 399   }
 400 }
 401
 402 `swank:buffer-first-change` <- function(slimeConnection, sldbState, filename) {
 403   FALSE
 404 }
 405
 406 `swank:eval-string-in-frame` <- function(slimeConnection, sldbState, string, index) {
 407   frame <- sldbState$frames[[1+index]]
 408   withRetryRestart("retry SLIME interactive evaluation request",
 409                    value <- eval(parse(text=string), envir=frame))
 410   printToString(value)
 411 }
 412
 413 `swank:frame-locals-and-catch-tags` <- function(slimeConnection, sldbState, index) {
 414   frame <- sldbState$frames[[1+index]]
 415   objs <- ls(envir=frame)
 416   list(lapply(objs, function(name) { list(quote(`:name`), name,
 417                                           quote(`:id`), 0,
 418                                           quote(`:value`), printToString(eval(parse(text=name), envir=frame))) }),
 419        list())
 420 }
 421
 422 `swank:simple-completions` <- function(slimeConnection, sldbState, prefix, package) {
 423   ## fails multiply if prefix contains regexp metacharacters
 424   matches <- apropos(sprintf("^%s", prefix), ignore.case=FALSE)
 425   nmatches <- length(matches)
 426   if(nmatches == 0) {
 427     list(list(), "")
 428   } else {
 429     longest <- matches[order(nchar(matches))][1]
 430     while(length(grep(sprintf("^%s", longest), matches)) < nmatches) {
 431       longest <- substr(longest, 1, nchar(longest)-1)
 432     }
 433     list(as.list(matches), longest)
 434   }
 435 }
 436
 437 `swank:compile-string-for-emacs` <- function(slimeConnection, sldbState, string, buffer, position, filename, policy) {
 438   lineOffset <- charOffset <- colOffset <- NULL
 439   for(pos in position) {
 440     switch(as.character(pos[[1]]),
 441            `:position` = {charOffset <- pos[[2]]},
 442            `:line` = {lineOffset <- pos[[2]]; colOffset <- pos[[3]]},
 443            warning("unknown content in pos", pos))
 444   }
 445   frob <- function(refs) {
 446     lapply(refs,
 447            function(x)
 448            srcref(attr(x,"srcfile"),
 449                   c(x[1]+lineOffset-1, ifelse(x[1]==1, x[2]+colOffset-1, x[2]),
 450                     x[3]+lineOffset-1, ifelse(x[3]==1, x[4]+colOffset-1, x[4]),
 451                     ifelse(x[1]==1, x[5]+colOffset-1, x[5]),
 452                     ifelse(x[3]==1, x[6]+colOffset-1, x[6]))))
 453   }
 454   transformSrcrefs <- function(s) {
 455     srcrefs <- attr(s, "srcref")
 456     attribs <- attributes(s)
 457     new <-
 458       switch(mode(s),
 459              "call"=as.call(lapply(s, transformSrcrefs)),
 460              "expression"=as.expression(lapply(s, transformSrcrefs)),
 461              s)
 462     attributes(new) <- attribs
 463     if(!is.null(attr(s, "srcref"))) {
 464       attr(new, "srcref") <- frob(srcrefs)
 465     }
 466     new
 467   }
 468   withRestarts({
 469     times <- system.time({
 470       exprs <- parse(text=string, srcfile=srcfile(filename))
 471       eval(transformSrcrefs(exprs), envir = globalenv()) })},
 472                abort="abort compilation")
 473   list(quote(`:compilation-result`), list(), TRUE, times[3], FALSE, FALSE)
 474 }
 475
 476 withRetryRestart <- function(description, expr) {
 477   call <- substitute(expr)
 478   retry <- TRUE
 479   while(retry) {
 480     retry <- FALSE
 481     withRestarts(eval.parent(call),
 482                  retry=list(description=description,
 483                    handler=function() retry <<- TRUE))
 484   }
 485 }
 486
 487 `swank:interactive-eval` <-  function(slimeConnection, sldbState, string) {
 488   withRetryRestart("retry SLIME interactive evaluation request",
 489                    value <- eval(parse(text=string), envir=globalenv()))
 490   prin1ToString(value)
 491 }
 492
 493 `swank:eval-and-grab-output` <- function(slimeConnection, sldbState, string) {
 494   withRetryRestart("retry SLIME interactive evaluation request",
 495                    { output <-
 496                        capture.output(value <- eval(parse(text=string),
 497                                                     envir=globalenv())) })
 498   output <- paste(output, sep="", collapse="\n")
 499   list(output, prin1ToString(value))
 500 }
 501
 502 `swank:interactive-eval-region` <- function(slimeConnection, sldbState, string) {
 503   withRetryRestart("retry SLIME interactive evaluation request",
 504                    value <- eval(parse(text=string), envir=globalenv()))
 505   prin1ToString(value)
 506 }
 507
 508 `swank:find-definitions-for-emacs` <- function(slimeConnection, sldbState, string) {
 509   if(exists(string, envir = globalenv())) {
 510     thing <- get(string, envir = globalenv())
 511     if(inherits(thing, "function")) {
 512       body <- body(thing)
 513       srcref <- attr(body, "srcref")
 514       srcfile <- attr(body, "srcfile")
 515       if(is.null(srcfile)) {
 516         list()
 517       } else {
 518         filename <- get("filename", srcfile)
 519         ## KLUDGE: what this means is "is the srcfile filename
 520         ## absolute?"
 521         if(substr(filename, 1, 1) == "/") {
 522           file <- filename
 523         } else {
 524           file <- sprintf("%s/%s", srcfile$wd, filename)
 525         }
 526         list(list(sprintf("function %s", string),
 527                   list(quote(`:location`),
 528                        list(quote(`:file`), file),
 529                        list(quote(`:line`), srcref[[2]][[1]], srcref[[2]][[2]]-1),
 530                        list())))
 531       }
 532     } else {
 533       list()
 534     }
 535   } else {
 536     list()
 537   }
 538 }
 539
 540 `swank:value-for-editing` <- function(slimeConnection, sldbState, string) {
 541   paste(deparse(eval(parse(text=string), envir = globalenv()), control="all"),
 542         collapse="\n", sep="")
 543 }
 544
 545 `swank:commit-edited-value` <- function(slimeConnection, sldbState, string, value) {
 546   eval(parse(text=sprintf("%s <- %s", string, value)), envir = globalenv())
 547   TRUE
 548 }
 549
 550 resetInspector <- function(slimeConnection) {
 551   assign("istate", list(), envir=slimeConnection)
 552   assign("inspectorHistory", NULL, envir=slimeConnection)
 553 }
 554
 555 `swank:init-inspector` <- function(slimeConnection, sldbState, string) {
 556   withRetryRestart("retry SLIME inspection request",
 557                    { resetInspector(slimeConnection)
 558                      value <- inspectObject(slimeConnection, eval(parse(text=string), envir=globalenv()))
 559                    })
 560   value
 561 }
 562
 563 inspectObject <- function(slimeConnection, object) {
 564   previous <- slimeConnection$istate
 565   slimeConnection$istate <- new.env()
 566   slimeConnection$istate$object <- object
 567   slimeConnection$istate$previous <- previous
 568   slimeConnection$istate$content <- emacsInspect(object)
 569   if(!(object %in% slimeConnection$inspectorHistory)) {
 570     slimeConnection$inspectorHistory <- c(slimeConnection$inspectorHistory, object)
 571   }
 572   if(!is.null(slimeConnection$istate$previous)) {
 573     slimeConnection$istate$previous$`next` <- slimeConnection$istate
 574   }
 575   istateToElisp(slimeConnection$istate)
 576 }
 577
 578 valuePart <- function(istate, object, string) {
 579   list(quote(`:value`),
 580        if(is.null(string)) printToString(object) else string,
 581        assignIndexInParts(object, istate))
 582 }
 583
 584 preparePart <- function(istate, part) {
 585   if(is.character(part)) {
 586     list(part)
 587   } else {
 588     switch(as.character(part[[1]]),
 589            `:newline` = list("\n"),
 590            `:value` = valuePart(istate, part[[2]], part[[3]]),
 591            `:line` = list(printToString(part[[2]]), ": ",
 592              valuePart(istate, part[[3]], NULL), "\n"))
 593   }
 594 }
 595
 596 prepareRange <- function(istate, start, end) {
 597   range <- istate$content[start+1:min(end+1, length(istate$content))]
 598   ps <- NULL
 599   for(part in range) {
 600     ps <- c(ps, preparePart(istate, part))
 601   }
 602   list(ps, if(length(ps)<end-start) { start+length(ps) } else { end+1000 },
 603        start, end)
 604 }
 605
 606 assignIndexInParts <- function(object, istate) {
 607   ret <- 1+length(istate$parts)
 608   istate$parts <- c(istate$parts, list(object))
 609   ret
 610 }
 611
 612 istateToElisp <- function(istate) {
 613   list(quote(`:title`), deparse(istate$object, control="all", nlines=1),
 614        quote(`:id`), assignIndexInParts(istate$object, istate),
 615        quote(`:content`), prepareRange(istate, 0, 500))
 616 }
 617
 618 emacsInspect <- function(object) {
 619   UseMethod("emacsInspect")
 620 }
 621
 622 emacsInspect.default <- function(thing) {
 623   c(list(paste("a ", class(thing)[[1]], sep=""), list(quote(`:newline`))))
 624 }
 625
 626 emacsInspect.list <- function(list) {
 627   c(list("a list", list(quote(`:newline`))),
 628     mapply(function(name, value) { list(list(quote(`:line`), name, value)) },
 629            names(list), list))
 630 }
 631
 632 emacsInspect.numeric <- function(numeric) {
 633   c(list("a numeric", list(quote(`:newline`))),
 634     mapply(function(name, value) { list(list(quote(`:line`), name, value)) },
 635            (1:length(numeric)), numeric))
 636 }
 637
 638 `swank:quit-inspector` <- function(slimeConnection, sldbState) {
 639   resetInspector(slimeConnection)
 640   FALSE
 641 }
 642
 643 `swank:inspector-nth-part` <- function(slimeConnection, sldbState, index) {
 644   slimeConnection$istate$parts[[index]]
 645 }
 646
 647 `swank:inspect-nth-part` <- function(slimeConnection, sldbState, index) {
 648   object <- `swank:inspector-nth-part`(slimeConnection, sldbState, index)
 649   inspectObject(slimeConnection, object)
 650 }
 651
 652 `swank:inspector-pop` <- function(slimeConnection, sldbState) {
 653   if(!is.null(slimeConnection$istate$previous)) {
 654     slimeConnection$istate <- slimeConnection$istate$previous
 655     istateToElisp(slimeConnection$istate)
 656   } else {
 657     FALSE
 658   }
 659 }
 660
 661 `swank:inspector-next` <- function(slimeConnection, sldbState) {
 662   if(!is.null(slimeConnection$istate$`next`)) {
 663     slimeConnection$istate <- slimeConnection$istate$`next`
 664     istateToElisp(slimeConnection$istate)
 665   } else {
 666     FALSE
 667   }
 668 }
 669
 670 `swank:inspector-eval` <- function(slimeConnection, sldbState, string) {
 671   expr <- parse(text=string)[[1]]
 672   object <- slimeConnection$istate$object
 673   if(inherits(object, "list")|inherits(object, "environment")) {
 674     substituted <- substituteDirect(expr, object)
 675     eval(substituted, envir=globalenv())
 676   } else {
 677     eval(expr, envir=globalenv())
 678   }
 679 }
 680
 681 `swank:inspect-current-condition` <- function(slimeConnection, sldbState) {
 682   resetInspector(slimeConnection)
 683   inspectObject(slimeConnection, sldbState$condition)
 684 }
 685
 686 `swank:inspect-frame-var` <- function(slimeConnection, sldbState, frame, var) {
 687   resetInspector(slimeConnection)
 688   frame <- sldbState$frames[[1+frame]]
 689   name <- ls(envir=frame)[[1+var]]
 690   object <- get(name, envir=frame)
 691   inspectObject(slimeConnection, object)
 692 }
 693
 694 `swank:default-directory` <- function(slimeConnection, sldbState) {
 695   getwd()
 696 }
 697
 698 `swank:set-default-directory` <- function(slimeConnection, sldbState, directory) {
 699   setwd(directory)
 700   `swank:default-directory`(slimeConnection, sldbState)
 701 }
 702
 703 `swank:load-file` <- function(slimeConnection, sldbState, filename) {
 704   source(filename, local=FALSE, keep.source=TRUE)
 705   TRUE
 706 }
 707
 708 `swank:compile-file-for-emacs` <- function(slimeConnection, sldbState, filename, loadp, ...) {
 709   times <- system.time(parse(filename, srcfile=srcfile(filename)))
 710   if(loadp) {
 711     ## KLUDGE: inelegant, but works.  It might be more in the spirit
 712     ## of things to keep the result of the parse above around to
 713     ## evaluate.
 714     `swank:load-file`(slimeConnection, sldbState, filename)
 715   }
 716   list(quote(`:compilation-result`), list(), TRUE, times[3], substitute(loadp), filename)
 717 }
 718
 719 `swank:quit-lisp` <- function(slimeConnection, sldbState) {
 720   quit()
 721 }