lispworks.lisp (37098B)
1 ;;; -*- indent-tabs-mode: nil -*- 2 ;;; 3 ;;; slynk-lispworks.lisp --- LispWorks specific code for SLIME. 4 ;;; 5 ;;; Created 2003, Helmut Eller 6 ;;; 7 ;;; This code has been placed in the Public Domain. All warranties 8 ;;; are disclaimed. 9 ;;; 10 11 (defpackage slynk-lispworks 12 (:use cl slynk-backend)) 13 14 (in-package slynk-lispworks) 15 16 (eval-when (:compile-toplevel :load-toplevel :execute) 17 (require "comm")) 18 19 (defimplementation gray-package-name () 20 "STREAM") 21 22 (import-slynk-mop-symbols :clos '(:slot-definition-documentation 23 :slot-boundp-using-class 24 :slot-value-using-class 25 :slot-makunbound-using-class 26 :eql-specializer 27 :eql-specializer-object 28 :compute-applicable-methods-using-classes)) 29 30 (defun slynk-mop:slot-definition-documentation (slot) 31 (documentation slot t)) 32 33 (defun slynk-mop:slot-boundp-using-class (class object slotd) 34 (clos:slot-boundp-using-class class object 35 (clos:slot-definition-name slotd))) 36 37 (defun slynk-mop:slot-value-using-class (class object slotd) 38 (clos:slot-value-using-class class object 39 (clos:slot-definition-name slotd))) 40 41 (defun (setf slynk-mop:slot-value-using-class) (value class object slotd) 42 (setf (clos:slot-value-using-class class object 43 (clos:slot-definition-name slotd)) 44 value)) 45 46 (defun slynk-mop:slot-makunbound-using-class (class object slotd) 47 (clos:slot-makunbound-using-class class object 48 (clos:slot-definition-name slotd))) 49 50 (defun slynk-mop:compute-applicable-methods-using-classes (gf classes) 51 (clos::compute-applicable-methods-from-classes gf classes)) 52 53 ;; lispworks doesn't have the eql-specializer class, it represents 54 ;; them as a list of `(EQL ,OBJECT) 55 (deftype slynk-mop:eql-specializer () 'cons) 56 57 (defun slynk-mop:eql-specializer-object (eql-spec) 58 (second eql-spec)) 59 60 (eval-when (:compile-toplevel :execute :load-toplevel) 61 (defvar *original-defimplementation* (macro-function 'defimplementation)) 62 (defmacro defimplementation (&whole whole name args &body body 63 &environment env) 64 (declare (ignore args body)) 65 `(progn 66 (dspec:record-definition '(defun ,name) (dspec:location) 67 :check-redefinition-p nil) 68 ,(funcall *original-defimplementation* whole env)))) 69 70 ;;; UTF8 71 72 (defimplementation string-to-utf8 (string) 73 (ef:encode-lisp-string string '(:utf-8 :eol-style :lf))) 74 75 (defimplementation utf8-to-string (octets) 76 (ef:decode-external-string octets '(:utf-8 :eol-style :lf))) 77 78 ;;; TCP server 79 80 (defimplementation preferred-communication-style () 81 :spawn) 82 83 (defun socket-fd (socket) 84 (etypecase socket 85 (fixnum socket) 86 (comm:socket-stream (comm:socket-stream-socket socket)))) 87 88 (defimplementation create-socket (host port &key backlog) 89 (multiple-value-bind (socket where errno) 90 #-(or lispworks4.1 (and macosx lispworks4.3)) 91 (comm::create-tcp-socket-for-service port :address host 92 :backlog (or backlog 5)) 93 #+(or lispworks4.1 (and macosx lispworks4.3)) 94 (comm::create-tcp-socket-for-service port) 95 (cond (socket socket) 96 (t (error 'network-error 97 :format-control "~A failed: ~A (~D)" 98 :format-arguments (list where 99 (list #+unix (lw:get-unix-error errno)) 100 errno)))))) 101 102 (defimplementation local-port (socket) 103 (nth-value 1 (comm:get-socket-address (socket-fd socket)))) 104 105 (defimplementation close-socket (socket) 106 (comm::close-socket (socket-fd socket))) 107 108 (defimplementation accept-connection (socket 109 &key external-format buffering timeout) 110 (declare (ignore buffering)) 111 (let* ((fd (comm::get-fd-from-socket socket))) 112 (assert (/= fd -1)) 113 (cond ((not external-format) 114 (make-instance 'comm:socket-stream 115 :socket fd 116 :direction :io 117 :read-timeout timeout 118 :element-type '(unsigned-byte 8))) 119 (t 120 (assert (valid-external-format-p external-format)) 121 (ecase (first external-format) 122 ((:latin-1 :ascii) 123 (make-instance 'comm:socket-stream 124 :socket fd 125 :direction :io 126 :read-timeout timeout 127 :element-type 'base-char)) 128 (:utf-8 129 (make-flexi-stream 130 (make-instance 'comm:socket-stream 131 :socket fd 132 :direction :io 133 :read-timeout timeout 134 :element-type '(unsigned-byte 8)) 135 external-format))))))) 136 137 (defun make-flexi-stream (stream external-format) 138 (unless (member :flexi-streams *features*) 139 (error "Cannot use external format ~A~ 140 without having installed flexi-streams in the inferior-lisp." 141 external-format)) 142 (funcall (read-from-string "FLEXI-STREAMS:MAKE-FLEXI-STREAM") 143 stream 144 :external-format 145 (apply (read-from-string "FLEXI-STREAMS:MAKE-EXTERNAL-FORMAT") 146 external-format))) 147 148 ;;; Coding Systems 149 150 (defun valid-external-format-p (external-format) 151 (member external-format *external-format-to-coding-system* 152 :test #'equal :key #'car)) 153 154 (defvar *external-format-to-coding-system* 155 '(((:latin-1 :eol-style :lf) 156 "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix") 157 ;;((:latin-1) "latin-1" "iso-latin-1" "iso-8859-1") 158 ;;((:utf-8) "utf-8") 159 ((:utf-8 :eol-style :lf) "utf-8-unix") 160 ;;((:euc-jp) "euc-jp") 161 ((:euc-jp :eol-style :lf) "euc-jp-unix") 162 ;;((:ascii) "us-ascii") 163 ((:ascii :eol-style :lf) "us-ascii-unix"))) 164 165 (defimplementation find-external-format (coding-system) 166 (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) 167 *external-format-to-coding-system*))) 168 169 ;;; Unix signals 170 171 (defun sigint-handler () 172 (with-simple-restart (continue "Continue from SIGINT handler.") 173 (invoke-debugger "SIGINT"))) 174 175 (defun make-sigint-handler (process) 176 (lambda (&rest args) 177 (declare (ignore args)) 178 (mp:process-interrupt process #'sigint-handler))) 179 180 (defun set-sigint-handler () 181 ;; Set SIGINT handler on Slynk request handler thread. 182 #-win32 183 (sys::set-signal-handler +sigint+ 184 (make-sigint-handler mp:*current-process*))) 185 186 #-win32 187 (defimplementation install-sigint-handler (handler) 188 (sys::set-signal-handler +sigint+ 189 (let ((self mp:*current-process*)) 190 (lambda (&rest args) 191 (declare (ignore args)) 192 (mp:process-interrupt self handler))))) 193 194 (defimplementation getpid () 195 #+win32 (win32:get-current-process-id) 196 #-win32 (system::getpid)) 197 198 (defimplementation lisp-implementation-type-name () 199 "lispworks") 200 201 (defimplementation set-default-directory (directory) 202 (namestring (hcl:change-directory directory))) 203 204 ;;;; Documentation 205 206 (defun map-list (function list) 207 "Map over proper and not proper lists." 208 (loop for (car . cdr) on list 209 collect (funcall function car) into result 210 when (null cdr) return result 211 when (atom cdr) return (nconc result (funcall function cdr)))) 212 213 (defun replace-strings-with-symbols (tree) 214 (map-list 215 (lambda (x) 216 (typecase x 217 (list 218 (replace-strings-with-symbols x)) 219 (symbol 220 x) 221 (string 222 (intern x)) 223 (t 224 (intern (write-to-string x))))) 225 tree)) 226 227 (defimplementation arglist (symbol-or-function) 228 (let ((arglist (lw:function-lambda-list symbol-or-function))) 229 (etypecase arglist 230 ((member :dont-know) 231 :not-available) 232 (list 233 (replace-strings-with-symbols arglist))))) 234 235 (defimplementation function-name (function) 236 (nth-value 2 (function-lambda-expression function))) 237 238 (defimplementation macroexpand-all (form &optional env) 239 (declare (ignore env)) 240 (walker:walk-form form)) 241 242 (defun generic-function-p (object) 243 (typep object 'generic-function)) 244 245 (defimplementation describe-symbol-for-emacs (symbol) 246 "Return a plist describing SYMBOL. 247 Return NIL if the symbol is unbound." 248 (let ((result '())) 249 (labels ((first-line (string) 250 (let ((pos (position #\newline string))) 251 (if (null pos) string (subseq string 0 pos)))) 252 (doc (kind &optional (sym symbol)) 253 (let ((string (or (documentation sym kind)))) 254 (if string 255 (first-line string) 256 :not-documented))) 257 (maybe-push (property value) 258 (when value 259 (setf result (list* property value result))))) 260 (maybe-push 261 :variable (when (boundp symbol) 262 (doc 'variable))) 263 (maybe-push 264 :generic-function (if (and (fboundp symbol) 265 (generic-function-p (fdefinition symbol))) 266 (doc 'function))) 267 (maybe-push 268 :function (if (and (fboundp symbol) 269 (not (generic-function-p (fdefinition symbol)))) 270 (doc 'function))) 271 (maybe-push 272 :setf (let ((setf-name (sys:underlying-setf-name `(setf ,symbol)))) 273 (if (fboundp setf-name) 274 (doc 'setf)))) 275 (maybe-push 276 :class (if (find-class symbol nil) 277 (doc 'class))) 278 result))) 279 280 (defimplementation describe-definition (symbol type) 281 (ecase type 282 (:variable (describe-symbol symbol)) 283 (:class (describe (find-class symbol))) 284 ((:function :generic-function) (describe-function symbol)) 285 (:setf (describe-function (sys:underlying-setf-name `(setf ,symbol)))))) 286 287 (defun describe-function (symbol) 288 (cond ((fboundp symbol) 289 (format t "(~A ~/pprint-fill/)~%~%~:[(not documented)~;~:*~A~]~%" 290 symbol 291 (lispworks:function-lambda-list symbol) 292 (documentation symbol 'function)) 293 (describe (fdefinition symbol))) 294 (t (format t "~S is not fbound" symbol)))) 295 296 (defun describe-symbol (sym) 297 (format t "~A is a symbol in package ~A." sym (symbol-package sym)) 298 (when (boundp sym) 299 (format t "~%~%Value: ~A" (symbol-value sym))) 300 (let ((doc (documentation sym 'variable))) 301 (when doc 302 (format t "~%~%Variable documentation:~%~A" doc))) 303 (when (fboundp sym) 304 (describe-function sym))) 305 306 (defimplementation type-specifier-p (symbol) 307 (or (ignore-errors 308 (subtypep nil symbol)) 309 (not (eq (type-specifier-arglist symbol) :not-available)))) 310 311 ;;; Debugging 312 313 (defclass sly-env (env:environment) 314 ((debugger-hook :initarg :debugger-hoook))) 315 316 (defun sly-env (hook io-bindings) 317 (make-instance 'sly-env :name "SLY Environment" 318 :io-bindings io-bindings 319 :debugger-hoook hook)) 320 321 (defmethod env-internals:environment-display-notifier 322 ((env sly-env) &key restarts condition) 323 (declare (ignore restarts condition)) 324 (funcall (slynk-sym :slynk-debugger-hook) condition *debugger-hook*) 325 ;; nil 326 ) 327 328 (defmethod env-internals:environment-display-debugger ((env sly-env)) 329 *debug-io*) 330 331 (defmethod env-internals:confirm-p ((e sly-env) &optional msg &rest args) 332 (apply (slynk-sym :y-or-n-p-in-emacs) msg args)) 333 334 (defimplementation call-with-debugger-hook (hook fun) 335 (let ((*debugger-hook* hook)) 336 (env:with-environment ((sly-env hook '())) 337 (funcall fun)))) 338 339 (defimplementation install-debugger-globally (function) 340 (setq *debugger-hook* function) 341 (setf (env:environment) (sly-env function '()))) 342 343 (defvar *sly-db-top-frame*) 344 345 (defun interesting-frame-p (frame) 346 (cond ((or (dbg::call-frame-p frame) 347 (dbg::derived-call-frame-p frame) 348 (dbg::foreign-frame-p frame) 349 (dbg::interpreted-call-frame-p frame)) 350 t) 351 ((dbg::catch-frame-p frame) dbg:*print-catch-frames*) 352 ((dbg::binding-frame-p frame) dbg:*print-binding-frames*) 353 ((dbg::handler-frame-p frame) dbg:*print-handler-frames*) 354 ((dbg::restart-frame-p frame) dbg:*print-restart-frames*) 355 (t nil))) 356 357 (defun nth-next-frame (frame n) 358 "Unwind FRAME N times." 359 (do ((frame frame (dbg::frame-next frame)) 360 (i n (if (interesting-frame-p frame) (1- i) i))) 361 ((or (not frame) 362 (and (interesting-frame-p frame) (zerop i))) 363 frame))) 364 365 (defun nth-frame (index) 366 (nth-next-frame *sly-db-top-frame* index)) 367 368 (defun find-top-frame () 369 "Return the most suitable top-frame for the debugger." 370 (flet ((find-named-frame (name) 371 (do ((frame (dbg::debugger-stack-current-frame 372 dbg::*debugger-stack*) 373 (nth-next-frame frame 1))) 374 ((or (null frame) ; no frame found! 375 (and (dbg::call-frame-p frame) 376 (eq (dbg::call-frame-function-name frame) 377 name))) 378 (nth-next-frame frame 1))))) 379 (or (find-named-frame 'invoke-debugger) 380 (find-named-frame (slynk-sym :safe-backtrace)) 381 ;; if we can't find a likely top frame, take any old frame 382 ;; at the top 383 (dbg::debugger-stack-current-frame dbg::*debugger-stack*)))) 384 385 (defimplementation call-with-debugging-environment (fn) 386 (dbg::with-debugger-stack () 387 (let ((*sly-db-top-frame* (find-top-frame))) 388 (funcall fn)))) 389 390 (defimplementation compute-backtrace (start end) 391 (let ((end (or end most-positive-fixnum)) 392 (backtrace '())) 393 (do ((frame (nth-frame start) (dbg::frame-next frame)) 394 (i start)) 395 ((or (not frame) (= i end)) (nreverse backtrace)) 396 (when (interesting-frame-p frame) 397 (incf i) 398 (push frame backtrace))))) 399 400 (defun frame-actual-args (frame) 401 (let ((*break-on-signals* nil) 402 (kind nil)) 403 (loop for arg in (dbg::call-frame-arglist frame) 404 if (eq kind '&rest) 405 nconc (handler-case 406 (dbg::dbg-eval arg frame) 407 (error (e) (list (format nil "<~A>" arg)))) 408 and do (loop-finish) 409 else 410 if (member arg '(&rest &optional &key)) 411 do (setq kind arg) 412 else 413 nconc 414 (handler-case 415 (nconc (and (eq kind '&key) 416 (list (cond ((symbolp arg) 417 (intern (symbol-name arg) :keyword)) 418 ((and (consp arg) (symbolp (car arg))) 419 (intern (symbol-name (car arg)) 420 :keyword)) 421 (t (caar arg))))) 422 (list (dbg::dbg-eval 423 (cond ((symbolp arg) arg) 424 ((and (consp arg) (symbolp (car arg))) 425 (car arg)) 426 (t (cadar arg))) 427 frame))) 428 (error (e) (list (format nil "<~A>" arg))))))) 429 430 (defimplementation print-frame (frame stream) 431 (cond ((dbg::call-frame-p frame) 432 (prin1 (cons (dbg::call-frame-function-name frame) 433 (frame-actual-args frame)) 434 stream)) 435 (t (princ frame stream)))) 436 437 (defun frame-vars (frame) 438 (first (dbg::frame-locals-format-list frame #'list 75 0))) 439 440 (defimplementation frame-locals (n) 441 (let ((frame (nth-frame n))) 442 (if (dbg::call-frame-p frame) 443 (mapcar (lambda (var) 444 (destructuring-bind (name value symbol location) var 445 (declare (ignore name location)) 446 (list :name symbol :id 0 447 :value value))) 448 (frame-vars frame))))) 449 450 (defimplementation frame-var-value (frame var) 451 (let ((frame (nth-frame frame))) 452 (destructuring-bind (_n value _s _l) (nth var (frame-vars frame)) 453 (declare (ignore _n _s _l)) 454 value))) 455 456 (defimplementation frame-source-location (frame) 457 (let ((frame (nth-frame frame)) 458 (callee (if (plusp frame) (nth-frame (1- frame))))) 459 (if (dbg::call-frame-p frame) 460 (let ((dspec (dbg::call-frame-function-name frame)) 461 (cname (and (dbg::call-frame-p callee) 462 (dbg::call-frame-function-name callee))) 463 (path (and (dbg::call-frame-p frame) 464 (dbg::call-frame-edit-path frame)))) 465 (if dspec 466 (frame-location dspec cname path)))))) 467 468 (defimplementation eval-in-frame (form frame-number) 469 (let ((frame (nth-frame frame-number))) 470 (dbg::dbg-eval form frame))) 471 472 (defun function-name-package (name) 473 (typecase name 474 (null nil) 475 (symbol (symbol-package name)) 476 ((cons (eql hcl:subfunction)) 477 (destructuring-bind (name parent) (cdr name) 478 (declare (ignore name)) 479 (function-name-package parent))) 480 ((cons (eql lw:top-level-form)) nil) 481 (t nil))) 482 483 (defimplementation frame-package (frame-number) 484 (let ((frame (nth-frame frame-number))) 485 (if (dbg::call-frame-p frame) 486 (function-name-package (dbg::call-frame-function-name frame))))) 487 488 (defimplementation return-from-frame (frame-number form) 489 (let* ((frame (nth-frame frame-number)) 490 (return-frame (dbg::find-frame-for-return frame))) 491 (dbg::dbg-return-from-call-frame frame form return-frame 492 dbg::*debugger-stack*))) 493 494 (defimplementation restart-frame (frame-number) 495 (let ((frame (nth-frame frame-number))) 496 (dbg::restart-frame frame :same-args t))) 497 498 (defimplementation disassemble-frame (frame-number) 499 (let* ((frame (nth-frame frame-number))) 500 (when (dbg::call-frame-p frame) 501 (let ((function (dbg::get-call-frame-function frame))) 502 (disassemble function))))) 503 504 ;;; Definition finding 505 506 (defun frame-location (dspec callee-name edit-path) 507 (let ((infos (dspec:find-dspec-locations dspec))) 508 (cond (infos 509 (destructuring-bind ((rdspec location) &rest _) infos 510 (declare (ignore _)) 511 (let ((name (and callee-name (symbolp callee-name) 512 (string callee-name))) 513 (path (edit-path-to-cmucl-source-path edit-path))) 514 (make-dspec-location rdspec location 515 `(:call-site ,name :edit-path ,path))))) 516 (t 517 (list :error (format nil "Source location not available for: ~S" 518 dspec)))))) 519 520 ;; dbg::call-frame-edit-path is not documented but lets assume the 521 ;; binary representation of the integer EDIT-PATH should be 522 ;; interpreted as a sequence of CAR or CDR. #b1111010 is roughly the 523 ;; same as cadadddr. Something is odd with the highest bit. 524 (defun edit-path-to-cmucl-source-path (edit-path) 525 (and edit-path 526 (cons 0 527 (let ((n -1)) 528 (loop for i from (1- (integer-length edit-path)) downto 0 529 if (logbitp i edit-path) do (incf n) 530 else collect (prog1 n (setq n 0))))))) 531 532 ;; (edit-path-to-cmucl-source-path #b1111010) => (0 3 1) 533 534 (defimplementation find-definitions (name) 535 (let ((locations (dspec:find-name-locations dspec:*dspec-classes* name))) 536 (loop for (dspec location) in locations 537 collect (list dspec (make-dspec-location dspec location))))) 538 539 540 ;;; Compilation 541 542 (defmacro with-slynk-compilation-unit ((location &rest options) &body body) 543 (lw:rebinding (location) 544 `(let ((compiler::*error-database* '())) 545 (with-compilation-unit ,options 546 (multiple-value-prog1 (progn ,@body) 547 (signal-error-data-base compiler::*error-database* 548 ,location) 549 (signal-undefined-functions compiler::*unknown-functions* 550 ,location)))))) 551 552 (defimplementation slynk-compile-file (input-file output-file 553 load-p external-format 554 &key policy) 555 (declare (ignore policy)) 556 (with-slynk-compilation-unit (input-file) 557 (compile-file input-file 558 :output-file output-file 559 :load load-p 560 :external-format external-format))) 561 562 (defvar *within-call-with-compilation-hooks* nil 563 "Whether COMPILE-FILE was called from within CALL-WITH-COMPILATION-HOOKS.") 564 565 (defvar *undefined-functions-hash* nil 566 "Hash table to map info about undefined functions to pathnames.") 567 568 (lw:defadvice (compile-file compile-file-and-collect-notes :around) 569 (pathname &rest rest) 570 (multiple-value-prog1 (apply #'lw:call-next-advice pathname rest) 571 (when *within-call-with-compilation-hooks* 572 (maphash (lambda (unfun dspecs) 573 (dolist (dspec dspecs) 574 (let ((unfun-info (list unfun dspec))) 575 (unless (gethash unfun-info *undefined-functions-hash*) 576 (setf (gethash unfun-info *undefined-functions-hash*) 577 pathname))))) 578 compiler::*unknown-functions*)))) 579 580 (defimplementation call-with-compilation-hooks (function) 581 (let ((compiler::*error-database* '()) 582 (*undefined-functions-hash* (make-hash-table :test 'equal)) 583 (*within-call-with-compilation-hooks* t)) 584 (with-compilation-unit () 585 (prog1 (funcall function) 586 (signal-error-data-base compiler::*error-database*) 587 (signal-undefined-functions compiler::*unknown-functions*))))) 588 589 (defun map-error-database (database fn) 590 (loop for (filename . defs) in database do 591 (loop for (dspec . conditions) in defs do 592 (dolist (c conditions) 593 (multiple-value-bind (condition path) 594 (if (consp c) (values (car c) (cdr c)) (values c nil)) 595 (funcall fn filename dspec condition path)))))) 596 597 (defun lispworks-severity (condition) 598 (cond ((not condition) :warning) 599 (t (etypecase condition 600 #-(or lispworks4 lispworks5) 601 (conditions:compiler-note :note) 602 (error :error) 603 (style-warning :warning) 604 (warning :warning))))) 605 606 (defun signal-compiler-condition (message location condition) 607 (check-type message string) 608 (signal 609 (make-instance 'compiler-condition :message message 610 :severity (lispworks-severity condition) 611 :location location 612 :original-condition condition))) 613 614 (defvar *temp-file-format* '(:utf-8 :eol-style :lf)) 615 616 (defun compile-from-temp-file (string filename) 617 (unwind-protect 618 (progn 619 (with-open-file (s filename :direction :output 620 :if-exists :supersede 621 :external-format *temp-file-format*) 622 623 (write-string string s) 624 (finish-output s)) 625 (multiple-value-bind (binary-filename warnings? failure?) 626 (compile-file filename :load t 627 :external-format *temp-file-format*) 628 (declare (ignore warnings?)) 629 (when binary-filename 630 (delete-file binary-filename)) 631 (not failure?))) 632 (delete-file filename))) 633 634 (defun dspec-function-name-position (dspec fallback) 635 (etypecase dspec 636 (cons (let ((name (dspec:dspec-primary-name dspec))) 637 (typecase name 638 ((or symbol string) 639 (list :function-name (string name))) 640 (t fallback)))) 641 (null fallback) 642 (symbol (list :function-name (string dspec))))) 643 644 (defmacro with-fairly-standard-io-syntax (&body body) 645 "Like WITH-STANDARD-IO-SYNTAX but preserve *PACKAGE* and *READTABLE*." 646 (let ((package (gensym)) 647 (readtable (gensym))) 648 `(let ((,package *package*) 649 (,readtable *readtable*)) 650 (with-standard-io-syntax 651 (let ((*package* ,package) 652 (*readtable* ,readtable)) 653 ,@body))))) 654 655 (defun skip-comments (stream) 656 (let ((pos0 (file-position stream))) 657 (cond ((equal (ignore-errors (list (read-delimited-list #\( stream))) 658 '(())) 659 (file-position stream (1- (file-position stream)))) 660 (t (file-position stream pos0))))) 661 662 #-(or lispworks4.1 lispworks4.2) ; no dspec:parse-form-dspec prior to 4.3 663 (defun dspec-stream-position (stream dspec) 664 (with-fairly-standard-io-syntax 665 (loop (let* ((pos (progn (skip-comments stream) (file-position stream))) 666 (form (read stream nil '#1=#:eof))) 667 (when (eq form '#1#) 668 (return nil)) 669 (labels ((check-dspec (form) 670 (when (consp form) 671 (let ((operator (car form))) 672 (case operator 673 ((progn) 674 (mapcar #'check-dspec 675 (cdr form))) 676 ((eval-when locally macrolet symbol-macrolet) 677 (mapcar #'check-dspec 678 (cddr form))) 679 ((in-package) 680 (let ((package (find-package (second form)))) 681 (when package 682 (setq *package* package)))) 683 (otherwise 684 (let ((form-dspec (dspec:parse-form-dspec form))) 685 (when (dspec:dspec-equal dspec form-dspec) 686 (return pos))))))))) 687 (check-dspec form)))))) 688 689 (defun dspec-file-position (file dspec) 690 (let* ((*compile-file-pathname* (pathname file)) 691 (*compile-file-truename* (truename *compile-file-pathname*)) 692 (*load-pathname* *compile-file-pathname*) 693 (*load-truename* *compile-file-truename*)) 694 (with-open-file (stream file) 695 (let ((pos 696 #-(or lispworks4.1 lispworks4.2) 697 (ignore-errors (dspec-stream-position stream dspec)))) 698 (if pos 699 (list :position (1+ pos)) 700 (dspec-function-name-position dspec `(:position 1))))))) 701 702 (defun emacs-buffer-location-p (location) 703 (and (consp location) 704 (eq (car location) :emacs-buffer))) 705 706 (defun make-dspec-location (dspec location &optional hints) 707 (etypecase location 708 ((or pathname string) 709 (multiple-value-bind (file err) 710 (ignore-errors (namestring (truename location))) 711 (if err 712 (list :error (princ-to-string err)) 713 (make-location `(:file ,file) 714 (dspec-file-position file dspec) 715 hints)))) 716 (symbol 717 `(:error ,(format nil "Cannot resolve location: ~S" location))) 718 ((satisfies emacs-buffer-location-p) 719 (destructuring-bind (_ buffer offset) location 720 (declare (ignore _)) 721 (make-location `(:buffer ,buffer) 722 (dspec-function-name-position dspec `(:offset ,offset 0)) 723 hints))))) 724 725 (defun make-dspec-progenitor-location (dspec location edit-path) 726 (let ((canon-dspec (dspec:canonicalize-dspec dspec))) 727 (make-dspec-location 728 (if canon-dspec 729 (if (dspec:local-dspec-p canon-dspec) 730 (dspec:dspec-progenitor canon-dspec) 731 canon-dspec) 732 nil) 733 location 734 (if edit-path 735 (list :edit-path (edit-path-to-cmucl-source-path edit-path)))))) 736 737 (defun signal-error-data-base (database &optional location) 738 (map-error-database 739 database 740 (lambda (filename dspec condition edit-path) 741 (signal-compiler-condition 742 (format nil "~A" condition) 743 (make-dspec-progenitor-location dspec (or location filename) edit-path) 744 condition)))) 745 746 (defun unmangle-unfun (symbol) 747 "Converts symbols like 'SETF::|\"CL-USER\" \"GET\"| to 748 function names like \(SETF GET)." 749 (cond ((sys::setf-symbol-p symbol) 750 (sys::setf-pair-from-underlying-name symbol)) 751 (t symbol))) 752 753 (defun signal-undefined-functions (htab &optional filename) 754 (maphash (lambda (unfun dspecs) 755 (dolist (dspec dspecs) 756 (signal-compiler-condition 757 (format nil "Undefined function ~A" (unmangle-unfun unfun)) 758 (make-dspec-progenitor-location 759 dspec 760 (or filename 761 (gethash (list unfun dspec) *undefined-functions-hash*)) 762 nil) 763 nil))) 764 htab)) 765 766 (defimplementation slynk-compile-string (string &key buffer position filename 767 line column policy) 768 (declare (ignore filename line column policy)) 769 (assert buffer) 770 (assert position) 771 (let* ((location (list :emacs-buffer buffer position)) 772 (tmpname (hcl:make-temp-file nil "lisp"))) 773 (with-slynk-compilation-unit (location) 774 (compile-from-temp-file 775 (with-output-to-string (s) 776 (let ((*print-radix* t)) 777 (print `(eval-when (:compile-toplevel) 778 (setq dspec::*location* (list ,@location))) 779 s)) 780 (write-string string s)) 781 tmpname)))) 782 783 ;;; xref 784 785 (defmacro defxref (name function) 786 `(defimplementation ,name (name) 787 (xref-results (,function name)))) 788 789 (defxref who-calls hcl:who-calls) 790 (defxref who-macroexpands hcl:who-calls) ; macros are in the calls table too 791 (defxref calls-who hcl:calls-who) 792 (defxref list-callers list-callers-internal) 793 (defxref list-callees list-callees-internal) 794 795 (defun list-callers-internal (name) 796 (let ((callers (make-array 100 797 :fill-pointer 0 798 :adjustable t))) 799 (hcl:sweep-all-objects 800 #'(lambda (object) 801 (when (and #+Harlequin-PC-Lisp (low:compiled-code-p object) 802 #+Harlequin-Unix-Lisp (sys:callablep object) 803 #-(or Harlequin-PC-Lisp Harlequin-Unix-Lisp) 804 (sys:compiled-code-p object) 805 (system::find-constant$funcallable name object)) 806 (vector-push-extend object callers)))) 807 ;; Delay dspec:object-dspec until after sweep-all-objects 808 ;; to reduce allocation problems. 809 (loop for object across callers 810 collect (if (symbolp object) 811 (list 'function object) 812 (or (dspec:object-dspec object) object))))) 813 814 (defun list-callees-internal (name) 815 (let ((callees '())) 816 (system::find-constant$funcallable 817 'junk name 818 :test #'(lambda (junk constant) 819 (declare (ignore junk)) 820 (when (and (symbolp constant) 821 (fboundp constant)) 822 (pushnew (list 'function constant) callees :test 'equal)) 823 ;; Return nil so we iterate over all constants. 824 nil)) 825 callees)) 826 827 ;; only for lispworks 4.2 and above 828 #-lispworks4.1 829 (progn 830 (defxref who-references hcl:who-references) 831 (defxref who-binds hcl:who-binds) 832 (defxref who-sets hcl:who-sets)) 833 834 (defimplementation who-specializes (classname) 835 (let ((class (find-class classname nil))) 836 (when class 837 (let ((methods (clos:class-direct-methods class))) 838 (xref-results (mapcar #'dspec:object-dspec methods)))))) 839 840 (defun xref-results (dspecs) 841 (flet ((frob-locs (dspec locs) 842 (cond (locs 843 (loop for (name loc) in locs 844 collect (list name (make-dspec-location name loc)))) 845 (t `((,dspec (:error "Source location not available"))))))) 846 (loop for dspec in dspecs 847 append (frob-locs dspec (dspec:dspec-definition-locations dspec))))) 848 849 ;;; Inspector 850 851 (defmethod emacs-inspect ((o t)) 852 (lispworks-inspect o)) 853 854 (defmethod emacs-inspect ((o function)) 855 (lispworks-inspect o)) 856 857 ;; FIXME: slot-boundp-using-class in LW works with names so we can't 858 ;; use our method in slynk.lisp. 859 (defmethod emacs-inspect ((o standard-object)) 860 (lispworks-inspect o)) 861 862 (defun lispworks-inspect (o) 863 (multiple-value-bind (names values _getter _setter type) 864 (lw:get-inspector-values o nil) 865 (declare (ignore _getter _setter)) 866 (append 867 (label-value-line "Type" type) 868 (loop for name in names 869 for value in values 870 append (label-value-line name value))))) 871 872 ;;; Miscellaneous 873 874 (defimplementation quit-lisp () 875 (lispworks:quit)) 876 877 ;;; Tracing 878 879 (defun parse-fspec (fspec) 880 "Return a dspec for FSPEC." 881 (ecase (car fspec) 882 ((:defmethod) `(method ,(cdr fspec))))) 883 884 (defun tracedp (dspec) 885 (member dspec (eval '(trace)) :test #'equal)) 886 887 (defun toggle-trace-aux (dspec) 888 (cond ((tracedp dspec) 889 (eval `(untrace ,dspec)) 890 (format nil "~S is now untraced." dspec)) 891 (t 892 (eval `(trace (,dspec))) 893 (format nil "~S is now traced." dspec)))) 894 895 (defimplementation toggle-trace (fspec) 896 (toggle-trace-aux (parse-fspec fspec))) 897 898 ;;; Multithreading 899 900 (defimplementation initialize-multiprocessing (continuation) 901 (cond ((not mp::*multiprocessing*) 902 (push (list "Initialize SLY" '() continuation) 903 mp:*initial-processes*) 904 (mp:initialize-multiprocessing)) 905 (t (funcall continuation)))) 906 907 (defimplementation spawn (fn &key name) 908 (mp:process-run-function name () fn)) 909 910 (defvar *id-lock* (mp:make-lock)) 911 (defvar *thread-id-counter* 0) 912 913 (defimplementation thread-id (thread) 914 (mp:with-lock (*id-lock*) 915 (or (getf (mp:process-plist thread) 'id) 916 (setf (getf (mp:process-plist thread) 'id) 917 (incf *thread-id-counter*))))) 918 919 (defimplementation find-thread (id) 920 (find id (mp:list-all-processes) 921 :key (lambda (p) (getf (mp:process-plist p) 'id)))) 922 923 (defimplementation thread-name (thread) 924 (mp:process-name thread)) 925 926 (defimplementation thread-status (thread) 927 (format nil "~A ~D" 928 (mp:process-whostate thread) 929 (mp:process-priority thread))) 930 931 (defimplementation make-lock (&key name) 932 (mp:make-lock :name name)) 933 934 (defimplementation call-with-lock-held (lock function) 935 (mp:with-lock (lock) (funcall function))) 936 937 (defimplementation current-thread () 938 mp:*current-process*) 939 940 (defimplementation all-threads () 941 (mp:list-all-processes)) 942 943 (defimplementation interrupt-thread (thread fn) 944 (mp:process-interrupt thread fn)) 945 946 (defimplementation kill-thread (thread) 947 (mp:process-kill thread)) 948 949 (defimplementation thread-alive-p (thread) 950 (mp:process-alive-p thread)) 951 952 (defstruct (mailbox (:conc-name mailbox.)) 953 (mutex (mp:make-lock :name "thread mailbox")) 954 (queue '() :type list)) 955 956 (defvar *mailbox-lock* (mp:make-lock)) 957 958 (defun mailbox (thread) 959 (mp:with-lock (*mailbox-lock*) 960 (or (getf (mp:process-plist thread) 'mailbox) 961 (setf (getf (mp:process-plist thread) 'mailbox) 962 (make-mailbox))))) 963 964 (defimplementation receive-if (test &optional timeout) 965 (let* ((mbox (mailbox mp:*current-process*)) 966 (lock (mailbox.mutex mbox))) 967 (assert (or (not timeout) (eq timeout t))) 968 (loop 969 (check-sly-interrupts) 970 (mp:with-lock (lock "receive-if/try") 971 (let* ((q (mailbox.queue mbox)) 972 (tail (member-if test q))) 973 (when tail 974 (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) 975 (return (car tail))))) 976 (when (eq timeout t) (return (values nil t))) 977 (mp:process-wait-with-timeout 978 "receive-if" 0.3 (lambda () (some test (mailbox.queue mbox))))))) 979 980 (defimplementation send (thread message) 981 (let ((mbox (mailbox thread))) 982 (mp:with-lock ((mailbox.mutex mbox)) 983 (setf (mailbox.queue mbox) 984 (nconc (mailbox.queue mbox) (list message)))))) 985 986 (let ((alist '()) 987 (lock (mp:make-lock :name "register-thread"))) 988 989 (defimplementation register-thread (name thread) 990 (declare (type symbol name)) 991 (mp:with-lock (lock) 992 (etypecase thread 993 (null 994 (setf alist (delete name alist :key #'car))) 995 (mp:process 996 (let ((probe (assoc name alist))) 997 (cond (probe (setf (cdr probe) thread)) 998 (t (setf alist (acons name thread alist)))))))) 999 nil) 1000 1001 (defimplementation find-registered (name) 1002 (mp:with-lock (lock) 1003 (cdr (assoc name alist))))) 1004 1005 1006 (defimplementation set-default-initial-binding (var form) 1007 (setq mp:*process-initial-bindings* 1008 (acons var `(eval (quote ,form)) 1009 mp:*process-initial-bindings* ))) 1010 1011 (defimplementation thread-attributes (thread) 1012 (list :priority (mp:process-priority thread) 1013 :idle (mp:process-idle-time thread))) 1014 1015 ;;; Some intergration with the lispworks environment 1016 1017 (defun slynk-sym (name) (find-symbol (string name) :slynk)) 1018 1019 1020 ;;;; Weak hashtables 1021 1022 (defimplementation make-weak-key-hash-table (&rest args) 1023 (apply #'make-hash-table :weak-kind :key args)) 1024 1025 (defimplementation make-weak-value-hash-table (&rest args) 1026 (apply #'make-hash-table :weak-kind :value args))