Files moved into module-system/
This commit is contained in:
		
							parent
							
								
									5b4575d4ad
								
							
						
					
					
						commit
						6355844d16
					
				| 
						 | 
				
			
			@ -1,15 +0,0 @@
 | 
			
		|||
(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))
 | 
			
		||||
| 
						 | 
				
			
			@ -1,46 +0,0 @@
 | 
			
		|||
(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))
 | 
			
		||||
| 
						 | 
				
			
			@ -1,49 +0,0 @@
 | 
			
		|||
;;; 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)))
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
	  
 | 
			
		||||
		Loading…
	
		Reference in New Issue