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   #:export (compile-tree-il))
  26
  27
  28 ; Find the source properties of some parsed expression if there are any
  29 ; associated with it.
  30
  31 (define (location x)
  32   (and (pair? x)
  33        (let ((props (source-properties x)))
  34          (and (not (null? props))
  35               props))))
  36
  37
  38 ; Value to use for Elisp's nil and t.
  39
  40 (define (nil-value loc) (make-const loc #f))
  41 (define (t-value loc) (make-const loc #t))
  42
  43
  44 ; Modules that contain the value and function slot bindings.
  45
  46 (define runtime '(language elisp runtime))
  47 (define value-slot '(language elisp runtime value-slot))
  48 (define function-slot '(language elisp runtime function-slot))
  49
  50
  51 ; Build a call to a primitive procedure nicely.
  52
  53 (define (call-primitive loc sym . args)
  54   (make-application loc (make-primitive-ref loc sym) args))
  55
  56
  57 ; Error reporting routine for syntax/compilation problems or build code for
  58 ; a runtime-error output.
  59
  60 (define (report-error loc . args)
  61   (apply error args))
  62
  63 (define (runtime-error loc msg . args)
  64   (make-application loc (make-primitive-ref loc 'error)
  65     (cons (make-const loc msg) args)))
  66
  67
  68 ; Generate code to ensure a fluid is there for further use of a given symbol.
  69 ; ensure-fluids-for does the same for a list of symbols and builds a sequence
  70 ; that executes the fluid-insurances first, followed by all body commands; this
  71 ; is a routine for convenience (needed with let, let*, lambda).
  72
  73 (define (ensure-fluid! loc sym module)
  74   ; FIXME: Do this!
  75   (make-void loc))
  76
  77 (define (ensure-fluids-for loc syms module . body)
  78   (make-sequence loc
  79     `(,@(map (lambda (sym) (ensure-fluid! loc sym module)) syms)
  80       ,@body)))
  81
  82
  83 ; Generate code to reference a fluid saved variable.
  84
  85 (define (reference-variable loc sym module)
  86   (make-sequence loc
  87     (list (ensure-fluid! loc sym module)
  88           (call-primitive loc 'fluid-ref
  89                           (make-module-ref loc module sym #t)))))
  90
  91
  92 ; Reference a variable and error if the value is void.
  93
  94 (define (reference-with-check loc sym module)
  95   (let ((var (gensym)))
  96     (make-let loc '(value) `(,var) `(,(reference-variable loc sym module))
  97       (make-conditional loc
  98         (call-primitive loc 'eq?
  99                         (make-module-ref loc runtime 'void #t)
 100                         (make-lexical-ref loc 'value var))
 101         (runtime-error loc "variable is void:" (make-const loc sym))
 102         (make-lexical-ref loc 'value var)))))
 103
 104
 105 ; Generate code to set a fluid saved variable.
 106
 107 (define (set-variable! loc sym module value)
 108   (make-sequence loc
 109     (list (ensure-fluid! loc sym module)
 110           (call-primitive loc 'fluid-set!
 111                           (make-module-ref loc module sym #t)
 112                           value))))
 113
 114
 115 ; Process the bindings part of a let or let* expression; that is, check for
 116 ; correctness and bring it to the form ((sym1 . val1) (sym2 . val2) ...).
 117
 118 (define (process-let-bindings loc bindings)
 119   (map (lambda (b)
 120          (if (symbol? b)
 121            (cons b 'nil)
 122            (if (or (not (list? b))
 123                    (not (= (length b) 2)))
 124              (report-error loc "expected symbol or list of 2 elements in let")
 125              (if (not (symbol? (car b)))
 126                (report-error loc "expected symbol in let")
 127                (cons (car b) (cadr b))))))
 128        bindings))
 129
 130
 131 ; Split the argument list of a lambda expression into required, optional and
 132 ; rest arguments and also check it is actually valid.
 133
 134 (define (split-lambda-arguments loc args)
 135   (let iterate ((tail args)
 136                 (mode 'required)
 137                 (required '())
 138                 (optional '()))
 139     (cond
 140
 141       ((null? tail)
 142        (values (reverse required) (reverse optional) #f))
 143
 144       ((and (eq? mode 'required)
 145             (eq? (car tail) '&optional))
 146        (iterate (cdr tail) 'optional required optional))
 147
 148       ((eq? (car tail) '&rest)
 149        (if (or (null? (cdr tail))
 150                (not (null? (cddr tail))))
 151          (report-error loc "expected exactly one symbol after &rest")
 152          (values (reverse required) (reverse optional) (cadr tail))))
 153
 154       (else
 155         (if (not (symbol? (car tail)))
 156           (report-error loc "expected symbol in argument list, got" (car tail))
 157           (case mode
 158             ((required) (iterate (cdr tail) mode
 159                                  (cons (car tail) required) optional))
 160             ((optional) (iterate (cdr tail) mode
 161                                  required (cons (car tail) optional)))
 162             ((else) (error "invalid mode in split-lambda-arguments" mode))))))))
 163
 164
 165 ; Compile a lambda expression.  Things get a little complicated because TreeIL
 166 ; does not allow optional arguments but only one rest argument, and also the
 167 ; rest argument should be nil instead of '() for no values given.  Because of
 168 ; this, we have to do a little preprocessing to get everything done before the
 169 ; real body is called.
 170 ;
 171 ; (lambda (a &optional b &rest c) body) should become:
 172 ; (lambda (a_ . rest_)
 173 ;   (with-fluids* (list a b c) (list a_ nil nil)
 174 ;     (lambda ()
 175 ;       (if (not (null? rest_))
 176 ;         (begin
 177 ;           (fluid-set! b (car rest_))
 178 ;           (set! rest_ (cdr rest_))
 179 ;           (if (not (null? rest_))
 180 ;             (fluid-set! c rest_))))
 181 ;       body)))
 182 ;
 183 ; This is formulated quite imperatively, but I think in this case that is quite
 184 ; clear and better than creating a lot of nested let's.
 185
 186 (define (compile-lambda loc args body)
 187   (call-with-values
 188     (lambda ()
 189       (split-lambda-arguments loc args))
 190     (lambda (required optional rest)
 191       (let ((required-sym (map (lambda (sym) (gensym)) required))
 192             (rest-sym (if (or rest (not (null? optional))) (gensym) '())))
 193         (let ((real-args (append required-sym rest-sym))
 194               (locals `(,@required ,@optional ,@(if rest (list rest) '()))))
 195           (make-lambda loc
 196             real-args real-args '()
 197             (ensure-fluids-for loc locals value-slot
 198               (call-primitive loc 'with-fluids*
 199                 (make-application loc (make-primitive-ref loc 'list)
 200                   (map (lambda (sym) (make-module-ref loc value-slot sym #t))
 201                        locals))
 202                 (make-application loc (make-primitive-ref loc 'list)
 203                   (append (map (lambda (sym) (make-lexical-ref loc sym sym))
 204                                required-sym)
 205                           (map (lambda (sym) (nil-value loc))
 206                                (if rest
 207                                  `(,@optional ,rest-sym)
 208                                  optional))))
 209                 (make-lambda loc '() '() '()
 210                   (make-sequence loc
 211                     `(,(process-optionals loc optional rest-sym)
 212                       ,(process-rest loc rest rest-sym)
 213                       ,@(map compile-expr body))))))))))))
 214
 215 ; Build the code to handle setting of optional arguments that are present
 216 ; and updating the rest list.
 217 (define (process-optionals loc optional rest-sym)
 218   (let iterate ((tail optional))
 219     (if (null? tail)
 220       (make-void loc)
 221       (make-conditional loc
 222         (call-primitive loc 'null? (make-lexical-ref loc rest-sym rest-sym))
 223         (make-void loc)
 224         (make-sequence loc
 225           (list (set-variable! loc (car tail) value-slot
 226                   (call-primitive loc 'car
 227                                   (make-lexical-ref loc rest-sym rest-sym)))
 228                 (make-lexical-set loc rest-sym rest-sym
 229                   (call-primitive loc 'cdr
 230                                   (make-lexical-ref loc rest-sym rest-sym)))
 231                 (iterate (cdr tail))))))))
 232
 233 ; This builds the code to set the rest variable to nil if it is empty.
 234 (define (process-rest loc rest rest-sym)
 235   (let ((rest-empty (call-primitive loc 'null?
 236                                     (make-lexical-ref loc rest-sym rest-sym))))
 237     (cond
 238       (rest
 239        (make-conditional loc rest-empty
 240          (make-void loc)
 241          (set-variable! loc rest value-slot
 242                         (make-lexical-ref loc rest-sym rest-sym))))
 243       ((not (null? rest-sym))
 244        (make-conditional loc rest-empty
 245          (make-void loc)
 246          (runtime-error loc "too many arguments and no rest argument")))
 247       (else (make-void loc)))))
 248
 249
 250 ; Compile a symbol expression.  This is a variable reference or maybe some
 251 ; special value like nil.
 252
 253 (define (compile-symbol loc sym)
 254   (case sym
 255     ((nil) (nil-value loc))
 256     ((t) (t-value loc))
 257     (else (reference-with-check loc sym value-slot))))
 258
 259
 260 ; Compile a pair-expression (that is, any structure-like construct).
 261
 262 (define (compile-pair loc expr)
 263   (pmatch expr
 264
 265     ((progn . ,forms)
 266      (make-sequence loc (map compile-expr forms)))
 267
 268     ((if ,condition ,ifclause)
 269      (make-conditional loc (compile-expr condition)
 270                            (compile-expr ifclause)
 271                            (nil-value loc)))
 272     ((if ,condition ,ifclause ,elseclause)
 273      (make-conditional loc (compile-expr condition)
 274                            (compile-expr ifclause)
 275                            (compile-expr elseclause)))
 276     ((if ,condition ,ifclause . ,elses)
 277      (make-conditional loc (compile-expr condition)
 278                            (compile-expr ifclause)
 279                            (make-sequence loc (map compile-expr elses))))
 280
 281     ; For (cond ...) forms, a special case is a (condition) clause without
 282     ; body.  In this case, the value of condition itself should be returned,
 283     ; and thus is saved in a local variable for testing and returning, if it
 284     ; is found true.
 285     ((cond . ,clauses) (guard (and-map (lambda (el)
 286                                          (and (list? el) (not (null? el))))
 287                                        clauses))
 288      (let iterate ((tail clauses))
 289        (if (null? tail)
 290          (nil-value loc)
 291          (let ((cur (car tail)))
 292            (if (null? (cdr cur))
 293              (let ((var (gensym)))
 294                (make-let loc
 295                  '(condition) `(,var) `(,(compile-expr (car cur)))
 296                  (make-conditional loc
 297                    (make-lexical-ref loc 'condition var)
 298                    (make-lexical-ref loc 'condition var)
 299                    (iterate (cdr tail)))))
 300              (make-conditional loc
 301                (compile-expr (car cur))
 302                (make-sequence loc (map compile-expr (cdr cur)))
 303                (iterate (cdr tail))))))))
 304
 305     ((and) (t-value loc))
 306     ((and . ,expressions)
 307      (let iterate ((tail expressions))
 308        (if (null? (cdr tail))
 309          (compile-expr (car tail))
 310          (make-conditional loc
 311            (compile-expr (car tail))
 312            (iterate (cdr tail))
 313            (nil-value loc)))))
 314
 315     ((or . ,expressions)
 316      (let iterate ((tail expressions))
 317        (if (null? tail)
 318          (nil-value loc)
 319          (let ((var (gensym)))
 320            (make-let loc
 321              '(condition) `(,var) `(,(compile-expr (car tail)))
 322              (make-conditional loc
 323                (make-lexical-ref loc 'condition var)
 324                (make-lexical-ref loc 'condition var)
 325                (iterate (cdr tail))))))))
 326
 327     ; Build a set form for possibly multiple values.  The code is not formulated
 328     ; tail recursive because it is clearer this way and large lists of symbol
 329     ; expression pairs are very unlikely.
 330     ((setq . ,args)
 331      (make-sequence loc
 332        (let iterate ((tail args))
 333          (if (null? tail)
 334            (list (make-void loc))
 335            (let ((sym (car tail))
 336                  (tailtail (cdr tail)))
 337              (if (not (symbol? sym))
 338                (report-error loc "expected symbol in setq")
 339                (if (null? tailtail)
 340                  (report-error loc "missing value for symbol in setq" sym)
 341                  (let* ((val (compile-expr (car tailtail)))
 342                         (op (set-variable! loc sym value-slot val)))
 343                    (cons op (iterate (cdr tailtail)))))))))))
 344
 345     ; Let is done with a single call to with-fluids* binding them locally to new
 346     ; values.
 347     ((let ,bindings . ,body) (guard (and (list? bindings)
 348                                          (list? body)
 349                                          (not (null? bindings))
 350                                          (not (null? body))))
 351      (let ((bind (process-let-bindings loc bindings)))
 352        (call-primitive loc 'with-fluids*
 353          (make-application loc (make-primitive-ref loc 'list)
 354            (map (lambda (el)
 355                (make-module-ref loc value-slot (car el) #t))
 356              bind))
 357          (make-application loc (make-primitive-ref loc 'list)
 358            (map (lambda (el)
 359                   (compile-expr (cdr el)))
 360                 bind))
 361          (make-lambda loc '() '() '()
 362            (make-sequence loc (map compile-expr body))))))
 363
 364     ; Let* is compiled to a cascaded set of with-fluid* for each binding in turn
 365     ; so that each one already sees the preceding bindings.
 366     ((let* ,bindings . ,body) (guard (and (list? bindings)
 367                                           (list? body)
 368                                           (not (null? bindings))
 369                                           (not (null? body))))
 370      (let ((bind (process-let-bindings loc bindings)))
 371        (let iterate ((tail bind))
 372          (if (null? tail)
 373            (make-sequence loc (map compile-expr body))
 374            (call-primitive loc 'with-fluid*
 375              (make-module-ref loc value-slot (caar tail) #t)
 376              (compile-expr (cdar tail))
 377              (make-lambda loc '() '() '() (iterate (cdr tail))))))))
 378
 379     ; A while construct is transformed into a tail-recursive loop like this:
 380     ; (letrec ((iterate (lambda ()
 381     ;                     (if condition
 382     ;                       (begin body
 383     ;                              (iterate))
 384     ;                       %nil))))
 385     ;   (iterate))
 386     ((while ,condition . ,body)
 387      (let* ((itersym (gensym))
 388             (compiled-body (map compile-expr body))
 389             (iter-call (make-application loc
 390                          (make-lexical-ref loc 'iterate itersym)
 391                          (list)))
 392             (full-body (make-sequence loc
 393                          `(,@compiled-body ,iter-call)))
 394             (lambda-body (make-conditional loc
 395                            (compile-expr condition)
 396                            full-body
 397                            (nil-value loc)))
 398             (iter-thunk (make-lambda loc '() '() '() lambda-body)))
 399        (make-letrec loc '(iterate) (list itersym) (list iter-thunk)
 400          iter-call)))
 401
 402     ; Either (lambda ...) or (function (lambda ...)) denotes a lambda-expression
 403     ; that should be compiled.
 404     ((lambda ,args . ,body) (guard (not (null? body)))
 405      (compile-lambda loc args body))
 406     ((function (lambda ,args . ,body)) (guard (not (null? body)))
 407      (compile-lambda loc args body))
 408
 409     ; Function calls using (function args) standard notation; here, we have to
 410     ; take the function value of a symbol if it is one.  It seems that functions
 411     ; in form of uncompiled lists are not supported in this syntax, so we don't
 412     ; have to care for them.
 413     ((,func . ,args)
 414      (make-application loc
 415        (if (symbol? func)
 416          (reference-with-check loc func function-slot)
 417          (compile-expr func))
 418        (map compile-expr args)))
 419
 420     (('quote ,val)
 421      (make-const loc val))
 422
 423     (else
 424       (report-error loc "unrecognized elisp" expr))))
 425
 426
 427 ; Compile a single expression to TreeIL.
 428
 429 (define (compile-expr expr)
 430   (let ((loc (location expr)))
 431     (cond
 432       ((symbol? expr)
 433        (compile-symbol loc expr))
 434       ((pair? expr)
 435        (compile-pair loc expr))
 436       (else (make-const loc expr)))))
 437
 438
 439 ; Entry point for compilation to TreeIL.
 440
 441 (define (compile-tree-il expr env opts)
 442   (values
 443     (compile-expr expr)
 444     env
 445     env))