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

Diff of /slime/swank-sbcl.lisp

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

revision 1.87 by lgorrie, Tue Jun 8 23:57:35 2004 UTC revision 1.88 by heller, Thu Jun 10 17:56:41 2004 UTC
# Line 209  information." Line 209  information."
209    
210  ;; SBCL doesn't have compile-from-stream, so C-c C-c ends up here  ;; SBCL doesn't have compile-from-stream, so C-c C-c ends up here
211  (defmethod resolve-note-location ((b string) (f (eql :lisp)) pos path source)  (defmethod resolve-note-location ((b string) (f (eql :lisp)) pos path source)
212    ;; Remove the sourounding lambda from the path (was added by    ;; Remove the surrounding lambda from the path (was added by
213    ;; swank-compile-string)    ;; swank-compile-string)
214    (destructuring-bind (_ form &rest rest) path    (destructuring-bind (_ form &rest rest) path
215      (declare (ignore _))      (declare (ignore _))
# Line 635  stack." Line 635  stack."
635                   (sb-pcl::generic-function-initial-methods  o)))))                   (sb-pcl::generic-function-initial-methods  o)))))
636    
637    
638    ;;;; Support for SBCL syntax
639    
640    (defun feature-in-list-p (feature list)
641      (etypecase feature
642        (symbol (member feature list :test #'eq))
643        (cons (flet ((subfeature-in-list-p (subfeature)
644                       (feature-in-list-p subfeature list)))
645                (ecase (first feature)
646                  (:or  (some  #'subfeature-in-list-p (rest feature)))
647                  (:and (every #'subfeature-in-list-p (rest feature)))
648                  (:not (let ((rest (cdr feature)))
649                          (if (or (null (car rest)) (cdr rest))
650                            (error "wrong number of terms in compound feature ~S"
651                                   feature)
652                            (not (subfeature-in-list-p (second feature)))))))))))
653    
654    (defun shebang-reader (stream sub-character infix-parameter)
655      (declare (ignore sub-character))
656      (when infix-parameter
657        (error "illegal read syntax: #~D!" infix-parameter))
658      (let ((next-char (read-char stream)))
659        (unless (find next-char "+-")
660          (error "illegal read syntax: #!~C" next-char))
661        ;; When test is not satisfied
662        ;; FIXME: clearer if order of NOT-P and (NOT NOT-P) were reversed? then
663        ;; would become "unless test is satisfied"..
664        (when (let* ((*package* (find-package "KEYWORD"))
665                     (*read-suppress* nil)
666                     (not-p (char= next-char #\-))
667                     (feature (read stream)))
668                (if (feature-in-list-p feature *features*)
669                    not-p
670                    (not not-p)))
671          ;; Read (and discard) a form from input.
672          (let ((*read-suppress* t))
673            (read stream t nil t))))
674     (values))
675    
676    (defvar *shebang-readtable*
677      (let ((*readtable* (copy-readtable nil)))
678        (set-dispatch-macro-character #\# #\!
679                                      (lambda (s c n) (shebang-reader s c n))
680                                      *readtable*)
681        *readtable*))
682    
683    (defun shebang-readtable ()
684      *shebang-readtable*)
685    
686    (defun sbcl-package-p (package)
687      (let ((name (package-name package)))
688        (eql (mismatch "SB-" name) 3)))
689    
690    (defvar *debootstrap-packages* t)
691    
692    (defimplementation call-with-syntax-hooks (fn)
693      (cond ((and *debootrap-packages*
694                  (sbcl-package-p *package*))
695             (handler-bind ((sb-int:bootstrap-package-not-found
696                             #'sb-int:debootstrap-package))
697               (funcall fn)))
698            (t
699             (funcall fn))))
700    
701    
702  ;;;; Multiprocessing  ;;;; Multiprocessing
703    
704  #+sb-thread  #+sb-thread

Legend:
Removed from v.1.87  
changed lines
  Added in v.1.88

  ViewVC Help
Powered by ViewVC 1.1.5