module/language/tree-il/canonicalize.scm

   1 ;;; Tree-il canonicalizer
   2
   3 ;; Copyright (C) 2011, 2012, 2013 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 tree-il canonicalize)
  22   #:use-module (language tree-il)
  23   #:use-module (ice-9 match)
  24   #:use-module (srfi srfi-1)
  25   #:export (canonicalize))
  26
  27 (define (tree-il-any proc exp)
  28   (tree-il-fold (lambda (exp res)
  29                   (or res (proc exp)))
  30                 (lambda (exp res) res)
  31                 #f exp))
  32
  33 (define (canonicalize x)
  34   (post-order
  35    (lambda (x)
  36      (match x
  37        (($ <let> src () () () body)
  38         body)
  39        (($ <letrec> src _ () () () body)
  40         body)
  41        (($ <fix> src () () () body)
  42         body)
  43        (($ <lambda> src meta #f)
  44         ;; Give a body to case-lambda with no clauses.
  45         (make-lambda
  46          src meta
  47          (make-lambda-case
  48           #f '() #f #f #f '() '()
  49           (make-primcall
  50            #f
  51            'throw
  52            (list (make-const #f 'wrong-number-of-args)
  53                  (make-const #f #f)
  54                  (make-const #f "Wrong number of arguments")
  55                  (make-const #f '())
  56                  (make-const #f #f)))
  57           #f)))
  58        (($ <prompt> src escape-only? tag body handler)
  59         ;; The prompt handler should be a simple lambda, so that we
  60         ;; can inline it.
  61         (match handler
  62           (($ <lambda> _ _
  63               ($ <lambda-case> _ req #f rest #f () syms body #f))
  64            x)
  65           (else
  66            (let ((handler-sym (gensym))
  67                  (args-sym (gensym)))
  68              (make-let
  69               #f (list 'handler) (list handler-sym) (list handler)
  70               (make-prompt
  71                src escape-only? tag body
  72                (make-lambda
  73                 #f '()
  74                 (make-lambda-case
  75                  #f '() #f 'args #f '() (list args-sym)
  76                  (make-primcall
  77                   #f 'apply
  78                   (list (make-lexical-ref #f 'handler handler-sym)
  79                         (make-lexical-ref #f 'args args-sym)))
  80                  #f))))))))
  81        (_ x)))
  82    x))