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-1 args))))
 463
 464 (defspecial eval-when-compile (loc args)
 465   (make-const loc (compile `(progn ,@args) #:from 'elisp #:to 'value)))
 466
 467 (define toplevel? (make-fluid))
 468
 469 (define compile-time-too? (make-fluid))
 470
 471 (defspecial eval-when (loc args)
 472   (pmatch args
 473     ((,situations . ,forms)
 474      (let ((compile? (or (memq ':compile-toplevel situations)
 475                          (memq 'compile situations)))
 476            (load? (or (memq ':load-toplevel situations)
 477                       (memq 'load situations)))
 478            (execute? (or (memq ':execute situations)
 479                          (memq 'eval situations))))
 480        (cond
 481         ((not (fluid-ref toplevel?))
 482          (if execute?
 483              (compile-expr `(progn ,@forms))
 484              (make-const loc #nil)))
 485         (load?
 486          (with-fluids ((compile-time-too?
 487                         (cond (compile? #t)
 488                               (execute? (fluid-ref compile-time-too?))
 489                               (else #f))))
 490            (when (fluid-ref compile-time-too?)
 491              (eval-elisp `(progn ,@forms)))
 492            (compile-expr-1 `(progn ,@forms))))
 493         ((or compile? (and execute? (fluid-ref compile-time-too?)))
 494          (eval-elisp `(progn ,@forms))
 495          (make-const loc #nil))
 496         (else
 497          (make-const loc #nil)))))))
 498
 499 (defspecial if (loc args)
 500   (pmatch args
 501     ((,cond ,then . ,else)
 502      (make-conditional
 503       loc
 504       (call-primitive loc 'not
 505        (call-primitive loc 'nil? (compile-expr cond)))
 506       (compile-expr then)
 507       (compile-expr `(progn ,@else))))
 508     (else (report-error loc "Bad if" args))))
 509
 510 (defspecial defconst (loc args)
 511   (pmatch args
 512     ((,sym ,value . ,doc)
 513      (proclaim-special! sym)
 514      (make-seq
 515       loc
 516       (make-call loc
 517                  (make-module-ref loc runtime 'proclaim-special! #t)
 518                  (list (make-const loc sym)))
 519       (make-seq loc
 520                 (set-variable! loc sym (compile-expr value))
 521                 (make-const loc sym))))
 522     (else (report-error loc "Bad defconst" args))))
 523
 524 (defspecial defvar (loc args)
 525   (pmatch args
 526     ((,sym)
 527      (proclaim-special! sym)
 528      (make-seq loc
 529                (make-call loc
 530                           (make-module-ref loc runtime 'proclaim-special! #t)
 531                           (list (make-const loc sym)))
 532                (make-const loc sym)))
 533     ((,sym ,value . ,doc)
 534      (proclaim-special! sym)
 535      (make-seq
 536       loc
 537       (make-call loc
 538                  (make-module-ref loc runtime 'proclaim-special! #t)
 539                  (list (make-const loc sym)))
 540       (make-seq
 541        loc
 542        (make-conditional
 543         loc
 544         (make-call loc
 545                    (make-module-ref loc runtime 'symbol-default-bound? #t)
 546                    (list (make-const loc sym)))
 547         (make-void loc)
 548         (make-call loc
 549                    (make-module-ref loc runtime 'set-symbol-default-value! #t)
 550                    (list (make-const loc sym)
 551                          (compile-expr value))))
 552        (make-const loc sym))))
 553     (else (report-error loc "Bad defvar" args))))
 554
 555 (defspecial setq (loc args)
 556   (define (car* x) (if (null? x) '() (car x)))
 557   (define (cdr* x) (if (null? x) '() (cdr x)))
 558   (define (cadr* x) (car* (cdr* x)))
 559   (define (cddr* x) (cdr* (cdr* x)))
 560   (list->seq
 561    loc
 562    (let loop ((args args) (last (nil-value loc)))
 563      (if (null? args)
 564          (list last)
 565          (let ((sym (car args))
 566                (val (compile-expr (cadr* args))))
 567            (if (not (symbol? sym))
 568                (report-error loc "expected symbol in setq" args)
 569                (cons
 570                 (set-variable! loc sym val)
 571                 (loop (cddr* args)
 572                       (reference-variable loc sym)))))))))
 573
 574 (defspecial let (loc args)
 575   (pmatch args
 576     ((,varlist . ,body)
 577      (let ((bindings (map (cut parse-let-binding loc <>) varlist)))
 578        (receive (decls forms) (parse-body body)
 579          (receive (lexical dynamic)
 580                   (partition
 581                    (compose (cut bind-lexically? <> decls)
 582                             car)
 583                    bindings)
 584            (let ((make-values (lambda (for)
 585                                 (map (lambda (el) (compile-expr (cdr el)))
 586                                      for)))
 587                  (make-body (lambda () (compile-expr `(progn ,@forms)))))
 588              (ensure-globals!
 589               loc
 590               (map car dynamic)
 591               (if (null? lexical)
 592                   (if (null? dynamic)
 593                       (make-body)
 594                       (make-dynlet loc
 595                                    (map (compose (cut make-const loc <>) car)
 596                                         dynamic)
 597                                    (map (compose compile-expr cdr)
 598                                         dynamic)
 599                                    (make-body)))
 600                   (let* ((lexical-syms (map (lambda (el) (gensym)) lexical))
 601                          (dynamic-syms (map (lambda (el) (gensym)) dynamic))
 602                          (all-syms (append lexical-syms dynamic-syms))
 603                          (vals (append (make-values lexical)
 604                                        (make-values dynamic))))
 605                     (make-let loc
 606                               all-syms
 607                               all-syms
 608                               vals
 609                               (with-lexical-bindings
 610                                (fluid-ref bindings-data)
 611                                (map car lexical)
 612                                lexical-syms
 613                                (lambda ()
 614                                  (if (null? dynamic)
 615                                      (make-body)
 616                                      (make-dynlet loc
 617                                                   (map
 618                                                    (compose (cut make-const
 619                                                                  loc
 620                                                                  <>)
 621                                                             car)
 622                                                    dynamic)
 623                                                   (map
 624                                                    (lambda (sym)
 625                                                      (make-lexical-ref
 626                                                       loc
 627                                                       sym
 628                                                       sym))
 629                                                    dynamic-syms)
 630                                                   (make-body))))))))))))))
 631     (else (report-error loc "bad let args"))))
 632
 633 (defspecial let* (loc args)
 634   (pmatch args
 635     ((,varlist . ,body)
 636      (let ((bindings (map (cut parse-let-binding loc <>) varlist)))
 637        (receive (decls forms) (parse-body body)
 638          (let iterate ((tail bindings))
 639            (if (null? tail)
 640                (compile-expr `(progn ,@forms))
 641                (let ((sym (caar tail))
 642                      (value (compile-expr (cdar tail))))
 643                  (if (bind-lexically? sym decls)
 644                      (let ((target (gensym)))
 645                        (make-let loc
 646                                  `(,target)
 647                                  `(,target)
 648                                  `(,value)
 649                                  (with-lexical-bindings
 650                                   (fluid-ref bindings-data)
 651                                   `(,sym)
 652                                   `(,target)
 653                                   (lambda () (iterate (cdr tail))))))
 654                      (ensure-globals!
 655                       loc
 656                       (list sym)
 657                       (make-dynlet loc
 658                                    (list (make-const loc sym))
 659                                    (list value)
 660                                    (iterate (cdr tail)))))))))))
 661     (else (report-error loc "Bad let*" args))))
 662
 663 (defspecial flet (loc args)
 664   (pmatch args
 665     ((,bindings . ,body)
 666      (let ((names+vals (map (cut parse-flet-binding loc <>) bindings)))
 667        (receive (decls forms) (parse-body body)
 668          (let ((names (map car names+vals))
 669                (vals (map cdr names+vals))
 670                (gensyms (map (lambda (x) (gensym)) names+vals)))
 671            (with-function-bindings
 672             (fluid-ref bindings-data)
 673             names
 674             gensyms
 675             (lambda ()
 676               (make-let loc
 677                         names
 678                         gensyms
 679                         (map compile-expr vals)
 680                         (compile-expr `(progn ,@forms)))))))))
 681     (else (report-error loc "bad flet" args))))
 682
 683 (defspecial labels (loc args)
 684   (pmatch args
 685     ((,bindings . ,body)
 686      (let ((names+vals (map (cut parse-flet-binding loc <>) bindings)))
 687        (receive (decls forms) (parse-body body)
 688          (let ((names (map car names+vals))
 689                (vals (map cdr names+vals))
 690                (gensyms (map (lambda (x) (gensym)) names+vals)))
 691            (with-function-bindings
 692             (fluid-ref bindings-data)
 693             names
 694             gensyms
 695             (lambda ()
 696               (make-letrec #f
 697                            loc
 698                            names
 699                            gensyms
 700                            (map compile-expr vals)
 701                            (compile-expr `(progn ,@forms)))))))))
 702     (else (report-error loc "bad labels" args))))
 703
 704 ;;; guile-ref allows building TreeIL's module references from within
 705 ;;; elisp as a way to access data within the Guile universe.  The module
 706 ;;; and symbol referenced are static values, just like (@ module symbol)
 707 ;;; does!
 708
 709 (defspecial guile-ref (loc args)
 710   (pmatch args
 711     ((,module ,sym) (guard (and (list? module) (symbol? sym)))
 712      (make-module-ref loc module sym #t))
 713     (else (report-error loc "bad guile-ref" args))))
 714
 715 (defspecial guile-private-ref (loc args)
 716   (pmatch args
 717     ((,module ,sym) (guard (and (list? module) (symbol? sym)))
 718      (make-module-ref loc module sym #f))
 719     (else (report-error loc "bad guile-private-ref" args))))
 720
 721 ;;; guile-primitive allows to create primitive references, which are
 722 ;;; still a little faster.
 723
 724 (defspecial guile-primitive (loc args)
 725   (pmatch args
 726     ((,sym)
 727      (make-primitive-ref loc sym))
 728     (else (report-error loc "bad guile-primitive" args))))
 729
 730 (defspecial %function (loc args)
 731   (pmatch args
 732     (((lambda ,args . ,body))
 733      (compile-lambda loc '() args body))
 734     (((closure ,env ,args . ,body))
 735      (let ((bindings (map (lambda (x) (list (car x) (cdr x)))
 736                           (filter pair? env))))
 737        (compile-expr
 738         (let ((form `(let ,bindings
 739                        (declare ,@(map (lambda (x) (list 'lexical x))
 740                                        bindings))
 741                        (function (lambda ,args
 742                                    (declare
 743                                     (lexical
 744                                      ,@(filter-map
 745                                         (lambda (x)
 746                                           (cond
 747                                            ((memq x '(&optional &rest))
 748                                             #f)
 749                                            ((symbol? x)
 750                                             x)
 751                                            ((list? x)
 752                                             (car x))))
 753                                         args)))
 754                                    ,@body)))))
 755           form))))
 756     ((,sym) (guard (symbol? sym))
 757      (reference-function loc sym))
 758     ((,x)
 759      (make-const loc x))
 760     (else (report-error loc "bad function" args))))
 761
 762 (defspecial function (loc args)
 763   (pmatch args
 764     ((,sym) (guard (symbol? sym))
 765      (make-const loc sym))
 766     (else ((cdr compile-%function) loc args))))
 767
 768 (defspecial defmacro (loc args)
 769   (pmatch args
 770     ((,name ,args . ,body)
 771      (if (not (symbol? name))
 772          (report-error loc "expected symbol as macro name" name)
 773          (let* ((tree-il
 774                  (make-seq
 775                   loc
 776                   (set-function!
 777                    loc
 778                    name
 779                    (make-call
 780                     loc
 781                     (make-module-ref loc '(guile) 'cons #t)
 782                     (list (make-const loc 'macro)
 783                           (compile-lambda loc
 784                                           `((name . ,name))
 785                                           args
 786                                           body))))
 787                   (make-const loc name))))
 788            (when (fluid-ref toplevel?)
 789              (compile tree-il #:from 'tree-il #:to 'value))
 790            tree-il)))
 791     (else (report-error loc "bad defmacro" args))))
 792
 793 (defspecial #{`}# (loc args)
 794   (pmatch args
 795     ((,val)
 796      (process-backquote loc val))
 797     (else (report-error loc "bad backquote" args))))
 798
 799 (defspecial quote (loc args)
 800   (pmatch args
 801     ((,val)
 802      (make-const loc val))
 803     (else (report-error loc "bad quote" args))))
 804
 805 (defspecial %funcall (loc args)
 806   (pmatch args
 807     ((,function . ,arguments)
 808      (make-call loc
 809                 (compile-expr function)
 810                 (map compile-expr arguments)))
 811     (else (report-error loc "bad %funcall" args))))
 812
 813 (defspecial %set-lexical-binding-mode (loc args)
 814   (pmatch args
 815     ((,val)
 816      (set-lexical-binding-mode val)
 817      (make-void loc))
 818     (else (report-error loc "bad %set-lexical-binding-mode" args))))
 819
 820 (define (eget s p)
 821   (if (symbol-fbound? 'get)
 822       ((symbol-function 'get) s p)
 823       #nil))
 824
 825 ;;; Compile a compound expression to Tree-IL.
 826
 827 (define (compile-pair loc expr)
 828   (let ((operator (car expr))
 829         (arguments (cdr expr)))
 830     (cond
 831      ((find-operator operator 'special-operator)
 832       => (lambda (special-operator-function)
 833            (special-operator-function loc arguments)))
 834      ((find-operator operator 'macro)
 835       => (lambda (macro-function)
 836            (compile-expr-1 (apply macro-function arguments))))
 837      ((and (symbol? operator)
 838            (eget operator '%compiler-macro))
 839       => (lambda (compiler-macro-function)
 840            (let ((new (compiler-macro-function expr)))
 841              (if (eq? new expr)
 842                  (compile-expr `(%funcall (%function ,operator) ,@arguments))
 843                  (compile-expr-1 new)))))
 844      (else
 845       (compile-expr `(%funcall (%function ,operator) ,@arguments))))))
 846
 847 ;;; Compile a symbol expression.  This is a variable reference or maybe
 848 ;;; some special value like nil.
 849
 850 (define (compile-symbol loc sym)
 851   (case sym
 852     ((nil) (nil-value loc))
 853     ((t) (t-value loc))
 854     (else (reference-variable loc sym))))
 855
 856 ;;; Compile a single expression to TreeIL.
 857
 858 (define (compile-expr-1 expr)
 859   (let ((loc (location expr)))
 860     (cond
 861      ((symbol? expr)
 862       (compile-symbol loc expr))
 863      ((pair? expr)
 864       (compile-pair loc expr))
 865      (else (make-const loc expr)))))
 866
 867 (define (compile-expr expr)
 868   (if (fluid-ref toplevel?)
 869       (with-fluids ((toplevel? #f))
 870         (compile-expr-1 expr))
 871       (compile-expr-1 expr)))
 872
 873 (define (compile-tree-il expr env opts)
 874   (values
 875    (with-fluids ((bindings-data (make-bindings))
 876                  (toplevel? #t)
 877                  (compile-time-too? #f))
 878      (compile-expr-1 expr))
 879    env
 880    env))