mirror of
https://github.com/amix/vimrc
synced 2025-07-12 14:15:00 +08:00
Add support for Scheme and Racket language.
This commit is contained in:
Kurtis Moxley
1536
sources_non_forked/slimv/slime/swank/abcl.lisp
Normal file
1536
sources_non_forked/slimv/slime/swank/abcl.lisp
Normal file
File diff suppressed because it is too large
Load Diff
1086
sources_non_forked/slimv/slime/swank/allegro.lisp
Normal file
1086
sources_non_forked/slimv/slime/swank/allegro.lisp
Normal file
File diff suppressed because it is too large
Load Diff
1581
sources_non_forked/slimv/slime/swank/backend.lisp
Normal file
1581
sources_non_forked/slimv/slime/swank/backend.lisp
Normal file
File diff suppressed because it is too large
Load Diff
868
sources_non_forked/slimv/slime/swank/ccl.lisp
Normal file
868
sources_non_forked/slimv/slime/swank/ccl.lisp
Normal file
@ -0,0 +1,868 @@
|
||||
;;;; -*- indent-tabs-mode: nil -*-
|
||||
;;;
|
||||
;;; swank-ccl.lisp --- SLIME backend for Clozure CL.
|
||||
;;;
|
||||
;;; Copyright (C) 2003, James Bielman <jamesjb@jamesjb.com>
|
||||
;;;
|
||||
;;; This program is licensed under the terms of the Lisp Lesser GNU
|
||||
;;; Public License, known as the LLGPL, and distributed with Clozure CL
|
||||
;;; as the file "LICENSE". The LLGPL consists of a preamble and the
|
||||
;;; LGPL, which is distributed with Clozure CL as the file "LGPL". Where
|
||||
;;; these conflict, the preamble takes precedence.
|
||||
;;;
|
||||
;;; The LLGPL is also available online at
|
||||
;;; http://opensource.franz.com/preamble.html
|
||||
|
||||
(defpackage swank/ccl
|
||||
(:use cl swank/backend))
|
||||
|
||||
(in-package swank/ccl)
|
||||
|
||||
(eval-when (:compile-toplevel :execute :load-toplevel)
|
||||
(assert (and (= ccl::*openmcl-major-version* 1)
|
||||
(>= ccl::*openmcl-minor-version* 4))
|
||||
() "This file needs CCL version 1.4 or newer"))
|
||||
|
||||
(defimplementation gray-package-name ()
|
||||
"CCL")
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(multiple-value-bind (ok err) (ignore-errors (require 'xref))
|
||||
(unless ok
|
||||
(warn "~a~%" err))))
|
||||
|
||||
;;; swank-mop
|
||||
|
||||
(import-to-swank-mop
|
||||
'( ;; classes
|
||||
cl:standard-generic-function
|
||||
ccl:standard-slot-definition
|
||||
cl:method
|
||||
cl:standard-class
|
||||
ccl:eql-specializer
|
||||
openmcl-mop:finalize-inheritance
|
||||
openmcl-mop:compute-applicable-methods-using-classes
|
||||
;; standard-class readers
|
||||
openmcl-mop:class-default-initargs
|
||||
openmcl-mop:class-direct-default-initargs
|
||||
openmcl-mop:class-direct-slots
|
||||
openmcl-mop:class-direct-subclasses
|
||||
openmcl-mop:class-direct-superclasses
|
||||
openmcl-mop:class-finalized-p
|
||||
cl:class-name
|
||||
openmcl-mop:class-precedence-list
|
||||
openmcl-mop:class-prototype
|
||||
openmcl-mop:class-slots
|
||||
openmcl-mop:specializer-direct-methods
|
||||
;; eql-specializer accessors
|
||||
openmcl-mop:eql-specializer-object
|
||||
;; generic function readers
|
||||
openmcl-mop:generic-function-argument-precedence-order
|
||||
openmcl-mop:generic-function-declarations
|
||||
openmcl-mop:generic-function-lambda-list
|
||||
openmcl-mop:generic-function-methods
|
||||
openmcl-mop:generic-function-method-class
|
||||
openmcl-mop:generic-function-method-combination
|
||||
openmcl-mop:generic-function-name
|
||||
;; method readers
|
||||
openmcl-mop:method-generic-function
|
||||
openmcl-mop:method-function
|
||||
openmcl-mop:method-lambda-list
|
||||
openmcl-mop:method-specializers
|
||||
openmcl-mop:method-qualifiers
|
||||
;; slot readers
|
||||
openmcl-mop:slot-definition-allocation
|
||||
openmcl-mop:slot-definition-documentation
|
||||
openmcl-mop:slot-value-using-class
|
||||
openmcl-mop:slot-definition-initargs
|
||||
openmcl-mop:slot-definition-initform
|
||||
openmcl-mop:slot-definition-initfunction
|
||||
openmcl-mop:slot-definition-name
|
||||
openmcl-mop:slot-definition-type
|
||||
openmcl-mop:slot-definition-readers
|
||||
openmcl-mop:slot-definition-writers
|
||||
openmcl-mop:slot-boundp-using-class
|
||||
openmcl-mop:slot-makunbound-using-class))
|
||||
|
||||
;;; UTF8
|
||||
|
||||
(defimplementation string-to-utf8 (string)
|
||||
(ccl:encode-string-to-octets string :external-format :utf-8))
|
||||
|
||||
(defimplementation utf8-to-string (octets)
|
||||
(ccl:decode-string-from-octets octets :external-format :utf-8))
|
||||
|
||||
;;; TCP Server
|
||||
|
||||
(defimplementation preferred-communication-style ()
|
||||
:spawn)
|
||||
|
||||
(defimplementation create-socket (host port &key backlog)
|
||||
(ccl:make-socket :connect :passive :local-port port
|
||||
:local-host host :reuse-address t
|
||||
:backlog (or backlog 5)))
|
||||
|
||||
(defimplementation local-port (socket)
|
||||
(ccl:local-port socket))
|
||||
|
||||
(defimplementation close-socket (socket)
|
||||
(close socket))
|
||||
|
||||
(defimplementation accept-connection (socket &key external-format
|
||||
buffering timeout)
|
||||
(declare (ignore buffering timeout))
|
||||
(let ((stream-args (and external-format
|
||||
`(:external-format ,external-format))))
|
||||
(ccl:accept-connection socket :wait t :stream-args stream-args)))
|
||||
|
||||
(defvar *external-format-to-coding-system*
|
||||
'((:iso-8859-1
|
||||
"latin-1" "latin-1-unix" "iso-latin-1-unix"
|
||||
"iso-8859-1" "iso-8859-1-unix")
|
||||
(:utf-8 "utf-8" "utf-8-unix")))
|
||||
|
||||
(defimplementation find-external-format (coding-system)
|
||||
(car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
|
||||
*external-format-to-coding-system*)))
|
||||
|
||||
(defimplementation socket-fd (stream)
|
||||
(ccl::ioblock-device (ccl::stream-ioblock stream t)))
|
||||
|
||||
;;; Unix signals
|
||||
|
||||
(defimplementation getpid ()
|
||||
(ccl::getpid))
|
||||
|
||||
(defimplementation lisp-implementation-type-name ()
|
||||
"ccl")
|
||||
|
||||
;;; Arglist
|
||||
|
||||
(defimplementation arglist (fname)
|
||||
(multiple-value-bind (arglist binding) (let ((*break-on-signals* nil))
|
||||
(ccl:arglist fname))
|
||||
(if binding
|
||||
arglist
|
||||
:not-available)))
|
||||
|
||||
(defimplementation function-name (function)
|
||||
(ccl:function-name function))
|
||||
|
||||
(defmethod declaration-arglist ((decl-identifier (eql 'optimize)))
|
||||
(let ((flags (ccl:declaration-information decl-identifier)))
|
||||
(if flags
|
||||
`(&any ,flags)
|
||||
(call-next-method))))
|
||||
|
||||
;;; Compilation
|
||||
|
||||
(defun handle-compiler-warning (condition)
|
||||
"Resignal a ccl:compiler-warning as swank/backend:compiler-warning."
|
||||
(signal 'compiler-condition
|
||||
:original-condition condition
|
||||
:message (compiler-warning-short-message condition)
|
||||
:source-context nil
|
||||
:severity (compiler-warning-severity condition)
|
||||
:location (source-note-to-source-location
|
||||
(ccl:compiler-warning-source-note condition)
|
||||
(lambda () "Unknown source")
|
||||
(ccl:compiler-warning-function-name condition))))
|
||||
|
||||
(defgeneric compiler-warning-severity (condition))
|
||||
(defmethod compiler-warning-severity ((c ccl:compiler-warning)) :warning)
|
||||
(defmethod compiler-warning-severity ((c ccl:style-warning)) :style-warning)
|
||||
|
||||
(defgeneric compiler-warning-short-message (condition))
|
||||
|
||||
;; Pretty much the same as ccl:report-compiler-warning but
|
||||
;; without the source position and function name stuff.
|
||||
(defmethod compiler-warning-short-message ((c ccl:compiler-warning))
|
||||
(with-output-to-string (stream)
|
||||
(ccl:report-compiler-warning c stream :short t)))
|
||||
|
||||
;; Needed because `ccl:report-compiler-warning' would return
|
||||
;; "Nonspecific warning".
|
||||
(defmethod compiler-warning-short-message ((c ccl::shadowed-typecase-clause))
|
||||
(princ-to-string c))
|
||||
|
||||
(defimplementation call-with-compilation-hooks (function)
|
||||
(handler-bind ((ccl:compiler-warning 'handle-compiler-warning))
|
||||
(let ((ccl:*merge-compiler-warnings* nil))
|
||||
(funcall function))))
|
||||
|
||||
(defimplementation swank-compile-file (input-file output-file
|
||||
load-p external-format
|
||||
&key policy)
|
||||
(declare (ignore policy))
|
||||
(with-compilation-hooks ()
|
||||
(compile-file input-file
|
||||
:output-file output-file
|
||||
:load load-p
|
||||
:external-format external-format)))
|
||||
|
||||
;; Use a temp file rather than in-core compilation in order to handle
|
||||
;; eval-when's as compile-time.
|
||||
(defimplementation swank-compile-string (string &key buffer position filename
|
||||
line column policy)
|
||||
(declare (ignore line column policy))
|
||||
(with-compilation-hooks ()
|
||||
(let ((temp-file-name (ccl:temp-pathname))
|
||||
(ccl:*save-source-locations* t))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(with-open-file (s temp-file-name :direction :output
|
||||
:if-exists :error :external-format :utf-8)
|
||||
(write-string string s))
|
||||
(let ((binary-filename (compile-temp-file
|
||||
temp-file-name filename buffer position)))
|
||||
(delete-file binary-filename)))
|
||||
(delete-file temp-file-name)))))
|
||||
|
||||
(defvar *temp-file-map* (make-hash-table :test #'equal)
|
||||
"A mapping from tempfile names to Emacs buffer names.")
|
||||
|
||||
(defun compile-temp-file (temp-file-name buffer-file-name buffer-name offset)
|
||||
(compile-file temp-file-name
|
||||
:load t
|
||||
:compile-file-original-truename
|
||||
(or buffer-file-name
|
||||
(progn
|
||||
(setf (gethash temp-file-name *temp-file-map*)
|
||||
buffer-name)
|
||||
temp-file-name))
|
||||
:compile-file-original-buffer-offset (1- offset)
|
||||
:external-format :utf-8))
|
||||
|
||||
(defimplementation save-image (filename &optional restart-function)
|
||||
(ccl:save-application filename :toplevel-function restart-function))
|
||||
|
||||
;;; Cross-referencing
|
||||
|
||||
(defun xref-locations (relation name &optional inverse)
|
||||
(delete-duplicates
|
||||
(mapcan #'find-definitions
|
||||
(if inverse
|
||||
(ccl::get-relation relation name :wild :exhaustive t)
|
||||
(ccl::get-relation relation :wild name :exhaustive t)))
|
||||
:test 'equal))
|
||||
|
||||
(defimplementation who-binds (name)
|
||||
(xref-locations :binds name))
|
||||
|
||||
(defimplementation who-macroexpands (name)
|
||||
(xref-locations :macro-calls name t))
|
||||
|
||||
(defimplementation who-references (name)
|
||||
(remove-duplicates
|
||||
(append (xref-locations :references name)
|
||||
(xref-locations :sets name)
|
||||
(xref-locations :binds name))
|
||||
:test 'equal))
|
||||
|
||||
(defimplementation who-sets (name)
|
||||
(xref-locations :sets name))
|
||||
|
||||
(defimplementation who-calls (name)
|
||||
(remove-duplicates
|
||||
(append
|
||||
(xref-locations :direct-calls name)
|
||||
(xref-locations :indirect-calls name)
|
||||
(xref-locations :macro-calls name t))
|
||||
:test 'equal))
|
||||
|
||||
(defimplementation who-specializes (class)
|
||||
(when (symbolp class)
|
||||
(setq class (find-class class nil)))
|
||||
(when class
|
||||
(delete-duplicates
|
||||
(mapcar (lambda (m)
|
||||
(car (find-definitions m)))
|
||||
(ccl:specializer-direct-methods class))
|
||||
:test 'equal)))
|
||||
|
||||
(defimplementation list-callees (name)
|
||||
(remove-duplicates
|
||||
(append
|
||||
(xref-locations :direct-calls name t)
|
||||
(xref-locations :macro-calls name nil))
|
||||
:test 'equal))
|
||||
|
||||
(defimplementation list-callers (symbol)
|
||||
(delete-duplicates
|
||||
(mapcan #'find-definitions (ccl:caller-functions symbol))
|
||||
:test #'equal))
|
||||
|
||||
;;; Profiling (alanr: lifted from swank-clisp)
|
||||
|
||||
(defimplementation profile (fname)
|
||||
(eval `(swank-monitor:monitor ,fname))) ;monitor is a macro
|
||||
|
||||
(defimplementation profiled-functions ()
|
||||
swank-monitor:*monitored-functions*)
|
||||
|
||||
(defimplementation unprofile (fname)
|
||||
(eval `(swank-monitor:unmonitor ,fname))) ;unmonitor is a macro
|
||||
|
||||
(defimplementation unprofile-all ()
|
||||
(swank-monitor:unmonitor))
|
||||
|
||||
(defimplementation profile-report ()
|
||||
(swank-monitor:report-monitoring))
|
||||
|
||||
(defimplementation profile-reset ()
|
||||
(swank-monitor:reset-all-monitoring))
|
||||
|
||||
(defimplementation profile-package (package callers-p methods)
|
||||
(declare (ignore callers-p methods))
|
||||
(swank-monitor:monitor-all package))
|
||||
|
||||
;;; Debugging
|
||||
|
||||
(defimplementation call-with-debugging-environment (debugger-loop-fn)
|
||||
(let* (;;(*debugger-hook* nil)
|
||||
;; don't let error while printing error take us down
|
||||
(ccl:*signal-printing-errors* nil))
|
||||
(funcall debugger-loop-fn)))
|
||||
|
||||
;; This is called for an async interrupt and is running in a random
|
||||
;; thread not selected by the user, so don't use thread-local vars
|
||||
;; such as *emacs-connection*.
|
||||
(defun find-repl-thread ()
|
||||
(let* ((*break-on-signals* nil)
|
||||
(conn (swank::default-connection)))
|
||||
(and (swank::multithreaded-connection-p conn)
|
||||
(swank::mconn.repl-thread conn))))
|
||||
|
||||
(defimplementation call-with-debugger-hook (hook fun)
|
||||
(let ((*debugger-hook* hook)
|
||||
(ccl:*break-hook* hook)
|
||||
(ccl:*select-interactive-process-hook* 'find-repl-thread))
|
||||
(funcall fun)))
|
||||
|
||||
(defimplementation install-debugger-globally (function)
|
||||
(setq *debugger-hook* function)
|
||||
(setq ccl:*break-hook* function)
|
||||
(setq ccl:*select-interactive-process-hook* 'find-repl-thread)
|
||||
)
|
||||
|
||||
(defun map-backtrace (function &optional
|
||||
(start-frame-number 0)
|
||||
end-frame-number)
|
||||
"Call FUNCTION passing information about each stack frame
|
||||
from frames START-FRAME-NUMBER to END-FRAME-NUMBER."
|
||||
(let ((end-frame-number (or end-frame-number most-positive-fixnum)))
|
||||
(ccl:map-call-frames function
|
||||
:origin ccl:*top-error-frame*
|
||||
:start-frame-number start-frame-number
|
||||
:count (- end-frame-number start-frame-number))))
|
||||
|
||||
(defimplementation compute-backtrace (start-frame-number end-frame-number)
|
||||
(let (result)
|
||||
(map-backtrace (lambda (p context)
|
||||
(push (list :frame p context) result))
|
||||
start-frame-number end-frame-number)
|
||||
(nreverse result)))
|
||||
|
||||
(defimplementation print-frame (frame stream)
|
||||
(assert (eq (first frame) :frame))
|
||||
(destructuring-bind (p context) (rest frame)
|
||||
(let ((lfun (ccl:frame-function p context)))
|
||||
(format stream "(~S" (or (ccl:function-name lfun) lfun))
|
||||
(let* ((unavailable (cons nil nil))
|
||||
(args (ccl:frame-supplied-arguments p context
|
||||
:unknown-marker unavailable)))
|
||||
(declare (dynamic-extent unavailable))
|
||||
(if (eq args unavailable)
|
||||
(format stream " #<Unknown Arguments>")
|
||||
(dolist (arg args)
|
||||
(if (eq arg unavailable)
|
||||
(format stream " #<Unavailable>")
|
||||
(format stream " ~s" arg)))))
|
||||
(format stream ")"))))
|
||||
|
||||
(defmacro with-frame ((p context) frame-number &body body)
|
||||
`(call/frame ,frame-number (lambda (,p ,context) . ,body)))
|
||||
|
||||
(defun call/frame (frame-number if-found)
|
||||
(map-backtrace
|
||||
(lambda (p context)
|
||||
(return-from call/frame
|
||||
(funcall if-found p context)))
|
||||
frame-number))
|
||||
|
||||
(defimplementation frame-call (frame-number)
|
||||
(with-frame (p context) frame-number
|
||||
(with-output-to-string (stream)
|
||||
(print-frame (list :frame p context) stream))))
|
||||
|
||||
(defimplementation frame-var-value (frame var)
|
||||
(with-frame (p context) frame
|
||||
(cdr (nth var (ccl:frame-named-variables p context)))))
|
||||
|
||||
(defimplementation frame-locals (index)
|
||||
(with-frame (p context) index
|
||||
(loop for (name . value) in (ccl:frame-named-variables p context)
|
||||
collect (list :name name :value value :id 0))))
|
||||
|
||||
(defimplementation frame-source-location (index)
|
||||
(with-frame (p context) index
|
||||
(multiple-value-bind (lfun pc) (ccl:frame-function p context)
|
||||
(if pc
|
||||
(pc-source-location lfun pc)
|
||||
(function-source-location lfun)))))
|
||||
|
||||
(defun function-name-package (name)
|
||||
(etypecase name
|
||||
(null nil)
|
||||
(symbol (symbol-package name))
|
||||
((cons (eql ccl::traced)) (function-name-package (second name)))
|
||||
((cons (eql setf)) (symbol-package (second name)))
|
||||
((cons (eql :internal)) (function-name-package (car (last name))))
|
||||
((cons (and symbol (not keyword)) (or (cons list null)
|
||||
(cons keyword (cons list null))))
|
||||
(symbol-package (car name)))
|
||||
(standard-method (function-name-package (ccl:method-name name)))))
|
||||
|
||||
(defimplementation frame-package (frame-number)
|
||||
(with-frame (p context) frame-number
|
||||
(let* ((lfun (ccl:frame-function p context))
|
||||
(name (ccl:function-name lfun)))
|
||||
(function-name-package name))))
|
||||
|
||||
(defimplementation eval-in-frame (form index)
|
||||
(with-frame (p context) index
|
||||
(let ((vars (ccl:frame-named-variables p context)))
|
||||
(eval `(let ,(loop for (var . val) in vars collect `(,var ',val))
|
||||
(declare (ignorable ,@(mapcar #'car vars)))
|
||||
,form)))))
|
||||
|
||||
(defimplementation return-from-frame (index form)
|
||||
(let ((values (multiple-value-list (eval-in-frame form index))))
|
||||
(with-frame (p context) index
|
||||
(declare (ignore context))
|
||||
(ccl:apply-in-frame p #'values values))))
|
||||
|
||||
(defimplementation restart-frame (index)
|
||||
(with-frame (p context) index
|
||||
(ccl:apply-in-frame p
|
||||
(ccl:frame-function p context)
|
||||
(ccl:frame-supplied-arguments p context))))
|
||||
|
||||
(defimplementation disassemble-frame (the-frame-number)
|
||||
(with-frame (p context) the-frame-number
|
||||
(multiple-value-bind (lfun pc) (ccl:frame-function p context)
|
||||
(format t "LFUN: ~a~%PC: ~a FP: #x~x CONTEXT: ~a~%" lfun pc p context)
|
||||
(disassemble lfun))))
|
||||
|
||||
;; CCL commit r11373 | gz | 2008-11-16 16:35:28 +0100 (Sun, 16 Nov 2008)
|
||||
;; contains some interesting details:
|
||||
;;
|
||||
;; Source location are recorded in CCL:SOURCE-NOTE's, which are objects
|
||||
;; with accessors CCL:SOURCE-NOTE-FILENAME, CCL:SOURCE-NOTE-START-POS,
|
||||
;; CCL:SOURCE-NOTE-END-POS and CCL:SOURCE-NOTE-TEXT. The start and end
|
||||
;; positions are file positions (not character positions). The text will
|
||||
;; be NIL unless text recording was on at read-time. If the original
|
||||
;; file is still available, you can force missing source text to be read
|
||||
;; from the file at runtime via CCL:ENSURE-SOURCE-NOTE-TEXT.
|
||||
;;
|
||||
;; Source-note's are associated with definitions (via record-source-file)
|
||||
;; and also stored in function objects (including anonymous and nested
|
||||
;; functions). The former can be retrieved via
|
||||
;; CCL:FIND-DEFINITION-SOURCES, the latter via CCL:FUNCTION-SOURCE-NOTE.
|
||||
;;
|
||||
;; The recording behavior is controlled by the new variable
|
||||
;; CCL:*SAVE-SOURCE-LOCATIONS*:
|
||||
;;
|
||||
;; If NIL, don't store source-notes in function objects, and store only
|
||||
;; the filename for definitions (the latter only if
|
||||
;; *record-source-file* is true).
|
||||
;;
|
||||
;; If T, store source-notes, including a copy of the original source
|
||||
;; text, for function objects and definitions (the latter only if
|
||||
;; *record-source-file* is true).
|
||||
;;
|
||||
;; If :NO-TEXT, store source-notes, but without saved text, for
|
||||
;; function objects and defintions (the latter only if
|
||||
;; *record-source-file* is true). This is the default.
|
||||
;;
|
||||
;; PC to source mapping is controlled by the new variable
|
||||
;; CCL:*RECORD-PC-MAPPING*. If true (the default), functions store a
|
||||
;; compressed table mapping pc offsets to corresponding source locations.
|
||||
;; This can be retrieved by (CCL:FIND-SOURCE-NOTE-AT-PC function pc)
|
||||
;; which returns a source-note for the source at offset pc in the
|
||||
;; function.
|
||||
|
||||
(defun function-source-location (function)
|
||||
(source-note-to-source-location
|
||||
(or (ccl:function-source-note function)
|
||||
(function-name-source-note function))
|
||||
(lambda ()
|
||||
(format nil "Function has no source note: ~A" function))
|
||||
(ccl:function-name function)))
|
||||
|
||||
(defun pc-source-location (function pc)
|
||||
(source-note-to-source-location
|
||||
(or (ccl:find-source-note-at-pc function pc)
|
||||
(ccl:function-source-note function)
|
||||
(function-name-source-note function))
|
||||
(lambda ()
|
||||
(format nil "No source note at PC: ~a[~d]" function pc))
|
||||
(ccl:function-name function)))
|
||||
|
||||
(defun function-name-source-note (fun)
|
||||
(let ((defs (ccl:find-definition-sources (ccl:function-name fun) 'function)))
|
||||
(and defs
|
||||
(destructuring-bind ((type . name) srcloc . srclocs) (car defs)
|
||||
(declare (ignore type name srclocs))
|
||||
srcloc))))
|
||||
|
||||
(defun source-note-to-source-location (source if-nil-thunk &optional name)
|
||||
(labels ((filename-to-buffer (filename)
|
||||
(cond ((gethash filename *temp-file-map*)
|
||||
(list :buffer (gethash filename *temp-file-map*)))
|
||||
((probe-file filename)
|
||||
(list :file (ccl:native-translated-namestring
|
||||
(truename filename))))
|
||||
(t (error "File ~s doesn't exist" filename)))))
|
||||
(handler-case
|
||||
(cond ((ccl:source-note-p source)
|
||||
(let* ((full-text (ccl:source-note-text source))
|
||||
(file-name (ccl:source-note-filename source))
|
||||
(start-pos (ccl:source-note-start-pos source)))
|
||||
(make-location
|
||||
(when file-name (filename-to-buffer (pathname file-name)))
|
||||
(when start-pos (list :position (1+ start-pos)))
|
||||
(when full-text
|
||||
(list :snippet (subseq full-text 0
|
||||
(min 40 (length full-text))))))))
|
||||
((and source name)
|
||||
;; This branch is probably never used
|
||||
(make-location
|
||||
(filename-to-buffer source)
|
||||
(list :function-name (princ-to-string
|
||||
(if (functionp name)
|
||||
(ccl:function-name name)
|
||||
name)))))
|
||||
(t `(:error ,(funcall if-nil-thunk))))
|
||||
(error (c) `(:error ,(princ-to-string c))))))
|
||||
|
||||
(defun alphatizer-definitions (name)
|
||||
(let ((alpha (gethash name ccl::*nx1-alphatizers*)))
|
||||
(and alpha (ccl:find-definition-sources alpha))))
|
||||
|
||||
(defun p2-definitions (name)
|
||||
(let ((nx1-op (gethash name ccl::*nx1-operators*)))
|
||||
(and nx1-op
|
||||
(let ((dispatch (ccl::backend-p2-dispatch ccl::*target-backend*)) )
|
||||
(and (array-in-bounds-p dispatch nx1-op)
|
||||
(let ((p2 (aref dispatch nx1-op)))
|
||||
(and p2
|
||||
(ccl:find-definition-sources p2))))))))
|
||||
|
||||
(defimplementation find-definitions (name)
|
||||
(let ((defs (append (or (ccl:find-definition-sources name)
|
||||
(and (symbolp name)
|
||||
(fboundp name)
|
||||
(ccl:find-definition-sources
|
||||
(symbol-function name))))
|
||||
(alphatizer-definitions name)
|
||||
(p2-definitions name))))
|
||||
(loop for ((type . name) . sources) in defs
|
||||
collect (list (definition-name type name)
|
||||
(source-note-to-source-location
|
||||
(find-if-not #'null sources)
|
||||
(lambda () "No source-note available")
|
||||
name)))))
|
||||
|
||||
(defimplementation find-source-location (obj)
|
||||
(let* ((defs (ccl:find-definition-sources obj))
|
||||
(best-def (or (find (ccl:name-of obj) defs :key #'cdar :test #'equal)
|
||||
(car defs)))
|
||||
(note (find-if-not #'null (cdr best-def))))
|
||||
(when note
|
||||
(source-note-to-source-location
|
||||
note
|
||||
(lambda () "No source note available")))))
|
||||
|
||||
(defun definition-name (type object)
|
||||
(case (ccl:definition-type-name type)
|
||||
(method (ccl:name-of object))
|
||||
(t (list (ccl:definition-type-name type) (ccl:name-of object)))))
|
||||
|
||||
;;; Utilities
|
||||
|
||||
(defimplementation describe-symbol-for-emacs (symbol)
|
||||
(let ((result '()))
|
||||
(flet ((doc (kind &optional (sym symbol))
|
||||
(or (documentation sym kind) :not-documented))
|
||||
(maybe-push (property value)
|
||||
(when value
|
||||
(setf result (list* property value result)))))
|
||||
(maybe-push
|
||||
:variable (when (boundp symbol)
|
||||
(doc 'variable)))
|
||||
(maybe-push
|
||||
:function (if (fboundp symbol)
|
||||
(doc 'function)))
|
||||
(maybe-push
|
||||
:setf (let ((setf-function-name (ccl:setf-function-spec-name
|
||||
`(setf ,symbol))))
|
||||
(when (fboundp setf-function-name)
|
||||
(doc 'function setf-function-name))))
|
||||
(maybe-push
|
||||
:type (when (ccl:type-specifier-p symbol)
|
||||
(doc 'type)))
|
||||
result)))
|
||||
|
||||
(defimplementation describe-definition (symbol namespace)
|
||||
(ecase namespace
|
||||
(:variable
|
||||
(describe symbol))
|
||||
((:function :generic-function)
|
||||
(describe (symbol-function symbol)))
|
||||
(:setf
|
||||
(describe (ccl:setf-function-spec-name `(setf ,symbol))))
|
||||
(:class
|
||||
(describe (find-class symbol)))
|
||||
(:type
|
||||
(describe (or (find-class symbol nil) symbol)))))
|
||||
|
||||
;; spec ::= (:defmethod <name> {<qualifier>}* ({<specializer>}*))
|
||||
(defun parse-defmethod-spec (spec)
|
||||
(values (second spec)
|
||||
(subseq spec 2 (position-if #'consp spec))
|
||||
(find-if #'consp (cddr spec))))
|
||||
|
||||
(defimplementation toggle-trace (spec)
|
||||
"We currently ignore just about everything."
|
||||
(let ((what (ecase (first spec)
|
||||
((setf)
|
||||
spec)
|
||||
((:defgeneric)
|
||||
(second spec))
|
||||
((:defmethod)
|
||||
(multiple-value-bind (name qualifiers specializers)
|
||||
(parse-defmethod-spec spec)
|
||||
(find-method (fdefinition name)
|
||||
qualifiers
|
||||
specializers))))))
|
||||
(cond ((member what (trace) :test #'equal)
|
||||
(ccl::%untrace what)
|
||||
(format nil "~S is now untraced." what))
|
||||
(t
|
||||
(ccl:trace-function what)
|
||||
(format nil "~S is now traced." what)))))
|
||||
|
||||
;;; Macroexpansion
|
||||
|
||||
(defimplementation macroexpand-all (form &optional env)
|
||||
(ccl:macroexpand-all form env))
|
||||
|
||||
;;;; Inspection
|
||||
|
||||
(defun comment-type-p (type)
|
||||
(or (eq type :comment)
|
||||
(and (consp type) (eq (car type) :comment))))
|
||||
|
||||
(defmethod emacs-inspect ((o t))
|
||||
(let* ((inspector:*inspector-disassembly* t)
|
||||
(i (inspector:make-inspector o))
|
||||
(count (inspector:compute-line-count i)))
|
||||
(loop for l from 0 below count append
|
||||
(multiple-value-bind (value label type) (inspector:line-n i l)
|
||||
(etypecase type
|
||||
((member nil :normal)
|
||||
`(,(or label "") (:value ,value) (:newline)))
|
||||
((member :colon)
|
||||
(label-value-line label value))
|
||||
((member :static)
|
||||
(list (princ-to-string label) " " `(:value ,value) '(:newline)))
|
||||
((satisfies comment-type-p)
|
||||
(list (princ-to-string label) '(:newline))))))))
|
||||
|
||||
(defmethod emacs-inspect :around ((o t))
|
||||
(if (or (uvector-inspector-p o)
|
||||
(not (ccl:uvectorp o)))
|
||||
(call-next-method)
|
||||
(let ((value (call-next-method)))
|
||||
(cond ((listp value)
|
||||
(append value
|
||||
`((:newline)
|
||||
(:value ,(make-instance 'uvector-inspector :object o)
|
||||
"Underlying UVECTOR"))))
|
||||
(t value)))))
|
||||
|
||||
(defmethod emacs-inspect ((f function))
|
||||
(append
|
||||
(label-value-line "Name" (function-name f))
|
||||
`("Its argument list is: "
|
||||
,(princ-to-string (arglist f)) (:newline))
|
||||
(label-value-line "Documentation" (documentation f t))
|
||||
(when (function-lambda-expression f)
|
||||
(label-value-line "Lambda Expression"
|
||||
(function-lambda-expression f)))
|
||||
(when (ccl:function-source-note f)
|
||||
(label-value-line "Source note"
|
||||
(ccl:function-source-note f)))
|
||||
(when (typep f 'ccl:compiled-lexical-closure)
|
||||
(append
|
||||
(label-value-line "Inner function" (ccl::closure-function f))
|
||||
'("Closed over values:" (:newline))
|
||||
(loop for (name value) in (ccl::closure-closed-over-values f)
|
||||
append (label-value-line (format nil " ~a" name)
|
||||
value))))))
|
||||
|
||||
(defclass uvector-inspector ()
|
||||
((object :initarg :object)))
|
||||
|
||||
(defgeneric uvector-inspector-p (object)
|
||||
(:method ((object t)) nil)
|
||||
(:method ((object uvector-inspector)) t))
|
||||
|
||||
(defmethod emacs-inspect ((uv uvector-inspector))
|
||||
(with-slots (object) uv
|
||||
(loop for i below (ccl:uvsize object) append
|
||||
(label-value-line (princ-to-string i) (ccl:uvref object i)))))
|
||||
|
||||
(defimplementation type-specifier-p (symbol)
|
||||
(or (ccl:type-specifier-p symbol)
|
||||
(not (eq (type-specifier-arglist symbol) :not-available))))
|
||||
|
||||
;;; Multiprocessing
|
||||
|
||||
(defvar *known-processes*
|
||||
(make-hash-table :size 20 :weak :key :test #'eq)
|
||||
"A map from threads to mailboxes.")
|
||||
|
||||
(defvar *known-processes-lock* (ccl:make-lock "*known-processes-lock*"))
|
||||
|
||||
(defstruct (mailbox (:conc-name mailbox.))
|
||||
(mutex (ccl:make-lock "thread mailbox"))
|
||||
(semaphore (ccl:make-semaphore))
|
||||
(queue '() :type list))
|
||||
|
||||
(defimplementation spawn (fun &key name)
|
||||
(ccl:process-run-function (or name "Anonymous (Swank)")
|
||||
fun))
|
||||
|
||||
(defimplementation thread-id (thread)
|
||||
(ccl:process-serial-number thread))
|
||||
|
||||
(defimplementation find-thread (id)
|
||||
(find id (ccl:all-processes) :key #'ccl:process-serial-number))
|
||||
|
||||
(defimplementation thread-name (thread)
|
||||
(ccl:process-name thread))
|
||||
|
||||
(defimplementation thread-status (thread)
|
||||
(format nil "~A" (ccl:process-whostate thread)))
|
||||
|
||||
(defimplementation thread-attributes (thread)
|
||||
(list :priority (ccl:process-priority thread)))
|
||||
|
||||
(defimplementation make-lock (&key name)
|
||||
(ccl:make-lock name))
|
||||
|
||||
(defimplementation call-with-lock-held (lock function)
|
||||
(ccl:with-lock-grabbed (lock)
|
||||
(funcall function)))
|
||||
|
||||
(defimplementation current-thread ()
|
||||
ccl:*current-process*)
|
||||
|
||||
(defimplementation all-threads ()
|
||||
(ccl:all-processes))
|
||||
|
||||
(defimplementation kill-thread (thread)
|
||||
;;(ccl:process-kill thread) ; doesn't cut it
|
||||
(ccl::process-initial-form-exited thread :kill))
|
||||
|
||||
(defimplementation thread-alive-p (thread)
|
||||
(not (ccl:process-exhausted-p thread)))
|
||||
|
||||
(defimplementation interrupt-thread (thread function)
|
||||
(ccl:process-interrupt
|
||||
thread
|
||||
(lambda ()
|
||||
(let ((ccl:*top-error-frame* (ccl::%current-exception-frame)))
|
||||
(funcall function)))))
|
||||
|
||||
(defun mailbox (thread)
|
||||
(ccl:with-lock-grabbed (*known-processes-lock*)
|
||||
(or (gethash thread *known-processes*)
|
||||
(setf (gethash thread *known-processes*) (make-mailbox)))))
|
||||
|
||||
(defimplementation send (thread message)
|
||||
(assert message)
|
||||
(let* ((mbox (mailbox thread))
|
||||
(mutex (mailbox.mutex mbox)))
|
||||
(ccl:with-lock-grabbed (mutex)
|
||||
(setf (mailbox.queue mbox)
|
||||
(nconc (mailbox.queue mbox) (list message)))
|
||||
(ccl:signal-semaphore (mailbox.semaphore mbox)))))
|
||||
|
||||
(defimplementation wake-thread (thread)
|
||||
(let* ((mbox (mailbox thread))
|
||||
(mutex (mailbox.mutex mbox)))
|
||||
(ccl:with-lock-grabbed (mutex)
|
||||
(ccl:signal-semaphore (mailbox.semaphore mbox)))))
|
||||
|
||||
(defimplementation receive-if (test &optional timeout)
|
||||
(let* ((mbox (mailbox ccl:*current-process*))
|
||||
(mutex (mailbox.mutex mbox)))
|
||||
(assert (or (not timeout) (eq timeout t)))
|
||||
(loop
|
||||
(check-slime-interrupts)
|
||||
(ccl:with-lock-grabbed (mutex)
|
||||
(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)))
|
||||
(ccl:wait-on-semaphore (mailbox.semaphore mbox)))))
|
||||
|
||||
(let ((alist '())
|
||||
(lock (ccl:make-lock "register-thread")))
|
||||
|
||||
(defimplementation register-thread (name thread)
|
||||
(declare (type symbol name))
|
||||
(ccl:with-lock-grabbed (lock)
|
||||
(etypecase thread
|
||||
(null
|
||||
(setf alist (delete name alist :key #'car)))
|
||||
(ccl:process
|
||||
(let ((probe (assoc name alist)))
|
||||
(cond (probe (setf (cdr probe) thread))
|
||||
(t (setf alist (acons name thread alist))))))))
|
||||
nil)
|
||||
|
||||
(defimplementation find-registered (name)
|
||||
(ccl:with-lock-grabbed (lock)
|
||||
(cdr (assoc name alist)))))
|
||||
|
||||
(defimplementation set-default-initial-binding (var form)
|
||||
(eval `(ccl::def-standard-initial-binding ,var ,form)))
|
||||
|
||||
(defimplementation quit-lisp ()
|
||||
(ccl:quit))
|
||||
|
||||
(defimplementation set-default-directory (directory)
|
||||
(let ((dir (truename (merge-pathnames directory))))
|
||||
(setf *default-pathname-defaults* (truename (merge-pathnames directory)))
|
||||
(ccl:cwd dir)
|
||||
(default-directory)))
|
||||
|
||||
;;; Weak datastructures
|
||||
|
||||
(defimplementation make-weak-key-hash-table (&rest args)
|
||||
(apply #'make-hash-table :weak :key args))
|
||||
|
||||
(defimplementation make-weak-value-hash-table (&rest args)
|
||||
(apply #'make-hash-table :weak :value args))
|
||||
|
||||
(defimplementation hash-table-weakness (hashtable)
|
||||
(ccl:hash-table-weak-p hashtable))
|
||||
|
||||
(pushnew 'deinit-log-output ccl:*save-exit-functions*)
|
||||
712
sources_non_forked/slimv/slime/swank/clasp.lisp
Normal file
712
sources_non_forked/slimv/slime/swank/clasp.lisp
Normal file
@ -0,0 +1,712 @@
|
||||
;;;; -*- indent-tabs-mode: nil -*-
|
||||
;;;
|
||||
;;; swank-clasp.lisp --- SLIME backend for CLASP.
|
||||
;;;
|
||||
;;; This code has been placed in the Public Domain. All warranties
|
||||
;;; are disclaimed.
|
||||
;;;
|
||||
|
||||
;;; Administrivia
|
||||
|
||||
(defpackage swank/clasp
|
||||
(:use cl swank/backend))
|
||||
|
||||
(in-package swank/clasp)
|
||||
|
||||
#+(or)
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(setq swank::*log-output* (open "/tmp/slime.log" :direction :output))
|
||||
(setq swank:*log-events* t))
|
||||
|
||||
(defmacro slime-dbg (fmt &rest args)
|
||||
`(swank::log-event "slime-dbg ~a ~a~%" mp:*current-process* (apply #'format nil ,fmt ,args)))
|
||||
|
||||
;; Hard dependencies.
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(require 'sockets))
|
||||
|
||||
;; Soft dependencies.
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(when (probe-file "sys:profile.fas")
|
||||
(require :profile)
|
||||
(pushnew :profile *features*))
|
||||
(when (probe-file "sys:serve-event")
|
||||
(require :serve-event)
|
||||
(pushnew :serve-event *features*)))
|
||||
|
||||
(declaim (optimize (debug 3)))
|
||||
|
||||
;;; Swank-mop
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(import-swank-mop-symbols :clos nil))
|
||||
|
||||
(defimplementation gray-package-name ()
|
||||
"GRAY")
|
||||
|
||||
|
||||
;;;; TCP Server
|
||||
|
||||
(defimplementation preferred-communication-style ()
|
||||
:spawn
|
||||
#| #+threads :spawn
|
||||
#-threads nil
|
||||
|#
|
||||
)
|
||||
|
||||
(defun resolve-hostname (name)
|
||||
(car (sb-bsd-sockets:host-ent-addresses
|
||||
(sb-bsd-sockets:get-host-by-name name))))
|
||||
|
||||
(defimplementation create-socket (host port &key backlog)
|
||||
(let ((socket (make-instance 'sb-bsd-sockets:inet-socket
|
||||
:type :stream
|
||||
:protocol :tcp)))
|
||||
(setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
|
||||
(sb-bsd-sockets:socket-bind socket (resolve-hostname host) port)
|
||||
(sb-bsd-sockets:socket-listen socket (or backlog 5))
|
||||
socket))
|
||||
|
||||
(defimplementation local-port (socket)
|
||||
(nth-value 1 (sb-bsd-sockets:socket-name socket)))
|
||||
|
||||
(defimplementation close-socket (socket)
|
||||
(sb-bsd-sockets:socket-close socket))
|
||||
|
||||
(defimplementation accept-connection (socket
|
||||
&key external-format
|
||||
buffering timeout)
|
||||
(declare (ignore timeout))
|
||||
(sb-bsd-sockets:socket-make-stream (accept socket)
|
||||
:output t
|
||||
:input t
|
||||
:buffering (ecase buffering
|
||||
((t) :full)
|
||||
((nil) :none)
|
||||
(:line :line))
|
||||
:element-type (if external-format
|
||||
'character
|
||||
'(unsigned-byte 8))
|
||||
:external-format external-format))
|
||||
(defun accept (socket)
|
||||
"Like socket-accept, but retry on EAGAIN."
|
||||
(loop (handler-case
|
||||
(return (sb-bsd-sockets:socket-accept socket))
|
||||
(sb-bsd-sockets:interrupted-error ()))))
|
||||
|
||||
(defimplementation socket-fd (socket)
|
||||
(etypecase socket
|
||||
(fixnum socket)
|
||||
(two-way-stream (socket-fd (two-way-stream-input-stream socket)))
|
||||
(sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket))
|
||||
(file-stream (si:file-stream-fd socket))))
|
||||
|
||||
(defvar *external-format-to-coding-system*
|
||||
'((:latin-1
|
||||
"latin-1" "latin-1-unix" "iso-latin-1-unix"
|
||||
"iso-8859-1" "iso-8859-1-unix")
|
||||
(:utf-8 "utf-8" "utf-8-unix")))
|
||||
|
||||
(defun external-format (coding-system)
|
||||
(or (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
|
||||
*external-format-to-coding-system*))
|
||||
(find coding-system (ext:all-encodings) :test #'string-equal)))
|
||||
|
||||
(defimplementation find-external-format (coding-system)
|
||||
#+unicode (external-format coding-system)
|
||||
;; Without unicode support, CLASP uses the one-byte encoding of the
|
||||
;; underlying OS, and will barf on anything except :DEFAULT. We
|
||||
;; return NIL here for known multibyte encodings, so
|
||||
;; SWANK:CREATE-SERVER will barf.
|
||||
#-unicode (let ((xf (external-format coding-system)))
|
||||
(if (member xf '(:utf-8))
|
||||
nil
|
||||
:default)))
|
||||
|
||||
|
||||
;;;; Unix Integration
|
||||
|
||||
;;; If CLASP is built with thread support, it'll spawn a helper thread
|
||||
;;; executing the SIGINT handler. We do not want to BREAK into that
|
||||
;;; helper but into the main thread, though. This is coupled with the
|
||||
;;; current choice of NIL as communication-style in so far as CLASP's
|
||||
;;; main-thread is also the Slime's REPL thread.
|
||||
|
||||
#+clasp-working
|
||||
(defimplementation call-with-user-break-handler (real-handler function)
|
||||
(let ((old-handler #'si:terminal-interrupt))
|
||||
(setf (symbol-function 'si:terminal-interrupt)
|
||||
(make-interrupt-handler real-handler))
|
||||
(unwind-protect (funcall function)
|
||||
(setf (symbol-function 'si:terminal-interrupt) old-handler))))
|
||||
|
||||
#+threads
|
||||
(defun make-interrupt-handler (real-handler)
|
||||
(let ((main-thread (find 'si:top-level (mp:all-processes)
|
||||
:key #'mp:process-name)))
|
||||
#'(lambda (&rest args)
|
||||
(declare (ignore args))
|
||||
(mp:interrupt-process main-thread real-handler))))
|
||||
|
||||
#-threads
|
||||
(defun make-interrupt-handler (real-handler)
|
||||
#'(lambda (&rest args)
|
||||
(declare (ignore args))
|
||||
(funcall real-handler)))
|
||||
|
||||
|
||||
(defimplementation getpid ()
|
||||
(si:getpid))
|
||||
|
||||
(defimplementation set-default-directory (directory)
|
||||
(ext:chdir (namestring directory)) ; adapts *DEFAULT-PATHNAME-DEFAULTS*.
|
||||
(default-directory))
|
||||
|
||||
(defimplementation default-directory ()
|
||||
(namestring (ext:getcwd)))
|
||||
|
||||
(defimplementation quit-lisp ()
|
||||
(core:quit))
|
||||
|
||||
|
||||
|
||||
;;; Instead of busy waiting with communication-style NIL, use select()
|
||||
;;; on the sockets' streams.
|
||||
#+serve-event
|
||||
(progn
|
||||
(defun poll-streams (streams timeout)
|
||||
(let* ((serve-event::*descriptor-handlers*
|
||||
(copy-list serve-event::*descriptor-handlers*))
|
||||
(active-fds '())
|
||||
(fd-stream-alist
|
||||
(loop for s in streams
|
||||
for fd = (socket-fd s)
|
||||
collect (cons fd s)
|
||||
do (serve-event:add-fd-handler fd :input
|
||||
#'(lambda (fd)
|
||||
(push fd active-fds))))))
|
||||
(serve-event:serve-event timeout)
|
||||
(loop for fd in active-fds collect (cdr (assoc fd fd-stream-alist)))))
|
||||
|
||||
(defimplementation wait-for-input (streams &optional timeout)
|
||||
(assert (member timeout '(nil t)))
|
||||
(loop
|
||||
(cond ((check-slime-interrupts) (return :interrupt))
|
||||
(timeout (return (poll-streams streams 0)))
|
||||
(t
|
||||
(when-let (ready (poll-streams streams 0.2))
|
||||
(return ready))))))
|
||||
|
||||
) ; #+serve-event (progn ...
|
||||
|
||||
#-serve-event
|
||||
(defimplementation wait-for-input (streams &optional timeout)
|
||||
(assert (member timeout '(nil t)))
|
||||
(loop
|
||||
(cond ((check-slime-interrupts) (return :interrupt))
|
||||
(timeout (return (remove-if-not #'listen streams)))
|
||||
(t
|
||||
(let ((ready (remove-if-not #'listen streams)))
|
||||
(if ready (return ready))
|
||||
(sleep 0.1))))))
|
||||
|
||||
|
||||
;;;; Compilation
|
||||
|
||||
(defvar *buffer-name* nil)
|
||||
(defvar *buffer-start-position*)
|
||||
|
||||
(defun condition-severity (condition)
|
||||
(etypecase condition
|
||||
(cmp:redefined-function-warning :redefinition)
|
||||
(style-warning :style-warning)
|
||||
(warning :warning)
|
||||
(reader-error :read-error)
|
||||
(error :error)))
|
||||
|
||||
(defun condition-location (origin)
|
||||
(if (null origin)
|
||||
(make-error-location "No error location available")
|
||||
;; NOTE: If we're compiling in a buffer, the origin
|
||||
;; will already be set up with the offset correctly
|
||||
;; due to the :source-debug parameters from
|
||||
;; swank-compile-string (below).
|
||||
(make-file-location
|
||||
(core:file-scope-pathname
|
||||
(core:file-scope origin))
|
||||
(core:source-pos-info-filepos origin))))
|
||||
|
||||
(defun signal-compiler-condition (condition origin)
|
||||
(signal 'compiler-condition
|
||||
:original-condition condition
|
||||
:severity (condition-severity condition)
|
||||
:message (princ-to-string condition)
|
||||
:location (condition-location origin)))
|
||||
|
||||
(defun handle-compiler-condition (condition)
|
||||
;; First resignal warnings, so that outer handlers - which may choose to
|
||||
;; muffle this - get a chance to run.
|
||||
(when (typep condition 'warning)
|
||||
(signal condition))
|
||||
(signal-compiler-condition (cmp:deencapsulate-compiler-condition condition)
|
||||
(cmp:compiler-condition-origin condition)))
|
||||
|
||||
(defimplementation call-with-compilation-hooks (function)
|
||||
(handler-bind
|
||||
(((or error warning) #'handle-compiler-condition))
|
||||
(funcall function)))
|
||||
|
||||
(defimplementation swank-compile-file (input-file output-file
|
||||
load-p external-format
|
||||
&key policy)
|
||||
(declare (ignore policy))
|
||||
(format t "Compiling file input-file = ~a output-file = ~a~%" input-file output-file)
|
||||
;; Ignore the output-file and generate our own
|
||||
(let ((tmp-output-file (compile-file-pathname (si:mkstemp "TMP:clasp-swank-compile-file-"))))
|
||||
(format t "Using tmp-output-file: ~a~%" tmp-output-file)
|
||||
(multiple-value-bind (fasl warnings-p failure-p)
|
||||
(with-compilation-hooks ()
|
||||
(compile-file input-file :output-file tmp-output-file
|
||||
:external-format external-format))
|
||||
(values fasl warnings-p
|
||||
(or failure-p
|
||||
(when load-p
|
||||
(not (load fasl))))))))
|
||||
|
||||
(defvar *tmpfile-map* (make-hash-table :test #'equal))
|
||||
|
||||
(defun note-buffer-tmpfile (tmp-file buffer-name)
|
||||
;; EXT:COMPILED-FUNCTION-FILE below will return a namestring.
|
||||
(let ((tmp-namestring (namestring (truename tmp-file))))
|
||||
(setf (gethash tmp-namestring *tmpfile-map*) buffer-name)
|
||||
tmp-namestring))
|
||||
|
||||
(defun tmpfile-to-buffer (tmp-file)
|
||||
(gethash tmp-file *tmpfile-map*))
|
||||
|
||||
(defimplementation swank-compile-string (string &key buffer position filename line column policy)
|
||||
(declare (ignore column policy)) ;; We may use column in the future
|
||||
(with-compilation-hooks ()
|
||||
(let ((*buffer-name* buffer) ; for compilation hooks
|
||||
(*buffer-start-position* position))
|
||||
(let ((tmp-file (si:mkstemp "TMP:clasp-swank-tmpfile-"))
|
||||
(fasl-file)
|
||||
(warnings-p)
|
||||
(failure-p))
|
||||
(unwind-protect
|
||||
(with-open-file (tmp-stream tmp-file :direction :output
|
||||
:if-exists :supersede)
|
||||
(write-string string tmp-stream)
|
||||
(finish-output tmp-stream)
|
||||
(multiple-value-setq (fasl-file warnings-p failure-p)
|
||||
(let ((truename (or filename (note-buffer-tmpfile tmp-file buffer))))
|
||||
(compile-file tmp-file
|
||||
:source-debug-pathname (pathname truename)
|
||||
;; emacs numbers are 1-based instead of 0-based,
|
||||
;; so we have to subtract
|
||||
:source-debug-lineno (1- line)
|
||||
:source-debug-offset (1- position)))))
|
||||
(when fasl-file (load fasl-file))
|
||||
(when (probe-file tmp-file)
|
||||
(delete-file tmp-file))
|
||||
(when fasl-file
|
||||
(delete-file fasl-file)))
|
||||
(not failure-p)))))
|
||||
|
||||
;;;; Documentation
|
||||
|
||||
(defimplementation arglist (name)
|
||||
(multiple-value-bind (arglist foundp)
|
||||
(core:function-lambda-list name) ;; Uses bc-split
|
||||
(if foundp arglist :not-available)))
|
||||
|
||||
(defimplementation function-name (f)
|
||||
(typecase f
|
||||
(generic-function (clos::generic-function-name f))
|
||||
(function (ext:compiled-function-name f))))
|
||||
|
||||
;; FIXME
|
||||
(defimplementation macroexpand-all (form &optional env)
|
||||
(declare (ignore env))
|
||||
(macroexpand form))
|
||||
|
||||
;;; modified from sbcl.lisp
|
||||
(defimplementation collect-macro-forms (form &optional environment)
|
||||
(let ((macro-forms '())
|
||||
(compiler-macro-forms '())
|
||||
(function-quoted-forms '()))
|
||||
(format t "In collect-macro-forms~%")
|
||||
(cmp:code-walk
|
||||
(lambda (form environment)
|
||||
(when (and (consp form)
|
||||
(symbolp (car form)))
|
||||
(cond ((eq (car form) 'function)
|
||||
(push (cadr form) function-quoted-forms))
|
||||
((member form function-quoted-forms)
|
||||
nil)
|
||||
((macro-function (car form) environment)
|
||||
(push form macro-forms))
|
||||
((not (eq form (core:compiler-macroexpand-1 form environment)))
|
||||
(push form compiler-macro-forms))))
|
||||
form)
|
||||
form environment)
|
||||
(values macro-forms compiler-macro-forms)))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
(defimplementation describe-symbol-for-emacs (symbol)
|
||||
(let ((result '()))
|
||||
(flet ((frob (type boundp)
|
||||
(when (funcall boundp symbol)
|
||||
(let ((doc (describe-definition symbol type)))
|
||||
(setf result (list* type doc result))))))
|
||||
(frob :VARIABLE #'boundp)
|
||||
(frob :FUNCTION #'fboundp)
|
||||
(frob :CLASS (lambda (x) (find-class x nil))))
|
||||
result))
|
||||
|
||||
(defimplementation describe-definition (name type)
|
||||
(case type
|
||||
(:variable (documentation name 'variable))
|
||||
(:function (documentation name 'function))
|
||||
(:class (documentation name 'class))
|
||||
(t nil)))
|
||||
|
||||
(defimplementation type-specifier-p (symbol)
|
||||
(or (subtypep nil symbol)
|
||||
(not (eq (type-specifier-arglist symbol) :not-available))))
|
||||
|
||||
|
||||
;;; Debugging
|
||||
|
||||
(defun make-invoke-debugger-hook (hook)
|
||||
(when hook
|
||||
#'(lambda (condition old-hook)
|
||||
;; Regard *debugger-hook* if set by user.
|
||||
(if *debugger-hook*
|
||||
nil ; decline, *DEBUGGER-HOOK* will be tried next.
|
||||
(funcall hook condition old-hook)))))
|
||||
|
||||
(defimplementation install-debugger-globally (function)
|
||||
(setq *debugger-hook* function)
|
||||
(setq ext:*invoke-debugger-hook* (make-invoke-debugger-hook function)))
|
||||
|
||||
(defimplementation call-with-debugger-hook (hook fun)
|
||||
(let ((*debugger-hook* hook)
|
||||
(ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
|
||||
(funcall fun)))
|
||||
|
||||
(defvar *backtrace* '())
|
||||
|
||||
;;; Commented out; it's not clear this is a good way of doing it. In
|
||||
;;; particular because it makes errors stemming from this file harder
|
||||
;;; to debug, and given the "young" age of CLASP's swank backend, that's
|
||||
;;; a bad idea.
|
||||
|
||||
;; (defun in-swank-package-p (x)
|
||||
;; (and
|
||||
;; (symbolp x)
|
||||
;; (member (symbol-package x)
|
||||
;; (list #.(find-package :swank)
|
||||
;; #.(find-package :swank/backend)
|
||||
;; #.(ignore-errors (find-package :swank-mop))
|
||||
;; #.(ignore-errors (find-package :swank-loader))))
|
||||
;; t))
|
||||
|
||||
;; (defun is-swank-source-p (name)
|
||||
;; (setf name (pathname name))
|
||||
;; (pathname-match-p
|
||||
;; name
|
||||
;; (make-pathname :defaults swank-loader::*source-directory*
|
||||
;; :name (pathname-name name)
|
||||
;; :type (pathname-type name)
|
||||
;; :version (pathname-version name))))
|
||||
|
||||
;; (defun is-ignorable-fun-p (x)
|
||||
;; (or
|
||||
;; (in-swank-package-p (frame-name x))
|
||||
;; (multiple-value-bind (file position)
|
||||
;; (ignore-errors (si::bc-file (car x)))
|
||||
;; (declare (ignore position))
|
||||
;; (if file (is-swank-source-p file)))))
|
||||
|
||||
(defimplementation call-with-debugging-environment (debugger-loop-fn)
|
||||
(declare (type function debugger-loop-fn))
|
||||
(clasp-debug:with-stack (stack)
|
||||
(let ((*backtrace* (clasp-debug:list-stack stack)))
|
||||
(funcall debugger-loop-fn))))
|
||||
|
||||
(defimplementation compute-backtrace (start end)
|
||||
(subseq *backtrace* start
|
||||
(and (numberp end)
|
||||
(min end (length *backtrace*)))))
|
||||
|
||||
(defun frame-from-number (frame-number)
|
||||
(elt *backtrace* frame-number))
|
||||
|
||||
(defimplementation print-frame (frame stream)
|
||||
(clasp-debug:prin1-frame-call frame stream))
|
||||
|
||||
(defimplementation frame-source-location (frame-number)
|
||||
(let ((csl (clasp-debug:frame-source-position (frame-from-number frame-number))))
|
||||
(if (clasp-debug:code-source-line-pathname csl)
|
||||
(make-location (list :file (namestring (clasp-debug:code-source-line-pathname csl)))
|
||||
(list :line (clasp-debug:code-source-line-line-number csl))
|
||||
'(:align t))
|
||||
`(:error ,(format nil "No source for frame: ~a" frame-number)))))
|
||||
|
||||
(defimplementation frame-locals (frame-number)
|
||||
(loop for (var . value)
|
||||
in (clasp-debug:frame-locals (frame-from-number frame-number))
|
||||
for i from 0
|
||||
collect (list :name var :id i :value value)))
|
||||
|
||||
(defimplementation frame-var-value (frame-number var-number)
|
||||
(let* ((frame (frame-from-number frame-number))
|
||||
(locals (clasp-debug:frame-locals frame)))
|
||||
(cdr (nth var-number locals))))
|
||||
|
||||
(defimplementation disassemble-frame (frame-number)
|
||||
(clasp-debug:disassemble-frame (frame-from-number frame-number)))
|
||||
|
||||
(defimplementation eval-in-frame (form frame-number)
|
||||
(let* ((frame (frame-from-number frame-number)))
|
||||
(eval
|
||||
`(let (,@(loop for (var . value)
|
||||
in (clasp-debug:frame-locals frame)
|
||||
collect `(,var ',value)))
|
||||
(progn ,form)))))
|
||||
|
||||
#+clasp-working
|
||||
(defimplementation gdb-initial-commands ()
|
||||
;; These signals are used by the GC.
|
||||
#+linux '("handle SIGPWR noprint nostop"
|
||||
"handle SIGXCPU noprint nostop"))
|
||||
|
||||
#+clasp-working
|
||||
(defimplementation command-line-args ()
|
||||
(loop for n from 0 below (si:argc) collect (si:argv n)))
|
||||
|
||||
|
||||
;;;; Inspector
|
||||
|
||||
;;; FIXME: Would be nice if it was possible to inspect objects
|
||||
;;; implemented in C.
|
||||
|
||||
|
||||
;;;; Definitions
|
||||
|
||||
(defun make-file-location (file file-position)
|
||||
;; File positions in CL start at 0, but Emacs' buffer positions
|
||||
;; start at 1. We specify (:ALIGN T) because the positions comming
|
||||
;; from CLASP point at right after the toplevel form appearing before
|
||||
;; the actual target toplevel form; (:ALIGN T) will DTRT in that case.
|
||||
(make-location `(:file ,(namestring (translate-logical-pathname file)))
|
||||
`(:position ,(1+ file-position))
|
||||
`(:align t)))
|
||||
|
||||
(defun make-buffer-location (buffer-name start-position &optional (offset 0))
|
||||
(make-location `(:buffer ,buffer-name)
|
||||
`(:offset ,start-position ,offset)
|
||||
`(:align t)))
|
||||
|
||||
(defun translate-location (location)
|
||||
(make-location (list :file (namestring (ext:source-location-pathname location)))
|
||||
(list :position (ext:source-location-offset location))
|
||||
'(:align t)))
|
||||
|
||||
(defun make-dspec (name location)
|
||||
(list* (ext:source-location-definer location)
|
||||
name
|
||||
(ext:source-location-description location)))
|
||||
|
||||
(defimplementation find-definitions (name)
|
||||
(loop for kind in ext:*source-location-kinds*
|
||||
for locations = (ext:source-location name kind)
|
||||
when locations
|
||||
nconc (loop for location in locations
|
||||
collect (list (make-dspec name location)
|
||||
(translate-location location)))))
|
||||
|
||||
(defun source-location (object)
|
||||
(let ((location (ext:source-location object t)))
|
||||
(when location
|
||||
(translate-location (car location)))))
|
||||
|
||||
(defimplementation find-source-location (object)
|
||||
(or (source-location object)
|
||||
(make-error-location "Source definition of ~S not found." object)))
|
||||
|
||||
|
||||
;;;; Profiling
|
||||
|
||||
;;;; as clisp and ccl
|
||||
|
||||
(defimplementation profile (fname)
|
||||
(eval `(swank-monitor:monitor ,fname))) ;monitor is a macro
|
||||
|
||||
(defimplementation profiled-functions ()
|
||||
swank-monitor:*monitored-functions*)
|
||||
|
||||
(defimplementation unprofile (fname)
|
||||
(eval `(swank-monitor:unmonitor ,fname))) ;unmonitor is a macro
|
||||
|
||||
(defimplementation unprofile-all ()
|
||||
(swank-monitor:unmonitor))
|
||||
|
||||
(defimplementation profile-report ()
|
||||
(swank-monitor:report-monitoring))
|
||||
|
||||
(defimplementation profile-reset ()
|
||||
(swank-monitor:reset-all-monitoring))
|
||||
|
||||
(defimplementation profile-package (package callers-p methods)
|
||||
(declare (ignore callers-p methods))
|
||||
(swank-monitor:monitor-all package))
|
||||
|
||||
|
||||
;;;; Threads
|
||||
|
||||
#+threads
|
||||
(progn
|
||||
(defvar *thread-id-counter* 0)
|
||||
|
||||
(defparameter *thread-id-map* (make-hash-table))
|
||||
|
||||
(defvar *thread-id-map-lock*
|
||||
(mp:make-lock :name "thread id map lock"))
|
||||
|
||||
(defimplementation spawn (fn &key name)
|
||||
(mp:process-run-function name fn))
|
||||
|
||||
(defimplementation thread-id (target-thread)
|
||||
(block thread-id
|
||||
(mp:with-lock (*thread-id-map-lock*)
|
||||
;; Does TARGET-THREAD have an id already?
|
||||
(maphash (lambda (id thread-pointer)
|
||||
(let ((thread (si:weak-pointer-value thread-pointer)))
|
||||
(cond ((not thread)
|
||||
(remhash id *thread-id-map*))
|
||||
((eq thread target-thread)
|
||||
(return-from thread-id id)))))
|
||||
*thread-id-map*)
|
||||
;; TARGET-THREAD not found in *THREAD-ID-MAP*
|
||||
(let ((id (incf *thread-id-counter*))
|
||||
(thread-pointer (si:make-weak-pointer target-thread)))
|
||||
(setf (gethash id *thread-id-map*) thread-pointer)
|
||||
id))))
|
||||
|
||||
(defimplementation find-thread (id)
|
||||
(mp:with-lock (*thread-id-map-lock*)
|
||||
(let* ((thread-ptr (gethash id *thread-id-map*))
|
||||
(thread (and thread-ptr (si:weak-pointer-value thread-ptr))))
|
||||
(unless thread
|
||||
(remhash id *thread-id-map*))
|
||||
thread)))
|
||||
|
||||
(defimplementation thread-name (thread)
|
||||
(mp:process-name thread))
|
||||
|
||||
(defimplementation thread-status (thread)
|
||||
(if (mp:process-active-p thread)
|
||||
"RUNNING"
|
||||
"STOPPED"))
|
||||
|
||||
(defimplementation make-lock (&key name)
|
||||
(mp:make-recursive-mutex name))
|
||||
|
||||
(defimplementation call-with-lock-held (lock function)
|
||||
(declare (type function function))
|
||||
(mp:with-lock (lock) (funcall function)))
|
||||
|
||||
(defimplementation current-thread ()
|
||||
mp:*current-process*)
|
||||
|
||||
(defimplementation all-threads ()
|
||||
(mp:all-processes))
|
||||
|
||||
(defimplementation interrupt-thread (thread fn)
|
||||
(mp:interrupt-process thread fn))
|
||||
|
||||
(defimplementation kill-thread (thread)
|
||||
(mp:process-kill thread))
|
||||
|
||||
(defimplementation thread-alive-p (thread)
|
||||
(mp:process-active-p thread))
|
||||
|
||||
(defvar *mailbox-lock* (mp:make-lock :name "mailbox lock"))
|
||||
(defvar *mailboxes* (list))
|
||||
(declaim (type list *mailboxes*))
|
||||
|
||||
(defstruct (mailbox (:conc-name mailbox.))
|
||||
thread
|
||||
(mutex (mp:make-lock :name "SLIMELCK"))
|
||||
(cvar (mp:make-condition-variable))
|
||||
(queue '() :type list))
|
||||
|
||||
(defun mailbox (thread)
|
||||
"Return THREAD's mailbox."
|
||||
(mp:with-lock (*mailbox-lock*)
|
||||
(or (find thread *mailboxes* :key #'mailbox.thread)
|
||||
(let ((mb (make-mailbox :thread thread)))
|
||||
(push mb *mailboxes*)
|
||||
mb))))
|
||||
|
||||
(defimplementation wake-thread (thread)
|
||||
(let* ((mbox (mailbox thread))
|
||||
(mutex (mailbox.mutex mbox)))
|
||||
(format t "About to with-lock in wake-thread~%")
|
||||
(mp:with-lock (mutex)
|
||||
(format t "In wake-thread~%")
|
||||
(mp:condition-variable-broadcast (mailbox.cvar mbox)))))
|
||||
|
||||
(defimplementation send (thread message)
|
||||
(let* ((mbox (mailbox thread))
|
||||
(mutex (mailbox.mutex mbox)))
|
||||
(swank::log-event "clasp.lisp: send message ~a mutex: ~a~%" message mutex)
|
||||
(swank::log-event "clasp.lisp: (lock-owner mutex) -> ~a~%" (mp:lock-owner mutex))
|
||||
(swank::log-event "clasp.lisp: (lock-count mutex) -> ~a~%" (mp:lock-count mutex))
|
||||
(mp:with-lock (mutex)
|
||||
(swank::log-event "clasp.lisp: in with-lock (lock-owner mutex) -> ~a~%" (mp:lock-owner mutex))
|
||||
(swank::log-event "clasp.lisp: in with-lock (lock-count mutex) -> ~a~%" (mp:lock-count mutex))
|
||||
(setf (mailbox.queue mbox)
|
||||
(nconc (mailbox.queue mbox) (list message)))
|
||||
(swank::log-event "clasp.lisp: send about to broadcast~%")
|
||||
(mp:condition-variable-broadcast (mailbox.cvar mbox)))))
|
||||
|
||||
|
||||
(defimplementation receive-if (test &optional timeout)
|
||||
(slime-dbg "Entered receive-if")
|
||||
(let* ((mbox (mailbox (current-thread)))
|
||||
(mutex (mailbox.mutex mbox)))
|
||||
(slime-dbg "receive-if assert")
|
||||
(assert (or (not timeout) (eq timeout t)))
|
||||
(loop
|
||||
(slime-dbg "receive-if check-slime-interrupts")
|
||||
(check-slime-interrupts)
|
||||
(slime-dbg "receive-if with-lock")
|
||||
(mp:with-lock (mutex)
|
||||
(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))))
|
||||
(slime-dbg "receive-if when (eq")
|
||||
(when (eq timeout t) (return (values nil t)))
|
||||
(slime-dbg "receive-if condition-variable-timedwait")
|
||||
(mp:condition-variable-wait (mailbox.cvar mbox) mutex) ; timedwait 0.2
|
||||
(slime-dbg "came out of condition-variable-timedwait")
|
||||
(core:check-pending-interrupts)))))
|
||||
|
||||
) ; #+threads (progn ...
|
||||
|
||||
|
||||
(defmethod emacs-inspect ((object core:cxx-object))
|
||||
(let ((encoded (core:encode object)))
|
||||
(loop for (key . value) in encoded
|
||||
append (list (string key) ": " (list :value value) (list :newline)))))
|
||||
|
||||
(defmethod emacs-inspect ((object core:va-list))
|
||||
(emacs-inspect (core:list-from-va-list object)))
|
||||
930
sources_non_forked/slimv/slime/swank/clisp.lisp
Normal file
930
sources_non_forked/slimv/slime/swank/clisp.lisp
Normal file
@ -0,0 +1,930 @@
|
||||
;;;; -*- indent-tabs-mode: nil -*-
|
||||
|
||||
;;;; SWANK support for CLISP.
|
||||
|
||||
;;;; Copyright (C) 2003, 2004 W. Jenkner, V. Sedach
|
||||
|
||||
;;;; This program is free software; you can redistribute it and/or
|
||||
;;;; modify it under the terms of the GNU General Public License as
|
||||
;;;; published by the Free Software Foundation; either version 2 of
|
||||
;;;; the License, or (at your option) any later version.
|
||||
|
||||
;;;; This program is distributed in the hope that it will be useful,
|
||||
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;;;; GNU General Public License for more details.
|
||||
|
||||
;;;; You should have received a copy of the GNU General Public
|
||||
;;;; License along with this program; if not, write to the Free
|
||||
;;;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
|
||||
;;;; MA 02111-1307, USA.
|
||||
|
||||
;;; This is work in progress, but it's already usable. Many things
|
||||
;;; are adapted from other swank-*.lisp, in particular from
|
||||
;;; swank-allegro (I don't use allegro at all, but it's the shortest
|
||||
;;; one and I found Helmut Eller's code there enlightening).
|
||||
|
||||
;;; This code will work better with recent versions of CLISP (say, the
|
||||
;;; last release or CVS HEAD) while it may not work at all with older
|
||||
;;; versions. It is reasonable to expect it to work on platforms with
|
||||
;;; a "SOCKET" package, in particular on GNU/Linux or Unix-like
|
||||
;;; systems, but also on Win32. This backend uses the portable xref
|
||||
;;; from the CMU AI repository and metering.lisp from CLOCC [1], which
|
||||
;;; are conveniently included in SLIME.
|
||||
|
||||
;;; [1] http://cvs.sourceforge.net/viewcvs.py/clocc/clocc/src/tools/metering/
|
||||
|
||||
(defpackage swank/clisp
|
||||
(:use cl swank/backend))
|
||||
|
||||
(in-package swank/clisp)
|
||||
|
||||
(eval-when (:compile-toplevel)
|
||||
(unless (string< "2.44" (lisp-implementation-version))
|
||||
(error "Need at least CLISP version 2.44")))
|
||||
|
||||
(defimplementation gray-package-name ()
|
||||
"GRAY")
|
||||
|
||||
;;;; if this lisp has the complete CLOS then we use it, otherwise we
|
||||
;;;; build up a "fake" swank-mop and then override the methods in the
|
||||
;;;; inspector.
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(defvar *have-mop*
|
||||
(and (find-package :clos)
|
||||
(eql :external
|
||||
(nth-value 1 (find-symbol (string ':standard-slot-definition)
|
||||
:clos))))
|
||||
"True in those CLISP images which have a complete MOP implementation."))
|
||||
|
||||
#+#.(cl:if swank/clisp::*have-mop* '(cl:and) '(cl:or))
|
||||
(progn
|
||||
(import-swank-mop-symbols :clos '(:slot-definition-documentation))
|
||||
|
||||
(defun swank-mop:slot-definition-documentation (slot)
|
||||
(clos::slot-definition-documentation slot)))
|
||||
|
||||
#-#.(cl:if swank/clisp::*have-mop* '(and) '(or))
|
||||
(defclass swank-mop:standard-slot-definition ()
|
||||
()
|
||||
(:documentation
|
||||
"Dummy class created so that swank.lisp will compile and load."))
|
||||
|
||||
(let ((getpid (or (find-symbol "PROCESS-ID" :system)
|
||||
;; old name prior to 2005-03-01, clisp <= 2.33.2
|
||||
(find-symbol "PROGRAM-ID" :system)
|
||||
#+win32 ; integrated into the above since 2005-02-24
|
||||
(and (find-package :win32) ; optional modules/win32
|
||||
(find-symbol "GetCurrentProcessId" :win32)))))
|
||||
(defimplementation getpid () ; a required interface
|
||||
(cond
|
||||
(getpid (funcall getpid))
|
||||
#+win32 ((ext:getenv "PID")) ; where does that come from?
|
||||
(t -1))))
|
||||
|
||||
(defimplementation call-with-user-break-handler (handler function)
|
||||
(handler-bind ((system::simple-interrupt-condition
|
||||
(lambda (c)
|
||||
(declare (ignore c))
|
||||
(funcall handler)
|
||||
(when (find-restart 'socket-status)
|
||||
(invoke-restart (find-restart 'socket-status)))
|
||||
(continue))))
|
||||
(funcall function)))
|
||||
|
||||
(defimplementation lisp-implementation-type-name ()
|
||||
"clisp")
|
||||
|
||||
(defimplementation set-default-directory (directory)
|
||||
(setf (ext:default-directory) directory)
|
||||
(namestring (setf *default-pathname-defaults* (ext:default-directory))))
|
||||
|
||||
(defimplementation filename-to-pathname (string)
|
||||
(cond ((member :cygwin *features*)
|
||||
(parse-cygwin-filename string))
|
||||
(t (parse-namestring string))))
|
||||
|
||||
(defun parse-cygwin-filename (string)
|
||||
(multiple-value-bind (match _ drive absolute)
|
||||
(regexp:match "^(([a-zA-Z\\]+):)?([\\/])?" string :extended t)
|
||||
(declare (ignore _))
|
||||
(assert (and match (if drive absolute t)) ()
|
||||
"Invalid filename syntax: ~a" string)
|
||||
(let* ((sans-prefix (subseq string (regexp:match-end match)))
|
||||
(path (remove "" (regexp:regexp-split "[\\/]" sans-prefix)))
|
||||
(path (loop for name in path collect
|
||||
(cond ((equal name "..") ':back)
|
||||
(t name))))
|
||||
(directoryp (or (equal string "")
|
||||
(find (aref string (1- (length string))) "\\/"))))
|
||||
(multiple-value-bind (file type)
|
||||
(cond ((and (not directoryp) (last path))
|
||||
(let* ((file (car (last path)))
|
||||
(pos (position #\. file :from-end t)))
|
||||
(cond ((and pos (> pos 0))
|
||||
(values (subseq file 0 pos)
|
||||
(subseq file (1+ pos))))
|
||||
(t file)))))
|
||||
(make-pathname :host nil
|
||||
:device nil
|
||||
:directory (cons
|
||||
(if absolute :absolute :relative)
|
||||
(let ((path (if directoryp
|
||||
path
|
||||
(butlast path))))
|
||||
(if drive
|
||||
(cons
|
||||
(regexp:match-string string drive)
|
||||
path)
|
||||
path)))
|
||||
:name file
|
||||
:type type)))))
|
||||
|
||||
;;;; UTF
|
||||
|
||||
(defimplementation string-to-utf8 (string)
|
||||
(let ((enc (load-time-value
|
||||
(ext:make-encoding :charset "utf-8" :line-terminator :unix)
|
||||
t)))
|
||||
(ext:convert-string-to-bytes string enc)))
|
||||
|
||||
(defimplementation utf8-to-string (octets)
|
||||
(let ((enc (load-time-value
|
||||
(ext:make-encoding :charset "utf-8" :line-terminator :unix)
|
||||
t)))
|
||||
(ext:convert-string-from-bytes octets enc)))
|
||||
|
||||
;;;; TCP Server
|
||||
|
||||
(defimplementation create-socket (host port &key backlog)
|
||||
(socket:socket-server port :interface host :backlog (or backlog 5)))
|
||||
|
||||
(defimplementation local-port (socket)
|
||||
(socket:socket-server-port socket))
|
||||
|
||||
(defimplementation close-socket (socket)
|
||||
(socket:socket-server-close socket))
|
||||
|
||||
(defimplementation accept-connection (socket
|
||||
&key external-format buffering timeout)
|
||||
(declare (ignore buffering timeout))
|
||||
(socket:socket-accept socket
|
||||
:buffered buffering ;; XXX may not work if t
|
||||
:element-type (if external-format
|
||||
'character
|
||||
'(unsigned-byte 8))
|
||||
:external-format (or external-format :default)))
|
||||
|
||||
#-win32
|
||||
(defimplementation wait-for-input (streams &optional timeout)
|
||||
(assert (member timeout '(nil t)))
|
||||
(let ((streams (mapcar (lambda (s) (list* s :input nil)) streams)))
|
||||
(loop
|
||||
(cond ((check-slime-interrupts) (return :interrupt))
|
||||
(timeout
|
||||
(socket:socket-status streams 0 0)
|
||||
(return (loop for (s nil . x) in streams
|
||||
if x collect s)))
|
||||
(t
|
||||
(with-simple-restart (socket-status "Return from socket-status.")
|
||||
(socket:socket-status streams 0 500000))
|
||||
(let ((ready (loop for (s nil . x) in streams
|
||||
if x collect s)))
|
||||
(when ready (return ready))))))))
|
||||
|
||||
#+win32
|
||||
(defimplementation wait-for-input (streams &optional timeout)
|
||||
(assert (member timeout '(nil t)))
|
||||
(loop
|
||||
(cond ((check-slime-interrupts) (return :interrupt))
|
||||
(t
|
||||
(let ((ready (remove-if-not #'input-available-p streams)))
|
||||
(when ready (return ready)))
|
||||
(when timeout (return nil))
|
||||
(sleep 0.1)))))
|
||||
|
||||
#+win32
|
||||
;; Some facts to remember (for the next time we need to debug this):
|
||||
;; - interactive-sream-p returns t for socket-streams
|
||||
;; - listen returns nil for socket-streams
|
||||
;; - (type-of <socket-stream>) is 'stream
|
||||
;; - (type-of *terminal-io*) is 'two-way-stream
|
||||
;; - stream-element-type on our sockets is usually (UNSIGNED-BYTE 8)
|
||||
;; - calling socket:socket-status on non sockets signals an error,
|
||||
;; but seems to mess up something internally.
|
||||
;; - calling read-char-no-hang on sockets does not signal an error,
|
||||
;; but seems to mess up something internally.
|
||||
(defun input-available-p (stream)
|
||||
(case (stream-element-type stream)
|
||||
(character
|
||||
(let ((c (read-char-no-hang stream nil nil)))
|
||||
(cond ((not c)
|
||||
nil)
|
||||
(t
|
||||
(unread-char c stream)
|
||||
t))))
|
||||
(t
|
||||
(eq (socket:socket-status (cons stream :input) 0 0)
|
||||
:input))))
|
||||
|
||||
;;;; Coding systems
|
||||
|
||||
(defvar *external-format-to-coding-system*
|
||||
'(((:charset "iso-8859-1" :line-terminator :unix)
|
||||
"latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix")
|
||||
((:charset "iso-8859-1")
|
||||
"latin-1" "iso-latin-1" "iso-8859-1")
|
||||
((:charset "utf-8") "utf-8")
|
||||
((:charset "utf-8" :line-terminator :unix) "utf-8-unix")
|
||||
((:charset "euc-jp") "euc-jp")
|
||||
((:charset "euc-jp" :line-terminator :unix) "euc-jp-unix")
|
||||
((:charset "us-ascii") "us-ascii")
|
||||
((:charset "us-ascii" :line-terminator :unix) "us-ascii-unix")))
|
||||
|
||||
(defimplementation find-external-format (coding-system)
|
||||
(let ((args (car (rassoc-if (lambda (x)
|
||||
(member coding-system x :test #'equal))
|
||||
*external-format-to-coding-system*))))
|
||||
(and args (apply #'ext:make-encoding args))))
|
||||
|
||||
|
||||
;;;; Swank functions
|
||||
|
||||
(defimplementation arglist (fname)
|
||||
(block nil
|
||||
(or (ignore-errors
|
||||
(let ((exp (function-lambda-expression fname)))
|
||||
(and exp (return (second exp)))))
|
||||
(ignore-errors
|
||||
(return (ext:arglist fname)))
|
||||
:not-available)))
|
||||
|
||||
(defimplementation macroexpand-all (form &optional env)
|
||||
(declare (ignore env))
|
||||
(ext:expand-form form))
|
||||
|
||||
(defimplementation collect-macro-forms (form &optional env)
|
||||
;; Currently detects only normal macros, not compiler macros.
|
||||
(declare (ignore env))
|
||||
(with-collected-macro-forms (macro-forms)
|
||||
(handler-bind ((warning #'muffle-warning))
|
||||
(ignore-errors
|
||||
(compile nil `(lambda () ,form))))
|
||||
(values macro-forms nil)))
|
||||
|
||||
(defimplementation describe-symbol-for-emacs (symbol)
|
||||
"Return a plist describing SYMBOL.
|
||||
Return NIL if the symbol is unbound."
|
||||
(let ((result ()))
|
||||
(flet ((doc (kind)
|
||||
(or (documentation symbol kind) :not-documented))
|
||||
(maybe-push (property value)
|
||||
(when value
|
||||
(setf result (list* property value result)))))
|
||||
(maybe-push :variable (when (boundp symbol) (doc 'variable)))
|
||||
(when (fboundp symbol)
|
||||
(maybe-push
|
||||
;; Report WHEN etc. as macros, even though they may be
|
||||
;; implemented as special operators.
|
||||
(if (macro-function symbol) :macro
|
||||
(typecase (fdefinition symbol)
|
||||
(generic-function :generic-function)
|
||||
(function :function)
|
||||
;; (type-of 'progn) -> ext:special-operator
|
||||
(t :special-operator)))
|
||||
(doc 'function)))
|
||||
(when (or (get symbol 'system::setf-function) ; e.g. #'(setf elt)
|
||||
(get symbol 'system::setf-expander)); defsetf
|
||||
(maybe-push :setf (doc 'setf)))
|
||||
(when (or (get symbol 'system::type-symbol); cf. clisp/src/describe.lisp
|
||||
(get symbol 'system::defstruct-description)
|
||||
(get symbol 'system::deftype-expander))
|
||||
(maybe-push :type (doc 'type))) ; even for 'structure
|
||||
(when (find-class symbol nil)
|
||||
(maybe-push :class (doc 'type)))
|
||||
;; Let this code work compiled in images without FFI
|
||||
(let ((types (load-time-value
|
||||
(and (find-package "FFI")
|
||||
(symbol-value
|
||||
(find-symbol "*C-TYPE-TABLE*" "FFI"))))))
|
||||
;; Use ffi::*c-type-table* so as not to suffer the overhead of
|
||||
;; (ignore-errors (ffi:parse-c-type symbol)) for 99.9% of symbols
|
||||
;; which are not FFI type names.
|
||||
(when (and types (nth-value 1 (gethash symbol types)))
|
||||
;; Maybe use (case (head (ffi:deparse-c-type)))
|
||||
;; to distinguish struct and union types?
|
||||
(maybe-push :alien-type :not-documented)))
|
||||
result)))
|
||||
|
||||
(defimplementation describe-definition (symbol namespace)
|
||||
(ecase namespace
|
||||
(:variable (describe symbol))
|
||||
(:macro (describe (macro-function symbol)))
|
||||
(:function (describe (symbol-function symbol)))
|
||||
(:class (describe (find-class symbol)))))
|
||||
|
||||
(defimplementation type-specifier-p (symbol)
|
||||
(or (ignore-errors
|
||||
(subtypep nil symbol))
|
||||
(not (eq (type-specifier-arglist symbol) :not-available))))
|
||||
|
||||
(defun fspec-pathname (spec)
|
||||
(let ((path spec)
|
||||
type
|
||||
lines)
|
||||
(when (consp path)
|
||||
(psetq type (car path)
|
||||
path (cadr path)
|
||||
lines (cddr path)))
|
||||
(when (and path
|
||||
(member (pathname-type path)
|
||||
custom:*compiled-file-types* :test #'equal))
|
||||
(setq path
|
||||
(loop for suffix in custom:*source-file-types*
|
||||
thereis (probe-file (make-pathname :defaults path
|
||||
:type suffix)))))
|
||||
(values path type lines)))
|
||||
|
||||
(defun fspec-location (name fspec)
|
||||
(multiple-value-bind (file type lines)
|
||||
(fspec-pathname fspec)
|
||||
(list (if type (list name type) name)
|
||||
(cond (file
|
||||
(multiple-value-bind (truename c)
|
||||
(ignore-errors (truename file))
|
||||
(cond (truename
|
||||
(make-location
|
||||
(list :file (namestring truename))
|
||||
(if (consp lines)
|
||||
(list* :line lines)
|
||||
(list :function-name (string name)))
|
||||
(when (consp type)
|
||||
(list :snippet (format nil "~A" type)))))
|
||||
(t (list :error (princ-to-string c))))))
|
||||
(t (list :error
|
||||
(format nil "No source information available for: ~S"
|
||||
fspec)))))))
|
||||
|
||||
(defimplementation find-definitions (name)
|
||||
(mapcar #'(lambda (e) (fspec-location name e))
|
||||
(documentation name 'sys::file)))
|
||||
|
||||
(defun trim-whitespace (string)
|
||||
(string-trim #(#\newline #\space #\tab) string))
|
||||
|
||||
(defvar *sldb-backtrace*)
|
||||
|
||||
(defun sldb-backtrace ()
|
||||
"Return a list ((ADDRESS . DESCRIPTION) ...) of frames."
|
||||
(let* ((modes '((:all-stack-elements 1)
|
||||
(:all-frames 2)
|
||||
(:only-lexical-frames 3)
|
||||
(:only-eval-and-apply-frames 4)
|
||||
(:only-apply-frames 5)))
|
||||
(mode (cadr (assoc :all-stack-elements modes))))
|
||||
(do ((frames '())
|
||||
(last nil frame)
|
||||
(frame (sys::the-frame)
|
||||
(sys::frame-up 1 frame mode)))
|
||||
((eq frame last) (nreverse frames))
|
||||
(unless (boring-frame-p frame)
|
||||
(push frame frames)))))
|
||||
|
||||
(defimplementation call-with-debugging-environment (debugger-loop-fn)
|
||||
(let* (;;(sys::*break-count* (1+ sys::*break-count*))
|
||||
;;(sys::*driver* debugger-loop-fn)
|
||||
;;(sys::*fasoutput-stream* nil)
|
||||
(*sldb-backtrace*
|
||||
(let* ((f (sys::the-frame))
|
||||
(bt (sldb-backtrace))
|
||||
(rest (member f bt)))
|
||||
(if rest (nthcdr 8 rest) bt))))
|
||||
(funcall debugger-loop-fn)))
|
||||
|
||||
(defun nth-frame (index)
|
||||
(nth index *sldb-backtrace*))
|
||||
|
||||
(defun boring-frame-p (frame)
|
||||
(member (frame-type frame) '(stack-value bind-var bind-env
|
||||
compiled-tagbody compiled-block)))
|
||||
|
||||
(defun frame-to-string (frame)
|
||||
(with-output-to-string (s)
|
||||
(sys::describe-frame s frame)))
|
||||
|
||||
(defun frame-type (frame)
|
||||
;; FIXME: should bind *print-length* etc. to small values.
|
||||
(frame-string-type (frame-to-string frame)))
|
||||
|
||||
;; FIXME: they changed the layout in 2.44 and not all patterns have
|
||||
;; been updated.
|
||||
(defvar *frame-prefixes*
|
||||
'(("\\[[0-9]\\+\\] frame binding variables" bind-var)
|
||||
("<1> #<compiled-function" compiled-fun)
|
||||
("<1> #<system-function" sys-fun)
|
||||
("<1> #<special-operator" special-op)
|
||||
("EVAL frame" eval)
|
||||
("APPLY frame" apply)
|
||||
("\\[[0-9]\\+\\] compiled tagbody frame" compiled-tagbody)
|
||||
("\\[[0-9]\\+\\] compiled block frame" compiled-block)
|
||||
("block frame" block)
|
||||
("nested block frame" block)
|
||||
("tagbody frame" tagbody)
|
||||
("nested tagbody frame" tagbody)
|
||||
("catch frame" catch)
|
||||
("handler frame" handler)
|
||||
("unwind-protect frame" unwind-protect)
|
||||
("driver frame" driver)
|
||||
("\\[[0-9]\\+\\] frame binding environments" bind-env)
|
||||
("CALLBACK frame" callback)
|
||||
("- " stack-value)
|
||||
("<1> " fun)
|
||||
("<2> " 2nd-frame)
|
||||
))
|
||||
|
||||
(defun frame-string-type (string)
|
||||
(cadr (assoc-if (lambda (pattern) (is-prefix-p pattern string))
|
||||
*frame-prefixes*)))
|
||||
|
||||
(defimplementation compute-backtrace (start end)
|
||||
(let* ((bt *sldb-backtrace*)
|
||||
(len (length bt)))
|
||||
(loop for f in (subseq bt start (min (or end len) len))
|
||||
collect f)))
|
||||
|
||||
(defimplementation print-frame (frame stream)
|
||||
(let* ((str (frame-to-string frame)))
|
||||
(write-string (extract-frame-line str)
|
||||
stream)))
|
||||
|
||||
(defun extract-frame-line (frame-string)
|
||||
(let ((s frame-string))
|
||||
(trim-whitespace
|
||||
(case (frame-string-type s)
|
||||
((eval special-op)
|
||||
(string-match "EVAL frame .*for form \\(.*\\)" s 1))
|
||||
(apply
|
||||
(string-match "APPLY frame for call \\(.*\\)" s 1))
|
||||
((compiled-fun sys-fun fun)
|
||||
(extract-function-name s))
|
||||
(t s)))))
|
||||
|
||||
(defun extract-function-name (string)
|
||||
(let ((1st (car (split-frame-string string))))
|
||||
(or (string-match (format nil "^<1>[ ~%]*#<[-A-Za-z]* \\(.*\\)>")
|
||||
1st
|
||||
1)
|
||||
(string-match (format nil "^<1>[ ~%]*\\(.*\\)") 1st 1)
|
||||
1st)))
|
||||
|
||||
(defun split-frame-string (string)
|
||||
(let ((rx (format nil "~%\\(~{~A~^\\|~}\\)"
|
||||
(mapcar #'car *frame-prefixes*))))
|
||||
(loop for pos = 0 then (1+ (regexp:match-start match))
|
||||
for match = (regexp:match rx string :start pos)
|
||||
if match collect (subseq string pos (regexp:match-start match))
|
||||
else collect (subseq string pos)
|
||||
while match)))
|
||||
|
||||
(defun string-match (pattern string n)
|
||||
(let* ((match (nth-value n (regexp:match pattern string))))
|
||||
(if match (regexp:match-string string match))))
|
||||
|
||||
(defimplementation eval-in-frame (form frame-number)
|
||||
(sys::eval-at (nth-frame frame-number) form))
|
||||
|
||||
(defimplementation frame-locals (frame-number)
|
||||
(let ((frame (nth-frame frame-number)))
|
||||
(loop for i below (%frame-count-vars frame)
|
||||
collect (list :name (%frame-var-name frame i)
|
||||
:value (%frame-var-value frame i)
|
||||
:id 0))))
|
||||
|
||||
(defimplementation frame-var-value (frame var)
|
||||
(%frame-var-value (nth-frame frame) var))
|
||||
|
||||
;;; Interpreter-Variablen-Environment has the shape
|
||||
;;; NIL or #(v1 val1 ... vn valn NEXT-ENV).
|
||||
|
||||
(defun %frame-count-vars (frame)
|
||||
(cond ((sys::eval-frame-p frame)
|
||||
(do ((venv (frame-venv frame) (next-venv venv))
|
||||
(count 0 (+ count (/ (1- (length venv)) 2))))
|
||||
((not venv) count)))
|
||||
((member (frame-type frame) '(compiled-fun sys-fun fun special-op))
|
||||
(length (%parse-stack-values frame)))
|
||||
(t 0)))
|
||||
|
||||
(defun %frame-var-name (frame i)
|
||||
(cond ((sys::eval-frame-p frame)
|
||||
(nth-value 0 (venv-ref (frame-venv frame) i)))
|
||||
(t (format nil "~D" i))))
|
||||
|
||||
(defun %frame-var-value (frame i)
|
||||
(cond ((sys::eval-frame-p frame)
|
||||
(let ((name (venv-ref (frame-venv frame) i)))
|
||||
(multiple-value-bind (v c) (ignore-errors (sys::eval-at frame name))
|
||||
(if c
|
||||
(format-sldb-condition c)
|
||||
v))))
|
||||
((member (frame-type frame) '(compiled-fun sys-fun fun special-op))
|
||||
(let ((str (nth i (%parse-stack-values frame))))
|
||||
(trim-whitespace (subseq str 2))))
|
||||
(t (break "Not implemented"))))
|
||||
|
||||
(defun frame-venv (frame)
|
||||
(let ((env (sys::eval-at frame '(sys::the-environment))))
|
||||
(svref env 0)))
|
||||
|
||||
(defun next-venv (venv) (svref venv (1- (length venv))))
|
||||
|
||||
(defun venv-ref (env i)
|
||||
"Reference the Ith binding in ENV.
|
||||
Return two values: NAME and VALUE"
|
||||
(let ((idx (* i 2)))
|
||||
(if (< idx (1- (length env)))
|
||||
(values (svref env idx) (svref env (1+ idx)))
|
||||
(venv-ref (next-venv env) (- i (/ (1- (length env)) 2))))))
|
||||
|
||||
(defun %parse-stack-values (frame)
|
||||
(labels ((next (fp) (sys::frame-down 1 fp 1))
|
||||
(parse (fp accu)
|
||||
(let ((str (frame-to-string fp)))
|
||||
(cond ((is-prefix-p "- " str)
|
||||
(parse (next fp) (cons str accu)))
|
||||
((is-prefix-p "<1> " str)
|
||||
;;(when (eq (frame-type frame) 'compiled-fun)
|
||||
;; (pop accu))
|
||||
(dolist (str (cdr (split-frame-string str)))
|
||||
(when (is-prefix-p "- " str)
|
||||
(push str accu)))
|
||||
(nreverse accu))
|
||||
(t (parse (next fp) accu))))))
|
||||
(parse (next frame) '())))
|
||||
|
||||
(defun is-prefix-p (regexp string)
|
||||
(if (regexp:match (concatenate 'string "^" regexp) string) t))
|
||||
|
||||
(defimplementation return-from-frame (index form)
|
||||
(sys::return-from-eval-frame (nth-frame index) form))
|
||||
|
||||
(defimplementation restart-frame (index)
|
||||
(sys::redo-eval-frame (nth-frame index)))
|
||||
|
||||
(defimplementation frame-source-location (index)
|
||||
`(:error
|
||||
,(format nil "frame-source-location not implemented. (frame: ~A)"
|
||||
(nth-frame index))))
|
||||
|
||||
;;;; Profiling
|
||||
|
||||
(defimplementation profile (fname)
|
||||
(eval `(swank-monitor:monitor ,fname))) ;monitor is a macro
|
||||
|
||||
(defimplementation profiled-functions ()
|
||||
swank-monitor:*monitored-functions*)
|
||||
|
||||
(defimplementation unprofile (fname)
|
||||
(eval `(swank-monitor:unmonitor ,fname))) ;unmonitor is a macro
|
||||
|
||||
(defimplementation unprofile-all ()
|
||||
(swank-monitor:unmonitor))
|
||||
|
||||
(defimplementation profile-report ()
|
||||
(swank-monitor:report-monitoring))
|
||||
|
||||
(defimplementation profile-reset ()
|
||||
(swank-monitor:reset-all-monitoring))
|
||||
|
||||
(defimplementation profile-package (package callers-p methods)
|
||||
(declare (ignore callers-p methods))
|
||||
(swank-monitor:monitor-all package))
|
||||
|
||||
;;;; Handle compiler conditions (find out location of error etc.)
|
||||
|
||||
(defmacro compile-file-frobbing-notes ((&rest args) &body body)
|
||||
"Pass ARGS to COMPILE-FILE, send the compiler notes to
|
||||
*STANDARD-INPUT* and frob them in BODY."
|
||||
`(let ((*error-output* (make-string-output-stream))
|
||||
(*compile-verbose* t))
|
||||
(multiple-value-prog1
|
||||
(compile-file ,@args)
|
||||
(handler-case
|
||||
(with-input-from-string
|
||||
(*standard-input* (get-output-stream-string *error-output*))
|
||||
,@body)
|
||||
(sys::simple-end-of-file () nil)))))
|
||||
|
||||
(defvar *orig-c-warn* (symbol-function 'system::c-warn))
|
||||
(defvar *orig-c-style-warn* (symbol-function 'system::c-style-warn))
|
||||
(defvar *orig-c-error* (symbol-function 'system::c-error))
|
||||
(defvar *orig-c-report-problems* (symbol-function 'system::c-report-problems))
|
||||
|
||||
(defmacro dynamic-flet (names-functions &body body)
|
||||
"(dynamic-flet ((NAME FUNCTION) ...) BODY ...)
|
||||
Execute BODY with NAME's function slot set to FUNCTION."
|
||||
`(ext:letf* ,(loop for (name function) in names-functions
|
||||
collect `((symbol-function ',name) ,function))
|
||||
,@body))
|
||||
|
||||
(defvar *buffer-name* nil)
|
||||
(defvar *buffer-offset*)
|
||||
|
||||
(defun compiler-note-location ()
|
||||
"Return the current compiler location."
|
||||
(let ((lineno1 sys::*compile-file-lineno1*)
|
||||
(lineno2 sys::*compile-file-lineno2*)
|
||||
(file sys::*compile-file-truename*))
|
||||
(cond ((and file lineno1 lineno2)
|
||||
(make-location (list ':file (namestring file))
|
||||
(list ':line lineno1)))
|
||||
(*buffer-name*
|
||||
(make-location (list ':buffer *buffer-name*)
|
||||
(list ':offset *buffer-offset* 0)))
|
||||
(t
|
||||
(list :error "No error location available")))))
|
||||
|
||||
(defun signal-compiler-warning (cstring args severity orig-fn)
|
||||
(signal 'compiler-condition
|
||||
:severity severity
|
||||
:message (apply #'format nil cstring args)
|
||||
:location (compiler-note-location))
|
||||
(apply orig-fn cstring args))
|
||||
|
||||
(defun c-warn (cstring &rest args)
|
||||
(signal-compiler-warning cstring args :warning *orig-c-warn*))
|
||||
|
||||
(defun c-style-warn (cstring &rest args)
|
||||
(dynamic-flet ((sys::c-warn *orig-c-warn*))
|
||||
(signal-compiler-warning cstring args :style-warning *orig-c-style-warn*)))
|
||||
|
||||
(defun c-error (&rest args)
|
||||
(signal 'compiler-condition
|
||||
:severity :error
|
||||
:message (apply #'format nil
|
||||
(if (= (length args) 3)
|
||||
(cdr args)
|
||||
args))
|
||||
:location (compiler-note-location))
|
||||
(apply *orig-c-error* args))
|
||||
|
||||
(defimplementation call-with-compilation-hooks (function)
|
||||
(handler-bind ((warning #'handle-notification-condition))
|
||||
(dynamic-flet ((system::c-warn #'c-warn)
|
||||
(system::c-style-warn #'c-style-warn)
|
||||
(system::c-error #'c-error))
|
||||
(funcall function))))
|
||||
|
||||
(defun handle-notification-condition (condition)
|
||||
"Handle a condition caused by a compiler warning."
|
||||
(signal 'compiler-condition
|
||||
:original-condition condition
|
||||
:severity :warning
|
||||
:message (princ-to-string condition)
|
||||
:location (compiler-note-location)))
|
||||
|
||||
(defimplementation swank-compile-file (input-file output-file
|
||||
load-p external-format
|
||||
&key policy)
|
||||
(declare (ignore policy))
|
||||
(with-compilation-hooks ()
|
||||
(with-compilation-unit ()
|
||||
(multiple-value-bind (fasl-file warningsp failurep)
|
||||
(compile-file input-file
|
||||
:output-file output-file
|
||||
:external-format external-format)
|
||||
(values fasl-file warningsp
|
||||
(or failurep
|
||||
(and load-p
|
||||
(not (load fasl-file)))))))))
|
||||
|
||||
(defimplementation swank-compile-string (string &key buffer position filename
|
||||
line column policy)
|
||||
(declare (ignore filename line column policy))
|
||||
(with-compilation-hooks ()
|
||||
(let ((*buffer-name* buffer)
|
||||
(*buffer-offset* position))
|
||||
(funcall (compile nil (read-from-string
|
||||
(format nil "(~S () ~A)" 'lambda string))))
|
||||
t)))
|
||||
|
||||
;;;; Portable XREF from the CMU AI repository.
|
||||
|
||||
(setq pxref::*handle-package-forms* '(cl:in-package))
|
||||
|
||||
(defmacro defxref (name function)
|
||||
`(defimplementation ,name (name)
|
||||
(xref-results (,function name))))
|
||||
|
||||
(defxref who-calls pxref:list-callers)
|
||||
(defxref who-references pxref:list-readers)
|
||||
(defxref who-binds pxref:list-setters)
|
||||
(defxref who-sets pxref:list-setters)
|
||||
(defxref list-callers pxref:list-callers)
|
||||
(defxref list-callees pxref:list-callees)
|
||||
|
||||
(defun xref-results (symbols)
|
||||
(let ((xrefs '()))
|
||||
(dolist (symbol symbols)
|
||||
(push (fspec-location symbol symbol) xrefs))
|
||||
xrefs))
|
||||
|
||||
(when (find-package :swank-loader)
|
||||
(setf (symbol-function (intern "USER-INIT-FILE" :swank-loader))
|
||||
(lambda ()
|
||||
(let ((home (user-homedir-pathname)))
|
||||
(and (ext:probe-directory home)
|
||||
(probe-file (format nil "~A/.swank.lisp"
|
||||
(namestring (truename home)))))))))
|
||||
|
||||
;;; Don't set *debugger-hook* to nil on break.
|
||||
(ext:without-package-lock ()
|
||||
(defun break (&optional (format-string "Break") &rest args)
|
||||
(if (not sys::*use-clcs*)
|
||||
(progn
|
||||
(terpri *error-output*)
|
||||
(apply #'format *error-output*
|
||||
(concatenate 'string "*** - " format-string)
|
||||
args)
|
||||
(funcall ext:*break-driver* t))
|
||||
(let ((condition
|
||||
(make-condition 'simple-condition
|
||||
:format-control format-string
|
||||
:format-arguments args))
|
||||
;;(*debugger-hook* nil)
|
||||
;; Issue 91
|
||||
)
|
||||
(ext:with-restarts
|
||||
((continue
|
||||
:report (lambda (stream)
|
||||
(format stream (sys::text "Return from ~S loop")
|
||||
'break))
|
||||
()))
|
||||
(with-condition-restarts condition (list (find-restart 'continue))
|
||||
(invoke-debugger condition)))))
|
||||
nil))
|
||||
|
||||
;;;; Inspecting
|
||||
|
||||
(defmethod emacs-inspect ((o t))
|
||||
(let* ((*print-array* nil) (*print-pretty* t)
|
||||
(*print-circle* t) (*print-escape* t)
|
||||
(*print-lines* custom:*inspect-print-lines*)
|
||||
(*print-level* custom:*inspect-print-level*)
|
||||
(*print-length* custom:*inspect-print-length*)
|
||||
(sys::*inspect-all* (make-array 10 :fill-pointer 0 :adjustable t))
|
||||
(tmp-pack (make-package (gensym "INSPECT-TMP-PACKAGE-")))
|
||||
(*package* tmp-pack)
|
||||
(sys::*inspect-unbound-value* (intern "#<unbound>" tmp-pack)))
|
||||
(let ((inspection (sys::inspect-backend o)))
|
||||
(append (list
|
||||
(format nil "~S~% ~A~{~%~A~}~%" o
|
||||
(sys::insp-title inspection)
|
||||
(sys::insp-blurb inspection)))
|
||||
(loop with count = (sys::insp-num-slots inspection)
|
||||
for i below count
|
||||
append (multiple-value-bind (value name)
|
||||
(funcall (sys::insp-nth-slot inspection)
|
||||
i)
|
||||
`((:value ,name) " = " (:value ,value)
|
||||
(:newline))))))))
|
||||
|
||||
(defimplementation quit-lisp ()
|
||||
#+lisp=cl (ext:quit)
|
||||
#-lisp=cl (lisp:quit))
|
||||
|
||||
|
||||
(defimplementation preferred-communication-style ()
|
||||
nil)
|
||||
|
||||
;;; FIXME
|
||||
;;;
|
||||
;;; Clisp 2.48 added experimental support for threads. Basically, you
|
||||
;;; can use :SPAWN now, BUT:
|
||||
;;;
|
||||
;;; - there are problems with GC, and threads stuffed into weak
|
||||
;;; hash-tables as is the case for *THREAD-PLIST-TABLE*.
|
||||
;;;
|
||||
;;; See test case at
|
||||
;;; http://thread.gmane.org/gmane.lisp.clisp.devel/20429
|
||||
;;;
|
||||
;;; Even though said to be fixed, it's not:
|
||||
;;;
|
||||
;;; http://thread.gmane.org/gmane.lisp.clisp.devel/20429/focus=20443
|
||||
;;;
|
||||
;;; - The DYNAMIC-FLET above is an implementation technique that's
|
||||
;;; probably not sustainable in light of threads. This got to be
|
||||
;;; rewritten.
|
||||
;;;
|
||||
;;; TCR (2009-07-30)
|
||||
|
||||
#+#.(cl:if (cl:find-package "MP") '(:and) '(:or))
|
||||
(progn
|
||||
(defimplementation spawn (fn &key name)
|
||||
(mp:make-thread fn :name name))
|
||||
|
||||
(defvar *thread-plist-table-lock*
|
||||
(mp:make-mutex :name "THREAD-PLIST-TABLE-LOCK"))
|
||||
|
||||
(defvar *thread-plist-table* (make-hash-table :weak :key)
|
||||
"A hashtable mapping threads to a plist.")
|
||||
|
||||
(defvar *thread-id-counter* 0)
|
||||
|
||||
(defimplementation thread-id (thread)
|
||||
(mp:with-mutex-lock (*thread-plist-table-lock*)
|
||||
(or (getf (gethash thread *thread-plist-table*) 'thread-id)
|
||||
(setf (getf (gethash thread *thread-plist-table*) 'thread-id)
|
||||
(incf *thread-id-counter*)))))
|
||||
|
||||
(defimplementation find-thread (id)
|
||||
(find id (all-threads)
|
||||
:key (lambda (thread)
|
||||
(getf (gethash thread *thread-plist-table*) 'thread-id))))
|
||||
|
||||
(defimplementation thread-name (thread)
|
||||
;; To guard against returning #<UNBOUND>.
|
||||
(princ-to-string (mp:thread-name thread)))
|
||||
|
||||
(defimplementation thread-status (thread)
|
||||
(if (thread-alive-p thread)
|
||||
"RUNNING"
|
||||
"STOPPED"))
|
||||
|
||||
(defimplementation make-lock (&key name)
|
||||
(mp:make-mutex :name name :recursive-p t))
|
||||
|
||||
(defimplementation call-with-lock-held (lock function)
|
||||
(mp:with-mutex-lock (lock)
|
||||
(funcall function)))
|
||||
|
||||
(defimplementation current-thread ()
|
||||
(mp:current-thread))
|
||||
|
||||
(defimplementation all-threads ()
|
||||
(mp:list-threads))
|
||||
|
||||
(defimplementation interrupt-thread (thread fn)
|
||||
(mp:thread-interrupt thread :function fn))
|
||||
|
||||
(defimplementation kill-thread (thread)
|
||||
(mp:thread-interrupt thread :function t))
|
||||
|
||||
(defimplementation thread-alive-p (thread)
|
||||
(mp:thread-active-p thread))
|
||||
|
||||
(defvar *mailboxes-lock* (make-lock :name "MAILBOXES-LOCK"))
|
||||
(defvar *mailboxes* (list))
|
||||
|
||||
(defstruct (mailbox (:conc-name mailbox.))
|
||||
thread
|
||||
(lock (make-lock :name "MAILBOX.LOCK"))
|
||||
(waitqueue (mp:make-exemption :name "MAILBOX.WAITQUEUE"))
|
||||
(queue '() :type list))
|
||||
|
||||
(defun mailbox (thread)
|
||||
"Return THREAD's mailbox."
|
||||
(mp:with-mutex-lock (*mailboxes-lock*)
|
||||
(or (find thread *mailboxes* :key #'mailbox.thread)
|
||||
(let ((mb (make-mailbox :thread thread)))
|
||||
(push mb *mailboxes*)
|
||||
mb))))
|
||||
|
||||
(defimplementation send (thread message)
|
||||
(let* ((mbox (mailbox thread))
|
||||
(lock (mailbox.lock mbox)))
|
||||
(mp:with-mutex-lock (lock)
|
||||
(setf (mailbox.queue mbox)
|
||||
(nconc (mailbox.queue mbox) (list message)))
|
||||
(mp:exemption-broadcast (mailbox.waitqueue mbox)))))
|
||||
|
||||
(defimplementation receive-if (test &optional timeout)
|
||||
(let* ((mbox (mailbox (current-thread)))
|
||||
(lock (mailbox.lock mbox)))
|
||||
(assert (or (not timeout) (eq timeout t)))
|
||||
(loop
|
||||
(check-slime-interrupts)
|
||||
(mp:with-mutex-lock (lock)
|
||||
(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:exemption-wait (mailbox.waitqueue mbox) lock :timeout 0.2))))))
|
||||
|
||||
|
||||
;;;; Weak hashtables
|
||||
|
||||
(defimplementation make-weak-key-hash-table (&rest args)
|
||||
(apply #'make-hash-table :weak :key args))
|
||||
|
||||
(defimplementation make-weak-value-hash-table (&rest args)
|
||||
(apply #'make-hash-table :weak :value args))
|
||||
|
||||
(defimplementation save-image (filename &optional restart-function)
|
||||
(let ((args `(,filename
|
||||
,@(if restart-function
|
||||
`((:init-function ,restart-function))))))
|
||||
(apply #'ext:saveinitmem args)))
|
||||
2470
sources_non_forked/slimv/slime/swank/cmucl.lisp
Normal file
2470
sources_non_forked/slimv/slime/swank/cmucl.lisp
Normal file
File diff suppressed because it is too large
Load Diff
583
sources_non_forked/slimv/slime/swank/corman.lisp
Normal file
583
sources_non_forked/slimv/slime/swank/corman.lisp
Normal file
@ -0,0 +1,583 @@
|
||||
;;;
|
||||
;;; swank-corman.lisp --- Corman Lisp specific code for SLIME.
|
||||
;;;
|
||||
;;; Copyright (C) 2004, 2005 Espen Wiborg (espenhw@grumblesmurf.org)
|
||||
;;;
|
||||
;;; License
|
||||
;;; =======
|
||||
;;; This software is provided 'as-is', without any express or implied
|
||||
;;; warranty. In no event will the author be held liable for any damages
|
||||
;;; arising from the use of this software.
|
||||
;;;
|
||||
;;; Permission is granted to anyone to use this software for any purpose,
|
||||
;;; including commercial applications, and to alter it and redistribute
|
||||
;;; it freely, subject to the following restrictions:
|
||||
;;;
|
||||
;;; 1. The origin of this software must not be misrepresented; you must
|
||||
;;; not claim that you wrote the original software. If you use this
|
||||
;;; software in a product, an acknowledgment in the product documentation
|
||||
;;; would be appreciated but is not required.
|
||||
;;;
|
||||
;;; 2. Altered source versions must be plainly marked as such, and must
|
||||
;;; not be misrepresented as being the original software.
|
||||
;;;
|
||||
;;; 3. This notice may not be removed or altered from any source
|
||||
;;; distribution.
|
||||
;;;
|
||||
;;; Notes
|
||||
;;; =====
|
||||
;;; You will need CCL 2.51, and you will *definitely* need to patch
|
||||
;;; CCL with the patches at
|
||||
;;; http://www.grumblesmurf.org/lisp/corman-patches, otherwise SLIME
|
||||
;;; will blow up in your face. You should also follow the
|
||||
;;; instructions on http://www.grumblesmurf.org/lisp/corman-slime.
|
||||
;;;
|
||||
;;; The only communication style currently supported is NIL.
|
||||
;;;
|
||||
;;; Starting CCL inside emacs (with M-x slime) seems to work for me
|
||||
;;; with Corman Lisp 2.51, but I have seen random failures with 2.5
|
||||
;;; (sometimes it works, other times it hangs on start or hangs when
|
||||
;;; initializing WinSock) - starting CCL externally and using M-x
|
||||
;;; slime-connect always works fine.
|
||||
;;;
|
||||
;;; Sometimes CCL gets confused and starts giving you random memory
|
||||
;;; access violation errors on startup; if this happens, try redumping
|
||||
;;; your image.
|
||||
;;;
|
||||
;;; What works
|
||||
;;; ==========
|
||||
;;; * Basic editing and evaluation
|
||||
;;; * Arglist display
|
||||
;;; * Compilation
|
||||
;;; * Loading files
|
||||
;;; * apropos/describe
|
||||
;;; * Debugger
|
||||
;;; * Inspector
|
||||
;;;
|
||||
;;; TODO
|
||||
;;; ====
|
||||
;;; * More debugger functionality (missing bits: restart-frame,
|
||||
;;; return-from-frame, disassemble-frame, activate-stepping,
|
||||
;;; toggle-trace)
|
||||
;;; * XREF
|
||||
;;; * Profiling
|
||||
;;; * More sophisticated communication styles than NIL
|
||||
;;;
|
||||
|
||||
(in-package :swank/backend)
|
||||
|
||||
;;; Pull in various needed bits
|
||||
(require :composite-streams)
|
||||
(require :sockets)
|
||||
(require :winbase)
|
||||
(require :lp)
|
||||
|
||||
(use-package :gs)
|
||||
|
||||
;; MOP stuff
|
||||
|
||||
(defclass swank-mop:standard-slot-definition ()
|
||||
()
|
||||
(:documentation
|
||||
"Dummy class created so that swank.lisp will compile and load."))
|
||||
|
||||
(defun named-by-gensym-p (c)
|
||||
(null (symbol-package (class-name c))))
|
||||
|
||||
(deftype swank-mop:eql-specializer ()
|
||||
'(satisfies named-by-gensym-p))
|
||||
|
||||
(defun swank-mop:eql-specializer-object (specializer)
|
||||
(with-hash-table-iterator (next-entry cl::*clos-singleton-specializers*)
|
||||
(loop (multiple-value-bind (more key value)
|
||||
(next-entry)
|
||||
(unless more (return nil))
|
||||
(when (eq specializer value)
|
||||
(return key))))))
|
||||
|
||||
(defun swank-mop:class-finalized-p (class)
|
||||
(declare (ignore class))
|
||||
t)
|
||||
|
||||
(defun swank-mop:class-prototype (class)
|
||||
(make-instance class))
|
||||
|
||||
(defun swank-mop:specializer-direct-methods (obj)
|
||||
(declare (ignore obj))
|
||||
nil)
|
||||
|
||||
(defun swank-mop:generic-function-argument-precedence-order (gf)
|
||||
(generic-function-lambda-list gf))
|
||||
|
||||
(defun swank-mop:generic-function-method-combination (gf)
|
||||
(declare (ignore gf))
|
||||
:standard)
|
||||
|
||||
(defun swank-mop:generic-function-declarations (gf)
|
||||
(declare (ignore gf))
|
||||
nil)
|
||||
|
||||
(defun swank-mop:slot-definition-documentation (slot)
|
||||
(declare (ignore slot))
|
||||
(getf slot :documentation nil))
|
||||
|
||||
(defun swank-mop:slot-definition-type (slot)
|
||||
(declare (ignore slot))
|
||||
t)
|
||||
|
||||
(import-swank-mop-symbols :cl '(;; classes
|
||||
:standard-slot-definition
|
||||
:eql-specializer
|
||||
:eql-specializer-object
|
||||
;; standard class readers
|
||||
:class-default-initargs
|
||||
:class-direct-default-initargs
|
||||
:class-finalized-p
|
||||
:class-prototype
|
||||
:specializer-direct-methods
|
||||
;; gf readers
|
||||
:generic-function-argument-precedence-order
|
||||
:generic-function-declarations
|
||||
:generic-function-method-combination
|
||||
;; method readers
|
||||
;; slot readers
|
||||
:slot-definition-documentation
|
||||
:slot-definition-type))
|
||||
|
||||
;;;; swank implementations
|
||||
|
||||
;;; Debugger
|
||||
|
||||
(defvar *stack-trace* nil)
|
||||
(defvar *frame-trace* nil)
|
||||
|
||||
(defstruct frame
|
||||
name function address debug-info variables)
|
||||
|
||||
(defimplementation call-with-debugging-environment (fn)
|
||||
(let* ((real-stack-trace (cl::stack-trace))
|
||||
(*stack-trace* (cdr (member 'cl:invoke-debugger real-stack-trace
|
||||
:key #'car)))
|
||||
(*frame-trace*
|
||||
(let* ((db::*debug-level* (1+ db::*debug-level*))
|
||||
(db::*debug-frame-pointer* (db::stash-ebp
|
||||
(ct:create-foreign-ptr)))
|
||||
(db::*debug-max-level* (length real-stack-trace))
|
||||
(db::*debug-min-level* 1))
|
||||
(cdr (member #'cl:invoke-debugger
|
||||
(cons
|
||||
(make-frame :function nil)
|
||||
(loop for i from db::*debug-min-level*
|
||||
upto db::*debug-max-level*
|
||||
until (eq (db::get-frame-function i)
|
||||
cl::*top-level*)
|
||||
collect
|
||||
(make-frame
|
||||
:function (db::get-frame-function i)
|
||||
:address (db::get-frame-address i))))
|
||||
:key #'frame-function)))))
|
||||
(funcall fn)))
|
||||
|
||||
(defimplementation compute-backtrace (start end)
|
||||
(loop for f in (subseq *stack-trace* start (min end (length *stack-trace*)))
|
||||
collect f))
|
||||
|
||||
(defimplementation print-frame (frame stream)
|
||||
(format stream "~S" frame))
|
||||
|
||||
(defun get-frame-debug-info (frame)
|
||||
(or (frame-debug-info frame)
|
||||
(setf (frame-debug-info frame)
|
||||
(db::prepare-frame-debug-info (frame-function frame)
|
||||
(frame-address frame)))))
|
||||
|
||||
(defimplementation frame-locals (frame-number)
|
||||
(let* ((frame (elt *frame-trace* frame-number))
|
||||
(info (get-frame-debug-info frame)))
|
||||
(let ((var-list
|
||||
(loop for i from 4 below (length info) by 2
|
||||
collect `(list :name ',(svref info i) :id 0
|
||||
:value (db::debug-filter ,(svref info i))))))
|
||||
(let ((vars (eval-in-frame `(list ,@var-list) frame-number)))
|
||||
(setf (frame-variables frame) vars)))))
|
||||
|
||||
(defimplementation eval-in-frame (form frame-number)
|
||||
(let ((frame (elt *frame-trace* frame-number)))
|
||||
(let ((cl::*compiler-environment* (get-frame-debug-info frame)))
|
||||
(eval form))))
|
||||
|
||||
(defimplementation frame-var-value (frame-number var)
|
||||
(let ((vars (frame-variables (elt *frame-trace* frame-number))))
|
||||
(when vars
|
||||
(second (elt vars var)))))
|
||||
|
||||
(defimplementation frame-source-location (frame-number)
|
||||
(fspec-location (frame-function (elt *frame-trace* frame-number))))
|
||||
|
||||
(defun break (&optional (format-control "Break") &rest format-arguments)
|
||||
(with-simple-restart (continue "Return from BREAK.")
|
||||
(let ();(*debugger-hook* nil))
|
||||
(let ((condition
|
||||
(make-condition 'simple-condition
|
||||
:format-control format-control
|
||||
:format-arguments format-arguments)))
|
||||
;;(format *debug-io* ";;; User break: ~A~%" condition)
|
||||
(invoke-debugger condition))))
|
||||
nil)
|
||||
|
||||
;;; Socket communication
|
||||
|
||||
(defimplementation create-socket (host port &key backlog)
|
||||
(sockets:start-sockets)
|
||||
(sockets:make-server-socket :host host :port port))
|
||||
|
||||
(defimplementation local-port (socket)
|
||||
(sockets:socket-port socket))
|
||||
|
||||
(defimplementation close-socket (socket)
|
||||
(close socket))
|
||||
|
||||
(defimplementation accept-connection (socket
|
||||
&key external-format buffering timeout)
|
||||
(declare (ignore buffering timeout external-format))
|
||||
(sockets:make-socket-stream (sockets:accept-socket socket)))
|
||||
|
||||
;;; Misc
|
||||
|
||||
(defimplementation preferred-communication-style ()
|
||||
nil)
|
||||
|
||||
(defimplementation getpid ()
|
||||
ccl:*current-process-id*)
|
||||
|
||||
(defimplementation lisp-implementation-type-name ()
|
||||
"cormanlisp")
|
||||
|
||||
(defimplementation quit-lisp ()
|
||||
(sockets:stop-sockets)
|
||||
(win32:exitprocess 0))
|
||||
|
||||
(defimplementation set-default-directory (directory)
|
||||
(setf (ccl:current-directory) directory)
|
||||
(directory-namestring (setf *default-pathname-defaults*
|
||||
(truename (merge-pathnames directory)))))
|
||||
|
||||
(defimplementation default-directory ()
|
||||
(directory-namestring (ccl:current-directory)))
|
||||
|
||||
(defimplementation macroexpand-all (form &optional env)
|
||||
(declare (ignore env))
|
||||
(ccl:macroexpand-all form))
|
||||
|
||||
;;; Documentation
|
||||
|
||||
(defun fspec-location (fspec)
|
||||
(when (symbolp fspec)
|
||||
(setq fspec (symbol-function fspec)))
|
||||
(let ((file (ccl::function-source-file fspec)))
|
||||
(if file
|
||||
(handler-case
|
||||
(let ((truename (truename
|
||||
(merge-pathnames file
|
||||
ccl:*cormanlisp-directory*))))
|
||||
(make-location (list :file (namestring truename))
|
||||
(if (ccl::function-source-line fspec)
|
||||
(list :line
|
||||
(1+ (ccl::function-source-line fspec)))
|
||||
(list :function-name
|
||||
(princ-to-string
|
||||
(function-name fspec))))))
|
||||
(error (c) (list :error (princ-to-string c))))
|
||||
(list :error (format nil "No source information available for ~S"
|
||||
fspec)))))
|
||||
|
||||
(defimplementation find-definitions (name)
|
||||
(list (list name (fspec-location name))))
|
||||
|
||||
(defimplementation arglist (name)
|
||||
(handler-case
|
||||
(cond ((and (symbolp name)
|
||||
(macro-function name))
|
||||
(ccl::macro-lambda-list (symbol-function name)))
|
||||
(t
|
||||
(when (symbolp name)
|
||||
(setq name (symbol-function name)))
|
||||
(if (eq (class-of name) cl::the-class-standard-gf)
|
||||
(generic-function-lambda-list name)
|
||||
(ccl:function-lambda-list name))))
|
||||
(error () :not-available)))
|
||||
|
||||
(defimplementation function-name (fn)
|
||||
(handler-case (getf (cl::function-info-list fn) 'cl::function-name)
|
||||
(error () nil)))
|
||||
|
||||
(defimplementation describe-symbol-for-emacs (symbol)
|
||||
(let ((result '()))
|
||||
(flet ((doc (kind &optional (sym symbol))
|
||||
(or (documentation sym kind) :not-documented))
|
||||
(maybe-push (property value)
|
||||
(when value
|
||||
(setf result (list* property value result)))))
|
||||
(maybe-push
|
||||
:variable (when (boundp symbol)
|
||||
(doc 'variable)))
|
||||
(maybe-push
|
||||
:function (if (fboundp symbol)
|
||||
(doc 'function)))
|
||||
(maybe-push
|
||||
:class (if (find-class symbol nil)
|
||||
(doc 'class)))
|
||||
result)))
|
||||
|
||||
(defimplementation describe-definition (symbol namespace)
|
||||
(ecase namespace
|
||||
(:variable
|
||||
(describe symbol))
|
||||
((:function :generic-function)
|
||||
(describe (symbol-function symbol)))
|
||||
(:class
|
||||
(describe (find-class symbol)))))
|
||||
|
||||
;;; Compiler
|
||||
|
||||
(defvar *buffer-name* nil)
|
||||
(defvar *buffer-position*)
|
||||
(defvar *buffer-string*)
|
||||
(defvar *compile-filename* nil)
|
||||
|
||||
;; FIXME
|
||||
(defimplementation call-with-compilation-hooks (FN)
|
||||
(handler-bind ((error (lambda (c)
|
||||
(signal 'compiler-condition
|
||||
:original-condition c
|
||||
:severity :warning
|
||||
:message (format nil "~A" c)
|
||||
:location
|
||||
(cond (*buffer-name*
|
||||
(make-location
|
||||
(list :buffer *buffer-name*)
|
||||
(list :offset *buffer-position* 0)))
|
||||
(*compile-filename*
|
||||
(make-location
|
||||
(list :file *compile-filename*)
|
||||
(list :position 1)))
|
||||
(t
|
||||
(list :error "No location")))))))
|
||||
(funcall fn)))
|
||||
|
||||
(defimplementation swank-compile-file (input-file output-file
|
||||
load-p external-format
|
||||
&key policy)
|
||||
(declare (ignore external-format policy))
|
||||
(with-compilation-hooks ()
|
||||
(let ((*buffer-name* nil)
|
||||
(*compile-filename* input-file))
|
||||
(multiple-value-bind (output-file warnings? failure?)
|
||||
(compile-file input-file :output-file output-file)
|
||||
(values output-file warnings?
|
||||
(or failure? (and load-p (load output-file))))))))
|
||||
|
||||
(defimplementation swank-compile-string (string &key buffer position filename
|
||||
line column policy)
|
||||
(declare (ignore filename line column policy))
|
||||
(with-compilation-hooks ()
|
||||
(let ((*buffer-name* buffer)
|
||||
(*buffer-position* position)
|
||||
(*buffer-string* string))
|
||||
(funcall (compile nil (read-from-string
|
||||
(format nil "(~S () ~A)" 'lambda string))))
|
||||
t)))
|
||||
|
||||
;;;; Inspecting
|
||||
|
||||
;; Hack to make swank.lisp load, at least
|
||||
(defclass file-stream ())
|
||||
|
||||
(defun comma-separated (list &optional (callback (lambda (v)
|
||||
`(:value ,v))))
|
||||
(butlast (loop for e in list
|
||||
collect (funcall callback e)
|
||||
collect ", ")))
|
||||
|
||||
(defmethod emacs-inspect ((class standard-class))
|
||||
`("Name: "
|
||||
(:value ,(class-name class))
|
||||
(:newline)
|
||||
"Super classes: "
|
||||
,@(comma-separated (swank-mop:class-direct-superclasses class))
|
||||
(:newline)
|
||||
"Direct Slots: "
|
||||
,@(comma-separated
|
||||
(swank-mop:class-direct-slots class)
|
||||
(lambda (slot)
|
||||
`(:value ,slot
|
||||
,(princ-to-string
|
||||
(swank-mop:slot-definition-name slot)))))
|
||||
(:newline)
|
||||
"Effective Slots: "
|
||||
,@(if (swank-mop:class-finalized-p class)
|
||||
(comma-separated
|
||||
(swank-mop:class-slots class)
|
||||
(lambda (slot)
|
||||
`(:value ,slot ,(princ-to-string
|
||||
(swank-mop:slot-definition-name slot)))))
|
||||
'("#<N/A (class not finalized)>"))
|
||||
(:newline)
|
||||
,@(when (documentation class t)
|
||||
`("Documentation:" (:newline) ,(documentation class t) (:newline)))
|
||||
"Sub classes: "
|
||||
,@(comma-separated (swank-mop:class-direct-subclasses class)
|
||||
(lambda (sub)
|
||||
`(:value ,sub ,(princ-to-string (class-name sub)))))
|
||||
(:newline)
|
||||
"Precedence List: "
|
||||
,@(if (swank-mop:class-finalized-p class)
|
||||
(comma-separated
|
||||
(swank-mop:class-precedence-list class)
|
||||
(lambda (class)
|
||||
`(:value ,class
|
||||
,(princ-to-string (class-name class)))))
|
||||
'("#<N/A (class not finalized)>"))
|
||||
(:newline)))
|
||||
|
||||
(defmethod emacs-inspect ((slot cons))
|
||||
;; Inspects slot definitions
|
||||
(if (eq (car slot) :name)
|
||||
`("Name: " (:value ,(swank-mop:slot-definition-name slot))
|
||||
(:newline)
|
||||
,@(when (swank-mop:slot-definition-documentation slot)
|
||||
`("Documentation:"
|
||||
(:newline)
|
||||
(:value
|
||||
,(swank-mop:slot-definition-documentation slot))
|
||||
(:newline)))
|
||||
"Init args: " (:value
|
||||
,(swank-mop:slot-definition-initargs slot))
|
||||
(:newline)
|
||||
"Init form: "
|
||||
,(if (swank-mop:slot-definition-initfunction slot)
|
||||
`(:value ,(swank-mop:slot-definition-initform slot))
|
||||
"#<unspecified>") (:newline)
|
||||
"Init function: "
|
||||
(:value ,(swank-mop:slot-definition-initfunction slot))
|
||||
(:newline))
|
||||
(call-next-method)))
|
||||
|
||||
(defmethod emacs-inspect ((pathname pathnames::pathname-internal))
|
||||
(list* (if (wild-pathname-p pathname)
|
||||
"A wild pathname."
|
||||
"A pathname.")
|
||||
'(:newline)
|
||||
(append (label-value-line*
|
||||
("Namestring" (namestring pathname))
|
||||
("Host" (pathname-host pathname))
|
||||
("Device" (pathname-device pathname))
|
||||
("Directory" (pathname-directory pathname))
|
||||
("Name" (pathname-name pathname))
|
||||
("Type" (pathname-type pathname))
|
||||
("Version" (pathname-version pathname)))
|
||||
(unless (or (wild-pathname-p pathname)
|
||||
(not (probe-file pathname)))
|
||||
(label-value-line "Truename" (truename pathname))))))
|
||||
|
||||
(defmethod emacs-inspect ((o t))
|
||||
(cond ((cl::structurep o) (inspect-structure o))
|
||||
(t (call-next-method))))
|
||||
|
||||
(defun inspect-structure (o)
|
||||
(let* ((template (cl::uref o 1))
|
||||
(num-slots (cl::struct-template-num-slots template)))
|
||||
(cond ((symbolp template)
|
||||
(loop for i below num-slots
|
||||
append (label-value-line i (cl::uref o (+ 2 i)))))
|
||||
(t
|
||||
(loop for i below num-slots
|
||||
append (label-value-line (elt template (+ 6 (* i 5)))
|
||||
(cl::uref o (+ 2 i))))))))
|
||||
|
||||
|
||||
;;; Threads
|
||||
|
||||
(require 'threads)
|
||||
|
||||
(defstruct (mailbox (:conc-name mailbox.))
|
||||
thread
|
||||
(lock (make-instance 'threads:critical-section))
|
||||
(queue '() :type list))
|
||||
|
||||
(defvar *mailbox-lock* (make-instance 'threads:critical-section))
|
||||
(defvar *mailboxes* (list))
|
||||
|
||||
(defmacro with-lock (lock &body body)
|
||||
`(threads:with-synchronization (threads:cs ,lock)
|
||||
,@body))
|
||||
|
||||
(defimplementation spawn (fun &key name)
|
||||
(declare (ignore name))
|
||||
(th:create-thread
|
||||
(lambda ()
|
||||
(handler-bind ((serious-condition #'invoke-debugger))
|
||||
(unwind-protect (funcall fun)
|
||||
(with-lock *mailbox-lock*
|
||||
(setq *mailboxes* (remove cormanlisp:*current-thread-id*
|
||||
*mailboxes* :key #'mailbox.thread))))))))
|
||||
|
||||
(defimplementation thread-id (thread)
|
||||
thread)
|
||||
|
||||
(defimplementation find-thread (thread)
|
||||
(if (thread-alive-p thread)
|
||||
thread))
|
||||
|
||||
(defimplementation thread-alive-p (thread)
|
||||
(if (threads:thread-handle thread) t nil))
|
||||
|
||||
(defimplementation current-thread ()
|
||||
cormanlisp:*current-thread-id*)
|
||||
|
||||
;; XXX implement it
|
||||
(defimplementation all-threads ()
|
||||
'())
|
||||
|
||||
;; XXX something here is broken
|
||||
(defimplementation kill-thread (thread)
|
||||
(threads:terminate-thread thread 'killed))
|
||||
|
||||
(defun mailbox (thread)
|
||||
(with-lock *mailbox-lock*
|
||||
(or (find thread *mailboxes* :key #'mailbox.thread)
|
||||
(let ((mb (make-mailbox :thread thread)))
|
||||
(push mb *mailboxes*)
|
||||
mb))))
|
||||
|
||||
(defimplementation send (thread message)
|
||||
(let ((mbox (mailbox thread)))
|
||||
(with-lock (mailbox.lock mbox)
|
||||
(setf (mailbox.queue mbox)
|
||||
(nconc (mailbox.queue mbox) (list message))))))
|
||||
|
||||
(defimplementation receive ()
|
||||
(let ((mbox (mailbox cormanlisp:*current-thread-id*)))
|
||||
(loop
|
||||
(with-lock (mailbox.lock mbox)
|
||||
(when (mailbox.queue mbox)
|
||||
(return (pop (mailbox.queue mbox)))))
|
||||
(sleep 0.1))))
|
||||
|
||||
|
||||
;;; This is probably not good, but it WFM
|
||||
(in-package :common-lisp)
|
||||
|
||||
(defvar *old-documentation* #'documentation)
|
||||
(defun documentation (thing &optional (type 'function))
|
||||
(if (symbolp thing)
|
||||
(funcall *old-documentation* thing type)
|
||||
(values)))
|
||||
|
||||
(defmethod print-object ((restart restart) stream)
|
||||
(if (or *print-escape*
|
||||
*print-readably*)
|
||||
(print-unreadable-object (restart stream :type t :identity t)
|
||||
(princ (restart-name restart) stream))
|
||||
(when (functionp (restart-report-function restart))
|
||||
(funcall (restart-report-function restart) stream))))
|
||||
1098
sources_non_forked/slimv/slime/swank/ecl.lisp
Normal file
1098
sources_non_forked/slimv/slime/swank/ecl.lisp
Normal file
File diff suppressed because it is too large
Load Diff
207
sources_non_forked/slimv/slime/swank/gray.lisp
Normal file
207
sources_non_forked/slimv/slime/swank/gray.lisp
Normal file
@ -0,0 +1,207 @@
|
||||
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
|
||||
;;;
|
||||
;;; swank-gray.lisp --- Gray stream based IO redirection.
|
||||
;;;
|
||||
;;; Created 2003
|
||||
;;;
|
||||
;;; This code has been placed in the Public Domain. All warranties
|
||||
;;; are disclaimed.
|
||||
;;;
|
||||
|
||||
(in-package swank/backend)
|
||||
|
||||
#.(progn
|
||||
(defvar *gray-stream-symbols*
|
||||
'(fundamental-character-output-stream
|
||||
stream-write-char
|
||||
stream-write-string
|
||||
stream-fresh-line
|
||||
stream-force-output
|
||||
stream-finish-output
|
||||
|
||||
fundamental-character-input-stream
|
||||
stream-read-char
|
||||
stream-peek-char
|
||||
stream-read-line
|
||||
stream-listen
|
||||
stream-unread-char
|
||||
stream-clear-input
|
||||
stream-line-column
|
||||
stream-read-char-no-hang))
|
||||
nil)
|
||||
|
||||
(defpackage swank/gray
|
||||
(:use cl swank/backend)
|
||||
(:import-from #.(gray-package-name) . #.*gray-stream-symbols*)
|
||||
(:export . #.*gray-stream-symbols*))
|
||||
|
||||
(in-package swank/gray)
|
||||
|
||||
(defclass slime-output-stream (fundamental-character-output-stream)
|
||||
((output-fn :initarg :output-fn)
|
||||
(buffer :initform (make-string 8000))
|
||||
(fill-pointer :initform 0)
|
||||
(column :initform 0)
|
||||
(lock :initform (make-lock :name "buffer write lock"))
|
||||
(flush-thread :initarg :flush-thread
|
||||
:initform nil
|
||||
:accessor flush-thread)
|
||||
(flush-scheduled :initarg :flush-scheduled
|
||||
:initform nil
|
||||
:accessor flush-scheduled)))
|
||||
|
||||
(defun maybe-schedule-flush (stream)
|
||||
(when (and (flush-thread stream)
|
||||
(not (flush-scheduled stream)))
|
||||
(setf (flush-scheduled stream) t)
|
||||
(send (flush-thread stream) t)))
|
||||
|
||||
(defmacro with-slime-output-stream (stream &body body)
|
||||
`(with-slots (lock output-fn buffer fill-pointer column) ,stream
|
||||
(call-with-lock-held lock (lambda () ,@body))))
|
||||
|
||||
(defmethod stream-write-char ((stream slime-output-stream) char)
|
||||
(with-slime-output-stream stream
|
||||
(setf (schar buffer fill-pointer) char)
|
||||
(incf fill-pointer)
|
||||
(incf column)
|
||||
(when (char= #\newline char)
|
||||
(setf column 0))
|
||||
(if (= fill-pointer (length buffer))
|
||||
(finish-output stream)
|
||||
(maybe-schedule-flush stream)))
|
||||
char)
|
||||
|
||||
(defmethod stream-write-string ((stream slime-output-stream) string
|
||||
&optional start end)
|
||||
(with-slime-output-stream stream
|
||||
(let* ((start (or start 0))
|
||||
(end (or end (length string)))
|
||||
(len (length buffer))
|
||||
(count (- end start))
|
||||
(free (- len fill-pointer)))
|
||||
(when (>= count free)
|
||||
(stream-finish-output stream))
|
||||
(cond ((< count len)
|
||||
(replace buffer string :start1 fill-pointer
|
||||
:start2 start :end2 end)
|
||||
(incf fill-pointer count)
|
||||
(maybe-schedule-flush stream))
|
||||
(t
|
||||
(funcall output-fn (subseq string start end))))
|
||||
(let ((last-newline (position #\newline string :from-end t
|
||||
:start start :end end)))
|
||||
(setf column (if last-newline
|
||||
(- end last-newline 1)
|
||||
(+ column count))))))
|
||||
string)
|
||||
|
||||
(defmethod stream-line-column ((stream slime-output-stream))
|
||||
(with-slime-output-stream stream column))
|
||||
|
||||
(defmethod stream-finish-output ((stream slime-output-stream))
|
||||
(with-slime-output-stream stream
|
||||
(unless (zerop fill-pointer)
|
||||
(funcall output-fn (subseq buffer 0 fill-pointer))
|
||||
(setf fill-pointer 0))
|
||||
(setf (flush-scheduled stream) nil))
|
||||
nil)
|
||||
|
||||
#+(and sbcl sb-thread)
|
||||
(defmethod stream-force-output :around ((stream slime-output-stream))
|
||||
;; Workaround for deadlocks between the world-lock and auto-flush-thread
|
||||
;; buffer write lock.
|
||||
;;
|
||||
;; Another alternative would be to grab the world-lock here, but that's less
|
||||
;; future-proof, and could introduce other lock-ordering issues in the
|
||||
;; future.
|
||||
(handler-case
|
||||
(sb-sys:with-deadline (:seconds 0.1)
|
||||
(call-next-method))
|
||||
(sb-sys:deadline-timeout ()
|
||||
nil)))
|
||||
|
||||
(defmethod stream-force-output ((stream slime-output-stream))
|
||||
(stream-finish-output stream))
|
||||
|
||||
(defmethod stream-fresh-line ((stream slime-output-stream))
|
||||
(with-slime-output-stream stream
|
||||
(cond ((zerop column) nil)
|
||||
(t (terpri stream) t))))
|
||||
|
||||
(defclass slime-input-stream (fundamental-character-input-stream)
|
||||
((input-fn :initarg :input-fn)
|
||||
(buffer :initform "") (index :initform 0)
|
||||
(lock :initform (make-lock :name "buffer read lock"))))
|
||||
|
||||
(defmethod stream-read-char ((s slime-input-stream))
|
||||
(call-with-lock-held
|
||||
(slot-value s 'lock)
|
||||
(lambda ()
|
||||
(with-slots (buffer index input-fn) s
|
||||
(when (= index (length buffer))
|
||||
(let ((string (funcall input-fn)))
|
||||
(cond ((zerop (length string))
|
||||
(return-from stream-read-char :eof))
|
||||
(t
|
||||
(setf buffer string)
|
||||
(setf index 0)))))
|
||||
(assert (plusp (length buffer)))
|
||||
(prog1 (aref buffer index) (incf index))))))
|
||||
|
||||
(defmethod stream-listen ((s slime-input-stream))
|
||||
(call-with-lock-held
|
||||
(slot-value s 'lock)
|
||||
(lambda ()
|
||||
(with-slots (buffer index) s
|
||||
(< index (length buffer))))))
|
||||
|
||||
(defmethod stream-unread-char ((s slime-input-stream) char)
|
||||
(call-with-lock-held
|
||||
(slot-value s 'lock)
|
||||
(lambda ()
|
||||
(with-slots (buffer index) s
|
||||
(decf index)
|
||||
(cond ((eql (aref buffer index) char)
|
||||
(setf (aref buffer index) char))
|
||||
(t
|
||||
(warn "stream-unread-char: ignoring ~S (expected ~S)"
|
||||
char (aref buffer index)))))))
|
||||
nil)
|
||||
|
||||
(defmethod stream-clear-input ((s slime-input-stream))
|
||||
(call-with-lock-held
|
||||
(slot-value s 'lock)
|
||||
(lambda ()
|
||||
(with-slots (buffer index) s
|
||||
(setf buffer ""
|
||||
index 0))))
|
||||
nil)
|
||||
|
||||
(defmethod stream-line-column ((s slime-input-stream))
|
||||
nil)
|
||||
|
||||
(defmethod stream-read-char-no-hang ((s slime-input-stream))
|
||||
(call-with-lock-held
|
||||
(slot-value s 'lock)
|
||||
(lambda ()
|
||||
(with-slots (buffer index) s
|
||||
(when (< index (length buffer))
|
||||
(prog1 (aref buffer index) (incf index)))))))
|
||||
|
||||
|
||||
;;;
|
||||
|
||||
(defimplementation make-auto-flush-thread (stream)
|
||||
(if (typep stream 'slime-output-stream)
|
||||
(setf (flush-thread stream)
|
||||
(spawn (lambda () (auto-flush-loop stream 0.08 t))
|
||||
:name "auto-flush-thread"))
|
||||
(spawn (lambda () (auto-flush-loop stream *auto-flush-interval*))
|
||||
:name "auto-flush-thread")))
|
||||
|
||||
(defimplementation make-output-stream (write-string)
|
||||
(make-instance 'slime-output-stream :output-fn write-string))
|
||||
|
||||
(defimplementation make-input-stream (read-string)
|
||||
(make-instance 'slime-input-stream :input-fn read-string))
|
||||
1020
sources_non_forked/slimv/slime/swank/lispworks.lisp
Normal file
1020
sources_non_forked/slimv/slime/swank/lispworks.lisp
Normal file
File diff suppressed because it is too large
Load Diff
242
sources_non_forked/slimv/slime/swank/match.lisp
Normal file
242
sources_non_forked/slimv/slime/swank/match.lisp
Normal file
@ -0,0 +1,242 @@
|
||||
;;
|
||||
;; SELECT-MATCH macro (and IN macro)
|
||||
;;
|
||||
;; Copyright 1990 Stephen Adams
|
||||
;;
|
||||
;; You are free to copy, distribute and make derivative works of this
|
||||
;; source provided that this copyright notice is displayed near the
|
||||
;; beginning of the file. No liability is accepted for the
|
||||
;; correctness or performance of the code. If you modify the code
|
||||
;; please indicate this fact both at the place of modification and in
|
||||
;; this copyright message.
|
||||
;;
|
||||
;; Stephen Adams
|
||||
;; Department of Electronics and Computer Science
|
||||
;; University of Southampton
|
||||
;; SO9 5NH, UK
|
||||
;;
|
||||
;; sra@ecs.soton.ac.uk
|
||||
;;
|
||||
|
||||
;;
|
||||
;; Synopsis:
|
||||
;;
|
||||
;; (select-match expression
|
||||
;; (pattern action+)*)
|
||||
;;
|
||||
;; --- or ---
|
||||
;;
|
||||
;; (select-match expression
|
||||
;; pattern => expression
|
||||
;; pattern => expression
|
||||
;; ...)
|
||||
;;
|
||||
;; pattern -> constant ;egs 1, #\x, #c(1.0 1.1)
|
||||
;; | symbol ;matches anything
|
||||
;; | 'anything ;must be EQUAL
|
||||
;; | (pattern = pattern) ;both patterns must match
|
||||
;; | (#'function pattern) ;predicate test
|
||||
;; | (pattern . pattern) ;cons cell
|
||||
;;
|
||||
|
||||
;; Example
|
||||
;;
|
||||
;; (select-match item
|
||||
;; (('if e1 e2 e3) 'if-then-else) ;(1)
|
||||
;; ((#'oddp k) 'an-odd-integer) ;(2)
|
||||
;; (((#'treep tree) = (hd . tl)) 'something-else) ;(3)
|
||||
;; (other 'anything-else)) ;(4)
|
||||
;;
|
||||
;; Notes
|
||||
;;
|
||||
;; . Each pattern is tested in turn. The first match is taken.
|
||||
;;
|
||||
;; . If no pattern matches, an error is signalled.
|
||||
;;
|
||||
;; . Constant patterns (things X for which (CONSTANTP X) is true, i.e.
|
||||
;; numbers, strings, characters, etc.) match things which are EQUAL.
|
||||
;;
|
||||
;; . Quoted patterns (which are CONSTANTP) are constants.
|
||||
;;
|
||||
;; . Symbols match anything. The symbol is bound to the matched item
|
||||
;; for the execution of the actions.
|
||||
;; For example, (SELECT-MATCH '(1 2 3)
|
||||
;; (1 . X) => X)
|
||||
;; returns (2 3) because X is bound to the cdr of the candidate.
|
||||
;;
|
||||
;; . The two pattern match (p1 = p2) can be used to name parts
|
||||
;; of the matched structure. For example, (ALL = (HD . TL))
|
||||
;; matches a cons cell. ALL is bound to the cons cell, HD to its car
|
||||
;; and TL to its tail.
|
||||
;;
|
||||
;; . A predicate test applies the predicate to the item being matched.
|
||||
;; If the predicate returns NIL then the match fails.
|
||||
;; If it returns truth, then the nested pattern is matched. This is
|
||||
;; often just a symbol like K in the example.
|
||||
;;
|
||||
;; . Care should be taken with the domain values for predicate matches.
|
||||
;; If, in the above eg, item is not an integer, an error would occur
|
||||
;; during the test. A safer pattern would be
|
||||
;; (#'integerp (#'oddp k))
|
||||
;; This would only test for oddness of the item was an integer.
|
||||
;;
|
||||
;; . A single symbol will match anything so it can be used as a default
|
||||
;; case, like OTHER above.
|
||||
;;
|
||||
|
||||
(in-package swank/match)
|
||||
|
||||
(defmacro match (expression &body patterns)
|
||||
`(select-match ,expression ,@patterns))
|
||||
|
||||
(defmacro select-match (expression &rest patterns)
|
||||
(let* ((do-let (not (atom expression)))
|
||||
(key (if do-let (gensym) expression))
|
||||
(cbody (expand-select-patterns key patterns))
|
||||
(cform `(cond . ,cbody)))
|
||||
(if do-let
|
||||
`(let ((,key ,expression)) ,cform)
|
||||
cform)))
|
||||
|
||||
(defun expand-select-patterns (key patterns)
|
||||
(if (eq (second patterns) '=>)
|
||||
(expand-select-patterns-style-2 key patterns)
|
||||
(expand-select-patterns-style-1 key patterns)))
|
||||
|
||||
(defun expand-select-patterns-style-1 (key patterns)
|
||||
(if (null patterns)
|
||||
`((t (error "Case select pattern match failure on ~S" ,key)))
|
||||
(let* ((pattern (caar patterns))
|
||||
(actions (cdar patterns))
|
||||
(rest (cdr patterns))
|
||||
(test (compile-select-test key pattern))
|
||||
(bindings (compile-select-bindings key pattern actions)))
|
||||
`(,(if bindings `(,test (let ,bindings . ,actions))
|
||||
`(,test . ,actions))
|
||||
. ,(unless (eq test t)
|
||||
(expand-select-patterns-style-1 key rest))))))
|
||||
|
||||
(defun expand-select-patterns-style-2 (key patterns)
|
||||
(cond ((null patterns)
|
||||
`((t (error "Case select pattern match failure on ~S" ,key))))
|
||||
(t (when (or (< (length patterns) 3)
|
||||
(not (eq (second patterns) '=>)))
|
||||
(error "Illegal patterns: ~S" patterns))
|
||||
(let* ((pattern (first patterns))
|
||||
(actions (list (third patterns)))
|
||||
(rest (cdddr patterns))
|
||||
(test (compile-select-test key pattern))
|
||||
(bindings (compile-select-bindings key pattern actions)))
|
||||
`(,(if bindings `(,test (let ,bindings . ,actions))
|
||||
`(,test . ,actions))
|
||||
. ,(unless (eq test t)
|
||||
(expand-select-patterns-style-2 key rest)))))))
|
||||
|
||||
(defun compile-select-test (key pattern)
|
||||
(let ((tests (remove t (compile-select-tests key pattern))))
|
||||
(cond
|
||||
;; note AND does this anyway, but this allows us to tell if
|
||||
;; the pattern will always match.
|
||||
((null tests) t)
|
||||
((= (length tests) 1) (car tests))
|
||||
(t `(and . ,tests)))))
|
||||
|
||||
(defun compile-select-tests (key pattern)
|
||||
(cond ((constantp pattern) `((,(cond ((numberp pattern) 'eql)
|
||||
((symbolp pattern) 'eq)
|
||||
(t 'equal))
|
||||
,key ,pattern)))
|
||||
((symbolp pattern) '(t))
|
||||
((select-double-match? pattern)
|
||||
(append
|
||||
(compile-select-tests key (first pattern))
|
||||
(compile-select-tests key (third pattern))))
|
||||
((select-predicate? pattern)
|
||||
(append
|
||||
`((,(second (first pattern)) ,key))
|
||||
(compile-select-tests key (second pattern))))
|
||||
((consp pattern)
|
||||
(append
|
||||
`((consp ,key))
|
||||
(compile-select-tests (cs-car key) (car
|
||||
pattern))
|
||||
(compile-select-tests (cs-cdr key) (cdr
|
||||
pattern))))
|
||||
(t (error "Illegal select pattern: ~S" pattern))))
|
||||
|
||||
|
||||
(defun compile-select-bindings (key pattern action)
|
||||
(cond ((constantp pattern) '())
|
||||
((symbolp pattern)
|
||||
(if (select-in-tree pattern action)
|
||||
`((,pattern ,key))
|
||||
'()))
|
||||
((select-double-match? pattern)
|
||||
(append
|
||||
(compile-select-bindings key (first pattern) action)
|
||||
(compile-select-bindings key (third pattern) action)))
|
||||
((select-predicate? pattern)
|
||||
(compile-select-bindings key (second pattern) action))
|
||||
((consp pattern)
|
||||
(append
|
||||
(compile-select-bindings (cs-car key) (car pattern)
|
||||
action)
|
||||
(compile-select-bindings (cs-cdr key) (cdr pattern)
|
||||
action)))))
|
||||
|
||||
(defun select-in-tree (atom tree)
|
||||
(or (eq atom tree)
|
||||
(if (consp tree)
|
||||
(or (select-in-tree atom (car tree))
|
||||
(select-in-tree atom (cdr tree))))))
|
||||
|
||||
(defun select-double-match? (pattern)
|
||||
;; (<pattern> = <pattern>)
|
||||
(and (consp pattern) (consp (cdr pattern)) (consp (cddr pattern))
|
||||
(null (cdddr pattern))
|
||||
(eq (second pattern) '=)))
|
||||
|
||||
(defun select-predicate? (pattern)
|
||||
;; ((function <f>) <pattern>)
|
||||
(and (consp pattern)
|
||||
(consp (cdr pattern))
|
||||
(null (cddr pattern))
|
||||
(consp (first pattern))
|
||||
(consp (cdr (first pattern)))
|
||||
(null (cddr (first pattern)))
|
||||
(eq (caar pattern) 'function)))
|
||||
|
||||
(defun cs-car (exp)
|
||||
(cs-car/cdr 'car exp
|
||||
'((car . caar) (cdr . cadr) (caar . caaar) (cadr . caadr)
|
||||
(cdar . cadar) (cddr . caddr)
|
||||
(caaar . caaaar) (caadr . caaadr) (cadar . caadar)
|
||||
(caddr . caaddr) (cdaar . cadaar) (cdadr . cadadr)
|
||||
(cddar . caddar) (cdddr . cadddr))))
|
||||
|
||||
(defun cs-cdr (exp)
|
||||
(cs-car/cdr 'cdr exp
|
||||
'((car . cdar) (cdr . cddr) (caar . cdaar) (cadr . cdadr)
|
||||
(cdar . cddar) (cddr . cdddr)
|
||||
(caaar . cdaaar) (caadr . cdaadr) (cadar . cdadar)
|
||||
(caddr . cdaddr) (cdaar . cddaar) (cdadr . cddadr)
|
||||
(cddar . cdddar) (cdddr . cddddr))))
|
||||
|
||||
(defun cs-car/cdr (op exp table)
|
||||
(if (and (consp exp) (= (length exp) 2))
|
||||
(let ((replacement (assoc (car exp) table)))
|
||||
(if replacement
|
||||
`(,(cdr replacement) ,(second exp))
|
||||
`(,op ,exp)))
|
||||
`(,op ,exp)))
|
||||
|
||||
;; (setf c1 '(select-match x (a 1) (b 2 3 4)))
|
||||
;; (setf c2 '(select-match (car y)
|
||||
;; (1 (print 100) 101) (2 200) ("hello" 5) (:x 20) (else (1+
|
||||
;; else))))
|
||||
;; (setf c3 '(select-match (caddr y)
|
||||
;; ((all = (x y)) (list x y all))
|
||||
;; ((a '= b) (list 'assign a b))
|
||||
;; ((#'oddp k) (1+ k)))))
|
||||
|
||||
|
||||
700
sources_non_forked/slimv/slime/swank/mezzano.lisp
Normal file
700
sources_non_forked/slimv/slime/swank/mezzano.lisp
Normal file
@ -0,0 +1,700 @@
|
||||
;;;;; -*- indent-tabs-mode: nil -*-
|
||||
;;;
|
||||
;;; swank-mezzano.lisp --- SLIME backend for Mezzano
|
||||
;;;
|
||||
;;; This code has been placed in the Public Domain. All warranties are
|
||||
;;; disclaimed.
|
||||
;;;
|
||||
|
||||
;;; Administrivia
|
||||
|
||||
(defpackage swank/mezzano
|
||||
(:use cl swank/backend))
|
||||
|
||||
(in-package swank/mezzano)
|
||||
|
||||
;;; swank-mop
|
||||
|
||||
(import-swank-mop-symbols :mezzano.clos '(:class-default-initargs
|
||||
:class-direct-default-initargs
|
||||
:specializer-direct-methods
|
||||
:generic-function-declarations))
|
||||
|
||||
(defun swank-mop:specializer-direct-methods (obj)
|
||||
(declare (ignore obj))
|
||||
'())
|
||||
|
||||
(defun swank-mop:generic-function-declarations (gf)
|
||||
(declare (ignore gf))
|
||||
'())
|
||||
|
||||
(defimplementation gray-package-name ()
|
||||
"MEZZANO.GRAY")
|
||||
|
||||
;;;; TCP server
|
||||
|
||||
(defclass listen-socket ()
|
||||
((%listener :initarg :listener)))
|
||||
|
||||
(defimplementation create-socket (host port &key backlog)
|
||||
(make-instance 'listen-socket
|
||||
:listener (mezzano.network.tcp:tcp-listen
|
||||
host
|
||||
port
|
||||
:backlog (or backlog 10))))
|
||||
|
||||
(defimplementation local-port (socket)
|
||||
(mezzano.network.tcp:tcp-listener-local-port (slot-value socket '%listener)))
|
||||
|
||||
(defimplementation close-socket (socket)
|
||||
(mezzano.network.tcp:close-tcp-listener (slot-value socket '%listener)))
|
||||
|
||||
(defimplementation accept-connection (socket &key external-format
|
||||
buffering timeout)
|
||||
(declare (ignore external-format buffering timeout))
|
||||
(loop
|
||||
(let ((value (mezzano.network.tcp:tcp-accept (slot-value socket '%listener)
|
||||
:wait-p nil)))
|
||||
(if value
|
||||
(return value)
|
||||
;; Poke standard-input every now and then to keep the console alive.
|
||||
(progn (listen)
|
||||
(sleep 0.05))))))
|
||||
|
||||
(defimplementation preferred-communication-style ()
|
||||
:spawn)
|
||||
|
||||
;;;; Unix signals
|
||||
;;;; ????
|
||||
|
||||
(defimplementation getpid ()
|
||||
0)
|
||||
|
||||
;;;; Compilation
|
||||
|
||||
(defun signal-compiler-condition (condition severity)
|
||||
(signal 'compiler-condition
|
||||
:original-condition condition
|
||||
:severity severity
|
||||
:message (format nil "~A" condition)
|
||||
:location nil))
|
||||
|
||||
(defimplementation call-with-compilation-hooks (func)
|
||||
(handler-bind
|
||||
((error
|
||||
(lambda (c)
|
||||
(signal-compiler-condition c :error)))
|
||||
(warning
|
||||
(lambda (c)
|
||||
(signal-compiler-condition c :warning)))
|
||||
(style-warning
|
||||
(lambda (c)
|
||||
(signal-compiler-condition c :style-warning))))
|
||||
(funcall func)))
|
||||
|
||||
(defimplementation swank-compile-string (string &key buffer position filename
|
||||
line column policy)
|
||||
(declare (ignore buffer line column policy))
|
||||
(let* ((*load-pathname* (ignore-errors (pathname filename)))
|
||||
(*load-truename* (when *load-pathname*
|
||||
(ignore-errors (truename *load-pathname*))))
|
||||
(sys.int::*top-level-form-number* `(:position ,position)))
|
||||
(with-compilation-hooks ()
|
||||
(eval (read-from-string (concatenate 'string "(progn " string " )")))))
|
||||
t)
|
||||
|
||||
(defimplementation swank-compile-file (input-file output-file load-p
|
||||
external-format
|
||||
&key policy)
|
||||
(with-compilation-hooks ()
|
||||
(multiple-value-prog1
|
||||
(compile-file input-file
|
||||
:output-file output-file
|
||||
:external-format external-format)
|
||||
(when load-p
|
||||
(load output-file)))))
|
||||
|
||||
(defimplementation find-external-format (coding-system)
|
||||
(if (or (equal coding-system "utf-8")
|
||||
(equal coding-system "utf-8-unix"))
|
||||
:default
|
||||
nil))
|
||||
|
||||
;;;; Debugging
|
||||
|
||||
;; Definitely don't allow this.
|
||||
(defimplementation install-debugger-globally (function)
|
||||
(declare (ignore function))
|
||||
nil)
|
||||
|
||||
(defvar *current-backtrace*)
|
||||
|
||||
(defimplementation call-with-debugging-environment (debugger-loop-fn)
|
||||
(let ((*current-backtrace* '()))
|
||||
(let ((prev-fp nil))
|
||||
(sys.int::map-backtrace
|
||||
(lambda (i fp)
|
||||
(push (list (1- i) fp prev-fp) *current-backtrace*)
|
||||
(setf prev-fp fp))))
|
||||
(setf *current-backtrace* (reverse *current-backtrace*))
|
||||
;; Drop the topmost frame, which is finished call to MAP-BACKTRACE.
|
||||
(pop *current-backtrace*)
|
||||
;; And the next one for good measure.
|
||||
(pop *current-backtrace*)
|
||||
(funcall debugger-loop-fn)))
|
||||
|
||||
(defimplementation compute-backtrace (start end)
|
||||
(subseq *current-backtrace* start end))
|
||||
|
||||
(defimplementation print-frame (frame stream)
|
||||
(format stream "~S" (sys.int::function-from-frame frame)))
|
||||
|
||||
(defimplementation frame-source-location (frame-number)
|
||||
(let* ((frame (nth frame-number *current-backtrace*))
|
||||
(fn (sys.int::function-from-frame frame)))
|
||||
(function-location fn)))
|
||||
|
||||
(defimplementation frame-locals (frame-number)
|
||||
(loop
|
||||
with frame = (nth frame-number *current-backtrace*)
|
||||
for (name id location repr) in (sys.int::frame-locals frame)
|
||||
collect (list :name name
|
||||
:id id
|
||||
:value (sys.int::read-frame-slot frame location repr))))
|
||||
|
||||
(defimplementation frame-var-value (frame-number var-id)
|
||||
(let* ((frame (nth frame-number *current-backtrace*))
|
||||
(locals (sys.int::frame-locals frame))
|
||||
(info (nth var-id locals)))
|
||||
(if info
|
||||
(destructuring-bind (name id location repr)
|
||||
info
|
||||
(declare (ignore id))
|
||||
(values (sys.int::read-frame-slot frame location repr) name))
|
||||
(error "Invalid variable id ~D for frame number ~D."
|
||||
var-id frame-number))))
|
||||
|
||||
;;;; Definition finding
|
||||
|
||||
(defun top-level-form-position (pathname tlf)
|
||||
(ignore-errors
|
||||
(with-open-file (s pathname)
|
||||
(loop
|
||||
repeat tlf
|
||||
do (with-standard-io-syntax
|
||||
(let ((*read-suppress* t)
|
||||
(*read-eval* nil))
|
||||
(read s nil))))
|
||||
(let ((default (make-pathname :host (pathname-host s))))
|
||||
(make-location `(:file ,(enough-namestring s default))
|
||||
`(:position ,(1+ (file-position s))))))))
|
||||
|
||||
(defun function-location (function)
|
||||
"Return a location object for FUNCTION."
|
||||
(let* ((info (sys.int::function-debug-info function))
|
||||
(pathname (sys.int::debug-info-source-pathname info))
|
||||
(tlf (sys.int::debug-info-source-top-level-form-number info)))
|
||||
(cond ((and (consp tlf)
|
||||
(eql (first tlf) :position))
|
||||
(let ((default (make-pathname :host (pathname-host pathname))))
|
||||
(make-location `(:file ,(enough-namestring pathname default))
|
||||
`(:position ,(second tlf)))))
|
||||
(t
|
||||
(top-level-form-position pathname tlf)))))
|
||||
|
||||
(defun method-definition-name (name method)
|
||||
`(defmethod ,name
|
||||
,@(mezzano.clos:method-qualifiers method)
|
||||
,(mapcar (lambda (x)
|
||||
(typecase x
|
||||
(mezzano.clos:class
|
||||
(mezzano.clos:class-name x))
|
||||
(mezzano.clos:eql-specializer
|
||||
`(eql ,(mezzano.clos:eql-specializer-object x)))
|
||||
(t x)))
|
||||
(mezzano.clos:method-specializers method))))
|
||||
|
||||
(defimplementation find-definitions (name)
|
||||
(let ((result '()))
|
||||
(labels
|
||||
((frob-fn (dspec fn)
|
||||
(let ((loc (function-location fn)))
|
||||
(when loc
|
||||
(push (list dspec loc) result))))
|
||||
(try-fn (name)
|
||||
(when (valid-function-name-p name)
|
||||
(when (and (fboundp name)
|
||||
(not (and (symbolp name)
|
||||
(or (special-operator-p name)
|
||||
(macro-function name)))))
|
||||
(let ((fn (fdefinition name)))
|
||||
(cond ((typep fn 'mezzano.clos:standard-generic-function)
|
||||
(dolist (m (mezzano.clos:generic-function-methods fn))
|
||||
(frob-fn (method-definition-name name m)
|
||||
(mezzano.clos:method-function m))))
|
||||
(t
|
||||
(frob-fn `(defun ,name) fn)))))
|
||||
(when (compiler-macro-function name)
|
||||
(frob-fn `(define-compiler-macro ,name)
|
||||
(compiler-macro-function name))))))
|
||||
(try-fn name)
|
||||
(try-fn `(setf name))
|
||||
(try-fn `(sys.int::cas name))
|
||||
(when (and (symbolp name)
|
||||
(get name 'sys.int::setf-expander))
|
||||
(frob-fn `(define-setf-expander ,name)
|
||||
(get name 'sys.int::setf-expander)))
|
||||
(when (and (symbolp name)
|
||||
(macro-function name))
|
||||
(frob-fn `(defmacro ,name)
|
||||
(macro-function name))))
|
||||
result))
|
||||
|
||||
;;;; XREF
|
||||
;;; Simpler variants.
|
||||
|
||||
(defun find-all-frefs ()
|
||||
(let ((frefs (make-array 500 :adjustable t :fill-pointer 0))
|
||||
(keep-going t))
|
||||
(loop
|
||||
(when (not keep-going)
|
||||
(return))
|
||||
(adjust-array frefs (* (array-dimension frefs 0) 2))
|
||||
(setf keep-going nil
|
||||
(fill-pointer frefs) 0)
|
||||
;; Walk the wired area looking for FREFs.
|
||||
(sys.int::walk-area
|
||||
:wired
|
||||
(lambda (object address size)
|
||||
(when (sys.int::function-reference-p object)
|
||||
(when (not (vector-push object frefs))
|
||||
(setf keep-going t))))))
|
||||
(remove-duplicates (coerce frefs 'list))))
|
||||
|
||||
(defimplementation list-callers (function-name)
|
||||
(let ((fref-for-fn (sys.int::function-reference function-name))
|
||||
(callers '()))
|
||||
(loop
|
||||
for fref in (find-all-frefs)
|
||||
for fn = (sys.int::function-reference-function fref)
|
||||
for name = (sys.int::function-reference-name fref)
|
||||
when fn
|
||||
do
|
||||
(cond ((typep fn 'standard-generic-function)
|
||||
(dolist (m (mezzano.clos:generic-function-methods fn))
|
||||
(let* ((mf (mezzano.clos:method-function m))
|
||||
(mf-frefs (get-all-frefs-in-function mf)))
|
||||
(when (member fref-for-fn mf-frefs)
|
||||
(push `((defmethod ,name
|
||||
,@(mezzano.clos:method-qualifiers m)
|
||||
,(mapcar #'specializer-name
|
||||
(mezzano.clos:method-specializers m)))
|
||||
,(function-location mf))
|
||||
callers)))))
|
||||
((member fref-for-fn
|
||||
(get-all-frefs-in-function fn))
|
||||
(push `((defun ,name) ,(function-location fn)) callers))))
|
||||
callers))
|
||||
|
||||
(defun specializer-name (specializer)
|
||||
(if (typep specializer 'standard-class)
|
||||
(mezzano.clos:class-name specializer)
|
||||
specializer))
|
||||
|
||||
(defun get-all-frefs-in-function (function)
|
||||
(when (sys.int::funcallable-std-instance-p function)
|
||||
(setf function (sys.int::funcallable-std-instance-function function)))
|
||||
(when (sys.int::closure-p function)
|
||||
(setf function (sys.int::%closure-function function)))
|
||||
(loop
|
||||
for i below (sys.int::function-pool-size function)
|
||||
for entry = (sys.int::function-pool-object function i)
|
||||
when (sys.int::function-reference-p entry)
|
||||
collect entry
|
||||
when (compiled-function-p entry) ; closures
|
||||
append (get-all-frefs-in-function entry)))
|
||||
|
||||
(defimplementation list-callees (function-name)
|
||||
(let* ((fn (fdefinition function-name))
|
||||
;; Grovel around in the function's constant pool looking for
|
||||
;; function-references. These may be for #', but they're
|
||||
;; probably going to be for normal calls.
|
||||
;; TODO: This doesn't work well on interpreted functions or
|
||||
;; funcallable instances.
|
||||
(callees (remove-duplicates (get-all-frefs-in-function fn))))
|
||||
(loop
|
||||
for fref in callees
|
||||
for name = (sys.int::function-reference-name fref)
|
||||
for fn = (sys.int::function-reference-function fref)
|
||||
when fn
|
||||
collect `((defun ,name) ,(function-location fn)))))
|
||||
|
||||
;;;; Documentation
|
||||
|
||||
(defimplementation arglist (name)
|
||||
(let ((macro (when (symbolp name)
|
||||
(macro-function name)))
|
||||
(fn (if (functionp name)
|
||||
name
|
||||
(ignore-errors (fdefinition name)))))
|
||||
(cond
|
||||
(macro
|
||||
(get name 'sys.int::macro-lambda-list))
|
||||
(fn
|
||||
(cond
|
||||
((typep fn 'mezzano.clos:standard-generic-function)
|
||||
(mezzano.clos:generic-function-lambda-list fn))
|
||||
(t
|
||||
(function-lambda-list fn))))
|
||||
(t :not-available))))
|
||||
|
||||
(defun function-lambda-list (function)
|
||||
(sys.int::debug-info-lambda-list
|
||||
(sys.int::function-debug-info function)))
|
||||
|
||||
(defimplementation type-specifier-p (symbol)
|
||||
(cond
|
||||
((or (get symbol 'sys.int::type-expander)
|
||||
(get symbol 'sys.int::compound-type)
|
||||
(get symbol 'sys.int::type-symbol))
|
||||
t)
|
||||
(t :not-available)))
|
||||
|
||||
(defimplementation function-name (function)
|
||||
(sys.int::function-name function))
|
||||
|
||||
(defimplementation valid-function-name-p (form)
|
||||
"Is FORM syntactically valid to name a function?
|
||||
If true, FBOUNDP should not signal a type-error for FORM."
|
||||
(flet ((length=2 (list)
|
||||
(and (not (null (cdr list))) (null (cddr list)))))
|
||||
(or (symbolp form)
|
||||
(and (consp form) (length=2 form)
|
||||
(or (eq (first form) 'setf)
|
||||
(eq (first form) 'sys.int::cas))
|
||||
(symbolp (second form))))))
|
||||
|
||||
(defimplementation describe-symbol-for-emacs (symbol)
|
||||
(let ((result '()))
|
||||
(when (boundp symbol)
|
||||
(setf (getf result :variable) nil))
|
||||
(when (and (fboundp symbol)
|
||||
(not (macro-function symbol)))
|
||||
(setf (getf result :function)
|
||||
(function-docstring symbol)))
|
||||
(when (fboundp `(setf ,symbol))
|
||||
(setf (getf result :setf)
|
||||
(function-docstring `(setf ,symbol))))
|
||||
(when (get symbol 'sys.int::setf-expander)
|
||||
(setf (getf result :setf) nil))
|
||||
(when (special-operator-p symbol)
|
||||
(setf (getf result :special-operator) nil))
|
||||
(when (macro-function symbol)
|
||||
(setf (getf result :macro) nil))
|
||||
(when (compiler-macro-function symbol)
|
||||
(setf (getf result :compiler-macro) nil))
|
||||
(when (type-specifier-p symbol)
|
||||
(setf (getf result :type) nil))
|
||||
(when (find-class symbol nil)
|
||||
(setf (getf result :class) nil))
|
||||
result))
|
||||
|
||||
(defun function-docstring (function-name)
|
||||
(let* ((definition (fdefinition function-name))
|
||||
(debug-info (sys.int::function-debug-info definition)))
|
||||
(sys.int::debug-info-docstring debug-info)))
|
||||
|
||||
;;;; Multithreading
|
||||
|
||||
;; FIXME: This should be a weak table.
|
||||
(defvar *thread-ids-for-emacs* (make-hash-table))
|
||||
(defvar *next-thread-id-for-emacs* 0)
|
||||
(defvar *thread-id-for-emacs-lock* (mezzano.supervisor:make-mutex
|
||||
"SWANK thread ID table"))
|
||||
|
||||
(defimplementation spawn (fn &key name)
|
||||
(mezzano.supervisor:make-thread fn :name name))
|
||||
|
||||
(defimplementation thread-id (thread)
|
||||
(mezzano.supervisor:with-mutex (*thread-id-for-emacs-lock*)
|
||||
(let ((id (gethash thread *thread-ids-for-emacs*)))
|
||||
(when (null id)
|
||||
(setf id (incf *next-thread-id-for-emacs*)
|
||||
(gethash thread *thread-ids-for-emacs*) id
|
||||
(gethash id *thread-ids-for-emacs*) thread))
|
||||
id)))
|
||||
|
||||
(defimplementation find-thread (id)
|
||||
(mezzano.supervisor:with-mutex (*thread-id-for-emacs-lock*)
|
||||
(gethash id *thread-ids-for-emacs*)))
|
||||
|
||||
(defimplementation thread-name (thread)
|
||||
(mezzano.supervisor:thread-name thread))
|
||||
|
||||
(defimplementation thread-status (thread)
|
||||
(format nil "~:(~A~)" (mezzano.supervisor:thread-state thread)))
|
||||
|
||||
(defimplementation current-thread ()
|
||||
(mezzano.supervisor:current-thread))
|
||||
|
||||
(defimplementation all-threads ()
|
||||
(mezzano.supervisor:all-threads))
|
||||
|
||||
(defimplementation thread-alive-p (thread)
|
||||
(not (eql (mezzano.supervisor:thread-state thread) :dead)))
|
||||
|
||||
(defimplementation interrupt-thread (thread fn)
|
||||
(mezzano.supervisor:establish-thread-foothold thread fn))
|
||||
|
||||
(defimplementation kill-thread (thread)
|
||||
;; Documentation says not to execute unwind-protected sections, but there's
|
||||
;; no way to do that.
|
||||
;; And killing threads at arbitrary points without unwinding them is a good
|
||||
;; way to hose the system.
|
||||
(mezzano.supervisor:terminate-thread thread))
|
||||
|
||||
(defvar *mailbox-lock* (mezzano.supervisor:make-mutex "mailbox lock"))
|
||||
(defvar *mailboxes* (list))
|
||||
|
||||
(defstruct (mailbox (:conc-name mailbox.))
|
||||
thread
|
||||
(mutex (mezzano.supervisor:make-mutex))
|
||||
(queue '() :type list))
|
||||
|
||||
(defun mailbox (thread)
|
||||
"Return THREAD's mailbox."
|
||||
;; Use weak pointers to avoid holding on to dead threads forever.
|
||||
(mezzano.supervisor:with-mutex (*mailbox-lock*)
|
||||
;; Flush forgotten threads.
|
||||
(setf *mailboxes*
|
||||
(remove-if-not #'sys.int::weak-pointer-value *mailboxes*))
|
||||
(loop
|
||||
for entry in *mailboxes*
|
||||
do
|
||||
(multiple-value-bind (key value livep)
|
||||
(sys.int::weak-pointer-pair entry)
|
||||
(when (eql key thread)
|
||||
(return value)))
|
||||
finally
|
||||
(let ((mb (make-mailbox :thread thread)))
|
||||
(push (sys.int::make-weak-pointer thread mb) *mailboxes*)
|
||||
(return mb)))))
|
||||
|
||||
(defimplementation send (thread message)
|
||||
(let* ((mbox (mailbox thread))
|
||||
(mutex (mailbox.mutex mbox)))
|
||||
(mezzano.supervisor:with-mutex (mutex)
|
||||
(setf (mailbox.queue mbox)
|
||||
(nconc (mailbox.queue mbox) (list message))))))
|
||||
|
||||
(defvar *receive-if-sleep-time* 0.02)
|
||||
|
||||
(defimplementation receive-if (test &optional timeout)
|
||||
(let* ((mbox (mailbox (current-thread)))
|
||||
(mutex (mailbox.mutex mbox)))
|
||||
(assert (or (not timeout) (eq timeout t)))
|
||||
(loop
|
||||
(check-slime-interrupts)
|
||||
(mezzano.supervisor:with-mutex (mutex)
|
||||
(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))))
|
||||
(sleep *receive-if-sleep-time*))))
|
||||
|
||||
(defvar *registered-threads* (make-hash-table))
|
||||
(defvar *registered-threads-lock*
|
||||
(mezzano.supervisor:make-mutex "registered threads lock"))
|
||||
|
||||
(defimplementation register-thread (name thread)
|
||||
(declare (type symbol name))
|
||||
(mezzano.supervisor:with-mutex (*registered-threads-lock*)
|
||||
(etypecase thread
|
||||
(null
|
||||
(remhash name *registered-threads*))
|
||||
(mezzano.supervisor:thread
|
||||
(setf (gethash name *registered-threads*) thread))))
|
||||
nil)
|
||||
|
||||
(defimplementation find-registered (name)
|
||||
(mezzano.supervisor:with-mutex (*registered-threads-lock*)
|
||||
(values (gethash name *registered-threads*))))
|
||||
|
||||
(defimplementation wait-for-input (streams &optional timeout)
|
||||
(loop
|
||||
(let ((ready '()))
|
||||
(dolist (s streams)
|
||||
(when (or (listen s)
|
||||
(and (typep s 'mezzano.network.tcp::tcp-stream)
|
||||
(mezzano.network.tcp::tcp-connection-closed-p s)))
|
||||
(push s ready)))
|
||||
(when ready
|
||||
(return ready))
|
||||
(when (check-slime-interrupts)
|
||||
(return :interrupt))
|
||||
(when timeout
|
||||
(return '()))
|
||||
(sleep 1)
|
||||
(when (numberp timeout)
|
||||
(decf timeout 1)
|
||||
(when (not (plusp timeout))
|
||||
(return '()))))))
|
||||
|
||||
;;;; Locks
|
||||
|
||||
(defstruct recursive-lock
|
||||
mutex
|
||||
(depth 0))
|
||||
|
||||
(defimplementation make-lock (&key name)
|
||||
(make-recursive-lock
|
||||
:mutex (mezzano.supervisor:make-mutex name)))
|
||||
|
||||
(defimplementation call-with-lock-held (lock function)
|
||||
(cond ((mezzano.supervisor:mutex-held-p
|
||||
(recursive-lock-mutex lock))
|
||||
(unwind-protect
|
||||
(progn (incf (recursive-lock-depth lock))
|
||||
(funcall function))
|
||||
(decf (recursive-lock-depth lock))))
|
||||
(t
|
||||
(mezzano.supervisor:with-mutex ((recursive-lock-mutex lock))
|
||||
(multiple-value-prog1
|
||||
(funcall function)
|
||||
(assert (eql (recursive-lock-depth lock) 0)))))))
|
||||
|
||||
;;;; Character names
|
||||
|
||||
(defimplementation character-completion-set (prefix matchp)
|
||||
;; TODO: Unicode characters too.
|
||||
(loop
|
||||
for names in sys.int::*char-name-alist*
|
||||
append
|
||||
(loop
|
||||
for name in (rest names)
|
||||
when (funcall matchp prefix name)
|
||||
collect name)))
|
||||
|
||||
;;;; Inspector
|
||||
|
||||
(defmethod emacs-inspect ((o function))
|
||||
(case (sys.int::%object-tag o)
|
||||
(#.sys.int::+object-tag-function+
|
||||
(label-value-line*
|
||||
(:name (sys.int::function-name o))
|
||||
(:arglist (arglist o))
|
||||
(:debug-info (sys.int::function-debug-info o))))
|
||||
(#.sys.int::+object-tag-closure+
|
||||
(append
|
||||
(label-value-line :function (sys.int::%closure-function o))
|
||||
`("Closed over values:" (:newline))
|
||||
(loop
|
||||
for i below (sys.int::%closure-length o)
|
||||
append (label-value-line i (sys.int::%closure-value o i)))))
|
||||
(t
|
||||
(call-next-method))))
|
||||
|
||||
(defmethod emacs-inspect ((o sys.int::weak-pointer))
|
||||
(label-value-line*
|
||||
(:key (sys.int::weak-pointer-key o))
|
||||
(:value (sys.int::weak-pointer-value o))))
|
||||
|
||||
(defmethod emacs-inspect ((o sys.int::function-reference))
|
||||
(label-value-line*
|
||||
(:name (sys.int::function-reference-name o))
|
||||
(:function (sys.int::function-reference-function o))))
|
||||
|
||||
(defmethod emacs-inspect ((object structure-object))
|
||||
(let ((class (class-of object)))
|
||||
`("Class: " (:value ,class) (:newline)
|
||||
,@(swank::all-slots-for-inspector object))))
|
||||
|
||||
(in-package :swank)
|
||||
|
||||
(defmethod all-slots-for-inspector ((object structure-object))
|
||||
(let* ((class (class-of object))
|
||||
(direct-slots (swank-mop:class-direct-slots class))
|
||||
(effective-slots (swank-mop:class-slots class))
|
||||
(longest-slot-name-length
|
||||
(loop for slot :in effective-slots
|
||||
maximize (length (symbol-name
|
||||
(swank-mop:slot-definition-name slot)))))
|
||||
(checklist
|
||||
(reinitialize-checklist
|
||||
(ensure-istate-metadata object :checklist
|
||||
(make-checklist (length effective-slots)))))
|
||||
(grouping-kind
|
||||
;; We box the value so we can re-set it.
|
||||
(ensure-istate-metadata object :grouping-kind
|
||||
(box *inspector-slots-default-grouping*)))
|
||||
(sort-order
|
||||
(ensure-istate-metadata object :sort-order
|
||||
(box *inspector-slots-default-order*)))
|
||||
(sort-predicate (ecase (ref sort-order)
|
||||
(:alphabetically #'string<)
|
||||
(:unsorted (constantly nil))))
|
||||
(sorted-slots (sort (copy-seq effective-slots)
|
||||
sort-predicate
|
||||
:key #'swank-mop:slot-definition-name))
|
||||
(effective-slots
|
||||
(ecase (ref grouping-kind)
|
||||
(:all sorted-slots)
|
||||
(:inheritance (stable-sort-by-inheritance sorted-slots
|
||||
class sort-predicate)))))
|
||||
`("--------------------"
|
||||
(:newline)
|
||||
" Group slots by inheritance "
|
||||
(:action ,(ecase (ref grouping-kind)
|
||||
(:all "[ ]")
|
||||
(:inheritance "[X]"))
|
||||
,(lambda ()
|
||||
;; We have to do this as the order of slots will
|
||||
;; be sorted differently.
|
||||
(fill (checklist.buttons checklist) nil)
|
||||
(setf (ref grouping-kind)
|
||||
(ecase (ref grouping-kind)
|
||||
(:all :inheritance)
|
||||
(:inheritance :all))))
|
||||
:refreshp t)
|
||||
(:newline)
|
||||
" Sort slots alphabetically "
|
||||
(:action ,(ecase (ref sort-order)
|
||||
(:unsorted "[ ]")
|
||||
(:alphabetically "[X]"))
|
||||
,(lambda ()
|
||||
(fill (checklist.buttons checklist) nil)
|
||||
(setf (ref sort-order)
|
||||
(ecase (ref sort-order)
|
||||
(:unsorted :alphabetically)
|
||||
(:alphabetically :unsorted))))
|
||||
:refreshp t)
|
||||
(:newline)
|
||||
,@ (case (ref grouping-kind)
|
||||
(:all
|
||||
`((:newline)
|
||||
"All Slots:"
|
||||
(:newline)
|
||||
,@(make-slot-listing checklist object class
|
||||
effective-slots direct-slots
|
||||
longest-slot-name-length)))
|
||||
(:inheritance
|
||||
(list-all-slots-by-inheritance checklist object class
|
||||
effective-slots direct-slots
|
||||
longest-slot-name-length)))
|
||||
(:newline)
|
||||
(:action "[set value]"
|
||||
,(lambda ()
|
||||
(do-checklist (idx checklist)
|
||||
(query-and-set-slot class object
|
||||
(nth idx effective-slots))))
|
||||
:refreshp t)
|
||||
" "
|
||||
(:action "[make unbound]"
|
||||
,(lambda ()
|
||||
(do-checklist (idx checklist)
|
||||
(swank-mop:slot-makunbound-using-class
|
||||
class object (nth idx effective-slots))))
|
||||
:refreshp t)
|
||||
(:newline))))
|
||||
933
sources_non_forked/slimv/slime/swank/mkcl.lisp
Normal file
933
sources_non_forked/slimv/slime/swank/mkcl.lisp
Normal file
@ -0,0 +1,933 @@
|
||||
;;;; -*- indent-tabs-mode: nil -*-
|
||||
;;;
|
||||
;;; swank-mkcl.lisp --- SLIME backend for MKCL.
|
||||
;;;
|
||||
;;; This code has been placed in the Public Domain. All warranties
|
||||
;;; are disclaimed.
|
||||
;;;
|
||||
|
||||
;;; Administrivia
|
||||
|
||||
(defpackage swank/mkcl
|
||||
(:use cl swank/backend))
|
||||
|
||||
(in-package swank/mkcl)
|
||||
|
||||
;;(declaim (optimize (debug 3)))
|
||||
|
||||
(defvar *tmp*)
|
||||
|
||||
(defimplementation gray-package-name ()
|
||||
'#:gray)
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel)
|
||||
|
||||
(swank/backend::import-swank-mop-symbols :clos
|
||||
;; '(:eql-specializer
|
||||
;; :eql-specializer-object
|
||||
;; :generic-function-declarations
|
||||
;; :specializer-direct-methods
|
||||
;; :compute-applicable-methods-using-classes)
|
||||
nil
|
||||
))
|
||||
|
||||
|
||||
;;; UTF8
|
||||
|
||||
(defimplementation string-to-utf8 (string)
|
||||
(mkcl:octets (si:utf-8 string)))
|
||||
|
||||
(defimplementation utf8-to-string (octets)
|
||||
(string (si:utf-8 octets)))
|
||||
|
||||
|
||||
;;;; TCP Server
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel)
|
||||
;; At compile-time we need access to the sb-bsd-sockets package for the
|
||||
;; the following code to be read properly.
|
||||
;; It is a bit a shame we have to load the entire module to get that.
|
||||
(require 'sockets))
|
||||
|
||||
|
||||
(defun resolve-hostname (name)
|
||||
(car (sb-bsd-sockets:host-ent-addresses
|
||||
(sb-bsd-sockets:get-host-by-name name))))
|
||||
|
||||
(defimplementation create-socket (host port &key backlog)
|
||||
(let ((socket (make-instance 'sb-bsd-sockets:inet-socket
|
||||
:type :stream
|
||||
:protocol :tcp)))
|
||||
(setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
|
||||
(sb-bsd-sockets:socket-bind socket (resolve-hostname host) port)
|
||||
(sb-bsd-sockets:socket-listen socket (or backlog 5))
|
||||
socket))
|
||||
|
||||
(defimplementation local-port (socket)
|
||||
(nth-value 1 (sb-bsd-sockets:socket-name socket)))
|
||||
|
||||
(defimplementation close-socket (socket)
|
||||
(sb-bsd-sockets:socket-close socket))
|
||||
|
||||
(defun accept (socket)
|
||||
"Like socket-accept, but retry on EINTR."
|
||||
(loop (handler-case
|
||||
(return (sb-bsd-sockets:socket-accept socket))
|
||||
(sb-bsd-sockets:interrupted-error ()))))
|
||||
|
||||
(defimplementation accept-connection (socket
|
||||
&key external-format
|
||||
buffering timeout)
|
||||
(declare (ignore timeout))
|
||||
(sb-bsd-sockets:socket-make-stream (accept socket)
|
||||
:output t ;; bogus
|
||||
:input t ;; bogus
|
||||
:buffering buffering ;; bogus
|
||||
:element-type (if external-format
|
||||
'character
|
||||
'(unsigned-byte 8))
|
||||
:external-format external-format
|
||||
))
|
||||
|
||||
(defimplementation preferred-communication-style ()
|
||||
:spawn
|
||||
)
|
||||
|
||||
(defvar *external-format-to-coding-system*
|
||||
'((:iso-8859-1
|
||||
"latin-1" "latin-1-unix" "iso-latin-1-unix"
|
||||
"iso-8859-1" "iso-8859-1-unix")
|
||||
(:utf-8 "utf-8" "utf-8-unix")))
|
||||
|
||||
(defun external-format (coding-system)
|
||||
(or (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
|
||||
*external-format-to-coding-system*))
|
||||
(find coding-system (si:all-encodings) :test #'string-equal)))
|
||||
|
||||
(defimplementation find-external-format (coding-system)
|
||||
#+unicode (external-format coding-system)
|
||||
;; Without unicode support, MKCL uses the one-byte encoding of the
|
||||
;; underlying OS, and will barf on anything except :DEFAULT. We
|
||||
;; return NIL here for known multibyte encodings, so
|
||||
;; SWANK:CREATE-SERVER will barf.
|
||||
#-unicode (let ((xf (external-format coding-system)))
|
||||
(if (member xf '(:utf-8))
|
||||
nil
|
||||
:default)))
|
||||
|
||||
|
||||
|
||||
;;;; Unix signals
|
||||
|
||||
(defimplementation install-sigint-handler (handler)
|
||||
(let ((old-handler (symbol-function 'si:terminal-interrupt)))
|
||||
(setf (symbol-function 'si:terminal-interrupt)
|
||||
(if (consp handler)
|
||||
(car handler)
|
||||
(lambda (&rest args)
|
||||
(declare (ignore args))
|
||||
(funcall handler)
|
||||
(continue))))
|
||||
(list old-handler)))
|
||||
|
||||
|
||||
(defimplementation getpid ()
|
||||
(mkcl:getpid))
|
||||
|
||||
(defimplementation set-default-directory (directory)
|
||||
(mk-ext::chdir (namestring directory))
|
||||
(default-directory))
|
||||
|
||||
(defimplementation default-directory ()
|
||||
(namestring (mk-ext:getcwd)))
|
||||
|
||||
(defmacro progf (plist &rest forms)
|
||||
`(let (_vars _vals)
|
||||
(do ((p ,plist (cddr p)))
|
||||
((endp p))
|
||||
(push (car p) _vars)
|
||||
(push (cadr p) _vals))
|
||||
(progv _vars _vals ,@forms)
|
||||
)
|
||||
)
|
||||
|
||||
(defvar *inferior-lisp-sleeping-post* nil)
|
||||
|
||||
(defimplementation quit-lisp ()
|
||||
(progf (ignore-errors (eval (read-from-string "swank::*saved-global-streams*"))) ;; restore original IO streams.
|
||||
(when *inferior-lisp-sleeping-post* (mt:semaphore-signal *inferior-lisp-sleeping-post*))
|
||||
;;(mk-ext:quit :verbose t)
|
||||
))
|
||||
|
||||
|
||||
;;;; Compilation
|
||||
|
||||
(defvar *buffer-name* nil)
|
||||
(defvar *buffer-start-position*)
|
||||
(defvar *buffer-string*)
|
||||
(defvar *compile-filename*)
|
||||
|
||||
(defun signal-compiler-condition (&rest args)
|
||||
(signal (apply #'make-condition 'compiler-condition args)))
|
||||
|
||||
#|
|
||||
(defun handle-compiler-warning (condition)
|
||||
(signal-compiler-condition
|
||||
:original-condition condition
|
||||
:message (format nil "~A" condition)
|
||||
:severity :warning
|
||||
:location
|
||||
(if *buffer-name*
|
||||
(make-location (list :buffer *buffer-name*)
|
||||
(list :offset *buffer-start-position* 0))
|
||||
;; ;; compiler::*current-form*
|
||||
;; (if compiler::*current-function*
|
||||
;; (make-location (list :file *compile-filename*)
|
||||
;; (list :function-name
|
||||
;; (symbol-name
|
||||
;; (slot-value compiler::*current-function*
|
||||
;; 'compiler::name))))
|
||||
(list :error "No location found.")
|
||||
;; )
|
||||
)))
|
||||
|#
|
||||
|
||||
#|
|
||||
(defun condition-location (condition)
|
||||
(let ((file (compiler:compiler-message-file condition))
|
||||
(position (compiler:compiler-message-file-position condition)))
|
||||
(if (and position (not (minusp position)))
|
||||
(if *buffer-name*
|
||||
(make-buffer-location *buffer-name*
|
||||
*buffer-start-position*
|
||||
position)
|
||||
(make-file-location file position))
|
||||
(make-error-location "No location found."))))
|
||||
|#
|
||||
|
||||
(defun condition-location (condition)
|
||||
(if *buffer-name*
|
||||
(make-location (list :buffer *buffer-name*)
|
||||
(list :offset *buffer-start-position* 0))
|
||||
;; ;; compiler::*current-form* ;
|
||||
;; (if compiler::*current-function* ;
|
||||
;; (make-location (list :file *compile-filename*) ;
|
||||
;; (list :function-name ;
|
||||
;; (symbol-name ;
|
||||
;; (slot-value compiler::*current-function* ;
|
||||
;; 'compiler::name)))) ;
|
||||
(if (typep condition 'compiler::compiler-message)
|
||||
(make-location (list :file (namestring (compiler:compiler-message-file condition)))
|
||||
(list :end-position (compiler:compiler-message-file-end-position condition)))
|
||||
(list :error "No location found."))
|
||||
)
|
||||
)
|
||||
|
||||
(defun handle-compiler-message (condition)
|
||||
(unless (typep condition 'compiler::compiler-note)
|
||||
(signal-compiler-condition
|
||||
:original-condition condition
|
||||
:message (princ-to-string condition)
|
||||
:severity (etypecase condition
|
||||
(compiler:compiler-fatal-error :error)
|
||||
(compiler:compiler-error :error)
|
||||
(error :error)
|
||||
(style-warning :style-warning)
|
||||
(warning :warning))
|
||||
:location (condition-location condition))))
|
||||
|
||||
(defimplementation call-with-compilation-hooks (function)
|
||||
(handler-bind ((compiler:compiler-message #'handle-compiler-message))
|
||||
(funcall function)))
|
||||
|
||||
(defimplementation swank-compile-file (input-file output-file
|
||||
load-p external-format
|
||||
&key policy)
|
||||
(declare (ignore policy))
|
||||
(with-compilation-hooks ()
|
||||
(let ((*buffer-name* nil)
|
||||
(*compile-filename* input-file))
|
||||
(handler-bind (#|
|
||||
(compiler::compiler-note
|
||||
#'(lambda (n)
|
||||
(format t "~%swank saw a compiler note: ~A~%" n) (finish-output) nil))
|
||||
(compiler::compiler-warning
|
||||
#'(lambda (w)
|
||||
(format t "~%swank saw a compiler warning: ~A~%" w) (finish-output) nil))
|
||||
(compiler::compiler-error
|
||||
#'(lambda (e)
|
||||
(format t "~%swank saw a compiler error: ~A~%" e) (finish-output) nil))
|
||||
|#
|
||||
)
|
||||
(multiple-value-bind (output-truename warnings-p failure-p)
|
||||
(compile-file input-file :output-file output-file :external-format external-format)
|
||||
(values output-truename warnings-p
|
||||
(or failure-p
|
||||
(and load-p (not (load output-truename))))))))))
|
||||
|
||||
(defimplementation swank-compile-string (string &key buffer position filename line column policy)
|
||||
(declare (ignore filename line column policy))
|
||||
(with-compilation-hooks ()
|
||||
(let ((*buffer-name* buffer)
|
||||
(*buffer-start-position* position)
|
||||
(*buffer-string* string))
|
||||
(with-input-from-string (s string)
|
||||
(when position (file-position position))
|
||||
(compile-from-stream s)))))
|
||||
|
||||
(defun compile-from-stream (stream)
|
||||
(let ((file (mkcl:mkstemp "TMP:MKCL-SWANK-TMPXXXXXX"))
|
||||
output-truename
|
||||
warnings-p
|
||||
failure-p
|
||||
)
|
||||
(with-open-file (s file :direction :output :if-exists :overwrite)
|
||||
(do ((line (read-line stream nil) (read-line stream nil)))
|
||||
((not line))
|
||||
(write-line line s)))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(multiple-value-setq (output-truename warnings-p failure-p)
|
||||
(compile-file file))
|
||||
(and (not failure-p) (load output-truename)))
|
||||
(when (probe-file file) (delete-file file))
|
||||
(when (probe-file output-truename) (delete-file output-truename)))))
|
||||
|
||||
|
||||
;;;; Documentation
|
||||
|
||||
(defun grovel-docstring-for-arglist (name type)
|
||||
(flet ((compute-arglist-offset (docstring)
|
||||
(when docstring
|
||||
(let ((pos1 (search "Args: " docstring)))
|
||||
(if pos1
|
||||
(+ pos1 6)
|
||||
(let ((pos2 (search "Syntax: " docstring)))
|
||||
(when pos2
|
||||
(+ pos2 8))))))))
|
||||
(let* ((docstring (si::get-documentation name type))
|
||||
(pos (compute-arglist-offset docstring)))
|
||||
(if pos
|
||||
(multiple-value-bind (arglist errorp)
|
||||
(ignore-errors
|
||||
(values (read-from-string docstring t nil :start pos)))
|
||||
(if (or errorp (not (listp arglist)))
|
||||
:not-available
|
||||
arglist
|
||||
))
|
||||
:not-available ))))
|
||||
|
||||
(defimplementation arglist (name)
|
||||
(cond ((and (symbolp name) (special-operator-p name))
|
||||
(let ((arglist (grovel-docstring-for-arglist name 'function)))
|
||||
(if (consp arglist) (cdr arglist) arglist)))
|
||||
((and (symbolp name) (macro-function name))
|
||||
(let ((arglist (grovel-docstring-for-arglist name 'function)))
|
||||
(if (consp arglist) (cdr arglist) arglist)))
|
||||
((or (functionp name) (fboundp name))
|
||||
(multiple-value-bind (name fndef)
|
||||
(if (functionp name)
|
||||
(values (function-name name) name)
|
||||
(values name (fdefinition name)))
|
||||
(let ((fle (function-lambda-expression fndef)))
|
||||
(case (car fle)
|
||||
(si:lambda-block (caddr fle))
|
||||
(t (typecase fndef
|
||||
(generic-function (clos::generic-function-lambda-list fndef))
|
||||
(compiled-function (grovel-docstring-for-arglist name 'function))
|
||||
(function :not-available)))))))
|
||||
(t :not-available)))
|
||||
|
||||
(defimplementation function-name (f)
|
||||
(si:compiled-function-name f)
|
||||
)
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel)
|
||||
;; At compile-time we need access to the walker package for the
|
||||
;; the following code to be read properly.
|
||||
;; It is a bit a shame we have to load the entire module to get that.
|
||||
(require 'walker))
|
||||
|
||||
(defimplementation macroexpand-all (form &optional env)
|
||||
(declare (ignore env))
|
||||
(walker:macroexpand-all form))
|
||||
|
||||
(defimplementation describe-symbol-for-emacs (symbol)
|
||||
(let ((result '()))
|
||||
(dolist (type '(:VARIABLE :FUNCTION :CLASS))
|
||||
(let ((doc (describe-definition symbol type)))
|
||||
(when doc
|
||||
(setf result (list* type doc result)))))
|
||||
result))
|
||||
|
||||
(defimplementation describe-definition (name type)
|
||||
(case type
|
||||
(:variable (documentation name 'variable))
|
||||
(:function (documentation name 'function))
|
||||
(:class (documentation name 'class))
|
||||
(t nil)))
|
||||
|
||||
;;; Debugging
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel)
|
||||
(import
|
||||
'(si::*break-env*
|
||||
si::*ihs-top*
|
||||
si::*ihs-current*
|
||||
si::*ihs-base*
|
||||
si::*frs-base*
|
||||
si::*frs-top*
|
||||
si::*tpl-commands*
|
||||
si::*tpl-level*
|
||||
si::frs-top
|
||||
si::ihs-top
|
||||
si::ihs-fun
|
||||
si::ihs-env
|
||||
si::sch-frs-base
|
||||
si::set-break-env
|
||||
si::set-current-ihs
|
||||
si::tpl-commands)))
|
||||
|
||||
(defvar *backtrace* '())
|
||||
|
||||
(defun in-swank-package-p (x)
|
||||
(and
|
||||
(symbolp x)
|
||||
(member (symbol-package x)
|
||||
(list #.(find-package :swank)
|
||||
#.(find-package :swank/backend)
|
||||
#.(ignore-errors (find-package :swank-mop))
|
||||
#.(ignore-errors (find-package :swank-loader))))
|
||||
t))
|
||||
|
||||
(defun is-swank-source-p (name)
|
||||
(setf name (pathname name))
|
||||
#+(or)
|
||||
(pathname-match-p
|
||||
name
|
||||
(make-pathname :defaults swank-loader::*source-directory*
|
||||
:name (pathname-name name)
|
||||
:type (pathname-type name)
|
||||
:version (pathname-version name)))
|
||||
nil)
|
||||
|
||||
(defun is-ignorable-fun-p (x)
|
||||
(or
|
||||
(in-swank-package-p (frame-name x))
|
||||
(multiple-value-bind (file position)
|
||||
(ignore-errors (si::compiled-function-file (car x)))
|
||||
(declare (ignore position))
|
||||
(if file (is-swank-source-p file)))))
|
||||
|
||||
(defmacro find-ihs-top (x)
|
||||
(declare (ignore x))
|
||||
'(si::ihs-top))
|
||||
|
||||
(defimplementation call-with-debugging-environment (debugger-loop-fn)
|
||||
(declare (type function debugger-loop-fn))
|
||||
(let* (;;(*tpl-commands* si::tpl-commands)
|
||||
(*ihs-base* 0)
|
||||
(*ihs-top* (find-ihs-top 'call-with-debugging-environment))
|
||||
(*ihs-current* *ihs-top*)
|
||||
(*frs-base* (or (sch-frs-base 0 #|*frs-top*|# *ihs-base*) (1+ (frs-top))))
|
||||
(*frs-top* (frs-top))
|
||||
(*read-suppress* nil)
|
||||
;;(*tpl-level* (1+ *tpl-level*))
|
||||
(*backtrace* (loop for ihs from 0 below *ihs-top*
|
||||
collect (list (si::ihs-fun ihs)
|
||||
(si::ihs-env ihs)
|
||||
nil))))
|
||||
(declare (special *ihs-current*))
|
||||
(loop for f from *frs-base* to *frs-top*
|
||||
do (let ((i (- (si::frs-ihs f) *ihs-base* 1)))
|
||||
(when (plusp i)
|
||||
(let* ((x (elt *backtrace* i))
|
||||
(name (si::frs-tag f)))
|
||||
(unless (mkcl:fixnump name)
|
||||
(push name (third x)))))))
|
||||
(setf *backtrace* (remove-if #'is-ignorable-fun-p (nreverse *backtrace*)))
|
||||
(setf *tmp* *backtrace*)
|
||||
(set-break-env)
|
||||
(set-current-ihs)
|
||||
(let ((*ihs-base* *ihs-top*))
|
||||
(funcall debugger-loop-fn))))
|
||||
|
||||
(defimplementation call-with-debugger-hook (hook fun)
|
||||
(let ((*debugger-hook* hook)
|
||||
(*ihs-base* (find-ihs-top 'call-with-debugger-hook)))
|
||||
(funcall fun)))
|
||||
|
||||
(defimplementation compute-backtrace (start end)
|
||||
(when (numberp end)
|
||||
(setf end (min end (length *backtrace*))))
|
||||
(loop for f in (subseq *backtrace* start end)
|
||||
collect f))
|
||||
|
||||
(defimplementation format-sldb-condition (condition)
|
||||
"Format a condition for display in SLDB."
|
||||
;;(princ-to-string condition)
|
||||
(format nil "~A~%In thread: ~S" condition mt:*thread*)
|
||||
)
|
||||
|
||||
(defun frame-name (frame)
|
||||
(let ((x (first frame)))
|
||||
(if (symbolp x)
|
||||
x
|
||||
(function-name x))))
|
||||
|
||||
(defun function-position (fun)
|
||||
(multiple-value-bind (file position)
|
||||
(si::compiled-function-file fun)
|
||||
(and file (make-location
|
||||
`(:file ,(if (stringp file) file (namestring file)))
|
||||
;;`(:position ,position)
|
||||
`(:end-position , position)))))
|
||||
|
||||
(defun frame-function (frame)
|
||||
(let* ((x (first frame))
|
||||
fun position)
|
||||
(etypecase x
|
||||
(symbol (and (fboundp x)
|
||||
(setf fun (fdefinition x)
|
||||
position (function-position fun))))
|
||||
(function (setf fun x position (function-position x))))
|
||||
(values fun position)))
|
||||
|
||||
(defun frame-decode-env (frame)
|
||||
(let ((functions '())
|
||||
(blocks '())
|
||||
(variables '()))
|
||||
(setf frame (si::decode-ihs-env (second frame)))
|
||||
(dolist (record frame)
|
||||
(let* ((record0 (car record))
|
||||
(record1 (cdr record)))
|
||||
(cond ((or (symbolp record0) (stringp record0))
|
||||
(setq variables (acons record0 record1 variables)))
|
||||
((not (mkcl:fixnump record0))
|
||||
(push record1 functions))
|
||||
((symbolp record1)
|
||||
(push record1 blocks))
|
||||
(t
|
||||
))))
|
||||
(values functions blocks variables)))
|
||||
|
||||
(defimplementation print-frame (frame stream)
|
||||
(let ((function (first frame)))
|
||||
(let ((fname
|
||||
;;; (cond ((symbolp function) function)
|
||||
;;; ((si:instancep function) (slot-value function 'name))
|
||||
;;; ((compiled-function-p function)
|
||||
;;; (or (si::compiled-function-name function) 'lambda))
|
||||
;;; (t :zombi))
|
||||
(si::get-fname function)
|
||||
))
|
||||
(if (eq fname 'si::bytecode)
|
||||
(format stream "~A [Evaluation of: ~S]"
|
||||
fname (function-lambda-expression function))
|
||||
(format stream "~A" fname)
|
||||
)
|
||||
(when (si::closurep function)
|
||||
(format stream
|
||||
", closure generated from ~A"
|
||||
(si::get-fname (si:closure-producer function)))
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
(defimplementation frame-source-location (frame-number)
|
||||
(nth-value 1 (frame-function (elt *backtrace* frame-number))))
|
||||
|
||||
(defimplementation frame-catch-tags (frame-number)
|
||||
(third (elt *backtrace* frame-number)))
|
||||
|
||||
(defimplementation frame-locals (frame-number)
|
||||
(loop for (name . value) in (nth-value 2 (frame-decode-env (elt *backtrace* frame-number)))
|
||||
with i = 0
|
||||
collect (list :name name :id (prog1 i (incf i)) :value value)))
|
||||
|
||||
(defimplementation frame-var-value (frame-number var-id)
|
||||
(cdr (elt (nth-value 2 (frame-decode-env (elt *backtrace* frame-number))) var-id)))
|
||||
|
||||
(defimplementation disassemble-frame (frame-number)
|
||||
(let ((fun (frame-fun (elt *backtrace* frame-number))))
|
||||
(disassemble fun)))
|
||||
|
||||
(defimplementation eval-in-frame (form frame-number)
|
||||
(let ((env (second (elt *backtrace* frame-number))))
|
||||
(si:eval-in-env form env)))
|
||||
|
||||
#|
|
||||
(defimplementation gdb-initial-commands ()
|
||||
;; These signals are used by the GC.
|
||||
#+linux '("handle SIGPWR noprint nostop"
|
||||
"handle SIGXCPU noprint nostop"))
|
||||
|
||||
(defimplementation command-line-args ()
|
||||
(loop for n from 0 below (si:argc) collect (si:argv n)))
|
||||
|#
|
||||
|
||||
;;;; Inspector
|
||||
|
||||
(defmethod emacs-inspect ((o t))
|
||||
; ecl clos support leaves some to be desired
|
||||
(cond
|
||||
((streamp o)
|
||||
(list*
|
||||
(format nil "~S is an ordinary stream~%" o)
|
||||
(append
|
||||
(list
|
||||
"Open for "
|
||||
(cond
|
||||
((ignore-errors (interactive-stream-p o)) "Interactive")
|
||||
((and (input-stream-p o) (output-stream-p o)) "Input and output")
|
||||
((input-stream-p o) "Input")
|
||||
((output-stream-p o) "Output"))
|
||||
`(:newline) `(:newline))
|
||||
(label-value-line*
|
||||
("Element type" (stream-element-type o))
|
||||
("External format" (stream-external-format o)))
|
||||
(ignore-errors (label-value-line*
|
||||
("Broadcast streams" (broadcast-stream-streams o))))
|
||||
(ignore-errors (label-value-line*
|
||||
("Concatenated streams" (concatenated-stream-streams o))))
|
||||
(ignore-errors (label-value-line*
|
||||
("Echo input stream" (echo-stream-input-stream o))))
|
||||
(ignore-errors (label-value-line*
|
||||
("Echo output stream" (echo-stream-output-stream o))))
|
||||
(ignore-errors (label-value-line*
|
||||
("Output String" (get-output-stream-string o))))
|
||||
(ignore-errors (label-value-line*
|
||||
("Synonym symbol" (synonym-stream-symbol o))))
|
||||
(ignore-errors (label-value-line*
|
||||
("Input stream" (two-way-stream-input-stream o))))
|
||||
(ignore-errors (label-value-line*
|
||||
("Output stream" (two-way-stream-output-stream o)))))))
|
||||
((si:instancep o) ;;t
|
||||
(let* ((cl (si:instance-class o))
|
||||
(slots (clos::class-slots cl)))
|
||||
(list* (format nil "~S is an instance of class ~A~%"
|
||||
o (clos::class-name cl))
|
||||
(loop for x in slots append
|
||||
(let* ((name (clos::slot-definition-name x))
|
||||
(value (if (slot-boundp o name)
|
||||
(clos::slot-value o name)
|
||||
"Unbound"
|
||||
)))
|
||||
(list
|
||||
(format nil "~S: " name)
|
||||
`(:value ,value)
|
||||
`(:newline)))))))
|
||||
(t (list (format nil "~A" o)))))
|
||||
|
||||
;;;; Definitions
|
||||
|
||||
(defimplementation find-definitions (name)
|
||||
(if (fboundp name)
|
||||
(let ((tmp (find-source-location (symbol-function name))))
|
||||
`(((defun ,name) ,tmp)))))
|
||||
|
||||
(defimplementation find-source-location (obj)
|
||||
(setf *tmp* obj)
|
||||
(or
|
||||
(typecase obj
|
||||
(function
|
||||
(multiple-value-bind (file pos) (ignore-errors (si::compiled-function-file obj))
|
||||
(if (and file pos)
|
||||
(make-location
|
||||
`(:file ,(if (stringp file) file (namestring file)))
|
||||
`(:end-position ,pos) ;; `(:position ,pos)
|
||||
`(:snippet
|
||||
,(with-open-file (s file)
|
||||
(file-position s pos)
|
||||
(skip-comments-and-whitespace s)
|
||||
(read-snippet s))))))))
|
||||
`(:error (format nil "Source definition of ~S not found" obj))))
|
||||
|
||||
;;;; Profiling
|
||||
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel)
|
||||
;; At compile-time we need access to the profile package for the
|
||||
;; the following code to be read properly.
|
||||
;; It is a bit a shame we have to load the entire module to get that.
|
||||
(require 'profile))
|
||||
|
||||
|
||||
(defimplementation profile (fname)
|
||||
(when fname (eval `(profile:profile ,fname))))
|
||||
|
||||
(defimplementation unprofile (fname)
|
||||
(when fname (eval `(profile:unprofile ,fname))))
|
||||
|
||||
(defimplementation unprofile-all ()
|
||||
(profile:unprofile-all)
|
||||
"All functions unprofiled.")
|
||||
|
||||
(defimplementation profile-report ()
|
||||
(profile:report))
|
||||
|
||||
(defimplementation profile-reset ()
|
||||
(profile:reset)
|
||||
"Reset profiling counters.")
|
||||
|
||||
(defimplementation profiled-functions ()
|
||||
(profile:profile))
|
||||
|
||||
(defimplementation profile-package (package callers methods)
|
||||
(declare (ignore callers methods))
|
||||
(eval `(profile:profile ,(package-name (find-package package)))))
|
||||
|
||||
|
||||
;;;; Threads
|
||||
|
||||
(defvar *thread-id-counter* 0)
|
||||
|
||||
(defvar *thread-id-counter-lock*
|
||||
(mt:make-lock :name "thread id counter lock"))
|
||||
|
||||
(defun next-thread-id ()
|
||||
(mt:with-lock (*thread-id-counter-lock*)
|
||||
(incf *thread-id-counter*))
|
||||
)
|
||||
|
||||
(defparameter *thread-id-map* (make-hash-table))
|
||||
(defparameter *id-thread-map* (make-hash-table))
|
||||
|
||||
(defvar *thread-id-map-lock*
|
||||
(mt:make-lock :name "thread id map lock"))
|
||||
|
||||
(defparameter +default-thread-local-variables+
|
||||
'(*macroexpand-hook*
|
||||
*default-pathname-defaults*
|
||||
*readtable*
|
||||
*random-state*
|
||||
*compile-print*
|
||||
*compile-verbose*
|
||||
*load-print*
|
||||
*load-verbose*
|
||||
*print-array*
|
||||
*print-base*
|
||||
*print-case*
|
||||
*print-circle*
|
||||
*print-escape*
|
||||
*print-gensym*
|
||||
*print-length*
|
||||
*print-level*
|
||||
*print-lines*
|
||||
*print-miser-width*
|
||||
*print-pprint-dispatch*
|
||||
*print-pretty*
|
||||
*print-radix*
|
||||
*print-readably*
|
||||
*print-right-margin*
|
||||
*read-base*
|
||||
*read-default-float-format*
|
||||
*read-eval*
|
||||
*read-suppress*
|
||||
))
|
||||
|
||||
(defun thread-local-default-bindings ()
|
||||
(let (local)
|
||||
(dolist (var +default-thread-local-variables+ local)
|
||||
(setq local (acons var (symbol-value var) local))
|
||||
)))
|
||||
|
||||
;; mkcl doesn't have weak pointers
|
||||
(defimplementation spawn (fn &key name initial-bindings)
|
||||
(let* ((local-defaults (thread-local-default-bindings))
|
||||
(thread
|
||||
;;(mt:make-thread :name name)
|
||||
(mt:make-thread :name name
|
||||
:initial-bindings (nconc initial-bindings
|
||||
local-defaults))
|
||||
)
|
||||
(id (next-thread-id)))
|
||||
(mt:with-lock (*thread-id-map-lock*)
|
||||
(setf (gethash id *thread-id-map*) thread)
|
||||
(setf (gethash thread *id-thread-map*) id))
|
||||
(mt:thread-preset
|
||||
thread
|
||||
#'(lambda ()
|
||||
(unwind-protect
|
||||
(progn
|
||||
;;(format t "~&Starting thread: ~S.~%" name) (finish-output)
|
||||
(mt:thread-detach nil)
|
||||
(funcall fn))
|
||||
(progn
|
||||
;;(format t "~&Wrapping up thread: ~S.~%" name) (finish-output)
|
||||
(mt:with-lock (*thread-id-map-lock*)
|
||||
(remhash thread *id-thread-map*)
|
||||
(remhash id *thread-id-map*))
|
||||
;;(format t "~&Finished thread: ~S~%" name) (finish-output)
|
||||
))))
|
||||
(mt:thread-enable thread)
|
||||
(mt:thread-yield)
|
||||
thread
|
||||
))
|
||||
|
||||
(defimplementation thread-id (thread)
|
||||
(block thread-id
|
||||
(mt:with-lock (*thread-id-map-lock*)
|
||||
(or (gethash thread *id-thread-map*)
|
||||
(let ((id (next-thread-id)))
|
||||
(setf (gethash id *thread-id-map*) thread)
|
||||
(setf (gethash thread *id-thread-map*) id)
|
||||
id)))))
|
||||
|
||||
(defimplementation find-thread (id)
|
||||
(mt:with-lock (*thread-id-map-lock*)
|
||||
(gethash id *thread-id-map*)))
|
||||
|
||||
(defimplementation thread-name (thread)
|
||||
(mt:thread-name thread))
|
||||
|
||||
(defimplementation thread-status (thread)
|
||||
(if (mt:thread-active-p thread)
|
||||
"RUNNING"
|
||||
"STOPPED"))
|
||||
|
||||
(defimplementation make-lock (&key name)
|
||||
(mt:make-lock :name name :recursive t))
|
||||
|
||||
(defimplementation call-with-lock-held (lock function)
|
||||
(declare (type function function))
|
||||
(mt:with-lock (lock) (funcall function)))
|
||||
|
||||
(defimplementation current-thread ()
|
||||
mt:*thread*)
|
||||
|
||||
(defimplementation all-threads ()
|
||||
(mt:all-threads))
|
||||
|
||||
(defimplementation interrupt-thread (thread fn)
|
||||
(mt:interrupt-thread thread fn))
|
||||
|
||||
(defimplementation kill-thread (thread)
|
||||
(mt:interrupt-thread thread #'mt:terminate-thread)
|
||||
)
|
||||
|
||||
(defimplementation thread-alive-p (thread)
|
||||
(mt:thread-active-p thread))
|
||||
|
||||
(defvar *mailbox-lock* (mt:make-lock :name "mailbox lock"))
|
||||
(defvar *mailboxes* (list))
|
||||
(declaim (type list *mailboxes*))
|
||||
|
||||
(defstruct (mailbox (:conc-name mailbox.))
|
||||
thread
|
||||
locked-by
|
||||
(mutex (mt:make-lock :name "thread mailbox"))
|
||||
(semaphore (mt:make-semaphore))
|
||||
(queue '() :type list))
|
||||
|
||||
(defun mailbox (thread)
|
||||
"Return THREAD's mailbox."
|
||||
(mt:with-lock (*mailbox-lock*)
|
||||
(or (find thread *mailboxes* :key #'mailbox.thread)
|
||||
(let ((mb (make-mailbox :thread thread)))
|
||||
(push mb *mailboxes*)
|
||||
mb))))
|
||||
|
||||
(defimplementation send (thread message)
|
||||
(handler-case
|
||||
(let* ((mbox (mailbox thread))
|
||||
(mutex (mailbox.mutex mbox)))
|
||||
;; (mt:interrupt-thread
|
||||
;; thread
|
||||
;; (lambda ()
|
||||
;; (mt:with-lock (mutex)
|
||||
;; (setf (mailbox.queue mbox)
|
||||
;; (nconc (mailbox.queue mbox) (list message))))))
|
||||
|
||||
;; (format t "~&! thread = ~S~% thread = ~S~% message = ~S~%"
|
||||
;; mt:*thread* thread message) (finish-output)
|
||||
(mt:with-lock (mutex)
|
||||
(setf (mailbox.locked-by mbox) mt:*thread*)
|
||||
(setf (mailbox.queue mbox)
|
||||
(nconc (mailbox.queue mbox) (list message)))
|
||||
;;(format t "*") (finish-output)
|
||||
(handler-case
|
||||
(mt:semaphore-signal (mailbox.semaphore mbox))
|
||||
(condition (condition)
|
||||
(format t "Something went bad with semaphore-signal ~A" condition) (finish-output)
|
||||
;;(break)
|
||||
))
|
||||
(setf (mailbox.locked-by mbox) nil)
|
||||
)
|
||||
;;(format t "+") (finish-output)
|
||||
)
|
||||
(condition (condition)
|
||||
(format t "~&Error in send: ~S~%" condition) (finish-output))
|
||||
)
|
||||
)
|
||||
|
||||
;; (defimplementation receive ()
|
||||
;; (block got-mail
|
||||
;; (let* ((mbox (mailbox mt:*thread*))
|
||||
;; (mutex (mailbox.mutex mbox)))
|
||||
;; (loop
|
||||
;; (mt:with-lock (mutex)
|
||||
;; (if (mailbox.queue mbox)
|
||||
;; (return-from got-mail (pop (mailbox.queue mbox)))))
|
||||
;; ;;interrupt-thread will halt this if it takes longer than 1sec
|
||||
;; (sleep 1)))))
|
||||
|
||||
|
||||
(defimplementation receive-if (test &optional timeout)
|
||||
(handler-case
|
||||
(let* ((mbox (mailbox (current-thread)))
|
||||
(mutex (mailbox.mutex mbox))
|
||||
got-one)
|
||||
(assert (or (not timeout) (eq timeout t)))
|
||||
(loop
|
||||
(check-slime-interrupts)
|
||||
;;(format t "~&: ~S~%" mt:*thread*) (finish-output)
|
||||
(handler-case
|
||||
(setq got-one (mt:semaphore-wait (mailbox.semaphore mbox) 2))
|
||||
(condition (condition)
|
||||
(format t "~&In (swank-mkcl) receive-if: Something went bad with semaphore-wait ~A~%" condition)
|
||||
(finish-output)
|
||||
nil
|
||||
)
|
||||
)
|
||||
(mt:with-lock (mutex)
|
||||
(setf (mailbox.locked-by mbox) mt:*thread*)
|
||||
(let* ((q (mailbox.queue mbox))
|
||||
(tail (member-if test q)))
|
||||
(when tail
|
||||
(setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
|
||||
(setf (mailbox.locked-by mbox) nil)
|
||||
;;(format t "~&thread ~S received: ~S~%" mt:*thread* (car tail))
|
||||
(return (car tail))))
|
||||
(setf (mailbox.locked-by mbox) nil)
|
||||
)
|
||||
|
||||
;;(format t "/ ~S~%" mt:*thread*) (finish-output)
|
||||
(when (eq timeout t) (return (values nil t)))
|
||||
;; (unless got-one
|
||||
;; (format t "~&In (swank-mkcl) receive-if: semaphore-wait timed out!~%"))
|
||||
)
|
||||
)
|
||||
(condition (condition)
|
||||
(format t "~&Error in (swank-mkcl) receive-if: ~S, ~A~%" condition condition) (finish-output)
|
||||
nil
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
(defmethod stream-finish-output ((stream stream))
|
||||
(finish-output stream))
|
||||
|
||||
|
||||
;;
|
||||
|
||||
;;#+windows
|
||||
(defimplementation doze-in-repl ()
|
||||
(setq *inferior-lisp-sleeping-post* (mt:make-semaphore))
|
||||
;;(loop (sleep 1))
|
||||
(mt:semaphore-wait *inferior-lisp-sleeping-post*)
|
||||
(mk-ext:quit :verbose t)
|
||||
)
|
||||
|
||||
162
sources_non_forked/slimv/slime/swank/rpc.lisp
Normal file
162
sources_non_forked/slimv/slime/swank/rpc.lisp
Normal file
@ -0,0 +1,162 @@
|
||||
;;; -*- indent-tabs-mode: nil; coding: latin-1-unix -*-
|
||||
;;;
|
||||
;;; swank-rpc.lisp -- Pass remote calls and responses between lisp systems.
|
||||
;;;
|
||||
;;; Created 2010, Terje Norderhaug <terje@in-progress.com>
|
||||
;;;
|
||||
;;; This code has been placed in the Public Domain. All warranties
|
||||
;;; are disclaimed.
|
||||
;;;
|
||||
|
||||
(in-package swank/rpc)
|
||||
|
||||
|
||||
;;;;; Input
|
||||
|
||||
(define-condition swank-reader-error (reader-error)
|
||||
((packet :type string :initarg :packet
|
||||
:reader swank-reader-error.packet)
|
||||
(cause :type reader-error :initarg :cause
|
||||
:reader swank-reader-error.cause)))
|
||||
|
||||
(defun read-message (stream package)
|
||||
(let ((packet (read-packet stream)))
|
||||
(handler-case (values (read-form packet package))
|
||||
(reader-error (c)
|
||||
(error 'swank-reader-error
|
||||
:packet packet :cause c)))))
|
||||
|
||||
(defun read-packet (stream)
|
||||
(let* ((length (parse-header stream))
|
||||
(octets (read-chunk stream length)))
|
||||
(handler-case (swank/backend:utf8-to-string octets)
|
||||
(error (c)
|
||||
(error 'swank-reader-error
|
||||
:packet (asciify octets)
|
||||
:cause c)))))
|
||||
|
||||
(defun asciify (packet)
|
||||
(with-output-to-string (*standard-output*)
|
||||
(loop for code across (etypecase packet
|
||||
(string (map 'vector #'char-code packet))
|
||||
(vector packet))
|
||||
do (cond ((<= code #x7f) (write-char (code-char code)))
|
||||
(t (format t "\\x~x" code))))))
|
||||
|
||||
(defun parse-header (stream)
|
||||
(parse-integer (map 'string #'code-char (read-chunk stream 6))
|
||||
:radix 16))
|
||||
|
||||
(defun read-chunk (stream length)
|
||||
(let* ((buffer (make-array length :element-type '(unsigned-byte 8)))
|
||||
(count (read-sequence buffer stream)))
|
||||
(cond ((= count length)
|
||||
buffer)
|
||||
((zerop count)
|
||||
(error 'end-of-file :stream stream))
|
||||
(t
|
||||
(error "Short read: length=~D count=~D" length count)))))
|
||||
|
||||
(defparameter *validate-input* nil
|
||||
"Set to true to require input that more strictly conforms to the protocol")
|
||||
|
||||
(defun read-form (string package)
|
||||
(with-standard-io-syntax
|
||||
(let ((*package* package))
|
||||
(if *validate-input*
|
||||
(validating-read string)
|
||||
(read-from-string string)))))
|
||||
|
||||
(defun validating-read (string)
|
||||
(with-input-from-string (*standard-input* string)
|
||||
(simple-read)))
|
||||
|
||||
(defun simple-read ()
|
||||
"Read a form that conforms to the protocol, otherwise signal an error."
|
||||
(let ((c (read-char)))
|
||||
(case c
|
||||
(#\( (loop collect (simple-read)
|
||||
while (ecase (read-char)
|
||||
(#\) nil)
|
||||
(#\space t))))
|
||||
(#\' `(quote ,(simple-read)))
|
||||
(t
|
||||
(cond
|
||||
((digit-char-p c)
|
||||
(parse-integer
|
||||
(map 'simple-string #'identity
|
||||
(loop for ch = c then (read-char nil nil)
|
||||
while (and ch (digit-char-p ch))
|
||||
collect ch
|
||||
finally (unread-char ch)))))
|
||||
((or (member c '(#\: #\")) (alpha-char-p c))
|
||||
(unread-char c)
|
||||
(read-preserving-whitespace))
|
||||
(t (error "Invalid character ~:c" c)))))))
|
||||
|
||||
|
||||
;;;;; Output
|
||||
|
||||
(defun write-message (message package stream)
|
||||
(let* ((string (prin1-to-string-for-emacs message package))
|
||||
(octets (handler-case (swank/backend:string-to-utf8 string)
|
||||
(error (c) (encoding-error c string))))
|
||||
(length (length octets)))
|
||||
(write-header stream length)
|
||||
(write-sequence octets stream)
|
||||
(finish-output stream)))
|
||||
|
||||
;; FIXME: for now just tell emacs that we and an encoding problem.
|
||||
(defun encoding-error (condition string)
|
||||
(swank/backend:string-to-utf8
|
||||
(prin1-to-string-for-emacs
|
||||
`(:reader-error
|
||||
,(asciify string)
|
||||
,(format nil "Error during string-to-utf8: ~a"
|
||||
(or (ignore-errors (asciify (princ-to-string condition)))
|
||||
(asciify (princ-to-string (type-of condition))))))
|
||||
(find-package :cl))))
|
||||
|
||||
(defun write-header (stream length)
|
||||
(declare (type (unsigned-byte 24) length))
|
||||
;;(format *trace-output* "length: ~d (#x~x)~%" length length)
|
||||
(loop for c across (format nil "~6,'0x" length)
|
||||
do (write-byte (char-code c) stream)))
|
||||
|
||||
(defun switch-to-double-floats (x)
|
||||
(typecase x
|
||||
(double-float x)
|
||||
(float (coerce x 'double-float))
|
||||
(null x)
|
||||
(list (loop for (x . cdr) on x
|
||||
collect (switch-to-double-floats x) into result
|
||||
until (atom cdr)
|
||||
finally (return (append result (switch-to-double-floats cdr)))))
|
||||
(t x)))
|
||||
|
||||
(defun prin1-to-string-for-emacs (object package)
|
||||
(with-standard-io-syntax
|
||||
(let ((*print-case* :downcase)
|
||||
(*print-readably* nil)
|
||||
(*print-pretty* nil)
|
||||
(*package* package)
|
||||
;; Emacs has only double floats.
|
||||
(*read-default-float-format* 'double-float))
|
||||
(prin1-to-string (switch-to-double-floats object)))))
|
||||
|
||||
|
||||
#| TEST/DEMO:
|
||||
|
||||
(defparameter *transport*
|
||||
(with-output-to-string (out)
|
||||
(write-message '(:message (hello "world")) *package* out)
|
||||
(write-message '(:return 5) *package* out)
|
||||
(write-message '(:emacs-rex NIL) *package* out)))
|
||||
|
||||
*transport*
|
||||
|
||||
(with-input-from-string (in *transport*)
|
||||
(loop while (peek-char T in NIL)
|
||||
collect (read-message in *package*)))
|
||||
|
||||
|#
|
||||
2036
sources_non_forked/slimv/slime/swank/sbcl.lisp
Normal file
2036
sources_non_forked/slimv/slime/swank/sbcl.lisp
Normal file
File diff suppressed because it is too large
Load Diff
1726
sources_non_forked/slimv/slime/swank/scl.lisp
Normal file
1726
sources_non_forked/slimv/slime/swank/scl.lisp
Normal file
File diff suppressed because it is too large
Load Diff
136
sources_non_forked/slimv/slime/swank/source-file-cache.lisp
Normal file
136
sources_non_forked/slimv/slime/swank/source-file-cache.lisp
Normal file
@ -0,0 +1,136 @@
|
||||
;;;; Source-file cache
|
||||
;;;
|
||||
;;; To robustly find source locations in CMUCL and SBCL it's useful to
|
||||
;;; have the exact source code that the loaded code was compiled from.
|
||||
;;; In this source we can accurately find the right location, and from
|
||||
;;; that location we can extract a "snippet" of code to show what the
|
||||
;;; definition looks like. Emacs can use this snippet in a best-match
|
||||
;;; search to locate the right definition, which works well even if
|
||||
;;; the buffer has been modified.
|
||||
;;;
|
||||
;;; The idea is that if a definition previously started with
|
||||
;;; `(define-foo bar' then it probably still does.
|
||||
;;;
|
||||
;;; Whenever we see that the file on disk has the same
|
||||
;;; `file-write-date' as a location we're looking for we cache the
|
||||
;;; whole file inside Lisp. That way we will still have the matching
|
||||
;;; version even if the file is later modified on disk. If the file is
|
||||
;;; later recompiled and reloaded then we replace our cache entry.
|
||||
;;;
|
||||
;;; This code has been placed in the Public Domain. All warranties
|
||||
;;; are disclaimed.
|
||||
|
||||
(defpackage swank/source-file-cache
|
||||
(:use cl)
|
||||
(:import-from swank/backend
|
||||
defimplementation buffer-first-change
|
||||
guess-external-format
|
||||
find-external-format)
|
||||
(:export
|
||||
get-source-code
|
||||
source-cache-get ;FIXME: isn't it odd that both are exported?
|
||||
|
||||
*source-snippet-size*
|
||||
read-snippet
|
||||
read-snippet-from-string
|
||||
))
|
||||
|
||||
(in-package swank/source-file-cache)
|
||||
|
||||
(defvar *cache-sourcecode* t
|
||||
"When true complete source files are cached.
|
||||
The cache is used to keep known good copies of the source text which
|
||||
correspond to the loaded code. Finding definitions is much more
|
||||
reliable when the exact source is available, so we cache it in case it
|
||||
gets edited on disk later.")
|
||||
|
||||
(defvar *source-file-cache* (make-hash-table :test 'equal)
|
||||
"Cache of source file contents.
|
||||
Maps from truename to source-cache-entry structure.")
|
||||
|
||||
(defstruct (source-cache-entry
|
||||
(:conc-name source-cache-entry.)
|
||||
(:constructor make-source-cache-entry (text date)))
|
||||
text date)
|
||||
|
||||
(defimplementation buffer-first-change (filename)
|
||||
"Load a file into the cache when the user modifies its buffer.
|
||||
This is a win if the user then saves the file and tries to M-. into it."
|
||||
(unless (source-cached-p filename)
|
||||
(ignore-errors
|
||||
(source-cache-get filename (file-write-date filename))))
|
||||
nil)
|
||||
|
||||
(defun get-source-code (filename code-date)
|
||||
"Return the source code for FILENAME as written on DATE in a string.
|
||||
If the exact version cannot be found then return the current one from disk."
|
||||
(or (source-cache-get filename code-date)
|
||||
(read-file filename)))
|
||||
|
||||
(defun source-cache-get (filename date)
|
||||
"Return the source code for FILENAME as written on DATE in a string.
|
||||
Return NIL if the right version cannot be found."
|
||||
(when *cache-sourcecode*
|
||||
(let ((entry (gethash filename *source-file-cache*)))
|
||||
(cond ((and entry (equal date (source-cache-entry.date entry)))
|
||||
;; Cache hit.
|
||||
(source-cache-entry.text entry))
|
||||
((or (null entry)
|
||||
(not (equal date (source-cache-entry.date entry))))
|
||||
;; Cache miss.
|
||||
(if (equal (file-write-date filename) date)
|
||||
;; File on disk has the correct version.
|
||||
(let ((source (read-file filename)))
|
||||
(setf (gethash filename *source-file-cache*)
|
||||
(make-source-cache-entry source date))
|
||||
source)
|
||||
nil))))))
|
||||
|
||||
(defun source-cached-p (filename)
|
||||
"Is any version of FILENAME in the source cache?"
|
||||
(if (gethash filename *source-file-cache*) t))
|
||||
|
||||
(defun read-file (filename)
|
||||
"Return the entire contents of FILENAME as a string."
|
||||
(with-open-file (s filename :direction :input
|
||||
:external-format (or (guess-external-format filename)
|
||||
(find-external-format "latin-1")
|
||||
:default))
|
||||
(let* ((string (make-string (file-length s)))
|
||||
(length (read-sequence string s)))
|
||||
(subseq string 0 length))))
|
||||
|
||||
;;;; Snippets
|
||||
|
||||
(defvar *source-snippet-size* 256
|
||||
"Maximum number of characters in a snippet of source code.
|
||||
Snippets at the beginning of definitions are used to tell Emacs what
|
||||
the definitions looks like, so that it can accurately find them by
|
||||
text search.")
|
||||
|
||||
(defun read-snippet (stream &optional position)
|
||||
"Read a string of upto *SOURCE-SNIPPET-SIZE* characters from STREAM.
|
||||
If POSITION is given, set the STREAM's file position first."
|
||||
(when position
|
||||
(file-position stream position))
|
||||
#+sbcl (skip-comments-and-whitespace stream)
|
||||
(read-upto-n-chars stream *source-snippet-size*))
|
||||
|
||||
(defun read-snippet-from-string (string &optional position)
|
||||
(with-input-from-string (s string)
|
||||
(read-snippet s position)))
|
||||
|
||||
(defun skip-comments-and-whitespace (stream)
|
||||
(case (peek-char nil stream nil nil)
|
||||
((#\Space #\Tab #\Newline #\Linefeed #\Page)
|
||||
(read-char stream)
|
||||
(skip-comments-and-whitespace stream))
|
||||
(#\;
|
||||
(read-line stream)
|
||||
(skip-comments-and-whitespace stream))))
|
||||
|
||||
(defun read-upto-n-chars (stream n)
|
||||
"Return a string of upto N chars from STREAM."
|
||||
(let* ((string (make-string n))
|
||||
(chars (read-sequence string stream)))
|
||||
(subseq string 0 chars)))
|
||||
242
sources_non_forked/slimv/slime/swank/source-path-parser.lisp
Normal file
242
sources_non_forked/slimv/slime/swank/source-path-parser.lisp
Normal file
@ -0,0 +1,242 @@
|
||||
;;;; Source-paths
|
||||
|
||||
;;; CMUCL/SBCL use a data structure called "source-path" to locate
|
||||
;;; subforms. The compiler assigns a source-path to each form in a
|
||||
;;; compilation unit. Compiler notes usually contain the source-path
|
||||
;;; of the error location.
|
||||
;;;
|
||||
;;; Compiled code objects don't contain source paths, only the
|
||||
;;; "toplevel-form-number" and the (sub-) "form-number". To get from
|
||||
;;; the form-number to the source-path we need the entire toplevel-form
|
||||
;;; (i.e. we have to read the source code). CMUCL has already some
|
||||
;;; utilities to do this translation, but we use some extended
|
||||
;;; versions, because we need more exact position info. Apparently
|
||||
;;; Hemlock is happy with the position of the toplevel-form; we also
|
||||
;;; need the position of subforms.
|
||||
;;;
|
||||
;;; We use a special readtable to get the positions of the subforms.
|
||||
;;; The readtable stores the start and end position for each subform in
|
||||
;;; hashtable for later retrieval.
|
||||
;;;
|
||||
;;; This code has been placed in the Public Domain. All warranties
|
||||
;;; are disclaimed.
|
||||
|
||||
;;; Taken from swank-cmucl.lisp, by Helmut Eller
|
||||
|
||||
(defpackage swank/source-path-parser
|
||||
(:use cl)
|
||||
(:export
|
||||
read-source-form
|
||||
source-path-string-position
|
||||
source-path-file-position
|
||||
source-path-source-position
|
||||
|
||||
sexp-in-bounds-p
|
||||
sexp-ref)
|
||||
(:shadow ignore-errors))
|
||||
|
||||
(in-package swank/source-path-parser)
|
||||
|
||||
;; Some test to ensure the required conformance
|
||||
(let ((rt (copy-readtable nil)))
|
||||
(assert (or (not (get-macro-character #\space rt))
|
||||
(nth-value 1 (get-macro-character #\space rt))))
|
||||
(assert (not (get-macro-character #\\ rt))))
|
||||
|
||||
(eval-when (:compile-toplevel)
|
||||
(defmacro ignore-errors (&rest forms)
|
||||
;;`(progn . ,forms) ; for debugging
|
||||
`(cl:ignore-errors . ,forms)))
|
||||
|
||||
(defun make-sharpdot-reader (orig-sharpdot-reader)
|
||||
(lambda (s c n)
|
||||
;; We want things like M-. to work regardless of any #.-fu in
|
||||
;; the source file that is to be visited. (For instance, when a
|
||||
;; file contains #. forms referencing constants that do not
|
||||
;; currently exist in the image.)
|
||||
(ignore-errors (funcall orig-sharpdot-reader s c n))))
|
||||
|
||||
(defun make-source-recorder (fn source-map)
|
||||
"Return a macro character function that does the same as FN, but
|
||||
additionally stores the result together with the stream positions
|
||||
before and after of calling FN in the hashtable SOURCE-MAP."
|
||||
(lambda (stream char)
|
||||
(let ((start (1- (file-position stream)))
|
||||
(values (multiple-value-list (funcall fn stream char)))
|
||||
(end (file-position stream)))
|
||||
#+(or)
|
||||
(format t "[~D \"~{~A~^, ~}\" ~D ~D ~S]~%"
|
||||
start values end (char-code char) char)
|
||||
(when values
|
||||
(destructuring-bind (&optional existing-start &rest existing-end)
|
||||
(car (gethash (car values) source-map))
|
||||
;; Some macros may return what a sub-call to another macro
|
||||
;; produced, e.g. "#+(and) (a)" may end up saving (a) twice,
|
||||
;; once from #\# and once from #\(. If the saved form
|
||||
;; is a subform, don't save it again.
|
||||
(unless (and existing-start existing-end
|
||||
(<= start existing-start end)
|
||||
(<= start existing-end end))
|
||||
(push (cons start end) (gethash (car values) source-map)))))
|
||||
(values-list values))))
|
||||
|
||||
(defun make-source-recording-readtable (readtable source-map)
|
||||
(declare (type readtable readtable) (type hash-table source-map))
|
||||
"Return a source position recording copy of READTABLE.
|
||||
The source locations are stored in SOURCE-MAP."
|
||||
(flet ((install-special-sharpdot-reader (rt)
|
||||
(let ((fun (ignore-errors
|
||||
(get-dispatch-macro-character #\# #\. rt))))
|
||||
(when fun
|
||||
(let ((wrapper (make-sharpdot-reader fun)))
|
||||
(set-dispatch-macro-character #\# #\. wrapper rt)))))
|
||||
(install-wrappers (rt)
|
||||
(dotimes (code 128)
|
||||
(let ((char (code-char code)))
|
||||
(multiple-value-bind (fun nt) (get-macro-character char rt)
|
||||
(when fun
|
||||
(let ((wrapper (make-source-recorder fun source-map)))
|
||||
(set-macro-character char wrapper nt rt))))))))
|
||||
(let ((rt (copy-readtable readtable)))
|
||||
(install-special-sharpdot-reader rt)
|
||||
(install-wrappers rt)
|
||||
rt)))
|
||||
|
||||
;; FIXME: try to do this with *READ-SUPPRESS* = t to avoid interning.
|
||||
;; Should be possible as we only need the right "list structure" and
|
||||
;; not the right atoms.
|
||||
(defun read-and-record-source-map (stream)
|
||||
"Read the next object from STREAM.
|
||||
Return the object together with a hashtable that maps
|
||||
subexpressions of the object to stream positions."
|
||||
(let* ((source-map (make-hash-table :test #'eq))
|
||||
(*readtable* (make-source-recording-readtable *readtable* source-map))
|
||||
(*read-suppress* nil)
|
||||
(start (file-position stream))
|
||||
(form (ignore-errors (read stream)))
|
||||
(end (file-position stream)))
|
||||
;; ensure that at least FORM is in the source-map
|
||||
(unless (gethash form source-map)
|
||||
(push (cons start end) (gethash form source-map)))
|
||||
(values form source-map)))
|
||||
|
||||
(defun starts-with-p (string prefix)
|
||||
(declare (type string string prefix))
|
||||
(not (mismatch string prefix
|
||||
:end1 (min (length string) (length prefix))
|
||||
:test #'char-equal)))
|
||||
|
||||
(defun extract-package (line)
|
||||
(declare (type string line))
|
||||
(let ((name (cadr (read-from-string line))))
|
||||
(find-package name)))
|
||||
|
||||
#+(or)
|
||||
(progn
|
||||
(assert (extract-package "(in-package cl)"))
|
||||
(assert (extract-package "(cl:in-package cl)"))
|
||||
(assert (extract-package "(in-package \"CL\")"))
|
||||
(assert (extract-package "(in-package #:cl)")))
|
||||
|
||||
;; FIXME: do something cleaner than this.
|
||||
(defun readtable-for-package (package)
|
||||
;; KLUDGE: due to the load order we can't reference the swank
|
||||
;; package.
|
||||
(funcall (read-from-string "swank::guess-buffer-readtable")
|
||||
(string-upcase (package-name package))))
|
||||
|
||||
;; Search STREAM for a "(in-package ...)" form. Use that to derive
|
||||
;; the values for *PACKAGE* and *READTABLE*.
|
||||
;;
|
||||
;; IDEA: move GUESS-READER-STATE to swank.lisp so that all backends
|
||||
;; use the same heuristic and to avoid the need to access
|
||||
;; swank::guess-buffer-readtable from here.
|
||||
(defun guess-reader-state (stream)
|
||||
(let* ((point (file-position stream))
|
||||
(pkg *package*))
|
||||
(file-position stream 0)
|
||||
(loop for line = (read-line stream nil nil) do
|
||||
(when (not line) (return))
|
||||
(when (or (starts-with-p line "(in-package ")
|
||||
(starts-with-p line "(cl:in-package "))
|
||||
(let ((p (extract-package line)))
|
||||
(when p (setf pkg p)))
|
||||
(return)))
|
||||
(file-position stream point)
|
||||
(values (readtable-for-package pkg) pkg)))
|
||||
|
||||
(defun skip-whitespace (stream)
|
||||
(peek-char t stream nil nil))
|
||||
|
||||
;; Skip over N toplevel forms.
|
||||
(defun skip-toplevel-forms (n stream)
|
||||
(let ((*read-suppress* t))
|
||||
(dotimes (i n)
|
||||
(read stream))
|
||||
(skip-whitespace stream)))
|
||||
|
||||
(defun read-source-form (n stream)
|
||||
"Read the Nth toplevel form number with source location recording.
|
||||
Return the form and the source-map."
|
||||
(multiple-value-bind (*readtable* *package*) (guess-reader-state stream)
|
||||
(let (#+sbcl
|
||||
(*features* (append *features*
|
||||
(symbol-value (find-symbol "+INTERNAL-FEATURES+" 'sb-impl)))))
|
||||
(skip-toplevel-forms n stream)
|
||||
(read-and-record-source-map stream))))
|
||||
|
||||
(defun source-path-stream-position (path stream)
|
||||
"Search the source-path PATH in STREAM and return its position."
|
||||
(check-source-path path)
|
||||
(destructuring-bind (tlf-number . path) path
|
||||
(multiple-value-bind (form source-map) (read-source-form tlf-number stream)
|
||||
(source-path-source-position (cons 0 path) form source-map))))
|
||||
|
||||
(defun check-source-path (path)
|
||||
(unless (and (consp path)
|
||||
(every #'integerp path))
|
||||
(error "The source-path ~S is not valid." path)))
|
||||
|
||||
(defun source-path-string-position (path string)
|
||||
(with-input-from-string (s string)
|
||||
(source-path-stream-position path s)))
|
||||
|
||||
(defun source-path-file-position (path filename)
|
||||
;; We go this long way round, and don't directly operate on the file
|
||||
;; stream because FILE-POSITION (used above) is not totally savy even
|
||||
;; on file character streams; on SBCL, FILE-POSITION returns the binary
|
||||
;; offset, and not the character offset---screwing up on Unicode.
|
||||
(let ((toplevel-number (first path))
|
||||
(buffer))
|
||||
(with-open-file (file filename)
|
||||
(skip-toplevel-forms (1+ toplevel-number) file)
|
||||
(let ((endpos (file-position file)))
|
||||
(setq buffer (make-array (list endpos) :element-type 'character
|
||||
:initial-element #\Space))
|
||||
(assert (file-position file 0))
|
||||
(read-sequence buffer file :end endpos)))
|
||||
(source-path-string-position path buffer)))
|
||||
|
||||
(defgeneric sexp-in-bounds-p (sexp i)
|
||||
(:method ((list list) i)
|
||||
(< i (loop for e on list
|
||||
count t)))
|
||||
(:method ((sexp t) i) nil))
|
||||
|
||||
(defgeneric sexp-ref (sexp i)
|
||||
(:method ((s list) i) (elt s i)))
|
||||
|
||||
(defun source-path-source-position (path form source-map)
|
||||
"Return the start position of PATH from FORM and SOURCE-MAP. All
|
||||
subforms along the path are considered and the start and end position
|
||||
of the deepest (i.e. smallest) possible form is returned."
|
||||
;; compute all subforms along path
|
||||
(let ((forms (loop for i in path
|
||||
for f = form then (if (sexp-in-bounds-p f i)
|
||||
(sexp-ref f i))
|
||||
collect f)))
|
||||
;; select the first subform present in source-map
|
||||
(loop for form in (nreverse forms)
|
||||
for ((start . end) . rest) = (gethash form source-map)
|
||||
when (and start end (not rest))
|
||||
return (return (values start end)))))
|
||||
Reference in New Issue
Block a user