Changeset 12185 in project


Ignore:
Timestamp:
10/17/08 04:38:39 (12 years ago)
Author:
Ivan Raikov
Message:

Save

Location:
release/3/nemo/trunk
Files:
1 added
5 edited

Legend:

Unmodified
Added
Removed
  • release/3/nemo/trunk/expr-parser.scm

    r12179 r12185  
    55(require-extension  syntax-case)
    66(require-extension  matchable)
     7
     8;; Chicken Scheme implementation of the box routines.  Based on
     9;; dfa2.sc in the benchmarks code supplied with Stalin 0.11
     10
     11(define-record-type box (make-box contents)
     12  box? (contents box-contents box-contents-set!))
     13
     14(define box make-box)
     15(define unbox box-contents)
     16(define set-box! box-contents-set!)
     17
     18;; Stack routines.  Based on dfa2.sc in the benchmarks code supplied
     19;; with Stalin 0.11
     20
     21(define (make-stack)
     22  (box '()))
     23
     24(define (stack-empty? s)
     25  (null? (unbox s)))
     26
     27(define (stack-push! s obj)
     28  (set-box! s (cons obj (unbox s)))
     29  s)
     30
     31(define (stack-pop! s)
     32  (let ((l (unbox s)))
     33    (set-box! s (cdr l))
     34    (car l)))
     35
     36(define (stack-cut! s start end)
     37  (cond
     38   ((negative? start)
     39    (error 'stack-cut! "start depth must be >= 0"))
     40   ((negative? end)
     41    (error 'stack-cut! "end depth must be >= 0"))
     42   ((< end start)
     43    (error 'stack-cut! "start depth must be <= to the end depth")))
     44  (let ((l (unbox s)))
     45    (let loop ((i 0) (l l) (nl (list)))
     46      (if (null? l) (set-box! s (reverse nl))
     47          (if (and (>= i start) (<= i end))
     48              (loop (+ i 1) (cdr l) nl)
     49              (loop (+ i 1) (cdr l) (cons (car l) nl))))))
     50  s)
     51
     52(define (stack-depth s)
     53  (let ((l (unbox s)))
     54    (length l)))
     55
     56(define (stack-peek s)
     57  (let ((l (unbox s)))
     58    (car l)))
     59
     60(define stack->list unbox)
     61(define (list->stack lst)
     62  (and (pair? lst) (box lst)))
    763
    864(define-record token symbol value line)
     
    2985
    3086
    31 (define (make-lexer port errorp)
     87(define (make-char-lexer port errorp)
    3288  (lambda ()
    3389    (letrec ((skip-spaces
     
    88144(include "expr.grm.scm")
    89145
    90 (define (nemo:expr-parse s)
     146(define (nemo:parse-string-expr s)
    91147  (or (and (string? s) (string-null? s) '())
    92148      (let ((port
    93149             (cond ((string? s)  (open-input-string s))
    94150                   ((port? s)    s)
    95                    (else (error 'cml:expr-parse "bad argument type: not a string or a port: " s)))))
    96         (expr-parser  (make-lexer port parse-error) parse-error))))
     151                   (else (error 'nemo:parse-expr "bad argument type: not a string or a port: " s)))))
     152        (expr-parser  (make-char-lexer port parse-error) parse-error))))
     153
     154(define (make-sym-lexer lst errorp)
     155  (if (not (list? lst)) (errorp ": illegal list: " lst))
     156  (let ((is (make-stack)))
     157    (stack-push! is lst)
     158    (lambda ()
     159      (if (stack-empty? is)  '*eoi*
     160          (let* ((p     (stack-pop! is))
     161                 (x     (and (not (null? p)) (car p))))
     162            (if x
     163                (begin (stack-push! is (cdr p))
     164                       (match x
     165                              ((or '> '>= '< '>= '^ '+ '- '* '/ '= )      x)
     166                              ('?           (tok (QUESTION)))
     167                              (':           (tok (COLON)))
     168                              ((? number?)  (tok (NUM ,x)))
     169                              ((? symbol?)  (tok (ID ,x)))
     170                              ((? list?)    (begin (stack-push! is x)
     171                                                   (tok (LPAREN))))
     172                              (else (errorp ": invalid input: " x))))
     173                (if (not (stack-empty? is)) (tok (RPAREN)))))))))
     174 
     175
     176(define (nemo:parse-sym-expr lst)
     177  (or (and (list? lst) (null? lst) '())
     178      (expr-parser  (make-sym-lexer lst parse-error) parse-error)))
     179
    97180
    98181;(print (nemo:expr-parse "1/(alpha + beta) <= 0.00005 ? 0.00005 : 1/(alpha + beta)"))
  • release/3/nemo/trunk/expr.grm

    r12179 r12185  
    99
    1010   ;; --- token definitions
    11    (ID NUM LPAREN RPAREN
     11   (ID NUM LET RPAREN
    1212       (right: QUESTION COLON)
    1313       (left: < > =)
     
    1515       (left: * /)
    1616       (left: uminus)
    17        (right: ^ )
    18        (left: COMMA ) )
     17       (right: ^ )
     18       (right: LPAREN)
     19       )
     20
    1921
    2022   (expr     (NUM)                   : (exact->inexact (token-value $1))
     
    3335             (expr > = expr)         : `(>= ,$1 ,$3)
    3436             (expr QUESTION expr COLON expr) :  `(if ,$1 ,$3 ,$5)
     37             (LET LPAREN bnds RPAREN expr)   :  `(let ,(reverse $3) ,$5)
    3538             (LPAREN expr RPAREN)    : $2 )
    3639
    3740   (args     (expr)                  : (list $1)
    38              (args COMMA expr)       : (cons $3 $1))
     41             (args expr)             : (cons $3 $1))
     42
     43   (bnds     (binding)               : (list $1)
     44             (bnds binding)          : (cons $3 $1))
     45
     46   (binding  (LPAREN ID expr RPAREN)  : (list $1 $2))
    3947
    4048  ))
  • release/3/nemo/trunk/extensions/nemo-hh.scm

    r12129 r12185  
    6161                  [(exn) dflt]))
    6262
    63 (define (hh-ionic-conductance-transform sys eval-const env-extend! add-external! component-extend! comp en)
     63(define (hh-ionic-conductance-transform sys parse-expr eval-const env-extend! add-external! component-extend! comp en)
     64  (define (and-parse-expr x) (and x (parse-expr x)))
    6465  (match en
    6566         ((or (('hh 'ionic 'conductance)  ('name (? symbol? ion)) . alst)
     
    6768          (check-decls ion '(m-power h-power) alst)
    6869          (let ((suffix (->string ion))
    69                 (m-power (eval-const sys (lookup-field 'm-power alst)))
    70                 (h-power (eval-const sys (lookup-field 'h-power alst 0))))
     70                (m-power (eval-const sys (parse-expr (lookup-field 'm-power alst))))
     71                (h-power (eval-const sys (parse-expr (lookup-field 'h-power alst 0)))))
    7172           
    7273            (if (not (and (integer? m-power) (positive? m-power)))
     
    9192                                                        " must be a positive integer"))
    9293                                         
    93             (let* ((initial-m  ((lambda (x) (handle (lambda () (eval-const sys x)) x))
     94            (let* ((initial-m  ((lambda (x)
     95                                  (let ((expr (parse-expr x)))
     96                                    (handle (lambda () (eval-const sys expr)) expr)))
    9497                                (lookup-field 'initial-m alst)))
    95                    (m-inf      (lookup-field 'm-inf alst))
    96                    (m-tau      (lookup-field 'm-tau alst))
     98                   (m-inf      (and-parse-expr (lookup-field 'm-inf alst)))
     99                   (m-tau      (and-parse-expr (lookup-field 'm-tau alst)))
    97100                   (m-inf-sym  (p$ ion 'm-inf))
    98101                   (m-tau-sym  (p$ ion 'm-tau))
    99                    (m-alpha    (or (lookup-field 'm-alpha alst)  `(/ ,m-inf-sym ,m-tau-sym)))
    100                    (m-beta     (or (lookup-field 'm-beta alst)   `(/ (- 1 ,m-inf-sym) ,m-tau-sym)))
     102                   (m-alpha    (or (and-parse-expr (lookup-field 'm-alpha alst))
     103                                   `(/ ,m-inf-sym ,m-tau-sym)))
     104                   (m-beta     (or (and-parse-expr (lookup-field 'm-beta alst))
     105                                   `(/ (- 1 ,m-inf-sym) ,m-tau-sym)))
    101106                   (open       'O)
    102107                   (closed     'C)
     
    113118           
    114119            (if (positive? h-power)
    115                 (let* ((initial-h  ((lambda (x) (handle (lambda () (eval-const sys x)) x))
     120                (let* ((initial-h  ((lambda (x)
     121                                      (let ((expr (parse-expr x)))
     122                                        (handle (lambda () (eval-const sys expr)) expr)))
    116123                                    (lookup-field 'initial-h alst)))
    117                        (h-inf      (lookup-field 'h-inf alst))
    118                        (h-tau      (lookup-field 'h-tau alst))
    119                        (h-alpha    (or (lookup-field 'h-alpha alst)
     124                       (h-inf      (and-parse-expr (lookup-field 'h-inf alst)))
     125                       (h-tau      (and-parse-expr (lookup-field 'h-tau alst)))
     126                       (h-alpha    (or (and-parse-expr (lookup-field 'h-alpha alst))
    120127                                       `(/ ,h-inf ,h-tau)))
    121                        (h-beta     (or (lookup-field 'h-beta alst)
     128                       (h-beta     (or (and-parse-expr (lookup-field 'h-beta alst))
    122129                                       `(/ (- 1 ,h-inf) ,h-tau)))
    123130
     
    134141
    135142(define (nemo:hh-transformer sys . rest)
    136   (let ((new-sys  (nemo:env-copy sys)))
    137    (match-let ((($ nemo:quantity 'DISPATCH  dis) (environment-ref new-sys (nemo-intern 'dispatch))))
    138      (let* ((eval-const         (dis 'eval-const))
    139             (env-extend!        ((dis 'env-extend!) new-sys))
    140             (add-external!      ((dis 'add-external!) new-sys))
    141             (component-extend!  ((dis 'component-extend!) new-sys))
    142             (indent  0)
    143             (indent+ (+ 2 indent )))
    144        (let recur ((comp-name (nemo-intern 'toplevel)))
    145          (let* ((comp-symbols   ((dis 'component-symbols) new-sys comp-name))
    146                 (subcomps       ((dis 'component-subcomps) new-sys comp-name)))
     143  (let-optionals rest ((parse-expr identity))
     144   (let ((new-sys  (nemo:env-copy sys)))
     145     (match-let ((($ nemo:quantity 'DISPATCH  dis) (environment-ref new-sys (nemo-intern 'dispatch))))
     146      (let* ((eval-const         (dis 'eval-const))
     147             (env-extend!        ((dis 'env-extend!) new-sys))
     148             (add-external!      ((dis 'add-external!) new-sys))
     149             (component-extend!  ((dis 'component-extend!) new-sys))
     150             (indent  0)
     151             (indent+ (+ 2 indent )))
     152        (let recur ((comp-name (nemo-intern 'toplevel)))
     153          (let* ((comp-symbols   ((dis 'component-symbols) new-sys comp-name))
     154                 (subcomps       ((dis 'component-subcomps) new-sys comp-name)))
    147155            (for-each (lambda (sym)
    148156                        (hh-ionic-conductance-transform 
    149                          new-sys (dis 'eval-const) env-extend! add-external! component-extend!
     157                         new-sys parse-expr (dis 'eval-const) env-extend! add-external! component-extend!
    150158                         comp-name (environment-ref new-sys sym)))
    151159                      comp-symbols)
    152160            (for-each recur (map third subcomps))))
    153        new-sys))))
     161        new-sys)))))
  • release/3/nemo/trunk/nemo-core.scm

    r12176 r12185  
    332332              (('tscomp)  (begin
    333333                            (let ((power         (or (lookup-def 'power alst) 1))
    334                                   (transitions
     334                                  (transitions   
    335335                                   (map (lambda (t)
    336                                           (match-let (((src dst rate1 rate2)
    337                                                        (match t
    338                                                               (('-> a b r) (list a b r #f))
    339                                                               ((a '-> b r) (list a b r #f))
    340                                                               (('<-> a b r1 r2) (list a b r1 r2))
    341                                                               ((a '<-> b r1 r2) (list a b r1 r2)))))
    342                                                      (if (and rate1 rate2)
    343                                                          `(<-> ,src ,dst ,(normalize-expr rate1) ,(normalize-expr rate2) )
    344                                                          `(-> ,src ,dst ,(normalize-expr rate1)))))
    345                                                     (or (alist-ref 'transitions alst) (list))))
    346                                   (open         (lookup-def 'open alst)))
    347                             (if (null? transitions)
    348                                 (nemo:error 'env-extend!
    349                                                ": transition state complex definitions require a transition scheme"))
    350                             (if (not open)
    351                                 (nemo:error 'env-extend! ": state complex definitions require open state"))
    352                             (if (not (integer? power))
    353                                 (nemo:error 'env-extend!
    354                                                ": definition for state " sym
    355                                                " requires an integer power (" power  " was given)"))
    356                             (let ((en (TSCOMP name initial open transitions power)))
    357                               (environment-extend! nemo-env sym en)))))
     336                                          (match t
     337                                                 (( '<-> (and src (? symbol?)) (and dst (? symbol?)) r1 r2) 
     338                                                  `( <-> ,src ,dst ,(normalize-expr r1) ,(normalize-expr r2)))
     339
     340                                                 (( '-> (and src (? symbol?)) (and dst (? symbol?)) r1) 
     341                                                  `( -> ,src ,dst ,(normalize-expr r1) ))
     342
     343                                                 (else
     344                                                  (nemo:error 'env-extend! ": invalid transition " t))))
     345                                        (or (alist-ref 'transitions alst) (list))))
     346                                  (open          (lookup-def 'open alst)))
     347                              (if (null? transitions)
     348                                  (nemo:error 'env-extend!
     349                                              ": transition state complex definitions require a transition scheme"))
     350                              (if (not open)
     351                                  (nemo:error 'env-extend! ": state complex definitions require open state"))
     352                              (if (not (integer? power))
     353                                  (nemo:error 'env-extend!
     354                                              ": definition for state " sym
     355                                              " requires an integer power (" power  " was given)"))
     356                              (let ((en (TSCOMP name initial open transitions power)))
     357                                (environment-extend! nemo-env sym en)))))
    358358
    359359              (('asgn)    (let ((rhs (lookup-def 'rhs alst)))
     
    849849    (string->symbol (string-append (->string prefix) (number->string v)))))
    850850
    851 (define (eval-nemo-system-decls nemo-core name sys declarations)
    852   (define (eval-const x) (and x ((nemo-core 'eval-const) sys x)))
    853   (let loop ((ds declarations) (qs (list)) (top #t))
    854     (if (null? ds) 
     851(define (eval-nemo-system-decls nemo-core name sys declarations . rest)
     852  (let-optionals rest ((parse-expr identity))
     853   (define (eval-const x) (and x ((nemo-core 'eval-const) sys x)))
     854   (define env-extend!  ((nemo-core 'env-extend!) sys))
     855   (let loop ((ds declarations) (qs (list)) (top #t))
     856     (if (null? ds) 
    855857        (let ((qs (reverse qs)))
    856858          (if top (let* ((top-syms   ((nemo-core 'component-symbols ) sys (nemo-intern 'toplevel)))
     
    895897                            (('const id '= expr)
    896898                             (cond ((and (symbol? id) (or (number? expr) (list? expr)))
    897                                     (let ((val (eval-const expr)))
    898                                       (((nemo-core 'env-extend!) sys) id '(const) val)
     899                                    (let ((val (eval-const (parse-expr expr))))
     900                                      (env-extend! id '(const) val)
    899901                                      (cons id qs)))
    900902                                   (else (nemo:error 'eval-nemo-system-decls
     
    905907                            (('state-complex (id . alst) )
    906908                             (cond ((and (symbol? id) (list? alst))
    907                                     (let ((initial    (lookup-def 'initial alst))
    908                                           (initial-eq (alist-ref 'initial-equilibrium alst))
    909                                           (power   (eval-const (lookup-def 'power alst))))
     909                                    (let ((initial      (lookup-def 'initial alst))
     910                                          (initial-eq   (alist-ref 'initial-equilibrium alst))
     911                                          (power        (eval-const (parse-expr (lookup-def 'power alst))))
     912                                          (transitions
     913                                           (map (lambda (t)
     914                                                  (match-let
     915                                                   (((src dst rate1 rate2)
     916                                                     (match t
     917                                                            (('-> a b r) (list a b r #f))
     918                                                            ((a '-> b r) (list a b r #f))
     919                                                            (('<-> a b r1 r2) (list a b r1 r2))
     920                                                            ((a '<-> b r1 r2) (list a b r1 r2)))))
     921                                                   (if (and rate1 rate2)
     922                                                       `( <-> ,src ,dst ,(parse-expr rate1) ,(parse-expr rate2))
     923                                                       `( -> ,src ,dst ,(parse-expr rate1)))))
     924                                                (or (alist-ref 'transitions alst) (list)))))
     925
    910926                                      (if (not (or initial initial-eq))
    911927                                          (nemo:error 'eval-nemo-system-decls
    912928                                                      "state complex declarations require initial value or "
    913929                                                      "initial equilibrium equations"))
     930
    914931                                      (if (and initial-eq
    915932                                               (or (not (list? initial-eq)) (not (every lineq? initial-eq))))
     
    917934                                                      "initial equilibrium field in state complex declarations "
    918935                                                      "must be a list of linear equations"))
    919                                       (let ((initialv (and initial (eval-const initial))))
    920                                         (apply ((nemo-core 'env-extend!) sys)
    921                                                (cons* id '(tscomp) (or initialv initial-eq) `(power ,power) alst))
     936
     937                                      (let ((initialv (and initial (eval-const (parse-expr initial)))))
     938                                        (apply env-extend!
     939                                               (cons* id '(tscomp) (or initialv initial-eq) `(power ,power)
     940                                                      (alist-update! 'transitions transitions alst)))
    922941                                        (cons id qs))))
     942
    923943                                   (else (nemo:error 'eval-nemo-system-decls
    924944                                                        "state complex declarations must be of the form: "
     
    928948                            ((id '= expr)
    929949                             (cond ((and (symbol? id) (or (symbol? expr) (number? expr) (list? expr)))
    930                                     (((nemo-core 'env-extend!) sys) id '(asgn) 'none `(rhs ,expr))
     950                                    (env-extend! id '(asgn) 'none `(rhs ,expr))
    931951                                    (cons id qs))
    932952                                   (else (nemo:error 'eval-nemo-system-decls
     
    937957                            (('defun id idlist expr)
    938958                             (cond ((and (symbol? id) (list? idlist) (every symbol? idlist) (list? expr))
    939                                     (((nemo-core 'defun!) sys) id idlist expr)
     959                                    (((nemo-core 'defun!) sys) id idlist (parse-expr expr))
    940960                                    (cons id qs))
    941961                                   (else (nemo:error 'eval-nemo-system-decls
     
    945965                            ;; compiled primitives
    946966                            (('prim id value)
    947                              (cond ((symbol? id)  (((nemo-core 'env-extend!) sys) id '(prim) value))
     967                             (cond ((symbol? id)  (env-extend! id '(prim) value))
    948968                                   (else (nemo:error 'eval-nemo-system-decls
    949969                                                        "prim declarations must be of the form: "
     
    10181038
    10191039                                             (let ((name (or name (qname tag))))
    1020                                                (((nemo-core 'env-extend!) sys) name  typ alst)
     1040                                               (env-extend! name  typ alst)
    10211041                                               (cons name qs)))
    10221042                                 (nemo:error 'eval-nemo-system-decls "extended declarations must be of the form: "
     
    10271047                     (loop (cdr ds) qs1 top)))
    10281048        ))
    1029   sys)
     1049  sys))
  • release/3/nemo/trunk/nemo.scm

    r12181 r12185  
    6060  `(
    6161    ,(args:make-option (i)       (required: "FORMAT")   
    62                        (s+ "specify input format (xml, sxml, s-exp)")
     62                       (s+ "specify input format (xml, nemo, sxml, s-exp)")
    6363                       (string->symbol arg))
    6464    ,(args:make-option (xml)       (optional: "FILE")   
     
    149149
    150150
    151 (define (nemo-constructor name declarations)
     151(define (nemo-constructor name declarations parse-expr)
    152152  (let* ((nemo   (make-nemo-core))
    153153         (sys    ((nemo 'system) name)))
    154     (eval-nemo-system-decls nemo name sys declarations)
     154    (eval-nemo-system-decls nemo name sys declarations parse-expr)
    155155    (list sys nemo)))
    156156
    157 (define (sexp->model options doc)
     157(define (sexp->model options doc parse-expr)
    158158  (match doc
    159159         (('nemo-model model-name model-decls)
    160           (let* ((model+nemo  (nemo-constructor model-name model-decls))
     160          (let* ((model+nemo  (nemo-constructor model-name model-decls parse-expr))
    161161                 (model (first model+nemo))
    162162                 (nemo  (second model+nemo)))
     
    283283       `(ncml:model (@ (name ,sysname)) ,@(component->ncml (nemo-intern 'toplevel))))))
    284284           
     285
     286(include "expr-parser.scm")
    285287
    286288(require-extension stx-engine)
     
    540542         (model-name   (sxml:attr ncml:model 'name))
    541543         (model-decls  (ncml->decls (sxml:kids ncml:model))))
    542     (let* ((model+nemo  (nemo-constructor model-name model-decls))
     544    (let* ((model+nemo  (nemo-constructor model-name model-decls identity))
    543545           (model (first model+nemo))
    544546           (nemo  (second model+nemo)))
     
    567569                                   (lambda (x)
    568570                                     (case ($ x)
     571                                       ((nemo)        'nemo)
    569572                                       ((s-exp sexp)  'sexp)
    570573                                       ((sxml)  'sxml)
     
    578581                                           (else    'xml)))))
    579582                (doc        (case in-format
    580                               ((s-exp sexp)  (read-sexp operand))
    581                               ((sxml)  (read-sexp operand))
     583                              ((nemo sxml s-exp sexp)  (read-sexp operand))
    582584                              ((xml)   (read-xml operand))
    583585                              (else    (error 'nemo "unknown input format" in-format))))
    584586                (model       (case in-format
    585                                ((sxml xml)  (ncml->model options doc))
    586                                ((s-exp sexp)      (sexp->model options doc))
     587                               ((sxml xml)          (ncml->model options doc))
     588                               ((s-exp sexp)        (sexp->model options doc identity))
     589                               ((nemo)              (sexp->model options doc nemo:parse-sym-expr))
    587590                               (else    (error 'nemo "unknown input format" in-format))))
    588591                (sxml-fname  ((lambda (x) (and x (if (and (cdr x) (string? (cdr x)))
Note: See TracChangeset for help on using the changeset viewer.