/[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.12 by camm, Wed Aug 10 13:52:24 2005 UTC revision 1.13 by camm, Wed Sep 7 02:39:26 2005 UTC
# Line 709  Line 709 
709  (defun co1typep (f args &aux tem) f  (defun co1typep (f args &aux tem) f
710    (let* ((x (car args))  new    (let* ((x (car args))  new
711           (type (and (literalp (cadr args)) (cmp-eval (cadr args)))))           (type (and (literalp (cadr args)) (cmp-eval (cadr args)))))
712        (let ((rt (result-type (car args))))        (let* ((rt (result-type (car args)))
713  ;       (format t "~a ~a ~a ~a ~a ~a~%" type rt (car args) (subtypep rt type) (multiple-value-list (subtypep type rt)) (type-and type rt))               (ta (type-and rt type)))
714          (cond ((subtypep rt type)  ;       (format t "~a ~a ~a ~a~%" type rt ta (eq ta rt))
715            (cond ((eq ta rt)
716                 (setq new t)                 (setq new t)
717                 (return-from co1typep (c1expr new)))                 (return-from co1typep (c1expr new)))
718                ;;FIXME only need type-and here when finalized                ((and type (not ta))
               ((and type (multiple-value-bind (m v) (subtypep type rt) (and (not m) v)) (not (type-and type rt)))  
719                 (setq new nil)                 (setq new nil)
720                 (return-from co1typep (c1expr new)))))                 (return-from co1typep (c1expr new)))))
721      (setq new      (setq new
# Line 969  Line 969 
969    
970    
971    
972  (defvar *aet-types*  (defvar *aet-types* ;FIXME generate and centralize
973    #(T STRING-CHAR SIGNED-CHAR FIXNUM SHORT-FLOAT LONG-FLOAT    #(T STRING-CHAR SIGNED-CHAR FIXNUM NON-NEGATIVE-FIXNUM SHORT-FLOAT LONG-FLOAT
974                          SIGNED-CHAR                          SIGNED-CHAR NON-NEGATIVE-CHAR
975                          UNSIGNED-CHAR SIGNED-SHORT UNSIGNED-SHORT))                          UNSIGNED-CHAR SIGNED-SHORT NON-NEGATIVE-SHORT UNSIGNED-SHORT))
976    
977    
978  (defun aet-c-type (type)  (defun aet-c-type (type)
979    (ecase type    (ecase type
980      ((t) "object")      ((t) "object")
981      ((string-char signed-char) "char")      ((string-char signed-char non-negative-char) "char")
982      (fixnum "fixnum")      ((non-negative-fixnum fixnum) "fixnum")
983      (unsigned-char "unsigned char")      (unsigned-char "unsigned char")
984      (signed-short "short")      ((signed-short non-negative-short) "short")
985      (unsigned-short "unsigned short")      (unsigned-short "unsigned short")
986      (long-float "longfloat")      (long-float "longfloat")
987      (short-float "shortfloat")))      (short-float "shortfloat")))

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

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