source: project/release/3/nemo/trunk/nemo.scm @ 12469

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

Added an option for user-supplied depend variables.

File size: 25.0 KB
Line 
1;;
2;; NEMO
3;;
4;; Copyright 2008 Ivan Raikov.
5;;
6;; This program is free software: you can redistribute it and/or
7;; modify it under the terms of the GNU General Public License as
8;; published by the Free Software Foundation, either version 3 of the
9;; License, or (at your option) any later version.
10;;
11;; This program is distributed in the hope that it will be useful, but
12;; WITHOUT ANY WARRANTY; without even the implied warranty of
13;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
14;; General Public License for more details.
15;;
16;; A full copy of the GPL license can be found at
17;; <http://www.gnu.org/licenses/>.
18;;
19
20
21(require-extension srfi-1)
22(require-extension syntax-case)
23(require-extension matchable)
24(require-extension args)
25(require-extension nemo-macros)
26(require-extension nemo-hh)
27
28(define nemo-nmodl? (extension-information 'nemo-nmodl)) 
29(define nemo-matlab? (extension-information 'nemo-matlab)) 
30
31(if nemo-nmodl? (use nemo-nmodl))
32(if nemo-matlab? (use nemo-matlab))
33
34(define (lookup-def k lst . rest)
35  (let-optionals rest ((default #f))
36      (let ((kv (assoc k lst)))
37        (if (not kv) default
38            (match kv ((k v) v) (else (cdr kv)))))))
39
40(define ($ x)  (and x (string->symbol (->string x))))
41
42;;; Procedures for string concatenation and pretty-printing
43
44(define (s+ . lst)    (string-concatenate (map ->string lst)))
45(define (sw+ lst)     (string-intersperse (filter-map (lambda (x) (and x (->string x))) lst) " "))
46(define (s\ p . lst)  (string-intersperse (map ->string lst) p))
47(define (sl\ p lst)   (string-intersperse (map ->string lst) p))
48(define nl "\n")
49
50
51(define (warn port message . specialising-msgs)
52  (print-error-message message (current-output-port) "Warning")
53  (print (string-concatenate (map ->string specialising-msgs))))
54
55;;; Error procedure for the XML parser
56
57(define (parser-error port message . specialising-msgs)
58  (error (string-append message (string-concatenate (map ->string specialising-msgs)))))
59
60(define ssax:warn warn)
61
62(define opts
63  `(
64    ,(args:make-option (i)       (required: "FORMAT")   
65                       (s+ "specify input format (nemo, xml, sxml, s-exp)")
66                       (string->symbol arg))
67    ,(args:make-option (xml)       (optional: "FILE")   
68                       (s+ "write XML output to file (default: <model-name>.xml)"))
69    ,(args:make-option (sxml)       (optional: "FILE")   
70                       (s+ "write SXML output to file (default: <model-name>.sxml)"))
71    ,@(if nemo-matlab? 
72          (list (args:make-option (matlab)      (optional: "FILE")   
73                                  (s+ "write MATLAB output to file (default: <model-name>.m)")))
74          `())
75    ,@(if nemo-nmodl?
76          (list
77           (args:make-option (nmodl)      (optional: "FILE")   
78                             (s+ "write NMODL output to file (default: <model-name>.mod)"))
79           (args:make-option (nmodl-kinetic)       (optional: "STATES")
80                             (s+ "use NMODL kinetic equations for the given state complexes "
81                                 "(or for all state complexes)"))
82           (args:make-option (nmodl-method)       (required: "METHOD")
83                             (s+ "specify NMODL integration method")
84                             (string->symbol arg))
85           (args:make-option (nmodl-depend)       (required: "VARS")
86                             (s+ "specify DEPEND variables for NMODL interpolation tables")
87                             (map string->symbol (string-split arg ","))))
88          `())
89    ,(args:make-option (t)       #:none
90                       (s+ "use interpolation tables in generated code, if possible")
91                       #t)
92    ,(args:make-option (h help)  #:none               "Print help"
93                       (usage))
94
95    ))
96
97
98;; Use args:usage to generate a formatted list of options (from OPTS),
99;; suitable for embedding into help text.
100(define (usage)
101  (print "Usage: " (car (argv)) " [options...] <list of files to be processed> ")
102  (newline)
103  (print "The following options are recognized: ")
104  (newline)
105  (print (parameterize ((args:indent 5) (args:width 30)) (args:usage opts)))
106  (exit 1))
107
108
109;; Process arguments and collate options and arguments into OPTIONS
110;; alist, and operands (filenames) into OPERANDS. 
111(define args    (command-line-arguments))
112(set!-values (options operands)  (args:parse args opts))
113
114
115(define (ncml:sxpath query doc)
116  ((sxpath query '((ncml . "ncml"))) doc))
117
118(define (ncml:car-sxpath query doc)
119  (let ((lst ((sxpath query '((ncml . "ncml") )) doc)))
120    (car lst)))
121
122(define (ncml:if-car-sxpath query doc)
123  (let ((lst ((sxpath query '((ncml . "ncml") )) doc)))
124    (and (not (null? lst)) (car lst))))
125
126(define (ncml:if-sxpath query doc)
127  (let ((lst ((sxpath query '((ncml . "ncml") )) doc)))
128    (and (not (null? lst)) lst)))
129
130(define (ncml-binding->binding node)
131  (match node
132    (('ncml:bnd ('@ ('id id)) ('ncml:expr expr))
133     `(,($ id) ,(ncml-expr->expr expr)))
134    (else (error 'ncml-binding->binding "invalid binding " node))))
135 
136(define (ncml-expr->expr node)
137  (match node
138         ((? number?)    node)
139         ((? string?)    (sxml:number node))
140         (('ncml:id id)  (string->symbol (->string id)))
141         (('ncml:apply ('@ ('id id)) . args)  (cons ($ id) (map ncml-expr->expr args)))
142         (('ncml:let ('ncml:bnds . bnds) ('ncml:expr body))
143          `(let ,(map ncml-binding->binding bnds) ,(ncml-expr->expr body)))
144         (((and op (? symbol?)) . args)       
145          (cons (ncml-op->op op) (map ncml-expr->expr args)))
146         (else (error 'ncml-expr->expr "unknown expression " node))))
147 
148
149(define (ncml-op->op op)
150  (case op
151    ((ncml:sum)    '+)
152    ((ncml:sub)    '-)
153    ((ncml:mul)    '*)
154    ((ncml:div)    '/)
155    ((ncml:gt)     '>)
156    ((ncml:lt)     '<)
157    ((ncml:lte)    '<=)
158    ((ncml:gte)    '>=)
159    ((ncml:eq)     '=)
160    (else          (match (string-split (->string op) ":")
161                          ((pre op)  (string->symbol op))
162                          (else (error 'ncml-op->op "invalid operator" op))))))
163
164
165(define (nemo-constructor name declarations parse-expr)
166  (let* ((nemo   (make-nemo-core))
167         (sys    ((nemo 'system) name)))
168    (eval-nemo-system-decls nemo name sys declarations parse-expr)
169    (list sys nemo)))
170
171(define (sexp->model options doc parse-expr)
172  (match doc
173         (('nemo-model model-name model-decls)
174          (let* ((model+nemo  (nemo-constructor model-name model-decls parse-expr))
175                 (model (first model+nemo))
176                 (nemo  (second model+nemo)))
177            (let ((model-1 (nemo:hh-transformer model parse-expr))) 
178              (if (assoc 'depgraph options) (print "dependency graph: " ((nemo 'depgraph*) model-1)))
179              (if (assoc 'exports options) (print "exports: " ((nemo 'exports) model-1)))       
180              (if (assoc 'imports options) (print "imports: " ((nemo 'imports) model-1)))
181              (if (assoc 'components options)
182                  (for-each (lambda (x) 
183                              (print "component " x ": " ((nemo 'component-exports) model-1 (second x)))
184                              (print "component " x " subcomponents: " ((nemo 'component-subcomps) model-1 (second x))))
185                            ((nemo 'components) model-1)))
186              model-1)))
187         (else (error 'sexp->model "unknown model format"))))
188
189(define model->nmodl 
190  (if nemo-nmodl?
191      (lambda (options model)
192        (nemo:nmodl-translator model (lookup-def 'method options) (lookup-def 'table options) 
193                               -150 150 1 (lookup-def 'depend options)
194                               (lookup-def 'kinetic options) ))
195      (lambda (options model) 
196        (void))))
197
198(define model->matlab 
199  (if nemo-matlab?
200      (lambda (options model)
201        (nemo:matlab-translator model (lookup-def 'method options) (lookup-def 'table options) 
202                                -150 150 1 #f
203                                (lookup-def 'kinetic options) ))
204      (lambda (options model) 
205        (void))))
206
207
208(define (transition->ncml-transition x)
209  (match x
210         (('-> src dst rate) 
211          `((ncml:transition (@ (src ,src) (dst ,dst))  (ncml:rate ,(expr->ncml-expr rate)))))
212         ((src '-> dst rate) 
213          `((ncml:transition (@ (src ,src) (dst ,dst))  (ncml:rate ,(expr->ncml-expr rate)))))
214         (('<-> src dst rate1 rate2) 
215          `((ncml:transition (@ (src ,src) (dst ,dst))  (ncml:rate ,(expr->ncml-expr rate1)))
216            (ncml:transition (@ (src ,dst) (dst ,src))  (ncml:rate ,(expr->ncml-expr rate2)))))
217         ((src '<-> dst rate1 rate2) 
218          `((ncml:transition (@ (src ,src) (dst ,dst))  (ncml:rate ,(expr->ncml-expr rate1)))
219            (ncml:transition (@ (src ,dst) (dst ,src))  (ncml:rate ,(expr->ncml-expr rate2)))))
220         (else (error 'transition->ncml-transition "invalid transition " x))))
221
222(define builtin-fns
223  `(+ - * / pow neg abs atan asin acos sin cos exp ln
224      sqrt tan cosh sinh tanh hypot gamma lgamma log10 log2 log1p ldexp cube
225      > < <= >= = and or round ceiling floor max min))
226
227(define (binding->ncml-binding bnd)
228  (match bnd
229         ((id expr)  `(ncml:bnd (@ (id ,id)) (ncml:expr ,(expr->ncml-expr expr))))
230         (else (error 'binding->ncml-binding "invalid binding " bnd))))
231 
232(define (expr->ncml-expr x)
233  (match x
234         ((? number?)    x)
235         ((? symbol?)    `(ncml:id ,x))
236         (('let bnds expr)
237          `(ncml:let (ncml:bnds . ,(map binding->ncml-binding bnds)) 
238                     (ncml:expr ,(expr->ncml-expr expr))))
239         (((and op (? symbol?)) . args)       
240          (let ((ncml-expr (if (member op builtin-fns)
241                               (cons (op->ncml-op op) (map expr->ncml-expr args))
242                               `(ncml:apply (@ (id ,op)) ,@(map expr->ncml-expr args)))))
243            ncml-expr))
244         (else (error 'expr->ncml-expr "unknown expression " x))))
245
246 
247
248(define (op->ncml-op op)
249  (case op
250    ((+)  'ncml:sum)
251    ((-)  'ncml:sub)
252    ((*)  'ncml:mul)
253    ((/)  'ncml:div)
254    ((>)  'ncml:gt)
255    ((<)  'ncml:lt)
256    ((<=) 'ncml:lte)
257    ((>=) 'ncml:gte)
258    ((=)  'ncml:eq)
259    (else  (string->symbol (string-append "ncml:" (->string op))))))
260
261
262(define (make-component->ncml dis model)
263  (lambda (x) 
264    (let ((en (environment-ref model x)))
265      (cond ((procedure? en)
266             (let ((fd (procedure-data en)))
267               `(ncml:defun (@ (id ,x)) 
268                            ,@(map (lambda (v) `(ncml:arg ,v)) (lookup-def 'vars fd))
269                            (ncml:body ,(expr->ncml-expr (lookup-def 'body fd))))))
270            (else
271             (match en
272                   
273                    (($ nemo:quantity 'EXTERNAL   local-name name namespace)
274                     (if namespace
275                         `(ncml:input (@ (id ,name)) (as ,local-name) (from ,namespace))
276                         `(ncml:input (@ (id ,name)) (as ,local-name))))
277                    (($ nemo:quantity 'CONST  name value) 
278                     `(ncml:const (@ (id ,name)) (ncml:expr ,value)))
279                   
280                    (($ nemo:quantity 'ASGN name value rhs)
281                     (let ((expr (expr->ncml-expr rhs)))
282                       `(ncml:asgn (@ (id ,name)) (ncml:expr ,expr))))
283                   
284                    (($ nemo:quantity 'TSCOMP name initial open trs p) 
285                     (let ((sxml-trs (append-map transition->ncml-transition trs)))
286                       `(ncml:state_complex (@ (id ,name))
287                                            (ncml:open ,open) (ncml:initial ,(expr->ncml-expr initial))
288                                            (ncml:transitions ,@sxml-trs)
289                                            (ncml:power ,(expr->ncml-expr p)))))
290                   
291                    (($ nemo:quantity 'COMPONENT name type lst) 
292                     (let ((component->ncml (make-component->ncml dis model))
293                           (component-exports ((dis 'component-exports) model x)))
294                       (case type
295                         ((toplevel) `(,@(map component->ncml lst)
296                                       ,@(map (lambda (x) `(ncml:output (@ (id ,x)))) component-exports)))
297                         (else `(ncml:component (@ (name ,name) (type ,type))
298                                                ,@(filter-map component->ncml lst)
299                                                ,@(map (lambda (x) `(ncml:output (@ (id ,x)))) component-exports)
300                                                )))))
301                     
302                     (else #f)))))))
303   
304
305(define (model->ncml options model)
306  (match-let ((($ nemo:quantity 'DISPATCH  dis)     (environment-ref model (nemo-intern 'dispatch))))
307     (let ((sysname     ((dis 'sysname) model))
308           (component->ncml (make-component->ncml dis model)))
309       `(ncml:model (@ (name ,sysname)) ,@(component->ncml (nemo-intern 'toplevel))))))
310           
311
312(include "expr-parser.scm")
313
314(require-extension stx-engine)
315(require-extension sxpath-plus)
316(require-extension sxml-transforms)
317(require-extension sxml-tools)
318
319(include "SXML.scm")
320(include "SSAX.scm")
321(include "SXML-to-XML.scm")
322
323
324(define null-template 
325  `(*default* ,(lambda (node bindings root env) 
326                 (begin
327                   (warn "Unrecognized input element:" node)
328                   '()))))
329
330(define-syntax  sxml:make-null-ss
331   (syntax-rules  ()
332      ((stx rule ...)
333       (list
334        ; default handler
335        null-template
336        ; handler for textual nodes
337        (list '*text*  (lambda (text) text)) 
338        rule ...))))
339
340(define (ensure-xmlns doc)
341  (sxml:add-attr doc '(xmlns ncml)))
342
343
344;; based on SRV:send-reply by Oleg Kiselyov
345(define (print-fragments b)
346  (let loop ((fragments b) (result #f))
347    (cond
348      ((null? fragments) result)
349      ((not (car fragments)) (loop (cdr fragments) result))
350      ((null? (car fragments)) (loop (cdr fragments) result))
351      ((eq? #t (car fragments)) (loop (cdr fragments) #t))
352      ((pair? (car fragments))
353        (loop (cdr fragments) (loop (car fragments) result)))
354      ((procedure? (car fragments))
355        ((car fragments))
356        (loop (cdr fragments) #t))
357      (else
358       (display (car fragments))
359       (loop (cdr fragments) #t)))))
360
361
362(define (ncml->decls ncml:model)
363  (letrec
364      ((input-template 
365        (sxml:match 'ncml:input
366                    (lambda (node bindings root env) 
367                      (let ((id    (sxml:attr node 'id))
368                            (from  (sxml:kidn* 'ncml:from node))
369                            (as    (sxml:kidn* 'ncml:as node)))
370                        (if (not id) (error 'input-template "input declaration requires id attribute"))
371                        (cond ((and from as)  `(input (,($ id) as ,($ (second as) ) from ,($ (second from)) )))
372                              (from           `(input (,($ id) from ,($ (second from)))))
373                              (as             `(input (,($ id) as ,($ (second as)))))
374                              (else           `(input ,($ id))))))))
375       
376       (output-template 
377        (sxml:match 'ncml:output
378                    (lambda (node bindings root env) 
379                      (let ((id   (sxml:attr node 'id)))
380                        (if (not id) (error 'output-template "output declaration requires id attribute"))
381                        `(output ,($ id))))))
382       
383       (const-template 
384        (sxml:match 'ncml:const
385                    (lambda (node bindings root env) 
386                      (let* ((id   (sxml:attr node 'id))
387                             (expr ((lambda (x) 
388                                      (if (not x) 
389                                          (error 'const-template "const declaration " id " requires expr element")
390                                          (ncml-expr->expr (second x))))
391                                   (sxml:kidn* 'ncml:expr node))))
392                        (if (not id) (error 'const-template "const declaration requires id attribute"))
393                        `(const ,($ id) = ,expr)))))
394       
395       (state-complex-transition-template 
396        (sxml:match 'ncml:transition
397                    (lambda (node bindings root env) 
398                      (let ((src  (sxml:attr node 'src))
399                            (dst  (sxml:attr node 'dst))
400                            (rate  ((lambda (x) 
401                                      (if (not x) 
402                                          (error 'state-complex-transition-template 
403                                                 "state complex transition requires rate element")
404                                          (ncml-expr->expr (second x))))
405                                    (sxml:kidn* 'ncml:rate node))))
406                        (if (not src) (error 'state-complex-transition-template
407                                             "state complex transition requires src attribute"))
408                        (if (not dst) (error 'state-complex-transition-template
409                                             "state complex transition requires dst attribute"))
410                       
411                        `(-> ,($ src) ,($ dst) ,rate)))))
412       
413       (asgn-template 
414        (sxml:match 'ncml:asgn
415                    (lambda (node bindings root env) 
416                      (let ((id   (sxml:attr node 'id))
417                            (expr ((lambda (x) 
418                                     (if (not x) 
419                                          (error 'asgn-template "algebraic assignment requires expr element")
420                                          (ncml-expr->expr (second x))))
421                                   (sxml:kidn* 'ncml:expr node))))
422                        (if (not id) (error 'asgn-template "algebraic assignment requires id attribute"))
423                        `(,($ id) = ,expr)))))
424       
425       
426       (state-complex-template 
427        (sxml:match 'ncml:state_complex
428                    (lambda (node bindings root env) 
429                      (let ((id   (string->symbol (->string (sxml:attr node 'id))))
430                            (initial ((lambda (x) 
431                                        (if (not x) 
432                                            (error 'state-complex-template 
433                                                   "state complex declaration requires initial element")
434                                            (ncml-expr->expr (second x))))
435                                      (sxml:kidn* 'ncml:initial node)))
436                            (open ((lambda (x) 
437                                     (if (not x) 
438                                         (error 'state-complex-template
439                                                "state complex declaration requires open element")
440                                         ($ (second x))))
441                                   (sxml:kidn* 'ncml:open node)))
442                            (power ((lambda (x) 
443                                      (if (not x) 
444                                          (error 'state-complex-template
445                                                 "state complex declaration requires open element")
446                                          (sxml:number (second x))))
447                                    (sxml:kidn* 'ncml:power node)))
448                            (transitions ((lambda (x) 
449                                            (if (not x) 
450                                                (error 'state-complex-template
451                                                       "state complex declaration requires transitions element")
452                                                (let ((tmpl (sxml:make-null-ss state-complex-transition-template)))
453                                                  (stx:apply-templates (cdr x) tmpl root env))))
454                                          (sxml:kidn* 'ncml:transitions node))))
455                                         
456                        (if (not id) (error 'state-complex-template "state complex transition requires id attribute"))
457                        `(state-complex (,id (initial ,initial) (open ,open) (power ,power)
458                                             (transitions ,@transitions)))))))
459
460
461       (defun-template 
462        (sxml:match 'ncml:defun
463                    (lambda (node bindings root env) 
464                      (let ((id    (sxml:attr node 'id))
465                            (args  ((lambda (x) 
466                                      (if (null? x) 
467                                          (error 'defun-template 
468                                                 "function definition requires at least one arg element")
469                                          (map (compose $ second) x)))
470                                    (sxml:kidsn 'ncml:arg node)))
471                            (body ((lambda (x) 
472                                     (if (not x) 
473                                         (error 'defun-template
474                                                "function definition requires body element")
475                                         (ncml-expr->expr (second x))))
476                                   (sxml:kidn* 'ncml:body node))))
477                        (if (not id) (error 'defun-template "function definition requires id attribute"))
478                        `(defun ,($ id) ,args ,body)))))
479
480       (component-template
481        (sxml:match 'ncml:component
482                    (lambda (node bindings root env)
483                      (let ((name (sxml:attr node 'name))
484                            (type (sxml:attr node 'type)))
485                        (if (not type) (error 'component-template "component definition requires type attribute"))
486                        (if name
487                            `(component (type ,($ type)) (name ,($ name)) ,@(ncml->decls (sxml:kids node)))
488                            `(component (type ,($ type)) ,@(ncml->decls (sxml:kids node))))))))
489
490       (hh-template 
491        (sxml:match 'ncml:hh_ionic_conductance 
492                    (lambda (node bindings root env)
493                      (let* ((or-expr   (lambda (x) (and x (ncml-expr->expr (second x)))))
494                             (id         (sxml:attr node 'id))
495                             (initial_m  (or-expr (sxml:kidn* 'ncml:initial_m node)))
496                             (initial_h  (or-expr (sxml:kidn* 'ncml:initial_h node)))
497                             (m_power    (or-expr (sxml:kidn* 'ncml:m_power node)))
498                             (h_power    (or-expr (sxml:kidn* 'ncml:h_power node)))
499                             (m_alpha    (or-expr (sxml:kidn* 'ncml:m_alpha node)))
500                             (m_beta     (or-expr (sxml:kidn* 'ncml:m_beta node)))
501                             (h_alpha    (or-expr (sxml:kidn* 'ncml:h_alpha node)))
502                             (h_beta     (or-expr (sxml:kidn* 'ncml:h_beta node)))
503                             (m_tau      (or-expr (sxml:kidn* 'ncml:m_tau node)))
504                             (m_inf      (or-expr (sxml:kidn* 'ncml:m_inf node)))
505                             (h_tau      (or-expr (sxml:kidn* 'ncml:h_tau node)))
506                             (h_inf      (or-expr (sxml:kidn* 'ncml:h_inf node))))
507                        (if (not id)
508                            (error 'hh-template "hh ionic conductance definition requires id attribute"))
509                        `(hh-ionic-conductance 
510                          (,($ id)
511                           ,@(if initial_m `((initial-m ,initial_m)) `())
512                           ,@(if initial_h `((initial-h ,initial_h)) `())
513                           ,@(if m_power `((m-power ,m_power)) '())
514                           ,@(if h_power `((h-power ,h_power)) '())
515                           ,@(if m_alpha `((m-alpha ,m_alpha)) '())
516                           ,@(if h_alpha `((h-alpha ,h_alpha)) '())
517                           ,@(if m_beta  `((m-beta ,m_beta)) '())
518                           ,@(if h_beta  `((h-beta ,h_beta)) '())
519                           ,@(if m_inf   `((m-inf ,m_inf)) '())
520                           ,@(if h_inf   `((h-inf ,h_inf)) '())
521                           ,@(if m_tau   `((m-tau ,m_tau)) '())
522                           ,@(if h_tau   `((h-tau ,h_tau)) '())
523                           ))))))
524
525       (decaying-pool-template 
526        (sxml:match 'ncml:decaying_pool 
527                    (lambda (node bindings root env)
528                      (let* ((or-expr   (lambda (x) (and x (ncml-expr->expr (second x)))))
529                             (id         (sxml:attr node 'id))
530                             (initial    (or-expr (sxml:kidn* 'ncml:initial node)))
531                             (beta       (or-expr (sxml:kidn* 'ncml:beta node)))
532                             (depth      (or-expr (sxml:kidn* 'ncml:depth node)))
533                             (temp-adj   (or-expr (sxml:kidn* 'ncml:temp_adj node))))
534                        (if (not id)
535                            (error 'decaying-pool-template "decaying pool definition requires id attribute"))
536                        (if (not initial) 
537                            (error 'decaying-pool-template "decaying pool definition requires initial value"))
538                        (if (not beta) 
539                            (error 'decaying-pool-template "decaying pool definition requires beta parameter"))
540                        (if (not depth) 
541                            (error 'decaying-pool-template "decaying pool definition requires depth parameter"))
542                           
543                        `(decaying-pool 
544                          (,($ id)
545                           ,@(if temp_adj `((temp_adj ,temp_adj)) `())
546                           (beta ,beta)
547                           (depth ,depth)
548                           (initial ,initial)))))))
549        )
550
551    (stx:apply-templates ncml:model (sxml:make-null-ss input-template
552                                                       output-template
553                                                       const-template
554                                                       asgn-template
555                                                       state-complex-template
556                                                       defun-template
557                                                       component-template
558                                                       hh-template
559                                                       decaying-pool-template) 
560                         ncml:model (list))))
561
562
563
564(define (ncml->model options doc)
565  (let* ((ncml:model   ((lambda (x) 
566                          (if (null? x) (error 'ncml->model "ncml:model element not found in input document") (car x)))
567                        (ncml:sxpath '(ncml:model) `(*TOP* . ,doc))))
568         (model-name   (sxml:attr ncml:model 'name))
569         (model-decls  (ncml->decls (sxml:kids ncml:model))))
570    (let* ((model+nemo  (nemo-constructor model-name model-decls identity))
571           (model (first model+nemo))
572           (nemo  (second model+nemo)))
573      (let ((model-1 (nemo:hh-transformer model))) 
574        (if (assoc 'depgraph options) (print "dependency graph: " ((nemo 'depgraph*) model-1)))
575        (if (assoc 'exports options) (print "exports: " ((nemo 'exports) model-1)))     
576        (if (assoc 'imports options) (print "imports: " ((nemo 'imports) model-1)))
577        (if (assoc 'components options)
578            (for-each (lambda (x) 
579                        (print "component " x ": " ((nemo 'component-exports) model-1 (second x)))
580                        (print "component " x " subcomponents: " ((nemo 'component-subcomps) model-1 (second x))))
581                      ((nemo 'components) model-1)))
582        model-1))))
583
584
585 
586(define (main options operands)
587  (if (null? operands)
588      (usage)
589      (for-each
590       (lambda (operand)
591         (let* ((read-xml   (lambda (name) (call-with-input-file name
592                                            (lambda (port) (ssax:xml->sxml port '((ncml . "ncml")))) )))
593                (read-sexp  (lambda (name) (call-with-input-file name read)))
594                (in-format  (cond ((lookup-def 'i options) =>
595                                   (lambda (x) 
596                                     (case ($ x)
597                                       ((nemo)        'nemo)
598                                       ((s-exp sexp)  'sexp)
599                                       ((sxml)  'sxml)
600                                       ((xml)   'xml)
601                                       (else    (error 'nemo "unknown input format" x)))))
602                                  (else  (case ((lambda (x) (or (not x) ($ x)))
603                                                (pathname-extension operand))
604                                           ((s-exp sexp)  'sexp)
605                                           ((sxml)  'sxml)
606                                           ((xml)   'xml)
607                                           (else    'nemo)))))
608                (doc        (case in-format
609                              ((nemo sxml s-exp sexp)  (read-sexp operand))
610                              ((xml)   (read-xml operand))
611                              (else    (error 'nemo "unknown input format" in-format))))
612                (model       (case in-format
613                               ((sxml xml)          (ncml->model options doc))
614                               ((s-exp sexp)        (sexp->model options doc identity))
615                               ((nemo)              (sexp->model options doc nemo:parse-sym-expr))
616                               (else    (error 'nemo "unknown input format" in-format))))
617                (sxml-fname  ((lambda (x) (and x (if (and (cdr x) (string? (cdr x)))
618                                                     (s+ (pathname-strip-extension (cdr x)) ".sxml")
619                                                     (s+  (pathname-strip-extension operand) ".sxml"))))
620                              (assoc 'sxml options)))
621                (xml-fname  ((lambda (x)  (and x (if (and (cdr x) (string? (cdr x)))
622                                                     (s+ (pathname-strip-extension (cdr x)) ".xml")
623                                                     (s+  (pathname-strip-extension operand) ".xml"))))
624                              (assoc 'xml options)))
625                (mod-fname  ((lambda (x) (and x (if (and (cdr x) (string? (cdr x)))
626                                                    (s+ (pathname-strip-extension (cdr x)) ".mod")
627                                                    (s+  (pathname-strip-extension operand) ".mod"))))
628                             (assoc 'nmodl options)))
629                (mat-fname  ((lambda (x) (and x (if (and (cdr x) (string? (cdr x)))
630                                                    (s+ (pathname-strip-extension (cdr x)) ".m")
631                                                    (s+  (pathname-strip-extension operand) ".m"))))
632                             (assoc 'matlab options)))
633                (nmodl-depend  (lookup-def 'nmodl-depend options))
634                                 
635                (nmodl-method
636                 (let ((method  ($ (lookup-def 'nmodl-method options) )))
637                   (case method
638
639                     ((adams runge euler adeuler heun adrunge gear
640                             newton simplex simeq seidel sparse derivimplicit cnexp clsoda
641                             after_cvode cvode_t cvode_t_v expeuler #f) method)
642                     (else (error "unknown nmodl-method " method))))))
643           (if sxml-fname (with-output-to-file sxml-fname (lambda () (pretty-print (model->ncml options model)))))
644           (if xml-fname  (let* ((doc  (model->ncml options model))
645                                 (doc1 (ensure-xmlns
646                                       (cond ((eq? (car doc) '*TOP*) (assoc 'ncml:model (cdr doc)))
647                                             (else doc)))))
648                            (with-output-to-file xml-fname (lambda () (print-fragments (generate-XML `(begin ,doc1)))))))
649           (if mod-fname
650               (with-output-to-file
651                   mod-fname  (lambda () 
652                                (model->nmodl `((depend  . ,nmodl-depend)
653                                                (method  . ,nmodl-method)
654                                                (table   . ,(assoc 't options))
655                                                (kinetic 
656                                                 ,(let ((opt (assoc 'nmodl-kinetic options)))
657                                                    (and opt
658                                                         (if (string? (cdr opt))
659                                                             (map string->symbol (string-split (cdr opt) ","))
660                                                             'all)))))
661                                              model))))
662           (if mat-fname
663               (with-output-to-file
664                   mat-fname  (lambda () 
665                                (model->matlab `(;(method  . ,matlab-method)
666                                                 (table   . ,(assoc 't options))
667                                                 (kinetic 
668                                                  ,(let ((opt (assoc 'matlab-kinetic options)))
669                                                     (and opt
670                                                          (if (string? (cdr opt))
671                                                              (map string->symbol (string-split (cdr opt) ","))
672                                                              'all)))))
673                                              model))))
674           ))
675       operands)))
676
677(main options operands)
678
Note: See TracBrowser for help on using the repository browser.