initial version of rt-modules

s48/rt-modules/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))

s48/rt-modules/packages.scm

@@ -0,0 +1,46 @@
+(define-structure rt-modules rt-modules-interface
+
+  (open scheme
+	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))

s48/rt-modules/rt-module.scm

@@ -0,0 +1,56 @@
+(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)))
+
+;(define-structure t (export b)
+;  (open scheme
+;	signals
+;	define-record-types
+;	primitives)
+;  (begin
+;    (define-record-type bar :bar
+;      (make-bar i)
+;      bar?
+;      (i bar-i))
+;    (define a-bar (make-bar "kjk"))
+;    (add-finalizer! :bar (lambda (a-bar) (warn "finalized a bar")))))
+
+      
+