sunet/scheme/httpd/surflets/rt-module.scm

59 lines
1.6 KiB
Scheme

;; rt-module.scm
;; Copyright Martin Gasbichler, 2002
;; Receipt:
;;(load-config-file "test.scm") --> nothing
;; load config file containing structure definition
;;
;; (reify-structure 'servlet) --> #{Rt-stucture servlet}
;; gets structure info about a structure
;;
;; (define servlet ##)
;; (load-structure servlet)
;; loads rt-structure
;;
;; (rt-structure-binding servlet 'main) --> value
;; get a binding of a structure
(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)))