| 4e987026 |
;;; tdecl/instance.scm
;;; Convert an instance decl to a definition
;;; The treatment of instances is more complex than the treatment of other
;;; type definitions due to the possibility of derived instances.
;;; Here's the plan:
;;; a) instance-decls are converted to instance structures. The type
;;; information is verified but the decls are unchanged.
;;; b) All instances are linked into the associated classes.
;;; c) Derived instances are generated.
;;; d) Instance dictionaries are generated from the decls in the instances.
;;;
;;; Instances-decl to instance definition conversion
;;; Errors detected:
;;; Class must be a class
;;; Data type must be an alg
;;; Tyvars must be distinct
;;; Correct number of tyvars
;;; Context applies only to tyvars in simple
;;; C-T restriction
;;; Needs work for interface files.
(define (instance->def inst-decl)
(recover-errors '#f
(remember-context inst-decl
(with-slots instance-decl (context class simple decls) inst-decl
(resolve-type simple)
(resolve-class class)
(let ((alg-def (tycon-def simple))
(class-def (class-ref-class class)))
(when (not (algdata? (tycon-def simple)))
(signal-datatype-required (tycon-def simple)))
(let ((tyvars (simple-tyvar-list simple)))
(resolve-signature-aux tyvars context)
(when (and (not (eq? *module-name* (def-module alg-def)))
(not (eq? *module-name* (def-module class-def))))
(signal-c-t-rule-violation class-def alg-def))
(let ((old-inst (lookup-instance alg-def class-def)))
(when (and (not (eq? old-inst '#f))
(not (instance-special? old-inst)))
(signal-multiple-instance class-def alg-def))
(let ((inst (new-instance class-def alg-def tyvars)))
(setf (instance-context inst) context)
(setf (instance-decls inst) decls)
(setf (instance-ok? inst) '#t)
inst))))))))
(define (signal-datatype-required def)
(phase-error 'datatype-required
"The synonym type ~a cannot be declared as an instance."
(def-name def)))
(define (signal-c-t-rule-violation class-def alg-def)
(phase-error 'c-t-rule-violation
"Instance declaration does not appear in the same module as either~%~
the class ~a or type ~a."
class-def alg-def))
(define (signal-multiple-instance class-def alg-def)
(phase-error 'multiple-instance
"The type ~a has already been declared to be an instance of class ~a."
alg-def class-def))
;;; This generates the dictionary for each instance and makes a few final
;;; integrity checks in the instance context. This happens after derived
;;; instances are inserted.
(define (expand-instance-decls inst)
(when (instance-ok? inst)
(check-inst-type inst)
(with-slots instance (class algdata dictionary decls context tyvars) inst
(let ((simple (**tycon/def algdata (map (function **tyvar) tyvars))))
(setf (instance-gcontext inst)
(gtype-context (ast->gtype/inst context simple)))
(with-slots class (super* method-vars) class
;; Before computing signatures uniquify tyvar names to prevent
;; collision with method tyvar names
(let ((new-tyvars (map (lambda (tyvar) (tuple tyvar (gentyvar "tv")))
(instance-tyvars inst))))
(setf (instance-tyvars inst) (map (function tuple-2-2) new-tyvars))
(setf (instance-context inst)
(map (lambda (c)
(**context (context-class c)
(tuple-2-2 (assq (context-tyvar c) new-tyvars))))
(instance-context inst))))
;; Now walk over the decls & rename each method with a unique name
;; generated by combining the class, type, and method. Watch for
;; multiple defs of methods and add defaults after all decls have
;; been scanned.
(let ((methods-used '())
(new-instance-vars (map (lambda (m)
(tuple m (method-def-var m inst)))
method-vars)))
(dolist (decl decls)
(setf methods-used
(process-instance-decl decl new-instance-vars methods-used)))
;; now add defaults when needed
(dolist (m-v new-instance-vars)
(let* ((method-var (tuple-2-1 m-v))
(definition-var (tuple-2-2 m-v))
(signature (generate-method-signature inst method-var '#t)))
(if (memq method-var methods-used)
(add-new-module-signature definition-var signature)
(let ((method-body
(if (eq? (method-var-default method-var) '#f)
(**abort (format '#f
"No method declared for method ~A in instance ~A(~A)."
method-var class algdata))
(**var/def (method-var-default method-var)))))
(add-new-module-def definition-var method-body)
(add-new-module-signature definition-var signature)))))
(setf (instance-methods inst) new-instance-vars)
(add-new-module-def dictionary
(**tuple/l (append (map (lambda (m-v)
(dict-method-ref
(tuple-2-1 m-v) (tuple-2-2 m-v) inst))
new-instance-vars)
(map (lambda (c)
(get-class-dict algdata c))
super*))))
(let ((dict-sig (generate-dictionary-signature inst)))
(add-new-module-signature dictionary dict-sig))
(setf (instance-decls inst) '())))))))
(define (dict-method-ref method-var inst-var inst)
(if (null? (signature-context (method-var-method-signature method-var)))
(**var/def inst-var)
(let* ((sig (generate-method-signature inst method-var '#f))
(ctxt (signature-context sig))
(ty (signature-type sig)))
(make overloaded-var-ref
(sig (ast->gtype ctxt ty))
(var inst-var)))))
(define (get-class-dict algdata class)
(let ((inst (lookup-instance algdata class)))
(if (eq? inst '#f)
(**abort "Missing super class")
(**var/def (instance-dictionary inst)))))
(define (process-instance-decl decl new-instance-vars methods-used)
(if (valdef? decl)
(rename-instance-decl decl new-instance-vars methods-used)
(begin
(dolist (a (annotation-decls-annotations decl))
(cond ((annotation-value? a)
(recoverable-error 'misplaced-annotation
"Misplaced annotation: ~A~%" a))
(else
(dolist (name (annotation-decl-names a))
(attach-method-annotation
name (annotation-decl-annotations a) new-instance-vars)))))
methods-used)))
(define (attach-method-annotation name annotations vars)
(cond ((null? vars)
(signal-no-method name))
((eq? name (def-name (tuple-2-1 (car vars))))
(setf (var-annotations (tuple-2-2 (car vars)))
(append annotations (var-annotations (tuple-2-2 (car vars))))))
(else (attach-method-annotation name annotations (cdr vars)))))
(define (signal-no-method name)
(recoverable-error 'no-method "~A is not a method in this class.~%"
name))
(define (rename-instance-decl decl new-instance-vars methods-used)
(let ((decl-vars (collect-pattern-vars (valdef-lhs decl))))
(dolist (var decl-vars)
(resolve-var var)
(let ((method (var-ref-var var)))
(when (not (eq? method *undefined-def*))
(let ((m-v (assq method new-instance-vars)))
(cond ((memq method methods-used)
(signal-multiple-instance-def method))
((eq? m-v '#f)
(signal-not-in-class method))
(else
(setf (var-ref-name var) (def-name (tuple-2-2 m-v)))
(setf (var-ref-var var) (tuple-2-2 m-v))
(push (tuple-2-1 m-v) methods-used)))))))
(add-new-module-decl decl)
methods-used))
(define (signal-multiple-instance-def method)
(phase-error 'multiple-instance-def
"The instance declaration has multiple definitions of the method ~a."
method))
(define (signal-not-in-class method)
(phase-error 'not-in-class
"The instance declaration includes a definition for ~a,~%~
which is not one of the methods for this class."
method))
(define (method-def-var method-var inst)
(make-new-var
(string-append "i-"
(symbol->string (print-name (instance-class inst))) "-"
(symbol->string (print-name (instance-algdata inst))) "-"
(symbol->string (def-name method-var)))))
(define (generate-method-signature inst method-var keep-method-context?)
(let* ((simple-type (make-instance-type inst))
(class-context (instance-context inst))
(class-tyvar (class-tyvar (instance-class inst)))
(signature (method-var-method-signature method-var)))
(make signature
(context (if keep-method-context?
(append class-context (signature-context signature))
class-context))
(type (substitute-tyvar (signature-type signature) class-tyvar
simple-type)))))
(define (make-instance-type inst)
(**tycon/def (instance-algdata inst)
(map (function **tyvar) (instance-tyvars inst))))
(define (generate-dictionary-signature inst)
(**signature (sort-inst-context-by-tyvar
(instance-context inst) (instance-tyvars inst))
(generate-dictionary-type inst (make-instance-type inst))))
(define (sort-inst-context-by-tyvar ctxt tyvars)
(concat (map (lambda (tyvar)
(extract-single-context tyvar ctxt)) tyvars)))
(define (extract-single-context tyvar ctxt)
(if (null? ctxt)
'()
(let ((rest (extract-single-context tyvar (cdr ctxt))))
(if (eq? tyvar (context-tyvar (car ctxt)))
(cons (car ctxt) rest)
rest))))
(define (generate-dictionary-type inst simple)
(let* ((class (instance-class inst))
(algdata (instance-algdata inst))
(tyvar (class-tyvar class)))
(**tuple-type/l (append (map (lambda (method-var)
;; This ignores the context associated
;; with a method
(let ((sig (method-var-method-signature
method-var)))
(substitute-tyvar (signature-type sig)
tyvar
simple)))
(class-method-vars class))
(map (lambda (super-class)
(generate-dictionary-type
(lookup-instance algdata super-class)
simple))
(class-super* class))))))
;;; Checks performed here:
;;; Instance context must include the following:
;;; Context associated with data type
;;; Context associated with instances for each super class
;;; All super class instances must exist
(define (check-inst-type inst)
(let* ((class (instance-class inst))
(algdata (instance-algdata inst))
(inst-context (instance-gcontext inst))
(alg-context (gtype-context (algdata-signature algdata))))
(when (not (full-context-implies? inst-context alg-context))
(signal-instance-context-needs-alg-context algdata))
(dolist (super-c (class-super class))
(let ((super-inst (lookup-instance algdata super-c)))
(cond ((eq? super-inst '#f)
(signal-no-super-class-instance class algdata super-c))
(else
(when (not (full-context-implies?
inst-context (instance-context super-inst)))
(signal-instance-context-insufficient-for-super
class algdata super-c))))))
))
(define (signal-instance-context-needs-alg-context algdata)
(phase-error 'instance-context-needs-alg-context
"The instance context needs to include context defined for data type ~A."
algdata))
(define (signal-no-super-class-instance class algdata super-c)
(fatal-error 'no-super-class-instance
"The instance ~A(~A) requires that the instance ~A(~A) be provided."
class algdata super-c algdata))
(define (signal-instance-context-insufficient-for-super class algdata super-c)
(phase-error 'instance-context-insufficient-for-super
"Instance ~A(~A) does not imply super class ~A instance context."
class algdata super-c))
|