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 2.1 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 (system base pmatch)
  21   #:use-module (system base syntax)
  22   #:export (tree-il-src
  23
  24             <void> void? make-void void-src
  25             <const> const? make-const const-src const-exp
  26             <primitive-ref> primitive-ref? make-primitive-ref primitive-ref-src primitive-ref-name
  27             <lexical-ref> lexical-ref? make-lexical-ref lexical-ref-src lexical-ref-name lexical-ref-gensym
  28             <lexical-set> lexical-set? make-lexical-set lexical-set-src lexical-set-name lexical-set-gensym lexical-set-exp
  29             <module-ref> module-ref? make-module-ref module-ref-src module-ref-mod module-ref-name module-ref-public?
  30             <module-set> module-set? make-module-set module-set-src module-set-mod module-set-name module-set-public? module-set-exp
  31             <toplevel-ref> toplevel-ref? make-toplevel-ref toplevel-ref-src toplevel-ref-name
  32             <toplevel-set> toplevel-set? make-toplevel-set toplevel-set-src toplevel-set-name toplevel-set-exp
  33             <toplevel-define> toplevel-define? make-toplevel-define toplevel-define-src toplevel-define-name toplevel-define-exp
  34             <conditional> conditional? make-conditional conditional-src conditional-test conditional-then conditional-else
  35             <application> application? make-application application-src application-proc application-args
  36             <sequence> sequence? make-sequence sequence-src sequence-exps
  37             <lambda> lambda? make-lambda lambda-src lambda-names lambda-vars lambda-meta lambda-body
  38             <let> let? make-let let-src let-names let-vars let-vals let-body
  39             <letrec> letrec? make-letrec letrec-src letrec-names letrec-vars letrec-vals letrec-body
  40             <let-values> let-values? make-let-values let-values-src let-values-names let-values-vars let-values-exp let-values-body
  41
  42             parse-tree-il
  43             unparse-tree-il
  44             tree-il->scheme
  45
  46             post-order!
  47             pre-order!))
  48
  49 (define-type (<tree-il> #:common-slots (src))
  50   (<void>)
  51   (<const> exp)
  52   (<primitive-ref> name)
  53   (<lexical-ref> name gensym)
  54   (<lexical-set> name gensym exp)
  55   (<module-ref> mod name public?)
  56   (<module-set> mod name public? exp)
  57   (<toplevel-ref> name)
  58   (<toplevel-set> name exp)
  59   (<toplevel-define> name exp)
  60   (<conditional> test then else)
  61   (<application> proc args)
  62   (<sequence> exps)
  63   (<lambda> names vars meta body)
  64   (<let> names vars vals body)
  65   (<letrec> names vars vals body)
  66   (<let-values> names vars exp body))
  67
  68 \f
  69
  70 (define (location x)
  71   (and (pair? x)
  72        (let ((props (source-properties x)))
  73          (and (pair? props) props))))
  74
  75 (define (parse-tree-il exp)
  76   (let ((loc (location exp))
  77         (retrans (lambda (x) (parse-tree-il x))))
  78     (pmatch exp
  79      ((void)
  80       (make-void loc))
  81
  82      ((apply ,proc . ,args)
  83       (make-application loc (retrans proc) (map retrans args)))
  84
  85      ((if ,test ,then ,else)
  86       (make-conditional loc (retrans test) (retrans then) (retrans else)))
  87
  88      ((primitive ,name) (guard (symbol? name))
  89       (make-primitive-ref loc name))
  90
  91      ((lexical ,name) (guard (symbol? name))
  92       (make-lexical-ref loc name name))
  93
  94      ((lexical ,name ,sym) (guard (symbol? name) (symbol? sym))
  95       (make-lexical-ref loc name sym))
  96
  97      ((set! (lexical ,name ,sym) ,exp) (guard (symbol? name) (symbol? sym))
  98       (make-lexical-set loc name sym (retrans exp)))
  99
 100      ((@ ,mod ,name) (guard (and-map symbol? mod) (symbol? name))
 101       (make-module-ref loc mod name #t))
 102
 103      ((set! (@ ,mod ,name) ,exp) (guard (and-map symbol? mod) (symbol? name))
 104       (make-module-set loc mod name #t (retrans exp)))
 105
 106      ((@@ ,mod ,name) (guard (and-map symbol? mod) (symbol? name))
 107       (make-module-ref loc mod name #f))
 108
 109      ((set! (@@ ,mod ,name) ,exp) (guard (and-map symbol? mod) (symbol? name))
 110       (make-module-set loc mod name #f (retrans exp)))
 111
 112      ((toplevel ,name) (guard (symbol? name))
 113       (make-toplevel-ref loc name))
 114
 115      ((set! (toplevel ,name) ,exp) (guard (symbol? name))
 116       (make-toplevel-set loc name (retrans exp)))
 117
 118      ((define ,name ,exp) (guard (symbol? name))
 119       (make-toplevel-define loc name (retrans exp)))
 120
 121      ((lambda ,names ,vars ,exp)
 122       (make-lambda loc names vars '() (retrans exp)))
 123
 124      ((lambda ,names ,vars ,meta ,exp)
 125       (make-lambda loc names vars meta (retrans exp)))
 126
 127      ((const ,exp)
 128       (make-const loc exp))
 129
 130      ((begin . ,exps)
 131       (make-sequence loc (map retrans exps)))
 132
 133      ((let ,names ,vars ,vals ,body)
 134       (make-let loc names vars (map retrans vals) (retrans body)))
 135
 136      ((letrec ,names ,vars ,vals ,body)
 137       (make-letrec loc names vars (map retrans vals) (retrans body)))
 138
 139      ((let-values ,names ,vars ,exp ,body)
 140       (make-let-values loc names vars (retrans exp) (retrans body)))
 141
 142      (else
 143       (error "unrecognized tree-il" exp)))))
 144
 145 (define (unparse-tree-il tree-il)
 146   (record-case tree-il
 147     ((<void>)
 148      '(void))
 149
 150     ((<application> proc args)
 151      `(apply ,(unparse-tree-il proc) ,@(map unparse-tree-il args)))
 152
 153     ((<conditional> test then else)
 154      `(if ,(unparse-tree-il test) ,(unparse-tree-il then) ,(unparse-tree-il else)))
 155
 156     ((<primitive-ref> name)
 157      `(primitive ,name))
 158
 159     ((<lexical-ref> name gensym)
 160      `(lexical ,name ,gensym))
 161
 162     ((<lexical-set> name gensym exp)
 163      `(set! (lexical ,name ,gensym) ,(unparse-tree-il exp)))
 164
 165     ((<module-ref> mod name public?)
 166      `(,(if public? '@ '@@) ,mod ,name))
 167
 168     ((<module-set> mod name public? exp)
 169      `(set! (,(if public? '@ '@@) ,mod ,name) ,(unparse-tree-il exp)))
 170
 171     ((<toplevel-ref> name)
 172      `(toplevel ,name))
 173
 174     ((<toplevel-set> name exp)
 175      `(set! (toplevel ,name) ,(unparse-tree-il exp)))
 176
 177     ((<toplevel-define> name exp)
 178      `(define ,name ,(unparse-tree-il exp)))
 179
 180     ((<lambda> names vars meta body)
 181      `(lambda ,names ,vars ,meta ,(unparse-tree-il body)))
 182
 183     ((<const> exp)
 184      `(const ,exp))
 185
 186     ((<sequence> exps)
 187      `(begin ,@(map unparse-tree-il exps)))
 188
 189     ((<let> names vars vals body)
 190      `(let ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
 191
 192     ((<letrec> names vars vals body)
 193      `(letrec ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
 194
 195     ((<let-values> names vars exp body)
 196      `(let-values ,names ,vars ,(unparse-tree-il exp) ,(unparse-tree-il body)))))
 197
 198 (define (tree-il->scheme e)
 199   (record-case e
 200     ((<void>)
 201      '(if #f #f))
 202
 203     ((<application> proc args)
 204      `(,(tree-il->scheme proc) ,@(map tree-il->scheme args)))
 205
 206     ((<conditional> test then else)
 207      (if (void? else)
 208          `(if ,(tree-il->scheme test) ,(tree-il->scheme then))
 209          `(if ,(tree-il->scheme test) ,(tree-il->scheme then) ,(tree-il->scheme else))))
 210
 211     ((<primitive-ref> name)
 212      name)
 213
 214     ((<lexical-ref> name gensym)
 215      gensym)
 216
 217     ((<lexical-set> name gensym exp)
 218      `(set! ,gensym ,(tree-il->scheme exp)))
 219
 220     ((<module-ref> mod name public?)
 221      `(,(if public? '@ '@@) ,mod ,name))
 222
 223     ((<module-set> mod name public? exp)
 224      `(set! (,(if public? '@ '@@) ,mod ,name) ,(tree-il->scheme exp)))
 225
 226     ((<toplevel-ref> name)
 227      name)
 228
 229     ((<toplevel-set> name exp)
 230      `(set! ,name ,(tree-il->scheme exp)))
 231
 232     ((<toplevel-define> name exp)
 233      `(define ,name ,(tree-il->scheme exp)))
 234
 235     ((<lambda> vars meta body)
 236      `(lambda ,vars
 237         ,@(cond ((assq-ref meta 'documentation) => list) (else '()))
 238         ,(tree-il->scheme body)))
 239
 240     ((<const> exp)
 241      (if (and (self-evaluating? exp) (not (vector? exp)))
 242          exp
 243          (list 'quote exp)))
 244
 245     ((<sequence> exps)
 246      `(begin ,@(map tree-il->scheme exps)))
 247
 248     ((<let> vars vals body)
 249      `(let ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme body)))
 250
 251     ((<letrec> vars vals body)
 252      `(letrec ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme body)))
 253
 254     ((<let-values> vars exp body)
 255      `(call-with-values (lambda () ,(tree-il->scheme exp))
 256         (lambda ,vars ,(tree-il->scheme body))))))
 257
 258 (define (post-order! f x)
 259   (let lp ((x x))
 260     (record-case x
 261       ((<application> proc args)
 262        (set! (application-proc x) (lp proc))
 263        (set! (application-args x) (map lp args)))
 264
 265       ((<conditional> test then else)
 266        (set! (conditional-test x) (lp test))
 267        (set! (conditional-then x) (lp then))
 268        (set! (conditional-else x) (lp else)))
 269
 270       ((<lexical-set> name gensym exp)
 271        (set! (lexical-set-exp x) (lp exp)))
 272
 273       ((<module-set> mod name public? exp)
 274        (set! (module-set-exp x) (lp exp)))
 275
 276       ((<toplevel-set> name exp)
 277        (set! (toplevel-set-exp x) (lp exp)))
 278
 279       ((<toplevel-define> name exp)
 280        (set! (toplevel-define-exp x) (lp exp)))
 281
 282       ((<lambda> vars meta body)
 283        (set! (lambda-body x) (lp body)))
 284
 285       ((<sequence> exps)
 286        (set! (sequence-exps x) (map lp exps)))
 287
 288       ((<let> vars vals body)
 289        (set! (let-vals x) (map lp vals))
 290        (set! (let-body x) (lp body)))
 291
 292       ((<letrec> vars vals body)
 293        (set! (letrec-vals x) (map lp vals))
 294        (set! (letrec-body x) (lp body)))
 295
 296       ((<let-values> vars exp body)
 297        (set! (let-values-exp x) (lp exp))
 298        (set! (let-values-body x) (lp body)))
 299
 300       (else #f))
 301
 302     (or (f x) x)))
 303
 304 (define (pre-order! f x)
 305   (let lp ((x x))
 306     (let ((x (or (f x) x)))
 307       (record-case x
 308         ((<application> proc args)
 309          (set! (application-proc x) (lp proc))
 310          (set! (application-args x) (map lp args)))
 311
 312         ((<conditional> test then else)
 313          (set! (conditional-test x) (lp test))
 314          (set! (conditional-then x) (lp then))
 315          (set! (conditional-else x) (lp else)))
 316
 317         ((<lexical-set> name gensym exp)
 318          (set! (lexical-set-exp x) (lp exp)))
 319
 320         ((<module-set> mod name public? exp)
 321          (set! (module-set-exp x) (lp exp)))
 322
 323         ((<toplevel-set> name exp)
 324          (set! (toplevel-set-exp x) (lp exp)))
 325
 326         ((<toplevel-define> name exp)
 327          (set! (toplevel-define-exp x) (lp exp)))
 328
 329         ((<lambda> vars meta body)
 330          (set! (lambda-body x) (lp body)))
 331
 332         ((<sequence> exps)
 333          (set! (sequence-exps x) (map lp exps)))
 334
 335         ((<let> vars vals body)
 336          (set! (let-vals x) (map lp vals))
 337          (set! (let-body x) (lp body)))
 338
 339         ((<letrec> vars vals body)
 340          (set! (letrec-vals x) (map lp vals))
 341          (set! (letrec-body x) (lp body)))
 342
 343         ((<let-values> vars exp body)
 344          (set! (let-values-exp x) (lp exp))
 345          (set! (let-values-body x) (lp body)))
 346
 347         (else #f))
 348       x)))