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.

---
 util/instance-manager.scm | 161 ++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 161 insertions(+)
 create mode 100644 util/instance-manager.scm

(limited to 'util/instance-manager.scm')

diff --git a/util/instance-manager.scm b/util/instance-manager.scm
new file mode 100644
index 0000000..231e27d
--- /dev/null
+++ b/util/instance-manager.scm
@@ -0,0 +1,161 @@
+
+;;; This file has some random utilities dealing with instances.
+
+;;; Right now, this is a linear search off the class.
+
+(define (lookup-instance alg-def class-def)
+  (let ((res (lookup-instance-1 alg-def (class-instances class-def))))
+    (if (and (eq? res '#f) (algdata-real-tuple? alg-def))
+	(lookup-possible-tuple-instances alg-def class-def)
+	res)))
+
+(define (lookup-instance-1 alg-def instances)
+  (cond ((null? instances)
+	 '#f)
+	((eq? (instance-algdata (car instances)) alg-def)
+	 (if (instance-ok? (car instances))
+	     (car instances)
+	     '#f))
+	(else
+	 (lookup-instance-1 alg-def (cdr instances)))))
+
+(define (lookup-possible-tuple-instances alg-def class-def)
+  (cond ((eq? class-def (core-symbol "Eq"))
+	 (get-tuple-eq-instance alg-def))
+	((eq? class-def (core-symbol "Ord"))
+	 (get-tuple-ord-instance alg-def))
+	((eq? class-def (core-symbol "Ix"))
+	 (get-tuple-ix-instance alg-def))
+	((eq? class-def (core-symbol "Text"))
+	 (get-tuple-text-instance alg-def))
+	((eq? class-def (core-symbol "Binary"))
+	 (get-tuple-binary-instance alg-def))
+	(else '#f)))
+
+(define *saved-eq-instances* '())
+(define *saved-ord-instances* '())
+(define *saved-ix-instances* '())
+(define *saved-text-instances* '())
+(define *saved-binary-instances* '())
+
+(define (get-tuple-eq-instance tpl)
+  (let ((res (assq tpl *saved-eq-instances*)))
+    (if (not (eq? res '#f))
+	(tuple-2-2 res)
+	(let ((inst (make-tuple-instance
+		     tpl (core-symbol "Eq") (core-symbol "tupleEqDict"))))
+	  (push (tuple tpl inst) *saved-eq-instances*)
+	  inst))))
+
+(define (get-tuple-ord-instance tpl)
+  (let ((res (assq tpl *saved-ord-instances*)))
+    (if (not (eq? res '#f))
+	(tuple-2-2 res)
+	(let ((inst (make-tuple-instance
+		     tpl (core-symbol "Ord") (core-symbol "tupleOrdDict"))))
+	  (push (tuple tpl inst) *saved-ord-instances*)
+	  inst))))
+
+(define (get-tuple-ix-instance tpl)
+  (let ((res (assq tpl *saved-ix-instances*)))
+    (if (not (eq? res '#f))
+	(tuple-2-2 res)
+	(let ((inst (make-tuple-instance
+		     tpl (core-symbol "Ix") (core-symbol "tupleIxDict"))))
+	  (push (tuple tpl inst) *saved-ix-instances*)
+	  inst))))
+
+(define (get-tuple-text-instance tpl)
+  (let ((res (assq tpl *saved-text-instances*)))
+    (if (not (eq? res '#f))
+	(tuple-2-2 res)
+	(let ((inst (make-tuple-instance
+		     tpl (core-symbol "Text") (core-symbol "tupleTextDict"))))
+	  (push (tuple tpl inst) *saved-text-instances*)
+	  inst))))
+
+(define (get-tuple-binary-instance tpl)
+  (let ((res (assq tpl *saved-binary-instances*)))
+    (if (not (eq? res '#f))
+	(tuple-2-2 res)
+	(let ((inst (make-tuple-instance
+		     tpl (core-symbol "Binary")
+		     (core-symbol "tupleBinaryDict"))))
+	  (push (tuple tpl inst) *saved-binary-instances*)
+	  inst))))
+
+(define (make-tuple-instance algdata class dict)
+  (let* ((size (tuple-size algdata))
+	 (tyvars (gen-symbols size))
+	 (context (map (lambda (tyvar)
+			  (**context (**class/def class) tyvar))
+			tyvars))
+	 (sig (**tycon/def algdata (map (lambda (x) (**tyvar x)) tyvars)))
+	 (gcontext (gtype-context (ast->gtype context sig))))
+    (make instance 
+	  (algdata algdata)
+	  (tyvars tyvars)
+	  (class class)
+	  (context context)
+	  (gcontext gcontext)
+	  (methods '())
+	  (dictionary dict)
+	  (ok? '#t)
+	  (special? '#t))))
+
+;;; I know these are somewhere else too ...
+
+(define (tuple-size alg)
+  (con-arity (car (algdata-constrs alg))))
+
+(define (gen-symbols n)
+  (gen-symbols-1 n '(|a| |b| |c| |d| |e| |f| |g| |h| |i| |j| |k| |l| |m|
+		     |n| |o| |p| |q| |r| |s| |t| |u| |v| |w| |x| |y| |z|)))
+
+(define (gen-symbols-1 n vars)
+  (if (eqv? n 0)
+      '()
+      (if (null? vars)
+	  (cons (string->symbol (format '#f "x~A" n))
+		(gen-symbols-1 (1- n) '()))
+	  (cons (car vars) (gen-symbols-1 (1- n) (cdr vars))))))
+
+;;; This handles the dynamic linking of instances into classes
+
+(define (link-instances modules)
+  (dolist (m modules)
+    ;; clear out any instances sitting around from old compiles
+    (dolist (class (module-class-defs m))
+      (setf (class-instances class) '())))
+  (dolist (m modules)
+    (dolist (inst (module-instance-defs m))
+       (link-instance inst)))
+  )
+
+(define (link-instance inst)  ; links an instance into the associated class
+  (push inst (class-instances (instance-class inst))))
+
+;;; This creates a new instance object and installs it.
+
+(predefine (make-new-var name))  ; in tdecl/tdecl-utils.scm
+
+(define (new-instance class algdata tyvars)
+ (let* ((dict-name
+	 (string-append "dict-"
+			(symbol->string (print-name class)) "-"
+			(symbol->string (print-name algdata))))
+	(inst (make instance (algdata algdata)
+			     (tyvars tyvars)
+		             (class class)
+			     (gcontext '())
+			     (context '())
+			     (dictionary (make-new-var dict-name)))))
+   (link-instance inst)
+   inst))
+
+
+
+
+
+
+
-- 
cgit v1.2.3