From 4e987026148fe65c323afbc93cd560c07bf06b3f Mon Sep 17 00:00:00 2001
From: Yale AI Dept <ai@nebula.cs.yale.edu>
Date: Wed, 14 Jul 1993 13:08:00 -0500
Subject: Import to github.

---
 tdecl/class.scm | 258 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 258 insertions(+)
 create mode 100644 tdecl/class.scm

(limited to 'tdecl/class.scm')

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*)))
-- 
cgit v1.2.3