[slime-cvs] CVS slime
heller
heller at common-lisp.net
Sun Nov 19 21:33:04 UTC 2006
Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv27672
Modified Files:
swank-backend.lisp swank-cmucl.lisp swank-sbcl.lisp
swank-clisp.lisp swank-lispworks.lisp swank-allegro.lisp
swank-corman.lisp swank-ecl.lisp swank-scl.lisp
swank-abcl.lisp swank-openmcl.lisp
Log Message:
(find-external-format, guess-external-format): New.
(swank-compile-file): The external-format argument is now a
backend specific value returned by find-external-format.
Update implementations accordingly.
--- /project/slime/cvsroot/slime/swank-backend.lisp 2006/10/28 17:41:41 1.108
+++ /project/slime/cvsroot/slime/swank-backend.lisp 2006/11/19 21:33:03 1.109
@@ -370,9 +370,11 @@
(abort-request "Couldn't find ASDF operation ~S" operation-name))
(apply operate operation system-name keyword-args))))
-(definterface swank-compile-file (filename load-p &optional external-format)
+(definterface swank-compile-file (filename load-p external-format)
"Compile FILENAME signalling COMPILE-CONDITIONs.
-If LOAD-P is true, load the file after compilation.")
+If LOAD-P is true, load the file after compilation.
+EXTERNAL-FORMAT is a value returned by find-external-format or
+:default.")
(deftype severity ()
'(member :error :read-error :warning :style-warning :note))
@@ -404,6 +406,48 @@
(location :initarg :location
:accessor location)))
+(definterface find-external-format (coding-system)
+ "Return a \"external file format designator\" for CODING-SYSTEM.
+CODING-SYSTEM is Emacs-style coding system name (a string),
+e.g. \"latin-1-unix\"."
+ (if (equal coding-system "iso-latin-1-unix")
+ :default
+ nil))
+
+(definterface guess-external-format (filename)
+ "Detect the external format for the file with name FILENAME.
+Return nil if the file contains no special markers."
+ ;; Look for a Emacs-style -*- coding: ... -*- or Local Variable: section.
+ (with-open-file (s filename :if-does-not-exist nil
+ :external-format (or (find-external-format "latin-1-unix")
+ :default))
+ (or (let* ((line (read-line s nil))
+ (p (search "-*-" line)))
+ (when p
+ (let* ((start (+ p (length "-*-")))
+ (end (search "-*-" line :start2 start)))
+ (when end
+ (%search-coding line start end)))))
+ (let* ((len (file-length s))
+ (buf (make-string (min len 3000))))
+ (file-position s (- len (length buf)))
+ (read-sequence buf s)
+ (let ((start (search "Local Variables:" buf :from-end t))
+ (end (search "End:" buf :from-end t)))
+ (and start end (< start end)
+ (%search-coding buf start end)))))))
+
+(defun %search-coding (str start end)
+ (let ((p (search "coding:" str :start2 start :end2 end)))
+ (when p
+ (incf p (length "coding:"))
+ (loop while (and (< p end)
+ (member (aref str p) '(#\space #\tab)))
+ do (incf p))
+ (let ((end (position-if (lambda (c) (find c '(#\space #\tab #\newline)))
+ str :start p)))
+ (find-external-format (subseq str p end))))))
+
;;;; Streams
--- /project/slime/cvsroot/slime/swank-cmucl.lisp 2006/10/20 17:07:55 1.166
+++ /project/slime/cvsroot/slime/swank-cmucl.lisp 2006/11/19 21:33:03 1.167
@@ -100,13 +100,8 @@
(defimplementation accept-connection (socket &key
external-format buffering timeout)
- (declare (ignore timeout))
- (let ((ef (or external-format :iso-latin-1-unix))
- (buffering (or buffering :full)))
- (unless (eq ef ':iso-latin-1-unix)
- (remove-fd-handlers socket)
- (remove-sigio-handlers socket)
- (error "External format ~S not supported" ef))
+ (declare (ignore timeout external-format))
+ (let ((buffering (or buffering :full)))
(make-socket-io-stream (ext:accept-tcp-connection socket) buffering)))
;;;;; Sockets
@@ -338,8 +333,7 @@
(c::warning #'handle-notification-condition))
(funcall function))))
-(defimplementation swank-compile-file (filename load-p
- &optional external-format)
+(defimplementation swank-compile-file (filename load-p external-format)
(declare (ignore external-format))
(clear-xref-info filename)
(with-compilation-hooks ()
--- /project/slime/cvsroot/slime/swank-sbcl.lisp 2006/10/27 06:24:26 1.170
+++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2006/11/19 21:33:03 1.171
@@ -129,22 +129,27 @@
(sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket))
(file-stream (sb-sys:fd-stream-fd socket))))
-(defun find-external-format (coding-system)
- (ecase coding-system
- (:iso-latin-1-unix :iso-8859-1)
- (:utf-8-unix :utf-8)
- (:euc-jp-unix :euc-jp)))
+(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")
+ (:euc-jp "euc-jp" "euc-jp-unix")
+ (:us-ascii "us-ascii" "us-ascii-unix")))
+
+(defimplementation find-external-format (coding-system)
+ (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
+ *external-format-to-coding-system*)))
(defun make-socket-io-stream (socket external-format buffering)
- (let ((ef (find-external-format external-format)))
- (sb-bsd-sockets:socket-make-stream socket
- :output t
- :input t
- :element-type 'character
- :buffering buffering
- #+sb-unicode :external-format
- #+sb-unicode ef
- )))
+ (sb-bsd-sockets:socket-make-stream socket
+ :output t
+ :input t
+ :element-type 'character
+ :buffering buffering
+ #+sb-unicode :external-format
+ #+sb-unicode external-format
+ ))
(defun accept (socket)
"Like socket-accept, but retry on EAGAIN."
@@ -373,20 +378,17 @@
(defvar *trap-load-time-warnings* nil)
-(defimplementation swank-compile-file (filename load-p
- &optional external-format)
- (let ((ef (if external-format
- (find-external-format external-format)
- :default)))
- (handler-case
- (let ((output-file (with-compilation-hooks ()
- (compile-file filename :external-format ef))))
- (when output-file
- ;; Cache the latest source file for definition-finding.
- (source-cache-get filename (file-write-date filename))
- (when load-p
- (load output-file))))
- (sb-c:fatal-compiler-error () nil))))
+(defimplementation swank-compile-file (filename load-p external-format)
+ (handler-case
+ (let ((output-file (with-compilation-hooks ()
+ (compile-file filename
+ :external-format external-format))))
+ (when output-file
+ ;; Cache the latest source file for definition-finding.
+ (source-cache-get filename (file-write-date filename))
+ (when load-p
+ (load output-file))))
+ (sb-c:fatal-compiler-error () nil)))
;;;; compile-string
--- /project/slime/cvsroot/slime/swank-clisp.lisp 2006/08/10 11:53:35 1.59
+++ /project/slime/cvsroot/slime/swank-clisp.lisp 2006/11/19 21:33:03 1.60
@@ -116,22 +116,35 @@
(defimplementation close-socket (socket)
(socket:socket-server-close socket))
-
-(defun find-encoding (external-format)
- (let ((charset (ecase external-format
- (:iso-latin-1-unix "iso-8859-1")
- (:utf-8-unix "utf-8")
- (:euc-jp-unix "euc-jp"))))
- (ext:make-encoding :charset charset :line-terminator :unix)))
(defimplementation accept-connection (socket
&key external-format buffering timeout)
(declare (ignore buffering timeout))
- (setq external-format (or external-format :iso-latin-1-unix))
(socket:socket-accept socket
:buffered nil ;; XXX should be t
:element-type 'character
- :external-format (find-encoding external-format)))
+ :external-format external-format))
+
+;;; 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)
+ "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
@@ -467,17 +480,14 @@
:message (princ-to-string condition)
:location (compiler-note-location))))
-(defimplementation swank-compile-file (filename load-p
- &optional external-format)
- (let ((ef (if external-format
- (find-encoding external-format)
- :default)))
- (with-compilation-hooks ()
- (with-compilation-unit ()
- (let ((fasl-file (compile-file filename :external-format ef)))
- (when (and load-p fasl-file)
- (load fasl-file))
- nil)))))
+(defimplementation swank-compile-file (filename load-p external-format)
+ (with-compilation-hooks ()
+ (with-compilation-unit ()
+ (let ((fasl-file (compile-file filename
+ :external-format external-format)))
+ (when (and load-p fasl-file)
+ (load fasl-file))
+ nil))))
(defimplementation swank-compile-string (string &key buffer position directory)
(declare (ignore directory))
--- /project/slime/cvsroot/slime/swank-lispworks.lisp 2006/10/21 09:28:57 1.87
+++ /project/slime/cvsroot/slime/swank-lispworks.lisp 2006/11/19 21:33:03 1.88
@@ -67,25 +67,36 @@
(defimplementation accept-connection (socket
&key external-format buffering timeout)
- (declare (ignore buffering timeout))
- (assert (member external-format '(nil :iso-latin-1-unix)))
+ (declare (ignore buffering timeout external-format))
(let* ((fd (comm::get-fd-from-socket socket)))
(assert (/= fd -1))
(make-instance 'comm:socket-stream :socket fd :direction :io
:element-type 'base-char)))
-(defun find-external-format (coding-system &optional default)
- (case coding-system
- (:iso-latin-1-unix '(:latin-1 :eol-style :lf))
- (:utf-8-unix '(:utf-8 :eol-style :lf))
- (t default)))
-
(defun set-sigint-handler ()
;; Set SIGINT handler on Swank request handler thread.
#-win32
(sys::set-signal-handler +sigint+
(make-sigint-handler mp:*current-process*)))
+;;; Coding Systems
+
+(defvar *external-format-to-coding-system*
+ '(((:latin-1 :eol-style :lf)
+ "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix")
+ ((:latin-1)
+ "latin-1" "iso-latin-1" "iso-8859-1")
+ ((:utf-8) "utf-8")
+ ((:utf-8 :eol-style :lf) "utf-8-unix")
+ ((:euc-jp) "euc-jp")
+ ((:euc-jp :eol-style :lf) "euc-jp-unix")
+ ((:ascii) "us-ascii")
+ ((:ascii :eol-style :lf) "us-ascii-unix")))
+
+(defimplementation find-external-format (coding-system)
+ (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
+ *external-format-to-coding-system*)))
+
;;; Unix signals
(defun sigint-handler ()
@@ -362,13 +373,9 @@
(signal-error-data-base compiler::*error-database* ,location)
(signal-undefined-functions compiler::*unknown-functions* ,location)))))
-(defimplementation swank-compile-file (filename load-p
- &optional external-format)
+(defimplementation swank-compile-file (filename load-p external-format)
(with-swank-compilation-unit (filename)
- (let ((ef (if external-format
- (find-external-format external-format)
- :default)))
- (compile-file filename :load load-p :external-format ef))))
+ (compile-file filename :load load-p :external-format external-format)))
(defvar *within-call-with-compilation-hooks* nil
"Whether COMPILE-FILE was called from within CALL-WITH-COMPILATION-HOOKS.")
--- /project/slime/cvsroot/slime/swank-allegro.lisp 2006/10/28 17:41:57 1.93
+++ /project/slime/cvsroot/slime/swank-allegro.lisp 2006/11/19 21:33:03 1.94
@@ -18,8 +18,6 @@
;;; swank-mop
-;; maybe better change MOP to ACLMOP ?
-;; CLOS also works in ACL5. --he
(import-swank-mop-symbols :clos '(:slot-definition-documentation))
(defun swank-mop:slot-definition-documentation (slot)
@@ -44,25 +42,26 @@
(defimplementation accept-connection (socket &key external-format buffering
timeout)
(declare (ignore buffering timeout))
- (let ((ef (or external-format :iso-latin-1-unix))
- (s (socket:accept-connection socket :wait t)))
- (set-external-format s ef)
+ (let ((s (socket:accept-connection socket :wait t)))
+ (when external-format
+ (setf (stream-external-format s) external-format))
s))
-(defun find-external-format (coding-system)
- #+(version>= 6)
- (let* ((name (ecase coding-system
- (:iso-latin-1-unix :latin1)
- (:utf-8-unix :utf8)
- (:emacs-mule-unix :emacs-mule))))
- (excl:crlf-base-ef (excl:find-external-format name :try-variant t)))
- #-(version>= 6)
- (ecase coding-system
- (:iso-latin-1-unix :default)))
-
-(defun set-external-format (stream external-format)
- (setf (stream-external-format stream)
- (find-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")
+ (:euc-jp "euc-jp" "euc-jp-unix")
+ (:us-ascii "us-ascii" "us-ascii-unix")
+ (:emacs-mule "emacs-mule" "emacs-mule-unix")))
+
+(defimplementation find-external-format (coding-system)
+ (let ((e (rassoc-if (lambda (x) (member coding-system x :test #'equal))
+ *external-format-to-coding-system*)))
+ (and e (excl:crlf-base-ef
+ (excl:find-external-format (car e)
+ :try-variant t)))))
(defimplementation format-sldb-condition (c)
(princ-to-string c))
@@ -237,7 +236,6 @@
(member (type-of object) '(excl::compiler-note compiler::compiler-note)))
(defun compiler-undefined-functions-called-warning-p (object)
- #+(version>= 6)
(typep object 'excl:compiler-undefined-functions-called-warning))
(deftype compiler-note ()
@@ -292,16 +290,12 @@
)
(funcall function)))
-(defimplementation swank-compile-file (filename load-p
- &optional external-format)
+(defimplementation swank-compile-file (filename load-p external-format)
(with-compilation-hooks ()
(let ((*buffer-name* nil)
- (*compile-filename* filename)
- (ef (if external-format
- (find-external-format external-format)
- :default)))
+ (*compile-filename* filename))
(compile-file *compile-filename* :load-after-compile load-p
- :external-format ef))))
+ :external-format external-format))))
(defun call-with-temp-file (fn)
(let ((tmpname (system:make-temp-file-name)))
--- /project/slime/cvsroot/slime/swank-corman.lisp 2006/08/10 11:53:35 1.9
+++ /project/slime/cvsroot/slime/swank-corman.lisp 2006/11/19 21:33:03 1.10
@@ -239,10 +239,8 @@
(defimplementation accept-connection (socket
&key external-format buffering timeout)
- (declare (ignore buffering timeout))
- (ecase (or external-format :iso-latin-1-unix)
- (:iso-latin-1-unix
- (sockets:make-socket-stream (sockets:accept-socket socket)))))
+ (declare (ignore buffering timeout external-format))
+ (sockets:make-socket-stream (sockets:accept-socket socket)))
;;; Misc
@@ -367,7 +365,7 @@
(funcall fn)))
(defimplementation swank-compile-file (*compile-filename* load-p
- &optional external-format)
+ external-format)
(declare (ignore external-format))
(with-compilation-hooks ()
(let ((*buffer-name* nil))
--- /project/slime/cvsroot/slime/swank-ecl.lisp 2006/08/10 11:53:35 1.6
+++ /project/slime/cvsroot/slime/swank-ecl.lisp 2006/11/19 21:33:03 1.7
@@ -1,6 +1,10 @@
-;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;; -*- indent-tabs-mode: nil -*-
;;;
;;; swank-ecl.lisp --- SLIME backend for ECL.
+;;;
+;;; This code has been placed in the Public Domain. All warranties
+;;; are disclaimed.
+;;;
;;; Administrivia
@@ -42,11 +46,10 @@
(defimplementation accept-connection (socket
&key external-format
buffering timeout)
- (declare (ignore buffering timeout))
- (assert (eq external-format :iso-latin-1-unix))
- (make-socket-io-stream (accept socket) external-format))
+ (declare (ignore buffering timeout external-format))
+ (make-socket-io-stream (accept socket)))
-(defun make-socket-io-stream (socket external-format)
+(defun make-socket-io-stream (socket)
(sb-bsd-sockets:socket-make-stream socket
:output t
:input t
@@ -118,7 +121,7 @@
(funcall function)))
(defimplementation swank-compile-file (*compile-filename* load-p
- &optional external-format)
+ external-format)
(declare (ignore external-format))
(with-compilation-hooks ()
(let ((*buffer-name* nil))
--- /project/slime/cvsroot/slime/swank-scl.lisp 2006/09/13 22:56:14 1.11
+++ /project/slime/cvsroot/slime/swank-scl.lisp 2006/11/19 21:33:03 1.12
@@ -38,7 +38,7 @@
(defimplementation accept-connection (socket
&key external-format buffering timeout)
- (let ((external-format (or external-format :iso-latin-1-unix))
+ (let ((external-format (or external-format :default))
(buffering (or buffering :full))
(fd (socket-fd socket)))
(loop
@@ -68,17 +68,20 @@
(let ((hostent (ext:lookup-host-entry hostname)))
(car (ext:host-entry-addr-list hostent))))
-(defun find-external-format (coding-system)
- (case coding-system
- (:iso-latin-1-unix :iso-8859-1)
- (:utf-8-unix :utf-8)
- (:euc-jp-unix :euc-jp)
- (t coding-system)))
+(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")
+ (:euc-jp "euc-jp" "euc-jp-unix")))
+
+(defimplementation find-external-format (coding-system)
+ (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
+ *external-format-to-coding-system*)))
(defun make-socket-io-stream (fd external-format buffering)
"Create a new input/output fd-stream for 'fd."
- (let* ((external-format (find-external-format external-format))
- (stream (sys:make-fd-stream fd :input t :output t
+ (let* ((stream (sys:make-fd-stream fd :input t :output t
:element-type 'base-char
:buffering buffering
:external-format external-format)))
@@ -374,21 +377,17 @@
(c::warning #'handle-notification-condition))
(funcall function))))
-(defimplementation swank-compile-file (filename load-p
- &optional external-format)
- (let ((external-format (if external-format
- (find-external-format external-format)
- :default)))
- (with-compilation-hooks ()
- (let ((*buffer-name* nil)
- (ext:*ignore-extra-close-parentheses* nil))
- (multiple-value-bind (output-file warnings-p failure-p)
- (compile-file filename :external-format external-format)
- (unless failure-p
- ;; Cache the latest source file for definition-finding.
- (source-cache-get filename (file-write-date filename))
- (when load-p (load output-file)))
- (values output-file warnings-p failure-p))))))
+(defimplementation swank-compile-file (filename load-p external-format)
+ (with-compilation-hooks ()
+ (let ((*buffer-name* nil)
+ (ext:*ignore-extra-close-parentheses* nil))
+ (multiple-value-bind (output-file warnings-p failure-p)
+ (compile-file filename :external-format external-format)
+ (unless failure-p
+ ;; Cache the latest source file for definition-finding.
+ (source-cache-get filename (file-write-date filename))
+ (when load-p (load output-file)))
+ (values output-file warnings-p failure-p)))))
(defimplementation swank-compile-string (string &key buffer position directory)
(declare (ignore directory))
--- /project/slime/cvsroot/slime/swank-abcl.lisp 2006/08/10 11:53:35 1.40
+++ /project/slime/cvsroot/slime/swank-abcl.lisp 2006/11/19 21:33:03 1.41
@@ -1,4 +1,4 @@
-;;;; -*- Mode: lisp; indent-tabs-mode: nil; outline-regexp: ";;;;;*"; -*-
+;;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;;*"; -*-
;;;
;;; swank-abcl.lisp --- Armedbear CL specific code for SLIME.
;;;
@@ -135,8 +135,7 @@
(defimplementation accept-connection (socket
&key external-format buffering timeout)
- (declare (ignore buffering timeout))
- (assert (member external-format '(nil :iso-latin-1-unix)))
+ (declare (ignore buffering timeout external-format))
(ext:get-socket-stream (ext:socket-accept socket)))
;;;; Unix signals
@@ -303,8 +302,7 @@
(defvar *abcl-signaled-conditions*)
-(defimplementation swank-compile-file (filename load-p
- &optional external-format)
+(defimplementation swank-compile-file (filename load-p external-format)
(declare (ignore external-format))
(let ((jvm::*resignal-compiler-warnings* t)
(*abcl-signaled-conditions* nil))
--- /project/slime/cvsroot/slime/swank-openmcl.lisp 2006/08/14 20:44:20 1.112
+++ /project/slime/cvsroot/slime/swank-openmcl.lisp 2006/11/19 21:33:03 1.113
@@ -168,9 +168,7 @@
(defimplementation accept-connection (socket
&key external-format buffering timeout)
- (declare (ignore buffering timeout))
- (let ((ef (or external-format :iso-latin-1-unix)))
- (assert (eq ef :iso-latin-1-unix)))
+ (declare (ignore buffering timeout external-format))
(ccl:accept-connection socket :wait t))
(defimplementation emacs-connected ()
@@ -298,8 +296,7 @@
(handler-bind ((ccl::compiler-warning 'handle-compiler-warning))
(funcall function)))
-(defimplementation swank-compile-file (filename load-p
- &optional external-format)
+(defimplementation swank-compile-file (filename load-p external-format)
(declare (ignore external-format))
(with-compilation-hooks ()
(let ((*buffer-name* nil)
More information about the slime-cvs
mailing list