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

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

Bug fixes to the example model.

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