From 4e987026148fe65c323afbc93cd560c07bf06b3f Mon Sep 17 00:00:00 2001 From: Yale AI Dept Date: Wed, 14 Jul 1993 13:08:00 -0500 Subject: Import to github. --- tdecl/alg-syn.scm | 228 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 228 insertions(+) create mode 100644 tdecl/alg-syn.scm (limited to 'tdecl/alg-syn.scm') 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)))) -- cgit v1.2.3