swank.R 24.8 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
### 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>.

16
17
18
19
20
21
### 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() 

22
23
24
25
26
swank <- function(port=4005) {
  acceptConnections(port, FALSE)
}

startSwank <- function(portFile) {
27
  acceptConnections(4005, portFile)
28
29
30
}

acceptConnections <- function(port, portFile) {
31
32
33
34
35
  if(portFile != FALSE) {
    f <- file(portFile, open="w+")
    cat(port, file=f)
    close(f)
  }
36
  ## FIXME: maybe we should support dontClose here?
37
38
  s <- socketConnection(host="localhost", server=TRUE, port=port, open="r+b")
  on.exit(close(s))
39
  tryCatch(serve(s), endOfFile=function(c) NULL)
40
41
42
43
44
45
46
}

serve <- function(io) {
  mainLoop(io)
}

mainLoop <- function(io) {
47
48
  slimeConnection <- new.env()
  slimeConnection$io <- io
Christophe Rhodes's avatar
Christophe Rhodes committed
49
  while(TRUE) {
50
    withRestarts(tryCatch(dispatch(slimeConnection, readPacket(io)),
51
52
                          swankTopLevel=function(c) NULL),
                 abort="return to SLIME's toplevel")
53
  }
Christophe Rhodes's avatar
Christophe Rhodes committed
54
55
}

56
dispatch <- function(slimeConnection, event, sldbState=NULL) {
Christophe Rhodes's avatar
Christophe Rhodes committed
57
58
  kind <- event[[1]]
  if(kind == quote(`:emacs-rex`)) {
59
    do.call("emacsRex", c(list(slimeConnection), list(sldbState), event[-1]))
60
  }
Christophe Rhodes's avatar
Christophe Rhodes committed
61
62
}

63
64
sendToEmacs <- function(slimeConnection, obj) {
  io <- slimeConnection$io
Christophe Rhodes's avatar
Christophe Rhodes committed
65
  payload <- writeSexpToString(obj)
66
  writeChar(sprintf("%06x", nchar(payload, type="bytes")), io, eos=NULL)
Christophe Rhodes's avatar
Christophe Rhodes committed
67
68
69
70
  writeChar(payload, io, eos=NULL)
  flush(io)
}

71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
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
  }
}

90
emacsRex <- function(slimeConnection, sldbState, form, pkg, thread, id, level=0) {
Christophe Rhodes's avatar
Christophe Rhodes committed
91
92
  ok <- FALSE
  value <- NULL
93
94
  conn <- textConnection(NULL, open="w")
  condition <- NULL
Christophe Rhodes's avatar
Christophe Rhodes committed
95
96
  tryCatch({
    withCallingHandlers({
97
      call <- callify(form)
98
99
100
101
102
103
104
      capture.output(value <- eval(call), file=conn)
      string <- paste(textConnectionValue(conn), sep="", collapse="\n")
      if(nchar(string) > 0) {
        sendToEmacs(slimeConnection, list(quote(`:write-string`), string))
        sendToEmacs(slimeConnection, list(quote(`:write-string`), "\n"))
      }
      close(conn)
Christophe Rhodes's avatar
Christophe Rhodes committed
105
106
      ok <- TRUE
    }, error=function(c) {
107
108
109
110
111
112
113
      condition <<- c
      string <- paste(textConnectionValue(conn), sep="", collapse="\n")
      if(nchar(string) > 0) {
        sendToEmacs(slimeConnection, list(quote(`:write-string`), string))
        sendToEmacs(slimeConnection, list(quote(`:write-string`), "\n"))
      }
      close(conn)
Christophe Rhodes's avatar
Christophe Rhodes committed
114
      newSldbState <- makeSldbState(c, if(is.null(sldbState)) 0 else sldbState$level+1, id)
115
      withRestarts(sldbLoop(slimeConnection, newSldbState, id), abort=paste("return to sldb level", newSldbState$level)) })},
116
    finally=sendToEmacs(slimeConnection, list(quote(`:return`), if(ok) list(quote(`:ok`), value) else list(quote(`:abort`), as.character(condition)), id)))
Christophe Rhodes's avatar
Christophe Rhodes committed
117
118
119
}

makeSldbState <- function(condition, level, id) {
120
121
  calls <- rev(sys.calls())[-1]
  frames <- rev(sys.frames())[-1]
122
123
  restarts <- rev(computeRestarts(condition))[-1]
  ret <- list(condition=condition, level=level, id=id, restarts=restarts, calls=calls, frames=frames)
Christophe Rhodes's avatar
Christophe Rhodes committed
124
125
126
127
  class(ret) <- c("sldbState", class(ret))
  ret
}

