123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189 |
- ;;; Ported from Scheme 48 1.9. See file COPYING for notices and license.
- ;;;
- ;;; Port Author: Andrew Whatson
- ;;;
- ;;; Original Authors: Richard Kelsey
- ;;;
- ;;; scheme48-1.9.2/ps-compiler/prescheme/type-var.scm
- ;;;
- ;;; Type variables - what a mess
- (define-module (ps-compiler prescheme type-var)
- #:use-module (ice-9 format)
- #:use-module (srfi srfi-9)
- #:use-module (prescheme scheme48)
- #:use-module (prescheme record-discloser)
- #:use-module (ps-compiler prescheme type)
- #:use-module (ps-compiler util util)
- #:export (make-uvar
- make-tuple-uvar
- uvar?
- maybe-follow-uvar
- uvar-source set-uvar-source!
- reset-type-vars!
- uvar-binding set-uvar-binding!
- uvar-prefix
- uvar-depth
- uvar-id
- uvar-temp set-uvar-temp!
- uvar-tuple-okay?
- uvar-place set-uvar-place!
- bind-uvar!
- make-nonpolymorphic!
- unique-id))
- (define-record-type :uvar
- (really-make-uvar prefix depth id tuple-okay?
- place source binding temp) ;; all initialized to #F
- uvar?
- (prefix uvar-prefix) ;; a name for debugging
- (depth uvar-depth set-uvar-depth!) ;; lexical depth of the uvar
- (id uvar-id) ;; a number
- ;; true if this can be unified with a tuple, set when merged
- (tuple-okay? uvar-tuple-okay? set-uvar-tuple-okay?!)
- (place uvar-place set-uvar-place!) ;; used in producing type schemes
- (source uvar-source set-uvar-source!)
- ;; to let the user know where this came from
- (binding uvar-binding set-uvar-binding!);; known value of this uvar
- (temp uvar-temp set-uvar-temp!)) ;; useful field
- (define-record-discloser :uvar
- (lambda (uvar)
- (list 'uvar
- (uvar-prefix uvar)
- (uvar-depth uvar)
- (uvar-id uvar)
- (uvar-binding uvar))))
- (define (make-uvar prefix depth . maybe-id)
- (really-make-uvar prefix
- depth
- (if (null? maybe-id)
- (unique-id)
- (car maybe-id))
- #f ;; tuple-okay?
- #f #f #f #f)) ;; place source binding temp
- (define (make-tuple-uvar prefix depth . maybe-id)
- (really-make-uvar prefix
- depth
- (if (null? maybe-id)
- (unique-id)
- (car maybe-id))
- #t ;; tuple-okay?
- #f #f #f #f)) ;; place source binding temp
- ;; Could this safely short-circuit the chains?
- (define (maybe-follow-uvar type)
- (cond ((and (uvar? type)
- (uvar-binding type))
- => maybe-follow-uvar)
- (else type)))
- ;; Substitute VALUE for UVAR, if this will not introduce a circularity.
- ;; or cause other problems. Returns an error-printing thunk if there is
- ;; a problem.
- (define (bind-uvar! uvar value)
- (cond ((uvar? value)
- (bind-uvar-to-uvar! uvar value)
- #f)
- (else
- (bind-uvar-to-type! uvar value))))
- (define (bind-uvar-to-uvar! uvar0 uvar1)
- (minimize-type-depth! uvar1 (uvar-depth uvar0))
- (set-uvar-binding! uvar0 uvar1)
- (if (and (uvar-tuple-okay? uvar1)
- (not (uvar-tuple-okay? uvar0)))
- (set-uvar-tuple-okay?! uvar1 #f)))
- (define (bind-uvar-to-type! uvar type)
- (let ((errors '()))
- (if (uvar-in-type? uvar type)
- (set! errors (cons circularity-error errors)))
- (if (and (tuple-type? type)
- (not (uvar-tuple-okay? uvar)))
- (set! errors (cons (tuple-error type) errors)))
- (cond ((null? errors) ;; whew!
- (minimize-type-depth! type (uvar-depth uvar))
- (set-uvar-binding! uvar type)
- #f)
- (else
- (lambda ()
- (format #t "unifying ")
- (display-type uvar (current-output-port))
- (format #t " == ")
- (display-type type (current-output-port))
- (format #t "~% would cause the following problem~A:"
- (if (null? (cdr errors)) "" "s"))
- (for-each (lambda (x) (x)) errors))))))
- (define (circularity-error)
- (format #t "~% creation of a circular type"))
- (define (tuple-error type)
- (lambda ()
- (if (null? (tuple-type-types type))
- (format #t "~% returning no values where one is expected")
- (format #t "~% returning ~D values where one is expected"
- (length (tuple-type-types type))))))
- ;; Check that UVAR does not occur in EXP.
- (define (uvar-in-type? uvar exp)
- (let label ((exp exp))
- (cond ((or (base-type? exp)
- (record-type? exp))
- #f)
- ((uvar? exp)
- (if (uvar-binding exp)
- (label (uvar-binding exp))
- (eq? exp uvar)))
- ((other-type? exp)
- (every? label (other-type-subtypes exp)))
- (else
- (identity (bug "funny type ~S" exp))))))
-
- ;; Make the depths of any uvars in TYPE be no greater than DEPTH.
- (define (minimize-type-depth! type depth)
- (let label ((type type))
- (cond ((other-type? type)
- (for-each label (other-type-subtypes type)))
- ((uvar? type)
- (cond ((uvar-binding type)
- => label)
- ((< depth (uvar-depth type))
- (set-uvar-depth! type depth)))))))
- ;; Set the depth of all uvars in TYPE to be -1 so that it will not be made
- ;; polymorphic at any level.
- (define (make-nonpolymorphic! type)
- (cond ((uvar? type)
- (set-uvar-depth! type -1))
- ((other-type? type)
- (for-each make-nonpolymorphic! (other-type-subtypes type)))
- ;;((type-scheme? type)
- ;; (make-nonpolymorphic! (type-scheme-type type)))
- ))
- ;;------------------------------------------------------------
- ;; Micro utilities
- (define *unique-id-counter* 0)
- (define (unique-id)
- (set! *unique-id-counter* (+ *unique-id-counter* 1))
- *unique-id-counter*)
- (define (reset-type-vars!)
- (set! *unique-id-counter* 0))
|