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

Last change on this file since 11995 was 11995, checked in by Ivan Raikov, 13 years ago

More bug fixes.

File size: 34.3 KB
Line 
1;;
2;; NeuroML substrate semantics.
3;;
4;; Copyright 2008 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
20(require-extension srfi-1)
21(require-extension srfi-4)
22(require-extension srfi-13)
23(require-extension srfi-14)
24(require-extension datatype)
25(require-extension vector-lib)
26(require-extension environments)
27(require-extension digraph)
28(require-extension graph-bfs)
29(require-extension graph-cycles)
30(require-extension mathh)
31(require-extension lolevel)
32
33(include "mathh-constants")
34
35(define-extension nemo-core)
36
37(declare (export make-nemo-core nemo:error nemo:warning 
38                 nemo:env-copy nemo-intern nemo:quantity?
39                 eval-nemo-system-decls
40                 TSCOMP ASGN CONST PRIM))
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 (rhs? x)  (or (symbol? x) (number? x) (and (list? x) (every rhs? x))))
79
80(define (transition? x)
81  (match x (('-> a b x) (and (symbol? a) (symbol? b) (rhs? x)))
82         (else #f)))
83
84(define-datatype nemo:quantity nemo:quantity?
85  (SYSNAME    (name symbol?))
86  (ASGN       (name symbol?) (value number?) (rhs rhs?) )
87  (CONST      (name symbol?) (value number?))
88  (TSCOMP     (name symbol?) (initial rhs?)
89              (open (lambda (x) (or (symbol? x) (and (list? x) (every symbol? x) ))))
90              (transitions (lambda (x) (and (list? x) (every transition? x)))) 
91              (power integer?))
92  (PRIM       (name symbol?) (value identity))
93  (EXTERNAL   (local-name symbol?) (name symbol?) (namespace (lambda (x) (or (not x) (symbol? x)))))
94  (DISPATCH   (value procedure?))
95  (EXPORTS    (lst (lambda (x) (and (list? x) (every symbol? x)))))
96  (COMPONENT  (name symbol?) (type symbol?) (lst (lambda (x) (and (list? x) (every symbol? x)))))
97  )
98
99(define (nemo-intern sym)
100  (string->symbol (string-append "#" (symbol->string sym))))
101
102(define (lookup-def k lst . rest)
103  (let-optionals rest ((default #f))
104    (let ((v (alist-ref k lst)))
105      (if v (first v) default))))
106
107(define (make-nemo-core . alst)
108
109  ;; floating point precision (single or double; default is double)
110  (define  fptype (lookup-def 'fpprec alst 'double))
111  (define  fpvector-type
112    (lookup-def 'fpvector-type alst (if (equal? fptype 'single) 'f32vector 'f64vector)))
113  (define  fpvector? 
114    (lookup-def 'fpvector? alst (if (equal? fptype 'single) f32vector? f64vector?)))
115  (define  fpvector 
116    (lookup-def 'fpvector alst (if (equal? fptype 'single) f32vector f64vector)))
117  (define  fpvector-ref
118    (lookup-def 'fpvector-ref alst (if (equal? fptype 'single) f32vector-ref f64vector-ref)))
119  (define  fpvector-set!
120    (lookup-def 'fpvector-set! alst (if (equal? fptype 'single) f32vector-set! f64vector-set!)))
121
122
123  (define builtin-fns
124    `(+ - * / pow neg abs atan asin acos sin cos exp ln
125        sqrt tan cosh sinh tanh hypot gamma lgamma log10 log2 log1p ldexp cube
126        > < <= >= = and or round ceiling floor max min
127        fpvector-ref))
128
129  (define (add-primitives! env)
130    (for-each (lambda (n b fms rt) 
131                (let ((fb (extend-procedure b `((rt ,rt) (formals ,fms)))))
132                  (environment-extend! env n fb)))
133              builtin-fns
134              (list fp+ fp- fp* fp/ expt fpneg
135                    abs atan asin acos sin cos exp log sqrt tan 
136                    cosh sinh tanh hypot gamma lgamma log10 log2 log1p ldexp
137                    (lambda (x) (* x x x))
138                    fp> fp< fp<= fp>= fp=
139                    (lambda (x y) (and x y)) (lambda (x y) (or x y)) 
140                    round ceiling floor fpmax fpmin
141                    fpvector-ref)
142              `((,fptype ,fptype) (,fptype ,fptype) (,fptype ,fptype) (,fptype ,fptype) 
143                (,fptype ,fptype) (,fptype)
144                (,fptype) (,fptype) (,fptype) (,fptype) (,fptype) (,fptype) (,fptype)
145                (,fptype) (,fptype) (,fptype)
146                (,fptype) (,fptype) (,fptype) (,fptype) (,fptype) (,fptype) (,fptype)
147                (,fptype) (,fptype) (,fptype)
148                (,fptype) 
149                (bool bool) (bool bool) (bool bool) (bool bool) (bool bool) (bool bool) (bool bool) 
150                (,fptype) (,fptype) (,fptype) (,fptype ,fptype) (,fptype ,fptype) 
151                (,fpvector-type integer) )
152              `(,fptype ,fptype ,fptype ,fptype 
153                ,fptype ,fptype
154                ,fptype ,fptype ,fptype ,fptype ,fptype ,fptype ,fptype
155                ,fptype ,fptype ,fptype
156                ,fptype ,fptype ,fptype ,fptype ,fptype ,fptype ,fptype
157                ,fptype ,fptype ,fptype
158                ,fptype 
159                bool bool bool bool bool bool bool 
160                ,fptype ,fptype ,fptype ,fptype ,fptype 
161                ,fptype )
162              ))
163
164  (define (add-constants! env)
165    (for-each (lambda (n b) (environment-extend! env n b))
166              `(E 1/E E^2 E^PI/4 LOG2E LOG10E LN2 LN3 LNPI LN10 1/LN2 1/LN10 PI PI/2
167                  PI/4 1/PI 2/PI 2/SQRTPI SQRTPI PI^2 DEGREE SQRT2 1/SQRT2 SQRT3 SQRT5
168                  SQRT10 CUBERT2 CUBERT3 4THRT2 GAMMA1/2 GAMMA1/3 GAMMA2/3 PHI LNPHI
169                  1/LNPHI EULER E^EULER SIN1 COS1 ZETA3)
170              (list E 1/E E^2 E^PI/4 LOG2E LOG10E LN2 LN3 LNPI LN10 1/LN2 1/LN10 PI PI/2
171                 PI/4 1/PI 2/PI 2/SQRTPI SQRTPI PI^2 DEGREE SQRT2 1/SQRT2 SQRT3 SQRT5
172                 SQRT10 CUBERT2 CUBERT3 4THRT2 GAMMA1/2 GAMMA1/3 GAMMA2/3 PHI LNPHI
173                 1/LNPHI EULER E^EULER SIN1 COS1 ZETA3)))
174
175
176  (define (enumdeps expr)
177    (let loop ((expr expr) (ax (list)) (lbs (list)))
178      (match expr 
179             (('let bs e)  (let let-loop ((bs bs) (ax ax) (lbs lbs))
180                             (if (null? bs) (loop e ax lbs)
181                                 (let ((x   (first  (car bs)))
182                                       (ex  (second (car bs))))
183                                   (let* ((lbs1  (cons x lbs))
184                                          (ax1   (loop ex ax lbs)))
185                                     (let-loop (cdr bs) ax1 lbs1))))))
186
187             ((s . es)     (if (symbol? s) (fold (lambda (e ax) (loop e ax lbs)) ax es) 
188                               (fold (lambda (e ax) (loop e ax lbs)) ax (cons s es))))
189             (id           (if (and (symbol? id) (not (member id lbs))) (cons id ax) ax)))))
190
191
192  (define (binop-fold op lst)
193    (if (null? lst) lst
194        (match lst
195               ((x)   x)
196               ((x y) `(,op ,x ,y))
197               ((x y . rest) `(,op (,op ,x ,y) ,(binop-fold op rest)))
198               ((x . rest) `(,op ,x ,(binop-fold op rest))))))
199
200
201  ;; if argument is constant, return the negative of that constant,
202  ;; otherwise return `(neg ,expr)
203  (define (negate expr)
204    (if (number? expr) (- expr)
205        `(neg ,expr)))
206
207  ;; 1. make sure all constants in an expression are flonums
208  ;; 2. fold expressions like (+ a b c d) into nested binops
209  (define (make-normalize-expr arity-check)
210    (lambda (expr)
211      (let recur ((expr expr))
212        (match expr 
213               (('let bs e)         (let ((normalize-bnd  (lambda (x) `(,(first x) ,(recur (second x))))))
214                                      `(let ,(map normalize-bnd bs) ,(recur e))))
215               (('if c t e)         `(if ,(recur c) ,(recur t) ,(recur e))) 
216               (('+ . es)           (binop-fold '+ (map recur es)))
217               (('- . es)           (let ((es1 (map recur es)))
218                                      (binop-fold '+ (cons (car es1) (map negate (cdr es1))))))
219               (('* . es)           (binop-fold '* (map recur es)))
220               (('/ . es)           (binop-fold '/ (map recur es)))
221               (('fix n)            n)
222               ((s . es)            (begin
223                                      (arity-check s es)
224                                      (cons s (map recur es))))
225               (x                   (if (number? x) (exact->inexact x) x))))))
226
227  (define (make-base-env)
228    (let ((env (make-environment #t)))
229      (add-primitives! env)
230      (add-constants! env)
231      env))
232   
233  (define (make-const-env nemo-env)
234    (let ((env (make-base-env)))
235      (environment-for-each nemo-env
236        (lambda (sym en)
237          (cond  ((nemo:quantity? en) 
238                  (cases nemo:quantity en
239                         (CONST (name value) 
240                                (environment-extend! env name value))
241                         (PRIM (name value) 
242                               (environment-extend! env name value))))
243                 ((procedure? en)
244                  (environment-extend! env sym en)))))
245        env))
246
247  (define (system name)
248    (let ((env  (make-base-env))
249          (name (if (symbol? name) name (string->symbol name))))
250      (environment-extend! env (nemo-intern 'dispatch)  (DISPATCH nemo-dispatch))
251      (environment-extend! env (nemo-intern 'name)      (SYSNAME name))
252      (environment-extend! env (nemo-intern 'exports)   (EXPORTS (list)))
253      (environment-extend! env (nemo-intern 'toplevel)  (COMPONENT 'toplevel 'toplevel (list)))
254      env))
255
256  (define (add-external! nemo-env)
257    (lambda (sym typ)
258      (match typ
259             ('output
260              (begin
261                (if (not (environment-has-binding? nemo-env sym))
262                    (nemo:error 'add-external! ": exported quantity " sym " is not defined"))
263                (let* ((exports-sym   (nemo-intern 'exports))
264                       (exports       (environment-ref nemo-env exports-sym)))
265                  (cases nemo:quantity exports
266                         (EXPORTS (lst) (environment-set! nemo-env exports-sym (EXPORTS (cons sym lst))))
267                         (else  (nemo:error 'add-external! ": invalid exports entry " exports))))))
268             
269             (('input sym lsym ns)
270              (let ((lsym (or lsym sym)))
271               
272                (if (environment-has-binding? nemo-env lsym)
273                    (nemo:error 'add-import! ": import symbol " lsym " is already defined"))
274               
275                ((env-extend! nemo-env) lsym '(external) 'none `(name ,sym) `(namespace ,ns))))
276             
277             )))
278
279
280  (define (make-arity-check nemo-env)
281    (lambda (s args)
282      (let ((op (environment-ref nemo-env s)))
283        (if (extended-procedure? op)
284            (let* ((fd   (procedure-data op))
285                   (fms   (lookup-def 'formals fd)))
286              (if (not (= (length fms) (length args)))
287                  (nemo:error 'eval-expr "procedure " s 
288                              " called with incorrect number of arguments: "
289                              args)))))))
290
291  (define (env-extend! nemo-env)
292    (lambda (name type initial . alst)
293       (let* ((sym (if (symbol? name) name (string->symbol name)))
294              (arity-check (make-arity-check nemo-env))
295              (normalize-expr (make-normalize-expr arity-check)))
296        (if (environment-has-binding? nemo-env sym)
297            (nemo:error 'env-extend! ": quantity " sym " already defined")
298            (match type
299              (('external)  (let ((ns  (lookup-def 'namespace alst))
300                                  (external-name  (lookup-def 'name alst)))
301                              (environment-extend! nemo-env sym (EXTERNAL name external-name ns ))))
302                             
303              (('prim)    (let* ((rhs (lookup-def 'rhs alst))
304                                 (val (if (and rhs (procedure? initial) )
305                                          (extend-procedure initial rhs)
306                                          initial)))
307                            (environment-extend! nemo-env sym (PRIM name val ))))
308
309              (('const)   (begin
310                            (if (not (number? initial)) 
311                                (nemo:error 'env-extend! ": constant definitions require numeric value"))
312                            (environment-extend! nemo-env sym (CONST name initial))))
313
314              (('tscomp)  (begin
315                            (let ((power         (or (lookup-def 'power alst) 1))
316                                (transitions   (map (lambda (t) 
317                                                      `(-> ,(second t) ,(third t) ,(normalize-expr (fourth t ))))
318                                                    (or (alist-ref 'transitions alst) (list))))
319                                (open         (lookup-def 'open alst)))
320                            (if (null? transitions)
321                                (nemo:error 'env-extend! 
322                                               ": transition state complex definitions require a transition scheme"))
323                            (if (not open) 
324                                (nemo:error 'env-extend! ": state complex definitions require open state"))
325                            (if (not (integer? power))
326                                (nemo:error 'env-extend!
327                                               ": definition for state " sym
328                                               " requires an integer power (" power  " was given)"))
329                            (let ((en (TSCOMP name initial open transitions power)))
330                              (environment-extend! nemo-env sym en)))))
331
332              (('asgn)    (let ((rhs (lookup-def 'rhs alst)))
333                            (if (not (eq? initial 'none))
334                                (nemo:error 'env-extend! 
335                                                    ": state function definitions must have initial value of '(none)"))
336                            (if (not rhs) 
337                                (nemo:error 'env-extend! ": state function definitions require an equation"))
338                            (environment-extend! nemo-env sym (ASGN  name 0.0 (normalize-expr rhs)))))
339
340              (else       (begin
341                            (environment-extend! nemo-env sym `(,type (name ,sym) . ,initial))))
342              )))))
343
344  (define (infer nemo-env ftenv body)
345    (let recur ((expr body) (lb (list)))
346      (match expr 
347             (('if c t e)
348              (let ((ct (recur c lb))
349                    (tt (recur t lb))
350                    (et (recur e lb)))
351                (and ct tt et 
352                     (begin
353                       (if (not (equal? ct 'bool)) 
354                           (nemo:error 'infer "if condition type must be boolean"))
355                       (if (equal? tt et) tt
356                           (nemo:error 'infer "type mismatch in if statement: then = " tt
357                                      " else = " et))))))
358             (('let bs e)
359              (let* ((rlb (lambda (x) (recur x lb)))
360                     (tbs (map rlb (map second bs)))
361                     (lb1 (append (zip (map first bs) tbs) lb)))
362                (recur e lb1)))
363             
364             ((s . es)   
365              (let* ((f    (environment-ref nemo-env s))
366                     (lst  (procedure-data f)))
367                (and lst 
368                     (let ((rt   (lookup-def 'rt   lst))
369                           (fms  (lookup-def 'formals lst)))
370                       (and rt fms
371                            (begin
372                              (for-each (lambda (x ft)
373                                          (if (and (symbol? x) (not (environment-includes? ftenv x)))
374                                              (environment-extend! ftenv x ft)))
375                                        es fms)
376                              (let* ((rlb (lambda (x) (recur x lb)))
377                                     (ets (map rlb es)))
378                                (and (every identity ets)
379                                     (every (lambda (xt ft) (equal? xt ft)) ets fms)
380                                     rt))))))))
381             
382             (id    (cond ((symbol? id)     (or (lookup-def id lb) (environment-ref ftenv id)))
383                          ((number? id)     fptype)
384                          ((boolean? id)    'bool)
385                          ((fpvector? id)   fpvector-type)
386                          (else #f))))))
387   
388
389  (define (defun! nemo-env)
390    (define arity-check (make-arity-check nemo-env))
391    (define normalize-expr (make-normalize-expr arity-check))
392
393    (lambda (name formals body)
394        (let ((base-env (make-base-env))
395              (sym (if (symbol? name) name (string->symbol name))))
396          (letrec ((enumconsts
397                    (lambda (lb)
398                      (lambda (expr ax)
399                        (match expr 
400                               (('let bs e)  (let ((ec (enumconsts (append (map first bs) lb))))
401                                               (ec e (fold ec ax (map second bs)))))
402                               (('if . es)   (fold (enumconsts lb) ax es))
403                               ((s . es)     (if (symbol? s)  (cons s (fold (enumconsts lb) ax es)) ax))
404                               (s            (cond
405                                               ((and (symbol? s) (not (member s lb)) (environment-includes? base-env s))
406                                                (cons s ax) )
407                                               ((and (symbol? s) (not (member s lb)))
408                                                (nemo:error 'defun ": quantity " s " not defined"))
409                                               (else ax))))))))
410            (if (environment-has-binding? nemo-env sym)
411                (nemo:error 'defun! ": quantity " sym " already defined")
412                (let* ((body    (normalize-expr body))
413                       (consts  (delete-duplicates ((enumconsts formals) body (list))))
414                       (fc     `(lambda (base-env)
415                                  (let ,(map (lambda (v) `(,v (environment-ref base-env ',v))) consts)
416                                    (lambda ,formals ,body))))
417                       (f      ((eval fc) base-env)))
418                 
419                  (let* ((ftenv  (make-environment))
420                         (rt     (infer nemo-env ftenv body))
421                         (ftypes (filter-map (lambda (x) (and (environment-includes? ftenv x)
422                                                              (environment-ref ftenv x))) 
423                                             formals))
424                         (ef     (extend-procedure f `((rt ,rt) (formals ,ftypes) (vars ,formals)
425                                                       (body ,body) (consts ,consts)))))
426                  (environment-extend! nemo-env sym ef))))))))
427
428  (define (symbol-list? lst)
429    (and (list? lst) (every symbol? lst)))
430
431  (define (extended nemo-env)
432      (filter-map (lambda (sym) 
433                    (let ((x (environment-ref nemo-env sym)))
434                      (and (not (nemo:quantity? x)) (not (procedure? x)) 
435                           (match x 
436                                  (((? symbol-list?) ('name name) . rest)  `(,sym ,x))
437                                  (else #f)))))
438           (environment-symbols nemo-env)))
439                       
440
441  (define (extended-with-tag nemo-env tag)
442      (filter-map (lambda (sym) 
443                    (let ((x (environment-ref nemo-env sym)))
444                      (and (not (nemo:quantity? x)) (not (procedure? x)) 
445                           (match x 
446                                  (((? (lambda (x) (equal? x tag))) ('name name) . rest) 
447                                   `(,sym ,x))
448                                  (else #f)))))
449           (environment-symbols nemo-env)))
450                       
451
452  (define (components nemo-env)
453      (filter-map (lambda (sym) 
454                    (let ((x (environment-ref nemo-env sym)))
455                      (and (nemo:quantity? x)
456                           (cases nemo:quantity x
457                                  (COMPONENT (name type lst)  `(,name ,type ,sym))
458                                  (else #f)))))
459           (environment-symbols nemo-env)))
460
461
462  (define (component-symbols nemo-env sym)
463    (let ((x (environment-ref nemo-env sym)))
464      (and (nemo:quantity? x)
465           (cases nemo:quantity x
466                  (COMPONENT (name type lst)  lst)
467                  (else #f)))))
468
469
470  (define (component-exports nemo-env sym)
471    (let ((all-exports (cases nemo:quantity (environment-ref nemo-env (nemo-intern 'exports))
472                              (EXPORTS (lst)  lst))))
473      (let ((x  (environment-ref nemo-env sym)))
474        (and (nemo:quantity? x)
475             (cases nemo:quantity x
476                    (COMPONENT (name type lst) 
477                      (filter-map (lambda (x) ((lambda (x) (and x (car x))) (member x all-exports))) lst))
478                    (else #f))))))
479
480  (define (component-subcomps nemo-env sym)
481    (define (component-type x)
482      (cases nemo:quantity x
483             (COMPONENT (name type lst) type)
484             (else #f)))
485    (define (component-name x)
486      (cases nemo:quantity x
487             (COMPONENT (name type lst) name)
488             (else #f)))
489    (let ((en (environment-ref nemo-env sym)))
490      (and (nemo:quantity? en)
491           (cases nemo:quantity en
492                  (COMPONENT (name type lst) 
493                             (filter-map 
494                              (lambda (s) 
495                                (let ((x (environment-ref nemo-env s)))
496                                  (and (iscomp? x) `(,(component-type x) ,(component-name x) ,s)))) lst))
497                  (else #f)))))
498
499  (define (component-extend! nemo-env)
500    (lambda (comp-name sym)
501      (let ((x (environment-ref nemo-env comp-name)))
502        (if (nemo:quantity? x)
503            (cases nemo:quantity x
504                   (COMPONENT (name type lst) 
505                              (let ((en1 (COMPONENT name type (delete-duplicates (append lst (list sym))))))
506                                (environment-set! nemo-env comp-name en1)))
507                   (else (nemo:error 'component-extend! ": invalid component " comp-name)))
508            (nemo:error 'component-extend! ": invalid component " comp-name)))))
509
510
511  (define (exports nemo-env)
512    (cases nemo:quantity (environment-ref nemo-env (nemo-intern 'exports))
513           (EXPORTS (lst)  lst)))
514
515
516  (define (imports nemo-env)
517      (filter-map (lambda (sym) 
518                    (let ((x (environment-ref nemo-env sym)))
519                      (and (nemo:quantity? x)
520                           (cases nemo:quantity x
521                                  (EXTERNAL (local-name name namespace)  (list local-name name namespace))
522                                  (else #f)))))
523           (environment-symbols nemo-env)))
524
525
526  (define (consts nemo-env)
527      (filter-map (lambda (sym) 
528                    (let ((x (environment-ref nemo-env sym)))
529                      (and (nemo:quantity? x)
530                           (cases nemo:quantity x
531                                  (CONST (name value)  (list name value) )
532                                  (else #f)))))
533           (environment-symbols nemo-env)))
534
535
536
537  (define (states nemo-env)
538      (fold (lambda (sym ax) 
539                    (let ((x (environment-ref nemo-env sym)))
540                      (if (nemo:quantity? x)
541                           (cases nemo:quantity x
542                                  (TSCOMP (name initial open transitions power)
543                                          (let ((ss (delete-duplicates (append (map second transitions) 
544                                                                               (map third transitions)))))
545                                            (append ss ax)))
546                                  (else ax))
547                           ax)))
548           (list) (environment-symbols nemo-env)))
549
550
551  (define (stcomps nemo-env)
552      (fold (lambda (sym ax) 
553                    (let ((x (environment-ref nemo-env sym)))
554                      (if (nemo:quantity? x)
555                           (cases nemo:quantity x
556                                  (TSCOMP (name initial open transitions power)
557                                          (cons name ax))
558                                  (else ax))
559                           ax)))
560           (list) (environment-symbols nemo-env)))
561
562
563  (define (asgns nemo-env)
564      (filter-map (lambda (sym) 
565                    (let ((x (environment-ref nemo-env sym)))
566                      (and (nemo:quantity? x)
567                           (cases nemo:quantity x
568                                  (ASGN (name value rhs) name)
569                                  (else #f)))))
570           (environment-symbols nemo-env)))
571
572
573  (define (defuns nemo-env)
574      (filter-map (lambda (sym) 
575                    (let ((x (environment-ref nemo-env sym)))
576                      (and (procedure? x) (not (member sym builtin-fns)) (list sym x))))
577           (environment-symbols nemo-env)))
578
579  (define (toplevel nemo-env)
580    (cases nemo:quantity (environment-ref nemo-env (nemo-intern 'toplevel))
581           (COMPONENT (name type lst) `(,type ,lst))))
582                                       
583  (define (exam nemo-env)
584    (lambda (name)
585      (let ((sym (if (symbol? name) name (string->symbol name)))
586            (out (current-output-port)))
587        (if (not (environment-has-binding? nemo-env sym))
588            (nemo:error 'exam ": quantity " sym " is not defined")
589            (let ((x (environment-ref nemo-env sym)))
590              (cases nemo:quantity x
591                     (PRIM  (name value)
592                            (begin
593                              (fprintf out "~a: compiled cnemo primitive\n" name)
594                              (fprintf out "    value: ~a\n" value)))
595
596                     (TSCOMP (name initial open transitions power)
597                             (begin
598                               (fprintf out "~a: transition state complex\n" name)
599                               (fprintf out "    initial value: ~a\n" initial)))
600                     
601                     (CONST    (name value)
602                               (begin
603                                 (fprintf out "~a: constant\n" name)
604                                 (fprintf out "    value: ~a\n" value)))
605                     
606                     (ASGN     (name value rhs)
607                               (begin
608                                 (fprintf out "~a: state function\n" name)
609                                 (fprintf out "    value: ~a\n" value)))
610
611                     (else (nemo:error 'exam name ": unknown type of quantity"))))))))
612 
613
614  (define (eval-const nemo-env expr)
615    (let* ((arity-check (make-arity-check nemo-env))
616           (normalize-expr (make-normalize-expr arity-check)))
617      (let ((expr1 (normalize-expr expr)))
618        (exact->inexact (eval expr1  (make-const-env nemo-env))))))
619
620
621  (define (iscomp? x)
622    (cond ((nemo:quantity? x)
623           (cases nemo:quantity x
624                  (COMPONENT  (name type lst)  #t)
625                  (else #f)))
626          (else #f)))
627
628  (define (isdep? x)
629    (cond ((nemo:quantity? x)
630           (cases nemo:quantity x
631                  (ASGN  (name value rhs)  #t)
632                  (else #f)))
633          ((and (list? x) (every pair? (cdr x)))  (alist-ref 'dep?  (cdr x)))
634          (else #f)))
635
636
637  (define (isstate? x)
638    (and (nemo:quantity? x)
639         (cases nemo:quantity x
640                (TSCOMP (name initial open transitions)  #t)
641                (else #f))))
642
643
644  (define (qrhs x)
645    (and (nemo:quantity? x)
646         (cases nemo:quantity x
647                (TSCOMP (name initial open transitions) 
648                        (begin
649                          (map cadddr transitions)))
650                (ASGN  (name value rhs)  rhs)
651                (else #f))))
652
653           
654  (define (sysname nemo-env)
655    (cases nemo:quantity (environment-ref nemo-env (nemo-intern 'name))
656           (SYSNAME (name)  name)))
657
658
659  ;; create equation dependency graph
660  (define (make-eqng nemo-env)
661    (let* ((sysname    (sysname nemo-env))
662           (g          (make-digraph sysname (string-append (symbol->string sysname) 
663                                                            " equation dependency graph")))
664           (add-node!  (g 'add-node!))
665           (add-edge!  (g 'add-edge!))
666           (nemo-list  (filter (lambda (sym) (let ((x (environment-ref nemo-env sym)))
667                                               (or (isstate? x) (isdep? x))))
668                               (environment-symbols nemo-env)))
669           (nemo-ids      (list-tabulate (length nemo-list) identity))
670           (name->id-map  (zip nemo-list nemo-ids)))
671      (let-values (((state-list asgn-list) 
672                    (partition (lambda (sym) (isstate? (environment-ref nemo-env sym)))
673                               nemo-list)))
674                 
675         ;; insert equations in the dependency graph
676         (for-each (lambda (i n) (add-node! i n)) nemo-ids nemo-list)
677         ;; create dependency edges in the graph
678         (for-each (lambda (e) 
679                     (match e ((ni . nj) (begin
680                                           (let ((i (car (alist-ref ni name->id-map)))
681                                                 (j (car (alist-ref nj name->id-map))))
682                                             (add-edge! (list i j (format "~A=>~A" ni nj))))))
683                            (else (nemo:error 'make-eqng ": invalid edge " e))))
684                   (fold (lambda (qsym ax) 
685                           (let* ((q   (environment-ref nemo-env qsym))
686                                  (rhs (qrhs q)))
687                             (if rhs 
688                                 (let* ((deps (filter (if (isstate? q)
689                                                          (lambda (sym) 
690                                                            (and (let ((x (environment-ref nemo-env sym)))
691                                                                   (and (isdep? x) (not (eq? sym qsym))))))
692                                                          (lambda (sym) 
693                                                            (and (let ((x (environment-ref nemo-env sym)))
694                                                                   (isdep? x)))))
695                                                      (enumdeps rhs)))
696                                          (edges (map (lambda (d) (cons d qsym)) deps)))
697                                   (if edges (append edges ax) ax))
698                                 ax)))
699                         (list) nemo-list))
700         (let ((cycles (graph-cycles-fold g (lambda (cycle ax) (cons cycle ax)) (list))))
701           (if (null? cycles) (list state-list asgn-list g)
702               (nemo:error 'make-eqng ": equation cycle detected: " (car cycles)))))))
703
704
705  ;; given a graph, create a partial ordering based on BFS distance from root
706  (define (graph->bfs-dist-poset g)
707    (define node-info (g 'node-info))
708
709    (let-values (((dists dmax) (graph-bfs-dist g ((g 'roots)))))
710      (let loop ((poset  (make-vector (fx+ 1 dmax) (list)))
711                 (i      (fx- (s32vector-length dists) 1)))
712        (if (fx>= i 0)
713            (let* ((c     (s32vector-ref dists i))
714                   (info  (node-info i)))
715              (vector-set! poset c (cons (cons i info) (vector-ref poset c)))
716              (loop poset (fx- i 1)))
717            (begin
718              poset)))))
719
720
721  (define (make-eval-poset nemo-env eqposet)
722    (vector-map 
723       (lambda (i lst) 
724         (filter-map (lambda (id+sym)
725                       (let* ((sym  (cdr id+sym))
726                              (x    (environment-ref nemo-env sym)))
727                         (and (nemo:quantity? x)
728                              (cases nemo:quantity x
729                                     (TSCOMP (name initial open transitions) 
730                                             (let ((rs (map cadddr transitions)))
731                                               (list 'ts sym rs)))
732                                     (ASGN  (name value rhs)
733                                            (list 'a sym rhs))
734                                     (else nemo:error 'make-eval-poset
735                                           ": invalid quantity in equation poset: " sym)))))
736                     lst))
737       eqposet))
738
739  (define (eval-expr env)
740    (lambda (expr)
741      (let ((val (match expr
742                        (('if c t f) 
743                         (let ((ee (eval-expr env)))
744                           (condition-case
745                            (if (ee c) (ee t) (ee f))
746                            [var () 
747                               (nemo:error 'eval-expr " exception in " expr ": \n"
748                                          (lambda () (print-error-message var)))])))
749
750                        ((s . es)   
751                         (condition-case 
752                          (let ((op   (environment-ref env s))
753                                (args (map (eval-expr env) es)))
754                            (if (extended-procedure? op)
755                                (let* ((fd   (procedure-data op))
756                                       (vs  (lookup-def 'vars fd)))
757                                  (if (not (= (length vs) (length args)))
758                                      (nemo:error 'eval-expr "procedure " s 
759                                                  " called with incorrect number of arguments"))))
760                            (apply op args))
761                          [var () 
762                               (nemo:error 'eval-expr " exception in " expr ": \n"
763                                          (lambda () (print-error-message var)))]))
764                       
765                        (s                 
766                         (cond ((symbol? s) (environment-ref env s))
767                               ((number? s) s)
768                               (else (nemo:error 'eval-expr "unknown expression " s)))))))
769        val)))
770
771
772  (define (depgraph nemo-env)
773    (match-let (((state-list asgn-list g)  (make-eqng nemo-env))) g))
774
775  (define (depgraph* nemo-env)
776    (match-let (((state-list asgn-list g)  (make-eqng nemo-env))) 
777               (list state-list asgn-list g)))
778
779
780  ;; Dispatcher
781  (define (nemo-dispatch selector)
782    (case selector
783      ((add-external!)     add-external!)
784      ((defun!)            defun!)
785      ((depgraph)          depgraph)
786      ((depgraph*)         depgraph*)
787      ((depgraph->bfs-dist-poset)  graph->bfs-dist-poset)
788      ((eval-const)          eval-const)
789      ((env-extend!)         env-extend!)
790      ((exam)                exam)
791      ((make-const-env)      make-const-env)
792      ((system)              system)
793      ((sysname)             sysname)
794      ((asgns)               asgns)
795      ((states)              states)
796      ((stcomps)             stcomps)
797      ((defuns)              defuns)
798      ((consts)              consts)
799      ((exports)             exports)
800      ((imports)             imports)
801      ((toplevel)            toplevel)
802      ((components)          components)
803      ((component-symbols)   component-symbols)
804      ((component-exports)   component-exports)
805      ((component-subcomps)  component-subcomps)
806      ((component-extend!)   component-extend!)
807      ((extended)            extended)
808      ((extended-with-tag)   extended-with-tag)
809      (else
810       (nemo:error 'selector ": unknown message " selector " sent to an nemo-core object")))) 
811
812  nemo-dispatch)
813
814(define nemo:env-copy environment-copy)
815
816(define qcounter 0)
817
818(define (qname prefix)
819  (let ((v qcounter))
820    (set! qcounter (+ 1 qcounter))
821    (string->symbol (string-append (->string prefix) (number->string v)))))
822
823(define (eval-nemo-system-decls nemo-core name sys declarations)
824  (define (eval-const x) (and x ((nemo-core 'eval-const) sys x)))
825  (let loop ((ds declarations) (qs (list)) (top #t))
826    (if (null? ds) 
827        (let ((qs (reverse qs)))
828          (if top (let* ((top-syms   ((nemo-core 'component-symbols ) sys (nemo-intern 'toplevel)))
829                         (top-syms1  (append qs top-syms)))
830                    (environment-set! sys (nemo-intern 'toplevel) (COMPONENT 'toplevel 'toplevel top-syms1))))
831          qs)
832        (let ((decl (car ds)))
833          (let ((qs1  (match decl
834                             ;; imported quantities
835                             (('input . lst) 
836                              (cond ((every (lambda (x) (or (symbol? x) (list? x))) lst)
837                                     (fold (lambda (x ax) 
838                                             (match x
839                                                    ((? symbol?) 
840                                                     (((nemo-core 'add-external!) sys) x `(input ,x ,x #f))
841                                                     (cons x ax))
842                                                    ((id1 'as x1) 
843                                                     (((nemo-core 'add-external!) sys) x `(input ,id1 ,x1 #f))
844                                                     (cons x1 ax))
845                                                    ((id1 'from n1) 
846                                                     (((nemo-core 'add-external!) sys) x `(input ,id1 ,id1 ,n1))
847                                                     (cons id1 ax))
848                                                    ((id1 'as x1 'from n1) 
849                                                     (((nemo-core 'add-external!) sys) x `(input ,id1 ,x1 ,n1))
850                                                     (cons x1 ax))
851                                                    ))
852                                           qs lst))
853                                    (else (nemo:error 'eval-nemo-system-decls 
854                                                      "import statement must be of the form: "
855                                                      "input id1 [as x1] ... "))))
856
857                            ;; exported quantities
858                            (('output . lst) 
859                             (cond ((every symbol? lst) 
860                                    (for-each (lambda (x) (((nemo-core 'add-external!) sys) x 'output)) lst)
861                                    qs)
862                                   (else (nemo:error 'eval-nemo-system-decls 
863                                                        "export statement must be of the form: "
864                                                        "output id1 ... "))))
865
866                            ;; constant during integration
867                            (('const id '= expr)
868                             (cond ((and (symbol? id) (or (number? expr) (list? expr)))
869                                    (let ((val (eval-const expr)))
870                                      (((nemo-core 'env-extend!) sys) id '(const) val)
871                                      (cons id qs)))
872                                   (else (nemo:error 'eval-nemo-system-decls 
873                                                        "constant declarations must be of the form: "
874                                                        "const id = expr")))) 
875
876                            ;; state transition complex
877                            (('state-complex (id . alst) )
878                             (cond ((and (symbol? id) (list? alst))
879                                    (let ((initial (eval-const (lookup-def 'initial alst)))
880                                          (power   (eval-const (lookup-def 'power alst))))
881                                      (apply ((nemo-core 'env-extend!) sys) 
882                                             (cons* id '(tscomp) initial `(power ,power) alst)))
883                                    (cons id qs))
884                                   (else (nemo:error 'eval-nemo-system-decls 
885                                                        "state complex declarations must be of the form: "
886                                                        "state-complex (id ...)"))))
887                           
888                            ;; algebraic assignment
889                            ((id '= expr) 
890                             (cond ((and (symbol? id) (or (symbol? expr) (number? expr) (list? expr)))
891                                    (((nemo-core 'env-extend!) sys) id '(asgn) 'none `(rhs ,expr))
892                                    (cons id qs))
893                                   (else (nemo:error 'eval-nemo-system-decls 
894                                                        "algebraic declarations must be of the form: "
895                                                        "id = expr"))))
896                           
897                            ;; user-defined function
898                            (('defun id idlist expr) 
899                             (cond ((and (symbol? id) (list? idlist) (every symbol? idlist) (list? expr))
900                                    (((nemo-core 'defun!) sys) id idlist expr)
901                                    (cons id qs))
902                                   (else (nemo:error 'eval-nemo-system-decls
903                                                        "function declarations must be of the form: "
904                                                        "defun id (arg1 arg2 ...) expr"))))
905                           
906                            ;; compiled primitives
907                            (('prim id value) 
908                             (cond ((symbol? id)  (((nemo-core 'env-extend!) sys) id '(prim) value))
909                                   (else (nemo:error 'eval-nemo-system-decls 
910                                                        "prim declarations must be of the form: "
911                                                        "prim id value"))))
912                           
913                            (('component ('type typ) ('name name) . lst) 
914                             (let* ((cqs   (loop lst (list) #f))
915                                    (sym   (qname "comp"))
916                                    (comp  (COMPONENT name typ cqs)))
917                               (environment-set! sys sym comp)
918                               (cons sym qs)))
919
920                             
921                            (('component ('type typ)  . lst) 
922                             (let* ((sym   (qname "comp"))
923                                    (cqs   (loop lst (list) #f))
924                                    (comp  (COMPONENT sym typ cqs)))
925                               (environment-set! sys sym comp)
926                               (cons sym qs)))
927                             
928                           
929                            (('sysname name)  (if (symbol? name)
930                                                  (environment-set! sys (nemo-intern 'name) (SYSNAME name))
931                                                  (nemo:error 'eval-nemo-system-decls
932                                                                 "system name must be a symbol")))
933                           
934                            (('const . _)
935                             (nemo:error 'eval-nemo-system-decls "constant declarations must be of the form: "
936                                            "const id = expr"))
937                           
938                            ((id '= . _) 
939                             (nemo:error 'eval-nemo-system-decls "algebraic equations must be of the form: "
940                                            "id = expr")) 
941                           
942                            (('state-complex . _)
943                             (nemo:error 'eval-nemo-system-decls 
944                                            "state complex declarations must be of the form: "
945                                            "state-complex (id ...)"))
946                           
947                            (('defun . _) 
948                             (nemo:error 'eval-nemo-system-decls "function declarations must be of the form: "
949                                            "defun id (arg1 arg2 ...) expr"))
950                           
951                            (('prim . _) 
952                             (nemo:error 'eval-nemo-system-decls "prim declarations must be of the form: "
953                                            "prim id value"))
954                           
955                            (('component . _) 
956                             (nemo:error 'eval-nemo-system-decls "invalid component: " decl))
957                           
958                            (('sysname . _) 
959                             (nemo:error 'eval-nemo-system-decls "system name must be of the form (sysname name)"))
960                           
961                            ;; anything that doesn't match is possibly
962                            ;; declarations recognized by the nemo extension
963                            ;; modules
964                            ((tag  . lst)
965                             (if (symbol? tag)
966                                 (match-let (((typ name alst) 
967                                              (let loop ((lst lst) (ax (list tag)))
968                                                (if (null? lst)
969                                                    (list (list (car (reverse ax))) #f (cdr (reverse ax)))
970                                                    (begin
971                                                      (match lst
972                                                             (((? symbol?) . rest) 
973                                                              (loop (cdr lst) (cons (car lst) ax)))
974                                                             (((x . rest)) 
975                                                              (if (and (symbol? x) (every list? rest))
976                                                                  (list (reverse ax) x rest)
977                                                                  (list (reverse ax) #f lst)))
978                                                             (else  (list (reverse ax) #f lst))))))))
979
980                                             (let ((name (or name (qname tag))))
981                                               (((nemo-core 'env-extend!) sys) name  typ alst)
982                                               (cons name qs)))
983                                 (nemo:error 'eval-nemo-system-decls "extended declarations must be of the form: "
984                                                "declaration (name (properties ...)")))
985                            )))
986                           
987                           
988                     (loop (cdr ds) qs1 top)))
989        ))
990  sys)
Note: See TracBrowser for help on using the repository browser.