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