source: project/release/3/ode/trunk/ode.scm @ 10819

Last change on this file since 10819 was 10819, checked in by Ivan Raikov, 12 years ago

Fixed license text.

File size: 40.3 KB
Line 
1;;
2;;
3;; Numerical solution of the initial value problem for a system of
4;; first-order differential equations.
5;;
6;; Copyright 2007 Ivan Raikov and the Okinawa Institute of Science and Technology
7;;
8;; This program is free software: you can redistribute it and/or
9;; modify it under the terms of the GNU General Public License as
10;; published by the Free Software Foundation, either version 3 of the
11;; License, or (at your option) any later version.
12;;
13;; This program is distributed in the hope that it will be useful, but
14;; WITHOUT ANY WARRANTY; without even the implied warranty of
15;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
16;; General Public License for more details.
17;;
18;; A full copy of the GPL license can be found at
19;; <http://www.gnu.org/licenses/>.
20;;
21
22(require-extension srfi-1)
23(require-extension srfi-4)
24(require-extension srfi-13)
25(require-extension srfi-14)
26(require-extension srfi-40)
27(require-extension datatype)
28(require-extension vector-lib)
29(require-extension environments)
30(require-extension digraph)
31(require-extension graph-bfs)
32(require-extension graph-cycles)
33(require-extension mathh)
34(require-extension lolevel)
35
36(include "mathh-constants")
37
38(define-extension ode)
39
40(declare (export make-ode ode:error ode:warning ode:numerror 
41                 ode:env-copy ode-intern ode:quantity?
42                 make-rhs-procedure rhs-procedure?
43                 rhs-procedure-vars rhs-procedure-proc
44                 eval-ode-system-decls
45                 STATE ASGN VASGN CONST PRIM))
46
47;--------------------
48;  Message routines
49;
50;
51
52(define (ode:warning x . rest)
53  (let loop ((port (open-output-string)) (objs (cons x rest)))
54    (if (null? objs)
55        (begin
56          (newline port)
57          (print-error-message (get-output-string port) 
58                               (current-error-port) "ode warning"))
59        (begin (display (car objs) port)
60               (display " " port)
61               (loop port (cdr objs))))))
62
63(define (ode:error x . rest)
64  (let ((port (open-output-string)))
65    (if (port? x)
66        (begin
67          (display "[" port)
68          (display (port-name x) port)
69          (display "] " port)))
70    (let loop ((objs (if (port? x) rest (cons x rest))))
71      (if (null? objs)
72          (begin
73            (newline port)
74            (error 'ode (get-output-string port)))
75          (let ((obj (car objs)))
76            (if (procedure? obj) 
77                (with-output-to-port port obj)
78                (begin
79                  (display obj port)
80                  (display " " port)))
81            (loop (cdr objs)))))))
82
83(define-record errinfo absmax absname relmax relname)
84
85(define-record rhs-procedure vars proc)
86
87(define (rhs? x)
88  (or (symbol? x) (number? x)
89      (list? x) (rhs-procedure? x) #t))
90
91
92(define-datatype ode:quantity ode:quantity?
93  (SYSNAME  (name symbol?))
94  (INDEP    (name symbol?) (value number?))
95  (TIMESTEP (name symbol?) (value number?))
96  (ASGN     (name symbol?) (value number?)
97            (rhs rhs?) (abserr number?)
98            (relerr number?))
99  (VASGN    (name symbol?) 
100            (value (lambda (x) (or (f32vector? x) (f64vector? x))))
101            (rhs rhs?))
102  (CONST    (name symbol?) (value number?))
103  (STATE    (name symbol?) (initial number?)
104            (value number?) (df symbol?) (rhs rhs?) 
105            (abserr number?) (relerr number?)
106            (deriv number?))
107  (PRIM     (name symbol?) (value identity))
108  (GUARDS   (value list?))
109  (ODECORE  (value procedure?))
110  (PRTLIST  (items list?) (every (lambda (x) (or (not x) (fixnum? x))))
111            (from (lambda (x) (or (not x) (fixnum? x)))))
112  (HOOKLIST (items list?) (every (lambda (x) (or (not x) (fixnum? x))))
113            (from (lambda (x) (or (not x) (fixnum? x))))))
114 
115
116(define (ode-intern sym)
117  (string->symbol (string-append "#" (symbol->string sym))))
118
119(define (numerror-exn x) (make-property-condition 'numerror 'message x))
120
121(define (ode:numerror message . rest)
122  (let ((port (open-output-string)))
123    (display message port)
124    (display " " port)
125    (let loop ((objs rest))
126      (if (null? objs)
127          (begin
128            (newline port)
129            (signal (numerror-exn (get-output-string port))))
130          (begin (display (car objs) port)
131                 (display " " port)
132                 (loop (cdr objs)))))))
133
134
135(define (make-ode . alst)
136
137  (define (lookup-def k lst . rest)
138    (let-optionals rest ((default #f))
139      (let ((v (alist-ref k lst)))
140        (if v (first v) default))))
141
142  ;; minimum step size
143  (define  hmin (lookup-def 'hmin alst 1e-16))
144
145  ;; maximum step size
146  (define  hmax (lookup-def 'hmax alst 1.0))
147
148  ;; error tolerance
149  (define  relmin  (lookup-def 'relmin alst 1e-11))
150  (define  relmax  (lookup-def 'relmax alst 1e-8))
151  (define  absmin  (lookup-def 'absmin alst 1e-36))
152  (define  absmax  (lookup-def 'absmax alst 1e-8))
153
154  ;; floating point precision (single or double; default is double)
155  (define  fptype (lookup-def 'fpprec alst 'double))
156  (define  fpvector-type
157    (lookup-def 'fpvector-type alst (if (equal? fptype 'single) 'f32vector 'f64vector)))
158  (define  fpvector? 
159    (lookup-def 'fpvector? alst (if (equal? fptype 'single) f32vector? f64vector?)))
160  (define  fpvector 
161    (lookup-def 'fpvector alst (if (equal? fptype 'single) f32vector f64vector)))
162  (define  fpvector-ref
163    (lookup-def 'fpvector-ref alst (if (equal? fptype 'single) f32vector-ref f64vector-ref)))
164  (define  fpvector-set!
165    (lookup-def 'fpvector-set! alst (if (equal? fptype 'single) f32vector-set! f64vector-set!)))
166
167  ;; maximum and minimum ratios by which to increase to decrease the
168  ;; step size
169  (define  hmax-factor    2)
170  (define  hmin-factor    0.5)
171  (define  hscale-factor  0.9)
172
173  (define svec-value-idx     0)
174  (define svec-abserr-idx    1)
175  (define svec-relerr-idx    2)
176  (define svec-deriv-idx     3)
177
178
179  (define (add-primitives! env)
180    (for-each (lambda (n b fms rt) 
181                (let ((fb (extend-procedure b `((rt ,rt) (formals ,fms)))))
182                  (environment-extend! env n fb)))
183              `(+ - * / pow neg
184                  abs atan asin acos sin cos exp ln sqrt tan 
185                  cosh sinh tanh hypot gamma lgamma log10 log2 log1p ldexp
186                  cube > < <= >= = and or
187                  round ceiling floor max min
188                  fpvector-ref)
189              (list fp+ fp- fp* fp/ expt fpneg
190                    abs atan asin acos sin cos exp log sqrt tan 
191                    cosh sinh tanh hypot gamma lgamma log10 log2 log1p ldexp
192                    (lambda (x) (* x x x))
193                    fp> fp< fp<= fp>= fp=
194                    (lambda (x y) (and x y)) (lambda (x y) (or x y)) 
195                    round ceiling floor fpmax fpmin
196                    fpvector-ref)
197              `((,fptype ,fptype) (,fptype ,fptype) (,fptype ,fptype) (,fptype ,fptype) 
198                (,fptype ,fptype) (,fptype)
199                (,fptype) (,fptype) (,fptype) (,fptype) (,fptype) (,fptype) (,fptype)
200                (,fptype) (,fptype) (,fptype)
201                (,fptype) (,fptype) (,fptype) (,fptype) (,fptype) (,fptype) (,fptype)
202                (,fptype) (,fptype) (,fptype)
203                (,fptype) 
204                (bool bool) (bool bool) (bool bool) (bool bool) (bool bool) (bool bool) (bool bool) 
205                (,fptype) (,fptype) (,fptype) (,fptype ,fptype) (,fptype ,fptype) 
206                (,fpvector-type integer) )
207              `(,fptype ,fptype ,fptype ,fptype 
208                ,fptype ,fptype
209                ,fptype ,fptype ,fptype ,fptype ,fptype ,fptype ,fptype
210                ,fptype ,fptype ,fptype
211                ,fptype ,fptype ,fptype ,fptype ,fptype ,fptype ,fptype
212                ,fptype ,fptype ,fptype
213                ,fptype 
214                bool bool bool bool bool bool bool 
215                ,fptype ,fptype ,fptype ,fptype ,fptype 
216                ,fptype )
217              ))
218
219  (define (add-constants! env)
220    (for-each (lambda (n b) (environment-extend! env n b))
221              `(E 1/E E^2 E^PI/4 LOG2E LOG10E LN2 LN3 LNPI LN10 1/LN2 1/LN10 PI PI/2
222                  PI/4 1/PI 2/PI 2/SQRTPI SQRTPI PI^2 DEGREE SQRT2 1/SQRT2 SQRT3 SQRT5
223                  SQRT10 CUBERT2 CUBERT3 4THRT2 GAMMA1/2 GAMMA1/3 GAMMA2/3 PHI LNPHI
224                  1/LNPHI EULER E^EULER SIN1 COS1 ZETA3)
225              (list E 1/E E^2 E^PI/4 LOG2E LOG10E LN2 LN3 LNPI LN10 1/LN2 1/LN10 PI PI/2
226                 PI/4 1/PI 2/PI 2/SQRTPI SQRTPI PI^2 DEGREE SQRT2 1/SQRT2 SQRT3 SQRT5
227                 SQRT10 CUBERT2 CUBERT3 4THRT2 GAMMA1/2 GAMMA1/3 GAMMA2/3 PHI LNPHI
228                 1/LNPHI EULER E^EULER SIN1 COS1 ZETA3)))
229
230
231  (define (enumdeps expr ax)
232    (if (rhs-procedure? expr) (rhs-procedure-vars expr)
233        (match expr 
234               ((s . es)           (if (symbol? s) (fold enumdeps ax es) ax))
235               (id                 (if (symbol? id) (cons id ax) ax)))))
236
237
238  (define (binop-fold op lst)
239    (if (null? lst) lst
240        (match lst
241               ((x)   x)
242               ((x y) `(,op ,x ,y))
243               ((x y . rest) `(,op (,op ,x ,y) ,(binop-fold op rest)))
244               ((x . rest) `(,op ,x ,(binop-fold op rest))))))
245
246  ;; if argument is constant, return the negative of that constant,
247  ;; otherwise return `(neg ,expr)
248  (define (negate expr)
249    (if (number? expr) (- expr)
250        `(neg ,expr)))
251
252  ;; 1. make sure all constants in an expression are flonums
253  ;; 2. fold expressions like (+ a b c d) into nested binops
254  (define (normalize-expr expr)
255    (match expr 
256           (('+ . es)           (binop-fold '+ (map normalize-expr es)))
257           (('- . es)           (let ((es1 (map normalize-expr es)))
258                                  (binop-fold '+ (cons (car es1) (map negate (cdr es1))))))
259           (('* . es)           (binop-fold '* (map normalize-expr es)))
260           (('/ . es)           (binop-fold '/ (map normalize-expr es)))
261           (('fix n)            n)
262           ((s . es)            (cons s (map normalize-expr es)))
263           (x                   (if (number? x) (exact->inexact x) x))))
264
265  (define (make-base-env)
266    (let ((env (make-environment #t)))
267      (add-primitives! env)
268      (add-constants! env)
269      env))
270   
271  (define (make-const-env ode-env)
272    (let ((env (make-base-env)))
273      (environment-for-each ode-env
274        (lambda (sym en)
275          (cond  ((ode:quantity? en) 
276                  (cases ode:quantity en
277                         (CONST (name value) 
278                                (environment-extend! env name value))
279                         (PRIM (name value) 
280                               (environment-extend! env name value))))
281                 ((procedure? en)
282                  (environment-extend! env sym en)))))
283        env))
284
285  (define (system name)
286    (let ((env  (make-base-env))
287          (name (if (symbol? name) name (string->symbol name))))
288      (environment-extend! env (ode-intern 'odecore)   (ODECORE odecore))
289      (environment-extend! env (ode-intern 'guards)    (GUARDS (list)))
290      (environment-extend! env (ode-intern 'name)      (SYSNAME name))
291      (environment-extend! env (ode-intern 'indep)     (INDEP 't 0.0))
292      (environment-extend! env (ode-intern 'timestep)  (TIMESTEP 'dt 0.0))
293      (environment-extend! env (ode-intern 'prtlist)   (PRTLIST (list) #f #f))
294      env))
295
296  (define (env-extend! ode-env)
297    (lambda (name type initial . rest)
298      (let-optionals  rest ((rhs #f))
299       (let ((sym (if (symbol? name) name (string->symbol name))))
300        (if (environment-has-binding? ode-env sym)
301            (ode:error 'env-extend! ": quantity " sym " already defined")
302            (match type
303              (('prim)    (let ((val (if (and rhs (procedure? initial) )
304                                         (extend-procedure initial rhs)
305                                         initial)))
306                            (environment-extend! ode-env sym (PRIM name val ))))
307              (('const)   (begin
308                             (if (not (number? initial)) 
309                                 (ode:error 'env-extend! ": constant definitions require numeric value"))
310                             (environment-extend! ode-env sym (CONST name initial))))
311              (('state)   (begin
312                             (if (not (number? initial)) 
313                                 (ode:error 'env-extend! ": definition for state " sym
314                                            " requires a numeric initial value (" initial  " was given)"))
315                             (environment-extend! ode-env sym (STATE name initial initial 'd
316                                                                     0.0 0.0 0.0 0.0))))
317              (('asgn)    (begin
318                             (if (not (eq? initial 'none))
319                                 (ode:error 'env-extend! 
320                                            ": state function definitions must have initial value of '(none)"))
321                             (if (not rhs) 
322                                 (ode:error 'env-extend! ": state function definitions require an equation"))
323                             (environment-extend! ode-env sym (ASGN name 0.0 (normalize-expr rhs) 0.0 0.0))))
324              (('vasgn dim)
325               (begin
326                 (if (not (eq? initial 'none))
327                     (ode:error 'env-extend! 
328                                ": state function definitions must have initial value of '(none)"))
329                 (if (not rhs) 
330                     (ode:error 'env-extend! ": state function definitions require an equation"))
331                 (if (not (and (integer? dim) (positive? dim)))
332                     (ode:error 'env-extend! ": vector state function definitions require a positive integer dimension"))
333                 (environment-extend! ode-env sym (VASGN name (fpvector dim 0.0) (normalize-expr rhs)))))
334              (else       (begin
335                            (environment-extend! ode-env sym `(,type (name ,sym) . ,initial))))))))))
336
337  (define (infer ode-env ftenv formals body)
338    (let recur ((expr body))
339      (match expr 
340             (('if c t e)
341              (let ((ct (recur c))
342                    (tt (recur t))
343                    (et (recur e)))
344                (and ct tt et 
345                     (begin
346                       (if (not (equal? ct 'bool)) 
347                           (ode:error 'infer "if condition type must be boolean"))
348                       (if (equal? tt et) tt
349                           (ode:error 'infer "type mismatch in if statement: then = " tt
350                                      " else = " et))))))
351             
352             ((s . es)   
353              (let* ((f    (environment-ref ode-env s))
354                     (lst  (procedure-data f)))
355                (and lst 
356                     (let ((rt   (lookup-def 'rt lst))
357                           (fms  (lookup-def 'formals lst)))
358                       (and rt fms
359                            (begin
360                              (for-each (lambda (x ft)
361                                          (if (and (symbol? x) (not (environment-includes? ftenv x)))
362                                              (environment-extend! ftenv x ft)))
363                                        es fms)
364                              (let ((ets (map recur es)))
365                                (and (every identity ets)
366                                     (every (lambda (xt ft) (equal? xt ft)) ets fms)
367                                     rt))))))))
368             
369             (id    (cond ((symbol? id)     (environment-ref ftenv id))
370                          ((number? id)     fptype)
371                          ((boolean? id)    'bool)
372                          ((fpvector? id)   'fpvector-type)
373                          (else #f))))))
374   
375
376  (define (defun! ode-env)
377    (lambda (name formals body)
378        (let ((const-env (make-const-env ode-env))
379              (sym (if (symbol? name) name (string->symbol name))))
380          (letrec ((enumconsts
381                    (lambda (expr ax)
382                      (match expr 
383                             (('if . es)  (fold enumconsts ax es))
384                             ((s . es)    (if (symbol? s)  (cons s (fold enumconsts ax es)) ax))
385                             (s           (if (and (symbol? s) (environment-includes? const-env s))
386                                              (cons s ax) ax))))))
387            (if (environment-has-binding? ode-env sym)
388                (ode:error 'defun! ": quantity " sym " already defined")
389                (let* ((body    (normalize-expr body))
390                       (consts  (delete-duplicates (enumconsts body (list))))
391                       (fc     `(lambda (const-env)
392                                  (let ,(map (lambda (v) `(,v (environment-ref const-env ',v))) consts)
393                                    (lambda ,formals ,body))))
394                       (f      ((eval fc) const-env)))
395                 
396                  (let* ((ftenv  (make-environment))
397                         (rt     (infer ode-env ftenv formals body))
398                         (ftypes (filter-map (lambda (x) (and (environment-includes? ftenv x)
399                                                              (environment-ref ftenv x))) 
400                                             formals))
401                         (ef     (extend-procedure f `((rt ,rt) (formals ,ftypes) (vars ,formals)
402                                                       (body ,body) (consts ,consts)))))
403                  (environment-extend! ode-env sym ef))))))))
404
405  (define (add-guard! ode-env)
406    (lambda (expr)
407      (let ((sym   (ode-intern 'guards))
408            (deps  (enumdeps expr (list))))
409        (let loop ((deps deps))
410          (if (not (null? deps))
411              (let ((sym (car deps)))
412                (if (not (environment-has-binding? ode-env sym))
413                    (ode:error 'add-guard! "undefined symbol in guard expression: " sym)
414                    (loop (cdr deps))))))
415        (let ((x (environment-ref ode-env sym)))
416          (cases ode:quantity x
417                 (GUARDS (value) (environment-set! ode-env sym (GUARDS (cons (normalize-expr expr) value))))
418                 (else  (ode:error 'add-guards! ": invalid guards entry " x)))))))
419                                                               
420                         
421  (define (set-indep! ode-env)
422    (lambda (name)
423      (let ((sym (if (symbol? name) name (string->symbol name))))
424        (if (environment-has-binding? ode-env sym)
425            (ode:error 'set-indep! ": quantity " sym " already defined")
426            (begin
427              (environment-remove! ode-env (ode-intern 'indep))
428              (environment-extend! ode-env (ode-intern 'indep) (INDEP name 0.0)))))))
429 
430  (define (set-timestep! ode-env)
431    (lambda (name)
432      (let ((sym (if (symbol? name) name (string->symbol name))))
433        (if (environment-has-binding? ode-env sym)
434            (ode:error 'set-timestep! ": quantity " sym " already defined")
435            (begin
436              (environment-remove! ode-env (ode-intern 'timestep))
437              (environment-extend! ode-env (ode-intern 'timestep) (TIMESTEP name 0.0)))))))
438 
439 
440  (define (eqdef! ode-env)
441    (lambda (name rhs . rest)
442      (let-optionals rest ((df 'd))
443        (let ((sym (if (symbol? name) name (string->symbol name))))
444          (if (not (environment-has-binding? ode-env sym))
445              (ode:error 'eqdef! ": quantity " sym " is not defined")
446              (let ((x (environment-ref ode-env sym)))
447                (cases ode:quantity x
448                       (STATE (name initial value rhs1 abserr relerr deriv)
449                              (environment-set! ode-env sym (STATE name initial initial df (normalize-expr rhs)
450                                                                   0.0 0.0 0.0)))
451                       (else
452                        (ode:error 'eqdef! ": cannot define a differential/difference equation for non-state quantity " 
453                                   sym)))))))))
454 
455 
456  (define (exam ode-env)
457    (lambda (name)
458      (let ((sym (if (symbol? name) name (string->symbol name)))
459            (out (current-output-port)))
460        (if (not (environment-has-binding? ode-env sym))
461            (ode:error 'exam ": quantity " sym " is not defined")
462            (let ((x (environment-ref ode-env sym)))
463              (cases ode:quantity x
464                     (PRIM  (name value)
465                            (begin
466                              (fprintf out "~a: compiled code primitive\n" name)
467                              (fprintf out "    value: ~a\n" value)))
468
469                     (STATE (name initial value df rhs abserr relerr deriv)
470                            (begin
471                              (fprintf out "~a: dynamic state\n" name)
472                              (fprintf out "    initial value: ~a\n" initial)
473                              (fprintf out "    value: ~a\n" value)
474                              (fprintf out "    absolute error: ~a\n" abserr)
475                              (fprintf out "    relative error: ~a\n" relerr)))
476                     
477                     (INDEP    (name value)
478                               (begin
479                                 (fprintf out "~a: independent variable\n" name)
480                                 (fprintf out "    value: ~a\n" value)))
481
482                     (TIMESTEP (name value)
483                               (begin
484                                 (fprintf out "~a: time step\n" name)
485                                 (fprintf out "    value: ~a\n" value)))
486                     
487                     (CONST    (name value)
488                               (begin
489                                 (fprintf out "~a: constant\n" name)
490                                 (fprintf out "    value: ~a\n" value)))
491                     
492                     (ASGN     (name value rhs abserr relerr)
493                               (begin
494                                 (fprintf out "~a: state function\n" name)
495                                 (fprintf out "    value: ~a\n" value)
496                                 (fprintf out "    absolute error: ~a\n" abserr)
497                                 (fprintf out "    relative error: ~a\n" relerr)))
498
499                     (VASGN    (name value rhs)
500                               (begin
501                                 (fprintf out "~a: vector state function\n" name)
502                                 (fprintf out "    value: ~a\n" value)))
503                     
504                     (else (ode:error 'exam name ": unknown type of quantity"))))))))
505 
506  (define (set-print! ode-env)
507    (lambda (prtlist . rest)
508      (let-optionals  rest ((every #f) (from #f))
509        (environment-set! ode-env (ode-intern 'prtlist) 
510                          (PRTLIST prtlist 
511                                   (if every (inexact->exact every) every) 
512                                   (if from (inexact->exact from) from))))))
513 
514  (define (set-hook! ode-env)
515    (lambda (cmdlist . rest)
516      (let-optionals  rest ((every #f) (from #f))
517                      (environment-set! ode-env (ode-intern 'cmdlist) (HOOKLIST cmdlist every from)))))
518
519  (define (eval-const ode-env expr)
520    (exact->inexact (eval (normalize-expr expr) (make-const-env ode-env))))
521
522  (define (isdep? x)
523    (cond ((ode:quantity? x)
524           (cases ode:quantity x
525                  (ASGN  (name value rhs abserr relerr)  #t)
526                  (VASGN (name value rhs)  #t)
527                  (else #f)))
528          ((list? x)
529           (begin
530             (alist-ref 'dep?  (cdr x))))
531          (else #f)))
532       
533
534  (define (isstate? x)
535    (and (ode:quantity? x)
536         (cases ode:quantity x
537                (STATE (name initial value df rhs abserr relerr deriv)  #t)
538                (else #f))))
539
540  (define (qrhs x)
541    (and (ode:quantity? x)
542         (cases ode:quantity x
543                (STATE (name initial value df rhs abserr relerr deriv)  rhs)
544                (ASGN  (name value rhs abserr relerr)  rhs)
545                (VASGN (name value rhs)  rhs)
546                (else #f))))
547           
548  (define (sysname ode-env)
549    (cases ode:quantity (environment-ref ode-env (ode-intern 'name))
550           (SYSNAME (name)  name)))
551
552  ;; create equation dependency graph
553  (define (make-eqng ode-env)
554    (let* ((sysname    (sysname ode-env))
555           (g          (make-digraph sysname (string-append (symbol->string sysname) 
556                                                            " equation dependency graph")))
557           (add-node!  (g 'add-node!))
558           (add-edge!  (g 'add-edge!))
559           (indep      (environment-ref ode-env (ode-intern 'indep)))
560           (timestep   (environment-ref ode-env (ode-intern 'timestep)))
561           (indep-sym  (cases ode:quantity indep
562                              (INDEP    (name value)  name)
563                              (else  (ode:error 'make-eqng ": invalid independent variable " indep))))
564           (timestep-sym (cases ode:quantity timestep
565                              (TIMESTEP    (name value)  name)
566                              (else  (ode:error 'make-eqng ": invalid timestep variable " timestep))))
567           (node-list  (filter (lambda (sym) (let ((x (environment-ref ode-env sym)))
568                                               (or (isstate? x) (isdep? x))))
569                               (environment-symbols ode-env)))
570           (node-ids      (list-tabulate (length node-list) identity))
571           (name->id-map  (zip node-list node-ids)))
572      (let-values (((state-list asgn-list) 
573                    (partition (lambda (sym) (isstate? (environment-ref ode-env sym)))
574                               node-list)))
575                 
576         ;; insert equation nodes in the dependency graph
577         (for-each (lambda (i n) (add-node! i n)) node-ids node-list)
578         ;; create dependency edges in the graph
579         (for-each (lambda (e) 
580                     (match e ((ni . nj) (begin
581                                           (let ((i (car (alist-ref ni name->id-map)))
582                                                 (j (car (alist-ref nj name->id-map))))
583                                             (add-edge! (list i j (format "~A=>~A" ni nj))))))
584                            (else (ode:error 'make-eqng ": invalid edge " e))))
585                   (fold (lambda (qsym ax) 
586                           (let* ((q   (environment-ref ode-env qsym))
587                                  (rhs (qrhs q)))
588                             (if rhs 
589                                 (let* ((deps (filter (if (isstate? q)
590                                                          (lambda (sym) 
591                                                            (and (not (or (eq? sym indep-sym) 
592                                                                          (eq? sym timestep-sym)))
593                                                                 (let ((x (environment-ref ode-env sym)))
594                                                                   (and (isdep? x) (not (eq? sym qsym))))))
595                                                          (lambda (sym) 
596                                                            (and (not (or (eq? sym indep-sym) 
597                                                                          (eq? sym timestep-sym)))
598                                                                 (let ((x (environment-ref ode-env sym)))
599                                                                   (isdep? x)))))
600                                                      (enumdeps rhs (list))))
601                                          (edges (map (lambda (d) (cons d qsym)) deps)))
602                                   (if edges (append edges ax) ax))
603                                 ax)))
604                         (list) node-list))
605         (let ((cycles (graph-cycles-fold g (lambda (cycle ax) (cons cycle ax)) (list))))
606           (if (null? cycles) (list state-list asgn-list g)
607               (ode:error 'make-eqng ": equation cycle detected: " (car cycles)))))))
608
609
610  ;; given an graph, create a partial ordering based on BFS distance
611  ;; from root
612  (define (graph->bfs-dist-poset g)
613    (define node-info (g 'node-info))
614
615    (let-values (((dists dmax) (graph-bfs-dist g ((g 'roots)))))
616      (let loop ((poset  (make-vector (fx+ 1 dmax) (list)))
617                 (i      (fx- (s32vector-length dists) 1)))
618        (if (fx>= i 0)
619            (let* ((c     (s32vector-ref dists i))
620                   (info  (node-info i)))
621              (vector-set! poset c (cons (cons i info) (vector-ref poset c)))
622              (loop poset (fx- i 1)))
623            (begin
624              poset)))))
625
626  (define (make-eval-poset ode-env eqposet)
627    (vector-map 
628       (lambda (i lst) 
629         (filter-map (lambda (id+sym)
630                       (let* ((sym  (cdr id+sym))
631                              (x    (environment-ref ode-env sym)))
632                         (and (ode:quantity? x)
633                              (cases ode:quantity x
634                                     (STATE (name initial value df rhs abserr relerr deriv) 
635                                            (list df sym rhs))
636                                     (ASGN  (name value rhs abserr relerr)
637                                            (list 'a sym rhs))
638                                     (VASGN (name value rhs)
639                                            (list 'va sym rhs))
640                                     (else ode:error 'make-eval-poset ": invalid quantity in equation poset: " sym)))))
641                     lst))
642       eqposet))
643
644  (define (make-eval-env ode-env)
645    (let ((env (make-const-env ode-env)))
646      (environment-for-each ode-env
647          (lambda (sym en)
648            (cond ((ode:quantity? en) 
649                   (cases ode:quantity en
650                          (PRIM  (name value) 
651                                 (environment-set! env sym value))
652                          (STATE (name initial value df rhs abserr relerr deriv) 
653                                 (environment-set! env sym value))
654                          (ASGN  (name value rhs abserr relerr) 
655                                 (environment-set! env sym value))
656                          (VASGN (name value rhs) 
657                                 (environment-set! env sym value))
658                          (CONST (name value) 
659                                 (environment-set! env sym value))
660                          (INDEP (name value) 
661                                 (environment-set! env sym value))
662                          (TIMESTEP (name value) 
663                                    (environment-set! env sym value))
664                          (else (void))))
665                  (else (environment-set! env sym en)))))
666      env))
667
668  (define (make-solve-env ode-env indep state-list asgn-list)
669    (let* ((env (make-environment #t))
670           (eenv (lambda (lst) 
671                   (for-each
672                    (lambda (sym)
673                      (let ((x (environment-ref ode-env sym)))
674                        (cond ((ode:quantity? x) 
675                               (cases ode:quantity x
676                                      (STATE (name initial value df rhs abserr relerr deriv) 
677                                             (environment-set! env sym (fpvector value abserr relerr deriv)))
678                                      (ASGN  (name value rhs abserr relerr) 
679                                             (environment-set! env sym (fpvector value abserr relerr)))
680                                      (VASGN (name value rhs) 
681                                             (environment-set! env sym (list value)))
682                                      (else (void))))
683                              (else (void)))))
684                    lst))))
685      (eenv state-list)
686      (eenv asgn-list)
687      (environment-set! env indep (fpvector 0.0))
688      env))
689
690
691  (define (hierror? relmax absmax hmin)
692    (lambda (t tstep err)
693      (let ((relname (errinfo-relname err))
694            (absname (errinfo-absname err))
695            (erelmax (errinfo-relmax err))
696            (eabsmax (errinfo-absmax err)))
697        (if (= t (+ tstep t))
698            (ode:numerror "step size is smaller than machine precision: " "t = " t " tstep = " tstep)
699            (cond  ((and (<= erelmax relmax) (<= eabsmax absmax)) #f)
700                   ((<= (abs hmin) (abs tstep)) (max erelmax eabsmax))
701                   ((< relmax erelmax) 
702                    (ode:numerror "relative error limit exceeded while calculating " relname))
703                   ((< absmax eabsmax)
704                    (ode:numerror "absolute error limit exceeded while calculating " absname "; absmax = " absmax))
705                   (else #f))))))
706
707
708  (define (lowerror? relmin absmin hmax)
709    (lambda (t tstep err)
710      (let ((relname (errinfo-relname err))
711            (absname (errinfo-absname err))
712            (erelmax (errinfo-relmax err))
713            (eabsmax (errinfo-absmax err)))
714        (if (or (< erelmax (* 0.25 relmin)) (< eabsmax (* 0.25 absmin)))
715            (and (<= (abs tstep) (abs hmax)) (max erelmax eabsmax))
716            #f))))
717
718
719  (define (eval-expr env)
720    (lambda (expr)
721      (if (rhs-procedure? expr) 
722          (let* ((args (rhs-procedure-vars expr))
723                 (argv (map (lambda (x) (environment-ref env x)) args)))
724            (apply (rhs-procedure-proc expr) argv))
725          (let ((val (match expr
726                        (('if c t f) 
727                         (let ((ee (eval-expr env)))
728                           (condition-case
729                            (if (ee c) (ee t) (ee f))
730                            [var () 
731                               (ode:error 'eval-expr " exception in " expr ": \n"
732                                          (lambda () (print-error-message var)))])))
733
734                        ((s . es)   
735                         (condition-case 
736                          (let ((op   (environment-ref env s))
737                                (args (map (eval-expr env) es)))
738                            (apply op args))
739                          [var () 
740                               (ode:error 'eval-expr " exception in " expr ": \n"
741                                          (lambda () (print-error-message var)))]))
742                       
743                        (s                 
744                         (cond ((symbol? s) (environment-ref env s))
745                               ((number? s) s)
746                               (else (ode:error 'eval-expr "unknown expression " s)))))))
747            val))))
748
749
750  (define (depgraph ode-env)
751    (match-let (((state-list asgn-list g)  (make-eqng ode-env))) g))
752
753  (define (depgraph* ode-env)
754    (match-let (((state-list asgn-list g)  (make-eqng ode-env))) 
755               (list state-list asgn-list g)))
756
757
758  (define (step! ode-env)
759    (lambda (solver start stop . rest)
760      (let-optionals  rest ((initial-h 0.1) (debug #f))
761       (if (<= stop start)
762           (ode:error 'step! ": stop <= start")
763           (match-let (((state-list asgn-list g)  (make-eqng ode-env)))
764            (let* ((eqposet     (graph->bfs-dist-poset g))
765                   (eval-poset  (make-eval-poset ode-env eqposet))
766                   (eval-env    (make-eval-env ode-env))
767                   (eval-expr   (eval-expr eval-env))
768                   (order       (length state-list))
769                   (guards      (cases ode:quantity (environment-ref ode-env (ode-intern 'guards))
770                                       (GUARDS (value)  value)
771                                       (else  (ode:error 'step! ": invalid guards entry"))))
772                   (indep       (cases ode:quantity (environment-ref ode-env (ode-intern 'indep))
773                                       (INDEP (name value)  name)
774                                       (else  (ode:error 'step! ": invalid independent variable entry"))))
775                   (timestep    (cases ode:quantity (environment-ref ode-env (ode-intern 'timestep))
776                                       (TIMESTEP (name value)  name)
777                                       (else  (ode:error 'step! ": invalid timestep entry"))))
778                   (solve-env   (make-solve-env ode-env indep state-list asgn-list))
779                   (prt         (cases ode:quantity (environment-ref ode-env (ode-intern 'prtlist))
780                                       (PRTLIST  (items every from)  (list items every from))
781                                       (else  (ode:error 'step! ": invalid independent variable entry"))))
782                   (prti        0)
783                   (prtitems    (first prt))
784                   (prtevery    (second prt))
785                   (prtfrom     (third prt))
786                   
787                   (dispatch   
788                    (lambda (selector)
789                      (case selector
790                        ((order)              order)
791                        ((svec-value-idx)     svec-value-idx)
792                        ((svec-abserr-idx)    svec-abserr-idx)
793                        ((svec-relerr-idx)    svec-relerr-idx)
794                        ((svec-deriv-idx)     svec-deriv-idx)
795                        ((is-state?)
796                         (lambda (sym) (let ((x (environment-ref ode-env sym)))
797                                         (cond ((ode:quantity? x) 
798                                                (cases ode:quantity x
799                                                       (STATE (name initial value df rhs abserr relerr deriv)  #t)
800                                                       (else #f)))
801                                               (else #f)))))
802                        ((is-asgn?)
803                         (lambda (sym) (let ((x (environment-ref ode-env sym)))
804                                         (cond ((ode:quantity? x) 
805                                                (cases ode:quantity x
806                                                       (ASGN  (name value rhs abserr relerr) #t)
807                                                       (VASGN (name value rhs) #t)
808                                                       (else #f)))
809                                               (else #f)))))
810                           
811                        ((eval-poset-foreach)   
812                         (lambda (proc)  ;; proc order df sym rhs
813                           (vector-for-each  proc eval-poset)))
814                        ((eval-poset-fold)     
815                         (lambda (proc initial) ;; proc order df sym rhs ax
816                           (vector-fold proc initial eval-poset)))
817                        ((eval-env-ref)         
818                         (lambda (sym) (environment-ref eval-env sym)))
819                        ((eval-env-set!)       
820                         (lambda (sym val) (environment-set! eval-env sym val)))
821                        ((solve-env-ref)       
822                         (lambda (sym) (environment-ref solve-env sym)))
823                        ((solve-env-set!)       
824                         (lambda (sym i val) (fpvector-set! (environment-ref solve-env sym) i val)))
825                        ((solve-env-state-fold)
826                         (lambda (proc initial) ;; proc sym svec ax
827                           (fold (lambda (sym ax)
828                                   (let ((svec (environment-ref solve-env sym)))
829                                     (proc sym svec ax)))
830                                 initial
831                                 state-list)))
832                        ((solve-env-state-foreach)
833                         (lambda (proc) ;; proc sym svec
834                           (for-each (lambda (sym)
835                                   (let ((svec (environment-ref solve-env sym)))
836                                     (proc sym svec)))
837                                 state-list)))
838                        ((solve-env-asgn-fold)
839                         (lambda (proc initial) ;; proc sym svec ax
840                           (fold (lambda (sym ax)
841                                   (let ((svec (environment-ref solve-env sym)))
842                                     (proc sym svec ax)))
843                                 initial
844                                 asgn-list)))
845
846                        ((eval-rhs)       (lambda (n rhs . rest) (eval-expr rhs)))
847                        ((eval-guard)     eval-expr)
848
849                        ((hmax-factor)    hmax-factor)
850                        ((hmin-factor)    hmin-factor)
851                        ((hscale-factor)  hscale-factor)
852
853                        ((relmax)         relmax)
854                        ((relmin)         relmin)
855                        ((absmax)         absmax)
856                        ((absmin)         absmin)
857                       
858
859                        ((maxerror)
860                         (lambda ()
861                           (let ((erelmax 0.0) (eabsmax 0.0)
862                                 (relname #f)  (absname #f))
863                             (let ((proc (lambda (sym)
864                                           (let ((svec (environment-ref solve-env sym)))
865                                             (if (fpvector? svec)
866                                                 (let ((relerr (fpvector-ref svec svec-relerr-idx))
867                                                       (abserr (fpvector-ref svec svec-abserr-idx)))
868                                                   (if (< erelmax relerr)
869                                                       (begin
870                                                         (set! erelmax relerr)
871                                                         (set! relname sym)))
872                                                   (if (< eabsmax abserr)
873                                                       (begin
874                                                         (set! eabsmax abserr)
875                                                         (set! absname sym)))))))))
876                               (for-each proc state-list)
877                               (for-each proc asgn-list)
878                               (make-errinfo eabsmax absname erelmax relname )))))
879
880                        ((hierror?)  (hierror? relmax absmax hmin))
881                        ((lowerror?) (lowerror? relmin absmin hmax))
882
883                        ((print)     (lambda ()
884                                       (let ((out (current-output-port)))
885                                         (if (and (pair? prtitems) (or (not prtfrom) (fx>= prti prtfrom)))
886                                             (if (or (not prtevery) (zero? (fxmod prti prtevery)))
887                                                 (begin
888                                                   (fprintf out "***")
889                                                   (for-each
890                                                    (lambda (prtitem)
891                                                      (match prtitem
892                                                             (( tag sym ) 
893                                                              (let ((svec (environment-ref solve-env sym)))
894                                                                (if (fpvector? svec)
895                                                                    (case tag
896                                                                      ((value) 
897                                                                       (fprintf out "~a " 
898                                                                                (fpvector-ref svec svec-value-idx)))
899                                                                      ((prime) 
900                                                                       (fprintf out "~a " 
901                                                                                (fpvector-ref svec svec-deriv-idx)))
902                                                                      ((abserr) 
903                                                                       (fprintf out "~a " 
904                                                                                (fpvector-ref svec svec-abserr-idx)))
905                                                                      ((relerr) 
906                                                                       (fprintf out "~a " sym 
907                                                                                (fpvector-ref svec svec-relerr-idx)))
908                                                                      (else (ode:error 'step! "invalid print item: " 
909                                                                                       prtitem)))
910                                                                    (case tag
911                                                                      ((value) 
912                                                                       (fprintf out "~a " (car svec)))
913                                                                      (else (ode:error 'step! "invalid print item: " 
914                                                                                       prtitem))))))))
915                                                    prtitems)
916                                                   (fprintf out "\n")
917                                                   (set! prti (if prtfrom (fx+ 1 prtfrom) 1)))
918                                                 (set! prti (fx+ 1 prti)))))))
919
920                        ((debug)      (list (cons 'eval-poset (vector->list eval-poset))
921                                            (let* ((ss (environment-symbols eval-env))
922                                                   (vv (map (lambda (x) (environment-ref eval-env x)) ss)))
923                                              (cons 'eval-env (zip ss vv)))
924                                            (let* ((ss (environment-symbols solve-env))
925                                                   (vv (map (lambda (x) (environment-ref solve-env x)) ss)))
926                                              (cons 'solve-env (zip ss vv)))))
927                        (else
928                         (ode:error 'step! ": unknown message " selector " sent to an ode runtime object"))))))
929
930              (condition-case (solver dispatch indep start stop timestep initial-h guards debug)
931                              [exn (numerror) 
932                                   (ode:warning ((condition-property-accessor 'numerror 'message) exn))])))))))
933
934  ;; Dispatcher
935  (define (odecore selector)
936    (case selector
937      ((add-guard!)        add-guard!)
938      ((defun!)            defun!)
939      ((depgraph)          depgraph)
940      ((depgraph*)         depgraph*)
941      ((depgraph->bfs-dist-poset)  graph->bfs-dist-poset)
942      ((env-extend!)       env-extend!)
943      ((eqdef!)            eqdef!)
944      ((exam)              exam)
945      ((eval-const)        eval-const)
946      ((make-const-env)    make-const-env)
947      ((set-hook!)         set-hook!)
948      ((set-indep!)        set-indep!)
949      ((set-print!)        set-print!)
950      ((set-timestep!)     set-timestep!)
951      ((step!)             step!)
952      ((system)            system)
953      ((sysname)           sysname)
954      ((fptype)            fptype)
955      ((relmax)            relmax)
956      ((relmin)            relmin)
957      ((absmax)            absmax)
958      ((absmin)            absmin)
959      (else
960       (ode:error 'selector ": unknown message " selector " sent to an ode object")))) 
961
962  odecore)
963
964(define ode:env-copy environment-copy)
965
966(define qcounter 0)
967
968(define (qname prefix)
969  (let ((v qcounter))
970    (set! qcounter (+ 1 qcounter))
971    (string->symbol (string-append (symbol->string prefix) (number->string v)))))
972
973(define (eval-ode-system-decls ode name sys declarations)
974  (let loop ((ds declarations))
975    (if (not (null? ds))
976        (let ((decl (car ds)))
977          (match decl
978                 ;; constant during integration
979                 (('const id '= expr)
980                  (cond ((and (symbol? id) (or (number? expr) (list? expr)))
981                         (let ((val ((ode 'eval-const) sys expr)))
982                           (((ode 'env-extend!) sys) id '(const) val)))
983                        (else (ode:error 'eval-ode-system-decls "constant declarations must be of the form: "
984                                         "const id = expr")))) 
985
986                 ;; system state
987                 (('state id '= expr) 
988                  (cond ((and (symbol? id) (or (number? expr) (symbol? expr) (list? expr)))
989                         (((ode 'env-extend!) sys) id '(state) ((ode 'eval-const) sys expr)))
990                        (else (ode:error 'eval-ode-system-decls "state declarations must be of the form: "
991                                         "state id = expr"))))
992                 ;; independent variable (default: t)
993                 (('indep id)
994                  (cond ((symbol? id)
995                         (((ode 'set-indep!) sys) id))
996                        (else (ode:error 'eval-ode-system-decls "independent variable declarations must be of the form: "
997                                         "indep id"))))
998                 ;; algebraic assignment
999                 ((id '= expr) 
1000                  (cond ((and (symbol? id) (or (symbol? expr) (number? expr) (list? expr)))
1001                         (((ode 'env-extend!) sys) id '(asgn) 'none expr))
1002                        (else (ode:error 'eval-ode-system-decls "algebraic declarations must be of the form: "
1003                                         "id = expr"))))
1004                 ;; user-defined function
1005                 (('defun id idlist expr) 
1006                  (cond ((and (symbol? id) (list? idlist) (every symbol? idlist) (list? expr))
1007                         (((ode 'defun!) sys) id idlist expr))
1008                        (else (ode:error 'eval-ode-system-decls "function declarations must be of the form: "
1009                                         "defun id (arg1 arg2 ...) expr"))))
1010                 ;; compiled code primitives
1011                 (('prim id value) 
1012                  (cond ((symbol? id)
1013                         (((ode 'env-extend!) sys) id '(prim) value))
1014                        (else (ode:error 'eval-ode-system-decls "prim declarations must be of the form: "
1015                                         "prim id value"))))
1016                 ;; differential equation
1017                 (('d (id) '= expr)
1018                  (cond ((and (symbol? id) (or (symbol? expr) (number? expr) (list? expr)))
1019                         (((ode 'eqdef!) sys) id  expr))
1020                        (else (ode:error 'eval-ode-system-decls "differential equations must be of the form: "
1021                                         "d (id) = expr"))))
1022                 ;; difference equation
1023                 (('q (id) '= expr)
1024                  (cond ((and (symbol? id) (or (symbol? expr) (number? expr) (list? expr)))
1025                         (((ode 'eqdef!) sys) id  expr 'q))
1026                        (else (ode:error 'eval-ode-system-decls "difference equations must be of the form: "
1027                                         "q (id) = expr"))))
1028                 
1029                 ;; guard expression
1030                 (('guard expr)
1031                  (((ode 'add-guard!) sys) expr))
1032                 
1033                 (('guards . lst)
1034                  (for-each (lambda (x) (((ode 'add-guard!) sys) x)) lst))
1035                 
1036                 ;; set print stmt to be executed during system run
1037                 (('print prtlist)
1038                  (cond ((list? prtlist)
1039                         (((ode 'set-print!) sys) prtlist))
1040                        (else (ode:error 'eval-ode-system-decls "print lists must be of the form: "
1041                                         "print (id1 id2 ...) [(every expr)] [(from expr)]"))))
1042                 (('print prtlist ('every every-expr))
1043                  (cond ((list? prtlist)
1044                         (((ode 'set-print!) sys) prtlist ((ode 'eval-const) sys every-expr)))
1045                        (else (ode:error 'eval-ode-system-decls "print lists must be of the form: "
1046                                         "print (id1 id2 ...) [(every expr)] [(from expr)]"))))
1047                 (('print prtlist ('every every-expr) ('from from-expr))
1048                  (cond ((list? prtlist)
1049                         (((ode 'set-print!) sys) prtlist 
1050                          ((ode 'eval-const) sys every-expr) 
1051                          ((ode 'eval-const) sys from-expr)))
1052                        (else (ode:error 'eval-ode-system-decls "print lists must be of the form: "
1053                                         "print (id1 id2 ...) [(every expr)] [(from expr)]"))))
1054
1055                 (('decls lst)  (loop lst))
1056
1057                 (('sysname name)  (if (symbol? name)
1058                                       (environment-set! sys (ode-intern 'name)      (SYSNAME name))
1059                                       (ode:error 'eval-ode-system-decls "system name must be a symbol")))
1060
1061                 (('const . _)
1062                  (ode:error 'eval-ode-system-decls "constant declarations must be of the form: "
1063                             "const id = expr"))
1064
1065                 (('state . _)
1066                  (ode:error 'eval-ode-system-decls "state declarations must be of the form: "
1067                             "state id = initial-expr"))
1068
1069                 (('indep . _)
1070                  (ode:error 'eval-ode-system-decls "independent variable declarations must be of the form: "
1071                             "indep id"))
1072
1073                 ((id '= . _) 
1074                  (ode:error 'eval-ode-system-decls "algebraic equations must be of the form: "
1075                             "id = expr")) 
1076
1077                 (('defun . _) 
1078                  (ode:error 'eval-ode-system-decls "function declarations must be of the form: "
1079                             "defun id (arg1 arg2 ...) expr"))
1080
1081                 (('prim . _) 
1082                  (ode:error 'eval-ode-system-decls "prim declarations must be of the form: "
1083                             "prim id value"))
1084
1085                 (('d . _)
1086                  (ode:error 'eval-ode-system-decls "differential equations must be of the form: "
1087                             "d (id) = expr"))
1088
1089                 (('q . _)
1090                  (ode:error 'eval-ode-system-decls "difference equations must be of the form: "
1091                             "q (id) = expr"))
1092                 
1093                 ;; guard expression
1094                 (('guard . _)
1095                  (ode:error 'eval-ode-system-decls "invalid guard declaration: " decl))
1096
1097                 ;; set print stmt to be executed during system run
1098                 (('print . _)
1099                  (ode:error 'eval-ode-system-decls "print lists must be of the form: "
1100                             "print (id1 id2 ...) [(every expr)] [(from expr)]"))
1101
1102                 (('decls . _) 
1103                  (ode:error 'eval-ode-system-decls "invalid decls list: " decl))
1104
1105                 (('sysname . _) 
1106                  (ode:error 'eval-ode-system-decls "system name must be of the form (sysname name)"))
1107
1108                 ;; anything that doesn't match is possibly
1109                 ;; declarations recognized by the ode extension
1110                 ;; modules
1111                 ((tag  . lst)
1112                  (if (symbol? tag)
1113                      (match-let (((typ name alst) 
1114                                    (let loop ((lst lst) (ax (list tag)))
1115                                      (if (symbol? (car lst))
1116                                          (loop (cdr lst) (cons (car lst) ax))
1117                                          (match lst
1118                                                 (((x . rest)) (if (and (symbol? x) (every list? rest))
1119                                                                   (list (reverse ax) x rest)
1120                                                                   (list (reverse ax) #f lst)))
1121                                                 (else  (list (reverse ax) #f lst)))))))
1122                         (if name
1123                             (((ode 'env-extend!) sys) name  typ alst)
1124                             (((ode 'env-extend!) sys) (qname tag)  typ alst)))
1125                      (ode:error 'eval-ode-system-decls "extended declarations must be of the form: "
1126                                 "declaration (name (properties ...)")))
1127
1128                 )
1129          (loop (cdr ds)))))
1130  sys)
Note: See TracBrowser for help on using the repository browser.