128
sldbLoop <- function(slimeConnection, sldbState, id) {
129
  tryCatch({
130
131
132
    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))
133
    while(TRUE) {
134
      dispatch(slimeConnection, readPacket(io), sldbState)
135
    }
136
  }, finally=sendToEmacs(slimeConnection, c(list(quote(`:debug-return`), id, sldbState$level, FALSE))))
137
138
139
}

readPacket <- function(io) {
140
  socketSelect(list(io))
141
142
143
144
145
146
147
148
  header <- readChunk(io, 6)
  len <- strtoi(header, base=16)
  payload <- readChunk(io, len)
  readSexpFromString(payload)
}

readChunk <- function(io, len) {
  buffer <- readChar(io, len)
149
150
151
152
153
  if(length(buffer) == 0) {
    condition <- simpleCondition("End of file on io")
    class(condition) <- c("endOfFile", class(condition))
    signalCondition(condition)
  }
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
  if(nchar(buffer) != len) {
    stop("short read in readChunk")
  }
  buffer
}

readSexpFromString <- function(string) {
  pos <- 1
  read <- function() {
    skipWhitespace()
    char <- substr(string, pos, pos)
    switch(char,
           "("=readList(),
           "\""=readString(),
           "'"=readQuote(),
           {
             if(pos > nchar(string))
               stop("EOF during read")
             obj <- readNumberOrSymbol()
             if(obj == quote(`.`)) {
               stop("Consing dot not implemented")
             }
             obj
           })
  }
  skipWhitespace <- function() {
    while(substr(string, pos, pos) %in% c(" ", "\t", "\n")) {
      pos <<- pos + 1
    }
  }
  readList <- function() {
    ret <- list()
    pos <<- pos + 1
    while(TRUE) {
      skipWhitespace()
      char <- substr(string, pos, pos)
      if(char == ")") {
        pos <<- pos + 1
        break
      } else {
        obj <- read()
        if(length(obj) == 1 && obj == quote(`.`)) {
          stop("Consing dot not implemented")
        }
        ret <- c(ret, list(obj))
      }
    }
    ret
  }
  readString <- function() {
    ret <- ""
    addChar <- function(c) { ret <<- paste(ret, c, sep="") }
    while(TRUE) {
      pos <<- pos + 1
      char <- substr(string, pos, pos)
      switch(char,
             "\""={ pos <<- pos + 1; break },
             "\\"={ pos <<- pos + 1
                    char2 <- substr(string, pos, pos)
                    switch(char2,
                           "\""=addChar(char2),
                           "\\"=addChar(char2),
                           stop("Unrecognized escape character")) },
             addChar(char))
    }
    ret
  }
  readNumberOrSymbol <- function() {
    token <- readToken()
    if(nchar(token)==0) {
      stop("End of file reading token")
    } else if(grepl("^[0-9]+$", token)) {
      strtoi(token)
    } else if(grepl("^[0-9]+\\.[0-9]+$", token)) {
      as.double(token)
    } else {
230
231
232
233
234
235
236
237
      name <- as.name(token)
      if(name == quote(t)) {
        TRUE
      } else if(name == quote(nil)) {
        FALSE
      } else {
        name
      }
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
    }
  }
  readToken <- function() {
    token <- ""
    while(TRUE) {
      char <- substr(string, pos, pos)
      if(char == "") {
        break;
      } else if(char %in% c(" ", "\n", "\t", "(", ")", "\"", "'")) {
        break;
      } else {
        token <- paste(token, char, sep="")
        pos <<- pos + 1
      }
    }
    token
  }
  read()
}

writeSexpToString <- function(obj) {
  writeSexpToStringLoop <- function(obj) {
    switch(typeof(obj),
           "character"={ string <- paste(string, "\"", gsub("([\"\\])", "\\\\\\1", obj), "\"", sep="") },
           "list"={ string <- paste(string, "(", sep="")
                    max <- length(obj)
                    if(max > 0) {
                      for(i in 1:max) {
                        string <- paste(string, writeSexpToString(obj[[i]]), sep="")
                        if(i != max) {
                          string <- paste(string, " ", sep="")
                        }
                      }
                    }
                    string <- paste(string, ")", sep="") },
           "symbol"={ string <- paste(string, as.character(obj), sep="") },
Christophe Rhodes's avatar
Christophe Rhodes committed
274
           "logical"={ string <- if(obj) { paste(string, "t", sep="") } else { paste(string, "nil", sep="") }},
275
276
277
278
279
280
281
282
283
           "double"={ string <- paste(string, as.character(obj), sep="") },
           "integer"={ string <- paste(string, as.character(obj), sep="") },
           stop(paste("can't write object ", obj, sep="")))
    string
  }
  string <- ""
  writeSexpToStringLoop(obj)
}

