Changeset 12556 in project


Ignore:
Timestamp:
11/19/08 01:19:43 (13 years ago)
Author:
Ivan Raikov
Message:

Some functionality factored out in library nemo-utils.

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

Legend:

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

    r12554 r12556  
    2323(require-extension strictly-pretty)
    2424(require-extension environments)
    25 (require-extension nemo-core)
    2625(require-extension srfi-1)
    27 (require-extension srfi-4)
    2826(require-extension srfi-13)
    29 (require-extension srfi-14)
    3027(require-extension utils)
    3128(require-extension lolevel)
     
    3431(require-extension datatype)
    3532
     33(require-extension nemo-core)
     34(require-extension nemo-utils)
     35
    3636(define-extension nemo-matlab)
    3737
     
    4040 (export  nemo:matlab-translator))
    4141
    42 (register-feature! 'nemo-matlab)
    43 
    44 (define (lookup-def k lst . rest)
    45   (let-optionals rest ((default #f))
    46       (let ((kv (assoc k lst)))
    47         (if (not kv) default
    48             (match kv ((k v) v) (else (cdr kv)))))))
    4942
    5043(define (matlab-name s)
     
    5649                           (else #\_))))
    5750            (loop (cons c1 lst) (cdr cs)))))))
    58                            
    59                  
    60 
    61 (define (matlab-state-name n s)
    62   (matlab-name (s+ n s)))
    63 
    64 (define (enum-bnds expr ax)
    65   (match expr
    66          (('if . es)        (fold enum-bnds ax es))
    67          (('let bnds body)  (enum-bnds body (append (map car bnds) (fold enum-bnds ax (map cadr bnds)))))
    68          ((s . es)          (if (symbol? s)  (fold enum-bnds ax es) ax))
    69          (else ax)))
    70 
    71 
    72 (define (enum-freevars expr bnds ax)
    73   (match expr
    74          (('if . es) 
    75           (fold (lambda (x ax) (enum-freevars x bnds ax)) ax es))
    76          (('let bnds body) 
    77           (let ((bnds1 (append (map first bnds) bnds)))
    78             (enum-freevars body bnds1 (fold (lambda (x ax) (enum-freevars x bnds ax)) ax (map second bnds)))))
    79          ((s . es)    (if (symbol? s)  (fold (lambda (x ax) (enum-freevars x bnds ax)) ax es) ax))
    80          (id          (if (and (symbol? id) (not (member id bnds)))  (cons id ax) ax))))
    81 
     51               
    8252(define (rhsvars rhs)
    8353  (enum-freevars rhs (list) (list)))
    84 
    85 (define (rhsexpr expr)
     54           
     55(define (rhsexpr/MATLAB expr)
    8656  (match expr
    87          (('if . es)  `(if . ,(map (lambda (x) (rhsexpr x)) es)))
     57         (('if . es)  `(if . ,(map (lambda (x) (rhsexpr/MATLAB x)) es)))
    8858         (('pow x y)  (if (and (integer? y)  (positive? y))
    8959                          (if (> y 1)  (let ((tmp (gensym "x")))
     
    9161                              x)
    9262                            expr))
    93          ((s . es)    (if (symbol? s)  (cons s (map (lambda (x) (rhsexpr x)) es)) expr))
     63         ((s . es)    (if (symbol? s)  (cons s (map (lambda (x) (rhsexpr/MATLAB x)) es)) expr))
    9464         (id          (if (symbol? id) (matlab-name id) id))))
    9565
    96 
    97 ;;; Procedures for string concatenation and pretty-printing
    98 
    99 (define (s+ . lst)    (string-concatenate (map ->string lst)))
    100 (define (sw+ lst)     (string-intersperse (filter-map (lambda (x) (and x (->string x))) lst) " "))
    101 (define (sl\ p lst)   (string-intersperse (map ->string lst) p))
    102 (define nl "\n")
    103 
    104 (define (spaces n)  (list->string (list-tabulate n (lambda (x) #\space))))
    105 
    106 (define (ppf indent . lst)
    107   (let ((sp (spaces indent)))
    108     (for-each (lambda (x)
    109                 (and x (match x
    110                               ((i . x1) (if (and (number? i) (positive? i))
    111                                             (for-each (lambda (x) (ppf (+ indent i) x)) x1)
    112                                             (print sp (sw+ x))))
    113                               (else   (print sp (if (list? x) (sw+ x) x))))))
    114               lst)))
    115 
     66(define (matlab-state-name n s)
     67  (matlab-name (s+ n s)))
    11668
    11769(define-syntax pp
     
    169121      fpvector-ref))
    170122
    171 (define (sum lst)
    172   (if (null? lst) lst
    173       (match lst
    174              ((x)   x)
    175              ((x y) `(+ ,x ,y))
    176              ((x y . rest) `(+ (+ ,x ,y) ,(sum rest)))
    177              ((x . rest) `(+ ,x ,(sum rest))))))
    178 
    179 
    180 (define (subst-term t subst k)
    181   (match t
    182          (('if c t e)
    183           `(if ,(k c subst) ,(k t subst) ,(k e subst)))
    184          (('let bs e)
    185           (k `(let ,(map (lambda (b) `(,(car b) ,(k (cadr b) subst))) bs) ,(k e subst)) subst))
    186          ((f . es)
    187           (cons (k f subst) (map (lambda (e) (k e subst)) es)))
    188          ((? symbol? )  (lookup-def t subst t))
    189          ((? atom? ) t)))
    190 
    191 (define (binding? t) (and (list? t) (eq? 'let (car t)) (cdr t)))
    192 
    193 (define (bind ks vs e) `(let ,(zip ks vs) ,e))
    194 
    195123(define (name-normalize expr)
    196124  (match expr
     
    203131         ((? atom? ) expr)))
    204132
    205 (define (if-convert expr)
    206   (match expr
    207          (('if c t e)
    208           (let ((r (gensym "if")))
    209             `(let ((,r (if ,(if-convert c) ,(if-convert t) ,(if-convert e)))) 
    210                ,r)))
    211          (('let bs e)
    212           `(let ,(map (lambda (b) `(,(car b) ,(if-convert (cadr b)))) bs) ,(if-convert e)))
    213          ((f . es)
    214           (cons f (map if-convert es)))
    215          ((? atom? ) expr)))
    216 
    217          
    218 (define (let-enum expr ax)
    219   (match expr
    220          (('let ((x ('if c t e))) y)
    221           (let ((ax (fold let-enum ax (list c ))))
    222             (if (eq? x y)  (append ax (list (list x `(if ,c ,t ,e)))) ax)))
    223 
    224          (('let bnds body)  (let-enum body (append ax bnds)))
    225 
    226          (('if c t e)  (let-enum ax c))
    227 
    228          ((f . es)  (fold let-enum ax es))
    229 
    230          (else ax)))
    231 
    232 
    233 (define (let-elim expr)
    234   (match expr
    235          (('let ((x ('if c t e))) y)
    236           (if (eq? x y)  y expr))
    237 
    238          (('let bnds body) (let-elim body))
    239 
    240          (('if c t e)  `(if ,(let-elim c) ,(let-lift t) ,(let-lift e)))
    241 
    242          ((f . es)  `(,f . ,(map let-elim es)))
    243 
    244          (else expr)))
    245  
    246 
    247 (define (let-lift expr)
    248   (let ((bnds (let-enum expr (list))))
    249     (if (null? bnds) expr
    250         `(let ,(map (lambda (b) (list (car b) (let-elim (cadr b)))) bnds) ,(let-elim expr)))))
    251133
    252134(define (canonicalize-expr/MATLAB expr)
     
    330212                   fe)))))))
    331213               
    332 
    333214         
    334215(define (expr->string/MATLAB x . rest)
     
    346227            (body     (lookup-def 'body lst)))
    347228        (pp indent ,nl (function ,retval = ,n (,(sl\ ", " vars)) ))
    348         (let* ((body1 (canonicalize-expr/MATLAB (rhsexpr body)))
     229        (let* ((body1 (canonicalize-expr/MATLAB (rhsexpr/MATLAB body)))
    349230               (lbs   (enum-bnds body1 (list))))
    350231          (pp indent+ ,(expr->string/MATLAB body1 retval))
    351232          (pp indent endfunction))
    352233          ))))
     234
    353235
    354236(define (define-state indent n)
     
    420302                                                      ((and (null? out) (not (null? in)))
    421303                                                       (sum (map third in)))))
    422                                          (fbody  (rhsexpr rhs1))
     304                                         (fbody  (rhsexpr/MATLAB rhs1))
    423305                                         (fbody1 (canonicalize-expr/MATLAB fbody)))
    424306                                    (cons (list name  fbody1) ax)))))
     
    430312
    431313(define (state-init n init)
    432   (let* ((init  (rhsexpr init))
     314  (let* ((init  (rhsexpr/MATLAB init))
    433315         (init1 (canonicalize-expr/MATLAB init)))
    434316    (list (matlab-name n) init1)))
     
    437319
    438320(define (asgn-eq n rhs)
    439   (let* ((fbody   (rhsexpr rhs))
     321  (let* ((fbody   (rhsexpr/MATLAB rhs))
    440322         (fbody1  (canonicalize-expr/MATLAB fbody)))
    441323    (list (matlab-name n) fbody1)))
     
    737619                                                                        ps))
    738620                                                            (sum (map third ps))))
    739                                                  (sum0  (rhsexpr sum))
     621                                                 (sum0  (rhsexpr/MATLAB sum))
    740622                                                 (sum1  (canonicalize-expr/MATLAB sum0)))
    741623                                            (cons (list i sum1) ax)))
    742624                                           
    743625                                         ((i e gion)
    744                                           (let* ((expr0  (rhsexpr (if e `(* ,gion (- v ,e)) gion)))
     626                                          (let* ((expr0  (rhsexpr/MATLAB (if e `(* ,gion (- v ,e)) gion)))
    745627                                                 (expr1  (canonicalize-expr/MATLAB expr0)))
    746628                                              (cons (list i expr1) ax)))
  • release/3/nemo/trunk/nemo-nmodl.scm

    r12469 r12556  
    2323(require-extension strictly-pretty)
    2424(require-extension environments)
    25 (require-extension nemo-core)
    2625(require-extension srfi-1)
    27 (require-extension srfi-4)
    2826(require-extension srfi-13)
    29 (require-extension srfi-14)
    3027(require-extension utils)
    3128(require-extension lolevel)
     
    3431(require-extension datatype)
    3532
     33(require-extension nemo-core)
     34(require-extension nemo-utils)
     35
    3636(define-extension nemo-nmodl)
    3737
     
    4040 (export  nemo:nmodl-translator))
    4141
    42 (register-feature! 'nemo-nmodl)
    43 
    44 (define (lookup-def k lst . rest)
    45   (let-optionals rest ((default #f))
    46       (let ((kv (assoc k lst)))
    47         (if (not kv) default
    48             (match kv ((k v) v) (else (cdr kv)))))))
    4942
    5043(define (nmodl-name s)
     
    5750            (loop (cons c1 lst) (cdr cs)))))))
    5851                           
    59                  
    6052
    6153(define (nmodl-state-name n s)
    6254  (nmodl-name (s+ n s)))
    63 
    64 (define (enum-bnds expr ax)
    65   (match expr
    66          (('if . es)        (fold enum-bnds ax es))
    67          (('let bnds body)  (enum-bnds body (append (map car bnds) (fold enum-bnds ax (map cadr bnds)))))
    68          ((s . es)          (if (symbol? s)  (fold enum-bnds ax es) ax))
    69          (else ax)))
    70 
    71 
    72 (define (enum-freevars expr bnds ax)
    73   (match expr
    74          (('if . es) 
    75           (fold (lambda (x ax) (enum-freevars x bnds ax)) ax es))
    76          (('let bnds body) 
    77           (let ((bnds1 (append (map first bnds) bnds)))
    78             (enum-freevars body bnds1 (fold (lambda (x ax) (enum-freevars x bnds ax)) ax (map second bnds)))))
    79          ((s . es)    (if (symbol? s)  (fold (lambda (x ax) (enum-freevars x bnds ax)) ax es) ax))
    80          (id          (if (and (symbol? id) (not (member id bnds)))  (cons id ax) ax))))
    8155
    8256(define (rhsvars rhs)
     
    9367         ((s . es)    (if (symbol? s)  (cons s (map (lambda (x) (rhsexpr x)) es)) expr))
    9468         (id          (if (symbol? id) (nmodl-name id) id))))
    95 
    96 
    97 ;;; Procedures for string concatenation and pretty-printing
    98 
    99 (define (s+ . lst)    (string-concatenate (map ->string lst)))
    100 (define (sw+ lst)     (string-intersperse (filter-map (lambda (x) (and x (->string x))) lst) " "))
    101 (define (sl\ p lst)   (string-intersperse (map ->string lst) p))
    102 (define nl "\n")
    103 
    104 (define (spaces n)  (list->string (list-tabulate n (lambda (x) #\space))))
    105 
    106 (define (ppf indent . lst)
    107   (let ((sp (spaces indent)))
    108     (for-each (lambda (x)
    109                 (and x (match x
    110                               ((i . x1) (if (and (number? i) (positive? i))
    111                                             (for-each (lambda (x) (ppf (+ indent i) x)) x1)
    112                                             (print sp (sw+ x))))
    113                               (else   (print sp (if (list? x) (sw+ x) x))))))
    114               lst)))
    11569
    11670
     
    177131      fpvector-ref))
    178132
    179 (define (sum lst)
    180   (if (null? lst) lst
    181       (match lst
    182              ((x)   x)
    183              ((x y) `(+ ,x ,y))
    184              ((x y . rest) `(+ (+ ,x ,y) ,(sum rest)))
    185              ((x . rest) `(+ ,x ,(sum rest))))))
    186 
    187 
    188 (define (subst-term t subst k)
    189   (match t
    190          (('if c t e)
    191           `(if ,(k c subst) ,(k t subst) ,(k e subst)))
    192          (('let bs e)
    193           (k `(let ,(map (lambda (b) `(,(car b) ,(k (cadr b) subst))) bs) ,(k e subst)) subst))
    194          ((f . es)
    195           (cons (k f subst) (map (lambda (e) (k e subst)) es)))
    196          ((? symbol? )  (lookup-def t subst t))
    197          ((? atom? ) t)))
    198 
    199 (define (binding? t) (and (list? t) (eq? 'let (car t)) (cdr t)))
    200 
    201 (define (bind ks vs e) `(let ,(zip ks vs) ,e))
    202 
    203133(define (name-normalize expr)
    204134  (match expr
     
    211141         ((? atom? ) expr)))
    212142
    213 (define (if-convert expr)
    214   (match expr
    215          (('if c t e)
    216           (let ((r (gensym "if")))
    217             `(let ((,r (if ,(if-convert c) ,(if-convert t) ,(if-convert e)))) 
    218                ,r)))
    219          (('let bs e)
    220           `(let ,(map (lambda (b) `(,(car b) ,(if-convert (cadr b)))) bs) ,(if-convert e)))
    221          ((f . es)
    222           (cons f (map if-convert es)))
    223          ((? atom? ) expr)))
    224 
    225          
    226 (define (let-enum expr ax)
    227   (match expr
    228          (('let ((x ('if c t e))) y)
    229           (let ((ax (fold let-enum ax (list c ))))
    230             (if (eq? x y)  (append ax (list (list x `(if ,c ,t ,e)))) ax)))
    231 
    232          (('let bnds body)  (let-enum body (append ax bnds)))
    233 
    234          (('if c t e)  (let-enum ax c))
    235 
    236          ((f . es)  (fold let-enum ax es))
    237 
    238          (else ax)))
    239 
    240 
    241 (define (let-elim expr)
    242   (match expr
    243          (('let ((x ('if c t e))) y)
    244           (if (eq? x y)  y expr))
    245 
    246          (('let bnds body) (let-elim body))
    247 
    248          (('if c t e)  `(if ,(let-elim c) ,(let-lift t) ,(let-lift e)))
    249 
    250          ((f . es)  `(,f . ,(map let-elim es)))
    251 
    252          (else expr)))
    253  
    254 
    255 (define (let-lift expr)
    256   (let ((bnds (let-enum expr (list))))
    257     (if (null? bnds) expr
    258         `(let ,(map (lambda (b) (list (car b) (let-elim (cadr b)))) bnds) ,(let-elim expr)))))
    259143
    260144(define (canonicalize-expr/NMODL expr)
  • release/3/nemo/trunk/nemo-utils.scm

    r12555 r12556  
    2222(require-extension matchable)
    2323(require-extension strictly-pretty)
    24 (require-extension environments)
    2524(require-extension nemo-core)
    2625(require-extension srfi-1)
    27 (require-extension srfi-4)
    2826(require-extension srfi-13)
    29 (require-extension srfi-14)
    30 (require-extension utils)
    31 (require-extension lolevel)
    3227(require-extension varsubst)
    33 (require-extension digraph)
    34 (require-extension datatype)
    3528
    3629(define-extension nemo-utils)
    3730
     31
     32
    3833(declare
    3934 (lambda-lift)
    40  (export  enum-bnds enum-freevars sum subst-term
     35 (export  lookup-def binding? bind
     36          enum-bnds enum-freevars sum subst-term
    4137          if-convert let-enum let-elim let-lift
    4238          s+ sw+ sl\ nl spaces ppf
    4339          ))
     40
     41(define (lookup-def k lst . rest)
     42  (let-optionals rest ((default #f))
     43      (let ((kv (assoc k lst)))
     44        (if (not kv) default
     45            (match kv ((k v) v) (else (cdr kv)))))))
    4446
    4547
  • release/3/nemo/trunk/nemo.meta

    r12243 r12556  
    55 ; List here all the files that should be bundled as part of your egg. 
    66
    7  (files "nemo-core.scm" "nemo-macros.scm" "nemo-nmodl.scm"
     7 (files "nemo-core.scm" "nemo-utils.scm" "nemo-macros.scm" "nemo-nmodl.scm"
    88        "expr.grm" "expr-parser.scm" "nemo.scm" "extensions"
    99        "SSAX.scm" "stx-macros.scm" "SXML.scm" "SXML-to-XML.scm"
  • release/3/nemo/trunk/nemo.setup

    r12471 r12556  
    2323
    2424  ; Assoc list with properties for your extension:
    25   `((version 1.15)
     25  `((version 1.16)
    2626    ;(documentation "nemo.html")
    2727    ,@(if has-exports? `((exports "nemo-core.exports")) (list)) ))
     28
     29(compile -O -d2 -s -o ,(dynld-name "nemo-utils")
     30         ,@(if has-exports? '(-check-imports -emit-exports nemo-utils.exports) '())
     31         nemo-utils.scm)
     32
     33
     34(install-extension
     35
     36  ; Name of your extension:
     37  'nemo-utils
     38
     39  ; Files to install for your extension:
     40  `(,(dynld-name "nemo-utils")
     41    ,@(if has-exports? '("nemo-utils.exports") (list)) )
     42
     43  ; Assoc list with properties for your extension:
     44  `((version 1.16)
     45    ;(documentation "nemo.html")
     46    ,@(if has-exports? `((exports "nemo-utils.exports")) (list)) ))
    2847
    2948
     
    3150 'nemo-macros
    3251 `("nemo-macros.scm" )
    33  `((version 1.15)
     52 `((version 1.16)
    3453   (syntax)
    3554   (require-at-runtime nemo-core)))
     
    5069
    5170  ; Assoc list with properties for your extension:
    52   `((version 1.15)
     71  `((version 1.16)
    5372    ,@(if has-exports? `((exports "nemo-nmodl.exports")) (list)) ))
    5473
     
    6988     
    7089     ;; Assoc list with properties for your extension:
    71      `((version 1.15)
     90     `((version 1.16)
    7291       ,@(if has-exports? `((exports "nemo-matlab.exports")) (list)) )))
    7392
     
    88107
    89108  ; Assoc list with properties for your extension:
    90   `((version 1.15)
     109  `((version 1.16)
    91110    ,@(if has-exports? `((exports "nemo-hh.exports")) (list)) ))
    92111
     
    102121
    103122  ; Assoc list with properties for the program:
    104   '((version 1.15)
     123  '((version 1.16)
    105124    (documentation "nemo.html")))
    106125
Note: See TracChangeset for help on using the changeset viewer.