module/language/r5rs/translate.scm

   1 ;;; translate.scm --- Scheme to Guile IL translator
   2
   3 ;; Copyright (C) 2001 Free Software Foundation, Inc.
   4
   5 ;; This file is part of Guile VM.
   6
   7 ;; Guile VM is free software; you can redistribute it and/or modify
   8 ;; it under the terms of the GNU General Public License as published by
   9 ;; the Free Software Foundation; either version 2, or (at your option)
  10 ;; any later version.
  11 ;;
  12 ;; Guile VM is distributed in the hope that it will be useful,
  13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;; GNU General Public License for more details.
  16 ;;
  17 ;; You should have received a copy of the GNU General Public License
  18 ;; along with Guile VM; see the file COPYING.  If not, write to
  19 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  20 ;; Boston, MA 02111-1307, USA.
  21
  22 (define-module (language r5rs translate)
  23   :export (translate))
  24
  25 (define (translate x) (trans x))
  26
  27 (define (trans x) (if (pair? x) (trans-pair x) x))
  28
  29 (define *primitive-procedure-list*
  30   '(void car cdr cons + - * / < >))
  31
  32 (define (trans-pair x)
  33   (let ((name (car x)) (args (cdr x)))
  34     (let ((il (case name
  35                 ((quote) (cons '@quote args))
  36                 ((define set! if and or begin)
  37                  (cons (symbol-append '@ name) (map trans args)))
  38                 ((let let* letrec)
  39                  (cons* (symbol-append '@ name)
  40                         (map (lambda (b)
  41                                (cons (car b) (map trans (cdr b))))
  42                              (car args))
  43                         (map trans (cdr args))))
  44                 ((lambda)
  45                  (cons* '@lambda (trans-formals (car args))
  46                         (map trans (cdr args))))
  47                 (else
  48                  (if (memq name *primitive-procedure-list*)
  49                      ;; FIXME: Temporary hack for direct optimization
  50                      (cons (symbol-append '@ name) (map trans args))
  51                      (cons (trans name) (map trans args))))))
  52           (props (source-properties x)))
  53       (if (not (null? props))
  54           (set-source-properties! il props))
  55       il)))
  56
  57 (define (trans-formals formals)
  58   (cond ((symbol? formals) `(:rest ,formals))
  59         ((or (null? formals) (null? (cdr (last-pair formals)))) formals)
  60         (else
  61          (let* ((list (list-copy formals))
  62                 (last (last-pair list)))
  63            (set-cdr! last `(:rest ,(cdr last)))
  64            list))))
  65
  66 ;;; translate.scm ends here