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