module/language/elisp/compile-tree-il.scm

   1 ;;; Guile Emacs Lisp
   2
   3 ;; Copyright (C) 2009, 2010, 2011, 2013 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 3, 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 elisp compile-tree-il)
  23   #:use-module (language elisp bindings)
  24   #:use-module (language elisp runtime)
  25   #:use-module (language tree-il)
  26   #:use-module (system base pmatch)
  27   #:use-module (system base compile)
  28   #:use-module (srfi srfi-1)
  29   #:use-module (srfi srfi-8)
  30   #:use-module (srfi srfi-11)
  31   #:use-module (srfi srfi-26)
  32   #:use-module (ice-9 format)
  33   #:export (compile-tree-il
  34             compile-progn
  35             compile-eval-when-compile
  36             compile-if
  37             compile-defconst
  38             compile-defvar
  39             compile-setq
  40             compile-let
  41             compile-flet
  42             compile-labels
  43             compile-let*
  44             compile-guile-ref
  45             compile-guile-private-ref
  46             compile-guile-primitive
  47             compile-%function
  48             compile-function
  49             compile-defmacro
  50             compile-defun
  51             #{compile-`}#
  52             compile-quote
  53             compile-%funcall
  54             compile-%set-lexical-binding-mode))
  55
  56 ;;; Certain common parameters (like the bindings data structure or
  57 ;;; compiler options) are not always passed around but accessed using
  58 ;;; fluids to simulate dynamic binding (hey, this is about elisp).
  59
  60 ;;; The bindings data structure to keep track of symbol binding related
  61 ;;; data.
  62
  63 (define bindings-data (make-fluid))
  64
  65 ;;; Find the source properties of some parsed expression if there are
  66 ;;; any associated with it.
  67
  68 (define (location x)
  69   (and (pair? x)
  70        (let ((props (source-properties x)))
  71          (and (not (null? props))
  72               props))))
  73
  74 ;;; Values to use for Elisp's nil and t.
  75
  76 (define (nil-value loc)
  77   (make-const loc (@ (language elisp runtime) nil-value)))
  78
  79 (define (t-value loc)
  80   (make-const loc (@ (language elisp runtime) t-value)))
  81
  82 ;;; Modules that contain the value and function slot bindings.
  83
  84 (define runtime '(language elisp runtime))
  85
  86 (define value-slot (@ (language elisp runtime) value-slot-module))
  87
  88 (define function-slot (@ (language elisp runtime) function-slot-module))
  89
  90 ;;; The backquoting works the same as quasiquotes in Scheme, but the
  91 ;;; forms are named differently; to make easy adaptions, we define these
  92 ;;; predicates checking for a symbol being the car of an
  93 ;;; unquote/unquote-splicing/backquote form.
  94
  95 (define (unquote? sym)
  96   (and (symbol? sym) (eq? sym '#{,}#)))
  97
  98 (define (unquote-splicing? sym)
  99   (and (symbol? sym) (eq? sym '#{,@}#)))
 100
 101 ;;; Build a call to a primitive procedure nicely.
 102
 103 (define (call-primitive loc sym . args)
 104   (make-primcall loc sym args))
 105
 106 ;;; Error reporting routine for syntax/compilation problems or build
 107 ;;; code for a runtime-error output.
 108
 109 (define (report-error loc . args)
 110   (apply error args))
 111
 112 (define (access-variable loc symbol handle-lexical handle-dynamic)
 113   (cond
 114    ((get-lexical-binding (fluid-ref bindings-data) symbol)
 115     => handle-lexical)
 116    (else
 117     (handle-dynamic))))
 118
 119 (define (reference-variable loc symbol)
 120   (access-variable
 121    loc
 122    symbol
 123    (lambda (lexical)
 124      (if (symbol? lexical)
 125          (make-lexical-ref loc symbol lexical)
 126          (make-call loc lexical '())))
 127    (lambda ()
 128      (make-call loc
 129                 (make-module-ref loc runtime 'symbol-value #t)
 130                 (list (make-const loc symbol))))))
 131
 132 (define (global? symbol)
 133   (module-variable value-slot symbol))
 134
 135 (define (ensure-globals! loc names body)
 136   (if (and (every global? names)
 137            (every symbol-interned? names))
 138       body
 139       (list->seq
 140        loc
 141        `(,@(map
 142             (lambda (name)
 143               (symbol-desc name)
 144               (make-call loc
 145                          (make-module-ref loc runtime 'symbol-desc #t)
 146                          (list (make-const loc name))))
 147             names)
 148          ,body))))
 149
 150 (define (set-variable! loc symbol value)
 151   (access-variable
 152    loc
 153    symbol
 154    (lambda (lexical)
 155      (if (symbol? lexical)
 156          (make-lexical-set loc symbol lexical value)
 157          (make-call loc lexical (list value))))
 158    (lambda ()
 159      (ensure-globals!
 160       loc
 161       (list symbol)
 162       (make-call loc
 163                  (make-module-ref loc runtime 'set-symbol-value! #t)
 164                  (list (make-const loc symbol)
 165                        value))))))
 166
 167 (define (access-function loc symbol handle-lexical handle-global)
 168   (cond
 169    ((get-function-binding (fluid-ref bindings-data) symbol)
 170     => handle-lexical)
 171    (else
 172     (handle-global))))
 173
 174 (define (reference-function loc symbol)
 175   (access-function
 176    loc
 177    symbol
 178    (lambda (gensym) (make-lexical-ref loc symbol gensym))
 179    (lambda ()
 180      (make-module-ref loc '(elisp-functions) symbol #t))))
 181
 182 (define (set-function! loc symbol value)
 183   (access-function
 184    loc
 185    symbol
 186    (lambda (gensym) (make-lexical-set loc symbol gensym value))
 187    (lambda ()
 188      (make-call
 189       loc
 190       (make-module-ref loc runtime 'set-symbol-function! #t)
 191       (list (make-const loc symbol) value)))))
 192
 193 (define (bind-lexically? sym decls)
 194   (let ((decl (assq-ref decls sym)))
 195     (or (eq? decl 'lexical)
 196         (and
 197          (lexical-binding?)
 198          (not (special? sym))))))
 199
 200 (define (parse-let-binding loc binding)
 201   (pmatch binding
 202     ((unquote var)
 203      (guard (symbol? var))
 204      (cons var #nil))
 205     ((,var)
 206      (guard (symbol? var))
 207      (cons var #nil))
 208     ((,var ,val)
 209      (guard (symbol? var))
 210      (cons var val))
 211     (else
 212      (report-error loc "malformed variable binding" binding))))
 213
 214 (define (parse-flet-binding loc binding)
 215   (pmatch binding
 216     ((,var ,args . ,body)
 217      (guard (symbol? var))
 218      (cons var `(function (lambda ,args ,@body))))
 219     (else
 220      (report-error loc "malformed function binding" binding))))
 221
 222 (define (parse-declaration expr)
 223   (pmatch expr
 224     ((lexical . ,vars)
 225      (map (cut cons <> 'lexical) vars))
 226     (else
 227      '())))
 228
 229 (define (parse-body-1 body lambda?)
 230   (let loop ((lst body)
 231              (decls '())
 232              (intspec #f)
 233              (doc #f))
 234     (pmatch lst
 235       (((declare . ,x) . ,tail)
 236        (loop tail (append-reverse x decls) intspec doc))
 237       (((interactive) . ,tail)
 238        (guard lambda? (not intspec))
 239        (loop tail decls (cons 'interactive-form #nil) doc))
 240       (((interactive ,x) . ,tail)
 241        (guard lambda? (not intspec))
 242        (loop tail decls (cons 'interactive-form x) doc))
 243       ((,x . ,tail)
 244        (guard lambda? (or (string? x) (lisp-string? x)) (not doc) (not (null? tail)))
 245        (loop tail decls intspec x))
 246       (else
 247        (values (append-map parse-declaration decls)
 248                intspec
 249                doc
 250                lst)))))
 251
 252 (define (parse-lambda-body body)
 253   (parse-body-1 body #t))
 254
 255 (define (parse-body body)
 256   (receive (decls intspec doc body) (parse-body-1 body #f)
 257     (values decls body)))
 258
 259 ;;; Partition the argument list of a lambda expression into required,
 260 ;;; optional and rest arguments.
 261
 262 (define (parse-lambda-list lst)
 263   (define (%match lst null optional rest symbol list*)
 264     (pmatch lst
 265       (() (null))
 266       ((&optional . ,tail) (optional tail))
 267       ((&rest . ,tail) (rest tail))
 268       ((,arg . ,tail) (guard (symbol? arg)) (symbol arg tail))
 269       ((,arg . ,tail) (guard (list? arg)) (list* arg tail))
 270       (else (fail))))
 271   (define (return rreq ropt rest)
 272     (values #t (reverse rreq) (reverse ropt) rest))
 273   (define (fail)
 274     (values #f #f #f #f))
 275   (define (parse-req lst rreq)
 276     (%match lst
 277             (lambda () (return rreq '() #f))
 278             (lambda (tail) (parse-opt tail rreq '()))
 279             (lambda (tail) (parse-rest tail rreq '()))
 280             (lambda (arg tail) (parse-req tail (cons arg rreq)))
 281             (lambda (arg tail) (fail))))
 282   (define (parse-opt lst rreq ropt)
 283     (%match lst
 284             (lambda () (return rreq ropt #f))
 285             (lambda (tail) (fail))
 286             (lambda (tail) (parse-rest tail rreq ropt))
 287             (lambda (arg tail) (parse-opt tail rreq (cons (list arg) ropt)))
 288             (lambda (arg tail) (parse-opt tail rreq (cons arg ropt)))))
 289   (define (parse-rest lst rreq ropt)
 290     (%match lst
 291             (lambda () (fail))
 292             (lambda (tail) (fail))
 293             (lambda (tail) (fail))
 294             (lambda (arg tail) (parse-post-rest tail rreq ropt arg))
 295             (lambda (arg tail) (fail))))
 296   (define (parse-post-rest lst rreq ropt rest)
 297     (%match lst
 298             (lambda () (return rreq ropt rest))
 299             (lambda () (fail))
 300             (lambda () (fail))
 301             (lambda (arg tail) (fail))
 302             (lambda (arg tail) (fail))))
 303   (parse-req lst '()))
 304
 305 (define (make-simple-lambda loc meta req opt init rest vars body)
 306   (make-lambda loc
 307                meta
 308                (make-lambda-case #f req opt rest #f init vars body #f)))
 309
 310 (define (make-dynlet src fluids vals body)
 311   (let ((f (map (lambda (x) (gensym "fluid ")) fluids))
 312         (v (map (lambda (x) (gensym "valud ")) vals)))
 313     (make-let src (map (lambda (_) 'fluid) fluids) f fluids
 314               (make-let src (map (lambda (_) 'val) vals) v vals
 315                         (let lp ((f f) (v v))
 316                           (if (null? f)
 317                               body
 318                               (make-call src
 319                                          (make-module-ref src runtime 'bind-symbol #t)
 320                                          (list (make-lexical-ref #f 'fluid (car f))
 321                                                (make-lexical-ref #f 'val (car v))
 322                                                (make-lambda
 323                                                 src '()
 324                                                 (make-lambda-case
 325                                                  src '() #f #f #f '() '()
 326                                                  (lp (cdr f) (cdr v))
 327                                                  #f))))))))))
 328
 329 (define (compile-lambda loc meta args body)
 330   (receive (valid? req-ids opts rest-id)
 331            (parse-lambda-list args)
 332     (if valid?
 333         (let* ((all-ids (append req-ids
 334                                 (and opts (map car opts))
 335                                 (or (and=> rest-id list) '())))
 336                (all-vars (map (lambda (ignore) (gensym)) all-ids)))
 337           (let*-values (((decls intspec doc forms)
 338                          (parse-lambda-body body))
 339                         ((lexical dynamic)
 340                          (partition
 341                           (compose (cut bind-lexically? <> decls)
 342                                    car)
 343                           (map list all-ids all-vars)))
 344                         ((lexical-ids lexical-vars) (unzip2 lexical))
 345                         ((dynamic-ids dynamic-vars) (unzip2 dynamic)))
 346             (with-dynamic-bindings
 347              (fluid-ref bindings-data)
 348              dynamic-ids
 349              (lambda ()
 350                (with-lexical-bindings
 351                 (fluid-ref bindings-data)
 352                 lexical-ids
 353                 lexical-vars
 354                 (lambda ()
 355                   (ensure-globals!
 356                    loc
 357                    dynamic-ids
 358                    (let* ((tree-il
 359                            (compile-expr
 360                             (if rest-id
 361                                 `(let ((,rest-id (if ,rest-id
 362                                                      ,rest-id
 363                                                      nil)))
 364                                    ,@forms)
 365                                 `(progn ,@forms))))
 366                           (full-body
 367                            (if (null? dynamic)
 368                                tree-il
 369                                (make-dynlet
 370                                 loc
 371                                 (map (cut make-const loc <>) dynamic-ids)
 372                                 (map (cut make-lexical-ref loc <> <>)
 373                                      dynamic-ids
 374                                      dynamic-vars)
 375                                 tree-il))))
 376                      (make-simple-lambda loc
 377                                          (append (if intspec
 378                                                      (list intspec)
 379                                                      '())
 380                                                  (if doc
 381                                                      (list (cons 'emacs-documentation doc))
 382                                                      '())
 383                                                  meta)
 384                                          req-ids
 385                                          (map car opts)
 386                                          (map (lambda (x)
 387                                                 (if (pair? (cdr x))
 388                                                     (compile-expr (car (cdr x)))
 389                                                     (make-const loc #nil)))
 390                                               opts)
 391                                          rest-id
 392                                          all-vars
 393                                          full-body)))))))))
 394         (report-error "invalid function" `(lambda ,args ,@body)))))
 395
 396 ;;; Handle macro and special operator bindings.
 397
 398 (define (find-operator name type)
 399   (and
 400    (symbol? name)
 401    (module-defined? function-slot name)
 402    (let ((op (module-ref function-slot name)))
 403      (if (and (pair? op) (eq? (car op) type))
 404          (cdr op)
 405          #f))))
 406
 407 (define (contains-unquotes? expr)
 408   (if (pair? expr)
 409       (if (or (unquote? (car expr)) (unquote-splicing? (car expr)))
 410           #t
 411           (or (contains-unquotes? (car expr))
 412               (contains-unquotes? (cdr expr))))
 413       #f))
 414
 415 ;;; Process a backquoted expression by building up the needed
 416 ;;; cons/append calls.  For splicing, it is assumed that the expression
 417 ;;; spliced in evaluates to a list.  The emacs manual does not really
 418 ;;; state either it has to or what to do if it does not, but Scheme
 419 ;;; explicitly forbids it and this seems reasonable also for elisp.
 420
 421 (define (unquote-cell? expr)
 422   (and (list? expr) (= (length expr) 2) (unquote? (car expr))))
 423
 424 (define (unquote-splicing-cell? expr)
 425   (and (list? expr) (= (length expr) 2) (unquote-splicing? (car expr))))
 426
 427 (define (process-backquote loc expr)
 428   (if (contains-unquotes? expr)
 429       (if (pair? expr)
 430           (if (or (unquote-cell? expr) (unquote-splicing-cell? expr))
 431               (compile-expr (cadr expr))
 432               (let* ((head (car expr))
 433                      (processed-tail (process-backquote loc (cdr expr)))
 434                      (head-is-list-2 (and (list? head)
 435                                           (= (length head) 2)))
 436                      (head-unquote (and head-is-list-2
 437                                         (unquote? (car head))))
 438                      (head-unquote-splicing (and head-is-list-2
 439                                                  (unquote-splicing?
 440                                                   (car head)))))
 441                 (if head-unquote-splicing
 442                     (call-primitive loc
 443                                     'append
 444                                     (compile-expr (cadr head))
 445                                     processed-tail)
 446                     (call-primitive loc 'cons
 447                                     (if head-unquote
 448                                         (compile-expr (cadr head))
 449                                         (process-backquote loc head))
 450                                     processed-tail))))
 451           (report-error loc
 452                         "non-pair expression contains unquotes"
 453                         expr))
 454       (make-const loc expr)))
 455
 456 ;;; Special operators
 457
 458 (defspecial progn (loc args)
 459   (list->seq loc
 460              (if (null? args)
 461                  (list (nil-value loc))
 462                  (map compile-expr args))))
 463
 464 (defspecial eval-when-compile (loc args)
 465   (make-const loc (compile `(progn ,@args) #:from 'elisp #:to 'value)))
 466
 467 (defspecial if (loc args)
 468   (pmatch args
 469     ((,cond ,then . ,else)
 470      (make-conditional
 471       loc
 472       (call-primitive loc 'not
 473        (call-primitive loc 'nil? (compile-expr cond)))
 474       (compile-expr then)
 475       (compile-expr `(progn ,@else))))
 476     (else (report-error loc "Bad if" args))))
 477
 478 (defspecial defconst (loc args)
 479   (pmatch args
 480     ((,sym ,value . ,doc)
 481      (make-seq
 482       loc
 483       (make-call loc
 484                  (make-module-ref loc runtime 'proclaim-special! #t)
 485                  (list (make-const loc sym)))
 486       (make-seq loc
 487                 (set-variable! loc sym (compile-expr value))
 488                 (make-const loc sym))))
 489     (else (report-error loc "Bad defconst" args))))
 490
 491 (defspecial defvar (loc args)
 492   (pmatch args
 493     ((,sym)
 494      (make-seq loc
 495                (make-call loc
 496                           (make-module-ref loc runtime 'proclaim-special! #t)
 497                           (list (make-const loc sym)))
 498                (make-const loc sym)))
 499     ((,sym ,value . ,doc)
 500      (make-seq
 501       loc
 502       (make-call loc
 503                  (make-module-ref loc runtime 'proclaim-special! #t)
 504                  (list (make-const loc sym)))
 505       (make-seq
 506        loc
 507        (make-conditional
 508         loc
 509         (make-call loc
 510                    (make-module-ref loc runtime 'symbol-bound? #t)
 511                    (list (make-const loc sym)))
 512         (make-void loc)
 513         (set-variable! loc sym (compile-expr value)))
 514        (make-const loc sym))))
 515     (else (report-error loc "Bad defvar" args))))
 516
 517 (defspecial setq (loc args)
 518   (define (car* x) (if (null? x) '() (car x)))
 519   (define (cdr* x) (if (null? x) '() (cdr x)))
 520   (define (cadr* x) (car* (cdr* x)))
 521   (define (cddr* x) (cdr* (cdr* x)))
 522   (list->seq
 523    loc
 524    (let loop ((args args) (last (nil-value loc)))
 525      (if (null? args)
 526          (list last)
 527          (let ((sym (car args))
 528                (val (compile-expr (cadr* args))))
 529            (if (not (symbol? sym))
 530                (report-error loc "expected symbol in setq" args)
 531                (cons
 532                 (set-variable! loc sym val)
 533                 (loop (cddr* args)
 534                       (reference-variable loc sym)))))))))
 535
 536 (defspecial let (loc args)
 537   (pmatch args
 538     ((,varlist . ,body)
 539      (let ((bindings (map (cut parse-let-binding loc <>) varlist)))
 540        (receive (decls forms) (parse-body body)
 541          (receive (lexical dynamic)
 542                   (partition
 543                    (compose (cut bind-lexically? <> decls)
 544                             car)
 545                    bindings)
 546            (let ((make-values (lambda (for)
 547                                 (map (lambda (el) (compile-expr (cdr el)))
 548                                      for)))
 549                  (make-body (lambda () (compile-expr `(progn ,@forms)))))
 550              (ensure-globals!
 551               loc
 552               (map car dynamic)
 553               (if (null? lexical)
 554                   (make-dynlet loc
 555                                (map (compose (cut make-const loc <>) car)
 556                                     dynamic)
 557                                (map (compose compile-expr cdr)
 558                                     dynamic)
 559                                (make-body))
 560                   (let* ((lexical-syms (map (lambda (el) (gensym)) lexical))
 561                          (dynamic-syms (map (lambda (el) (gensym)) dynamic))
 562                          (all-syms (append lexical-syms dynamic-syms))
 563                          (vals (append (make-values lexical)
 564                                        (make-values dynamic))))
 565                     (make-let loc
 566                               all-syms
 567                               all-syms
 568                               vals
 569                               (with-lexical-bindings
 570                                (fluid-ref bindings-data)
 571                                (map car lexical)
 572                                lexical-syms
 573                                (lambda ()
 574                                  (if (null? dynamic)
 575                                      (make-body)
 576                                      (make-dynlet loc
 577                                                   (map
 578                                                    (compose (cut make-const
 579                                                                  loc
 580                                                                  <>)
 581                                                             car)
 582                                                    dynamic)
 583                                                   (map
 584                                                    (lambda (sym)
 585                                                      (make-lexical-ref
 586                                                       loc
 587                                                       sym
 588                                                       sym))
 589                                                    dynamic-syms)
 590                                                   (make-body))))))))))))))
 591     (else (report-error loc "bad let args"))))
 592
 593 (defspecial let* (loc args)
 594   (pmatch args
 595     ((,varlist . ,body)
 596      (let ((bindings (map (cut parse-let-binding loc <>) varlist)))
 597        (receive (decls forms) (parse-body body)
 598          (let iterate ((tail bindings))
 599            (if (null? tail)
 600                (compile-expr `(progn ,@forms))
 601                (let ((sym (caar tail))
 602                      (value (compile-expr (cdar tail))))
 603                  (if (bind-lexically? sym decls)
 604                      (let ((target (gensym)))
 605                        (make-let loc
 606                                  `(,target)
 607                                  `(,target)
 608                                  `(,value)
 609                                  (with-lexical-bindings
 610                                   (fluid-ref bindings-data)
 611                                   `(,sym)
 612                                   `(,target)
 613                                   (lambda () (iterate (cdr tail))))))
 614                      (ensure-globals!
 615                       loc
 616                       (list sym)
 617                       (make-dynlet loc
 618                                    (list (make-const loc sym))
 619                                    (list value)
 620                                    (iterate (cdr tail)))))))))))
 621     (else (report-error loc "Bad let*" args))))
 622
 623 (defspecial flet (loc args)
 624   (pmatch args
 625     ((,bindings . ,body)
 626      (let ((names+vals (map (cut parse-flet-binding loc <>) bindings)))
 627        (receive (decls forms) (parse-body body)
 628          (let ((names (map car names+vals))
 629                (vals (map cdr names+vals))
 630                (gensyms (map (lambda (x) (gensym)) names+vals)))
 631            (with-function-bindings
 632             (fluid-ref bindings-data)
 633             names
 634             gensyms
 635             (lambda ()
 636               (make-let loc
 637                         names
 638                         gensyms
 639                         (map compile-expr vals)
 640                         (compile-expr `(progn ,@forms)))))))))
 641     (else (report-error loc "bad flet" args))))
 642
 643 (defspecial labels (loc args)
 644   (pmatch args
 645     ((,bindings . ,body)
 646      (let ((names+vals (map (cut parse-flet-binding loc <>) bindings)))
 647        (receive (decls forms) (parse-body body)
 648          (let ((names (map car names+vals))
 649                (vals (map cdr names+vals))
 650                (gensyms (map (lambda (x) (gensym)) names+vals)))
 651            (with-function-bindings
 652             (fluid-ref bindings-data)
 653             names
 654             gensyms
 655             (lambda ()
 656               (make-letrec #f
 657                            loc
 658                            names
 659                            gensyms
 660                            (map compile-expr vals)
 661                            (compile-expr `(progn ,@forms)))))))))
 662     (else (report-error loc "bad labels" args))))
 663
 664 ;;; guile-ref allows building TreeIL's module references from within
 665 ;;; elisp as a way to access data within the Guile universe.  The module
 666 ;;; and symbol referenced are static values, just like (@ module symbol)
 667 ;;; does!
 668
 669 (defspecial guile-ref (loc args)
 670   (pmatch args
 671     ((,module ,sym) (guard (and (list? module) (symbol? sym)))
 672      (make-module-ref loc module sym #t))
 673     (else (report-error loc "bad guile-ref" args))))
 674
 675 (defspecial guile-private-ref (loc args)
 676   (pmatch args
 677     ((,module ,sym) (guard (and (list? module) (symbol? sym)))
 678      (make-module-ref loc module sym #f))
 679     (else (report-error loc "bad guile-private-ref" args))))
 680
 681 ;;; guile-primitive allows to create primitive references, which are
 682 ;;; still a little faster.
 683
 684 (defspecial guile-primitive (loc args)
 685   (pmatch args
 686     ((,sym)
 687      (make-primitive-ref loc sym))
 688     (else (report-error loc "bad guile-primitive" args))))
 689
 690 (defspecial %function (loc args)
 691   (pmatch args
 692     (((lambda ,args . ,body))
 693      (compile-lambda loc '() args body))
 694     (((closure ,env ,args . ,body))
 695      (let ((bindings (map (lambda (x) (list (car x) (cdr x)))
 696                           (filter pair? env))))
 697        (compile-expr
 698         (let ((form `(let ,bindings
 699                        (declare ,@(map (lambda (x) (list 'lexical x))
 700                                        bindings))
 701                        (function (lambda ,args
 702                                    (declare
 703                                     (lexical
 704                                      ,@(filter-map
 705                                         (lambda (x)
 706                                           (cond
 707                                            ((memq x '(&optional &rest))
 708                                             #f)
 709                                            ((symbol? x)
 710                                             x)
 711                                            ((list? x)
 712                                             (car x))))
 713                                         args)))
 714                                    ,@body)))))
 715           form))))
 716     ((,sym) (guard (symbol? sym))
 717      (reference-function loc sym))
 718     ((,x)
 719      (make-const loc x))
 720     (else (report-error loc "bad function" args))))
 721
 722 (defspecial function (loc args)
 723   (pmatch args
 724     ((,sym) (guard (symbol? sym))
 725      (make-const loc sym))
 726     (else ((cdr compile-%function) loc args))))
 727
 728 (defspecial defmacro (loc args)
 729   (pmatch args
 730     ((,name ,args . ,body)
 731      (if (not (symbol? name))
 732          (report-error loc "expected symbol as macro name" name)
 733          (let* ((tree-il
 734                  (make-seq
 735                   loc
 736                   (set-function!
 737                    loc
 738                    name
 739                    (make-call
 740                     loc
 741                     (make-module-ref loc '(guile) 'cons #t)
 742                     (list (make-const loc 'macro)
 743                           (compile-lambda loc
 744                                           `((name . ,name))
 745                                           args
 746                                           body))))
 747                   (make-const loc name))))
 748            (compile tree-il #:from 'tree-il #:to 'value)
 749            tree-il)))
 750     (else (report-error loc "bad defmacro" args))))
 751
 752 (defspecial #{`}# (loc args)
 753   (pmatch args
 754     ((,val)
 755      (process-backquote loc val))
 756     (else (report-error loc "bad backquote" args))))
 757
 758 (defspecial quote (loc args)
 759   (pmatch args
 760     ((,val)
 761      (make-const loc val))
 762     (else (report-error loc "bad quote" args))))
 763
 764 (defspecial %funcall (loc args)
 765   (pmatch args
 766     ((,function . ,arguments)
 767      (make-call loc
 768                 (compile-expr function)
 769                 (map compile-expr arguments)))
 770     (else (report-error loc "bad %funcall" args))))
 771
 772 (defspecial %set-lexical-binding-mode (loc args)
 773   (pmatch args
 774     ((,val)
 775      (set-lexical-binding-mode val)
 776      (make-void loc))
 777     (else (report-error loc "bad %set-lexical-binding-mode" args))))
 778
 779 (define special-operators (make-hash-table))
 780
 781 (for-each
 782  (lambda (pair) (hashq-set! special-operators (car pair) (cddr pair)))
 783  `((progn . ,compile-progn)
 784    (eval-when-compile . ,compile-eval-when-compile)
 785    (if . ,compile-if)
 786    (defconst . ,compile-defconst)
 787    (defvar . ,compile-defvar)
 788    (setq . ,compile-setq)
 789    (let . ,compile-let)
 790    (flet . ,compile-flet)
 791    (labels . ,compile-labels)
 792    (let* . ,compile-let*)
 793    (guile-ref . ,compile-guile-ref)
 794    (guile-private-ref . ,compile-guile-private-ref)
 795    (guile-primitive . ,compile-guile-primitive)
 796    (%function . ,compile-%function)
 797    (function . ,compile-function)
 798    (defmacro . ,compile-defmacro)
 799    (#{`}# . ,#{compile-`}#)
 800    (quote . ,compile-quote)
 801    (%funcall . ,compile-%funcall)
 802    (%set-lexical-binding-mode . ,compile-%set-lexical-binding-mode)))
 803
 804 ;;; Compile a compound expression to Tree-IL.
 805
 806 (define (compile-pair loc expr)
 807   (let ((operator (car expr))
 808         (arguments (cdr expr)))
 809     (cond
 810      ((find-operator operator 'macro)
 811       => (lambda (macro-function)
 812            (compile-expr (apply macro-function arguments))))
 813      ((hashq-ref special-operators operator)
 814       => (lambda (special-operator-function)
 815            (special-operator-function loc arguments)))
 816      (else
 817       (compile-expr `(%funcall (%function ,operator) ,@arguments))))))
 818
 819 ;;; Compile a symbol expression.  This is a variable reference or maybe
 820 ;;; some special value like nil.
 821
 822 (define (compile-symbol loc sym)
 823   (case sym
 824     ((nil) (nil-value loc))
 825     ((t) (t-value loc))
 826     (else (reference-variable loc sym))))
 827
 828 ;;; Compile a single expression to TreeIL.
 829
 830 (define (compile-expr expr)
 831   (let ((loc (location expr)))
 832     (cond
 833      ((symbol? expr)
 834       (compile-symbol loc expr))
 835      ((pair? expr)
 836       (compile-pair loc expr))
 837      (else (make-const loc expr)))))
 838
 839 (define (compile-tree-il expr env opts)
 840   (values
 841    (with-fluids ((bindings-data (make-bindings)))
 842      (compile-expr expr))
 843    env
 844    env))