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