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

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

Removed incomplete examples, started a general sexp->sxml
converter, added support for function call arity check.

File size: 16.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(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)")
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 
111(define (ncml-expr->expr node)
112  (match node
113         ((? number?)    node)
114         ((? string?)    (sxml:number node))
115         (('ncml:id id)  (string->symbol (->string id)))
116         (('ncml:apply ('ncml:id id) . args)  (cons (string->symbol (->string id)) (map ncml-expr->expr args)))
117         (((and op (? symbol?)) . args)       (cons (ncml-op->op op) (map ncml-expr->expr args)))))
118 
119
120(define (ncml-op->op op)
121  (case op
122    ((ncml:sum)    '+)
123    ((ncml:sub)    '-)
124    ((ncml:mul)    '*)
125    ((ncml:div)    '/)
126    ((ncml:gt)     '>)
127    ((ncml:lt)     '<)
128    ((ncml:lte)    '<=)
129    ((ncml:gte)    '>=)
130    ((ncml:eq)     '=)
131    (else          (match (string-split (->string op) ":")
132                          ((pre op)  (string->symbol op))
133                          (else (error 'ncml-op->op "invalid operator" op))))))
134
135(require-extension  stx-engine)
136(require-extension  sxpath-plus)
137(require-extension  sxml-transforms)
138(require-extension  sxml-tools)
139
140(include "SXML.scm")
141(include "SSAX.scm")
142(include "SXML-to-XML.scm")
143
144
145(define null-template `(*default* ,(lambda (node bindings root env) '())))
146
147(define-syntax  sxml:make-null-ss
148   (syntax-rules  ()
149      ((stx rule ...)
150       (list
151        ; default handler
152        null-template
153        ; handler for textual nodes
154        (list '*text*  (lambda (text) text)) 
155        rule ...))))
156
157(define (ensure-xmlns doc)
158  (sxml:add-attr doc '(xmlns ncml)))
159
160
161;; based on SRV:send-reply by Oleg Kiselyov
162(define (print-fragments b)
163  (let loop ((fragments b) (result #f))
164    (cond
165      ((null? fragments) result)
166      ((not (car fragments)) (loop (cdr fragments) result))
167      ((null? (car fragments)) (loop (cdr fragments) result))
168      ((eq? #t (car fragments)) (loop (cdr fragments) #t))
169      ((pair? (car fragments))
170        (loop (cdr fragments) (loop (car fragments) result)))
171      ((procedure? (car fragments))
172        ((car fragments))
173        (loop (cdr fragments) #t))
174      (else
175       (display (car fragments))
176       (loop (cdr fragments) #t)))))
177
178
179(define (ncml->decls ncml:model)
180  (letrec
181      ((input-template 
182        (sxml:match 'ncml:input
183                    (lambda (node bindings root env) 
184                      (let ((id    (sxml:attr node 'id))
185                            (from  (sxml:kidn 'ncml:from node))
186                            (as    (sxml:kidn 'ncml:as node)))
187                        (if (not id) (error 'input-template "input declaration requires id attribute"))
188                        (cond ((and from as)  `(input (,($ id) as ,($ (second as) ) from ,($ (second from)) )))
189                              (from           `(input (,($ id) from ,($ (second from)))))
190                              (as             `(input (,($ id) as ,($ (second as)))))
191                              (else           `(input ,($ id))))))))
192       
193       (output-template 
194        (sxml:match 'ncml:output
195                    (lambda (node bindings root env) 
196                      (let ((id   (sxml:attr node 'id)))
197                        (if (not id) (error 'output-template "output declaration requires id attribute"))
198                        `(output ,($ id))))))
199       
200       (const-template 
201        (sxml:match 'ncml:const
202                    (lambda (node bindings root env) 
203                      (let* ((id   (sxml:attr node 'id))
204                             (expr ((lambda (x) 
205                                      (if (not x) 
206                                          (error 'const-template "const declaration " id " requires expr element")
207                                          (ncml-expr->expr (second x))))
208                                   (sxml:kidn 'ncml:expr node))))
209                        (if (not id) (error 'const-template "const declaration requires id attribute"))
210                        `(const ,($ id) = ,expr)))))
211       
212       (state-complex-transition-template 
213        (sxml:match 'ncml:transition
214                    (lambda (node bindings root env) 
215                      (let ((src  (sxml:attr node 'src))
216                            (dest (sxml:attr node 'dest))
217                            (expr ((lambda (x) 
218                                     (if (not x) 
219                                         (error 'state-complex-transition-template 
220                                                "state complex transition requires rate element")
221                                         (ncml-expr->expr (second x))))
222                                   (sxml:kidn 'ncml:rate node))))
223                        (if (not src) (error 'state-complex-transition-template
224                                             "state complex transition requires src attribute"))
225                        (if (not dest) (error 'state-complex-transition-template
226                                              "state complex transition requires dest attribute"))
227                        `(-> ,($ src) ,($ dest) ,rate)))))
228       
229       (asgn-template 
230        (sxml:match 'ncml:asgn
231                    (lambda (node bindings root env) 
232                      (let ((id   (sxml:attr node 'id))
233                            (expr ((lambda (x) 
234                                     (if (not x) 
235                                          (error 'asgn-template "algebraic assignment requires expr element")
236                                          (ncml-expr->expr (second x))))
237                                   (sxml:kidn 'ncml:expr node))))
238                        (if (not id) (error 'asgn-template "algebraic assignment requires id attribute"))
239                        `(,($ id) = ,expr)))))
240       
241       
242       (state-complex-template 
243        (sxml:match 'ncml:state_complex
244                    (lambda (node bindings root env) 
245                      (let ((id   (sxml:attr node 'id))
246                            (initial ((lambda (x) 
247                                        (if (not x) 
248                                            (error 'state-complex-template 
249                                                   "state complex declaration requires initial element")
250                                            (ncml-expr->expr (second x))))
251                                      (sxml:kidn 'ncml:initial node)))
252                            (open ((lambda (x) 
253                                     (if (not x) 
254                                         (error 'state-complex-template
255                                                "state complex declaration requires open element")
256                                         ($ (second x))))
257                                   (sxml:kidn 'ncml:open node)))
258                            (power ((lambda (x) 
259                                      (if (not x) 
260                                          (error 'state-complex-template
261                                                 "state complex declaration requires open element")
262                                          (string->integer (second x))))
263                                    (sxml:kidn 'ncml:power node)))
264                            (transitions ((lambda (x) 
265                                            (if (not x) 
266                                                (error 'state-complex-template
267                                                       "state complex declaration requires transitions element")
268                                                (let ((tmpl (sxml:make-null-ss state-complex-transition-template)))
269                                                  (stx:apply-templates x tmpl root env))))
270                                          (sxml:kidn 'ncml:transitions node))))
271                                         
272                        (if (not id) (error 'state-complex-template "state complex transition requires id attribute"))
273                        `(state-complex (,id (initial ,initial) (open ,open) (power ,power)
274                                             (transitions ,transitions)))))))
275
276
277       (defun-template 
278        (sxml:match 'ncml:defun
279                    (lambda (node bindings root env) 
280                      (let ((id    (sxml:attr node 'id))
281                            (args  ((lambda (x) 
282                                      (if (null? x) 
283                                          (error 'defun-template 
284                                                 "function definition requires at least one arg element")
285                                          (map (compose $ second) x)))
286                                    (sxml:kidsn 'ncml:arg node)))
287                            (body ((lambda (x) 
288                                     (if (not x) 
289                                         (error 'defun-template
290                                                "function definition requires body element")
291                                         (ncml-expr->expr (second x))))
292                                   (sxml:kidn 'ncml:body node))))
293                        (if (not id) (error 'defun-template "function definition requires id attribute"))
294                        `(defun ,($ id) ,args ,body)))))
295
296       (component-template
297        (sxml:match 'ncml:component
298                    (lambda (node bindings root env)
299                      (let ((name (sxml:attr node 'name))
300                            (type (sxml:attr node 'type)))
301                        (if (not type) (error 'component-template "component definition requires type attribute"))
302                        (if name
303                            `(component (type ,($ type)) (name ,($ name)) ,@(ncml->decls (sxml:kids node)))
304                            `(component (type ,($ type)) ,@(ncml->decls (sxml:kids node))))))))
305
306       (hh-template 
307        (sxml:match 'ncml:hh_ionic_conductance 
308                    (lambda (node bindings root env)
309                      (let* ((or-expr   (lambda (x) (and x (ncml-expr->expr (second x)))))
310                             (id         (sxml:attr node 'id))
311                             (initial_m  (or-expr (sxml:kidn 'ncml:initial_m node)))
312                             (initial_h  (or-expr (sxml:kidn 'ncml:initial_h node)))
313                             (m_power    (or-expr (sxml:kidn 'ncml:m_power node)))
314                             (h_power    (or-expr (sxml:kidn 'ncml:h_power node)))
315                             (m_alpha    (or-expr (sxml:kidn 'ncml:m_alpha node)))
316                             (m_beta     (or-expr (sxml:kidn 'ncml:m_beta node)))
317                             (h_alpha    (or-expr (sxml:kidn 'ncml:h_alpha node)))
318                             (h_beta     (or-expr (sxml:kidn 'ncml:h_beta node)))
319                             (m_tau      (or-expr (sxml:kidn 'ncml:m_tau node)))
320                             (m_inf      (or-expr (sxml:kidn 'ncml:m_inf node)))
321                             (h_tau      (or-expr (sxml:kidn 'ncml:h_tau node)))
322                             (h_inf      (or-expr (sxml:kidn 'ncml:h_inf node))))
323                        (if (not id)
324                            (error 'hh-template "hh ionic conductance definition requires id attribute"))
325                        `(hh-ionic-conductance 
326                          (,($ id)
327                           ,@(if initial_m `((initial-m ,initial_m)) `())
328                           ,@(if initial_h `((initial-h ,initial_h)) `())
329                           ,@(if m_power `((m-power ,m_power)) '())
330                           ,@(if h_power `((h-power ,h_power)) '())
331                           ,@(if m_alpha `((m-alpha ,m_alpha)) '())
332                           ,@(if h_alpha `((h-alpha ,h_alpha)) '())
333                           ,@(if m_beta  `((m-beta ,m_beta)) '())
334                           ,@(if h_beta  `((h-beta ,h_beta)) '())
335                           ,@(if m_inf   `((m-inf ,m_inf)) '())
336                           ,@(if h_inf   `((h-inf ,h_inf)) '())
337                           ,@(if m_tau   `((m-tau ,m_tau)) '())
338                           ,@(if h_tau   `((h-tau ,h_tau)) '())
339                           ))))))
340
341        )
342
343    (stx:apply-templates ncml:model (sxml:make-null-ss input-template
344                                                       output-template
345                                                       const-template
346                                                       asgn-template
347                                                       state-complex-template
348                                                       defun-template
349                                                       component-template
350                                                       hh-template) 
351                         ncml:model (list))))
352
353
354
355(define (ncml->model options doc)
356  (let* ((ncml:model   (car (ncml:sxpath '(ncml:model) doc)))
357         (model-name   (sxml:attr ncml:model 'name))
358         (model-decls  (ncml->decls (sxml:kids ncml:model))))
359    (let* ((model+nemo  (nemo-constructor model-name model-decls))
360           (model (first model+nemo))
361           (nemo  (second model+nemo)))
362      (let ((model-1 (nemo:hh-transformer model))) 
363        (if (assoc 'depgraph options) (print "dependency graph: " ((nemo 'depgraph*) model-1)))
364        (if (assoc 'exports options) (print "exports: " ((nemo 'exports) model-1)))
365        (if (assoc 'imports options) (print "imports: " ((nemo 'imports) model-1)))
366        (if (assoc 'components options)
367            (for-each (lambda (x) 
368                        (print "component " x ": " ((nemo 'component-exports) model-1 (second x)))
369                        (print "component " x " subcomponents: " ((nemo 'component-subcomps) model-1 (second x))))
370                      ((nemo 'components) model-1)))
371        model-1))))
372
373
374(define (nemo-constructor name declarations)
375  (let* ((nemo   (make-nemo-core))
376         (sys    ((nemo 'system) name)))
377    (eval-nemo-system-decls nemo name sys declarations)
378    (list sys nemo)))
379
380
381(define (model->nmodl options model)
382  (nemo:nmodl-translator model-1 (lookup-def 'nmodl-method options) (lookup-def 'table options) -150 150 1))
383
384#|
385(define (model->sxml options model)
386  (match-let ((($ nemo:quantity 'DISPATCH  dis) (environment-ref model (nemo-intern 'dispatch)))
387              (($ nemo:quantity 'SYSNAME  dis)  (environment-ref model (nemo-intern 'sysname))))
388    (let* ((defuns  ((dis 'defuns) model))
389           (sxml-defuns  (map (lambda (x) (let* ((ef (environment-ref model x))
390                                                 (fd (procedure-data ef)))
391                                            `(ncml:defun (@ (ncml:id ,x))
392                                                         ,(map (lambda (v) `(ncml:arg ,v)) (alist-ref 'vars fd))
393                                                         (ncml:body ,(alist-ref 'body fd)))
394                                            )) defuns))
395           (consts  ((dis 'consts) model))
396|#
397           
398 
399(define (main options operands)
400  (if (not (null? operands))
401      (for-each
402       (lambda (operand)
403         (let* ((read-xml   (lambda (name) (call-with-input-file name
404                                            (lambda (port) (ssax:xml->sxml port '((ncml . "ncml")))) )))
405                (read-sexp  (lambda (name) (call-with-input-file name read)))
406                (in-format  (cond ((lookup-def 'i options) =>
407                                   (lambda (x) 
408                                     (case ($ x)
409                                       ((sexp)  'sexp)
410                                       ((sxml)  'sxml)
411                                       ((xml)   'xml)
412                                       (else    (error 'nemo "unknown input format" x)))))
413                                  (else  (case ((lambda (x) (or (not x) ($ x)))
414                                                (pathname-extension operand))
415                                           ((sexp)  'sexp)
416                                           ((sxml)  'sxml)
417                                           ((xml)   'xml)
418                                           (else    'xml)))))
419                (doc        (case in-format
420                              ((sexp)  (read-sexp operand))
421                              ((sxml)  (read-sexp operand))
422                              ((xml)  (read-sxml operand))
423                              (else    (error 'nemo "unknown input format" in-format))))
424                (model       (case in-format
425                               ((sxml xml)  (ncml->model options doc))
426                               ((sexp)      (ncml->model options doc))
427                               (else    (error 'nemo "unknown input format" in-format))))
428                (sxml-fname  ((lambda (x) (and x (if (string? (cdr x)) (s+ (pathname-strip-extension (cdr x)) ".sxml")
429                                                     (s+  (pathname-strip-extension operand) ".sxml"))))
430                              (assoc 'sxml options)))
431                (xml-fname  ((lambda (x) (and x (if (string? (cdr x)) (s+ (pathname-strip-extension (cdr x)) ".xml")
432                                                    (s+  (pathname-strip-extension operand) ".xml"))))
433                              (assoc 'xml options)))
434                (mod-fname  ((lambda (x) (and x (if (string? (cdr x)) (s+ (pathname-strip-extension (cdr x)) ".mod")
435                                                    (s+  (pathname-strip-extension operand) ".mod"))))
436                             (assoc 'nmodl options)))
437                (nmodl-method
438                 (let ((method  ($ (lookup-def 'nmodl-method options) )))
439                   (case method
440                     ((cnexp derivimplicit #f) method)
441                     (else (error "nmodl-method must be one of cnexp, derivimplicit"))))))
442           (if sxml-fname (with-output-to-file sxml-fname (lambda () (pretty-print doc))))
443           (if xml-fname  (let ((doc1 (ensure-xmlns
444                                       (cond ((eq? (car doc) '*TOP*) (assoc 'ncml:model (cdr doc)))
445                                             (else doc)))))
446                            (with-output-to-file xml-fname (lambda () (print-fragments (generate-XML `(begin ,doc1)))))))
447           (with-output-to-file
448               mod-fname  (lambda () 
449                            (model->nmodl `((method . ,nmodl-method)
450                                            (table  . ,(assoc 't options))) model)))
451           ))
452       operands)))
453
454(main options operands)
455
Note: See TracBrowser for help on using the repository browser.