Ignore:
Timestamp:
Mar 26, 2006, 3:12:45 AM (13 years ago)
Author:
gb
Message:

rearrange %type-of for tag changes.

File:
1 edited

Legend:

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

    r3838 r3885  
    701701(progn
    702702(defparameter *nodeheader-0-types*
    703   #(function-vector
     703  #(bogus
    704704    symbol-vector
    705705    catch-frame
     
    709709    package
    710710    slot-vector
    711     lisp-thread                         ;8
    712     vector-header
    713     bogus
     711    lisp-thread
     712    function-vector                                        ;8
     713    array--header
    714714    bogus
    715715    bogus
     
    720720
    721721(defparameter *nodeheader-1-types*
    722   #(ratio
     722  #(bogus
     723    ratio
    723724    complex
    724     instance
    725725    struct
    726726    istruct
    727727    value-cell
    728728    xfunction
    729     lock                                ;7
    730     array-header
     729    lock
     730    instance
     731    bogus
     732    vector-header
    731733    simple-vector
    732     bogus
    733     bogus
    734734    bogus
    735735    bogus
     
    820820 
    821821(defun %type-of (thing)
    822   (let* ((fulltag (fulltag thing))
    823          (high4 (ash (the fixnum (%lisp-lowbyte-ref thing)) (- x8664::ntagbits))))
    824     (declare (fixnum fulltag high4))
    825     (if (= fulltag x8664::fulltag-function)
    826       (let ((bits (lfun-bits thing)))
    827         (declare (fixnum bits))
    828         (if (logbitp $lfbits-trampoline-bit bits)
    829           (if (logbitp $lfbits-evaluated-bit bits)
    830             'interpreted-lexical-closure
    831             (let ((inner-fn (closure-function thing)))
    832               (if (neq inner-fn thing)
    833                 (let ((inner-bits (lfun-bits inner-fn)))
    834                   (if (logbitp $lfbits-method-bit inner-bits)
    835                     'compiled-lexical-closure
    836                     (if (logbitp $lfbits-gfn-bit inner-bits)
    837                       'standard-generic-function ; not precisely - see class-of
    838                       (if (logbitp  $lfbits-cm-bit inner-bits)
    839                         'combined-method
    840                         'compiled-lexical-closure))))
    841                 'compiled-lexical-closure)))
    842           (if (logbitp $lfbits-evaluated-bit bits)
    843             (if (logbitp $lfbits-method-bit bits)
    844               'interpreted-method-function
    845               'interpreted-function)
    846             (if (logbitp  $lfbits-method-bit bits)
    847               'method-function         
    848               'compiled-function))))
    849       (%svref (%svref *x8664-fulltag-types* fulltag) high4))))
     822  (let* ((lisptag (lisptag thing))
     823         (typecode (typecode thing))
     824         (high4 (ash typecode (- x8664::ntagbits))))
     825    (declare (type (mod 8) lisptag)
     826             (type (mod 256) typecode))
     827    (if (logbitp lisptag (logior (ash 1 x8664::fulltag-nodeheader-0)
     828                                 (ash 1 x8664::fulltag-nodeheader-1)
     829                                 (ash 1 x8664::fulltag-immheader-0)
     830                                 (ash 1 x8664::fulltag-immheader-1)
     831                                 (ash 1 x8664::fulltag-immheader-2)))
     832      (%svref (%svref *x8664-fulltag-types* fulltag) high4)
     833      (if (= lisp x8664::tag-function)
     834        (let ((bits (lfun-bits thing)))
     835          (declare (fixnum bits))
     836          (if (logbitp $lfbits-trampoline-bit bits)
     837            (if (logbitp $lfbits-evaluated-bit bits)
     838              'interpreted-lexical-closure
     839              (let ((inner-fn (closure-function thing)))
     840                (if (neq inner-fn thing)
     841                  (let ((inner-bits (lfun-bits inner-fn)))
     842                    (if (logbitp $lfbits-method-bit inner-bits)
     843                      'compiled-lexical-closure
     844                      (if (logbitp $lfbits-gfn-bit inner-bits)
     845                        'standard-generic-function ; not precisely - see class-of
     846                        (if (logbitp  $lfbits-cm-bit inner-bits)
     847                          'combined-method
     848                          'compiled-lexical-closure))))
     849                  'compiled-lexical-closure)))
     850            (if (logbitp $lfbits-evaluated-bit bits)
     851              (if (logbitp $lfbits-method-bit bits)
     852                'interpreted-method-function
     853                'interpreted-function)
     854              (if (logbitp  $lfbits-method-bit bits)
     855                'method-function         
     856                'compiled-function))))
     857        (%svref (%svref *x8664-fulltag-types* fulltag)
     858                (the fixnum (ash (%lisp-lowbyte-ref thing)
     859                                 (- x8664::ntagbits))))))))
     860       
    850861
    851862);#+x8664-target
Note: See TracChangeset for help on using the changeset viewer.