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

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