top level fixes

[bpt/guile.git] / module / language / elisp / compile-tree-il.scm

diff --git a/module/language/elisp/compile-tree-il.scm b/module/language/elisp/compile-tree-il.scm
index 1e09334..22b437b 100644 (file)
--- a/module/language/elisp/compile-tree-il.scm
+++ b/module/language/elisp/compile-tree-il.scm
@@ -459,11 +459,40 @@
   (list->seq loc
              (if (null? args)
                  (list (nil-value loc))
-                 (map compile-expr args))))
+                 (map compile-expr-1 args))))
 
 (defspecial eval-when-compile (loc args)
   (make-const loc (compile `(progn ,@args) #:from 'elisp #:to 'value)))
 
+(define toplevel? (make-fluid))
+
+(define compile-time-too? (make-fluid))
+
+(defspecial eval-when (loc args)
+  (pmatch args
+    ((,situations . ,forms)
+     (let ((compile? (memq ':compile-toplevel situations))
+           (load? (memq ':load-toplevel situations))
+           (execute? (memq ':execute situations)))
+       (cond
+        ((not (fluid-ref toplevel?))
+         (if execute?
+             (compile-expr `(progn ,@forms))
+             (make-const loc #nil)))
+        (load?
+         (with-fluids ((compile-time-too?
+                        (cond (compile? #t)
+                              (execute? (fluid-ref compile-time-too?))
+                              (else #f))))
+           (when (fluid-ref compile-time-too?)
+             (eval-elisp `(progn ,@forms)))
+           (compile-expr-1 `(progn ,@forms))))
+        ((or compile? (and execute? (fluid-ref compile-time-too?)))
+         (eval-elisp `(progn ,@forms))
+         (make-const loc #nil))
+        (else
+         (make-const loc #nil)))))))
+
 (defspecial if (loc args)
   (pmatch args
     ((,cond ,then . ,else)
@@ -478,6 +507,7 @@
 (defspecial defconst (loc args)
   (pmatch args
     ((,sym ,value . ,doc)
+     (proclaim-special! sym)
      (make-seq
       loc
       (make-call loc
@@ -491,12 +521,14 @@
 (defspecial defvar (loc args)
   (pmatch args
     ((,sym)
+     (proclaim-special! sym)
      (make-seq loc
                (make-call loc
                           (make-module-ref loc runtime 'proclaim-special! #t)
                           (list (make-const loc sym)))
                (make-const loc sym)))
     ((,sym ,value . ,doc)
+     (proclaim-special! sym)
      (make-seq
       loc
       (make-call loc
@@ -554,12 +586,14 @@
               loc
               (map car dynamic)
               (if (null? lexical)
-                  (make-dynlet loc
-                               (map (compose (cut make-const loc <>) car)
-                                    dynamic)
-                               (map (compose compile-expr cdr)
-                                    dynamic)
-                               (make-body))
+                  (if (null? dynamic)
+                      (make-body)
+                      (make-dynlet loc
+                                   (map (compose (cut make-const loc <>) car)
+                                        dynamic)
+                                   (map (compose compile-expr cdr)
+                                        dynamic)
+                                   (make-body)))
                   (let* ((lexical-syms (map (lambda (el) (gensym)) lexical))
                          (dynamic-syms (map (lambda (el) (gensym)) dynamic))
                          (all-syms (append lexical-syms dynamic-syms))
@@ -748,7 +782,8 @@
                                           args
                                           body))))
                   (make-const loc name))))
-           (compile tree-il #:from 'tree-il #:to 'value)
+           (when (fluid-ref toplevel?)
+             (compile tree-il #:from 'tree-il #:to 'value))
            tree-il)))
     (else (report-error loc "bad defmacro" args))))
 
@@ -779,30 +814,10 @@
      (make-void loc))
     (else (report-error loc "bad %set-lexical-binding-mode" args))))
 
-(define special-operators (make-hash-table))
-
-(for-each
- (lambda (pair) (hashq-set! special-operators (car pair) (cddr pair)))
- `((progn . ,compile-progn)
-   (eval-when-compile . ,compile-eval-when-compile)
-   (if . ,compile-if)
-   (defconst . ,compile-defconst)
-   (defvar . ,compile-defvar)
-   (setq . ,compile-setq)
-   (let . ,compile-let)
-   (flet . ,compile-flet)
-   (labels . ,compile-labels)
-   (let* . ,compile-let*)
-   (guile-ref . ,compile-guile-ref)
-   (guile-private-ref . ,compile-guile-private-ref)
-   (guile-primitive . ,compile-guile-primitive)
-   (%function . ,compile-%function)
-   (function . ,compile-function)
-   (defmacro . ,compile-defmacro)
-   (#{`}# . ,#{compile-`}#)
-   (quote . ,compile-quote)
-   (%funcall . ,compile-%funcall)
-   (%set-lexical-binding-mode . ,compile-%set-lexical-binding-mode)))
+(define (eget s p)
+  (if (symbol-fbound? 'get)
+      ((symbol-function 'get) s p)
+      #nil))
 
 ;;; Compile a compound expression to Tree-IL.
 
@@ -810,12 +825,19 @@
   (let ((operator (car expr))
         (arguments (cdr expr)))
     (cond
-     ((find-operator operator 'macro)
-      => (lambda (macro-function)
-           (compile-expr (apply macro-function arguments))))
-     ((hashq-ref special-operators operator)
+     ((find-operator operator 'special-operator)
       => (lambda (special-operator-function)
            (special-operator-function loc arguments)))
+     ((find-operator operator 'macro)
+      => (lambda (macro-function)
+           (compile-expr-1 (apply macro-function arguments))))
+     ((and (symbol? operator)
+           (eget operator '%compiler-macro))
+      => (lambda (compiler-macro-function)
+           (let ((new (compiler-macro-function expr)))
+             (if (eq? new expr)
+                 (compile-expr `(%funcall (%function ,operator) ,@arguments))
+                 (compile-expr-1 new)))))
      (else
       (compile-expr `(%funcall (%function ,operator) ,@arguments))))))
 
@@ -830,7 +852,7 @@
 
 ;;; Compile a single expression to TreeIL.
 
-(define (compile-expr expr)
+(define (compile-expr-1 expr)
   (let ((loc (location expr)))
     (cond
      ((symbol? expr)
@@ -839,9 +861,17 @@
       (compile-pair loc expr))
      (else (make-const loc expr)))))
 
+(define (compile-expr expr)
+  (if (fluid-ref toplevel?)
+      (with-fluids ((toplevel? #f))
+        (compile-expr-1 expr))
+      (compile-expr-1 expr)))
+
 (define (compile-tree-il expr env opts)
   (values
-   (with-fluids ((bindings-data (make-bindings)))
-     (compile-expr expr))
+   (with-fluids ((bindings-data (make-bindings))
+                 (toplevel? #t)
+                 (compile-time-too? #f))
+     (compile-expr-1 expr))
    env
    env))