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 ; Error reporting routine for syntax/compilation problems.
  52
  53 (define (report-error loc . args)
  54   (apply error args))
  55
  56
  57 ; Generate code to ensure a fluid is there for further use of a given symbol.
  58
  59 (define (ensure-fluid! loc sym module)
  60   ; FIXME: Do this!
  61   (make-void loc))
  62
  63
  64 ; Generate code to reference a fluid saved variable.
  65
  66 (define (reference-variable loc sym module)
  67   (make-sequence loc
  68     (list (ensure-fluid! loc sym module)
  69           (make-application loc (make-primitive-ref loc 'fluid-ref)
  70             (list (make-module-ref loc module sym #f))))))
  71
  72
  73 ; Reference a variable and error if the value is void.
  74
  75 (define (reference-with-check loc sym module)
  76   (let ((var (gensym)))
  77     (make-let loc '(value) `(,var) `(,(reference-variable loc sym module))
  78       (make-conditional loc
  79         (make-application loc (make-primitive-ref loc 'eq?)
  80           (list (make-module-ref loc runtime 'void #t)
  81                 (make-lexical-ref loc 'value var)))
  82         (make-application loc (make-primitive-ref loc 'error)
  83           (list (make-const loc "variable is void:")
  84                 (make-const loc sym)))
  85         (make-lexical-ref loc 'value var)))))
  86
  87
  88 ; Generate code to set a fluid saved variable.
  89
  90 (define (set-variable! loc sym module value)
  91   (make-sequence loc
  92     (list (ensure-fluid! loc sym module)
  93           (make-application loc (make-primitive-ref loc 'fluid-set!)
  94             (list (make-module-ref loc module sym #f)
  95                   value)))))
  96
  97
  98 ; Compile a symbol expression.  This is a variable reference or maybe some
  99 ; special value like nil.
 100
 101 (define (compile-symbol loc sym)
 102   (case sym
 103
 104     ((nil) (nil-value loc))
 105
 106     ((t) (t-value loc))
 107
 108     (else
 109       (reference-with-check loc sym value-slot))))
 110
 111
 112 ; Compile a pair-expression (that is, any structure-like construct).
 113
 114 (define (compile-pair loc expr)
 115   (pmatch expr
 116
 117     ((progn . ,forms)
 118      (make-sequence loc (map compile-expr forms)))
 119
 120     ((if ,condition ,ifclause)
 121      (make-conditional loc (compile-expr condition)
 122                            (compile-expr ifclause)
 123                            (nil-value loc)))
 124     ((if ,condition ,ifclause ,elseclause)
 125      (make-conditional loc (compile-expr condition)
 126                            (compile-expr ifclause)
 127                            (compile-expr elseclause)))
 128     ((if ,condition ,ifclause . ,elses)
 129      (make-conditional loc (compile-expr condition)
 130                            (compile-expr ifclause)
 131                            (make-sequence loc (map compile-expr elses))))
 132
 133     ; For (cond ...) forms, a special case is a (condition) clause without
 134     ; body.  In this case, the value of condition itself should be returned,
 135     ; and thus is saved in a local variable for testing and returning, if it
 136     ; is found true.
 137     ((cond . ,clauses) (guard (and-map (lambda (el)
 138                                          (and (list? el) (not (null? el))))
 139                                        clauses))
 140      (let iterate ((tail clauses))
 141        (if (null? tail)
 142          (nil-value loc)
 143          (let ((cur (car tail)))
 144            (if (null? (cdr cur))
 145              (let ((var (gensym)))
 146                (make-let loc
 147                  '(condition) `(,var) `(,(compile-expr (car cur)))
 148                  (make-conditional loc
 149                    (make-lexical-ref loc 'condition var)
 150                    (make-lexical-ref loc 'condition var)
 151                    (iterate (cdr tail)))))
 152              (make-conditional loc
 153                (compile-expr (car cur))
 154                (make-sequence loc (map compile-expr (cdr cur)))
 155                (iterate (cdr tail))))))))
 156
 157     ((and) (t-value loc))
 158     ((and . ,expressions)
 159      (let iterate ((tail expressions))
 160        (if (null? (cdr tail))
 161          (compile-expr (car tail))
 162          (make-conditional loc
 163            (compile-expr (car tail))
 164            (iterate (cdr tail))
 165            (nil-value loc)))))
 166
 167     ((or . ,expressions)
 168      (let iterate ((tail expressions))
 169        (if (null? tail)
 170          (nil-value loc)
 171          (let ((var (gensym)))
 172            (make-let loc
 173              '(condition) `(,var) `(,(compile-expr (car tail)))
 174              (make-conditional loc
 175                (make-lexical-ref loc 'condition var)
 176                (make-lexical-ref loc 'condition var)
 177                (iterate (cdr tail))))))))
 178
 179     ; Build a set form for possibly multiple values.  The code is not formulated
 180     ; tail recursive because it is clearer this way and large lists of symbol
 181     ; expression pairs are very unlikely.
 182     ((setq . ,args)
 183      (make-sequence loc
 184        (let iterate ((tail args))
 185          (if (null? tail)
 186            (list (make-void loc))
 187            (let ((sym (car tail))
 188                  (tailtail (cdr tail)))
 189              (if (not (symbol? sym))
 190                (report-error loc "expected symbol in setq")
 191                (if (null? tailtail)
 192                  (report-error loc "missing value for symbol in setq" sym)
 193                  (let* ((val (compile-expr (car tailtail)))
 194                         (op (set-variable! loc sym value-slot val)))
 195                    (cons op (iterate (cdr tailtail)))))))))))
 196
 197     (('quote ,val)
 198      (make-const loc val))
 199
 200     (else
 201       (report-error loc "unrecognized elisp" expr))))
 202
 203
 204 ; Compile a single expression to TreeIL.
 205
 206 (define (compile-expr expr)
 207   (let ((loc (location expr)))
 208     (cond
 209       ((symbol? expr)
 210        (compile-symbol loc expr))
 211       ((pair? expr)
 212        (compile-pair loc expr))
 213       (else (make-const loc expr)))))
 214
 215
 216 ; Entry point for compilation to TreeIL.
 217
 218 (define (compile-tree-il expr env opts)
 219   (values
 220     (compile-expr expr)
 221     env
 222     env))