Changeset 12185 in project
- Timestamp:
- 10/17/08 04:38:39 (12 years ago)
- Location:
- release/3/nemo/trunk
- Files:
-
- 1 added
- 5 edited
-
expr-parser.scm (modified) (3 diffs)
-
expr.grm (modified) (3 diffs)
-
extensions/nemo-hh.scm (modified) (5 diffs)
-
make-bundle.sh (added)
-
nemo-core.scm (modified) (10 diffs)
-
nemo.scm (modified) (6 diffs)
Legend:
- Unmodified
- Added
- Removed
-
release/3/nemo/trunk/expr-parser.scm
r12179 r12185 5 5 (require-extension syntax-case) 6 6 (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))) 7 63 8 64 (define-record token symbol value line) … … 29 85 30 86 31 (define (make- lexer port errorp)87 (define (make-char-lexer port errorp) 32 88 (lambda () 33 89 (letrec ((skip-spaces … … 88 144 (include "expr.grm.scm") 89 145 90 (define (nemo: expr-parses)146 (define (nemo:parse-string-expr s) 91 147 (or (and (string? s) (string-null? s) '()) 92 148 (let ((port 93 149 (cond ((string? s) (open-input-string s)) 94 150 ((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 97 180 98 181 ;(print (nemo:expr-parse "1/(alpha + beta) <= 0.00005 ? 0.00005 : 1/(alpha + beta)")) -
release/3/nemo/trunk/expr.grm
r12179 r12185 9 9 10 10 ;; --- token definitions 11 (ID NUM L PARENRPAREN11 (ID NUM LET RPAREN 12 12 (right: QUESTION COLON) 13 13 (left: < > =) … … 15 15 (left: * /) 16 16 (left: uminus) 17 (right: ^ ) 18 (left: COMMA ) ) 17 (right: ^ ) 18 (right: LPAREN) 19 ) 20 19 21 20 22 (expr (NUM) : (exact->inexact (token-value $1)) … … 33 35 (expr > = expr) : `(>= ,$1 ,$3) 34 36 (expr QUESTION expr COLON expr) : `(if ,$1 ,$3 ,$5) 37 (LET LPAREN bnds RPAREN expr) : `(let ,(reverse $3) ,$5) 35 38 (LPAREN expr RPAREN) : $2 ) 36 39 37 40 (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)) 39 47 40 48 )) -
release/3/nemo/trunk/extensions/nemo-hh.scm
r12129 r12185 61 61 [(exn) dflt])) 62 62 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))) 64 65 (match en 65 66 ((or (('hh 'ionic 'conductance) ('name (? symbol? ion)) . alst) … … 67 68 (check-decls ion '(m-power h-power) alst) 68 69 (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))))) 71 72 72 73 (if (not (and (integer? m-power) (positive? m-power))) … … 91 92 " must be a positive integer")) 92 93 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))) 94 97 (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))) 97 100 (m-inf-sym (p$ ion 'm-inf)) 98 101 (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))) 101 106 (open 'O) 102 107 (closed 'C) … … 113 118 114 119 (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))) 116 123 (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)) 120 127 `(/ ,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)) 122 129 `(/ (- 1 ,h-inf) ,h-tau))) 123 130 … … 134 141 135 142 (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))) 147 155 (for-each (lambda (sym) 148 156 (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! 150 158 comp-name (environment-ref new-sys sym))) 151 159 comp-symbols) 152 160 (for-each recur (map third subcomps)))) 153 new-sys))))161 new-sys))))) -
release/3/nemo/trunk/nemo-core.scm
r12176 r12185 332 332 (('tscomp) (begin 333 333 (let ((power (or (lookup-def 'power alst) 1)) 334 (transitions 334 (transitions 335 335 (map (lambda (t) 336 (match -let (((src dst rate1 rate2)337 (match t338 (('-> 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 346 (open (lookup-def 'open alst)))347 (if (null? transitions)348 (nemo:error 'env-extend!349 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 355 356 (let ((en (TSCOMP name initial open transitions power)))357 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))))) 358 358 359 359 (('asgn) (let ((rhs (lookup-def 'rhs alst))) … … 849 849 (string->symbol (string-append (->string prefix) (number->string v))))) 850 850 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) 855 857 (let ((qs (reverse qs))) 856 858 (if top (let* ((top-syms ((nemo-core 'component-symbols ) sys (nemo-intern 'toplevel))) … … 895 897 (('const id '= expr) 896 898 (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) 899 901 (cons id qs))) 900 902 (else (nemo:error 'eval-nemo-system-decls … … 905 907 (('state-complex (id . alst) ) 906 908 (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 910 926 (if (not (or initial initial-eq)) 911 927 (nemo:error 'eval-nemo-system-decls 912 928 "state complex declarations require initial value or " 913 929 "initial equilibrium equations")) 930 914 931 (if (and initial-eq 915 932 (or (not (list? initial-eq)) (not (every lineq? initial-eq)))) … … 917 934 "initial equilibrium field in state complex declarations " 918 935 "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))) 922 941 (cons id qs)))) 942 923 943 (else (nemo:error 'eval-nemo-system-decls 924 944 "state complex declarations must be of the form: " … … 928 948 ((id '= expr) 929 949 (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)) 931 951 (cons id qs)) 932 952 (else (nemo:error 'eval-nemo-system-decls … … 937 957 (('defun id idlist expr) 938 958 (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)) 940 960 (cons id qs)) 941 961 (else (nemo:error 'eval-nemo-system-decls … … 945 965 ;; compiled primitives 946 966 (('prim id value) 947 (cond ((symbol? id) ( ((nemo-core 'env-extend!) sys)id '(prim) value))967 (cond ((symbol? id) (env-extend! id '(prim) value)) 948 968 (else (nemo:error 'eval-nemo-system-decls 949 969 "prim declarations must be of the form: " … … 1018 1038 1019 1039 (let ((name (or name (qname tag)))) 1020 ( ((nemo-core 'env-extend!) sys)name typ alst)1040 (env-extend! name typ alst) 1021 1041 (cons name qs))) 1022 1042 (nemo:error 'eval-nemo-system-decls "extended declarations must be of the form: " … … 1027 1047 (loop (cdr ds) qs1 top))) 1028 1048 )) 1029 sys) 1049 sys)) -
release/3/nemo/trunk/nemo.scm
r12181 r12185 60 60 `( 61 61 ,(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)") 63 63 (string->symbol arg)) 64 64 ,(args:make-option (xml) (optional: "FILE") … … 149 149 150 150 151 (define (nemo-constructor name declarations )151 (define (nemo-constructor name declarations parse-expr) 152 152 (let* ((nemo (make-nemo-core)) 153 153 (sys ((nemo 'system) name))) 154 (eval-nemo-system-decls nemo name sys declarations )154 (eval-nemo-system-decls nemo name sys declarations parse-expr) 155 155 (list sys nemo))) 156 156 157 (define (sexp->model options doc )157 (define (sexp->model options doc parse-expr) 158 158 (match doc 159 159 (('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)) 161 161 (model (first model+nemo)) 162 162 (nemo (second model+nemo))) … … 283 283 `(ncml:model (@ (name ,sysname)) ,@(component->ncml (nemo-intern 'toplevel)))))) 284 284 285 286 (include "expr-parser.scm") 285 287 286 288 (require-extension stx-engine) … … 540 542 (model-name (sxml:attr ncml:model 'name)) 541 543 (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)) 543 545 (model (first model+nemo)) 544 546 (nemo (second model+nemo))) … … 567 569 (lambda (x) 568 570 (case ($ x) 571 ((nemo) 'nemo) 569 572 ((s-exp sexp) 'sexp) 570 573 ((sxml) 'sxml) … … 578 581 (else 'xml))))) 579 582 (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)) 582 584 ((xml) (read-xml operand)) 583 585 (else (error 'nemo "unknown input format" in-format)))) 584 586 (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)) 587 590 (else (error 'nemo "unknown input format" in-format)))) 588 591 (sxml-fname ((lambda (x) (and x (if (and (cdr x) (string? (cdr x)))
Note: See TracChangeset
for help on using the changeset viewer.
