From 756c0c15aed97a5567ba8e7dff8456d2a45fed3a Mon Sep 17 00:00:00 2001
From: Martin Gasbichler <gasbichl@informatik.uni-tuebingen.de>
Date: Tue, 28 Jan 2003 13:13:10 +0000
Subject: [PATCH] Moved from rt-modules/

---
 s48/module-system/interfaces.scm | 15 ++++++++++
 s48/module-system/packages.scm   | 51 ++++++++++++++++++++++++++++----
 s48/module-system/rt-module.scm  | 49 ++++++++++++++++++++++++++++++
 3 files changed, 109 insertions(+), 6 deletions(-)
 create mode 100644 s48/module-system/interfaces.scm
 create mode 100644 s48/module-system/rt-module.scm

diff --git a/s48/module-system/interfaces.scm b/s48/module-system/interfaces.scm
new file mode 100644
index 0000000..8a3a24a
--- /dev/null
+++ b/s48/module-system/interfaces.scm
@@ -0,0 +1,15 @@
+(define-interface rt-modules-interface
+  (export ((lambda-interface 
+	    with-names-from-rt-structure)
+	   :syntax)
+	  reify-structure
+	  load-structure
+	  load-config-file
+	  rt-structure-binding))
+
+(define-interface rt-modules-core-interface
+  (export interface-value-names 
+	  reify-structure
+	  load-config-file
+	  rt-structure-binding
+	  load-structure))
\ No newline at end of file
diff --git a/s48/module-system/packages.scm b/s48/module-system/packages.scm
index bd0d269..d4c1953 100644
--- a/s48/module-system/packages.scm
+++ b/s48/module-system/packages.scm
@@ -1,7 +1,46 @@
-(define-structure overlapping-imports? (export)
+(define-structure rt-modules rt-modules-interface
+
   (open scheme
-	optimizer
-	signals 
-	general-tables 
-	packages-internal)
-  (files overlapping-imports))
\ No newline at end of file
+	rt-modules-core)
+  (for-syntax (open scheme
+		    rt-modules-core))
+
+  (begin
+    (define-syntax lambda-interface
+      (lambda (expr rename compare)
+	(let ((%lambda (rename 'lambda))
+	      (interface-name (cadr expr))
+	      (body (cddr expr)))
+	  `(,%lambda ,(interface-value-names interface-name) ,@body))))
+
+    (define-syntax with-names-from-rt-structure
+      (lambda (expr rename compare)
+	(let ((%lambda (rename 'lambda))
+	      (%let (rename 'let))
+	      (%rt-structure-value (rename 'rt-structure-value))
+	      (%rt-structure-binding (rename 'rt-structure-binding))
+	      (rt-structure (cadr expr))
+	      (interface-name (caddr expr))
+	      (body (cdddr expr)))
+ 	  (let ((ivn (interface-value-names interface-name)))
+	    `(,%let ((,%rt-structure-value ,rt-structure))
+	       ((,%lambda ,ivn ,@body)
+		,@(map (lambda (name)
+			 `(,%rt-structure-binding ,%rt-structure-value ',name))
+		       ivn)))))))))
+
+(define-structure rt-modules-core rt-modules-core-interface
+  (open scheme
+	meta-types ; syntax-type
+	interfaces ; for-each-declaration
+	define-record-types
+	records
+	signals
+	bindings
+	packages
+	packages-internal
+	locations
+	environments
+	ensures-loaded
+	package-commands-internal)
+  (files rt-module))
diff --git a/s48/module-system/rt-module.scm b/s48/module-system/rt-module.scm
new file mode 100644
index 0000000..bd9f4e0
--- /dev/null
+++ b/s48/module-system/rt-module.scm
@@ -0,0 +1,49 @@
+;;; This file is part of the Scheme Untergrund Library.
+
+;;; Copyright (c) 2002-2003 by Martin Gasbichler.
+;;; For copyright information, see the file COPYING which comes with
+;;; the distribution.
+
+(define (interface-value-names interface-name)
+  (let ((interface (environment-ref (config-package) interface-name))
+	(value-names '()))
+    (for-each-declaration
+     (lambda (name base-neme type)
+       (if (not (equal? type syntax-type))
+	   (set! value-names (cons name value-names))))
+     interface)
+    value-names))
+
+(define-record-type rt-structure :rt-structure
+  (make-rt-structure meta-structure)
+  rt-structure?
+  (meta-structure rt-structure-meta-structure))
+
+(define (rt-structure-loaded? rt-structure)
+  (package-loaded? 
+   (structure-package (rt-structure-meta-structure rt-structure))))
+
+(define-record-discloser :rt-structure
+  (lambda (s)
+    (list 'rt-stucture (structure-name (rt-structure-meta-structure s)))))
+
+(define (reify-structure name)
+  (let ((struct (get-structure name)))
+    (make-rt-structure struct)))
+
+(define (load-structure rts)
+  (ensure-loaded (rt-structure-meta-structure rts)))
+
+(define (rt-structure-binding structure name)
+  (if (not (rt-structure-loaded? structure))
+      (error "Structure not loaded" structure))
+  (contents
+   (binding-place
+    (generic-lookup (rt-structure-meta-structure structure)
+		    name))))
+
+(define (load-config-file file)
+  (load file (config-package)))
+
+
+