[slime-cvs] CVS slime/contrib

[CVS User heller]

Update of /project/slime/cvsroot/slime/contrib
In directory cl-net:/tmp/cvs-serv6068/contrib

Modified Files:
	ChangeLog swank-kawa.scm 
Log Message:
* swank-kawa.scm (operator-arglist): Implemented, at least for
some kind of function.

--- /project/slime/cvsroot/slime/contrib/ChangeLog	2009/07/15 19:37:25	1.226
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2009/07/21 11:02:36	1.227
@@ -3,6 +3,11 @@
 	* swank-sbcl-exts.lisp (compute-enriched-decoded-arglist): Filter
 	uninteresting arguments for SB-ASSEM:INST.
 
+2009-07-19  Helmut Eller  <heller at common-lisp.net>
+
+	* swank-kawa.scm (operator-arglist): Implemented, at least for
+	some kind of function.
+
 2009-07-12  Helmut Eller  <heller at common-lisp.net>
 
 	* swank-kawa.scm (swank-writer): Use set! for now, as the svn
--- /project/slime/cvsroot/slime/contrib/swank-kawa.scm	2009/07/12 08:01:15	1.16
+++ /project/slime/cvsroot/slime/contrib/swank-kawa.scm	2009/07/21 11:02:36	1.17
@@ -192,8 +192,8 @@
            (result #!null))
        (if (instance? tmp <pair>)
            (let ((tmp :: <pair> tmp))
-             (mif (p tmp:car)
-                (mif (ps tmp:cdr)
+             (mif (p (@ car tmp))
+                (mif (ps (@ cdr tmp))
                      (set! result then)
                      (set! fail? -1))
                 (set! fail? -1)))
@@ -205,8 +205,8 @@
            (tmp value))
        (if (instance? tmp <pair>)
            (let ((tmp :: <pair> tmp))
-             (mif (p tmp:car)
-                  (mif (ps tmp:cdr)
+             (mif (p (@ car tmp))
+                  (mif (ps (@ cdr tmp))
                        then
                        (fail))
                   (fail)))
@@ -774,10 +774,38 @@
 
 ;;;; Dummy defs
 
-(defslimefun operator-arglist (#!rest y) '())
+
 (defslimefun buffer-first-change (#!rest y) '())
 (defslimefun swank-require (#!rest y) '())
 
+;;;; arglist
+
+(defslimefun operator-arglist (env name #!rest _)
+  (mcase (try-catch `(ok ,(eval (read-from-string name) env))
+                    (ex <throwable> 'nil))
+    (('ok obj)
+     (mcase (arglist obj)
+       ('#f 'nil)
+       ((args rtype)
+        (format "(~a~{~^ ~a~})~a" name 
+                (map (fun (e) 
+                       (if (equal (cadr e) "java.lang.Object") (car e) e))
+                     args)
+                (if (equal rtype "java.lang.Object")
+                    ""
+                    (format " => ~a" rtype))))))
+    (_ 'nil)))
+
+(df arglist (obj)
+  (typecase obj
+    (<gnu.expr.ModuleMethod> 
+     (let* ((mref (module-method>meth-ref obj)))
+       (list (mapi (! arguments mref)
+                   (fun ((v <local-var>))
+                     (list (! name v) (! typeName v))))
+             (! returnTypeName mref))))
+    (<object> #f)))
+
 ;;;; M-.
 
 (defslimefun find-definitions-for-emacs (env name)
@@ -818,7 +846,10 @@
                                       (if s (all-definitions s) '()))))
     (<java.lang.Class> (list o))
     (<gnu.mapping.Procedure> (all-definitions (! get-class o)))
-    (<kawa.lang.Macro> (list o))))
+    (<kawa.lang.Macro> (list o))
+    (<gnu.bytecode.ObjectType> (all-definitions (! getReflectClass o)))
+    (<java.lang.Object> '())
+    ))
 
 (df gf-methods ((f <gnu.expr.GenericProc>))
   (let* ((o :: <obj-ref> (vm-mirror *the-vm* f))
@@ -913,8 +944,9 @@
          (ex <throwable> #f)))))
 
 (define swank-java-source-path
-        (let ((jre-home (<java.lang.System>:getProperty "java.home")))
-          (list (<file> (<file> jre-home):parent "src.zip"):path)))
+  (let ((jre-home (<java.lang.System>:getProperty "java.home")))
+    (list (! get-path (<file> (! get-parent (<file> jre-home)) "src.zip"))
+          )))
 
 (df source-path ()
   (mlet ((base) (search-path-prop "user.dir"))
@@ -975,7 +1007,7 @@
                       (! write s cpool)
                       (! flush s)
                       (! toByteArray bs))))
-    (vm-set-slot *the-vm* ct 'constants 
+    (vm-set-slot *the-vm* ct "constants"
                  (<gnu.bytecode.ConstantPool>
                   (<java.io.DataInputStream>
                    (<java.io.ByteArrayInputStream>
@@ -1016,7 +1048,7 @@
 
 (df %macroexpand (sexp)
   (let ((tr :: kawa.lang.Translator (gnu.expr.Compilation:getCurrent)))
-    (! rewrite tr sexp)))
+    (! rewrite tr `(begin ,sexp))))
 
 
 ;;;; Inspector
@@ -1173,6 +1205,7 @@
 (df vm-monitor ((c <chan>))
   (! set-name (current-thread) "swank-vm-monitor")
   (let ((vm (vm-attach)))
+    (log-vm-props vm)
     ;;(enable-uncaught-exception-events vm)
     (mlet* (((ev . _) (spawn/chan/catch 
                        (fun (c) 
@@ -1315,6 +1348,25 @@
   ((request) :: <com.sun.jdi.request.EventRequest> #!null)
   ((virtualMachine) :: <vm> (! virtualMachine thread)))
 
+(df log-vm-props ((vm <vm>))
+  (letrec-syntax ((p (syntax-rules ()
+                       ((p name) (log "~s: ~s\n" 'name (! name vm)))))
+                  (p* (syntax-rules ()
+                        ((p* n ...) (seq (p n) ...)))))
+    (p* canBeModified
+        canRedefineClasses
+        canAddMethod
+        canUnrestrictedlyRedefineClasses
+        canGetBytecodes
+        canGetConstantPool
+        canGetSyntheticAttribute
+        canGetSourceDebugExtension
+        canPopFrames
+        canForceEarlyReturn
+        canGetMethodReturnValues
+        canGetInstanceInfo
+        )))
+
 ;;;;; Debugger
 
 (df debug-thread ((tref <thread-ref>) state (c <chan>))