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

Diff of /slime/swank-cmucl.lisp

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

revision 1.101 by heller, Tue May 4 19:02:36 2004 UTC revision 1.102 by heller, Sat May 8 19:00:38 2004 UTC
# Line 146  Line 146 
146  (defimplementation lisp-implementation-type-name ()  (defimplementation lisp-implementation-type-name ()
147    "cmucl")    "cmucl")
148    
149    (defimplementation quit-lisp ()
150      (ext::quit))
151    
152    
153  ;;;; Stream handling  ;;;; Stream handling
154    
# Line 815  NAME can any valid function name (e.g, ( Line 818  NAME can any valid function name (e.g, (
818            (make-location `(:buffer ,emacs-buffer)            (make-location `(:buffer ,emacs-buffer)
819                           `(:position ,(+ emacs-buffer-offset pos))))))))                           `(:position ,(+ emacs-buffer-offset pos))))))))
820    
821    ;; XXX predicates for 18e backward compatibilty.  Remove them when
822    ;; we're 19a only.
823  (defun file-source-location-p (object)  (defun file-source-location-p (object)
824    (when (fboundp 'c::file-source-location-p)    (when (fboundp 'c::file-source-location-p)
825      (c::file-source-location-p object)))      (c::file-source-location-p object)))
# Line 823  NAME can any valid function name (e.g, ( Line 828  NAME can any valid function name (e.g, (
828    (when (fboundp 'c::stream-source-location-p)    (when (fboundp 'c::stream-source-location-p)
829      (c::stream-source-location-p object)))      (c::stream-source-location-p object)))
830    
831    (defun source-location-p (object)
832      (or (file-source-location-p object)
833          (stream-source-location-p object)))
834    
835    (defun resolve-source-location (location)
836      (etypecase location
837        ((satisfies file-source-location-p)
838         (resolve-file-source-location location))
839        ((satisfies stream-source-location-p)
840         (resolve-stream-source-location location))))
841    
842  (defun definition-source-location (object name)  (defun definition-source-location (object name)
843    (let ((source (pcl::definition-source object)))    (let ((source (pcl::definition-source object)))
844      (etypecase source      (etypecase source
845        (null        (null
846         `(:error ,(format nil "No source info for: ~A" object)))         `(:error ,(format nil "No source info for: ~A" object)))
847        ((satisfies file-source-location-p)        ((satisfies source-location-p)
848         (resolve-file-source-location source))         (resolve-source-location source))
       ((satisfies stream-source-location-p)  
        (resolve-stream-source-location source))  
849        (pathname        (pathname
850         (make-name-in-file-location source name))         (make-name-in-file-location source name))
851        (cons        (cons
# Line 869  NAME can any valid function name (e.g, ( Line 883  NAME can any valid function name (e.g, (
883          (list (list `(setf ,name)          (list (list `(setf ,name)
884                      (function-location (coerce function 'function)))))))                      (function-location (coerce function 'function)))))))
885    
886    
887    (defun variable-location (symbol)
888      (multiple-value-bind (location foundp)
889          ;; XXX for 18e compatibilty. rewrite this when we drop 18e
890          ;; support.
891          (ignore-errors (eval `(ext:info :source-location :defvar ',symbol)))
892        (if (and foundp location)
893            (resolve-source-location location)
894            `(:error ,(format nil "No source info for variable ~S" symbol)))))
895    
896    (defun variable-definitions (name)
897      (if (symbolp name)
898          (multiple-value-bind (kind recorded-p) (ext:info :variable :kind name)
899            (if recorded-p
900                (list (list `(variable ,kind ,name)
901                            (variable-location name)))))))
902    
903  (defun compiler-macro-definitions (symbol)  (defun compiler-macro-definitions (symbol)
904    (maybe-make-definition (compiler-macro-function symbol)    (maybe-make-definition (compiler-macro-function symbol)
905                           'define-compiler-macro                           'define-compiler-macro
# Line 909  NAME can any valid function name (e.g, ( Line 940  NAME can any valid function name (e.g, (
940  (defimplementation find-definitions (name)  (defimplementation find-definitions (name)
941    (append (function-definitions name)    (append (function-definitions name)
942            (setf-definitions name)            (setf-definitions name)
943              (variable-definitions name)
944            (class-definitions name)            (class-definitions name)
945            (type-definitions name)            (type-definitions name)
946            (compiler-macro-definitions name)            (compiler-macro-definitions name)
947            (source-transform-definitions name)            (source-transform-definitions name)
948            (function-info-definitions name)            (function-info-definitions name)
949            (ir1-translator-definitions name)))            (ir1-translator-definitions name)))
950    
951    
952  ;;;; Documentation.  ;;;; Documentation.
953    
# Line 1116  A utility for debugging DEBUG-FUNCTION-A Line 1149  A utility for debugging DEBUG-FUNCTION-A
1149  (defimplementation macroexpand-all (form)  (defimplementation macroexpand-all (form)
1150    (walker:macroexpand-all form))    (walker:macroexpand-all form))
1151    
 ;; (in-package :c)  
 ;;  
 ;; (defun swank-backend::expand-ir1-top-level (form)  
 ;;   "A scaled down version of the first pass of the compiler."  
 ;;   (with-compilation-unit ()  
 ;;     (let* ((*lexical-environment*  
 ;;             (make-lexenv :default (make-null-environment)  
 ;;                          :cookie *default-cookie*  
 ;;                          :interface-cookie *default-interface-cookie*))  
 ;;            (*source-info* (make-lisp-source-info form))  
 ;;            (*block-compile* nil)  
 ;;            (*block-compile-default* nil))  
 ;;       (with-ir1-namespace  
 ;;           (clear-stuff)  
 ;;         (find-source-paths form 0)  
 ;;         (ir1-top-level form '(0) t)))))  
 ;;  
 ;; (in-package :swank-backend)  
 ;;  
 ;; (defun print-ir1-converted-blocks (form)  
 ;;   (with-output-to-string (*standard-output*)  
 ;;     (c::print-all-blocks (expand-ir1-top-level (from-string form)))))  
 ;;  
 ;; (defun print-compilation-trace (form)  
 ;;   (with-output-to-string (*standard-output*)  
 ;;     (with-input-from-string (s form)  
 ;;       (ext:compile-from-stream s  
 ;;                                :verbose t  
 ;;                                :progress t  
 ;;                                :trace-stream *standard-output*))))  
   
1152  (defimplementation set-default-directory (directory)  (defimplementation set-default-directory (directory)
1153    (setf (ext:default-directory) (namestring directory))    (setf (ext:default-directory) (namestring directory))
1154    ;; Setting *default-pathname-defaults* to an absolute directory    ;; Setting *default-pathname-defaults* to an absolute directory
# Line 1413  LRA  =  ~X~%" (mapcar #'fixnum Line 1415  LRA  =  ~X~%" (mapcar #'fixnum
1415        (di::bogus-debug-function        (di::bogus-debug-function
1416         (format t "~%[Disassembling bogus frames not implemented]")))))         (format t "~%[Disassembling bogus frames not implemented]")))))
1417    
 #+(or)  
 (defun print-binding-stack ()  
   (flet ((bsp- (p) (sys:sap+ p (- (* vm:binding-size vm:word-bytes))))  
          (frob (p offset) (kernel:make-lisp-obj (sys:sap-ref-32 p offset))))  
     (do ((bsp (bsp- (kernel:binding-stack-pointer-sap)) (bsp- bsp))  
          (start (sys:int-sap (lisp::binding-stack-start))))  
         ((sys:sap= bsp start))  
       (format t "~X:  ~S = ~S~%"  
               (sys:sap-int bsp)  
               (frob bsp (* vm:binding-symbol-slot vm:word-bytes))  
               (frob bsp (* vm:binding-value-slot vm:word-bytes))))))  
   
 ;; (print-binding-stack)  
   
 #+(or)  
 (defun print-catch-blocks ()  
   (do ((b (di::descriptor-sap lisp::*current-catch-block*)  
           (sys:sap-ref-sap b (* vm:catch-block-previous-catch-slot  
                                 vm:word-bytes))))  
       (nil)  
     (let ((int (sys:sap-int b)))  
       (when (zerop int) (return))  
       (flet ((ref (offset) (sys:sap-ref-32 b (* offset vm:word-bytes))))  
         (let ((uwp (ref vm:catch-block-current-uwp-slot))  
               (cfp (ref vm:catch-block-current-cont-slot))  
               (tag (ref vm:catch-block-tag-slot))  
               )  
       (format t "~X:  uwp = ~8X  cfp = ~8X  tag = ~X~%"  
               int uwp cfp (kernel:make-lisp-obj tag)))))))  
   
 ;; (print-catch-blocks)  
   
 #+(or)  
 (defun print-unwind-blocks ()  
   (do ((b (di::descriptor-sap lisp::*current-unwind-protect-block*)  
           (sys:sap-ref-sap b (* vm:unwind-block-current-uwp-slot  
                                 vm:word-bytes))))  
       (nil)  
     (let ((int (sys:sap-int b)))  
       (when (zerop int) (return))  
       (flet ((ref (offset) (sys:sap-ref-32 b (* offset vm:word-bytes))))  
         (let ((cfp (ref vm:unwind-block-current-cont-slot)))  
           (format t "~X:  cfp = ~X~%" int cfp))))))  
   
 ;; (print-unwind-blocks)  
   
1418    
1419  ;;;; Inspecting  ;;;; Inspecting
1420    
# Line 1473  LRA  =  ~X~%" (mapcar #'fixnum Line 1429  LRA  =  ~X~%" (mapcar #'fixnum
1429      vm:other-pointer-type))      vm:other-pointer-type))
1430    
1431  (defconstant +header-type-symbols+  (defconstant +header-type-symbols+
1432    ;; Is there a convinient place for all those constants?    (flet ((suffixp (suffix string)
1433    (flet ((tail-comp (string tail)             (and (>= (length string) (length suffix))
1434             (and (>= (length string) (length tail))                  (string= string suffix :start1 (- (length string)
1435                  (string= string tail :start1 (- (length string)                                                    (length suffix))))))
1436                                                  (length tail))))))      ;; Is there a convinient place for all those constants?
1437      (remove-if-not      (remove-if-not
1438       (lambda (x) (and (tail-comp (symbol-name x) "-TYPE")       (lambda (x) (and (suffixp "-TYPE" (symbol-name x))
1439                        (not (member x +lowtag-symbols+))                        (not (member x +lowtag-symbols+))
1440                        (boundp x)                        (boundp x)
1441                        (typep (symbol-value x) 'fixnum)))                        (typep (symbol-value x) 'fixnum)))
1442       (append (apropos-list "-TYPE" "VM" t)       (append (apropos-list "-TYPE" "VM" t)
1443               (apropos-list "-TYPE" "BIGNUM" t)))))               (apropos-list "-TYPE" "BIGNUM" t))))
1444      "A list of names of the type codes in boxed objects.")
1445    
1446  (defimplementation describe-primitive-type (object)  (defimplementation describe-primitive-type (object)
1447    (with-output-to-string (*standard-output*)    (with-output-to-string (*standard-output*)
# Line 1641  LRA  =  ~X~%" (mapcar #'fixnum Line 1598  LRA  =  ~X~%" (mapcar #'fixnum
1598          (pop (mailbox.queue mbox)))))          (pop (mailbox.queue mbox)))))
1599    
1600    )    )
   
 (defimplementation quit-lisp ()  
   (ext::quit))  

Legend:
Removed from v.1.101  
changed lines
  Added in v.1.102

  ViewVC Help
Powered by ViewVC 1.1.5