source: project/release/4/nemo/trunk/nemo-core.scm @ 27305

Last change on this file since 27305 was 27305, checked in by Ivan Raikov, 9 years ago

nemo: print entire environment upon symbol not found error
File size: 55.1 KB
Line 
1;;
2;; NEMO substrate semantics.
3;;
4;; Copyright 2008-2012 Ivan Raikov and the Okinawa Institute of Science and Technology
5;;
6;; This program is free software: you can redistribute it and/or
7;; modify it under the terms of the GNU General Public License as
8;; published by the Free Software Foundation, either version 3 of the
9;; License, or (at your option) any later version.
10;;
11;; This program is distributed in the hope that it will be useful, but
12;; WITHOUT ANY WARRANTY; without even the implied warranty of
13;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
14;; General Public License for more details.
15;;
16;; A full copy of the GPL license can be found at
17;; <http://www.gnu.org/licenses/>.
18;;
19;; TODO: * check that open states in reactions are valid
20;;       * check that reactions do not specify more than
21;;         one transition between any two states
22;;
23
24(module nemo-core
25
26 (make-nemo-core nemo:error nemo:warning 
27  nemo:env-copy nemo-intern nemo-scoped nemo:quantity?
28  nemo:rhs? nemo:conseq? nemo:subst-term nemo:binding? nemo:bind
29  eval-nemo-system-decls
30  CONST ASGN REACTION RATE PRIM LABEL)
31
32 (import scheme chicken data-structures ports lolevel extras
33         srfi-1 srfi-4 srfi-13 srfi-14 srfi-69)
34
35 (require-extension lolevel datatype matchable vector-lib
36                    varsubst digraph graph-bfs graph-cycles mathh)
37
38 (include "mathh-constants")
39
40
41;--------------------
42;  Message routines
43;
44;
45
46(define (nemo:warning x . rest)
47  (let loop ((port (open-output-string)) (objs (cons x rest)))
48    (if (null? objs)
49        (begin
50          (newline port)
51          (print-error-message (get-output-string port) 
52                               (current-error-port) "nemo warning"))
53        (begin (display (car objs) port)
54               (display " " port)
55               (loop port (cdr objs))))))
56
57(define (nemo:error x . rest)
58  (let ((port (open-output-string)))
59    (if (port? x)
60        (begin
61          (display "[" port)
62          (display (port-name x) port)
63          (display "] " port)))
64    (let loop ((objs (if (port? x) rest (cons x rest))))
65      (if (null? objs)
66          (begin
67            (newline port)
68            (error 'nemo (get-output-string port)))
69          (let ((obj (car objs)))
70            (if (procedure? obj) 
71                (with-output-to-port port obj)
72                (begin
73                  (display obj port)
74                  (display " " port)))
75            (loop (cdr objs)))))))
76
77(define (make-opt pred?) (lambda (x) 
78                           (or (not x) (pred? x))))
79
80(define (eval-math x . rest)
81  (if (null? rest)
82      (let ((ex `(begin (import mathh) ,x)))
83        (eval ex))
84      (let ((ex `(begin (import mathh) (list ,x . ,rest))))
85        (eval ex))
86      ))
87     
88
89(define (expr? x) 
90  (or (symbol? x) (number? x) 
91      (match x (((? symbol?) . rest)  (every expr? rest)) 
92             (((and hd (? expr?)) . rest)  (every expr? rest)) 
93             (else #f))))
94
95(define (rhs? x) 
96  (or (symbol? x) (number? x) 
97      (match x 
98             (('let bnds body) (and (rhs? body)
99                                    (every (lambda (b) 
100                                             (and (symbol? (car b)) (rhs? (cadr b)))) bnds)))
101             (((? symbol?) . rest)  (every rhs? rest)) 
102             (else #f))))
103
104(define (conseq? x)  (match x (((? number?) '= ('+ . rest))  #t) (else #f)))
105
106(define nemo:rhs?    rhs?)
107(define nemo:conseq?  conseq?)
108
109(define (transition? x)
110  (match x
111         (('-> a b r)       (and (symbol? a) (symbol? b) (rhs? r)))
112         ((a '-> b r)       (and (symbol? a) (symbol? b) (rhs? r)))
113         (('<-> a b r1 r2)  (and (symbol? a) (symbol? b) (rhs? r1) (rhs? r2)))
114         ((a '<-> b r1 r2)  (and (symbol? a) (symbol? b) (rhs? r1) (rhs? r2)))
115         (else #f)))
116
117(define-datatype nemo:quantity nemo:quantity?
118  (SYSNAME    (name symbol?))
119  (LABEL      (v symbol?))
120  (CONST      (name symbol?) (value number?))
121  (ASGN       (name symbol?) (value number?) (rhs rhs?) )
122  (REACTION   (name symbol?) 
123              (initial      (lambda (x) (or (rhs? x) (not x))))
124              (open         (lambda (x) (or (symbol? x) (and (list? x) (every symbol? x) ))))
125              (transitions  (lambda (x) (and (list? x) (every transition? x)))) 
126              (conserve     (lambda (x) (or (not x) (and (list? x) (every conseq? x)))))
127              (power        integer?))
128  (RATE       (name symbol?) 
129              (initial      (lambda (x) (or (rhs? x) (not x))))
130              (rhs          rhs?)
131              (power       (lambda (x) (or (integer? x) (not x)))))
132  (PRIM       (name symbol?) (value identity))
133  (EXTERNAL   (local-name symbol?) (name symbol?) (namespace (make-opt symbol?)))
134  (EXPORTS    (lst (lambda (x) (and (list? x) (every symbol? x)))))
135  (COMPONENT  (name symbol?) (type symbol?) (lst (lambda (x) (and (list? x) (every symbol? x)))) (scope-subst list?))
136  (FUNCTOR    (name symbol?) (args (lambda (x) (and (list? x) (every symbol? x)))) (type symbol?)  (decls list?))
137  (DISPATCH   (value procedure?))
138  )
139
140(define (nemo-intern sym)
141  (string->symbol (string-append "#" (symbol->string sym))))
142
143(define (nemo-scoped scope sym)
144  (string->symbol (string-append (->string scope) ":" (->string sym))))
145
146(define fresh gensym)
147
148(define (alist? x)
149  (every (lambda (x) (and (pair? x) (symbol? (car x)))) x))
150
151(define (lookup-def k lst . rest)
152  (let-optionals rest ((default #f))
153    (let ((k (->string k))) 
154     (let recur ((kv #f) (lst lst))
155       (if (or kv (null? lst))
156        (if (not kv) default
157            (match kv ((k v) v) (else (cdr kv))))
158        (let ((kv (car lst)))
159          (recur (and (string=? (->string (car kv)) k) kv)
160                 (cdr lst)) ))))))
161
162
163(define (nemo:subst-term t subst k)
164  (assert (every symbol? (map car subst)))
165  (match t
166         (('if c t e)
167          `(if ,(k c subst) ,(k t subst) ,(k e subst)))
168                 
169         (('let bs e)
170          (let ((r `(let ,(map (lambda (b) `(,(car b) ,(k (cadr b) subst))) bs) ,(k e subst))))
171            (k r subst)))
172                 
173         ((f . es)
174          (cons (k f subst) (map (lambda (e) (k e subst)) es)))
175         
176         ((? symbol? )  (lookup-def t subst t))
177         
178         ((? atom? ) t)))
179   
180
181(define (nemo:binding? t) 
182  (and (list? t) (eq? 'let (car t)) (cdr t)))
183
184(define (nemo:bind ks vs e) `(let ,(zip ks vs) ,e))
185
186(define nemo:env-copy hash-table-copy)
187
188
189(define (make-nemo-core . alst)
190
191  ;; floating point precision (single or double; default is double)
192  (define  fptype (lookup-def 'fpprec alst 'double))
193  (define  fpvector-type
194    (lookup-def 'fpvector-type alst (if (equal? fptype 'single) 'f32vector 'f64vector)))
195  (define  fpvector? 
196    (lookup-def 'fpvector? alst (if (equal? fptype 'single) f32vector? f64vector?)))
197  (define  fpvector 
198    (lookup-def 'fpvector alst (if (equal? fptype 'single) f32vector f64vector)))
199  (define  fpvector-ref
200    (lookup-def 'fpvector-ref alst (if (equal? fptype 'single) f32vector-ref f64vector-ref)))
201  (define  fpvector-set!
202    (lookup-def 'fpvector-set! alst (if (equal? fptype 'single) f32vector-set! f64vector-set!)))
203
204
205  (define builtin-fns
206    `(+ - * / pow neg abs atan asin acos sin cos exp ln
207        sqrt tan cosh sinh tanh hypot gamma lgamma log10 log2 log1p ldexp cube
208        > < <= >= = and or round ceiling floor max min
209        ))
210
211
212  (define (add-primitives! env)
213    (let ((prim-exprs
214           '(fp+ fp- fp* fp/ expt fpneg
215                 abs atan asin acos sin cos exp log sqrt tan 
216                 cosh sinh tanh hypot gamma lgamma log10 log2 log1p ldexp
217                 (lambda (x) (* x x x))
218                 fp> fp< fp<= fp>= fp=
219                 (lambda (x y) (and x y)) (lambda (x y) (or x y)) 
220                 round ceiling floor fpmax fpmin
221                 )))
222      (for-each (lambda (n v qb fms rt) 
223                  (let ((fb (extend-procedure 
224                             v `((name ,n) (eval-body ,qb)
225                                 (rt ,rt) (formals ,fms)))))
226                    (hash-table-set! env n fb)))
227                builtin-fns
228                (apply eval-math prim-exprs)
229                prim-exprs
230                `((,fptype ,fptype) (,fptype ,fptype) (,fptype ,fptype) (,fptype ,fptype) 
231                  (,fptype ,fptype) (,fptype)
232                  (,fptype) (,fptype) (,fptype) (,fptype) (,fptype) (,fptype) (,fptype)
233                  (,fptype) (,fptype) (,fptype)
234                  (,fptype) (,fptype) (,fptype) (,fptype) (,fptype) (,fptype) (,fptype)
235                  (,fptype) (,fptype) (,fptype)
236                  (,fptype) 
237                  (bool bool) (bool bool) (bool bool) (bool bool) (bool bool) (bool bool) (bool bool) 
238                  (,fptype) (,fptype) (,fptype) (,fptype ,fptype) (,fptype ,fptype) 
239                  (,fpvector-type integer) )
240                `(,fptype ,fptype ,fptype ,fptype 
241                          ,fptype ,fptype
242                          ,fptype ,fptype ,fptype ,fptype ,fptype ,fptype ,fptype
243                          ,fptype ,fptype ,fptype
244                          ,fptype ,fptype ,fptype ,fptype ,fptype ,fptype ,fptype
245                          ,fptype ,fptype ,fptype
246                          ,fptype 
247                          bool bool bool bool bool bool bool 
248                          ,fptype ,fptype ,fptype ,fptype ,fptype 
249                          ,fptype )
250                )))
251
252  (define (add-constants! env)
253    (for-each (lambda (n b) (hash-table-set! env n b))
254              `(E 1/E E^2 E^PI/4 LOG2E LOG10E LN2 LN3 LNPI LN10 1/LN2 1/LN10 PI PI/2
255                  PI/4 1/PI 2/PI 2/SQRTPI SQRTPI PI^2 DEGREE SQRT2 1/SQRT2 SQRT3 SQRT5
256                  SQRT10 CUBERT2 CUBERT3 4THRT2 GAMMA1/2 GAMMA1/3 GAMMA2/3 PHI LNPHI
257                  1/LNPHI EULER E^EULER SIN1 COS1 ZETA3)
258              (list E 1/E E^2 E^PI/4 LOG2E LOG10E LN2 LN3 LNPI LN10 1/LN2 1/LN10 PI PI/2
259                 PI/4 1/PI 2/PI 2/SQRTPI SQRTPI PI^2 DEGREE SQRT2 1/SQRT2 SQRT3 SQRT5
260                 SQRT10 CUBERT2 CUBERT3 4THRT2 GAMMA1/2 GAMMA1/3 GAMMA2/3 PHI LNPHI
261                 1/LNPHI EULER E^EULER SIN1 COS1 ZETA3)))
262
263
264  (define (enumdeps expr)
265    (let loop ((expr expr) (ax (list)) (lbs (list)))
266      (match expr 
267             (('let bs e)  (let let-loop ((bs bs) (ax ax) (lbs lbs))
268                             (if (null? bs) (loop e ax lbs)
269                                 (let ((x   (first  (car bs)))
270                                       (ex  (second (car bs))))
271                                   (let* ((lbs1  (cons x lbs))
272                                          (ax1   (loop ex ax lbs)))
273                                     (let-loop (cdr bs) ax1 lbs1))))))
274
275             ((s . es)     (if (symbol? s) (fold (lambda (e ax) (loop e ax lbs)) ax es) 
276                               (fold (lambda (e ax) (loop e ax lbs)) ax (cons s es))))
277             (id           (if (and (symbol? id) (not (member id lbs))) (cons id ax) ax)))))
278
279
280  (define (binop-fold op lst)
281    (if (null? lst) lst
282        (match lst
283               ((x)   x)
284               ((x y) `(,op ,x ,y))
285               ((x y . rest) `(,op (,op ,x ,y) ,(binop-fold op rest)))
286               ((x . rest) `(,op ,x ,(binop-fold op rest))))))
287
288
289  ;; if argument is constant, return the negative of that constant,
290  ;; otherwise return `(neg ,expr)
291  (define (negate expr)
292    (if (number? expr) (- expr)
293        `(neg ,expr)))
294
295  ;; 1. make sure all constants in an expression are flonums
296  ;; 2. fold expressions like (+ a b c d) into nested binops
297  (define (make-normalize-expr arity-check symbol-check)
298    (lambda (expr loc)
299      (let recur ((expr expr) (lbs '()))
300        (match expr 
301               (('let bs e)         (let ((normalize-bnd  (lambda (x) `(,(first x) ,(recur (second x) lbs))))
302                                          (lbs1 (append (map first bs) lbs)))
303                                      `(let ,(map normalize-bnd bs) ,(recur e lbs1))))
304               (('if c t e)         `(if ,(recur c lbs) ,(recur t lbs) ,(recur e lbs))) 
305               (('+ . es)           (binop-fold '+ (map (lambda (x) (recur x lbs)) es)))
306               (('- . es)           (let ((es1 (map (lambda (x) (recur x lbs)) es)))
307                                      (binop-fold '+ (cons (car es1) (map negate (cdr es1))))))
308               (('* . es)           (binop-fold '* (map (lambda (x) (recur x lbs)) es)))
309               (('/ . es)           (binop-fold '/ (map (lambda (x) (recur x lbs)) es)))
310               (('fix n)            n)
311               ((s . es)            (begin
312                                      (arity-check s es loc)
313                                      (cons s (map (lambda (x) (recur x lbs)) es))))
314               (x                   (cond ((number? x) (exact->inexact x))
315                                          ((symbol? x) (begin (symbol-check x loc lbs) x))
316                                          (else x)))
317                                                             
318               ))))
319
320  (define (make-base-env)
321    (let ((env (make-hash-table size: 10000 min-load: 0.9 max-load: 0.9)))
322      (add-primitives! env)
323      (add-constants! env)
324      env))
325   
326  (define (make-const-env nemo-env)
327    (let ((env (make-base-env)))
328      (hash-table-for-each nemo-env
329        (lambda (sym en)
330          (cond  ((nemo:quantity? en) 
331                  (cases nemo:quantity en
332                         (CONST (name value) 
333                                (hash-table-set! env name value))
334                         (PRIM (name value) 
335                               (hash-table-set! env name value))))
336                 ((procedure? en)
337                  (hash-table-set! env sym en)))))
338        env))
339
340
341  (define (const-env-entry->value en)
342    (cond  ((nemo:quantity? en) 
343            (cases nemo:quantity en
344                   (CONST (name value)  value)
345                   (PRIM (name value)  value)
346                   ))
347           ((procedure? en) (lookup-def 'eval-body (procedure-data en)))
348           ((or (number? en) (symbol? en))   en)
349           (else #f)))
350
351  (define (system name)
352    (let ((env  (make-base-env))
353          (name (if (symbol? name) name (string->symbol name))))
354      (hash-table-set! env (nemo-intern 'dispatch)  (DISPATCH nemo-dispatch))
355      (hash-table-set! env (nemo-intern 'name)      (SYSNAME name))
356      (hash-table-set! env (nemo-intern 'exports)   (EXPORTS (list)))
357      (hash-table-set! env (nemo-intern 'toplevel)  (COMPONENT 'toplevel 'toplevel (list) (list)))
358      env))
359
360  (define (add-external! nemo-env)
361    (lambda (sym typ)
362      (match typ
363             ('output
364              (begin
365                (if (not (hash-table-exists? nemo-env sym))
366                    (nemo:error 'add-external! ": exported quantity " sym " is not defined"))
367                (let* ((exports-sym   (nemo-intern 'exports))
368                       (exports       (hash-table-ref nemo-env exports-sym)))
369                  (cases nemo:quantity exports
370                         (EXPORTS (lst) (hash-table-set! nemo-env exports-sym (EXPORTS (cons sym lst))))
371                         (else  (nemo:error 'add-external! ": invalid exports entry " exports))))))
372             
373             (('input sym lsym ns)
374              (let ((lsym (or lsym sym)))
375               
376                (if (hash-table-exists? nemo-env lsym)
377                    (nemo:error 'add-import! ": import symbol " lsym " is already defined"))
378               
379                ((env-extend! nemo-env) lsym '(external) 'none `(name ,sym) `(namespace ,ns))))
380             
381             )))
382
383
384  (define (make-symbol-check nemo-env)
385    (lambda (s loc . rest)
386      (let-optionals rest ((lbs '()))
387
388        (if (and (not (hash-table-exists? nemo-env s)) 
389                 (not (member s lbs)))
390            (begin
391              (pp (hash-table->alist nemo-env))
392              (nemo:error 'symbol-check: s " in the definition of " loc " is not defined")
393              )
394            ))
395      ))
396
397
398  (define (make-arity-check nemo-env)
399    (lambda (s args loc)
400      (if (hash-table-exists? nemo-env s)
401          (let ((op (hash-table-ref nemo-env s)))
402            (if (extended-procedure? op)
403                (let* ((fd   (procedure-data op))
404                       (fms   (lookup-def 'formals fd)))
405                 
406                  (if (not (= (length fms) (length args)))
407                      (nemo:error 'arity-check: "procedure " s 
408                                  " called with incorrect number of arguments: "
409                                  args)))))
410          (nemo:error 'arity-check: "symbol " s "(" loc ")" " is not defined")
411          )))
412
413  (define (env-extend! nemo-env)
414    (lambda (name type initial . alst)
415
416       (let* ((sym (if (symbol? name) name (string->symbol name)))
417              (arity-check (make-arity-check nemo-env))
418              (symbol-check (make-symbol-check nemo-env))
419              (normalize-expr (make-normalize-expr arity-check symbol-check)))
420
421        (if (hash-table-exists? nemo-env sym)
422            (nemo:error 'env-extend! ": quantity " sym " already defined")
423            (match type
424              (('label)   (begin
425                            (if (not (symbol? initial)) 
426                                (nemo:error 'env-extend! ": label definitions require symbolic value"))
427                            (hash-table-set! nemo-env sym (LABEL initial))))
428
429              (('external)  (begin
430                              (let* ((ns             (lookup-def 'namespace alst))
431                                     (external-name  (lookup-def 'name alst))
432                                     (x              (EXTERNAL name external-name ns )))
433                                (hash-table-set! nemo-env sym x)
434                                )))
435                             
436              (('prim)    (let* ((rhs (lookup-def 'rhs alst))
437                                 (val (if (and rhs (procedure? initial) )
438                                          (extend-procedure initial rhs)
439                                          initial)))
440                            (hash-table-set! nemo-env sym (PRIM name val ))))
441
442              (('const)   (begin
443                            (if (not (number? initial)) 
444                                (nemo:error 'env-extend! ": constant definitions require numeric value" name initial))
445                            (hash-table-set! nemo-env sym (CONST name initial))
446                            ))
447
448              (('asgn)    (let ((rhs (lookup-def 'rhs alst)))
449
450                            (if (not (eq? initial 'none))
451                                (nemo:error 'env-extend! 
452                                                    ": state function definitions must have initial value of '(none)"))
453                            (if (not rhs) 
454                                (nemo:error 'env-extend! ": state function definitions require an equation"))
455                            (let ((expr1 (normalize-expr rhs (sprintf "assignment ~A" sym))))
456                              (hash-table-set! nemo-env sym (ASGN name 0.0 expr1)))
457                            ))
458
459              (('rate)    (let* ((rhs (lookup-def 'rhs alst))
460                                 (power (lookup-def 'power alst))
461                                 (local-env (let ((local-env (hash-table-copy nemo-env)))
462                                              (hash-table-set! local-env name #t)
463                                              local-env))
464                                 (symbol-check (make-symbol-check local-env))
465                                 (normalize-expr (make-normalize-expr arity-check symbol-check))
466                                 )
467
468                            (if (not (rhs? rhs))
469                                (nemo:error 'env-extend! ": rate equation definitions require an equation"))
470
471                            (let ((initial-expr
472                                   (and initial
473                                        (normalize-expr initial
474                                                        (sprintf "initial value for rate equation ~A" sym))))
475                                  (rhs-expr (normalize-expr rhs (sprintf "rate equation ~A" sym))))
476                              (hash-table-set! nemo-env sym (RATE name initial-expr rhs-expr power)))
477
478                            ))
479
480              (('reaction)  (begin
481                            (let ((power         (or (lookup-def 'power alst) 1))
482                                  (transitions   
483                                   (map (lambda (t) 
484                                          (match t
485                                                 (( '<-> (and src (? symbol?)) (and dst (? symbol?)) r1 r2) 
486                                                  (let ((r1-expr
487                                                         (normalize-expr 
488                                                          r1 (sprintf "forward transition rate between states ~A and ~A in reaction ~A "
489                                                                      src dst sym)))
490                                                        (r2-expr
491                                                         (normalize-expr 
492                                                          r2 (sprintf "backward transition rate between states ~A and ~A in reaction ~A "
493                                                                      src dst sym)))
494                                                        )
495                                                  `( <-> ,src ,dst ,r1-expr ,r2-expr)))
496
497                                                 (( '-> (and src (? symbol?)) (and dst (? symbol?)) r1) 
498                                                  (let ((r1-expr
499                                                         (normalize-expr 
500                                                          r1 (sprintf "transition rate between states ~A and ~A in reaction ~A "
501                                                                      src dst sym))))
502                                                  `( -> ,src ,dst ,(normalize-expr r1) )))
503
504                                                 (else
505                                                  (nemo:error 'env-extend! ": invalid transition " t))))
506                                        (or (alist-ref 'transitions alst) (list))))
507                                  (conserve      (lookup-def 'conserve alst))
508                                  (open          (lookup-def 'open alst)))
509                              (if (null? transitions)
510                                  (nemo:error 'env-extend! 
511                                              ": transition state complex definitions require a transition scheme"))
512                              (if (not open) 
513                                  (nemo:error 'env-extend! ": state complex definitions require open state"))
514                              (if (not (integer? power))
515                                  (nemo:error 'env-extend!
516                                              ": definition for state " sym
517                                              " requires an integer power (" power  " was given)"))
518                             
519                              (let ((en (REACTION name (and initial (normalize-expr initial (sprintf "initial value for reaction ~A" sym)))
520                                                  open transitions 
521                                                  (and conserve (list conserve)) power)))
522                                (hash-table-set! nemo-env sym en)))))
523
524
525              (else       (begin
526                            (hash-table-set! nemo-env sym `(,type (name ,sym) . ,initial))))
527              )))))
528
529  (define (infer nemo-env ftenv body)
530    (let recur ((expr body) (lb (list)))
531      (match expr 
532             (('if c t e)
533              (let ((ct (recur c lb))
534                    (tt (recur t lb))
535                    (et (recur e lb)))
536                (and ct tt et 
537                     (begin
538                       (if (not (equal? ct 'bool)) 
539                           (nemo:error 'infer "if condition type must be boolean"))
540                       (if (equal? tt et) tt
541                           (nemo:error 'infer "type mismatch in if statement: then = " tt
542                                      " else = " et))))))
543             (('let bs e)
544              (let* ((rlb (lambda (x) (recur x lb)))
545                     (tbs (map rlb (map second bs)))
546                     (lb1 (append (zip (map first bs) tbs) lb)))
547                (recur e lb1)))
548             
549             ((s . es)   
550              (let* ((f    (hash-table-ref nemo-env s))
551                     (lst  (procedure-data f)))
552                (and lst 
553                     (let ((rt   (lookup-def 'rt   lst))
554                           (fms  (lookup-def 'formals lst)))
555                       (and rt fms
556                            (begin
557                              (for-each (lambda (x ft)
558                                          (if (and (symbol? x) (not (hash-table-exists? ftenv x)))
559                                              (hash-table-set! ftenv x ft)))
560                                        es fms)
561                              (let* ((rlb (lambda (x) (recur x lb)))
562                                     (ets (map rlb es)))
563                                (and (every identity ets)
564                                     (every (lambda (xt ft) (equal? xt ft)) ets fms)
565                                     rt))))))))
566             
567             (id    (cond ((symbol? id)     (or (lookup-def id lb) (hash-table-ref ftenv id)))
568                          ((number? id)     fptype)
569                          ((boolean? id)    'bool)
570                          ((fpvector? id)   fpvector-type)
571                          (else #f))))))
572   
573
574  (define (defun! nemo-env)
575
576    (lambda (name formals body)
577        (let* ((const-env (make-const-env nemo-env))
578               (local-env (let ((local-env (hash-table-copy nemo-env)))
579                            (for-each (lambda (s) (hash-table-set! local-env s #t))  formals)
580                            local-env))
581               (arity-check (make-arity-check local-env))
582               (symbol-check (make-symbol-check local-env))
583               (normalize-expr (make-normalize-expr arity-check symbol-check))
584               (sym (if (symbol? name) name (string->symbol name))))
585          (letrec ((enumconsts
586                    (lambda (lb)
587                      (lambda (expr ax)
588                        (match expr 
589                               (('let bs e)  (let ((ec (enumconsts (append (map first bs) lb))))
590                                               (ec e (fold ec ax (map second bs)))))
591                               (('if . es)   (fold (enumconsts lb) ax es))
592                               ((s . es)     (cond ((and (symbol? s) (hash-table-exists? const-env s))
593                                                    (let ((v (const-env-entry->value (hash-table-ref const-env s))))
594                                                      (cons (cons s v) (fold (enumconsts lb) ax es)))
595                                                    ax)
596                                                   ((and (symbol? s) (not (member s lb)))
597                                                    (nemo:error 'defun ": quantity " s " not defined"))
598                                                   (else ax)
599                                                   ))
600                               (s            (cond
601                                               ((and (symbol? s) (not (member s lb)) 
602                                                     (hash-table-exists? const-env s))
603                                                (let ((v (const-env-entry->value (hash-table-ref const-env s))))
604                                                  (cons (cons s v) ax) ))
605                                               ((and (symbol? s) (not (member s lb)))
606                                                (nemo:error 'defun ": quantity " s " not defined"))
607                                               (else ax)))
608                               ))
609                      ))
610                   
611                   )
612            (if (hash-table-exists? nemo-env sym)
613                (nemo:error 'defun! ": quantity " sym " already defined")
614                (let* (
615                       (body    (normalize-expr body (sprintf "function definition ~A" sym)))
616                       (consts  (delete-duplicates ((enumconsts formals) body (list)) 
617                                                   (lambda (x y) (equal? (car x) (car y)))))
618                       (eval-body `(let ,(map (lambda (sv)
619                                                `(,(car sv) ,(cdr sv))) consts)
620                                     (lambda ,formals ,body)))
621                       (f      (eval eval-body))
622                       )
623                  (let* ((ftenv  (make-hash-table))
624                         (rt     (infer nemo-env ftenv body))
625                         (ftypes (filter-map (lambda (x) 
626                                               (or (and (hash-table-exists? ftenv x)
627                                                        (hash-table-ref ftenv x)) 'double))
628                                             formals))
629                         (ef     (extend-procedure f 
630                                   `((name ,sym) (body ,body) (eval-body ,eval-body) 
631                                     (rt ,rt) (formals ,ftypes) (vars ,formals)
632                                     (consts ,(filter (lambda (x) (not (member x builtin-fns))) consts)))))
633                         )
634                  (hash-table-set! nemo-env sym ef))))))))
635
636  (define (symbol-list? lst)
637    (and (list? lst) (every symbol? lst)))
638
639  (define (extended nemo-env)
640      (filter-map (lambda (sym) 
641                    (let ((x (hash-table-ref nemo-env sym)))
642                      (and (not (nemo:quantity? x)) (not (procedure? x)) 
643                           (match x 
644                                  (((? symbol-list?) ('name name) . rest)  `(,sym ,x))
645                                  (else #f)))))
646           (hash-table-keys nemo-env)))
647                       
648
649  (define (extended-with-tag nemo-env tag)
650      (filter-map (lambda (sym) 
651                    (let ((x (hash-table-ref nemo-env sym)))
652                      (and (not (nemo:quantity? x)) (not (procedure? x)) 
653                           (match x 
654                                  (((? (lambda (x) (equal? x tag))) ('name name) . rest) 
655                                   `(,sym ,x))
656                                  (else #f)))))
657           (hash-table-keys nemo-env)))
658                       
659
660  (define (components nemo-env)
661      (filter-map (lambda (sym) 
662                    (let ((x (hash-table-ref nemo-env sym)))
663                      (and (nemo:quantity? x)
664                           (cases nemo:quantity x
665                                  (COMPONENT (name type lst _)  `(,name ,type ,sym))
666                                  (else #f)))))
667           (hash-table-keys nemo-env)))
668
669
670  (define (component-name nemo-env sym)
671    (let ((x (hash-table-ref nemo-env sym)))
672      (and (nemo:quantity? x)
673           (cases nemo:quantity x
674                  (COMPONENT (name type lst _)  name)
675                  (else #f)))))
676
677
678  (define (component-symbols nemo-env sym)
679    (let ((x (hash-table-ref nemo-env sym)))
680      (and (nemo:quantity? x)
681           (cases nemo:quantity x
682                  (COMPONENT (name type lst _)  lst)
683                  (else #f)))))
684
685
686  (define (component-scope-subst nemo-env sym)
687    (let ((x (hash-table-ref nemo-env sym)))
688      (and (nemo:quantity? x)
689           (cases nemo:quantity x
690                  (COMPONENT (name type lst scope-subst)  scope-subst)
691                  (else #f)))))
692
693
694  (define (component-exports nemo-env sym)
695    (let ((all-exports (cases nemo:quantity (hash-table-ref nemo-env (nemo-intern 'exports))
696                              (EXPORTS (lst)  lst))))
697      (let ((x  (hash-table-ref nemo-env sym)))
698        (and (nemo:quantity? x)
699             (cases nemo:quantity x
700                    (COMPONENT (name type lst _) 
701                      (filter-map (lambda (x) ((lambda (x) (and x (car x))) (member x all-exports))) lst))
702                    (else #f))))))
703
704  (define (component-subcomps nemo-env sym)
705
706    (define (component-type x)
707      (cases nemo:quantity x
708             (COMPONENT (name type lst _) type)
709             (else #f)))
710    (define (component-name x)
711      (cases nemo:quantity x
712             (COMPONENT (name type lst _) name)
713             (else #f)))
714    (let ((en (hash-table-ref nemo-env sym)))
715      (and (nemo:quantity? en)
716           (cases nemo:quantity en
717                  (COMPONENT (name type lst _) 
718                             (filter-map 
719                              (lambda (s) 
720                                (let ((x (hash-table-ref nemo-env s)))
721                                  (and (iscomp? x) `(,(component-type x) ,(component-name x) ,s)))) lst))
722                  (else #f)))))
723
724  (define (component-extend! nemo-env)
725    (lambda (comp-name sym)
726      (let ((x (hash-table-ref nemo-env comp-name)))
727        (if (nemo:quantity? x)
728            (cases nemo:quantity x
729                   (COMPONENT (name type lst scope-subst) 
730                              (let ((en1 (COMPONENT name type (delete-duplicates (append lst (list sym))) scope-subst)))
731                                (hash-table-set! nemo-env comp-name en1)))
732                   (else (nemo:error 'component-extend! ": invalid component " comp-name)))
733            (nemo:error 'component-extend! ": invalid component " comp-name)))))
734
735  (define (component-enumdeps nemo-env sym)
736    (let ((x (hash-table-ref nemo-env sym)))
737      (and (nemo:quantity? x)
738           (cases nemo:quantity x
739                  (COMPONENT 
740                   (name type lst scope-subst) 
741                   (delete-duplicates
742                    (append
743                     (fold (lambda (qsym ax)
744                             (let* ((q   (hash-table-ref nemo-env qsym))
745                                    (rhs (qrhs q)))
746                               (or (and rhs (append (enumdeps rhs) ax)) ax)))
747                           '()
748                           lst)
749                     (map (lambda (x) (component-enumdeps  nemo-env x))
750                          (component-subcomps nemo-env sym)))))
751                  (else #f)))))
752
753  (define (component-env nemo-env sym . syms)
754    (fold 
755     (lambda (sym env)
756       (let ((comp (hash-table-ref nemo-env sym)))
757         (and (nemo:quantity? comp)
758              (cases nemo:quantity comp
759                     (COMPONENT 
760                      (name type lst scope-subst) 
761                      (let* ((depnames (component-enumdeps nemo-env sym))
762                             (subnames (map third (component-subcomps nemo-env sym)))
763                             (cnames   lst))
764
765                        (let* ((syms (delete-duplicates (append depnames subnames cnames)))
766                               (vals (map (lambda (x) (hash-table-ref nemo-env x)) syms)))
767                          (for-each (lambda (s v) (hash-table-set! env s v)) 
768                                    syms vals)
769                          env
770                          )))
771                     (else env)))))
772     (make-base-env)
773     (cons sym syms)))
774
775
776  (define (exports nemo-env)
777    (cases nemo:quantity (hash-table-ref nemo-env (nemo-intern 'exports))
778           (EXPORTS (lst)  lst)))
779
780
781  (define (imports nemo-env)
782      (filter-map (lambda (sym) 
783                    (let ((x (hash-table-ref nemo-env sym)))
784                      (and (nemo:quantity? x)
785                           (cases nemo:quantity x
786                                  (EXTERNAL (local-name name namespace)  (list local-name name namespace))
787                                  (else #f)))))
788           (hash-table-keys nemo-env)))
789
790
791  (define (consts nemo-env)
792      (filter-map (lambda (sym) 
793                    (let ((x (hash-table-ref nemo-env sym)))
794                      (and (nemo:quantity? x)
795                           (cases nemo:quantity x
796                                  (CONST (name value)  (list name value) )
797                                  (else #f)))))
798           (hash-table-keys nemo-env)))
799
800
801
802  (define (states nemo-env)
803      (fold (lambda (sym ax) 
804                    (let ((x (hash-table-ref nemo-env sym)))
805                      (if (nemo:quantity? x)
806                           (cases nemo:quantity x
807                                  (REACTION (name initial open transitions conserve power)
808                                          (let* ((ss1 (delete-duplicates (append (map second transitions) 
809                                                                                 (map third transitions))))
810                                                 (ss2 (map (lambda (x) (list name x))  ss1)))
811                                            (append ss2 ax)))
812                                  (RATE (name initial rhs _) (cons (list #f name) ax))
813                                  (else ax))
814                           ax)))
815           (list) (hash-table-keys nemo-env)))
816
817
818  (define (reactions nemo-env)
819      (fold (lambda (sym ax) 
820                    (let ((x (hash-table-ref nemo-env sym)))
821                      (if (nemo:quantity? x)
822                           (cases nemo:quantity x
823                                  (REACTION (name initial open transitions conserve power)
824                                          (cons name ax))
825                                  (else ax))
826                           ax)))
827           (list) (hash-table-keys nemo-env)))
828
829
830  (define (rates nemo-env)
831      (filter-map (lambda (sym) 
832                    (let ((x (hash-table-ref nemo-env sym)))
833                      (and (nemo:quantity? x)
834                           (cases nemo:quantity x
835                                  (RATE (name value rhs _) name)
836                                  (else #f)))))
837           (hash-table-keys nemo-env)))
838
839  (define (asgns nemo-env)
840      (filter-map (lambda (sym) 
841                    (let ((x (hash-table-ref nemo-env sym)))
842                      (and (nemo:quantity? x)
843                           (cases nemo:quantity x
844                                  (ASGN (name value rhs) name)
845                                  (else #f)))))
846           (hash-table-keys nemo-env)))
847
848
849  (define (defuns nemo-env)
850      (filter-map (lambda (sym) 
851                    (let ((x (hash-table-ref nemo-env sym)))
852                      (and (procedure? x) (not (member sym builtin-fns)) (list sym x))))
853           (hash-table-keys nemo-env)))
854
855
856  (define (toplevel nemo-env)
857    (cases nemo:quantity (hash-table-ref nemo-env (nemo-intern 'toplevel))
858           (COMPONENT (name type lst _) `(,type ,lst))))
859
860                                       
861  (define (exam nemo-env)
862    (lambda (name)
863      (let ((sym (if (symbol? name) name (string->symbol name)))
864            (out (current-output-port)))
865        (if (not (hash-table-exists? nemo-env sym))
866            (nemo:error 'exam ": quantity " sym " is not defined")
867            (let ((x (hash-table-ref nemo-env sym)))
868              (cases nemo:quantity x
869                     (LABEL  (v)
870                            (begin
871                              (fprintf out "~a: label\n" name)
872                              (fprintf out "    value: ~a\n" v)))
873
874                     (PRIM  (name value)
875                            (begin
876                              (fprintf out "~a: compiled nemo primitive\n" name)
877                              (fprintf out "    value: ~a\n" value)))
878
879                     (CONST    (name value)
880                               (begin
881                                 (fprintf out "~a: constant\n" name)
882                                 (fprintf out "    value: ~a\n" value)))
883                     
884                     (ASGN     (name value rhs)
885                               (begin
886                                 (fprintf out "~a: state function\n" name)
887                                 (fprintf out "    value: ~a\n" value)))
888
889                     (REACTION (name initial open transitions conserve power)
890                             (begin
891                               (fprintf out "~a: transition state complex\n" name)
892                               (fprintf out "    initial value: ~a\n" initial)))
893                     
894                     (RATE     (name initial rhs power)
895                               (begin
896                                 (fprintf out "~a: rate equation\n" name)
897                                 (fprintf out "    rhs: ~a\n" rhs)
898                                 (if power (fprintf out "    power: ~a\n" power))
899                                 ))
900
901                     (else (nemo:error 'exam name ": unknown type of quantity"))))))))
902 
903  (define (eval-simple-expr env expr)
904    (cond ((number? expr) expr)
905          ((symbol? expr) (hash-table-ref env expr))
906          ((pair? expr)   (let ((expr1 (map (lambda (x) (eval-simple-expr env x)) expr)))
907                            (apply (car expr1) (cdr expr1))))))
908
909  (define (eval-const nemo-env expr qname)
910    (let* ((arity-check (make-arity-check nemo-env))
911           (symbol-check (make-symbol-check nemo-env))
912           (normalize-expr (make-normalize-expr arity-check symbol-check)))
913      (let ((expr1 (normalize-expr expr (sprintf "constant ~A" qname)))
914            (const-env (make-const-env nemo-env)))
915        (condition-case
916         (exact->inexact (eval-simple-expr const-env expr1))
917         [var () expr1])
918        )))
919
920
921  (define (iscomp? x)
922    (cond ((nemo:quantity? x)
923           (cases nemo:quantity x
924                  (COMPONENT  (name type lst _)  #t)
925                  (else #f)))
926          (else #f)))
927
928  (define (isdep? x)
929    (cond ((nemo:quantity? x)
930           (cases nemo:quantity x
931                  (ASGN  (name value rhs)  #t)
932                  (else #f)))
933          ((and (list? x) (every pair? (cdr x)))  (alist-ref 'dep?  (cdr x)))
934          (else #f)))
935
936
937  (define (isstate? x)
938    (and (nemo:quantity? x)
939         (cases nemo:quantity x
940                (REACTION (name initial open transitions)  #t)
941                (RATE     (name initial rhs _) #t)
942                (else #f))))
943
944
945  (define (qrhs x)
946    (and (nemo:quantity? x)
947         (cases nemo:quantity x
948                (REACTION (name initial open transitions) 
949                        (begin
950                          (map cadddr transitions)))
951                (RATE  (name initial rhs _)  rhs)
952                (ASGN  (name value rhs)  rhs)
953                (else #f))))
954
955           
956  (define (sysname nemo-env)
957    (cases nemo:quantity (hash-table-ref nemo-env (nemo-intern 'name))
958           (SYSNAME (name)  name)))
959
960
961  ;; create equation dependency graph
962  (define (make-eqng nemo-env)
963    (let* ((sysname    (sysname nemo-env))
964           (g          (make-digraph sysname (string-append (symbol->string sysname) 
965                                                            " equation dependency graph")))
966           (add-node!  (g 'add-node!))
967           (add-edge!  (g 'add-edge!))
968           (nemo-list  (filter (lambda (sym) (let ((x (hash-table-ref nemo-env sym)))
969                                               (or (isstate? x) (isdep? x))))
970                               (hash-table-keys nemo-env)))
971           (nemo-ids      (list-tabulate (length nemo-list) identity))
972           (name->id-map  (zip nemo-list nemo-ids)))
973      (let-values (((state-list asgn-list) 
974                    (partition (lambda (sym) (isstate? (hash-table-ref nemo-env sym)))
975                               nemo-list)))
976                 
977         ;; insert equations in the dependency graph
978         (for-each (lambda (i n) (add-node! i n)) nemo-ids nemo-list)
979         ;; create dependency edges in the graph
980         (for-each (lambda (e) 
981                     (match e ((ni . nj) (begin
982                                           (let ((i (car (alist-ref ni name->id-map)))
983                                                 (j (car (alist-ref nj name->id-map))))
984                                             (add-edge! (list i j (format "~A=>~A" ni nj))))))
985                            (else (nemo:error 'make-eqng ": invalid edge " e))))
986                   (fold (lambda (qsym ax) 
987                           (let* ((q   (hash-table-ref nemo-env qsym))
988                                  (rhs (qrhs q)))
989                             (if rhs 
990                                 (let* ((deps (filter (if (isstate? q)
991                                                          (lambda (sym) 
992                                                            (if (not (hash-table-exists? nemo-env sym))
993                                                                (nemo:error 'make-eqng ": undefined symbol " sym 
994                                                                            " in definition of quantity " qsym))
995                                                            (and (let ((x (hash-table-ref nemo-env sym)))
996                                                                   (and (isdep? x) (not (eq? sym qsym))))))
997                                                          (lambda (sym) 
998                                                            (if (not (hash-table-exists? nemo-env sym))
999                                                                (nemo:error 'make-eqng ": undefined symbol " sym 
1000                                                                            " in definition of quantity " qsym))
1001                                                            (and (let ((x (hash-table-ref nemo-env sym)))
1002                                                                   (isdep? x)))))
1003                                                      (enumdeps rhs)))
1004                                          (edges (map (lambda (d) (cons d qsym)) deps)))
1005                                   (if edges (append edges ax) ax))
1006                                 ax)))
1007                         (list) nemo-list))
1008         (let ((cycles (graph-cycles-fold g (lambda (cycle ax) (cons cycle ax)) (list))))
1009           (if (null? cycles) (list state-list asgn-list g)
1010               (nemo:error 'make-eqng ": equation cycle detected: " (car cycles)))))))
1011
1012
1013  ;; given a graph, create a partial ordering based on BFS distance from root
1014  (define (graph->bfs-dist-poset g)
1015    (define node-info (g 'node-info))
1016
1017    (let-values (((dists dmax) (graph-bfs-dist g ((g 'roots)))))
1018      (let loop ((poset  (make-vector (fx+ 1 dmax) (list)))
1019                 (i      (fx- (s32vector-length dists) 1)))
1020        (if (fx>= i 0)
1021            (let* ((c     (s32vector-ref dists i))
1022                   (info  (node-info i)))
1023              (vector-set! poset c (cons (cons i info) (vector-ref poset c)))
1024              (loop poset (fx- i 1)))
1025            (begin
1026              poset)))))
1027
1028
1029  (define (make-eval-poset nemo-env eqposet)
1030    (vector-map 
1031       (lambda (i lst) 
1032         (filter-map (lambda (id+sym)
1033                       (let* ((sym  (cdr id+sym))
1034                              (x    (hash-table-ref nemo-env sym)))
1035                         (and (nemo:quantity? x)
1036                              (cases nemo:quantity x
1037                                     (REACTION (name initial open transitions) 
1038                                             (let ((rs (map cadddr transitions)))
1039                                               (list 're sym rs)))
1040                                     (RATE  (name initial rhs _)
1041                                            (list 'r sym rhs))
1042                                     (ASGN  (name value rhs)
1043                                            (list 'a sym rhs))
1044                                     (else nemo:error 'make-eval-poset
1045                                           ": invalid quantity in equation poset: " sym)))))
1046                     lst))
1047       eqposet))
1048
1049  (define (eval-expr env)
1050    (lambda (expr)
1051      (let ((val (match expr
1052                        (('if c t f) 
1053                         (let ((ee (eval-expr env)))
1054                           (condition-case
1055                            (if (ee c) (ee t) (ee f))
1056                            [var () 
1057                               (nemo:error 'eval-expr " exception in " expr ": \n"
1058                                          (lambda () (print-error-message var)))])))
1059
1060                        ((s . es)   
1061                         (condition-case 
1062                          (let ((op   (hash-table-ref env s))
1063                                (args (map (eval-expr env) es)))
1064                            (if (extended-procedure? op)
1065                                (let* ((fd   (procedure-data op))
1066                                       (vs  (lookup-def 'vars fd)))
1067
1068                                  (if (not (= (length vs) (length args)))
1069                                      (nemo:error 'eval-expr "procedure " s 
1070                                                  " called with incorrect number of arguments"))))
1071                            (apply op args))
1072                          [var () 
1073                               (nemo:error 'eval-expr " exception in " expr ": \n"
1074                                          (lambda () (print-error-message var)))]))
1075                       
1076                        (s                 
1077                         (cond ((symbol? s) (hash-table-ref env s))
1078                               ((number? s) s)
1079                               (else (nemo:error 'eval-expr "unknown expression " s)))))))
1080        val)))
1081
1082
1083  (define (depgraph nemo-env)
1084    (match-let (((state-list asgn-list g)  (make-eqng nemo-env))) g))
1085
1086  (define (depgraph* nemo-env)
1087    (match-let (((state-list asgn-list g)  (make-eqng nemo-env))) 
1088               (list state-list asgn-list g)))
1089
1090
1091  ;; Dispatcher
1092  (define (nemo-dispatch selector)
1093    (case selector
1094      ((add-external!)     add-external!)
1095      ((defun!)            defun!)
1096      ((depgraph)          depgraph)
1097      ((depgraph*)         depgraph*)
1098      ((depgraph->bfs-dist-poset)  graph->bfs-dist-poset)
1099      ((eval-const)          eval-const)
1100      ((env-extend!)         env-extend!)
1101      ((subst-expr)        (subst-driver (lambda (x) (and (symbol? x) x)) 
1102                                         nemo:binding? 
1103                                         identity 
1104                                         nemo:bind 
1105                                         nemo:subst-term))
1106      ((exam)                exam)
1107      ((make-const-env)      make-const-env)
1108      ((system)              system)
1109      ((sysname)             sysname)
1110      ((asgns)               asgns)
1111      ((states)              states)
1112      ((reactions)           reactions)
1113      ((rates)               rates)
1114      ((defuns)              defuns)
1115      ((consts)              consts)
1116      ((exports)             exports)
1117      ((imports)             imports)
1118      ((toplevel)            toplevel)
1119      ((components)          components)
1120      ((component-env)       component-env)
1121      ((component-name)      component-name)
1122      ((component-symbols)   component-symbols)
1123      ((component-exports)   component-exports)
1124      ((component-subcomps)  component-subcomps)
1125      ((component-scope-subst)  component-scope-subst)
1126      ((component-extend!)   component-extend!)
1127      ((extended)            extended)
1128      ((extended-with-tag)   extended-with-tag)
1129      (else
1130       (nemo:error 'selector ": unknown message " selector " sent to an nemo-core object"))))
1131
1132  nemo-dispatch)
1133
1134(define (eval-nemo-system-decls nemo-core name sys declarations . rest)
1135  (let-optionals rest ((parse-expr (lambda (x . rest) x)))
1136   (define (eval-const x loc) (and x ((nemo-core 'eval-const) sys x loc)))
1137   (define env-extend!  ((nemo-core 'env-extend!) sys))
1138   (define (compute-qid id scope scope-subst) (or (and scope scope-subst (nemo-scoped scope id)) id))
1139   (define (update-subst id qid subst) (if (equal? id qid) subst
1140                                           (subst-extend id qid subst) ))
1141   (define subst-expr  (subst-driver (lambda (x) (and (symbol? x) x)) 
1142                                     nemo:binding? 
1143                                     identity 
1144                                     nemo:bind 
1145                                     nemo:subst-term))
1146   (let ((res
1147          (let loop ((ds declarations) (qs (list)) (scope #f) (scope-subst '()))
1148
1149            (if (null? ds) 
1150                (let ((qs (reverse qs)))
1151                  (if (not scope)
1152                      (let* ((top-syms   ((nemo-core 'component-symbols ) sys (nemo-intern 'toplevel)))
1153                             (top-syms1  (append qs top-syms)))
1154                        (hash-table-set! sys (nemo-intern 'toplevel) (COMPONENT 'toplevel 'toplevel top-syms1 '()))))
1155                  (list qs scope-subst))
1156                (let ((decl (car ds)))
1157                  (if (null? decl)
1158                      (loop (cdr ds) qs scope scope-subst)
1159                  (match-let 
1160                   (((qs1 scope-subst1)
1161                     (match decl
1162
1163                            ;; labels
1164                            (((or 'label 'LABEL) (and id (? symbol?)) '= (and v (? symbol?)))
1165                             (let* ((qid  (compute-qid id scope scope-subst)))
1166                               (env-extend! qid '(label) v)
1167                               (list (cons qid qs) (update-subst id qid scope-subst))))
1168                           
1169                            ;; imported quantities
1170                            (((or 'input 'INPUT) . lst) 
1171                             (cond ((every (lambda (x) (or (symbol? x) (list? x))) lst)
1172                                    (fold
1173                                     (lambda (x ax) 
1174                                       (match-let (((qs scope-subst) ax))
1175                                                  (match x
1176                                                         ((? symbol?) 
1177                                                          (let ((qid (compute-qid x scope scope-subst)))
1178                                                            (((nemo-core 'add-external!) sys) x `(input ,x ,qid #f))
1179                                                            (list (cons qid qs) (update-subst x qid scope-subst))))
1180                                                         ((id1 (or 'as 'AS) x1) 
1181                                                          (let ((qid (compute-qid x1 scope scope-subst)))
1182                                                            (((nemo-core 'add-external!) sys) x `(input ,id1 ,qid #f))
1183                                                            (list (cons qid qs) (update-subst x1 qid scope-subst))))
1184                                                         ((id1 (or 'from 'FROM) n1) 
1185                                                          (let ((qid (compute-qid id1 scope scope-subst)))
1186                                                            (((nemo-core 'add-external!) sys) x `(input ,id1 ,qid ,n1))
1187                                                            (list (cons qid qs) (update-subst id1 qid scope-subst))))
1188                                                         ((id1 (or 'as 'AS) x1 (or 'from 'FROM) n1) 
1189                                                          (let ((qid (compute-qid x1 scope scope-subst)))
1190                                                            (((nemo-core 'add-external!) sys) x `(input ,id1 ,qid ,n1))
1191                                                            (list (cons qid qs) (update-subst x1 qid scope-subst))))
1192                                                         )))
1193                                     (list qs scope-subst) lst))
1194                                   (else (nemo:error 'eval-nemo-system-decls 
1195                                                     "import statement must be of the form: "
1196                                                     "input id1 [as x1] ... "))))
1197                           
1198                            ;; exported quantities
1199                            (((or 'output 'OUTPUT) . (and lst (? (lambda (x) (every symbol? x)))))
1200                             (let ((lst1 (map (lambda (x) (compute-qid x scope scope-subst)) lst)))
1201                               (for-each (lambda (x) (((nemo-core 'add-external!) sys) x 'output)) lst1)
1202                               (list qs scope-subst)))
1203                           
1204                            ;; constant during integration
1205                            (((or 'const 'CONST) (and id (? symbol?)) '= (and expr (? expr? )))
1206                             (let* ((qid    (compute-qid id scope scope-subst))
1207                                    (qexpr  (subst-expr (parse-expr expr `(const ,qid)) scope-subst))
1208                                    (qval   (eval-const qexpr id)))
1209                               (env-extend! qid '(const) qval)
1210                               (list (cons qid qs) (update-subst id qid scope-subst))
1211                               ))
1212
1213                            ;; state transition complex
1214                            (((or 'reaction 'REACTION) ((and id (? symbol?)) . alst) )
1215                             (let* ((loc          `(reaction ,id))
1216                                    (alst         (filter identity alst))
1217                                    (initial      (lookup-def 'initial alst))
1218                                    (conserve-eq  (alist-ref 'conserve alst))
1219                                    (power        (lookup-def 'power alst))
1220                                    (power-val    (if (expr? power) 
1221                                                      (eval-const (subst-expr (parse-expr power loc) scope-subst) 
1222                                                                  (sprintf "~A.power" id))
1223                                                      (nemo:error 'eval-nemo-system-decls 
1224                                                                  "invalid power expression" power
1225                                                                  " in definition of state complex" id)))
1226                                    (transitions
1227                                     (map (lambda (t) 
1228                                            (match-let
1229                                             (((src dst rate1 rate2)
1230                                               (match t
1231                                                      (('-> a b r) (list a b r #f))
1232                                                      ((a '-> b r) (list a b r #f))
1233                                                      (('<-> a b r1 r2) (list a b r1 r2))
1234                                                      ((a '<-> b r1 r2) (list a b r1 r2))
1235                                                      (else (nemo:error "invalid transition " t
1236                                                                        " in definition of state complex " id))
1237                                                      )))
1238                                             (if (and rate1 rate2)
1239                                                 (let ((loc `(,@loc (eq. ,src <-> ,dst))))
1240                                                   `( <-> ,(subst-expr src scope-subst) 
1241                                                          ,(subst-expr dst scope-subst)
1242                                                          ,(subst-expr (parse-expr rate1 loc) scope-subst)
1243                                                          ,(subst-expr (parse-expr rate2 loc) scope-subst)))
1244                                                 (let ((loc `(,@loc (eq. ,src -> ,dst))))
1245                                                   `( -> ,(subst-expr src scope-subst)
1246                                                         ,(subst-expr dst scope-subst)
1247                                                         ,(subst-expr (parse-expr rate1 loc) scope-subst))))))
1248                                          (or (alist-ref 'transitions alst) (list)))))
1249
1250                               (let ((conserve-eq 
1251                                      (and conserve-eq
1252                                           (let ((loc `(,@loc (cons. eqs.))))
1253                                             (map (lambda (eq) 
1254                                                    (if (expr? (third eq))
1255                                                        `(,(first eq) = 
1256                                                          ,(subst-expr (parse-expr (third eq) loc) scope-subst))
1257                                                        (nemo:error 'eval-nemo-system-decls 
1258                                                                    "invalid equation " eq)))
1259                                                  conserve-eq)))))
1260                                 
1261                                 (if (and (list? conserve-eq) (not (every conseq? conserve-eq)))
1262                                     (nemo:error 'env-extend!
1263                                                 ": conservation equation for " id
1264                                                 " must be a linear equation: " conserve-eq))
1265                                 
1266                                 (let* ((qid          (compute-qid id scope scope-subst))
1267                                        (initial-expr (and initial 
1268                                                           (let ((loc `(,@loc (init. eq.))))
1269                                                             (subst-expr (parse-expr initial loc) scope-subst))))
1270                                        (initial-val  (and initial-expr (eval-const initial-expr
1271                                                                                    (sprintf "~A.initial" id)))))
1272                                   (let ((lst (cons* qid '(reaction) initial-val 
1273                                                     `(power ,power-val) 
1274                                                     (if conserve-eq `(conserve ,@conserve-eq)
1275                                                         `(conserve #f))
1276                                                     `(transitions ,@transitions) alst)))
1277                                     (apply env-extend! lst))
1278                                   (list (cons qid qs) (update-subst id qid scope-subst))))))
1279                           
1280                           
1281                            ;; rate equation
1282                            (((or 'd 'D) ((and id (? symbol?))) '= (and expr (? expr?) ) 
1283                              . rest)
1284
1285                             (let* ((qid     (compute-qid id scope scope-subst))
1286                                    (scope-subst1 (update-subst id qid scope-subst))
1287                                    (qexpr   (subst-expr (parse-expr expr `(rate ,id)) scope-subst1))
1288                                    (rest    (filter identity rest))
1289                                    (initial ((lambda (x) (and x (subst-expr (parse-expr x `(rate ,id)) scope-subst)))
1290                                              (lookup-def 'initial rest))))
1291
1292                               (env-extend! qid '(rate) 
1293                                            (and initial (eval-const initial (sprintf "~A.initial" id)) )
1294                                            `(rhs ,qexpr))
1295                                           
1296                               (list (cons qid qs) scope-subst1)))
1297                           
1298                            ;; algebraic assignment
1299                            (((and id (? symbol?)) '= (and expr (? expr?) ))
1300                             (let* ((qid    (compute-qid id scope scope-subst))
1301                                    (qexpr  (subst-expr (parse-expr expr `(asgn ,id)) scope-subst)))
1302                               (env-extend! qid '(asgn) 'none `(rhs ,qexpr))
1303                               (list (cons qid qs) (update-subst id qid scope-subst))))
1304                           
1305                            ;; user-defined function
1306                            (((or 'fun 'FUN 'rel 'REL 'defun 'DEFUN) (and id (? symbol?)) 
1307                              (and idlist (? (lambda (x) (every symbol? x)))) 
1308                              (and expr (? expr?)))
1309
1310                             (let* ((qid          (compute-qid id scope scope-subst))
1311                                    (scope-subst1 (fold (lambda (x ax) (subst-remove x ax))
1312                                                        scope-subst
1313                                                        idlist))
1314                                    (qexpr         (subst-expr (parse-expr expr `(defun ,qid)) 
1315                                                               scope-subst1))
1316                                    )
1317                               (((nemo-core 'defun!) sys) qid idlist qexpr)
1318                               (list (cons qid qs) (update-subst id qid scope-subst))))
1319                           
1320                            ;; compiled primitives
1321                            (((or 'prim 'PRIM) id value) 
1322                             (cond ((symbol? id)  (env-extend! id '(prim) value))
1323                                   (else (nemo:error 'eval-nemo-system-decls 
1324                                                        "prim declarations must be of the form: "
1325                                                        "prim id value"))))
1326
1327                            (((or 'sysname 'SYSNAME) name) 
1328                             (if (symbol? name)
1329                                 (hash-table-set! sys (nemo-intern 'name) (SYSNAME name))
1330                                 (nemo:error 'eval-nemo-system-decls
1331                                             "system name must be a symbol")))
1332                           
1333                            (((or 'component 'COMPONENT)
1334                              ((or 'type 'TYPE) typ) 
1335                              ((or 'name 'NAME) name) . lst)
1336
1337                             (let ((name1 (let ((x (and (hash-table-exists? 
1338                                                         sys (or (lookup-def name scope-subst) name))
1339                                                        (hash-table-ref 
1340                                                         sys (or (lookup-def name scope-subst) name)))))
1341                                            (or (and x (nemo:quantity? x)
1342                                                     (cases nemo:quantity x
1343                                                            (LABEL (v)  v)
1344                                                            (else name)))
1345                                                name))))
1346
1347                               (let* ((sym   (fresh "comp"))
1348                                      (scope (or scope sym)))
1349                                 (match-let (((cqs scope-subst1)   (loop lst (list) scope scope-subst)))
1350                                            (let ((comp  (COMPONENT name1 typ cqs scope-subst1)))
1351                                              (hash-table-set! sys sym comp)
1352                                              (list (cons sym qs) scope-subst1))))))
1353
1354                            (((or 'component 'COMPONENT) ((or 'type 'TYPE) typ)  . lst) 
1355                             (let* ((sym   (fresh "comp"))
1356                                    (scope (or scope sym)))
1357                                   (match-let (((cqs scope-subst1)   (loop lst (list) scope scope-subst)))
1358                                      (let ((comp  (COMPONENT sym typ cqs scope-subst1)))
1359                                        (hash-table-set! sys sym comp)
1360                                        (list (cons sym qs) scope-subst1)))))
1361
1362                            (((or 'component 'COMPONENT)  ((or 'name 'NAME) name) '= 
1363                              (and functor-name (? symbol?)) 
1364                              (and args (? list?)))
1365
1366                             (if (and scope scope-subst) 
1367                                 (nemo:error 'eval-nemo-system-decls
1368                                             "functor instantiation is not permitted in nested scope"))
1369
1370                             (match-let
1371                              (((functor-args functor-type functor-lst)
1372                                (let ((x (hash-table-ref sys functor-name)))
1373                                  (or (and (nemo:quantity? x)
1374                                           (cases nemo:quantity x
1375                                                  (FUNCTOR (sym args typ lst)  (list args typ lst))
1376                                                  (else #f)))
1377                                      (nemo:error 'eval-nemo-system-decls! functor-name 
1378                                                  " is not a functor" )))))
1379
1380                              (if (not (<= (length functor-args)  (length args)))
1381                                  (let ((n (length args)))
1382                                    (nemo:error 'eval-nemo-system-decls! "functor " functor-name 
1383                                                " requires at least " (length functor-args) " arguments; "
1384                                                args  " (total " n ") "
1385                                                (if (= n 1) "was" "were") " given" )))
1386
1387                              (match-let
1388                               (((cqs1 scope-subst1)   (loop args (list) name subst-empty)))
1389                                 (let ((cqs1-names (sort (map ->string cqs1) string< ))
1390                                       (args-names (let ((qs (map (lambda (x) 
1391                                                                    (->string (compute-qid x name scope-subst1)) )
1392                                                                    functor-args)))
1393                                                     (sort qs string<))))
1394
1395                                   (if (not (every (lambda (x) (member x cqs1-names string=)) args-names))
1396                                       (nemo:error 'eval-nemo-system-decls! "functor " functor-name 
1397                                              " instantiation did not include required arguments " 
1398                                              (filter (lambda (x) (not (member x cqs1-names string=))) args-names)))
1399                               
1400                                   (match-let
1401                                    (((cqs2 scope-subst2)   (loop functor-lst (list) name scope-subst1)))
1402                                    (let* ((sym    (fresh "comp"))
1403                                           (comp   (COMPONENT name functor-type (append cqs1 cqs2) scope-subst2)))
1404                                      (hash-table-set! sys sym comp)
1405                                     
1406                                      (list (cons sym qs) '())))))))
1407                             
1408                            (((or 'functor 'FUNCTOR) ((or 'name 'NAME) name) ((or 'type 'TYPE) typ)
1409                              (and args (? list?))  '= . lst)
1410
1411                             (if (and scope scope-subst) 
1412                                 (nemo:error 'eval-nemo-system-decls
1413                                             "functor declaration is not permitted in nested scope"))
1414                             (let* ((sym      (string->symbol (->string name)))
1415                                    (functor  (FUNCTOR sym args typ lst)))
1416                               (if (hash-table-exists? sys sym)
1417                                   (nemo:error 'eval-nemo-system-decls! ": functor " sym " already defined"))
1418                               (hash-table-set! sys sym functor)
1419                               (list (cons sym qs) '())))
1420                           
1421                            (((or 'const 'CONST) . _)
1422                             (nemo:error 'eval-nemo-system-decls "declaration: " decl
1423                                         ": constant declarations must be of the form: "
1424                                            "const id = expr"))
1425                           
1426                            ((id '= . _) 
1427                             (nemo:error 'eval-nemo-system-decls 
1428                                         "declaration " decl
1429                                         ": algebraic equations must be of the form: "
1430                                         "id = expr")) 
1431                           
1432                            (((or 'reaction 'REACTION) . _)
1433                             (nemo:error 'eval-nemo-system-decls 
1434                                         "declaration " decl 
1435                                         ": reaction declarations must be of the form: "
1436                                         "reaction (id ...)"))
1437                           
1438                            (((or 'fun 'FUN 'rel 'REL 'defun 'DEFUN) . _) 
1439                             (nemo:error 'eval-nemo-system-decls "function declarations must be of the form: "
1440                                            "fun id (arg1 arg2 ...) expr"))
1441                           
1442                            (((or 'prim 'PRIM) . _) 
1443                             (nemo:error 'eval-nemo-system-decls "prim declarations must be of the form: "
1444                                            "prim id value"))
1445                           
1446                            (((or 'component 'COMPONENT) . _) 
1447                             (nemo:error 'eval-nemo-system-decls "invalid component: " decl))
1448                           
1449                            (((or 'sysname 'SYSNAME) . _) 
1450                             (nemo:error 'eval-nemo-system-decls "system name must be of the form (sysname name)"))
1451                           
1452                            ;; anything that doesn't match is possibly
1453                            ;; declarations recognized by the nemo extension
1454                            ;; modules
1455                            (((and tag (? symbol?))  . lst)
1456                             (match-let (((typ name alst) 
1457                                          (let loop ((lst lst) (ax (list tag)))
1458                                            (if (null? lst)
1459                                                (list (list (car (reverse ax))) #f (cdr (reverse ax)))
1460                                                (match lst
1461                                                       (((? symbol?) . rest) 
1462                                                        (loop (cdr lst) (cons (car lst) ax) ))
1463                                                       (((x . rest)) 
1464                                                          (if (and (symbol? x) (every list? rest))
1465                                                              (list (reverse ax) x rest)
1466                                                              (list (reverse ax) #f lst)))
1467                                                       (else  (list (reverse ax) #f lst)))))))
1468                                       
1469                                        (let* ((name (or name (fresh tag)))
1470                                               (qid  name))
1471                                          (env-extend! qid  typ (if scope (append alst `((scope ,scope))) alst))
1472                                          (list (cons qid qs) (update-subst name qid scope-subst)))))
1473
1474                            (else
1475                             (nemo:error 'eval-nemo-system-decls 
1476                                         "declaration " decl ": "
1477                                         "extended declarations must be of the form: "
1478                                         "declaration (name (properties ...)"
1479                                         ))
1480                            )))
1481           (loop (cdr ds) qs1 scope scope-subst1))))
1482        ))))
1483     res
1484     )))
1485)
Note: See TracBrowser for help on using the repository browser.