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