Changeset 25365 in project


Ignore:
Timestamp:
10/14/11 04:24:59 (9 years ago)
Author:
Ivan Raikov
Message:

9ML-toolkit: fixes to definition-apply

File:
1 edited

Legend:

Unmodified
Added
Removed
  • release/4/9ML-toolkit/trunk/repr.scm

    r25361 r25365  
    2626         sxml-value->sexpr sexpr->diagram+initial print-fragments
    2727         print-eval-env print-type-env print-source-defs
    28          generate-diagram html-report traverse-definitions
     28         generate-diagram html-report traverse-definitions definition-apply
    2929         )
    3030
     
    12941294(define (traverse-definitions prefix uenv #!key (type-hook #f) (component-hook #f) (value-hook #f) (filter (lambda (x) x)))
    12951295
    1296   (let (
    1297           (moddef-ss
    1298            
    1299            `(
    1300              (Type_def
    1301               *macro*
    1302               . ,(lambda (tag elems)
    1303                    (let ((node (cons tag elems)))
    1304                      (let ((name (sxml:attr node 'name))
    1305                            (deftype (sxml:kidn* 'deftype node)))
    1306                        (and type-hook (type-hook prefix name deftype))
    1307                    ))))
    1308 
    1309              (Component
    1310               *macro*
    1311               . ,(lambda (tag elems)
    1312                    (let ((node (cons tag elems)))
    1313                      (let ((name (sxml:attr node 'name)))
    1314                        (if (not name) (error 'process-definition "component element requires name attribute"))
    1315                        (and component-hook (component-hook prefix name (sxml:kid node)))
    1316                        ))))
    1317 
    1318              (Val
    1319               *macro*
    1320               . ,(lambda (tag elems)
    1321                    (let ((node (cons tag elems)))
    1322                      
    1323                      (let* ((name (sxml:attr node 'name))
    1324                             (value (sxml:kid node))
    1325                             (tuple-label ((sxpath '(Tuple left Const label *text*)) `(*TOP* ,value))))
    1326 
    1327                        (if (not name) (error 'process-definitions "binding element requires name attribute"))
    1328 
    1329                        (cond ((and value-hook (pair? tuple-label) (value-hook prefix name (car tuple-label) value)) =>
    1330                               (lambda (x) x))
    1331 
    1332                              (else #f))
    1333                        ))))
    1334              
    1335              ,@alist-conv-rules*
    1336          
    1337              (*text* . ,(lambda (trigger str) str))
    1338              
    1339              (*default* . ,(lambda (tag elems) (cons tag elems)))
    1340              
    1341              ))
    1342           )
    1343 
     1296 
    13441297  (let ((source-defs (car uenv))
    13451298        (type-env    (cadr uenv))
    13461299        (eval-env    (caddr uenv)))
    1347 
     1300   
    13481301    (let recur ((eval-env eval-env))
    13491302      (if (pair? eval-env)
     
    13651318            ))
    13661319      ))
    1367   ))
     1320  )
     1321
     1322
     1323(define (definition-apply prefix name uenv #!key (type-hook #f) (component-hook #f) (value-hook #f))
     1324
     1325  (let ((name (if (or (string? name) (symbol? name)) (ident-create (->string name)) name))
     1326        (source-defs (car uenv))
     1327        (type-env    (cadr uenv))
     1328        (eval-env    (caddr uenv)))
     1329
     1330    (let ((v (ident-find name eval-env)))
     1331
     1332      (and v
     1333             
     1334             (cond ((MLvalue? v)
     1335                    (let ((sxml-value (MLvalue->sxml v)))
     1336                      (let* ((name (sxml:attr sxml-value 'name))
     1337                             (value (sxml:kid sxml-value))
     1338                             (tuple-label ((sxpath '(Tuple left Const label *text*)) `(*TOP* ,sxml-value))))
     1339                        (if (pair? tuple-label)
     1340                            (value-hook prefix name (car tuple-label) sxml-value)))))
     1341                   (else #f))
     1342             ))
     1343      ))
     1344
     1345
    13681346
    13691347;; Taken from regex.scm:
Note: See TracChangeset for help on using the changeset viewer.