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

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

Added stx-macros and some initial xml templates in nemo.scm.

File size: 10.6 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
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
37;;; Procedures for string concatenation and pretty-printing
38
39(define (s+ . lst)    (string-concatenate (map ->string lst)))
40(define (sw+ lst)     (string-intersperse (filter-map (lambda (x) (and x (->string x))) lst) " "))
41(define (s\ p . lst)  (string-intersperse (map ->string lst) p))
42(define (sl\ p lst)   (string-intersperse (map ->string lst) p))
43(define nl "\n")
44
45;;; Error/warning procedures for the XML parser
46
47(define (parser-error port message . specialising-msgs)
48  (error (string-append message (string-concatenate (map ->string specialising-msgs)))))
49
50(define (ssax:warn port message . specialising-msgs)
51  (print-error-message message (current-output-port) "Warning")
52  (print (string-concatenate (map ->string specialising-msgs))))
53
54(require-extension  stx-engine)
55(require-extension  sxpath-plus)
56(require-extension  sxml-transforms)
57(require-extension  sxml-tools)
58
59(include "SXML.scm")
60(include "SSAX.scm")
61(include "SXML-to-XML.scm")
62
63
64
65(define opts
66  `(
67    ,(args:make-option (i)       (required: "FORMAT")   
68                       (s+ "specify input format (xml, sxml)")
69                       (string->symbol arg))
70    ,(args:make-option (o)       (required: "FORMAT")   
71                       (s+ "specify output format (nmodl, sxml)")
72                       (string->symbol arg))
73    ,(args:make-option (sxml-file)       (required: "FILE")   
74                       (s+ "write SXML output to file (default: <model-name>.sxml)"))
75    ,(args:make-option (nmodl-file)       (required: "FILE")   
76                       (s+ "write NMODL output to file"))
77    ,(args:make-option (nmodl-file)       (required: "FILE")   
78                       (s+ "write NMODL output to file"))
79    ,(args:make-option (nmodl-method)       (required: "METHOD")
80                       (s+ "specify NMODL integration method (cnexp, derivimplicit)")
81                       (string->symbol arg))
82    ,(args:make-option (t)       #:none
83                       (s+ "use interpolation tables")
84                       #t)
85    ,(args:make-option (h help)  #:none               "Print help"
86                       (usage))
87
88    ))
89
90
91;; Use args:usage to generate a formatted list of options (from OPTS),
92;; suitable for embedding into help text.
93(define (usage)
94  (print "Usage: " (car (argv)) " [options...] <list of files to be processed> ")
95  (newline)
96  (print "The following options are recognized: ")
97  (newline)
98  (print (parameterize ((args:indent 5)) (args:usage opts)))
99  (exit 1))
100
101
102;; Process arguments and collate options and arguments into OPTIONS
103;; alist, and operands (filenames) into OPERANDS. 
104(define args    (command-line-arguments))
105(set!-values (options operands)  (args:parse args opts))
106
107
108(define (nemoml:sxpath query doc)
109  ((sxpath query '((ncml . "ncml"))) doc))
110
111(define (ncml:car-sxpath query doc)
112  (let ((lst ((sxpath query '((ncml . "ncml") )) doc)))
113    (car lst)))
114
115(define (ncml:if-car-sxpath query doc)
116  (let ((lst ((sxpath query '((ncml . "ncml") )) doc)))
117    (and (not (null? lst)) (car lst))))
118
119(define (ncml:if-sxpath query doc)
120  (let ((lst ((sxpath query '((ncml . "ncml") )) doc)))
121    (and (not (null? lst)) lst)))
122
123
124(define (ncml->decls ncml:model)
125  (letrec
126      ((input-template 
127        (sxml:match 'ncml:input
128                    (lambda (node bindings root env) 
129                      (let ((id   (sxml:attrv 'id node))
130                            (from (sxml:kidn 'from node))
131                            (as   (sxml:kidn 'as node)))
132                        (if (not id) (error 'input-template "input declaration requires id attribute"))
133                        (cond ((and from as)  `(input (,(string->symbol id) as ,(string->symbol as) 
134                                                       from ,(string->symbol from))))
135                              (from           `(input (,(string->symbol id) from ,(string->symbol from))))
136                              (as             `(input (,(string->symbol id) as ,(string->symbol as))))
137                              (else           `(input ,(string->symbol id))))))))
138       
139       (output-template 
140        (sxml:match 'ncml:output
141                    (lambda (node bindings root env) 
142                      (let ((id   (sxml:attrv 'id node)))
143                        (if (not id) (error 'output-template "output declaration requires id attribute"))
144                        `(output ,(string->symbol id))))))
145       
146       (const-template 
147        (sxml:match 'ncml:const
148                    (lambda (node bindings root env) 
149                      (let ((id   (sxml:attrv 'id node))
150                            (expr ((lambda (x) 
151                                     (if (not x) 
152                                          (error 'const-template "const declaration requires expr element")
153                                          (ncml-expr->expr x)))
154                                   (sxml:kidn 'expr node))))
155                        (if (not id) (error 'const-template "const declaration requires id attribute"))
156                        `(const ,(string->symbol id) = ,expr)))))
157       
158       (state-complex-transition-template 
159        (sxml:match 'ncml:transition
160                    (lambda (node bindings root env) 
161                      (let ((src  (sxml:attrv 'src node))
162                            (dest (sxml:attrv 'dest node))
163                            (expr ((lambda (x) 
164                                     (if (not x) 
165                                         (error 'state-complex-transition-template 
166                                                "state complex transition requires rate element")
167                                         (ncml-expr->expr x)))
168                                   (sxml:kidn 'rate node))))
169                        (if (not src) (error 'state-complex-transition-template
170                                             "state complex transition requires src attribute"))
171                        (if (not dest) (error 'state-complex-transition-template
172                                              "state complex transition requires dest attribute"))
173                        `(-> ,(string->symbol src) ,(string->symbol dest) ,rate)))))
174       
175       (asgn-template 
176        (sxml:match 'ncml:asgn
177                    (lambda (node bindings root env) 
178                      (let ((id   (sxml:attrv 'id node))
179                            (expr ((lambda (x) 
180                                     (if (not x) 
181                                          (error 'asgn-template "algebraic assignment requires expr element")
182                                          (ncml-expr->expr x)))
183                                   (sxml:kidn 'expr node))))
184                        (if (not id) (error 'asgn-template "algebraic assignment requires id attribute"))
185                        `(,(string->symbol id) = ,expr)))))
186       
187       
188       (state-complex-template 
189        (sxml:match 'ncml:state_complex
190                    (lambda (node bindings root env) 
191                      (let ((id   (sxml:attrv 'id node))
192                            (initial ((lambda (x) 
193                                        (if (not x) 
194                                            (error 'state-complex-template 
195                                                   "state complex declaration requires initial element")
196                                            (ncml-expr->expr x)))
197                                      (sxml:kidn 'initial node)))
198                            (open ((lambda (x) 
199                                     (if (not x) 
200                                         (error 'state-complex-template
201                                                "state complex declaration requires open element")
202                                         (string->symbol x)))
203                                   (sxml:kidn 'open node)))
204                            (power ((lambda (x) 
205                                      (if (not x) 
206                                          (error 'state-complex-template
207                                                 "state complex declaration requires open element")
208                                          (string->integer x)))
209                                    (sxml:kidn 'power node)))
210                            (transitions ((lambda (x) 
211                                            (if (not x) 
212                                                (error 'state-complex-template
213                                                       "state complex declaration requires transitions element")
214                                                (let ((tmpl (sxml:make-null-ss state-complex-transition-template)))
215                                                  (stx:apply-templates x tmpl root env))))
216                                          (sxml:kidn 'transitions node))))
217                                         
218                        (if (not id) (error 'state-complex-template "state complex transition requires id attribute"))
219                        `(state-complex (,id (initial ,initial) (open ,open) (power ,power)
220                                             (transitions ,transitions)))))))
221
222       (defun-template 
223        (sxml:match 'ncml:defun
224                    (lambda (node bindings root env) 
225                      (let ((id    (sxml:attrv 'id node))
226                            (args  ((lambda (x) 
227                                      (if (null? x) 
228                                          (error 'defun-template 
229                                                 "function definition requires at least one arg element")
230                                          (map string->symbol x)))
231                                    (sxml:kidsn 'arg node)))
232                            (body ((lambda (x) 
233                                     (if (not x) 
234                                         (error 'defun-template
235                                                "function definition requires body element")
236                                         (ncml-expr->expr x)))
237                                   (sxml:kidn 'body node))))
238                        (if (not id) (error 'defun-template "function definition requires id attribute"))
239                        `(defun (,id ,args ,body))))))
240
241       
242       
243        )
244    (stx:apply-templates ncml:model (sxml:make-null-ss input-template
245                                                       output-template
246                                                       const-template
247                                                       asgn-template
248                                                       state-complex-template
249                                                       defun-template) 
250                         ncml:model (list))))
251
252(define (ncml->nmodl options doc)
253  (let* ((ncml:model   (ncml:sxpath '(ncml:model) doc))
254         (model-name  (sxml:attrv 'name ncml:model))
255         (model-decls (ncml->decls ncml:model)))
256    (match  (nemo-constructor model-name model-decls)
257            ((model nemo) 
258             (let ((model-1 (nemo:hh-transformer model))) 
259               (if (assoc 'depgraph options) (print "dependency graph: " ((nemo 'depgraph*) model-1)))
260               (if (assoc 'exports options) (print "exports: " ((nemo 'exports) model-1)))
261               (if (assoc 'imports options) (print "imports: " ((nemo 'imports) model-1)))
262               (if (assoc 'components options)
263                   (for-each (lambda (x) 
264                               (print "component " x ": " ((nemo 'component-exports) model-1 (second x)))
265                               (print "component " x " subcomponents: " ((nemo 'component-subcomps) model-1 (second x))))
266                             ((nemo 'components) model-1)))
267             (nemo:nmodl-translator model-1 (lookup-def 'nmodl-method options) (lookup-def 'table options) -150 150 1)
268             )))))
269
270 
271(define (main options operands)
272  (if (not (null? operands))
273      (for-each
274       (lambda (operand)
275         (let ((doc        (call-with-input-file operand (lambda (port) (ssax:xml->sxml port '((ncml . "ncml")))) ))
276               (mod-fname  (s+ (lookup-def 'nmodl-file options (pathname-strip-extension operand)) ".mod"))
277               (sxml-fname ((lambda (x) (and x (if (string? (cdr x)) (s+ (pathname-strip-extension (cdr x)) ".sxml")
278                                                   (s+  (pathname-strip-extension operand) ".sxml"))))
279                            (assoc 'sxml-file options)))
280               (nmodl-method
281                (let ((method  ((lambda (x) (and x (string->symbol x))) (lookup-def 'nmodl-method options) )))
282                  (case method
283                    ((cnexp derivimplicit #f) method)
284                    (else (error "nmodl-method must be one of cnexp, derivimplicit"))))))
285           (if sxml-fname (with-output-to-file sxml-fname (lambda () (print doc))))
286           (with-output-to-file
287               mod-fname  (lambda () (ncml->nmodl `((method . ,method)
288                                                    (table  . ,(assoc 't options))) doc)))
289           ))
290       operands)))
291
292(main options operands)
293
Note: See TracBrowser for help on using the repository browser.