Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-20 14:19:18 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

adding type inference from assertions

Browse source
This commit is contained in:
Alex Shinn 2011-11-10 22:11:12 +09:00
parent 58ac066820
commit 372a7b37b3
1 changed files with 70 additions and 44 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -42,6 +42,11 @@
(member b (cdr a)))
(and (union-type? b) (member a (cdr b))))))
(define (type-not a)
(match a
(('not b) b)
(else (list 'not a))))
;; XXXX check for type hierarchies
(define (type-union a b)
(cond
@ -88,6 +93,20 @@
(cond ((lambda-param-type-memq f x)
=> (lambda (cell) (set-car! cell y)))))
(define (type-assert x true?)
(match x
(((? opcode? f) ($ Ref name (_ . (? lambda? g))))
(cond
((eq? (opcode-class f) (opcode-class pair?))
(let ((t (type-intersection
(lambda-param-type-ref g name)
(if true? (opcode-data f) (type-not (opcode-data f))))))
(lambda-param-type-set! g name t)))))
((($ Ref _ ('not . (? procedure? f))) expr)
(if (eq? f not)
(type-assert expr (not true?))))
(else #f)))
(define (type-analyze-expr x)
(match x
(($ Lam name params body defs)
@ -101,7 +120,7 @@
(($ Set ref value)
(type-analyze-expr value)
(if #f #f))
(($ Ref name (value . loc) source)
(($ Ref name (value . loc))
(cond
((lambda? loc) (lambda-param-type-ref loc name))
((procedure? loc)
@ -114,7 +133,15 @@
(let ((test-type (type-analyze-expr test))
(pass-type (type-analyze-expr pass))
(fail-type (type-analyze-expr fail)))
(type-union pass-type fail-type)))
(cond
((equal? '(error) pass-type)
(type-assert test #f)
fail-type)
((equal? '(error) fail-type)
(type-assert test #t)
pass-type)
(else
(type-union pass-type fail-type)))))
(($ Seq ls)
(let lp ((ls ls))
(cond ((null? (cdr ls))
@ -122,14 +149,13 @@
(else
(type-analyze-expr (car ls))
(lp (cdr ls))))))
((f args ...)
(cond
((opcode? f)
(((? opcode? f) args ...)
(let lp ((p (opcode-param-types f))
(a args))
(cond
((pair? a)
(cond ((or (pair? p) (opcode-variadic? f))
(cond
((or (pair? p) (opcode-variadic? f))
(let ((p-type
(if (pair? p)
(car p)
@ -155,7 +181,7 @@
(else
(for-each type-analyze-expr a))))))
(opcode-return-type f))
(else
((f args ...)
(let ((f-type (type-analyze-expr f)))
;; XXXX apply f-type to params
(for-each type-analyze-expr args)
@ -165,7 +191,7 @@
((and (pair? f-type) (memq (car f-type) '(return-type param-type)))
f-type)
(else
Object))))))
Object))))
(($ Lit value)
(type-of value))
(else