Changeset 27283 in project


Ignore:
Timestamp:
08/22/12 03:02:19 (9 years ago)
Author:
Ivan Raikov
Message:

9ML-toolkit: extensions to evaluator for closures

Location:
release/4/9ML-toolkit/trunk
Files:
4 edited

Legend:

Unmodified
Added
Removed

  • release/4/9ML-toolkit/trunk/NineML.grm

    r25756 r27283  
    4444          (left:  LG LESS LEQ GREATER GEQ EQEQ EQUAL)
    4545          (left:  PLUS MINUS STAR SLASH)
    46           (right: TYPE VALUE ARROW MODULE FUNCTOR)
     46          (right: TYPE VALUE ARROW DARROW MODULE FUNCTOR)
    4747          (right: LPAREN SEMICOLON COLON QUOTE))
    4848
    … …  
    7474    (valexpr GREATER valexpr)              : (binop ">" $1 $3 )
    7575    (valexpr GEQ valexpr)                  : (binop ">=" $1 $3 )
    76     (FUNCTION IDENT ARROW valexpr)         : (Function $2 $4)
     76    (FUNCTION IDENT DARROW valexpr)         : (Function $2 $4)
    7777    (LET IDENT valbind IN valexpr)         : (Let0 $2 $3 $5)
    7878    (RETURN valexpr)                       : $2

  • release/4/9ML-toolkit/trunk/NineML.l

    r25756 r27283  
    119119";"                                (tok yyline SEMICOLON)
    120120"->"                               (tok yyline ARROW)
     121"=>"                               (tok yyline DARROW)
    121122"="                                (tok yyline EQUAL)
    122123","                                (tok yyline COMMA)

  • release/4/9ML-toolkit/trunk/eval.scm

    r27270 r27283  
    8383  (let recur ((p p) (ax '()))
    8484    (case (car p)
     85      ((path) (recur (cadr p) ax))
    8586      ((Pident)
    86        (let ((id (cadr p)))
     87       (let ((id (sxml:text (cdr p))))
    8788         (let ((ax1 (cons id ax)))
    88            (string-concatenate (intersperse  (reverse ax1) "."))
     89           (string->symbol (string-concatenate (intersperse  ax1 ".")))
    8990           )))
    9091      ((Pdot)
    9192       (let ((name (sxml:attr p 'name)))
    92          (recur (sxml:kid p) (cons name ax))))
     93         (recur (sxml:kid p) (cons (sxml:text name) ax))))
    9394      (else (error 'sxml-path->symbol "invalid path" p))
    9495      )))
    9596   
    9697
     98   
     99
     100
    97101(define (sxml-term->sexpr term)
     102  (print "term = " term)
    98103  (let ((tree
    99104         (sxml:pre-post-order*
    100105          term
    101106          `(
    102             (Const . ,(lambda (tag elems)  (car elems)))
    103             (Longid . ,(lambda (tag elems) (sxml-path->symbol (car elems))))
    104             (Function *macro* . ,(lambda (tag elems)
    105                                    (let ((formal (string->symbol (sxml:attr term 'formal))))
    106                                      `(lambda (,formal) ,elems))))
    107             (Apply *macro* . ,(lambda (tag elems) elems))
    108             (Let0 *macro* . ,(lambda (tag elems)
    109                                (let ((name (sxml:attr term 'name))
    110                                      (value (sxml:kidn-cadr 'value term))
    111                                      (body (sxml:kidn-cadr 'body term)))
    112                                  `(let ((,name ,value))
    113                                     ,body))))
     107            (Const
     108             (
     109              (label *preorder* . ,(lambda (tag elems) (string->symbol (sxml:text elems))))
     110             
     111              (string *preorder* . ,(lambda (tag elems) (sxml:text elems)))
     112             
     113              (real *preorder* . ,(lambda (tag elems) (string->number (sxml:text elems))))
     114             
     115              (nat  *preorder* . ,(lambda (tag elems) (string->number (sxml:text elems))))
     116             
     117              (bool *preorder* . ,(lambda (tag elems) (if (string=? (sxml:text elems) "true") #t #f)))
     118             
     119              (null *preorder* . ,(lambda (tag elems) '()))
     120             
     121              (*text* . ,(lambda (trigger str) str))
     122             
     123              (*default* . ,(lambda (tag elems) (cons tag elems)))
     124              )
     125             
     126             . ,(lambda (tag elems)  (car elems)))
     127
     128            (Longid *preorder* . ,(lambda (tag elems) (sxml-path->symbol (car elems))))
     129            (Function *preorder* . ,(lambda (tag elems)
     130                                      (let ((formal (string->symbol (sxml:attr (cons tag elems) 'formal)))
     131                                            (body (sxml:kid elems)))
     132                                        (print "Function body = " body)
     133                                        (print "Function formal = " formal)
     134                                        `(lambda (,formal) ,(sxml-term->sexpr body)))))
     135            (Let0 *preorder* . ,(lambda (tag elems)
     136                                  (let ((name (string->symbol (sxml:attr (cons tag elems) 'name)))
     137                                        (value (sxml:kidn-cadr 'value (cons tag elems)))
     138                                        (body (sxml:kidn-cadr 'body (cons tag elems))))
     139                                    `(let ((,name ,(sxml-term->sexpr value)))
     140                                       ,(sxml-term->sexpr body)))))
     141            (Apply *macro* . ,(lambda (tag elems)
     142                                (let ((left (sxml:kidn-cadr 'left (cons tag elems)))
     143                                      (right (sxml:kidn-cadr 'right (cons tag elems))))
     144                                  `(,left ,right))))
     145            (*text* . ,(lambda (trigger str) str))
     146            (*default* . ,(lambda (tag elems) (cons tag elems)))
    114147            ))))
    115148    tree))
    … …  
    119152  (let recur ((env env) (ax '()))
    120153    (if (null? env)
    121         `(let ,ax ,fin)
     154        `(let (,ax) ,fin)
    122155        (let ((en (car env)))
     156          (print "en = " en)
     157          (print "ax = " ax)
    123158          (let ((name (string->symbol (sxml:attr en 'name)))
    124159                (value (sxml-value->sexpr (sxml:kid en))))
     160            (print "value = " value)
    125161            (let ((en (list name value)))
    126               (recur (cdr env) (cons en ax))
     162              (recur (cdr env) (if value (cons en ax) ax))
    127163              )))
    128164        )))
    … …  
    130166                                         
    131167(define (sxml-value->sexpr tree)
     168  (print "tree = " tree)
    132169    (let* ((tree
    133170            (sxml:pre-post-order*
    134171            tree
    135172            `(
    136               (Closure *macro* .
     173              (Tuple *macro*  .
     174                      ,(lambda (tag elems)
     175                         (let ((node (cons tag elems)))
     176                           (print "Tuple elems = " elems)
     177                           (let ((left (sxml:kidn-cadr 'left node))
     178                                 (right (sxml:kidn-cdr 'right node)))
     179                             (print "left = " left)
     180                             (print "right = " right)
     181                             (cons left right)))
     182                         ))
     183
     184              (Const (
     185                      (label . ,(lambda (tag elems) (string->symbol (car elems))))
     186                     
     187                      (string . ,(lambda (tag elems) (car elems)))
     188                     
     189                      (real . ,(lambda (tag elems) (string->number (car elems))))
     190                     
     191                      (nat  . ,(lambda (tag elems) (string->number (car elems))))
     192                     
     193                      (bool . ,(lambda (tag elems) (if (string=? (car elems) "true") #t #f)))
     194                     
     195                      (null . ,(lambda (tag elems) '()))
     196                     
     197                      (*text* . ,(lambda (trigger str) str))
     198
     199                      (*default* . ,(lambda (tag elems) (cons tag elems)))
     200
     201                      ) . ,(lambda (tag elems)
     202                             (print "Const elems = " elems)
     203                             (car elems)))
     204
     205              (Closure .
    137206                       ,(lambda (tag elems)
    138207                          (let ((node (cons tag elems)))
    … …  
    140209                                  (env  (sxml:kidn-cdr 'env node)))
    141210                              (let ((term (sxml-term->sexpr body)))
    142                                 (sxml-eval-env->sexpr env term)
     211                                (list (sxml-eval-env->sexpr env term))
     212                                ;;                              (list term)
    143213                                )))
    144214                          ))
    145              
    146               (Tuple *macro* .
    147                      ,(lambda (tag elems)
    148                         (let ((node (cons tag elems)))
    149                           (let ((left (sxml:kidn-cadr 'left node))
    150                                 (right (sxml:kidn-cdr 'right node)))
    151                             (cons left right)))
    152                         ))
    153              
    154               (Const . ,(lambda (tag elems) (car elems)))
    155              
    156               (label . ,(lambda (tag elems) (string->symbol (car elems))))
    157              
    158               (string . ,(lambda (tag elems) (car elems)))
    159              
    160               (real . ,(lambda (tag elems) (car elems)))
    161              
    162               (nat  . ,(lambda (tag elems) (car elems)))
    163              
    164               (bool . ,(lambda (tag elems) (if (string=? (car elems) "true") #t #f)))
    165              
    166               (null . ,(lambda (tag elems) '()))
    167              
     215
     216
    168217              (*text* . ,(lambda (trigger str) str))
    169              
     218
    170219              (*default* . ,(lambda (tag elems) (cons tag elems)))
     220
    171221              )))
    172222
    … …  
    180230
    181231               (*text* . ,(lambda (trigger str) str))
    182                
     232
    183233               (*default* . ,(lambda (tag elems) (cons tag elems)))
    184234               )))
    … …  
    186236           (tree
    187237            (let flatten ((tree tree))
    188               (cond ((atom? tree) tree)
    189                     (else (cons (flatten (car tree)) (flatten (cadr tree))))))))
     238              (cond ((or (atom? tree) (null? tree) (null? (cdr tree))) tree)
     239                    (else (cons (flatten (car tree))
     240                                (flatten (cadr tree))))))))
    190241      tree))
    191242

  • release/4/9ML-toolkit/trunk/parse.scm

    r25988 r27283  
    144144      (cond  [(not arg) (error loc-str msg)]
    145145             [(lexical-token? arg)
    146               (error (conc "line " (source-location-line (lexical-token-source arg)) ": " msg) loc-str
     146              (error (conc "line " (let ((src (lexical-token-source arg)))
     147                                     (if (source-location? src)
     148                                         (source-location-line (lexical-token-source arg))
     149                                         src)) ": " msg)
     150                     loc-str
    147151                     (conc (lexical-token-category arg)
    148152                           (if (lexical-token-value arg) (conc " " (lexical-token-value arg)) "")))]
Note: See TracChangeset for help on using the changeset viewer.