clisp.lisp (34377B)
1 ;;;; -*- indent-tabs-mode: nil -*- 2 3 ;;;; SLYNK support for CLISP. 4 5 ;;;; Copyright (C) 2003, 2004 W. Jenkner, V. Sedach 6 7 ;;;; This program is free software; you can redistribute it and/or 8 ;;;; modify it under the terms of the GNU General Public License as 9 ;;;; published by the Free Software Foundation; either version 2 of 10 ;;;; the License, or (at your option) any later version. 11 12 ;;;; This program is distributed in the hope that it will be useful, 13 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 14 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 ;;;; GNU General Public License for more details. 16 17 ;;;; You should have received a copy of the GNU General Public 18 ;;;; License along with this program; if not, write to the Free 19 ;;;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, 20 ;;;; MA 02111-1307, USA. 21 22 ;;; This is work in progress, but it's already usable. Many things 23 ;;; are adapted from other slynk-*.lisp, in particular from 24 ;;; slynk-allegro (I don't use allegro at all, but it's the shortest 25 ;;; one and I found Helmut Eller's code there enlightening). 26 27 ;;; This code will work better with recent versions of CLISP (say, the 28 ;;; last release or CVS HEAD) while it may not work at all with older 29 ;;; versions. It is reasonable to expect it to work on platforms with 30 ;;; a "SOCKET" package, in particular on GNU/Linux or Unix-like 31 ;;; systems, but also on Win32. This backend uses the portable xref 32 ;;; from the CMU AI repository and metering.lisp from CLOCC [1], which 33 ;;; are conveniently included in SLY. 34 35 ;;; [1] http://cvs.sourceforge.net/viewcvs.py/clocc/clocc/src/tools/metering/ 36 37 (defpackage slynk-clisp 38 (:use cl slynk-backend)) 39 40 (in-package slynk-clisp) 41 42 (eval-when (:compile-toplevel) 43 (unless (string< "2.44" (lisp-implementation-version)) 44 (error "Need at least CLISP version 2.44"))) 45 46 (defimplementation gray-package-name () 47 "GRAY") 48 49 ;;;; if this lisp has the complete CLOS then we use it, otherwise we 50 ;;;; build up a "fake" slynk-mop and then override the methods in the 51 ;;;; inspector. 52 53 (eval-when (:compile-toplevel :load-toplevel :execute) 54 (defvar *have-mop* 55 (and (find-package :clos) 56 (eql :external 57 (nth-value 1 (find-symbol (string ':standard-slot-definition) 58 :clos)))) 59 "True in those CLISP images which have a complete MOP implementation.")) 60 61 #+#.(cl:if slynk-clisp::*have-mop* '(cl:and) '(cl:or)) 62 (progn 63 (import-slynk-mop-symbols :clos '(:slot-definition-documentation)) 64 65 (defun slynk-mop:slot-definition-documentation (slot) 66 (clos::slot-definition-documentation slot))) 67 68 #-#.(cl:if slynk-clisp::*have-mop* '(and) '(or)) 69 (defclass slynk-mop:standard-slot-definition () 70 () 71 (:documentation 72 "Dummy class created so that slynk.lisp will compile and load.")) 73 74 (let ((getpid (or (find-symbol "PROCESS-ID" :system) 75 ;; old name prior to 2005-03-01, clisp <= 2.33.2 76 (find-symbol "PROGRAM-ID" :system) 77 #+win32 ; integrated into the above since 2005-02-24 78 (and (find-package :win32) ; optional modules/win32 79 (find-symbol "GetCurrentProcessId" :win32))))) 80 (defimplementation getpid () ; a required interface 81 (cond 82 (getpid (funcall getpid)) 83 #+win32 ((ext:getenv "PID")) ; where does that come from? 84 (t -1)))) 85 86 (defimplementation call-with-user-break-handler (handler function) 87 (handler-bind ((system::simple-interrupt-condition 88 (lambda (c) 89 (declare (ignore c)) 90 (funcall handler) 91 (when (find-restart 'socket-status) 92 (invoke-restart (find-restart 'socket-status))) 93 (continue)))) 94 (funcall function))) 95 96 (defimplementation lisp-implementation-type-name () 97 "clisp") 98 99 (defimplementation set-default-directory (directory) 100 (setf (ext:default-directory) directory) 101 (namestring (setf *default-pathname-defaults* (ext:default-directory)))) 102 103 (defimplementation filename-to-pathname (string) 104 (cond ((member :cygwin *features*) 105 (parse-cygwin-filename string)) 106 (t (parse-namestring string)))) 107 108 (defun parse-cygwin-filename (string) 109 (multiple-value-bind (match _ drive absolute) 110 (regexp:match "^(([a-zA-Z\\]+):)?([\\/])?" string :extended t) 111 (declare (ignore _)) 112 (assert (and match (if drive absolute t)) () 113 "Invalid filename syntax: ~a" string) 114 (let* ((sans-prefix (subseq string (regexp:match-end match))) 115 (path (remove "" (regexp:regexp-split "[\\/]" sans-prefix))) 116 (path (loop for name in path collect 117 (cond ((equal name "..") ':back) 118 (t name)))) 119 (directoryp (or (equal string "") 120 (find (aref string (1- (length string))) "\\/")))) 121 (multiple-value-bind (file type) 122 (cond ((and (not directoryp) (last path)) 123 (let* ((file (car (last path))) 124 (pos (position #\. file :from-end t))) 125 (cond ((and pos (> pos 0)) 126 (values (subseq file 0 pos) 127 (subseq file (1+ pos)))) 128 (t file))))) 129 (make-pathname :host nil 130 :device nil 131 :directory (cons 132 (if absolute :absolute :relative) 133 (let ((path (if directoryp 134 path 135 (butlast path)))) 136 (if drive 137 (cons 138 (regexp:match-string string drive) 139 path) 140 path))) 141 :name file 142 :type type))))) 143 144 ;;;; UTF 145 146 (defimplementation string-to-utf8 (string) 147 (let ((enc (load-time-value 148 (ext:make-encoding :charset "utf-8" :line-terminator :unix) 149 t))) 150 (ext:convert-string-to-bytes string enc))) 151 152 (defimplementation utf8-to-string (octets) 153 (let ((enc (load-time-value 154 (ext:make-encoding :charset "utf-8" :line-terminator :unix) 155 t))) 156 (ext:convert-string-from-bytes octets enc))) 157 158 ;;;; TCP Server 159 160 (defimplementation create-socket (host port &key backlog) 161 (socket:socket-server port :interface host :backlog (or backlog 5))) 162 163 (defimplementation local-port (socket) 164 (socket:socket-server-port socket)) 165 166 (defimplementation close-socket (socket) 167 (socket:socket-server-close socket)) 168 169 (defimplementation accept-connection (socket 170 &key external-format buffering timeout) 171 (declare (ignore buffering timeout)) 172 (socket:socket-accept socket 173 :buffered buffering ;; XXX may not work if t 174 :element-type (if external-format 175 'character 176 '(unsigned-byte 8)) 177 :external-format (or external-format :default))) 178 179 #-win32 180 (defimplementation wait-for-input (streams &optional timeout) 181 (assert (member timeout '(nil t))) 182 (let ((streams (mapcar (lambda (s) (list* s :input nil)) streams))) 183 (loop 184 (cond ((check-sly-interrupts) (return :interrupt)) 185 (timeout 186 (socket:socket-status streams 0 0) 187 (return (loop for (s nil . x) in streams 188 if x collect s))) 189 (t 190 (with-simple-restart (socket-status "Return from socket-status.") 191 (socket:socket-status streams 0 500000)) 192 (let ((ready (loop for (s nil . x) in streams 193 if x collect s))) 194 (when ready (return ready)))))))) 195 196 #+win32 197 (defimplementation wait-for-input (streams &optional timeout) 198 (assert (member timeout '(nil t))) 199 (loop 200 (cond ((check-sly-interrupts) (return :interrupt)) 201 (t 202 (let ((ready (remove-if-not #'input-available-p streams))) 203 (when ready (return ready))) 204 (when timeout (return nil)) 205 (sleep 0.1))))) 206 207 #+win32 208 ;; Some facts to remember (for the next time we need to debug this): 209 ;; - interactive-sream-p returns t for socket-streams 210 ;; - listen returns nil for socket-streams 211 ;; - (type-of <socket-stream>) is 'stream 212 ;; - (type-of *terminal-io*) is 'two-way-stream 213 ;; - stream-element-type on our sockets is usually (UNSIGNED-BYTE 8) 214 ;; - calling socket:socket-status on non sockets signals an error, 215 ;; but seems to mess up something internally. 216 ;; - calling read-char-no-hang on sockets does not signal an error, 217 ;; but seems to mess up something internally. 218 (defun input-available-p (stream) 219 (case (stream-element-type stream) 220 (character 221 (let ((c (read-char-no-hang stream nil nil))) 222 (cond ((not c) 223 nil) 224 (t 225 (unread-char c stream) 226 t)))) 227 (t 228 (eq (socket:socket-status (cons stream :input) 0 0) 229 :input)))) 230 231 ;;;; Coding systems 232 233 (defvar *external-format-to-coding-system* 234 '(((:charset "iso-8859-1" :line-terminator :unix) 235 "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix") 236 ((:charset "iso-8859-1") 237 "latin-1" "iso-latin-1" "iso-8859-1") 238 ((:charset "utf-8") "utf-8") 239 ((:charset "utf-8" :line-terminator :unix) "utf-8-unix") 240 ((:charset "euc-jp") "euc-jp") 241 ((:charset "euc-jp" :line-terminator :unix) "euc-jp-unix") 242 ((:charset "us-ascii") "us-ascii") 243 ((:charset "us-ascii" :line-terminator :unix) "us-ascii-unix"))) 244 245 (defimplementation find-external-format (coding-system) 246 (let ((args (car (rassoc-if (lambda (x) 247 (member coding-system x :test #'equal)) 248 *external-format-to-coding-system*)))) 249 (and args (apply #'ext:make-encoding args)))) 250 251 252 ;;;; Slynk functions 253 254 (defimplementation arglist (fname) 255 (block nil 256 (or (ignore-errors 257 (let ((exp (function-lambda-expression fname))) 258 (and exp (return (second exp))))) 259 (ignore-errors 260 (return (ext:arglist fname))) 261 :not-available))) 262 263 (defimplementation macroexpand-all (form &optional env) 264 (declare (ignore env)) 265 (ext:expand-form form)) 266 267 (defimplementation describe-symbol-for-emacs (symbol) 268 "Return a plist describing SYMBOL. 269 Return NIL if the symbol is unbound." 270 (let ((result ())) 271 (flet ((doc (kind) 272 (or (documentation symbol kind) :not-documented)) 273 (maybe-push (property value) 274 (when value 275 (setf result (list* property value result))))) 276 (maybe-push :variable (when (boundp symbol) (doc 'variable))) 277 (when (fboundp symbol) 278 (maybe-push 279 ;; Report WHEN etc. as macros, even though they may be 280 ;; implemented as special operators. 281 (if (macro-function symbol) :macro 282 (typecase (fdefinition symbol) 283 (generic-function :generic-function) 284 (function :function) 285 ;; (type-of 'progn) -> ext:special-operator 286 (t :special-operator))) 287 (doc 'function))) 288 (when (or (get symbol 'system::setf-function) ; e.g. #'(setf elt) 289 (get symbol 'system::setf-expander)); defsetf 290 (maybe-push :setf (doc 'setf))) 291 (when (or (get symbol 'system::type-symbol); cf. clisp/src/describe.lisp 292 (get symbol 'system::defstruct-description) 293 (get symbol 'system::deftype-expander)) 294 (maybe-push :type (doc 'type))) ; even for 'structure 295 (when (find-class symbol nil) 296 (maybe-push :class (doc 'type))) 297 ;; Let this code work compiled in images without FFI 298 (let ((types (load-time-value 299 (and (find-package "FFI") 300 (symbol-value 301 (find-symbol "*C-TYPE-TABLE*" "FFI")))))) 302 ;; Use ffi::*c-type-table* so as not to suffer the overhead of 303 ;; (ignore-errors (ffi:parse-c-type symbol)) for 99.9% of symbols 304 ;; which are not FFI type names. 305 (when (and types (nth-value 1 (gethash symbol types))) 306 ;; Maybe use (case (head (ffi:deparse-c-type))) 307 ;; to distinguish struct and union types? 308 (maybe-push :alien-type :not-documented))) 309 result))) 310 311 (defimplementation describe-definition (symbol namespace) 312 (ecase namespace 313 (:variable (describe symbol)) 314 (:macro (describe (macro-function symbol))) 315 (:function (describe (symbol-function symbol))) 316 (:class (describe (find-class symbol))))) 317 318 (defimplementation type-specifier-p (symbol) 319 (or (ignore-errors 320 (subtypep nil symbol)) 321 (not (eq (type-specifier-arglist symbol) :not-available)))) 322 323 (defun fspec-pathname (spec) 324 (let ((path spec) 325 type 326 lines) 327 (when (consp path) 328 (psetq type (car path) 329 path (cadr path) 330 lines (cddr path))) 331 (when (and path 332 (member (pathname-type path) 333 custom:*compiled-file-types* :test #'equal)) 334 (setq path 335 (loop for suffix in custom:*source-file-types* 336 thereis (probe-file (make-pathname :defaults path 337 :type suffix))))) 338 (values path type lines))) 339 340 (defun fspec-location (name fspec) 341 (multiple-value-bind (file type lines) 342 (fspec-pathname fspec) 343 (list (if type (list name type) name) 344 (cond (file 345 (multiple-value-bind (truename c) 346 (ignore-errors (truename file)) 347 (cond (truename 348 (make-location 349 (list :file (namestring truename)) 350 (if (consp lines) 351 (list* :line lines) 352 (list :function-name (string name))) 353 (when (consp type) 354 (list :snippet (format nil "~A" type))))) 355 (t (list :error (princ-to-string c)))))) 356 (t (list :error 357 (format nil "No source information available for: ~S" 358 fspec))))))) 359 360 (defimplementation find-definitions (name) 361 (mapcar #'(lambda (e) (fspec-location name e)) 362 (documentation name 'sys::file))) 363 364 (defun trim-whitespace (string) 365 (string-trim #(#\newline #\space #\tab) string)) 366 367 (defvar *sly-db-backtrace*) 368 369 (defun sly-db-backtrace () 370 "Return a list ((ADDRESS . DESCRIPTION) ...) of frames." 371 (let* ((modes '((:all-stack-elements 1) 372 (:all-frames 2) 373 (:only-lexical-frames 3) 374 (:only-eval-and-apply-frames 4) 375 (:only-apply-frames 5))) 376 (mode (cadr (assoc :all-stack-elements modes)))) 377 (do ((frames '()) 378 (last nil frame) 379 (frame (sys::the-frame) 380 (sys::frame-up 1 frame mode))) 381 ((eq frame last) (nreverse frames)) 382 (unless (boring-frame-p frame) 383 (push frame frames))))) 384 385 (defimplementation call-with-debugging-environment (debugger-loop-fn) 386 (let* (;;(sys::*break-count* (1+ sys::*break-count*)) 387 ;;(sys::*driver* debugger-loop-fn) 388 ;;(sys::*fasoutput-stream* nil) 389 (*sly-db-backtrace* 390 (let* ((f (sys::the-frame)) 391 (bt (sly-db-backtrace)) 392 (rest (member f bt))) 393 (if rest (nthcdr 8 rest) bt)))) 394 (funcall debugger-loop-fn))) 395 396 (defun nth-frame (index) 397 (nth index *sly-db-backtrace*)) 398 399 (defun boring-frame-p (frame) 400 (member (frame-type frame) '(stack-value bind-var bind-env 401 compiled-tagbody compiled-block))) 402 403 (defun frame-to-string (frame) 404 (with-output-to-string (s) 405 (sys::describe-frame s frame))) 406 407 (defun frame-type (frame) 408 ;; FIXME: should bind *print-length* etc. to small values. 409 (frame-string-type (frame-to-string frame))) 410 411 ;; FIXME: they changed the layout in 2.44 and not all patterns have 412 ;; been updated. 413 (defvar *frame-prefixes* 414 '(("\\[[0-9]\\+\\] frame binding variables" bind-var) 415 ("<1> #<compiled-function" compiled-fun) 416 ("<1> #<system-function" sys-fun) 417 ("<1> #<special-operator" special-op) 418 ("EVAL frame" eval) 419 ("APPLY frame" apply) 420 ("\\[[0-9]\\+\\] compiled tagbody frame" compiled-tagbody) 421 ("\\[[0-9]\\+\\] compiled block frame" compiled-block) 422 ("block frame" block) 423 ("nested block frame" block) 424 ("tagbody frame" tagbody) 425 ("nested tagbody frame" tagbody) 426 ("catch frame" catch) 427 ("handler frame" handler) 428 ("unwind-protect frame" unwind-protect) 429 ("driver frame" driver) 430 ("\\[[0-9]\\+\\] frame binding environments" bind-env) 431 ("CALLBACK frame" callback) 432 ("- " stack-value) 433 ("<1> " fun) 434 ("<2> " 2nd-frame) 435 )) 436 437 (defun frame-string-type (string) 438 (cadr (assoc-if (lambda (pattern) (is-prefix-p pattern string)) 439 *frame-prefixes*))) 440 441 (defimplementation compute-backtrace (start end) 442 (let* ((bt *sly-db-backtrace*) 443 (len (length bt))) 444 (loop for f in (subseq bt start (min (or end len) len)) 445 collect f))) 446 447 (defimplementation print-frame (frame stream) 448 (let* ((str (frame-to-string frame))) 449 (write-string (extract-frame-line str) 450 stream))) 451 452 (defun extract-frame-line (frame-string) 453 (let ((s frame-string)) 454 (trim-whitespace 455 (case (frame-string-type s) 456 ((eval special-op) 457 (string-match "EVAL frame .*for form \\(.*\\)" s 1)) 458 (apply 459 (string-match "APPLY frame for call \\(.*\\)" s 1)) 460 ((compiled-fun sys-fun fun) 461 (extract-function-name s)) 462 (t s))))) 463 464 (defun extract-function-name (string) 465 (let ((1st (car (split-frame-string string)))) 466 (or (string-match (format nil "^<1>[ ~%]*#<[-A-Za-z]* \\(.*\\)>") 467 1st 468 1) 469 (string-match (format nil "^<1>[ ~%]*\\(.*\\)") 1st 1) 470 1st))) 471 472 (defun split-frame-string (string) 473 (let ((rx (format nil "~%\\(~{~A~^\\|~}\\)" 474 (mapcar #'car *frame-prefixes*)))) 475 (loop for pos = 0 then (1+ (regexp:match-start match)) 476 for match = (regexp:match rx string :start pos) 477 if match collect (subseq string pos (regexp:match-start match)) 478 else collect (subseq string pos) 479 while match))) 480 481 (defun string-match (pattern string n) 482 (let* ((match (nth-value n (regexp:match pattern string)))) 483 (if match (regexp:match-string string match)))) 484 485 (defimplementation eval-in-frame (form frame-number) 486 (sys::eval-at (nth-frame frame-number) form)) 487 488 (defimplementation frame-locals (frame-number) 489 (let ((frame (nth-frame frame-number))) 490 (loop for i below (%frame-count-vars frame) 491 collect (list :name (%frame-var-name frame i) 492 :value (%frame-var-value frame i) 493 :id 0)))) 494 495 (defimplementation frame-var-value (frame var) 496 (%frame-var-value (nth-frame frame) var)) 497 498 ;;; Interpreter-Variablen-Environment has the shape 499 ;;; NIL or #(v1 val1 ... vn valn NEXT-ENV). 500 501 (defun %frame-count-vars (frame) 502 (cond ((sys::eval-frame-p frame) 503 (do ((venv (frame-venv frame) (next-venv venv)) 504 (count 0 (+ count (/ (1- (length venv)) 2)))) 505 ((not venv) count))) 506 ((member (frame-type frame) '(compiled-fun sys-fun fun special-op)) 507 (length (%parse-stack-values frame))) 508 (t 0))) 509 510 (defun %frame-var-name (frame i) 511 (cond ((sys::eval-frame-p frame) 512 (nth-value 0 (venv-ref (frame-venv frame) i))) 513 (t (format nil "~D" i)))) 514 515 (defun %frame-var-value (frame i) 516 (cond ((sys::eval-frame-p frame) 517 (let ((name (venv-ref (frame-venv frame) i))) 518 (multiple-value-bind (v c) (ignore-errors (sys::eval-at frame name)) 519 (if c 520 (format-sly-db-condition c) 521 v)))) 522 ((member (frame-type frame) '(compiled-fun sys-fun fun special-op)) 523 (let ((str (nth i (%parse-stack-values frame)))) 524 (trim-whitespace (subseq str 2)))) 525 (t (break "Not implemented")))) 526 527 (defun frame-venv (frame) 528 (let ((env (sys::eval-at frame '(sys::the-environment)))) 529 (svref env 0))) 530 531 (defun next-venv (venv) (svref venv (1- (length venv)))) 532 533 (defun venv-ref (env i) 534 "Reference the Ith binding in ENV. 535 Return two values: NAME and VALUE" 536 (let ((idx (* i 2))) 537 (if (< idx (1- (length env))) 538 (values (svref env idx) (svref env (1+ idx))) 539 (venv-ref (next-venv env) (- i (/ (1- (length env)) 2)))))) 540 541 (defun %parse-stack-values (frame) 542 (labels ((next (fp) (sys::frame-down 1 fp 1)) 543 (parse (fp accu) 544 (let ((str (frame-to-string fp))) 545 (cond ((is-prefix-p "- " str) 546 (parse (next fp) (cons str accu))) 547 ((is-prefix-p "<1> " str) 548 ;;(when (eq (frame-type frame) 'compiled-fun) 549 ;; (pop accu)) 550 (dolist (str (cdr (split-frame-string str))) 551 (when (is-prefix-p "- " str) 552 (push str accu))) 553 (nreverse accu)) 554 (t (parse (next fp) accu)))))) 555 (parse (next frame) '()))) 556 557 (defun is-prefix-p (regexp string) 558 (if (regexp:match (concatenate 'string "^" regexp) string) t)) 559 560 (defimplementation return-from-frame (index form) 561 (sys::return-from-eval-frame (nth-frame index) form)) 562 563 (defimplementation restart-frame (index) 564 (sys::redo-eval-frame (nth-frame index))) 565 566 (defimplementation frame-source-location (index) 567 `(:error 568 ,(format nil "frame-source-location not implemented. (frame: ~A)" 569 (nth-frame index)))) 570 571 ;;;; Profiling 572 573 (defimplementation profile (fname) 574 (eval `(slynk-monitor:monitor ,fname))) ;monitor is a macro 575 576 (defimplementation profiled-functions () 577 slynk-monitor:*monitored-functions*) 578 579 (defimplementation unprofile (fname) 580 (eval `(slynk-monitor:unmonitor ,fname))) ;unmonitor is a macro 581 582 (defimplementation unprofile-all () 583 (slynk-monitor:unmonitor)) 584 585 (defimplementation profile-report () 586 (slynk-monitor:report-monitoring)) 587 588 (defimplementation profile-reset () 589 (slynk-monitor:reset-all-monitoring)) 590 591 (defimplementation profile-package (package callers-p methods) 592 (declare (ignore callers-p methods)) 593 (slynk-monitor:monitor-all package)) 594 595 ;;;; Handle compiler conditions (find out location of error etc.) 596 597 (defmacro compile-file-frobbing-notes ((&rest args) &body body) 598 "Pass ARGS to COMPILE-FILE, send the compiler notes to 599 *STANDARD-INPUT* and frob them in BODY." 600 `(let ((*error-output* (make-string-output-stream)) 601 (*compile-verbose* t)) 602 (multiple-value-prog1 603 (compile-file ,@args) 604 (handler-case 605 (with-input-from-string 606 (*standard-input* (get-output-stream-string *error-output*)) 607 ,@body) 608 (sys::simple-end-of-file () nil))))) 609 610 (defvar *orig-c-warn* (symbol-function 'system::c-warn)) 611 (defvar *orig-c-style-warn* (symbol-function 'system::c-style-warn)) 612 (defvar *orig-c-error* (symbol-function 'system::c-error)) 613 (defvar *orig-c-report-problems* (symbol-function 'system::c-report-problems)) 614 615 (defmacro dynamic-flet (names-functions &body body) 616 "(dynamic-flet ((NAME FUNCTION) ...) BODY ...) 617 Execute BODY with NAME's function slot set to FUNCTION." 618 `(ext:letf* ,(loop for (name function) in names-functions 619 collect `((symbol-function ',name) ,function)) 620 ,@body)) 621 622 (defvar *buffer-name* nil) 623 (defvar *buffer-offset*) 624 625 (defun compiler-note-location () 626 "Return the current compiler location." 627 (let ((lineno1 sys::*compile-file-lineno1*) 628 (lineno2 sys::*compile-file-lineno2*) 629 (file sys::*compile-file-truename*)) 630 (cond ((and file lineno1 lineno2) 631 (make-location (list ':file (namestring file)) 632 (list ':line lineno1))) 633 (*buffer-name* 634 (make-location (list ':buffer *buffer-name*) 635 (list ':offset *buffer-offset* 0))) 636 (t 637 (list :error "No error location available"))))) 638 639 (defun signal-compiler-warning (cstring args severity orig-fn) 640 (signal 'compiler-condition 641 :severity severity 642 :message (apply #'format nil cstring args) 643 :location (compiler-note-location)) 644 (apply orig-fn cstring args)) 645 646 (defun c-warn (cstring &rest args) 647 (signal-compiler-warning cstring args :warning *orig-c-warn*)) 648 649 (defun c-style-warn (cstring &rest args) 650 (dynamic-flet ((sys::c-warn *orig-c-warn*)) 651 (signal-compiler-warning cstring args :style-warning *orig-c-style-warn*))) 652 653 (defun c-error (&rest args) 654 (signal 'compiler-condition 655 :severity :error 656 :message (apply #'format nil 657 (if (= (length args) 3) 658 (cdr args) 659 args)) 660 :location (compiler-note-location)) 661 (apply *orig-c-error* args)) 662 663 (defimplementation call-with-compilation-hooks (function) 664 (handler-bind ((warning #'handle-notification-condition)) 665 (dynamic-flet ((system::c-warn #'c-warn) 666 (system::c-style-warn #'c-style-warn) 667 (system::c-error #'c-error)) 668 (funcall function)))) 669 670 (defun handle-notification-condition (condition) 671 "Handle a condition caused by a compiler warning." 672 (signal 'compiler-condition 673 :original-condition condition 674 :severity :warning 675 :message (princ-to-string condition) 676 :location (compiler-note-location))) 677 678 (defimplementation slynk-compile-file (input-file output-file 679 load-p external-format 680 &key policy) 681 (declare (ignore policy)) 682 (with-compilation-hooks () 683 (with-compilation-unit () 684 (multiple-value-bind (fasl-file warningsp failurep) 685 (compile-file input-file 686 :output-file output-file 687 :external-format external-format) 688 (values fasl-file warningsp 689 (or failurep 690 (and load-p 691 (not (load fasl-file))))))))) 692 693 (defimplementation slynk-compile-string (string &key buffer position filename 694 line column policy) 695 (declare (ignore filename line column policy)) 696 (with-compilation-hooks () 697 (let ((*buffer-name* buffer) 698 (*buffer-offset* position)) 699 (funcall (compile nil (read-from-string 700 (format nil "(~S () ~A)" 'lambda string)))) 701 t))) 702 703 ;;;; Portable XREF from the CMU AI repository. 704 705 (setq pxref::*handle-package-forms* '(cl:in-package)) 706 707 (defmacro defxref (name function) 708 `(defimplementation ,name (name) 709 (xref-results (,function name)))) 710 711 (defxref who-calls pxref:list-callers) 712 (defxref who-references pxref:list-readers) 713 (defxref who-binds pxref:list-setters) 714 (defxref who-sets pxref:list-setters) 715 (defxref list-callers pxref:list-callers) 716 (defxref list-callees pxref:list-callees) 717 718 (defun xref-results (symbols) 719 (let ((xrefs '())) 720 (dolist (symbol symbols) 721 (push (fspec-location symbol symbol) xrefs)) 722 xrefs)) 723 724 (when (find-package :slynk-loader) 725 (setf (symbol-function (intern "USER-INIT-FILE" :slynk-loader)) 726 (lambda () 727 (let ((home (user-homedir-pathname))) 728 (and (ext:probe-directory home) 729 (probe-file (format nil "~A/.slynk.lisp" 730 (namestring (truename home))))))))) 731 732 ;;; Don't set *debugger-hook* to nil on break. 733 (ext:without-package-lock () 734 (defun break (&optional (format-string "Break") &rest args) 735 (if (not sys::*use-clcs*) 736 (progn 737 (terpri *error-output*) 738 (apply #'format *error-output* 739 (concatenate 'string "*** - " format-string) 740 args) 741 (funcall ext:*break-driver* t)) 742 (let ((condition 743 (make-condition 'simple-condition 744 :format-control format-string 745 :format-arguments args)) 746 ;;(*debugger-hook* nil) 747 ;; Issue 91 748 ) 749 (ext:with-restarts 750 ((continue 751 :report (lambda (stream) 752 (format stream (sys::text "Return from ~S loop") 753 'break)) 754 ())) 755 (with-condition-restarts condition (list (find-restart 'continue)) 756 (invoke-debugger condition))))) 757 nil)) 758 759 ;;;; Inspecting 760 761 (defmethod emacs-inspect ((o t)) 762 (let* ((*print-array* nil) (*print-pretty* t) 763 (*print-circle* t) (*print-escape* t) 764 (*print-lines* custom:*inspect-print-lines*) 765 (*print-level* custom:*inspect-print-level*) 766 (*print-length* custom:*inspect-print-length*) 767 (sys::*inspect-all* (make-array 10 :fill-pointer 0 :adjustable t)) 768 (tmp-pack (make-package (gensym "INSPECT-TMP-PACKAGE-"))) 769 (*package* tmp-pack) 770 (sys::*inspect-unbound-value* (intern "#<unbound>" tmp-pack))) 771 (let ((inspection (sys::inspect-backend o))) 772 (append (list 773 (format nil "~S~% ~A~{~%~A~}~%" o 774 (sys::insp-title inspection) 775 (sys::insp-blurb inspection))) 776 (loop with count = (sys::insp-num-slots inspection) 777 for i below count 778 append (multiple-value-bind (value name) 779 (funcall (sys::insp-nth-slot inspection) 780 i) 781 `((:value ,name) " = " (:value ,value) 782 (:newline)))))))) 783 784 (defimplementation quit-lisp () 785 #+lisp=cl (ext:quit) 786 #-lisp=cl (lisp:quit)) 787 788 789 (defimplementation preferred-communication-style () 790 nil) 791 792 ;;; FIXME 793 ;;; 794 ;;; Clisp 2.48 added experimental support for threads. Basically, you 795 ;;; can use :SPAWN now, BUT: 796 ;;; 797 ;;; - there are problems with GC, and threads stuffed into weak 798 ;;; hash-tables as is the case for *THREAD-PLIST-TABLE*. 799 ;;; 800 ;;; See test case at 801 ;;; http://thread.gmane.org/gmane.lisp.clisp.devel/20429 802 ;;; 803 ;;; Even though said to be fixed, it's not: 804 ;;; 805 ;;; http://thread.gmane.org/gmane.lisp.clisp.devel/20429/focus=20443 806 ;;; 807 ;;; - The DYNAMIC-FLET above is an implementation technique that's 808 ;;; probably not sustainable in light of threads. This got to be 809 ;;; rewritten. 810 ;;; 811 ;;; TCR (2009-07-30) 812 813 #+#.(cl:if (cl:find-package "MP") '(:and) '(:or)) 814 (progn 815 (defimplementation spawn (fn &key name) 816 (mp:make-thread fn :name name)) 817 818 (defvar *thread-plist-table-lock* 819 (mp:make-mutex :name "THREAD-PLIST-TABLE-LOCK")) 820 821 (defvar *thread-plist-table* (make-hash-table :weak :key) 822 "A hashtable mapping threads to a plist.") 823 824 (defvar *thread-id-counter* 0) 825 826 (defimplementation thread-id (thread) 827 (mp:with-mutex-lock (*thread-plist-table-lock*) 828 (or (getf (gethash thread *thread-plist-table*) 'thread-id) 829 (setf (getf (gethash thread *thread-plist-table*) 'thread-id) 830 (incf *thread-id-counter*))))) 831 832 (defimplementation find-thread (id) 833 (find id (all-threads) 834 :key (lambda (thread) 835 (getf (gethash thread *thread-plist-table*) 'thread-id)))) 836 837 (defimplementation thread-name (thread) 838 ;; To guard against returning #<UNBOUND>. 839 (princ-to-string (mp:thread-name thread))) 840 841 (defimplementation thread-status (thread) 842 (if (thread-alive-p thread) 843 "RUNNING" 844 "STOPPED")) 845 846 (defimplementation make-lock (&key name) 847 (mp:make-mutex :name name :recursive-p t)) 848 849 (defimplementation call-with-lock-held (lock function) 850 (mp:with-mutex-lock (lock) 851 (funcall function))) 852 853 (defimplementation current-thread () 854 (mp:current-thread)) 855 856 (defimplementation all-threads () 857 (mp:list-threads)) 858 859 (defimplementation interrupt-thread (thread fn) 860 (mp:thread-interrupt thread :function fn)) 861 862 (defimplementation kill-thread (thread) 863 (mp:thread-interrupt thread :function t)) 864 865 (defimplementation thread-alive-p (thread) 866 (mp:thread-active-p thread)) 867 868 (defvar *mailboxes-lock* (make-lock :name "MAILBOXES-LOCK")) 869 (defvar *mailboxes* (list)) 870 871 (defstruct (mailbox (:conc-name mailbox.)) 872 thread 873 (lock (make-lock :name "MAILBOX.LOCK")) 874 (waitqueue (mp:make-exemption :name "MAILBOX.WAITQUEUE")) 875 (queue '() :type list)) 876 877 (defun mailbox (thread) 878 "Return THREAD's mailbox." 879 (mp:with-mutex-lock (*mailboxes-lock*) 880 (or (find thread *mailboxes* :key #'mailbox.thread) 881 (let ((mb (make-mailbox :thread thread))) 882 (push mb *mailboxes*) 883 mb)))) 884 885 (defimplementation send (thread message) 886 (let* ((mbox (mailbox thread)) 887 (lock (mailbox.lock mbox))) 888 (mp:with-mutex-lock (lock) 889 (setf (mailbox.queue mbox) 890 (nconc (mailbox.queue mbox) (list message))) 891 (mp:exemption-broadcast (mailbox.waitqueue mbox))))) 892 893 (defimplementation receive-if (test &optional timeout) 894 (let* ((mbox (mailbox (current-thread))) 895 (lock (mailbox.lock mbox))) 896 (assert (or (not timeout) (eq timeout t))) 897 (loop 898 (check-sly-interrupts) 899 (mp:with-mutex-lock (lock) 900 (let* ((q (mailbox.queue mbox)) 901 (tail (member-if test q))) 902 (when tail 903 (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) 904 (return (car tail)))) 905 (when (eq timeout t) (return (values nil t))) 906 (mp:exemption-wait (mailbox.waitqueue mbox) lock :timeout 0.2)))))) 907 908 909 ;;;; Weak hashtables 910 911 (defimplementation make-weak-key-hash-table (&rest args) 912 (apply #'make-hash-table :weak :key args)) 913 914 (defimplementation make-weak-value-hash-table (&rest args) 915 (apply #'make-hash-table :weak :value args)) 916 917 (defimplementation save-image (filename &optional restart-function) 918 (let ((args `(,filename 919 ,@(if restart-function 920 `((:init-function ,restart-function)))))) 921 (apply #'ext:saveinitmem args)))