1021 lines
36 KiB
Common Lisp
1021 lines
36 KiB
Common Lisp
;;; -*- indent-tabs-mode: nil -*-
|
||
;;;
|
||
;;; swank-lispworks.lisp --- LispWorks specific code for SLIME.
|
||
;;;
|
||
;;; Created 2003, Helmut Eller
|
||
;;;
|
||
;;; This code has been placed in the Public Domain. All warranties
|
||
;;; are disclaimed.
|
||
;;;
|
||
|
||
(defpackage swank/lispworks
|
||
(:use cl swank/backend))
|
||
|
||
(in-package swank/lispworks)
|
||
|
||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||
(require "comm"))
|
||
|
||
(defimplementation gray-package-name ()
|
||
"STREAM")
|
||
|
||
(import-swank-mop-symbols :clos '(:slot-definition-documentation
|
||
:slot-boundp-using-class
|
||
:slot-value-using-class
|
||
:slot-makunbound-using-class
|
||
:eql-specializer
|
||
:eql-specializer-object
|
||
:compute-applicable-methods-using-classes))
|
||
|
||
(defun swank-mop:slot-definition-documentation (slot)
|
||
(documentation slot t))
|
||
|
||
(defun swank-mop:slot-boundp-using-class (class object slotd)
|
||
(clos:slot-boundp-using-class class object
|
||
(clos:slot-definition-name slotd)))
|
||
|
||
(defun swank-mop:slot-value-using-class (class object slotd)
|
||
(clos:slot-value-using-class class object
|
||
(clos:slot-definition-name slotd)))
|
||
|
||
(defun (setf swank-mop:slot-value-using-class) (value class object slotd)
|
||
(setf (clos:slot-value-using-class class object
|
||
(clos:slot-definition-name slotd))
|
||
value))
|
||
|
||
(defun swank-mop:slot-makunbound-using-class (class object slotd)
|
||
(clos:slot-makunbound-using-class class object
|
||
(clos:slot-definition-name slotd)))
|
||
|
||
(defun swank-mop:compute-applicable-methods-using-classes (gf classes)
|
||
(clos::compute-applicable-methods-from-classes gf classes))
|
||
|
||
;; lispworks doesn't have the eql-specializer class, it represents
|
||
;; them as a list of `(EQL ,OBJECT)
|
||
(deftype swank-mop:eql-specializer () 'cons)
|
||
|
||
(defun swank-mop:eql-specializer-object (eql-spec)
|
||
(second eql-spec))
|
||
|
||
(eval-when (:compile-toplevel :execute :load-toplevel)
|
||
(defvar *original-defimplementation* (macro-function 'defimplementation))
|
||
(defmacro defimplementation (&whole whole name args &body body
|
||
&environment env)
|
||
(declare (ignore args body))
|
||
`(progn
|
||
(dspec:record-definition '(defun ,name) (dspec:location)
|
||
:check-redefinition-p nil)
|
||
,(funcall *original-defimplementation* whole env))))
|
||
|
||
;;; UTF8
|
||
|
||
(defimplementation string-to-utf8 (string)
|
||
(ef:encode-lisp-string string '(:utf-8 :eol-style :lf)))
|
||
|
||
(defimplementation utf8-to-string (octets)
|
||
(ef:decode-external-string octets '(:utf-8 :eol-style :lf)))
|
||
|
||
;;; TCP server
|
||
|
||
(defimplementation preferred-communication-style ()
|
||
:spawn)
|
||
|
||
(defun socket-fd (socket)
|
||
(etypecase socket
|
||
(fixnum socket)
|
||
(comm:socket-stream (comm:socket-stream-socket socket))))
|
||
|
||
(defimplementation create-socket (host port &key backlog)
|
||
(multiple-value-bind (socket where errno)
|
||
#-(or lispworks4.1 (and macosx lispworks4.3))
|
||
(comm::create-tcp-socket-for-service port :address host
|
||
:backlog (or backlog 5))
|
||
#+(or lispworks4.1 (and macosx lispworks4.3))
|
||
(comm::create-tcp-socket-for-service port)
|
||
(cond (socket socket)
|
||
(t (error 'network-error
|
||
:format-control "~A failed: ~A (~D)"
|
||
:format-arguments (list where
|
||
(list #+unix (lw:get-unix-error errno))
|
||
errno))))))
|
||
|
||
(defimplementation local-port (socket)
|
||
(nth-value 1 (comm:get-socket-address (socket-fd socket))))
|
||
|
||
(defimplementation close-socket (socket)
|
||
(comm::close-socket (socket-fd socket)))
|
||
|
||
(defimplementation accept-connection (socket
|
||
&key external-format buffering timeout)
|
||
(declare (ignore buffering))
|
||
(let* ((fd (comm::get-fd-from-socket socket)))
|
||
(assert (/= fd -1))
|
||
(cond ((not external-format)
|
||
(make-instance 'comm:socket-stream
|
||
:socket fd
|
||
:direction :io
|
||
:read-timeout timeout
|
||
:element-type '(unsigned-byte 8)))
|
||
(t
|
||
(assert (valid-external-format-p external-format))
|
||
(ecase (first external-format)
|
||
((:latin-1 :ascii)
|
||
(make-instance 'comm:socket-stream
|
||
:socket fd
|
||
:direction :io
|
||
:read-timeout timeout
|
||
:element-type 'base-char))
|
||
(:utf-8
|
||
(make-flexi-stream
|
||
(make-instance 'comm:socket-stream
|
||
:socket fd
|
||
:direction :io
|
||
:read-timeout timeout
|
||
:element-type '(unsigned-byte 8))
|
||
external-format)))))))
|
||
|
||
(defun make-flexi-stream (stream external-format)
|
||
(unless (member :flexi-streams *features*)
|
||
(error "Cannot use external format ~A~
|
||
without having installed flexi-streams in the inferior-lisp."
|
||
external-format))
|
||
(funcall (read-from-string "FLEXI-STREAMS:MAKE-FLEXI-STREAM")
|
||
stream
|
||
:external-format
|
||
(apply (read-from-string "FLEXI-STREAMS:MAKE-EXTERNAL-FORMAT")
|
||
external-format)))
|
||
|
||
;;; Coding Systems
|
||
|
||
(defun valid-external-format-p (external-format)
|
||
(member external-format *external-format-to-coding-system*
|
||
:test #'equal :key #'car))
|
||
|
||
(defvar *external-format-to-coding-system*
|
||
'(((:latin-1 :eol-style :lf)
|
||
"latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix")
|
||
;;((:latin-1) "latin-1" "iso-latin-1" "iso-8859-1")
|
||
;;((:utf-8) "utf-8")
|
||
((:utf-8 :eol-style :lf) "utf-8-unix")
|
||
;;((:euc-jp) "euc-jp")
|
||
((:euc-jp :eol-style :lf) "euc-jp-unix")
|
||
;;((:ascii) "us-ascii")
|
||
((:ascii :eol-style :lf) "us-ascii-unix")))
|
||
|
||
(defimplementation find-external-format (coding-system)
|
||
(car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
|
||
*external-format-to-coding-system*)))
|
||
|
||
;;; Unix signals
|
||
|
||
(defun sigint-handler ()
|
||
(with-simple-restart (continue "Continue from SIGINT handler.")
|
||
(invoke-debugger "SIGINT")))
|
||
|
||
(defun make-sigint-handler (process)
|
||
(lambda (&rest args)
|
||
(declare (ignore args))
|
||
(mp:process-interrupt process #'sigint-handler)))
|
||
|
||
(defun set-sigint-handler ()
|
||
;; Set SIGINT handler on Swank request handler thread.
|
||
#-win32
|
||
(sys::set-signal-handler +sigint+
|
||
(make-sigint-handler mp:*current-process*)))
|
||
|
||
#-win32
|
||
(defimplementation install-sigint-handler (handler)
|
||
(sys::set-signal-handler +sigint+
|
||
(let ((self mp:*current-process*))
|
||
(lambda (&rest args)
|
||
(declare (ignore args))
|
||
(mp:process-interrupt self handler)))))
|
||
|
||
(defimplementation getpid ()
|
||
#+win32 (win32:get-current-process-id)
|
||
#-win32 (system::getpid))
|
||
|
||
(defimplementation lisp-implementation-type-name ()
|
||
"lispworks")
|
||
|
||
(defimplementation set-default-directory (directory)
|
||
(namestring (hcl:change-directory directory)))
|
||
|
||
;;;; Documentation
|
||
|
||
(defun map-list (function list)
|
||
"Map over proper and not proper lists."
|
||
(loop for (car . cdr) on list
|
||
collect (funcall function car) into result
|
||
when (null cdr) return result
|
||
when (atom cdr) return (nconc result (funcall function cdr))))
|
||
|
||
(defun replace-strings-with-symbols (tree)
|
||
(map-list
|
||
(lambda (x)
|
||
(typecase x
|
||
(list
|
||
(replace-strings-with-symbols x))
|
||
(symbol
|
||
x)
|
||
(string
|
||
(intern x))
|
||
(t
|
||
(intern (write-to-string x)))))
|
||
tree))
|
||
|
||
(defimplementation arglist (symbol-or-function)
|
||
(let ((arglist (lw:function-lambda-list symbol-or-function)))
|
||
(etypecase arglist
|
||
((member :dont-know)
|
||
:not-available)
|
||
(list
|
||
(replace-strings-with-symbols arglist)))))
|
||
|
||
(defimplementation function-name (function)
|
||
(nth-value 2 (function-lambda-expression function)))
|
||
|
||
(defimplementation macroexpand-all (form &optional env)
|
||
(declare (ignore env))
|
||
(walker:walk-form form))
|
||
|
||
(defun generic-function-p (object)
|
||
(typep object 'generic-function))
|
||
|
||
(defimplementation describe-symbol-for-emacs (symbol)
|
||
"Return a plist describing SYMBOL.
|
||
Return NIL if the symbol is unbound."
|
||
(let ((result '()))
|
||
(labels ((first-line (string)
|
||
(let ((pos (position #\newline string)))
|
||
(if (null pos) string (subseq string 0 pos))))
|
||
(doc (kind &optional (sym symbol))
|
||
(let ((string (or (documentation sym kind))))
|
||
(if string
|
||
(first-line string)
|
||
:not-documented)))
|
||
(maybe-push (property value)
|
||
(when value
|
||
(setf result (list* property value result)))))
|
||
(maybe-push
|
||
:variable (when (boundp symbol)
|
||
(doc 'variable)))
|
||
(maybe-push
|
||
:generic-function (if (and (fboundp symbol)
|
||
(generic-function-p (fdefinition symbol)))
|
||
(doc 'function)))
|
||
(maybe-push
|
||
:function (if (and (fboundp symbol)
|
||
(not (generic-function-p (fdefinition symbol))))
|
||
(doc 'function)))
|
||
(maybe-push
|
||
:setf (let ((setf-name (sys:underlying-setf-name `(setf ,symbol))))
|
||
(if (fboundp setf-name)
|
||
(doc 'setf))))
|
||
(maybe-push
|
||
:class (if (find-class symbol nil)
|
||
(doc 'class)))
|
||
result)))
|
||
|
||
(defimplementation describe-definition (symbol type)
|
||
(ecase type
|
||
(:variable (describe-symbol symbol))
|
||
(:class (describe (find-class symbol)))
|
||
((:function :generic-function) (describe-function symbol))
|
||
(:setf (describe-function (sys:underlying-setf-name `(setf ,symbol))))))
|
||
|
||
(defun describe-function (symbol)
|
||
(cond ((fboundp symbol)
|
||
(format t "(~A ~/pprint-fill/)~%~%~:[(not documented)~;~:*~A~]~%"
|
||
symbol
|
||
(lispworks:function-lambda-list symbol)
|
||
(documentation symbol 'function))
|
||
(describe (fdefinition symbol)))
|
||
(t (format t "~S is not fbound" symbol))))
|
||
|
||
(defun describe-symbol (sym)
|
||
(format t "~A is a symbol in package ~A." sym (symbol-package sym))
|
||
(when (boundp sym)
|
||
(format t "~%~%Value: ~A" (symbol-value sym)))
|
||
(let ((doc (documentation sym 'variable)))
|
||
(when doc
|
||
(format t "~%~%Variable documentation:~%~A" doc)))
|
||
(when (fboundp sym)
|
||
(describe-function sym)))
|
||
|
||
(defimplementation type-specifier-p (symbol)
|
||
(or (ignore-errors
|
||
(subtypep nil symbol))
|
||
(not (eq (type-specifier-arglist symbol) :not-available))))
|
||
|
||
;;; Debugging
|
||
|
||
(defclass slime-env (env:environment)
|
||
((debugger-hook :initarg :debugger-hoook)))
|
||
|
||
(defun slime-env (hook io-bindings)
|
||
(make-instance 'slime-env :name "SLIME Environment"
|
||
:io-bindings io-bindings
|
||
:debugger-hoook hook))
|
||
|
||
(defmethod env-internals:environment-display-notifier
|
||
((env slime-env) &key restarts condition)
|
||
(declare (ignore restarts condition))
|
||
(swank:swank-debugger-hook condition *debugger-hook*))
|
||
|
||
(defmethod env-internals:environment-display-debugger ((env slime-env))
|
||
*debug-io*)
|
||
|
||
(defmethod env-internals:confirm-p ((e slime-env) &optional msg &rest args)
|
||
(apply #'swank:y-or-n-p-in-emacs msg args))
|
||
|
||
(defimplementation call-with-debugger-hook (hook fun)
|
||
(let ((*debugger-hook* hook))
|
||
(env:with-environment ((slime-env hook '()))
|
||
(funcall fun))))
|
||
|
||
(defimplementation install-debugger-globally (function)
|
||
(setq *debugger-hook* function)
|
||
(setf (env:environment) (slime-env function '())))
|
||
|
||
(defvar *sldb-top-frame*)
|
||
|
||
(defun interesting-frame-p (frame)
|
||
(cond ((or (dbg::call-frame-p frame)
|
||
(dbg::derived-call-frame-p frame)
|
||
(dbg::foreign-frame-p frame)
|
||
(dbg::interpreted-call-frame-p frame))
|
||
t)
|
||
((dbg::catch-frame-p frame) dbg:*print-catch-frames*)
|
||
((dbg::binding-frame-p frame) dbg:*print-binding-frames*)
|
||
((dbg::handler-frame-p frame) dbg:*print-handler-frames*)
|
||
((dbg::restart-frame-p frame) dbg:*print-restart-frames*)
|
||
(t nil)))
|
||
|
||
(defun nth-next-frame (frame n)
|
||
"Unwind FRAME N times."
|
||
(do ((frame frame (dbg::frame-next frame))
|
||
(i n (if (interesting-frame-p frame) (1- i) i)))
|
||
((or (not frame)
|
||
(and (interesting-frame-p frame) (zerop i)))
|
||
frame)))
|
||
|
||
(defun nth-frame (index)
|
||
(nth-next-frame *sldb-top-frame* index))
|
||
|
||
(defun find-top-frame ()
|
||
"Return the most suitable top-frame for the debugger."
|
||
(flet ((find-named-frame (name)
|
||
(do ((frame (dbg::debugger-stack-current-frame
|
||
dbg::*debugger-stack*)
|
||
(nth-next-frame frame 1)))
|
||
((or (null frame) ; no frame found!
|
||
(and (dbg::call-frame-p frame)
|
||
(eq (dbg::call-frame-function-name frame)
|
||
name)))
|
||
(nth-next-frame frame 1)))))
|
||
(or (find-named-frame 'invoke-debugger)
|
||
(find-named-frame 'swank::safe-backtrace)
|
||
;; if we can't find a likely top frame, take any old frame
|
||
;; at the top
|
||
(dbg::debugger-stack-current-frame dbg::*debugger-stack*))))
|
||
|
||
(defimplementation call-with-debugging-environment (fn)
|
||
(dbg::with-debugger-stack ()
|
||
(let ((*sldb-top-frame* (find-top-frame)))
|
||
(funcall fn))))
|
||
|
||
(defimplementation compute-backtrace (start end)
|
||
(let ((end (or end most-positive-fixnum))
|
||
(backtrace '()))
|
||
(do ((frame (nth-frame start) (dbg::frame-next frame))
|
||
(i start))
|
||
((or (not frame) (= i end)) (nreverse backtrace))
|
||
(when (interesting-frame-p frame)
|
||
(incf i)
|
||
(push frame backtrace)))))
|
||
|
||
(defun frame-actual-args (frame)
|
||
(let ((*break-on-signals* nil)
|
||
(kind nil))
|
||
(loop for arg in (dbg::call-frame-arglist frame)
|
||
if (eq kind '&rest)
|
||
nconc (handler-case
|
||
(dbg::dbg-eval arg frame)
|
||
(error (e) (list (format nil "<~A>" arg))))
|
||
and do (loop-finish)
|
||
else
|
||
if (member arg '(&rest &optional &key))
|
||
do (setq kind arg)
|
||
else
|
||
nconc
|
||
(handler-case
|
||
(nconc (and (eq kind '&key)
|
||
(list (cond ((symbolp arg)
|
||
(intern (symbol-name arg) :keyword))
|
||
((and (consp arg) (symbolp (car arg)))
|
||
(intern (symbol-name (car arg))
|
||
:keyword))
|
||
(t (caar arg)))))
|
||
(list (dbg::dbg-eval
|
||
(cond ((symbolp arg) arg)
|
||
((and (consp arg) (symbolp (car arg)))
|
||
(car arg))
|
||
(t (cadar arg)))
|
||
frame)))
|
||
(error (e) (list (format nil "<~A>" arg)))))))
|
||
|
||
(defimplementation print-frame (frame stream)
|
||
(cond ((dbg::call-frame-p frame)
|
||
(prin1 (cons (dbg::call-frame-function-name frame)
|
||
(frame-actual-args frame))
|
||
stream))
|
||
(t (princ frame stream))))
|
||
|
||
(defun frame-vars (frame)
|
||
(first (dbg::frame-locals-format-list frame #'list 75 0)))
|
||
|
||
(defimplementation frame-locals (n)
|
||
(let ((frame (nth-frame n)))
|
||
(if (dbg::call-frame-p frame)
|
||
(mapcar (lambda (var)
|
||
(destructuring-bind (name value symbol location) var
|
||
(declare (ignore name location))
|
||
(list :name symbol :id 0
|
||
:value value)))
|
||
(frame-vars frame)))))
|
||
|
||
(defimplementation frame-var-value (frame var)
|
||
(let ((frame (nth-frame frame)))
|
||
(destructuring-bind (_n value _s _l) (nth var (frame-vars frame))
|
||
(declare (ignore _n _s _l))
|
||
value)))
|
||
|
||
(defimplementation frame-source-location (frame)
|
||
(let ((frame (nth-frame frame))
|
||
(callee (if (plusp frame) (nth-frame (1- frame)))))
|
||
(if (dbg::call-frame-p frame)
|
||
(let ((dspec (dbg::call-frame-function-name frame))
|
||
(cname (and (dbg::call-frame-p callee)
|
||
(dbg::call-frame-function-name callee)))
|
||
(path (and (dbg::call-frame-p frame)
|
||
(dbg::call-frame-edit-path frame))))
|
||
(if dspec
|
||
(frame-location dspec cname path))))))
|
||
|
||
(defimplementation eval-in-frame (form frame-number)
|
||
(let ((frame (nth-frame frame-number)))
|
||
(dbg::dbg-eval form frame)))
|
||
|
||
(defun function-name-package (name)
|
||
(typecase name
|
||
(null nil)
|
||
(symbol (symbol-package name))
|
||
((cons (eql hcl:subfunction))
|
||
(destructuring-bind (name parent) (cdr name)
|
||
(declare (ignore name))
|
||
(function-name-package parent)))
|
||
((cons (eql lw:top-level-form)) nil)
|
||
(t nil)))
|
||
|
||
(defimplementation frame-package (frame-number)
|
||
(let ((frame (nth-frame frame-number)))
|
||
(if (dbg::call-frame-p frame)
|
||
(function-name-package (dbg::call-frame-function-name frame)))))
|
||
|
||
(defimplementation return-from-frame (frame-number form)
|
||
(let* ((frame (nth-frame frame-number))
|
||
(return-frame (dbg::find-frame-for-return frame)))
|
||
(dbg::dbg-return-from-call-frame frame form return-frame
|
||
dbg::*debugger-stack*)))
|
||
|
||
(defimplementation restart-frame (frame-number)
|
||
(let ((frame (nth-frame frame-number)))
|
||
(dbg::restart-frame frame :same-args t)))
|
||
|
||
(defimplementation disassemble-frame (frame-number)
|
||
(let* ((frame (nth-frame frame-number)))
|
||
(when (dbg::call-frame-p frame)
|
||
(let ((function (dbg::get-call-frame-function frame)))
|
||
(disassemble function)))))
|
||
|
||
;;; Definition finding
|
||
|
||
(defun frame-location (dspec callee-name edit-path)
|
||
(let ((infos (dspec:find-dspec-locations dspec)))
|
||
(cond (infos
|
||
(destructuring-bind ((rdspec location) &rest _) infos
|
||
(declare (ignore _))
|
||
(let ((name (and callee-name (symbolp callee-name)
|
||
(string callee-name)))
|
||
(path (edit-path-to-cmucl-source-path edit-path)))
|
||
(make-dspec-location rdspec location
|
||
`(:call-site ,name :edit-path ,path)))))
|
||
(t
|
||
(list :error (format nil "Source location not available for: ~S"
|
||
dspec))))))
|
||
|
||
;; dbg::call-frame-edit-path is not documented but lets assume the
|
||
;; binary representation of the integer EDIT-PATH should be
|
||
;; interpreted as a sequence of CAR or CDR. #b1111010 is roughly the
|
||
;; same as cadadddr. Something is odd with the highest bit.
|
||
(defun edit-path-to-cmucl-source-path (edit-path)
|
||
(and edit-path
|
||
(cons 0
|
||
(let ((n -1))
|
||
(loop for i from (1- (integer-length edit-path)) downto 0
|
||
if (logbitp i edit-path) do (incf n)
|
||
else collect (prog1 n (setq n 0)))))))
|
||
|
||
;; (edit-path-to-cmucl-source-path #b1111010) => (0 3 1)
|
||
|
||
(defimplementation find-definitions (name)
|
||
(let ((locations (dspec:find-name-locations dspec:*dspec-classes* name)))
|
||
(loop for (dspec location) in locations
|
||
collect (list dspec (make-dspec-location dspec location)))))
|
||
|
||
|
||
;;; Compilation
|
||
|
||
(defmacro with-swank-compilation-unit ((location &rest options) &body body)
|
||
(lw:rebinding (location)
|
||
`(let ((compiler::*error-database* '()))
|
||
(with-compilation-unit ,options
|
||
(multiple-value-prog1 (progn ,@body)
|
||
(signal-error-data-base compiler::*error-database*
|
||
,location)
|
||
(signal-undefined-functions compiler::*unknown-functions*
|
||
,location))))))
|
||
|
||
(defimplementation swank-compile-file (input-file output-file
|
||
load-p external-format
|
||
&key policy)
|
||
(declare (ignore policy))
|
||
(with-swank-compilation-unit (input-file)
|
||
(compile-file input-file
|
||
:output-file output-file
|
||
:load load-p
|
||
:external-format external-format)))
|
||
|
||
(defvar *within-call-with-compilation-hooks* nil
|
||
"Whether COMPILE-FILE was called from within CALL-WITH-COMPILATION-HOOKS.")
|
||
|
||
(defvar *undefined-functions-hash* nil
|
||
"Hash table to map info about undefined functions to pathnames.")
|
||
|
||
(lw:defadvice (compile-file compile-file-and-collect-notes :around)
|
||
(pathname &rest rest)
|
||
(multiple-value-prog1 (apply #'lw:call-next-advice pathname rest)
|
||
(when *within-call-with-compilation-hooks*
|
||
(maphash (lambda (unfun dspecs)
|
||
(dolist (dspec dspecs)
|
||
(let ((unfun-info (list unfun dspec)))
|
||
(unless (gethash unfun-info *undefined-functions-hash*)
|
||
(setf (gethash unfun-info *undefined-functions-hash*)
|
||
pathname)))))
|
||
compiler::*unknown-functions*))))
|
||
|
||
(defimplementation call-with-compilation-hooks (function)
|
||
(let ((compiler::*error-database* '())
|
||
(*undefined-functions-hash* (make-hash-table :test 'equal))
|
||
(*within-call-with-compilation-hooks* t))
|
||
(with-compilation-unit ()
|
||
(prog1 (funcall function)
|
||
(signal-error-data-base compiler::*error-database*)
|
||
(signal-undefined-functions compiler::*unknown-functions*)))))
|
||
|
||
(defun map-error-database (database fn)
|
||
(loop for (filename . defs) in database do
|
||
(loop for (dspec . conditions) in defs do
|
||
(dolist (c conditions)
|
||
(multiple-value-bind (condition path)
|
||
(if (consp c) (values (car c) (cdr c)) (values c nil))
|
||
(funcall fn filename dspec condition path))))))
|
||
|
||
(defun lispworks-severity (condition)
|
||
(cond ((not condition) :warning)
|
||
(t (etypecase condition
|
||
#-(or lispworks4 lispworks5)
|
||
(conditions:compiler-note :note)
|
||
(error :error)
|
||
(style-warning :warning)
|
||
(warning :warning)))))
|
||
|
||
(defun signal-compiler-condition (message location condition)
|
||
(check-type message string)
|
||
(signal
|
||
(make-instance 'compiler-condition :message message
|
||
:severity (lispworks-severity condition)
|
||
:location location
|
||
:original-condition condition)))
|
||
|
||
(defvar *temp-file-format* '(:utf-8 :eol-style :lf))
|
||
|
||
(defun compile-from-temp-file (string filename)
|
||
(unwind-protect
|
||
(progn
|
||
(with-open-file (s filename :direction :output
|
||
:if-exists :supersede
|
||
:external-format *temp-file-format*)
|
||
|
||
(write-string string s)
|
||
(finish-output s))
|
||
(multiple-value-bind (binary-filename warnings? failure?)
|
||
(compile-file filename :load t
|
||
:external-format *temp-file-format*)
|
||
(declare (ignore warnings?))
|
||
(when binary-filename
|
||
(delete-file binary-filename))
|
||
(not failure?)))
|
||
(delete-file filename)))
|
||
|
||
(defun dspec-function-name-position (dspec fallback)
|
||
(etypecase dspec
|
||
(cons (let ((name (dspec:dspec-primary-name dspec)))
|
||
(typecase name
|
||
((or symbol string)
|
||
(list :function-name (string name)))
|
||
(t fallback))))
|
||
(null fallback)
|
||
(symbol (list :function-name (string dspec)))))
|
||
|
||
(defmacro with-fairly-standard-io-syntax (&body body)
|
||
"Like WITH-STANDARD-IO-SYNTAX but preserve *PACKAGE* and *READTABLE*."
|
||
(let ((package (gensym))
|
||
(readtable (gensym)))
|
||
`(let ((,package *package*)
|
||
(,readtable *readtable*))
|
||
(with-standard-io-syntax
|
||
(let ((*package* ,package)
|
||
(*readtable* ,readtable))
|
||
,@body)))))
|
||
|
||
(defun skip-comments (stream)
|
||
(let ((pos0 (file-position stream)))
|
||
(cond ((equal (ignore-errors (list (read-delimited-list #\( stream)))
|
||
'(()))
|
||
(file-position stream (1- (file-position stream))))
|
||
(t (file-position stream pos0)))))
|
||
|
||
#-(or lispworks4.1 lispworks4.2) ; no dspec:parse-form-dspec prior to 4.3
|
||
(defun dspec-stream-position (stream dspec)
|
||
(with-fairly-standard-io-syntax
|
||
(loop (let* ((pos (progn (skip-comments stream) (file-position stream)))
|
||
(form (read stream nil '#1=#:eof)))
|
||
(when (eq form '#1#)
|
||
(return nil))
|
||
(labels ((check-dspec (form)
|
||
(when (consp form)
|
||
(let ((operator (car form)))
|
||
(case operator
|
||
((progn)
|
||
(mapcar #'check-dspec
|
||
(cdr form)))
|
||
((eval-when locally macrolet symbol-macrolet)
|
||
(mapcar #'check-dspec
|
||
(cddr form)))
|
||
((in-package)
|
||
(let ((package (find-package (second form))))
|
||
(when package
|
||
(setq *package* package))))
|
||
(otherwise
|
||
(let ((form-dspec (dspec:parse-form-dspec form)))
|
||
(when (dspec:dspec-equal dspec form-dspec)
|
||
(return pos)))))))))
|
||
(check-dspec form))))))
|
||
|
||
(defun dspec-file-position (file dspec)
|
||
(let* ((*compile-file-pathname* (pathname file))
|
||
(*compile-file-truename* (truename *compile-file-pathname*))
|
||
(*load-pathname* *compile-file-pathname*)
|
||
(*load-truename* *compile-file-truename*))
|
||
(with-open-file (stream file)
|
||
(let ((pos
|
||
#-(or lispworks4.1 lispworks4.2)
|
||
(ignore-errors (dspec-stream-position stream dspec))))
|
||
(if pos
|
||
(list :position (1+ pos))
|
||
(dspec-function-name-position dspec `(:position 1)))))))
|
||
|
||
(defun emacs-buffer-location-p (location)
|
||
(and (consp location)
|
||
(eq (car location) :emacs-buffer)))
|
||
|
||
(defun make-dspec-location (dspec location &optional hints)
|
||
(etypecase location
|
||
((or pathname string)
|
||
(multiple-value-bind (file err)
|
||
(ignore-errors (namestring (truename location)))
|
||
(if err
|
||
(list :error (princ-to-string err))
|
||
(make-location `(:file ,file)
|
||
(dspec-file-position file dspec)
|
||
hints))))
|
||
(symbol
|
||
`(:error ,(format nil "Cannot resolve location: ~S" location)))
|
||
((satisfies emacs-buffer-location-p)
|
||
(destructuring-bind (_ buffer offset) location
|
||
(declare (ignore _))
|
||
(make-location `(:buffer ,buffer)
|
||
(dspec-function-name-position dspec `(:offset ,offset 0))
|
||
hints)))))
|
||
|
||
(defun make-dspec-progenitor-location (dspec location edit-path)
|
||
(let ((canon-dspec (dspec:canonicalize-dspec dspec)))
|
||
(make-dspec-location
|
||
(if canon-dspec
|
||
(if (dspec:local-dspec-p canon-dspec)
|
||
(dspec:dspec-progenitor canon-dspec)
|
||
canon-dspec)
|
||
nil)
|
||
location
|
||
(if edit-path
|
||
(list :edit-path (edit-path-to-cmucl-source-path edit-path))))))
|
||
|
||
(defun signal-error-data-base (database &optional location)
|
||
(map-error-database
|
||
database
|
||
(lambda (filename dspec condition edit-path)
|
||
(signal-compiler-condition
|
||
(format nil "~A" condition)
|
||
(make-dspec-progenitor-location dspec (or location filename) edit-path)
|
||
condition))))
|
||
|
||
(defun unmangle-unfun (symbol)
|
||
"Converts symbols like 'SETF::|\"CL-USER\" \"GET\"| to
|
||
function names like \(SETF GET)."
|
||
(cond ((sys::setf-symbol-p symbol)
|
||
(sys::setf-pair-from-underlying-name symbol))
|
||
(t symbol)))
|
||
|
||
(defun signal-undefined-functions (htab &optional filename)
|
||
(maphash (lambda (unfun dspecs)
|
||
(dolist (dspec dspecs)
|
||
(signal-compiler-condition
|
||
(format nil "Undefined function ~A" (unmangle-unfun unfun))
|
||
(make-dspec-progenitor-location
|
||
dspec
|
||
(or filename
|
||
(gethash (list unfun dspec) *undefined-functions-hash*))
|
||
nil)
|
||
nil)))
|
||
htab))
|
||
|
||
(defimplementation swank-compile-string (string &key buffer position filename
|
||
line column policy)
|
||
(declare (ignore filename line column policy))
|
||
(assert buffer)
|
||
(assert position)
|
||
(let* ((location (list :emacs-buffer buffer position))
|
||
(tmpname (hcl:make-temp-file nil "lisp")))
|
||
(with-swank-compilation-unit (location)
|
||
(compile-from-temp-file
|
||
(with-output-to-string (s)
|
||
(let ((*print-radix* t))
|
||
(print `(eval-when (:compile-toplevel)
|
||
(setq dspec::*location* (list ,@location)))
|
||
s))
|
||
(write-string string s))
|
||
tmpname))))
|
||
|
||
;;; xref
|
||
|
||
(defmacro defxref (name function)
|
||
`(defimplementation ,name (name)
|
||
(xref-results (,function name))))
|
||
|
||
(defxref who-calls hcl:who-calls)
|
||
(defxref who-macroexpands hcl:who-calls) ; macros are in the calls table too
|
||
(defxref calls-who hcl:calls-who)
|
||
(defxref list-callers list-callers-internal)
|
||
(defxref list-callees list-callees-internal)
|
||
|
||
(defun list-callers-internal (name)
|
||
(let ((callers (make-array 100
|
||
:fill-pointer 0
|
||
:adjustable t)))
|
||
(hcl:sweep-all-objects
|
||
#'(lambda (object)
|
||
(when (and #+Harlequin-PC-Lisp (low:compiled-code-p object)
|
||
#+Harlequin-Unix-Lisp (sys:callablep object)
|
||
#-(or Harlequin-PC-Lisp Harlequin-Unix-Lisp)
|
||
(sys:compiled-code-p object)
|
||
(system::find-constant$funcallable name object))
|
||
(vector-push-extend object callers))))
|
||
;; Delay dspec:object-dspec until after sweep-all-objects
|
||
;; to reduce allocation problems.
|
||
(loop for object across callers
|
||
collect (if (symbolp object)
|
||
(list 'function object)
|
||
(or (dspec:object-dspec object) object)))))
|
||
|
||
(defun list-callees-internal (name)
|
||
(let ((callees '()))
|
||
(system::find-constant$funcallable
|
||
'junk name
|
||
:test #'(lambda (junk constant)
|
||
(declare (ignore junk))
|
||
(when (and (symbolp constant)
|
||
(fboundp constant))
|
||
(pushnew (list 'function constant) callees :test 'equal))
|
||
;; Return nil so we iterate over all constants.
|
||
nil))
|
||
callees))
|
||
|
||
;; only for lispworks 4.2 and above
|
||
#-lispworks4.1
|
||
(progn
|
||
(defxref who-references hcl:who-references)
|
||
(defxref who-binds hcl:who-binds)
|
||
(defxref who-sets hcl:who-sets))
|
||
|
||
(defimplementation who-specializes (classname)
|
||
(let ((class (find-class classname nil)))
|
||
(when class
|
||
(let ((methods (clos:class-direct-methods class)))
|
||
(xref-results (mapcar #'dspec:object-dspec methods))))))
|
||
|
||
(defun xref-results (dspecs)
|
||
(flet ((frob-locs (dspec locs)
|
||
(cond (locs
|
||
(loop for (name loc) in locs
|
||
collect (list name (make-dspec-location name loc))))
|
||
(t `((,dspec (:error "Source location not available")))))))
|
||
(loop for dspec in dspecs
|
||
append (frob-locs dspec (dspec:dspec-definition-locations dspec)))))
|
||
|
||
;;; Inspector
|
||
|
||
(defmethod emacs-inspect ((o t))
|
||
(lispworks-inspect o))
|
||
|
||
(defmethod emacs-inspect ((o function))
|
||
(lispworks-inspect o))
|
||
|
||
;; FIXME: slot-boundp-using-class in LW works with names so we can't
|
||
;; use our method in swank.lisp.
|
||
(defmethod emacs-inspect ((o standard-object))
|
||
(lispworks-inspect o))
|
||
|
||
(defun lispworks-inspect (o)
|
||
(multiple-value-bind (names values _getter _setter type)
|
||
(lw:get-inspector-values o nil)
|
||
(declare (ignore _getter _setter))
|
||
(append
|
||
(label-value-line "Type" type)
|
||
(loop for name in names
|
||
for value in values
|
||
append (label-value-line name value)))))
|
||
|
||
;;; Miscellaneous
|
||
|
||
(defimplementation quit-lisp ()
|
||
(lispworks:quit))
|
||
|
||
;;; Tracing
|
||
|
||
(defun parse-fspec (fspec)
|
||
"Return a dspec for FSPEC."
|
||
(ecase (car fspec)
|
||
((:defmethod) `(method ,(cdr fspec)))))
|
||
|
||
(defun tracedp (dspec)
|
||
(member dspec (eval '(trace)) :test #'equal))
|
||
|
||
(defun toggle-trace-aux (dspec)
|
||
(cond ((tracedp dspec)
|
||
(eval `(untrace ,dspec))
|
||
(format nil "~S is now untraced." dspec))
|
||
(t
|
||
(eval `(trace (,dspec)))
|
||
(format nil "~S is now traced." dspec))))
|
||
|
||
(defimplementation toggle-trace (fspec)
|
||
(toggle-trace-aux (parse-fspec fspec)))
|
||
|
||
;;; Multithreading
|
||
|
||
(defimplementation initialize-multiprocessing (continuation)
|
||
(cond ((not mp::*multiprocessing*)
|
||
(push (list "Initialize SLIME" '() continuation)
|
||
mp:*initial-processes*)
|
||
(mp:initialize-multiprocessing))
|
||
(t (funcall continuation))))
|
||
|
||
(defimplementation spawn (fn &key name)
|
||
(mp:process-run-function name () fn))
|
||
|
||
(defvar *id-lock* (mp:make-lock))
|
||
(defvar *thread-id-counter* 0)
|
||
|
||
(defimplementation thread-id (thread)
|
||
(mp:with-lock (*id-lock*)
|
||
(or (getf (mp:process-plist thread) 'id)
|
||
(setf (getf (mp:process-plist thread) 'id)
|
||
(incf *thread-id-counter*)))))
|
||
|
||
(defimplementation find-thread (id)
|
||
(find id (mp:list-all-processes)
|
||
:key (lambda (p) (getf (mp:process-plist p) 'id))))
|
||
|
||
(defimplementation thread-name (thread)
|
||
(mp:process-name thread))
|
||
|
||
(defimplementation thread-status (thread)
|
||
(format nil "~A ~D"
|
||
(mp:process-whostate thread)
|
||
(mp:process-priority thread)))
|
||
|
||
(defimplementation make-lock (&key name)
|
||
(mp:make-lock :name name))
|
||
|
||
(defimplementation call-with-lock-held (lock function)
|
||
(mp:with-lock (lock) (funcall function)))
|
||
|
||
(defimplementation current-thread ()
|
||
mp:*current-process*)
|
||
|
||
(defimplementation all-threads ()
|
||
(mp:list-all-processes))
|
||
|
||
(defimplementation interrupt-thread (thread fn)
|
||
(mp:process-interrupt thread fn))
|
||
|
||
(defimplementation kill-thread (thread)
|
||
(mp:process-kill thread))
|
||
|
||
(defimplementation thread-alive-p (thread)
|
||
(mp:process-alive-p thread))
|
||
|
||
(defstruct (mailbox (:conc-name mailbox.))
|
||
(mutex (mp:make-lock :name "thread mailbox"))
|
||
(queue '() :type list))
|
||
|
||
(defvar *mailbox-lock* (mp:make-lock))
|
||
|
||
(defun mailbox (thread)
|
||
(mp:with-lock (*mailbox-lock*)
|
||
(or (getf (mp:process-plist thread) 'mailbox)
|
||
(setf (getf (mp:process-plist thread) 'mailbox)
|
||
(make-mailbox)))))
|
||
|
||
(defimplementation receive-if (test &optional timeout)
|
||
(let* ((mbox (mailbox mp:*current-process*))
|
||
(lock (mailbox.mutex mbox)))
|
||
(assert (or (not timeout) (eq timeout t)))
|
||
(loop
|
||
(check-slime-interrupts)
|
||
(mp:with-lock (lock "receive-if/try")
|
||
(let* ((q (mailbox.queue mbox))
|
||
(tail (member-if test q)))
|
||
(when tail
|
||
(setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
|
||
(return (car tail)))))
|
||
(when (eq timeout t) (return (values nil t)))
|
||
(mp:process-wait-with-timeout
|
||
"receive-if" 0.3 (lambda () (some test (mailbox.queue mbox)))))))
|
||
|
||
(defimplementation send (thread message)
|
||
(let ((mbox (mailbox thread)))
|
||
(mp:with-lock ((mailbox.mutex mbox))
|
||
(setf (mailbox.queue mbox)
|
||
(nconc (mailbox.queue mbox) (list message))))))
|
||
|
||
(let ((alist '())
|
||
(lock (mp:make-lock :name "register-thread")))
|
||
|
||
(defimplementation register-thread (name thread)
|
||
(declare (type symbol name))
|
||
(mp:with-lock (lock)
|
||
(etypecase thread
|
||
(null
|
||
(setf alist (delete name alist :key #'car)))
|
||
(mp:process
|
||
(let ((probe (assoc name alist)))
|
||
(cond (probe (setf (cdr probe) thread))
|
||
(t (setf alist (acons name thread alist))))))))
|
||
nil)
|
||
|
||
(defimplementation find-registered (name)
|
||
(mp:with-lock (lock)
|
||
(cdr (assoc name alist)))))
|
||
|
||
|
||
(defimplementation set-default-initial-binding (var form)
|
||
(setq mp:*process-initial-bindings*
|
||
(acons var `(eval (quote ,form))
|
||
mp:*process-initial-bindings* )))
|
||
|
||
(defimplementation thread-attributes (thread)
|
||
(list :priority (mp:process-priority thread)
|
||
:idle (mp:process-idle-time thread)))
|
||
|
||
|
||
;;;; Weak hashtables
|
||
|
||
(defimplementation make-weak-key-hash-table (&rest args)
|
||
(apply #'make-hash-table :weak-kind :key args))
|
||
|
||
(defimplementation make-weak-value-hash-table (&rest args)
|
||
(apply #'make-hash-table :weak-kind :value args))
|