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

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

Bug fixes.

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