Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-07 13:16:36 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

comparing with type=?

Browse source
This commit is contained in:
Alex Shinn 2011-11-11 22:54:20 +09:00
parent 846b9a1e40
commit 587273bee2
1 changed files with 27 additions and 15 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

42
lib/chibi/type-inference.scm
View file

@ -30,17 +30,29 @@
(eq? a Procedure) (eq? a Procedure)
(and (pair? a) (eq? (car a) 'lambda)))) (and (pair? a) (eq? (car a) 'lambda))))
(define (type=? a b)
(cond
((and (pair? a) (eq? (car a) 'param-type))
(and (pair? b) (eq? (car b) 'param-type)
(eq? (cadr a) (cadr b))
(eq? (caddr a) (caddr b))))
((and (pair? a) (eq? (car a) 'return-type))
(and (pair? b) (eq? (car b) 'return-type)
(eq? (cadr a) (cadr b))))
(else
(equal? a b))))
(define (type-subset? a b) (define (type-subset? a b)
(or (equal? a b) (or (type=? a b)
(equal? a Object) (eq? a Object)
(equal? b Object) (eq? b Object)
(and (numeric-type? a) (numeric-type? b)) (and (numeric-type? a) (numeric-type? b))
(and (procedure-type? a) (procedure-type? b)) (and (procedure-type? a) (procedure-type? b))
(if (union-type? a) (if (union-type? a)
(if (union-type? b) (if (union-type? b)
(lset<= equal? (cdr a) (cdr b)) (lset<= type=? (cdr a) (cdr b))
(member b (cdr a))) (member b (cdr a) type=?))
(and (union-type? b) (member a (cdr b)))))) (and (union-type? b) (member a (cdr b) type=?)))))
(define (type-not a) (define (type-not a)
(match a (match a
@ -50,24 +62,24 @@
;; XXXX check for type hierarchies ;; XXXX check for type hierarchies
(define (type-union a b) (define (type-union a b)
(cond (cond
((equal? a b) a) ((type=? a b) a)
((or (equal? a Object) (equal? b Object)) Object) ((or (eq? a Object) (eq? b Object)) Object)
((union-type? a) ((union-type? a)
(if (union-type? b) (if (union-type? b)
(cons (car a) (lset-union equal? (cdr a) (cdr b))) (cons (car a) (lset-union type=? (cdr a) (cdr b)))
(cons (car a) (lset-adjoin equal? (cdr a) b)))) (cons (car a) (lset-adjoin type=? (cdr a) b))))
(else (list 'or a b)))) (else (list 'or a b))))
;; XXXX check for conflicts ;; XXXX check for conflicts
(define (type-intersection a b) (define (type-intersection a b)
(cond (cond
((equal? a b) a) ((type=? a b) a)
((or (equal? a Object) (unfinalized-type? a)) b) ((or (eq? a Object) (unfinalized-type? a)) b)
((or (equal? b Object) (unfinalized-type? b)) a) ((or (eq? b Object) (unfinalized-type? b)) a)
((intersection-type? a) ((intersection-type? a)
(if (intersection-type? b) (if (intersection-type? b)
(lset-intersection equal? (cdr a) (cdr b)) (lset-intersection type=? (cdr a) (cdr b))
(cons (car a) (lset-adjoin equal? (cdr a) b)))) (cons (car a) (lset-adjoin type=? (cdr a) b))))
(else (list 'and a b)))) (else (list 'and a b))))
(define (lambda-param-types-initialize! f) (define (lambda-param-types-initialize! f)