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