clasp.lisp (25302B)
1 ;;;; -*- indent-tabs-mode: nil -*- 2 ;;; 3 ;;; slynk-clasp.lisp --- SLY backend for CLASP. 4 ;;; 5 ;;; This code has been placed in the Public Domain. All warranties 6 ;;; are disclaimed. 7 ;;; 8 9 ;;; Administrivia 10 11 (defpackage slynk-clasp 12 (:use cl slynk-backend)) 13 14 (in-package slynk-clasp) 15 16 ;; #+(or) 17 ;; (eval-when (:compile-toplevel :load-toplevel :execute) 18 ;; (set slynk::*log-output* (open "/tmp/sly.log" :direction :output)) 19 ;; (set slynk:*log-events* t)) 20 21 (defmacro sly-dbg (fmt &rest args) 22 `(funcall (read-from-string "slynk::log-event") 23 "sly-dbg ~a ~a~%" mp:*current-process* (apply #'format nil ,fmt ,args))) 24 25 ;; Hard dependencies. 26 (eval-when (:compile-toplevel :load-toplevel :execute) 27 (require 'sockets)) 28 29 ;; Soft dependencies. 30 (eval-when (:compile-toplevel :load-toplevel :execute) 31 (when (probe-file "sys:profile.fas") 32 (require :profile) 33 (pushnew :profile *features*)) 34 (when (probe-file "sys:serve-event") 35 (require :serve-event) 36 (pushnew :serve-event *features*))) 37 38 (declaim (optimize (debug 3))) 39 40 ;;; Slynk-mop 41 42 (eval-when (:compile-toplevel :load-toplevel :execute) 43 (import-slynk-mop-symbols :clos nil)) 44 45 (defimplementation gray-package-name () 46 "GRAY") 47 48 49 ;;;; TCP Server 50 51 (defimplementation preferred-communication-style () 52 :spawn 53 #| #+threads :spawn 54 #-threads nil 55 |# 56 ) 57 58 (defun resolve-hostname (name) 59 (car (sb-bsd-sockets:host-ent-addresses 60 (sb-bsd-sockets:get-host-by-name name)))) 61 62 (defimplementation create-socket (host port &key backlog) 63 (let ((socket (make-instance 'sb-bsd-sockets:inet-socket 64 :type :stream 65 :protocol :tcp))) 66 (setf (sb-bsd-sockets:sockopt-reuse-address socket) t) 67 (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port) 68 (sb-bsd-sockets:socket-listen socket (or backlog 5)) 69 socket)) 70 71 (defimplementation local-port (socket) 72 (nth-value 1 (sb-bsd-sockets:socket-name socket))) 73 74 (defimplementation close-socket (socket) 75 (sb-bsd-sockets:socket-close socket)) 76 77 (defimplementation accept-connection (socket 78 &key external-format 79 buffering timeout) 80 (declare (ignore timeout)) 81 (sb-bsd-sockets:socket-make-stream (accept socket) 82 :output t 83 :input t 84 :buffering (ecase buffering 85 ((t) :full) 86 ((nil) :none) 87 (:line :line)) 88 :element-type (if external-format 89 'character 90 '(unsigned-byte 8)) 91 :external-format external-format)) 92 (defun accept (socket) 93 "Like socket-accept, but retry on EAGAIN." 94 (loop (handler-case 95 (return (sb-bsd-sockets:socket-accept socket)) 96 (sb-bsd-sockets:interrupted-error ())))) 97 98 (defimplementation socket-fd (socket) 99 (etypecase socket 100 (fixnum socket) 101 (two-way-stream (socket-fd (two-way-stream-input-stream socket))) 102 (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket)) 103 (file-stream (si:file-stream-fd socket)))) 104 105 (defvar *external-format-to-coding-system* 106 '((:latin-1 107 "latin-1" "latin-1-unix" "iso-latin-1-unix" 108 "iso-8859-1" "iso-8859-1-unix") 109 (:utf-8 "utf-8" "utf-8-unix"))) 110 111 (defun external-format (coding-system) 112 (or (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) 113 *external-format-to-coding-system*)) 114 (find coding-system (ext:all-encodings) :test #'string-equal))) 115 116 (defimplementation find-external-format (coding-system) 117 #+unicode (external-format coding-system) 118 ;; Without unicode support, CLASP uses the one-byte encoding of the 119 ;; underlying OS, and will barf on anything except :DEFAULT. We 120 ;; return NIL here for known multibyte encodings, so 121 ;; SLYNK:CREATE-SERVER will barf. 122 #-unicode (let ((xf (external-format coding-system))) 123 (if (member xf '(:utf-8)) 124 nil 125 :default))) 126 127 128 ;;;; Unix Integration 129 130 ;;; If CLASP is built with thread support, it'll spawn a helper thread 131 ;;; executing the SIGINT handler. We do not want to BREAK into that 132 ;;; helper but into the main thread, though. This is coupled with the 133 ;;; current choice of NIL as communication-style in so far as CLASP's 134 ;;; main-thread is also the Sly's REPL thread. 135 136 #+clasp-working 137 (defimplementation call-with-user-break-handler (real-handler function) 138 (let ((old-handler #'si:terminal-interrupt)) 139 (setf (symbol-function 'si:terminal-interrupt) 140 (make-interrupt-handler real-handler)) 141 (unwind-protect (funcall function) 142 (setf (symbol-function 'si:terminal-interrupt) old-handler)))) 143 144 #+threads 145 (defun make-interrupt-handler (real-handler) 146 (let ((main-thread (find 'si:top-level (mp:all-processes) 147 :key #'mp:process-name))) 148 #'(lambda (&rest args) 149 (declare (ignore args)) 150 (mp:interrupt-process main-thread real-handler)))) 151 152 #-threads 153 (defun make-interrupt-handler (real-handler) 154 #'(lambda (&rest args) 155 (declare (ignore args)) 156 (funcall real-handler))) 157 158 159 (defimplementation getpid () 160 (si:getpid)) 161 162 (defimplementation set-default-directory (directory) 163 (ext:chdir (namestring directory)) ; adapts *DEFAULT-PATHNAME-DEFAULTS*. 164 (default-directory)) 165 166 (defimplementation default-directory () 167 (namestring (ext:getcwd))) 168 169 (defimplementation quit-lisp () 170 (core:quit)) 171 172 173 174 ;;; Instead of busy waiting with communication-style NIL, use select() 175 ;;; on the sockets' streams. 176 #+serve-event 177 (progn 178 (defun poll-streams (streams timeout) 179 (let* ((serve-event::*descriptor-handlers* 180 (copy-list serve-event::*descriptor-handlers*)) 181 (active-fds '()) 182 (fd-stream-alist 183 (loop for s in streams 184 for fd = (socket-fd s) 185 collect (cons fd s) 186 do (serve-event:add-fd-handler fd :input 187 #'(lambda (fd) 188 (push fd active-fds)))))) 189 (serve-event:serve-event timeout) 190 (loop for fd in active-fds collect (cdr (assoc fd fd-stream-alist))))) 191 192 (defimplementation wait-for-input (streams &optional timeout) 193 (assert (member timeout '(nil t))) 194 (loop 195 (cond ((check-sly-interrupts) (return :interrupt)) 196 (timeout (return (poll-streams streams 0))) 197 (t 198 (when-let (ready (poll-streams streams 0.2)) 199 (return ready)))))) 200 201 ) ; #+serve-event (progn ... 202 203 #-serve-event 204 (defimplementation wait-for-input (streams &optional timeout) 205 (assert (member timeout '(nil t))) 206 (loop 207 (cond ((check-sly-interrupts) (return :interrupt)) 208 (timeout (return (remove-if-not #'listen streams))) 209 (t 210 (let ((ready (remove-if-not #'listen streams))) 211 (if ready (return ready)) 212 (sleep 0.1)))))) 213 214 215 ;;;; Compilation 216 217 (defvar *buffer-name* nil) 218 (defvar *buffer-start-position*) 219 220 (defun condition-severity (condition) 221 (etypecase condition 222 (cmp:redefined-function-warning :redefinition) 223 (style-warning :style-warning) 224 (warning :warning) 225 (reader-error :read-error) 226 (error :error))) 227 228 (defun condition-location (origin) 229 (if (null origin) 230 (make-error-location "No error location available") 231 ;; NOTE: If we're compiling in a buffer, the origin 232 ;; will already be set up with the offset correctly 233 ;; due to the :source-debug parameters from 234 ;; slynk-compile-string (below). 235 (make-file-location 236 (core:file-scope-pathname 237 (core:file-scope origin)) 238 (core:source-pos-info-filepos origin)))) 239 240 (defun signal-compiler-condition (condition origin) 241 (signal 'compiler-condition 242 :original-condition condition 243 :severity (condition-severity condition) 244 :message (princ-to-string condition) 245 :location (condition-location origin))) 246 247 (defun handle-compiler-condition (condition) 248 ;; First resignal warnings, so that outer handlers - which may choose to 249 ;; muffle this - get a chance to run. 250 (when (typep condition 'warning) 251 (signal condition)) 252 (signal-compiler-condition (cmp:deencapsulate-compiler-condition condition) 253 (cmp:compiler-condition-origin condition))) 254 255 (defimplementation call-with-compilation-hooks (function) 256 (handler-bind 257 (((or error warning) #'handle-compiler-condition)) 258 (funcall function))) 259 260 (defimplementation slynk-compile-file (input-file output-file 261 load-p external-format 262 &key policy) 263 (declare (ignore policy)) 264 (format t "Compiling file input-file = ~a output-file = ~a~%" input-file output-file) 265 ;; Ignore the output-file and generate our own 266 (let ((tmp-output-file (compile-file-pathname (si:mkstemp "TMP:clasp-slynk-compile-file-")))) 267 (format t "Using tmp-output-file: ~a~%" tmp-output-file) 268 (multiple-value-bind (fasl warnings-p failure-p) 269 (with-compilation-hooks () 270 (compile-file input-file :output-file tmp-output-file 271 :external-format external-format)) 272 (values fasl warnings-p 273 (or failure-p 274 (when load-p 275 (not (load fasl)))))))) 276 277 (defvar *tmpfile-map* (make-hash-table :test #'equal)) 278 279 (defun note-buffer-tmpfile (tmp-file buffer-name) 280 ;; EXT:COMPILED-FUNCTION-FILE below will return a namestring. 281 (let ((tmp-namestring (namestring (truename tmp-file)))) 282 (setf (gethash tmp-namestring *tmpfile-map*) buffer-name) 283 tmp-namestring)) 284 285 (defun tmpfile-to-buffer (tmp-file) 286 (gethash tmp-file *tmpfile-map*)) 287 288 (defimplementation slynk-compile-string (string &key buffer position filename line column policy) 289 (declare (ignore column policy)) ;; We may use column in the future 290 (with-compilation-hooks () 291 (let ((*buffer-name* buffer) ; for compilation hooks 292 (*buffer-start-position* position)) 293 (let ((tmp-file (si:mkstemp "TMP:clasp-slynk-tmpfile-")) 294 (fasl-file) 295 (warnings-p) 296 (failure-p)) 297 (unwind-protect 298 (with-open-file (tmp-stream tmp-file :direction :output 299 :if-exists :supersede) 300 (write-string string tmp-stream) 301 (finish-output tmp-stream) 302 (multiple-value-setq (fasl-file warnings-p failure-p) 303 (let ((truename (or filename (note-buffer-tmpfile tmp-file buffer)))) 304 (compile-file tmp-file 305 :source-debug-pathname (pathname truename) 306 ;; emacs numbers are 1-based instead of 0-based, 307 ;; so we have to subtract 308 :source-debug-lineno (1- line) 309 :source-debug-offset (1- position))))) 310 (when fasl-file (load fasl-file)) 311 (when (probe-file tmp-file) 312 (delete-file tmp-file)) 313 (when fasl-file 314 (delete-file fasl-file))) 315 (not failure-p))))) 316 317 ;;;; Documentation 318 319 (defimplementation arglist (name) 320 (multiple-value-bind (arglist foundp) 321 (core:function-lambda-list name) ;; Uses bc-split 322 (if foundp arglist :not-available))) 323 324 (defimplementation function-name (f) 325 (typecase f 326 (generic-function (clos::generic-function-name f)) 327 (function (ext:compiled-function-name f)))) 328 329 ;; FIXME 330 (defimplementation macroexpand-all (form &optional env) 331 (declare (ignore env)) 332 (macroexpand form)) 333 334 ;;; modified from sbcl.lisp 335 (defimplementation collect-macro-forms (form &optional environment) 336 (let ((macro-forms '()) 337 (compiler-macro-forms '()) 338 (function-quoted-forms '())) 339 (format t "In collect-macro-forms~%") 340 (cmp:code-walk 341 (lambda (form environment) 342 (when (and (consp form) 343 (symbolp (car form))) 344 (cond ((eq (car form) 'function) 345 (push (cadr form) function-quoted-forms)) 346 ((member form function-quoted-forms) 347 nil) 348 ((macro-function (car form) environment) 349 (push form macro-forms)) 350 ((not (eq form (core:compiler-macroexpand-1 form environment))) 351 (push form compiler-macro-forms)))) 352 form) 353 form environment) 354 (values macro-forms compiler-macro-forms))) 355 356 357 358 359 360 (defimplementation describe-symbol-for-emacs (symbol) 361 (let ((result '())) 362 (flet ((frob (type boundp) 363 (when (funcall boundp symbol) 364 (let ((doc (describe-definition symbol type))) 365 (setf result (list* type doc result)))))) 366 (frob :VARIABLE #'boundp) 367 (frob :FUNCTION #'fboundp) 368 (frob :CLASS (lambda (x) (find-class x nil)))) 369 result)) 370 371 (defimplementation describe-definition (name type) 372 (case type 373 (:variable (documentation name 'variable)) 374 (:function (documentation name 'function)) 375 (:class (documentation name 'class)) 376 (t nil))) 377 378 (defimplementation type-specifier-p (symbol) 379 (or (subtypep nil symbol) 380 (not (eq (type-specifier-arglist symbol) :not-available)))) 381 382 383 ;;; Debugging 384 385 (defun make-invoke-debugger-hook (hook) 386 (when hook 387 #'(lambda (condition old-hook) 388 ;; Regard *debugger-hook* if set by user. 389 (if *debugger-hook* 390 nil ; decline, *DEBUGGER-HOOK* will be tried next. 391 (funcall hook condition old-hook))))) 392 393 (defimplementation install-debugger-globally (function) 394 (setq *debugger-hook* function) 395 (setq ext:*invoke-debugger-hook* (make-invoke-debugger-hook function))) 396 397 (defimplementation call-with-debugger-hook (hook fun) 398 (let ((*debugger-hook* hook) 399 (ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook))) 400 (funcall fun))) 401 402 (defvar *backtrace* '()) 403 404 ;;; Commented out; it's not clear this is a good way of doing it. In 405 ;;; particular because it makes errors stemming from this file harder 406 ;;; to debug, and given the "young" age of CLASP's slynk backend, that's 407 ;;; a bad idea. 408 409 ;; (defun in-slynk-package-p (x) 410 ;; (and 411 ;; (symbolp x) 412 ;; (member (symbol-package x) 413 ;; (list #.(find-package :slynk) 414 ;; #.(find-package :slynk-backend) 415 ;; #.(ignore-errors (find-package :slynk-mop)) 416 ;; #.(ignore-errors (find-package :slynk-loader)))) 417 ;; t)) 418 419 ;; (defun is-slynk-source-p (name) 420 ;; (setf name (pathname name)) 421 ;; (pathname-match-p 422 ;; name 423 ;; (make-pathname :defaults slynk-loader::*source-directory* 424 ;; :name (pathname-name name) 425 ;; :type (pathname-type name) 426 ;; :version (pathname-version name)))) 427 428 ;; (defun is-ignorable-fun-p (x) 429 ;; (or 430 ;; (in-slynk-package-p (frame-name x)) 431 ;; (multiple-value-bind (file position) 432 ;; (ignore-errors (si::bc-file (car x))) 433 ;; (declare (ignore position)) 434 ;; (if file (is-slynk-source-p file))))) 435 436 (defimplementation call-with-debugging-environment (debugger-loop-fn) 437 (declare (type function debugger-loop-fn)) 438 (clasp-debug:with-stack (stack) 439 (let ((*backtrace* (clasp-debug:list-stack stack))) 440 (funcall debugger-loop-fn)))) 441 442 (defimplementation compute-backtrace (start end) 443 (subseq *backtrace* start 444 (and (numberp end) 445 (min end (length *backtrace*))))) 446 447 (defun frame-from-number (frame-number) 448 (elt *backtrace* frame-number)) 449 450 (defimplementation print-frame (frame stream) 451 (clasp-debug:prin1-frame-call frame stream)) 452 453 (defimplementation frame-source-location (frame-number) 454 (let ((csl (clasp-debug:frame-source-position (frame-from-number frame-number)))) 455 (if (clasp-debug:code-source-line-pathname csl) 456 (make-location (list :file (namestring (clasp-debug:code-source-line-pathname csl))) 457 (list :line (clasp-debug:code-source-line-line-number csl)) 458 '(:align t)) 459 `(:error ,(format nil "No source for frame: ~a" frame-number))))) 460 461 (defimplementation frame-locals (frame-number) 462 (loop for (var . value) 463 in (clasp-debug:frame-locals (frame-from-number frame-number)) 464 for i from 0 465 collect (list :name var :id i :value value))) 466 467 (defimplementation frame-var-value (frame-number var-number) 468 (let* ((frame (frame-from-number frame-number)) 469 (locals (clasp-debug:frame-locals frame))) 470 (cdr (nth var-number locals)))) 471 472 (defimplementation disassemble-frame (frame-number) 473 (clasp-debug:disassemble-frame (frame-from-number frame-number))) 474 475 (defimplementation eval-in-frame (form frame-number) 476 (let* ((frame (frame-from-number frame-number))) 477 (eval 478 `(let (,@(loop for (var . value) 479 in (clasp-debug:frame-locals frame) 480 collect `(,var ',value))) 481 (progn ,form))))) 482 483 #+clasp-working 484 (defimplementation gdb-initial-commands () 485 ;; These signals are used by the GC. 486 #+linux '("handle SIGPWR noprint nostop" 487 "handle SIGXCPU noprint nostop")) 488 489 #+clasp-working 490 (defimplementation command-line-args () 491 (loop for n from 0 below (si:argc) collect (si:argv n))) 492 493 494 ;;;; Inspector 495 496 ;;; FIXME: Would be nice if it was possible to inspect objects 497 ;;; implemented in C. 498 499 500 ;;;; Definitions 501 502 (defun make-file-location (file file-position) 503 ;; File positions in CL start at 0, but Emacs' buffer positions 504 ;; start at 1. We specify (:ALIGN T) because the positions comming 505 ;; from CLASP point at right after the toplevel form appearing before 506 ;; the actual target toplevel form; (:ALIGN T) will DTRT in that case. 507 (make-location `(:file ,(namestring (translate-logical-pathname file))) 508 `(:position ,(1+ file-position)) 509 `(:align t))) 510 511 (defun make-buffer-location (buffer-name start-position &optional (offset 0)) 512 (make-location `(:buffer ,buffer-name) 513 `(:offset ,start-position ,offset) 514 `(:align t))) 515 516 (defun translate-location (location) 517 (make-location (list :file (namestring (ext:source-location-pathname location))) 518 (list :position (ext:source-location-offset location)) 519 '(:align t))) 520 521 (defun make-dspec (name location) 522 (list* (ext:source-location-definer location) 523 name 524 (ext:source-location-description location))) 525 526 (defimplementation find-definitions (name) 527 (loop for kind in ext:*source-location-kinds* 528 for locations = (ext:source-location name kind) 529 when locations 530 nconc (loop for location in locations 531 collect (list (make-dspec name location) 532 (translate-location location))))) 533 534 (defun source-location (object) 535 (let ((location (ext:source-location object t))) 536 (when location 537 (translate-location (car location))))) 538 539 (defimplementation find-source-location (object) 540 (or (source-location object) 541 (make-error-location "Source definition of ~S not found." object))) 542 543 544 ;;;; Profiling 545 546 ;;;; as clisp and ccl 547 548 (defimplementation profile (fname) 549 (eval `(slynk-monitor:monitor ,fname))) ;monitor is a macro 550 551 (defimplementation profiled-functions () 552 slynk-monitor:*monitored-functions*) 553 554 (defimplementation unprofile (fname) 555 (eval `(slynk-monitor:unmonitor ,fname))) ;unmonitor is a macro 556 557 (defimplementation unprofile-all () 558 (slynk-monitor:unmonitor)) 559 560 (defimplementation profile-report () 561 (slynk-monitor:report-monitoring)) 562 563 (defimplementation profile-reset () 564 (slynk-monitor:reset-all-monitoring)) 565 566 (defimplementation profile-package (package callers-p methods) 567 (declare (ignore callers-p methods)) 568 (slynk-monitor:monitor-all package)) 569 570 571 ;;;; Threads 572 573 #+threads 574 (progn 575 (defvar *thread-id-counter* 0) 576 577 (defparameter *thread-id-map* (make-hash-table)) 578 579 (defvar *thread-id-map-lock* 580 (mp:make-lock :name "thread id map lock")) 581 582 (defimplementation spawn (fn &key name) 583 (mp:process-run-function name fn)) 584 585 (defimplementation thread-id (target-thread) 586 (block thread-id 587 (mp:with-lock (*thread-id-map-lock*) 588 ;; Does TARGET-THREAD have an id already? 589 (maphash (lambda (id thread-pointer) 590 (let ((thread (si:weak-pointer-value thread-pointer))) 591 (cond ((not thread) 592 (remhash id *thread-id-map*)) 593 ((eq thread target-thread) 594 (return-from thread-id id))))) 595 *thread-id-map*) 596 ;; TARGET-THREAD not found in *THREAD-ID-MAP* 597 (let ((id (incf *thread-id-counter*)) 598 (thread-pointer (si:make-weak-pointer target-thread))) 599 (setf (gethash id *thread-id-map*) thread-pointer) 600 id)))) 601 602 (defimplementation find-thread (id) 603 (mp:with-lock (*thread-id-map-lock*) 604 (let* ((thread-ptr (gethash id *thread-id-map*)) 605 (thread (and thread-ptr (si:weak-pointer-value thread-ptr)))) 606 (unless thread 607 (remhash id *thread-id-map*)) 608 thread))) 609 610 (defimplementation thread-name (thread) 611 (mp:process-name thread)) 612 613 (defimplementation thread-status (thread) 614 (if (mp:process-active-p thread) 615 "RUNNING" 616 "STOPPED")) 617 618 (defimplementation make-lock (&key name) 619 (mp:make-recursive-mutex name)) 620 621 (defimplementation call-with-lock-held (lock function) 622 (declare (type function function)) 623 (mp:with-lock (lock) (funcall function))) 624 625 (defimplementation current-thread () 626 mp:*current-process*) 627 628 (defimplementation all-threads () 629 (mp:all-processes)) 630 631 (defimplementation interrupt-thread (thread fn) 632 (mp:interrupt-process thread fn)) 633 634 (defimplementation kill-thread (thread) 635 (mp:process-kill thread)) 636 637 (defimplementation thread-alive-p (thread) 638 (mp:process-active-p thread)) 639 640 (defvar *mailbox-lock* (mp:make-lock :name "mailbox lock")) 641 (defvar *mailboxes* (list)) 642 (declaim (type list *mailboxes*)) 643 644 (defstruct (mailbox (:conc-name mailbox.)) 645 thread 646 (mutex (mp:make-lock :name "SLYLCK")) 647 (cvar (mp:make-condition-variable)) 648 (queue '() :type list)) 649 650 (defun mailbox (thread) 651 "Return THREAD's mailbox." 652 (mp:with-lock (*mailbox-lock*) 653 (or (find thread *mailboxes* :key #'mailbox.thread) 654 (let ((mb (make-mailbox :thread thread))) 655 (push mb *mailboxes*) 656 mb)))) 657 658 (defimplementation wake-thread (thread) 659 (let* ((mbox (mailbox thread)) 660 (mutex (mailbox.mutex mbox))) 661 (format t "About to with-lock in wake-thread~%") 662 (mp:with-lock (mutex) 663 (format t "In wake-thread~%") 664 (mp:condition-variable-broadcast (mailbox.cvar mbox))))) 665 666 (defimplementation send (thread message) 667 (let* ((mbox (mailbox thread)) 668 (mutex (mailbox.mutex mbox))) 669 ;; (sly-dbg "clasp.lisp: send message ~a mutex: ~a~%" message mutex) 670 ;; (sly-dbg "clasp.lisp: (lock-owner mutex) -> ~a~%" (mp:lock-owner mutex)) 671 ;; (sly-dbg "clasp.lisp: (lock-count mutex) -> ~a~%" (mp:lock-count mutex)) 672 (mp:with-lock (mutex) 673 ;; (sly-dbg "clasp.lisp: in with-lock (lock-owner mutex) -> ~a~%" (mp:lock-owner mutex)) 674 ;; (sly-dbg "clasp.lisp: in with-lock (lock-count mutex) -> ~a~%" (mp:lock-count mutex)) 675 (setf (mailbox.queue mbox) 676 (nconc (mailbox.queue mbox) (list message))) 677 (sly-dbg "clasp.lisp: send about to broadcast~%") 678 (mp:condition-variable-broadcast (mailbox.cvar mbox))))) 679 680 681 (defimplementation receive-if (test &optional timeout) 682 (sly-dbg "Entered receive-if") 683 (let* ((mbox (mailbox (current-thread))) 684 (mutex (mailbox.mutex mbox))) 685 (sly-dbg "receive-if assert") 686 (assert (or (not timeout) (eq timeout t))) 687 (loop 688 (sly-dbg "receive-if check-sly-interrupts") 689 (check-sly-interrupts) 690 (sly-dbg "receive-if with-lock") 691 (mp:with-lock (mutex) 692 (let* ((q (mailbox.queue mbox)) 693 (tail (member-if test q))) 694 (when tail 695 (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) 696 (return (car tail)))) 697 (sly-dbg "receive-if when (eq") 698 (when (eq timeout t) (return (values nil t))) 699 (sly-dbg "receive-if condition-variable-timedwait") 700 (mp:condition-variable-wait (mailbox.cvar mbox) mutex) ; timedwait 0.2 701 (sly-dbg "came out of condition-variable-timedwait") 702 (core:check-pending-interrupts))))) 703 704 ) ; #+threads (progn ... 705 706 707 (defmethod emacs-inspect ((object core:cxx-object)) 708 (let ((encoded (core:encode object))) 709 (loop for (key . value) in encoded 710 append (list (string key) ": " (list :value value) (list :newline))))) 711 712 (defmethod emacs-inspect ((object core:va-list)) 713 (emacs-inspect (core:list-from-va-list object)))