source: project/release/3/oru/core.scm @ 11638

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

Some bugs fixed in processing defun declarations.

File size: 31.5 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 oru-core)
36
37(declare (export make-oru-core oru:error oru:warning 
38                 oru:env-copy oru-intern oru:quantity?
39                 eval-oru-system-decls
40                 TSCOMP ASGN CONST PRIM))
41
42;--------------------
43;  Message routines
44;
45;
46
47(define (oru: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) "oru warning"))
54        (begin (display (car objs) port)
55               (display " " port)
56               (loop port (cdr objs))))))
57
58(define (oru: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 'oru (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 oru:quantity oru: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  (type symbol?) (lst (lambda (x) (and (list? x) (every symbol? x)))))
97  )
98
99(define (oru-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-oru-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 ax)
177    (match expr 
178           ((s . es)   (if (symbol? s) (fold enumdeps ax es) (fold enumdeps ax (cons s es))))
179           (id         (if (symbol? id) (cons id ax) ax))))
180
181
182  (define (binop-fold op lst)
183    (if (null? lst) lst
184        (match lst
185               ((x)   x)
186               ((x y) `(,op ,x ,y))
187               ((x y . rest) `(,op (,op ,x ,y) ,(binop-fold op rest)))
188               ((x . rest) `(,op ,x ,(binop-fold op rest))))))
189
190
191  ;; if argument is constant, return the negative of that constant,
192  ;; otherwise return `(neg ,expr)
193  (define (negate expr)
194    (if (number? expr) (- expr)
195        `(neg ,expr)))
196
197  ;; 1. make sure all constants in an expression are flonums
198  ;; 2. fold expressions like (+ a b c d) into nested binops
199  (define (normalize-expr expr)
200    (define (normalize-bnd x)
201      `(,(first x) ,(normalize-expr (second x))))
202    (match expr 
203           (('let bs e)         `(let ,(map normalize-bnd bs) ,(normalize-expr e)))
204           (('if c t e)         `(if ,(normalize-expr c) ,(normalize-expr t) ,(normalize-expr e))) 
205           (('+ . es)           (binop-fold '+ (map normalize-expr es)))
206           (('- . es)           (let ((es1 (map normalize-expr es)))
207                                  (binop-fold '+ (cons (car es1) (map negate (cdr es1))))))
208           (('* . es)           (binop-fold '* (map normalize-expr es)))
209           (('/ . es)           (binop-fold '/ (map normalize-expr es)))
210           (('fix n)            n)
211           ((s . es)            (cons s (map normalize-expr es)))
212           (x                   (if (number? x) (exact->inexact x) x))))
213
214  (define (make-base-env)
215    (let ((env (make-environment #t)))
216      (add-primitives! env)
217      (add-constants! env)
218      env))
219   
220  (define (make-const-env oru-env)
221    (let ((env (make-base-env)))
222      (environment-for-each oru-env
223        (lambda (sym en)
224          (cond  ((oru:quantity? en) 
225                  (cases oru:quantity en
226                         (CONST (name value) 
227                                (environment-extend! env name value))
228                         (PRIM (name value) 
229                               (environment-extend! env name value))))
230                 ((procedure? en)
231                  (environment-extend! env sym en)))))
232        env))
233
234  (define (system name)
235    (let ((env  (make-base-env))
236          (name (if (symbol? name) name (string->symbol name))))
237      (environment-extend! env (oru-intern 'dispatch)  (DISPATCH oru-dispatch))
238      (environment-extend! env (oru-intern 'name)      (SYSNAME name))
239      (environment-extend! env (oru-intern 'exports)   (EXPORTS (list)))
240      env))
241
242  (define (add-external! oru-env)
243    (lambda (sym typ)
244      (match typ
245             ('output
246              (begin
247                (if (not (environment-has-binding? oru-env sym))
248                    (oru:error 'add-external! ": exported quantity " sym " is not defined"))
249                (let* ((exports-sym   (oru-intern 'exports))
250                       (exports       (environment-ref oru-env exports-sym)))
251                  (cases oru:quantity exports
252                         (EXPORTS (lst) (environment-set! oru-env exports-sym (EXPORTS (cons sym lst))))
253                         (else  (oru:error 'add-external! ": invalid exports entry " exports))))))
254             
255             (('input sym lsym ns)
256              (let ((lsym (or lsym sym)))
257               
258                (if (environment-has-binding? oru-env lsym)
259                    (oru:error 'add-import! ": import symbol " lsym " is already defined"))
260               
261                ((env-extend! oru-env) lsym '(external) 'none `(name ,sym) `(namespace ,ns))))
262             
263             )))
264
265  (define (env-extend! oru-env)
266    (lambda (name type initial . alst)
267       (let ((sym (if (symbol? name) name (string->symbol name))))
268        (if (environment-has-binding? oru-env sym)
269            (oru:error 'env-extend! ": quantity " sym " already defined")
270            (match type
271              (('external)  (let ((ns  (lookup-def 'namespace alst))
272                                  (external-name  (lookup-def 'name alst)))
273                              (environment-extend! oru-env sym (EXTERNAL name external-name ns ))))
274                             
275              (('prim)    (let* ((rhs (lookup-def 'rhs alst))
276                                 (val (if (and rhs (procedure? initial) )
277                                          (extend-procedure initial rhs)
278                                          initial)))
279                            (environment-extend! oru-env sym (PRIM name val ))))
280
281              (('const)   (begin
282                            (if (not (number? initial)) 
283                                (oru:error 'env-extend! ": constant definitions require numeric value"))
284                            (environment-extend! oru-env sym (CONST name initial))))
285
286              (('tscomp)  (let ((power        (or (lookup-def 'power alst) 1))
287                                (transitions  (or (alist-ref 'transitions alst) (list)))
288                                (open         (lookup-def 'open alst)))
289                            (if (null? transitions)
290                                (oru:error 'env-extend! 
291                                               ": transition state complex definitions require a transition scheme"))
292                            (if (not open) 
293                                (oru:error 'env-extend! ": state complex definitions require open state"))
294                            (if (not (integer? power))
295                                (oru:error 'env-extend!
296                                               ": definition for state " sym
297                                               " requires an integer power (" power  " was given)"))
298                            (let ((en (TSCOMP name initial open transitions power)))
299                              (environment-extend! oru-env sym en))))
300
301              (('asgn)    (let ((rhs (lookup-def 'rhs alst)))
302                            (if (not (eq? initial 'none))
303                                (oru:error 'env-extend! 
304                                                    ": state function definitions must have initial value of '(none)"))
305                            (if (not rhs) 
306                                (oru:error 'env-extend! ": state function definitions require an equation"))
307                            (environment-extend! oru-env sym (ASGN  name 0.0 (normalize-expr rhs)))))
308
309              (else       (begin
310                            (environment-extend! oru-env sym `(,type (name ,sym) . ,initial))))
311              )))))
312
313  (define (infer oru-env ftenv body)
314    (let recur ((expr body) (lb (list)))
315      (match expr 
316             (('if c t e)
317              (let ((ct (recur c lb))
318                    (tt (recur t lb))
319                    (et (recur e lb)))
320                (and ct tt et 
321                     (begin
322                       (if (not (equal? ct 'bool)) 
323                           (oru:error 'infer "if condition type must be boolean"))
324                       (if (equal? tt et) tt
325                           (oru:error 'infer "type mismatch in if statement: then = " tt
326                                      " else = " et))))))
327             (('let bs e)
328              (let* ((rlb (lambda (x) (recur x lb)))
329                     (tbs (map rlb (map second bs)))
330                     (lb1 (append (zip (map first bs) tbs) lb)))
331                (recur e lb1)))
332             
333             ((s . es)   
334              (let* ((f    (environment-ref oru-env s))
335                     (lst  (procedure-data f)))
336                (and lst 
337                     (let ((rt   (lookup-def 'rt lst))
338                           (fms  (lookup-def 'formals lst)))
339                       (and rt fms
340                            (begin
341                              (for-each (lambda (x ft)
342                                          (if (and (symbol? x) (not (environment-includes? ftenv x)))
343                                              (environment-extend! ftenv x ft)))
344                                        es fms)
345                              (let* ((rlb (lambda (x) (recur x lb)))
346                                     (ets (map rlb es)))
347                                (and (every identity ets)
348                                     (every (lambda (xt ft) (equal? xt ft)) ets fms)
349                                     rt))))))))
350             
351             (id    (cond ((symbol? id)     (or (lookup-def id lb) (environment-ref ftenv id)))
352                          ((number? id)     fptype)
353                          ((boolean? id)    'bool)
354                          ((fpvector? id)   fpvector-type)
355                          (else #f))))))
356   
357
358  (define (defun! oru-env)
359    (lambda (name formals body)
360        (let ((const-env (make-const-env oru-env))
361              (sym (if (symbol? name) name (string->symbol name))))
362          (letrec ((enumconsts
363                    (lambda (lb)
364                      (lambda (expr ax)
365                        (match expr 
366                               (('let bs e)  (let ((ec (enumconsts (append (map first bs) lb))))
367                                               (ec e (fold ec ax (map second bs)))))
368                               (('if . es)   (fold (enumconsts lb) ax es))
369                               ((s . es)     (if (symbol? s)  (cons s (fold (enumconsts lb) ax es)) ax))
370                               (s            (if (and (symbol? s) (not (member s lb)) 
371                                                      (environment-includes? const-env s))
372                                                 (cons s ax) ax)))))))
373            (if (environment-has-binding? oru-env sym)
374                (oru:error 'defun! ": quantity " sym " already defined")
375                (let* ((body    (normalize-expr body))
376                       (consts  (delete-duplicates ((enumconsts formals) body (list))))
377                       (fc     `(lambda (const-env)
378                                  (let ,(map (lambda (v) `(,v (environment-ref const-env ',v))) consts)
379                                    (lambda ,formals ,body))))
380                       (f      ((eval fc) const-env)))
381                 
382                  (let* ((ftenv  (make-environment))
383                         (rt     (infer oru-env ftenv body))
384                         (ftypes (filter-map (lambda (x) (and (environment-includes? ftenv x)
385                                                              (environment-ref ftenv x))) 
386                                             formals))
387                         (ef     (extend-procedure f `((rt ,rt) (formals ,ftypes) (vars ,formals)
388                                                       (body ,body) (consts ,consts)))))
389                  (environment-extend! oru-env sym ef))))))))
390
391  (define (symbol-list? lst)
392    (and (list? lst) (every symbol? lst)))
393
394  (define (extended oru-env)
395      (filter-map (lambda (sym) 
396                    (let ((x (environment-ref oru-env sym)))
397                      (and (not (oru:quantity? x)) (not (procedure? x)) 
398                           (match x 
399                                  (((? symbol-list?) ('name name) . rest)  `(,sym ,x))
400                                  (else #f)))))
401           (environment-symbols oru-env)))
402                       
403
404  (define (extended-with-tag oru-env tag)
405      (filter-map (lambda (sym) 
406                    (let ((x (environment-ref oru-env sym)))
407                      (and (not (oru:quantity? x)) (not (procedure? x)) 
408                           (match x 
409                                  (((? (lambda (x) (equal? x tag))) ('name name) . rest) 
410                                   `(,sym ,x))
411                                  (else #f)))))
412           (environment-symbols oru-env)))
413                       
414
415  (define (components oru-env)
416      (filter-map (lambda (sym) 
417                    (let ((x (environment-ref oru-env sym)))
418                      (and (oru:quantity? x)
419                           (cases oru:quantity x
420                                  (COMPONENT (type lst)  `(,type ,sym))
421                                  (else #f)))))
422           (environment-symbols oru-env)))
423
424
425  (define (component-symbols oru-env sym)
426    (let ((x (environment-ref oru-env sym)))
427      (and (oru:quantity? x)
428           (cases oru:quantity x
429                  (COMPONENT (type lst)  lst)
430                  (else #f)))))
431
432
433  (define (component-exports oru-env sym)
434    (let ((all-exports (cases oru:quantity (environment-ref oru-env (oru-intern 'exports))
435                              (EXPORTS (lst)  lst))))
436      (let ((x (environment-ref oru-env sym)))
437        (and (oru:quantity? x)
438             (cases oru:quantity x
439                    (COMPONENT (type lst) 
440                      (filter-map (lambda (x) ((lambda (x) (and x (car x))) (member x all-exports))) lst))
441                    (else #f))))))
442
443  (define (component-subcomps oru-env sym)
444    (define (component-type x)
445      (cases oru:quantity x
446             (COMPONENT (type lst) type)
447             (else #f)))
448    (let ((x (environment-ref oru-env sym)))
449      (and (oru:quantity? x)
450           (cases oru:quantity x
451                  (COMPONENT (type lst) 
452                             (filter-map (lambda (s) (let ((x (environment-ref oru-env s)))
453                                                       (and (iscomp? x) `(,(component-type x) ,s)))) lst))
454                  (else #f)))))
455
456  (define (component-extend! oru-env)
457    (lambda (comp sym)
458      (let ((x (environment-ref oru-env comp)))
459        (if (oru:quantity? x)
460            (cases oru:quantity x
461                   (COMPONENT (type lst) 
462                              (let ((en1 (COMPONENT type (cons sym lst))))
463                                (environment-set! oru-env comp en1)))
464                   (else (oru:error 'component-extend! ": invalid component " comp)))
465            (oru:error 'component-extend! ": invalid component " comp)))))
466
467
468  (define (exports oru-env)
469    (cases oru:quantity (environment-ref oru-env (oru-intern 'exports))
470           (EXPORTS (lst)  lst)))
471
472
473  (define (imports oru-env)
474      (filter-map (lambda (sym) 
475                    (let ((x (environment-ref oru-env sym)))
476                      (and (oru:quantity? x)
477                           (cases oru:quantity x
478                                  (EXTERNAL (local-name name namespace)  (list local-name name namespace))
479                                  (else #f)))))
480           (environment-symbols oru-env)))
481
482
483  (define (consts oru-env)
484      (filter-map (lambda (sym) 
485                    (let ((x (environment-ref oru-env sym)))
486                      (and (oru:quantity? x)
487                           (cases oru:quantity x
488                                  (CONST (name value)  (list name value) )
489                                  (else #f)))))
490           (environment-symbols oru-env)))
491
492
493  (define (states oru-env)
494      (fold (lambda (sym ax) 
495                    (let ((x (environment-ref oru-env sym)))
496                      (if (oru:quantity? x)
497                           (cases oru:quantity x
498                                  (TSCOMP (name initial open transitions power)
499                                          (let ((ss (delete-duplicates (append (map second transitions) 
500                                                                               (map third transitions)))))
501                                            (append ss ax)))
502                                  (else ax))
503                           ax)))
504           (list) (environment-symbols oru-env)))
505
506
507  (define (stcomps oru-env)
508      (fold (lambda (sym ax) 
509                    (let ((x (environment-ref oru-env sym)))
510                      (if (oru:quantity? x)
511                           (cases oru:quantity x
512                                  (TSCOMP (name initial open transitions power)
513                                          (cons name ax))
514                                  (else ax))
515                           ax)))
516           (list) (environment-symbols oru-env)))
517
518
519  (define (asgns oru-env)
520      (filter-map (lambda (sym) 
521                    (let ((x (environment-ref oru-env sym)))
522                      (and (oru:quantity? x)
523                           (cases oru:quantity x
524                                  (ASGN (name value rhs) name)
525                                  (else #f)))))
526           (environment-symbols oru-env)))
527
528
529  (define (defuns oru-env)
530      (filter-map (lambda (sym) 
531                    (let ((x (environment-ref oru-env sym)))
532                      (and (procedure? x) (not (member sym builtin-fns)) (list sym x))))
533           (environment-symbols oru-env)))
534
535
536                                       
537  (define (exam oru-env)
538    (lambda (name)
539      (let ((sym (if (symbol? name) name (string->symbol name)))
540            (out (current-output-port)))
541        (if (not (environment-has-binding? oru-env sym))
542            (oru:error 'exam ": quantity " sym " is not defined")
543            (let ((x (environment-ref oru-env sym)))
544              (cases oru:quantity x
545                     (PRIM  (name value)
546                            (begin
547                              (fprintf out "~a: compiled coru primitive\n" name)
548                              (fprintf out "    value: ~a\n" value)))
549
550                     (TSCOMP (name initial open transitions power)
551                             (begin
552                               (fprintf out "~a: transition state complex\n" name)
553                               (fprintf out "    initial value: ~a\n" initial)))
554                     
555                     (CONST    (name value)
556                               (begin
557                                 (fprintf out "~a: constant\n" name)
558                                 (fprintf out "    value: ~a\n" value)))
559                     
560                     (ASGN     (name value rhs)
561                               (begin
562                                 (fprintf out "~a: state function\n" name)
563                                 (fprintf out "    value: ~a\n" value)))
564
565                     (else (oru:error 'exam name ": unknown type of quantity"))))))))
566 
567
568  (define (eval-const oru-env expr)
569    (exact->inexact (eval (normalize-expr expr) (make-const-env oru-env))))
570
571
572  (define (iscomp? x)
573    (cond ((oru:quantity? x)
574           (cases oru:quantity x
575                  (COMPONENT  (type lst)  #t)
576                  (else #f)))
577          (else #f)))
578
579  (define (isdep? x)
580    (cond ((oru:quantity? x)
581           (cases oru:quantity x
582                  (ASGN  (name value rhs)  #t)
583                  (else #f)))
584          ((and (list? x) (every pair? (cdr x)))  (alist-ref 'dep?  (cdr x)))
585          (else #f)))
586
587
588  (define (isstate? x)
589    (and (oru:quantity? x)
590         (cases oru:quantity x
591                (TSCOMP (name initial open transitions)  #t)
592                (else #f))))
593
594
595  (define (qrhs x)
596    (and (oru:quantity? x)
597         (cases oru:quantity x
598                (TSCOMP (name initial open transitions) 
599                        (begin
600                          (map cadddr transitions)))
601                (ASGN  (name value rhs)  rhs)
602                (else #f))))
603
604           
605  (define (sysname oru-env)
606    (cases oru:quantity (environment-ref oru-env (oru-intern 'name))
607           (SYSNAME (name)  name)))
608
609
610  ;; create equation dependency graph
611  (define (make-eqng oru-env)
612    (let* ((sysname    (sysname oru-env))
613           (g          (make-digraph sysname (string-append (symbol->string sysname) 
614                                                            " equation dependency graph")))
615           (add-node!  (g 'add-node!))
616           (add-edge!  (g 'add-edge!))
617           (oru-list  (filter (lambda (sym) (let ((x (environment-ref oru-env sym)))
618                                               (or (isstate? x) (isdep? x))))
619                               (environment-symbols oru-env)))
620           (oru-ids      (list-tabulate (length oru-list) identity))
621           (name->id-map  (zip oru-list oru-ids)))
622      (let-values (((state-list asgn-list) 
623                    (partition (lambda (sym) (isstate? (environment-ref oru-env sym)))
624                               oru-list)))
625                 
626         ;; insert equations in the dependency graph
627         (for-each (lambda (i n) (add-node! i n)) oru-ids oru-list)
628         ;; create dependency edges in the graph
629         (for-each (lambda (e) 
630                     (match e ((ni . nj) (begin
631                                           (let ((i (car (alist-ref ni name->id-map)))
632                                                 (j (car (alist-ref nj name->id-map))))
633                                             (add-edge! (list i j (format "~A=>~A" ni nj))))))
634                            (else (oru:error 'make-eqng ": invalid edge " e))))
635                   (fold (lambda (qsym ax) 
636                           (let* ((q   (environment-ref oru-env qsym))
637                                  (rhs (qrhs q)))
638                             (if rhs 
639                                 (let* ((deps (filter (if (isstate? q)
640                                                          (lambda (sym) 
641                                                            (and (let ((x (environment-ref oru-env sym)))
642                                                                   (and (isdep? x) (not (eq? sym qsym))))))
643                                                          (lambda (sym) 
644                                                            (and (let ((x (environment-ref oru-env sym)))
645                                                                   (isdep? x)))))
646                                                      (enumdeps rhs (list))))
647                                          (edges (map (lambda (d) (cons d qsym)) deps)))
648                                   (if edges (append edges ax) ax))
649                                 ax)))
650                         (list) oru-list))
651         (let ((cycles (graph-cycles-fold g (lambda (cycle ax) (cons cycle ax)) (list))))
652           (if (null? cycles) (list state-list asgn-list g)
653               (oru:error 'make-eqng ": equation cycle detected: " (car cycles)))))))
654
655
656  ;; given a graph, create a partial ordering based on BFS distance from root
657  (define (graph->bfs-dist-poset g)
658    (define node-info (g 'node-info))
659
660    (let-values (((dists dmax) (graph-bfs-dist g ((g 'roots)))))
661      (let loop ((poset  (make-vector (fx+ 1 dmax) (list)))
662                 (i      (fx- (s32vector-length dists) 1)))
663        (if (fx>= i 0)
664            (let* ((c     (s32vector-ref dists i))
665                   (info  (node-info i)))
666              (vector-set! poset c (cons (cons i info) (vector-ref poset c)))
667              (loop poset (fx- i 1)))
668            (begin
669              poset)))))
670
671
672  (define (make-eval-poset oru-env eqposet)
673    (vector-map 
674       (lambda (i lst) 
675         (filter-map (lambda (id+sym)
676                       (let* ((sym  (cdr id+sym))
677                              (x    (environment-ref oru-env sym)))
678                         (and (oru:quantity? x)
679                              (cases oru:quantity x
680                                     (TSCOMP (name initial open transitions) 
681                                             (let ((rs (map cadddr transitions)))
682                                               (list 'ts sym rs)))
683                                     (ASGN  (name value rhs)
684                                            (list 'a sym rhs))
685                                     (else oru:error 'make-eval-poset
686                                           ": invalid quantity in equation poset: " sym)))))
687                     lst))
688       eqposet))
689
690  (define (eval-expr env)
691    (lambda (expr)
692      (let ((val (match expr
693                        (('if c t f) 
694                         (let ((ee (eval-expr env)))
695                           (condition-case
696                            (if (ee c) (ee t) (ee f))
697                            [var () 
698                               (oru:error 'eval-expr " exception in " expr ": \n"
699                                          (lambda () (print-error-message var)))])))
700
701                        ((s . es)   
702                         (condition-case 
703                          (let ((op   (environment-ref env s))
704                                (args (map (eval-expr env) es)))
705                            (apply op args))
706                          [var () 
707                               (oru:error 'eval-expr " exception in " expr ": \n"
708                                          (lambda () (print-error-message var)))]))
709                       
710                        (s                 
711                         (cond ((symbol? s) (environment-ref env s))
712                               ((number? s) s)
713                               (else (oru:error 'eval-expr "unknown expression " s)))))))
714        val)))
715
716
717  (define (depgraph oru-env)
718    (match-let (((state-list asgn-list g)  (make-eqng oru-env))) g))
719
720  (define (depgraph* oru-env)
721    (match-let (((state-list asgn-list g)  (make-eqng oru-env))) 
722               (list state-list asgn-list g)))
723
724
725  ;; Dispatcher
726  (define (oru-dispatch selector)
727    (case selector
728      ((add-external!)     add-external!)
729      ((defun!)            defun!)
730      ((depgraph)          depgraph)
731      ((depgraph*)         depgraph*)
732      ((depgraph->bfs-dist-poset)  graph->bfs-dist-poset)
733      ((eval-const)          eval-const)
734      ((env-extend!)         env-extend!)
735      ((exam)                exam)
736      ((make-const-env)      make-const-env)
737      ((system)              system)
738      ((sysname)             sysname)
739      ((asgns)               asgns)
740      ((states)              states)
741      ((stcomps)             stcomps)
742      ((defuns)              defuns)
743      ((consts)              consts)
744      ((exports)             exports)
745      ((imports)             imports)
746      ((components)          components)
747      ((component-symbols)   component-symbols)
748      ((component-exports)   component-exports)
749      ((component-subcomps)  component-subcomps)
750      ((component-extend!)   component-extend!)
751      ((extended)            extended)
752      ((extended-with-tag)   extended-with-tag)
753      (else
754       (oru:error 'selector ": unknown message " selector " sent to an oru-core object")))) 
755
756  oru-dispatch)
757
758(define oru:env-copy environment-copy)
759
760(define qcounter 0)
761
762(define (qname prefix)
763  (let ((v qcounter))
764    (set! qcounter (+ 1 qcounter))
765    (string->symbol (string-append (->string prefix) (number->string v)))))
766
767(define (eval-oru-system-decls oru-core name sys declarations)
768  (define (eval-const x) (and x ((oru-core 'eval-const) sys x)))
769  (let loop ((ds declarations) (qs (list)))
770    (if (null? ds) qs
771        (let ((decl (car ds)))
772          (let ((qs1  (match decl
773                            ;; imported quantities
774                            (('input . lst) 
775                             (cond ((every (lambda (x) (or (symbol? x) (list? x))) lst)
776                                    (fold (lambda (x ax) 
777                                            (match x
778                                                   ((? symbol?) 
779                                                    (((oru-core 'add-external!) sys) x `(input ,x ,x #f))
780                                                    (cons x ax))
781                                                   ((id1 'as x1) 
782                                                    (((oru-core 'add-external!) sys) x `(input ,id1 ,x1 #f))
783                                                    (cons x1 ax))
784                                                   ((id1 'from n1) 
785                                                    (((oru-core 'add-external!) sys) x `(input ,id1 ,id1 ,n1))
786                                                    (cons id1 ax))
787                                                   ((id1 'as x1 'from n1) 
788                                                    (((oru-core 'add-external!) sys) x `(input ,id1 ,x1 ,n1))
789                                                    (cons x1 ax))
790                                                   ))
791                                          qs lst))
792                                   (else (oru:error 'eval-oru-system-decls 
793                                                        "import statement must be of the form: "
794                                                        "input id1 [as x1] ... "))))
795
796                            ;; exported quantities
797                            (('output . lst) 
798                             (cond ((every symbol? lst) 
799                                    (for-each (lambda (x) (((oru-core 'add-external!) sys) x 'output)) lst)
800                                    qs)
801                                   (else (oru:error 'eval-oru-system-decls 
802                                                        "export statement must be of the form: "
803                                                        "output id1 ... "))))
804
805                            ;; constant during integration
806                            (('const id '= expr)
807                             (cond ((and (symbol? id) (or (number? expr) (list? expr)))
808                                    (let ((val (eval-const expr)))
809                                      (((oru-core 'env-extend!) sys) id '(const) val)
810                                      (cons id qs)))
811                                   (else (oru:error 'eval-oru-system-decls 
812                                                        "constant declarations must be of the form: "
813                                                        "const id = expr")))) 
814
815                            ;; state transition complex
816                            (('state-complex (id . alst) )
817                             (cond ((and (symbol? id) (list? alst))
818                                    (let ((initial (eval-const (lookup-def 'initial alst)))
819                                          (power   (eval-const (lookup-def 'power alst))))
820                                      (apply ((oru-core 'env-extend!) sys) 
821                                             (cons* id '(tscomp) initial `(power ,power) alst)))
822                                    (cons id qs))
823                                   (else (oru:error 'eval-oru-system-decls 
824                                                        "state complex declarations must be of the form: "
825                                                        "state-complex (id ...)"))))
826                           
827                            ;; algebraic assignment
828                            ((id '= expr) 
829                             (cond ((and (symbol? id) (or (symbol? expr) (number? expr) (list? expr)))
830                                    (((oru-core 'env-extend!) sys) id '(asgn) 'none `(rhs ,expr))
831                                    (cons id qs))
832                                   (else (oru:error 'eval-oru-system-decls 
833                                                        "algebraic declarations must be of the form: "
834                                                        "id = expr"))))
835                           
836                            ;; user-defined function
837                            (('defun id idlist expr) 
838                             (cond ((and (symbol? id) (list? idlist) (every symbol? idlist) (list? expr))
839                                    (((oru-core 'defun!) sys) id idlist expr)
840                                    (cons id qs))
841                                   (else (oru:error 'eval-oru-system-decls
842                                                        "function declarations must be of the form: "
843                                                        "defun id (arg1 arg2 ...) expr"))))
844                           
845                            ;; compiled coru primitives
846                            (('prim id value) 
847                             (cond ((symbol? id)  (((oru-core 'env-extend!) sys) id '(prim) value))
848                                   (else (oru:error 'eval-oru-system-decls 
849                                                        "prim declarations must be of the form: "
850                                                        "prim id value"))))
851                           
852                            (('component ('type typ) ('name name) . lst) 
853                             (let* ((cqs   (loop lst (list)))
854                                    (comp  (COMPONENT typ cqs))
855                                    (sym   (string->symbol (->string name))))
856                               (environment-set! sys sym comp)
857                               (cons sym qs)))
858
859                             
860                            (('component ('type typ)  . lst) 
861                             (let* ((cqs   (loop lst (list)))
862                                    (comp  (COMPONENT typ cqs))
863                                    (sym   (qname "comp")))
864                               (environment-set! sys sym comp)
865                               (cons sym qs)))
866                             
867                           
868                            (('sysname name)  (if (symbol? name)
869                                                  (environment-set! sys (oru-intern 'name)      (SYSNAME name))
870                                                  (oru:error 'eval-oru-system-decls
871                                                                 "system name must be a symbol")))
872                           
873                            (('const . _)
874                             (oru:error 'eval-oru-system-decls "constant declarations must be of the form: "
875                                            "const id = expr"))
876                           
877                            ((id '= . _) 
878                             (oru:error 'eval-oru-system-decls "algebraic equations must be of the form: "
879                                            "id = expr")) 
880                           
881                            (('state-complex . _)
882                             (oru:error 'eval-oru-system-decls 
883                                            "state complex declarations must be of the form: "
884                                            "state-complex (id ...)"))
885                           
886                            (('defun . _) 
887                             (oru:error 'eval-oru-system-decls "function declarations must be of the form: "
888                                            "defun id (arg1 arg2 ...) expr"))
889                           
890                            (('prim . _) 
891                             (oru:error 'eval-oru-system-decls "prim declarations must be of the form: "
892                                            "prim id value"))
893                           
894                            (('component . _) 
895                             (oru:error 'eval-oru-system-decls "invalid component: " decl))
896                           
897                            (('sysname . _) 
898                             (oru:error 'eval-oru-system-decls "system name must be of the form (sysname name)"))
899                           
900                            ;; anything that doesn't match is possibly
901                            ;; declarations recognized by the oru extension
902                            ;; modules
903                            ((tag  . lst)
904                             (if (symbol? tag)
905                                 (match-let (((typ name alst) 
906                                              (let loop ((lst lst) (ax (list tag)))
907                                                (if (null? lst)
908                                                    (list (list (car (reverse ax))) #f (cdr (reverse ax)))
909                                                    (match lst
910                                                           (((? symbol?) . rest) 
911                                                            (loop (cdr lst) (cons (car lst) ax)))
912                                                           (((x . rest)) 
913                                                            (if (and (symbol? x) (every list? rest))
914                                                                (list (reverse ax) x rest)
915                                                                (list (reverse ax) #f lst)))
916                                                           (else  (list (reverse ax) #f lst)))))))
917                                             (let ((name (or name (qname tag))))
918                                               (((oru-core 'env-extend!) sys) name  typ alst)
919                                               (cons name qs)))
920                                 (oru:error 'eval-oru-system-decls "extended declarations must be of the form: "
921                                                "declaration (name (properties ...)"))))))
922                           
923                           
924                     (loop (cdr ds) qs1)))
925        ))
926  sys)
Note: See TracBrowser for help on using the repository browser.