Changeset 11638 in project
 Timestamp:
 08/14/08 06:20:31 (12 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 (normalizeexpr expr) 200 (define (normalizebnd x) 201 `(,(first x) ,(normalizeexpr (second x)))) 200 202 (match expr 203 (('let bs e) `(let ,(map normalizebnd bs) ,(normalizeexpr e))) 204 (('if c t e) `(if ,(normalizeexpr c) ,(normalizeexpr t) ,(normalizeexpr e))) 201 205 (('+ . es) (binopfold '+ (map normalizeexpr es))) 202 206 ((' . es) (let ((es1 (map normalizeexpr es))) … … 307 311 ))))) 308 312 309 (define (infer oruenv ftenv formalsbody)310 (let recur ((expr body) )313 (define (infer oruenv 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 (environmentextend! 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) ( environmentref ftenv id))351 (id (cond ((symbol? id) (or (lookupdef id lb) (environmentref 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) (environmentincludes? constenv 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 (environmentincludes? constenv s)) 372 (cons s ax) ax))))))) 359 373 (if (environmenthasbinding? oruenv sym) 360 374 (oru:error 'defun! ": quantity " sym " already defined") 361 375 (let* ((body (normalizeexpr body)) 362 (consts (deleteduplicates ( enumconstsbody (list))))376 (consts (deleteduplicates ((enumconsts formals) body (list)))) 363 377 (fc `(lambda (constenv) 364 378 (let ,(map (lambda (v) `(,v (environmentref constenv ',v))) consts) … … 367 381 368 382 (let* ((ftenv (makeenvironment)) 369 (rt (infer oruenv ftenv formalsbody))383 (rt (infer oruenv ftenv body)) 370 384 (ftypes (filtermap (lambda (x) (and (environmentincludes? ftenv x) 371 385 (environmentref 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 (accions (deleteduplicates 520 (fold (lambda (n ax) 521 (let* ((subcomps ((dis 'componentsubcomps) sys n)) 522 (acc (lookupdef 'accumulatingsubstance subcomps)) 523 (i (and acc (nmodlname (s+ 'i acc)))) 524 (in (and acc (nmodlname (s+ acc 'i)))) 525 (out (and acc (nmodlname (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 (withoutputtofile sfname … … 529 539 (USEION ,(first x) READ ,(third x) WRITE ,(second x)))) 530 540 permions) 541 (foreach (lambda (x) 542 (pp indent+ (RANGE ,(second x)) 543 (USEION ,(first x) READ ,(third x) ", " ,(fourth x) WRITE ,(second x)))) 544 accions) 545 531 546 (pp indent "}") 532 547 … … 562 577 imports) 563 578 (foreach (lambda (x) (pp indent+ ,(second x) ,(third x))) permions) 579 (foreach (lambda (x) (pp indent+ ,(second x) ,(third x) ,(fourth x))) accions) 564 580 (pp indent "}") 565 581 … … 592 608 (lambda (n) 593 609 (let* ((subcomps ((dis 'componentsubcomps) sys n)) 610 (acc (lookupdef 'accumulatingsubstance subcomps)) 594 611 (perm (lookupdef 'permeatingsubstance subcomps)) 595 612 (pore (lookupdef 'pore subcomps)) 596 613 (gate (lookupdef 'gate subcomps)) 597 614 (sts (and gate ((dis 'componentexports) sys gate)))) 598 (and perm pore gate 599 (let* ((i (nmodlname (s+ 'i perm))) 600 (e (nmodlname (s+ 'e perm))) 601 (gmax (car ((dis 'componentexports) sys pore))) 602 (pwrs (map (lambda (n) (statepower 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 (nmodlname (s+ 'i perm))) 617 (e (nmodlname (s+ 'e perm))) 618 (gmax (car ((dis 'componentexports) sys pore))) 619 (pwrs (map (lambda (n) (statepower 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 (nmodlname (s+ 'i acc))) 624 (gmax (car ((dis 'componentexports) sys pore))) 625 (pwrs (map (lambda (n) (statepower 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:nmodltranslator ": invalid ion channel definition " n)) 629 ))) 605 630 ionchs)) 606 631 (ibkts (bucketpartition (lambda (x y) (eq? (car x) (car y))) ieqs)) … … 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 (canonicalizeexpr/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 (canonicalizeexpr/NMODL expr0))) 618 644 (cons (list i expr1) ax)))
Note: See TracChangeset
for help on using the changeset viewer.