1; libctl: flexible Guile-based control files for scientific software 2; Copyright (C) 1998-2020 Massachusetts Institute of Technology and Steven G. Johnson 3; 4; This library is free software; you can redistribute it and/or 5; modify it under the terms of the GNU Lesser General Public 6; License as published by the Free Software Foundation; either 7; version 2 of the License, or (at your option) any later version. 8; 9; This library is distributed in the hope that it will be useful, 10; but WITHOUT ANY WARRANTY; without even the implied warranty of 11; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 12; Lesser General Public License for more details. 13; 14; You should have received a copy of the GNU Lesser General Public 15; License along with this library; if not, write to the 16; Free Software Foundation, Inc., 59 Temple Place - Suite 330, 17; Boston, MA 02111-1307, USA. 18; 19; Steven G. Johnson can be contacted at stevenj@alum.mit.edu. 20 21; **************************************************************** 22; define-param: defining local variables that can be set easily 23; from the command-line (or assume a default value if not set). 24 25(define params-set-list '()) 26(defmacro-public define-param (name value) 27 `(define ,name (if (defined? (quote ,name)) ,name ,value))) 28 29(defmacro-public set-param! (name value) 30 `(if (not (memq (quote ,name) params-set-list)) 31 (set! ,name ,value))) 32 33; **************************************************************** 34; Input/Output variables. 35 36(define input-var-list '()) 37(define output-var-list '()) 38 39(define (make-var value-thunk var-name var-type-name var-constraints) 40 (list var-name var-type-name var-constraints value-thunk)) 41(define (var-name var) (first var)) 42(define (var-type-name var) (second var)) 43(define (var-constraints var) (third var)) 44(define (var-value-thunk var) (fourth var)) 45(define (var-value var) ((var-value-thunk var))) 46 47(define (input-var! value-thunk var-name var-type-name . var-constraints) 48 (let ((new-var (make-var value-thunk var-name 49 var-type-name var-constraints))) 50 (set! input-var-list (cons new-var input-var-list)) 51 new-var)) 52(define (output-var! value-thunk var-name var-type-name) 53 (let ((new-var (make-var value-thunk var-name 54 var-type-name no-constraints))) 55 (set! output-var-list (cons new-var output-var-list)) 56 new-var)) 57 58(defmacro-public define-input-var 59 (name init-val var-type-name . var-constraints) 60 `(begin 61 (define-param ,name ,init-val) 62 (input-var! (lambda () ,name) (quote ,name) 63 ,var-type-name ,@var-constraints))) 64 65(defmacro-public define-input-output-var 66 (name init-val var-type-name . var-constraints) 67 `(begin 68 (define ,name ,init-val) 69 (input-var! (lambda () ,name) (quote ,name) 70 ,var-type-name ,@var-constraints) 71 (output-var! (lambda () ,name) (quote ,name) ,var-type-name))) 72 73(defmacro-public define-output-var (name var-type-name) 74 `(begin 75 (define ,name 'no-value) 76 (output-var! (lambda () ,name) (quote ,name) ,var-type-name))) 77 78(define (check-vars var-list) 79 (for-all? var-list 80 (lambda (v) 81 (if (not (check-type (var-type-name v) (var-value v))) 82 (error "wrong type for variable" (var-name v) 'type 83 (var-type-name v)) 84 (if (not (check-constraints 85 (var-constraints v) (var-value v))) 86 (error "failed constraint for" (var-name v)) 87 true))))) 88 89; **************************************************************** 90