Changeset 9356


Ignore:
Timestamp:
May 5, 2008, 11:12:20 AM (11 years ago)
Author:
mb
Message:

Add find-definition-of-thing.

This funtion will attempt to return the source-note which defines the object. Only works for function, class and method
objects.

Location:
branches/working-0711/ccl
Files:
5 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/compiler/optimizers.lisp

    r9350 r9356  
    19361936        `(let* ((,code (char-code ,ch)))
    19371937          (and (eq ,code (setq ,code (char-code ,other)))
    1938            (eq ,code (char-code ,third)))))
     1938               (eq ,code (char-code ,third)))))
    19391939      call)))
    19401940
  • branches/working-0711/ccl/level-1/l1-readloop-lds.lisp

    r8682 r9356  
    100100    (dotimes (i (length r) (terpri))
    101101      (format *debug-io* "~&~d. ~a" i (svref r i)))))
    102 
    103 ;;; From Marco Baringer 2003/03/18
    104102
    105103(define-toplevel-command :break set (n frame value) "Set <n>th item of frame <frame> to <value>"
  • branches/working-0711/ccl/lib/ccl-export-syms.lisp

    r9117 r9356  
    4141     auxilliary-names
    4242     find-definitions-for-name
     43     find-definitions-of-thing
    4344     
    4445     show-documentation
  • branches/working-0711/ccl/lib/chars.lisp

    r8924 r9356  
    445445      (setq start2 0 end2 (length string2))
    446446      (multiple-value-setq (string2 start2 end2)(string-start-end string2 start2 end2)))
    447     (setq istart1 (%i- start1 istart1))       
     447    (setq istart1 (%i- start1 istart1))
    448448    (let* ((val t))
    449449      (declare (optimize (speed 3)(safety 0)))
     
    452452           ()
    453453        (when (eq i end1)
    454           (when (neq j end2)(setq val -1))
     454          (when (neq j end2)
     455            (setq val -1))
    455456          (return))
    456457        (when (eq j end2)
    457458          (setq end1 i)
    458           (setq val 1)(return))
     459          (setq val 1)
     460          (return))
    459461        (let ((code1 (%scharcode string1 i))
    460462              (code2 (%scharcode string2 j)))
     
    501503    (if (eq result -1) nil pos)))
    502504
    503 (defun string-equal (string1 string2 &key start1 end1 start2 end2)
     505(defun string-equal (string1 string2 &key (start1 0) (end1 (length (string string1)))
     506                                          (start2 0) (end2 (length (string string2))))
    504507  "Given two strings (string1 and string2), and optional integers start1,
    505508  start2, end1 and end2, compares characters in string1 to characters in
    506509  string2 (using char-equal)."
    507   (eq t (string-compare string1 start1 end1 string2 start2 end2)))
    508 
     510  (%string-equal (if (typep string1 'simple-string)
     511                   string1
     512                   (multiple-value-setq (string1 start1 end1)
     513                     (string-start-end string1 start1 end1)))
     514                 start1 end1
     515                 (if (typep string2 'simple-string)
     516                   string2
     517                   (multiple-value-setq (string2 start2 end2)
     518                     (string-start-end string2 start2 end2)))
     519                 start2 end2))
     520
     521(defun %string-equal (simple-string-1 start1 end1 simple-string-2 start2 end2)
     522  (declare (type simple-string simple-string-1 simple-string-2)
     523           (type fixnum start1 end1 start2 end2)
     524           (optimize (speed 3) (safety 0) (debug 0)))
     525  (let ((len1 (- end1 start1))
     526        (len2 (- end2 start2)))
     527    (declare (type fixnum len1 len2))
     528    (when (/= len1 len2)
     529      (return-from %string-equal nil))
     530    (do* ((index1 start1 (%i+ 1 index1))
     531          (index2 start2 (%i+ 1 index2))
     532          (char1  (uvref simple-string-1 index1) (uvref simple-string-1 index1))
     533          (char2  (uvref simple-string-2 index2) (uvref simple-string-2 index2)))
     534        ()
     535      (declare (type fixnum index1 index2)
     536               (type character char1 char2))
     537      (when (eq index1 end1)
     538        (return-from %string-equal t))
     539      (when (and (not (char= char1 char2))
     540                 (not (char-equal char1 char2)))
     541        (return-from %string-equal nil)))))
    509542
    510543(defun string-lessp (string1 string2 &key start1 end1 start2 end2)
  • branches/working-0711/ccl/lib/source-files.lisp

    r8965 r9356  
    254254    (second name)))
    255255
    256 (define-definition-name-function function (cons)
    257   (validate-function-name cons)
    258   cons)
     256(define-definition-name-function function (cons) cons)
    259257
    260258(define-definition-name-function function (function)
     
    409407;;;; * Finding definitions from a name
    410408
    411 (defun find-definitions-for-name (name)
     409(defun find-definitions-for-name (name &optional (type-name t))
    412410  "Returns a list of (TYPE . DEFINITION-SOURCE) for all the known definitions of NAME."
    413411  (let ((definitions '()))
    414412    (flet ((collect-def (type name)
    415              (let ((source (definition-source type name)))
    416                (when source
    417                  (push (list type name source) definitions)))))
     413             (when (or (eql t type-name)
     414                       (eql (definition-type-name type) type-name))
     415               (let ((source (definition-source type name)))
     416                 (when source
     417                   (push (list type name source) definitions))))))
    418418      (dolist (definition-type *definition-types*)
    419         (collect-def (definition-type-name definition-type) name)
     419        (collect-def definition-type name)
    420420        (dolist (other-name (auxilliary-names definition-type name))
    421           (collect-def (first other-name) (second other-name))))
     421          (collect-def (definition-type-instance (first other-name)) (second other-name))))
    422422      (remove-duplicates definitions
    423423                         :test (lambda (a b)
    424424                                 (and (eql (first a) (first b))
    425425                                      (definition-name-equal-p (second a) (second b))))))))
     426
     427(defun find-definitions-of-thing (thing)
     428  (let ((definitions '()))
     429    (labels ((def-eql (a b)
     430               (and (eql (first a) (first b))
     431                    (definition-name-equal-p (second a) (second b))))
     432             (collect-def (type name)
     433               (setf definitions
     434                     (remove-duplicates (append definitions
     435                                                (find-definitions-for-name name type))
     436                                        :test #'def-eql))))
     437
     438      (typecase thing
     439        (function  (collect-def 'function (function-name thing)))
     440        (class     (collect-def 'class (class-name thing)))
     441        (method    (collect-def 'method thing))
     442        (symbol    (collect-def 't thing))))
     443
     444    definitions))
    426445
    427446;;;; * backwards compatability. find-definitions-for-name or definition-source is the preferred way
Note: See TracChangeset for help on using the changeset viewer.