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-loc
  23
  24            <lexical> make-lexical
  25            lexical-name lexical-gensym
  26
  27            <application> make-application application-loc application-proc application-args
  28            <conditional> make-conditional conditional-loc conditional-test conditional-then conditional-else
  29            <primitive-ref> make-primitive-ref primitive-ref-loc primitive-ref-name
  30            <lexical-ref> make-lexical-ref lexical-ref-loc lexical-ref-name lexical-ref-gensym
  31            <lexical-set> make-lexical-set lexical-set-loc lexical-set-name lexical-set-gensym lexical-set-exp
  32            <module-ref> make-module-ref module-ref-loc module-ref-mod module-ref-name module-ref-public?
  33            <module-set> make-module-set module-set-loc module-set-mod module-set-name module-set-public? module-set-exp
  34            <toplevel-ref> make-toplevel-ref toplevel-ref-loc toplevel-ref-name
  35            <toplevel-set> make-toplevel-set toplevel-set-loc toplevel-set-name toplevel-set-exp
  36            <toplevel-define> make-toplevel-define toplevel-define-loc toplevel-define-name toplevel-define-exp
  37            <lambda> make-lambda lambda-loc lambda-vars lambda-meta lambda-body
  38            <const> make-const const-loc const-exp
  39            <sequence> make-sequence sequence-loc sequence-exps
  40            <let> make-let let-loc let-vars let-vals let-exp
  41            <letrec> make-letrec letrec-loc letrec-vars letrec-vals letrec-exp
  42
  43            parse-tree-il
  44            unparse-tree-il
  45            tree-il->scheme))
  46
  47 (define-type (<tree-il> #:common-slots (src))
  48   (<application> proc args)
  49   (<conditional> test then else)
  50   (<primitive-ref> name)
  51   (<lexical-ref> name gensym)
  52   (<lexical-set> name gensym exp)
  53   (<module-ref> mod name public?)
  54   (<module-set> mod name public? exp)
  55   (<toplevel-ref> name)
  56   (<toplevel-set> name exp)
  57   (<toplevel-define> name exp)
  58   (<lambda> vars meta body)
  59   (<const> exp)
  60   (<sequence> exps)
  61   (<let> vars vals exp)
  62   (<letrec> vars vals exp))
  63
  64 (define <lexical> <lexical-ref>)
  65 (define lexical? lexical-ref?)
  66 (define make-lexical make-lexical-ref)
  67 (define lexical-name lexical-ref-name)
  68 (define lexical-gensym lexical-ref-gensym)
  69
  70 \f
  71
  72 ;; FIXME: use this in psyntax
  73 (define (location x)
  74   (and (pair? x)
  75        (let ((props (source-properties x)))
  76          (and (not (null? props))
  77               (vector (assq-ref props 'line)
  78                       (assq-ref props 'column)
  79                       (assq-ref props 'filename))))))
  80
  81 (define (parse-tree-il env exp)
  82   (let ((loc (location exp))
  83         (retrans (lambda (x) (parse-ghil env x))))
  84     (pmatch exp
  85      ((apply ,proc ,args)
  86       (make-application loc (retrans proc) (retrans args)))
  87
  88      ((if ,test ,then ,else)
  89       (make-conditional loc (retrans test) (retrans then) (retrans else)))
  90
  91      ((primitive ,name) (guard (symbol? name))
  92       (make-primitive-ref loc name))
  93
  94      ((lexical ,name) (guard (symbol? name))
  95       (make-lexical-ref loc name name))
  96
  97      ((lexical ,name ,sym) (guard (symbol? name) (symbol? sym))
  98       (make-lexical-ref loc name sym))
  99
 100      ((set! (lexical ,name ,sym) ,exp) (guard (symbol? name) (symbol? sym))
 101       (make-lexical-set loc name sym (retrans exp)))
 102
 103      ((@ ,mod ,name) (guard (and-map symbol? mod) (symbol? name))
 104       (make-module-ref loc mod name #t))
 105
 106      ((set! (@ ,mod ,name) ,exp) (guard (and-map symbol? mod) (symbol? name))
 107       (make-module-set loc mod name #t (retrans exp)))
 108
 109      ((@@ ,mod ,name) (guard (and-map symbol? mod) (symbol? name))
 110       (make-module-ref loc mod name #f))
 111
 112      ((set! (@ ,mod ,name) ,exp) (guard (and-map symbol? mod) (symbol? name))
 113       (make-module-set loc mod name #f (retrans exp)))
 114
 115      ((toplevel ,name) (guard (symbol? name))
 116       (make-toplevel-ref loc name))
 117
 118      ((set! (toplevel ,name) exp) (guard (symbol? name))
 119       (make-toplevel-set loc name (retrans exp)))
 120
 121      ((define ,name exp) (guard (symbol? name))
 122       (make-toplevel-define loc name (retrans exp)))
 123
 124      ((lambda ,vars ,exp)
 125       (make-lambda loc vars '() (retrans exp)))
 126
 127      ((lambda ,vars ,meta ,exp)
 128       (make-lambda loc vars meta (retrans exp)))
 129
 130      ((const ,exp)
 131       (make-const loc exp))
 132
 133      ((begin . ,exps)
 134       (make-sequence loc (map retrans exps)))
 135
 136      ((let ,vars ,vals ,exp)
 137       (make-let loc vars vals (retrans exp)))
 138
 139      ((letrec ,vars ,vals ,exp)
 140       (make-letrec loc vars vals (retrans exp)))
 141
 142      (else
 143       (error "unrecognized tree-il" exp)))))
 144
 145 (define (unparse-tree-il tree-il)
 146   (record-case tree-il
 147     ((<application> proc args)
 148      `(apply ,(unparse-tree-il proc) ,(map unparse-tree-il args)))
 149
 150     ((<conditional> test then else)
 151      `(if ,(unparse-tree-il test) ,(unparse-tree-il then) ,(unparse-tree-il else)))
 152
 153     ((<primitive-ref> name)
 154      `(primitive ,name))
 155
 156     ((<lexical-ref> name gensym)
 157      `(lexical ,name ,gensym))
 158
 159     ((<lexical-set> name gensym exp)
 160      `(set! (lexical ,name ,gensym) ,(unparse-tree-il exp)))
 161
 162     ((<module-ref> mod name public?)
 163      `(,(if public? '@ '@@) ,mod ,name))
 164
 165     ((<module-set> mod name public? exp)
 166      `(set! (,(if public? '@ '@@) ,mod ,name) ,(unparse-tree-il exp)))
 167
 168     ((<toplevel-ref> name)
 169      `(toplevel ,name))
 170
 171     ((<toplevel-set> name exp)
 172      `(set! (toplevel ,name) ,(unparse-tree-il exp)))
 173
 174     ((<toplevel-define> name exp)
 175      `(define ,name ,(unparse-tree-il exp)))
 176
 177     ((<lambda> vars meta body)
 178      `(lambda ,vars ,meta ,(unparse-tree-il body)))
 179
 180     ((<const> exp)
 181      `(const ,exp))
 182
 183     ((<sequence> exps)
 184      `(begin ,@(map unparse-tree-il exps)))
 185
 186     ((<let> vars vals exp)
 187      `(let ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il exp)))
 188
 189     ((<letrec> vars vals exp)
 190      `(letrec ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il exp)))))
 191
 192 (define (tree-il->scheme e)
 193   (cond ((list? e)
 194          (map tree-il->scheme e))
 195         ((pair? e)
 196          (cons (tree-il->scheme (car e))
 197                (tree-il->scheme (cdr e))))
 198         ((record? e)
 199          (record-case e
 200            ((<application> proc args)
 201             `(,(tree-il->scheme proc) ,@(map tree-il->scheme args)))
 202
 203            ((<conditional> test then else)
 204             `(if ,(tree-il->scheme test) ,(tree-il->scheme then) ,(tree-il->scheme else)))
 205
 206            ((<primitive-ref> name)
 207             name)
 208
 209            ((<lexical-ref> name gensym)
 210             gensym)
 211
 212            ((<lexical-set> name gensym exp)
 213             `(set! ,gensym ,(tree-il->scheme exp)))
 214
 215            ((<module-ref> mod name public?)
 216             `(,(if public? '@ '@@) ,mod ,name))
 217
 218            ((<module-set> mod name public? exp)
 219             `(set! (,(if public? '@ '@@) ,mod ,name) ,(tree-il->scheme exp)))
 220
 221            ((<toplevel-ref> name)
 222             name)
 223
 224            ((<toplevel-set> name exp)
 225             `(set! ,name ,(tree-il->scheme exp)))
 226
 227            ((<toplevel-define> name exp)
 228             `(define ,name ,(tree-il->scheme exp)))
 229
 230            ((<lambda> vars meta body)
 231             `(lambda ,vars
 232                ,@(cond ((assq-ref meta 'documentation) => list) (else '()))
 233                ,(tree-il->scheme body)))
 234
 235            ((<const> exp)
 236             (if (and (self-evaluating? exp) (not (vector? exp)))
 237                 exp
 238                 (list 'quote exp)))
 239
 240            ((<sequence> exps)
 241             `(begin ,@(map tree-il->scheme exps)))
 242
 243            ((<let> vars vals exp)
 244             `(let ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme exp)))
 245
 246            ((<letrec> vars vals exp)
 247             `(letrec ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme exp)))))
 248         (else e)))