786 |
(defun var-array-type (a) |
(defun var-array-type (a) |
787 |
(when (consp a) |
(when (consp a) |
788 |
(cond ((eq (car a) 'var) (var-type (cadr a))) |
(cond ((eq (car a) 'var) (var-type (cadr a))) |
789 |
|
((eq (car a) 'VV) (object-type (cdr (aref (car *data*) (cadr a))))) |
790 |
((eq (car a) 'cvar) |
((eq (car a) 'cvar) |
791 |
(or (cdr (assoc (cadr a) *c-vars*)) |
(or (cdr (assoc (cadr a) *c-vars*)) |
792 |
(car (rassoc (cadr a) *c-vars*))))))) |
(car (rassoc (cadr a) *c-vars*))))))) |
793 |
|
|
794 |
;(setf (symbol-function 'cmp-aref) (symbol-function 'row-major-aref)) |
;(setf (symbol-function 'cmp-aref) (symbol-function 'row-major-aref)) |
795 |
|
|
796 |
(defmacro wt-bit-index (i) |
(defmacro wt-bv-index (a i) |
797 |
`(wt #+clx-little-endian "(7-" "(" ,i "&0x7)" #+clx-little-endian ")")) |
`(wt "(((" ,a ")->bv.bv_offset) + " ,i ")")) |
798 |
|
|
799 |
|
(defmacro wt-bv-shift (a i) |
800 |
|
`(progn |
801 |
|
(wt #+clx-little-endian "(7-" "(") |
802 |
|
(wt-bv-index ,a ,i) |
803 |
|
(wt "&0x7)" #+clx-little-endian ")"))) |
804 |
|
|
805 |
(defun cmp-aref-inline-types (&rest r) |
(defun cmp-aref-inline-types (&rest r) |
806 |
(let ((art (car r))) |
(let ((art (car r))) |
815 |
(if aet |
(if aet |
816 |
(if (eq aet 'bit) |
(if (eq aet 'bit) |
817 |
(progn |
(progn |
818 |
(wt "(((" (c-cast aet) " *)(" a ")->v.v_self)[" i ">>3]>>") |
(wt "(((" (c-cast aet) " *)(" a ")->bv.bv_self)[") |
819 |
(wt-bit-index i) |
(wt-bv-index a i) |
820 |
|
(wt ">>3]>>") |
821 |
|
(wt-bv-shift a i) |
822 |
(wt "&0x1)")) |
(wt "&0x1)")) |
823 |
(wt "((" (c-cast aet) " *)(" a ")->v.v_self)[" i "]")) |
(wt "((" (c-cast aet) " *)(" a ")->v.v_self)[" i "]")) |
824 |
(wt "fLrow_major_aref(" a "," i ")"))))) |
(wt "fLrow_major_aref(" a "," i ")"))))) |
842 |
(if aet |
(if aet |
843 |
(if (eq aet 'bit) |
(if (eq aet 'bit) |
844 |
(progn |
(progn |
845 |
(wt "(" j " ? (((" (c-cast aet) " *)(" a ")->v.v_self)[" i ">>3]|=(1<<") |
(wt "(" j " ? (((" (c-cast aet) " *)(" a ")->bv.bv_self)[") |
846 |
(wt-bit-index i) |
(wt-bv-index a i) |
847 |
(wt ")) : (((" (c-cast aet) " *)(" a ")->v.v_self)[" i ">>3]&=~(1<<") |
(wt ">>3]|=(1<<") |
848 |
(wt-bit-index i) |
(wt-bv-shift a i) |
849 |
|
(wt ")) : (((" (c-cast aet) " *)(" a ")->bv.bv_self)[") |
850 |
|
(wt-bv-index a i) |
851 |
|
(wt ">>3]&=~(1<<") |
852 |
|
(wt-bv-shift a i) |
853 |
(wt ")))")) |
(wt ")))")) |
854 |
(wt "((" (c-cast aet) " *)(" a ")->v.v_self)[" i "]=" j)) |
(wt "((" (c-cast aet) " *)(" a ")->v.v_self)[" i "]=" j)) |
855 |
(wt "fSaset1(" a "," i "," j ")"))))) |
(wt "fSaset1(" a "," i "," j ")"))))) |
867 |
(defun cmp-array-dimension-inline (a i) |
(defun cmp-array-dimension-inline (a i) |
868 |
(let ((at (cmp-norm-tp (var-array-type a)))) |
(let ((at (cmp-norm-tp (var-array-type a)))) |
869 |
(let ((aet (and (consp at) (member (car at) '(array simple-array))))) |
(let ((aet (and (consp at) (member (car at) '(array simple-array))))) |
870 |
(if aet |
(cond ((and (not *safe-compile*) (not aet)) |
871 |
(if (and (consp (third at)) (= (length (third at)) 1)) |
(wt "fixint(fLarray_dimension(" a "," i "))")) |
872 |
(wt "(" a ")->v.v_dim") |
((and aet (consp (third at)) (= (length (third at)) 1)) |
873 |
(wt "(" a ")->a.a_dims[(" i ")]")) |
(wt "(" a ")->v.v_dim")) |
874 |
(if *safe-compile* |
((and (constantp i) (> i 0)) |
875 |
;;FIXME -- alter C definition to remove the fixint here. |
(wt "(" a ")->a.a_dims[(" i ")]")) |
876 |
(wt "fixint(fLarray_dimension(" a "," i "))") |
((wt "(type_of(" a ")==t_array ? (" a ")->a.a_dims[(" i ")] : (" a ")->v.v_dim)")))))) |
|
(if (or (not (constantp i)) (eql 0 i)) |
|
|
(wt "(type_of(" a ")==t_array ? (" a ")->a.a_dims[(" i ")] : (" a ")->v.v_dim)") |
|
|
(wt "(" a ")->a.a_dims[(" i ")]"))))))) |
|
877 |
|
|
878 |
(defun list*-inline (&rest x) |
(defun list*-inline (&rest x) |
879 |
(case (length x) |
(case (length x) |