module/language/scheme/translate.scm

   1 ;;; Guile Scheme specification
   2
   3 ;; Copyright (C) 2001 Free Software Foundation, Inc.
   4
   5 ;; This program is free software; you can redistribute it and/or modify
   6 ;; it under the terms of the GNU General Public License as published by
   7 ;; the Free Software Foundation; either version 2, or (at your option)
   8 ;; any later version.
   9 ;;
  10 ;; This program 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
  13 ;; GNU General Public License for more details.
  14 ;;
  15 ;; You should have received a copy of the GNU General Public License
  16 ;; along with this program; see the file COPYING.  If not, write to
  17 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  18 ;; Boston, MA 02111-1307, USA.
  19
  20 ;;; Code:
  21
  22 (define-module (language scheme translate)
  23   :use-module (system base language)
  24   :use-module (system il ghil)
  25   :use-module (ice-9 match)
  26   :use-module (ice-9 receive)
  27   :export (translate))
  28
  29 (define (translate x e)
  30   (call-with-ghil-environment (make-ghil-mod e) '()
  31     (lambda (env vars)
  32       (make-<ghil-lambda> env #f vars 0 (trans env #f x)))))
  33
  34 \f
  35 ;;;
  36 ;;; Translator
  37 ;;;
  38
  39 (define (trans e l x)
  40   (cond ((pair? x)
  41          (let ((y (macroexpand x)))
  42            (if (eq? x y)
  43                (trans-pair e (or (location x) l) (car x) (cdr x))
  44                (trans e l y))))
  45         ((symbol? x) (make-<ghil-ref> e l (ghil-lookup e x)))
  46         (else (make-<ghil-quote> e l x))))
  47
  48 (define (trans-pair e l head tail)
  49   (define (trans:x x) (trans e l x))
  50   (define (trans:pair x) (trans-pair e l (car x) (cdr x)))
  51   (define (trans:body body) (trans-body e l body))
  52   (define (make:void) (make-<ghil-void> e l))
  53   (define (bad-syntax)
  54     (syntax-error l (format #f "bad ~A" head) (cons head tail)))
  55   (case head
  56     ;; (void)
  57     ((void)
  58      (match tail
  59        (() (make:void))
  60        (else (bad-syntax))))
  61
  62     ;; (quote OBJ)
  63     ((quote)
  64      (match tail
  65        ((obj) (make-<ghil-quote> e l obj))
  66        (else (bad-syntax))))
  67
  68     ;; (quasiquote OBJ)
  69     ((quasiquote)
  70      (match tail
  71        ((obj) (make-<ghil-quasiquote> e l (trans-quasiquote e l obj)))
  72        (else (bad-syntax))))
  73
  74     ((define define-private)
  75      (match tail
  76        ;; (define NAME VAL)
  77        (((? symbol? name) val)
  78         (make-<ghil-define> e l (ghil-lookup e name) (trans:x val)))
  79
  80        ;; (define (NAME FORMALS...) BODY...)
  81        ((((? symbol? name) . formals) . body)
  82         ;; -> (define NAME (lambda FORMALS BODY...))
  83         (let ((val (trans:x `(lambda ,formals ,@body))))
  84           (make-<ghil-define> e l (ghil-lookup e name) val)))
  85
  86        (else (bad-syntax))))
  87
  88     ((set!)
  89      (match tail
  90        ;; (set! NAME VAL)
  91        (((? symbol? name) val)
  92         (make-<ghil-set> e l (ghil-lookup e name) (trans:x val)))
  93
  94        ;; (set! (NAME ARGS...) VAL)
  95        ((((? symbol? name) . args) val)
  96         ;; -> ((setter NAME) ARGS... VAL)
  97         (trans:pair `((setter ,name) (,@args ,val))))
  98
  99        (else (bad-syntax))))
 100
 101     ;; (if TEST THEN [ELSE])
 102     ((if)
 103      (match tail
 104        ((test then)
 105         (make-<ghil-if> e l (trans:x test) (trans:x then) (make:void)))
 106        ((test then else)
 107         (make-<ghil-if> e l (trans:x test) (trans:x then) (trans:x else)))
 108        (else (bad-syntax))))
 109
 110     ;; (and EXPS...)
 111     ((and)
 112      (make-<ghil-and> e l (map trans:x tail)))
 113
 114     ;; (or EXPS...)
 115     ((or)
 116      (make-<ghil-or> e l (map trans:x tail)))
 117
 118     ;; (begin EXPS...)
 119     ((begin)
 120      (make-<ghil-begin> e l (map trans:x tail)))
 121
 122     ((let)
 123      (match tail
 124        ;; (let NAME ((SYM VAL) ...) BODY...)
 125        (((? symbol? name) (((? symbol? sym) val) ...) body ...)
 126         ;; -> (letrec ((NAME (lambda (SYM...) BODY...))) (NAME VAL...))
 127         (trans:pair `(letrec ((,name (lambda ,sym ,@body))) (,name ,@val))))
 128
 129        ;; (let () BODY...)
 130        ((() body ...)
 131         ;; NOTE: This differs from `begin'
 132         (make-<ghil-begin> e l (list (trans:body body))))
 133
 134        ;; (let ((SYM VAL) ...) BODY...)
 135        (((((? symbol? sym) val) ...) body ...)
 136         (let ((vals (map trans:x val)))
 137           (call-with-ghil-bindings e sym
 138             (lambda (vars)
 139               (make-<ghil-bind> e l vars vals (trans:body body))))))
 140
 141        (else (bad-syntax))))
 142
 143     ;; (let* ((SYM VAL) ...) BODY...)
 144     ((let*)
 145      (match tail
 146        (((def ...) body ...)
 147         (if (null? def)
 148             (trans:pair `(let () ,@body))
 149             (trans:pair `(let (,(car def)) (let* ,(cdr def) ,@body)))))
 150        (else (bad-syntax))))
 151
 152     ;; (letrec ((SYM VAL) ...) BODY...)
 153     ((letrec)
 154      (match tail
 155        (((((? symbol? sym) val) ...) body ...)
 156         (call-with-ghil-bindings e sym
 157           (lambda (vars)
 158             (let ((vals (map trans:x val)))
 159               (make-<ghil-bind> e l vars vals (trans:body body))))))
 160        (else (bad-syntax))))
 161
 162     ;; (cond (CLAUSE BODY...) ...)
 163     ((cond)
 164      (match tail
 165        (() (make:void))
 166        ((('else . body)) (trans:body body))
 167        (((test) . rest) (trans:pair `(or ,test (cond ,@rest))))
 168        (((test '=> proc) . rest)
 169         (trans:pair `(let ((_t ,test)) (if _t (,proc _t) (cond ,@rest)))))
 170        (((test . body) . rest)
 171         (trans:pair `(if ,test (begin ,@body) (cond ,@rest))))
 172        (else (bad-syntax))))
 173
 174     ;; (case EXP ((KEY...) BODY...) ...)
 175     ((case)
 176      (match tail
 177        ((exp . clauses)
 178         (trans:pair
 179          `(let ((_t ,exp))
 180             ,(let loop ((ls clauses))
 181                (cond ((null? ls) '(void))
 182                      ((eq? (caar ls) 'else) `(begin ,@(cdar ls)))
 183                      (else `(if (memv _t ',(caar ls))
 184                                 (begin ,@(cdar ls))
 185                                 ,(loop (cdr ls)))))))))
 186        (else (bad-syntax))))
 187
 188     ;; (do ((SYM VAL [UPDATE]) ...) (TEST RESULT...) BODY...)
 189     ((do)
 190      (let ()
 191        (define (next s x) (if (pair? x) (car x) s))
 192        (match tail
 193          ((((sym init . update) ...) (test . result) body ...)
 194           (trans:pair
 195            `(letrec ((_l (lambda ,sym
 196                            (if ,test
 197                                (let () (void) ,@result)
 198                                (let () (void) ,@body
 199                                     (_l ,@(map next sym update)))))))
 200               (_l ,@init))))
 201          (else (bad-syntax)))))
 202
 203     ;; (lambda FORMALS BODY...)
 204     ((lambda)
 205      (match tail
 206        ((formals body ...)
 207         (receive (syms rest) (parse-formals formals)
 208           (call-with-ghil-environment e syms
 209             (lambda (env vars)
 210               (make-<ghil-lambda> env l vars rest (trans-body env l body))))))
 211        (else (bad-syntax))))
 212
 213     ((eval-case)
 214      (let loop ((x tail))
 215        (match x
 216          (() (make:void))
 217          ((('else . body)) (trans:pair `(begin ,@body)))
 218          (((((? symbol? key) ...) body ...) rest ...)
 219           (if (memq 'compile key)
 220               (primitive-eval `(begin ,@(copy-tree body))))
 221           (if (memq 'load-toplevel key)
 222               (trans:pair `(begin ,@body))
 223               (loop rest)))
 224          (else (bad-syntax)))))
 225
 226     (else
 227      (make-<ghil-call> e l (trans:x head) (map trans:x tail)))))
 228
 229 (define (trans-quasiquote e l x)
 230   (cond ((not (pair? x)) x)
 231         ((memq (car x) '(unquote unquote-splicing))
 232          (let ((l (location x)))
 233            (match (cdr x)
 234              ((obj)
 235               (if (eq? (car x) 'unquote)
 236                   (make-<ghil-unquote> e l (trans e l obj))
 237                   (make-<ghil-unquote-splicing> e l (trans e l obj))))
 238              (else (syntax-error l (format #f "bad ~A" (car x)) x)))))
 239         (else (cons (trans-quasiquote e l (car x))
 240                     (trans-quasiquote e l (cdr x))))))
 241
 242 (define (trans-body e l body)
 243   (define (define->binding df)
 244     (match (cdr df)
 245       (((? symbol? name) val) (list name val))
 246       ((((? symbol? name) . formals) . body)
 247        (list name `(lambda ,formals ,@body)))
 248       (else (syntax-error (location df) "bad define" df))))
 249   ;; main
 250   (let loop ((ls body) (ds '()))
 251     (cond ((null? ls) (syntax-error l "bad body" body))
 252           ((and (pair? (car ls)) (eq? (caar ls) 'define))
 253            (loop (cdr ls) (cons (car ls) ds)))
 254           (else
 255            (if (null? ds)
 256                (trans-pair e l 'begin ls)
 257                (trans-pair e l 'letrec (cons (map define->binding ds) ls)))))))
 258
 259 (define (parse-formals formals)
 260   (cond
 261    ;; (lambda x ...)
 262    ((symbol? formals) (values (list formals) #t))
 263    ;; (lambda (x y z) ...)
 264    ((list? formals) (values formals #f))
 265    ;; (lambda (x y . z) ...)
 266    ((pair? formals)
 267     (let loop ((l formals) (v '()))
 268       (if (pair? l)
 269           (loop (cdr l) (cons (car l) v))
 270           (values (reverse! (cons l v)) #t))))
 271    (else (syntax-error (location formals) "bad formals" formals))))
 272
 273 (define (location x)
 274   (and (pair? x)
 275        (let ((props (source-properties x)))
 276          (and (not (null? props))
 277               (cons (assq-ref props 'line) (assq-ref props 'column))))))