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