/[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.28 by camm, Sun Nov 6 18:07:35 2005 UTC revision 1.29 by camm, Mon Nov 14 04:46:11 2005 UTC
# Line 786  Line 786 
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)))
# Line 808  Line 815 
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 ")")))))
# Line 833  Line 842 
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 ")")))))
# Line 854  Line 867 
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)

Legend:
Removed from v.1.28  
changed lines
  Added in v.1.29

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