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

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

nemo: more informative error message on missing symbol

File size: 55.0 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 hash: symbol-hash)))
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            (nemo:error 'symbol-check: s " in the definition of " loc " is not defined")
391            ))
392      ))
393
394
395  (define (make-arity-check nemo-env)
396    (lambda (s args loc)
397      (if (hash-table-exists? nemo-env s)
398          (let ((op (hash-table-ref nemo-env s)))
399            (if (extended-procedure? op)
400                (let* ((fd   (procedure-data op))
401                       (fms   (lookup-def 'formals fd)))
402                 
403                  (if (not (= (length fms) (length args)))
404                      (nemo:error 'arity-check: "procedure " s 
405                                  " called with incorrect number of arguments: "
406                                  args)))))
407          (nemo:error 'arity-check: "symbol " s "(" loc ")" " is not defined")
408          )))
409
410  (define (env-extend! nemo-env)
411    (lambda (name type initial . alst)
412
413       (let* ((sym (if (symbol? name) name (string->symbol name)))
414              (arity-check (make-arity-check nemo-env))
415              (symbol-check (make-symbol-check nemo-env))
416              (normalize-expr (make-normalize-expr arity-check symbol-check)))
417
418        (if (hash-table-exists? nemo-env sym)
419            (nemo:error 'env-extend! ": quantity " sym " already defined")
420            (match type
421              (('label)   (begin
422                            (if (not (symbol? initial)) 
423                                (nemo:error 'env-extend! ": label definitions require symbolic value"))
424                            (hash-table-set! nemo-env sym (LABEL initial))))
425
426              (('external)  (begin
427                              (let* ((ns             (lookup-def 'namespace alst))
428                                     (external-name  (lookup-def 'name alst))
429                                     (x              (EXTERNAL name external-name ns )))
430                                (hash-table-set! nemo-env sym x)
431                                )))
432                             
433              (('prim)    (let* ((rhs (lookup-def 'rhs alst))
434                                 (val (if (and rhs (procedure? initial) )
435                                          (extend-procedure initial rhs)
436                                          initial)))
437                            (hash-table-set! nemo-env sym (PRIM name val ))))
438
439              (('const)   (begin
440                            (if (not (number? initial)) 
441                                (nemo:error 'env-extend! ": constant definitions require numeric value" name initial))
442                            (hash-table-set! nemo-env sym (CONST name initial))
443                            ))
444
445              (('asgn)    (let ((rhs (lookup-def 'rhs alst)))
446
447                            (if (not (eq? initial 'none))
448                                (nemo:error 'env-extend! 
449                                                    ": state function definitions must have initial value of '(none)"))
450                            (if (not rhs) 
451                                (nemo:error 'env-extend! ": state function definitions require an equation"))
452                            (let ((expr1 (normalize-expr rhs (sprintf "assignment ~A" sym))))
453                              (hash-table-set! nemo-env sym (ASGN name 0.0 expr1)))
454                            ))
455
456              (('rate)    (let* ((rhs (lookup-def 'rhs alst))
457                                 (power (lookup-def 'power alst))
458                                 (local-env (let ((local-env (hash-table-copy nemo-env)))
459                                              (hash-table-set! local-env name #t)
460                                              local-env))
461                                 (symbol-check (make-symbol-check local-env))
462                                 (normalize-expr (make-normalize-expr arity-check symbol-check))
463                                 )
464
465                            (if (not (rhs? rhs))
466                                (nemo:error 'env-extend! ": rate equation definitions require an equation"))
467
468                            (let ((initial-expr
469                                   (and initial
470                                        (normalize-expr initial
471                                                        (sprintf "initial value for rate equation ~A" sym))))
472                                  (rhs-expr (normalize-expr rhs (sprintf "rate equation ~A" sym))))
473                              (hash-table-set! nemo-env sym (RATE name initial-expr rhs-expr power)))
474
475                            ))
476
477              (('reaction)  (begin
478                            (let ((power         (or (lookup-def 'power alst) 1))
479                                  (transitions   
480                                   (map (lambda (t) 
481                                          (match t
482                                                 (( '<-> (and src (? symbol?)) (and dst (? symbol?)) r1 r2) 
483                                                  (let ((r1-expr
484                                                         (normalize-expr 
485                                                          r1 (sprintf "forward transition rate between states ~A and ~A in reaction ~A "
486                                                                      src dst sym)))
487                                                        (r2-expr
488                                                         (normalize-expr 
489                                                          r2 (sprintf "backward transition rate between states ~A and ~A in reaction ~A "
490                                                                      src dst sym)))
491                                                        )
492                                                  `( <-> ,src ,dst ,r1-expr ,r2-expr)))
493
494                                                 (( '-> (and src (? symbol?)) (and dst (? symbol?)) r1) 
495                                                  (let ((r1-expr
496                                                         (normalize-expr 
497                                                          r1 (sprintf "transition rate between states ~A and ~A in reaction ~A "
498                                                                      src dst sym))))
499                                                  `( -> ,src ,dst ,(normalize-expr r1) )))
500
501                                                 (else
502                                                  (nemo:error 'env-extend! ": invalid transition " t))))
503                                        (or (alist-ref 'transitions alst) (list))))
504                                  (conserve      (lookup-def 'conserve alst))
505                                  (open          (lookup-def 'open alst)))
506                              (if (null? transitions)
507                                  (nemo:error 'env-extend! 
508                                              ": transition state complex definitions require a transition scheme"))
509                              (if (not open) 
510                                  (nemo:error 'env-extend! ": state complex definitions require open state"))
511                              (if (not (integer? power))
512                                  (nemo:error 'env-extend!
513                                              ": definition for state " sym
514                                              " requires an integer power (" power  " was given)"))
515                             
516                              (let ((en (REACTION name (and initial (normalize-expr initial (sprintf "initial value for reaction ~A" sym)))
517                                                  open transitions 
518                                                  (and conserve (list conserve)) power)))
519                                (hash-table-set! nemo-env sym en)))))
520
521
522              (else       (begin
523                            (hash-table-set! nemo-env sym `(,type (name ,sym) . ,initial))))
524              )))))
525
526  (define (infer nemo-env ftenv body)
527    (let recur ((expr body) (lb (list)))
528      (match expr 
529             (('if c t e)
530              (let ((ct (recur c lb))
531                    (tt (recur t lb))
532                    (et (recur e lb)))
533                (and ct tt et 
534                     (begin
535                       (if (not (equal? ct 'bool)) 
536                           (nemo:error 'infer "if condition type must be boolean"))
537                       (if (equal? tt et) tt
538                           (nemo:error 'infer "type mismatch in if statement: then = " tt
539                                      " else = " et))))))
540             (('let bs e)
541              (let* ((rlb (lambda (x) (recur x lb)))
542                     (tbs (map rlb (map second bs)))
543                     (lb1 (append (zip (map first bs) tbs) lb)))
544                (recur e lb1)))
545             
546             ((s . es)   
547              (let* ((f    (hash-table-ref nemo-env s))
548                     (lst  (procedure-data f)))
549                (and lst 
550                     (let ((rt   (lookup-def 'rt   lst))
551                           (fms  (lookup-def 'formals lst)))
552                       (and rt fms
553                            (begin
554                              (for-each (lambda (x ft)
555                                          (if (and (symbol? x) (not (hash-table-exists? ftenv x)))
556                                              (hash-table-set! ftenv x ft)))
557                                        es fms)
558                              (let* ((rlb (lambda (x) (recur x lb)))
559                                     (ets (map rlb es)))
560                                (and (every identity ets)
561                                     (every (lambda (xt ft) (equal? xt ft)) ets fms)
562                                     rt))))))))
563             
564             (id    (cond ((symbol? id)     (or (lookup-def id lb) (hash-table-ref ftenv id)))
565                          ((number? id)     fptype)
566                          ((boolean? id)    'bool)
567                          ((fpvector? id)   fpvector-type)
568                          (else #f))))))
569   
570
571  (define (defun! nemo-env)
572
573    (lambda (name formals body)
574        (let* ((const-env (make-const-env nemo-env))
575               (local-env (let ((local-env (hash-table-copy nemo-env)))
576                            (for-each (lambda (s) (hash-table-set! local-env s #t))  formals)
577                            local-env))
578               (arity-check (make-arity-check local-env))
579               (symbol-check (make-symbol-check local-env))
580               (normalize-expr (make-normalize-expr arity-check symbol-check))
581               (sym (if (symbol? name) name (string->symbol name))))
582          (letrec ((enumconsts
583                    (lambda (lb)
584                      (lambda (expr ax)
585                        (match expr 
586                               (('let bs e)  (let ((ec (enumconsts (append (map first bs) lb))))
587                                               (ec e (fold ec ax (map second bs)))))
588                               (('if . es)   (fold (enumconsts lb) ax es))
589                               ((s . es)     (cond ((and (symbol? s) (hash-table-exists? const-env s))
590                                                    (let ((v (const-env-entry->value (hash-table-ref const-env s))))
591                                                      (cons (cons s v) (fold (enumconsts lb) ax es)))
592                                                    ax)
593                                                   ((and (symbol? s) (not (member s lb)))
594                                                    (nemo:error 'defun ": quantity " s " not defined"))
595                                                   (else ax)
596                                                   ))
597                               (s            (cond
598                                               ((and (symbol? s) (not (member s lb)) 
599                                                     (hash-table-exists? const-env s))
600                                                (let ((v (const-env-entry->value (hash-table-ref const-env s))))
601                                                  (cons (cons s v) ax) ))
602                                               ((and (symbol? s) (not (member s lb)))
603                                                (nemo:error 'defun ": quantity " s " not defined"))
604                                               (else ax)))
605                               ))
606                      ))
607                   
608                   )
609            (if (hash-table-exists? nemo-env sym)
610                (nemo:error 'defun! ": quantity " sym " already defined")
611                (let* (
612                       (body    (normalize-expr body (sprintf "function definition ~A" sym)))
613                       (consts  (delete-duplicates ((enumconsts formals) body (list)) 
614                                                   (lambda (x y) (equal? (car x) (car y)))))
615                       (eval-body `(let ,(map (lambda (sv)
616                                                `(,(car sv) ,(cdr sv))) consts)
617                                     (lambda ,formals ,body)))
618                       (f      (eval eval-body))
619                       )
620                  (let* ((ftenv  (make-hash-table))
621                         (rt     (infer nemo-env ftenv body))
622                         (ftypes (filter-map (lambda (x) 
623                                               (or (and (hash-table-exists? ftenv x)
624                                                        (hash-table-ref ftenv x)) 'double))
625                                             formals))
626                         (ef     (extend-procedure f 
627                                   `((name ,sym) (body ,body) (eval-body ,eval-body) 
628                                     (rt ,rt) (formals ,ftypes) (vars ,formals)
629                                     (consts ,(filter (lambda (x) (not (member x builtin-fns))) consts)))))
630                         )
631                  (hash-table-set! nemo-env sym ef))))))))
632
633  (define (symbol-list? lst)
634    (and (list? lst) (every symbol? lst)))
635
636  (define (extended nemo-env)
637      (filter-map (lambda (sym) 
638                    (let ((x (hash-table-ref nemo-env sym)))
639                      (and (not (nemo:quantity? x)) (not (procedure? x)) 
640                           (match x 
641                                  (((? symbol-list?) ('name name) . rest)  `(,sym ,x))
642                                  (else #f)))))
643           (hash-table-keys nemo-env)))
644                       
645
646  (define (extended-with-tag nemo-env tag)
647      (filter-map (lambda (sym) 
648                    (let ((x (hash-table-ref nemo-env sym)))
649                      (and (not (nemo:quantity? x)) (not (procedure? x)) 
650                           (match x 
651                                  (((? (lambda (x) (equal? x tag))) ('name name) . rest) 
652                                   `(,sym ,x))
653                                  (else #f)))))
654           (hash-table-keys nemo-env)))
655                       
656
657  (define (components nemo-env)
658      (filter-map (lambda (sym) 
659                    (let ((x (hash-table-ref nemo-env sym)))
660                      (and (nemo:quantity? x)
661                           (cases nemo:quantity x
662                                  (COMPONENT (name type lst _)  `(,name ,type ,sym))
663                                  (else #f)))))
664           (hash-table-keys nemo-env)))
665
666
667  (define (component-name nemo-env sym)
668    (let ((x (hash-table-ref nemo-env sym)))
669      (and (nemo:quantity? x)
670           (cases nemo:quantity x
671                  (COMPONENT (name type lst _)  name)
672                  (else #f)))))
673
674
675  (define (component-symbols nemo-env sym)
676    (let ((x (hash-table-ref nemo-env sym)))
677      (and (nemo:quantity? x)
678           (cases nemo:quantity x
679                  (COMPONENT (name type lst _)  lst)
680                  (else #f)))))
681
682
683  (define (component-scope-subst nemo-env sym)
684    (let ((x (hash-table-ref nemo-env sym)))
685      (and (nemo:quantity? x)
686           (cases nemo:quantity x
687                  (COMPONENT (name type lst scope-subst)  scope-subst)
688                  (else #f)))))
689
690
691  (define (component-exports nemo-env sym)
692    (let ((all-exports (cases nemo:quantity (hash-table-ref nemo-env (nemo-intern 'exports))
693                              (EXPORTS (lst)  lst))))
694      (let ((x  (hash-table-ref nemo-env sym)))
695        (and (nemo:quantity? x)
696             (cases nemo:quantity x
697                    (COMPONENT (name type lst _) 
698                      (filter-map (lambda (x) ((lambda (x) (and x (car x))) (member x all-exports))) lst))
699                    (else #f))))))
700
701  (define (component-subcomps nemo-env sym)
702
703    (define (component-type x)
704      (cases nemo:quantity x
705             (COMPONENT (name type lst _) type)
706             (else #f)))
707    (define (component-name x)
708      (cases nemo:quantity x
709             (COMPONENT (name type lst _) name)
710             (else #f)))
711    (let ((en (hash-table-ref nemo-env sym)))
712      (and (nemo:quantity? en)
713           (cases nemo:quantity en
714                  (COMPONENT (name type lst _) 
715                             (filter-map 
716                              (lambda (s) 
717                                (let ((x (hash-table-ref nemo-env s)))
718                                  (and (iscomp? x) `(,(component-type x) ,(component-name x) ,s)))) lst))
719                  (else #f)))))
720
721  (define (component-extend! nemo-env)
722    (lambda (comp-name sym)
723      (let ((x (hash-table-ref nemo-env comp-name)))
724        (if (nemo:quantity? x)
725            (cases nemo:quantity x
726                   (COMPONENT (name type lst scope-subst) 
727                              (let ((en1 (COMPONENT name type (delete-duplicates (append lst (list sym))) scope-subst)))
728                                (hash-table-set! nemo-env comp-name en1)))
729                   (else (nemo:error 'component-extend! ": invalid component " comp-name)))
730            (nemo:error 'component-extend! ": invalid component " comp-name)))))
731
732  (define (component-enumdeps nemo-env sym)
733    (let ((x (hash-table-ref nemo-env sym)))
734      (and (nemo:quantity? x)
735           (cases nemo:quantity x
736                  (COMPONENT 
737                   (name type lst scope-subst) 
738                   (delete-duplicates
739                    (append
740                     (fold (lambda (qsym ax)
741                             (let* ((q   (hash-table-ref nemo-env qsym))
742                                    (rhs (qrhs q)))
743                               (or (and rhs (append (enumdeps rhs) ax)) ax)))
744                           '()
745                           lst)
746                     (map (lambda (x) (component-enumdeps  nemo-env x))
747                          (component-subcomps nemo-env sym)))))
748                  (else #f)))))
749
750  (define (component-env nemo-env sym . syms)
751    (fold 
752     (lambda (sym env)
753       (let ((comp (hash-table-ref nemo-env sym)))
754         (and (nemo:quantity? comp)
755              (cases nemo:quantity comp
756                     (COMPONENT 
757                      (name type lst scope-subst) 
758                      (let* ((depnames (component-enumdeps nemo-env sym))
759                             (subnames (map third (component-subcomps nemo-env sym)))
760                             (cnames   lst))
761
762                        (let* ((syms (delete-duplicates (append depnames subnames cnames)))
763                               (vals (map (lambda (x) (hash-table-ref nemo-env x)) syms)))
764                          (for-each (lambda (s v) (hash-table-set! env s v)) 
765                                    syms vals)
766                          env
767                          )))
768                     (else env)))))
769     (make-base-env)
770     (cons sym syms)))
771
772
773  (define (exports nemo-env)
774    (cases nemo:quantity (hash-table-ref nemo-env (nemo-intern 'exports))
775           (EXPORTS (lst)  lst)))
776
777
778  (define (imports nemo-env)
779      (filter-map (lambda (sym) 
780                    (let ((x (hash-table-ref nemo-env sym)))
781                      (and (nemo:quantity? x)
782                           (cases nemo:quantity x
783                                  (EXTERNAL (local-name name namespace)  (list local-name name namespace))
784                                  (else #f)))))
785           (hash-table-keys nemo-env)))
786
787
788  (define (consts nemo-env)
789      (filter-map (lambda (sym) 
790                    (let ((x (hash-table-ref nemo-env sym)))
791                      (and (nemo:quantity? x)
792                           (cases nemo:quantity x
793                                  (CONST (name value)  (list name value) )
794                                  (else #f)))))
795           (hash-table-keys nemo-env)))
796
797
798
799  (define (states nemo-env)
800      (fold (lambda (sym ax) 
801                    (let ((x (hash-table-ref nemo-env sym)))
802                      (if (nemo:quantity? x)
803                           (cases nemo:quantity x
804                                  (REACTION (name initial open transitions conserve power)
805                                          (let* ((ss1 (delete-duplicates (append (map second transitions) 
806                                                                                 (map third transitions))))
807                                                 (ss2 (map (lambda (x) (list name x))  ss1)))
808                                            (append ss2 ax)))
809                                  (RATE (name initial rhs _) (cons (list #f name) ax))
810                                  (else ax))
811                           ax)))
812           (list) (hash-table-keys nemo-env)))
813
814
815  (define (reactions nemo-env)
816      (fold (lambda (sym ax) 
817                    (let ((x (hash-table-ref nemo-env sym)))
818                      (if (nemo:quantity? x)
819                           (cases nemo:quantity x
820                                  (REACTION (name initial open transitions conserve power)
821                                          (cons name ax))
822                                  (else ax))
823                           ax)))
824           (list) (hash-table-keys nemo-env)))
825
826
827  (define (rates nemo-env)
828      (filter-map (lambda (sym) 
829                    (let ((x (hash-table-ref nemo-env sym)))
830                      (and (nemo:quantity? x)
831                           (cases nemo:quantity x
832                                  (RATE (name value rhs _) name)
833                                  (else #f)))))
834           (hash-table-keys nemo-env)))
835
836  (define (asgns nemo-env)
837      (filter-map (lambda (sym) 
838                    (let ((x (hash-table-ref nemo-env sym)))
839                      (and (nemo:quantity? x)
840                           (cases nemo:quantity x
841                                  (ASGN (name value rhs) name)
842                                  (else #f)))))
843           (hash-table-keys nemo-env)))
844
845
846  (define (defuns nemo-env)
847      (filter-map (lambda (sym) 
848                    (let ((x (hash-table-ref nemo-env sym)))
849                      (and (procedure? x) (not (member sym builtin-fns)) (list sym x))))
850           (hash-table-keys nemo-env)))
851
852
853  (define (toplevel nemo-env)
854    (cases nemo:quantity (hash-table-ref nemo-env (nemo-intern 'toplevel))
855           (COMPONENT (name type lst _) `(,type ,lst))))
856
857                                       
858  (define (exam nemo-env)
859    (lambda (name)
860      (let ((sym (if (symbol? name) name (string->symbol name)))
861            (out (current-output-port)))
862        (if (not (hash-table-exists? nemo-env sym))
863            (nemo:error 'exam ": quantity " sym " is not defined")
864            (let ((x (hash-table-ref nemo-env sym)))
865              (cases nemo:quantity x
866                     (LABEL  (v)
867                            (begin
868                              (fprintf out "~a: label\n" name)
869                              (fprintf out "    value: ~a\n" v)))
870
871                     (PRIM  (name value)
872                            (begin
873                              (fprintf out "~a: compiled nemo primitive\n" name)
874                              (fprintf out "    value: ~a\n" value)))
875
876                     (CONST    (name value)
877                               (begin
878                                 (fprintf out "~a: constant\n" name)
879                                 (fprintf out "    value: ~a\n" value)))
880                     
881                     (ASGN     (name value rhs)
882                               (begin
883                                 (fprintf out "~a: state function\n" name)
884                                 (fprintf out "    value: ~a\n" value)))
885
886                     (REACTION (name initial open transitions conserve power)
887                             (begin
888                               (fprintf out "~a: transition state complex\n" name)
889                               (fprintf out "    initial value: ~a\n" initial)))
890                     
891                     (RATE     (name initial rhs power)
892                               (begin
893                                 (fprintf out "~a: rate equation\n" name)
894                                 (fprintf out "    rhs: ~a\n" rhs)
895                                 (if power (fprintf out "    power: ~a\n" power))
896                                 ))
897
898                     (else (nemo:error 'exam name ": unknown type of quantity"))))))))
899 
900  (define (eval-simple-expr env expr)
901    (cond ((number? expr) expr)
902          ((symbol? expr) (hash-table-ref env expr))
903          ((pair? expr)   (let ((expr1 (map (lambda (x) (eval-simple-expr env x)) expr)))
904                            (apply (car expr1) (cdr expr1))))))
905
906  (define (eval-const nemo-env expr qname)
907    (let* ((arity-check (make-arity-check nemo-env))
908           (symbol-check (make-symbol-check nemo-env))
909           (normalize-expr (make-normalize-expr arity-check symbol-check)))
910      (let ((expr1 (normalize-expr expr (sprintf "constant ~A" qname)))
911            (const-env (make-const-env nemo-env)))
912        (condition-case
913         (exact->inexact (eval-simple-expr const-env expr1))
914         [var () expr1])
915        )))
916
917
918  (define (iscomp? x)
919    (cond ((nemo:quantity? x)
920           (cases nemo:quantity x
921                  (COMPONENT  (name type lst _)  #t)
922                  (else #f)))
923          (else #f)))
924
925  (define (isdep? x)
926    (cond ((nemo:quantity? x)
927           (cases nemo:quantity x
928                  (ASGN  (name value rhs)  #t)
929                  (else #f)))
930          ((and (list? x) (every pair? (cdr x)))  (alist-ref 'dep?  (cdr x)))
931          (else #f)))
932
933
934  (define (isstate? x)
935    (and (nemo:quantity? x)
936         (cases nemo:quantity x
937                (REACTION (name initial open transitions)  #t)
938                (RATE     (name initial rhs _) #t)
939                (else #f))))
940
941
942  (define (qrhs x)
943    (and (nemo:quantity? x)
944         (cases nemo:quantity x
945                (REACTION (name initial open transitions) 
946                        (begin
947                          (map cadddr transitions)))
948                (RATE  (name initial rhs _)  rhs)
949                (ASGN  (name value rhs)  rhs)
950                (else #f))))
951
952           
953  (define (sysname nemo-env)
954    (cases nemo:quantity (hash-table-ref nemo-env (nemo-intern 'name))
955           (SYSNAME (name)  name)))
956
957
958  ;; create equation dependency graph
959  (define (make-eqng nemo-env)
960    (let* ((sysname    (sysname nemo-env))
961           (g          (make-digraph sysname (string-append (symbol->string sysname) 
962                                                            " equation dependency graph")))
963           (add-node!  (g 'add-node!))
964           (add-edge!  (g 'add-edge!))
965           (nemo-list  (filter (lambda (sym) (let ((x (hash-table-ref nemo-env sym)))
966                                               (or (isstate? x) (isdep? x))))
967                               (hash-table-keys nemo-env)))
968           (nemo-ids      (list-tabulate (length nemo-list) identity))
969           (name->id-map  (zip nemo-list nemo-ids)))
970      (let-values (((state-list asgn-list) 
971                    (partition (lambda (sym) (isstate? (hash-table-ref nemo-env sym)))
972                               nemo-list)))
973                 
974         ;; insert equations in the dependency graph
975         (for-each (lambda (i n) (add-node! i n)) nemo-ids nemo-list)
976         ;; create dependency edges in the graph
977         (for-each (lambda (e) 
978                     (match e ((ni . nj) (begin
979                                           (let ((i (car (alist-ref ni name->id-map)))
980                                                 (j (car (alist-ref nj name->id-map))))
981                                             (add-edge! (list i j (format "~A=>~A" ni nj))))))
982                            (else (nemo:error 'make-eqng ": invalid edge " e))))
983                   (fold (lambda (qsym ax) 
984                           (let* ((q   (hash-table-ref nemo-env qsym))
985                                  (rhs (qrhs q)))
986                             (if rhs 
987                                 (let* ((deps (filter (if (isstate? q)
988                                                          (lambda (sym) 
989                                                            (if (not (hash-table-exists? nemo-env sym))
990                                                                (nemo:error 'make-eqng ": undefined symbol " sym 
991                                                                            " in definition of quantity " qsym))
992                                                            (and (let ((x (hash-table-ref nemo-env sym)))
993                                                                   (and (isdep? x) (not (eq? sym qsym))))))
994                                                          (lambda (sym) 
995                                                            (if (not (hash-table-exists? nemo-env sym))
996                                                                (nemo:error 'make-eqng ": undefined symbol " sym 
997                                                                            " in definition of quantity " qsym))
998                                                            (and (let ((x (hash-table-ref nemo-env sym)))
999                                                                   (isdep? x)))))
1000                                                      (enumdeps rhs)))
1001                                          (edges (map (lambda (d) (cons d qsym)) deps)))
1002                                   (if edges (append edges ax) ax))
1003                                 ax)))
1004                         (list) nemo-list))
1005         (let ((cycles (graph-cycles-fold g (lambda (cycle ax) (cons cycle ax)) (list))))
1006           (if (null? cycles) (list state-list asgn-list g)
1007               (nemo:error 'make-eqng ": equation cycle detected: " (car cycles)))))))
1008
1009
1010  ;; given a graph, create a partial ordering based on BFS distance from root
1011  (define (graph->bfs-dist-poset g)
1012    (define node-info (g 'node-info))
1013
1014    (let-values (((dists dmax) (graph-bfs-dist g ((g 'roots)))))
1015      (let loop ((poset  (make-vector (fx+ 1 dmax) (list)))
1016                 (i      (fx- (s32vector-length dists) 1)))
1017        (if (fx>= i 0)
1018            (let* ((c     (s32vector-ref dists i))
1019                   (info  (node-info i)))
1020              (vector-set! poset c (cons (cons i info) (vector-ref poset c)))
1021              (loop poset (fx- i 1)))
1022            (begin
1023              poset)))))
1024
1025
1026  (define (make-eval-poset nemo-env eqposet)
1027    (vector-map 
1028       (lambda (i lst) 
1029         (filter-map (lambda (id+sym)
1030                       (let* ((sym  (cdr id+sym))
1031                              (x    (hash-table-ref nemo-env sym)))
1032                         (and (nemo:quantity? x)
1033                              (cases nemo:quantity x
1034                                     (REACTION (name initial open transitions) 
1035                                             (let ((rs (map cadddr transitions)))
1036                                               (list 're sym rs)))
1037                                     (RATE  (name initial rhs _)
1038                                            (list 'r sym rhs))
1039                                     (ASGN  (name value rhs)
1040                                            (list 'a sym rhs))
1041                                     (else nemo:error 'make-eval-poset
1042                                           ": invalid quantity in equation poset: " sym)))))
1043                     lst))
1044       eqposet))
1045
1046  (define (eval-expr env)
1047    (lambda (expr)
1048      (let ((val (match expr
1049                        (('if c t f) 
1050                         (let ((ee (eval-expr env)))
1051                           (condition-case
1052                            (if (ee c) (ee t) (ee f))
1053                            [var () 
1054                               (nemo:error 'eval-expr " exception in " expr ": \n"
1055                                          (lambda () (print-error-message var)))])))
1056
1057                        ((s . es)   
1058                         (condition-case 
1059                          (let ((op   (hash-table-ref env s))
1060                                (args (map (eval-expr env) es)))
1061                            (if (extended-procedure? op)
1062                                (let* ((fd   (procedure-data op))
1063                                       (vs  (lookup-def 'vars fd)))
1064
1065                                  (if (not (= (length vs) (length args)))
1066                                      (nemo:error 'eval-expr "procedure " s 
1067                                                  " called with incorrect number of arguments"))))
1068                            (apply op args))
1069                          [var () 
1070                               (nemo:error 'eval-expr " exception in " expr ": \n"
1071                                          (lambda () (print-error-message var)))]))
1072                       
1073                        (s                 
1074                         (cond ((symbol? s) (hash-table-ref env s))
1075                               ((number? s) s)
1076                               (else (nemo:error 'eval-expr "unknown expression " s)))))))
1077        val)))
1078
1079
1080  (define (depgraph nemo-env)
1081    (match-let (((state-list asgn-list g)  (make-eqng nemo-env))) g))
1082
1083  (define (depgraph* nemo-env)
1084    (match-let (((state-list asgn-list g)  (make-eqng nemo-env))) 
1085               (list state-list asgn-list g)))
1086
1087
1088  ;; Dispatcher
1089  (define (nemo-dispatch selector)
1090    (case selector
1091      ((add-external!)     add-external!)
1092      ((defun!)            defun!)
1093      ((depgraph)          depgraph)
1094      ((depgraph*)         depgraph*)
1095      ((depgraph->bfs-dist-poset)  graph->bfs-dist-poset)
1096      ((eval-const)          eval-const)
1097      ((env-extend!)         env-extend!)
1098      ((subst-expr)        (subst-driver (lambda (x) (and (symbol? x) x)) 
1099                                         nemo:binding? 
1100                                         identity 
1101                                         nemo:bind 
1102                                         nemo:subst-term))
1103      ((exam)                exam)
1104      ((make-const-env)      make-const-env)
1105      ((system)              system)
1106      ((sysname)             sysname)
1107      ((asgns)               asgns)
1108      ((states)              states)
1109      ((reactions)           reactions)
1110      ((rates)               rates)
1111      ((defuns)              defuns)
1112      ((consts)              consts)
1113      ((exports)             exports)
1114      ((imports)             imports)
1115      ((toplevel)            toplevel)
1116      ((components)          components)
1117      ((component-env)       component-env)
1118      ((component-name)      component-name)
1119      ((component-symbols)   component-symbols)
1120      ((component-exports)   component-exports)
1121      ((component-subcomps)  component-subcomps)
1122      ((component-scope-subst)  component-scope-subst)
1123      ((component-extend!)   component-extend!)
1124      ((extended)            extended)
1125      ((extended-with-tag)   extended-with-tag)
1126      (else
1127       (nemo:error 'selector ": unknown message " selector " sent to an nemo-core object"))))
1128
1129  nemo-dispatch)
1130
1131(define (eval-nemo-system-decls nemo-core name sys declarations . rest)
1132  (let-optionals rest ((parse-expr (lambda (x . rest) x)))
1133   (define (eval-const x loc) (and x ((nemo-core 'eval-const) sys x loc)))
1134   (define env-extend!  ((nemo-core 'env-extend!) sys))
1135   (define (compute-qid id scope scope-subst) (or (and scope scope-subst (nemo-scoped scope id)) id))
1136   (define (update-subst id qid subst) (if (equal? id qid) subst
1137                                           (subst-extend id qid subst) ))
1138   (define subst-expr  (subst-driver (lambda (x) (and (symbol? x) x)) 
1139                                     nemo:binding? 
1140                                     identity 
1141                                     nemo:bind 
1142                                     nemo:subst-term))
1143   (let ((res
1144          (let loop ((ds declarations) (qs (list)) (scope #f) (scope-subst '()))
1145
1146            (if (null? ds) 
1147                (let ((qs (reverse qs)))
1148                  (if (not scope)
1149                      (let* ((top-syms   ((nemo-core 'component-symbols ) sys (nemo-intern 'toplevel)))
1150                             (top-syms1  (append qs top-syms)))
1151                        (hash-table-set! sys (nemo-intern 'toplevel) (COMPONENT 'toplevel 'toplevel top-syms1 '()))))
1152                  (list qs scope-subst))
1153                (let ((decl (car ds)))
1154                  (if (null? decl)
1155                      (loop (cdr ds) qs scope scope-subst)
1156                  (match-let 
1157                   (((qs1 scope-subst1)
1158                     (match decl
1159
1160                            ;; labels
1161                            (((or 'label 'LABEL) (and id (? symbol?)) '= (and v (? symbol?)))
1162                             (let* ((qid  (compute-qid id scope scope-subst)))
1163                               (env-extend! qid '(label) v)
1164                               (list (cons qid qs) (update-subst id qid scope-subst))))
1165                           
1166                            ;; imported quantities
1167                            (((or 'input 'INPUT) . lst) 
1168                             (cond ((every (lambda (x) (or (symbol? x) (list? x))) lst)
1169                                    (fold
1170                                     (lambda (x ax) 
1171                                       (match-let (((qs scope-subst) ax))
1172                                                  (match x
1173                                                         ((? symbol?) 
1174                                                          (let ((qid (compute-qid x scope scope-subst)))
1175                                                            (((nemo-core 'add-external!) sys) x `(input ,x ,qid #f))
1176                                                            (list (cons qid qs) (update-subst x qid scope-subst))))
1177                                                         ((id1 (or 'as 'AS) x1) 
1178                                                          (let ((qid (compute-qid x1 scope scope-subst)))
1179                                                            (((nemo-core 'add-external!) sys) x `(input ,id1 ,qid #f))
1180                                                            (list (cons qid qs) (update-subst x1 qid scope-subst))))
1181                                                         ((id1 (or 'from 'FROM) n1) 
1182                                                          (let ((qid (compute-qid id1 scope scope-subst)))
1183                                                            (((nemo-core 'add-external!) sys) x `(input ,id1 ,qid ,n1))
1184                                                            (list (cons qid qs) (update-subst id1 qid scope-subst))))
1185                                                         ((id1 (or 'as 'AS) x1 (or 'from 'FROM) n1) 
1186                                                          (let ((qid (compute-qid x1 scope scope-subst)))
1187                                                            (((nemo-core 'add-external!) sys) x `(input ,id1 ,qid ,n1))
1188                                                            (list (cons qid qs) (update-subst x1 qid scope-subst))))
1189                                                         )))
1190                                     (list qs scope-subst) lst))
1191                                   (else (nemo:error 'eval-nemo-system-decls 
1192                                                     "import statement must be of the form: "
1193                                                     "input id1 [as x1] ... "))))
1194                           
1195                            ;; exported quantities
1196                            (((or 'output 'OUTPUT) . (and lst (? (lambda (x) (every symbol? x)))))
1197                             (let ((lst1 (map (lambda (x) (compute-qid x scope scope-subst)) lst)))
1198                               (for-each (lambda (x) (((nemo-core 'add-external!) sys) x 'output)) lst1)
1199                               (list qs scope-subst)))
1200                           
1201                            ;; constant during integration
1202                            (((or 'const 'CONST) (and id (? symbol?)) '= (and expr (? expr? )))
1203                             (let* ((qid    (compute-qid id scope scope-subst))
1204                                    (qexpr  (subst-expr (parse-expr expr `(const ,qid)) scope-subst))
1205                                    (qval   (eval-const qexpr id)))
1206                               (env-extend! qid '(const) qval)
1207                               (list (cons qid qs) (update-subst id qid scope-subst))
1208                               ))
1209
1210                            ;; state transition complex
1211                            (((or 'reaction 'REACTION) ((and id (? symbol?)) . alst) )
1212                             (let* ((loc          `(reaction ,id))
1213                                    (alst         (filter identity alst))
1214                                    (initial      (lookup-def 'initial alst))
1215                                    (conserve-eq  (alist-ref 'conserve alst))
1216                                    (power        (lookup-def 'power alst))
1217                                    (power-val    (if (expr? power) 
1218                                                      (eval-const (subst-expr (parse-expr power loc) scope-subst) 
1219                                                                  (sprintf "~A.power" id))
1220                                                      (nemo:error 'eval-nemo-system-decls 
1221                                                                  "invalid power expression" power
1222                                                                  " in definition of state complex" id)))
1223                                    (transitions
1224                                     (map (lambda (t) 
1225                                            (match-let
1226                                             (((src dst rate1 rate2)
1227                                               (match t
1228                                                      (('-> a b r) (list a b r #f))
1229                                                      ((a '-> b r) (list a b r #f))
1230                                                      (('<-> a b r1 r2) (list a b r1 r2))
1231                                                      ((a '<-> b r1 r2) (list a b r1 r2))
1232                                                      (else (nemo:error "invalid transition " t
1233                                                                        " in definition of state complex " id))
1234                                                      )))
1235                                             (if (and rate1 rate2)
1236                                                 (let ((loc `(,@loc (eq. ,src <-> ,dst))))
1237                                                   `( <-> ,(subst-expr src scope-subst) 
1238                                                          ,(subst-expr dst scope-subst)
1239                                                          ,(subst-expr (parse-expr rate1 loc) scope-subst)
1240                                                          ,(subst-expr (parse-expr rate2 loc) scope-subst)))
1241                                                 (let ((loc `(,@loc (eq. ,src -> ,dst))))
1242                                                   `( -> ,(subst-expr src scope-subst)
1243                                                         ,(subst-expr dst scope-subst)
1244                                                         ,(subst-expr (parse-expr rate1 loc) scope-subst))))))
1245                                          (or (alist-ref 'transitions alst) (list)))))
1246
1247                               (let ((conserve-eq 
1248                                      (and conserve-eq
1249                                           (let ((loc `(,@loc (cons. eqs.))))
1250                                             (map (lambda (eq) 
1251                                                    (if (expr? (third eq))
1252                                                        `(,(first eq) = 
1253                                                          ,(subst-expr (parse-expr (third eq) loc) scope-subst))
1254                                                        (nemo:error 'eval-nemo-system-decls 
1255                                                                    "invalid equation " eq)))
1256                                                  conserve-eq)))))
1257                                 
1258                                 (if (and (list? conserve-eq) (not (every conseq? conserve-eq)))
1259                                     (nemo:error 'env-extend!
1260                                                 ": conservation equation for " id
1261                                                 " must be a linear equation: " conserve-eq))
1262                                 
1263                                 (let* ((qid          (compute-qid id scope scope-subst))
1264                                        (initial-expr (and initial 
1265                                                           (let ((loc `(,@loc (init. eq.))))
1266                                                             (subst-expr (parse-expr initial loc) scope-subst))))
1267                                        (initial-val  (and initial-expr (eval-const initial-expr
1268                                                                                    (sprintf "~A.initial" id)))))
1269                                   (let ((lst (cons* qid '(reaction) initial-val 
1270                                                     `(power ,power-val) 
1271                                                     (if conserve-eq `(conserve ,@conserve-eq)
1272                                                         `(conserve #f))
1273                                                     `(transitions ,@transitions) alst)))
1274                                     (apply env-extend! lst))
1275                                   (list (cons qid qs) (update-subst id qid scope-subst))))))
1276                           
1277                           
1278                            ;; rate equation
1279                            (((or 'd 'D) ((and id (? symbol?))) '= (and expr (? expr?) ) 
1280                              . rest)
1281
1282                             (let* ((qid     (compute-qid id scope scope-subst))
1283                                    (scope-subst1 (update-subst id qid scope-subst))
1284                                    (qexpr   (subst-expr (parse-expr expr `(rate ,id)) scope-subst1))
1285                                    (rest    (filter identity rest))
1286                                    (initial ((lambda (x) (and x (subst-expr (parse-expr x `(rate ,id)) scope-subst)))
1287                                              (lookup-def 'initial rest))))
1288
1289                               (env-extend! qid '(rate) 
1290                                            (and initial (eval-const initial (sprintf "~A.initial" id)) )
1291                                            `(rhs ,qexpr))
1292                                           
1293                               (list (cons qid qs) scope-subst1)))
1294                           
1295                            ;; algebraic assignment
1296                            (((and id (? symbol?)) '= (and expr (? expr?) ))
1297                             (let* ((qid    (compute-qid id scope scope-subst))
1298                                    (qexpr  (subst-expr (parse-expr expr `(asgn ,id)) scope-subst)))
1299                               (env-extend! qid '(asgn) 'none `(rhs ,qexpr))
1300                               (list (cons qid qs) (update-subst id qid scope-subst))))
1301                           
1302                            ;; user-defined function
1303                            (((or 'fun 'FUN 'rel 'REL 'defun 'DEFUN) (and id (? symbol?)) 
1304                              (and idlist (? (lambda (x) (every symbol? x)))) 
1305                              (and expr (? expr?)))
1306
1307                             (let* ((qid          (compute-qid id scope scope-subst))
1308                                    (scope-subst1 (fold (lambda (x ax) (subst-remove x ax))
1309                                                        scope-subst
1310                                                        idlist))
1311                                    (qexpr         (subst-expr (parse-expr expr `(defun ,qid)) 
1312                                                               scope-subst1))
1313                                    )
1314                               (((nemo-core 'defun!) sys) qid idlist qexpr)
1315                               (list (cons qid qs) (update-subst id qid scope-subst))))
1316                           
1317                            ;; compiled primitives
1318                            (((or 'prim 'PRIM) id value) 
1319                             (cond ((symbol? id)  (env-extend! id '(prim) value))
1320                                   (else (nemo:error 'eval-nemo-system-decls 
1321                                                        "prim declarations must be of the form: "
1322                                                        "prim id value"))))
1323
1324                            (((or 'sysname 'SYSNAME) name) 
1325                             (if (symbol? name)
1326                                 (hash-table-set! sys (nemo-intern 'name) (SYSNAME name))
1327                                 (nemo:error 'eval-nemo-system-decls
1328                                             "system name must be a symbol")))
1329                           
1330                            (((or 'component 'COMPONENT)
1331                              ((or 'type 'TYPE) typ) 
1332                              ((or 'name 'NAME) name) . lst)
1333
1334                             (let ((name1 (let ((x (and (hash-table-exists? 
1335                                                         sys (or (lookup-def name scope-subst) name))
1336                                                        (hash-table-ref 
1337                                                         sys (or (lookup-def name scope-subst) name)))))
1338                                            (or (and x (nemo:quantity? x)
1339                                                     (cases nemo:quantity x
1340                                                            (LABEL (v)  v)
1341                                                            (else name)))
1342                                                name))))
1343
1344                               (let* ((sym   (fresh "comp"))
1345                                      (scope (or scope sym)))
1346                                 (match-let (((cqs scope-subst1)   (loop lst (list) scope scope-subst)))
1347                                            (let ((comp  (COMPONENT name1 typ cqs scope-subst1)))
1348                                              (hash-table-set! sys sym comp)
1349                                              (list (cons sym qs) scope-subst1))))))
1350
1351                            (((or 'component 'COMPONENT) ((or 'type 'TYPE) typ)  . lst) 
1352                             (let* ((sym   (fresh "comp"))
1353                                    (scope (or scope sym)))
1354                                   (match-let (((cqs scope-subst1)   (loop lst (list) scope scope-subst)))
1355                                      (let ((comp  (COMPONENT sym typ cqs scope-subst1)))
1356                                        (hash-table-set! sys sym comp)
1357                                        (list (cons sym qs) scope-subst1)))))
1358
1359                            (((or 'component 'COMPONENT)  ((or 'name 'NAME) name) '= 
1360                              (and functor-name (? symbol?)) 
1361                              (and args (? list?)))
1362
1363                             (if (and scope scope-subst) 
1364                                 (nemo:error 'eval-nemo-system-decls
1365                                             "functor instantiation is not permitted in nested scope"))
1366
1367                             (match-let
1368                              (((functor-args functor-type functor-lst)
1369                                (let ((x (hash-table-ref sys functor-name)))
1370                                  (or (and (nemo:quantity? x)
1371                                           (cases nemo:quantity x
1372                                                  (FUNCTOR (sym args typ lst)  (list args typ lst))
1373                                                  (else #f)))
1374                                      (nemo:error 'eval-nemo-system-decls! functor-name 
1375                                                  " is not a functor" )))))
1376
1377                              (if (not (<= (length functor-args)  (length args)))
1378                                  (let ((n (length args)))
1379                                    (nemo:error 'eval-nemo-system-decls! "functor " functor-name 
1380                                                " requires at least " (length functor-args) " arguments; "
1381                                                args  " (total " n ") "
1382                                                (if (= n 1) "was" "were") " given" )))
1383
1384                              (match-let
1385                               (((cqs1 scope-subst1)   (loop args (list) name subst-empty)))
1386                                 (let ((cqs1-names (sort (map ->string cqs1) string< ))
1387                                       (args-names (let ((qs (map (lambda (x) 
1388                                                                    (->string (compute-qid x name scope-subst1)) )
1389                                                                    functor-args)))
1390                                                     (sort qs string<))))
1391
1392                                   (if (not (every (lambda (x) (member x cqs1-names string=)) args-names))
1393                                       (nemo:error 'eval-nemo-system-decls! "functor " functor-name 
1394                                              " instantiation did not include required arguments " 
1395                                              (filter (lambda (x) (not (member x cqs1-names string=))) args-names)))
1396                               
1397                                   (match-let
1398                                    (((cqs2 scope-subst2)   (loop functor-lst (list) name scope-subst1)))
1399                                    (let* ((sym    (fresh "comp"))
1400                                           (comp   (COMPONENT name functor-type (append cqs1 cqs2) scope-subst2)))
1401                                      (hash-table-set! sys sym comp)
1402                                     
1403                                      (list (cons sym qs) '())))))))
1404                             
1405                            (((or 'functor 'FUNCTOR) ((or 'name 'NAME) name) ((or 'type 'TYPE) typ)
1406                              (and args (? list?))  '= . lst)
1407
1408                             (if (and scope scope-subst) 
1409                                 (nemo:error 'eval-nemo-system-decls
1410                                             "functor declaration is not permitted in nested scope"))
1411                             (let* ((sym      (string->symbol (->string name)))
1412                                    (functor  (FUNCTOR sym args typ lst)))
1413                               (if (hash-table-exists? sys sym)
1414                                   (nemo:error 'eval-nemo-system-decls! ": functor " sym " already defined"))
1415                               (hash-table-set! sys sym functor)
1416                               (list (cons sym qs) '())))
1417                           
1418                            (((or 'const 'CONST) . _)
1419                             (nemo:error 'eval-nemo-system-decls "declaration: " decl
1420                                         ": constant declarations must be of the form: "
1421                                            "const id = expr"))
1422                           
1423                            ((id '= . _) 
1424                             (nemo:error 'eval-nemo-system-decls 
1425                                         "declaration " decl
1426                                         ": algebraic equations must be of the form: "
1427                                         "id = expr")) 
1428                           
1429                            (((or 'reaction 'REACTION) . _)
1430                             (nemo:error 'eval-nemo-system-decls 
1431                                         "declaration " decl 
1432                                         ": reaction declarations must be of the form: "
1433                                         "reaction (id ...)"))
1434                           
1435                            (((or 'fun 'FUN 'rel 'REL 'defun 'DEFUN) . _) 
1436                             (nemo:error 'eval-nemo-system-decls "function declarations must be of the form: "
1437                                            "fun id (arg1 arg2 ...) expr"))
1438                           
1439                            (((or 'prim 'PRIM) . _) 
1440                             (nemo:error 'eval-nemo-system-decls "prim declarations must be of the form: "
1441                                            "prim id value"))
1442                           
1443                            (((or 'component 'COMPONENT) . _) 
1444                             (nemo:error 'eval-nemo-system-decls "invalid component: " decl))
1445                           
1446                            (((or 'sysname 'SYSNAME) . _) 
1447                             (nemo:error 'eval-nemo-system-decls "system name must be of the form (sysname name)"))
1448                           
1449                            ;; anything that doesn't match is possibly
1450                            ;; declarations recognized by the nemo extension
1451                            ;; modules
1452                            (((and tag (? symbol?))  . lst)
1453                             (match-let (((typ name alst) 
1454                                          (let loop ((lst lst) (ax (list tag)))
1455                                            (if (null? lst)
1456                                                (list (list (car (reverse ax))) #f (cdr (reverse ax)))
1457                                                (match lst
1458                                                       (((? symbol?) . rest) 
1459                                                        (loop (cdr lst) (cons (car lst) ax) ))
1460                                                       (((x . rest)) 
1461                                                          (if (and (symbol? x) (every list? rest))
1462                                                              (list (reverse ax) x rest)
1463                                                              (list (reverse ax) #f lst)))
1464                                                       (else  (list (reverse ax) #f lst)))))))
1465                                       
1466                                        (let* ((name (or name (fresh tag)))
1467                                               (qid  name))
1468                                          (env-extend! qid  typ (if scope (append alst `((scope ,scope))) alst))
1469                                          (list (cons qid qs) (update-subst name qid scope-subst)))))
1470
1471                            (else
1472                             (nemo:error 'eval-nemo-system-decls 
1473                                         "declaration " decl ": "
1474                                         "extended declarations must be of the form: "
1475                                         "declaration (name (properties ...)"
1476                                         ))
1477                            )))
1478           (loop (cdr ds) qs1 scope scope-subst1))))
1479        ))))
1480     res
1481     )))
1482)
Note: See TracBrowser for help on using the repository browser.