104 |
(t (bsearchleq x a (1+ k) j le))))) |
(t (bsearchleq x a (1+ k) j le))))) |
105 |
|
|
106 |
(defun push-array (x ar s lin) |
(defun push-array (x ar s lin) |
107 |
(declare (object x lin) ((vector t) ar) (fixnum s) (ignore lin)) |
(declare ((vector t) ar) (seqind s) (ignore lin)) |
|
; (j (if lin |
|
|
; (do ((k s (1+ k))) ((or (eql k (length ar)) (si::objlt x (aref ar k)) (eq x (aref ar k))) k) |
|
|
; (declare (fixnum k))) |
|
|
; (bsearchleq x ar s (length ar))))) |
|
108 |
(let ((j (bsearchleq x ar s (length ar) t))) |
(let ((j (bsearchleq x ar s (length ar) t))) |
|
(declare (fixnum j)) |
|
109 |
(when (and (< j (length ar)) (eq (aref ar j) x)) |
(when (and (< j (length ar)) (eq (aref ar j) x)) |
110 |
(return-from push-array -1)) |
(return-from push-array -1)) |
111 |
(let ((ar (if (eql (length ar) (the fixnum (array-total-size ar))) |
(let ((ar (if (= (length ar) (array-total-size ar)) |
112 |
(adjust-array ar (the fixnum (* 2 (length ar)))) |
(adjust-array ar (* 2 (length ar))) |
113 |
ar))) |
ar))) |
114 |
(declare ((vector t) ar)) |
(declare ((vector t) ar)) |
115 |
(do ((i (length ar) (1- i))) ((<= i j)) |
(do ((i (length ar) (1- i))) ((<= i j)) |
116 |
(declare (fixnum i)) |
(declare (seqind i)) |
117 |
(setf (aref ar i) (aref ar (the fixnum (1- i))))) |
(setf (aref ar i) (aref ar (1- i)))) |
118 |
(setf (aref ar j) x) |
(setf (aref ar j) x) |
119 |
(setf (fill-pointer ar) (the fixnum (1+ (length ar)))) |
(setf (fill-pointer ar) (1+ (length ar))) |
120 |
j))) |
j))) |
121 |
|
|
122 |
|
|
728 |
(defun c-cast (aet) |
(defun c-cast (aet) |
729 |
(case aet |
(case aet |
730 |
(signed-char "char") |
(signed-char "char") |
731 |
((string-char character unsigned-char non-negative-char) "unsigned char") |
((bit character unsigned-char non-negative-char) "unsigned char") |
732 |
(signed-short "short") |
(signed-short "short") |
733 |
((non-negative-short unsigned-short) "unsigned short") |
((non-negative-short unsigned-short) "unsigned short") |
734 |
|
(signed-int "int") |
735 |
|
((non-negative-int unsigned-int) "unsigned int") |
736 |
((signed-fixnum fixnum non-negative-fixnum) "fixnum") |
((signed-fixnum fixnum non-negative-fixnum) "fixnum") |
737 |
((unsigned-fixnum ) "object") ;FIXME |
((unsigned-fixnum ) "object") ;FIXME |
738 |
(short-float "float") |
(short-float "float") |
772 |
(and (consp x) (member (car x) '(array simple-array)) |
(and (consp x) (member (car x) '(array simple-array)) |
773 |
(let ((uaet (and (not (eq (cadr x) '*)) (upgraded-array-element-type (nil-to-t (cadr x)))))) |
(let ((uaet (and (not (eq (cadr x) '*)) (upgraded-array-element-type (nil-to-t (cadr x)))))) |
774 |
;; FIXME -- inline bit-vectors too. |
;; FIXME -- inline bit-vectors too. |
775 |
(unless (eq uaet 'bit) |
(unless nil;(eq uaet 'bit) |
776 |
;;FIXME string-char -> character for ansi throughout, this is just a bridge for now. |
uaet))))) |
|
;;20050509 CM |
|
|
(if (eq uaet 'string-char) 'character uaet)))))) |
|
777 |
|
|
778 |
(defun var-array-type (a) |
(defun var-array-type (a) |
779 |
(when (consp a) |
(when (consp a) |
782 |
(or (cdr (assoc (cadr a) *c-vars*)) |
(or (cdr (assoc (cadr a) *c-vars*)) |
783 |
(car (rassoc (cadr a) *c-vars*))))))) |
(car (rassoc (cadr a) *c-vars*))))))) |
784 |
|
|
785 |
(setf (symbol-function 'cmp-aref) (symbol-function 'row-major-aref)) |
;(setf (symbol-function 'cmp-aref) (symbol-function 'row-major-aref)) |
786 |
|
|
787 |
|
(defmacro wt-bit-index (i) |
788 |
|
`(wt #+clx-little-endian "(7-" "(" ,i "&0x7)" #+clx-little-endian ")")) |
789 |
|
|
790 |
(defun cmp-aref-inline-types (&rest r) |
(defun cmp-aref-inline-types (&rest r) |
791 |
(let ((art (car r))) |
(let ((art (car r))) |
798 |
(let ((at (nil-to-t (var-array-type a)))) |
(let ((at (nil-to-t (var-array-type a)))) |
799 |
(let ((aet (aref-propagator 'cmp-aref at))) |
(let ((aet (aref-propagator 'cmp-aref at))) |
800 |
(if aet |
(if aet |
801 |
(wt "((" (c-cast aet) " *)(" a ")->v.v_self)[" i "]") |
(if (eq aet 'bit) |
802 |
|
(progn |
803 |
|
(wt "(((" (c-cast aet) " *)(" a ")->v.v_self)[" i ">>3]>>") |
804 |
|
(wt-bit-index i) |
805 |
|
(wt "&0x1)")) |
806 |
|
(wt "((" (c-cast aet) " *)(" a ")->v.v_self)[" i "]")) |
807 |
(wt "fLrow_major_aref(" a "," i ")"))))) |
(wt "fLrow_major_aref(" a "," i ")"))))) |
808 |
|
|
809 |
|
|
810 |
(setf (symbol-function 'cmp-aset) (symbol-function 'si::aset1)) |
;(setf (symbol-function 'cmp-aset) (symbol-function 'si::aset1)) |
811 |
|
|
812 |
(defun cmp-aset-inline-types (&rest r) |
(defun cmp-aset-inline-types (&rest r) |
813 |
(let ((art (car r))) |
(let ((art (car r))) |
823 |
(let ((at (nil-to-t (var-array-type a)))) |
(let ((at (nil-to-t (var-array-type a)))) |
824 |
(let ((aet (aref-propagator 'cmp-aset at))) |
(let ((aet (aref-propagator 'cmp-aset at))) |
825 |
(if aet |
(if aet |
826 |
(wt "((" (c-cast aet) " *)(" a ")->v.v_self)[" i "]=" j) |
(if (eq aet 'bit) |
827 |
|
(progn |
828 |
|
(wt "(" j " ? (((" (c-cast aet) " *)(" a ")->v.v_self)[" i ">>3]|=(1<<") |
829 |
|
(wt-bit-index i) |
830 |
|
(wt ")) : (((" (c-cast aet) " *)(" a ")->v.v_self)[" i ">>3]&=~(1<<") |
831 |
|
(wt-bit-index i) |
832 |
|
(wt ")))")) |
833 |
|
(wt "((" (c-cast aet) " *)(" a ")->v.v_self)[" i "]=" j)) |
834 |
(wt "fSaset1(" a "," i "," j ")"))))) |
(wt "fSaset1(" a "," i "," j ")"))))) |
835 |
|
|
836 |
|
|