Changeset 11944 in project


Ignore:
Timestamp:
09/12/08 09:52:21 (13 years ago)
Author:
Ivan Raikov
Message:

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

Location:
release/3/nemo/trunk
Files:
2 deleted
5 edited

Legend:

Unmodified
Added
Removed
  • release/3/nemo/trunk/SXML.scm

    r11895 r11944  
    33;;
    44;; Auxilliary functions for SXML manipulation.
    5 ;;
    65;;
    76;; Copyright Ivan Raikov and the Okinawa Institute of Science and Technology
  • release/3/nemo/trunk/core.scm

    r11895 r11944  
    207207  ;; 1. make sure all constants in an expression are flonums
    208208  ;; 2. fold expressions like (+ a b c d) into nested binops
    209   (define (normalize-expr expr)
    210     (define (normalize-bnd x)
    211       `(,(first x) ,(normalize-expr (second x))))
    212     (match expr
    213            (('let bs e)         `(let ,(map normalize-bnd bs) ,(normalize-expr e)))
    214            (('if c t e)         `(if ,(normalize-expr c) ,(normalize-expr t) ,(normalize-expr e)))
    215            (('+ . es)           (binop-fold '+ (map normalize-expr es)))
    216            (('- . es)           (let ((es1 (map normalize-expr es)))
    217                                   (binop-fold '+ (cons (car es1) (map negate (cdr es1))))))
    218            (('* . es)           (binop-fold '* (map normalize-expr es)))
    219            (('/ . es)           (binop-fold '/ (map normalize-expr es)))
    220            (('fix n)            n)
    221            ((s . es)            (cons s (map normalize-expr es)))
    222            (x                   (if (number? x) (exact->inexact x) x))))
     209  (define (make-normalize-expr arity-check)
     210    (lambda (expr)
     211      (let recur ((expr expr))
     212        (match expr
     213               (('let bs e)         (let ((normalize-bnd  (lambda (x) `(,(first x) ,(recur (second x))))))
     214                                      `(let ,(map normalize-bnd bs) ,(recur e))))
     215               (('if c t e)         `(if ,(recur c) ,(recur t) ,(recur e)))
     216               (('+ . es)           (binop-fold '+ (map recur es)))
     217               (('- . es)           (let ((es1 (map recur es)))
     218                                      (binop-fold '+ (cons (car es1) (map negate (cdr es1))))))
     219               (('* . es)           (binop-fold '* (map recur es)))
     220               (('/ . es)           (binop-fold '/ (map recur es)))
     221               (('fix n)            n)
     222               ((s . es)            (begin
     223                                      (arity-check s es)
     224                                      (cons s (map recur es))))
     225               (x                   (if (number? x) (exact->inexact x) x))))))
    223226
    224227  (define (make-base-env)
     
    273276             )))
    274277
     278
     279  (define (make-arity-check nemo-env)
     280    (lambda (s args)
     281      (let ((op (environment-ref nemo-env s)))
     282        (if (extended-procedure? op)
     283            (let* ((fd   (procedure-data op))
     284                   (fms   (lookup-def 'formals fd)))
     285              (if (not (= (length fms) (length args)))
     286                  (nemo:error 'eval-expr "procedure " s
     287                              " called with incorrect number of arguments: "
     288                              args)))))))
     289
    275290  (define (env-extend! nemo-env)
    276291    (lambda (name type initial . alst)
    277        (let ((sym (if (symbol? name) name (string->symbol name))))
     292       (let* ((sym (if (symbol? name) name (string->symbol name)))
     293              (arity-check (make-arity-check nemo-env))
     294              (normalize-expr (make-normalize-expr arity-check)))
    278295        (if (environment-has-binding? nemo-env sym)
    279296            (nemo:error 'env-extend! ": quantity " sym " already defined")
     
    294311                            (environment-extend! nemo-env sym (CONST name initial))))
    295312
    296               (('tscomp)  (let ((power        (or (lookup-def 'power alst) 1))
    297                                 (transitions  (or (alist-ref 'transitions alst) (list)))
     313              (('tscomp)  (let ((power         (or (lookup-def 'power alst) 1))
     314                                (transitions   (map (lambda (t)
     315                                                      (print "t = " t)
     316                                                      `(-> ,(second t) ,(third t) ,(normalize-expr (fourth t ))))
     317                                                    (or (alist-ref 'transitions alst) (list))))
    298318                                (open         (lookup-def 'open alst)))
    299319                            (if (null? transitions)
     
    345365                     (lst  (procedure-data f)))
    346366                (and lst
    347                      (let ((rt   (lookup-def 'rt lst))
     367                     (let ((rt   (lookup-def 'rt   lst))
    348368                           (fms  (lookup-def 'formals lst)))
    349369                       (and rt fms
     
    367387
    368388  (define (defun! nemo-env)
     389    (define arity-check (make-arity-check nemo-env))
     390    (define normalize-expr (make-normalize-expr arity-check))
     391
    369392    (lambda (name formals body)
    370         (let ((const-env (make-const-env nemo-env))
     393        (let ((base-env (make-base-env))
    371394              (sym (if (symbol? name) name (string->symbol name))))
    372395          (letrec ((enumconsts
     
    378401                               (('if . es)   (fold (enumconsts lb) ax es))
    379402                               ((s . es)     (if (symbol? s)  (cons s (fold (enumconsts lb) ax es)) ax))
    380                                (s            (if (and (symbol? s) (not (member s lb))
    381                                                       (environment-includes? const-env s))
    382                                                  (cons s ax) ax)))))))
     403                               (s            (cond
     404                                              ((and (symbol? s) (not (member s lb)) (environment-includes? base-env s))
     405                                               (cons s ax) )
     406                                              ((and (symbol? s) (not (member s lb)))
     407                                               (nemo:error 'defun ": quantity " s " not defined"))
     408                                              (else ax))))))))
    383409            (if (environment-has-binding? nemo-env sym)
    384410                (nemo:error 'defun! ": quantity " sym " already defined")
    385411                (let* ((body    (normalize-expr body))
    386412                       (consts  (delete-duplicates ((enumconsts formals) body (list))))
    387                        (fc     `(lambda (const-env)
    388                                   (let ,(map (lambda (v) `(,v (environment-ref const-env ',v))) consts)
     413                       (fc     `(lambda (base-env)
     414                                  (let ,(map (lambda (v) `(,v (environment-ref base-env ',v))) consts)
    389415                                    (lambda ,formals ,body))))
    390                        (f      ((eval fc) const-env)))
     416                       (f      ((eval fc) base-env)))
    391417                 
    392418                  (let* ((ftenv  (make-environment))
     
    577603
    578604  (define (eval-const nemo-env expr)
    579     (let ((expr1 (normalize-expr expr)))
    580       (exact->inexact (eval expr1  (make-const-env nemo-env)))))
     605    (let* ((arity-check (make-arity-check nemo-env))
     606           (normalize-expr (make-normalize-expr arity-check)))
     607      (let ((expr1 (normalize-expr expr)))
     608        (exact->inexact (eval expr1  (make-const-env nemo-env))))))
    581609
    582610
     
    714742                          (let ((op   (environment-ref env s))
    715743                                (args (map (eval-expr env) es)))
     744                            (if (extended-procedure? op)
     745                                (let* ((fd   (procedure-data op))
     746                                       (vs  (lookup-def 'vars fd)))
     747                                  (if (not (= (length vs) (length args)))
     748                                      (nemo:error 'eval-expr "procedure " s
     749                                                  " called with incorrect number of arguments"))))
    716750                            (apply op args))
    717751                          [var ()
  • release/3/nemo/trunk/examples/AKP06/PotIhCa.scm

    r11857 r11944  
    1414       (const celsius = 24)
    1515
    16        (const F = 96485.0)
    17        (const R = 8.3145)
    18        
    1916       (const temp_adj = (pow 3 (/ (- celsius 22) 10)))
    2017
    21        (defun ghk (v ci co)
    22          (let ((zeta (/ (* 2e-3 F v) (* R (+ 273.19 celsius)))))
    23            (if (< (abs (- 1.0 (exp (neg zeta)))) 1e-6)
    24                (* 1e-6  (* 2 F) (- ci (* co (exp (neg zeta)))) (+ 1.0 (/ zeta 2)))
    25                (/ (* 1e-6 (* 2 zeta F) (- ci (* co (exp (neg zeta))))) (- 1.0 (exp (neg zeta)))))))
     18       (defun ghk (v celsius ci co)
     19         (let ((F 96485.0) (R 8.3145))
     20           (let ((zeta (/ (* 2e-3 F v) (* R (+ 273.19 celsius)))))
     21             (if (< (abs (- 1.0 (exp (neg zeta)))) 1e-6)
     22                 (* 1e-6  (* 2 F) (- ci (* co (exp (neg zeta)))) (+ 1.0 (/ zeta 2)))
     23                 (/ (* 1e-6 (* 2 zeta F) (- ci (* co (exp (neg zeta))))) (- 1.0 (exp (neg zeta))))))))
    2624
    2725
     
    3533            (const cva  = 45)
    3634
    37             (defun Kv1_amf (v) (* temp_adj cma (exp (neg (/ (+ v cva) cka)))))
     35            (defun Kv1_amf (v cma cva cka temp_adj) (* temp_adj cma (exp (neg (/ (+ v cva) cka)))))
    3836
    3937            (const cmb   = 0.12889)
    4038            (const ckb   = 12.42101)
    4139            (const cvb   = 45)
    42             (defun Kv1_bmf (v) (* temp_adj cmb (exp (neg (/ (+ v cvb) ckb)))))
     40            (defun Kv1_bmf (v cmb cvb ckb temp_adj) (* temp_adj cmb (exp (neg (/ (+ v cvb) ckb)))))
    4341
    4442            (hh-ionic-conductance
    4543             (Kv1  ;; ion name: exported variables will be of the form {ion}_{id}
    46               (initial-m (/ (Kv1_amf Vrest) (+ (Kv1_amf Vrest) (Kv1_bmf Vrest))) )
     44              (initial-m (/ (Kv1_amf Vrest cma cva cka temp_adj)
     45                            (+ (Kv1_amf Vrest cma cva cka temp_adj)
     46                               (Kv1_bmf Vrest cmb cvb ckb temp_adj))))
    4747              (m-power   4)
    4848              (h-power   0)
    49               (m-alpha   (Kv1_amf v))
    50               (m-beta    (Kv1_bmf v))))
     49              (m-alpha   (Kv1_amf v cma cva cka temp_adj) )
     50              (m-beta    (Kv1_bmf v cmb cvb ckb temp_adj) )))
    5151             
    5252            )
     
    7373            (const cvan  = 57)
    7474
    75             (defun Kv4_amf (v)  (* temp_adj can (exp (neg (/ (+ v cvan) ckan)))))
     75            (defun Kv4_amf (v can cvan ckan temp_adj)  (* temp_adj can (exp (neg (/ (+ v cvan) ckan)))))
    7676
    7777            (const  cbn   = 0.15743)
     
    7979            (const  cvbn  = 57)
    8080
    81             (defun Kv4_bmf (v)  (* temp_adj cbn (exp (neg (/ (+ v cvbn) ckbn)))))
     81            (defun Kv4_bmf (v cbn cvbn ckbn temp_adj)  (* temp_adj cbn (exp (neg (/ (+ v cvbn) ckbn)))))
    8282
    8383            (const cah   = 0.01342)
     
    8585            (const cvah  = 60)
    8686
    87             (defun Kv4_ahf (v)  (* temp_adj (/ cah (+ 1.0 (exp (neg (/ (+ v cvah) ckah)))))))
     87            (defun Kv4_ahf (v cah cvah ckah temp_adj)  (* temp_adj (/ cah (+ 1.0 (exp (neg (/ (+ v cvah) ckah)))))))
    8888
    8989            (const  cbh   = 0.04477)
     
    9191            (const  cvbh  = 54)
    9292
    93             (defun Kv4_bhf (v)  (* temp_adj (/ cbh (+ 1.0 (exp (neg (/ (+ v cvbh) ckbh)))))))
     93            (defun Kv4_bhf (v cbh cvbh ckbh temp_adj)  (* temp_adj (/ cbh (+ 1.0 (exp (neg (/ (+ v cvbh) ckbh)))))))
    9494
    9595
    9696            (hh-ionic-conductance
    9797             (Kv4  ;; ion name: exported variables will be of the form {ion}_{id}
    98               (initial-m (/ (Kv4_amf Vrest) (+ (Kv4_amf Vrest) (Kv4_bmf Vrest))) )
    99               (initial-h (/ (Kv4_ahf Vrest) (+ (Kv4_ahf Vrest) (Kv4_bhf Vrest))) )
     98              (initial-m (/ (Kv4_amf Vrest can cvan ckan temp_adj)
     99                            (+ (Kv4_amf Vrest v can cvan ckan temp_adj)
     100                               (Kv4_bmf Vrest cbn cvbn ckbn temp_adj))))
     101              (initial-h (/ (Kv4_ahf Vrest cah cvh ckah temp_adj)
     102                            (+ (Kv4_ahf Vrest cah cvh ckah temp_adj)
     103                               (Kv4_bhf Vrest cbh cvbh ckbh temp_adj))) )
    100104              (m-power   4)
    101105              (h-power   1)
    102               (m-alpha   (Kv4_amf v))
    103               (m-beta    (Kv4_bmf v))
    104               (h-alpha   (Kv4_ahf v))
    105               (h-beta    (Kv4_bhf v))
     106              (m-alpha   (Kv4_amf v can cvan ckan temp_adj))
     107              (m-beta    (Kv4_bmf v cbn cvbn ckbn temp_adj))
     108              (h-alpha   (Kv4_ahf v cah cvh ckah temp_adj))
     109              (h-beta    (Kv4_bhf v cbh cvbh ckbh temp_adj))
    106110              ))
    107111             
     
    127131            (const cvn =  90.1)
    128132            (const ckn =  -9.9)
    129             (defun Ih_inf (v)   (/ 1.0 (+ 1.0 (exp (neg (/ (+ v cvn) ckn) )))))
     133            (defun Ih_inf (v cvn ckn)   (/ 1.0 (+ 1.0 (exp (neg (/ (+ v cvn) ckn) )))))
    130134           
    131135            (const cct = 190)
     
    134138            (const ckt = 11.9)
    135139
    136             (defun Ih_tau (v)   (/ (+ cct (* cat (exp (neg (pow (/ (+ v cvt) ckt) 2))))) temp_adj))
     140            (defun Ih_tau (v cct cat cvt ckt temp_adj)   
     141              (/ (+ cct (* cat (exp (neg (pow (/ (+ v cvt) ckt) 2))))) temp_adj))
    137142
    138143            (hh-ionic-conductance
    139144             (Ih  ;; ion name: exported variables will be of the form {ion}_{id}
    140               (initial-m (Ih_inf v))
     145              (initial-m (Ih_inf Vrest cvn ckn))
    141146              (m-power   1)
    142147              (h-power   0)
    143               (m-inf     (Ih_inf v))
    144               (m-tau     (Ih_tau v))
     148              (m-inf     (Ih_inf v cvn ckn))
     149              (m-tau     (Ih_tau v cct cat cvt ckt temp_adj))
    145150              ))
    146151             
     
    166171            (const ck = 5.5)
    167172
    168             (defun CaP_inf (v)  (/ 1.0 (+ 1.0 (exp (neg (/ (+ v cv) ck))))))
    169 
    170             (defun CaP_tau (v)  (/ (if (> v -50) (* 1e3 (+ 0.000191 (* 0.00376 (pow (exp (neg (/ (+ v 41.9) 27.8)))  2))))
    171                                        (* 1e3 (+ 0.00026367 (* 0.1278 (exp (* 0.10327 v)))))) temp_adj))
     173            (defun CaP_inf (v cv ck)  (/ 1.0 (+ 1.0 (exp (neg (/ (+ v cv) ck))))))
     174
     175            (defun CaP_tau (v temp_adj) 
     176              (/ (if (> v -50) (* 1e3 (+ 0.000191 (* 0.00376 (pow (exp (neg (/ (+ v 41.9) 27.8)))  2))))
     177                     (* 1e3 (+ 0.00026367 (* 0.1278 (exp (* 0.10327 v)))))) temp_adj))
    172178
    173179            (hh-ionic-conductance
    174180             (CaP  ;; ion name: exported variables will be of the form {ion}_{id}
    175               (initial-m  (CaP_inf v))
     181              (initial-m  (CaP_inf Vrest cv ck))
    176182              (m-power    1)
    177183              (h-power    0)
    178               (m-inf      (CaP_inf v))
    179               (m-tau      (CaP_tau v))))
     184              (m-inf      (CaP_inf v cv ck))
     185              (m-tau      (CaP_tau v temp_adj))))
    180186             
    181187            )
     
    183189         (component (type pore)
    184190            (const gmax_CaP  = 0.01667)
    185             (gbar_CaP = (* gmax_CaP (ghk v cai cao)))
     191            (gbar_CaP = (* gmax_CaP (ghk v celsius cai cao)))
    186192            (output gbar_CaP ))
    187193
     
    199205
    200206            (const zhalf = 0.001)
    201             (defun CaBK_zinf (ca)  (/ 1 (+ 1 (/ zhalf ca))))
     207            (defun CaBK_zinf (ca zhalf)  (/ 1 (+ 1 (/ zhalf ca))))
    202208            (const CaBK_ztau = (/ 1.0 temp_adj))
    203209
    204210            (const cvm = 28.9)
    205211            (const ckm = 6.2)
    206             (defun CaBK_minf (v)     (/ (/ 1.0 (+ 1.0 (exp (neg (/ (+ v 5.0 cvm) ckm)))))
    207                                         temp_adj))
     212            (defun CaBK_minf (v cvm ckm temp_adj)
     213              (/ (/ 1.0 (+ 1.0 (exp (neg (/ (+ v 5.0 cvm) ckm)))))
     214                 temp_adj))
    208215           
    209216            (const ctm    = 0.000505)
     
    212219            (const cvtm2  = -33.3)
    213220            (const cktm2  = 10)
    214             (defun CaBK_mtau (v)     (/ (+ ctm (/ 1.0 (+ (exp (neg (/ (+ v 5.0 cvtm1) cktm1)))
    215                                                          (exp (neg (/ (+ v 5.0 cvtm2) cktm2))))))
    216                                       temp_adj))
     221            (defun CaBK_mtau (v ctm cvtm1 cktm1 cvtm2 cktm2 temp_adj)
     222              (/ (+ ctm (/ 1.0 (+ (exp (neg (/ (+ v 5.0 cvtm1) cktm1)))
     223                                  (exp (neg (/ (+ v 5.0 cvtm2) cktm2))))))
     224                 temp_adj))
    217225           
    218226            (const ch   = 0.085)
    219227            (const cvh  = 32)
    220228            (const ckh  = -5.8)
    221             (defun CaBK_hinf (v)    (/ (+ ch (/ (- 1.0 ch) (+ 1.0 (exp (neg (/ (+ v 5.0 cvh) ckh))))))
    222                                        temp_adj))
     229            (defun CaBK_hinf (v ch cvh ckh temp_adj)
     230              (/ (+ ch (/ (- 1.0 ch) (+ 1.0 (exp (neg (/ (+ v 5.0 cvh) ckh))))))
     231                 temp_adj))
    223232
    224233            (const cth    = 0.0019)
     
    227236            (const cvth2  = -54.2)
    228237            (const ckth2  = 12.9)
    229             (defun CaBK_htau (v)    (/ (+ cth (/ 1.0 ( + (exp (- (/ (+ v cvth1) ckth1)))
    230                                                          (exp (- (/ (+ v cvth2) ckth2))))))
    231                                        temp_adj))
    232            
    233            
    234             (state-complex (CaBK_z (transitions (-> zC zO  (/ (CaBK_zinf cai) CaBK_ztau))
    235                                                 (-> zO zC  (/ (- 1 (CaBK_zinf cai)) CaBK_ztau)))
    236                                    (initial   (CaBK_zinf 1e-4))
     238            (defun CaBK_htau (v cth ckth1 ckth2 cvth1 cvth2 temp_adj)
     239              (/ (+ cth (/ 1.0 ( + (exp (- (/ (+ v cvth1) ckth1)))
     240                                   (exp (- (/ (+ v cvth2) ckth2))))))
     241                 temp_adj))
     242           
     243           
     244            (state-complex (CaBK_z (transitions (-> zC zO  (/ (CaBK_zinf cai zhalf) CaBK_ztau))
     245                                                (-> zO zC  (/ (- 1 (CaBK_zinf cai zhalf)) CaBK_ztau)))
     246                                   (initial   (CaBK_zinf 1e-4 zhalf))
    237247                                   (open zO)  (power 2)))
    238248           
     
    242252            (hh-ionic-conductance
    243253             (CaBK  ;; ion name: exported variables will be of the form {ion}_{id}
    244               (initial-m (CaBK_minf v))
    245               (initial-h (CaBK_hinf v))
    246               (m-power   3)
    247               (h-power   1)
    248               (m-inf     (CaBK_minf v))
    249               (m-tau     (CaBK_mtau v))
    250               (h-inf     (CaBK_hinf v))
    251               (h-tau     (CaBK_htau v))))
     254              (initial-m  (CaBK_minf Vrest cvm ckm temp_adj ))
     255              (initial-h  (CaBK_hinf Vrest ch cvh ckh temp_adj ))
     256              (m-power    3)
     257              (h-power    1)
     258              (m-inf      (CaBK_minf v cvm ckm temp_adj) )
     259              (m-tau      (CaBK_mtau v ctm cvtm1 cktm1 cvtm2 cktm2 temp_adj) )
     260              (h-inf      (CaBK_hinf v ch cvh ckh temp_adj) )
     261              (h-tau      (CaBK_htau v cth cvth1 ckth1 cvth2 cvth2 temp_adj) )))
    252262
    253263            )
  • release/3/nemo/trunk/nemo.scm

    r11898 r11944  
    154154        (list '*text*  (lambda (text) text))
    155155        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)))))
    156177
    157178
     
    330351                         ncml:model (list))))
    331352
    332 (define (ncml->nmodl options doc)
     353
     354
     355(define (ncml->model options doc)
    333356  (let* ((ncml:model   (car (ncml:sxpath '(ncml:model) doc)))
    334357         (model-name   (sxml:attr ncml:model 'name))
     
    346369                        (print "component " x " subcomponents: " ((nemo 'component-subcomps) model-1 (second x))))
    347370                      ((nemo 'components) model-1)))
    348         (nemo:nmodl-translator model-1 (lookup-def 'nmodl-method options) (lookup-def 'table options) -150 150 1)
    349         ))))
     371        model-1))))
    350372
    351373
     
    357379
    358380
    359 ;; based on SRV:send-reply by Oleg Kiselyov
    360 (define (print-fragments b)
    361   (let loop ((fragments b) (result #f))
    362     (cond
    363       ((null? fragments) result)
    364       ((not (car fragments)) (loop (cdr fragments) result))
    365       ((null? (car fragments)) (loop (cdr fragments) result))
    366       ((eq? #t (car fragments)) (loop (cdr fragments) #t))
    367       ((pair? (car fragments))
    368         (loop (cdr fragments) (loop (car fragments) result)))
    369       ((procedure? (car fragments))
    370         ((car fragments))
    371         (loop (cdr fragments) #t))
    372       (else
    373        (display (car fragments))
    374        (loop (cdr fragments) #t)))))
    375 
    376 (define (ensure-xmlns doc)
    377   (sxml:add-attr doc '(xmlns ncml)))
     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           
    378398 
    379399(define (main options operands)
     
    381401      (for-each
    382402       (lambda (operand)
    383          (let* ((read-xml  (lambda (name) (call-with-input-file name
     403         (let* ((read-xml   (lambda (name) (call-with-input-file name
    384404                                            (lambda (port) (ssax:xml->sxml port '((ncml . "ncml")))) )))
    385                 (read-sxml  (lambda (name) (call-with-input-file name read)))
    386                 (doc        (cond ((lookup-def 'i options) => (lambda (x)
    387                                                                 (case ($ x)
    388                                                                   ((sxml)  (read-sxml operand))
    389                                                                   ((xml)   (read-xml operand))
    390                                                                   (else    (error 'nemo "unknown input format" x)))))
     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)))))
    391413                                  (else  (case ((lambda (x) (or (not x) ($ x)))
    392414                                                (pathname-extension operand))
    393                                           ((xml)   (read-xml operand))
    394                                           ((sxml)  (read-sxml operand))
    395                                           (else    (read-xml 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))))
    396428                (sxml-fname  ((lambda (x) (and x (if (string? (cdr x)) (s+ (pathname-strip-extension (cdr x)) ".sxml")
    397429                                                     (s+  (pathname-strip-extension operand) ".sxml"))))
     
    415447           (with-output-to-file
    416448               mod-fname  (lambda ()
    417                             (ncml->nmodl `((method . ,nmodl-method)
    418                                            (table  . ,(assoc 't options))) doc)))
     449                            (model->nmodl `((method . ,nmodl-method)
     450                                            (table  . ,(assoc 't options))) model)))
    419451           ))
    420452       operands)))
  • release/3/nemo/trunk/nemo.setup

    r11895 r11944  
    66  (make-pathname #f fn ##sys#load-dynamic-extension))   
    77
    8 (compile -d2 -O -s -o ,(dynld-name "nemo-core")
     8(compile -d2 -s -o ,(dynld-name "nemo-core")
    99         ,@(if has-exports? '(-check-imports -emit-exports nemo-core.exports) '())
    1010         core.scm)
Note: See TracChangeset for help on using the changeset viewer.