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