Ignore:
Timestamp:
Feb 12, 2006, 2:51:31 AM (14 years ago)
Author:
gb
Message:

Start to conditionalize for #+x8664-target.

File:
1 edited

Legend:

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

    r2666 r3437  
    9595        (and (>= typecode ppc32::min-numeric-subtag)
    9696             (<= typecode ppc32::max-rational-subtag))
    97         #+ppc64-target
    98         (cond ((= typecode ppc64::subtag-bignum) t)
    99               ((= typecode ppc64::subtag-ratio) t)))))
     97        #+(or ppc64-target x8664-target)
     98        (cond ((= typecode target::subtag-bignum) t)
     99              ((= typecode target::subtag-ratio) t)))))
    100100
    101101(defun short-float-p (x)
     
    128128                       (ash 1 ppc64::subtag-double-float)
    129129                       (ash 1 ppc64::subtag-bignum)
    130                        (ash 1 ppc64::subtag-ratio))))))
     130                       (ash 1 ppc64::subtag-ratio))))
     131    #+x8664-target
     132    (if (< typecode x8664::nbits-in-word)
     133      (logbitp (the (integer 0 #.x8664::subtag-double-float) typecode)
     134               (logior (ash 1 x8664::tag-fixnum)
     135                       (ash 1 x8664::subtag-bignum)
     136                       (ash 1 x8664::tag-single-float)
     137                       (ash 1 x8664::subtag-double-float)
     138                       (ash 1 x8664::subtag-ratio))))))
    131139
    132140(defun complexp (x)
     
    150158                       (ash 1 ppc64::subtag-double-float)
    151159                       (ash 1 ppc64::subtag-ratio)
    152                        (ash 1 ppc64::subtag-complex))))))
     160                       (ash 1 ppc64::subtag-complex))))
     161    #+x8664-target
     162    (if (< typecode x8664::nbits-in-word)
     163      (logbitp (the (integer 0 #.x8664::subtag-double-float) typecode)
     164               (logior (ash 1 x8664::tag-fixnum)
     165                       (ash 1 x8664::subtag-bignum)
     166                       (ash 1 x8664::tag-single-float)
     167                       (ash 1 x8664::subtag-double-float)
     168                       (ash 1 x8664::subtag-ratio)
     169                       (ash 1 x8664::subtag-complex))))
     170   
     171    ))
    153172
    154173(defun arrayp (x)
     
    206225  (= (the fixnum (logand (the fixnum (typecode x)) ppc32::fulltagmask)) ppc32::fulltag-nodeheader)
    207226  #+ppc64-target
    208   (= (the fixnum (logand (the fixnum (typecode x)) ppc64::lowtagmask)) ppc64::lowtag-nodeheader))
     227  (= (the fixnum (logand (the fixnum (typecode x)) ppc64::lowtagmask)) ppc64::lowtag-nodeheader)
     228  #+x8664-target
     229  (let* ((fulltag (logand (the fixnum (typecode x)) x8664::fulltagmask)))
     230    (declare (fixnum fulltag))
     231    (or (= fulltag x8664::fulltag-nodeheader-0)
     232        (= fulltag x8664::fulltag-nodeheader-1)))
     233  )
    209234
    210235
     
    216241       ppc32::fulltag-immheader)
    217242  #+ppc64-target
    218   (= (the fixnum (logand (the fixnum (typecode x)) ppc64::lowtagmask)) ppc64::lowtag-immheader))
     243  (= (the fixnum (logand (the fixnum (typecode x)) ppc64::lowtagmask)) ppc64::lowtag-immheader)
     244  #+x8664-target
     245  (let* ((fulltag (logand (the fixnum (typecode x)) x8664::fulltagmask)))
     246    (declare (fixnum fulltag))
     247    (or (= fulltag x8664::fulltag-immheader-0)
     248        (= fulltag x8664::fulltag-immheader-1)
     249        (= fulltag x8664::fulltag-immheader-2)))
     250  )
    219251
    220252(setf (type-predicate 'ivector) 'ivectorp)
    221253
    222254(defun miscobjp (x)
    223   #+ppc32-target
    224   (= (the fixnum (lisptag x)) ppc32::tag-misc)
     255  #+(or ppc32-target x8664-target)
     256  (= (the fixnum (lisptag x)) target::tag-misc)
    225257  #+ppc64-target
    226258  (= (the fixnum (fulltag x)) ppc64::fulltag-misc)
     
    355387
    356388#+ppc32-target
     389(progn
    357390(defparameter *nodeheader-types*
    358391  #(bogus                               ; 0
     
    390423    ))
    391424
    392 #+ppc32-target
     425
    393426(defparameter *immheader-types*
    394427  #(bignum                              ; 0
     
    427460    ))
    428461
    429 
    430 
    431 
    432 #+ppc32-target
    433462(defun %type-of (thing)
    434463  (let* ((typecode (typecode thing)))
     
    481510                      type)))))))))))
    482511
     512);#+ppc32-target
     513
    483514#+ppc64-target
     515(progn
    484516(defparameter *immheader-types*
    485517  #(bogus
     
    548580    bogus))
    549581
    550 #+ppc64-target
    551582(defparameter *nodeheader-types*
    552583    #(function
     
    617648  )
    618649
    619 #+ppc64-target
     650
    620651(defun %type-of (thing)
    621   (let* ((typecode (typecode thing)))
    622     (declare (fixnum typecode))
    623     (cond ((= typecode ppc64::tag-fixnum) 'fixnum)
    624           ((= typecode ppc64::fulltag-cons) 'cons)
    625           ((= typecode ppc64::subtag-character) 'character)
    626           ((= typecode ppc64::subtag-single-float) 'short-float)
    627           (t (let* ((lowtag (logand typecode ppc64::lowtagmask)))
    628                (declare (fixnum lowtag))
    629                (cond ((= lowtag ppc64::lowtag-immheader)
    630                        (%svref *immheader-types* (ash typecode -2)))
    631                       ((= lowtag ppc64::lowtag-nodeheader)
    632                        (let* ((type (%svref *nodeheader-types*
    633                                             (ash typecode -2))))
    634                          (cond ((eq type 'function)
    635                                 (let ((bits (lfun-bits thing)))
    636                                   (declare (fixnum bits))
    637                                   (if (logbitp $lfbits-trampoline-bit bits)
    638                                     (if (logbitp $lfbits-evaluated-bit bits)
    639                                       'interpreted-lexical-closure
    640                                       (let ((inner-fn (closure-function thing)))
    641                                         (if (neq inner-fn thing)
    642                                           (let ((inner-bits (lfun-bits inner-fn)))
    643                                             (if (logbitp $lfbits-method-bit inner-bits)
    644                                               'compiled-lexical-closure
    645                                               (if (logbitp $lfbits-gfn-bit inner-bits)
    646                                                 'standard-generic-function ; not precisely - see class-of
    647                                                 (if (logbitp  $lfbits-cm-bit inner-bits)
    648                                                   'combined-method
    649                                                   'compiled-lexical-closure))))
    650                                           'compiled-lexical-closure)))
    651                                     (if (logbitp $lfbits-evaluated-bit bits)
    652                                       (if (logbitp $lfbits-method-bit bits)
    653                                         'interpreted-method-function
    654                                         'interpreted-function)
    655                                       (if (logbitp  $lfbits-method-bit bits)
    656                                         'method-function         
    657                                         'compiled-function)))))
    658                                ((eq type 'lock)
    659                                 (or (uvref thing ppc64::lock.kind-cell)
    660                                     type))
    661                                (t type))))
    662                       (t 'immediate)))))))
     652  (if (null thing)
     653    'null
     654    (let* ((typecode (typecode thing)))
     655      (declare (fixnum typecode))
     656      (cond ((= typecode ppc64::tag-fixnum) 'fixnum)
     657            ((= typecode ppc64::fulltag-cons) 'cons)
     658            ((= typecode ppc64::subtag-character) 'character)
     659            ((= typecode ppc64::subtag-single-float) 'short-float)
     660            (t (let* ((lowtag (logand typecode ppc64::lowtagmask)))
     661                 (declare (fixnum lowtag))
     662                 (cond ((= lowtag ppc64::lowtag-immheader)
     663                        (%svref *immheader-types* (ash typecode -2)))
     664                       ((= lowtag ppc64::lowtag-nodeheader)
     665                        (let* ((type (%svref *nodeheader-types*
     666                                             (ash typecode -2))))
     667                          (cond ((eq type 'function)
     668                                 (let ((bits (lfun-bits thing)))
     669                                   (declare (fixnum bits))
     670                                   (if (logbitp $lfbits-trampoline-bit bits)
     671                                     (if (logbitp $lfbits-evaluated-bit bits)
     672                                       'interpreted-lexical-closure
     673                                       (let ((inner-fn (closure-function thing)))
     674                                         (if (neq inner-fn thing)
     675                                           (let ((inner-bits (lfun-bits inner-fn)))
     676                                             (if (logbitp $lfbits-method-bit inner-bits)
     677                                               'compiled-lexical-closure
     678                                               (if (logbitp $lfbits-gfn-bit inner-bits)
     679                                                 'standard-generic-function ; not precisely - see class-of
     680                                                 (if (logbitp  $lfbits-cm-bit inner-bits)
     681                                                   'combined-method
     682                                                   'compiled-lexical-closure))))
     683                                           'compiled-lexical-closure)))
     684                                     (if (logbitp $lfbits-evaluated-bit bits)
     685                                       (if (logbitp $lfbits-method-bit bits)
     686                                         'interpreted-method-function
     687                                         'interpreted-function)
     688                                       (if (logbitp  $lfbits-method-bit bits)
     689                                         'method-function         
     690                                         'compiled-function)))))
     691                                ((eq type 'lock)
     692                                 (or (uvref thing ppc64::lock.kind-cell)
     693                                     type))
     694                                (t type))))
     695                       (t 'immediate))))))))
     696);#+ppc64-target
     697
     698
    663699
    664700
     
    702738    t)
    703739  #+ppc64-target
    704   (= (the fixnum (typecode thing)) ppc64::subtag-symbol))
     740  (= (the fixnum (typecode thing)) ppc64::subtag-symbol)
     741  #+x8664-target
     742  (if thing
     743    (= (the fixnum (lisptag thing)) x8664::tag-symbol)
     744    t)
     745  )
    705746     
    706747(defun packagep (thing)
Note: See TracChangeset for help on using the changeset viewer.