Ignore:
Timestamp:
Dec 31, 2003, 11:03:33 AM (16 years ago)
Author:
gb
Message:

Half-hearted change to %TYPEP, to handle foreign-typed macptrs.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/ccl/level-0/l0-pred.lisp

    r114 r163  
    381381            'base-char
    382382            'immediate)
    383           (let* ((tag-type (logand typecode ppc32::full-tag-mask))
    384                  (tag-val (ash typecode (- ppc32::ntagbits))))
    385             (declare (fixnum tag-type tag-val))
    386             ;; When we get to the point that we can differentiate between
    387             ;; different types of functions, do so.
    388             (if (/= tag-type ppc32::fulltag-nodeheader)
    389               (%svref *immheader-types* tag-val)
    390               (let ((type (%svref *nodeheader-types* tag-val)))
    391                 (if (eq type 'function)
    392                   (let ((bits (lfun-bits thing)))
    393                     (declare (fixnum bits))
    394                     (if (logbitp $lfbits-trampoline-bit bits)
    395                       (if (logbitp $lfbits-evaluated-bit bits)
    396                         'interpreted-lexical-closure
    397                         (let ((inner-fn (closure-function thing)))
    398                           (if (neq inner-fn thing)
    399                             (let ((inner-bits (lfun-bits inner-fn)))
    400                               (if (logbitp $lfbits-method-bit inner-bits)
    401                                 'compiled-lexical-closure
    402                                 (if (logbitp $lfbits-gfn-bit inner-bits)
    403                                   'standard-generic-function ; not precisely - see class-of
    404                                   (if (logbitp  $lfbits-cm-bit inner-bits)
    405                                     'combined-method
    406                                     'compiled-lexical-closure))))
    407                             'compiled-lexical-closure)))
    408                       (if (logbitp $lfbits-evaluated-bit bits)
    409                         (if (logbitp $lfbits-method-bit bits)
    410                           'interpreted-method-function
    411                           'interpreted-function)
    412                         (if (logbitp  $lfbits-method-bit bits)
    413                           'method-function         
    414                           'compiled-function))))
    415                   (if (eq type 'lock)
    416                     (or (uvref thing ppc32::lock.kind-cell)
    417                         type)
    418                     type))))))))))
     383          (if (= typecode ppc32::subtag-macptr)
     384            (if (classp thing)
     385              (class-name thing)
     386              'macptr)
     387            (let* ((tag-type (logand typecode ppc32::full-tag-mask))
     388                   (tag-val (ash typecode (- ppc32::ntagbits))))
     389              (declare (fixnum tag-type tag-val))
     390              (if (/= tag-type ppc32::fulltag-nodeheader)
     391                (%svref *immheader-types* tag-val)
     392                (let ((type (%svref *nodeheader-types* tag-val)))
     393                  (if (eq type 'function)
     394                    (let ((bits (lfun-bits thing)))
     395                      (declare (fixnum bits))
     396                      (if (logbitp $lfbits-trampoline-bit bits)
     397                        (if (logbitp $lfbits-evaluated-bit bits)
     398                          'interpreted-lexical-closure
     399                          (let ((inner-fn (closure-function thing)))
     400                            (if (neq inner-fn thing)
     401                              (let ((inner-bits (lfun-bits inner-fn)))
     402                                (if (logbitp $lfbits-method-bit inner-bits)
     403                                  'compiled-lexical-closure
     404                                  (if (logbitp $lfbits-gfn-bit inner-bits)
     405                                    'standard-generic-function ; not precisely - see class-of
     406                                    (if (logbitp  $lfbits-cm-bit inner-bits)
     407                                      'combined-method
     408                                      'compiled-lexical-closure))))
     409                              'compiled-lexical-closure)))
     410                        (if (logbitp $lfbits-evaluated-bit bits)
     411                          (if (logbitp $lfbits-method-bit bits)
     412                            'interpreted-method-function
     413                            'interpreted-function)
     414                          (if (logbitp  $lfbits-method-bit bits)
     415                            'method-function         
     416                            'compiled-function))))
     417                    (if (eq type 'lock)
     418                      (or (uvref thing ppc32::lock.kind-cell)
     419                          type)
     420                      type)))))))))))
    419421
    420422
Note: See TracChangeset for help on using the changeset viewer.