/[gcl]/gcl/cmpnew/gcl_cmpinline.lsp
ViewVC logotype

Diff of /gcl/cmpnew/gcl_cmpinline.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.24 by camm, Wed Sep 7 02:40:14 2005 UTC revision 1.25 by camm, Sun Sep 18 01:51:31 2005 UTC
# Line 104  Line 104 
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    
# Line 733  Line 728 
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")
# Line 775  Line 772 
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)
# Line 787  Line 782 
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)))
# Line 800  Line 798 
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)))
# Line 820  Line 823 
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        

Legend:
Removed from v.1.24  
changed lines
  Added in v.1.25

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26