Changeset 14958


Ignore:
Timestamp:
01/18/17 07:24:50 (5 years ago)
Author:
Mark Evenson
Message:

abcl-introspect: fix for SYMBOL-FUNCTION

The ANSI-TEST DESCRIBE.* tests were failing because they tried to
describe 'cl:lambda, and there was an error printing the
symbol-function <http://abcl.org/trac/ticket/438>.

In the process of tracking this down I found other cases that might be
problematic and so revised any-function-name, maybe-jss-function, and
print-object to avoid those problems.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/contrib/abcl-introspect/abcl-introspect.lisp

    r14946 r14958  
    175175       (when (and method-function (compiled-function-p method-function))
    176176         (setf (getf (function-plist method-function) :method-function) method)
    177          (annotate-internal-functions (list method-function) method))
     177         (annotate-internal-functions (list method-function) method)
     178         (index-function-class-names (list method-function)))
    178179       (when (and fast-function (compiled-function-p fast-function))
    179180         (setf (getf (function-plist fast-function) :method-fast-function) method)
    180          (annotate-internal-functions (list fast-function) method)))))
     181         (annotate-internal-functions (list fast-function) method)
     182         (index-function-class-names (list method-function))))))
    181183      (if (eq which :all)
    182184    (loop for q = (list (find-class t)) then q
     
    226228named function or the values on the function-plist that functions
    227229above have used annotate local functions"
    228   (maybe-jss-function function)
    229   (let ((interpreted (not (compiled-function-p function))))
    230     (let ((plist (sys::function-plist function)))
    231       (cond ((setq it (getf plist :internal-to-function))
    232        `(:local-function ,@(if (java::jcall "getLambdaName" function)
    233              (list (java::jcall "getLambdaName" function))
    234              (if (getf plist :jss-function)
    235            (list (concatenate 'string "#\"" (getf plist :jss-function) "\"")))
    236              )
    237              ,@(if interpreted '((interpreted)))
    238              :in ,@(if (typep it 'mop::standard-method)
    239            (cons :method (method-spec-list it))
    240            (list it))))
    241       ((setq it (getf plist :method-function))
    242        `(:method-function ,@(if interpreted '((interpreted))) ,@(sys::method-spec-list it)))     
    243       ((setq it (getf plist :method-fast-function))
    244        `(:method-fast-function ,@(if interpreted '("(interpreted)")) ,@(sys::method-spec-list it)))
    245       ((setq it (getf plist :initfunction))
    246        (let ((class (and (slot-boundp it 'allocation-class) (slot-value it 'allocation-class))))
    247          `(:slot-initfunction ,(slot-value it 'name ) ,@(if interpreted '((interpreted))) :for ,(if class (class-name class) '??))))
    248       (t (or (and (nth-value 2 (function-lambda-expression function))
    249       (if interpreted
    250           `(,(nth-value 2 (function-lambda-expression function)) ,'(interpreted))
    251       (nth-value 2 (function-lambda-expression function))))   
    252        (and (not (compiled-function-p function))
    253       `(:anonymous-interpreted-function))
    254        (function-name-by-where-loaded-from function)))))))
     230  (cond ((typep function 'generic-function)
     231   (mop::generic-function-name function))
     232  ((typep function 'mop::method)
     233   (mop::generic-function-name (mop::method-generic-function function)))
     234  (t
     235   (maybe-jss-function function)
     236   (let ((interpreted (not (compiled-function-p function))))
     237     (let ((plist (sys::function-plist function)))
     238       (cond ((setq it (getf plist :internal-to-function))
     239        `(:local-function ,@(if (java::jcall "getLambdaName" function)
     240              (list (java::jcall "getLambdaName" function))
     241              (if (getf plist :jss-function)
     242            (list (concatenate 'string "#\"" (getf plist :jss-function) "\"")))
     243              )
     244              ,@(if interpreted '((interpreted)))
     245              :in ,@(if (typep it 'mop::standard-method)
     246            (cons :method (method-spec-list it))
     247            (list it))))
     248       ((setq it (getf plist :method-function))
     249        `(:method-function ,@(if interpreted '((interpreted))) ,@(sys::method-spec-list it)))   
     250       ((setq it (getf plist :method-fast-function))
     251        `(:method-fast-function ,@(if interpreted '("(interpreted)")) ,@(sys::method-spec-list it)))
     252       ((setq it (getf plist :initfunction))
     253        (let ((class (and (slot-boundp it 'allocation-class) (slot-value it 'allocation-class))))
     254          `(:slot-initfunction ,(slot-value it 'name ) ,@(if interpreted '((interpreted))) :for ,(if class (class-name class) '??))))
     255       ((#"equals" function (symbol-function 'lambda))
     256        '(:macro-function lambda))
     257       (t (or (and (nth-value 2 (function-lambda-expression function))
     258             (if interpreted
     259           `(,(nth-value 2 (function-lambda-expression function)) ,'(interpreted))
     260           (let ((name (nth-value 2 (function-lambda-expression function))))
     261             (if (macro-function-p function)
     262           `(:macro ,name)
     263           name))))
     264        (and (not (compiled-function-p function))
     265             `(:anonymous-interpreted-function))
     266        (function-name-by-where-loaded-from function)))))))))
    255267
    256268(defun function-name-by-where-loaded-from (function)
     
    268280  name of the java methods"
    269281  (and (find-package :jss)
     282       (eq (type-of f) 'compiled-function)
    270283       (or (getf (sys::function-plist f) :jss-function)
    271284     (let ((internals (function-internal-fields f)))
     
    293306  system::output-ugly-object in order to prevent the function being
    294307  printed by a java primitive"
    295   (print-unreadable-object (f stream :identity t)
    296     (let ((name (any-function-name  f)))
    297        (if (consp name)
    298            (format stream "~{~a~^ ~}" name)
    299            (princ name stream)))))
     308  (if (or (typep f 'mop::generic-function)
     309    (typep f 'mop::method))
     310      (call-next-method)
     311      (print-unreadable-object (f stream :identity t)
     312  (let ((name (any-function-name  f)))
     313    (if (consp name)
     314        (format stream "~{~a~^ ~}" name)
     315        (format stream "function ~a" name))))))
    300316
    301317(defun each-non-symbol-compiled-function (f)
     
    325341    (annotate-clos-methods)
    326342    (annotate-clos-slots)
    327     (index-function-class-names)
     343    (index-function-class-names) ;; still missing some cases e.g. generic functions and method functions
    328344    )
    329345  (index-function-class-names (list function))
     
    334350
    335351(defmethod mop::add-direct-method :after (class method)
    336   (annotate-clos-methods (list method)))
     352  (annotate-clos-methods (list method))
     353)
    337354
    338355(defmethod mop::ensure-class-using-class :after (class name  &key direct-slots
     
    344361(pushnew 'fset-hook-annotate-internal-function sys::*fset-hooks*)
    345362
    346 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    347      
    348363(provide :abcl-introspect)
Note: See TracChangeset for help on using the changeset viewer.