Changeset 9261


Ignore:
Timestamp:
Apr 24, 2008, 9:32:53 AM (11 years ago)
Author:
gb
Message:

THE typechecking in PPC backend, too.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/compiler/PPC/ppc2.lisp

    r9163 r9261  
    55225522  (ppc2-vset seg vreg xfer :simple-vector  vector index value (nx-lookup-target-uvector-subtag :simple-vector)))
    55235523
    5524 (defppc2 ppc2-typed-form typed-form (seg vreg xfer typespec form)
    5525   (declare (ignore typespec)) ; Boy, do we ever !
    5526   (ppc2-form seg vreg xfer form))
     5524(defppc2 ppc2-typed-form typed-form (seg vreg xfer typespec form &optional check)
     5525  (if check
     5526    (ppc2-typechecked-form seg vreg xfer typespec form)
     5527    (ppc2-form seg vreg xfer form)))
    55275528
    55285529(defppc2 ppc2-%primitive %primitive (seg vreg xfer &rest ignore)
     
    79677968  (def-ppc2-require ppc2-require-s8 require-u64))
    79687969
     7970(defun ppc2-typechecked-form (seg vreg xfer typespec form)
     7971  (with-ppc-local-vinsn-macros (seg vreg xfer)
     7972    (let* ((op
     7973            (cond ((eq typespec 'fixnum) (%nx1-operator require-fixnum))
     7974                  ((eq typespec 'integer) (%nx1-operator require-integer))
     7975                  ((memq typespec '(base-char character))
     7976                   (%nx1-operator require-character))
     7977                  ((eq typespec 'symbol) (%nx1-operator require-symbol))
     7978                  ((eq typespec 'list) (%nx1-operator require-list))
     7979                  ((eq typespec 'real) (%nx1-operator require-real))
     7980                  ((memq typespec '(simple-base-string simple-string))
     7981                   (%nx1-operator require-simple-string))
     7982                  ((eq typespec 'number) (%nx1-operator require-number))
     7983                  ((eq typespec 'simple-vector) (%nx1-operator require-simple-vector))
     7984                  (t
     7985                   (let* ((ctype (specifier-type typespec)))
     7986                     (cond ((type= ctype (load-time-value (specifier-type '(signed-byte 8))))
     7987                            (%nx1-operator require-s8))
     7988                           ((type= ctype (load-time-value (specifier-type '(unsigned-byte 8))))
     7989                            (%nx1-operator require-u8))
     7990                           ((type= ctype (load-time-value (specifier-type '(signed-byte 16))))
     7991                            (%nx1-operator require-s16))
     7992                           ((type= ctype (load-time-value (specifier-type '(unsigned-byte 16))))
     7993                            (%nx1-operator require-u16))
     7994                           ((type= ctype (load-time-value (specifier-type '(signed-byte 32))))                           
     7995                            (%nx1-operator require-s32))
     7996                           ((type= ctype (load-time-value (specifier-type '(unsigned-byte 32))))
     7997                            (%nx1-operator require-u32))
     7998                           ((type= ctype (load-time-value (specifier-type '(signed-byte 64))))
     7999                            (%nx1-operator require-s64))
     8000                           ((type= ctype (load-time-value (specifier-type '(unsigned-byte 64))))
     8001                            (%nx1-operator require-u64))))))))
     8002      (if op
     8003        (ppc2-use-operator op seg vreg xfer form)
     8004        (if (or (eq typespec t)
     8005                (eq typespec '*))
     8006          (ppc2-form seg vreg xfer form)
     8007          (let* ((ok (backend-get-next-label)))
     8008            (ppc2-one-targeted-reg-form seg form ($ ppc::arg_y))
     8009            (ppc2-store-immediate seg typespec ($ ppc::arg_z))
     8010            (ppc2-store-immediate seg 'typep ($ ppc::fname))
     8011            (ppc2-set-nargs seg 2)
     8012            (ppc2-vpush-register seg ($ ppc::arg_y))
     8013            (! call-known-symbol ($ ppc::arg_z))
     8014            (with-crf-target () crf
     8015               (! compare-to-nil crf ($ ppc::arg_z))
     8016               (ppc2-vpop-register seg ($ ppc::arg_y))
     8017               (! cbranch-false (aref *backend-labels* ok) crf ppc::ppc-eq-bit))
     8018            (ppc2-lri seg ($ ppc::arg_x) (ash $XWRONGTYPE *ppc2-target-fixnum-shift*))
     8019            (ppc2-store-immediate seg typespec ($ ppc::arg_z))
     8020            (ppc2-set-nargs seg 3)
     8021            (! ksignalerr)
     8022            (@ ok)
     8023            (<- ($ ppc::arg_y))
     8024            (^)))))))
     8025
    79698026(defppc2 ppc2-%badarg2 %badarg2 (seg vreg xfer badthing goodthing)
    79708027  (ppc2-two-targeted-reg-forms seg badthing ($ ppc::arg_y) goodthing ($ ppc::arg_z))
Note: See TracChangeset for help on using the changeset viewer.