module/language/glil.scm

   1 ;;; Guile Low Intermediate Language
   2
   3 ;; Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
   4
   5 ;;;; This library is free software; you can redistribute it and/or
   6 ;;;; modify it under the terms of the GNU Lesser General Public
   7 ;;;; License as published by the Free Software Foundation; either
   8 ;;;; version 3 of the License, or (at your option) any later version.
   9 ;;;;
  10 ;;;; This library is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;;;; Lesser General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU Lesser General Public
  16 ;;;; License along with this library; if not, write to the Free Software
  17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 ;;; Code:
  20
  21 (define-module (language glil)
  22   #:use-module (system base syntax)
  23   #:use-module (system base pmatch)
  24   #:use-module ((srfi srfi-1) #:select (fold))
  25   #:export
  26   (<glil-program> make-glil-program glil-program?
  27    glil-program-meta glil-program-body
  28
  29    <glil-std-prelude> make-glil-std-prelude glil-std-prelude?
  30    glil-std-prelude-nreq glil-std-prelude-nlocs glil-std-prelude-else-label
  31
  32    <glil-opt-prelude> make-glil-opt-prelude glil-opt-prelude?
  33    glil-opt-prelude-nreq glil-opt-prelude-nopt glil-opt-prelude-rest
  34    glil-opt-prelude-nlocs glil-opt-prelude-else-label
  35
  36    <glil-kw-prelude> make-glil-kw-prelude glil-kw-prelude?
  37    glil-kw-prelude-nreq glil-kw-prelude-nopt glil-kw-prelude-kw
  38    glil-kw-prelude-allow-other-keys? glil-kw-prelude-rest
  39    glil-kw-prelude-nlocs glil-kw-prelude-else-label
  40
  41    <glil-bind> make-glil-bind glil-bind?
  42    glil-bind-vars
  43
  44    <glil-mv-bind> make-glil-mv-bind glil-mv-bind?
  45    glil-mv-bind-vars glil-mv-bind-rest
  46
  47    <glil-unbind> make-glil-unbind glil-unbind?
  48
  49    <glil-source> make-glil-source glil-source?
  50    glil-source-props
  51
  52    <glil-void> make-glil-void glil-void?
  53
  54    <glil-const> make-glil-const glil-const?
  55    glil-const-obj
  56
  57    <glil-lexical> make-glil-lexical glil-lexical?
  58    glil-lexical-local? glil-lexical-boxed? glil-lexical-op glil-lexical-index
  59
  60    <glil-toplevel> make-glil-toplevel glil-toplevel?
  61    glil-toplevel-op glil-toplevel-name
  62
  63    <glil-module> make-glil-module glil-module?
  64    glil-module-op glil-module-mod glil-module-name glil-module-public?
  65
  66    <glil-label> make-glil-label glil-label?
  67    glil-label-label
  68
  69    <glil-branch> make-glil-branch glil-branch?
  70    glil-branch-inst glil-branch-label
  71
  72    <glil-call> make-glil-call glil-call?
  73    glil-call-inst glil-call-nargs
  74
  75    <glil-mv-call> make-glil-mv-call glil-mv-call?
  76    glil-mv-call-nargs glil-mv-call-ra
  77
  78    <glil-prompt> make-glil-prompt glil-prompt? glil-prompt-label glil-prompt-escape-only?
  79
  80    parse-glil unparse-glil))
  81
  82 (define (print-glil x port)
  83   (format port "#<glil ~s>" (unparse-glil x)))
  84
  85 (define-type (<glil> #:printer print-glil)
  86   ;; Meta operations
  87   (<glil-program> meta body)
  88   (<glil-std-prelude> nreq nlocs else-label)
  89   (<glil-opt-prelude> nreq nopt rest nlocs else-label)
  90   (<glil-kw-prelude> nreq nopt rest kw allow-other-keys? nlocs else-label)
  91   (<glil-bind> vars)
  92   (<glil-mv-bind> vars rest)
  93   (<glil-unbind>)
  94   (<glil-source> props)
  95   ;; Objects
  96   (<glil-void>)
  97   (<glil-const> obj)
  98   ;; Variables
  99   (<glil-lexical> local? boxed? op index)
 100   (<glil-toplevel> op name)
 101   (<glil-module> op mod name public?)
 102   ;; Controls
 103   (<glil-label> label)
 104   (<glil-branch> inst label)
 105   (<glil-call> inst nargs)
 106   (<glil-mv-call> nargs ra)
 107   (<glil-prompt> label escape-only?))
 108
 109 \f
 110
 111 (define (parse-glil x)
 112   (pmatch x
 113     ((program ,meta . ,body)
 114      (make-glil-program meta (map parse-glil body)))
 115     ((std-prelude ,nreq ,nlocs ,else-label)
 116      (make-glil-std-prelude nreq nlocs else-label))
 117     ((opt-prelude ,nreq ,nopt ,rest ,nlocs ,else-label)
 118      (make-glil-opt-prelude nreq nopt rest nlocs else-label))
 119     ((kw-prelude ,nreq ,nopt ,rest ,kw ,allow-other-keys? ,nlocs ,else-label)
 120      (make-glil-kw-prelude nreq nopt rest kw allow-other-keys? nlocs else-label))
 121     ((bind . ,vars) (make-glil-bind vars))
 122     ((mv-bind ,vars ,rest) (make-glil-mv-bind vars rest))
 123     ((unbind) (make-glil-unbind))
 124     ((source ,props) (make-glil-source props))
 125     ((void) (make-glil-void))
 126     ((const ,obj) (make-glil-const obj))
 127     ((lexical ,local? ,boxed? ,op ,index) (make-glil-lexical local? boxed? op index))
 128     ((toplevel ,op ,name) (make-glil-toplevel op name))
 129     ((module public ,op ,mod ,name) (make-glil-module op mod name #t))
 130     ((module private ,op ,mod ,name) (make-glil-module op mod name #f))
 131     ((label ,label) (make-glil-label label))
 132     ((branch ,inst ,label) (make-glil-branch inst label))
 133     ((call ,inst ,nargs) (make-glil-call inst nargs))
 134     ((mv-call ,nargs ,ra) (make-glil-mv-call nargs ra))
 135     ((prompt ,label ,escape-only?)
 136      (make-glil-prompt label escape-only?))
 137     (else (error "invalid glil" x))))
 138
 139 (define (unparse-glil glil)
 140   (record-case glil
 141     ;; meta
 142     ((<glil-program> meta body)
 143      `(program ,meta ,@(map unparse-glil body)))
 144     ((<glil-std-prelude> nreq nlocs else-label)
 145      `(std-prelude ,nreq ,nlocs ,else-label))
 146     ((<glil-opt-prelude> nreq nopt rest nlocs else-label)
 147      `(opt-prelude ,nreq ,nopt ,rest ,nlocs ,else-label))
 148     ((<glil-kw-prelude> nreq nopt rest kw allow-other-keys? nlocs else-label)
 149      `(kw-prelude ,nreq ,nopt ,rest ,kw ,allow-other-keys? ,nlocs ,else-label))
 150     ((<glil-bind> vars) `(bind ,@vars))
 151     ((<glil-mv-bind> vars rest) `(mv-bind ,vars ,rest))
 152     ((<glil-unbind>) `(unbind))
 153     ((<glil-source> props) `(source ,props))
 154     ;; constants
 155     ((<glil-void>) `(void))
 156     ((<glil-const> obj) `(const ,obj))
 157     ;; variables
 158     ((<glil-lexical> local? boxed? op index)
 159      `(lexical ,local? ,boxed? ,op ,index))
 160     ((<glil-toplevel> op name)
 161      `(toplevel ,op ,name))
 162     ((<glil-module> op mod name public?)
 163      `(module ,(if public? 'public 'private) ,op ,mod ,name))
 164     ;; controls
 165     ((<glil-label> label) `(label ,label))
 166     ((<glil-branch> inst label) `(branch ,inst ,label))
 167     ((<glil-call> inst nargs) `(call ,inst ,nargs))
 168     ((<glil-mv-call> nargs ra) `(mv-call ,nargs ,ra))
 169     ((<glil-prompt> label escape-only?)
 170      `(prompt ,label escape-only?))))