Changeset 12784 in project


Ignore:
Timestamp:
12/05/08 08:36:44 (12 years ago)
Author:
Ivan Raikov
Message:

Completed functor code; some bug fixes in code generator identifier names.

Location:
release/3/nemo/trunk
Files:
6 edited

Legend:

Unmodified
Added
Removed
  • release/3/nemo/trunk/extensions/nemo-hh.scm

    r12185 r12784  
    11;;
    22;;
    3 ;; An extension for specifying Hodgkin-Huxley type dynamics in NeuroML
    4 ;; systems
     3;; An extension for specifying Hodgkin-Huxley type dynamics in NEMO
     4;; systems.
    55;;
    66;; Copyright 2008 Ivan Raikov and the Okinawa Institute of Science and Technology
  • release/3/nemo/trunk/nemo-core.scm

    r12710 r12784  
    2929(require-extension vector-lib)
    3030(require-extension environments)
     31(require-extension varsubst)
    3132(require-extension digraph)
    3233(require-extension graph-bfs)
     
    4142(declare (export make-nemo-core nemo:error nemo:warning
    4243                 nemo:env-copy nemo-intern nemo:quantity?
    43                  nemo:rhs? nemo:lineq?
     44                 nemo:rhs? nemo:lineq? nemo:subst-term nemo:binding? nemo:bind
    4445                 eval-nemo-system-decls
    4546                 TSCOMP ASGN CONST PRIM))
     
    122123  (EXPORTS    (lst (lambda (x) (and (list? x) (every symbol? x)))))
    123124  (COMPONENT  (name symbol?) (type symbol?) (lst (lambda (x) (and (list? x) (every symbol? x)))))
     125  (FUNCTOR    (name symbol?) (args (lambda (x) (and (list? x) (every symbol? x)))) (type symbol?)  (decls list?))
    124126  )
    125127
    126128(define (nemo-intern sym)
    127129  (string->symbol (string-append "#" (symbol->string sym))))
     130
     131(define (nemo-scoped scope sym)
     132  (string->symbol (string-append (->string scope) ":" (->string sym))))
     133
     134(define qcounter 0)
     135
     136(define (fresh prefix)
     137  (let ((v qcounter))
     138    (set! qcounter (+ 1 qcounter))
     139    (string->symbol (string-append (->string prefix) (number->string v)))))
     140
    128141
    129142(define (lookup-def k lst . rest)
     
    131144    (let ((v (alist-ref k lst)))
    132145      (if v (first v) default))))
     146
     147
     148(define (nemo:subst-term t subst k)
     149  (match t
     150         (('if c t e)
     151          `(if ,(k c subst) ,(k t subst) ,(k e subst)))
     152
     153         (('let bs e)
     154          (k `(let ,(map (lambda (b) `(,(car b) ,(k (cadr b) subst))) bs) ,(k e subst))
     155             subst))
     156
     157         ((f . es)
     158          (cons (k f subst) (map (lambda (e) (k e subst)) es)))
     159
     160         ((? symbol? )  (lookup-def t subst t))
     161
     162         ((? atom? ) t)))
     163
     164(define (nemo:binding? t) (and (list? t) (eq? 'let (car t)) (cdr t)))
     165
     166(define (nemo:bind ks vs e) `(let ,(zip ks vs) ,e))
     167
     168(define nemo:env-copy environment-copy)
     169
    133170
    134171(define (make-nemo-core . alst)
     
    847884      ((extended-with-tag)   extended-with-tag)
    848885      (else
    849        (nemo:error 'selector ": unknown message " selector " sent to an nemo-core object")))) 
     886       (nemo:error 'selector ": unknown message " selector " sent to an nemo-core object"))))
    850887
    851888  nemo-dispatch)
    852 
    853 (define nemo:env-copy environment-copy)
    854 
    855 (define qcounter 0)
    856 
    857 (define (qname prefix)
    858   (let ((v qcounter))
    859     (set! qcounter (+ 1 qcounter))
    860     (string->symbol (string-append (->string prefix) (number->string v)))))
    861889
    862890(define (eval-nemo-system-decls nemo-core name sys declarations . rest)
     
    864892   (define (eval-const x) (and x ((nemo-core 'eval-const) sys x)))
    865893   (define env-extend!  ((nemo-core 'env-extend!) sys))
    866    (let loop ((ds declarations) (qs (list)) (top #t))
     894   (define (compute-qid id scope scope-subst) (or (and scope scope-subst (nemo-scoped scope id)) id))
     895   (define (update-subst id qid subst) (if (not (equal? id qid)) (subst-extend id qid subst) subst))
     896   (define subst-expr  (subst-driver (lambda (x) (and (symbol? x) x))
     897                                     nemo:binding? identity nemo:bind nemo:subst-term))
     898   (let loop ((ds declarations) (qs (list)) (scope #f) (scope-subst #f))
    867899     (if (null? ds) 
    868900        (let ((qs (reverse qs)))
    869           (if top (let* ((top-syms   ((nemo-core 'component-symbols ) sys (nemo-intern 'toplevel)))
    870                          (top-syms1  (append qs top-syms)))
    871                     (environment-set! sys (nemo-intern 'toplevel) (COMPONENT 'toplevel 'toplevel top-syms1))))
    872           qs)
     901          (if (not scope)
     902              (let* ((top-syms   ((nemo-core 'component-symbols ) sys (nemo-intern 'toplevel)))
     903                     (top-syms1  (append qs top-syms)))
     904                (environment-set! sys (nemo-intern 'toplevel) (COMPONENT 'toplevel 'toplevel top-syms1))))
     905          (list qs scope-subst))
    873906        (let ((decl (car ds)))
    874           (let ((qs1  (match decl
    875                              ;; imported quantities
    876                              (((or 'input 'INPUT) . lst)
    877                               (cond ((every (lambda (x) (or (symbol? x) (list? x))) lst)
    878                                      (fold (lambda (x ax)
    879                                              (match x
    880                                                     ((? symbol?) 
    881                                                      (((nemo-core 'add-external!) sys) x `(input ,x ,x #f))
    882                                                      (cons x ax))
    883                                                     ((id1 (or 'as 'AS) x1)
    884                                                      (((nemo-core 'add-external!) sys) x `(input ,id1 ,x1 #f))
    885                                                      (cons x1 ax))
    886                                                     ((id1 (or 'from 'FROM) n1)
    887                                                      (((nemo-core 'add-external!) sys) x `(input ,id1 ,id1 ,n1))
    888                                                      (cons id1 ax))
    889                                                     ((id1 (or 'as 'AS) x1 (or 'from 'FROM) n1)
    890                                                      (((nemo-core 'add-external!) sys) x `(input ,id1 ,x1 ,n1))
    891                                                      (cons x1 ax))
    892                                                     ))
    893                                            qs lst))
    894                                     (else (nemo:error 'eval-nemo-system-decls
    895                                                       "import statement must be of the form: "
    896                                                       "input id1 [as x1] ... "))))
     907          (match-let
     908           (((qs1 scope-subst1)
     909             (match decl
     910                    ;; imported quantities
     911                    (((or 'input 'INPUT) . lst)
     912                     (cond ((every (lambda (x) (or (symbol? x) (list? x))) lst)
     913                            (fold
     914                             (lambda (x ax)
     915                               (match x
     916                                      ((? symbol?)
     917                                       (let ((qid (compute-qid x scope scope-subst)))
     918                                         (((nemo-core 'add-external!) sys) x `(input ,x ,qid #f))
     919                                         (list (cons qid qs) (update-subst x qid scope-subst))))
     920                                      ((id1 (or 'as 'AS) x1)
     921                                       (let ((qid (compute-qid x1 scope scope-subst)))
     922                                         (((nemo-core 'add-external!) sys) x `(input ,id1 ,qid #f))
     923                                         (list (cons qid qs) (update-subst x1 qid scope-subst))))
     924                                      ((id1 (or 'from 'FROM) n1)
     925                                       (let ((qid (compute-qid id1 scope scope-subst)))
     926                                         (((nemo-core 'add-external!) sys) x `(input ,id1 ,qid ,n1))
     927                                         (list (cons qid qs) (update-subst id1 qid scope-subst))))
     928                                      ((id1 (or 'as 'AS) x1 (or 'from 'FROM) n1)
     929                                       (let ((qid (compute-qid x1 scope scope-subst)))
     930                                         (((nemo-core 'add-external!) sys) x `(input ,id1 ,qid ,n1))
     931                                         (list (cons qid qs) (update-subst x1 qid scope-subst))))
     932                                      ))
     933                                  (list qs scope-subst) lst))
     934                           (else (nemo:error 'eval-nemo-system-decls
     935                                             "import statement must be of the form: "
     936                                             "input id1 [as x1] ... "))))
    897937
    898938                            ;; exported quantities
    899                             (((or 'output 'OUTPUT) . lst)
    900                              (cond ((every symbol? lst) 
    901                                     (for-each (lambda (x) (((nemo-core 'add-external!) sys) x 'output)) lst)
    902                                     qs)
    903                                    (else (nemo:error 'eval-nemo-system-decls
    904                                                         "export statement must be of the form: "
    905                                                         "output id1 ... "))))
     939                            (((or 'output 'OUTPUT) . (and lst (? (lambda (x) (every symbol? x)))))
     940                             (let ((lst1 (map (lambda (x) (compute-qid x scope scope-subst)) lst)))
     941                               (for-each (lambda (x) (((nemo-core 'add-external!) sys) x 'output)) lst1)
     942                               (list qs scope-subst)))
    906943
    907944                            ;; constant during integration
    908                             (((or 'const 'CONST) id '= expr)
    909                              (cond ((and (symbol? id) (expr? expr))
    910                                     (let ((val (eval-const (parse-expr expr))))
    911                                       (env-extend! id '(const) val)
    912                                       (cons id qs)))
    913                                    (else (nemo:error 'eval-nemo-system-decls
    914                                                         "constant declarations must be of the form: "
    915                                                         "const id = expr"))))
     945                            (((or 'const 'CONST) (and id (? symbol?)) '= (and expr (? expr? )))
     946                             (let* ((qid    (compute-qid id scope scope-subst))
     947                                    (qexpr  (subst-expr (parse-expr expr) scope-subst))
     948                                    (qval   (eval-const qexpr)))
     949                               (env-extend! qid '(const) qval)
     950                               (list (cons qid qs) (update-subst id qid scope-subst))))
    916951
    917952                            ;; state transition complex
    918                             (((or 'state-complex 'STATE-COMPLEX) (id . alst) )
    919                              (cond ((and (symbol? id) (list? alst))
    920                                     (let* ((initial      (lookup-def 'initial alst))
    921                                            (conserve-eq  (alist-ref 'conserve alst))
    922                                            (power        (lookup-def 'power alst))
    923                                            (power-val    (if (expr? power) (eval-const (parse-expr power))
    924                                                              (nemo:error 'eval-nemo-system-decls
    925                                                                          "invalid power expression" power
    926                                                                          " in definition of state complex" id)))
    927                                           (transitions
    928                                            (map (lambda (t)
    929                                                   (match-let
    930                                                    (((src dst rate1 rate2)
    931                                                      (match t
    932                                                             (('-> a b r) (list a b r #f))
    933                                                             ((a '-> b r) (list a b r #f))
    934                                                             (('<-> a b r1 r2) (list a b r1 r2))
    935                                                             ((a '<-> b r1 r2) (list a b r1 r2)))))
    936                                                    (if (and rate1 rate2)
    937                                                        `( <-> ,src ,dst ,(parse-expr rate1) ,(parse-expr rate2))
    938                                                        `( -> ,src ,dst ,(parse-expr rate1)))))
    939                                                 (or (alist-ref 'transitions alst) (list)))))
    940 
    941                                       (let ((conserve-eq
    942                                              (and conserve-eq (map (lambda (eq)
    943                                                                      (if (expr? (third eq))
    944                                                                          `(,(first eq) = ,(parse-expr (third eq)))
    945                                                                          (nemo:error 'eval-nemo-system-decls
    946                                                                                      "invalid equation " eq)))
    947                                                                    conserve-eq))))
    948 
    949                                         (if (and (list? conserve-eq) (not (every lineq? conserve-eq)))
    950                                             (nemo:error 'env-extend!
    951                                                         ": conservation equation for " id
    952                                                         " must be a linear equation: " conserve-eq))
    953 
    954                                         (let ((initialv (and initial (eval-const (parse-expr initial)))))
    955                                           (apply env-extend!
    956                                                  (cons* id '(tscomp) initialv `(power ,power)
    957                                                         (alist-update! 'conserve conserve-eq
    958                                                           (alist-update! 'transitions transitions alst))
    959                                                         ))
    960                                           (cons id qs)))))
    961 
    962                                    (else (nemo:error 'eval-nemo-system-decls
    963                                                         "state complex declarations must be of the form: "
    964                                                         "state-complex (id ...)"))))
     953                            (((or 'state-complex 'STATE-COMPLEX) ((and id (? symbol?)) . alst) )
     954                             (let* ((initial      (lookup-def 'initial alst))
     955                                    (conserve-eq  (alist-ref 'conserve alst))
     956                                    (power        (lookup-def 'power alst))
     957                                    (power-val    (if (expr? power)
     958                                                      (eval-const (subst-expr (parse-expr power) scope-subst))
     959                                                      (nemo:error 'eval-nemo-system-decls
     960                                                                  "invalid power expression" power
     961                                                                  " in definition of state complex" id)))
     962                                    (transitions
     963                                     (map (lambda (t)
     964                                            (match-let
     965                                             (((src dst rate1 rate2)
     966                                               (match t
     967                                                      (('-> a b r) (list a b r #f))
     968                                                      ((a '-> b r) (list a b r #f))
     969                                                      (('<-> a b r1 r2) (list a b r1 r2))
     970                                                      ((a '<-> b r1 r2) (list a b r1 r2)))))
     971                                             (if (and rate1 rate2)
     972                                                 `( <-> ,src ,dst
     973                                                        ,(subst-expr (parse-expr rate1) scope-subst)
     974                                                        ,(subst-expr (parse-expr rate2) scope-subst))
     975                                                 `( -> ,src ,dst ,(subst-expr (parse-expr rate1) scope-subst)))))
     976                                          (or (alist-ref 'transitions alst) (list)))))
     977                               
     978                               (let ((conserve-eq
     979                                      (and conserve-eq (map (lambda (eq)
     980                                                              (if (expr? (third eq))
     981                                                                  `(,(first eq) =
     982                                                                    ,(subst-expr (parse-expr (third eq)) scope-subst))
     983                                                                  (nemo:error 'eval-nemo-system-decls
     984                                                                              "invalid equation " eq)))
     985                                                            conserve-eq))))
     986                                 
     987                                 (if (and (list? conserve-eq) (not (every lineq? conserve-eq)))
     988                                     (nemo:error 'env-extend!
     989                                                 ": conservation equation for " id
     990                                                 " must be a linear equation: " conserve-eq))
     991                                 
     992                                 (let* ((qid          (compute-qid id scope scope-subst))
     993                                        (initial-expr (and initial (subst-expr (parse-expr initial) scope-subst)))
     994                                        (initial-val  (and initial-expr (eval-const initial-expr))))
     995                                   (apply env-extend!
     996                                          (cons* qid '(tscomp) initial-val `(power ,power-val)
     997                                                 (alist-update! 'conserve conserve-eq
     998                                                                (alist-update! 'transitions transitions alst))
     999                                                 ))
     1000                                   (list (cons qid qs) (update-subst id qid scope-subst))))))
     1001                           
    9651002                           
    9661003                            ;; algebraic assignment
    967                             ((id '= expr)
    968                              (cond ((and (symbol? id) (expr? expr))
    969                                     (env-extend! id '(asgn) 'none `(rhs ,(parse-expr expr)))
    970                                     (cons id qs))
    971                                    (else (nemo:error 'eval-nemo-system-decls
    972                                                         "algebraic declarations must be of the form: "
    973                                                         "id = expr"))))
     1004                            (((and id (? symbol?)) '= (and expr (? expr?) ))
     1005                             (let* ((qid    (compute-qid id scope scope-subst))
     1006                                    (qexpr  (subst-expr (parse-expr expr) scope-subst)))
     1007                               (env-extend! qid '(asgn) 'none `(rhs ,qexpr))
     1008                               (list (cons qid qs) (update-subst id qid scope-subst))))
    9741009                           
    9751010                            ;; user-defined function
    976                             (((or 'defun 'DEFUN) id idlist expr)
    977                              (cond ((and (symbol? id) (list? idlist) (every symbol? idlist) (expr? expr))
    978                                     (((nemo-core 'defun!) sys) id idlist (parse-expr expr))
    979                                     (cons id qs))
    980                                    (else (nemo:error 'eval-nemo-system-decls
    981                                                         "function declarations must be of the form: "
    982                                                         "defun id (arg1 arg2 ...) expr"))))
     1011                            (((or 'defun 'DEFUN) (and id (? symbol?))
     1012                              (and idlist (? (lambda (x) (every symbol? x)))) (and expr (? expr?)))
     1013                             (let ((qid    (compute-qid id scope scope-subst)))
     1014                               (((nemo-core 'defun!) sys) qid idlist (parse-expr expr))
     1015                               (list (cons qid qs) (update-subst id qid scope-subst))))
    9831016                           
    9841017                            ;; compiled primitives
     
    9881021                                                        "prim declarations must be of the form: "
    9891022                                                        "prim id value"))))
    990                            
    991                             (((or 'component 'COMPONENT)
    992                               ((or 'type 'TYPE) typ)
    993                               ((or 'name 'NAME) name) . lst) 
    994                              (let* ((cqs   (loop lst (list) #f))
    995                                     (sym   (qname "comp"))
    996                                     (comp  (COMPONENT name typ cqs)))
    997                                (environment-set! sys sym comp)
    998                                (cons sym qs)))
    999 
    1000                              
    1001                             (((or 'component 'COMPONENT) ((or 'type 'TYPE) typ)  . lst) 
    1002                              (let* ((sym   (qname "comp"))
    1003                                     (cqs   (loop lst (list) #f))
    1004                                     (comp  (COMPONENT sym typ cqs)))
    1005                                (environment-set! sys sym comp)
    1006                                (cons sym qs)))
    1007                              
    1008                            
     1023
    10091024                            (((or 'sysname 'SYSNAME) name) 
    10101025                             (if (symbol? name)
     
    10131028                                             "system name must be a symbol")))
    10141029                           
     1030                            (((or 'component 'COMPONENT)
     1031                              ((or 'type 'TYPE) typ)
     1032                              ((or 'name 'NAME) name) . lst)
     1033                             
     1034                             (let* ((sym   (fresh "comp"))
     1035                                    (scope (or scope sym)))
     1036                               (match-let (((cqs scope-subst1)   (loop lst (list) scope scope-subst)))
     1037                                 (let ((comp  (COMPONENT name typ cqs)))
     1038                                   (environment-set! sys sym comp)
     1039                                   (list (cons sym qs) scope-subst1)))))
     1040
     1041                            (((or 'component 'COMPONENT) ((or 'type 'TYPE) typ)  . lst) 
     1042                             (let* ((sym   (fresh "comp"))
     1043                                    (scope (or scope sym)))
     1044                                   (match-let (((cqs scope-subst1)   (loop lst (list) scope scope-subst)))
     1045                                      (let ((comp  (COMPONENT sym typ cqs)))
     1046                                        (environment-set! sys sym comp)
     1047                                        (list (cons sym qs) scope-subst1)))))
     1048
     1049
     1050                            (((or 'component 'COMPONENT)  ((or 'name 'NAME) name) '=
     1051                              (and functor-name (? symbol?)) (and args (? list?)))
     1052
     1053                             (if (and scope scope-subst)
     1054                                 (nemo:error 'eval-nemo-system-decls
     1055                                             "functor instantiation is not permitted in nested scope"))
     1056
     1057                             (match-let
     1058                              (((functor-args functor-type functor-lst)
     1059                                (let ((x (environment-ref sys functor-name)))
     1060                                  (or (and (nemo:quantity? x)
     1061                                           (cases nemo:quantity x
     1062                                                  (FUNCTOR (sym args typ lst)  (list args typ lst))
     1063                                                  (else #f)))
     1064                                      (nemo:error 'eval-nemo-system-decls! functor-name
     1065                                                  " is not a functor" )))))
     1066                              (if (not (= (length functor-args)  (length args)))
     1067                                  (nemo:error 'eval-nemo-system-decls! "functor " functor-name
     1068                                              " requires " (length functor-args) " arguments; "
     1069                                              args " was given"))
     1070                              (match-let
     1071                               (((cqs1 scope-subst1)   (loop args (list) name subst-empty)))
     1072                                 (let ((cqs1-names (sort (map ->string cqs1) string< ))
     1073                                       (args-names (let ((qs (map (lambda (x)
     1074                                                                    (->string (compute-qid x name scope-subst1)) )
     1075                                                                    functor-args)))
     1076                                                     (sort qs string<))))
     1077                                                       
     1078                                   (if (not (every string= cqs1-names args-names))
     1079                                       (nemo:error 'eval-nemo-system-decls! "functor " functor-name
     1080                                              " instantiation did not include all required arguments "
     1081                                              functor-args)))
     1082                               
     1083                               (match-let
     1084                                (((cqs2 scope-subst2)   (loop functor-lst (list) name scope-subst1)))
     1085                               (let* ((sym    (fresh "comp"))
     1086                                      (comp   (COMPONENT name functor-type (append cqs1 cqs2))))
     1087                                 (environment-set! sys sym comp)
     1088                                 (list (cons sym qs) #f))))))
     1089                             
     1090                            (((or 'functor 'FUNCTOR) ((or 'name 'NAME) name) ((or 'type 'TYPE) typ)
     1091                              (and args (? list?))  '= . lst)
     1092                             (if (and scope scope-subst)
     1093                                 (nemo:error 'eval-nemo-system-decls
     1094                                             "functor declaration is not permitted in nested scope"))
     1095                             (let* ((sym      (string->symbol (->string name)))
     1096                                    (functor  (FUNCTOR sym args typ lst)))
     1097                               (if (environment-has-binding? sys sym)
     1098                                   (nemo:error 'eval-nemo-system-decls! ": functor " sym " already defined"))
     1099                               (environment-set! sys sym functor)
     1100                               (list (cons sym qs) #f)))
     1101                           
    10151102                            (((or 'const 'CONST) . _)
    10161103                             (nemo:error 'eval-nemo-system-decls "constant declarations must be of the form: "
     
    10431130                            ;; declarations recognized by the nemo extension
    10441131                            ;; modules
    1045                             ((tag  . lst)
    1046                              (if (symbol? tag)
    1047                                  (match-let (((typ name alst) 
    1048                                               (let loop ((lst lst) (ax (list tag)))
    1049                                                 (if (null? lst)
    1050                                                     (list (list (car (reverse ax))) #f (cdr (reverse ax)))
    1051                                                     (begin
    1052                                                       (match lst
    1053                                                              (((? symbol?) . rest)
    1054                                                               (loop (cdr lst) (cons (car lst) ax)))
    1055                                                              (((x . rest))
    1056                                                               (if (and (symbol? x) (every list? rest))
    1057                                                                   (list (reverse ax) x rest)
    1058                                                                   (list (reverse ax) #f lst)))
    1059                                                              (else  (list (reverse ax) #f lst))))))))
    1060 
    1061                                              (let ((name (or name (qname tag))))
    1062                                                (env-extend! name  typ alst)
    1063                                                (cons name qs)))
    1064                                  (nemo:error 'eval-nemo-system-decls "extended declarations must be of the form: "
    1065                                                 "declaration (name (properties ...)")))
     1132                            (((and tag (? symbol?))  . lst)
     1133                             (match-let (((typ name alst) 
     1134                                          (let loop ((lst lst) (ax (list tag)))
     1135                                            (if (null? lst)
     1136                                                (list (list (car (reverse ax))) #f (cdr (reverse ax)))
     1137                                                (match lst
     1138                                                       (((? symbol?) . rest)
     1139                                                        (loop (cdr lst) (cons (car lst) ax) ))
     1140                                                       (((x . rest))
     1141                                                          (if (and (symbol? x) (every list? rest))
     1142                                                              (list (reverse ax) x rest)
     1143                                                              (list (reverse ax) #f lst)))
     1144                                                       (else  (list (reverse ax) #f lst)))))))
     1145                                       
     1146                                        (let* ((name (or name (fresh tag)))
     1147                                               (qid  (compute-qid name scope scope-subst)))
     1148                                          (env-extend! qid  typ (if scope (append alst `((scope ,scope))) alst))
     1149                                          (list (cons name qs) (update-subst name qid scope-subst)))))
     1150
     1151                            (else
     1152                             (nemo:error 'eval-nemo-system-decls "extended declarations must be of the form: "
     1153                                         "declaration (name (properties ...)"))
    10661154                            )))
    1067                            
    1068                            
    1069                      (loop (cdr ds) qs1 top)))
     1155           (loop (cdr ds) qs1 scope scope-subst1)))
    10701156        ))
    1071   sys))
     1157   sys))
  • release/3/nemo/trunk/nemo-matlab.scm

    r12685 r12784  
    11;;       
    22;;
    3 ;; An extension for translating NEMO models to Matlab code.
     3;; An extension for translating NEMO models to Matlab/Octave code.
    44;;
    55;; Copyright 2008 Ivan Raikov and the Okinawa Institute of Science and Technology
     
    134134
    135135(define (canonicalize-expr/MATLAB expr)
    136   (let ((subst-convert  (subst-driver (lambda (x) (and (symbol? x) x)) binding? identity bind subst-term)))
     136  (let ((subst-convert  (subst-driver (lambda (x) (and (symbol? x) x)) nemo:binding? identity nemo:bind nemo:subst-term)))
    137137    (let* ((expr1 (if-convert expr))
    138138           (expr2 (subst-convert expr1 subst-empty))
     
    228228            (vars     (lookup-def 'vars lst))
    229229            (body     (lookup-def 'body lst)))
    230         (pp indent ,nl (function ,retval = ,n (,(sl\ ", " vars)) ))
     230        (pp indent ,nl (function ,retval = ,(matlab-name n) (,(sl\ ", " vars)) ))
    231231        (let* ((body1 (canonicalize-expr/MATLAB (rhsexpr/MATLAB body)))
    232232               (lbs   (enum-bnds body1 (list))))
     
    429429                                     (and (not (member (first nv) matlab-builtin-consts))
    430430                                          (let ((v1 (canonicalize-expr/MATLAB (second nv))))
    431                                             (list (first nv) v1))))
     431                                            (list (matlab-name (first nv)) v1))))
    432432                                   consts))
    433                 (globals          (delete-duplicates (append (map first imports) exports (map first const-defs))))
     433                (globals          (map matlab-name
     434                                       (delete-duplicates (append (map first imports) exports (map first const-defs)))))
    434435                (poset            (vector->list ((dis 'depgraph->bfs-dist-poset) g)))
    435436                (asgn-eq-defs     (poset->asgn-eq-defs poset sys))
  • release/3/nemo/trunk/nemo-nmodl.scm

    r12685 r12784  
    142142
    143143(define (canonicalize-expr/NMODL expr)
    144   (let ((subst-convert  (subst-driver (lambda (x) (and (symbol? x) x)) binding? identity bind subst-term)))
     144  (let ((subst-convert  (subst-driver (lambda (x) (and (symbol? x) x))
     145                                      nemo:binding? identity nemo:bind nemo:subst-term)))
    145146    (let* ((expr1 (if-convert expr))
    146147           (expr2 (subst-convert expr1 subst-empty))
     
    228229(define (expr->string/NMODL x . rest)
    229230  (let-optionals rest ((rv #f) (width 72))
    230     (sdoc->string (doc:format width (format-expr/NMODL 2 x rv)))))
     231    (sdoc->string (doc:format width (format-expr/NMODL 2 x (and rv (nmodl-name rv)))))))
    231232 
    232233
     
    305306               
    306307
    307 #|       
    308 (define (lineq->string/NMODL x val . rest)
    309   (let-optionals rest ((width 72))
    310     (s+ "~ " (sdoc->string (doc:format width (format-lineq/NMODL 2 x #f)))
    311         " = " (number->string val))))
    312 |# 
    313          
    314308(define (conserve-lineq->string/NMODL x val . rest)
    315309  (let-optionals rest ((width 72))
     
    335329                                               FROM ,min-v TO ,max-v WITH ,with)))
    336330                     (else  (void))))
    337           (pp indent+ ,(expr->string/NMODL body1 n)))
     331          (pp indent+ ,(expr->string/NMODL body1 (nmodl-name n))))
    338332        (pp indent "}"))) 
    339333    ))
    340334
    341335(define (define-state indent n)
    342   (pp indent (,n)))
     336  (pp indent (,(nmodl-name n))))
    343337
    344338(define (expeuler dt name rhs)
     
    409403
    410404(define (kstate-eqs n initial open transitions power)
    411   (let* ((subst-convert  (subst-driver (lambda (x) (and (symbol? x) x)) binding? identity bind subst-term))
     405  (let* ((subst-convert  (subst-driver (lambda (x) (and (symbol? x) x))
     406                                       nemo:binding? identity nemo:bind nemo:subst-term))
    412407         (state-list     (let loop ((lst (list)) (tlst transitions))
    413408                           (if (null? tlst)  (delete-duplicates lst eq?)
     
    706701           
    707702           (pp indent ,nl (NEURON "{"))
    708            (if (not (null? exports)) (pp indent+ (RANGE ,(sl\ ", " exports))))
     703           (if (not (null? exports)) (pp indent+ (RANGE ,(sl\ ", " (map nmodl-name exports)))))
    709704
    710705           (for-each (lambda (x)
     
    839834                   (if (not (null? locals)) (pp indent+ (LOCAL ,(sl\ ", " locals))))
    840835                   (for-each (lambda (def)
    841                                (let ((n (first def)) (b (second def)))
     836                               (let ((n (nmodl-name (first def))) (b (second def)))
    842837                                 (pp indent+ ,(expr->string/NMODL b n)))) eq-defs))
    843838                 
     
    898893                                       (else
    899894                                        (nemo:error 'nemo:nmodl-translator ": ion channel definition " label
     895                                                    (s+ "(" n ")")
    900896                                                    "lacks permeating-substance or accumulating-substance "
    901897                                                    "component"))))
  • release/3/nemo/trunk/nemo-utils.scm

    r12685 r12784  
    3434(declare
    3535 (lambda-lift)
    36  (export  lookup-def binding? bind
    37           enum-bnds enum-freevars sum subst-term
     36 (export  lookup-def enum-bnds enum-freevars sum
    3837          if-convert let-enum let-elim let-lift
    3938          s+ sw+ sl\ nl spaces ppf
     
    7776             ((x . rest) `(+ ,x ,(sum rest))))))
    7877
    79 
    80 (define (subst-term t subst k)
    81   (match t
    82          (('if c t e)
    83           `(if ,(k c subst) ,(k t subst) ,(k e subst)))
    84 
    85          (('let bs e)
    86           (k `(let ,(map (lambda (b) `(,(car b) ,(k (cadr b) subst))) bs) ,(k e subst))
    87              subst))
    88 
    89          ((f . es)
    90           (cons (k f subst) (map (lambda (e) (k e subst)) es)))
    91 
    92          ((? symbol? )  (lookup-def t subst t))
    93 
    94          ((? atom? ) t)))
    95 
    96 (define (binding? t) (and (list? t) (eq? 'let (car t)) (cdr t)))
    97 
    98 (define (bind ks vs e) `(let ,(zip ks vs) ,e))
    9978
    10079(define (if-convert expr)
     
    164143
    165144(define (transitions-graph n open transitions state-name)
    166   (let* ((subst-convert  (subst-driver (lambda (x) (and (symbol? x) x)) binding? identity bind subst-term))
     145  (let* ((subst-convert  (subst-driver (lambda (x) (and (symbol? x) x))
     146                                       nemo:binding? identity nemo:bind nemo:subst-term))
    167147         (g          (make-digraph n (string-append (->string n) " transitions graph")))
    168148         (add-node!  (g 'add-node!))
     
    220200
    221201(define (state-lineqs n transitions lineqs state-name)
    222   (let* ((subst-convert  (subst-driver (lambda (x) (and (symbol? x) x)) binding? identity bind subst-term))
     202  (let* ((subst-convert  (subst-driver (lambda (x) (and (symbol? x) x))
     203                                       nemo:binding? identity nemo:bind nemo:subst-term))
    223204         (state-list     (let loop ((lst (list)) (tlst transitions))
    224205                           (if (null? tlst)  (delete-duplicates lst eq?)
  • release/3/nemo/trunk/nemo.meta

    r12712 r12784  
    99        "nemo-nmodl.scm" "nemo-matlab.scm" "extensions"
    1010        "SSAX.scm" "stx-macros.scm" "SXML.scm" "SXML-to-XML.scm"
    11         "nemo.setup" "nemo-eggdoc.scm" "examples"
     11        "nemo.setup" "nemo-eggdoc.scm" "examples" 
    1212        )
    1313
Note: See TracChangeset for help on using the changeset viewer.