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