dynamic.scm

Scheme跨平台编译器

  (set-cdr! (cdr elem) info))

; (define (find! x)
;   ; finds the class representative of x and sets the parent field 
;   ; directly to the class representative (a class representative has
;   ; '() as its parent) (uses path halving)
;   ;(display "Find!: ")
;   ;(display (pretty-print (info x)))
;   ;(newline)
;   (let ((px (car x)))
;     (if (null? px)
;       x
;       (let ((ppx (car px)))
;         (if (null? ppx)
;             px
;             (begin
;               (set-car! x ppx)
;               (find! ppx)))))))

(define (find! elem)
  ; finds the class representative of elem and sets the parent field 
  ; directly to the class representative (a class representative has
  ; '() as its parent)
  ;(display "Find!: ")
  ;(display (pretty-print (info elem)))
  ;(newline)
  (let ((p-elem (car elem)))
    (if (null? p-elem)
        elem
        (let ((rep-elem (find! p-elem)))
          (set-car! elem rep-elem)
          rep-elem))))

(define (link! elem-1 elem-2)
  ; links class elements by rank
  ; they must be distinct class representatives
  ; returns the class representative of the merged equivalence classes
  ;(display "Link!: ")
  ;(display (pretty-print (list (info elem-1) (info elem-2))))
  ;(newline)
  (let ((rank-1 (cadr elem-1))
        (rank-2 (cadr elem-2)))
    (cond
     ((= rank-1 rank-2)
      (set-car! (cdr elem-2) (+ rank-2 1))
      (set-car! elem-1 elem-2)
      elem-2)
     ((> rank-1 rank-2)
      (set-car! elem-2 elem-1)
      elem-1)
     (else
      (set-car! elem-1 elem-2)
      elem-2))))

(define asymm-link! (lambda (l x) (set-car! l x)))

;(define (asymm-link! elem-1 elem-2)
  ; links elem-1 onto elem-2 no matter what rank; 
  ; does not update the rank of elem-2 and does not return a value
  ; the two arguments must be distinct
  ;(display "AsymmLink: ")
  ;(display (pretty-print (list (info elem-1) (info elem-2))))
  ;(newline)
  ;(set-car! elem-1 elem-2))

;----------------------------------------------------------------------------
; Type management
;----------------------------------------------------------------------------

; introduces type variables and types for Scheme,


;; type TVar (type variables)
;;
;; gen-tvar:          () -> TVar
;; gen-type:          TCon x TVar* -> TVar
;; dynamic:           TVar
;; tvar-id:           TVar -> Symbol
;; tvar-def:          TVar -> Type + Null
;; tvar-show:         TVar -> Symbol*
;;
;; set-def!:          !TVar x TCon x TVar* -> Null
;; equiv!:            !TVar x !TVar -> Null
;;
;;
;; type TCon (type constructors)
;;
;; ...
;;
;; type Type (types)
;;
;; gen-type:          TCon x TVar* -> Type
;; type-con:          Type -> TCon
;; type-args:         Type -> TVar*
;;
;; boolean:           TVar
;; character:         TVar
;; null:              TVar
;; pair:              TVar x TVar -> TVar
;; procedure:         TVar x TVar* -> TVar
;; charseq:           TVar
;; symbol:            TVar
;; array:             TVar -> TVar


; Needed packages: union/find

;(load "union-fi.so")

; TVar

(define counter 0)
; counter for generating tvar id's

(define (gen-id)
  ; generates a new id (for printing purposes)
  (set! counter (+ counter 1))
  counter)

(define (gen-tvar)
  ; generates a new type variable from a new symbol
  ; uses union/find elements with two info fields
  ; a type variable has exactly four fields:
  ; car:     TVar (the parent field; initially null)
  ; cadr:    Number (the rank field; is always nonnegative)
  ; caddr:   Symbol (the type variable identifier; used only for printing)
  ; cdddr:   Type (the leq field; initially null)
  (gen-element (cons (gen-id) '())))

(define (gen-type tcon targs)
  ; generates a new type variable with an associated type definition
  (gen-element (cons (gen-id) (cons tcon targs))))

(define dynamic (gen-element (cons 0 '())))
; the special type variable dynamic
; Generic operations

(define (tvar-id tvar)
  ; returns the (printable) symbol representing the type variable
  (car (info tvar)))

(define (tvar-def tvar)
  ; returns the type definition (if any) of the type variable
  (cdr (info tvar)))

(define (set-def! tvar tcon targs)
  ; sets the type definition part of tvar to type
  (set-cdr! (info tvar) (cons tcon targs))
  '())

(define (reset-def! tvar)
  ; resets the type definition part of tvar to nil
  (set-cdr! (info tvar) '()))

(define type-con (lambda (l) (car l)))
; returns the type constructor of a type definition

(define type-args (lambda (l) (cdr l)))
; returns the type variables of a type definition

(define (tvar->string tvar)
  ; converts a tvar's id to a string
  (if (eqv? (tvar-id tvar) 0)
      "Dynamic"
      (string-append "t#" (number->string (tvar-id tvar) 10))))

(define (tvar-show tv)
  ; returns a printable list representation of type variable tv
  (let* ((tv-rep (find! tv))
         (tv-def (tvar-def tv-rep)))
    (cons (tvar->string tv-rep)
          (if (null? tv-def)
              '()
              (cons 'is (type-show tv-def))))))

(define (type-show type)
  ; returns a printable list representation of type definition type
  (cond
   ((eqv? (type-con type) ptype-con)
    (let ((new-tvar (gen-tvar)))
      (cons ptype-con
            (cons (tvar-show new-tvar)
                  (tvar-show ((type-args type) new-tvar))))))
   (else
    (cons (type-con type)
          (map (lambda (tv)
                 (tvar->string (find! tv)))
               (type-args type))))))



; Special type operations

; type constructor literals

(define boolean-con 'boolean)
(define char-con 'char)
(define null-con 'null)
(define number-con 'number)
(define pair-con 'pair)
(define procedure-con 'procedure)
(define string-con 'string)
(define symbol-con 'symbol)
(define vector-con 'vector)

; type constants and type constructors

(define (null2)
  ; ***Note***: Temporarily changed to be a pair!
  ; (gen-type null-con '())
  (pair (gen-tvar) (gen-tvar)))
(define (boolean)
  (gen-type boolean-con '()))
(define (character)
  (gen-type char-con '()))
(define (number)
  (gen-type number-con '()))
(define (charseq)
  (gen-type string-con '()))
(define (symbol)
  (gen-type symbol-con '()))
(define (pair tvar-1 tvar-2)
  (gen-type pair-con (list tvar-1 tvar-2)))
(define (array tvar)
  (gen-type vector-con (list tvar)))
(define (procedure arg-tvar res-tvar)
  (gen-type procedure-con (list arg-tvar res-tvar)))


; equivalencing of type variables

(define (equiv! tv1 tv2)
  (let* ((tv1-rep (find! tv1))
         (tv2-rep (find! tv2))
         (tv1-def (tvar-def tv1-rep))
         (tv2-def (tvar-def tv2-rep)))
    (cond
     ((eqv? tv1-rep tv2-rep)
      '())
     ((eqv? tv2-rep dynamic)
      (equiv-with-dynamic! tv1-rep))
     ((eqv? tv1-rep dynamic)
      (equiv-with-dynamic! tv2-rep))
     ((null? tv1-def)
      (if (null? tv2-def)
          ; both tv1 and tv2 are distinct type variables
          (link! tv1-rep tv2-rep)
          ; tv1 is a type variable, tv2 is a (nondynamic) type
          (asymm-link! tv1-rep tv2-rep)))
     ((null? tv2-def)
      ; tv1 is a (nondynamic) type, tv2 is a type variable
      (asymm-link! tv2-rep tv1-rep))
     ((eqv? (type-con tv1-def) (type-con tv2-def))
      ; both tv1 and tv2 are (nondynamic) types with equal numbers of
      ; arguments
      (link! tv1-rep tv2-rep)
      (map equiv! (type-args tv1-def) (type-args tv2-def)))
     (else
      ; tv1 and tv2 are types with distinct type constructors or different
      ; numbers of arguments
      (equiv-with-dynamic! tv1-rep)
      (equiv-with-dynamic! tv2-rep))))
  '())

(define (equiv-with-dynamic! tv)
  (let ((tv-rep (find! tv)))
    (if (not (eqv? tv-rep dynamic))
        (let ((tv-def (tvar-def tv-rep)))
          (asymm-link! tv-rep dynamic)
          (if (not (null? tv-def))
              (map equiv-with-dynamic! (type-args tv-def))))))
  '())
;----------------------------------------------------------------------------
; Polymorphic type management
;----------------------------------------------------------------------------

; introduces parametric polymorphic types


;; forall: (Tvar -> Tvar) -> TVar
;; fix: (Tvar -> Tvar) -> Tvar
;;  
;; instantiate-type: TVar -> TVar

; type constructor literal for polymorphic types

(define ptype-con 'forall)

(define (forall tv-func)
  (gen-type ptype-con tv-func))

(define (forall2 tv-func2)
  (forall (lambda (tv1)
            (forall (lambda (tv2)
                      (tv-func2 tv1 tv2))))))

(define (forall3 tv-func3)
  (forall (lambda (tv1)
            (forall2 (lambda (tv2 tv3)
                       (tv-func3 tv1 tv2 tv3))))))

(define (forall4 tv-func4)
  (forall (lambda (tv1)
            (forall3 (lambda (tv2 tv3 tv4)
                       (tv-func4 tv1 tv2 tv3 tv4))))))

(define (forall5 tv-func5)
  (forall (lambda (tv1)
            (forall4 (lambda (tv2 tv3 tv4 tv5)
                       (tv-func5 tv1 tv2 tv3 tv4 tv5))))))


; (polymorphic) instantiation

(define (instantiate-type tv)
  ; instantiates type tv and returns a generic instance
  (let* ((tv-rep (find! tv))
         (tv-def (tvar-def tv-rep)))
    (cond 
     ((null? tv-def)
      tv-rep)
     ((eqv? (type-con tv-def) ptype-con)
      (instantiate-type ((type-args tv-def) (gen-tvar))))
     (else
      tv-rep))))

(define (fix tv-func)
  ; forms a recursive type: the fixed point of type mapping tv-func
  (let* ((new-tvar (gen-tvar))
         (inst-tvar (tv-func new-tvar))
         (inst-def (tvar-def inst-tvar)))
    (if (null? inst-def)
        (error 'fix "Illegal recursive type: ~s"
               (list (tvar-show new-tvar) '= (tvar-show inst-tvar)))
        (begin
          (set-def! new-tvar 
                    (type-con inst-def)
                    (type-args inst-def))
          new-tvar))))

  
;----------------------------------------------------------------------------
;       Constraint management 
;----------------------------------------------------------------------------


; constraints

(define gen-constr (lambda (a b) (cons a b)))
; generates an equality between tvar1 and tvar2

(define constr-lhs (lambda (c) (car c)))
; returns the left-hand side of a constraint

(define constr-rhs (lambda (c) (cdr c)))
; returns the right-hand side of a constraint

(define (constr-show c)
  (cons (tvar-show (car c)) 
        (cons '= 
              (cons (tvar-show (cdr c)) '()))))


; constraint set management

(define global-constraints '())

(define (init-global-constraints!)
  (set! global-constraints '()))

(define (add-constr! lhs rhs)
  (set! global-constraints
        (cons (gen-constr lhs rhs) global-constraints))
  '())

(define (glob-constr-show) 
  ; returns printable version of global constraints
  (map constr-show global-constraints))


; constraint normalization