Changeset 11638 in project
- Timestamp:
- 08/14/08 06:20:31 (13 years ago)
- Location:
- release/3/oru
- Files:
-
- 2 edited
Legend:
- Unmodified
- Added
- Removed
-
release/3/oru/core.scm
r11412 r11638 198 198 ;; 2. fold expressions like (+ a b c d) into nested binops 199 199 (define (normalize-expr expr) 200 (define (normalize-bnd x) 201 `(,(first x) ,(normalize-expr (second x)))) 200 202 (match expr 203 (('let bs e) `(let ,(map normalize-bnd bs) ,(normalize-expr e))) 204 (('if c t e) `(if ,(normalize-expr c) ,(normalize-expr t) ,(normalize-expr e))) 201 205 (('+ . es) (binop-fold '+ (map normalize-expr es))) 202 206 (('- . es) (let ((es1 (map normalize-expr es))) … … 307 311 ))))) 308 312 309 (define (infer oru-env ftenv formalsbody)310 (let recur ((expr body) )313 (define (infer oru-env ftenv body) 314 (let recur ((expr body) (lb (list))) 311 315 (match expr 312 316 (('if c t e) 313 (let ((ct (recur c ))314 (tt (recur t ))315 (et (recur e )))317 (let ((ct (recur c lb)) 318 (tt (recur t lb)) 319 (et (recur e lb))) 316 320 (and ct tt et 317 321 (begin … … 321 325 (oru:error 'infer "type mismatch in if statement: then = " tt 322 326 " else = " et)))))) 327 (('let bs e) 328 (let* ((rlb (lambda (x) (recur x lb))) 329 (tbs (map rlb (map second bs))) 330 (lb1 (append (zip (map first bs) tbs) lb))) 331 (recur e lb1))) 323 332 324 333 ((s . es) … … 334 343 (environment-extend! ftenv x ft))) 335 344 es fms) 336 (let ((ets (map recur es))) 345 (let* ((rlb (lambda (x) (recur x lb))) 346 (ets (map rlb es))) 337 347 (and (every identity ets) 338 348 (every (lambda (xt ft) (equal? xt ft)) ets fms) 339 349 rt)))))))) 340 350 341 (id (cond ((symbol? id) ( environment-ref ftenv id))351 (id (cond ((symbol? id) (or (lookup-def id lb) (environment-ref ftenv id))) 342 352 ((number? id) fptype) 343 353 ((boolean? id) 'bool) … … 351 361 (sym (if (symbol? name) name (string->symbol name)))) 352 362 (letrec ((enumconsts 353 (lambda (expr ax) 354 (match expr 355 (('if . es) (fold enumconsts ax es)) 356 ((s . es) (if (symbol? s) (cons s (fold enumconsts ax es)) ax)) 357 (s (if (and (symbol? s) (environment-includes? const-env s)) 358 (cons s ax) ax)))))) 363 (lambda (lb) 364 (lambda (expr ax) 365 (match expr 366 (('let bs e) (let ((ec (enumconsts (append (map first bs) lb)))) 367 (ec e (fold ec ax (map second bs))))) 368 (('if . es) (fold (enumconsts lb) ax es)) 369 ((s . es) (if (symbol? s) (cons s (fold (enumconsts lb) ax es)) ax)) 370 (s (if (and (symbol? s) (not (member s lb)) 371 (environment-includes? const-env s)) 372 (cons s ax) ax))))))) 359 373 (if (environment-has-binding? oru-env sym) 360 374 (oru:error 'defun! ": quantity " sym " already defined") 361 375 (let* ((body (normalize-expr body)) 362 (consts (delete-duplicates ( enumconstsbody (list))))376 (consts (delete-duplicates ((enumconsts formals) body (list)))) 363 377 (fc `(lambda (const-env) 364 378 (let ,(map (lambda (v) `(,v (environment-ref const-env ',v))) consts) … … 367 381 368 382 (let* ((ftenv (make-environment)) 369 (rt (infer oru-env ftenv formalsbody))383 (rt (infer oru-env ftenv body)) 370 384 (ftypes (filter-map (lambda (x) (and (environment-includes? ftenv x) 371 385 (environment-ref ftenv x))) -
release/3/oru/nmodl.scm
r11603 r11638 516 516 (if perm (cons `(,perm ,i ,e ,erev) ax) ax))) 517 517 (list) ionchs) 518 (lambda (x y) (eq? (car x) (car y)))) 519 )) 518 (lambda (x y) (eq? (car x) (car y))))) 519 (acc-ions (delete-duplicates 520 (fold (lambda (n ax) 521 (let* ((subcomps ((dis 'component-subcomps) sys n)) 522 (acc (lookup-def 'accumulating-substance subcomps)) 523 (i (and acc (nmodl-name (s+ 'i acc)))) 524 (in (and acc (nmodl-name (s+ acc 'i)))) 525 (out (and acc (nmodl-name (s+ acc 'o))))) 526 (if acc (cons `(,acc ,i ,in ,out) ax) ax))) 527 (list) ionchs) 528 (lambda (x y) (eq? (car x) (car y))))) 529 ) 520 530 521 531 (with-output-to-file sfname … … 529 539 (USEION ,(first x) READ ,(third x) WRITE ,(second x)))) 530 540 perm-ions) 541 (for-each (lambda (x) 542 (pp indent+ (RANGE ,(second x)) 543 (USEION ,(first x) READ ,(third x) ", " ,(fourth x) WRITE ,(second x)))) 544 acc-ions) 545 531 546 (pp indent "}") 532 547 … … 562 577 imports) 563 578 (for-each (lambda (x) (pp indent+ ,(second x) ,(third x))) perm-ions) 579 (for-each (lambda (x) (pp indent+ ,(second x) ,(third x) ,(fourth x))) acc-ions) 564 580 (pp indent "}") 565 581 … … 592 608 (lambda (n) 593 609 (let* ((subcomps ((dis 'component-subcomps) sys n)) 610 (acc (lookup-def 'accumulating-substance subcomps)) 594 611 (perm (lookup-def 'permeating-substance subcomps)) 595 612 (pore (lookup-def 'pore subcomps)) 596 613 (gate (lookup-def 'gate subcomps)) 597 614 (sts (and gate ((dis 'component-exports) sys gate)))) 598 (and perm pore gate 599 (let* ((i (nmodl-name (s+ 'i perm))) 600 (e (nmodl-name (s+ 'e perm))) 601 (gmax (car ((dis 'component-exports) sys pore))) 602 (pwrs (map (lambda (n) (state-power sys n)) sts)) 603 (gion `(* ,gmax . ,(map (lambda (st pwr) `(pow ,st ,pwr)) sts pwrs)))) 604 (list i e gion))))) 615 (cond ((and perm pore gate) 616 (let* ((i (nmodl-name (s+ 'i perm))) 617 (e (nmodl-name (s+ 'e perm))) 618 (gmax (car ((dis 'component-exports) sys pore))) 619 (pwrs (map (lambda (n) (state-power sys n)) sts)) 620 (gion `(* ,gmax . ,(map (lambda (st pwr) `(pow ,st ,pwr)) sts pwrs)))) 621 (list i e gion))) 622 ((and acc pore gate) 623 (let* ((i (nmodl-name (s+ 'i acc))) 624 (gmax (car ((dis 'component-exports) sys pore))) 625 (pwrs (map (lambda (n) (state-power sys n)) sts)) 626 (gion `(* ,gmax . ,(map (lambda (st pwr) `(pow ,st ,pwr)) sts pwrs)))) 627 (list i #f gion))) 628 (else (oru:error 'oru:nmodl-translator ": invalid ion channel definition " n)) 629 ))) 605 630 ionchs)) 606 631 (i-bkts (bucket-partition (lambda (x y) (eq? (car x) (car y))) i-eqs)) … … 608 633 (match b 609 634 ((and ps ((i e gion) . rst)) 610 (let* ((sum `(* ,(sum (map third ps)) (- v ,e))) 635 (let* ((sum (if e `(* ,(sum (map third ps)) (- v ,e)) 636 (sum (map third ps)))) 611 637 (sum0 (rhsexpr sum)) 612 638 (sum1 (canonicalize-expr/NMODL sum0))) … … 614 640 615 641 ((i e gion) 616 (let* ((expr0 (rhsexpr `(* ,gion (- v ,e))))642 (let* ((expr0 (rhsexpr (if e `(* ,gion (- v ,e)) gion))) 617 643 (expr1 (canonicalize-expr/NMODL expr0))) 618 644 (cons (list i expr1) ax)))
Note: See TracChangeset
for help on using the changeset viewer.