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 pmatch)
  24   :use-module (system base language)
  25   :use-module (system il ghil)
  26   :use-module (ice-9 receive)
  27   :use-module (srfi srfi-39)
  28   :use-module ((system base compile) :select (syntax-error))
  29   :export (translate))
  30
  31
  32 ;; Module in which compile-time code (macros) is evaluated.
  33 (define &compile-time-module (make-parameter #f))
  34
  35 (define (eval-at-compile-time exp)
  36   "Evaluate @var{exp} in the current compile-time module."
  37   (catch #t
  38     (lambda ()
  39       (save-module-excursion
  40        (lambda ()
  41          (eval exp (&compile-time-module)))))
  42     (lambda (key . args)
  43       (syntax-error #f
  44                     (format #f "~a: compile-time evaluation failed" exp)
  45                     (cons key args)))))
  46
  47 (define (translate x e)
  48   (parameterize ((&compile-time-module (make-module)))
  49
  50     ;; Import only core bindings in the macro module.
  51     (module-use! (&compile-time-module) the-root-module)
  52
  53     (call-with-ghil-environment (make-ghil-mod e) '()
  54       (lambda (env vars)
  55         (make-ghil-lambda env #f vars #f (trans env #f x))))))
  56
  57 \f
  58 ;;;
  59 ;;; Macro tricks
  60 ;;;
  61
  62 (define (expand-macro e)
  63   ;; Similar to `macroexpand' in `boot-9.scm' except that it does not expand
  64   ;; `define-macro' and `defmacro'.
  65   (cond
  66    ((pair? e)
  67     (let* ((head (car e))
  68            (val (and (symbol? head)
  69                      (false-if-exception
  70                       (module-ref (&compile-time-module) head)))))
  71       (case head
  72         ((defmacro define-macro)
  73          ;; Normally, these are expanded as `defmacro:transformer' but we
  74          ;; don't want it to happen since they are handled by `trans-pair'.
  75          e)
  76
  77         ((use-syntax)
  78          ;; `use-syntax' is used to express a compile-time dependency
  79          ;; (because we use a macro from that module, or because one of our
  80          ;; macros uses bindings from that module).  Thus, we arrange to get
  81          ;; the current compile-time module to use it.
  82          (let* ((module-name (cadr e))
  83                 (module (false-if-exception (resolve-module module-name))))
  84            (if (module? module)
  85                (let ((public-if (module-public-interface module)))
  86                  (module-use! (&compile-time-module) public-if))
  87                (syntax-error #f "invalid `use-syntax' form" e)))
  88          '(void))
  89
  90         ((begin let let* letrec lambda quote quasiquote if and or
  91                 set! cond case eval-case define do)
  92          ;; All these built-in macros should not be expanded.
  93          e)
  94
  95         (else
  96          ;; Look for a macro.
  97          (let ((ref (false-if-exception
  98                      (module-ref (&compile-time-module) head))))
  99            (if (macro? ref)
 100                (expand-macro
 101                 (save-module-excursion
 102                  (lambda ()
 103                    (let ((transformer (macro-transformer ref))
 104                          (syntax-error syntax-error))
 105                      (set-current-module (&compile-time-module))
 106                      (catch #t
 107                        (lambda ()
 108                          (transformer (copy-tree e) (current-module)))
 109                        (lambda (key . args)
 110                          (syntax-error #f
 111                                        (format #f "~a: macro transformer failed"
 112                                                head)
 113                                        (cons key args))))))))
 114                e))))))
 115
 116    (#t e)))
 117
 118 \f
 119 ;;;
 120 ;;; Translator
 121 ;;;
 122
 123 (define %scheme-primitives
 124   '(not null? eq? eqv? equal? pair? list? cons car cdr set-car! set-cdr!))
 125
 126 (define %forbidden-primitives
 127   ;; Guile's `procedure->macro' family is evil because it crosses the
 128   ;; compilation boundary.  One solution might be to evaluate calls to
 129   ;; `procedure->memoizing-macro' at compilation time, but it may be more
 130   ;; compicated than that.
 131   '(procedure->syntax procedure->macro procedure->memoizing-macro))
 132
 133 (define (trans e l x)
 134   (cond ((pair? x)
 135          (let ((y (expand-macro x)))
 136            (if (eq? x y)
 137                (trans-pair e (or (location x) l) (car x) (cdr x))
 138                (trans e l y))))
 139         ((symbol? x)
 140          (let ((y (symbol-expand x)))
 141            (if (symbol? y)
 142                (make-ghil-ref e l (ghil-lookup e y))
 143                (trans e l y))))
 144         (else (make-ghil-quote e l x))))
 145
 146 (define (symbol-expand x)
 147   (let loop ((s (symbol->string x)))
 148     (let ((i (string-rindex s #\.)))
 149       (if i
 150         (let ((sym (string->symbol (substring s (1+ i)))))
 151           `(slot ,(loop (substring s 0 i)) (quote ,sym)))
 152         (string->symbol s)))))
 153
 154 (define (valid-bindings? bindings . it-is-for-do)
 155   (define (valid-binding? b)
 156     (pmatch b
 157       ((,sym ,var) (guard (symbol? sym)) #t)
 158       ((,sym ,var ,update) (guard (pair? it-is-for-do) (symbol? sym)) #t)
 159       (else #f)))
 160   (and (list? bindings) (and-map valid-binding? bindings)))
 161
 162 (define (trans-pair e l head tail)
 163   (define (trans:x x) (trans e l x))
 164   (define (trans:pair x) (trans-pair e l (car x) (cdr x)))
 165   (define (trans:body body) (trans-body e l body))
 166   (define (make:void) (make-ghil-void e l))
 167   (define (bad-syntax)
 168     (syntax-error l (format #f "bad ~A" head) (cons head tail)))
 169   ;; have to use a case first, because pmatch treats e.g. (quote foo)
 170   ;; and (unquote foo) specially
 171   (case head
 172     ;; (void)
 173     ((void)
 174      (pmatch tail
 175        (() (make:void))
 176        (else (bad-syntax))))
 177
 178     ;; (quote OBJ)
 179     ((quote)
 180      (pmatch tail
 181        ((,obj) (make-ghil-quote e l obj))
 182        (else (bad-syntax))))
 183
 184     ;; (quasiquote OBJ)
 185     ((quasiquote)
 186      (pmatch tail
 187        ((,obj) (make-ghil-quasiquote e l (trans-quasiquote e l obj)))
 188        (else (bad-syntax))))
 189
 190     ((define)
 191      (pmatch tail
 192        ;; (define NAME VAL)
 193        ((,name ,val) (guard (symbol? name))
 194         (make-ghil-define e l (ghil-lookup e name) (trans:x val)))
 195
 196        ;; (define (NAME FORMALS...) BODY...)
 197        (((,name . ,formals) . ,body) (guard (symbol? name))
 198         ;; -> (define NAME (lambda FORMALS BODY...))
 199         (let ((val (trans:x `(lambda ,formals ,@body))))
 200           (make-ghil-define e l (ghil-lookup e name) val)))
 201
 202        (else (bad-syntax))))
 203
 204     ;; simple macros
 205     ((defmacro define-macro)
 206      ;; Evaluate the macro definition in the current compile-time module.
 207      (eval-at-compile-time (cons head tail))
 208
 209      ;; FIXME: We need to evaluate them in the runtime module as well.
 210      (make:void))
 211
 212     ((set!)
 213      (pmatch tail
 214        ;; (set! NAME VAL)
 215        ((,name ,val) (guard (symbol? name))
 216         (make-ghil-set e l (ghil-lookup e name) (trans:x val)))
 217
 218        ;; (set! (NAME ARGS...) VAL)
 219        (((,name . ,args) ,val) (guard (symbol? name))
 220         ;; -> ((setter NAME) ARGS... VAL)
 221         (trans:pair `((setter ,name) . (,@args ,val))))
 222
 223        (else (bad-syntax))))
 224
 225     ;; (if TEST THEN [ELSE])
 226     ((if)
 227      (pmatch tail
 228        ((,test ,then)
 229         (make-ghil-if e l (trans:x test) (trans:x then) (make:void)))
 230        ((,test ,then ,else)
 231         (make-ghil-if e l (trans:x test) (trans:x then) (trans:x else)))
 232        (else (bad-syntax))))
 233
 234     ;; (and EXPS...)
 235     ((and)
 236      (make-ghil-and e l (map trans:x tail)))
 237
 238     ;; (or EXPS...)
 239     ((or)
 240      (make-ghil-or e l (map trans:x tail)))
 241
 242     ;; (begin EXPS...)
 243     ((begin)
 244      (make-ghil-begin e l (map trans:x tail)))
 245
 246     ((let)
 247      (pmatch tail
 248        ;; (let NAME ((SYM VAL) ...) BODY...)
 249        ((,name ,bindings . ,body) (guard (symbol? name)
 250                                          (valid-bindings? bindings))
 251         ;; -> (letrec ((NAME (lambda (SYM...) BODY...))) (NAME VAL...))
 252         (trans:pair `(letrec ((,name (lambda ,(map car bindings) ,@body)))
 253                        (,name ,@(map cadr bindings)))))
 254
 255        ;; (let () BODY...)
 256        ((() . ,body)
 257         ;; Note: this differs from `begin'
 258         (make-ghil-begin e l (list (trans:body body))))
 259
 260        ;; (let ((SYM VAL) ...) BODY...)
 261        ((,bindings . ,body) (guard (valid-bindings? bindings))
 262         (let ((vals (map trans:x (map cadr bindings))))
 263           (call-with-ghil-bindings e (map car bindings)
 264             (lambda (vars)
 265               (make-ghil-bind e l vars vals (trans:body body))))))
 266        (else (bad-syntax))))
 267
 268     ;; (let* ((SYM VAL) ...) BODY...)
 269     ((let*)
 270      (pmatch tail
 271        ((() . ,body)
 272         (trans:pair `(let () ,@body)))
 273        ((((,sym ,val) . ,rest) . ,body) (guard (symbol? sym))
 274         (trans:pair `(let ((,sym ,val)) (let* ,rest ,@body))))
 275        (else (bad-syntax))))
 276
 277     ;; (letrec ((SYM VAL) ...) BODY...)
 278     ((letrec)
 279      (pmatch tail
 280        ((,bindings . ,body) (guard (valid-bindings? bindings))
 281         (call-with-ghil-bindings e (map car bindings)
 282           (lambda (vars)
 283             (let ((vals (map trans:x (map cadr bindings))))
 284               (make-ghil-bind e l vars vals (trans:body body))))))
 285        (else (bad-syntax))))
 286
 287     ;; (cond (CLAUSE BODY...) ...)
 288     ((cond)
 289      (pmatch tail
 290        (() (make:void))
 291        (((else . ,body)) (trans:body body))
 292        (((,test) . ,rest) (trans:pair `(or ,test (cond ,@rest))))
 293        (((,test => ,proc) . ,rest)
 294         ;; FIXME hygiene!
 295         (trans:pair `(let ((_t ,test)) (if _t (,proc _t) (cond ,@rest)))))
 296        (((,test . ,body) . ,rest)
 297         (trans:pair `(if ,test (begin ,@body) (cond ,@rest))))
 298        (else (bad-syntax))))
 299
 300     ;; (case EXP ((KEY...) BODY...) ...)
 301     ((case)
 302      (pmatch tail
 303        ((,exp . ,clauses)
 304         (trans:pair
 305          ;; FIXME hygiene!
 306          `(let ((_t ,exp))
 307             ,(let loop ((ls clauses))
 308                (cond ((null? ls) '(void))
 309                      ((eq? (caar ls) 'else) `(begin ,@(cdar ls)))
 310                      (else `(if (memv _t ',(caar ls))
 311                                 (begin ,@(cdar ls))
 312                                 ,(loop (cdr ls)))))))))
 313        (else (bad-syntax))))
 314
 315     ;; (do ((SYM VAL [UPDATE]) ...) (TEST RESULT...) BODY...)
 316     ((do)
 317      (pmatch tail
 318        ((,bindings (,test . ,result) . ,body)
 319         (let ((sym (map car bindings))
 320               (val (map cadr bindings))
 321               (update (map cddr bindings)))
 322           (define (next s x) (if (pair? x) (car x) s))
 323           (trans:pair
 324            ;; FIXME hygiene!
 325            `(letrec ((_l (lambda ,sym
 326                            (if ,test
 327                                (let () (void) ,@result)
 328                                (let () (void) ,@body
 329                                     (_l ,@(map next sym update)))))))
 330               (_l ,@val)))))
 331        (else (bad-syntax))))
 332
 333     ;; (lambda FORMALS BODY...)
 334     ((lambda)
 335      (pmatch tail
 336        ((,formals . ,body)
 337         (receive (syms rest) (parse-formals formals)
 338           (call-with-ghil-environment e syms
 339          (lambda (env vars)
 340               (make-ghil-lambda env l vars rest (trans-body env l body))))))
 341        (else (bad-syntax))))
 342
 343     ((eval-case)
 344      (let loop ((x tail))
 345        (pmatch x
 346          (() (make:void))
 347          (((else . ,body)) (trans:pair `(begin ,@body)))
 348          (((,keys . ,body) . ,rest) (guard (list? keys) (and-map symbol? keys))
 349           (if (memq 'load-toplevel keys)
 350               (begin
 351                 (primitive-eval `(begin ,@(copy-tree body)))
 352                 (trans:pair `(begin ,@body)))
 353               (loop rest)))
 354          (else (bad-syntax)))))
 355
 356     (else
 357      (if (memq head %scheme-primitives)
 358          (make-ghil-inline e l head (map trans:x tail))
 359          (if (memq head %forbidden-primitives)
 360              (syntax-error l (format #f "`~a' is forbidden" head)
 361                            (cons head tail))
 362              (make-ghil-call e l (trans:x head) (map trans:x tail)))))))
 363
 364 (define (trans-quasiquote e l x)
 365   (cond ((not (pair? x)) x)
 366         ((memq (car x) '(unquote unquote-splicing))
 367          (let ((l (location x)))
 368            (pmatch (cdr x)
 369              ((,obj)
 370               (if (eq? (car x) 'unquote)
 371                   (make-ghil-unquote e l (trans e l obj))
 372                   (make-ghil-unquote-splicing e l (trans e l obj))))
 373              (else (syntax-error l (format #f "bad ~A" (car x)) x)))))
 374         (else (cons (trans-quasiquote e l (car x))
 375                     (trans-quasiquote e l (cdr x))))))
 376
 377 (define (trans-body e l body)
 378   (define (define->binding df)
 379     (pmatch (cdr df)
 380       ((,name ,val) (guard (symbol? name)) (list name val))
 381       (((,name . ,formals) . ,body) (guard (symbol? name))
 382        (list name `(lambda ,formals ,@body)))
 383       (else (syntax-error (location df) "bad define" df))))
 384   ;; main
 385   (let loop ((ls body) (ds '()))
 386     (pmatch ls
 387       (() (syntax-error l "bad body" body))
 388       (((define . _) . _)
 389        (loop (cdr ls) (cons (car ls) ds)))
 390       (else
 391        (if (null? ds)
 392            (trans-pair e l 'begin ls)
 393            (trans-pair e l 'letrec (cons (map define->binding ds) ls)))))))
 394
 395 (define (parse-formals formals)
 396   (cond
 397    ;; (lambda x ...)
 398    ((symbol? formals) (values (list formals) #t))
 399    ;; (lambda (x y z) ...)
 400    ((list? formals) (values formals #f))
 401    ;; (lambda (x y . z) ...)
 402    ((pair? formals)
 403     (let loop ((l formals) (v '()))
 404       (if (pair? l)
 405           (loop (cdr l) (cons (car l) v))
 406           (values (reverse! (cons l v)) #t))))
 407    (else (syntax-error (location formals) "bad formals" formals))))
 408
 409 (define (location x)
 410   (and (pair? x)
 411        (let ((props (source-properties x)))
 412          (and (not (null? props))
 413               (cons (assq-ref props 'line) (assq-ref props 'column))))))