source: project/release/4/9ML-toolkit/trunk/network.scm @ 29971

Last change on this file since 29971 was 29971, checked in by Ivan Raikov, 7 years ago

9ML-toolkit: option eval-ivp -> single-ivp

File size: 54.1 KB
Line 
1;
2;;  NineML network level descriptions.
3;;
4;;
5;; Copyright 2010-2013 Ivan Raikov and the Okinawa Institute of
6;; Science and Technology.
7;;
8;; This program is free software: you can redistribute it and/or
9;; modify it under the terms of the GNU General Public License as
10;; published by the Free Software Foundation, either version 3 of the
11;; License, or (at your option) any later version.
12;;
13;; This program is distributed in the hope that it will be useful, but
14;; WITHOUT ANY WARRANTY; without even the implied warranty of
15;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
16;; General Public License for more details.
17;;
18;; A full copy of the GPL license can be found at
19;; <http://www.gnu.org/licenses/>.
20;;
21
22
23#|
24
25TODO: use term rewriting rules for eval-ul-component, e.g.:
26
27     ( (M component (definition $url) $properties) =>
28       (M component (eval-env (M eval-definition $url)) $properties) )
29
30     ( (M component (eval-env $eval-env) $properties) =>
31       (M component (model-module (eval-env-last-entry $eval-env)) $properties) )
32
33     ( (M component (eval-env $eval-env) $properties) =>
34       (M component (model-module (eval-env-last-entry $eval-env)) $properties) )
35
36     ( (M component (model-module $model-module) $properties) =>
37       (eval-term (M apply-terms (Longid (Pdot (entry-name $model-module) "construct")) $properties)) )
38
39     ( (M eval-definition $url ) =>
40       (eval-source (fetch (uri-reference $url)) current-scope current-type-env current-eval-env ) )
41
42     ( (M apply-terms $operator (seq $term $rest)) =>
43       (M apply-terms (Apply $operator $term) $rest) )
44       
45     ( (M apply-terms $operator (seq-empty)) => $operator )
46|#
47
48
49(require-extension extras posix utils files data-structures tcp srfi-1 srfi-13 irregex)
50(require-extension datatype matchable static-modules miniML miniMLsyntax miniMLvalue miniMLeval)
51(require-extension make signal-diagram ssax sxml-transforms sxpath sxpath-lolevel object-graph ersatz-lib uri-generic getopt-long )
52(require-extension 9ML-parse 9ML-eval 9ML-ivp-lib 9ML-ivp-mlton)
53
54(require-library ersatz-lib)
55(import (prefix ersatz-lib ersatz: ))
56
57
58(define (string-match rx str)
59  (and-let* ((m (irregex-match rx str)))
60    (let loop ((i (irregex-match-num-submatches m))
61               (res '()))
62      (if (fx<= i 0)
63          (cons str res)
64          (loop (fx- i 1) (cons (irregex-match-substring m i) res))))))
65
66
67(define lookup-def 
68  (lambda (k lst . rest)
69    (let-optionals rest ((default #f))
70      (alist-ref k lst eq? default))))
71
72
73(define (safe-car x) (and (pair? x) (car x)))
74
75(define $ string->symbol)
76
77(define (alist->tenv xs)
78  (map (lambda (x) (cons (car x) (ersatz:sexpr->tvalue (cdr x)))) xs))
79
80(define (warn port message . specialising-msgs)
81  (print-error-message message (current-output-port) "Warning")
82  (print (string-concatenate (map ->string specialising-msgs))))
83
84       
85(include "SXML.scm")
86(include "SXML-to-XML.scm")
87(include "stx-engine.scm")
88
89(define-values (env-binding? env-empty env-add-signature env-add-module env-add-type env-add-spec env-add-value
90                env-find-value env-find-type env-find-module env-find)
91  (make-mod-env core-syntax))
92
93(define-values (scope-typedecl scope-modtype scope-signature scope-modterm scope-moddef)
94  (make-mod-scoping core-syntax core-scoping))
95
96(define-values (check-modtype check-signature type-modterm type-moddef type-definition)
97  (make-mod-typing core-syntax core-typing))
98
99(include "NineMLcore.scm")
100(include "NineMLreal.scm")
101(include "NineMLrandom.scm")
102(include "NineMLsignal.scm")
103(include "NineMLdiagram.scm")
104(include "NineMLivp.scm")
105(include "NineMLgenerator.scm")
106
107
108(define current-scope      (make-parameter st-empty))
109(define current-type-env   (make-parameter env-empty))
110(define current-eval-env   (make-parameter env-empty))
111
112
113(define (enter-typedecl id decl)
114  (current-scope (st-enter-type id (current-scope)))
115  (current-type-env   (env-add-type id decl (current-type-env))))
116
117(define (enter-valtype name ty)
118  (let ((id (ident-create name)))
119    (current-scope (st-enter-value id (current-scope)))
120    (current-type-env   (env-add-value id ty (current-type-env)))))
121
122(define (enter-val name val)
123  (let ((id (or (and (ident? name) name) (ident-create name))))
124    (current-eval-env (ident-add id val (current-eval-env)))))
125
126(core-initialize enter-typedecl enter-valtype)
127(eval-cbv-initialize enter-val)
128
129
130(define (enter-module id mty)
131  (current-scope (st-enter-module id (current-scope)))
132  (current-type-env (env-add-module id mty (current-type-env))))
133
134
135(define (apply-terms operator terms)
136  (if (null? terms) 
137      operator
138      (apply-terms 
139       (Apply operator (car terms))
140       (cdr terms))))
141
142
143
144(define (closure-formals v)
145
146  (define (term-formals f ax)
147    (cases term f
148           (Function (i t) 
149                     (term-formals t (cons ($ (ident-name i)) ax)))
150           (else (reverse ax))))
151
152  (cases MLvalue v
153         (Closure_v (body env) (term-formals body '()))
154         (else (error 'closure-formals "invalid closure" v))
155         ))
156 
157
158
159(define opt-defaults
160  `(
161    (platform . mlton)
162    ))
163
164
165(define (defopt x)
166  (lookup-def x opt-defaults))
167
168(define opt-grammar
169  `(
170
171    (print-type-env  "prints the type environment of each operand"
172                     (single-char #\t)
173                     (value (optional COMPONENT-LIST)
174                            (default all)
175                            (transformer 
176                             ,(lambda (x) 
177                                (if (string=? x "all") x
178                                    (list (string-split x ",")))))))
179
180    (print-eval-env  "prints the evaluation environment of each operand"
181                     (single-char #\e)
182                     (value (optional COMPONENT-LIST)
183                            (default all)
184                            (transformer 
185                             ,(lambda (x) 
186                                (if (string=? x "all") x
187                                    (list (string-split x ",")))))))
188
189    (print-source-defs  "prints the source definitions of each operand"
190                        (single-char #\s))
191
192    (output-sxml        "sets output format to SXML")
193
194    (output-xml         "sets output format to XML")
195
196    (single-ivp          "evaluate all single-node IVP problems and save data in files ${OPERAND}_NAME.log"
197                         (single-char #\d))
198
199    (platform        "simulation platform (one of mlton, chicken, chicken/cvode, octave, octave/mlton)"
200                     (value (required PLATFORM)
201                            (predicate 
202                             ,(lambda (x) 
203                                (let ((s (string->symbol (string-downcase x))))
204                                  (case s
205                                    ((chicken chicken/cvode mlton octave octave/mlton) s)
206                                    (else (error '9ML-network "unrecognized platform" x))))))
207                            (transformer ,string->symbol)
208                             ))
209
210    (verbose          "print commands as they are executed"
211                      (single-char #\v))
212
213    (help  "Print help"
214            (single-char #\h))
215 
216  ))
217
218
219;; Use args:usage to generate a formatted list of options (from OPTS),
220;; suitable for embedding into help text.
221(define (network:usage)
222  (print "Usage: " (car (argv)) " file1... [options...] ")
223  (newline)
224  (print "Where operands are NineML user layer files")
225  (newline)
226  (print "The following options are recognized: ")
227  (newline)
228  (width 35)
229  (print (parameterize ((indent 5)) (usage opt-grammar)))
230  (exit 1))
231
232
233;; Process arguments and collate options and arguments into OPTIONS
234;; alist, and operands (filenames) into OPERANDS.  You can handle
235;; options as they are processed, or afterwards.
236
237(define opts    (getopt-long (command-line-arguments) opt-grammar))
238(define opt     (make-option-dispatch opts opt-grammar))
239
240(define network-verbose (make-parameter 0))
241(define data-dir (make-parameter #f))
242(define simulation-platform (make-parameter #f))
243
244
245(define (d fstr . args)
246  (let ([port (current-error-port)])
247    (if (positive? (network-verbose)) 
248        (begin (apply fprintf port fstr args)
249               (flush-output port) ) )))
250
251
252(define (sxml-string->uri s) 
253  (let ((ss (string-trim-both s)))
254    (uri-reference ss)))
255
256
257(define (get-data-dir)
258  (or (opt 'data-dir)
259      (or (data-dir)
260          (let ([dir (create-temporary-directory)])
261            (data-dir dir)
262            dir ) ) ))
263
264
265(define (run:execute explist)
266  (define (smooth lst)
267    (let ((slst (map ->string lst)))
268      (string-intersperse (cons (car slst) (cdr slst)) " ")))
269  (for-each (lambda (cmd) (system (->string cmd)))
270            (map smooth explist)))
271
272
273(define (run:execute* explist)
274  (define (smooth lst)
275    (let ((slst (map ->string lst)))
276      (string-intersperse (cons (car slst) (cdr slst)) " ")))
277  (for-each (lambda (cmd) (system* "~a" cmd))
278            (map smooth explist)))
279
280
281(define-syntax run
282  (syntax-rules ()
283    ((_ exp ...)
284     (begin
285       (d "running ~A ...~%" (list `exp ...))
286       (run:execute* (list `exp ...))))))
287
288
289(define-syntax run-
290  (syntax-rules ()
291    ((_ exp ...)
292     (begin
293       (d "running ~A ...~%" (list `exp ...))
294       (run:execute (list `exp ...))))))
295
296
297(define (create-temporary-directory)
298  (let ((dir (or (get-environment-variable "TMPDIR") 
299                 (get-environment-variable "TEMP") 
300                 (get-environment-variable "TMP") 
301                 "/tmp")))
302    (let loop ()
303      (let* ((n (current-milliseconds))
304             (pn (make-pathname dir (string-append "9ML-network-" (number->string n 16)) "tmp")))
305        (cond ((file-exists? pn) (loop))
306              (else (mkdir pn) pn))))))
307
308
309(define (network-failure msg . args)
310  (signal
311   (make-composite-condition
312    (make-property-condition
313       'exn
314       'message "invalid response from server"
315       'arguments args)
316    (make-property-condition 'http-fetch))) )
317
318
319
320(define (make-HTTP-GET/1.1 location user-agent host
321                           #!key
322                           (port 80)
323                           (connection "close")
324                           (accept "*")
325                           (content-length 0))
326  (conc
327   "GET " location " HTTP/1.1" "\r\n"
328   "Connection: " connection "\r\n"
329   "User-Agent: " user-agent "\r\n"
330   "Accept: " accept "\r\n"
331   "Host: " host #\: port "\r\n"
332   "Content-length: " content-length "\r\n"
333   "\r\n") )
334
335(define (match-http-response rsp)
336  (and (string? rsp)
337       (string-match "HTTP/[0-9.]+\\s+([0-9]+)\\s+.*" rsp)) )
338
339(define (response-match-code? mrsp code)
340  (and mrsp (string=? (number->string code) (cadr mrsp))) )
341
342(define (match-chunked-transfer-encoding ln)
343  (string-match "[Tt]ransfer-[Ee]ncoding:\\s*chunked.*" ln) )
344
345
346(define (http-fetch uri dest)
347  (d "fetching ~s ...~%" (uri->string uri))
348  (match-let (((_ ((_ host port) ('/ . path) query) _) (uri->list uri)))
349    (let* ((port      (or port 80))
350           (locn      (uri->string (update-uri (update-uri uri scheme: #f) host: #f)))
351           (query     (and query (not (string-null? query)) query))
352           (filedir   (uri-decode-string (string-concatenate (intersperse (if query path (drop-right path 1)) "/"))))
353           (filename  (uri-decode-string (or (and query (cadr (string-split query "="))) (last path))))
354           (dest      (make-pathname dest filedir))
355           (filepath  (make-pathname dest filename)))
356      (if (file-exists? filepath) filepath
357          (begin
358          (d "connecting to host ~s, port ~a ...~%" host port)
359          (let-values ([(in out) (tcp-connect host port)])
360                      (d "requesting ~s ...~%" locn)
361                      (display
362                       (make-HTTP-GET/1.1 locn "NineML" host port: port accept: "*/*")
363                       out)
364                      (flush-output out)
365                      (d "reading response ...~%")
366                      (let ([chunked #f] [ok-response #f])
367                        (let* ([h1 (read-line in)]
368                               [response-match (match-http-response h1)])
369                          (d "~a~%" h1)
370                          ;;*** handle redirects here
371                          (cond ((response-match-code? response-match 200)
372                                 (set! ok-response #t))
373                                ((response-match-code? response-match 404)
374                                 (d "file not found on server: ~s~%" locn))
375                                (else (network-failure "invalid response from server" h1) ))
376                        (and ok-response
377                            (begin
378                              (let loop ()
379                                (let ([ln (read-line in)])
380                                  (unless (string-null? ln)
381                                    (when (match-chunked-transfer-encoding ln) (set! chunked #t))
382                                    (d "~a~%" ln)
383                                    (loop) ) ) )
384                              (if chunked
385                                  (begin
386                                    (d "reading chunks ...~%")
387                                    (let ([data (read-chunks in)])
388                                      (close-input-port in)
389                                      (close-output-port out)
390                                      (if (not (file-exists? dest)) (mkdir dest))
391                                      (d "writing to ~s~%" filepath)
392                                      (with-output-to-file filepath (cut display data) )
393                                      filepath))
394                                 
395                                  (begin
396                                    (d "reading data ...~%")
397                                    (let ([data (read-string #f in)])
398                                      (close-input-port in)
399                                      (close-output-port out)
400                                      (if (not (file-exists? dest)) (mkdir dest))
401                                      (d "writing to ~s~%" filepath)
402                                      (with-output-to-file filepath (cut display data) binary:)
403                                      filepath)))))
404                        )
405                      )))))))
406
407  (define (read-chunks in)
408    (let get-chunks ([data '()])
409      (let ([size (string->number (read-line in) 16)])
410        (if (zero? size)
411            (string-concatenate-reverse data)
412            (let ([chunk (read-string size in)])
413              (read-line in)
414              (get-chunks (cons chunk data)) ) ) ) ) )
415
416
417(define (fetch uri)
418  (case (uri-scheme uri)
419    ((http)
420     (let-values (((fd temp-path) (file-mkstemp "/tmp/9ML.XXXXXX")))
421       (let ((data (and (http-fetch uri temp-path) (read-all temp-path))))
422         (file-close fd)
423         data)))
424
425    ((file #f)
426     (let ((data (read-all 
427                  (string-concatenate
428                   (intersperse (map ->string (uri-path uri)) "/")))))
429       data))
430   
431    (else (error 'fetch "unknown scheme" (uri-scheme uri)))
432    ))
433
434
435
436(define (parse-xml str)
437  (call-with-input-string str
438      (lambda (in)
439        (ssax:xml->sxml in `((nml . ,nineml-xmlns))))
440      ))
441
442
443(define (eval-source defs current-scope current-type-env current-eval-env)
444  (d "eval-source: defs = ~A~%" defs)
445  (let* (
446         (scoped-defs      (scope-moddef (current-scope) defs))
447         (mty              (type-moddef (current-type-env) '() scoped-defs))
448         (typed-defs         (map (lambda (x) (cases modspec x
449                                                     (Value_sig (id vty) (cons id x))
450                                                     (Type_sig (id decl) (cons id x))
451                                                     (Module_sig (id mty) (cons id x))
452                                                     )) mty))
453         (type-env1        (fold (lambda (x ax) 
454                                   (cases modspec x 
455                                          (Value_sig  (id vty)   (env-add-value  id vty ax))
456                                          (Type_sig   (id decl)  (env-add-type   id decl ax))
457                                          (Module_sig (id mty)   (env-add-module id mty ax))
458                                          )) 
459                                 (current-type-env) mty))
460         (scope1          (fold (lambda (x ax) 
461                                  (cases modspec x
462                                         (Value_sig  (id vty)   (st-enter-value id ax))
463                                         (Type_sig   (id decl)  (st-enter-type id ax))
464                                         (Module_sig (id mty)   (st-enter-module id ax))
465                                         )) 
466                                (current-scope) mty))
467         (eval-env         (mod-eval-cbv (current-eval-env) scoped-defs))
468         (unified-env      (list scoped-defs
469                                 (filter (lambda (x) (not (assoc (car x) (current-type-env)))) typed-defs) 
470                                 (filter (lambda (x) (not (assoc (car x) (current-eval-env)))) eval-env) ))
471         )
472    (list unified-env (list scope1 type-env1))
473    ))
474
475
476(define (string->bool x)
477  (cond ((string-contains-ci x "false") 0)
478        ((string-contains-ci x "true") 1)
479        (else #f)))
480
481
482(define (make-real-const-signal value)
483  (Apply (Longid (Pdot (Pident (ident-create "Signal")) "realconst"))
484         (Const `(real ,value))))
485
486(define (make-bool-const-signal value)
487  (Apply (Longid (Pdot (Pident (ident-create "Signal")) "boolconst"))
488         (Const `(bool ,(if (zero? value) #f #t)))))
489
490
491(define (make-real-signal name value)
492  (Apply
493   (Apply (Longid (Pdot (Pident (ident-create "Signal")) "realsig"))
494          (Const `(label ,($ name))))
495   (Apply (Longid (Pdot (Pident (ident-create "Signal")) "realconst"))
496          (Const `(real ,value)))
497   ))
498
499(define (make-bool-signal name value)
500  (Apply
501   (Apply (Longid (Pdot (Pident (ident-create "Signal")) "boolsig"))
502          (Const `(label ,($ name))))
503   (Apply (Longid (Pdot (Pident (ident-create "Signal")) "boolconst"))
504          (Const `(bool ,(if (zero? value) #f #t))))
505   ))
506
507
508
509
510(define (match-builtin-model name uri)
511 
512  (define src-poisson (Longid (Pdot (Pident (ident-create "Generator")) "poisson")))
513  (define diagram-identity (Longid (Pdot (Pident (ident-create "Diagram")) "IDENTITY")))
514  (define diagram-sense (Longid (Pdot (Pident (ident-create "Diagram")) "SENSE")))
515
516  (case (uri-scheme uri)
517    ((http)
518     (and
519      (string-ci= (uri-host uri) "www.NineML.org")
520      (let ((p (uri-path uri)))
521        (let ((def
522               (match p
523                      (('/ "stim" "Poisson.9ml")
524                       (Value_def (ident-create name)
525                                  (Function (ident-create "rate")
526                                            (Function (ident-create "t")
527                                                      (Function (ident-create "h")
528                                                                (apply-terms 
529                                                                 src-poisson
530                                                                 (list
531                                                                  (Longid (Pident (ident-create "rate")))
532                                                                  (Longid (Pident (ident-create "t")))
533                                                                  (Longid (Pident (ident-create "h")))
534                                                                  ))
535                                                                ))
536                                                      ))
537                       )
538
539                      (else #f))))
540          (and def (eval-source (list def) current-scope current-type-env current-eval-env))))
541      ))
542    (else #f)))
543
544
545(define (eval-ul-component x) 
546
547  (let (
548        (node-name  (sxml:attr x 'name))
549        (definition ((sxpath `(// nml:Definition nml:link))  x))
550        (propns     ((sxpath `(// nml:properties nml:Property nml:label))  x))
551        (propvs     ((sxpath `(// nml:properties nml:Property nml:value))  x))
552        (fieldns    ((sxpath `(// nml:properties nml:Field nml:label))  x))
553        (fieldvs    ((sxpath `(// nml:properties nml:Field nml:value))  x))
554        (initialns  ((sxpath `(// nml:properties nml:Initial nml:label))  x))
555        (initialvs  ((sxpath `(// nml:properties nml:Initial nml:value))  x))
556        (ivp        (safe-car ((sxpath `(// nml:ivp))  x)))
557        )
558
559
560    (if (null? definition)
561        (error 'eval-ul-component "component without definition" x))
562
563    (let ((uri  (sxml-string->uri (sxml:text (safe-car definition)))))
564
565      (d "NineML abstraction layer URI: ~A~%" uri)
566      (d "NineML component propns: ~A~%" propns)
567      (d "NineML component propvs: ~A~%" propvs)
568      (d "NineML component fieldns: ~A~%" fieldns)
569      (d "NineML component fieldvs: ~A~%" fieldvs)
570     
571      (let* (
572             (uenv.tbls
573              (or (match-builtin-model node-name uri)
574                  (let ((src (fetch uri)))
575                    (d "NineML abstraction layer source: ~A~%" src)
576                    (if (not src)
577                        (error 'eval-ul-component "resource not found" (uri->string uri))
578                        (eval-source (parse-al-sxml (parse-xml src))
579                                     current-scope current-type-env current-eval-env)))
580                  ))
581             
582             (dd    (d "NineML abstraction layer uenv: ~A~%" uenv.tbls))
583             (uenv  (car uenv.tbls))
584             (tbls  (cadr uenv.tbls))
585             )
586       
587        (let ((eval-env (caddr uenv))
588              (scope    (car tbls))
589              (type-env (cadr tbls))
590              )
591         
592          (current-scope scope)
593          (current-type-env type-env)
594          (current-eval-env (append eval-env (current-eval-env)))
595         
596          (if (null? eval-env)
597              (error 'eval-ul-component "empty definition" (safe-car definition)))
598         
599          (d "NineML abstraction layer value: ~A~%" (last eval-env))
600         
601          (let* ((al-entry-name
602                  (car (last eval-env)))
603                 (al-entry-formals
604                  (closure-formals (cdr (last eval-env))))
605                 
606                 (property-values
607                  (map (lambda (n v) 
608                         (let ((vtext (sxml:text v))
609                               (name (sxml:text n)))
610                           (let ((nv (string->number vtext))
611                                 (bv (string->bool vtext)))
612                             (cons ($ name)
613                                   (or (and nv (make-real-signal name nv))
614                                       (and bv (make-bool-signal name bv))
615                                       (Apply
616                                        (Apply (Longid (Pdot (Pident (ident-create "Signal")) "realsig"))
617                                               (Const `(label ,($ name))))
618                                        (make-signal-expr
619                                         (parse-string-expr (->string (sxml:kidn-cadr 'nml:MathInline v ))))
620                                        )))
621                             )))
622                       propns propvs))
623                 
624                 (field-values
625                  (map (lambda (n v) 
626                         (let ((vtext (sxml:text v))
627                               (name (sxml:text n)))
628                           (let ((nv (string->number vtext))
629                                 (bv (string->bool vtext)))
630                             (cons ($ name)
631                                   (or (and nv (make-real-signal name nv))
632                                       (and bv (make-bool-signal name bv))
633                                       (Apply
634                                        (Apply (Longid (Pdot (Pident (ident-create "Signal")) "realfield"))
635                                               (Const `(label ,($ name))))
636                                        (make-signal-expr
637                                         (parse-string-expr (->string (sxml:kidn-cadr 'nml:MathInline v ))))
638                                        )))
639                             )))
640                       fieldns fieldvs))
641                 
642                 (initial-values
643                  (map (lambda (n v) 
644                         (let ((name (sxml:text n))
645                               (vtext (sxml:text v)))
646                           (let ((nv (string->number vtext))
647                                 (bv (string->bool vtext)))
648                             (cons ($ name)
649                                   (or (and nv (make-real-signal name nv))
650                                       (and bv (make-bool-signal name bv))
651                                       (Apply
652                                        (Apply (Longid (Pdot (Pident (ident-create "Signal")) "realsig"))
653                                               (Const `(label ,($ name))))
654                                        (make-signal-expr
655                                         (parse-string-expr (->string (sxml:kidn-cadr 'nml:MathInline v ))))
656                                        ))
657                                   ))
658                             ))
659                       initialns initialvs))
660                 
661                 
662                 (ivp-duration (and ivp
663                                    (car ((sxpath `(// nml:duration))  ivp))
664                                    ))
665                 
666                 (ivp-timestep (and ivp
667                                    (string->number
668                                     (sxml:text
669                                      (car ((sxpath `(// nml:timestep))  ivp))))
670                                    ))
671
672                 (dd (d "NineML abstraction layer formals: ~A property-values: ~A field-values: ~A initial-values: ~A~%" 
673                        al-entry-formals property-values field-values initial-values))
674                 
675                 (node (Value_def (ident-create node-name) 
676                                  (apply-terms (Longid (Pident al-entry-name)) 
677                                               (let ((pfi-alst
678                                                      (append property-values 
679                                                              field-values
680                                                              initial-values
681                                                              `((t . ,(make-real-signal "t" 0.0))
682                                                                (h . ,(make-real-signal "h" (or ivp-timestep 0.1)))))
683                                                      ))
684                                                 (map
685                                                  (lambda (x) (let ((v (alist-ref x pfi-alst)))
686                                                                (if (not v) 
687                                                                    (error 'eval-ul-component 
688                                                                           "value for quantity not found" x)
689                                                                    v)))
690                                                  al-entry-formals))
691                                               )
692                                  ))
693                 
694                 (ivp-values  (and ivp
695                                   (cons* (Longid (Pident (ident-create node-name)))
696                                          (Const `(label t))
697                                          (Const `(label h))
698                                          (Const `(real 0.0))
699                                          (map (compose (lambda (x) (Const `(real ,x))) string->number sxml:text) 
700                                               (list ivp-duration)))))
701
702                 
703                 (ivp-name    (and ivp (sxml:attr ivp 'name)))
704                 (ivp-node    (or
705                               (and ivp-values
706                                    (Value_def (ident-create ivp-name) 
707                                               (apply-terms (Longid
708                                                             (Pdot (Pident (ident-create "IVP")) "run"))
709                                                            ivp-values)))
710                                    (Value_def (ident-create (string-append "ivp_" node-name) )
711                                               (apply-terms (Longid
712                                                             (Pdot (Pident (ident-create "IVP")) "initial"))
713                                                            (list (Longid (Pident (ident-create node-name)))
714                                                                  (Const `(label t))
715                                                                  (Const `(label h)))))
716                               ))
717                 )
718           
719            (d "NineML abstraction layer current scope: ~A~%" (current-scope))
720            (d "NineML abstraction layer entry: ~A~%" al-entry-name)
721            (d "NineML ivp: ~A~%" ivp-node)
722           
723            (let ((v (car
724                      (eval-source (list node ivp-node)
725                                   current-scope current-type-env current-eval-env) )))
726
727              v)
728            ))
729        ))
730    ))
731
732
733(define (parse-ul-properties prefix sxml-properties) 
734
735  (define (parse-property-hook prefix name label value)
736
737    (d "parse-property-hook: label = ~A name = ~A value = ~A~%" 
738       label name (sxml-value->sexpr value))
739
740      (cond
741       
742       ((or (and (string? label) (string=? label "sigfun"))
743            (and (pair? label) (string=? (car label) "sigfun")))
744
745        (sxml-value->sexpr value))
746       
747       ((not label)
748        (sxml-value->sexpr value))
749       
750       (else #f)
751       ))
752           
753
754  (let ((prop-env
755         (reverse
756         (fold
757          (lambda (node lst)
758           
759            (let ((name0 (sxml:text (sxml:kidn* 'nml:label node)))
760                  (sxml-value (sxml:kidn* 'nml:value node)))
761             
762              (let* ((name (if (not (string-null? name0)) name0 (sxml:attr node 'name)))
763                     (uenv.tbls
764                      (let ((def
765                             (Value_def (ident-create name) 
766                                        (let ((vtext (sxml:text sxml-value)))
767                                          (let ((n (string->number vtext))
768                                                (b (string->bool vtext)))
769                                            (or (and n (make-real-signal name n))
770                                                (and b (make-bool-signal name b))
771                                                (and
772                                                 (sxml:kidn 'nml:MathInline sxml-value)
773                                                 (make-signal-expr
774                                                  (parse-string-expr (->string (sxml:kidn-cadr 'nml:MathInline sxml-value )))))
775                                                (Const `(string ,vtext)))
776                                            ))
777                                        ))
778                             )
779                        (eval-source (list def)
780                                     current-scope current-type-env current-eval-env) ))
781                     
782                     (uenv  (car uenv.tbls))
783                     (tbls  (cadr uenv.tbls))
784                     )
785               
786                (let ((eval-env (caddr uenv))
787                      (scope    (car tbls))
788                      (type-env (cadr tbls))
789                      )
790                 
791                  (current-scope scope)
792                  (current-type-env type-env)
793                  (current-eval-env (append eval-env (current-eval-env)))
794                 
795                  (let* ((last-entry (last eval-env)))
796                   
797                    (cons last-entry lst)
798                    ))
799                ))
800            )
801          '() sxml-properties)))
802        )
803
804    (map (lambda (entry) 
805           (d "eval-ul-property: entry = ~A~%" entry)
806           (let* ((name ($ (ident-name (car entry))))
807                  (val  (definition-apply prefix (car entry)
808                          (list (current-scope) (current-type-env) (list entry))
809                          value-hook: parse-property-hook)))
810             (d "eval-ul-property: name = ~A val = ~A~%" name val)
811             `(,name (expr . ,(->string val))
812                     (exprML . ,(mlton-value val))
813                     )))
814         prop-env)
815
816    ))
817
818
819(define (eval-ul-property prefix sxml-value) 
820
821  (define (eval-property-hook prefix name label value)
822
823    (d "eval-property-hook: label = ~A name = ~A value = ~A~%" 
824       label name (sxml-value->sexpr value))
825
826      (cond
827       
828       ((or (and (string? label) (string=? label "sigfun"))
829            (and (pair? label) (string=? (car label) "sigfun")))
830
831        (sigfun-eval (sxml-value->sexpr value)))
832       
833       (else #f)
834       ))
835
836
837  (let* ((name (gensym 'prop))
838         (uenv.tbls
839          (let ((def
840                 (Value_def (ident-create name) 
841                            (let ((vtext (sxml:text sxml-value)))
842                              (let ((n (string->number vtext))
843                                    (b (string->bool vtext)))
844                                (or (and n (make-real-signal name n))
845                                    (and b (make-bool-signal name b))
846                                    (make-signal-expr
847                                     (or (string->number (sxml:text sxml-value))
848                                         (parse-string-expr (->string (sxml:kidn-cadr 'nml:MathInline sxml-value ))))
849                                     ))
850                                ))
851                            ))
852                )
853            (eval-source (list def)
854                         current-scope current-type-env current-eval-env) ))
855         
856         (uenv  (car uenv.tbls))
857         (tbls  (cadr uenv.tbls))
858         )
859   
860    (let ((eval-env (caddr uenv))
861          (scope    (car tbls))
862          (type-env (cadr tbls))
863          )
864                 
865      (let* ((entry (last eval-env)))
866       
867        (let* ((name (ident-name (car entry)))
868               (val  (definition-apply prefix (car entry)
869                       (list (current-scope) (current-type-env) (list entry))
870                       value-hook: eval-property-hook)))
871          `(,name . ,val))
872        ))
873    ))
874
875
876
877(define (make-prototype-tenv prefix name env)
878  (d "NineML make-prototype-tenv: env = ~A~%" env)
879  (let ((ivp-name ($ (string-append "ivp_" (->string name)))))
880    (d "NineML make-prototype-tenv: ivp-name = ~A~%" ivp-name)
881    (let ((sdinfo (lookup-def ivp-name env)))
882      (if (not sdinfo) (error 'make-prototype "unable to find prototype" name))
883      (let (
884            (ivar    (lookup-def 'ivar sdinfo))
885            (dvars   (lookup-def 'dvars sdinfo))
886            (hvar    (lookup-def 'hvar sdinfo))
887            (events  (lookup-def 'events sdinfo))
888            (ic      (lookup-def 'initial-conditions sdinfo))
889            (fields  (lookup-def 'fields sdinfo))
890            )
891        (let* ((ivpFn                (lookup-def 'ivp-id sdinfo))
892               (states               (cons ivar dvars))
893               (icstates             (filter (lambda (x) (member (car x) states)) ic))
894               (initialExpr/ML       (mlton-initial ic update: '((h . h))))
895               (fieldExpr/ML         (and (not (null? fields)) (mlton-initial fields)))
896               (initialStateExpr/ML  (mlton-initial icstates))
897               (copyStateIsyn/ML     (mlton-state-update 
898                                      (map car ic) 
899                                      nstate: "input" input: "initial" field-input: "fieldV"
900                                      states: states fields: (map car fields)
901                                      update: '((Isyn . Isyn_i))))
902               (copyStateNstate/ML   (mlton-state-update states input: "initial" states: states ))
903               )
904          (alist->tenv
905           `((name               . ,name)
906             (ivpFn              . ,ivpFn)
907             (ivar               . ,ivar)
908             (hvar               . ,hvar)
909             (states             . ,states)
910             (events             . ,(if (null? events) '(tnull) events))
911             (initialExprML      . ,initialExpr/ML)
912             (fieldExprML        . ,fieldExpr/ML)
913             (initialStateExprML . ,initialStateExpr/ML)
914             (copyStateIsynML    . ,copyStateIsyn/ML)
915             (copyStateNstateML  . ,copyStateNstate/ML)
916             ))
917          ))
918      ))
919  )
920 
921
922(define (make-population-tenv name prototype size order)
923  (alist->tenv
924   `((name      . ,name)
925     (prototype . ,prototype)
926     (size      . ,size)
927     (start     . ,order))
928   ))
929
930
931(define (population= x y) (equal? (car x) (car y)))
932
933
934(define (make-population-set node populations)
935  (let*
936      (
937
938       (fromlist-template 
939        (sxml:match 'nml:fromList
940                    (lambda (node bindings root env) 
941                      (let ((kids (sxml:kids node)))
942                        (fold (lambda (x ax)
943                                (lset-union population= 
944                                    (make-population-set x populations) ax))
945                              '() kids)
946                        ))
947                    ))
948
949       (union-template 
950        (sxml:match 'nml:union
951                    (lambda (node bindings root env) 
952                      (let ((left (sxml:kidn* 'nml:left node))
953                            (right (sxml:kidn* 'nml:right node)))
954                        (lset-union population=
955                                    (make-population-set (sxml:kid left) populations)
956                                    (make-population-set (sxml:kid right) populations))
957                        ))
958                    ))
959
960       (intersection-template 
961        (sxml:match 'nml:intersection
962                    (lambda (node bindings root env) 
963                      (let ((left (sxml:kidn* 'nml:left node))
964                            (right (sxml:kidn* 'nml:right node)))
965                        (lset-intersection population=
966                                           (make-population-set (sxml:kid left) populations)
967                                           (make-population-set (sxml:kid right) populations))
968                        ))
969                    ))
970
971       (difference-template 
972        (sxml:match 'nml:difference
973                    (lambda (node bindings root env) 
974                      (let ((left (sxml:kidn* 'nml:left node))
975                            (right (sxml:kidn* 'nml:right node)))
976                        (lset-difference population=
977                                         (make-population-set (sxml:kid left) populations)
978                                         (make-population-set (sxml:kid right) populations))
979                        ))
980                    ))
981
982       (singleton-template 
983        (sxml:match 'nml:singleton
984                    (lambda (node bindings root env) 
985                      (let ((name ($ (sxml:text node))))
986                        (let ((population (lookup-def name populations)))
987                          (if population
988                              `((,name . ,population))
989                              (error 'make-population-set "unknown population" name))
990                          ))
991                      )))
992       )
993
994    (stx:apply-templates 
995     node
996     (sxml:make-null-ss union-template
997                        intersection-template
998                        difference-template
999                        singleton-template)
1000     node (list))
1001    ))
1002
1003   
1004   
1005(define (make-population-set-tenv name populations)
1006  (alist->tenv
1007   `((name        . ,name)
1008     (populations . ,(map cdr populations))
1009     (size        . ,(fold + 0 (map (lambda (x) 
1010                                      (ersatz:tvalue->sexpr (alist-ref 'size (cdr x)))) 
1011                                    populations)))
1012     )))
1013 
1014
1015(define (make-projection-tenv name source target rule response properties)
1016  (alist->tenv
1017   `((name       . ,name)
1018     (type       . ,type)
1019     (source     . ,source)
1020     (target     . ,target)
1021     (rule       . ,rule)
1022     (response   . ,response)
1023     (properties . ,properties)
1024     )
1025   ))
1026 
1027 
1028
1029(define (make-response-tenv prefix name env)
1030  (let ((ivp-name ($ (string-append "ivp_" (->string name)))))
1031    (let ((sdinfo (lookup-def ivp-name env)))
1032      (if (not sdinfo) (error 'make-response "unable to find prototype" name))
1033      (let ((ivar    (lookup-def 'ivar sdinfo))
1034            (dvars   (lookup-def 'dvars sdinfo))
1035            (hvar    (lookup-def 'hvar sdinfo))
1036            (events  (lookup-def 'events sdinfo))
1037            (ic      (lookup-def 'initial-conditions sdinfo)))
1038        (let* ((ivpFn  (lookup-def 'ivp-id sdinfo))
1039               (states (cons ivar dvars))
1040               (icstates             (filter (lambda (x) (member (car x) states)) ic))
1041               (initialExpr/ML       (mlton-initial ic update: '((h . h))))
1042               (initialStateExpr/ML  (mlton-initial icstates))
1043               (copyStateIspike/ML   (mlton-state-update (map car ic) nstate: "input" input: "initial" 
1044                                                         states: states update: '((spike . spike_i) (Ispike . Ispike_i))))
1045               (copyStateNstate/ML   (mlton-state-update states input: "initial" states: states ))
1046               )
1047          (d "NineML make-response-tenv: states = ~A~%" states)
1048          (alist->tenv
1049           `((name               . ,name)
1050             (ivpFn              . ,ivpFn)
1051             (states             . ,states)
1052             (ics                . ,(map car ic))
1053             (initialExprML      . ,initialExpr/ML)
1054             (initialStateExprML . ,initialStateExpr/ML)
1055             (copyStateIspikeML  . ,copyStateIspike/ML)
1056             (copyStateNstateML  . ,copyStateNstate/ML)))
1057          ))
1058      ))
1059  )
1060
1061
1062(define (make-group-tenv name order populations sets projections psr-types
1063                         spikepoplst properties)
1064  (let ((alst 
1065         `((group 
1066            . 
1067            ((name        . ,name)
1068             (order       . ,order)
1069             (sets        . ,sets)
1070             (populations . ,populations)
1071             (projections . ,projections)
1072             (psrtypes    . ,(if (null? psr-types) #f psr-types))
1073             (properties  . ,(if (null? properties) '(tnull) properties))
1074             (spikepoplst . ,spikepoplst)
1075             ))
1076           ))
1077        )
1078    (alist->tenv alst)))
1079
1080
1081(define (eval-ul-group prefix ul-properties node env)
1082
1083  (define (projections-range projections)
1084    (let ((target-union
1085           (fold
1086            (lambda (x ax)
1087              (let* ((props (cdr x))
1088                     (target (ersatz:tvalue->sexpr (alist-ref 'target props))))
1089                (lset-union population= (alist-ref 'populations target) ax)))
1090            '() projections)))
1091      (fold (lambda (x ax) (+ (alist-ref 'size x) ax)) 0 target-union)
1092      ))
1093         
1094  (let (
1095        (group-name       (sxml:attr node 'name))
1096        (populations-sxml ((sxpath `(// nml:Population))  node))
1097        (sets-sxml        ((sxpath `(// nml:set))  node))
1098        (projections-sxml ((sxpath `(// nml:Projection)) node))
1099        (properties-sxml  ((sxpath `(nml:Property)) node))
1100        (spikerecord-sxml ((sxpath `(nml:SpikeRecording)) node))
1101        )
1102
1103    (d "UL group: ~A properties: ~A populations: ~A sets: ~A projections: ~A~%" 
1104       group-name properties-sxml populations-sxml sets-sxml projections-sxml)
1105
1106    (if (null? populations-sxml)
1107        (error 'eval-ul-group "group without populations" node))
1108
1109    (let* ((properties (parse-ul-properties group-name properties-sxml))
1110
1111           (populations+order
1112            (fold 
1113             (lambda (node ax)
1114               (let ((populations (car ax))
1115                     (order (cadr ax)))
1116                 (let* ((name (sxml:attr node 'name))
1117                        (prototype-name ($ (sxml:text (sxml:kidn* 'nml:reference (sxml:kidn* 'nml:prototype node)))))
1118                        (size (eval-ul-property group-name (sxml:kidn* 'nml:number node)))
1119                        (size-val (inexact->exact (cdr size))))
1120                   (list
1121                    (cons
1122                     `(,($ name) . ,(make-population-tenv ($ name) (make-prototype-tenv prefix prototype-name env) size-val order))
1123                     populations)
1124                    (+ size-val order)
1125                    ))
1126                 ))
1127             (list '() 0)
1128             populations-sxml))
1129
1130           (populations (reverse (car populations+order)))
1131           (order (cadr populations+order))
1132
1133           (sets
1134            (append
1135             (map (lambda (x) 
1136                    (let ((name (car x)))
1137                      `(,name . ((name . ,name) 
1138                                 (populations . ,(ersatz:sexpr->tvalue (list (cdr x))))
1139                                 (size . ,(alist-ref 'size (cdr x))))
1140                              )
1141                      ))
1142                  populations)
1143             (map (lambda (node)
1144                    (let* ((name (sxml:attr node 'name))
1145                           (set (make-population-set (sxml:kid node) populations)))
1146
1147                      `(,($ name) . ,(make-population-set-tenv ($ name) set))))
1148                  sets-sxml)))
1149
1150           (projections+psr-types 
1151            (map (lambda (node)
1152                   (let* (
1153                          (name          (sxml:attr node 'name))
1154                          (type          ($ (or (sxml:attr node 'type) "event")))
1155                          (source-name   ($ (sxml:text (sxml:kidn* 'nml:reference (sxml:kidn* 'nml:source node)))))
1156                          (target-name   ($ (sxml:text (sxml:kidn* 'nml:reference (sxml:kidn* 'nml:target node)))))
1157                          (response      (sxml:kidn* 'nml:response node))
1158                          (response-name (and response (sxml:text (sxml:kidn* 'nml:reference response ))))
1159                          (rule          (sxml:kidn* 'nml:rule node))
1160                          (rule-name     (sxml:text (sxml:kidn* 'nml:reference rule)))
1161                          (properties    (parse-ul-properties name (sxml:kidsn 'nml:Property rule)))
1162                          )
1163
1164                     (d "group-ul-eval: projection node = ~A~%" node)
1165                     (d "group-ul-eval: response = ~A response-name = ~A~%" response response-name)
1166                     (d "group-ul-eval: properties = ~A ~%" properties)
1167
1168                     (let (
1169                           (source (lookup-def source-name sets))
1170                           (target (lookup-def target-name sets))
1171                           (response (and response-name (make-response-tenv prefix response-name env)))
1172                           )
1173                       
1174                       (if (not source)
1175                           (error 'eval-ul-group "invalid projection source" source))
1176
1177                       (if (not target)
1178                           (error 'eval-ul-group "invalid projection target" target))
1179                       
1180                       (list `(,($ name) . ,(make-projection-tenv ($ name) type source target rule-name response-name properties))
1181                             `(,(and response-name ($ response-name)) (response . ,response) (projection . ,name)))
1182                       ))
1183                   )
1184                 projections-sxml))
1185
1186           (projections (map car projections+psr-types ))
1187           
1188           (psr-types (let* ((psr-types0 (filter car (map cadr projections+psr-types)))
1189                             (psr-projections
1190                              (fold (lambda (x ax)
1191                                      (let* ((psr-name (car x))
1192                                             (projection (alist-ref 'projection (cdr x)))
1193                                             (psr-projections (alist-ref psr-name ax)))
1194                                        (if psr-projections
1195                                            (alist-update psr-name (cons projection psr-projections) ax)
1196                                            (alist-update psr-name (list projection) ax))))
1197                                    '() psr-types0))
1198                             )
1199                        (map
1200                         (lambda (x)
1201                           (let* ((name (car x)) (response (alist-ref 'response (cdr x)))
1202                                  (projection-names (alist-ref name psr-projections)))
1203                             `(,name . ,(append response 
1204                                                `((projections . ,projection-names)
1205                                                  (range . ,(projections-range
1206                                                             (map (lambda (x) (alist-ref ($ x) projections)) 
1207                                                                  projection-names)))
1208                                                  )))
1209                             ))
1210                         (delete-duplicates psr-types0
1211                                            (lambda (x y) (eq? (car x) (car y)))
1212                                            psr-types0))
1213                        ))
1214                         
1215           )
1216
1217      (d "group-ul-eval: order = ~A~%" order)
1218
1219      (let* (
1220             (shared-dir    (chicken-home))
1221             (template-dir  (make-pathname (make-pathname shared-dir "9ML") "templates"))
1222             (network-tmpl  "Network.sml.tmpl")
1223             (sim-tmpl      "Sim.sml.tmpl")
1224             (mlb-tmpl      "Sim.mlb.tmpl")
1225             (makefile-tmpl "Makefile.tmpl")
1226             (group-path    (make-pathname (pathname-directory prefix)
1227                                           (string-append group-name ".sml")))
1228             (sim-path      (make-pathname (pathname-directory prefix)
1229                                           (string-append "Sim" group-name ".sml")))
1230             (mlb-path      (make-pathname (pathname-directory prefix)
1231                                           (string-append "Sim" group-name ".mlb")))
1232             (exec-path     (make-pathname (pathname-directory prefix)
1233                                           (string-append "Sim" group-name)))
1234             (makefile-path (make-pathname (pathname-directory prefix) 
1235                                           (string-append "Makefile." group-name)))
1236             (spikelst      (fold (lambda (node ax)
1237                                    (let ((set (alist-ref ($ (sxml:attr node 'set)) sets)))
1238                                      (let ((populations
1239                                             (let ((poplst (alist-ref 'populations set)))
1240                                               (ersatz:tvalue->sexpr poplst))))
1241                                        (append
1242                                         (map (lambda (x) (->string (alist-ref 'name x))) populations)
1243                                         ax))))
1244                                  '() spikerecord-sxml))
1245             (group-tenv    (make-group-tenv group-name order populations sets projections psr-types 
1246                                             spikelst (append properties ul-properties) ))
1247
1248             )
1249
1250        (d "group-tenv = ~A~%" (map (lambda (x) (cons (car x) (ersatz:tvalue->sexpr (cdr x)))) group-tenv))
1251
1252        (make (
1253
1254               (group-path (prefix)
1255                           (with-output-to-file group-path 
1256                             (lambda ()
1257                               (print (ersatz:from-file 
1258                                       network-tmpl
1259                                       env: (template-std-env search-path: `(,template-dir))
1260                                       models: group-tenv))))
1261                           )
1262       
1263               (sim-path (prefix)
1264                         (with-output-to-file sim-path 
1265                           (lambda ()
1266                             (print (ersatz:from-file 
1267                                     sim-tmpl
1268                                     env: (template-std-env search-path: `(,template-dir))
1269                                     models: group-tenv))))
1270                         )
1271               
1272               (mlb-path ()
1273                         (with-output-to-file mlb-path 
1274                           (lambda ()
1275                             (print (ersatz:from-file 
1276                                     mlb-tmpl
1277                                     env: (template-std-env search-path: `(,template-dir))
1278                                         models: group-tenv))))
1279                         )
1280
1281               (makefile-path ()
1282                              (with-output-to-file makefile-path 
1283                                (lambda ()
1284                                  (print (ersatz:from-file 
1285                                          makefile-tmpl
1286                                          env: (template-std-env search-path: `(,template-dir))
1287                                          models: (append
1288                                                   group-tenv
1289                                                   `((sml_lib_home . ,(Tstr (make-pathname 
1290                                                                             (make-pathname shared-dir "flsim")
1291                                                                             "sml-lib")))))
1292                                          ))))
1293                              )
1294
1295               (exec-path (group-path sim-path mlb-path makefile-path)
1296                          (run (,make)))
1297
1298               )
1299
1300          (list exec-path) )
1301        ))
1302    ))
1303 
1304
1305(define (main options operands)
1306
1307  (if (options 'help) (network:usage))
1308
1309  (let ((find-module (lambda (x) (env-find-module x (current-type-env)))))
1310    (for-each (lambda (init name) (init name enter-module find-module current-eval-env))
1311              (list Real:module-initialize   
1312                    Random:module-initialize   
1313                    Signal:module-initialize   
1314                    Diagram:module-initialize 
1315                    IVP:module-initialize 
1316                    Generator:module-initialize   )
1317              (list "Real" "Random" "Signal" "Diagram" "IVP" "Generator"  )) )
1318
1319  (if (null? operands)
1320
1321      (network:usage)
1322
1323      (let ((output-type (cond ((options 'output-xml)  'xml)
1324                               ((options 'output-sxml) 'sxml)
1325                               (else #f))))
1326
1327        (if (options 'verbose) (begin (eval-verbose 1) (ivp-verbose 1) (network-verbose 1)))
1328        (simulation-platform (or (options 'platform) (defopt 'platform) ))
1329
1330        (for-each
1331
1332         (lambda (operand)
1333
1334           (let* (
1335                  (ul-sxml (parse-xml (read-all operand)))
1336                  (ul-imports ((sxpath `(// nml:NineML nml:import))  ul-sxml))
1337                  (ul-import-sxmls (map (lambda (x) (parse-xml (fetch (sxml-string->uri (sxml:text x))))) ul-imports))
1338                  )
1339
1340             (let* (
1341                    (ul-sxml (fold append ul-sxml ul-import-sxmls))
1342                    (ul-properties  (parse-ul-properties
1343                                     operand ((sxpath `(// nml:NineML nml:Property))  ul-sxml)))
1344                    (ul-groups ((sxpath `(// nml:NineML nml:Group))  ul-sxml))
1345
1346                    (ul-components ((sxpath `(// nml:NineML nml:Component))  ul-sxml))
1347                    (ul-component-uenvs (map eval-ul-component ul-components))
1348                   
1349                    (ivp-node-env (make-parameter '()))
1350                    )
1351
1352               (d "ul-properties = ~A~%" ul-properties)
1353
1354               (for-each
1355                (lambda (uenv) 
1356               
1357                  (let (
1358                        (source-defs (car uenv))
1359                        (mty         (cadr uenv))
1360                        (eval-env    (caddr uenv))
1361                        )
1362                   
1363                    (let ((type-env-opt (options 'print-type-env)))
1364                      (if type-env-opt
1365                          (if (and (string? type-env-opt) (string=?  type-env-opt "all"))
1366                              (print-type-env mty output-type)
1367                              (let ((fc (lambda (x) (and (member (ident-name (car x)) type-env-opt) x))))
1368                                (print-type-env mty output-type fc)))
1369                          ))
1370                   
1371                    (let ((eval-env-opt (options 'print-eval-env)))
1372                      (if eval-env-opt
1373                          (if (and (string? eval-env-opt) (string=? eval-env-opt "all"))
1374                              (print-eval-env eval-env output-type)
1375                              (let ((fc (lambda (x) (and (member (ident-name (car x)) eval-env-opt) x))))
1376                                (print-eval-env eval-env output-type fc)))
1377                          ))
1378                   
1379                    (if (options 'print-source-defs)
1380                        (print-source-defs source-defs output-type))
1381                   
1382                    (if (options 'single-ivp)
1383                        (begin
1384                          (traverse-definitions operand uenv value-hook: (make-ivp-data-hook ivp: #t))
1385                          (process-wait) )
1386                        (traverse-definitions operand uenv value-hook: (make-ivp-cgen-hook ivp-node-env))
1387                        )
1388                   
1389                    ))
1390                 ul-component-uenvs)
1391
1392               (d "ivp-node-env = ~A~%" (ivp-node-env))
1393
1394               (for-each (lambda (x) (eval-ul-group operand ul-properties x (ivp-node-env))) ul-groups)
1395
1396               ))
1397           )
1398
1399         operands))))
1400
1401(main opt (opt '@))
1402
1403
Note: See TracBrowser for help on using the repository browser.