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 (system il inline)
  27   #:use-module (ice-9 receive)
  28   #:use-module ((ice-9 syncase) #:select (sc-macro))
  29   #:use-module ((system base compile) #:select (syntax-error))
  30   #:export (translate))
  31
  32
  33 (define (translate x e)
  34   (call-with-ghil-environment (make-ghil-toplevel-env) '()
  35     (lambda (env vars)
  36       (make-ghil-lambda env #f vars #f '() (trans env (location x) x)))))
  37
  38 \f
  39 ;;;
  40 ;;; Translator
  41 ;;;
  42
  43 (define *forbidden-primitives*
  44   ;; Guile's `procedure->macro' family is evil because it crosses the
  45   ;; compilation boundary.  One solution might be to evaluate calls to
  46   ;; `procedure->memoizing-macro' at compilation time, but it may be more
  47   ;; compicated than that.
  48   '(procedure->syntax procedure->macro))
  49
  50 ;; Looks up transformers relative to the current module at
  51 ;; compilation-time. See also the discussion of ghil-lookup in ghil.scm.
  52 (define (lookup-transformer head retrans)
  53   (let* ((mod (current-module))
  54          (val (and (symbol? head)
  55                    (and=> (module-variable mod head)
  56                           (lambda (var)
  57                             ;; unbound vars can happen if the module
  58                             ;; definition forward-declared them
  59                             (and (variable-bound? var) (variable-ref var)))))))
  60     (cond
  61      ((assq-ref custom-transformer-table val))
  62
  63      ((defmacro? val)
  64       (lambda (env loc exp)
  65         (retrans (apply (defmacro-transformer val) (cdr exp)))))
  66
  67      ((eq? val sc-macro)
  68       ;; syncase!
  69       (let* ((the-syncase-module (resolve-module '(ice-9 syncase)))
  70              (eec (module-ref the-syncase-module 'expansion-eval-closure))
  71              (sc-expand3 (module-ref the-syncase-module 'sc-expand3)))
  72         (lambda (env loc exp)
  73           (retrans
  74            (with-fluids ((eec (module-eval-closure mod)))
  75              (sc-expand3 exp 'c '(compile load eval)))))))
  76
  77      ((primitive-macro? val)
  78       (syntax-error #f "unhandled primitive macro" head))
  79
  80      ((macro? val)
  81       (syntax-error #f "unknown kind of macro" head))
  82
  83      (else #f))))
  84
  85 (define (trans e l x)
  86   (define (retrans x) (trans e (location x) x))
  87   (cond ((pair? x)
  88          (let ((head (car x)) (tail (cdr x)))
  89            (cond
  90             ((lookup-transformer head retrans)
  91              => (lambda (t) (t e l x)))
  92
  93             ;; FIXME: lexical/module overrides of forbidden primitives
  94             ((memq head *forbidden-primitives*)
  95              (syntax-error l (format #f "`~a' is forbidden" head)
  96                            (cons head tail)))
  97
  98             (else
  99              (let ((tail (map retrans tail)))
 100                (or (and (symbol? head)
 101                         (try-inline-with-env e l (cons head tail)))
 102                    (make-ghil-call e l (retrans head) tail)))))))
 103
 104         ((symbol? x)
 105          (make-ghil-ref e l (ghil-lookup e x)))
 106
 107         ;; fixme: non-self-quoting objects like #<foo>
 108         (else
 109          (make-ghil-quote e l #:obj x))))
 110
 111 (define (valid-bindings? bindings . it-is-for-do)
 112   (define (valid-binding? b)
 113     (pmatch b
 114       ((,sym ,var) (guard (symbol? sym)) #t)
 115       ((,sym ,var ,update) (guard (pair? it-is-for-do) (symbol? sym)) #t)
 116       (else #f)))
 117   (and (list? bindings) (and-map valid-binding? bindings)))
 118
 119 (define-macro (make-pmatch-transformers env loc retranslate . body)
 120   (define exp (gensym))
 121   (define (make1 clause)
 122     (let ((sym (car clause))
 123           (clauses (cdr clause)))
 124       `(cons ,sym
 125              (lambda (,env ,loc ,exp)
 126                (define (,retranslate x) (trans ,env (location x) x))
 127                (pmatch (cdr ,exp)
 128                 ,@clauses
 129                 (else (syntax-error ,loc (format #f "bad ~A" ',sym) ,exp)))))))
 130   `(list ,@(map make1 body)))
 131
 132 (define *the-compile-toplevel-symbol* 'compile-toplevel)
 133
 134 (define custom-transformer-table
 135   (make-pmatch-transformers
 136    e l retrans
 137    (quote
 138     ;; (quote OBJ)
 139     ((,obj) (make-ghil-quote e l obj)))
 140
 141    (quasiquote
 142     ;; (quasiquote OBJ)
 143     ((,obj) (make-ghil-quasiquote e l (trans-quasiquote e l obj 0))))
 144
 145    (define
 146     ;; (define NAME VAL)
 147     ((,name ,val) (guard (symbol? name)
 148                          (ghil-toplevel-env? (ghil-env-parent e)))
 149      (make-ghil-define e l (ghil-define (ghil-env-parent e) name)
 150                        (maybe-name-value! (retrans val) name)))
 151     ;; (define (NAME FORMALS...) BODY...)
 152     (((,name . ,formals) . ,body) (guard (symbol? name))
 153      ;; -> (define NAME (lambda FORMALS BODY...))
 154      (retrans `(define ,name (lambda ,formals ,@body)))))
 155
 156    (set!
 157     ;; (set! NAME VAL)
 158     ((,name ,val) (guard (symbol? name))
 159      (make-ghil-set e l (ghil-lookup e name) (retrans val)))
 160
 161     ;; (set! (NAME ARGS...) VAL)
 162     (((,name . ,args) ,val) (guard (symbol? name))
 163      ;; -> ((setter NAME) ARGS... VAL)
 164      (retrans `((setter ,name) . (,@args ,val)))))
 165
 166    (if
 167     ;; (if TEST THEN [ELSE])
 168     ((,test ,then)
 169      (make-ghil-if e l (retrans test) (retrans then) (retrans '(begin))))
 170     ((,test ,then ,else)
 171      (make-ghil-if e l (retrans test) (retrans then) (retrans else))))
 172
 173    (and
 174     ;; (and EXPS...)
 175     (,tail (make-ghil-and e l (map retrans tail))))
 176
 177    (or
 178     ;; (or EXPS...)
 179     (,tail (make-ghil-or e l (map retrans tail))))
 180
 181    (begin
 182      ;; (begin EXPS...)
 183      (,tail (make-ghil-begin e l (map retrans tail))))
 184
 185    (let
 186     ;; (let NAME ((SYM VAL) ...) BODY...)
 187     ((,name ,bindings . ,body) (guard (symbol? name)
 188                                       (valid-bindings? bindings))
 189      ;; -> (letrec ((NAME (lambda (SYM...) BODY...))) (NAME VAL...))
 190      (retrans `(letrec ((,name (lambda ,(map car bindings) ,@body)))
 191                  (,name ,@(map cadr bindings)))))
 192
 193     ;; (let () BODY...)
 194     ((() . ,body)
 195      ;; Note: this differs from `begin'
 196      (make-ghil-begin e l (list (trans-body e l body))))
 197
 198     ;; (let ((SYM VAL) ...) BODY...)
 199     ((,bindings . ,body) (guard (valid-bindings? bindings))
 200      (let ((vals (map retrans (map cadr bindings))))
 201        (call-with-ghil-bindings e (map car bindings)
 202          (lambda (vars)
 203            (make-ghil-bind e l vars vals (trans-body e l body)))))))
 204
 205    (let*
 206     ;; (let* ((SYM VAL) ...) BODY...)
 207     ((() . ,body)
 208      (retrans `(let () ,@body)))
 209     ((((,sym ,val) . ,rest) . ,body) (guard (symbol? sym))
 210      (retrans `(let ((,sym ,val)) (let* ,rest ,@body)))))
 211
 212    (letrec
 213     ;; (letrec ((SYM VAL) ...) BODY...)
 214     ((,bindings . ,body) (guard (valid-bindings? bindings))
 215      (call-with-ghil-bindings e (map car bindings)
 216         (lambda (vars)
 217           (let ((vals (map retrans (map cadr bindings))))
 218             (make-ghil-bind e l vars vals (trans-body e l body)))))))
 219
 220    (cond
 221     ;; (cond (CLAUSE BODY...) ...)
 222     (() (retrans '(begin)))
 223     (((else . ,body)) (retrans `(begin ,@body)))
 224     (((,test) . ,rest) (retrans `(or ,test (cond ,@rest))))
 225     (((,test => ,proc) . ,rest)
 226      ;; FIXME hygiene!
 227      (retrans `(let ((_t ,test)) (if _t (,proc _t) (cond ,@rest)))))
 228     (((,test . ,body) . ,rest)
 229      (retrans `(if ,test (begin ,@body) (cond ,@rest)))))
 230
 231    (case
 232     ;; (case EXP ((KEY...) BODY...) ...)
 233     ((,exp . ,clauses)
 234      (retrans
 235       ;; FIXME hygiene!
 236       `(let ((_t ,exp))
 237          ,(let loop ((ls clauses))
 238             (cond ((null? ls) '(begin))
 239                   ((eq? (caar ls) 'else) `(begin ,@(cdar ls)))
 240                   (else `(if (memv _t ',(caar ls))
 241                              (begin ,@(cdar ls))
 242                              ,(loop (cdr ls))))))))))
 243
 244     (do
 245      ;; (do ((SYM VAL [UPDATE]) ...) (TEST RESULT...) BODY...)
 246      ((,bindings (,test . ,result) . ,body)
 247       (let ((sym (map car bindings))
 248             (val (map cadr bindings))
 249             (update (map cddr bindings)))
 250         (define (next s x) (if (pair? x) (car x) s))
 251         (retrans
 252          ;; FIXME hygiene!
 253          `(letrec ((_l (lambda ,sym
 254                          (if ,test
 255                              (begin ,@result)
 256                              (begin ,@body
 257                                     (_l ,@(map next sym update)))))))
 258             (_l ,@val))))))
 259
 260     (lambda
 261      ;; (lambda FORMALS BODY...)
 262      ((,formals . ,body)
 263       (receive (syms rest) (parse-formals formals)
 264         (call-with-ghil-environment e syms
 265           (lambda (env vars)
 266             (receive (meta body) (parse-lambda-meta body)
 267               (make-ghil-lambda env l vars rest meta
 268                                 (trans-body env l body))))))))
 269
 270     ;; FIXME not hygienic
 271     (delay
 272      ((,expr)
 273       (retrans `(make-promise (lambda () ,expr)))))
 274
 275     (eval-case
 276      (,clauses
 277       (retrans
 278        `(begin
 279           ;; Compilation of toplevel units is always wrapped in a lambda
 280           ,@(let ((toplevel? (ghil-toplevel-env? (ghil-env-parent e))))
 281               (let loop ((seen '()) (in clauses) (runtime '()))
 282                 (cond
 283                  ((null? in) runtime)
 284                  (else
 285                   (pmatch (car in)
 286                    ((else . ,body)
 287                     (if (and toplevel? (not (memq *the-compile-toplevel-symbol* seen)))
 288                         (primitive-eval `(begin ,@body)))
 289                     (if (memq (if toplevel? *the-compile-toplevel-symbol* 'evaluate) seen)
 290                         runtime
 291                         body))
 292                    ((,keys . ,body) (guard (list? keys) (and-map symbol? keys))
 293                     (for-each (lambda (k)
 294                                 (if (memq k seen)
 295                                     (syntax-error l "eval-case condition seen twice" k)))
 296                               keys)
 297                     (if (and toplevel? (memq *the-compile-toplevel-symbol* keys))
 298                         (primitive-eval `(begin ,@body)))
 299                     (loop (append keys seen)
 300                           (cdr in)
 301                           (if (memq (if toplevel? 'load-toplevel 'evaluate) keys)
 302                               (append runtime body)
 303                               runtime)))
 304                    (else (syntax-error l "bad eval-case clause" (car in))))))))))))
 305
 306     ;; FIXME: not hygienic, relies on @apply not being shadowed
 307     (apply
 308      (,args (retrans `(@apply ,@args))))
 309
 310     (@apply
 311      ((,proc ,arg1 . ,args)
 312       (let ((args (cons (retrans arg1) (map retrans args))))
 313         (cond ((and (symbol? proc)
 314                     (not (ghil-lookup e proc #f))
 315                     (and=> (module-variable (current-module) proc)
 316                            (lambda (var)
 317                              (and (variable-bound? var)
 318                                   (lookup-apply-transformer (variable-ref var))))))
 319                ;; that is, a variable, not part of this compilation
 320                ;; unit, but defined in the toplevel environment, and has
 321                ;; an apply transformer registered
 322                => (lambda (t) (t e l args)))
 323               (else (make-ghil-inline e l 'apply
 324                                       (cons (retrans proc) args)))))))
 325
 326     ;; FIXME: not hygienic, relies on @call-with-values not being shadowed
 327     (call-with-values
 328      ((,producer ,consumer)
 329       (retrans `(@call-with-values ,producer ,consumer)))
 330      (else #f))
 331
 332     (@call-with-values
 333      ((,producer ,consumer)
 334       (make-ghil-mv-call e l (retrans producer) (retrans consumer))))
 335
 336     ;; FIXME: not hygienic, relies on @call-with-current-continuation
 337     ;; not being shadowed
 338     (call-with-current-continuation
 339      ((,proc)
 340       (retrans `(@call-with-current-continuation ,proc)))
 341      (else #f))
 342
 343     (@call-with-current-continuation
 344      ((,proc)
 345       (make-ghil-inline e l 'call/cc (list (retrans proc)))))
 346
 347     (receive
 348      ((,formals ,producer-exp . ,body)
 349       ;; Lovely, self-referential usage. Not strictly necessary, the
 350       ;; macro would do the trick; but it's good to test the mv-bind
 351       ;; code.
 352       (receive (syms rest) (parse-formals formals)
 353         (call-with-ghil-bindings e syms
 354           (lambda (vars)
 355             (make-ghil-mv-bind e l (retrans `(lambda () ,producer-exp))
 356                                vars rest (trans-body e l body)))))))
 357
 358     (values
 359      ((,x) (retrans x))
 360      (,args (make-ghil-values e l (map retrans args))))))
 361
 362 (define (lookup-apply-transformer proc)
 363   (cond ((eq? proc values)
 364          (lambda (e l args)
 365            (make-ghil-values* e l args)))
 366         (else #f)))
 367
 368 (define (trans-quasiquote e l x level)
 369   (cond ((not (pair? x)) x)
 370         ((memq (car x) '(unquote unquote-splicing))
 371          (let ((l (location x)))
 372            (pmatch (cdr x)
 373              ((,obj)
 374               (cond
 375                ((zero? level)
 376                 (if (eq? (car x) 'unquote)
 377                     (make-ghil-unquote e l (trans e l obj))
 378                     (make-ghil-unquote-splicing e l (trans e l obj))))
 379                (else
 380                 (list (car x) (trans-quasiquote e l obj (1- level))))))
 381              (else (syntax-error l (format #f "bad ~A" (car x)) x)))))
 382         ((eq? (car x) 'quasiquote)
 383          (let ((l (location x)))
 384            (pmatch (cdr x)
 385              ((,obj) (list 'quasiquote (trans-quasiquote e l obj (1+ level))))
 386              (else (syntax-error l (format #f "bad ~A" (car x)) x)))))
 387         (else (cons (trans-quasiquote e l (car x) level)
 388                     (trans-quasiquote e l (cdr x) level)))))
 389
 390 (define (trans-body e l body)
 391   (define (define->binding df)
 392     (pmatch (cdr df)
 393       ((,name ,val) (guard (symbol? name)) (list name val))
 394       (((,name . ,formals) . ,body) (guard (symbol? name))
 395        (list name `(lambda ,formals ,@body)))
 396       (else (syntax-error (location df) "bad define" df))))
 397   ;; main
 398   (let loop ((ls body) (ds '()))
 399     (pmatch ls
 400       (() (syntax-error l "bad body" body))
 401       (((define . _) . _)
 402        (loop (cdr ls) (cons (car ls) ds)))
 403       (else
 404        (if (null? ds)
 405            (trans e l `(begin ,@ls))
 406            (trans e l `(letrec ,(map define->binding ds) ,@ls)))))))
 407
 408 (define (parse-formals formals)
 409   (cond
 410    ;; (lambda x ...)
 411    ((symbol? formals) (values (list formals) #t))
 412    ;; (lambda (x y z) ...)
 413    ((list? formals) (values formals #f))
 414    ;; (lambda (x y . z) ...)
 415    ((pair? formals)
 416     (let loop ((l formals) (v '()))
 417       (if (pair? l)
 418           (loop (cdr l) (cons (car l) v))
 419           (values (reverse! (cons l v)) #t))))
 420    (else (syntax-error (location formals) "bad formals" formals))))
 421
 422 (define (parse-lambda-meta body)
 423   (cond ((or (null? body) (null? (cdr body))) (values '() body))
 424         ((string? (car body))
 425          (values `((documentation . ,(car body))) (cdr body)))
 426         (else (values '() body))))
 427
 428 (define (maybe-name-value! val name)
 429   (cond
 430    ((ghil-lambda? val)
 431     (if (not (assq-ref (ghil-lambda-meta val) 'name))
 432         (set! (ghil-lambda-meta val)
 433               (acons 'name name (ghil-lambda-meta val))))))
 434   val)
 435
 436 (define (location x)
 437   (and (pair? x)
 438        (let ((props (source-properties x)))
 439          (and (not (null? props))
 440               (vector (assq-ref props 'line)
 441                       (assq-ref props 'column)
 442                       (assq-ref props 'filename))))))