284
285
286
prin1ToString <- function(val) {
  paste(deparse(val, backtick=TRUE, control=c("delayPromises", "keepNA")),
        sep="", collapse="\n")
287
288
}

289
printToString <- function(val) {
290
  paste(capture.output(print(val)), sep="", collapse="\n")
291
292
}

293
`swank:connection-info` <- function (slimeConnection, sldbState) {
294
295
  list(quote(`:pid`), Sys.getpid(),
       quote(`:package`), list(quote(`:name`), "R", quote(`:prompt`), "R> "),
296
       quote(`:version`), "2012-04-23",
297
       quote(`:encoding`), list(quote(`:coding-systems`), list("utf-8-unix")),
298
299
300
301
302
       quote(`:lisp-implementation`), list(quote(`:type`), "R",
                                           quote(`:name`), "R",
                                           quote(`:version`), paste(R.version$major, R.version$minor, sep=".")))
}

303
`swank:swank-require` <- function (slimeConnection, sldbState, contribs) {
304
  for(contrib in contribs) {
305
    filename <- sprintf("%s/%s.R", swankrPath, as.character(contrib))
306
    if(file.exists(filename)) {
307
      source(filename)
308
309
    }
  }
310
311
312
  list()
}

313
`swank:create-repl` <- function(slimeConnection, sldbState, env, ...) {
314
315
316
  list("R", "R")
}

317
makeReplResult <- function(value) {
318
  string <- printToString(value)
319
  list(quote(`:write-string`), string,
320
321
322
323
324
325
326
327
       quote(`:repl-result`))
}

makeReplResultFunction <- makeReplResult

sendReplResult <- function(slimeConnection, value) {
  result <- makeReplResultFunction(value)
  sendToEmacs(slimeConnection, result)
328
329
330
331
}

sendReplResultFunction <- sendReplResult

332
`swank:listener-eval` <- function(slimeConnection, sldbState, string) {
333
  ## O how ugly
334
  string <- gsub("#\\.\\(swank:lookup-presented-object-or-lose([^)]*)\\)", ".(`swank:lookup-presented-object-or-lose`(slimeConnection, sldbState,\\1))", string)
335
336
337
338
339
340
341
342
  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)
    }
343
  }
344
  list()
345
346
}

347
`swank:autodoc` <- function(slimeConnection, sldbState, rawForm, ...) {
348
349
  "No Arglist Information"
}
350

351
`swank:operator-arglist` <- function(slimeConnection, sldbState, op, package) {
352
353
354
355
356
357
358
359
360
361
  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()
  }
362
363
}

364
`swank:throw-to-toplevel` <- function(slimeConnection, sldbState) {
Christophe Rhodes's avatar
Christophe Rhodes committed
365
  condition <- simpleCondition("Throw to toplevel")
366
367
368
  class(condition) <- c("swankTopLevel", class(condition))
  signalCondition(condition)
}
Christophe Rhodes's avatar
Christophe Rhodes committed
369

370
`swank:backtrace` <- function(slimeConnection, sldbState, from=0, to=NULL) {
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
  calls <- sldbState$calls
  if(is.null(to)) to <- length(calls)
  from <- from+1
  calls <- lapply(calls[from:to],
                  { frameNumber <- from-1;
                    function (x) {
                      ret <- list(frameNumber, paste(format(x), sep="", collapse=" "))
                      frameNumber <<- 1+frameNumber
                      ret
                    }
                  })
}

computeRestartsForEmacs <- function (sldbState) {
  lapply(sldbState$restarts,
         function(x) {
           ## this is all a little bit internalsy
           restartName <- x[[1]][[1]]
           description <- restartDescription(x)
           list(restartName, if(is.null(description)) restartName else description)
         })
}

394
`swank:debugger-info-for-emacs` <- function(slimeConnection, sldbState, from=0, to=NULL) {
395
396
  list(list(as.character(sldbState$condition), sprintf("  [%s]", class(sldbState$condition)[[1]]), FALSE),
       computeRestartsForEmacs(sldbState),
397
       `swank:backtrace`(slimeConnection, sldbState, from, to),
398
       list(sldbState$id))
Christophe Rhodes's avatar
Christophe Rhodes committed
399
}
400

401
`swank:invoke-nth-restart-for-emacs` <- function(slimeConnection, sldbState, level, n) {
402
  if(sldbState$level == level) {
403
    invokeRestart(sldbState$restarts[[n+1]])
404
405
  }
}
406

