ccl.lisp (31776B)
1 ;;;; -*- indent-tabs-mode: nil -*- 2 ;;; 3 ;;; slynk-ccl.lisp --- SLY backend for Clozure CL. 4 ;;; 5 ;;; Copyright (C) 2003, James Bielman <jamesjb@jamesjb.com> 6 ;;; 7 ;;; This program is licensed under the terms of the Lisp Lesser GNU 8 ;;; Public License, known as the LLGPL, and distributed with Clozure CL 9 ;;; as the file "LICENSE". The LLGPL consists of a preamble and the 10 ;;; LGPL, which is distributed with Clozure CL as the file "LGPL". Where 11 ;;; these conflict, the preamble takes precedence. 12 ;;; 13 ;;; The LLGPL is also available online at 14 ;;; http://opensource.franz.com/preamble.html 15 16 (defpackage slynk-ccl 17 (:use cl slynk-backend)) 18 19 (in-package slynk-ccl) 20 21 (eval-when (:compile-toplevel :execute :load-toplevel) 22 (assert (and (= ccl::*openmcl-major-version* 1) 23 (>= ccl::*openmcl-minor-version* 4)) 24 () "This file needs CCL version 1.4 or newer")) 25 26 (defimplementation gray-package-name () 27 "CCL") 28 29 (eval-when (:compile-toplevel :load-toplevel :execute) 30 (multiple-value-bind (ok err) (ignore-errors (require 'xref)) 31 (unless ok 32 (warn "~a~%" err)))) 33 34 ;;; slynk-mop 35 36 (import-to-slynk-mop 37 '( ;; classes 38 cl:standard-generic-function 39 ccl:standard-slot-definition 40 cl:method 41 cl:standard-class 42 ccl:eql-specializer 43 openmcl-mop:finalize-inheritance 44 openmcl-mop:compute-applicable-methods-using-classes 45 ;; standard-class readers 46 openmcl-mop:class-default-initargs 47 openmcl-mop:class-direct-default-initargs 48 openmcl-mop:class-direct-slots 49 openmcl-mop:class-direct-subclasses 50 openmcl-mop:class-direct-superclasses 51 openmcl-mop:class-finalized-p 52 cl:class-name 53 openmcl-mop:class-precedence-list 54 openmcl-mop:class-prototype 55 openmcl-mop:class-slots 56 openmcl-mop:specializer-direct-methods 57 ;; eql-specializer accessors 58 openmcl-mop:eql-specializer-object 59 ;; generic function readers 60 openmcl-mop:generic-function-argument-precedence-order 61 openmcl-mop:generic-function-declarations 62 openmcl-mop:generic-function-lambda-list 63 openmcl-mop:generic-function-methods 64 openmcl-mop:generic-function-method-class 65 openmcl-mop:generic-function-method-combination 66 openmcl-mop:generic-function-name 67 ;; method readers 68 openmcl-mop:method-generic-function 69 openmcl-mop:method-function 70 openmcl-mop:method-lambda-list 71 openmcl-mop:method-specializers 72 openmcl-mop:method-qualifiers 73 ;; slot readers 74 openmcl-mop:slot-definition-allocation 75 openmcl-mop:slot-definition-documentation 76 openmcl-mop:slot-value-using-class 77 openmcl-mop:slot-definition-initargs 78 openmcl-mop:slot-definition-initform 79 openmcl-mop:slot-definition-initfunction 80 openmcl-mop:slot-definition-name 81 openmcl-mop:slot-definition-type 82 openmcl-mop:slot-definition-readers 83 openmcl-mop:slot-definition-writers 84 openmcl-mop:slot-boundp-using-class 85 openmcl-mop:slot-makunbound-using-class)) 86 87 (defmacro slynk-sym (sym) 88 (let ((str (symbol-name sym))) 89 `(or (find-symbol ,str :slynk) 90 (error "There is no symbol named ~a in the SLYNK package" ,str)))) 91 ;;; UTF8 92 93 (defimplementation string-to-utf8 (string) 94 (ccl:encode-string-to-octets string :external-format :utf-8)) 95 96 (defimplementation utf8-to-string (octets) 97 (ccl:decode-string-from-octets octets :external-format :utf-8)) 98 99 ;;; TCP Server 100 101 (defimplementation preferred-communication-style () 102 :spawn) 103 104 (defimplementation create-socket (host port &key backlog) 105 (ccl:make-socket :connect :passive :local-port port 106 :local-host host :reuse-address t 107 :backlog (or backlog 5))) 108 109 (defimplementation local-port (socket) 110 (ccl:local-port socket)) 111 112 (defimplementation close-socket (socket) 113 (close socket)) 114 115 (defimplementation accept-connection (socket &key external-format 116 buffering timeout) 117 (declare (ignore buffering timeout)) 118 (let ((stream-args (and external-format 119 `(:external-format ,external-format)))) 120 (ccl:accept-connection socket :wait t :stream-args stream-args))) 121 122 (defvar *external-format-to-coding-system* 123 '((:iso-8859-1 124 "latin-1" "latin-1-unix" "iso-latin-1-unix" 125 "iso-8859-1" "iso-8859-1-unix") 126 (:utf-8 "utf-8" "utf-8-unix"))) 127 128 (defimplementation find-external-format (coding-system) 129 (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) 130 *external-format-to-coding-system*))) 131 132 (defimplementation socket-fd (stream) 133 (ccl::ioblock-device (ccl::stream-ioblock stream t))) 134 135 ;;; Unix signals 136 137 (defimplementation getpid () 138 (ccl::getpid)) 139 140 (defimplementation lisp-implementation-type-name () 141 "ccl") 142 143 ;;; Arglist 144 145 (defimplementation arglist (fname) 146 (multiple-value-bind (arglist binding) (let ((*break-on-signals* nil)) 147 (ccl:arglist fname)) 148 (if binding 149 arglist 150 :not-available))) 151 152 (defimplementation function-name (function) 153 (ccl:function-name function)) 154 155 (defmethod declaration-arglist ((decl-identifier (eql 'optimize))) 156 (let ((flags (ccl:declaration-information decl-identifier))) 157 (if flags 158 `(&any ,flags) 159 (call-next-method)))) 160 161 ;;; Compilation 162 163 (defun handle-compiler-warning (condition) 164 "Resignal a ccl:compiler-warning as slynk-backend:compiler-warning." 165 (signal 'compiler-condition 166 :original-condition condition 167 :message (compiler-warning-short-message condition) 168 :source-context nil 169 :severity (compiler-warning-severity condition) 170 :location (source-note-to-source-location 171 (ccl:compiler-warning-source-note condition) 172 (lambda () "Unknown source") 173 (ccl:compiler-warning-function-name condition)))) 174 175 (defgeneric compiler-warning-severity (condition)) 176 (defmethod compiler-warning-severity ((c ccl:compiler-warning)) :warning) 177 (defmethod compiler-warning-severity ((c ccl:style-warning)) :style-warning) 178 179 (defgeneric compiler-warning-short-message (condition)) 180 181 ;; Pretty much the same as ccl:report-compiler-warning but 182 ;; without the source position and function name stuff. 183 (defmethod compiler-warning-short-message ((c ccl:compiler-warning)) 184 (with-output-to-string (stream) 185 (ccl:report-compiler-warning c stream :short t))) 186 187 ;; Needed because `ccl:report-compiler-warning' would return 188 ;; "Nonspecific warning". 189 (defmethod compiler-warning-short-message ((c ccl::shadowed-typecase-clause)) 190 (princ-to-string c)) 191 192 (defimplementation call-with-compilation-hooks (function) 193 (handler-bind ((ccl:compiler-warning 'handle-compiler-warning)) 194 (let ((ccl:*merge-compiler-warnings* nil)) 195 (funcall function)))) 196 197 (defimplementation slynk-compile-file (input-file output-file 198 load-p external-format 199 &key policy) 200 (declare (ignore policy)) 201 (with-compilation-hooks () 202 (compile-file input-file 203 :output-file output-file 204 :load load-p 205 :external-format external-format))) 206 207 ;; Use a temp file rather than in-core compilation in order to handle 208 ;; eval-when's as compile-time. 209 (defimplementation slynk-compile-string (string &key buffer position filename 210 line column policy) 211 (declare (ignore line column policy)) 212 (with-compilation-hooks () 213 (let ((temp-file-name (ccl:temp-pathname)) 214 (ccl:*save-source-locations* t)) 215 (unwind-protect 216 (progn 217 (with-open-file (s temp-file-name :direction :output 218 :if-exists :error :external-format :utf-8) 219 (write-string string s)) 220 (let ((binary-filename (compile-temp-file 221 temp-file-name filename buffer position))) 222 (delete-file binary-filename))) 223 (delete-file temp-file-name))))) 224 225 (defvar *temp-file-map* (make-hash-table :test #'equal) 226 "A mapping from tempfile names to Emacs buffer names.") 227 228 (defun compile-temp-file (temp-file-name buffer-file-name buffer-name offset) 229 (compile-file temp-file-name 230 :load t 231 :compile-file-original-truename 232 (or buffer-file-name 233 (progn 234 (setf (gethash temp-file-name *temp-file-map*) 235 buffer-name) 236 temp-file-name)) 237 :compile-file-original-buffer-offset (1- offset) 238 :external-format :utf-8)) 239 240 (defimplementation save-image (filename &optional restart-function) 241 (ccl:save-application filename :toplevel-function restart-function)) 242 243 ;;; Cross-referencing 244 245 (defun xref-locations (relation name &optional inverse) 246 (delete-duplicates 247 (mapcan #'find-definitions 248 (if inverse 249 (ccl::get-relation relation name :wild :exhaustive t) 250 (ccl::get-relation relation :wild name :exhaustive t))) 251 :test 'equal)) 252 253 (defimplementation who-binds (name) 254 (xref-locations :binds name)) 255 256 (defimplementation who-macroexpands (name) 257 (xref-locations :macro-calls name t)) 258 259 (defimplementation who-references (name) 260 (remove-duplicates 261 (append (xref-locations :references name) 262 (xref-locations :sets name) 263 (xref-locations :binds name)) 264 :test 'equal)) 265 266 (defimplementation who-sets (name) 267 (xref-locations :sets name)) 268 269 (defimplementation who-calls (name) 270 (remove-duplicates 271 (append 272 (xref-locations :direct-calls name) 273 (xref-locations :indirect-calls name) 274 (xref-locations :macro-calls name t)) 275 :test 'equal)) 276 277 (defimplementation who-specializes (class) 278 (when (symbolp class) 279 (setq class (find-class class nil))) 280 (when class 281 (delete-duplicates 282 (mapcar (lambda (m) 283 (car (find-definitions m))) 284 (ccl:specializer-direct-methods class)) 285 :test 'equal))) 286 287 (defimplementation list-callees (name) 288 (remove-duplicates 289 (append 290 (xref-locations :direct-calls name t) 291 (xref-locations :macro-calls name nil)) 292 :test 'equal)) 293 294 (defimplementation list-callers (symbol) 295 (delete-duplicates 296 (mapcan #'find-definitions (ccl:caller-functions symbol)) 297 :test #'equal)) 298 299 ;;; Profiling (alanr: lifted from slynk-clisp) 300 301 (defimplementation profile (fname) 302 (eval `(slynk-monitor:monitor ,fname))) ;monitor is a macro 303 304 (defimplementation profiled-functions () 305 slynk-monitor:*monitored-functions*) 306 307 (defimplementation unprofile (fname) 308 (eval `(slynk-monitor:unmonitor ,fname))) ;unmonitor is a macro 309 310 (defimplementation unprofile-all () 311 (slynk-monitor:unmonitor)) 312 313 (defimplementation profile-report () 314 (slynk-monitor:report-monitoring)) 315 316 (defimplementation profile-reset () 317 (slynk-monitor:reset-all-monitoring)) 318 319 (defimplementation profile-package (package callers-p methods) 320 (declare (ignore callers-p methods)) 321 (slynk-monitor:monitor-all package)) 322 323 ;;; Debugging 324 325 (defimplementation call-with-debugging-environment (debugger-loop-fn) 326 (let* (;;(*debugger-hook* nil) 327 ;; don't let error while printing error take us down 328 (ccl:*signal-printing-errors* nil)) 329 (funcall debugger-loop-fn))) 330 331 ;; This is called for an async interrupt and is running in a random 332 ;; thread not selected by the user, so don't use thread-local vars 333 ;; such as *emacs-connection*. 334 (defun find-repl-thread () 335 (let* ((*break-on-signals* nil) 336 (conn (funcall (slynk-sym default-connection)))) 337 (and conn 338 (ignore-errors ;; this errors if no repl-thread 339 (funcall (slynk-sym repl-thread) conn))))) 340 341 (defimplementation call-with-debugger-hook (hook fun) 342 (let ((*debugger-hook* hook) 343 (ccl:*break-hook* hook) 344 (ccl:*select-interactive-process-hook* 'find-repl-thread)) 345 (funcall fun))) 346 347 (defimplementation install-debugger-globally (function) 348 (setq *debugger-hook* function) 349 (setq ccl:*break-hook* function) 350 (setq ccl:*select-interactive-process-hook* 'find-repl-thread) 351 ) 352 353 (defun map-backtrace (function &optional 354 (start-frame-number 0) 355 end-frame-number) 356 "Call FUNCTION passing information about each stack frame 357 from frames START-FRAME-NUMBER to END-FRAME-NUMBER." 358 (let ((end-frame-number (or end-frame-number most-positive-fixnum))) 359 (ccl:map-call-frames function 360 :origin ccl:*top-error-frame* 361 :start-frame-number start-frame-number 362 :count (- end-frame-number start-frame-number)))) 363 364 (defimplementation compute-backtrace (start-frame-number end-frame-number) 365 (let (result) 366 (map-backtrace (lambda (p context) 367 (push (list :frame p context) result)) 368 start-frame-number end-frame-number) 369 (nreverse result))) 370 371 (defimplementation print-frame (frame stream) 372 (assert (eq (first frame) :frame)) 373 (destructuring-bind (p context) (rest frame) 374 (let ((lfun (ccl:frame-function p context))) 375 (format stream "(~S" (or (ccl:function-name lfun) lfun)) 376 (let* ((unavailable (cons nil nil)) 377 (args (ccl:frame-supplied-arguments p context 378 :unknown-marker unavailable))) 379 (declare (dynamic-extent unavailable)) 380 (if (eq args unavailable) 381 (format stream " #<Unknown Arguments>") 382 (dolist (arg args) 383 (if (eq arg unavailable) 384 (format stream " #<Unavailable>") 385 (format stream " ~s" arg))))) 386 (format stream ")")))) 387 388 (defmacro with-frame ((p context) frame-number &body body) 389 `(call/frame ,frame-number (lambda (,p ,context) . ,body))) 390 391 (defun call/frame (frame-number if-found) 392 (map-backtrace 393 (lambda (p context) 394 (return-from call/frame 395 (funcall if-found p context))) 396 frame-number)) 397 398 (defimplementation frame-var-value (frame var) 399 (with-frame (p context) frame 400 (cdr (nth var (ccl:frame-named-variables p context))))) 401 402 (defimplementation frame-locals (index) 403 (with-frame (p context) index 404 (loop for (name . value) in (ccl:frame-named-variables p context) 405 collect (list :name name :value value :id 0)))) 406 407 (defimplementation frame-source-location (index) 408 (with-frame (p context) index 409 (multiple-value-bind (lfun pc) (ccl:frame-function p context) 410 (if pc 411 (pc-source-location lfun pc) 412 (function-source-location lfun))))) 413 414 (defun function-name-package (name) 415 (etypecase name 416 (null nil) 417 (symbol (symbol-package name)) 418 ((cons (eql ccl::traced)) (function-name-package (second name))) 419 ((cons (eql setf)) (symbol-package (second name))) 420 ((cons (eql :internal)) (function-name-package (car (last name)))) 421 ((cons (and symbol (not keyword)) (or (cons list null) 422 (cons keyword (cons list null)))) 423 (symbol-package (car name))) 424 (standard-method (function-name-package (ccl:method-name name))))) 425 426 (defimplementation frame-package (frame-number) 427 (with-frame (p context) frame-number 428 (let* ((lfun (ccl:frame-function p context)) 429 (name (ccl:function-name lfun))) 430 (function-name-package name)))) 431 432 (defimplementation eval-in-frame (form index) 433 (with-frame (p context) index 434 (let ((vars (ccl:frame-named-variables p context))) 435 (eval `(let ,(loop for (var . val) in vars collect `(,var ',val)) 436 (declare (ignorable ,@(mapcar #'car vars))) 437 ,form))))) 438 439 (defimplementation return-from-frame (index form) 440 (let ((values (multiple-value-list (eval-in-frame form index)))) 441 (with-frame (p context) index 442 (declare (ignore context)) 443 (ccl:apply-in-frame p #'values values)))) 444 445 (defimplementation restart-frame (index) 446 (with-frame (p context) index 447 (ccl:apply-in-frame p 448 (ccl:frame-function p context) 449 (ccl:frame-supplied-arguments p context)))) 450 451 (defimplementation disassemble-frame (the-frame-number) 452 (with-frame (p context) the-frame-number 453 (multiple-value-bind (lfun pc) (ccl:frame-function p context) 454 (format t "LFUN: ~a~%PC: ~a FP: #x~x CONTEXT: ~a~%" lfun pc p context) 455 (disassemble lfun)))) 456 457 ;; CCL commit r11373 | gz | 2008-11-16 16:35:28 +0100 (Sun, 16 Nov 2008) 458 ;; contains some interesting details: 459 ;; 460 ;; Source location are recorded in CCL:SOURCE-NOTE's, which are objects 461 ;; with accessors CCL:SOURCE-NOTE-FILENAME, CCL:SOURCE-NOTE-START-POS, 462 ;; CCL:SOURCE-NOTE-END-POS and CCL:SOURCE-NOTE-TEXT. The start and end 463 ;; positions are file positions (not character positions). The text will 464 ;; be NIL unless text recording was on at read-time. If the original 465 ;; file is still available, you can force missing source text to be read 466 ;; from the file at runtime via CCL:ENSURE-SOURCE-NOTE-TEXT. 467 ;; 468 ;; Source-note's are associated with definitions (via record-source-file) 469 ;; and also stored in function objects (including anonymous and nested 470 ;; functions). The former can be retrieved via 471 ;; CCL:FIND-DEFINITION-SOURCES, the latter via CCL:FUNCTION-SOURCE-NOTE. 472 ;; 473 ;; The recording behavior is controlled by the new variable 474 ;; CCL:*SAVE-SOURCE-LOCATIONS*: 475 ;; 476 ;; If NIL, don't store source-notes in function objects, and store only 477 ;; the filename for definitions (the latter only if 478 ;; *record-source-file* is true). 479 ;; 480 ;; If T, store source-notes, including a copy of the original source 481 ;; text, for function objects and definitions (the latter only if 482 ;; *record-source-file* is true). 483 ;; 484 ;; If :NO-TEXT, store source-notes, but without saved text, for 485 ;; function objects and defintions (the latter only if 486 ;; *record-source-file* is true). This is the default. 487 ;; 488 ;; PC to source mapping is controlled by the new variable 489 ;; CCL:*RECORD-PC-MAPPING*. If true (the default), functions store a 490 ;; compressed table mapping pc offsets to corresponding source locations. 491 ;; This can be retrieved by (CCL:FIND-SOURCE-NOTE-AT-PC function pc) 492 ;; which returns a source-note for the source at offset pc in the 493 ;; function. 494 495 (defun function-source-location (function) 496 (source-note-to-source-location 497 (or (ccl:function-source-note function) 498 (function-name-source-note function)) 499 (lambda () 500 (format nil "Function has no source note: ~A" function)) 501 (ccl:function-name function))) 502 503 (defun pc-source-location (function pc) 504 (source-note-to-source-location 505 (or (ccl:find-source-note-at-pc function pc) 506 (ccl:function-source-note function) 507 (function-name-source-note function)) 508 (lambda () 509 (format nil "No source note at PC: ~a[~d]" function pc)) 510 (ccl:function-name function))) 511 512 (defun function-name-source-note (fun) 513 (let ((defs (ccl:find-definition-sources (ccl:function-name fun) 'function))) 514 (and defs 515 (destructuring-bind ((type . name) srcloc . srclocs) (car defs) 516 (declare (ignore type name srclocs)) 517 srcloc)))) 518 519 (defun source-note-to-source-location (source if-nil-thunk &optional name) 520 (labels ((filename-to-buffer (filename) 521 (cond ((gethash filename *temp-file-map*) 522 (list :buffer (gethash filename *temp-file-map*))) 523 ((probe-file filename) 524 (list :file (ccl:native-translated-namestring 525 (truename filename)))) 526 (t (error "File ~s doesn't exist" filename))))) 527 (handler-case 528 (cond ((ccl:source-note-p source) 529 (let* ((full-text (ccl:source-note-text source)) 530 (file-name (ccl:source-note-filename source)) 531 (start-pos (ccl:source-note-start-pos source))) 532 (make-location 533 (when file-name (filename-to-buffer (pathname file-name))) 534 (when start-pos (list :position (1+ start-pos))) 535 (when full-text 536 (list :snippet (subseq full-text 0 537 (min 40 (length full-text)))))))) 538 ((and source name) 539 ;; This branch is probably never used 540 (make-location 541 (filename-to-buffer source) 542 (list :function-name (princ-to-string 543 (if (functionp name) 544 (ccl:function-name name) 545 name))))) 546 (t `(:error ,(funcall if-nil-thunk)))) 547 (error (c) `(:error ,(princ-to-string c)))))) 548 549 (defun alphatizer-definitions (name) 550 (let ((alpha (gethash name ccl::*nx1-alphatizers*))) 551 (and alpha (ccl:find-definition-sources alpha)))) 552 553 (defun p2-definitions (name) 554 (let ((nx1-op (gethash name ccl::*nx1-operators*))) 555 (and nx1-op 556 (let ((dispatch (ccl::backend-p2-dispatch ccl::*target-backend*)) ) 557 (and (array-in-bounds-p dispatch nx1-op) 558 (let ((p2 (aref dispatch nx1-op))) 559 (and p2 560 (ccl:find-definition-sources p2)))))))) 561 562 (defimplementation find-definitions (name) 563 (let ((defs (append (or (ccl:find-definition-sources name) 564 (and (symbolp name) 565 (fboundp name) 566 (ccl:find-definition-sources 567 (symbol-function name)))) 568 (alphatizer-definitions name) 569 (p2-definitions name)))) 570 (loop for ((type . name) . sources) in defs 571 collect (list (definition-name type name) 572 (source-note-to-source-location 573 (find-if-not #'null sources) 574 (lambda () "No source-note available") 575 name))))) 576 577 (defimplementation find-source-location (obj) 578 (let* ((defs (ccl:find-definition-sources obj)) 579 (best-def (or (find (ccl:name-of obj) defs :key #'cdar :test #'equal) 580 (car defs))) 581 (note (find-if-not #'null (cdr best-def)))) 582 (when note 583 (source-note-to-source-location 584 note 585 (lambda () "No source note available"))))) 586 587 (defun definition-name (type object) 588 (case (ccl:definition-type-name type) 589 (method (ccl:name-of object)) 590 (t (list (ccl:definition-type-name type) (ccl:name-of object))))) 591 592 ;;; Packages 593 594 #+#.(slynk-backend:with-symbol 'package-local-nicknames 'ccl) 595 (defimplementation package-local-nicknames (package) 596 (ccl:package-local-nicknames package)) 597 598 ;;; Utilities 599 600 (defimplementation describe-symbol-for-emacs (symbol) 601 (let ((result '())) 602 (flet ((doc (kind &optional (sym symbol)) 603 (or (documentation sym kind) :not-documented)) 604 (maybe-push (property value) 605 (when value 606 (setf result (list* property value result))))) 607 (maybe-push 608 :variable (when (boundp symbol) 609 (doc 'variable))) 610 (maybe-push 611 :function (if (fboundp symbol) 612 (doc 'function))) 613 (maybe-push 614 :setf (let ((setf-function-name (ccl:setf-function-spec-name 615 `(setf ,symbol)))) 616 (when (fboundp setf-function-name) 617 (doc 'function setf-function-name)))) 618 (maybe-push 619 :type (when (ccl:type-specifier-p symbol) 620 (doc 'type))) 621 result))) 622 623 (defimplementation describe-definition (symbol namespace) 624 (ecase namespace 625 (:variable 626 (describe symbol)) 627 ((:function :generic-function) 628 (describe (symbol-function symbol))) 629 (:setf 630 (describe (ccl:setf-function-spec-name `(setf ,symbol)))) 631 (:class 632 (describe (find-class symbol))) 633 (:type 634 (describe (or (find-class symbol nil) symbol))))) 635 636 ;; spec ::= (:defmethod <name> {<qualifier>}* ({<specializer>}*)) 637 (defun parse-defmethod-spec (spec) 638 (values (second spec) 639 (subseq spec 2 (position-if #'consp spec)) 640 (find-if #'consp (cddr spec)))) 641 642 (defimplementation toggle-trace (spec) 643 "We currently ignore just about everything." 644 (let ((what (ecase (first spec) 645 ((setf) 646 spec) 647 ((:defgeneric) 648 (second spec)) 649 ((:defmethod) 650 (multiple-value-bind (name qualifiers specializers) 651 (parse-defmethod-spec spec) 652 (find-method (fdefinition name) 653 qualifiers 654 specializers)))))) 655 (cond ((member what (trace) :test #'equal) 656 (ccl::%untrace what) 657 (format nil "~S is now untraced." what)) 658 (t 659 (ccl:trace-function what) 660 (format nil "~S is now traced." what))))) 661 662 ;;; Macroexpansion 663 664 (defimplementation macroexpand-all (form &optional env) 665 (ccl:macroexpand-all form env)) 666 667 ;;;; Inspection 668 669 (defun comment-type-p (type) 670 (or (eq type :comment) 671 (and (consp type) (eq (car type) :comment)))) 672 673 (defmethod emacs-inspect ((o t)) 674 (let* ((inspector:*inspector-disassembly* t) 675 (i (inspector:make-inspector o)) 676 (count (inspector:compute-line-count i))) 677 (loop for l from 0 below count append 678 (multiple-value-bind (value label type) (inspector:line-n i l) 679 (etypecase type 680 ((member nil :normal) 681 `(,(or label "") (:value ,value) (:newline))) 682 ((member :colon) 683 (label-value-line label value)) 684 ((member :static) 685 (list (princ-to-string label) " " `(:value ,value) '(:newline))) 686 ((satisfies comment-type-p) 687 (list (princ-to-string label) '(:newline)))))))) 688 689 (defmethod emacs-inspect :around ((o t)) 690 (if (or (uvector-inspector-p o) 691 (not (ccl:uvectorp o))) 692 (call-next-method) 693 (let ((value (call-next-method))) 694 (cond ((listp value) 695 (append value 696 `((:newline) 697 (:value ,(make-instance 'uvector-inspector :object o) 698 "Underlying UVECTOR")))) 699 (t value))))) 700 701 (defmethod emacs-inspect ((f function)) 702 (append 703 (label-value-line "Name" (function-name f)) 704 `("Its argument list is: " 705 ,(princ-to-string (arglist f)) (:newline)) 706 (label-value-line "Documentation" (documentation f t)) 707 (when (function-lambda-expression f) 708 (label-value-line "Lambda Expression" 709 (function-lambda-expression f))) 710 (when (ccl:function-source-note f) 711 (label-value-line "Source note" 712 (ccl:function-source-note f))) 713 (when (typep f 'ccl:compiled-lexical-closure) 714 (append 715 (label-value-line "Inner function" (ccl::closure-function f)) 716 '("Closed over values:" (:newline)) 717 (loop for (name value) in (ccl::closure-closed-over-values f) 718 append (label-value-line (format nil " ~a" name) 719 value)))))) 720 721 (defclass uvector-inspector () 722 ((object :initarg :object))) 723 724 (defgeneric uvector-inspector-p (object) 725 (:method ((object t)) nil) 726 (:method ((object uvector-inspector)) t)) 727 728 (defmethod emacs-inspect ((uv uvector-inspector)) 729 (with-slots (object) uv 730 (loop for i below (ccl:uvsize object) append 731 (label-value-line (princ-to-string i) (ccl:uvref object i))))) 732 733 (defimplementation type-specifier-p (symbol) 734 (or (ccl:type-specifier-p symbol) 735 (not (eq (type-specifier-arglist symbol) :not-available)))) 736 737 ;;; Multiprocessing 738 739 (defvar *known-processes* 740 (make-hash-table :size 20 :weak :key :test #'eq) 741 "A map from threads to mailboxes.") 742 743 (defvar *known-processes-lock* (ccl:make-lock "*known-processes-lock*")) 744 745 (defstruct (mailbox (:conc-name mailbox.)) 746 (mutex (ccl:make-lock "thread mailbox")) 747 (semaphore (ccl:make-semaphore)) 748 (queue '() :type list)) 749 750 (defimplementation spawn (fun &key name) 751 (ccl:process-run-function (or name "Anonymous (Slynk)") 752 fun)) 753 754 (defimplementation thread-id (thread) 755 (ccl:process-serial-number thread)) 756 757 (defimplementation find-thread (id) 758 (find id (ccl:all-processes) :key #'ccl:process-serial-number)) 759 760 (defimplementation thread-name (thread) 761 (ccl:process-name thread)) 762 763 (defimplementation thread-status (thread) 764 (format nil "~A" (ccl:process-whostate thread))) 765 766 (defimplementation thread-attributes (thread) 767 (list :priority (ccl:process-priority thread))) 768 769 (defimplementation make-lock (&key name) 770 (ccl:make-lock name)) 771 772 (defimplementation call-with-lock-held (lock function) 773 (ccl:with-lock-grabbed (lock) 774 (funcall function))) 775 776 (defimplementation current-thread () 777 ccl:*current-process*) 778 779 (defimplementation all-threads () 780 (ccl:all-processes)) 781 782 (defimplementation kill-thread (thread) 783 ;;(ccl:process-kill thread) ; doesn't cut it 784 (ccl::process-initial-form-exited thread :kill)) 785 786 (defimplementation thread-alive-p (thread) 787 (not (ccl:process-exhausted-p thread))) 788 789 (defimplementation interrupt-thread (thread function) 790 (ccl:process-interrupt 791 thread 792 (lambda () 793 (let ((ccl:*top-error-frame* (ccl::%current-exception-frame))) 794 (funcall function))))) 795 796 (defun mailbox (thread) 797 (ccl:with-lock-grabbed (*known-processes-lock*) 798 (or (gethash thread *known-processes*) 799 (setf (gethash thread *known-processes*) (make-mailbox))))) 800 801 (defimplementation send (thread message) 802 (assert message) 803 (let* ((mbox (mailbox thread)) 804 (mutex (mailbox.mutex mbox))) 805 (ccl:with-lock-grabbed (mutex) 806 (setf (mailbox.queue mbox) 807 (nconc (mailbox.queue mbox) (list message))) 808 (ccl:signal-semaphore (mailbox.semaphore mbox))))) 809 810 (defimplementation wake-thread (thread) 811 (let* ((mbox (mailbox thread)) 812 (mutex (mailbox.mutex mbox))) 813 (ccl:with-lock-grabbed (mutex) 814 (ccl:signal-semaphore (mailbox.semaphore mbox))))) 815 816 (defimplementation receive-if (test &optional timeout) 817 (let* ((mbox (mailbox ccl:*current-process*)) 818 (mutex (mailbox.mutex mbox))) 819 (assert (or (not timeout) (eq timeout t))) 820 (loop 821 (check-sly-interrupts) 822 (ccl:with-lock-grabbed (mutex) 823 (let* ((q (mailbox.queue mbox)) 824 (tail (member-if test q))) 825 (when tail 826 (setf (mailbox.queue mbox) 827 (nconc (ldiff q tail) (cdr tail))) 828 (return (car tail))))) 829 (when (eq timeout t) (return (values nil t))) 830 (ccl:wait-on-semaphore (mailbox.semaphore mbox))))) 831 832 (let ((alist '()) 833 (lock (ccl:make-lock "register-thread"))) 834 835 (defimplementation register-thread (name thread) 836 (declare (type symbol name)) 837 (ccl:with-lock-grabbed (lock) 838 (etypecase thread 839 (null 840 (setf alist (delete name alist :key #'car))) 841 (ccl:process 842 (let ((probe (assoc name alist))) 843 (cond (probe (setf (cdr probe) thread)) 844 (t (setf alist (acons name thread alist)))))))) 845 nil) 846 847 (defimplementation find-registered (name) 848 (ccl:with-lock-grabbed (lock) 849 (cdr (assoc name alist))))) 850 851 (defimplementation set-default-initial-binding (var form) 852 (eval `(ccl::def-standard-initial-binding ,var ,form))) 853 854 (defimplementation quit-lisp () 855 (ccl:quit)) 856 857 (defimplementation set-default-directory (directory) 858 (let ((dir (truename (merge-pathnames directory)))) 859 (setf *default-pathname-defaults* (truename (merge-pathnames directory))) 860 (ccl:cwd dir) 861 (default-directory))) 862 863 ;;; Weak datastructures 864 865 (defimplementation make-weak-key-hash-table (&rest args) 866 (apply #'make-hash-table :weak :key args)) 867 868 (defimplementation make-weak-value-hash-table (&rest args) 869 (apply #'make-hash-table :weak :value args)) 870 871 (defimplementation hash-table-weakness (hashtable) 872 (ccl:hash-table-weak-p hashtable)) 873 874 (pushnew 'deinit-log-output ccl:*save-exit-functions*)