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.

---
 import-export/top-definitions.scm | 98 +++++++++++++++++++++++++++++++++++++++
 1 file changed, 98 insertions(+)
 create mode 100644 import-export/top-definitions.scm

(limited to 'import-export/top-definitions.scm')

diff --git a/import-export/top-definitions.scm b/import-export/top-definitions.scm
new file mode 100644
index 0000000..07722dd
--- /dev/null
+++ b/import-export/top-definitions.scm
@@ -0,0 +1,98 @@
+;;; File: top-definitions.scm
+
+;;; Description: This creates definitions for all top level (exportable)
+;;;  object in a module.
+
+(define (create-top-definitions)
+  (dolist (decl (module-decls *module*))
+    (if (eq? (module-type *module*) 'interface)
+	(when (signdecl? decl)
+	   (create-var-definitions decl (signdecl-vars decl)))
+	(when (valdef? decl)
+	   (create-var-definitions
+	    decl (collect-pattern-vars (valdef-lhs decl))))))
+  (dolist (algdata (module-algdatas *module*))
+    (create-alg-definitions algdata))
+  (dolist (synonym (module-synonyms *module*))
+    (create-syn-definitions synonym))
+  (dolist (class (module-classes *module*))
+    (create-class-definitions class)))
+
+;;; ------------------------------------------------------------------------
+;;; creation of definitions
+;;; ------------------------------------------------------------------------
+
+(define (create-var-definitions decl vars)
+  (remember-context decl
+    (dolist (v vars)
+     (let* ((var-name (var-ref-name v))
+	    (def (create-top-definition var-name 'var)))
+       (setf (var-ref-var v) def)
+       (push def (module-vars *module*))
+       (add-new-group var-name def)))))
+
+;;; This also creates definitions for the constructors
+
+(define (create-alg-definitions algdata)
+  (remember-context algdata
+    (with-slots data-decl (simple constrs) algdata
+      (let* ((alg-name (tycon-name simple))
+	     (def (create-top-definition alg-name 'algdata)))
+	(setf (tycon-def simple) def)
+	(let ((constr-group
+	       (map (lambda (constr) 
+		     (let* ((con-ref (constr-constructor constr))
+			    (con-name (con-ref-name con-ref))
+			    (con-def (create-top-definition con-name 'con)))
+		        (setf (con-ref-con con-ref) con-def)
+			(tuple con-name con-def)))
+		    constrs)))
+	  (setf (algdata-constrs def) (map (function tuple-2-2) constr-group))
+	  (setf (tycon-def-arity def) (length (tycon-args simple)))
+	  (add-new-group alg-name def constr-group))))))
+
+(define (create-class-definitions class-decl)
+  (remember-context class-decl
+    (with-slots class-decl (class decls) class-decl
+      (let* ((class-name (class-ref-name class))
+	     (class-def (create-top-definition class-name 'class)))
+	(setf (class-ref-class class) class-def)
+	(let ((method-group
+	       (concat
+		(map
+		 (lambda (decl) 
+		  (if (is-type? 'signdecl decl)
+		      (remember-context decl
+		       (map (lambda (method-var)
+			      (let* ((var-name (var-ref-name method-var))
+				     (def (create-top-definition
+					      var-name 'method-var)))
+				(setf (method-var-class def) class-def)
+				(setf (method-var-default def) '#f)
+				(setf (var-ref-var method-var) def)
+				(tuple var-name def)))
+			    (signdecl-vars decl)))
+		      '()))
+		decls))))
+	  (setf (class-method-vars class-def)
+		(map (function tuple-2-2) method-group))
+	  (add-new-group class-name class-def method-group))))))
+
+(define (create-syn-definitions synonym-decl)
+  (remember-context synonym-decl
+    (let* ((simple (synonym-decl-simple synonym-decl))
+	   (syn-name (tycon-name simple))
+	   (def (create-top-definition syn-name 'synonym)))
+      (setf (tycon-def simple) def)
+      (setf (tycon-def-arity def) (length (tycon-args simple)))
+      (add-new-group syn-name def))))
+
+(define (add-new-group name def . others)
+  (when (memq *module* (module-exported-modules *module*))
+      (export-group (cons (tuple name def)
+			  (if (null? others)
+			      '()
+			      (car others))))))
+
+
+
-- 
cgit v1.2.3