407
`swank:frame-source-location` <- function(slimeConnection, sldbState, n) {
408
409
410
411
412
413
  call <- sldbState$calls[[n+1]]
  srcref <- attr(call, "srcref")
  srcfile <- attr(srcref, "srcfile")
  if(is.null(srcfile)) {
    list(quote(`:error`), "no srcfile")
  } else {
414
415
416
417
418
419
420
421
    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)
    }
422
    list(quote(`:location`),
423
         list(quote(`:file`), file),
424
425
426
427
428
         list(quote(`:line`), srcref[[1]], srcref[[2]]-1),
         FALSE)
  }
}

429
`swank:buffer-first-change` <- function(slimeConnection, sldbState, filename) {
430
431
  FALSE
}
432

433
434
435
436
437
438
439
`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)
}

440
`swank:frame-locals-and-catch-tags` <- function(slimeConnection, sldbState, index) {
441
442
  frame <- sldbState$frames[[1+index]]
  objs <- ls(envir=frame)
443
444
445
  if(identical(frame, globalenv())) {
    objs <- c()
  }
446
447
  list(lapply(objs, function(name) { list(quote(`:name`), name,
                                          quote(`:id`), 0,
448
449
450
451
452
453
                                          quote(`:value`),
                                          tryCatch({
                                            printToString(eval(parse(text=name), envir=frame))
                                          }, error=function(c) {
                                            sprintf("error printing object")
                                          }))}),
454
455
       list())
}
456

457
`swank:simple-completions` <- function(slimeConnection, sldbState, prefix, package) {
458
459
460
461
462
  literal2rx <- function(string) {
    ## list of ERE metacharacters from ?regexp
    gsub("([.\\|()[{^$*+?])", "\\\\\\1", string)
  }
  matches <- apropos(sprintf("^%s", literal2rx(prefix)), ignore.case=FALSE)
463
464
465
466
467
  nmatches <- length(matches)
  if(nmatches == 0) {
    list(list(), "")
  } else {
    longest <- matches[order(nchar(matches))][1]
468
    while(length(grep(sprintf("^%s", literal2rx(longest)), matches)) < nmatches) {
469
470
471
472
473
      longest <- substr(longest, 1, nchar(longest)-1)
    }
    list(as.list(matches), longest)
  }
}
474

475
`swank:compile-string-for-emacs` <- function(slimeConnection, sldbState, string, buffer, position, filename, policy) {
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
  lineOffset <- charOffset <- colOffset <- NULL
  for(pos in position) {
    switch(as.character(pos[[1]]),
           `:position` = {charOffset <- pos[[2]]},
           `:line` = {lineOffset <- pos[[2]]; colOffset <- pos[[3]]},
           warning("unknown content in pos", pos))
  }
  frob <- function(refs) {
    lapply(refs,
           function(x)
           srcref(attr(x,"srcfile"),
                  c(x[1]+lineOffset-1, ifelse(x[1]==1, x[2]+colOffset-1, x[2]),
                    x[3]+lineOffset-1, ifelse(x[3]==1, x[4]+colOffset-1, x[4]),
                    ifelse(x[1]==1, x[5]+colOffset-1, x[5]),
                    ifelse(x[3]==1, x[6]+colOffset-1, x[6]))))
  }
  transformSrcrefs <- function(s) {
    srcrefs <- attr(s, "srcref")
    attribs <- attributes(s)
    new <- 
      switch(mode(s),
             "call"=as.call(lapply(s, transformSrcrefs)),
             "expression"=as.expression(lapply(s, transformSrcrefs)),
             s)
    attributes(new) <- attribs
    if(!is.null(attr(s, "srcref"))) {
      attr(new, "srcref") <- frob(srcrefs)
    }
    new
  }
  withRestarts({
    times <- system.time({
      exprs <- parse(text=string, srcfile=srcfile(filename))
      eval(transformSrcrefs(exprs), envir = globalenv()) })},
510
               abort="abort compilation")
511
  list(quote(`:compilation-result`), list(), TRUE, times[3], FALSE, FALSE)
512
}
513

Christophe Rhodes's avatar
Christophe Rhodes committed
514
515
withRetryRestart <- function(description, expr) {
  call <- substitute(expr)
516
517
518
  retry <- TRUE
  while(retry) {
    retry <- FALSE
Christophe Rhodes's avatar
Christophe Rhodes committed
519
520
521
    withRestarts(eval.parent(call),
                 retry=list(description=description,
                   handler=function() retry <<- TRUE))
522
  }
Christophe Rhodes's avatar
Christophe Rhodes committed
523
524
525
526
}

`swank:interactive-eval` <-  function(slimeConnection, sldbState, string) {
  withRetryRestart("retry SLIME interactive evaluation request",
527
528
529
530
531
532
                   tmp <- withVisible(eval(parse(text=string), envir=globalenv())))
  if(tmp$visible) {
    prin1ToString(tmp$value)
  } else {
    "# invisible value"
  }
533
534
}

535
`swank:eval-and-grab-output` <- function(slimeConnection, sldbState, string) {
Christophe Rhodes's avatar
Christophe Rhodes committed
536
537
  withRetryRestart("retry SLIME interactive evaluation request",
                   { output <-
538
539
                       capture.output(tmp <- withVisible(eval(parse(text=string),
                                                              envir=globalenv()))) })
540
  output <- paste(output, sep="", collapse="\n")
541
  if(tmp$visible) {
542
    list(output, prin1ToString(tmp$value))
543
544
545
  } else {
    list(output, "# invisible value")
  }
546
}
547

548
549
`swank:interactive-eval-region` <- function(slimeConnection, sldbState, string) {
  withRetryRestart("retry SLIME interactive evaluation request",
550
551
                   tmp <- withVisible(eval(parse(text=string), envir=globalenv())))
  if(tmp$visible) {
552
    prin1ToString(tmp$value)
553
554
555
  } else {
    "# invisible value"
  }
556
557
}

558
559
560
561
562
563
564
565
566
567
568
`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)
569
570
571
572
573
574
575
        ## 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)
        }
