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

Diff of /gcl/cmpnew/gcl_cmpfun.lsp

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

revision 1.13 by camm, Wed Sep 7 02:39:26 2005 UTC revision 1.14 by camm, Sun Sep 18 01:46:25 2005 UTC
# Line 391  Line 391 
391           (t2 (and (cadr args) (info-type (cadadr nargs))))           (t2 (and (cadr args) (info-type (cadadr nargs))))
392           (r (and t1 t2 (num-type-rel fn t1 t2))))           (r (and t1 t2 (num-type-rel fn t1 t2))))
393      (cond ((cddr args) (list 'call-global info fn nargs))      (cond ((cddr args) (list 'call-global info fn nargs))
394            ((car r) (c1expr t))            ((car r) (c1expr** t info))
395            ((cadr r) (c1expr nil))            ((cadr r) (c1expr** nil info))
396            ((list 'call-global info fn nargs)))))            ((list 'call-global info fn nargs)))))
397    
398  (dolist (l `(>= > < <= = /=))  (dolist (l `(>= > < <= = /=))
# Line 435  Line 435 
435           (tf (cadr ltf))           (tf (cadr ltf))
436           (info (make-info)))           (info (make-info)))
437      (if (not tf)      (if (not tf)
438          (c1expr nil)          (c1expr** nil info)
439        (let ((nargs (c1args (cdr args) info)))        (let ((nargs (c1args (cdr args) info)))
440          (multiple-value-bind          (multiple-value-bind
441           (m1 f1) (funcall tf (info-type (cadar nargs)))           (m1 f1) (funcall tf (info-type (cadar nargs)))
442           (multiple-value-bind           (multiple-value-bind
443            (m2 f2) (list-tp-test tf (info-type (cadadr nargs)))            (m2 f2) (list-tp-test tf (info-type (cadadr nargs)))
444            (declare (ignore f2))            (declare (ignore f2))
445            (cond ((or m1 m2) (c1expr t))            (cond ((or m1 m2) (c1expr** t info))
446                  (f1 (c1expr nil))                  (f1 (c1expr** nil info))
447                  ((let ((info (make-info))) (list 'call-global info (car ltf) (c1args (list (cadr args)) info)))))))))))                  ((let ((info (make-info)))
448                       (list 'call-global info (car ltf) (c1args (list (cadr args)) info)))))))))))
449  (si::putprop 'is-eq-test-item-list 'c1is-eq-test-item-list 'c1)  (si::putprop 'is-eq-test-item-list 'c1is-eq-test-item-list 'c1)
450    
451  (defun do-predicate (fn args)  (defun do-predicate (fn args)
452    (let* ((info (make-info))    (let* ((info (make-info))
453          (nargs (c1args args info))           (nargs (c1args args info))
454          (tp (car (rassoc fn *type-alist*))))           (tp (car (rassoc fn *type-alist*))))
455      (let ((at (and (not (cdr args)) (info-type (cadar nargs)))))      (let ((at (and (not (cdr args)) (info-type (cadar nargs)))))
456        (cond ((and at (subtypep at tp)) (c1expr t))        (cond ((and at (subtypep at tp)) (c1expr** t info))
457              ((not (type-and at tp)) (c1expr nil))              ((not (type-and at tp)) (c1expr** nil info))
458              ((list 'call-global info fn nargs))))))              ((list 'call-global info fn nargs))))))
459  (dolist (l *type-alist*) (when (symbolp (cdr l)) (si::putprop (cdr l) 'do-predicate 'c1g)))  (dolist (l *type-alist*) (when (symbolp (cdr l)) (si::putprop (cdr l) 'do-predicate 'c1g)))
460    
# Line 732  Line 733 
733                        (equal (third type) '(*)))))                        (equal (third type) '(*)))))
734              (setq tem (si::best-array-element-type              (setq tem (si::best-array-element-type
735                         (second type)))                         (second type)))
736              (cond ((eq tem 'string-char) `(stringp ,x))              (cond ((eq tem 'character) `(stringp ,x))
737                    ((eq tem 'bit) `(bit-vector-p ,x))                    ((eq tem 'bit) `(bit-vector-p ,x))
738                    ((setq tem (position tem *aet-types*))                    ((setq tem (position tem +array-types+))
739                     `(the boolean (vector-type ,x ,tem)))))                     `(the boolean (vector-type ,x ,tem)))))
740             ((and (consp type)             ((and (consp type)
741                   (eq (car type) 'satisfies)                   (eq (car type) 'satisfies)
# Line 969  Line 970 
970    
971    
972    
 (defvar *aet-types* ;FIXME generate and centralize  
   #(T STRING-CHAR SIGNED-CHAR FIXNUM NON-NEGATIVE-FIXNUM SHORT-FLOAT LONG-FLOAT  
                         SIGNED-CHAR NON-NEGATIVE-CHAR  
                         UNSIGNED-CHAR SIGNED-SHORT NON-NEGATIVE-SHORT UNSIGNED-SHORT))  
   
973    
974  (defun aet-c-type (type)  (defun aet-c-type (type)
975    (ecase type    (ecase type
976      ((t) "object")      ((t) "object")
977      ((string-char signed-char non-negative-char) "char")      ((character signed-char non-negative-char) "char")
978      ((non-negative-fixnum fixnum) "fixnum")      ((non-negative-fixnum fixnum) "fixnum")
979      (unsigned-char "unsigned char")      (unsigned-char "unsigned char")
980      ((signed-short non-negative-short) "short")      ((signed-short non-negative-short) "short")
981      (unsigned-short "unsigned short")      (unsigned-short "unsigned short")
982        ((signed-int non-negative-int) "int")
983        (unsigned-int "unsigned int")
984      (long-float "longfloat")      (long-float "longfloat")
985      (short-float "shortfloat")))      (short-float "shortfloat")))
986    

Legend:
Removed from v.1.13  
changed lines
  Added in v.1.14

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