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

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

9ML-toolkit: updates to support proper NineML schema

File size: 54.4 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 . ,(string-append nineml-xmlns-base "0.2"))
440                             (nml . ,(string-append nineml-xmlns-base "0.3"))
441                             (nml . ,(string-append nineml-xmlns-base "1.0"))
442                             )))
443      ))
444
445
446(define (eval-source defs current-scope current-type-env current-eval-env)
447  (d "eval-source: defs = ~A~%" defs)
448  (let* (
449         (scoped-defs      (scope-moddef (current-scope) defs))
450         (mty              (type-moddef (current-type-env) '() scoped-defs))
451         (typed-defs         (map (lambda (x) (cases modspec x
452                                                     (Value_sig (id vty) (cons id x))
453                                                     (Type_sig (id decl) (cons id x))
454                                                     (Module_sig (id mty) (cons id x))
455                                                     )) mty))
456         (type-env1        (fold (lambda (x ax) 
457                                   (cases modspec x 
458                                          (Value_sig  (id vty)   (env-add-value  id vty ax))
459                                          (Type_sig   (id decl)  (env-add-type   id decl ax))
460                                          (Module_sig (id mty)   (env-add-module id mty ax))
461                                          )) 
462                                 (current-type-env) mty))
463         (scope1          (fold (lambda (x ax) 
464                                  (cases modspec x
465                                         (Value_sig  (id vty)   (st-enter-value id ax))
466                                         (Type_sig   (id decl)  (st-enter-type id ax))
467                                         (Module_sig (id mty)   (st-enter-module id ax))
468                                         )) 
469                                (current-scope) mty))
470         (eval-env         (mod-eval-cbv (current-eval-env) scoped-defs))
471         (unified-env      (list scoped-defs
472                                 (filter (lambda (x) (not (assoc (car x) (current-type-env)))) typed-defs) 
473                                 (filter (lambda (x) (not (assoc (car x) (current-eval-env)))) eval-env) ))
474         )
475    (list unified-env (list scope1 type-env1))
476    ))
477
478
479(define (string->bool x)
480  (cond ((string-contains-ci x "false") 0)
481        ((string-contains-ci x "true") 1)
482        (else #f)))
483
484
485(define (make-real-const-signal value)
486  (Apply (Longid (Pdot (Pident (ident-create "Signal")) "realconst"))
487         (Const `(real ,value))))
488
489(define (make-bool-const-signal value)
490  (Apply (Longid (Pdot (Pident (ident-create "Signal")) "boolconst"))
491         (Const `(bool ,(if (zero? value) #f #t)))))
492
493
494(define (make-real-signal name value)
495  (Apply
496   (Apply (Longid (Pdot (Pident (ident-create "Signal")) "realsig"))
497          (Const `(label ,($ name))))
498   (Apply (Longid (Pdot (Pident (ident-create "Signal")) "realconst"))
499          (Const `(real ,value)))
500   ))
501
502(define (make-bool-signal name value)
503  (Apply
504   (Apply (Longid (Pdot (Pident (ident-create "Signal")) "boolsig"))
505          (Const `(label ,($ name))))
506   (Apply (Longid (Pdot (Pident (ident-create "Signal")) "boolconst"))
507          (Const `(bool ,(if (zero? value) #f #t))))
508   ))
509
510
511
512
513(define (match-builtin-model name uri)
514 
515  (define src-poisson (Longid (Pdot (Pident (ident-create "Generator")) "poisson")))
516  (define diagram-identity (Longid (Pdot (Pident (ident-create "Diagram")) "IDENTITY")))
517  (define diagram-sense (Longid (Pdot (Pident (ident-create "Diagram")) "SENSE")))
518
519  (case (uri-scheme uri)
520    ((http)
521     (and
522      (string-ci= (uri-host uri) "www.NineML.org")
523      (let ((p (uri-path uri)))
524        (let ((def
525               (match p
526                      (('/ "stim" "Poisson.9ml")
527                       (Value_def (ident-create name)
528                                  (Function (ident-create "rate")
529                                            (Function (ident-create "t")
530                                                      (Function (ident-create "h")
531                                                                (apply-terms 
532                                                                 src-poisson
533                                                                 (list
534                                                                  (Longid (Pident (ident-create "rate")))
535                                                                  (Longid (Pident (ident-create "t")))
536                                                                  (Longid (Pident (ident-create "h")))
537                                                                  ))
538                                                                ))
539                                                      ))
540                       )
541
542                      (else #f))))
543          (and def (eval-source (list def) current-scope current-type-env current-eval-env))))
544      ))
545    (else #f)))
546
547
548(define (eval-ul-component x) 
549
550  (let (
551        (node-name  (sxml:attr x 'name))
552        (definition ((sxpath `(// nml:Definition nml:link))  x))
553        (propns     ((sxpath `(// nml:properties nml:Property nml:label))  x))
554        (propvs     ((sxpath `(// nml:properties nml:Property nml:value))  x))
555        (fieldns    ((sxpath `(// nml:properties nml:Field nml:label))  x))
556        (fieldvs    ((sxpath `(// nml:properties nml:Field nml:value))  x))
557        (initialns  ((sxpath `(// nml:properties nml:Initial nml:label))  x))
558        (initialvs  ((sxpath `(// nml:properties nml:Initial nml:value))  x))
559        (ivp        (safe-car ((sxpath `(// nml:ivp))  x)))
560        )
561
562
563    (if (null? definition)
564        (error 'eval-ul-component "component without definition" x))
565
566    (let ((uri  (sxml-string->uri (sxml:text (safe-car definition)))))
567
568      (d "NineML abstraction layer URI: ~A~%" uri)
569      (d "NineML component propns: ~A~%" propns)
570      (d "NineML component propvs: ~A~%" propvs)
571      (d "NineML component fieldns: ~A~%" fieldns)
572      (d "NineML component fieldvs: ~A~%" fieldvs)
573     
574      (let* (
575             (uenv.tbls
576              (or (match-builtin-model node-name uri)
577                  (let ((src (fetch uri)))
578                    (d "NineML abstraction layer source: ~A~%" src)
579                    (if (not src)
580                        (error 'eval-ul-component "resource not found" (uri->string uri))
581                        (eval-source (parse-al-sxml (parse-xml src))
582                                     current-scope current-type-env current-eval-env)))
583                  ))
584             
585             (dd    (d "NineML abstraction layer uenv: ~A~%" uenv.tbls))
586             (uenv  (car uenv.tbls))
587             (tbls  (cadr uenv.tbls))
588             )
589       
590        (let ((eval-env (caddr uenv))
591              (scope    (car tbls))
592              (type-env (cadr tbls))
593              )
594         
595          (current-scope scope)
596          (current-type-env type-env)
597          (current-eval-env (append eval-env (current-eval-env)))
598         
599          (if (null? eval-env)
600              (error 'eval-ul-component "empty definition" (safe-car definition)))
601         
602          (d "NineML abstraction layer value: ~A~%" (last eval-env))
603         
604          (let* ((al-entry-name
605                  (car (last eval-env)))
606                 (al-entry-formals
607                  (closure-formals (cdr (last eval-env))))
608                 
609                 (property-values
610                  (map (lambda (n v) 
611                         (let ((vtext (sxml:text v))
612                               (name (sxml:text n)))
613                           (let ((nv (string->number vtext))
614                                 (bv (string->bool vtext)))
615                             (cons ($ name)
616                                   (or (and nv (make-real-signal name nv))
617                                       (and bv (make-bool-signal name bv))
618                                       (Apply
619                                        (Apply (Longid (Pdot (Pident (ident-create "Signal")) "realsig"))
620                                               (Const `(label ,($ name))))
621                                        (make-signal-expr
622                                         (parse-string-expr (->string (sxml:kidn-cadr 'nml:MathInline v ))))
623                                        )))
624                             )))
625                       propns propvs))
626                 
627                 (field-values
628                  (map (lambda (n v) 
629                         (let ((vtext (sxml:text v))
630                               (name (sxml:text n)))
631                           (let ((nv (string->number vtext))
632                                 (bv (string->bool vtext)))
633                             (cons ($ name)
634                                   (or (and nv (make-real-signal name nv))
635                                       (and bv (make-bool-signal name bv))
636                                       (Apply
637                                        (Apply (Longid (Pdot (Pident (ident-create "Signal")) "realfield"))
638                                               (Const `(label ,($ name))))
639                                        (make-signal-expr
640                                         (parse-string-expr (->string (sxml:kidn-cadr 'nml:MathInline v ))))
641                                        )))
642                             )))
643                       fieldns fieldvs))
644                 
645                 (initial-values
646                  (map (lambda (n v) 
647                         (let ((name (sxml:text n))
648                               (vtext (sxml:text v)))
649                           (let ((nv (string->number vtext))
650                                 (bv (string->bool vtext)))
651                             (cons ($ name)
652                                   (or (and nv (make-real-signal name nv))
653                                       (and bv (make-bool-signal name bv))
654                                       (Apply
655                                        (Apply (Longid (Pdot (Pident (ident-create "Signal")) "realsig"))
656                                               (Const `(label ,($ name))))
657                                        (make-signal-expr
658                                         (parse-string-expr (->string (sxml:kidn-cadr 'nml:MathInline v ))))
659                                        ))
660                                   ))
661                             ))
662                       initialns initialvs))
663                 
664                 
665                 (ivp-duration (and ivp
666                                    (car ((sxpath `(// nml:duration))  ivp))
667                                    ))
668                 
669                 (ivp-timestep (and ivp
670                                    (string->number
671                                     (sxml:text
672                                      (car ((sxpath `(// nml:timestep))  ivp))))
673                                    ))
674
675                 (dd (d "NineML abstraction layer formals: ~A property-values: ~A field-values: ~A initial-values: ~A~%" 
676                        al-entry-formals property-values field-values initial-values))
677                 
678                 (node (Value_def (ident-create node-name) 
679                                  (apply-terms (Longid (Pident al-entry-name)) 
680                                               (let ((pfi-alst
681                                                      (append property-values 
682                                                              field-values
683                                                              initial-values
684                                                              `((t . ,(make-real-signal "t" 0.0))
685                                                                (h . ,(make-real-signal "h" (or ivp-timestep 0.1)))))
686                                                      ))
687                                                 (map
688                                                  (lambda (x) (let ((v (alist-ref x pfi-alst)))
689                                                                (if (not v) 
690                                                                    (error 'eval-ul-component 
691                                                                           "value for quantity not found" x)
692                                                                    v)))
693                                                  al-entry-formals))
694                                               )
695                                  ))
696                 
697                 (ivp-values  (and ivp
698                                   (cons* (Longid (Pident (ident-create node-name)))
699                                          (Const `(label t))
700                                          (Const `(label h))
701                                          (Const `(real 0.0))
702                                          (map (compose (lambda (x) (Const `(real ,x))) string->number sxml:text) 
703                                               (list ivp-duration)))))
704
705                 
706                 (ivp-name    (and ivp (sxml:attr ivp 'name)))
707                 (ivp-node    (or
708                               (and ivp-values
709                                    (Value_def (ident-create ivp-name) 
710                                               (apply-terms (Longid
711                                                             (Pdot (Pident (ident-create "IVP")) "run"))
712                                                            ivp-values)))
713                                    (Value_def (ident-create (string-append "ivp_" node-name) )
714                                               (apply-terms (Longid
715                                                             (Pdot (Pident (ident-create "IVP")) "initial"))
716                                                            (list (Longid (Pident (ident-create node-name)))
717                                                                  (Const `(label t))
718                                                                  (Const `(label h)))))
719                               ))
720                 )
721           
722            (d "NineML abstraction layer current scope: ~A~%" (current-scope))
723            (d "NineML abstraction layer entry: ~A~%" al-entry-name)
724            (d "NineML ivp: ~A~%" ivp-node)
725           
726            (let ((v (car
727                      (eval-source (list node ivp-node)
728                                   current-scope current-type-env current-eval-env) )))
729
730              v)
731            ))
732        ))
733    ))
734
735
736(define (parse-ul-properties prefix sxml-properties) 
737
738  (define (parse-property-hook prefix name label value)
739
740    (d "parse-property-hook: label = ~A name = ~A value = ~A~%" 
741       label name (sxml-value->sexpr value))
742
743      (cond
744       
745       ((or (and (string? label) (string=? label "sigfun"))
746            (and (pair? label) (string=? (car label) "sigfun")))
747
748        (sxml-value->sexpr value))
749       
750       ((not label)
751        (sxml-value->sexpr value))
752       
753       (else #f)
754       ))
755           
756
757  (let ((prop-env
758         (reverse
759         (fold
760          (lambda (node lst)
761           
762            (let ((name0 (sxml:text (sxml:kidn* 'nml:label node)))
763                  (sxml-value (sxml:kidn* 'nml:value node)))
764             
765              (let* ((name (if (not (string-null? name0)) name0 (sxml:attr node 'name)))
766                     (uenv.tbls
767                      (let ((def
768                             (Value_def (ident-create name) 
769                                        (let ((vtext (sxml:text sxml-value)))
770                                          (let ((n (string->number vtext))
771                                                (b (string->bool vtext)))
772                                            (or (and n (make-real-signal name n))
773                                                (and b (make-bool-signal name b))
774                                                (and
775                                                 (sxml:kidn 'nml:MathInline sxml-value)
776                                                 (make-signal-expr
777                                                  (parse-string-expr (->string (sxml:kidn-cadr 'nml:MathInline sxml-value )))))
778                                                (Const `(string ,vtext)))
779                                            ))
780                                        ))
781                             )
782                        (eval-source (list def)
783                                     current-scope current-type-env current-eval-env) ))
784                     
785                     (uenv  (car uenv.tbls))
786                     (tbls  (cadr uenv.tbls))
787                     )
788               
789                (let ((eval-env (caddr uenv))
790                      (scope    (car tbls))
791                      (type-env (cadr tbls))
792                      )
793                 
794                  (current-scope scope)
795                  (current-type-env type-env)
796                  (current-eval-env (append eval-env (current-eval-env)))
797                 
798                  (let* ((last-entry (last eval-env)))
799                   
800                    (cons last-entry lst)
801                    ))
802                ))
803            )
804          '() sxml-properties)))
805        )
806
807    (map (lambda (entry) 
808           (d "eval-ul-property: entry = ~A~%" entry)
809           (let* ((name ($ (ident-name (car entry))))
810                  (val  (definition-apply prefix (car entry)
811                          (list (current-scope) (current-type-env) (list entry))
812                          value-hook: parse-property-hook)))
813             (d "eval-ul-property: name = ~A val = ~A~%" name val)
814             `(,name (expr . ,(->string val))
815                     (exprML . ,(mlton-value val))
816                     )))
817         prop-env)
818
819    ))
820
821
822(define (eval-ul-property prefix sxml-value) 
823
824  (define (eval-property-hook prefix name label value)
825
826    (d "eval-property-hook: label = ~A name = ~A value = ~A~%" 
827       label name (sxml-value->sexpr value))
828
829      (cond
830       
831       ((or (and (string? label) (string=? label "sigfun"))
832            (and (pair? label) (string=? (car label) "sigfun")))
833
834        (sigfun-eval (sxml-value->sexpr value)))
835       
836       (else #f)
837       ))
838
839
840  (let* ((name (gensym 'prop))
841         (uenv.tbls
842          (let ((def
843                 (Value_def (ident-create name) 
844                            (let ((vtext (sxml:text sxml-value)))
845                              (let ((n (string->number vtext))
846                                    (b (string->bool vtext)))
847                                (or (and n (make-real-signal name n))
848                                    (and b (make-bool-signal name b))
849                                    (make-signal-expr
850                                     (or (string->number (sxml:text sxml-value))
851                                         (parse-string-expr (->string (sxml:kidn-cadr 'nml:MathInline sxml-value ))))
852                                     ))
853                                ))
854                            ))
855                )
856            (eval-source (list def)
857                         current-scope current-type-env current-eval-env) ))
858         
859         (uenv  (car uenv.tbls))
860         (tbls  (cadr uenv.tbls))
861         )
862   
863    (let ((eval-env (caddr uenv))
864          (scope    (car tbls))
865          (type-env (cadr tbls))
866          )
867                 
868      (let* ((entry (last eval-env)))
869       
870        (let* ((name (ident-name (car entry)))
871               (val  (definition-apply prefix (car entry)
872                       (list (current-scope) (current-type-env) (list entry))
873                       value-hook: eval-property-hook)))
874          `(,name . ,val))
875        ))
876    ))
877
878
879
880(define (make-prototype-tenv prefix name env)
881  (d "NineML make-prototype-tenv: env = ~A~%" env)
882  (let ((ivp-name ($ (string-append "ivp_" (->string name)))))
883    (d "NineML make-prototype-tenv: ivp-name = ~A~%" ivp-name)
884    (let ((sdinfo (lookup-def ivp-name env)))
885      (if (not sdinfo) (error 'make-prototype "unable to find prototype" name))
886      (let (
887            (ivar    (lookup-def 'ivar sdinfo))
888            (dvars   (lookup-def 'dvars sdinfo))
889            (hvar    (lookup-def 'hvar sdinfo))
890            (events  (lookup-def 'events sdinfo))
891            (ic      (lookup-def 'initial-conditions sdinfo))
892            (fields  (lookup-def 'fields sdinfo))
893            )
894        (let* ((ivpFn                (lookup-def 'ivp-id sdinfo))
895               (states               (cons ivar dvars))
896               (icstates             (filter (lambda (x) (member (car x) states)) ic))
897               (initialExpr/ML       (mlton-initial ic update: '((h . h))))
898               (fieldExpr/ML         (and (not (null? fields)) (mlton-initial fields)))
899               (initialStateExpr/ML  (mlton-initial icstates))
900               (copyStateIsyn/ML     (mlton-state-update 
901                                      (map car ic) 
902                                      nstate: "input" input: "initial" field-input: "fieldV"
903                                      states: states fields: (map car fields)
904                                      update: '((Isyn . Isyn_i))))
905               (copyStateNstate/ML   (mlton-state-update states input: "initial" states: states ))
906               )
907          (alist->tenv
908           `((name               . ,name)
909             (ivpFn              . ,ivpFn)
910             (ivar               . ,ivar)
911             (hvar               . ,hvar)
912             (states             . ,states)
913             (events             . ,(if (null? events) '(tnull) events))
914             (initialExprML      . ,initialExpr/ML)
915             (fieldExprML        . ,fieldExpr/ML)
916             (initialStateExprML . ,initialStateExpr/ML)
917             (copyStateIsynML    . ,copyStateIsyn/ML)
918             (copyStateNstateML  . ,copyStateNstate/ML)
919             ))
920          ))
921      ))
922  )
923 
924
925(define (make-population-tenv name prototype size order)
926  (alist->tenv
927   `((name      . ,name)
928     (prototype . ,prototype)
929     (size      . ,size)
930     (start     . ,order))
931   ))
932
933
934(define (population= x y) (equal? (car x) (car y)))
935
936
937(define (make-population-set node populations)
938  (let*
939      (
940
941       (fromlist-template 
942        (sxml:match 'nml:fromList
943                    (lambda (node bindings root env) 
944                      (let ((kids (sxml:kids node)))
945                        (fold (lambda (x ax)
946                                (lset-union population= 
947                                    (make-population-set x populations) ax))
948                              '() kids)
949                        ))
950                    ))
951
952       (union-template 
953        (sxml:match 'nml:union
954                    (lambda (node bindings root env) 
955                      (let ((left (sxml:kidn* 'nml:left node))
956                            (right (sxml:kidn* 'nml:right node)))
957                        (lset-union population=
958                                    (make-population-set (sxml:kid left) populations)
959                                    (make-population-set (sxml:kid right) populations))
960                        ))
961                    ))
962
963       (intersection-template 
964        (sxml:match 'nml:intersection
965                    (lambda (node bindings root env) 
966                      (let ((left (sxml:kidn* 'nml:left node))
967                            (right (sxml:kidn* 'nml:right node)))
968                        (lset-intersection population=
969                                           (make-population-set (sxml:kid left) populations)
970                                           (make-population-set (sxml:kid right) populations))
971                        ))
972                    ))
973
974       (difference-template 
975        (sxml:match 'nml:difference
976                    (lambda (node bindings root env) 
977                      (let ((left (sxml:kidn* 'nml:left node))
978                            (right (sxml:kidn* 'nml:right node)))
979                        (lset-difference population=
980                                         (make-population-set (sxml:kid left) populations)
981                                         (make-population-set (sxml:kid right) populations))
982                        ))
983                    ))
984
985       (singleton-template 
986        (sxml:match 'nml:singleton
987                    (lambda (node bindings root env) 
988                      (let ((name ($ (sxml:text node))))
989                        (let ((population (lookup-def name populations)))
990                          (if population
991                              `((,name . ,population))
992                              (error 'make-population-set "unknown population" name))
993                          ))
994                      )))
995       )
996
997    (stx:apply-templates 
998     node
999     (sxml:make-null-ss union-template
1000                        intersection-template
1001                        difference-template
1002                        singleton-template)
1003     node (list))
1004    ))
1005
1006   
1007   
1008(define (make-population-set-tenv name populations)
1009  (alist->tenv
1010   `((name        . ,name)
1011     (populations . ,(map cdr populations))
1012     (size        . ,(fold + 0 (map (lambda (x) 
1013                                      (ersatz:tvalue->sexpr (alist-ref 'size (cdr x)))) 
1014                                    populations)))
1015     )))
1016 
1017
1018(define (make-projection-tenv name type source target rule response properties)
1019  (alist->tenv
1020   `((name       . ,name)
1021     (type       . ,type)
1022     (source     . ,source)
1023     (target     . ,target)
1024     (rule       . ,rule)
1025     (response   . ,response)
1026     (properties . ,properties)
1027     )
1028   ))
1029 
1030 
1031
1032(define (make-response-tenv prefix name env)
1033  (let ((ivp-name ($ (string-append "ivp_" (->string name)))))
1034    (let ((sdinfo (lookup-def ivp-name env)))
1035      (if (not sdinfo) (error 'make-response "unable to find prototype" name))
1036      (let ((ivar    (lookup-def 'ivar sdinfo))
1037            (dvars   (lookup-def 'dvars sdinfo))
1038            (hvar    (lookup-def 'hvar sdinfo))
1039            (events  (lookup-def 'events sdinfo))
1040            (ic      (lookup-def 'initial-conditions sdinfo)))
1041        (let* ((ivpFn  (lookup-def 'ivp-id sdinfo))
1042               (states (cons ivar dvars))
1043               (icstates             (filter (lambda (x) (member (car x) states)) ic))
1044               (initialExpr/ML       (mlton-initial ic update: '((h . h))))
1045               (initialStateExpr/ML  (mlton-initial icstates))
1046               (copyStateIspike/ML   (mlton-state-update (map car ic) nstate: "input" input: "initial" 
1047                                                         states: states update: '((spike . spike_i) (Ispike . Ispike_i))))
1048               (copyStateNstate/ML   (mlton-state-update states input: "initial" states: states ))
1049               )
1050          (d "NineML make-response-tenv: states = ~A~%" states)
1051          (alist->tenv
1052           `((name               . ,name)
1053             (ivpFn              . ,ivpFn)
1054             (states             . ,states)
1055             (ics                . ,(map car ic))
1056             (initialExprML      . ,initialExpr/ML)
1057             (initialStateExprML . ,initialStateExpr/ML)
1058             (copyStateIspikeML  . ,copyStateIspike/ML)
1059             (copyStateNstateML  . ,copyStateNstate/ML)))
1060          ))
1061      ))
1062  )
1063
1064
1065(define (make-group-tenv name order populations sets projections psr-types
1066                         spikepoplst properties)
1067  (let ((alst 
1068         `((group 
1069            . 
1070            ((name        . ,name)
1071             (order       . ,order)
1072             (sets        . ,sets)
1073             (populations . ,populations)
1074             (projections . ,projections)
1075             (psrtypes    . ,(if (null? psr-types) #f psr-types))
1076             (properties  . ,(if (null? properties) '(tnull) properties))
1077             (spikepoplst . ,spikepoplst)
1078             ))
1079           ))
1080        )
1081    (alist->tenv alst)))
1082
1083
1084(define (eval-ul-group prefix ul-properties node env)
1085
1086  (define (projections-range projections)
1087    (let ((target-union
1088           (fold
1089            (lambda (x ax)
1090              (let* ((props (cdr x))
1091                     (target (ersatz:tvalue->sexpr (alist-ref 'target props))))
1092                (lset-union population= (alist-ref 'populations target) ax)))
1093            '() projections)))
1094      (fold (lambda (x ax) (+ (alist-ref 'size x) ax)) 0 target-union)
1095      ))
1096         
1097  (let (
1098        (group-name       (sxml:attr node 'name))
1099        (populations-sxml ((sxpath `(// nml:Population))  node))
1100        (sets-sxml        ((sxpath `(// nml:set))  node))
1101        (projections-sxml ((sxpath `(// nml:Projection)) node))
1102        (properties-sxml  ((sxpath `(nml:Property)) node))
1103        (spikerecord-sxml ((sxpath `(nml:SpikeRecording)) node))
1104        )
1105
1106    (d "UL group: ~A properties: ~A populations: ~A sets: ~A projections: ~A~%" 
1107       group-name properties-sxml populations-sxml sets-sxml projections-sxml)
1108
1109    (if (null? populations-sxml)
1110        (error 'eval-ul-group "group without populations" node))
1111
1112    (let* ((properties (parse-ul-properties group-name properties-sxml))
1113
1114           (populations+order
1115            (fold 
1116             (lambda (node ax)
1117               (let ((populations (car ax))
1118                     (order (cadr ax)))
1119                 (let* ((name (sxml:attr node 'name))
1120                        (prototype-name ($ (sxml:text (sxml:kidn* 'nml:reference (sxml:kidn* 'nml:prototype node)))))
1121                        (size (eval-ul-property group-name (sxml:kidn* 'nml:number node)))
1122                        (size-val (inexact->exact (cdr size))))
1123                   (list
1124                    (cons
1125                     `(,($ name) . ,(make-population-tenv ($ name) (make-prototype-tenv prefix prototype-name env) size-val order))
1126                     populations)
1127                    (+ size-val order)
1128                    ))
1129                 ))
1130             (list '() 0)
1131             populations-sxml))
1132
1133           (populations (reverse (car populations+order)))
1134           (order (cadr populations+order))
1135
1136           (sets
1137            (append
1138             (map (lambda (x) 
1139                    (let ((name (car x)))
1140                      `(,name . ((name . ,name) 
1141                                 (populations . ,(ersatz:sexpr->tvalue (list (cdr x))))
1142                                 (size . ,(alist-ref 'size (cdr x))))
1143                              )
1144                      ))
1145                  populations)
1146             (map (lambda (node)
1147                    (let* ((name (sxml:attr node 'name))
1148                           (set (make-population-set (sxml:kid node) populations)))
1149
1150                      `(,($ name) . ,(make-population-set-tenv ($ name) set))))
1151                  sets-sxml)))
1152
1153           (projections+psr-types 
1154            (map (lambda (node)
1155                   (let* (
1156                          (name          (sxml:attr node 'name))
1157                          (type          ($ (or (sxml:attr node 'type) "event")))
1158                          (source-name   ($ (sxml:text (sxml:kidn* 'nml:reference (sxml:kidn* 'nml:source node)))))
1159                          (target-name   ($ (sxml:text (sxml:kidn* 'nml:reference (sxml:kidn* 'nml:target node)))))
1160                          (response      (sxml:kidn* 'nml:response node))
1161                          (response-name (and response (sxml:text (sxml:kidn* 'nml:reference response ))))
1162                          (rule          (sxml:kidn* 'nml:rule node))
1163                          (rule-name     (sxml:text (sxml:kidn* 'nml:reference rule)))
1164                          (properties    (parse-ul-properties name (sxml:kidsn 'nml:Property rule)))
1165                          )
1166
1167                     (d "group-ul-eval: projection node = ~A~%" node)
1168                     (d "group-ul-eval: response = ~A response-name = ~A~%" response response-name)
1169                     (d "group-ul-eval: properties = ~A ~%" properties)
1170
1171                     (let (
1172                           (source (lookup-def source-name sets))
1173                           (target (lookup-def target-name sets))
1174                           (response (and response-name (make-response-tenv prefix response-name env)))
1175                           )
1176                       
1177                       (if (not source)
1178                           (error 'eval-ul-group "invalid projection source" source))
1179
1180                       (if (not target)
1181                           (error 'eval-ul-group "invalid projection target" target))
1182                       
1183                       (list `(,($ name) . ,(make-projection-tenv ($ name) type source target rule-name response-name properties))
1184                             `(,(and response-name ($ response-name)) (response . ,response) (projection . ,name)))
1185                       ))
1186                   )
1187                 projections-sxml))
1188
1189           (projections (map car projections+psr-types ))
1190           
1191           (psr-types (let* ((psr-types0 (filter car (map cadr projections+psr-types)))
1192                             (psr-projections
1193                              (fold (lambda (x ax)
1194                                      (let* ((psr-name (car x))
1195                                             (projection (alist-ref 'projection (cdr x)))
1196                                             (psr-projections (alist-ref psr-name ax)))
1197                                        (if psr-projections
1198                                            (alist-update psr-name (cons projection psr-projections) ax)
1199                                            (alist-update psr-name (list projection) ax))))
1200                                    '() psr-types0))
1201                             )
1202                        (map
1203                         (lambda (x)
1204                           (let* ((name (car x)) (response (alist-ref 'response (cdr x)))
1205                                  (projection-names (alist-ref name psr-projections)))
1206                             `(,name . ,(append response 
1207                                                `((projections . ,projection-names)
1208                                                  (range . ,(projections-range
1209                                                             (map (lambda (x) (alist-ref ($ x) projections)) 
1210                                                                  projection-names)))
1211                                                  )))
1212                             ))
1213                         (delete-duplicates psr-types0
1214                                            (lambda (x y) (eq? (car x) (car y)))
1215                                            psr-types0))
1216                        ))
1217                         
1218           )
1219
1220      (d "group-ul-eval: order = ~A~%" order)
1221
1222      (let* (
1223             (shared-dir    (chicken-home))
1224             (template-dir  (make-pathname (make-pathname shared-dir "9ML") "templates"))
1225             (network-tmpl  "Network.sml.tmpl")
1226             (sim-tmpl      "Sim.sml.tmpl")
1227             (mlb-tmpl      "Sim.mlb.tmpl")
1228             (makefile-tmpl "Makefile.tmpl")
1229             (group-path    (make-pathname (pathname-directory prefix)
1230                                           (string-append group-name ".sml")))
1231             (sim-path      (make-pathname (pathname-directory prefix)
1232                                           (string-append "Sim" group-name ".sml")))
1233             (mlb-path      (make-pathname (pathname-directory prefix)
1234                                           (string-append "Sim" group-name ".mlb")))
1235             (exec-path     (make-pathname (pathname-directory prefix)
1236                                           (string-append "Sim" group-name)))
1237             (makefile-path (make-pathname (pathname-directory prefix) 
1238                                           (string-append "Makefile." group-name)))
1239             (spikelst      (fold (lambda (node ax)
1240                                    (let ((set (alist-ref ($ (sxml:attr node 'set)) sets)))
1241                                      (let ((populations
1242                                             (let ((poplst (alist-ref 'populations set)))
1243                                               (ersatz:tvalue->sexpr poplst))))
1244                                        (append
1245                                         (map (lambda (x) (->string (alist-ref 'name x))) populations)
1246                                         ax))))
1247                                  '() spikerecord-sxml))
1248             (group-tenv    (make-group-tenv group-name order populations sets projections psr-types 
1249                                             spikelst (append properties ul-properties) ))
1250
1251             )
1252
1253        (d "group-tenv = ~A~%" (map (lambda (x) (cons (car x) (ersatz:tvalue->sexpr (cdr x)))) group-tenv))
1254
1255        (make (
1256
1257               (group-path (prefix)
1258                           (with-output-to-file group-path 
1259                             (lambda ()
1260                               (print (ersatz:from-file 
1261                                       network-tmpl
1262                                       env: (template-std-env search-path: `(,template-dir))
1263                                       models: group-tenv))))
1264                           )
1265       
1266               (sim-path (prefix)
1267                         (with-output-to-file sim-path 
1268                           (lambda ()
1269                             (print (ersatz:from-file 
1270                                     sim-tmpl
1271                                     env: (template-std-env search-path: `(,template-dir))
1272                                     models: group-tenv))))
1273                         )
1274               
1275               (mlb-path ()
1276                         (with-output-to-file mlb-path 
1277                           (lambda ()
1278                             (print (ersatz:from-file 
1279                                     mlb-tmpl
1280                                     env: (template-std-env search-path: `(,template-dir))
1281                                         models: group-tenv))))
1282                         )
1283
1284               (makefile-path ()
1285                              (with-output-to-file makefile-path 
1286                                (lambda ()
1287                                  (print (ersatz:from-file 
1288                                          makefile-tmpl
1289                                          env: (template-std-env search-path: `(,template-dir))
1290                                          models: (append
1291                                                   group-tenv
1292                                                   `((sml_lib_home . ,(Tstr (make-pathname 
1293                                                                             (make-pathname shared-dir "flsim")
1294                                                                             "sml-lib")))))
1295                                          ))))
1296                              )
1297
1298               (exec-path (group-path sim-path mlb-path makefile-path)
1299                          (run (make -f ,makefile-path)))
1300
1301               )
1302
1303          (list exec-path) )
1304        ))
1305    ))
1306 
1307
1308(define (main options operands)
1309
1310  (if (options 'help) (network:usage))
1311
1312  (let ((find-module (lambda (x) (env-find-module x (current-type-env)))))
1313    (for-each (lambda (init name) (init name enter-module find-module current-eval-env))
1314              (list Real:module-initialize   
1315                    Random:module-initialize   
1316                    Signal:module-initialize   
1317                    Diagram:module-initialize 
1318                    IVP:module-initialize 
1319                    Generator:module-initialize   )
1320              (list "Real" "Random" "Signal" "Diagram" "IVP" "Generator"  )) )
1321
1322  (if (null? operands)
1323
1324      (network:usage)
1325
1326      (let ((output-type (cond ((options 'output-xml)  'xml)
1327                               ((options 'output-sxml) 'sxml)
1328                               (else #f))))
1329
1330        (if (options 'verbose) (begin (eval-verbose 1) (ivp-verbose 1) (network-verbose 1)))
1331        (simulation-platform (or (options 'platform) (defopt 'platform) ))
1332
1333        (for-each
1334
1335         (lambda (operand)
1336
1337           (let* (
1338                  (ul-sxml (parse-xml (read-all operand)))
1339                  (ul-imports ((sxpath `(// nml:NineML nml:import))  ul-sxml))
1340                  (ul-import-sxmls (map (lambda (x) (parse-xml (fetch (sxml-string->uri (sxml:text x))))) ul-imports))
1341                  )
1342
1343             (let* (
1344                    (ul-sxml (fold append ul-sxml ul-import-sxmls))
1345                    (ul-properties  (parse-ul-properties
1346                                     operand ((sxpath `(// nml:NineML nml:Property))  ul-sxml)))
1347                    (ul-groups ((sxpath `(// nml:NineML nml:Group))  ul-sxml))
1348
1349                    (ul-components ((sxpath `(// nml:NineML nml:Component))  ul-sxml))
1350                    (ul-component-uenvs (map eval-ul-component ul-components))
1351                   
1352                    (ivp-node-env (make-parameter '()))
1353                    )
1354
1355               (d "ul-properties = ~A~%" ul-properties)
1356               (d "ul-groups = ~A~%" ul-groups)
1357
1358               (for-each
1359                (lambda (uenv) 
1360               
1361                  (let (
1362                        (source-defs (car uenv))
1363                        (mty         (cadr uenv))
1364                        (eval-env    (caddr uenv))
1365                        )
1366                   
1367                    (let ((type-env-opt (options 'print-type-env)))
1368                      (if type-env-opt
1369                          (if (and (string? type-env-opt) (string=?  type-env-opt "all"))
1370                              (print-type-env mty output-type)
1371                              (let ((fc (lambda (x) (and (member (ident-name (car x)) type-env-opt) x))))
1372                                (print-type-env mty output-type fc)))
1373                          ))
1374                   
1375                    (let ((eval-env-opt (options 'print-eval-env)))
1376                      (if eval-env-opt
1377                          (if (and (string? eval-env-opt) (string=? eval-env-opt "all"))
1378                              (print-eval-env eval-env output-type)
1379                              (let ((fc (lambda (x) (and (member (ident-name (car x)) eval-env-opt) x))))
1380                                (print-eval-env eval-env output-type fc)))
1381                          ))
1382                   
1383                    (if (options 'print-source-defs)
1384                        (print-source-defs source-defs output-type))
1385                   
1386                    (if (options 'single-ivp)
1387                        (begin
1388                          (traverse-definitions operand uenv value-hook: (make-ivp-data-hook ivp: #t))
1389                          (process-wait) )
1390                        (traverse-definitions operand uenv value-hook: (make-ivp-cgen-hook ivp-node-env))
1391                        )
1392                   
1393                    ))
1394                 ul-component-uenvs)
1395
1396               (d "ivp-node-env = ~A~%" (ivp-node-env))
1397
1398               (for-each (lambda (x) (eval-ul-group operand ul-properties x (ivp-node-env))) ul-groups)
1399
1400               ))
1401           )
1402
1403         operands))))
1404
1405(main opt (opt '@))
1406
1407
Note: See TracBrowser for help on using the repository browser.