576
577
        list(list(sprintf("function %s", string),
                  list(quote(`:location`),
578
                       list(quote(`:file`), file),
579
580
581
582
583
584
585
586
587
588
                       list(quote(`:line`), srcref[[2]][[1]], srcref[[2]][[2]]-1),
                       list())))
      }
    } else {
      list()
    }
  } else {
    list()
  }
}
589
590
591
592
593
594
595
596
597
598

`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
}
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613

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) {
Christophe Rhodes's avatar
Christophe Rhodes committed
614
615
616
617
618
619
620
  vectorify <- function(x) {
    if(is.vector(x)) {
      x
    } else {
      list(x)
    }
  }
621
622
623
624
  previous <- slimeConnection$istate
  slimeConnection$istate <- new.env()
  slimeConnection$istate$object <- object
  slimeConnection$istate$previous <- previous
625
  slimeConnection$istate$content <- emacsInspect(object)
Christophe Rhodes's avatar
Christophe Rhodes committed
626
  if(!(vectorify(object) %in% slimeConnection$inspectorHistory)) {
627
628
629
630
631
632
633
634
635
636
    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`),
637
       if(is.null(string)) printToString(object) else string,
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
       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)
665
  istate$parts <- c(istate$parts, list(object))
666
667
668
669
670
671
672
673
674
675
676
677
678
  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")
}

679
680
681
682
emacsInspect.default <- function(thing) {
  c(list(paste("a ", class(thing)[[1]], sep=""), list(quote(`:newline`))))
}

683
684
685
686
687
688
emacsInspect.list <- function(list) {
  c(list("a list", list(quote(`:newline`))),
    mapply(function(name, value) { list(list(quote(`:line`), name, value)) },
           names(list), list))
}

689
690
691
692
693
694
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))
}

695
696
697
698
`swank:quit-inspector` <- function(slimeConnection, sldbState) {
  resetInspector(slimeConnection)
  FALSE
}
699
700
701
702
703
704
705
706
707

`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)
}
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725

`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
  }
}
726
727
728
729
730
731
732
733
734
735
736

`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())
  }
}
737
738
739
740
741
742
743
744
745
746
747
748
749

`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)
}
750
751
752
753
754
755
756
757
758

`swank:default-directory` <- function(slimeConnection, sldbState) {
  getwd()
}

`swank:set-default-directory` <- function(slimeConnection, sldbState, directory) {
  setwd(directory)
  `swank:default-directory`(slimeConnection, sldbState)
}
759
760

`swank:load-file` <- function(slimeConnection, sldbState, filename) {
761
  source(filename, local=FALSE, keep.source=TRUE)
762
763
764
765
  TRUE
}

`swank:compile-file-for-emacs` <- function(slimeConnection, sldbState, filename, loadp, ...) {
766
767
768
769
770
771
772
  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)
  }
773
  list(quote(`:compilation-result`), list(), TRUE, times[3], substitute(loadp), filename)
774
}
Christophe Rhodes's avatar
Christophe Rhodes committed
775
776
777
778

`swank:quit-lisp` <- function(slimeConnection, sldbState) {
  quit()
}