module/language/tree-il.scm

   1 ;;;;    Copyright (C) 2009 Free Software Foundation, Inc.
   2 ;;;;
   3 ;;;; This library is free software; you can redistribute it and/or
   4 ;;;; modify it under the terms of the GNU Lesser General Public
   5 ;;;; License as published by the Free Software Foundation; either
   6 ;;;; version 3 of the License, or (at your option) any later version.
   7 ;;;;
   8 ;;;; This library is distributed in the hope that it will be useful,
   9 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11 ;;;; Lesser General Public License for more details.
  12 ;;;;
  13 ;;;; You should have received a copy of the GNU Lesser General Public
  14 ;;;; License along with this library; if not, write to the Free Software
  15 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  16 ;;;;
  17 \f
  18
  19 (define-module (language tree-il)
  20   #:use-module (srfi srfi-1)
  21   #:use-module (srfi srfi-11)
  22   #:use-module (system base pmatch)
  23   #:use-module (system base syntax)
  24   #:export (tree-il-src
  25
  26             <void> void? make-void void-src
  27             <const> const? make-const const-src const-exp
  28             <primitive-ref> primitive-ref? make-primitive-ref primitive-ref-src primitive-ref-name
  29             <lexical-ref> lexical-ref? make-lexical-ref lexical-ref-src lexical-ref-name lexical-ref-gensym
  30             <lexical-set> lexical-set? make-lexical-set lexical-set-src lexical-set-name lexical-set-gensym lexical-set-exp
  31             <module-ref> module-ref? make-module-ref module-ref-src module-ref-mod module-ref-name module-ref-public?
  32             <module-set> module-set? make-module-set module-set-src module-set-mod module-set-name module-set-public? module-set-exp
  33             <toplevel-ref> toplevel-ref? make-toplevel-ref toplevel-ref-src toplevel-ref-name
  34             <toplevel-set> toplevel-set? make-toplevel-set toplevel-set-src toplevel-set-name toplevel-set-exp
  35             <toplevel-define> toplevel-define? make-toplevel-define toplevel-define-src toplevel-define-name toplevel-define-exp
  36             <conditional> conditional? make-conditional conditional-src conditional-test conditional-then conditional-else
  37             <application> application? make-application application-src application-proc application-args
  38             <sequence> sequence? make-sequence sequence-src sequence-exps
  39             <lambda> lambda? make-lambda lambda-src lambda-names lambda-vars lambda-meta lambda-body
  40             <let> let? make-let let-src let-names let-vars let-vals let-body
  41             <letrec> letrec? make-letrec letrec-src letrec-names letrec-vars letrec-vals letrec-body
  42             <fix> fix? make-fix fix-src fix-names fix-vars fix-vals fix-body
  43             <let-values> let-values? make-let-values let-values-src let-values-names let-values-vars let-values-exp let-values-body
  44
  45             parse-tree-il
  46             unparse-tree-il
  47             tree-il->scheme
  48
  49             tree-il-fold
  50             make-tree-il-folder
  51             post-order!
  52             pre-order!))
  53
  54 (define-type (<tree-il> #:common-slots (src))
  55   (<void>)
  56   (<const> exp)
  57   (<primitive-ref> name)
  58   (<lexical-ref> name gensym)
  59   (<lexical-set> name gensym exp)
  60   (<module-ref> mod name public?)
  61   (<module-set> mod name public? exp)
  62   (<toplevel-ref> name)
  63   (<toplevel-set> name exp)
  64   (<toplevel-define> name exp)
  65   (<conditional> test then else)
  66   (<application> proc args)
  67   (<sequence> exps)
  68   (<lambda> names vars meta body)
  69   (<let> names vars vals body)
  70   (<letrec> names vars vals body)
  71   (<fix> names vars vals body)
  72   (<let-values> names vars exp body))
  73
  74 \f
  75
  76 (define (location x)
  77   (and (pair? x)
  78        (let ((props (source-properties x)))
  79          (and (pair? props) props))))
  80
  81 (define (parse-tree-il exp)
  82   (let ((loc (location exp))
  83         (retrans (lambda (x) (parse-tree-il x))))
  84     (pmatch exp
  85      ((void)
  86       (make-void loc))
  87
  88      ((apply ,proc . ,args)
  89       (make-application loc (retrans proc) (map retrans args)))
  90
  91      ((if ,test ,then ,else)
  92       (make-conditional loc (retrans test) (retrans then) (retrans else)))
  93
  94      ((primitive ,name) (guard (symbol? name))
  95       (make-primitive-ref loc name))
  96
  97      ((lexical ,name) (guard (symbol? name))
  98       (make-lexical-ref loc name name))
  99
 100      ((lexical ,name ,sym) (guard (symbol? name) (symbol? sym))
 101       (make-lexical-ref loc name sym))
 102
 103      ((set! (lexical ,name) ,exp) (guard (symbol? name))
 104       (make-lexical-set loc name name (retrans exp)))
 105
 106      ((set! (lexical ,name ,sym) ,exp) (guard (symbol? name) (symbol? sym))
 107       (make-lexical-set loc name sym (retrans exp)))
 108
 109      ((@ ,mod ,name) (guard (and-map symbol? mod) (symbol? name))
 110       (make-module-ref loc mod name #t))
 111
 112      ((set! (@ ,mod ,name) ,exp) (guard (and-map symbol? mod) (symbol? name))
 113       (make-module-set loc mod name #t (retrans exp)))
 114
 115      ((@@ ,mod ,name) (guard (and-map symbol? mod) (symbol? name))
 116       (make-module-ref loc mod name #f))
 117
 118      ((set! (@@ ,mod ,name) ,exp) (guard (and-map symbol? mod) (symbol? name))
 119       (make-module-set loc mod name #f (retrans exp)))
 120
 121      ((toplevel ,name) (guard (symbol? name))
 122       (make-toplevel-ref loc name))
 123
 124      ((set! (toplevel ,name) ,exp) (guard (symbol? name))
 125       (make-toplevel-set loc name (retrans exp)))
 126
 127      ((define ,name ,exp) (guard (symbol? name))
 128       (make-toplevel-define loc name (retrans exp)))
 129
 130      ((lambda ,names ,vars ,exp)
 131       (make-lambda loc names vars '() (retrans exp)))
 132
 133      ((lambda ,names ,vars ,meta ,exp)
 134       (make-lambda loc names vars meta (retrans exp)))
 135
 136      ((const ,exp)
 137       (make-const loc exp))
 138
 139      ((begin . ,exps)
 140       (make-sequence loc (map retrans exps)))
 141
 142      ((let ,names ,vars ,vals ,body)
 143       (make-let loc names vars (map retrans vals) (retrans body)))
 144
 145      ((letrec ,names ,vars ,vals ,body)
 146       (make-letrec loc names vars (map retrans vals) (retrans body)))
 147
 148      ((fix ,names ,vars ,vals ,body)
 149       (make-fix loc names vars (map retrans vals) (retrans body)))
 150
 151      ((let-values ,names ,vars ,exp ,body)
 152       (make-let-values loc names vars (retrans exp) (retrans body)))
 153
 154      (else
 155       (error "unrecognized tree-il" exp)))))
 156
 157 (define (unparse-tree-il tree-il)
 158   (record-case tree-il
 159     ((<void>)
 160      '(void))
 161
 162     ((<application> proc args)
 163      `(apply ,(unparse-tree-il proc) ,@(map unparse-tree-il args)))
 164
 165     ((<conditional> test then else)
 166      `(if ,(unparse-tree-il test) ,(unparse-tree-il then) ,(unparse-tree-il else)))
 167
 168     ((<primitive-ref> name)
 169      `(primitive ,name))
 170
 171     ((<lexical-ref> name gensym)
 172      `(lexical ,name ,gensym))
 173
 174     ((<lexical-set> name gensym exp)
 175      `(set! (lexical ,name ,gensym) ,(unparse-tree-il exp)))
 176
 177     ((<module-ref> mod name public?)
 178      `(,(if public? '@ '@@) ,mod ,name))
 179
 180     ((<module-set> mod name public? exp)
 181      `(set! (,(if public? '@ '@@) ,mod ,name) ,(unparse-tree-il exp)))
 182
 183     ((<toplevel-ref> name)
 184      `(toplevel ,name))
 185
 186     ((<toplevel-set> name exp)
 187      `(set! (toplevel ,name) ,(unparse-tree-il exp)))
 188
 189     ((<toplevel-define> name exp)
 190      `(define ,name ,(unparse-tree-il exp)))
 191
 192     ((<lambda> names vars meta body)
 193      `(lambda ,names ,vars ,meta ,(unparse-tree-il body)))
 194
 195     ((<const> exp)
 196      `(const ,exp))
 197
 198     ((<sequence> exps)
 199      `(begin ,@(map unparse-tree-il exps)))
 200
 201     ((<let> names vars vals body)
 202      `(let ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
 203
 204     ((<letrec> names vars vals body)
 205      `(letrec ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
 206
 207     ((<fix> names vars vals body)
 208      `(fix ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
 209
 210     ((<let-values> names vars exp body)
 211      `(let-values ,names ,vars ,(unparse-tree-il exp) ,(unparse-tree-il body)))))
 212
 213 (define (tree-il->scheme e)
 214   (record-case e
 215     ((<void>)
 216      '(if #f #f))
 217
 218     ((<application> proc args)
 219      `(,(tree-il->scheme proc) ,@(map tree-il->scheme args)))
 220
 221     ((<conditional> test then else)
 222      (if (void? else)
 223          `(if ,(tree-il->scheme test) ,(tree-il->scheme then))
 224          `(if ,(tree-il->scheme test) ,(tree-il->scheme then) ,(tree-il->scheme else))))
 225
 226     ((<primitive-ref> name)
 227      name)
 228
 229     ((<lexical-ref> name gensym)
 230      gensym)
 231
 232     ((<lexical-set> name gensym exp)
 233      `(set! ,gensym ,(tree-il->scheme exp)))
 234
 235     ((<module-ref> mod name public?)
 236      `(,(if public? '@ '@@) ,mod ,name))
 237
 238     ((<module-set> mod name public? exp)
 239      `(set! (,(if public? '@ '@@) ,mod ,name) ,(tree-il->scheme exp)))
 240
 241     ((<toplevel-ref> name)
 242      name)
 243
 244     ((<toplevel-set> name exp)
 245      `(set! ,name ,(tree-il->scheme exp)))
 246
 247     ((<toplevel-define> name exp)
 248      `(define ,name ,(tree-il->scheme exp)))
 249
 250     ((<lambda> vars meta body)
 251      `(lambda ,vars
 252         ,@(cond ((assq-ref meta 'documentation) => list) (else '()))
 253         ,(tree-il->scheme body)))
 254
 255     ((<const> exp)
 256      (if (and (self-evaluating? exp) (not (vector? exp)))
 257          exp
 258          (list 'quote exp)))
 259
 260     ((<sequence> exps)
 261      `(begin ,@(map tree-il->scheme exps)))
 262
 263     ((<let> vars vals body)
 264      `(let ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme body)))
 265
 266     ((<letrec> vars vals body)
 267      `(letrec ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme body)))
 268
 269     ((<fix> vars vals body)
 270      ;; not a typo, we really do translate back to letrec
 271      `(letrec ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme body)))
 272
 273     ((<let-values> vars exp body)
 274      `(call-with-values (lambda () ,(tree-il->scheme exp))
 275         (lambda ,vars ,(tree-il->scheme body))))))
 276
 277 \f
 278 (define (tree-il-fold leaf down up seed tree)
 279   "Traverse TREE, calling LEAF on each leaf encountered, DOWN upon descent
 280 into a sub-tree, and UP when leaving a sub-tree.  Each of these procedures is
 281 invoked as `(PROC TREE SEED)', where TREE is the sub-tree or leaf considered
 282 and SEED is the current result, intially seeded with SEED.
 283
 284 This is an implementation of `foldts' as described by Andy Wingo in
 285 ``Applications of fold to XML transformation''."
 286   (let loop ((tree   tree)
 287              (result seed))
 288     (if (or (null? tree) (pair? tree))
 289         (fold loop result tree)
 290         (record-case tree
 291           ((<lexical-set> exp)
 292            (up tree (loop exp (down tree result))))
 293           ((<module-set> exp)
 294            (up tree (loop exp (down tree result))))
 295           ((<toplevel-set> exp)
 296            (up tree (loop exp (down tree result))))
 297           ((<toplevel-define> exp)
 298            (up tree (loop exp (down tree result))))
 299           ((<conditional> test then else)
 300            (up tree (loop else
 301                           (loop then
 302                                 (loop test (down tree result))))))
 303           ((<application> proc args)
 304            (up tree (loop (cons proc args) (down tree result))))
 305           ((<sequence> exps)
 306            (up tree (loop exps (down tree result))))
 307           ((<lambda> body)
 308            (up tree (loop body (down tree result))))
 309           ((<let> vals body)
 310            (up tree (loop body
 311                           (loop vals
 312                                 (down tree result)))))
 313           ((<letrec> vals body)
 314            (up tree (loop body
 315                           (loop vals
 316                                 (down tree result)))))
 317           ((<fix> vals body)
 318            (up tree (loop body
 319                           (loop vals
 320                                 (down tree result)))))
 321           ((<let-values> exp body)
 322            (up tree (loop body (loop exp (down tree result)))))
 323           (else
 324            (leaf tree result))))))
 325
 326
 327 (define-syntax make-tree-il-folder
 328   (syntax-rules ()
 329     ((_ seed ...)
 330      (lambda (tree down up seed ...)
 331        (define (fold-values proc exps seed ...)
 332          (if (null? exps)
 333              (values seed ...)
 334              (let-values (((seed ...) (proc (car exps) seed ...)))
 335                (fold-values proc (cdr exps) seed ...))))
 336        (let foldts ((tree tree) (seed seed) ...)
 337          (let*-values
 338              (((seed ...) (down tree seed ...))
 339               ((seed ...)
 340                (record-case tree
 341                  ((<lexical-set> exp)
 342                   (foldts exp seed ...))
 343                  ((<module-set> exp)
 344                   (foldts exp seed ...))
 345                  ((<toplevel-set> exp)
 346                   (foldts exp seed ...))
 347                  ((<toplevel-define> exp)
 348                   (foldts exp seed ...))
 349                  ((<conditional> test then else)
 350                   (let*-values (((seed ...) (foldts test seed ...))
 351                                 ((seed ...) (foldts then seed ...)))
 352                     (foldts else seed ...)))
 353                  ((<application> proc args)
 354                   (let-values (((seed ...) (foldts proc seed ...)))
 355                     (fold-values foldts args seed ...)))
 356                  ((<sequence> exps)
 357                   (fold-values foldts exps seed ...))
 358                  ((<lambda> body)
 359                   (foldts body seed ...))
 360                  ((<let> vals body)
 361                   (let*-values (((seed ...) (fold-values foldts vals seed ...)))
 362                     (foldts body seed ...)))
 363                  ((<letrec> vals body)
 364                   (let*-values (((seed ...) (fold-values foldts vals seed ...)))
 365                     (foldts body seed ...)))
 366                  ((<fix> vals body)
 367                   (let*-values (((seed ...) (fold-values foldts vals seed ...)))
 368                     (foldts body seed ...)))
 369                  ((<let-values> exp body)
 370                   (let*-values (((seed ...) (foldts exp seed ...)))
 371                     (foldts body seed ...)))
 372                  (else
 373                   (values seed ...)))))
 374            (up tree seed ...)))))))
 375
 376 (define (post-order! f x)
 377   (let lp ((x x))
 378     (record-case x
 379       ((<application> proc args)
 380        (set! (application-proc x) (lp proc))
 381        (set! (application-args x) (map lp args)))
 382
 383       ((<conditional> test then else)
 384        (set! (conditional-test x) (lp test))
 385        (set! (conditional-then x) (lp then))
 386        (set! (conditional-else x) (lp else)))
 387
 388       ((<lexical-set> name gensym exp)
 389        (set! (lexical-set-exp x) (lp exp)))
 390
 391       ((<module-set> mod name public? exp)
 392        (set! (module-set-exp x) (lp exp)))
 393
 394       ((<toplevel-set> name exp)
 395        (set! (toplevel-set-exp x) (lp exp)))
 396
 397       ((<toplevel-define> name exp)
 398        (set! (toplevel-define-exp x) (lp exp)))
 399
 400       ((<lambda> vars meta body)
 401        (set! (lambda-body x) (lp body)))
 402
 403       ((<sequence> exps)
 404        (set! (sequence-exps x) (map lp exps)))
 405
 406       ((<let> vars vals body)
 407        (set! (let-vals x) (map lp vals))
 408        (set! (let-body x) (lp body)))
 409
 410       ((<letrec> vars vals body)
 411        (set! (letrec-vals x) (map lp vals))
 412        (set! (letrec-body x) (lp body)))
 413
 414       ((<fix> vars vals body)
 415        (set! (fix-vals x) (map lp vals))
 416        (set! (fix-body x) (lp body)))
 417
 418       ((<let-values> vars exp body)
 419        (set! (let-values-exp x) (lp exp))
 420        (set! (let-values-body x) (lp body)))
 421
 422       (else #f))
 423
 424     (or (f x) x)))
 425
 426 (define (pre-order! f x)
 427   (let lp ((x x))
 428     (let ((x (or (f x) x)))
 429       (record-case x
 430         ((<application> proc args)
 431          (set! (application-proc x) (lp proc))
 432          (set! (application-args x) (map lp args)))
 433
 434         ((<conditional> test then else)
 435          (set! (conditional-test x) (lp test))
 436          (set! (conditional-then x) (lp then))
 437          (set! (conditional-else x) (lp else)))
 438
 439         ((<lexical-set> name gensym exp)
 440          (set! (lexical-set-exp x) (lp exp)))
 441
 442         ((<module-set> mod name public? exp)
 443          (set! (module-set-exp x) (lp exp)))
 444
 445         ((<toplevel-set> name exp)
 446          (set! (toplevel-set-exp x) (lp exp)))
 447
 448         ((<toplevel-define> name exp)
 449          (set! (toplevel-define-exp x) (lp exp)))
 450
 451         ((<lambda> vars meta body)
 452          (set! (lambda-body x) (lp body)))
 453
 454         ((<sequence> exps)
 455          (set! (sequence-exps x) (map lp exps)))
 456
 457         ((<let> vars vals body)
 458          (set! (let-vals x) (map lp vals))
 459          (set! (let-body x) (lp body)))
 460
 461         ((<letrec> vars vals body)
 462          (set! (letrec-vals x) (map lp vals))
 463          (set! (letrec-body x) (lp body)))
 464
 465         ((<fix> vars vals body)
 466          (set! (fix-vals x) (map lp vals))
 467          (set! (fix-body x) (lp body)))
 468
 469         ((<let-values> vars exp body)
 470          (set! (let-values-exp x) (lp exp))
 471          (set! (let-values-body x) (lp body)))
 472
 473         (else #f))
 474       x)))