| 4e987026 |
;;; Before classes are converted, the super class relation is computed.
;;; This sets up the super and super* field of each class and
;;; checks for the following errors:
;;; Wrong tyvar in context
;;; cyclic class structure
;;; Non-class in context
(define (compute-super-classes modules)
(let ((all-classes '()))
(walk-modules modules
(lambda ()
(dolist (c (module-classes *module*))
(remember-context c
(with-slots class-decl (super-classes class class-var) c
(let* ((def (class-ref-class class))
(local-ctxts '())
(super '()))
(dolist (context super-classes)
(with-slots context (class tyvar) context
(when (not (eq? class-var tyvar))
(signal-super-class-tyvar-error class class-var tyvar))
(resolve-class class)
(let ((super-def (class-ref-class class)))
(when (not (eq? super-def *undefined-def*))
(push super-def super)
(when (eq? *unit* (def-unit super-def))
(push super-def local-ctxts))))))
(update-slots class def
(super super)
(tyvar class-var))
(push (cons def local-ctxts) all-classes)))))))
(multiple-value-bind (status sorted) (topsort all-classes)
(when (eq? status 'cyclic)
(signal-cyclic-class-structure sorted))
(dolist (c sorted)
(let* ((super (class-super c))
(super* super))
(dolist (s super)
(setf super* (set-union super* (class-super* s)))
(setf (class-super* c) super*)))))))
(define (signal-super-class-tyvar-error class class-var tyvar)
(recoverable-error 'super-class-tyvar-error
"The context for class ~A must only refer to type variable ~A.~%~
Type variable ~A cannot be used here."
(class-ref-name class) class-var tyvar))
(define (signal-cyclic-class-structure classes)
(fatal-error 'cyclic-class-structure
"There is a cycle in the superclass relation involving these classes:~%~a"
classes))
;;; This sets up the following fields in the class entry:
;;; instances '()
;;; defaults = ast for defaults
;;; kind
;;; methods
;;; signatures
;;; method-vars
;;; selectors
;;; Each method is initialized with
;;; class
;;; signature
;;; type
;;; Errors detected:
;;; signature doesnt reference class
(define (class->def class-decl)
(remember-context class-decl
(let* ((class (class-ref-class (class-decl-class class-decl)))
(decls (class-decl-decls class-decl)))
(setf (class-instances class) '())
(setf (class-kind class) (find-class-kind class))
(init-methods class decls) ; sets up defaults, method signatures
(setf (class-n-methods class) (length (class-method-vars class)))
(setf (class-dict-size class)
(+ (class-n-methods class) (length (class-super* class))))
class)))
(define (find-class-kind class)
(cond ((not (module-prelude? *module*))
'other)
((memq class
(list (core-symbol "Eq") (core-symbol "Ord")
(core-symbol "Text") (core-symbol "Binary")
(core-symbol "Ix") (core-symbol "Enum")))
'Standard)
((memq class
(list (core-symbol "Num") (core-symbol "Real")
(core-symbol "Integral") (core-symbol "Fractional")
(core-symbol "Floating") (core-symbol "RealFrac")
(core-symbol "RealFloat")))
'Numeric)
(else
'other)))
(define (init-methods class decls)
(let* ((tyvar (class-tyvar class))
(class-context (**context (**class/def class) tyvar)))
(dolist (decl decls)
(remember-context decl
(cond ((is-type? 'signdecl decl)
(let* ((signature (signdecl-signature decl))
(vars (resolve-signature signature)))
(when (not (memq tyvar vars))
(signal-class-sig-ignores-type signature))
;; Note: signature does not include defined class yet
(dolist (context (signature-context signature))
(when (eq? tyvar (context-tyvar context))
(signal-method-constrains-class-tyvar context)))
(setf signature (rename-class-sig-vars signature tyvar))
(let ((gtype (ast->gtype (cons class-context
(signature-context signature))
(signature-type signature))))
(dolist (var-ref (signdecl-vars decl))
(let ((var (var-ref-var var-ref)))
(setf (var-type var) gtype)
(setf (method-var-method-signature var) signature))))))
(else ; decl must be a default definition
(let ((vars (collect-pattern-vars (valdef-lhs decl))))
(dolist (var-ref vars)
(resolve-var var-ref)
(let* ((method-name (var-ref-name var-ref))
(method-var (var-ref-var var-ref)))
(when (not (eq? method-var *undefined-def*))
(if (and (method-var? method-var)
(eq? (method-var-class method-var) class))
(let ((default-var
(make-new-var
(string-append
"default-"
(symbol->string (def-name method-var))))))
(setf (var-ref-var var-ref) default-var)
(setf (var-ref-name var-ref) (def-name default-var))
(when (not (eq? (method-var-default method-var) '#f))
(signal-multiple-definition-of-default method-name))
(setf (method-var-default method-var) default-var)
(let* ((sig (method-var-method-signature method-var))
(context (cons class-context
(signature-context sig)))
(new-sig (**signature context
(signature-type sig))))
(add-new-module-signature default-var new-sig)))
(signal-default-not-in-class method-var class)))))
(add-new-module-decl decl))))))))
(define (signal-class-sig-ignores-type signature)
(phase-error 'class-sig-ignores-type
"The method signature ~a does not reference the overloaded type."
signature))
;;; *** I don't understand this message.
(define (signal-method-constrains-class-tyvar context)
(phase-error 'method-constrains-class-tyvar
"Individual methods may not further constrain a class: ~A" context))
;;; *** I don't understand this message.
(define (signal-multiple-definition-of-default method-name)
(phase-error 'multiple-definition-of-default
"More that one default for ~A."
method-name))
;;; *** I don't understand this message.
(define (signal-default-not-in-class method-var class)
(phase-error 'default-not-in-class
"~A is not a method in class ~A."
method-var class))
(define (create-selector-functions class)
(let ((res '()))
(dolist (c (cons class (class-super* class)))
(dolist (m (class-method-vars c))
(let* ((var (make-new-var
(string-append "sel-"
(symbol->string (def-name class))
"/"
(symbol->string (def-name m)))))
(sel-body (create-selector-code class m)))
(setf (var-selector-fn? var) '#t)
(push (tuple m var) res)
(when (not (eq? (module-type *module*) 'interface))
(add-new-module-def var sel-body)))))
res))
(define (create-selector-code c m)
(let ((var (create-local-definition '|d|)))
(setf (var-force-strict? var) '#t)
(let ((body (create-selector-code-1 c m (**var/def var))))
(**lambda/pat (list (**var-pat/def var)) body))))
(define (create-selector-code-1 class method d)
(let ((mcl (method-var-class method)))
(cond ((eq? mcl class)
(**dsel/method class method d))
(else
(**dsel/method mcl method (**dsel/dict class mcl d))))))
;;; The following code is for the alpha conversion of method
;;; signatures. The class tyvar is unchanged; all others are renamed.
;;; This is needed because all method types are combined to form the
;;; dictionary signature and aliasing among different tyvars should be
;;; prevented.
(define (rename-class-sig-vars signature tyvar)
(mlet (((new-context env1)
(rename-context-vars (signature-context signature)
(list (tuple tyvar tyvar))))
((new-type _)
(rename-type-vars (signature-type signature) env1)))
(**signature new-context new-type)))
(define (rename-context-vars contexts env)
(if (null? contexts)
(values '() env)
(mlet (((new-tyvar env1)
(rename-sig-tyvar (context-tyvar (car contexts)) env))
((rest env2)
(rename-context-vars (cdr contexts) env1)))
(values (cons (**context (context-class (car contexts)) new-tyvar) rest)
env2))))
(define (rename-type-vars type env)
(if (tyvar? type)
(mlet (((tyvar env1)
(rename-sig-tyvar (tyvar-name type) env)))
(values (**tyvar tyvar) env1))
(mlet (((new-types env1) (rename-type-vars/l (tycon-args type) env)))
(values (**tycon/def (tycon-def type) new-types) env1))))
(define (rename-type-vars/l types env)
(if (null? types)
(values '() env)
(mlet (((type1 env1) (rename-type-vars (car types) env))
((new-types env2) (rename-type-vars/l (cdr types) env1)))
(values (cons type1 new-types) env2))))
(define (rename-sig-tyvar tyvar env)
(let ((res (assq tyvar env)))
(if (eq? res '#f)
(let ((new-tyvar (gentyvar (symbol->string tyvar))))
(values new-tyvar (cons (tuple tyvar new-tyvar) env)))
(values (tuple-2-2 res) env))))
(define *tyvar-counter* 0)
;;; This generates a new interned tyvar name
(define (gentyvar root)
(incf *tyvar-counter*)
(string->symbol (format '#f "~A-~A" root *tyvar-counter*)))
|