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

Last change on this file since 14732 was 14732, checked in by Ivan Raikov, 11 years ago

nemo ported to Chicken 4

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