diff options
Diffstat (limited to 'tdecl')
| -rw-r--r-- | tdecl/README | 2 | ||||
| -rw-r--r-- | tdecl/alg-syn.scm | 228 | ||||
| -rw-r--r-- | tdecl/class.scm | 258 | ||||
| -rw-r--r-- | tdecl/instance.scm | 296 | ||||
| -rw-r--r-- | tdecl/tdecl-utils.scm | 16 | ||||
| -rw-r--r-- | tdecl/tdecl.scm | 18 | ||||
| -rw-r--r-- | tdecl/type-declaration-analysis.scm | 72 |
7 files changed, 890 insertions, 0 deletions
diff --git a/tdecl/README b/tdecl/README new file mode 100644 index 0000000..62e6b0a --- /dev/null +++ b/tdecl/README @@ -0,0 +1,2 @@ +This directory contains code to convert type-related declarations to +definition form. diff --git a/tdecl/alg-syn.scm b/tdecl/alg-syn.scm new file mode 100644 index 0000000..b128486 --- /dev/null +++ b/tdecl/alg-syn.scm @@ -0,0 +1,228 @@ + +;;; Description: Convert algdata & synonym from ast to definition form. +;;; Lots of error checking. + +;;; Algdata: +;;; Errors detected: +;;; Types & classes (deriving & context) resolved +;;; context tyvars must be parameters +;;; all parameter tyvars must be referenced +;;; only parameter tyvars must be referenced + +(define (algdata->def data-decl) + (remember-context data-decl + (with-slots data-decl (context simple constrs deriving annotations) data-decl + (let* ((def (tycon-def simple)) + (tyvars (simple-tyvar-list simple)) + (enum? '#t) + (tag 0) + (derived-classes '()) + (tyvars-referenced '()) + (all-con-vars '()) + (all-strict? (process-alg-strictness-annotation annotations)) + (constr-defs + (map (lambda (constr) + (with-slots constr (constructor types) constr + (let ((constr-def (con-ref-con constructor)) + (c-arity (length types)) + (con-vars '()) + (all-types '()) + (strictness '())) + (when (not (eqv? c-arity 0)) + (setf enum? '#f)) + (dolist (type types) + (let* ((ty (tuple-2-1 type)) + (anns (tuple-2-2 type)) + (tyvars1 (resolve-type ty))) + (push ty all-types) + (push (get-constr-strictness anns all-strict?) + strictness) + (dolist (v tyvars1) + (if (not (memq v tyvars)) + (signal-bad-algdata-tyvar v))) + (setf con-vars (append tyvars1 tyvars-referenced)) + (setf tyvars-referenced + (append tyvars1 tyvars-referenced)))) + (push (tuple constr con-vars) all-con-vars) + (update-slots con constr-def + (arity c-arity) + (types (reverse all-types)) + (tag tag) + (alg def) + (infix? (con-ref-infix? constructor)) + (slot-strict? (reverse strictness))) + (incf tag) + constr-def))) + constrs))) + (dolist (class deriving) + (if (eq? (class-ref-name class) '|Printers|) + (setf (class-ref-class class) *printer-class*) + (resolve-class class)) + (when (not (eq? (class-ref-class class) *undefined-def*)) + (push (class-ref-class class) derived-classes))) + (when (not (null? constrs)) + (dolist (tyvar tyvars) + (when (not (memq tyvar tyvars-referenced)) + (signal-unreferenced-tyvar-arg tyvar)))) + (resolve-signature-aux tyvars context) + ;; This computes a signature for the datatype as a whole. + (let ((gtype (ast->gtype context simple))) + ;; This sets the signatures for the constructors + (dolist (con constr-defs) + (let* ((con-type (**arrow-type/l (append (con-types con) + (list simple)))) + (con-context (restrict-context + context (tuple-2-2 (assq con all-con-vars)))) + (con-signature (ast->gtype con-context con-type))) + (setf (con-signature con) con-signature))) + (update-slots algdata def + (n-constr (length constrs)) + (constrs constr-defs) + (context context) + (tyvars tyvars) + (signature gtype) + (classes '()) + (enum? enum?) + (tuple? (and (not (null? constrs)) (null? (cdr constrs)))) + (real-tuple? '#f) + (deriving derived-classes) + )) + (process-alg-annotations def) + def)))) + + +(define (process-alg-strictness-annotation anns) + (let ((res '#f)) + (dolist (a anns) + (if (and (annotation-value? a) + (eq? (annotation-value-name a) '|STRICT|) + (null? (annotation-value-args a))) + (setf res '#t) + (signal-unknown-annotation a))) + res)) + +(define (get-constr-strictness anns all-strict?) + (let ((res all-strict?)) + (dolist (a anns) + (cond ((annotation-value? a) + (if (and (eq? (annotation-value-name a) '|STRICT|) + (null? (annotation-value-args a))) + (setf res '#t) + (signal-unknown-annotation a))) + (else (signal-unknown-annotation a)))) + res)) + +(define (process-alg-annotations alg) + (dolist (a (module-annotations *module*)) + (when (and (annotation-value? a) + (or (eq? (annotation-value-name a) '|ImportLispType|) + (eq? (annotation-value-name a) '|ExportLispType|)) + (assq (def-name alg) (car (annotation-value-args a)))) + (if (eq? (annotation-value-name a) '|ImportLispType|) + (setf (algdata-implemented-by-lisp? alg) '#t) + (setf (algdata-export-to-lisp? alg) '#t)) + (let ((constrs (tuple-2-2 (assq (def-name alg) + (car (annotation-value-args a)))))) + (dolist (c constrs) + (process-annotated-constr + alg + (lookup-alg-constr (tuple-2-1 c) (algdata-constrs alg)) + (tuple-2-2 c))))))) + +(define (lookup-alg-constr name constrs) + (if (null? constrs) + (fatal-error 'bad-constr-name "Constructor ~A not in algdata~%" + name) + (if (eq? name (def-name (car constrs))) + (car constrs) + (lookup-alg-constr name (cdr constrs))))) + +(define (process-annotated-constr alg con lisp-fns) + ;; For nullary tuples, allow a single annotation to represent a constant + ;; and generate the test function by default. + (when (and (eqv? (con-arity con) 0) + lisp-fns + (null? (cdr lisp-fns))) + (push `(lambda (x) (eq? x ,(car lisp-fns))) lisp-fns)) + ;; Insert an implicit test function for tuples (never used anyway!) + (when (and (algdata-tuple? alg) + (eqv? (+ 1 (con-arity con)) (length lisp-fns))) + (push '(lambda (x) '#t) lisp-fns)) + (when (or (not (null? (con-lisp-fns con))) + (not (eqv? (length lisp-fns) (+ 2 (con-arity con))))) + (fatal-error 'bad-constr-annotation + "Bad annotation for ~A in ~A~%" con alg)) + (setf (con-lisp-fns con) lisp-fns)) + +(define (signal-unknown-annotation a) + (recoverable-error 'bad-annotation "Bad or misplaced annotation: ~A%" + a)) + +(define (restrict-context context vars) + (if (null? context) + '() + (let ((rest (restrict-context (cdr context) vars))) + (if (memq (context-tyvar (car context)) vars) + (cons (car context) rest) + rest)))) + +(define (signal-bad-algdata-tyvar tyvar) + (phase-error 'bad-algdata-tyvar + "~a is referenced on the right-hand side of a data type declaration,~%~ + but is not bound as a type variable." + tyvar)) + +(define (signal-unreferenced-tyvar-arg tyvar) + (phase-error 'unreferenced-tyvar-arg + "~a is bound as a type variable in a data type declaration,~%~ + but is not referenced on the right-hand side." + tyvar)) + +;;; Synonyms + +;;; Errors detected: + +(define (synonym->def synonym-decl) + (remember-context synonym-decl + (with-slots synonym-decl (simple body) synonym-decl + (let* ((def (tycon-def simple)) + (tyvars (simple-tyvar-list simple)) + (tyvars-referenced (resolve-type body))) + (dolist (v tyvars) + (if (not (memq v tyvars-referenced)) + (signal-unreferenced-synonym-arg v))) + (dolist (v tyvars-referenced) + (if (not (memq v tyvars)) + (signal-bad-synonym-tyvar v))) + (update-slots synonym def + (args tyvars) + (body body)) + (push (cons def (gather-synonyms body '())) *synonym-refs*) + def)))) + +(define (signal-bad-synonym-tyvar tyvar) + (phase-error 'bad-synonym-tyvar + "~a is referenced on the right-hand side of a type synonym declaration,~%~ + but is not bound as a type variable." + tyvar)) + +(define (signal-unreferenced-synonym-arg tyvar) + (haskell-warning 'unreferenced-synonym-arg + "~a is bound as a type variable in a type synonym declaration,~%~ + but is not referenced on the right-hand side." + tyvar)) + +(define (gather-synonyms type acc) + (cond ((tyvar? type) + acc) + ((and (synonym? (tycon-def type)) + (eq? *unit* (def-unit (tycon-def type)))) + (gather-synonyms/list (tycon-args type) + (cons (tycon-def type) acc))) + (else + (gather-synonyms/list (tycon-args type) acc)))) + +(define (gather-synonyms/list types acc) + (if (null? types) + acc + (gather-synonyms/list (cdr types) (gather-synonyms (car types) acc)))) diff --git a/tdecl/class.scm b/tdecl/class.scm new file mode 100644 index 0000000..c95bbc2 --- /dev/null +++ b/tdecl/class.scm @@ -0,0 +1,258 @@ +;;; 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*))) diff --git a/tdecl/instance.scm b/tdecl/instance.scm new file mode 100644 index 0000000..1866339 --- /dev/null +++ b/tdecl/instance.scm @@ -0,0 +1,296 @@ +;;; 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)) diff --git a/tdecl/tdecl-utils.scm b/tdecl/tdecl-utils.scm new file mode 100644 index 0000000..0009eeb --- /dev/null +++ b/tdecl/tdecl-utils.scm @@ -0,0 +1,16 @@ +;;; This file contains routines which generate the code for the +;;; dictionaries used in the class system. + +(define (make-sel-node size i) + (**lambda '(x) + (if (eqv? size 1) + (**var 'x) + (**sel (tuple-constructor size) (**var 'x) i)))) + +(define (make-compose f1 f2) + (**lambda '(x) + (**app f1 (**app f2 (**var 'x))))) + +(define (make-new-var name) ; name is a string + (create-definition *module* (string->symbol name) 'var)) + diff --git a/tdecl/tdecl.scm b/tdecl/tdecl.scm new file mode 100644 index 0000000..227171e --- /dev/null +++ b/tdecl/tdecl.scm @@ -0,0 +1,18 @@ +;;; -- compilation unit definition for type declaration analysis +;;; +;;; author : John +;;; + +(define-compilation-unit tdecl + (source-filename "$Y2/tdecl/") + (require global) + (unit type-declaration-analysis + (source-filename "type-declaration-analysis.scm")) + (unit tdecl-utils + (source-filename "tdecl-utils.scm")) + (unit alg-syn + (source-filename "alg-syn.scm")) + (unit class + (source-filename "class.scm")) + (unit instance + (source-filename "instance.scm"))) diff --git a/tdecl/type-declaration-analysis.scm b/tdecl/type-declaration-analysis.scm new file mode 100644 index 0000000..bffcb23 --- /dev/null +++ b/tdecl/type-declaration-analysis.scm @@ -0,0 +1,72 @@ +;;; This processes type declarations (data, type, instance, class) +;;; Static errors in type declarations are detected and type decls +;;; are replaced by type definitions. All code (class and instance +;;; definitions) is moved to the module decls. + +(define *synonym-refs* '()) + +(predefine (add-derived-instances modules)) ; in derived/derived-instances.scm + +(define (process-type-declarations modules) +;;; Convert data & type decls to definitions + (let ((interface? (eq? (module-type (car modules)) 'interface))) + (setf *synonym-refs* '()) + (walk-modules modules + (lambda () + (setf (module-alg-defs *module*) + (map (function algdata->def) (module-algdatas *module*))) + (setf (module-synonym-defs *module*) + (map (function synonym->def) (module-synonyms *module*))) + (when (not interface?) + (dolist (ty (default-decl-types (module-default *module*))) + (resolve-type ty)))) + ;; A test to see that ty is in Num and is a monotype is needed here. + ) + (multiple-value-bind (ty vals) (topsort *synonym-refs*) + (when (eq? ty 'cyclic) (signal-recursive-synonyms vals))) + ;; Build the class heirarchy + (compute-super-classes modules) + ;; Convert class declarations and instance declarations to definitions. + (walk-modules modules + (lambda () + (setf (module-class-defs *module*) + (map (function class->def) (module-classes *module*))))) + (walk-modules modules + (lambda () + (dolist (class (module-class-defs *module*)) + (setf (class-selectors class) (create-selector-functions class))))) + (walk-modules modules + (lambda () + (setf (module-instance-defs *module*) '()) + (dolist (inst-decl (module-instances *module*)) + (let ((inst (instance->def inst-decl))) + (when (not (eq? inst '#f)) + (push inst (module-instance-defs *module*))))))) + (add-derived-instances modules) + (walk-modules modules + (lambda () + (dolist (inst (module-instance-defs *module*)) + (expand-instance-decls inst)))) + (when (not interface?) + (walk-modules modules + (lambda () + (dolist (ty (default-decl-types (module-default *module*))) + (resolve-type ty))))) + )) + + +(define (signal-recursive-synonyms vals) + (fatal-error 'recursive-synonyms + "There is a cycle in type synonym definitions involving these types:~%~a" + vals)) + +(define (add-new-module-decl decl) + (setf (module-decls *module*) (cons decl (module-decls *module*)))) + +(define (add-new-module-def var value) + (add-new-module-decl + (**define var '() value))) + +(define (add-new-module-signature var signature) + (add-new-module-decl + (**signdecl/def (list var) signature))) |