type-var.scm 5.9 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189
  1. ;;; Ported from Scheme 48 1.9. See file COPYING for notices and license.
  2. ;;;
  3. ;;; Port Author: Andrew Whatson
  4. ;;;
  5. ;;; Original Authors: Richard Kelsey
  6. ;;;
  7. ;;; scheme48-1.9.2/ps-compiler/prescheme/type-var.scm
  8. ;;;
  9. ;;; Type variables - what a mess
  10. (define-module (ps-compiler prescheme type-var)
  11. #:use-module (ice-9 format)
  12. #:use-module (srfi srfi-9)
  13. #:use-module (prescheme scheme48)
  14. #:use-module (prescheme record-discloser)
  15. #:use-module (ps-compiler prescheme type)
  16. #:use-module (ps-compiler util util)
  17. #:export (make-uvar
  18. make-tuple-uvar
  19. uvar?
  20. maybe-follow-uvar
  21. uvar-source set-uvar-source!
  22. reset-type-vars!
  23. uvar-binding set-uvar-binding!
  24. uvar-prefix
  25. uvar-depth
  26. uvar-id
  27. uvar-temp set-uvar-temp!
  28. uvar-tuple-okay?
  29. uvar-place set-uvar-place!
  30. bind-uvar!
  31. make-nonpolymorphic!
  32. unique-id))
  33. (define-record-type :uvar
  34. (really-make-uvar prefix depth id tuple-okay?
  35. place source binding temp) ;; all initialized to #F
  36. uvar?
  37. (prefix uvar-prefix) ;; a name for debugging
  38. (depth uvar-depth set-uvar-depth!) ;; lexical depth of the uvar
  39. (id uvar-id) ;; a number
  40. ;; true if this can be unified with a tuple, set when merged
  41. (tuple-okay? uvar-tuple-okay? set-uvar-tuple-okay?!)
  42. (place uvar-place set-uvar-place!) ;; used in producing type schemes
  43. (source uvar-source set-uvar-source!)
  44. ;; to let the user know where this came from
  45. (binding uvar-binding set-uvar-binding!);; known value of this uvar
  46. (temp uvar-temp set-uvar-temp!)) ;; useful field
  47. (define-record-discloser :uvar
  48. (lambda (uvar)
  49. (list 'uvar
  50. (uvar-prefix uvar)
  51. (uvar-depth uvar)
  52. (uvar-id uvar)
  53. (uvar-binding uvar))))
  54. (define (make-uvar prefix depth . maybe-id)
  55. (really-make-uvar prefix
  56. depth
  57. (if (null? maybe-id)
  58. (unique-id)
  59. (car maybe-id))
  60. #f ;; tuple-okay?
  61. #f #f #f #f)) ;; place source binding temp
  62. (define (make-tuple-uvar prefix depth . maybe-id)
  63. (really-make-uvar prefix
  64. depth
  65. (if (null? maybe-id)
  66. (unique-id)
  67. (car maybe-id))
  68. #t ;; tuple-okay?
  69. #f #f #f #f)) ;; place source binding temp
  70. ;; Could this safely short-circuit the chains?
  71. (define (maybe-follow-uvar type)
  72. (cond ((and (uvar? type)
  73. (uvar-binding type))
  74. => maybe-follow-uvar)
  75. (else type)))
  76. ;; Substitute VALUE for UVAR, if this will not introduce a circularity.
  77. ;; or cause other problems. Returns an error-printing thunk if there is
  78. ;; a problem.
  79. (define (bind-uvar! uvar value)
  80. (cond ((uvar? value)
  81. (bind-uvar-to-uvar! uvar value)
  82. #f)
  83. (else
  84. (bind-uvar-to-type! uvar value))))
  85. (define (bind-uvar-to-uvar! uvar0 uvar1)
  86. (minimize-type-depth! uvar1 (uvar-depth uvar0))
  87. (set-uvar-binding! uvar0 uvar1)
  88. (if (and (uvar-tuple-okay? uvar1)
  89. (not (uvar-tuple-okay? uvar0)))
  90. (set-uvar-tuple-okay?! uvar1 #f)))
  91. (define (bind-uvar-to-type! uvar type)
  92. (let ((errors '()))
  93. (if (uvar-in-type? uvar type)
  94. (set! errors (cons circularity-error errors)))
  95. (if (and (tuple-type? type)
  96. (not (uvar-tuple-okay? uvar)))
  97. (set! errors (cons (tuple-error type) errors)))
  98. (cond ((null? errors) ;; whew!
  99. (minimize-type-depth! type (uvar-depth uvar))
  100. (set-uvar-binding! uvar type)
  101. #f)
  102. (else
  103. (lambda ()
  104. (format #t "unifying ")
  105. (display-type uvar (current-output-port))
  106. (format #t " == ")
  107. (display-type type (current-output-port))
  108. (format #t "~% would cause the following problem~A:"
  109. (if (null? (cdr errors)) "" "s"))
  110. (for-each (lambda (x) (x)) errors))))))
  111. (define (circularity-error)
  112. (format #t "~% creation of a circular type"))
  113. (define (tuple-error type)
  114. (lambda ()
  115. (if (null? (tuple-type-types type))
  116. (format #t "~% returning no values where one is expected")
  117. (format #t "~% returning ~D values where one is expected"
  118. (length (tuple-type-types type))))))
  119. ;; Check that UVAR does not occur in EXP.
  120. (define (uvar-in-type? uvar exp)
  121. (let label ((exp exp))
  122. (cond ((or (base-type? exp)
  123. (record-type? exp))
  124. #f)
  125. ((uvar? exp)
  126. (if (uvar-binding exp)
  127. (label (uvar-binding exp))
  128. (eq? exp uvar)))
  129. ((other-type? exp)
  130. (every? label (other-type-subtypes exp)))
  131. (else
  132. (identity (bug "funny type ~S" exp))))))
  133. ;; Make the depths of any uvars in TYPE be no greater than DEPTH.
  134. (define (minimize-type-depth! type depth)
  135. (let label ((type type))
  136. (cond ((other-type? type)
  137. (for-each label (other-type-subtypes type)))
  138. ((uvar? type)
  139. (cond ((uvar-binding type)
  140. => label)
  141. ((< depth (uvar-depth type))
  142. (set-uvar-depth! type depth)))))))
  143. ;; Set the depth of all uvars in TYPE to be -1 so that it will not be made
  144. ;; polymorphic at any level.
  145. (define (make-nonpolymorphic! type)
  146. (cond ((uvar? type)
  147. (set-uvar-depth! type -1))
  148. ((other-type? type)
  149. (for-each make-nonpolymorphic! (other-type-subtypes type)))
  150. ;;((type-scheme? type)
  151. ;; (make-nonpolymorphic! (type-scheme-type type)))
  152. ))
  153. ;;------------------------------------------------------------
  154. ;; Micro utilities
  155. (define *unique-id-counter* 0)
  156. (define (unique-id)
  157. (set! *unique-id-counter* (+ *unique-id-counter* 1))
  158. *unique-id-counter*)
  159. (define (reset-type-vars!)
  160. (set! *unique-id-counter* 0))