Changeset 8871


Ignore:
Timestamp:
Mar 24, 2008, 1:23:30 PM (11 years ago)
Author:
mb
Message:

Record source location for condition classe with the label CONDITION (instead of CLASS)

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

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/level-0/l0-source-files.lisp

    r8867 r8871  
    3030(defun register-definition-type (name)
    3131  (push name *early-definition-types*))
     32
     33(defun definition-name-equal-p (a b)
     34  "Returns T if A and B represent the same definition-name."
     35  (let ((seen '()))
     36    (labels ((rec (a b)
     37             (cond
     38               ((and (atom a) (atom b)) (eql a b))
     39               ((and (consp a) (consp b))
     40                (when (or (member a seen)
     41                          (member b seen))
     42                  (return-from definition-name-equal-p nil))
     43                (push a seen)
     44                (push b seen)
     45                (and (rec (car a) (car b))
     46                     (rec (cdr a) (cdr b))))
     47               (t nil))))
     48      (rec a b))))
     49
     50(defun remove-definition-source (type-name name)
     51  (setf *early-source-files*
     52        (delete-if (lambda (def)
     53                     (and (eq (first def) type-name)
     54                          (definition-name-equal-p (second def) name)))
     55                   *early-source-files*))
     56  *early-source-files*)
  • branches/working-0711/ccl/lib/macros.lisp

    r8783 r8871  
    21102110       (defclass ,name ,(or supers '(condition)) ,slots ,@classopts)
    21112111       ,@reporter
     2112       ;; defclass will record name as a class, we only want
     2113       (remove-definition-source 'class ',name)
     2114       (record-source-file ',name 'condition)
    21122115       ',name)))
     2116
     2117(define-definition-type condition (class-definition-type))
    21132118
    21142119(defmacro with-condition-restarts (&environment env condition restarts &body body)
  • branches/working-0711/ccl/lib/source-files.lisp

    r8867 r8871  
    9090                           *source-files*)))))))
    9191
     92;; defined as a function in l0-source-files.lisp
     93(fmakunbound 'remove-definition-source)
     94(defgeneric remove-definition-source (definition-type name)
     95  (:method ((definition-type-name symbol) name)
     96    (remove-definition-source (definition-type-instance definition-type-name) name))
     97  (:method ((definition-type definition-type) name)
     98    (symbol-macrolet ((definitions
     99                          (gethash (definition-short-name definition-type effective-name) *source-files*)))
     100      (let ((effective-name (effective-name definition-type name)))
     101        (setf definitions (delete-if (lambda (def)
     102                                       (and (eq (first def) (definition-type-name definition-type))
     103                                            (definition-name-equal-p (second def) effective-name)))
     104                                     definitions))
     105        (when (null definitions)
     106          (remhash (definition-short-name definition-type effective-name) *source-files*))))
     107    *source-files*))
     108
    92109(defun definition-name-equal-p (a b)
    93110  "Returns T if A and B represent the same definition-name."
     
    97114               ((and (atom a) (atom b)) (eql a b))
    98115               ((and (consp a) (consp b))
    99                 (if (or (member a seen)
    100                         (member b seen))
    101                   (return-from definition-name-equal-p nil)
    102                   (prog1
    103                       (and (rec (car a) (car b))
    104                            (rec (cdr a) (cdr b)))
    105                     (push a seen)
    106                     (push b seen))))
     116                (when (or (member a seen)
     117                          (member b seen))
     118                  (return-from definition-name-equal-p nil))
     119                (push a seen)
     120                (push b seen)
     121                (and (rec (car a) (car b))
     122                     (rec (cdr a) (cdr b))))
    107123               (t nil))))
    108124      (rec a b))))
Note: See TracChangeset for help on using the changeset viewer.