abcl.lisp (64812B)
1 ;;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;;*"; -*- 2 ;;; 3 ;;; slynk-abcl.lisp --- Armedbear CL specific code for SLY. 4 ;;; 5 ;;; Adapted from slynk-acl.lisp, Andras Simon, 2004 6 ;;; New work by Alan Ruttenberg, 2016-7 7 ;;; 8 ;;; This code has been placed in the Public Domain. All warranties 9 ;;; are disclaimed. 10 ;;; 11 12 (defpackage slynk/abcl 13 (:use cl slynk/backend) 14 (:import-from :java 15 #:jcall #:jstatic 16 #:jmethod 17 #:jfield 18 #:jconstructor 19 #:jnew-array #:jarray-length #:jarray-ref #:jnew-array-from-array 20 #:jclass #:jnew #:java-object 21 ;; be conservative and add any import java functions only for later lisps 22 #+#.(slynk/backend:with-symbol 'jfield-name 'java) #:jfield-name 23 #+#.(slynk/backend:with-symbol 'jinstance-of-p 'java) #:jinstance-of-p 24 #+#.(slynk/backend:with-symbol 'jclass-superclass 'java) #:jclass-superclass 25 #+#.(slynk/backend:with-symbol 'jclass-interfaces 'java) #:jclass-interfaces 26 #+#.(slynk/backend:with-symbol 'java-exception 'java) #:java-exception 27 #+#.(slynk/backend:with-symbol 'jobject-class 'java) #:jobject-class 28 #+#.(slynk/backend:with-symbol 'jclass-name 'java) #:jclass-name 29 #+#.(slynk/backend:with-symbol 'java-object-p 'java) #:java-object-p)) 30 31 (in-package slynk/abcl) 32 33 (eval-when (:compile-toplevel :load-toplevel :execute) 34 (require :collect) ;just so that it doesn't spoil the flying letters 35 (require :pprint) 36 (require :gray-streams) 37 (require :abcl-contrib) 38 39 ;;; Probe and load ABCL-INTROSPECT pushing to *FEATURES* on success 40 ;;; allowing us to conditionalize usage via `#+abcl-introspect` forms. 41 (when (ignore-errors (and 42 (fboundp '(setf sys::function-plist)) 43 (progn 44 (require :abcl-introspect) 45 (find "ABCL-INTROSPECT" *modules* :test 46 'equal)))) 47 (pushnew :abcl-introspect *features*))) 48 49 (defimplementation gray-package-name () 50 "GRAY-STREAMS") 51 52 ;; FIXME: switch to shared Gray stream implementation when the 53 ;; architecture for booting streams allows us to replace the Java-side 54 ;; implementation of a Sly{Input,Output}Stream.java classes are 55 ;; subsumed <http://abcl.org/trac/ticket/373>. 56 (progn 57 (defimplementation make-output-stream (write-string) 58 (ext:make-slime-output-stream write-string)) 59 60 (defimplementation make-input-stream (read-string) 61 (ext:make-slime-input-stream read-string 62 (make-synonym-stream '*standard-output*)))) 63 64 ;;; Have CL:INSPECT use SLY 65 ;;; 66 ;;; Since Slynk may also be run in a server not running under Emacs 67 ;;; and potentially with other REPLs, we export a functional toggle 68 ;;; for the user to call after loading these definitions. 69 (defun enable-cl-inspect-in-emacs () 70 (slynk::wrap 'cl:inspect :use-sly :replace 'slynk::inspect-in-emacs)) 71 72 ;; ??? repair bare print object so inspector titles show java class 73 (defun %print-unreadable-object-java-too (object stream type identity body) 74 (setf stream (sys::out-synonym-of stream)) 75 (when *print-readably* 76 (error 'print-not-readable :object object)) 77 (format stream "#<") 78 (when type 79 (if (java-object-p object) 80 ;; Special handling for java objects 81 (if (jinstance-of-p object "java.lang.Class") 82 (progn 83 (write-string "jclass " stream) 84 (format stream "~a" (jclass-name object))) 85 (format stream "~a" (jclass-name (jobject-class object)))) 86 ;; usual handling 87 (format stream "~S" (type-of object))) 88 (format stream " ")) 89 (when body 90 (funcall body)) 91 (when identity 92 (when (or body (not type)) 93 (format stream " ")) 94 (format stream "{~X}" (sys::identity-hash-code object))) 95 (format stream ">") 96 nil) 97 98 ;;; TODO: move such invocations out of toplevel? 99 (eval-when (:load-toplevel) 100 (unless (get 'sys::%print-unreadable-object 'sly-backend::sly-wrap) 101 (wrap 'sys::%print-unreadable-object :more-informative :replace '%print-unreadable-object-java-too))) 102 103 (defimplementation call-with-compilation-hooks (function) 104 (funcall function)) 105 106 107 ;;;; MOP 108 109 ;;dummies and definition 110 111 (defclass standard-slot-definition ()()) 112 113 (defun slot-definition-documentation (slot) 114 (declare (ignore slot)) 115 #+abcl-introspect 116 (documentation slot 't)) 117 118 (defun slot-definition-type (slot) 119 (declare (ignore slot)) 120 t) 121 122 (defun class-prototype (class) 123 (declare (ignore class)) 124 nil) 125 126 (defun generic-function-declarations (gf) 127 (declare (ignore gf)) 128 nil) 129 130 (defun specializer-direct-methods (spec) 131 (mop:class-direct-methods spec)) 132 133 (defun slot-definition-name (slot) 134 (mop:slot-definition-name slot)) 135 136 (defun class-slots (class) 137 (mop:class-slots class)) 138 139 (defun method-generic-function (method) 140 (mop:method-generic-function method)) 141 142 (defun method-function (method) 143 (mop:method-function method)) 144 145 (defun slot-boundp-using-class (class object slotdef) 146 (declare (ignore class)) 147 (system::slot-boundp object (slot-definition-name slotdef))) 148 149 (defun slot-value-using-class (class object slotdef) 150 (declare (ignore class)) 151 (system::slot-value object (slot-definition-name slotdef))) 152 153 (defun (setf slot-value-using-class) (new class object slotdef ) 154 (declare (ignore class)) 155 (mop::%set-slot-value object (slot-definition-name slotdef) new)) 156 157 (import-to-slynk-mop 158 '( ;; classes 159 cl:standard-generic-function 160 standard-slot-definition ;;dummy 161 cl:method 162 cl:standard-class 163 #+#.(slynk/backend:with-symbol 164 'compute-applicable-methods-using-classes 'mop) 165 mop:compute-applicable-methods-using-classes 166 ;; standard-class readers 167 mop:class-default-initargs 168 mop:class-direct-default-initargs 169 mop:class-direct-slots 170 mop:class-direct-subclasses 171 mop:class-direct-superclasses 172 mop:eql-specializer 173 mop:class-finalized-p 174 mop:finalize-inheritance 175 cl:class-name 176 mop:class-precedence-list 177 class-prototype ;;dummy 178 class-slots 179 specializer-direct-methods 180 ;; eql-specializer accessors 181 mop::eql-specializer-object 182 ;; generic function readers 183 mop:generic-function-argument-precedence-order 184 generic-function-declarations ;;dummy 185 mop:generic-function-lambda-list 186 mop:generic-function-methods 187 mop:generic-function-method-class 188 mop:generic-function-method-combination 189 mop:generic-function-name 190 ;; method readers 191 method-generic-function 192 method-function 193 mop:method-lambda-list 194 mop:method-specializers 195 mop:method-qualifiers 196 ;; slot readers 197 mop:slot-definition-allocation 198 slot-definition-documentation ;;dummy 199 mop:slot-definition-initargs 200 mop:slot-definition-initform 201 mop:slot-definition-initfunction 202 slot-definition-name 203 slot-definition-type ;;dummy 204 mop:slot-definition-readers 205 mop:slot-definition-writers 206 slot-boundp-using-class 207 slot-value-using-class 208 set-slot-value-using-class 209 #+#.(slynk/backend:with-symbol 210 'slot-makunbound-using-class 'mop) 211 mop:slot-makunbound-using-class)) 212 213 ;;;; TCP Server 214 215 (defimplementation preferred-communication-style () 216 :spawn) 217 218 (defimplementation create-socket (host port &key backlog) 219 (ext:make-server-socket port)) 220 221 (defimplementation local-port (socket) 222 (jcall (jmethod "java.net.ServerSocket" "getLocalPort") socket)) 223 224 (defimplementation close-socket (socket) 225 (ext:server-socket-close socket)) 226 227 (defimplementation accept-connection (socket 228 &key external-format buffering timeout) 229 (declare (ignore buffering timeout)) 230 (ext:get-socket-stream (ext:socket-accept socket) 231 :element-type (if external-format 232 'character 233 '(unsigned-byte 8)) 234 :external-format (or external-format :default))) 235 236 ;;;; UTF8 237 238 ;; faster please! 239 (defimplementation string-to-utf8 (s) 240 (jbytes-to-octets 241 (java:jcall 242 (java:jmethod "java.lang.String" "getBytes" "java.lang.String") 243 s 244 "UTF8"))) 245 246 (defimplementation utf8-to-string (u) 247 (java:jnew 248 (java:jconstructor "org.armedbear.lisp.SimpleString" 249 "java.lang.String") 250 (java:jnew (java:jconstructor "java.lang.String" "[B" "java.lang.String") 251 (octets-to-jbytes u) 252 "UTF8"))) 253 254 (defun octets-to-jbytes (octets) 255 (declare (type octets (simple-array (unsigned-byte 8) (*)))) 256 (let* ((len (length octets)) 257 (bytes (java:jnew-array "byte" len))) 258 (loop for byte across octets 259 for i from 0 260 do (java:jstatic (java:jmethod "java.lang.reflect.Array" "setByte" 261 "java.lang.Object" "int" "byte") 262 "java.lang.reflect.Array" 263 bytes i byte)) 264 bytes)) 265 266 (defun jbytes-to-octets (jbytes) 267 (let* ((len (java:jarray-length jbytes)) 268 (octets (make-array len :element-type '(unsigned-byte 8)))) 269 (loop for i from 0 below len 270 for jbyte = (java:jarray-ref jbytes i) 271 do (setf (aref octets i) jbyte)) 272 octets)) 273 274 ;;;; External formats 275 276 (defvar *external-format-to-coding-system* 277 '((:iso-8859-1 "latin-1" "iso-latin-1" "iso-8859-1") 278 ((:iso-8859-1 :eol-style :lf) 279 "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix") 280 (:utf-8 "utf-8") 281 ((:utf-8 :eol-style :lf) "utf-8-unix") 282 (:euc-jp "euc-jp") 283 ((:euc-jp :eol-style :lf) "euc-jp-unix") 284 (:us-ascii "us-ascii") 285 ((:us-ascii :eol-style :lf) "us-ascii-unix"))) 286 287 (defimplementation find-external-format (coding-system) 288 (car (rassoc-if (lambda (x) 289 (member coding-system x :test #'equal)) 290 *external-format-to-coding-system*))) 291 292 ;;;; Unix signals 293 294 (defimplementation getpid () 295 (if (fboundp 'ext::get-pid) 296 (ext::get-pid) ;;; Introduced with abcl-1.5.0 297 (handler-case 298 (let* ((runtime 299 (java:jstatic "getRuntime" "java.lang.Runtime")) 300 (command 301 (java:jnew-array-from-array 302 "java.lang.String" #("sh" "-c" "echo $PPID"))) 303 (runtime-exec-jmethod 304 ;; Complicated because java.lang.Runtime.exec() is 305 ;; overloaded on a non-primitive type (array of 306 ;; java.lang.String), so we have to use the actual 307 ;; parameter instance to get java.lang.Class 308 (java:jmethod "java.lang.Runtime" "exec" 309 (java:jcall 310 (java:jmethod "java.lang.Object" "getClass") 311 command))) 312 (process 313 (java:jcall runtime-exec-jmethod runtime command)) 314 (output 315 (java:jcall (java:jmethod "java.lang.Process" "getInputStream") 316 process))) 317 (java:jcall (java:jmethod "java.lang.Process" "waitFor") 318 process) 319 (loop :with b :do 320 (setq b 321 (java:jcall (java:jmethod "java.io.InputStream" "read") 322 output)) 323 :until (member b '(-1 #x0a)) ; Either EOF or LF 324 :collecting (code-char b) :into result 325 :finally (return 326 (parse-integer (coerce result 'string))))) 327 (t () 0)))) 328 329 (defimplementation lisp-implementation-type-name () 330 "armedbear") 331 332 (defimplementation set-default-directory (directory) 333 (let ((dir (sys::probe-directory directory))) 334 (when dir (setf *default-pathname-defaults* dir)) 335 (namestring dir))) 336 337 338 ;;;; Misc 339 340 (defimplementation arglist (fun) 341 (cond ((symbolp fun) 342 (multiple-value-bind (arglist present) 343 (sys::arglist fun) 344 (when (and (not present) 345 (fboundp fun) 346 (typep (symbol-function fun) 347 'standard-generic-function)) 348 (setq arglist 349 (mop::generic-function-lambda-list (symbol-function fun)) 350 present 351 t)) 352 (if present arglist :not-available))) 353 (t :not-available))) 354 355 (defimplementation function-name (function) 356 (if (fboundp 'sys::any-function-name) 357 ;; abcl-1.5.0 358 (sys::any-function-name function) 359 ;; pre abcl-1.5.0 360 (nth-value 2 (function-lambda-expression function)))) 361 362 (defimplementation macroexpand-all (form &optional env) 363 (ext:macroexpand-all form env)) 364 365 (defimplementation collect-macro-forms (form &optional env) 366 ;; Currently detects only normal macros, not compiler macros. 367 (declare (ignore env)) 368 (with-collected-macro-forms (macro-forms) 369 (handler-bind ((warning #'muffle-warning)) 370 (ignore-errors 371 (compile nil `(lambda () ,(macroexpand-all form env))))) 372 (values macro-forms nil))) 373 374 (defimplementation describe-symbol-for-emacs (symbol) 375 (let ((result '())) 376 (flet ((doc (kind &optional (sym symbol)) 377 (or (documentation sym kind) :not-documented)) 378 (maybe-push (property value) 379 (when value 380 (setf result (list* property value result))))) 381 (maybe-push 382 :variable (when (boundp symbol) 383 (doc 'variable))) 384 (when (fboundp symbol) 385 (maybe-push 386 (cond ((macro-function symbol) :macro) 387 ((special-operator-p symbol) :special-operator) 388 ((typep (fdefinition symbol) 'generic-function) 389 :generic-function) 390 (t :function)) 391 (doc 'function))) 392 (maybe-push 393 :class (if (find-class symbol nil) 394 (doc 'class))) 395 result))) 396 397 (defimplementation describe-definition (symbol namespace) 398 (ecase namespace 399 ((:variable :macro) 400 (describe symbol)) 401 ((:function :generic-function) 402 (describe (symbol-function symbol))) 403 (:class 404 (describe (find-class symbol))))) 405 406 (defimplementation describe-definition (symbol namespace) 407 (ecase namespace 408 (:variable 409 (describe symbol)) 410 ((:function :generic-function) 411 (describe (symbol-function symbol))) 412 (:class 413 (describe (find-class symbol))))) 414 415 ;;;; Debugger 416 417 ;; Copied from slynk-sbcl.lisp. 418 #+abcl-introspect 419 (defvar sys::*caught-frames*) 420 ;; 421 ;; Notice that *INVOKE-DEBUGGER-HOOK* is tried before *DEBUGGER-HOOK*, 422 ;; so we have to make sure that the latter gets run when it was 423 ;; established locally by a user (i.e. changed meanwhile.) 424 (defun make-invoke-debugger-hook (hook) 425 (lambda (condition old-hook) 426 (prog1 (let (#+abcl-introspect 427 (sys::*caught-frames* nil)) 428 ;; the next might be the right thing for earlier lisps but I don't know 429 ;;; XXX probably doesn't work in absence of ABCL-INTROSPECT on abcl-1.4 and earlier 430 (let (#+abcl-introspect 431 (sys::*saved-backtrace* 432 (if (fboundp 'sys::new-backtrace) 433 (sys::new-backtrace condition) 434 (sys::backtrace)))) 435 (if *debugger-hook* 436 (funcall *debugger-hook* condition old-hook) 437 (funcall hook condition old-hook))))))) 438 439 (defimplementation call-with-debugger-hook (hook fun) 440 (let ((*debugger-hook* hook) 441 (sys::*invoke-debugger-hook* (make-invoke-debugger-hook hook))) 442 (funcall fun))) 443 444 (defimplementation install-debugger-globally (function) 445 (setq *debugger-hook* function) 446 (setq sys::*invoke-debugger-hook* (make-invoke-debugger-hook function))) 447 448 (defvar *sldb-topframe*) 449 450 (defimplementation call-with-debugging-environment (debugger-loop-fn) 451 (let* ((magic-token (intern "SLYNK-DEBUGGER-HOOK" 'slynk)) 452 (*sldb-topframe* 453 (or 454 (second (member magic-token 455 #+abcl-introspect sys::*saved-backtrace* 456 #-abcl-introspect (sys:backtrace) 457 :key (lambda (frame) 458 (first (sys:frame-to-list frame))))) 459 (car sys::*saved-backtrace*))) 460 #+#.(slynk/backend:with-symbol *debug-condition* 'ext) 461 (ext::*debug-condition* slynk::*slynk-debugger-condition*)) 462 (funcall debugger-loop-fn))) 463 464 (defun backtrace (start end) 465 "A backtrace without initial SLYNK frames." 466 (let ((backtrace 467 #+abcl-introspect sys::*saved-backtrace* 468 #-abcl-introspect (sys:backtrace))) 469 (subseq (or (member *sldb-topframe* backtrace) backtrace) start end))) 470 471 (defun nth-frame (index) 472 (nth index (backtrace 0 nil))) 473 474 (defimplementation compute-backtrace (start end) 475 (let ((end (or end most-positive-fixnum))) 476 (backtrace start end))) 477 478 ;; Don't count on JSS being loaded, but if it is then there's some more stuff we can do 479 +#+#.(slynk/backend:with-symbol 'invoke-restargs 'jss) 480 (defun jss-p () 481 (and (member "JSS" *modules* :test 'string=) (intern "INVOKE-RESTARGS" "JSS"))) 482 483 +#+#.(slynk/backend:with-symbol 'invoke-restargs 'jss) 484 (defun matches-jss-call (form) 485 (flet ((gensymp (s) (and (symbolp s) (null (symbol-package s)))) 486 (invokep (s) (and (symbolp s) (eq s (jss-p))))) 487 (let ((method 488 (slynk/match::select-match 489 form 490 (((LAMBDA ((#'gensymp a) &REST (#'gensymp b)) 491 ((#'invokep fun) (#'stringp c) (#'gensymp d) (#'gensymp e) . args)) . args) '=> c) 492 (other nil)))) 493 method))) 494 495 #-abcl-introspect 496 (defimplementation print-frame (frame stream) 497 (write-string (sys:frame-to-string frame) 498 stream)) 499 500 ;; Use princ cs write-string for lisp frames as it respects (print-object (function t)) 501 ;; Rewrite jss expansions to their unexpanded state 502 ;; Show java exception frames up to where a java exception happened with a "!" 503 ;; Check if a java class corresponds to a lisp function and tell us if to 504 (defvar *debugger-package* (find-package 'cl-user)) 505 506 #+abcl-introspect 507 (defimplementation print-frame (frame stream) 508 ;; make clear which functions aren't Common Lisp. Otherwise uses 509 ;; default package, which is invisible 510 (let ((*package* (or *debugger-package* *package*))) 511 (if (typep frame 'sys::lisp-stack-frame) 512 (if (not (jss-p)) 513 (princ (system:frame-to-list frame) stream) 514 ;; rewrite jss forms as they would be written 515 (let ((form (system:frame-to-list frame))) 516 (if (eq (car form) (jss-p)) 517 (format stream "(#~s ~{~s~^~})" (second form) (list* (third form) (fourth form))) 518 (loop initially (write-char #\( stream) 519 for (el . rest) on form 520 for method = (slynk/abcl::matches-jss-call el) 521 do 522 (cond (method 523 (format stream "(#~s ~{~s~^~})" method (cdr el))) 524 (t 525 (prin1 el stream))) 526 (unless (null rest) (write-char #\space stream)) 527 finally (write-char #\) stream))))) 528 (let ((classname (getf (sys:frame-to-list frame) :class))) 529 (if (and (fboundp 'sys::javaframe) 530 (member (sys::javaframe frame) sys::*caught-frames* :test 'equal)) 531 (write-string "! " stream)) 532 (write-string (sys:frame-to-string frame) stream) 533 (if (and classname (sys::java-class-lisp-function classname)) 534 (format stream " = ~a" (sys::java-class-lisp-function classname))))))) 535 536 ;;; Machinery for DEFIMPLEMENTATION 537 ;;; FIXME can't seem to use FLET forms with DEFIMPLEMENTATION --ME 20150403 538 (defun nth-frame-list (index) 539 (jcall "toLispList" (nth-frame index))) 540 541 (defun match-lambda (operator values) 542 (jvm::match-lambda-list 543 (multiple-value-list 544 (jvm::parse-lambda-list (ext:arglist operator))) 545 values)) 546 547 (defimplementation frame-locals (index) 548 (let ((frame (nth-frame index))) 549 ;; FIXME introspect locals in SYS::JAVA-STACK-FRAME 550 (when (typep frame 'sys::lisp-stack-frame) 551 (loop 552 :for id :upfrom 0 553 :with frame = (nth-frame-list index) 554 :with operator = (first frame) 555 :with values = (rest frame) 556 :with arglist = (if (and operator (consp values) (not (null values))) 557 (handler-case (match-lambda operator values) 558 (jvm::lambda-list-mismatch (e) (declare(ignore e)) 559 :lambda-list-mismatch)) 560 :not-available) 561 :for value :in values 562 :collecting (list 563 :name (if (not (keywordp arglist)) 564 (first (nth id arglist)) 565 (format nil "arg~A" id)) 566 :id id 567 :value value))))) 568 569 (defimplementation frame-var-value (index id) 570 (elt (rest (jcall "toLispList" (nth-frame index))) id)) 571 572 #+abcl-introspect 573 (defimplementation disassemble-frame (index) 574 (sys::disassemble (frame-function (nth-frame index)))) 575 576 (defun frame-function (frame) 577 (let ((list (sys::frame-to-list frame))) 578 (cond 579 ((keywordp (car list)) 580 (find (getf list :method) 581 (jcall "getDeclaredMethods" (jclass (getf list :class))) 582 :key (lambda(e)(jcall "getName" e)) :test 'equal)) 583 (t (car list) )))) 584 585 (defimplementation frame-source-location (index) 586 (let ((frame (nth-frame index))) 587 (or (source-location (nth-frame index)) 588 `(:error ,(format nil "No source for frame: ~a" frame))))) 589 590 591 ;;;; Compiler hooks 592 593 (defvar *buffer-name* nil) 594 (defvar *buffer-start-position*) 595 (defvar *buffer-string*) 596 (defvar *compile-filename*) 597 598 (defvar *abcl-signaled-conditions*) 599 600 (defun handle-compiler-warning (condition) 601 (let ((loc (when (and jvm::*compile-file-pathname* 602 system::*source-position*) 603 (cons jvm::*compile-file-pathname* system::*source-position*)))) 604 ;; filter condition signaled more than once. 605 (unless (member condition *abcl-signaled-conditions*) 606 (push condition *abcl-signaled-conditions*) 607 (signal 'compiler-condition 608 :original-condition condition 609 :severity :warning 610 :message (format nil "~A" condition) 611 :location (cond (*buffer-name* 612 (make-location 613 (list :buffer *buffer-name*) 614 (list :offset *buffer-start-position* 0))) 615 (loc 616 (destructuring-bind (file . pos) loc 617 (make-location 618 (list :file (namestring (truename file))) 619 (list :position (1+ pos))))) 620 (t 621 (make-location 622 (list :file (namestring *compile-filename*)) 623 (list :position 1)))))))) 624 625 (defimplementation slynk-compile-file (input-file output-file 626 load-p external-format 627 &key policy) 628 (declare (ignore external-format policy)) 629 (let ((jvm::*resignal-compiler-warnings* t) 630 (*abcl-signaled-conditions* nil)) 631 (handler-bind ((warning #'handle-compiler-warning)) 632 (let ((*buffer-name* nil) 633 (*compile-filename* input-file)) 634 (multiple-value-bind (fn warn fail) 635 (compile-file input-file :output-file output-file) 636 (values fn warn 637 (and fn load-p 638 (not (load fn))))))))) 639 640 (defimplementation slynk-compile-string (string &key buffer position filename 641 line column policy) 642 (declare (ignore filename line column policy)) 643 (let ((jvm::*resignal-compiler-warnings* t) 644 (*abcl-signaled-conditions* nil)) 645 (handler-bind ((warning #'handle-compiler-warning)) 646 (let ((*buffer-name* buffer) 647 (*buffer-start-position* position) 648 (*buffer-string* string) 649 (sys::*source* (make-pathname :device "emacs-buffer" :name buffer)) 650 (sys::*source-position* position)) 651 (funcall (compile nil (read-from-string 652 (format nil "(~S () ~A)" 'lambda string)))) 653 t)))) 654 655 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 656 ;; source location and users of it 657 658 (defgeneric source-location (object)) 659 660 ;; try to find some kind of source for internals 661 #+abcl-introspect 662 (defun implementation-source-location (arg) 663 (let ((function (cond ((functionp arg) 664 arg) 665 ((and (symbolp arg) (fboundp arg)) 666 (or (symbol-function arg) (macro-function arg)))))) 667 (when (typep function 'generic-function) 668 (setf function (mop::funcallable-instance-function function))) 669 ;; functions are execute methods of class 670 (when (or (functionp function) (special-operator-p arg)) 671 (let ((fclass (jcall "getClass" function))) 672 (let ((classname (jcall "getName" fclass))) 673 (destructuring-bind (class local) 674 (if (find #\$ classname) 675 (split-string classname "\\$") 676 (list classname (jcall "replaceFirst" classname "([^.]*\\.)*" ""))) 677 (unless (member local '("MacroObject" "CompiledClosure" "Closure") :test 'equal) 678 ;; look for java source 679 (let* ((partial-path (substitute #\/ #\. class)) 680 (java-path (concatenate 'string partial-path ".java")) 681 (found-in-source-path (find-file-in-path java-path *source-path*))) 682 ;; snippet for finding the internal class within the file 683 (if found-in-source-path 684 `((:primitive ,local) 685 (:location ,found-in-source-path 686 (:line 0) 687 (:snippet ,(format nil "class ~a" local)))) 688 ;; if not, look for the class file, and hope that 689 ;; emacs is configured to disassemble class entries 690 ;; in jars. 691 692 ;; Alan uses jdc.el 693 ;; <https://github.com/m0smith/dotfiles/blob/master/.emacs.d/site-lisp/jdc.el> 694 ;; with jad <https://github.com/moparisthebest/jad> 695 ;; Also (setq sys::*disassembler* "jad -a -p") 696 (let ((class-in-source-path 697 (find-file-in-path (concatenate 'string partial-path ".class") *source-path*))) 698 ;; no snippet, since internal class is in its own file 699 (when class-in-source-path 700 `(:primitive (:location ,class-in-source-path (:line 0) nil))))))))))))) 701 702 #+abcl-introspect 703 (defun get-declared-field (class fieldname) 704 (find fieldname (jcall "getDeclaredFields" class) :key 'jfield-name :test 'equal)) 705 706 #+abcl-introspect 707 (defun symbol-defined-in-java (symbol) 708 (loop with internal-name1 = (jcall "replaceAll" (jcall "replaceAll" (string symbol) "\\*" "") "-" "_") 709 with internal-name2 = (jcall "replaceAll" (jcall "replaceAll" (string symbol) "\\*" "_") "-" "_") 710 for class in 711 (load-time-value (mapcar 712 'jclass 713 '("org.armedbear.lisp.Package" 714 "org.armedbear.lisp.Symbol" 715 "org.armedbear.lisp.Debug" 716 "org.armedbear.lisp.Extensions" 717 "org.armedbear.lisp.JavaObject" 718 "org.armedbear.lisp.Lisp" 719 "org.armedbear.lisp.Pathname" 720 "org.armedbear.lisp.Site"))) 721 thereis 722 (or (get-declared-field class internal-name1) 723 (get-declared-field class internal-name2)))) 724 725 #+abcl-introspect 726 (defun maybe-implementation-variable (s) 727 (let ((field (symbol-defined-in-java s))) 728 (and field 729 (let ((class (jcall "getName" (jcall "getDeclaringClass" field)))) 730 (let* ((partial-path (substitute #\/ #\. class)) 731 (java-path (concatenate 'string partial-path ".java")) 732 (found-in-source-path (find-file-in-path java-path *source-path*))) 733 (when found-in-source-path 734 `(symbol (:location ,found-in-source-path (:line 0) 735 (:snippet ,(format nil "~s" (string s))))))))))) 736 737 #+abcl-introspect 738 (defun if-we-have-to-choose-one-choose-the-function (sources) 739 (or (loop for spec in sources 740 for (dspec) = spec 741 when (and (consp dspec) (eq (car dspec) :function)) 742 when (and (consp dspec) (member (car dspec) '(:slynk-implementation :function))) 743 do (return-from if-we-have-to-choose-one-choose-the-function spec)) 744 (car sources))) 745 746 (defmethod source-location ((symbol symbol)) 747 (or #+abcl-introspect 748 (let ((maybe (if-we-have-to-choose-one-choose-the-function (get symbol 'sys::source)))) 749 (and maybe (second (sly-location-from-source-annotation symbol maybe)))) 750 ;; This below should be obsolete - it uses the old sys:%source 751 ;; leave it here for now just in case 752 (and (pathnamep (ext:source-pathname symbol)) 753 (let ((pos (ext:source-file-position symbol)) 754 (path (namestring (ext:source-pathname symbol)))) 755 ; boot.lisp gets recorded wrong 756 (when (equal path "boot.lisp") 757 (setq path (second (find-file-in-path "org/armedbear/lisp/boot.lisp" *source-path*)))) 758 (cond ((ext:pathname-jar-p path) 759 `(:location 760 ;; strip off "jar:file:" = 9 characters 761 (:zip ,@(split-string (subseq path (length "jar:file:")) "!/")) 762 ;; pos never seems right. Use function name. 763 (:function-name ,(string symbol)) 764 (:align t))) 765 ((equal (pathname-device (ext:source-pathname symbol)) "emacs-buffer") 766 ;; conspire with slynk-compile-string to keep the buffer 767 ;; name in a pathname whose device is "emacs-buffer". 768 `(:location 769 (:buffer ,(pathname-name (ext:source-pathname symbol))) 770 (:function-name ,(string symbol)) 771 (:align t))) 772 (t 773 `(:location 774 (:file ,path) 775 ,(if pos 776 (list :position (1+ pos)) 777 (list :function-name (string symbol))) 778 (:align t)))))) 779 #+abcl-introspect 780 (second (implementation-source-location symbol)))) 781 782 (defmethod source-location ((frame sys::java-stack-frame)) 783 (destructuring-bind (&key class method file line) (sys:frame-to-list frame) 784 (declare (ignore method)) 785 (let ((file (or (find-file-in-path file *source-path*) 786 (let ((f (format nil "~{~a/~}~a" 787 (butlast (split-string class "\\.")) 788 file))) 789 (find-file-in-path f *source-path*))))) 790 (and file 791 `(:location ,file (:line ,line) ()))))) 792 793 (defmethod source-location ((frame sys::lisp-stack-frame)) 794 (destructuring-bind (operator &rest args) (sys:frame-to-list frame) 795 (declare (ignore args)) 796 (etypecase operator 797 (function (source-location operator)) 798 (list nil) 799 (symbol (source-location operator))))) 800 801 (defmethod source-location ((fun function)) 802 (if #+abcl-introspect 803 (sys::local-function-p fun) 804 #-abcl-introspect 805 nil 806 (source-location (sys::local-function-owner fun)) 807 (let ((name (function-name fun))) 808 (and name (source-location name))))) 809 810 (defmethod source-location ((method method)) 811 #+abcl-introspect 812 (let ((found 813 (find `(:method ,@(sys::method-spec-list method)) 814 (get (function-name method) 'sys::source) 815 :key 'car :test 'equalp))) 816 (and found (second (sly-location-from-source-annotation (function-name method) found)))) 817 #-abcl-introspect 818 (let ((name (function-name fun))) 819 (and name (source-location name)))) 820 821 (defun system-property (name) 822 (jstatic "getProperty" "java.lang.System" name)) 823 824 (defun pathname-parent (pathname) 825 (make-pathname :directory (butlast (pathname-directory pathname)))) 826 827 (defun pathname-absolute-p (pathname) 828 (eq (car (pathname-directory pathname)) ':absolute)) 829 830 (defun split-string (string regexp) 831 (coerce 832 (jcall (jmethod "java.lang.String" "split" "java.lang.String") 833 string regexp) 834 'list)) 835 836 (defun path-separator () 837 (jfield "java.io.File" "pathSeparator")) 838 839 (defun search-path-property (prop-name) 840 (let ((string (system-property prop-name))) 841 (and string 842 (remove nil 843 (mapcar #'truename 844 (split-string string (path-separator))))))) 845 846 (defun jdk-source-path () 847 (let* ((jre-home (truename (system-property "java.home"))) 848 (src-zip (merge-pathnames "src.zip" (pathname-parent jre-home))) 849 (truename (probe-file src-zip))) 850 (and truename (list truename)))) 851 852 (defun class-path () 853 (append (search-path-property "java.class.path") 854 (search-path-property "sun.boot.class.path"))) 855 856 (defvar *source-path* 857 (remove nil 858 (append (search-path-property "user.dir") 859 (jdk-source-path) 860 ;; include lib jar files. contrib has lisp code. Would be good to build abcl.jar with source code as well 861 #+abcl-introspect 862 (list (sys::find-system-jar) 863 (sys::find-contrib-jar)))) 864 ;; you should tell sly where the abcl sources are. In .slynk.lisp I have: 865 ;; (push (probe-file "/Users/alanr/repos/abcl/src/") *SOURCE-PATH*) 866 "List of directories to search for source files.") 867 868 (defun zipfile-contains-p (zipfile-name entry-name) 869 (let ((zipfile (jnew (jconstructor "java.util.zip.ZipFile" 870 "java.lang.String") 871 zipfile-name))) 872 (jcall 873 (jmethod "java.util.zip.ZipFile" "getEntry" "java.lang.String") 874 zipfile entry-name))) 875 876 ;; Try to find FILENAME in PATH. If found, return a file spec as 877 ;; needed by Emacs. We also look in zip files. 878 (defun find-file-in-path (filename path) 879 (labels ((try (dir) 880 (cond ((not (pathname-type dir)) 881 (let ((f (probe-file (merge-pathnames filename dir)))) 882 (and f `(:file ,(namestring f))))) 883 ((member (pathname-type dir) '("zip" "jar") :test 'equal) 884 (try-zip dir)) 885 (t (error "strange path element: ~s" path)))) 886 (try-zip (zip) 887 (let* ((zipfile-name (namestring (truename zip)))) 888 (and (zipfile-contains-p zipfile-name filename) 889 `(#+abcl-introspect 890 :zip 891 #-abcl-introspect 892 :dir 893 ,zipfile-name ,filename))))) 894 (cond ((pathname-absolute-p filename) (probe-file filename)) 895 (t 896 (loop for dir in path 897 if (try dir) return it))))) 898 899 (defparameter *definition-types* 900 '(:variable defvar 901 :constant defconstant 902 :type deftype 903 :symbol-macro define-symbol-macro 904 :macro defmacro 905 :compiler-macro define-compiler-macro 906 :function defun 907 :generic-function defgeneric 908 :method defmethod 909 :setf-expander define-setf-expander 910 :structure defstruct 911 :condition define-condition 912 :class defclass 913 :method-combination define-method-combination 914 :package defpackage 915 :transform :deftransform 916 :optimizer :defoptimizer 917 :vop :define-vop 918 :source-transform :define-source-transform 919 :ir1-convert :def-ir1-translator 920 :declaration declaim 921 :alien-type :define-alien-type) 922 "Map SB-INTROSPECT definition type names to Sly-friendly forms") 923 924 (defun definition-specifier (type) 925 "Return a pretty specifier for NAME representing a definition of type TYPE." 926 (or (if (and (consp type) (getf *definition-types* (car type))) 927 `(,(getf *definition-types* (car type)) ,(second type) ,@(third type) ,@(cdddr type)) 928 (getf *definition-types* type)) 929 type)) 930 931 (defun stringify-method-specs (type) 932 "return a (:method ..) location for sly" 933 (let ((*print-case* :downcase)) 934 (flet ((p (a) (princ-to-string a))) 935 (destructuring-bind (name qualifiers specializers) (cdr type) 936 `(,(car type) ,(p name) ,(mapcar #'p specializers) ,@(mapcar #'p qualifiers)))))) 937 938 ;; for abcl source, check if it is still there, and if not, look in abcl jar instead 939 (defun maybe-redirect-to-jar (path) 940 (setq path (namestring path)) 941 (if (probe-file path) 942 path 943 (if (search "/org/armedbear/lisp" path :test 'string=) 944 (let ((jarpath (format nil "jar:file:~a!~a" (namestring (sys::find-system-jar)) 945 (subseq path (search "/org/armedbear/lisp" path))))) 946 (if (probe-file jarpath) 947 jarpath 948 path)) 949 path))) 950 951 #-abcl-introspect 952 (defimplementation find-definitions (symbol) 953 (ext:resolve symbol) 954 (let ((srcloc (source-location symbol))) 955 (and srcloc `((,symbol ,srcloc))))) 956 957 #+abcl-introspect 958 (defimplementation find-definitions (symbol) 959 (when (stringp symbol) 960 ;; allow a string to be passed. If it is package prefixed, remove the prefix 961 (setq symbol (intern (string-upcase 962 (subseq symbol (1+ (or (position #\: symbol :from-end t) -1)))) 963 'keyword))) 964 (let ((sources nil) 965 (implementation-variables nil) 966 (implementation-functions nil)) 967 (loop for package in (list-all-packages) 968 for sym = (find-symbol (string symbol) package) 969 when (and sym (equal (symbol-package sym) package)) 970 do 971 (when (sys::autoloadp symbol) 972 (sys::resolve symbol)) 973 (let ((source (or (get sym 'ext::source) (get sym 'sys::source))) 974 (i-var (maybe-implementation-variable sym)) 975 (i-fun (implementation-source-location sym))) 976 (when source 977 (setq sources (append sources (or (get sym 'ext::source) (get sym 'sys::source))))) 978 (when i-var 979 (push i-var implementation-variables)) 980 (when i-fun 981 (push i-fun implementation-functions)))) 982 (setq sources (remove-duplicates sources :test 'equalp)) 983 (append (remove-duplicates implementation-functions :test 'equalp) 984 (mapcar (lambda(s) (sly-location-from-source-annotation symbol s)) sources) 985 (remove-duplicates implementation-variables :test 'equalp)))) 986 987 (defun sly-location-from-source-annotation (sym it) 988 (destructuring-bind (what path pos) it 989 990 (let* ((isfunction 991 ;; all of these are (defxxx forms, which is what :function locations look for in sly 992 (and (consp what) (member (car what) 993 '(:function :generic-function :macro :class :compiler-macro 994 :type :constant :variable :package :structure :condition)))) 995 (ismethod (and (consp what) (eq (car what) :method))) 996 (<position> (cond (isfunction (list :function-name (princ-to-string (second what)))) 997 (ismethod (stringify-method-specs what)) 998 (t (list :position (1+ (or pos 0)))))) 999 1000 (path2 (if (eq path :top-level) 1001 ;; this is bogus - figure out some way to guess which is the repl associated with :toplevel 1002 ;; or get rid of this 1003 "emacs-buffer:*sly-repl*" 1004 (maybe-redirect-to-jar path)))) 1005 (when (atom what) 1006 (setq what (list what sym))) 1007 (list (definition-specifier what) 1008 (if (ext:pathname-jar-p path2) 1009 `(:location 1010 (:zip ,@(split-string (subseq path2 (length "jar:file:")) "!/")) 1011 ;; pos never seems right. Use function name. 1012 ,<position> 1013 (:align t)) 1014 ;; conspire with slynk-compile-string to keep the 1015 ;; buffer name in a pathname whose device is 1016 ;; "emacs-buffer". 1017 (if (eql 0 (search "emacs-buffer:" path2)) 1018 `(:location 1019 (:buffer ,(subseq path2 (load-time-value (length "emacs-buffer:")))) 1020 ,<position> 1021 (:align t)) 1022 `(:location 1023 (:file ,path2) 1024 ,<position> 1025 (:align t)))))))) 1026 1027 #+abcl-introspect 1028 (defimplementation list-callers (thing) 1029 (loop for caller in (sys::callers thing) 1030 when (typep caller 'method) 1031 append (let ((name (mop:generic-function-name 1032 (mop:method-generic-function caller)))) 1033 (mapcar (lambda(s) (sly-location-from-source-annotation thing s)) 1034 (remove `(:method ,@(sys::method-spec-list caller)) 1035 (get 1036 (if (consp name) (second name) name) 1037 'sys::source) 1038 :key 'car :test-not 'equalp))) 1039 when (symbolp caller) 1040 append (mapcar (lambda(s) (sly-location-from-source-annotation caller s)) 1041 (get caller 'sys::source)))) 1042 1043 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1044 ;;;; Inspecting 1045 1046 ;;; BEGIN FIXME move into generalized Slynk infrastructure, or add to contrib mechanism 1047 ;; this is only for hyperspec request in an inspector window 1048 ;; TODO have sly-hyperspec-lookup respect this variable too 1049 (defvar *sly-inspector-hyperspec-in-browser* t 1050 "If t then invoking hyperspec within the inspector browses the hyperspec in an emacs buffer, otherwise respecting the value of browse-url-browser-function") 1051 1052 (defun hyperspec-do (name) 1053 (let ((form `(let ((browse-url-browser-function 1054 ,(if *sly-inspector-hyperspec-in-browser* 1055 '(lambda(a v) (eww a)) 1056 'browse-url-browser-function))) 1057 (sly-hyperdoc-lookup ,name)))) 1058 (slynk::eval-in-emacs form t))) 1059 ;;; END FIXME move into generalized Slynk infrastructure, or add to contrib mechanism 1060 1061 ;;; Although by convention toString() is supposed to be a 1062 ;;; non-computationally expensive operation this isn't always the 1063 ;;; case, so make its computation a user interaction. 1064 (defparameter *to-string-hashtable* (make-hash-table :weakness :key)) 1065 1066 (defmethod emacs-inspect ((o t)) 1067 (let* ((type (type-of o)) 1068 (class (ignore-errors (find-class type))) 1069 (jclass (and (typep class 'sys::built-in-class) 1070 (jcall "getClass" o)))) 1071 (let ((parts (sys:inspected-parts o))) 1072 `((:label "Type: ") (:value ,(or class type)) (:Newline) 1073 ,@(if jclass 1074 `((:label "Java type: ") (:value ,jclass) (:newline))) 1075 ,@(if parts 1076 (loop :for (label . value) :in parts 1077 :appending (list 1078 (list :label (string-capitalize label)) 1079 ": " 1080 (list :value value (princ-to-string value)) '(:newline))) 1081 (list '(:label "No inspectable parts, dumping output of CL:DESCRIBE:") 1082 '(:newline) 1083 (with-output-to-string (desc) (describe o desc)))))))) 1084 1085 (defmethod emacs-inspect ((string string)) 1086 (slynk::lcons* 1087 '(:label "Value: ") `(:value ,string ,(concatenate 'string "\"" string "\"")) '(:newline) 1088 #+abcl-introspect ;; ??? This doesn't appear depend on ABCL-INTROSPECT. Why disable? 1089 `(:action "[Edit in emacs buffer]" ,(lambda() (slynk::ed-in-emacs `(:string ,string)))) 1090 '(:newline) 1091 (if (ignore-errors (jclass string)) 1092 `(:line "Names java class" ,(jclass string)) 1093 "") 1094 #+abcl-introspect 1095 (if (and (jss-p) 1096 (stringp (funcall (intern "LOOKUP-CLASS-NAME" :jss) string :return-ambiguous t :muffle-warning t))) 1097 `(:multiple 1098 (:label "Abbreviates java class: ") 1099 ,(let ((it (funcall (intern "LOOKUP-CLASS-NAME" :jss) string :return-ambiguous t :muffle-warning t))) 1100 `(:value ,(jclass it))) 1101 (:newline)) 1102 "") 1103 (if (ignore-errors (find-package (string-upcase string))) 1104 `(:line "Names package" ,(find-package (string-upcase string))) 1105 "") 1106 (let ((symbols (loop for p in (list-all-packages) 1107 for found = (find-symbol (string-upcase string)) 1108 when (and found (eq (symbol-package found) p) 1109 (or (fboundp found) 1110 (boundp found) 1111 (symbol-plist found) 1112 (ignore-errors (find-class found)))) 1113 collect found))) 1114 (if symbols 1115 `(:multiple (:label "Names symbols: ") 1116 ,@(loop for s in symbols 1117 collect 1118 (Let ((*package* (find-package :keyword))) 1119 `(:value ,s ,(prin1-to-string s))) collect " ") (:newline)) 1120 "")) 1121 (call-next-method))) 1122 1123 #+#.(slynk/backend:with-symbol 'java-exception 'java) 1124 (defmethod emacs-inspect ((o java:java-exception)) 1125 (append (call-next-method) 1126 (list '(:newline) '(:label "Stack trace") 1127 '(:newline) 1128 (let ((w (jnew "java.io.StringWriter"))) 1129 (jcall "printStackTrace" (java:java-exception-cause o) (jnew "java.io.PrintWriter" w)) 1130 (jcall "toString" w))))) 1131 1132 (defmethod emacs-inspect ((slot mop::slot-definition)) 1133 `("Name: " 1134 (:value ,(mop:slot-definition-name slot)) 1135 (:newline) 1136 "Documentation:" (:newline) 1137 ,@(when (slot-definition-documentation slot) 1138 `((:value ,(slot-definition-documentation slot)) (:newline))) 1139 "Initialization:" (:newline) 1140 (:label " Args: ") (:value ,(mop:slot-definition-initargs slot)) (:newline) 1141 (:label " Form: ") ,(if (mop:slot-definition-initfunction slot) 1142 `(:value ,(mop:slot-definition-initform slot)) 1143 "#<unspecified>") (:newline) 1144 (:label " Function: ") 1145 (:value ,(mop:slot-definition-initfunction slot)) 1146 (:newline))) 1147 1148 (defmethod emacs-inspect ((f function)) 1149 `(,@(when (function-name f) 1150 `((:label "Name: ") 1151 ,(princ-to-string (sys::any-function-name f)) (:newline))) 1152 ,@(multiple-value-bind (args present) (sys::arglist f) 1153 (when present 1154 `((:label "Argument list: ") 1155 ,(princ-to-string args) 1156 (:newline)))) 1157 #+abcl-introspect 1158 ,@(when (documentation f t) 1159 `("Documentation:" (:newline) 1160 ,(documentation f t) (:newline))) 1161 ,@(when (function-lambda-expression f) 1162 `((:label "Lambda expression:") 1163 (:newline) ,(princ-to-string 1164 (function-lambda-expression f)) (:newline))) 1165 (:label "Function java class: ") (:value ,(jcall "getClass" f)) (:newline) 1166 #+abcl-introspect 1167 ,@(when (jcall "isInstance" (java::jclass "org.armedbear.lisp.CompiledClosure") f) 1168 `((:label "Closed over: ") 1169 ,@(loop 1170 for el in (sys::compiled-closure-context f) 1171 collect `(:value ,el) 1172 collect " ") 1173 (:newline))) 1174 #+abcl-introspect 1175 ,@(when (sys::get-loaded-from f) 1176 (list `(:label "Defined in: ") 1177 `(:value ,(sys::get-loaded-from f) ,(namestring (sys::get-loaded-from f))) 1178 '(:newline))) 1179 ;; I think this should work in older lisps too -- alanr 1180 ,@(let ((fields (jcall "getDeclaredFields" (jcall "getClass" f)))) 1181 (when (plusp (length fields)) 1182 (list* '(:label "Internal fields: ") '(:newline) 1183 (loop for field across fields 1184 do (jcall "setAccessible" field t) ;;; not a great idea esp. wrt. Java9 1185 append 1186 (let ((value (jcall "get" field f))) 1187 (list " " 1188 `(:label ,(jcall "getName" field)) 1189 ": " 1190 `(:value ,value ,(princ-to-string value)) 1191 '(:newline))))))) 1192 #+abcl-introspect 1193 ,@(when (and (function-name f) (symbolp (function-name f)) 1194 (eq (symbol-package (function-name f)) (find-package :cl))) 1195 (list '(:newline) (list :action "Lookup in hyperspec" 1196 (lambda () (hyperspec-do (symbol-name (function-name f)))) 1197 :refreshp nil) 1198 '(:newline))))) 1199 1200 (defmethod emacs-inspect ((o java:java-object)) 1201 (if (jinstance-of-p o (jclass "java.lang.Class")) 1202 (emacs-inspect-java-class o) 1203 (emacs-inspect-java-object o))) 1204 1205 (defvar *sly-tostring-on-demand* nil 1206 "Set to t if you don't want to automatically show toString() for java objects and instead have inspector action to compute") 1207 1208 (defun static-field? (field) 1209 ;; (plusp (logand #"reflect.Modifier.STATIC" (jcall "getModifiers" field))) 1210 ;; ugly replace with answer to avoid using jss 1211 (plusp (logand 8 (jcall "getModifiers" field)))) 1212 1213 (defun inspector-java-object-fields (object) 1214 (loop 1215 for super = (java::jobject-class object) then (jclass-superclass super) 1216 while super 1217 ;;; NOTE: In the next line, if I write #'(lambda.... then I 1218 ;;; get an error compiling "Attempt to throw to the 1219 ;;; nonexistent tag DUPLICATABLE-CODE-P.". WTF 1220 for fields 1221 = (sort (jcall "getDeclaredFields" super) 'string-lessp :key (lambda(x) (jcall "getName" x))) 1222 for fromline 1223 = nil then (list `(:label "From: ") `(:value ,super ,(jcall "getName" super)) '(:newline)) 1224 when (and (plusp (length fields)) fromline) 1225 append fromline 1226 append 1227 (loop for this across fields 1228 for value = (jcall "get" (progn (jcall "setAccessible" this t) this) object) 1229 for line = `(" " (:label ,(jcall "getName" this)) ": " (:value ,value) (:newline)) 1230 if (static-field? this) 1231 append line into statics 1232 else append line into members 1233 finally (return (append 1234 (if members `((:label "Member fields: ") (:newline) ,@members)) 1235 (if statics `((:label "Static fields: ") (:newline) ,@statics))))))) 1236 1237 (defun emacs-inspect-java-object (object) 1238 (let ((to-string (lambda () 1239 (handler-case 1240 (setf (gethash object *to-string-hashtable*) 1241 (jcall "toString" object)) 1242 (t (e) 1243 (setf (gethash object *to-string-hashtable*) 1244 (format nil 1245 "Could not invoke toString(): ~A" 1246 e)))))) 1247 (intended-class (cdr (assoc "intendedClass" (sys::inspected-parts object) 1248 :test 'equal)))) 1249 `((:label "Class: ") 1250 (:value ,(jcall "getClass" object) ,(jcall "getName" (jcall "getClass" object) )) (:newline) 1251 ,@(if (and intended-class (not (equal intended-class (jcall "getName" (jcall "getClass" object))))) 1252 `((:label "Intended Class: ") 1253 (:value ,(jclass intended-class) ,intended-class) (:newline))) 1254 ,@(if (or (gethash object *to-string-hashtable*) (not *sly-tostring-on-demand*)) 1255 (label-value-line "toString()" (funcall to-string)) 1256 `((:action "[compute toString()]" ,to-string) (:newline))) 1257 ,@(inspector-java-object-fields object)))) 1258 1259 (defmethod emacs-inspect ((slot mop::slot-definition)) 1260 `("Name: " 1261 (:value ,(mop:slot-definition-name slot)) 1262 (:newline) 1263 "Documentation:" (:newline) 1264 ,@(when (slot-definition-documentation slot) 1265 `((:value ,(slot-definition-documentation slot)) (:newline))) 1266 (:label "Initialization:") (:newline) 1267 (:label " Args: ") (:value ,(mop:slot-definition-initargs slot)) (:newline) 1268 (:label " Form: ") 1269 ,(if (mop:slot-definition-initfunction slot) 1270 `(:value ,(mop:slot-definition-initform slot)) 1271 "#<unspecified>") (:newline) 1272 " Function: " 1273 (:value ,(mop:slot-definition-initfunction slot)) 1274 (:newline))) 1275 1276 (defun inspector-java-fields (class) 1277 (loop 1278 for super 1279 = class then (jclass-superclass super) 1280 while super 1281 for fields 1282 = (jcall "getDeclaredFields" super) 1283 for fromline 1284 = nil then (list `(:label "From: ") `(:value ,super ,(jcall "getName" super)) '(:newline)) 1285 when (and (plusp (length fields)) fromline) 1286 append fromline 1287 append 1288 (loop for this across fields 1289 for pre = (subseq (jcall "toString" this) 1290 0 1291 (1+ (position #\. (jcall "toString" this) :from-end t))) 1292 collect " " 1293 collect (list :value this pre) 1294 collect (list :value this (jcall "getName" this) ) 1295 collect '(:newline)))) 1296 1297 (defun inspector-java-methods (class) 1298 (loop 1299 for super 1300 = class then (jclass-superclass super) 1301 while super 1302 for methods 1303 = (jcall "getDeclaredMethods" super) 1304 for fromline 1305 = nil then (list `(:label "From: ") `(:value ,super ,(jcall "getName" super)) '(:newline)) 1306 when (and (plusp (length methods)) fromline) 1307 append fromline 1308 append 1309 (loop for this across methods 1310 for desc = (jcall "toString" this) 1311 for paren = (position #\( desc) 1312 for dot = (position #\. (subseq desc 0 paren) :from-end t) 1313 for pre = (subseq desc 0 dot) 1314 for name = (subseq desc dot paren) 1315 for after = (subseq desc paren) 1316 collect " " 1317 collect (list :value this pre) 1318 collect (list :value this name) 1319 collect (list :value this after) 1320 collect '(:newline)))) 1321 1322 (defun emacs-inspect-java-class (class) 1323 (let ((has-superclasses (jclass-superclass class)) 1324 (has-interfaces (plusp (length (jclass-interfaces class)))) 1325 (fields (inspector-java-fields class)) 1326 (path (jcall "replaceFirst" 1327 (jcall "replaceFirst" 1328 (jcall "toString" (jcall "getResource" 1329 class 1330 (concatenate 'string 1331 "/" (substitute #\/ #\. (jcall "getName" class)) 1332 ".class"))) 1333 "jar:file:" "") "!.*" ""))) 1334 `((:label ,(format nil "Java Class: ~a" (jcall "getName" class) )) 1335 (:newline) 1336 ,@(when path (list `(:label ,"Loaded from: ") 1337 `(:value ,path) 1338 " " 1339 `(:action "[open in emacs buffer]" ,(lambda() (slynk::ed-in-emacs `( ,path)))) '(:newline))) 1340 ,@(if has-superclasses 1341 (list* '(:label "Superclasses: ") (butlast (loop for super = (jclass-superclass class) then (jclass-superclass super) 1342 while super collect (list :value super (jcall "getName" super)) collect ", ")))) 1343 ,@(if has-interfaces 1344 (list* '(:newline) '(:label "Implements Interfaces: ") 1345 (butlast (loop for i across (jclass-interfaces class) collect (list :value i (jcall "getName" i)) collect ", ")))) 1346 (:newline) (:label "Methods:") (:newline) 1347 ,@(inspector-java-methods class) 1348 ,@(if fields 1349 (list* 1350 '(:newline) '(:label "Fields:") '(:newline) 1351 fields))))) 1352 1353 (defmethod emacs-inspect ((object sys::structure-object)) 1354 `((:label "Type: ") (:value ,(type-of object)) (:newline) 1355 (:label "Class: ") (:value ,(class-of object)) (:newline) 1356 ,@(inspector-structure-slot-names-and-values object))) 1357 1358 (defun inspector-structure-slot-names-and-values (structure) 1359 (let ((structure-def (get (type-of structure) 'system::structure-definition))) 1360 (if structure-def 1361 `((:label "Slots: ") (:newline) 1362 ,@(loop for slotdef in (sys::dd-slots structure-def) 1363 for name = (sys::dsd-name slotdef) 1364 for reader = (sys::dsd-reader slotdef) 1365 for value = (eval `(,reader ,structure)) 1366 append 1367 `(" " (:label ,(string-downcase (string name))) ": " (:value ,value) (:newline)))) 1368 `("No slots available for inspection.")))) 1369 1370 (defmethod emacs-inspect ((object sys::structure-class)) 1371 (let* ((name (jss::get-java-field object "name" t)) 1372 (def (get name 'system::structure-definition))) 1373 `((:label "Class: ") (:value ,object) (:newline) 1374 (:label "Raw defstruct definition: ") (:value ,def ,(let ((*print-array* nil)) (prin1-to-string def))) (:newline) 1375 ,@(parts-for-structure-def name) 1376 ;; copy-paste from slynk fancy inspector 1377 ,@(when (slynk-mop:specializer-direct-methods object) 1378 `((:label "It is used as a direct specializer in the following methods:") 1379 (:newline) 1380 ,@(loop 1381 for method in (specializer-direct-methods object) 1382 for method-spec = (slynk::method-for-inspect-value method) 1383 collect " " 1384 collect `(:value ,method ,(string-downcase (string (car method-spec)))) 1385 collect `(:value ,method ,(format nil " (~{~a~^ ~})" (cdr method-spec))) 1386 append (let ((method method)) 1387 `(" " (:action "[remove]" 1388 ,(lambda () (remove-method (slynk-mop::method-generic-function method) method))))) 1389 collect '(:newline) 1390 if (documentation method t) 1391 collect " Documentation: " and 1392 collect (slynk::abbrev-doc (documentation method t)) and 1393 collect '(:newline))))))) 1394 1395 (defun parts-for-structure-def-slot (def) 1396 `((:label ,(string-downcase (sys::dsd-name def))) " reader: " (:value ,(sys::dsd-reader def) ,(string-downcase (string (sys::dsdreader def)))) 1397 ", index: " (:value ,(sys::dsd-index def)) 1398 ,@(if (sys::dsd-initform def) 1399 `(", initform: " (:value ,(sys::dsd-initform def)))) 1400 ,@(if (sys::dsd-read-only def) 1401 '(", Read only")))) 1402 1403 (defun parts-for-structure-def (name) 1404 (let ((structure-def (get name 'system::structure-definition ))) 1405 (append 1406 (loop for accessor in '(dd-name dd-conc-name dd-default-constructor dd-constructors dd-copier dd-include dd-type 1407 dd-named dd-initial-offset dd-predicate dd-print-function dd-print-object 1408 dd-inherited-accessors) 1409 for key = (intern (subseq (string accessor) 3) 'keyword) 1410 for fsym = (find-symbol (string accessor) 'system) 1411 for value = (eval `(,fsym ,structure-def)) 1412 append `((:label ,(string-capitalize (string key))) ": " (:value ,value) (:newline))) 1413 (let* ((direct (sys::dd-direct-slots structure-def) ) 1414 (all (sys::dd-slots structure-def)) 1415 (inherited (set-difference all direct))) 1416 `((:label "Direct slots: ") (:newline) 1417 ,@(loop for slotdef in direct 1418 append `(" " ,@(parts-for-structure-def-slot slotdef) 1419 (:newline))) 1420 ,@(if inherited 1421 (append '((:label "Inherited slots: ") (:newline)) 1422 (loop for slotdef in inherited 1423 append `(" " (:label ,(string-downcase (string (sys::dsd-name slotdef)))) 1424 (:value ,slotdef "slot definition") 1425 (:newline)))))))))) 1426 1427 ;;;; Multithreading 1428 1429 (defimplementation spawn (fn &key name) 1430 (threads:make-thread (lambda () (funcall fn)) :name name)) 1431 1432 (defvar *thread-plists* (make-hash-table) ; should be a weak table 1433 "A hashtable mapping threads to a plist.") 1434 1435 (defvar *thread-id-counter* 0) 1436 1437 (defimplementation thread-id (thread) 1438 (threads:synchronized-on *thread-plists* 1439 (or (getf (gethash thread *thread-plists*) 'id) 1440 (setf (getf (gethash thread *thread-plists*) 'id) 1441 (incf *thread-id-counter*))))) 1442 1443 (defimplementation find-thread (id) 1444 (find id (all-threads) 1445 :key (lambda (thread) 1446 (getf (gethash thread *thread-plists*) 'id)))) 1447 1448 (defimplementation thread-name (thread) 1449 (threads:thread-name thread)) 1450 1451 (defimplementation thread-status (thread) 1452 (format nil "Thread is ~:[dead~;alive~]" (threads:thread-alive-p thread))) 1453 1454 (defimplementation make-lock (&key name) 1455 (declare (ignore name)) 1456 (threads:make-thread-lock)) 1457 1458 (defimplementation call-with-lock-held (lock function) 1459 (threads:with-thread-lock (lock) (funcall function))) 1460 1461 (defimplementation current-thread () 1462 (threads:current-thread)) 1463 1464 (defimplementation all-threads () 1465 (copy-list (threads:mapcar-threads #'identity))) 1466 1467 (defimplementation thread-alive-p (thread) 1468 (member thread (all-threads))) 1469 1470 (defimplementation interrupt-thread (thread fn) 1471 (threads:interrupt-thread thread fn)) 1472 1473 (defimplementation kill-thread (thread) 1474 (threads:destroy-thread thread)) 1475 1476 (defstruct mailbox 1477 (queue '())) 1478 1479 (defun mailbox (thread) 1480 "Return THREAD's mailbox." 1481 (threads:synchronized-on *thread-plists* 1482 (or (getf (gethash thread *thread-plists*) 'mailbox) 1483 (setf (getf (gethash thread *thread-plists*) 'mailbox) 1484 (make-mailbox))))) 1485 1486 (defimplementation send (thread message) 1487 (let ((mbox (mailbox thread))) 1488 (threads:synchronized-on mbox 1489 (setf (mailbox-queue mbox) 1490 (nconc (mailbox-queue mbox) (list message))) 1491 (threads:object-notify-all mbox)))) 1492 1493 (defimplementation receive-if (test &optional timeout) 1494 (let* ((mbox (mailbox (current-thread)))) 1495 (assert (or (not timeout) (eq timeout t))) 1496 (loop 1497 (check-sly-interrupts) 1498 (threads:synchronized-on mbox 1499 (let* ((q (mailbox-queue mbox)) 1500 (tail (member-if test q))) 1501 (when tail 1502 (setf (mailbox-queue mbox) (nconc (ldiff q tail) (cdr tail))) 1503 (return (car tail))) 1504 (when (eq timeout t) (return (values nil t))) 1505 (threads:object-wait mbox 0.3)))))) 1506 1507 (defimplementation quit-lisp () 1508 (ext:exit)) 1509 1510 ;; FIXME probably should be promoted to other lisps but I don't want to mess with them 1511 (defvar *inspector-print-case* *print-case*) 1512 1513 (defimplementation call-with-syntax-hooks (fn) 1514 (let ((*print-case* *inspector-print-case*)) 1515 (funcall fn))) 1516 1517 ;;; 1518 #+#.(slynk/backend:with-symbol 'package-local-nicknames 'ext) 1519 (defimplementation package-local-nicknames (package) 1520 (ext:package-local-nicknames package)) 1521 1522 ;; all the defimplentations aren't compiled. Compile them. Set their 1523 ;; function name to be the same as the implementation name so 1524 ;; meta-. works. 1525 1526 #+abcl-introspect 1527 (eval-when (:load-toplevel :execute) 1528 (loop for s in slynk-backend::*interface-functions* 1529 for impl = (get s 'slynk-backend::implementation) 1530 do (when (and impl (not (compiled-function-p impl))) 1531 (let ((name (gensym))) 1532 (compile name impl) 1533 (let ((compiled (symbol-function name))) 1534 (system::%set-lambda-name compiled (second (sys::lambda-name impl))) 1535 (setf (get s 'slynk-backend::implementation) compiled)))))) 1536