| 1 | ;;; Guile Emacs Lisp |
| 2 | |
| 3 | ;; Copyright (C) 2009, 2010, 2011 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 | #:export (compile-tree-il |
| 33 | compile-progn |
| 34 | compile-if |
| 35 | compile-defconst |
| 36 | compile-defvar |
| 37 | compile-setq |
| 38 | compile-let |
| 39 | compile-lexical-let |
| 40 | compile-flet |
| 41 | compile-let* |
| 42 | compile-lexical-let* |
| 43 | compile-flet* |
| 44 | compile-without-void-checks |
| 45 | compile-with-always-lexical |
| 46 | compile-guile-ref |
| 47 | compile-guile-primitive |
| 48 | compile-while |
| 49 | compile-function |
| 50 | compile-defmacro |
| 51 | compile-defun |
| 52 | #{compile-`}# |
| 53 | compile-quote)) |
| 54 | |
| 55 | ;;; Certain common parameters (like the bindings data structure or |
| 56 | ;;; compiler options) are not always passed around but accessed using |
| 57 | ;;; fluids to simulate dynamic binding (hey, this is about elisp). |
| 58 | |
| 59 | ;;; The bindings data structure to keep track of symbol binding related |
| 60 | ;;; data. |
| 61 | |
| 62 | (define bindings-data (make-fluid)) |
| 63 | |
| 64 | ;;; Store for which symbols (or all/none) void checks are disabled. |
| 65 | |
| 66 | (define disable-void-check (make-fluid)) |
| 67 | |
| 68 | ;;; Store which symbols (or all/none) should always be bound lexically, |
| 69 | ;;; even with ordinary let and as lambda arguments. |
| 70 | |
| 71 | (define always-lexical (make-fluid)) |
| 72 | |
| 73 | ;;; Find the source properties of some parsed expression if there are |
| 74 | ;;; any associated with it. |
| 75 | |
| 76 | (define (location x) |
| 77 | (and (pair? x) |
| 78 | (let ((props (source-properties x))) |
| 79 | (and (not (null? props)) |
| 80 | props)))) |
| 81 | |
| 82 | ;;; Values to use for Elisp's nil and t. |
| 83 | |
| 84 | (define (nil-value loc) |
| 85 | (make-const loc (@ (language elisp runtime) nil-value))) |
| 86 | |
| 87 | (define (t-value loc) |
| 88 | (make-const loc (@ (language elisp runtime) t-value))) |
| 89 | |
| 90 | ;;; Modules that contain the value and function slot bindings. |
| 91 | |
| 92 | (define runtime '(language elisp runtime)) |
| 93 | |
| 94 | (define value-slot (@ (language elisp runtime) value-slot-module)) |
| 95 | |
| 96 | (define function-slot (@ (language elisp runtime) function-slot-module)) |
| 97 | |
| 98 | ;;; The backquoting works the same as quasiquotes in Scheme, but the |
| 99 | ;;; forms are named differently; to make easy adaptions, we define these |
| 100 | ;;; predicates checking for a symbol being the car of an |
| 101 | ;;; unquote/unquote-splicing/backquote form. |
| 102 | |
| 103 | (define (unquote? sym) |
| 104 | (and (symbol? sym) (eq? sym '#{,}#))) |
| 105 | |
| 106 | (define (unquote-splicing? sym) |
| 107 | (and (symbol? sym) (eq? sym '#{,@}#))) |
| 108 | |
| 109 | ;;; Build a call to a primitive procedure nicely. |
| 110 | |
| 111 | (define (call-primitive loc sym . args) |
| 112 | (make-primcall loc sym args)) |
| 113 | |
| 114 | ;;; Error reporting routine for syntax/compilation problems or build |
| 115 | ;;; code for a runtime-error output. |
| 116 | |
| 117 | (define (report-error loc . args) |
| 118 | (apply error args)) |
| 119 | |
| 120 | (define (runtime-error loc msg . args) |
| 121 | (make-primcall loc 'error |
| 122 | (cons (make-const loc msg) args))) |
| 123 | |
| 124 | ;;; Generate code to ensure a global symbol is there for further use of |
| 125 | ;;; a given symbol. In general during the compilation, those needed are |
| 126 | ;;; only tracked with the bindings data structure. Afterwards, however, |
| 127 | ;;; for all those needed symbols the globals are really generated with |
| 128 | ;;; this routine. |
| 129 | |
| 130 | (define (generate-ensure-global loc sym module) |
| 131 | (make-call loc |
| 132 | (make-module-ref loc runtime 'ensure-fluid! #t) |
| 133 | (list (make-const loc module) |
| 134 | (make-const loc sym)))) |
| 135 | |
| 136 | (define (ensuring-globals loc bindings body) |
| 137 | (make-sequence |
| 138 | loc |
| 139 | `(,@(map-globals-needed (fluid-ref bindings) |
| 140 | (lambda (mod sym) |
| 141 | (generate-ensure-global loc sym mod))) |
| 142 | ,body))) |
| 143 | |
| 144 | ;;; Build a construct that establishes dynamic bindings for certain |
| 145 | ;;; variables. We may want to choose between binding with fluids and |
| 146 | ;;; with-fluids* and using just ordinary module symbols and |
| 147 | ;;; setting/reverting their values with a dynamic-wind. |
| 148 | |
| 149 | (define (let-dynamic loc syms module vals body) |
| 150 | (call-primitive |
| 151 | loc |
| 152 | 'with-fluids* |
| 153 | (make-primcall loc 'list |
| 154 | (map (lambda (sym) |
| 155 | (make-module-ref loc module sym #t)) |
| 156 | syms)) |
| 157 | (make-primcall loc 'list vals) |
| 158 | (make-lambda loc |
| 159 | '() |
| 160 | (make-lambda-case #f '() #f #f #f '() '() body #f)))) |
| 161 | |
| 162 | ;;; Handle access to a variable (reference/setting) correctly depending |
| 163 | ;;; on whether it is currently lexically or dynamically bound. lexical |
| 164 | ;;; access is done only for references to the value-slot module! |
| 165 | |
| 166 | (define (access-variable loc |
| 167 | sym |
| 168 | module |
| 169 | handle-global |
| 170 | handle-lexical |
| 171 | handle-dynamic) |
| 172 | (let ((lexical (get-lexical-binding (fluid-ref bindings-data) sym))) |
| 173 | (cond |
| 174 | (lexical (handle-lexical lexical)) |
| 175 | ((equal? module function-slot) (handle-global)) |
| 176 | (else (handle-dynamic))))) |
| 177 | |
| 178 | ;;; Generate code to reference a variable. For references in the |
| 179 | ;;; value-slot module, we may want to generate a lexical reference |
| 180 | ;;; instead if the variable has a lexical binding. |
| 181 | |
| 182 | (define (reference-variable loc sym module) |
| 183 | (access-variable |
| 184 | loc |
| 185 | sym |
| 186 | module |
| 187 | (lambda () (make-module-ref loc module sym #t)) |
| 188 | (lambda (lexical) (make-lexical-ref loc lexical lexical)) |
| 189 | (lambda () |
| 190 | (mark-global-needed! (fluid-ref bindings-data) sym module) |
| 191 | (call-primitive loc |
| 192 | 'fluid-ref |
| 193 | (make-module-ref loc module sym #t))))) |
| 194 | |
| 195 | ;;; Generate code to set a variable. Just as with reference-variable, in |
| 196 | ;;; case of a reference to value-slot, we want to generate a lexical set |
| 197 | ;;; when the variable has a lexical binding. |
| 198 | |
| 199 | (define (set-variable! loc sym module value) |
| 200 | (access-variable |
| 201 | loc |
| 202 | sym |
| 203 | module |
| 204 | (lambda () |
| 205 | (make-call |
| 206 | loc |
| 207 | (make-module-ref loc runtime 'set-variable! #t) |
| 208 | (list (make-const loc module) (make-const loc sym) value))) |
| 209 | (lambda (lexical) (make-lexical-set loc lexical lexical value)) |
| 210 | (lambda () |
| 211 | (mark-global-needed! (fluid-ref bindings-data) sym module) |
| 212 | (call-primitive loc |
| 213 | 'fluid-set! |
| 214 | (make-module-ref loc module sym #t) |
| 215 | value)))) |
| 216 | |
| 217 | ;;; Process the bindings part of a let or let* expression; that is, |
| 218 | ;;; check for correctness and bring it to the form ((sym1 . val1) (sym2 |
| 219 | ;;; . val2) ...). |
| 220 | |
| 221 | (define (process-let-bindings loc bindings) |
| 222 | (map |
| 223 | (lambda (b) |
| 224 | (if (symbol? b) |
| 225 | (cons b 'nil) |
| 226 | (if (or (not (list? b)) |
| 227 | (not (= (length b) 2))) |
| 228 | (report-error |
| 229 | loc |
| 230 | "expected symbol or list of 2 elements in let") |
| 231 | (if (not (symbol? (car b))) |
| 232 | (report-error loc "expected symbol in let") |
| 233 | (cons (car b) (cadr b)))))) |
| 234 | bindings)) |
| 235 | |
| 236 | ;;; Split the let bindings into a list to be done lexically and one |
| 237 | ;;; dynamically. A symbol will be bound lexically if and only if: We're |
| 238 | ;;; processing a lexical-let (i.e. module is 'lexical), OR we're |
| 239 | ;;; processing a value-slot binding AND the symbol is already lexically |
| 240 | ;;; bound or is always lexical, OR we're processing a function-slot |
| 241 | ;;; binding. |
| 242 | |
| 243 | (define (bind-lexically? sym module) |
| 244 | (or (eq? module 'lexical) |
| 245 | (eq? module function-slot) |
| 246 | (and (equal? module value-slot) |
| 247 | (let ((always (fluid-ref always-lexical))) |
| 248 | (or (eq? always 'all) |
| 249 | (memq sym always) |
| 250 | (get-lexical-binding (fluid-ref bindings-data) sym)))))) |
| 251 | |
| 252 | (define (split-let-bindings bindings module) |
| 253 | (let iterate ((tail bindings) |
| 254 | (lexical '()) |
| 255 | (dynamic '())) |
| 256 | (if (null? tail) |
| 257 | (values (reverse lexical) (reverse dynamic)) |
| 258 | (if (bind-lexically? (caar tail) module) |
| 259 | (iterate (cdr tail) (cons (car tail) lexical) dynamic) |
| 260 | (iterate (cdr tail) lexical (cons (car tail) dynamic)))))) |
| 261 | |
| 262 | ;;; Compile let and let* expressions. The code here is used both for |
| 263 | ;;; let/let* and flet/flet*, just with a different bindings module. |
| 264 | ;;; |
| 265 | ;;; A special module value 'lexical means that we're doing a lexical-let |
| 266 | ;;; instead and the bindings should not be saved to globals at all but |
| 267 | ;;; be done with the lexical framework instead. |
| 268 | |
| 269 | ;;; Let is done with a single call to let-dynamic binding them locally |
| 270 | ;;; to new values all "at once". If there is at least one variable to |
| 271 | ;;; bind lexically among the bindings, we first do a let for all of them |
| 272 | ;;; to evaluate all values before any bindings take place, and then call |
| 273 | ;;; let-dynamic for the variables to bind dynamically. |
| 274 | |
| 275 | (define (generate-let loc module bindings body) |
| 276 | (let ((bind (process-let-bindings loc bindings))) |
| 277 | (call-with-values |
| 278 | (lambda () (split-let-bindings bind module)) |
| 279 | (lambda (lexical dynamic) |
| 280 | (for-each (lambda (sym) |
| 281 | (mark-global-needed! (fluid-ref bindings-data) |
| 282 | sym |
| 283 | module)) |
| 284 | (map car dynamic)) |
| 285 | (let ((make-values (lambda (for) |
| 286 | (map (lambda (el) (compile-expr (cdr el))) |
| 287 | for))) |
| 288 | (make-body (lambda () |
| 289 | (make-sequence loc (map compile-expr body))))) |
| 290 | (if (null? lexical) |
| 291 | (let-dynamic loc (map car dynamic) module |
| 292 | (make-values dynamic) (make-body)) |
| 293 | (let* ((lexical-syms (map (lambda (el) (gensym)) lexical)) |
| 294 | (dynamic-syms (map (lambda (el) (gensym)) dynamic)) |
| 295 | (all-syms (append lexical-syms dynamic-syms)) |
| 296 | (vals (append (make-values lexical) |
| 297 | (make-values dynamic)))) |
| 298 | (make-let loc |
| 299 | all-syms |
| 300 | all-syms |
| 301 | vals |
| 302 | (with-lexical-bindings |
| 303 | (fluid-ref bindings-data) |
| 304 | (map car lexical) lexical-syms |
| 305 | (lambda () |
| 306 | (if (null? dynamic) |
| 307 | (make-body) |
| 308 | (let-dynamic loc |
| 309 | (map car dynamic) |
| 310 | module |
| 311 | (map |
| 312 | (lambda (sym) |
| 313 | (make-lexical-ref loc |
| 314 | sym |
| 315 | sym)) |
| 316 | dynamic-syms) |
| 317 | (make-body))))))))))))) |
| 318 | |
| 319 | ;;; Let* is compiled to a cascaded set of "small lets" for each binding |
| 320 | ;;; in turn so that each one already sees the preceding bindings. |
| 321 | |
| 322 | (define (generate-let* loc module bindings body) |
| 323 | (let ((bind (process-let-bindings loc bindings))) |
| 324 | (begin |
| 325 | (for-each (lambda (sym) |
| 326 | (if (not (bind-lexically? sym module)) |
| 327 | (mark-global-needed! (fluid-ref bindings-data) |
| 328 | sym |
| 329 | module))) |
| 330 | (map car bind)) |
| 331 | (let iterate ((tail bind)) |
| 332 | (if (null? tail) |
| 333 | (make-sequence loc (map compile-expr body)) |
| 334 | (let ((sym (caar tail)) |
| 335 | (value (compile-expr (cdar tail)))) |
| 336 | (if (bind-lexically? sym module) |
| 337 | (let ((target (gensym))) |
| 338 | (make-let loc |
| 339 | `(,target) |
| 340 | `(,target) |
| 341 | `(,value) |
| 342 | (with-lexical-bindings |
| 343 | (fluid-ref bindings-data) |
| 344 | `(,sym) |
| 345 | `(,target) |
| 346 | (lambda () (iterate (cdr tail)))))) |
| 347 | (let-dynamic loc |
| 348 | `(,(caar tail)) |
| 349 | module |
| 350 | `(,value) |
| 351 | (iterate (cdr tail)))))))))) |
| 352 | |
| 353 | ;;; Split the argument list of a lambda expression into required, |
| 354 | ;;; optional and rest arguments and also check it is actually valid. |
| 355 | ;;; Additionally, we create a list of all "local variables" (that is, |
| 356 | ;;; required, optional and rest arguments together) and also this one |
| 357 | ;;; split into those to be bound lexically and dynamically. Returned is |
| 358 | ;;; as multiple values: required optional rest lexical dynamic |
| 359 | |
| 360 | (define (bind-arg-lexical? arg) |
| 361 | (let ((always (fluid-ref always-lexical))) |
| 362 | (or (eq? always 'all) |
| 363 | (memq arg always)))) |
| 364 | |
| 365 | (define (split-lambda-arguments loc args) |
| 366 | (let iterate ((tail args) |
| 367 | (mode 'required) |
| 368 | (required '()) |
| 369 | (optional '()) |
| 370 | (lexical '()) |
| 371 | (dynamic '())) |
| 372 | (cond |
| 373 | ((null? tail) |
| 374 | (let ((final-required (reverse required)) |
| 375 | (final-optional (reverse optional)) |
| 376 | (final-lexical (reverse lexical)) |
| 377 | (final-dynamic (reverse dynamic))) |
| 378 | (values final-required |
| 379 | final-optional |
| 380 | #f |
| 381 | final-lexical |
| 382 | final-dynamic))) |
| 383 | ((and (eq? mode 'required) |
| 384 | (eq? (car tail) '&optional)) |
| 385 | (iterate (cdr tail) 'optional required optional lexical dynamic)) |
| 386 | ((eq? (car tail) '&rest) |
| 387 | (if (or (null? (cdr tail)) |
| 388 | (not (null? (cddr tail)))) |
| 389 | (report-error loc "expected exactly one symbol after &rest") |
| 390 | (let* ((rest (cadr tail)) |
| 391 | (rest-lexical (bind-arg-lexical? rest)) |
| 392 | (final-required (reverse required)) |
| 393 | (final-optional (reverse optional)) |
| 394 | (final-lexical (reverse (if rest-lexical |
| 395 | (cons rest lexical) |
| 396 | lexical))) |
| 397 | (final-dynamic (reverse (if rest-lexical |
| 398 | dynamic |
| 399 | (cons rest dynamic))))) |
| 400 | (values final-required |
| 401 | final-optional |
| 402 | rest |
| 403 | final-lexical |
| 404 | final-dynamic)))) |
| 405 | (else |
| 406 | (if (not (symbol? (car tail))) |
| 407 | (report-error loc |
| 408 | "expected symbol in argument list, got" |
| 409 | (car tail)) |
| 410 | (let* ((arg (car tail)) |
| 411 | (bind-lexical (bind-arg-lexical? arg)) |
| 412 | (new-lexical (if bind-lexical |
| 413 | (cons arg lexical) |
| 414 | lexical)) |
| 415 | (new-dynamic (if bind-lexical |
| 416 | dynamic |
| 417 | (cons arg dynamic)))) |
| 418 | (case mode |
| 419 | ((required) (iterate (cdr tail) mode |
| 420 | (cons arg required) optional |
| 421 | new-lexical new-dynamic)) |
| 422 | ((optional) (iterate (cdr tail) mode |
| 423 | required (cons arg optional) |
| 424 | new-lexical new-dynamic)) |
| 425 | (else |
| 426 | (error "invalid mode in split-lambda-arguments" |
| 427 | mode))))))))) |
| 428 | |
| 429 | ;;; Compile a lambda expression. One thing we have to be aware of is |
| 430 | ;;; that lambda arguments are usually dynamically bound, even when a |
| 431 | ;;; lexical binding is intact for a symbol. For symbols that are marked |
| 432 | ;;; as 'always lexical,' however, we lexically bind here as well, and |
| 433 | ;;; thus we get them out of the let-dynamic call and register a lexical |
| 434 | ;;; binding for them (the lexical target variable is already there, |
| 435 | ;;; namely the real lambda argument from TreeIL). |
| 436 | |
| 437 | (define (compile-lambda loc args body) |
| 438 | (if (not (list? args)) |
| 439 | (report-error loc "expected list for argument-list" args)) |
| 440 | (if (null? body) |
| 441 | (report-error loc "function body must not be empty")) |
| 442 | (receive (required optional rest lexical dynamic) |
| 443 | (split-lambda-arguments loc args) |
| 444 | (define (process-args args) |
| 445 | (define (find-pairs pairs filter) |
| 446 | (lset-intersection (lambda (name+sym x) |
| 447 | (eq? (car name+sym) x)) |
| 448 | pairs |
| 449 | filter)) |
| 450 | (let* ((syms (map (lambda (x) (gensym)) args)) |
| 451 | (pairs (map cons args syms)) |
| 452 | (lexical-pairs (find-pairs pairs lexical)) |
| 453 | (dynamic-pairs (find-pairs pairs dynamic))) |
| 454 | (values syms pairs lexical-pairs dynamic-pairs))) |
| 455 | (let*-values (((required-syms |
| 456 | required-pairs |
| 457 | required-lex-pairs |
| 458 | required-dyn-pairs) |
| 459 | (process-args required)) |
| 460 | ((optional-syms |
| 461 | optional-pairs |
| 462 | optional-lex-pairs |
| 463 | optional-dyn-pairs) |
| 464 | (process-args optional)) |
| 465 | ((rest-syms rest-pairs rest-lex-pairs rest-dyn-pairs) |
| 466 | (process-args (if rest (list rest) '()))) |
| 467 | ((the-rest-sym) (if rest (car rest-syms) #f)) |
| 468 | ((all-syms) (append required-syms |
| 469 | optional-syms |
| 470 | rest-syms)) |
| 471 | ((all-lex-pairs) (append required-lex-pairs |
| 472 | optional-lex-pairs |
| 473 | rest-lex-pairs)) |
| 474 | ((all-dyn-pairs) (append required-dyn-pairs |
| 475 | optional-dyn-pairs |
| 476 | rest-dyn-pairs))) |
| 477 | (for-each (lambda (sym) |
| 478 | (mark-global-needed! (fluid-ref bindings-data) |
| 479 | sym |
| 480 | value-slot)) |
| 481 | dynamic) |
| 482 | (with-dynamic-bindings |
| 483 | (fluid-ref bindings-data) |
| 484 | dynamic |
| 485 | (lambda () |
| 486 | (with-lexical-bindings |
| 487 | (fluid-ref bindings-data) |
| 488 | (map car all-lex-pairs) |
| 489 | (map cdr all-lex-pairs) |
| 490 | (lambda () |
| 491 | (make-lambda |
| 492 | loc |
| 493 | '() |
| 494 | (make-lambda-case |
| 495 | #f |
| 496 | required |
| 497 | optional |
| 498 | rest |
| 499 | #f |
| 500 | (map (lambda (x) (nil-value loc)) optional) |
| 501 | all-syms |
| 502 | (let ((compiled-body |
| 503 | (make-sequence loc (map compile-expr body)))) |
| 504 | (make-sequence |
| 505 | loc |
| 506 | (list |
| 507 | (if rest |
| 508 | (make-conditional |
| 509 | loc |
| 510 | (call-primitive loc |
| 511 | 'null? |
| 512 | (make-lexical-ref loc |
| 513 | rest |
| 514 | the-rest-sym)) |
| 515 | (make-lexical-set loc |
| 516 | rest |
| 517 | the-rest-sym |
| 518 | (nil-value loc)) |
| 519 | (make-void loc)) |
| 520 | (make-void loc)) |
| 521 | (if (null? dynamic) |
| 522 | compiled-body |
| 523 | (let-dynamic loc |
| 524 | dynamic |
| 525 | value-slot |
| 526 | (map (lambda (name-sym) |
| 527 | (make-lexical-ref |
| 528 | loc |
| 529 | (car name-sym) |
| 530 | (cdr name-sym))) |
| 531 | all-dyn-pairs) |
| 532 | compiled-body))))) |
| 533 | #f))))))))) |
| 534 | |
| 535 | ;;; Handle the common part of defconst and defvar, that is, checking for |
| 536 | ;;; a correct doc string and arguments as well as maybe in the future |
| 537 | ;;; handling the docstring somehow. |
| 538 | |
| 539 | (define (handle-var-def loc sym doc) |
| 540 | (cond |
| 541 | ((not (symbol? sym)) (report-error loc "expected symbol, got" sym)) |
| 542 | ((> (length doc) 1) (report-error loc "too many arguments to defvar")) |
| 543 | ((and (not (null? doc)) (not (string? (car doc)))) |
| 544 | (report-error loc "expected string as third argument of defvar, got" |
| 545 | (car doc))) |
| 546 | ;; TODO: Handle doc string if present. |
| 547 | (else #t))) |
| 548 | |
| 549 | ;;; Handle macro and special operator bindings. |
| 550 | |
| 551 | (define (find-operator sym type) |
| 552 | (and |
| 553 | (symbol? sym) |
| 554 | (module-defined? (resolve-interface function-slot) sym) |
| 555 | (let* ((op (module-ref (resolve-module function-slot) sym)) |
| 556 | (op (if (fluid? op) (fluid-ref op) op))) |
| 557 | (if (and (pair? op) (eq? (car op) type)) |
| 558 | (cdr op) |
| 559 | #f)))) |
| 560 | |
| 561 | ;;; See if a (backquoted) expression contains any unquotes. |
| 562 | |
| 563 | (define (contains-unquotes? expr) |
| 564 | (if (pair? expr) |
| 565 | (if (or (unquote? (car expr)) (unquote-splicing? (car expr))) |
| 566 | #t |
| 567 | (or (contains-unquotes? (car expr)) |
| 568 | (contains-unquotes? (cdr expr)))) |
| 569 | #f)) |
| 570 | |
| 571 | ;;; Process a backquoted expression by building up the needed |
| 572 | ;;; cons/append calls. For splicing, it is assumed that the expression |
| 573 | ;;; spliced in evaluates to a list. The emacs manual does not really |
| 574 | ;;; state either it has to or what to do if it does not, but Scheme |
| 575 | ;;; explicitly forbids it and this seems reasonable also for elisp. |
| 576 | |
| 577 | (define (unquote-cell? expr) |
| 578 | (and (list? expr) (= (length expr) 2) (unquote? (car expr)))) |
| 579 | |
| 580 | (define (unquote-splicing-cell? expr) |
| 581 | (and (list? expr) (= (length expr) 2) (unquote-splicing? (car expr)))) |
| 582 | |
| 583 | (define (process-backquote loc expr) |
| 584 | (if (contains-unquotes? expr) |
| 585 | (if (pair? expr) |
| 586 | (if (or (unquote-cell? expr) (unquote-splicing-cell? expr)) |
| 587 | (compile-expr (cadr expr)) |
| 588 | (let* ((head (car expr)) |
| 589 | (processed-tail (process-backquote loc (cdr expr))) |
| 590 | (head-is-list-2 (and (list? head) |
| 591 | (= (length head) 2))) |
| 592 | (head-unquote (and head-is-list-2 |
| 593 | (unquote? (car head)))) |
| 594 | (head-unquote-splicing (and head-is-list-2 |
| 595 | (unquote-splicing? |
| 596 | (car head))))) |
| 597 | (if head-unquote-splicing |
| 598 | (call-primitive loc |
| 599 | 'append |
| 600 | (compile-expr (cadr head)) |
| 601 | processed-tail) |
| 602 | (call-primitive loc 'cons |
| 603 | (if head-unquote |
| 604 | (compile-expr (cadr head)) |
| 605 | (process-backquote loc head)) |
| 606 | processed-tail)))) |
| 607 | (report-error loc |
| 608 | "non-pair expression contains unquotes" |
| 609 | expr)) |
| 610 | (make-const loc expr))) |
| 611 | |
| 612 | ;;; Temporarily update a list of symbols that are handled specially |
| 613 | ;;; (disabled void check or always lexical) for compiling body. We need |
| 614 | ;;; to handle special cases for already all / set to all and the like. |
| 615 | |
| 616 | (define (with-added-symbols loc fluid syms body) |
| 617 | (if (null? body) |
| 618 | (report-error loc "symbol-list construct has empty body")) |
| 619 | (if (not (or (eq? syms 'all) |
| 620 | (and (list? syms) (and-map symbol? syms)))) |
| 621 | (report-error loc "invalid symbol list" syms)) |
| 622 | (let ((old (fluid-ref fluid)) |
| 623 | (make-body (lambda () |
| 624 | (make-sequence loc (map compile-expr body))))) |
| 625 | (if (eq? old 'all) |
| 626 | (make-body) |
| 627 | (let ((new (if (eq? syms 'all) |
| 628 | 'all |
| 629 | (append syms old)))) |
| 630 | (with-fluids ((fluid new)) |
| 631 | (make-body)))))) |
| 632 | |
| 633 | ;;; Special operators |
| 634 | |
| 635 | (defspecial progn (loc args) |
| 636 | (make-sequence loc (map compile-expr args))) |
| 637 | |
| 638 | (defspecial if (loc args) |
| 639 | (pmatch args |
| 640 | ((,cond ,then . ,else) |
| 641 | (make-conditional loc |
| 642 | (compile-expr cond) |
| 643 | (compile-expr then) |
| 644 | (if (null? else) |
| 645 | (nil-value loc) |
| 646 | (make-sequence loc |
| 647 | (map compile-expr else))))))) |
| 648 | |
| 649 | (defspecial defconst (loc args) |
| 650 | (pmatch args |
| 651 | ((,sym ,value . ,doc) |
| 652 | (if (handle-var-def loc sym doc) |
| 653 | (make-sequence loc |
| 654 | (list (set-variable! loc |
| 655 | sym |
| 656 | value-slot |
| 657 | (compile-expr value)) |
| 658 | (make-const loc sym))))))) |
| 659 | |
| 660 | (defspecial defvar (loc args) |
| 661 | (pmatch args |
| 662 | ((,sym) (make-const loc sym)) |
| 663 | ((,sym ,value . ,doc) |
| 664 | (if (handle-var-def loc sym doc) |
| 665 | (make-sequence |
| 666 | loc |
| 667 | (list |
| 668 | (make-conditional |
| 669 | loc |
| 670 | (make-conditional |
| 671 | loc |
| 672 | (call-primitive |
| 673 | loc |
| 674 | 'module-bound? |
| 675 | (call-primitive loc |
| 676 | 'resolve-interface |
| 677 | (make-const loc value-slot)) |
| 678 | (make-const loc sym)) |
| 679 | (call-primitive loc |
| 680 | 'fluid-bound? |
| 681 | (make-module-ref loc value-slot sym #t)) |
| 682 | (make-const loc #f)) |
| 683 | (make-void loc) |
| 684 | (set-variable! loc sym value-slot (compile-expr value))) |
| 685 | (make-const loc sym))))))) |
| 686 | |
| 687 | (defspecial setq (loc args) |
| 688 | (define (car* x) (if (null? x) '() (car x))) |
| 689 | (define (cdr* x) (if (null? x) '() (cdr x))) |
| 690 | (define (cadr* x) (car* (cdr* x))) |
| 691 | (define (cddr* x) (cdr* (cdr* x))) |
| 692 | (make-sequence |
| 693 | loc |
| 694 | (let loop ((args args) (last (nil-value loc))) |
| 695 | (if (null? args) |
| 696 | (list last) |
| 697 | (let ((sym (car args)) |
| 698 | (val (compile-expr (cadr* args)))) |
| 699 | (if (not (symbol? sym)) |
| 700 | (report-error loc "expected symbol in setq") |
| 701 | (cons |
| 702 | (set-variable! loc sym value-slot val) |
| 703 | (loop (cddr* args) |
| 704 | (reference-variable loc sym value-slot))))))))) |
| 705 | |
| 706 | (defspecial let (loc args) |
| 707 | (pmatch args |
| 708 | ((,bindings . ,body) |
| 709 | (generate-let loc value-slot bindings body)))) |
| 710 | |
| 711 | (defspecial lexical-let (loc args) |
| 712 | (pmatch args |
| 713 | ((,bindings . ,body) |
| 714 | (generate-let loc 'lexical bindings body)))) |
| 715 | |
| 716 | (defspecial flet (loc args) |
| 717 | (pmatch args |
| 718 | ((,bindings . ,body) |
| 719 | (generate-let loc function-slot bindings body)))) |
| 720 | |
| 721 | (defspecial let* (loc args) |
| 722 | (pmatch args |
| 723 | ((,bindings . ,body) |
| 724 | (generate-let* loc value-slot bindings body)))) |
| 725 | |
| 726 | (defspecial lexical-let* (loc args) |
| 727 | (pmatch args |
| 728 | ((,bindings . ,body) |
| 729 | (generate-let* loc 'lexical bindings body)))) |
| 730 | |
| 731 | (defspecial flet* (loc args) |
| 732 | (pmatch args |
| 733 | ((,bindings . ,body) |
| 734 | (generate-let* loc function-slot bindings body)))) |
| 735 | |
| 736 | ;;; Temporarily set symbols as always lexical only for the lexical scope |
| 737 | ;;; of a construct. |
| 738 | |
| 739 | (defspecial with-always-lexical (loc args) |
| 740 | (pmatch args |
| 741 | ((,syms . ,body) |
| 742 | (with-added-symbols loc always-lexical syms body)))) |
| 743 | |
| 744 | ;;; guile-ref allows building TreeIL's module references from within |
| 745 | ;;; elisp as a way to access data within the Guile universe. The module |
| 746 | ;;; and symbol referenced are static values, just like (@ module symbol) |
| 747 | ;;; does! |
| 748 | |
| 749 | (defspecial guile-ref (loc args) |
| 750 | (pmatch args |
| 751 | ((,module ,sym) (guard (and (list? module) (symbol? sym))) |
| 752 | (make-module-ref loc module sym #t)))) |
| 753 | |
| 754 | ;;; guile-primitive allows to create primitive references, which are |
| 755 | ;;; still a little faster. |
| 756 | |
| 757 | (defspecial guile-primitive (loc args) |
| 758 | (pmatch args |
| 759 | ((,sym) |
| 760 | (make-primitive-ref loc sym)))) |
| 761 | |
| 762 | ;;; A while construct is transformed into a tail-recursive loop like |
| 763 | ;;; this: |
| 764 | ;;; |
| 765 | ;;; (letrec ((iterate (lambda () |
| 766 | ;;; (if condition |
| 767 | ;;; (begin body |
| 768 | ;;; (iterate)) |
| 769 | ;;; #nil)))) |
| 770 | ;;; (iterate)) |
| 771 | ;;; |
| 772 | ;;; As letrec is not directly accessible from elisp, while is |
| 773 | ;;; implemented here instead of with a macro. |
| 774 | |
| 775 | (defspecial while (loc args) |
| 776 | (pmatch args |
| 777 | ((,condition . ,body) |
| 778 | (let* ((itersym (gensym)) |
| 779 | (compiled-body (map compile-expr body)) |
| 780 | (iter-call (make-call loc |
| 781 | (make-lexical-ref loc |
| 782 | 'iterate |
| 783 | itersym) |
| 784 | (list))) |
| 785 | (full-body (make-sequence loc |
| 786 | `(,@compiled-body ,iter-call))) |
| 787 | (lambda-body (make-conditional loc |
| 788 | (compile-expr condition) |
| 789 | full-body |
| 790 | (nil-value loc))) |
| 791 | (iter-thunk (make-lambda loc |
| 792 | '() |
| 793 | (make-lambda-case #f |
| 794 | '() |
| 795 | #f |
| 796 | #f |
| 797 | #f |
| 798 | '() |
| 799 | '() |
| 800 | lambda-body |
| 801 | #f)))) |
| 802 | (make-letrec loc |
| 803 | #f |
| 804 | '(iterate) |
| 805 | (list itersym) |
| 806 | (list iter-thunk) |
| 807 | iter-call))))) |
| 808 | |
| 809 | (defspecial function (loc args) |
| 810 | (pmatch args |
| 811 | (((lambda ,args . ,body)) |
| 812 | (compile-lambda loc args body)) |
| 813 | ((,sym) (guard (symbol? sym)) |
| 814 | (reference-variable loc sym function-slot)))) |
| 815 | |
| 816 | (defspecial defmacro (loc args) |
| 817 | (pmatch args |
| 818 | ((,name ,args . ,body) |
| 819 | (if (not (symbol? name)) |
| 820 | (report-error loc "expected symbol as macro name" name) |
| 821 | (let* ((tree-il |
| 822 | (make-sequence |
| 823 | loc |
| 824 | (list |
| 825 | (set-variable! |
| 826 | loc |
| 827 | name |
| 828 | function-slot |
| 829 | (make-primcall loc 'cons |
| 830 | (list (make-const loc 'macro) |
| 831 | (compile-lambda loc args body)))) |
| 832 | (make-const loc name))))) |
| 833 | (compile (ensuring-globals loc bindings-data tree-il) |
| 834 | #:from 'tree-il |
| 835 | #:to 'value) |
| 836 | tree-il))))) |
| 837 | |
| 838 | (defspecial defun (loc args) |
| 839 | (pmatch args |
| 840 | ((,name ,args . ,body) |
| 841 | (if (not (symbol? name)) |
| 842 | (report-error loc "expected symbol as function name" name) |
| 843 | (make-sequence loc |
| 844 | (list (set-variable! loc |
| 845 | name |
| 846 | function-slot |
| 847 | (compile-lambda loc |
| 848 | args |
| 849 | body)) |
| 850 | (make-const loc name))))))) |
| 851 | |
| 852 | (defspecial #{`}# (loc args) |
| 853 | (pmatch args |
| 854 | ((,val) |
| 855 | (process-backquote loc val)))) |
| 856 | |
| 857 | (defspecial quote (loc args) |
| 858 | (pmatch args |
| 859 | ((,val) |
| 860 | (make-const loc val)))) |
| 861 | |
| 862 | ;;; Compile a compound expression to Tree-IL. |
| 863 | |
| 864 | (define (compile-pair loc expr) |
| 865 | (let ((operator (car expr)) |
| 866 | (arguments (cdr expr))) |
| 867 | (cond |
| 868 | ((find-operator operator 'special-operator) |
| 869 | => (lambda (special-operator-function) |
| 870 | (special-operator-function loc arguments))) |
| 871 | ((find-operator operator 'macro) |
| 872 | => (lambda (macro-function) |
| 873 | (compile-expr (apply macro-function arguments)))) |
| 874 | (else |
| 875 | (make-call loc |
| 876 | (if (symbol? operator) |
| 877 | (reference-variable loc |
| 878 | operator |
| 879 | function-slot) |
| 880 | (compile-expr operator)) |
| 881 | (map compile-expr arguments)))))) |
| 882 | |
| 883 | ;;; Compile a symbol expression. This is a variable reference or maybe |
| 884 | ;;; some special value like nil. |
| 885 | |
| 886 | (define (compile-symbol loc sym) |
| 887 | (case sym |
| 888 | ((nil) (nil-value loc)) |
| 889 | ((t) (t-value loc)) |
| 890 | (else (reference-variable loc sym value-slot)))) |
| 891 | |
| 892 | ;;; Compile a single expression to TreeIL. |
| 893 | |
| 894 | (define (compile-expr expr) |
| 895 | (let ((loc (location expr))) |
| 896 | (cond |
| 897 | ((symbol? expr) |
| 898 | (compile-symbol loc expr)) |
| 899 | ((pair? expr) |
| 900 | (compile-pair loc expr)) |
| 901 | (else (make-const loc expr))))) |
| 902 | |
| 903 | ;;; Process the compiler options. |
| 904 | ;;; FIXME: Why is '(()) passed as options by the REPL? |
| 905 | |
| 906 | (define (valid-symbol-list-arg? value) |
| 907 | (or (eq? value 'all) |
| 908 | (and (list? value) (and-map symbol? value)))) |
| 909 | |
| 910 | (define (process-options! opt) |
| 911 | (if (and (not (null? opt)) |
| 912 | (not (equal? opt '(())))) |
| 913 | (if (null? (cdr opt)) |
| 914 | (report-error #f "Invalid compiler options" opt) |
| 915 | (let ((key (car opt)) |
| 916 | (value (cadr opt))) |
| 917 | (case key |
| 918 | ((#:warnings) ; ignore |
| 919 | #f) |
| 920 | ((#:always-lexical) |
| 921 | (if (valid-symbol-list-arg? value) |
| 922 | (fluid-set! always-lexical value) |
| 923 | (report-error #f |
| 924 | "Invalid value for #:always-lexical" |
| 925 | value))) |
| 926 | (else (report-error #f |
| 927 | "Invalid compiler option" |
| 928 | key))))))) |
| 929 | |
| 930 | ;;; Entry point for compilation to TreeIL. This creates the bindings |
| 931 | ;;; data structure, and after compiling the main expression we need to |
| 932 | ;;; make sure all globals for symbols used during the compilation are |
| 933 | ;;; created using the generate-ensure-global function. |
| 934 | |
| 935 | (define (compile-tree-il expr env opts) |
| 936 | (values |
| 937 | (with-fluids ((bindings-data (make-bindings)) |
| 938 | (disable-void-check '()) |
| 939 | (always-lexical '())) |
| 940 | (process-options! opts) |
| 941 | (let ((compiled (compile-expr expr))) |
| 942 | (ensuring-globals (location expr) bindings-data compiled))) |
| 943 | env |
| 944 | env)) |