Changeset 11638 in project


Ignore:
Timestamp:
08/14/08 06:20:31 (13 years ago)
Author:
Ivan Raikov
Message:

Some bugs fixed in processing defun declarations.

Location:
release/3/oru
Files:
2 edited

Legend:

Unmodified
Added
Removed

  • release/3/oru/core.scm

    r11412 r11638  
    198198  ;; 2. fold expressions like (+ a b c d) into nested binops
    199199  (define (normalize-expr expr)
     200    (define (normalize-bnd x)
     201      `(,(first x) ,(normalize-expr (second x))))
    200202    (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)))
    201205           (('+ . es)           (binop-fold '+ (map normalize-expr es)))
    202206           (('- . es)           (let ((es1 (map normalize-expr es)))
    … …  
    307311              )))))
    308312
    309   (define (infer oru-env ftenv formals body)
    310     (let recur ((expr body))
     313  (define (infer oru-env ftenv body)
     314    (let recur ((expr body) (lb (list)))
    311315      (match expr
    312316             (('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)))
    316320                (and ct tt et
    317321                     (begin
    … …  
    321325                           (oru:error 'infer "type mismatch in if statement: then = " tt
    322326                                      " 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)))
    323332             
    324333             ((s . es)   
    … …  
    334343                                              (environment-extend! ftenv x ft)))
    335344                                        es fms)
    336                               (let ((ets (map recur es)))
     345                              (let* ((rlb (lambda (x) (recur x lb)))
     346                                     (ets (map rlb es)))
    337347                                (and (every identity ets)
    338348                                     (every (lambda (xt ft) (equal? xt ft)) ets fms)
    339349                                     rt))))))))
    340350             
    341              (id    (cond ((symbol? id)     (environment-ref ftenv id))
     351             (id    (cond ((symbol? id)     (or (lookup-def id lb) (environment-ref ftenv id)))
    342352                          ((number? id)     fptype)
    343353                          ((boolean? id)    'bool)
    … …  
    351361              (sym (if (symbol? name) name (string->symbol name))))
    352362          (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)))))))
    359373            (if (environment-has-binding? oru-env sym)
    360374                (oru:error 'defun! ": quantity " sym " already defined")
    361375                (let* ((body    (normalize-expr body))
    362                        (consts  (delete-duplicates (enumconsts body (list))))
     376                       (consts  (delete-duplicates ((enumconsts formals) body (list))))
    363377                       (fc     `(lambda (const-env)
    364378                                  (let ,(map (lambda (v) `(,v (environment-ref const-env ',v))) consts)
    … …  
    367381                 
    368382                  (let* ((ftenv  (make-environment))
    369                          (rt     (infer oru-env ftenv formals body))
     383                         (rt     (infer oru-env ftenv body))
    370384                         (ftypes (filter-map (lambda (x) (and (environment-includes? ftenv x)
    371385                                                              (environment-ref ftenv x)))

  • release/3/oru/nmodl.scm

    r11603 r11638  
    516516                                    (if perm  (cons `(,perm ,i ,e ,erev) ax) ax)))
    517517                                (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               )
    520530               
    521531           (with-output-to-file sfname
    … …  
    529539                               (USEION ,(first x) READ ,(third x) WRITE ,(second x))))
    530540                         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               
    531546               (pp indent "}")
    532547
    … …  
    562577                         imports)
    563578               (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)
    564580               (pp indent "}")
    565581
    … …  
    592608                              (lambda (n)
    593609                                (let* ((subcomps ((dis 'component-subcomps) sys n))
     610                                       (acc   (lookup-def 'accumulating-substance subcomps))
    594611                                       (perm  (lookup-def 'permeating-substance subcomps))
    595612                                       (pore  (lookup-def 'pore subcomps))
    596613                                       (gate  (lookup-def 'gate subcomps))
    597614                                       (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                                        )))
    605630                                 ionchs))
    606631                      (i-bkts (bucket-partition (lambda (x y) (eq? (car x) (car y))) i-eqs))
    … …  
    608633                                      (match b
    609634                                             ((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))))
    611637                                                     (sum0  (rhsexpr sum))
    612638                                                     (sum1  (canonicalize-expr/NMODL sum0)))
    … …  
    614640
    615641                                             ((i e gion)
    616                                               (let* ((expr0  (rhsexpr `(* ,gion (- v ,e))))
     642                                              (let* ((expr0  (rhsexpr (if e `(* ,gion (- v ,e)) gion)))
    617643                                                     (expr1  (canonicalize-expr/NMODL expr0)))
    618644                                                (cons (list i expr1) ax)))
Note: See TracChangeset for help on using the changeset viewer.