[slime-cvs] CVS update: slime/swank-scheme48/source-location.scm slime/swank-scheme48/completion.scm slime/swank-scheme48/module.scm slime/swank-scheme48/interfaces.scm slime/swank-scheme48/inspector.scm slime/swank-scheme48/load.scm slime/swank-scheme48/packages.scm
Helmut Eller
heller at common-lisp.net
Tue Sep 27 22:13:30 UTC 2005
Update of /project/slime/cvsroot/slime/swank-scheme48
In directory common-lisp.net:/tmp/cvs-serv8853
Modified Files:
module.scm interfaces.scm inspector.scm load.scm packages.scm
Added Files:
source-location.scm completion.scm
Log Message:
* swank-scheme48/source-location.scm: New file. For M-.
* swank-scheme48/module.scm (list-all-package): New function.
* swank-scheme48/interfaces.scm (module-control-interface): Export it.
* swank-scheme48/inspector.scm: Add methods for records and and
hashtables.
(swank:arglist-for-echo-area): Implement it. Only works for
functions with enough debug-data (ie. only user-defined functions).
* swank-scheme48/completion.scm: New file.
(swank:simple-completions, swank:apropos-list-for-emacs): Implemented.
* swank-scheme48/load.scm, swank-scheme48/defrectypeX.scm: Renamed the
file from defrectype*.scm
* swank-scheme48/packages.scm (swank-general-rpc): Don't use
posix-process because it doesn't work on Windows, and we don't need it
for a mulithreaded server.
Date: Wed Sep 28 00:13:28 2005
Author: heller
Index: slime/swank-scheme48/module.scm
diff -u slime/swank-scheme48/module.scm:1.1 slime/swank-scheme48/module.scm:1.2
--- slime/swank-scheme48/module.scm:1.1 Sun Sep 18 23:10:21 2005
+++ slime/swank-scheme48/module.scm Wed Sep 28 00:13:28 2005
@@ -140,3 +140,14 @@
(warn "can't undefine inherited binding"))
(else
(warn "can't undefine nonexistent binding")))))
+
+
+
+;;; Heap groveling
+
+;; Return a list of all known packages.
+(define (list-all-packages)
+ (vector->list (find-all-records :package)))
+
+;; The package record-type. Only needed for find-all-records.
+(define :package (record-type (interaction-environment)))
Index: slime/swank-scheme48/interfaces.scm
diff -u slime/swank-scheme48/interfaces.scm:1.1 slime/swank-scheme48/interfaces.scm:1.2
--- slime/swank-scheme48/interfaces.scm:1.1 Sun Sep 18 23:10:21 2005
+++ slime/swank-scheme48/interfaces.scm Wed Sep 28 00:13:28 2005
@@ -56,7 +56,7 @@
current-swank-session
current-swank-world
- current-swank-return-tag
+ current-swank-return-tag
push-swank-level
pop-swank-level
@@ -173,10 +173,13 @@
swank:inspector-next
swank:quit-inspector
swank:describe-inspectee
+ swank:inspector-reinspect
+
+ swank:arglist-for-echo-area
))
(define-interface swank-arglist-rpc-interface
- (export swank:arglist-for-echo-area
+ (export ;;swank:arglist-for-echo-area
swank:variable-desc-for-echo-area
swank:arglist-for-insertion
swank:complete-form
@@ -188,6 +191,8 @@
swank:fuzzy-completions
swank:fuzzy-completion-selected
swank:list-all-package-names
+
+ swank:apropos-list-for-emacs
))
(define-interface swank-definition-finding-rpc-interface
@@ -207,6 +212,7 @@
fold-config-structures
config-structure-names
config-package-names
+ list-all-packages
maybe-environment-ref
maybe-structure-ref
package-reflective-tower
Index: slime/swank-scheme48/inspector.scm
diff -u slime/swank-scheme48/inspector.scm:1.1 slime/swank-scheme48/inspector.scm:1.2
--- slime/swank-scheme48/inspector.scm:1.1 Sun Sep 18 23:10:21 2005
+++ slime/swank-scheme48/inspector.scm Wed Sep 28 00:13:28 2005
@@ -90,6 +90,9 @@
(set-current-inspector! #f)
'nil)
+(define (swank:inspector-reinspect)
+ (reinspect-object))
+
(define (inspect-object obj)
(set-current-inspector! (make-inspector obj))
(reinspect-object))
@@ -118,7 +121,7 @@
(process-inspector-listing listing)
(set-current-inspector-parts! parts)
`(:TITLE ,title
- :TYPE ,(string-upcase (symbol->string type))
+ :TYPE ,(symbol->string type)
:CONTENT ,contents))))
(define (process-inspector-listing listing)
@@ -202,7 +205,10 @@
(define-method &inspect-object ((loc :location))
(values "A location (top-level variable cell)."
'location
- `("Contents: " (,(contents loc)))))
+ `("Contents: " (,(contents loc)) #\newline
+ "id: " (,(location-id loc)) #\newline
+ "assigned?: " (,(location-assigned? loc)) #\newline
+ "defined?: " (,(location-defined? loc)) #\newline)))
(define-method &inspect-object ((cell :cell))
(values "A cell."
@@ -216,6 +222,60 @@
'weak-pointer
`("Ref: " (,(weak-pointer-ref weak)))))
+(define-method &inspect-object ((r :record))
+ (let ((type (record-type r))
+ (len (record-length r)))
+ (values "A record."
+ (record-type-name type)
+ `(,@(let loop ((i 1)
+ (ns (record-type-field-names type)))
+ (cond ((= i len) '())
+ (else
+ `(,(symbol->string (car ns))
+ ": "
+ (,(record-ref r i)) #\newline
+ ,@(loop (+ i 1) (cdr ns))))))
+ ;;#\newline type (,type) #\newline
+ ))))
+
+(define-simple-type :table (:record) table?)
+
+(define-method &inspect-object ((t :table))
+ (values "A table."
+ (record-type-name (record-type t))
+ `("size: " ,(number->string (table-size t)) #\newline #\newline
+ ,@(let ((result '()))
+ (table-walk
+ (lambda (key value)
+ (set! result (append `((,key) ": " (,value) #\newline)
+ result)))
+ t)
+ result))))
+
+(define-method &inspect-object ((p :closure))
+ (values "A closure."
+ 'closure
+ `("env: " (,(closure-env p)) #\newline
+ "template: " (,(closure-template p)) #\newline)))
+
+(define-method &inspect-object ((t :template))
+ (values "A template (compiled code)." 'template
+ `("code: " (,(template-code t)) #\newline
+ "byte-code: " (,(template-byte-code t)) #\newline
+ "info: " (,(template-info t)) #\newline
+ "package-id: " (,(template-package-id t)) #\newline
+ ,@(build-indexed-inspector-listing
+ t template-ref template-length (lambda (t i) #f))
+ #\newline #\newline
+ "disassembly:" #\newline #\newline ,(disassemble-to-string t)
+ )))
+
+(define (disassemble-to-string template)
+ (call-with-string-output-port
+ (lambda (port)
+ (call-with-current-output-port
+ port (lambda () (disassemble template))))))
+
;;; Numbers
@@ -264,27 +324,33 @@
unassigned?)
(define-method &inspect-object ((obj :type))
(values title type-id
- (let ((len (length obj)))
- `("Length: " (,len) ,newline
- "Contents:" ,newline
- ,@(reduce ((count* i 0 len))
- ((items '()))
- (append-reverse `(,newline ,i
- ,(if (unassigned? obj i)
- "{unassigned}"
- (list (ref obj i))))
- items)
+ (build-indexed-inspector-listing obj ref length unassigned?))))
- (reverse items)))))))
+(define (build-indexed-inspector-listing object ref length unassigned?)
+ (let ((len (length object)))
+ `("Length: " (,len) ,newline
+ "Contents:" ,newline
+ ,@(reduce ((count* i 0 len))
+ ((items '()))
+ (append-reverse `(,newline ,i
+ ,(if (unassigned? object i)
+ "{unassigned}"
+ (list (ref object i))))
+ items)
+ (reverse items)))))
(define-indexed-inspector :vector "A vector." 'vector
vector-ref vector-length
vector-unassigned?) ; may be the case in environments
-(define-indexed-inspector :template "A template (compiled code)."
- 'template
- template-ref template-length
- (lambda (t i) #f))
+(define-simple-type :byte-vector (:value) byte-vector?)
+(define-simple-type :code-vector (:value) code-vector?)
+
+(define-indexed-inspector :code-vector "A code-vector." 'code-vector
+ code-vector-ref code-vector-length (lambda (v i) #f))
+
+(define-indexed-inspector :byte-vector "A byte-vector." 'byte-vector
+ byte-vector-ref byte-vector-length (lambda (v i) #f))
@@ -301,7 +367,7 @@
'proper-list
`("Length: " (1) ,newline
"Contents:" ,newline
- 0 ,(car pair) ,newline)))
+ 0 (,(car pair)) ,newline)))
((pair? (cdr pair))
(inspect-list pair))
(else
@@ -393,7 +459,34 @@
;;; General compound data
+;;;
+
+(define (swank:arglist-for-echo-area names)
+ (let* ((name (car names))
+ (value (ignore-errors (lambda ()
+ (eval (read-from-string name)
+ (interaction-environment))))))
+ (or (and (procedure? value)
+ (let ((arglist (procedure-arglist value)))
+ (and arglist
+ (format-arglist name arglist))))
+ 'nil)))
+
+(define (format-arglist op args)
+ (if (null? args)
+ (string-append "(" op ")")
+ (string-append "(" op " " (mapconcat symbol->string args " ") ")")))
+
+(define (procedure-arglist procedure)
+ (let ((debug-data (get-debug-data
+ (template-info
+ (closure-template procedure)))))
+ (and debug-data
+ (let ((env-maps (debug-data-env-maps debug-data)))
+ (and (pair? env-maps)
+ (vector->list (vector-ref (car env-maps) 3)))))))
+
;;; Random utilities & parameters
(define (inspector-depth) 4)
@@ -411,3 +504,12 @@
(do ((i 0 (+ i 1)))
((= i len) result)
(string-set! result i (char-upcase (string-ref string i))))))
+
+(define (mapconcat fun list separator)
+ (let ((strings (map fun list)))
+ (cond ((null? strings) "")
+ (else
+ (apply string-append
+ (cons (car strings)
+ (map (lambda (string) (string-append separator string))
+ (cdr strings))))))))
Index: slime/swank-scheme48/load.scm
diff -u slime/swank-scheme48/load.scm:1.2 slime/swank-scheme48/load.scm:1.3
--- slime/swank-scheme48/load.scm:1.2 Wed Sep 21 13:45:12 2005
+++ slime/swank-scheme48/load.scm Wed Sep 28 00:13:28 2005
@@ -6,7 +6,7 @@
;;; This code is written by Taylor Campbell and placed in the Public
;;; Domain. All warranties are disclaimed.
-(config '(load "=slime48/defrectype*.scm"
+(config '(load "=slime48/defrectypeX.scm"
"=slime48/interfaces.scm"
"=slime48/packages.scm"))
Index: slime/swank-scheme48/packages.scm
diff -u slime/swank-scheme48/packages.scm:1.1 slime/swank-scheme48/packages.scm:1.2
--- slime/swank-scheme48/packages.scm:1.1 Sun Sep 18 23:10:21 2005
+++ slime/swank-scheme48/packages.scm Wed Sep 28 00:13:28 2005
@@ -106,7 +106,9 @@
(open scheme formats i/o)
;++ cheesy temporary implementation
(begin (define (swank-log fmt . args)
- (format (current-noise-port) "~&[Swank: ~?]~%" fmt args))))
+ ;;(format (current-noise-port) "~&[Swank: ~?]~%" fmt args)
+ #t
+ )))
@@ -117,13 +119,14 @@
(open scheme
(subset posix-files (working-directory
set-working-directory!))
- (subset posix-process-data (get-process-id))
- (subset posix-processes (process-id->integer))
+ ;; doesn't work on Windows
+ ;;(subset posix-process-data (get-process-id))
+ ;;(subset posix-processes (process-id->integer))
swank-sessions
)
(optimize auto-integrate)
(begin (define (swank:connection-info)
- (list (process-id->integer (get-process-id))
+ (list 49 ;;(process-id->integer (get-process-id))
"Scheme48" ; Lisp implementation type
"scheme48" ; symbolic name for the above
'() ; empty features list
@@ -214,7 +217,9 @@
receiving
destructuring
string-i/o
+ (subset i/o-internal (call-with-current-output-port))
simple-signals
+ handle
xvectors
methods
reduce ; looping macros
@@ -228,6 +233,14 @@
weak
cells
templates
+ records
+ record-types
+ tables
+ closures
+ debug-data
+ (subset disassembler (disassemble))
+ byte-vectors
+ code-vectors
)
(optimize auto-integrate)
(files inspector))
@@ -252,33 +265,39 @@
(define-structure swank-completion-rpc swank-completion-rpc-interface
(open scheme
+ big-scheme
string-i/o
+ module-control
swank-sessions
swank-worlds
- )
+ packages
+ packages-internal
+ bindings
+ locations
+ names)
(optimize auto-integrate)
- (begin (define (swank:completions prefix package)
- (list '() prefix))
- (define (swank:simple-completions prefix package)
- (list '() prefix))
- (define (swank:fuzzy-completions prefix package)
- '())
- (define (swank:fuzzy-completion-selected orig completion)
- '())
- (define (swank:list-all-package-names include-nicknames?)
- (map write-to-string
- (swank-world-package-names (current-swank-world))))
- ))
+ (files completion))
-(define-structure swank-definition-finding-rpc
- swank-definition-finding-rpc-interface
- (open scheme)
+(define-structure swank-definition-finding-rpc
+ swank-definition-finding-rpc-interface
+ (open scheme
+ big-scheme
+ handle
+ string-i/o
+ module-control
+ swank-sessions
+ swank-worlds
+ packages
+ packages-internal
+ bindings
+ locations
+ names
+ filenames
+ templates
+ closures
+ debug-data)
(optimize auto-integrate)
- (begin (define (swank:find-definitions-for-emacs name)
- '())
- (define (swank:buffer-first-change filename)
- '())
- ))
+ (files source-location))
;;; This macro should go somewhere else.
@@ -323,7 +342,8 @@
(subset meta-types (syntax-type))
(subset names (name?))
package-loader
- )
+ (subset primitives (find-all-records))
+ (subset record (record-type)))
(optimize auto-integrate)
(files module))
More information about the slime-cvs
mailing list