support "#'" syntax for function expressions

[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 cb2271a..0e48298 100644 (file)
--- a/module/language/elisp/compile-tree-il.scm
+++ b/module/language/elisp/compile-tree-il.scm
@@ -49,7 +49,7 @@
             compile-function
             compile-defmacro
             compile-defun
-            compile-\`
+            #{compile-`}#
             compile-quote))
 
 ;;; Certain common parameters (like the bindings data structure or
@@ -101,10 +101,10 @@
 ;;; unquote/unquote-splicing/backquote form.
 
 (define (unquote? sym)
-  (and (symbol? sym) (eq? sym '\,)))
+  (and (symbol? sym) (eq? sym '#{,}#)))
 
 (define (unquote-splicing? sym)
-  (and (symbol? sym) (eq? sym '\,@)))
+  (and (symbol? sym) (eq? sym '#{,@}#)))
 
 ;;; Build a call to a primitive procedure nicely.
 
@@ -694,37 +694,24 @@
                 (make-const loc sym)))))))
 
 (defspecial setq (loc args)
+  (define (car* x) (if (null? x) '() (car x)))
+  (define (cdr* x) (if (null? x) '() (cdr x)))
+  (define (cadr* x) (car* (cdr* x)))
+  (define (cddr* x) (cdr* (cdr* x)))
   (make-sequence
    loc
-   (let iterate ((tail args))
-     (let ((sym (car tail))
-           (tailtail (cdr tail)))
-       (if (not (symbol? sym))
-           (report-error loc "expected symbol in setq")
-           (if (null? tailtail)
-               (report-error loc
-                             "missing value for symbol in setq"
-                             sym)
-               (let* ((val (compile-expr (car tailtail)))
-                      (op (set-variable! loc sym value-slot val)))
-                 (if (null? (cdr tailtail))
-                     (let* ((temp (gensym))
-                            (ref (make-lexical-ref loc temp temp)))
-                       (list (make-let
-                              loc
-                              `(,temp)
-                              `(,temp)
-                              `(,val)
-                              (make-sequence
-                               loc
-                               (list (set-variable! loc
-                                                    sym
-                                                    value-slot
-                                                    ref)
-                                     ref)))))
-                     (cons (set-variable! loc sym value-slot val)
-                           (iterate (cdr tailtail)))))))))))
-
+   (let loop ((args args) (last (nil-value loc)))
+     (if (null? args)
+         (list last)
+         (let ((sym (car args))
+               (val (compile-expr (cadr* args))))
+           (if (not (symbol? sym))
+               (report-error loc "expected symbol in setq")
+               (cons
+                (set-variable! loc sym value-slot val)
+                (loop (cddr* args)
+                      (reference-variable loc sym value-slot)))))))))
+  
 (defspecial let (loc args)
   (pmatch args
     ((,bindings . ,body)
@@ -876,7 +863,7 @@
                                                              body))
                               (make-const loc name)))))))
 
-(defspecial \` (loc args)
+(defspecial #{`}# (loc args)
   (pmatch args
     ((,val)
      (process-backquote loc val))))