Moved from rt-modules/
This commit is contained in:
parent
6355844d16
commit
756c0c15ae
|
@ -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))
|
|
@ -1,7 +1,46 @@
|
||||||
(define-structure overlapping-imports? (export)
|
(define-structure rt-modules rt-modules-interface
|
||||||
|
|
||||||
(open scheme
|
(open scheme
|
||||||
optimizer
|
rt-modules-core)
|
||||||
signals
|
(for-syntax (open scheme
|
||||||
general-tables
|
rt-modules-core))
|
||||||
packages-internal)
|
|
||||||
(files overlapping-imports))
|
(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))
|
||||||
|
|
|
@ -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)))
|
||||||
|
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue