/[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.9 by camm, Sat Jul 23 08:47:45 2005 UTC revision 1.10 by camm, Mon Aug 8 22:58:06 2005 UTC
# Line 387  Line 387 
387  (defun do-num-relations (fn args)  (defun do-num-relations (fn args)
388    (let* ((info (make-info))    (let* ((info (make-info))
389           (nargs (c1args args info))           (nargs (c1args args info))
390           (t1 (and (cddr args) (info-type (cadar nargs))))           (t1 (and (car args) (info-type (cadar nargs))))
391           (t2 (and (cddr 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))
# Line 409  Line 409 
409    
410    
411  (defun list-tp-test (tf lt)  (defun list-tp-test (tf lt)
412    (cond ((null lt) (values t t))    (cond ((atom lt) (let ((z (funcall tf lt))) (values z z)))
         ((atom lt) (values nil nil))  
413          ((eq (car lt) 'cons)          ((eq (car lt) 'cons)
414           (multiple-value-bind           (multiple-value-bind
415            (m1 f1) (funcall tf (cadr lt))            (m1 f1) (funcall tf (cadr lt))
416            (multiple-value-bind            (multiple-value-bind
417             (m2 f2) (list-tp-test tf (caddr lt))             (m2 f2) (list-tp-test tf (caddr lt))
418             (values (and m1 m2) (or f1 f2)))))             (values (and m1 m2) (or f1 f2)))))
419          (t (values nil nil))))          ((list-tp-test tf (car lt)))))
420    ;       (t (values nil nil))))
421    
422  (defun test-to-tf (test)  (defun test-to-tf (test)
423    (let ((test (if (constantp test) (cmp-eval test) test)))    (let ((test (if (constantp test) (cmp-eval test) test)))
# Line 457  Line 457 
457              ((list 'call-global info fn nargs))))))              ((list 'call-global info fn nargs))))))
458  (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)))
459    
460  (defun c1or (args)  ;(defun c1or (args)
461    (cond ((null args) (c1expr nil))  ;  (cond ((null args) (c1expr nil))
462          ((constantp (car args)) (let ((na (cmp-eval (car args)))) (if na (c1expr na) (c1or (cdr args)))))  ;       ((constantp (car args)) (let ((na (cmp-eval (car args)))) (if na (c1expr na) (c1or (cdr args)))))
463          ((null (cdr args)) (c1expr (car args)))  ;       ((null (cdr args)) (c1expr (car args)))
464          ((macro-function 'or) (c1expr (cmp-macroexpand `(or ,@args))))  ;       ((macro-function 'or) (c1expr (cmp-macroexpand `(or ,@args))))
465          ((let ((info (make-info))) (list 'call-global info 'or (c1args args info))))))  ;       ((let ((info (make-info))) (list 'call-global info 'or (c1args args info))))))
466  (si::putprop 'or 'c1or 'c1)  ;(si::putprop 'or 'c1or 'c1)
467    
468  (defun cmp-array-element-type (&rest args)  (defun cmp-array-element-type (&rest args)
469    (and    (and
# Line 706  Line 706 
706          (t t)))          (t t)))
707    
708    
 ;(defvar *std-instance-class-type* nil)  
 ;(defvar *std-instance-symbol* nil)  
   
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)))))
 ;    (unless *std-instance-symbol*  
 ;      (setq *std-instance-symbol* (let ((p (find-package 'pcl))) (and p (find-symbol "STD-INSTANCE" p)))))  
 ;    (when (eq type *std-instance-symbol*)  
 ;      (unless *std-instance-class-type*  
 ;       (let* ((p (find-package 'pcl))  
 ;              (s (and p (find-symbol "SLOT-OBJECT" p)))  
 ;              (si (and s (import s 'compiler)))  
 ;              (q (and p (find-symbol "FUNCALLABLE-STANDARD-OBJECT" p)))  
 ;              (qi (and q (import q 'compiler))))  
 ;         (when (and si qi)  
 ;           (setq *std-instance-class-type* `(and ,s (not ,q)))))))  
 ;    (let ((type (or (and (eq type *std-instance-symbol*) *std-instance-class-type*) type)))  
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))  ;       (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))
714          (cond ((subtypep rt type)          (cond ((subtypep rt type)
715                 (setq new t)                 (setq new t)
716                 (return-from co1typep (c1expr new)))                 (return-from co1typep (c1expr new)))
717                  ;;FIXME only need type-and here when finalized
718                ((and type (multiple-value-bind (m v) (subtypep type rt) (and (not m) v)) (not (type-and type rt)))                ((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
722            (cond            (cond
723             ((null type) nil)             ((null type) nil)
# Line 1107  Line 1092 
1092  (defun c1list (args)  (defun c1list (args)
1093    (let* ((info (make-info))    (let* ((info (make-info))
1094          (nargs (c1args args info)))          (nargs (c1args args info)))
1095      (setf (info-type info) (nil-to-t (reduce (lambda (x y) (list 'cons (info-type (cadr x)) y)) (append nargs '(nil)) :from-end t)))      (setf (info-type info) (nil-to-t (reduce (lambda (x y) (list 'cons (info-type (cadr x)) y)) (append nargs '(null)) :from-end t)))
1096      (list 'call-global info 'list nargs)));      (list 'call-global info 'list nargs)));
1097  (si::putprop 'list 'c1list 'c1)  (si::putprop 'list 'c1list 'c1)
1098                

Legend:
Removed from v.1.9  
changed lines
  Added in v.1.10

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