/[slime]/slime/swank.lisp
ViewVC logotype

Diff of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.264 by heller, Fri Nov 19 19:02:19 2004 UTC revision 1.265 by heller, Wed Nov 24 19:52:52 2004 UTC
# Line 46  Line 46 
46             #:quit-lisp             #:quit-lisp
47             ))             ))
48    
49  (in-package #:swank)  (in-package :swank)
50    
51  ;;;; Top-level variables, constants, macros  ;;;; Top-level variables, constants, macros
52    
# Line 581  of the toplevel restart." Line 581  of the toplevel restart."
581  ;;;;;; Simple sequential IO  ;;;;;; Simple sequential IO
582    
583  (defun simple-serve-requests (connection)  (defun simple-serve-requests (connection)
584    (let ((socket-io (connection.socket-io connection)))    (with-reader-error-handler (connection)
585      (with-reader-error-handler (connection)      (loop (handle-request connection))))
       (loop (handle-request connection)))))  
586    
587  (defun read-from-socket-io ()  (defun read-from-socket-io ()
588    (let ((event (decode-message (current-socket-io))))    (let ((event (decode-message (current-socket-io))))
# Line 957  Emacs buffer." Line 956  Emacs buffer."
956         ;; Don't shadow *readtable* unnecessarily because that prevents         ;; Don't shadow *readtable* unnecessarily because that prevents
957         ;; the user from assigning to it.         ;; the user from assigning to it.
958         (if (eq *readtable* *buffer-readtable*)         (if (eq *readtable* *buffer-readtable*)
959             #1=(call-with-syntax-hooks (lambda () ,@body))             (call-with-syntax-hooks (lambda () ,@body))
960             (let ((*readtable* *buffer-readtable*))             (let ((*readtable* *buffer-readtable*))
961               #1#)))))               (call-with-syntax-hooks (lambda () ,@body)))))))
962    
963  (defun from-string (string)  (defun from-string (string)
964    "Read string in the *BUFFER-PACKAGE*"    "Read string in the *BUFFER-PACKAGE*"
# Line 1105  pretty printing of (function foo) as #'f Line 1104  pretty printing of (function foo) as #'f
1104    (string= (arglist-to-string list (find-package :swank)) string))    (string= (arglist-to-string list (find-package :swank)) string))
1105    
1106  ;; Should work:  ;; Should work:
1107  (assert (test-print-arglist '(function cons) "(function cons)"))  (progn
1108  (assert (test-print-arglist '(quote cons) "(quote cons)"))    (assert (test-print-arglist '(function cons) "(function cons)"))
1109  (assert (test-print-arglist '(&key (function #'+)) "(&key (function #'+))"))    (assert (test-print-arglist '(quote cons) "(quote cons)"))
1110      (assert (test-print-arglist '(&key (function #'+)) "(&key (function #'+))")))
1111  ;; Expected failure:  ;; Expected failure:
1112  ;; (assert (test-print-arglist '(&key ((function f))) "(&key ((function f)))"))  ;; (assert (test-print-arglist '(&key ((function f))) "(&key ((function f)))"))
1113    
# Line 2601  Do NOT pass circular lists to this funct Line 2601  Do NOT pass circular lists to this funct
2601  (defun inspect-for-emacs-list (list)  (defun inspect-for-emacs-list (list)
2602    (let ((maxlen 40))    (let ((maxlen 40))
2603      (multiple-value-bind (length tail) (safe-length list)      (multiple-value-bind (length tail) (safe-length list)
2604        (flet ((frob (title list &rest rest)        (flet ((frob (title list)
2605                 (values title                 (let ((lines
2606                         (append '("Elements:" (:newline))                        (do ((i 0 (1+ i))
2607                                 (loop for i from 0                             (l list (cdr l))
2608                                       for e in list                             (a '() (cons (label-value-line i (car l)) a)))
2609                                       append (label-value-line i e))                            ((not (consp l))
2610                                 rest))))                             (let ((a (if (null l)
2611                                            a
2612                                            (cons (label-value-line :tail l) a))))
2613                                 (apply #'append (reverse a)))))))
2614                     (values title (append '("Elements:" (:newline)) lines)))))
2615    
2616          (cond ((not length)             ; circular          (cond ((not length)             ; circular
2617                 (frob "A circular list."                 (frob "A circular list."
2618                       (cons (car list)                       (cons (car list)
# Line 2615  Do NOT pass circular lists to this funct Line 2620  Do NOT pass circular lists to this funct
2620                ((and (<= length maxlen) (not tail))                ((and (<= length maxlen) (not tail))
2621                 (frob "A proper list." list))                 (frob "A proper list." list))
2622                (tail                (tail
2623                 (frob "An improper list."                 (frob "An improper list." list))
                      (subseq list 0 length)  
                      (list :value tail "tail")))  
2624                (t                (t
2625                 (frob "A proper list."                 (frob "A proper list." list)))))))
2626                       (subseq list 0 maxlen)  
2627                       (list :value (nthcdr maxlen list) "rest"))))))))  ;; (inspect-for-emacs-list '#1=(a #1# . #1# ))
2628    
2629  (defun safe-length (list)  (defun safe-length (list)
2630    "Similar to `list-length', but avoid errors on improper lists.    "Similar to `list-length', but avoid errors on improper lists.
# Line 3055  See `methods-by-applicability'.") Line 3058  See `methods-by-applicability'.")
3058    (values "A number."    (values "A number."
3059            (append            (append
3060             `(,(format nil "Value: ~D = #x~X = #o~O = #b~,,' ,8:B = ~E"             `(,(format nil "Value: ~D = #x~X = #o~O = #b~,,' ,8:B = ~E"
3061                        i i i i i)                        i i i i i)
3062                (:newline))                (:newline))
3063             (if (< -1 i char-code-limit)             (if (< -1 i char-code-limit)
3064                 (label-value-line "Corresponding character" (code-char i)))                 (label-value-line "Corresponding character" (code-char i)))

Legend:
Removed from v.1.264  
changed lines
  Added in v.1.265

  ViewVC Help
Powered by ViewVC 1.1.5