[slime-cvs] CVS slime
CVS User heller
heller at common-lisp.net
Sun Jul 26 08:00:43 UTC 2009
Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv31627
Modified Files:
ChangeLog swank-loader.lisp
Added Files:
swank-ccl.lisp
Log Message:
* swank-ccl.lisp: New file. An updated version of
swank-openmcl.lisp in preparation for a slew of changes to CCL and
to honor the new name.
* swank-loader.lisp (*sysdep-files*): Use it.
By Gail Zacharias <gz at clozure.com>
--- /project/slime/cvsroot/slime/ChangeLog 2009/07/21 18:34:54 1.1813
+++ /project/slime/cvsroot/slime/ChangeLog 2009/07/26 08:00:40 1.1814
@@ -1,3 +1,11 @@
+2009-07-26 Gail Zacharias <gz at clozure.com>
+
+ * swank-ccl.lisp: New file. An updated version of
+ swank-openmcl.lisp in preparation for a slew of changes to CCL and
+ to honor the new name.
+
+ * swank-loader.lisp (*sysdep-files*): Use it.
+
2009-07-21 Stas Boukarev <stassats at gmail.com>
* slime.el (slime-sexp-at-point-for-macroexpansion): use markers
--- /project/slime/cvsroot/slime/swank-loader.lisp 2009/01/08 16:20:14 1.90
+++ /project/slime/cvsroot/slime/swank-loader.lisp 2009/07/26 08:00:40 1.91
@@ -37,7 +37,7 @@
#+scl '(swank-source-path-parser swank-source-file-cache swank-scl)
#+sbcl '(swank-source-path-parser swank-source-file-cache
swank-sbcl swank-gray)
- #+openmcl '(metering swank-openmcl swank-gray)
+ #+clozure '(metering swank-ccl swank-gray)
#+lispworks '(swank-lispworks swank-gray)
#+allegro '(swank-allegro swank-gray)
#+clisp '(xref metering swank-clisp swank-gray)
@@ -46,7 +46,7 @@
#+ecl '(swank-source-path-parser swank-source-file-cache swank-ecl swank-gray))
(defparameter *implementation-features*
- '(:allegro :lispworks :sbcl :openmcl :cmu :clisp :ccl :corman :cormanlisp
+ '(:allegro :lispworks :sbcl :clozure :cmu :clisp :ccl :corman :cormanlisp
:armedbear :gcl :ecl :scl))
(defparameter *os-features*
@@ -58,8 +58,8 @@
:sparc64 :sparc :hppa64 :hppa))
(defun lisp-version-string ()
- #+(or openmcl cmu) (substitute-if #\_ (lambda (x) (find x " /"))
- (lisp-implementation-version))
+ #+(or clozure cmu) (substitute-if #\_ (lambda (x) (find x " /"))
+ (lisp-implementation-version))
#+(or cormanlisp scl sbcl ecl) (lisp-implementation-version)
#+lispworks (lisp-implementation-version)
#+allegro (format nil
--- /project/slime/cvsroot/slime/swank-ccl.lisp 2009/07/26 08:00:43 NONE
+++ /project/slime/cvsroot/slime/swank-ccl.lisp 2009/07/26 08:00:43 1.1
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; openmcl-swank.lisp --- SLIME backend for OpenMCL.
;;;
;;; Copyright (C) 2003, James Bielman <jamesjb at jamesjb.com>
;;;
;;; This program is licensed under the terms of the Lisp Lesser GNU
;;; Public License, known as the LLGPL, and distributed with OpenMCL
;;; as the file "LICENSE". The LLGPL consists of a preamble and the
;;; LGPL, which is distributed with OpenMCL as the file "LGPL". Where
;;; these conflict, the preamble takes precedence.
;;;
;;; The LLGPL is also available online at
;;; http://opensource.franz.com/preamble.html
;;;
;;; This is the beginning of a Slime backend for OpenMCL. It has been
;;; tested only with OpenMCL version 0.14-030901 on Darwin --- I would
;;; be interested in hearing the results with other versions.
;;;
;;; Additionally, reporting the positions of warnings accurately requires
;;; a small patch to the OpenMCL file compiler, which may be found at:
;;;
;;; http://www.jamesjb.com/slime/openmcl-warning-position.diff
;;;
;;; Things that work:
;;;
;;; * Evaluation of forms with C-M-x.
;;; * Compilation of defuns with C-c C-c.
;;; * File compilation with C-c C-k.
;;; * Most of the debugger functionality, except EVAL-IN-FRAME,
;;; FRAME-SOURCE-LOCATION, and FRAME-CATCH-TAGS.
;;; * Macroexpanding with C-c RET.
;;; * Disassembling the symbol at point with C-c M-d.
;;; * Describing symbol at point with C-c C-d.
;;; * Compiler warnings are trapped and sent to Emacs using the buffer
;;; position of the offending top level form.
;;; * Symbol completion and apropos.
;;;
;;; Things that sort of work:
;;;
;;; * WHO-CALLS is implemented but is only able to return the file a
;;; caller is defined in---source location information is not
;;; available.
;;;
;;; Things that aren't done yet:
;;;
;;; * Cross-referencing.
;;; * Due to unimplementation functionality the test suite does not
;;; run correctly (it hangs upon entering the debugger).
;;;
(in-package :swank-backend)
;; Backward compatibility
(eval-when (:compile-toplevel)
(unless (fboundp 'ccl:compute-applicable-methods-using-classes)
(compile-file (make-pathname :name "swank-openmcl" :type "lisp" :defaults swank-loader::*source-directory*)
:output-file (make-pathname :name "swank-ccl" :defaults swank-loader::*fasl-directory*)
:verbose t)
(invoke-restart (find-restart 'ccl::skip-compile-file))))
(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"))
(import-from :ccl *gray-stream-symbols* :swank-backend)
(eval-when (:compile-toplevel :load-toplevel :execute)
(require 'xref))
;;; 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))
(defmacro swank-sym (sym)
(let ((str (symbol-name sym)))
`(or (find-symbol ,str :swank)
(error "There is no symbol named ~a in the SWANK package" ,str))))
;;; TCP Server
(defimplementation preferred-communication-style ()
:spawn)
(defimplementation create-socket (host port)
(ccl:make-socket :connect :passive :local-port port
:local-host host :reuse-address t))
(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))
(ccl:accept-connection socket :wait t
:stream-args (and external-format
`(:external-format ,external-format))))
(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*)))
;;; Unix signals
(defimplementation call-without-interrupts (fn)
;; This prevents the current thread from being interrupted, but it doesn't
;; keep other threads from running concurrently, so it's not an appropriate
;; replacement for locking.
(ccl:without-interrupts (funcall fn)))
(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 (make-condition
'compiler-condition
:original-condition condition
:message (format nil "~A" condition)
:short-message (compiler-warning-short-message condition)
: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)))
(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)
(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
policy)
(declare (ignore 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)
(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)))
(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)
(delete-duplicates
(mapcar (lambda (m)
(car (find-definitions m)))
(ccl:specializer-direct-methods (if (symbolp class) (find-class class) 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 `(mon:monitor ,fname))) ;monitor is a macro
(defimplementation profiled-functions ()
mon:*monitored-functions*)
(defimplementation unprofile (fname)
(eval `(mon:unmonitor ,fname))) ;unmonitor is a macro
(defimplementation unprofile-all ()
(mon:unmonitor))
(defimplementation profile-report ()
(mon:report-monitoring))
(defimplementation profile-reset ()
(mon:reset-all-monitoring))
(defimplementation profile-package (package callers-p methods)
(declare (ignore callers-p methods))
(mon:monitor-all package))
;;; Debugging
(defun openmcl-set-debug-switches ()
(setq ccl:*fasl-save-definitions* nil)
(setq ccl:*fasl-save-doc-strings* t)
(setq ccl:*fasl-save-local-symbols* t)
(setq ccl:*save-arglist-info* t)
(setq ccl:*save-definitions* nil)
(setq ccl:*save-doc-strings* t)
(setq ccl:*save-local-symbols* t)
(ccl:start-xref))
(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)))
(defun find-repl-thread ()
;; 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*.
(let* ((conn (funcall (swank-sym default-connection))))
[459 lines skipped]
More information about the slime-cvs
mailing list