allegro.lisp (41473B)
1 ;;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;;* "; -*- 2 ;;; 3 ;;; slynk-allegro.lisp --- Allegro CL specific code for SLY. 4 ;;; 5 ;;; Created 2003 6 ;;; 7 ;;; This code has been placed in the Public Domain. All warranties 8 ;;; are disclaimed. 9 ;;; 10 11 (defpackage slynk-allegro 12 (:use cl slynk-backend)) 13 14 (in-package slynk-allegro) 15 16 (eval-when (:compile-toplevel :load-toplevel :execute) 17 (require :sock) 18 (require :process) 19 #+(version>= 8 2) 20 (require 'lldb) 21 ) 22 23 (defimplementation gray-package-name () 24 '#:excl) 25 26 ;;; slynk-mop 27 28 (import-slynk-mop-symbols :clos '(:slot-definition-documentation)) 29 30 (defun slynk-mop:slot-definition-documentation (slot) 31 (documentation slot t)) 32 33 34 ;;;; UTF8 35 36 (define-symbol-macro utf8-ef 37 (load-time-value 38 (excl:crlf-base-ef (excl:find-external-format :utf-8)) 39 t)) 40 41 (defimplementation string-to-utf8 (s) 42 (excl:string-to-octets s :external-format utf8-ef 43 :null-terminate nil)) 44 45 (defimplementation utf8-to-string (u) 46 (excl:octets-to-string u :external-format utf8-ef)) 47 48 49 ;;;; TCP Server 50 51 (defimplementation preferred-communication-style () 52 :spawn) 53 54 (defimplementation create-socket (host port &key backlog) 55 (socket:make-socket :connect :passive :local-port port 56 :local-host host :reuse-address t 57 :backlog (or backlog 5))) 58 59 (defimplementation local-port (socket) 60 (socket:local-port socket)) 61 62 (defimplementation close-socket (socket) 63 (close socket)) 64 65 (defimplementation accept-connection (socket &key external-format buffering 66 timeout) 67 (declare (ignore buffering timeout)) 68 (let ((s (socket:accept-connection socket :wait t))) 69 (when external-format 70 (setf (stream-external-format s) external-format)) 71 s)) 72 73 (defimplementation socket-fd (stream) 74 (excl::stream-input-handle stream)) 75 76 (defvar *external-format-to-coding-system* 77 '((:iso-8859-1 78 "latin-1" "latin-1-unix" "iso-latin-1-unix" 79 "iso-8859-1" "iso-8859-1-unix") 80 (:utf-8 "utf-8" "utf-8-unix") 81 (:euc-jp "euc-jp" "euc-jp-unix") 82 (:us-ascii "us-ascii" "us-ascii-unix") 83 (:emacs-mule "emacs-mule" "emacs-mule-unix"))) 84 85 (defimplementation find-external-format (coding-system) 86 (let ((e (rassoc-if (lambda (x) (member coding-system x :test #'equal)) 87 *external-format-to-coding-system*))) 88 (and e (excl:crlf-base-ef 89 (excl:find-external-format (car e) 90 :try-variant t))))) 91 92 ;;;; Unix signals 93 94 (defimplementation getpid () 95 (excl::getpid)) 96 97 (defimplementation lisp-implementation-type-name () 98 "allegro") 99 100 (defimplementation set-default-directory (directory) 101 (let* ((dir (namestring (truename (merge-pathnames directory))))) 102 (setf *default-pathname-defaults* (pathname (excl:chdir dir))) 103 dir)) 104 105 (defimplementation default-directory () 106 (namestring (excl:current-directory))) 107 108 ;;;; Misc 109 110 (defimplementation arglist (symbol) 111 (handler-case (excl:arglist symbol) 112 (simple-error () :not-available))) 113 114 (defimplementation macroexpand-all (form &optional env) 115 (declare (ignore env)) 116 #+(version>= 8 0) 117 (excl::walk-form form) 118 #-(version>= 8 0) 119 (excl::walk form)) 120 121 (defimplementation describe-symbol-for-emacs (symbol) 122 (let ((result '())) 123 (flet ((doc (kind &optional (sym symbol)) 124 (or (ignore-errors 125 (documentation sym kind)) 126 :not-documented)) 127 (maybe-push (property value) 128 (when value 129 (setf result (list* property value result))))) 130 (maybe-push 131 :variable (when (boundp symbol) 132 (doc 'variable))) 133 (maybe-push 134 :function (if (fboundp symbol) 135 (doc 'function))) 136 (maybe-push 137 :class (if (find-class symbol nil) 138 (doc 'class))) 139 result))) 140 141 (defimplementation describe-definition (symbol namespace) 142 (ecase namespace 143 (:variable 144 (describe symbol)) 145 ((:function :generic-function) 146 (describe (symbol-function symbol))) 147 (:class 148 (describe (find-class symbol))))) 149 150 (defimplementation type-specifier-p (symbol) 151 (or (ignore-errors 152 (subtypep nil symbol)) 153 (not (eq (type-specifier-arglist symbol) :not-available)))) 154 155 (defimplementation function-name (f) 156 (check-type f function) 157 (cross-reference::object-to-function-name f)) 158 159 ;;;; Debugger 160 161 (defvar *sly-db-topframe*) 162 163 (defimplementation call-with-debugging-environment (debugger-loop-fn) 164 (let ((*sly-db-topframe* (find-topframe)) 165 (excl::*break-hook* nil)) 166 (funcall debugger-loop-fn))) 167 168 (defimplementation sly-db-break-at-start (fname) 169 ;; :print-before is kind of mis-used but we just want to stuff our 170 ;; break form somewhere. This does not work for setf, :before and 171 ;; :after methods, which need special syntax in the trace call, see 172 ;; ACL's doc/debugging.htm chapter 10. 173 (eval `(trace (,fname 174 :print-before 175 ((break "Function start breakpoint of ~A" ',fname))))) 176 `(:ok ,(format nil "Set breakpoint at start of ~S" fname))) 177 178 (defun find-topframe () 179 (let ((magic-symbol (intern (symbol-name :slynk-debugger-hook) 180 (find-package :slynk))) 181 (top-frame (excl::int-newest-frame (excl::current-thread)))) 182 (loop for frame = top-frame then (next-frame frame) 183 for i from 0 184 while (and frame (< i 30)) 185 when (eq (debugger:frame-name frame) magic-symbol) 186 return (next-frame frame) 187 finally (return top-frame)))) 188 189 (defun next-frame (frame) 190 (let ((next (excl::int-next-older-frame frame))) 191 (cond ((not next) nil) 192 ((debugger:frame-visible-p next) next) 193 (t (next-frame next))))) 194 195 (defun nth-frame (index) 196 (do ((frame *sly-db-topframe* (next-frame frame)) 197 (i index (1- i))) 198 ((zerop i) frame))) 199 200 (defimplementation compute-backtrace (start end) 201 (let ((end (or end most-positive-fixnum))) 202 (loop for f = (nth-frame start) then (next-frame f) 203 for i from start below end 204 while f collect f))) 205 206 (defimplementation print-frame (frame stream) 207 (debugger:output-frame stream frame :moderate)) 208 209 (defimplementation frame-locals (index) 210 (let ((frame (nth-frame index))) 211 (loop for i from 0 below (debugger:frame-number-vars frame) 212 collect (list :name (debugger:frame-var-name frame i) 213 :id 0 214 :value (debugger:frame-var-value frame i))))) 215 216 (defimplementation frame-arguments (index) 217 (let ((frame (nth-frame index))) 218 ;; (values-list (debugger::.actuals frame)) 219 (values-list 220 (loop for i from 0 below (debugger:frame-number-vars frame) 221 unless (eq :local (debugger:frame-var-type frame i)) 222 collect (debugger:frame-var-value frame i))))) 223 224 (defimplementation frame-var-value (frame var) 225 (let ((frame (nth-frame frame))) 226 (debugger:frame-var-value frame var))) 227 228 (defimplementation disassemble-frame (index) 229 (let ((frame (nth-frame index))) 230 (multiple-value-bind (x fun xx xxx pc) (debugger::dyn-fd-analyze frame) 231 (format t "pc: ~d (~s ~s ~s)~%fun: ~a~%" pc x xx xxx fun) 232 (disassemble (debugger:frame-function frame))))) 233 234 (defimplementation frame-source-location (index) 235 (let* ((frame (nth-frame index))) 236 (multiple-value-bind (x fun xx xxx pc) (debugger::dyn-fd-analyze frame) 237 (declare (ignore x xx xxx)) 238 (cond ((and pc 239 #+(version>= 8 2) 240 (pc-source-location fun pc) 241 #-(version>= 8 2) 242 (function-source-location fun))) 243 (t ; frames for unbound functions etc end up here 244 (cadr (car (fspec-definition-locations 245 (car (debugger:frame-expression frame)))))))))) 246 247 (defun function-source-location (fun) 248 (cadr (car (fspec-definition-locations 249 (xref::object-to-function-name fun))))) 250 251 #+(version>= 8 2) 252 (defun pc-source-location (fun pc) 253 (let* ((debug-info (excl::function-source-debug-info fun))) 254 (cond ((not debug-info) 255 (function-source-location fun)) 256 (t 257 (let* ((code-loc (find-if (lambda (c) 258 (<= (- pc (sys::natural-width)) 259 (let ((x (excl::ldb-code-pc c))) 260 (or x -1)) 261 pc)) 262 debug-info))) 263 (cond ((not code-loc) 264 (ldb-code-to-src-loc (aref debug-info 0))) 265 (t 266 (ldb-code-to-src-loc code-loc)))))))) 267 268 #+(version>= 8 2) 269 (defun ldb-code-to-src-loc (code) 270 (declare (optimize debug)) 271 (let* ((func (excl::ldb-code-func code)) 272 (debug-info (excl::function-source-debug-info func)) 273 (start (and debug-info 274 (loop for i from (excl::ldb-code-index code) downto 0 275 for bpt = (aref debug-info i) 276 for start = (excl::ldb-code-start-char bpt) 277 when start 278 return (if (listp start) 279 (first start) 280 start)))) 281 (src-file (and func (excl:source-file func)))) 282 (cond (start 283 (buffer-or-file-location src-file start)) 284 (func 285 (let* ((debug-info (excl::function-source-debug-info func)) 286 (whole (aref debug-info 0)) 287 (paths (source-paths-of (excl::ldb-code-source whole) 288 (excl::ldb-code-source code))) 289 (path (if paths (longest-common-prefix paths) '())) 290 (start 0)) 291 (buffer-or-file 292 src-file 293 (lambda (file) 294 (make-location `(:file ,file) 295 `(:source-path (0 . ,path) ,start))) 296 (lambda (buffer bstart) 297 (make-location `(:buffer ,buffer) 298 `(:source-path (0 . ,path) 299 ,(+ bstart start))))))) 300 (t 301 nil)))) 302 303 (defun longest-common-prefix (sequences) 304 (assert sequences) 305 (flet ((common-prefix (s1 s2) 306 (let ((diff-pos (mismatch s1 s2))) 307 (if diff-pos (subseq s1 0 diff-pos) s1)))) 308 (reduce #'common-prefix sequences))) 309 310 (defun source-paths-of (whole part) 311 (let ((result '())) 312 (labels ((walk (form path) 313 (cond ((eq form part) 314 (push (reverse path) result)) 315 ((consp form) 316 (loop for i from 0 while (consp form) do 317 (walk (pop form) (cons i path))))))) 318 (walk whole '()) 319 (reverse result)))) 320 321 (defimplementation eval-in-frame (form frame-number) 322 (let ((frame (nth-frame frame-number))) 323 ;; let-bind lexical variables 324 (let ((vars (loop for i below (debugger:frame-number-vars frame) 325 for name = (debugger:frame-var-name frame i) 326 if (typep name '(and symbol (not null) (not keyword))) 327 collect `(,name ',(debugger:frame-var-value frame i))))) 328 (debugger:eval-form-in-context 329 `(let* ,vars ,form) 330 (debugger:environment-of-frame frame))))) 331 332 (defimplementation frame-package (frame-number) 333 (let* ((frame (nth-frame frame-number)) 334 (exp (debugger:frame-expression frame))) 335 (typecase exp 336 ((cons symbol) (symbol-package (car exp))) 337 ((cons (cons (eql :internal) (cons symbol))) 338 (symbol-package (cadar exp)))))) 339 340 (defimplementation return-from-frame (frame-number form) 341 (let ((frame (nth-frame frame-number))) 342 (multiple-value-call #'debugger:frame-return 343 frame (debugger:eval-form-in-context 344 form 345 (debugger:environment-of-frame frame))))) 346 347 (defimplementation frame-restartable-p (frame) 348 (handler-case (debugger:frame-retryable-p frame) 349 (serious-condition (c) 350 (declare (ignore c)) 351 ;; How to log this? Should we? 352 nil))) 353 354 (defimplementation restart-frame (frame-number) 355 (let ((frame (nth-frame frame-number))) 356 (cond ((frame-restartable-p frame) 357 (apply #'debugger:frame-retry frame (debugger:frame-function frame) 358 (cdr (debugger:frame-expression frame)))) 359 (t "Frame is not retryable")))) 360 361 ;;;; Compiler hooks 362 363 (defvar *buffer-name* nil) 364 (defvar *buffer-start-position*) 365 (defvar *buffer-string*) 366 (defvar *compile-filename* nil) 367 368 (defun compiler-note-p (object) 369 (member (type-of object) '(excl::compiler-note compiler::compiler-note))) 370 371 (defun redefinition-p (condition) 372 (and (typep condition 'style-warning) 373 (every #'char-equal "redefin" (princ-to-string condition)))) 374 375 (defun compiler-undefined-functions-called-warning-p (object) 376 (typep object 'excl:compiler-undefined-functions-called-warning)) 377 378 (deftype compiler-note () 379 `(satisfies compiler-note-p)) 380 381 (deftype redefinition () 382 `(satisfies redefinition-p)) 383 384 (defun signal-compiler-condition (&rest args) 385 (apply #'signal 'compiler-condition args)) 386 387 (defun handle-compiler-warning (condition) 388 (declare (optimize (debug 3) (speed 0) (space 0))) 389 (cond ((and #-(version>= 10 0) (not *buffer-name*) 390 (compiler-undefined-functions-called-warning-p condition)) 391 (handle-undefined-functions-warning condition)) 392 ((and (typep condition 'excl::compiler-note) 393 (let ((format (slot-value condition 'excl::format-control))) 394 (and (search "Closure" format) 395 (search "will be stack allocated" format)))) 396 ;; Ignore "Closure <foo> will be stack allocated" notes. 397 ;; That occurs often but is usually uninteresting. 398 ) 399 (t 400 (signal-compiler-condition 401 :original-condition condition 402 :severity (etypecase condition 403 (redefinition :redefinition) 404 (style-warning :style-warning) 405 (warning :warning) 406 (compiler-note :note) 407 (reader-error :read-error) 408 (error :error)) 409 :message (format nil "~A" condition) 410 :location (compiler-warning-location condition))))) 411 412 (defun condition-pathname-and-position (condition) 413 (let* ((context #+(version>= 10 0) 414 (getf (slot-value condition 'excl::plist) 415 :source-context)) 416 (location-available (and context 417 (excl::source-context-start-char context)))) 418 (cond (location-available 419 (values (excl::source-context-pathname context) 420 (when-let (start-char (excl::source-context-start-char context)) 421 (let ((position (if (listp start-char) ; HACK 422 (first start-char) 423 start-char))) 424 (if (typep condition 'excl::compiler-free-reference-warning) 425 position 426 (1+ position)))))) 427 ((typep condition 'reader-error) 428 (let ((pos (car (last (slot-value condition 'excl::format-arguments)))) 429 (file (pathname (stream-error-stream condition)))) 430 (when (integerp pos) 431 (values file pos)))) 432 (t 433 (let ((loc (getf (slot-value condition 'excl::plist) :loc))) 434 (when loc 435 (destructuring-bind (file . pos) loc 436 (let ((start 437 (if (consp pos) 438 ;; FIXME: report this bug to Franz. See 439 ;; the commit message for recipe 440 #+(version>= 10 1) 441 (if (typep 442 condition 443 'excl::compiler-inconsistent-name-usage-warning) 444 (second pos) (first pos)) 445 #-(version>= 10 1) 446 (first pos) 447 pos))) 448 (values file start))))))))) 449 450 (defun compiler-warning-location (condition) 451 (multiple-value-bind (pathname position) 452 (condition-pathname-and-position condition) 453 (cond (*buffer-name* 454 (make-location 455 (list :buffer *buffer-name*) 456 (if position 457 (list :offset 1 (1- position)) 458 (list :offset *buffer-start-position* 0)))) 459 (pathname 460 (make-location 461 (list :file (namestring (truename pathname))) 462 #+(version>= 10 1) 463 (list :offset 1 position) 464 #-(version>= 10 1) 465 (list :position (1+ position)))) 466 (t 467 (make-error-location "No error location available."))))) 468 469 ;; TODO: report it as a bug to Franz that the condition's plist 470 ;; slot contains (:loc nil). 471 (defun handle-undefined-functions-warning (condition) 472 (let ((fargs (slot-value condition 'excl::format-arguments))) 473 (loop for (fname . locs) in (car fargs) do 474 (dolist (loc locs) 475 (multiple-value-bind (pos file) (ecase (length loc) 476 (2 (values-list loc)) 477 (3 (destructuring-bind 478 (start end file) loc 479 (declare (ignore end)) 480 (values start file)))) 481 (signal-compiler-condition 482 :original-condition condition 483 :severity :warning 484 :message (format nil "Undefined function referenced: ~S" 485 fname) 486 :location (make-location (list :file file) 487 #+(version>= 9 0) 488 (list :offset 1 pos) 489 #-(version>= 9 0) 490 (list :position (1+ pos))))))))) 491 492 (defimplementation call-with-compilation-hooks (function) 493 (handler-bind ((warning #'handle-compiler-warning) 494 (compiler-note #'handle-compiler-warning) 495 (reader-error #'handle-compiler-warning)) 496 (funcall function))) 497 498 (defimplementation slynk-compile-file (input-file output-file 499 load-p external-format 500 &key policy) 501 (declare (ignore policy)) 502 (handler-case 503 (with-compilation-hooks () 504 (let ((*buffer-name* nil) 505 (*compile-filename* input-file) 506 #+(version>= 8 2) 507 (compiler:save-source-level-debug-info-switch t) 508 (excl:*load-source-file-info* t) 509 #+(version>= 8 2) 510 (excl:*load-source-debug-info* t)) 511 (compile-file *compile-filename* 512 :output-file output-file 513 :load-after-compile load-p 514 :external-format external-format))) 515 (reader-error () (values nil nil t)))) 516 517 (defun call-with-temp-file (fn) 518 (let ((tmpname (system:make-temp-file-name))) 519 (unwind-protect 520 (with-open-file (file tmpname :direction :output :if-exists :error) 521 (funcall fn file tmpname)) 522 (delete-file tmpname)))) 523 524 (defvar *temp-file-map* (make-hash-table :test #'equal) 525 "A mapping from tempfile names to Emacs buffer names.") 526 527 (defun write-tracking-preamble (stream file file-offset) 528 "Instrument the top of the temporary file to be compiled. 529 530 The header tells allegro that any definitions compiled in the temp 531 file should be found in FILE exactly at FILE-OFFSET. To get Allegro 532 to do this, this factors in the length of the inserted header itself." 533 (with-standard-io-syntax 534 (let* ((*package* (find-package :keyword)) 535 (source-pathname-form 536 `(cl:eval-when (:compile-toplevel :load-toplevel :execute) 537 (cl:setq excl::*source-pathname* 538 (pathname ,(sys::frob-source-file file))))) 539 (source-pathname-string (write-to-string source-pathname-form)) 540 (position-form-length-bound 160) ; should be enough for everyone 541 (header-length (+ (length source-pathname-string) 542 position-form-length-bound)) 543 (position-form 544 `(cl:eval-when (:compile-toplevel :load-toplevel :execute) 545 (cl:setq excl::*partial-source-file-p* ,(- file-offset 546 header-length 547 1 ; for the newline 548 )))) 549 (position-form-string (write-to-string position-form)) 550 (padding-string (make-string (- position-form-length-bound 551 (length position-form-string)) 552 :initial-element #\;))) 553 (write-string source-pathname-string stream) 554 (write-string position-form-string stream) 555 (write-string padding-string stream) 556 (write-char #\newline stream)))) 557 558 (defun compile-from-temp-file (string buffer offset file) 559 (call-with-temp-file 560 (lambda (stream filename) 561 (when (and file offset (probe-file file)) 562 (write-tracking-preamble stream file offset)) 563 (write-string string stream) 564 (finish-output stream) 565 (multiple-value-bind (binary-filename warnings? failure?) 566 (let ((sys:*source-file-types* '(nil)) ; suppress .lisp extension 567 #+(version>= 8 2) 568 (compiler:save-source-level-debug-info-switch t) 569 (excl:*redefinition-warnings* nil)) 570 (compile-file filename)) 571 (declare (ignore warnings?)) 572 (when binary-filename 573 (let ((excl:*load-source-file-info* t) 574 #+(version>= 8 2) 575 (excl:*load-source-debug-info* t)) 576 excl::*source-pathname* 577 (load binary-filename)) 578 (when (and buffer offset (or (not file) 579 (not (probe-file file)))) 580 (setf (gethash (pathname stream) *temp-file-map*) 581 (list buffer offset))) 582 (delete-file binary-filename)) 583 (not failure?))))) 584 585 (defimplementation slynk-compile-string (string &key buffer position filename 586 line column policy) 587 (declare (ignore line column policy)) 588 (handler-case 589 (with-compilation-hooks () 590 (let ((*buffer-name* buffer) 591 (*buffer-start-position* position) 592 (*buffer-string* string)) 593 (compile-from-temp-file string buffer position filename))) 594 (reader-error () nil))) 595 596 ;;;; Definition Finding 597 598 (defun buffer-or-file (file file-fun buffer-fun) 599 (let* ((probe (gethash file *temp-file-map*))) 600 (cond (probe 601 (destructuring-bind (buffer start) probe 602 (funcall buffer-fun buffer start))) 603 (t (funcall file-fun (namestring (truename file))))))) 604 605 (defun buffer-or-file-location (file offset) 606 (buffer-or-file file 607 (lambda (filename) 608 (make-location `(:file ,filename) 609 `(:position ,(1+ offset)))) 610 (lambda (buffer start) 611 (make-location `(:buffer ,buffer) 612 `(:offset ,start ,offset))))) 613 614 (defun fspec-primary-name (fspec) 615 (etypecase fspec 616 (symbol fspec) 617 (list (fspec-primary-name (second fspec))))) 618 619 (defun find-definition-in-file (fspec type file top-level) 620 (let* ((part 621 (or (scm::find-definition-in-definition-group 622 fspec type (scm:section-file :file file) 623 :top-level top-level) 624 (scm::find-definition-in-definition-group 625 (fspec-primary-name fspec) 626 type (scm:section-file :file file) 627 :top-level top-level))) 628 (start (and part 629 (scm::source-part-start part))) 630 (pos (if start 631 (list :offset 1 start) 632 (list :function-name (string (fspec-primary-name fspec)))))) 633 (make-location (list :file (namestring (truename file))) 634 pos))) 635 636 (defun find-fspec-location (fspec type file top-level) 637 (handler-case 638 (etypecase file 639 (pathname 640 (let ((probe (gethash file *temp-file-map*))) 641 (cond (probe 642 (destructuring-bind (buffer offset) probe 643 (make-location `(:buffer ,buffer) 644 `(:offset ,offset 0)))) 645 (t 646 (find-definition-in-file fspec type file top-level))))) 647 ((member :top-level) 648 (make-error-location "Defined at toplevel: ~A" 649 (fspec->string fspec)))) 650 (error (e) 651 (make-error-location "Error: ~A" e)))) 652 653 (defun fspec->string (fspec) 654 (typecase fspec 655 (symbol (let ((*package* (find-package :keyword))) 656 (prin1-to-string fspec))) 657 (list (format nil "(~A ~A)" 658 (prin1-to-string (first fspec)) 659 (let ((*package* (find-package :keyword))) 660 (prin1-to-string (second fspec))))) 661 (t (princ-to-string fspec)))) 662 663 (defun fspec-definition-locations (fspec) 664 (cond 665 ((and (listp fspec) (eq (car fspec) :internal)) 666 (destructuring-bind (_internal next _n) fspec 667 (declare (ignore _internal _n)) 668 (fspec-definition-locations next))) 669 (t 670 (let ((defs (excl::find-source-file fspec))) 671 (when (and (null defs) 672 (listp fspec) 673 (string= (car fspec) '#:method)) 674 ;; If methods are defined in a defgeneric form, the source location is 675 ;; recorded for the gf but not for the methods. Therefore fall back to 676 ;; the gf as the likely place of definition. 677 (setq defs (excl::find-source-file (second fspec)))) 678 (if (null defs) 679 (list 680 (list fspec 681 (make-error-location "Unknown source location for ~A" 682 (fspec->string fspec)))) 683 (loop for (fspec type file top-level) in defs collect 684 (list (list type fspec) 685 (find-fspec-location fspec type file top-level)))))))) 686 687 (defimplementation find-definitions (symbol) 688 (fspec-definition-locations symbol)) 689 690 (defimplementation find-source-location (obj) 691 (first (rest (first (fspec-definition-locations obj))))) 692 693 ;;;; XREF 694 695 (defmacro defxref (name relation name1 name2) 696 `(defimplementation ,name (x) 697 (xref-result (xref:get-relation ,relation ,name1 ,name2)))) 698 699 (defxref who-calls :calls :wild x) 700 (defxref calls-who :calls x :wild) 701 (defxref who-references :uses :wild x) 702 (defxref who-binds :binds :wild x) 703 (defxref who-macroexpands :macro-calls :wild x) 704 (defxref who-sets :sets :wild x) 705 706 (defun xref-result (fspecs) 707 (loop for fspec in fspecs 708 append (fspec-definition-locations fspec))) 709 710 ;; list-callers implemented by groveling through all fbound symbols. 711 ;; Only symbols are considered. Functions in the constant pool are 712 ;; searched recursively. Closure environments are ignored at the 713 ;; moment (constants in methods are therefore not found). 714 715 (defun map-function-constants (function fn depth) 716 "Call FN with the elements of FUNCTION's constant pool." 717 (do ((i 0 (1+ i)) 718 (max (excl::function-constant-count function))) 719 ((= i max)) 720 (let ((c (excl::function-constant function i))) 721 (cond ((and (functionp c) 722 (not (eq c function)) 723 (plusp depth)) 724 (map-function-constants c fn (1- depth))) 725 (t 726 (funcall fn c)))))) 727 728 (defun in-constants-p (fun symbol) 729 (map-function-constants fun 730 (lambda (c) 731 (when (eq c symbol) 732 (return-from in-constants-p t))) 733 3)) 734 735 (defun function-callers (name) 736 (let ((callers '())) 737 (do-all-symbols (sym) 738 (when (fboundp sym) 739 (let ((fn (fdefinition sym))) 740 (when (in-constants-p fn name) 741 (push sym callers))))) 742 callers)) 743 744 (defimplementation list-callers (name) 745 (xref-result (function-callers name))) 746 747 (defimplementation list-callees (name) 748 (let ((result '())) 749 (map-function-constants (fdefinition name) 750 (lambda (c) 751 (when (fboundp c) 752 (push c result))) 753 2) 754 (xref-result result))) 755 756 ;;;; Profiling 757 758 ;; Per-function profiling based on description in 759 ;; http://www.franz.com/support/documentation/8.0/\ 760 ;; doc/runtime-analyzer.htm#data-collection-control-2 761 762 (defvar *profiled-functions* ()) 763 (defvar *profile-depth* 0) 764 765 (defmacro with-redirected-y-or-n-p (&body body) 766 ;; If the profiler is restarted when the data from the previous 767 ;; session is not reported yet, the user is warned via Y-OR-N-P. 768 ;; As the CL:Y-OR-N-P question is (for some reason) not directly 769 ;; sent to the Sly user, the function CL:Y-OR-N-P is temporarily 770 ;; overruled. 771 `(let* ((pkg (find-package :common-lisp)) 772 (saved-pdl (excl::package-definition-lock pkg)) 773 (saved-ynp (symbol-function 'cl:y-or-n-p))) 774 (setf (excl::package-definition-lock pkg) nil 775 (symbol-function 'cl:y-or-n-p) 776 (symbol-function (read-from-string "slynk:y-or-n-p-in-emacs"))) 777 (unwind-protect 778 (progn ,@body) 779 (setf (symbol-function 'cl:y-or-n-p) saved-ynp 780 (excl::package-definition-lock pkg) saved-pdl)))) 781 782 (defun start-acl-profiler () 783 (with-redirected-y-or-n-p 784 (prof:start-profiler :type :time :count t 785 :start-sampling-p nil :verbose nil))) 786 (defun acl-profiler-active-p () 787 (not (eq (prof:profiler-status :verbose nil) :inactive))) 788 789 (defun stop-acl-profiler () 790 (prof:stop-profiler :verbose nil)) 791 792 (excl:def-fwrapper profile-fwrapper (&rest args) 793 ;; Ensures sampling is done during the execution of the function, 794 ;; taking into account recursion. 795 (declare (ignore args)) 796 (cond ((zerop *profile-depth*) 797 (let ((*profile-depth* (1+ *profile-depth*))) 798 (prof:start-sampling) 799 (unwind-protect (excl:call-next-fwrapper) 800 (prof:stop-sampling)))) 801 (t 802 (excl:call-next-fwrapper)))) 803 804 (defimplementation profile (fname) 805 (unless (acl-profiler-active-p) 806 (start-acl-profiler)) 807 (excl:fwrap fname 'profile-fwrapper 'profile-fwrapper) 808 (push fname *profiled-functions*)) 809 810 (defimplementation profiled-functions () 811 *profiled-functions*) 812 813 (defimplementation unprofile (fname) 814 (excl:funwrap fname 'profile-fwrapper) 815 (setq *profiled-functions* (remove fname *profiled-functions*))) 816 817 (defimplementation profile-report () 818 (prof:show-flat-profile :verbose nil) 819 (when *profiled-functions* 820 (start-acl-profiler))) 821 822 (defimplementation profile-reset () 823 (when (acl-profiler-active-p) 824 (stop-acl-profiler) 825 (start-acl-profiler)) 826 "Reset profiling counters.") 827 828 ;;;; Inspecting 829 830 (excl:without-redefinition-warnings 831 (defmethod emacs-inspect ((o t)) 832 (allegro-inspect o))) 833 834 (defmethod emacs-inspect ((o function)) 835 (allegro-inspect o)) 836 837 (defmethod emacs-inspect ((o standard-object)) 838 (allegro-inspect o)) 839 840 (defun allegro-inspect (o) 841 (loop for (d dd) on (inspect::inspect-ctl o) 842 append (frob-allegro-field-def o d) 843 until (eq d dd))) 844 845 (defun frob-allegro-field-def (object def) 846 (with-struct (inspect::field-def- name type access) def 847 (ecase type 848 ((:unsigned-word :unsigned-byte :unsigned-natural 849 :unsigned-long :unsigned-half-long 850 :unsigned-3byte :unsigned-long32) 851 (label-value-line name (inspect::component-ref-v object access type))) 852 ((:lisp :value :func) 853 (label-value-line name (inspect::component-ref object access))) 854 (:indirect 855 (destructuring-bind (prefix count ref set) access 856 (declare (ignore set prefix)) 857 (loop for i below (funcall count object) 858 append (label-value-line (format nil "~A-~D" name i) 859 (funcall ref object i)))))))) 860 861 ;;;; Multithreading 862 863 (defimplementation initialize-multiprocessing (continuation) 864 (mp:start-scheduler) 865 (funcall continuation)) 866 867 (defimplementation spawn (fn &key name) 868 (mp:process-run-function name fn)) 869 870 (defvar *process-plist-lock* (mp:make-process-lock :name "process-plist-lock")) 871 (defvar *thread-id-counter* 0) 872 873 (defimplementation thread-id (thread) 874 #+(version>= 10 0) 875 (mp:process-sequence thread) 876 #-(version> 10 0) 877 (mp:with-process-lock (*process-plist-lock*) 878 (or (getf (mp:process-property-list thread) 'id) 879 (setf (getf (mp:process-property-list thread) 'id) 880 (incf *thread-id-counter*))))) 881 882 (defimplementation find-thread (id) 883 (find id mp:*all-processes* 884 :key 885 #+(version>= 10 0) 886 #'mp:process-sequence 887 #-(version>= 10 0) 888 (lambda (p) (getf (mp:process-property-list p) 'id)))) 889 890 (defimplementation thread-name (thread) 891 (mp:process-name thread)) 892 893 (defimplementation thread-status (thread) 894 (princ-to-string (mp:process-whostate thread))) 895 896 (defimplementation thread-attributes (thread) 897 (list :priority (mp:process-priority thread) 898 :times-resumed (mp:process-times-resumed thread))) 899 900 (defimplementation make-lock (&key name) 901 (mp:make-process-lock :name name)) 902 903 (defimplementation call-with-lock-held (lock function) 904 (mp:with-process-lock (lock) (funcall function))) 905 906 (defimplementation current-thread () 907 mp:*current-process*) 908 909 (defimplementation all-threads () 910 (copy-list mp:*all-processes*)) 911 912 (defimplementation interrupt-thread (thread fn) 913 (mp:process-interrupt thread fn)) 914 915 (defimplementation kill-thread (thread) 916 (mp:process-kill thread)) 917 918 (defstruct (mailbox (:conc-name mailbox.)) 919 (lock (mp:make-process-lock :name "process mailbox")) 920 (queue '() :type list) 921 (gate (mp:make-gate nil))) 922 923 (defvar *global-mailbox-ht-lock* 924 (mp:make-process-lock :name '*global-mailbox-ht-lock*)) 925 926 (defvar *mailboxes* (make-hash-table :weak-keys t) 927 "Threads' mailboxes.") 928 929 (defun mailbox (thread) 930 "Return THREAD's mailbox." 931 (mp:with-process-lock (*global-mailbox-ht-lock*) 932 (or (gethash thread *mailboxes*) 933 (setf (gethash thread *mailboxes*) (make-mailbox))))) 934 935 (defimplementation send (thread message) 936 (let* ((mbox (mailbox thread))) 937 (mp:with-process-lock ((mailbox.lock mbox)) 938 (setf (mailbox.queue mbox) 939 (nconc (mailbox.queue mbox) (list message))) 940 (mp:open-gate (mailbox.gate mbox))))) 941 942 (defimplementation wake-thread (thread) 943 (let* ((mbox (mailbox thread))) 944 (mp:open-gate (mailbox.gate mbox)))) 945 946 (defimplementation receive-if (test &optional timeout) 947 (let ((mbox (mailbox mp:*current-process*))) 948 (flet ((open-mailbox () 949 ;; this opens the mailbox and returns if has the message 950 ;; we are expecting. But first, check for interrupts. 951 (check-sly-interrupts) 952 (mp:with-process-lock ((mailbox.lock mbox)) 953 (let* ((q (mailbox.queue mbox)) 954 (tail (member-if test q))) 955 (when tail 956 (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) 957 (return-from receive-if (car tail))) 958 ;; ...if it doesn't, we close the gate (even if it 959 ;; was already closed) 960 (mp:close-gate (mailbox.gate mbox)))))) 961 (cond (timeout 962 ;; open the mailbox and return asap 963 (open-mailbox) 964 (return-from receive-if (values nil t))) 965 (t 966 ;; wait until gate open, then open mailbox. If there's 967 ;; no message there, repeat forever. 968 (loop 969 (mp:process-wait 970 "receive-if (waiting on gate)" 971 #'mp:gate-open-p (mailbox.gate mbox)) 972 (open-mailbox))))))) 973 974 (let ((alist '()) 975 (lock (mp:make-process-lock :name "register-thread"))) 976 977 (defimplementation register-thread (name thread) 978 (declare (type symbol name)) 979 (mp:with-process-lock (lock) 980 (etypecase thread 981 (null 982 (setf alist (delete name alist :key #'car))) 983 (mp:process 984 (let ((probe (assoc name alist))) 985 (cond (probe (setf (cdr probe) thread)) 986 (t (setf alist (acons name thread alist)))))))) 987 nil) 988 989 (defimplementation find-registered (name) 990 (mp:with-process-lock (lock) 991 (cdr (assoc name alist))))) 992 993 (defimplementation set-default-initial-binding (var form) 994 (push (cons var form) 995 #+(version>= 9 0) 996 excl:*required-thread-bindings* 997 #-(version>= 9 0) 998 excl::required-thread-bindings)) 999 1000 (defimplementation quit-lisp () 1001 (excl:exit 0 :quiet t)) 1002 1003 1004 ;;Trace implementations 1005 ;;In Allegro 7.0, we have: 1006 ;; (trace <name>) 1007 ;; (trace ((method <name> <qualifier>? (<specializer>+)))) 1008 ;; (trace ((labels <name> <label-name>))) 1009 ;; (trace ((labels (method <name> (<specializer>+)) <label-name>))) 1010 ;; <name> can be a normal name or a (setf name) 1011 1012 (defimplementation toggle-trace (spec) 1013 (ecase (car spec) 1014 ((setf) 1015 (toggle-trace-aux spec)) 1016 (:defgeneric (toggle-trace-generic-function-methods (second spec))) 1017 ((setf :defmethod :labels :flet) 1018 (toggle-trace-aux (process-fspec-for-allegro spec))) 1019 (:call 1020 (destructuring-bind (caller callee) (cdr spec) 1021 (toggle-trace-aux callee 1022 :inside (list (process-fspec-for-allegro caller))))))) 1023 1024 (defun tracedp (fspec) 1025 (member fspec (eval '(trace)) :test #'equal)) 1026 1027 (defun toggle-trace-aux (fspec &rest args) 1028 (cond ((tracedp fspec) 1029 (eval `(untrace ,fspec)) 1030 (format nil "~S is now untraced." fspec)) 1031 (t 1032 (eval `(trace (,fspec ,@args))) 1033 (format nil "~S is now traced." fspec)))) 1034 1035 (defun toggle-trace-generic-function-methods (name) 1036 (let ((methods (mop:generic-function-methods (fdefinition name)))) 1037 (cond ((tracedp name) 1038 (eval `(untrace ,name)) 1039 (dolist (method methods (format nil "~S is now untraced." name)) 1040 (excl:funtrace (mop:method-function method)))) 1041 (t 1042 (eval `(trace (,name))) 1043 (dolist (method methods (format nil "~S is now traced." name)) 1044 (excl:ftrace (mop:method-function method))))))) 1045 1046 (defun process-fspec-for-allegro (fspec) 1047 (cond ((consp fspec) 1048 (ecase (first fspec) 1049 ((setf) fspec) 1050 ((:defun :defgeneric) (second fspec)) 1051 ((:defmethod) `(method ,@(rest fspec))) 1052 ((:labels) `(labels ,(process-fspec-for-allegro (second fspec)) 1053 ,(third fspec))) 1054 ((:flet) `(flet ,(process-fspec-for-allegro (second fspec)) 1055 ,(third fspec))))) 1056 (t 1057 fspec))) 1058 1059 1060 ;;;; Weak hashtables 1061 1062 (defimplementation make-weak-key-hash-table (&rest args) 1063 (apply #'make-hash-table :weak-keys t args)) 1064 1065 (defimplementation make-weak-value-hash-table (&rest args) 1066 (apply #'make-hash-table :values :weak args)) 1067 1068 (defimplementation hash-table-weakness (hashtable) 1069 (cond ((excl:hash-table-weak-keys hashtable) :key) 1070 ((eq (excl:hash-table-values hashtable) :weak) :value))) 1071 1072 1073 1074 ;;;; Character names 1075 1076 (defimplementation character-completion-set (prefix matchp) 1077 (loop for name being the hash-keys of excl::*name-to-char-table* 1078 when (funcall matchp prefix name) 1079 collect (string-capitalize name))) 1080 1081 1082 ;;;; wrap interface implementation 1083 1084 (defimplementation wrap (spec indicator &key before after replace) 1085 (let ((allegro-spec (process-fspec-for-allegro spec))) 1086 (excl:fwrap allegro-spec 1087 indicator 1088 (excl:def-fwrapper allegro-wrapper (&rest args) 1089 (let (retlist completed) 1090 (unwind-protect 1091 (progn 1092 (when before 1093 (funcall before args)) 1094 (setq retlist (multiple-value-list 1095 (if replace 1096 (funcall replace args) 1097 (excl:call-next-fwrapper)))) 1098 (setq completed t) 1099 (values-list retlist)) 1100 (when after 1101 (funcall after (if completed 1102 retlist 1103 :exited-non-locally))))))))) 1104 1105 (defimplementation unwrap (spec indicator) 1106 (let ((allegro-spec (process-fspec-for-allegro spec))) 1107 (excl:funwrap allegro-spec indicator) 1108 allegro-spec)) 1109 1110 (defimplementation wrapped-p (spec indicator) 1111 (getf (excl:fwrap-order (process-fspec-for-allegro spec)) indicator)) 1112 1113 ;;;; Package-local nicknames 1114 #+(version>= 10 0) 1115 (defimplementation package-local-nicknames (package) 1116 (excl:package-local-nicknames package))