defconst, defvar: proclaim special at compile-time

[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 850edee..b23d939 100644 (file)
--- a/module/language/elisp/compile-tree-il.scm
+++ b/module/language/elisp/compile-tree-il.scm
@@ -478,6 +478,7 @@
 (defspecial defconst (loc args)
   (pmatch args
     ((,sym ,value . ,doc)
+     (proclaim-special! sym)
      (make-seq
       loc
       (make-call loc
@@ -491,12 +492,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
@@ -507,10 +510,13 @@
        (make-conditional
         loc
         (make-call loc
-                   (make-module-ref loc runtime 'symbol-bound? #t)
+                   (make-module-ref loc runtime 'symbol-default-bound? #t)
                    (list (make-const loc sym)))
         (make-void loc)
-        (set-variable! loc sym (compile-expr value)))
+        (make-call loc
+                   (make-module-ref loc runtime 'set-symbol-default-value! #t)
+                   (list (make-const loc sym)
+                         (compile-expr value))))
        (make-const loc sym))))
     (else (report-error loc "Bad defvar" args))))
 
@@ -776,43 +782,18 @@
      (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)))
-
 ;;; Compile a compound expression to Tree-IL.
 
 (define (compile-pair loc expr)
   (let ((operator (car expr))
         (arguments (cdr expr)))
     (cond
+     ((find-operator operator 'special-operator)
+      => (lambda (special-operator-function)
+           (special-operator-function loc arguments)))
      ((find-operator operator 'macro)
       => (lambda (macro-function)
            (compile-expr (apply macro-function arguments))))
-     ((hashq-ref special-operators operator)
-      => (lambda (special-operator-function)
-           (special-operator-function loc arguments)))
      (else
       (compile-expr `(%funcall (%function ,operator) ,@arguments))))))