source: project/release/3/nemo/trunk/nemo-core.scm @ 13235

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

XML parser and generator brought up to date.

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