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