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

   1 ;;; Guile Emac Lisp
   2
   3 ;; Copyright (C) 2001 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 2, 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 tree-il)
  24   #:use-module (system base pmatch)
  25   #:use-module (system base compile)
  26   #:export (compile-tree-il))
  27
  28
  29 ; Find the source properties of some parsed expression if there are any
  30 ; associated with it.
  31
  32 (define (location x)
  33   (and (pair? x)
  34        (let ((props (source-properties x)))
  35          (and (not (null? props))
  36               props))))
  37
  38
  39 ; Values to use for Elisp's nil and t.
  40
  41 (define (nil-value loc) (make-const loc (@ (language elisp runtime) nil-value)))
  42 (define (t-value loc) (make-const loc (@ (language elisp runtime) t-value)))
  43
  44
  45 ; Modules that contain the value and function slot bindings.
  46
  47 (define runtime '(language elisp runtime))
  48 (define value-slot '(language elisp runtime value-slot))
  49 (define function-slot '(language elisp runtime function-slot))
  50 (define macro-slot '(language elisp runtime macro-slot))
  51
  52
  53 ; The backquoting works the same as quasiquotes in Scheme, but the forms are
  54 ; named differently; to make easy adaptions, we define these predicates checking
  55 ; for a symbol being the car of an unquote/unquote-splicing/backquote form.
  56
  57 ; FIXME: Remove the quasiquote/unquote/unquote-splicing symbols when real elisp
  58 ; reader is there.
  59
  60 (define (backquote? sym)
  61   (and (symbol? sym) (or (eq? sym 'quasiquote)
  62                          (eq? sym '\`))))
  63
  64 (define (unquote? sym)
  65   (and (symbol? sym) (or (eq? sym 'unquote)
  66                          (eq? sym '\,))))
  67
  68 (define (unquote-splicing? sym)
  69   (and (symbol? sym) (or (eq? sym 'unquote-splicing)
  70                          (eq? sym '\,@))))
  71
  72
  73 ; Build a call to a primitive procedure nicely.
  74
  75 (define (call-primitive loc sym . args)
  76   (make-application loc (make-primitive-ref loc sym) args))
  77
  78
  79 ; Error reporting routine for syntax/compilation problems or build code for
  80 ; a runtime-error output.
  81
  82 (define (report-error loc . args)
  83   (apply error args))
  84
  85 (define (runtime-error loc msg . args)
  86   (make-application loc (make-primitive-ref loc 'error)
  87     (cons (make-const loc msg) args)))
  88
  89
  90 ; Generate code to ensure a fluid is there for further use of a given symbol.
  91 ; ensure-fluids-for does the same for a list of symbols and builds a sequence
  92 ; that executes the fluid-insurances first, followed by all body commands; this
  93 ; is a routine for convenience (needed with let, let*, lambda).
  94
  95 (define (ensure-fluid! loc sym module)
  96   (let ((resolved-module (call-primitive loc 'resolve-module
  97                                          (make-const loc module)))
  98         (resolved-intf (call-primitive loc 'resolve-interface
  99                                        (make-const loc module))))
 100     (make-conditional loc
 101       (call-primitive loc 'module-defined? resolved-intf (make-const loc sym))
 102       (make-void loc)
 103       (make-sequence loc
 104         (list (call-primitive loc 'module-define!
 105                 resolved-module (make-const loc sym)
 106                 (call-primitive loc 'make-fluid))
 107               (call-primitive loc 'module-export!
 108                 resolved-module
 109                 (call-primitive loc 'list (make-const loc sym)))
 110               (call-primitive loc 'fluid-set!
 111                 (make-module-ref loc module sym #t)
 112                 (make-module-ref loc runtime 'void #t)))))))
 113
 114
 115 (define (ensure-fluids-for loc syms module . body)
 116   (make-sequence loc
 117     `(,@(map (lambda (sym) (ensure-fluid! loc sym module)) syms)
 118       ,@body)))
 119
 120
 121 ; Generate code to reference a fluid saved variable.
 122
 123 (define (reference-variable loc sym module)
 124   (make-sequence loc
 125     (list (ensure-fluid! loc sym module)
 126           (call-primitive loc 'fluid-ref
 127                           (make-module-ref loc module sym #t)))))
 128
 129
 130 ; Reference a variable and error if the value is void.
 131
 132 (define (reference-with-check loc sym module)
 133   (let ((var (gensym)))
 134     (make-let loc '(value) `(,var) `(,(reference-variable loc sym module))
 135       (make-conditional loc
 136         (call-primitive loc 'eq?
 137                         (make-module-ref loc runtime 'void #t)
 138                         (make-lexical-ref loc 'value var))
 139         (runtime-error loc "variable is void:" (make-const loc sym))
 140         (make-lexical-ref loc 'value var)))))
 141
 142
 143 ; Generate code to set a fluid saved variable.
 144
 145 (define (set-variable! loc sym module value)
 146   (make-sequence loc
 147     (list (ensure-fluid! loc sym module)
 148           (call-primitive loc 'fluid-set!
 149                           (make-module-ref loc module sym #t)
 150                           value))))
 151
 152
 153 ; Process the bindings part of a let or let* expression; that is, check for
 154 ; correctness and bring it to the form ((sym1 . val1) (sym2 . val2) ...).
 155
 156 (define (process-let-bindings loc bindings)
 157   (map (lambda (b)
 158          (if (symbol? b)
 159            (cons b 'nil)
 160            (if (or (not (list? b))
 161                    (not (= (length b) 2)))
 162              (report-error loc "expected symbol or list of 2 elements in let")
 163              (if (not (symbol? (car b)))
 164                (report-error loc "expected symbol in let")
 165                (cons (car b) (cadr b))))))
 166        bindings))
 167
 168
 169 ; Split the argument list of a lambda expression into required, optional and
 170 ; rest arguments and also check it is actually valid.
 171
 172 (define (split-lambda-arguments loc args)
 173   (let iterate ((tail args)
 174                 (mode 'required)
 175                 (required '())
 176                 (optional '()))
 177     (cond
 178
 179       ((null? tail)
 180        (values (reverse required) (reverse optional) #f))
 181
 182       ((and (eq? mode 'required)
 183             (eq? (car tail) '&optional))
 184        (iterate (cdr tail) 'optional required optional))
 185
 186       ((eq? (car tail) '&rest)
 187        (if (or (null? (cdr tail))
 188                (not (null? (cddr tail))))
 189          (report-error loc "expected exactly one symbol after &rest")
 190          (values (reverse required) (reverse optional) (cadr tail))))
 191
 192       (else
 193         (if (not (symbol? (car tail)))
 194           (report-error loc "expected symbol in argument list, got" (car tail))
 195           (case mode
 196             ((required) (iterate (cdr tail) mode
 197                                  (cons (car tail) required) optional))
 198             ((optional) (iterate (cdr tail) mode
 199                                  required (cons (car tail) optional)))
 200             ((else) (error "invalid mode in split-lambda-arguments" mode))))))))
 201
 202
 203 ; Compile a lambda expression.  Things get a little complicated because TreeIL
 204 ; does not allow optional arguments but only one rest argument, and also the
 205 ; rest argument should be nil instead of '() for no values given.  Because of
 206 ; this, we have to do a little preprocessing to get everything done before the
 207 ; real body is called.
 208 ;
 209 ; (lambda (a &optional b &rest c) body) should become:
 210 ; (lambda (a_ . rest_)
 211 ;   (with-fluids* (list a b c) (list a_ nil nil)
 212 ;     (lambda ()
 213 ;       (if (not (null? rest_))
 214 ;         (begin
 215 ;           (fluid-set! b (car rest_))
 216 ;           (set! rest_ (cdr rest_))
 217 ;           (if (not (null? rest_))
 218 ;             (fluid-set! c rest_))))
 219 ;       body)))
 220 ;
 221 ; This is formulated quite imperatively, but I think in this case that is quite
 222 ; clear and better than creating a lot of nested let's.
 223
 224 (define (compile-lambda loc args body)
 225   (if (not (list? args))
 226     (error "expected list for argument-list" args))
 227   (if (null? body)
 228     (error "function body might not be empty"))
 229   (call-with-values
 230     (lambda ()
 231       (split-lambda-arguments loc args))
 232     (lambda (required optional rest)
 233       (let ((required-sym (map (lambda (sym) (gensym)) required))
 234             (rest-sym (if (or rest (not (null? optional))) (gensym) '())))
 235         (let ((real-args (append required-sym rest-sym))
 236               (locals `(,@required ,@optional ,@(if rest (list rest) '()))))
 237           (make-lambda loc
 238             real-args real-args '()
 239             (ensure-fluids-for loc locals value-slot
 240               (call-primitive loc 'with-fluids*
 241                 (make-application loc (make-primitive-ref loc 'list)
 242                   (map (lambda (sym) (make-module-ref loc value-slot sym #t))
 243                        locals))
 244                 (make-application loc (make-primitive-ref loc 'list)
 245                   (append (map (lambda (sym) (make-lexical-ref loc sym sym))
 246                                required-sym)
 247                           (map (lambda (sym) (nil-value loc))
 248                                (if rest
 249                                  `(,@optional ,rest-sym)
 250                                  optional))))
 251                 (make-lambda loc '() '() '()
 252                   (make-sequence loc
 253                     `(,(process-optionals loc optional rest-sym)
 254                       ,(process-rest loc rest rest-sym)
 255                       ,@(map compile-expr body))))))))))))
 256
 257 ; Build the code to handle setting of optional arguments that are present
 258 ; and updating the rest list.
 259 (define (process-optionals loc optional rest-sym)
 260   (let iterate ((tail optional))
 261     (if (null? tail)
 262       (make-void loc)
 263       (make-conditional loc
 264         (call-primitive loc 'null? (make-lexical-ref loc rest-sym rest-sym))
 265         (make-void loc)
 266         (make-sequence loc
 267           (list (set-variable! loc (car tail) value-slot
 268                   (call-primitive loc 'car
 269                                   (make-lexical-ref loc rest-sym rest-sym)))
 270                 (make-lexical-set loc rest-sym rest-sym
 271                   (call-primitive loc 'cdr
 272                                   (make-lexical-ref loc rest-sym rest-sym)))
 273                 (iterate (cdr tail))))))))
 274
 275 ; This builds the code to set the rest variable to nil if it is empty.
 276 (define (process-rest loc rest rest-sym)
 277   (let ((rest-empty (call-primitive loc 'null?
 278                                     (make-lexical-ref loc rest-sym rest-sym))))
 279     (cond
 280       (rest
 281        (make-conditional loc rest-empty
 282          (make-void loc)
 283          (set-variable! loc rest value-slot
 284                         (make-lexical-ref loc rest-sym rest-sym))))
 285       ((not (null? rest-sym))
 286        (make-conditional loc rest-empty
 287          (make-void loc)
 288          (runtime-error loc "too many arguments and no rest argument")))
 289       (else (make-void loc)))))
 290
 291
 292 ; Handle the common part of defconst and defvar, that is, checking for a correct
 293 ; doc string and arguments as well as maybe in the future handling the docstring
 294 ; somehow.
 295
 296 (define (handle-var-def loc sym doc)
 297   (cond
 298     ((not (symbol? sym)) (report-error loc "expected symbol, got" sym))
 299     ((> (length doc) 1) (report-error loc "too many arguments to defvar"))
 300     ((and (not (null? doc)) (not (string? (car doc))))
 301      (report-error loc "expected string as third argument of defvar, got"
 302                    (car doc)))
 303     ; TODO: Handle doc string if present.
 304     (else #t)))
 305
 306
 307 ; Handle macro bindings.
 308
 309 (define (is-macro? sym)
 310   (module-defined? (resolve-interface macro-slot) sym))
 311
 312 (define (define-macro! loc sym definition)
 313   (let ((resolved (resolve-module macro-slot)))
 314     (if (is-macro? sym)
 315       (report-error loc "macro is already defined" sym)
 316       (begin
 317         (module-define! resolved sym definition)
 318         (module-export! resolved (list sym))))))
 319
 320 (define (get-macro sym)
 321   (module-ref (resolve-module macro-slot) sym))
 322
 323
 324 ; See if a (backquoted) expression contains any unquotes.
 325
 326 (define (contains-unquotes? expr)
 327   (if (pair? expr)
 328     (if (or (unquote? (car expr)) (unquote-splicing? (car expr)))
 329       #t
 330       (or (contains-unquotes? (car expr))
 331           (contains-unquotes? (cdr expr))))
 332     #f))
 333
 334
 335 ; Process a backquoted expression by building up the needed cons/append calls.
 336 ; For splicing, it is assumed that the expression spliced in evaluates to a
 337 ; list.  The emacs manual does not really state either it has to or what to do
 338 ; if it does not, but Scheme explicitly forbids it and this seems reasonable
 339 ; also for elisp.
 340
 341 (define (unquote-cell? expr)
 342   (and (list? expr) (= (length expr) 2) (unquote? (car expr))))
 343 (define (unquote-splicing-cell? expr)
 344   (and (list? expr) (= (length expr) 2) (unquote-splicing? (car expr))))
 345
 346 (define (process-backquote loc expr)
 347   (if (contains-unquotes? expr)
 348     (if (pair? expr)
 349       (if (or (unquote-cell? expr) (unquote-splicing-cell? expr))
 350         (compile-expr (cadr expr))
 351         (let* ((head (car expr))
 352                (processed-tail (process-backquote loc (cdr expr)))
 353                (head-is-list-2 (and (list? head) (= (length head) 2)))
 354                (head-unquote (and head-is-list-2 (unquote? (car head))))
 355                (head-unquote-splicing (and head-is-list-2
 356                                            (unquote-splicing? (car head)))))
 357           (if head-unquote-splicing
 358             (call-primitive loc 'append
 359               (compile-expr (cadr head)) processed-tail)
 360             (call-primitive loc 'cons
 361               (if head-unquote
 362                 (compile-expr (cadr head))
 363                 (process-backquote loc head))
 364               processed-tail))))
 365       (error "non-pair expression contains unquotes" expr))
 366     (make-const loc expr)))
 367
 368
 369 ; Compile a symbol expression.  This is a variable reference or maybe some
 370 ; special value like nil.
 371
 372 (define (compile-symbol loc sym)
 373   (case sym
 374     ((nil) (nil-value loc))
 375     ((t) (t-value loc))
 376     (else (reference-with-check loc sym value-slot))))
 377
 378
 379 ; Compile a pair-expression (that is, any structure-like construct).
 380
 381 (define (compile-pair loc expr)
 382   (pmatch expr
 383
 384     ((progn . ,forms)
 385      (make-sequence loc (map compile-expr forms)))
 386
 387     ((if ,condition ,ifclause)
 388      (make-conditional loc (compile-expr condition)
 389                            (compile-expr ifclause)
 390                            (nil-value loc)))
 391     ((if ,condition ,ifclause ,elseclause)
 392      (make-conditional loc (compile-expr condition)
 393                            (compile-expr ifclause)
 394                            (compile-expr elseclause)))
 395     ((if ,condition ,ifclause . ,elses)
 396      (make-conditional loc (compile-expr condition)
 397                            (compile-expr ifclause)
 398                            (make-sequence loc (map compile-expr elses))))
 399
 400     ; For (cond ...) forms, a special case is a (condition) clause without
 401     ; body.  In this case, the value of condition itself should be returned,
 402     ; and thus is saved in a local variable for testing and returning, if it
 403     ; is found true.
 404     ((cond . ,clauses) (guard (and-map (lambda (el)
 405                                          (and (list? el) (not (null? el))))
 406                                        clauses))
 407      (let iterate ((tail clauses))
 408        (if (null? tail)
 409          (nil-value loc)
 410          (let ((cur (car tail)))
 411            (if (null? (cdr cur))
 412              (let ((var (gensym)))
 413                (make-let loc
 414                  '(condition) `(,var) `(,(compile-expr (car cur)))
 415                  (make-conditional loc
 416                    (make-lexical-ref loc 'condition var)
 417                    (make-lexical-ref loc 'condition var)
 418                    (iterate (cdr tail)))))
 419              (make-conditional loc
 420                (compile-expr (car cur))
 421                (make-sequence loc (map compile-expr (cdr cur)))
 422                (iterate (cdr tail))))))))
 423
 424     ((and) (t-value loc))
 425     ((and . ,expressions)
 426      (let iterate ((tail expressions))
 427        (if (null? (cdr tail))
 428          (compile-expr (car tail))
 429          (make-conditional loc
 430            (compile-expr (car tail))
 431            (iterate (cdr tail))
 432            (nil-value loc)))))
 433
 434     ((or . ,expressions)
 435      (let iterate ((tail expressions))
 436        (if (null? tail)
 437          (nil-value loc)
 438          (let ((var (gensym)))
 439            (make-let loc
 440              '(condition) `(,var) `(,(compile-expr (car tail)))
 441              (make-conditional loc
 442                (make-lexical-ref loc 'condition var)
 443                (make-lexical-ref loc 'condition var)
 444                (iterate (cdr tail))))))))
 445
 446     ((defconst ,sym ,value . ,doc)
 447      (if (handle-var-def loc sym doc)
 448        (make-sequence loc
 449          (list (set-variable! loc sym value-slot (compile-expr value))
 450                (make-const loc sym)))))
 451
 452     ((defvar ,sym) (make-const loc sym))
 453     ((defvar ,sym ,value . ,doc)
 454      (if (handle-var-def loc sym doc)
 455        (make-sequence loc
 456          (list (make-conditional loc
 457                  (call-primitive loc 'eq?
 458                                  (make-module-ref loc runtime 'void #t)
 459                                  (reference-variable loc sym value-slot))
 460                  (set-variable! loc sym value-slot (compile-expr value))
 461                  (make-void loc))
 462                (make-const loc sym)))))
 463
 464     ; Build a set form for possibly multiple values.  The code is not formulated
 465     ; tail recursive because it is clearer this way and large lists of symbol
 466     ; expression pairs are very unlikely.
 467     ((setq . ,args)
 468      (make-sequence loc
 469        (let iterate ((tail args))
 470          (if (null? tail)
 471            (list (make-void loc))
 472            (let ((sym (car tail))
 473                  (tailtail (cdr tail)))
 474              (if (not (symbol? sym))
 475                (report-error loc "expected symbol in setq")
 476                (if (null? tailtail)
 477                  (report-error loc "missing value for symbol in setq" sym)
 478                  (let* ((val (compile-expr (car tailtail)))
 479                         (op (set-variable! loc sym value-slot val)))
 480                    (cons op (iterate (cdr tailtail)))))))))))
 481
 482     ; Let is done with a single call to with-fluids* binding them locally to new
 483     ; values.
 484     ((let ,bindings . ,body) (guard (and (list? bindings)
 485                                          (list? body)
 486                                          (not (null? bindings))
 487                                          (not (null? body))))
 488      (let ((bind (process-let-bindings loc bindings)))
 489        (ensure-fluids-for loc (map car bind) value-slot
 490          (call-primitive loc 'with-fluids*
 491            (make-application loc (make-primitive-ref loc 'list)
 492              (map (lambda (el)
 493                  (make-module-ref loc value-slot (car el) #t))
 494                bind))
 495            (make-application loc (make-primitive-ref loc 'list)
 496              (map (lambda (el)
 497                     (compile-expr (cdr el)))
 498                   bind))
 499            (make-lambda loc '() '() '()
 500              (make-sequence loc (map compile-expr body)))))))
 501
 502     ; Let* is compiled to a cascaded set of with-fluid* for each binding in turn
 503     ; so that each one already sees the preceding bindings.
 504     ((let* ,bindings . ,body) (guard (and (list? bindings)
 505                                           (list? body)
 506                                           (not (null? bindings))
 507                                           (not (null? body))))
 508      (let ((bind (process-let-bindings loc bindings)))
 509        (ensure-fluids-for loc (map car bind) value-slot
 510          (let iterate ((tail bind))
 511            (if (null? tail)
 512              (make-sequence loc (map compile-expr body))
 513              (call-primitive loc 'with-fluid*
 514                (make-module-ref loc value-slot (caar tail) #t)
 515                (compile-expr (cdar tail))
 516                (make-lambda loc '() '() '() (iterate (cdr tail)))))))))
 517
 518     ; A while construct is transformed into a tail-recursive loop like this:
 519     ; (letrec ((iterate (lambda ()
 520     ;                     (if condition
 521     ;                       (begin body
 522     ;                              (iterate))
 523     ;                       %nil))))
 524     ;   (iterate))
 525     ((while ,condition . ,body)
 526      (let* ((itersym (gensym))
 527             (compiled-body (map compile-expr body))
 528             (iter-call (make-application loc
 529                          (make-lexical-ref loc 'iterate itersym)
 530                          (list)))
 531             (full-body (make-sequence loc
 532                          `(,@compiled-body ,iter-call)))
 533             (lambda-body (make-conditional loc
 534                            (compile-expr condition)
 535                            full-body
 536                            (nil-value loc)))
 537             (iter-thunk (make-lambda loc '() '() '() lambda-body)))
 538        (make-letrec loc '(iterate) (list itersym) (list iter-thunk)
 539          iter-call)))
 540
 541     ; Either (lambda ...) or (function (lambda ...)) denotes a lambda-expression
 542     ; that should be compiled.
 543     ((lambda ,args . ,body)
 544      (compile-lambda loc args body))
 545     ((function (lambda ,args . ,body))
 546      (compile-lambda loc args body))
 547
 548     ; Build a lambda and also assign it to the function cell of some symbol.
 549     ((defun ,name ,args . ,body)
 550      (if (not (symbol? name))
 551        (error "expected symbol as function name" name)
 552        (make-sequence loc
 553          (list (set-variable! loc name function-slot
 554                               (compile-lambda loc args body))
 555                (make-const loc name)))))
 556
 557     ; Define a macro (this is done directly at compile-time!).
 558     ; FIXME: Recursive macros don't work!
 559     ((defmacro ,name ,args . ,body)
 560      (if (not (symbol? name))
 561        (error "expected symbol as macro name" name)
 562        (let* ((tree-il (compile-lambda loc args body))
 563               (object (compile tree-il #:from 'tree-il #:to 'value)))
 564          (define-macro! loc name object)
 565          (make-const loc name))))
 566
 567     ((,backq ,val) (guard (backquote? backq))
 568      (process-backquote loc val))
 569
 570     ; XXX: Why do we need 'quote here instead of quote?
 571     (('quote ,val)
 572      (make-const loc val))
 573
 574     ; Macro calls are simply expanded and recursively compiled.
 575     ((,macro . ,args) (guard (and (symbol? macro) (is-macro? macro)))
 576      (let ((expander (get-macro macro)))
 577        (compile-expr (apply expander args))))
 578
 579     ; Function calls using (function args) standard notation; here, we have to
 580     ; take the function value of a symbol if it is one.  It seems that functions
 581     ; in form of uncompiled lists are not supported in this syntax, so we don't
 582     ; have to care for them.
 583     ((,func . ,args)
 584      (make-application loc
 585        (if (symbol? func)
 586          (reference-with-check loc func function-slot)
 587          (compile-expr func))
 588        (map compile-expr args)))
 589
 590     (else
 591       (report-error loc "unrecognized elisp" expr))))
 592
 593
 594 ; Compile a single expression to TreeIL.
 595
 596 (define (compile-expr expr)
 597   (let ((loc (location expr)))
 598     (cond
 599       ((symbol? expr)
 600        (compile-symbol loc expr))
 601       ((pair? expr)
 602        (compile-pair loc expr))
 603       (else (make-const loc expr)))))
 604
 605
 606 ; Entry point for compilation to TreeIL.
 607
 608 (define (compile-tree-il expr env opts)
 609   (values
 610     (compile-expr expr)
 611     env
 612     env))