Implement some elisp constructs in macros instead of hard-coded compiler code.

* module/language/elisp/compile-tree-il.scm: Remove implementation of prog1,
  and, or, cond, dolist.
* module/language/elisp/runtime/macro-slot.scm: Implement them here instead.

diff --git a/module/language/elisp/compile-tree-il.scm b/module/language/elisp/compile-tree-il.scm
index 269037d..42daaf1 100644 (file)
--- a/module/language/elisp/compile-tree-il.scm
+++ b/module/language/elisp/compile-tree-il.scm
@@ -504,45 +504,6 @@
     (make-const loc expr)))
 
 
     (make-const loc expr)))
 
 

-; Compile a dolist construct.
-; This is compiled to something along:
-; (with-fluid* iter-var %nil
-;   (lambda ()
-;     (let iterate ((tail list))
-;       (if (null? tail)
-;         result
-;         (begin
-;           (fluid-set! iter-var (car tail))
-;           body
-;           (iterate (cdr tail)))))))
-
-(define (compile-dolist loc var iter-list result body)
-  (let* ((tailvar (gensym))
-         (iterate (gensym))
-         (tailref (make-lexical-ref loc tailvar tailvar))
-         (iterate-func (make-lambda loc `(,tailvar) `(,tailvar) '()
-                         (make-conditional loc
-                           (call-primitive loc 'null? tailref)
-                           (compile-expr result)
-                           (make-sequence loc
-                             `(,(set-variable! loc var value-slot
-                                  (call-primitive loc 'car tailref))
-                               ,@(map compile-expr body)
-                               ,(make-application loc
-                                  (make-lexical-ref loc iterate iterate)
-                                  (list (call-primitive loc 'cdr
-                                          tailref)))))))))
-    (mark-fluid-needed! (fluid-ref bindings-data) var value-slot)
-    (call-primitive loc 'with-fluid*
-      (make-module-ref loc value-slot var #t)
-      (nil-value loc)
-      (make-lambda loc '() '() '()
-        (make-letrec loc `(,iterate) `(,iterate) `(,iterate-func)
-          (make-application loc
-            (make-lexical-ref loc iterate iterate)
-            (list (compile-expr iter-list))))))))
-
-

 ; Compile a symbol expression.  This is a variable reference or maybe some
 ; special value like nil.
 
 ; Compile a symbol expression.  This is a variable reference or maybe some
 ; special value like nil.
 


@@ -561,16 +522,6 @@
     ((progn . ,forms)
      (make-sequence loc (map compile-expr forms)))
 
     ((progn . ,forms)
      (make-sequence loc (map compile-expr forms)))
 

-    ; I chose to implement prog1 directly (not with macros) so that the
-    ; temporary variable used can be a lexical one that is not backed by a fluid
-    ; for better performance.
-    ((prog1 ,form1 . ,forms)
-     (let ((temp (gensym)))
-       (make-let loc `(,temp) `(,temp) `(,(compile-expr form1))
-         (make-sequence loc
-           (append (map compile-expr forms)
-                   (list (make-lexical-ref loc temp temp)))))))
-

     ((if ,condition ,ifclause)
      (make-conditional loc (compile-expr condition)
                            (compile-expr ifclause)
     ((if ,condition ,ifclause)
      (make-conditional loc (compile-expr condition)
                            (compile-expr ifclause)


@@ -584,51 +535,8 @@
                            (compile-expr ifclause)
                            (make-sequence loc (map compile-expr elses))))
 
                            (compile-expr ifclause)
                            (make-sequence loc (map compile-expr elses))))
 

-    ; For (cond ...) forms, a special case is a (condition) clause without
-    ; body.  In this case, the value of condition itself should be returned,
-    ; and thus is saved in a local variable for testing and returning, if it
-    ; is found true.
-    ((cond . ,clauses) (guard (and-map (lambda (el)
-                                         (and (list? el) (not (null? el))))
-                                       clauses))
-     (let iterate ((tail clauses))
-       (if (null? tail)
-         (nil-value loc)
-         (let ((cur (car tail)))
-           (if (null? (cdr cur))
-             (let ((var (gensym)))
-               (make-let loc
-                 '(condition) `(,var) `(,(compile-expr (car cur)))
-                 (make-conditional loc
-                   (make-lexical-ref loc 'condition var)
-                   (make-lexical-ref loc 'condition var)
-                   (iterate (cdr tail)))))
-             (make-conditional loc
-               (compile-expr (car cur))
-               (make-sequence loc (map compile-expr (cdr cur)))
-               (iterate (cdr tail))))))))
-
-    ((and) (t-value loc))
-    ((and . ,expressions)
-     (let iterate ((tail expressions))
-       (if (null? (cdr tail))
-         (compile-expr (car tail))
-         (make-conditional loc
-           (compile-expr (car tail))
-           (iterate (cdr tail))
-           (nil-value loc)))))
-
-    ((or . ,expressions)
-     (let iterate ((tail expressions))
-       (if (null? tail)
-         (nil-value loc)
-         (let ((var (gensym)))
-           (make-let loc
-             '(condition) `(,var) `(,(compile-expr (car tail)))
-             (make-conditional loc
-               (make-lexical-ref loc 'condition var)
-               (make-lexical-ref loc 'condition var)
-               (iterate (cdr tail))))))))
+    ; defconst and defvar are kept here in the compiler (rather than doing them
+    ; as macros) for if we may want to handle the docstring somehow.

 
     ((defconst ,sym ,value . ,doc)
      (if (handle-var-def loc sym doc)
 
     ((defconst ,sym ,value . ,doc)
      (if (handle-var-def loc sym doc)


@@ -754,13 +662,6 @@
        (make-letrec loc '(iterate) (list itersym) (list iter-thunk)
          iter-call)))
 
        (make-letrec loc '(iterate) (list itersym) (list iter-thunk)
          iter-call)))
 

-    ; dolist is treated here rather than as macro because it can take advantage
-    ; of a non-fluid-based variable.
-    ((dolist (,var ,iter-list) . ,body) (guard (symbol? var))
-     (compile-dolist loc var iter-list 'nil body))
-    ((dolist (,var ,iter-list ,result) . ,body) (guard (symbol? var))
-     (compile-dolist loc var iter-list result body))
-

     ; catch and throw can mainly be implemented directly using Guile's
     ; primitives for exceptions, the only difficulty is that the keys used
     ; within Guile must be symbols, while elisp allows any value and checks
     ; catch and throw can mainly be implemented directly using Guile's
     ; primitives for exceptions, the only difficulty is that the keys used
     ; within Guile must be symbols, while elisp allows any value and checks


@@ -768,6 +669,9 @@
     ; for the Guile primitives and check for matches inside the handler; if
     ; the elisp keys are not eq?, we rethrow the exception.
     ;
     ; for the Guile primitives and check for matches inside the handler; if
     ; the elisp keys are not eq?, we rethrow the exception.
     ;

+    ; TODO: Implement catch with a macro once we can build the lambda with
+    ; lexical arguments.
+    ;

     ; throw is implemented as built-in function.
 
     ((catch ,tag . ,body) (guard (not (null? body)))
     ; throw is implemented as built-in function.
 
     ((catch ,tag . ,body) (guard (not (null? body)))


@@ -794,6 +698,8 @@
 
     ; unwind-protect is just some weaker construct as dynamic-wind, so 
     ; straight-forward to implement.
 
     ; unwind-protect is just some weaker construct as dynamic-wind, so 
     ; straight-forward to implement.

+    ; TODO: This might be implemented as a macro, once lambda's without
+    ; arguments do not call with-fluids* anymore.

     ((unwind-protect ,body . ,clean-ups) (guard (not (null? clean-ups)))
      (call-primitive loc 'dynamic-wind
                      (make-lambda loc '() '() '() (make-void loc))
     ((unwind-protect ,body . ,clean-ups) (guard (not (null? clean-ups)))
      (call-primitive loc 'dynamic-wind
                      (make-lambda loc '() '() '() (make-void loc))


@@ -811,6 +717,8 @@
      (compile-lambda loc args body))
 
     ; Build a lambda and also assign it to the function cell of some symbol.
      (compile-lambda loc args body))
 
     ; Build a lambda and also assign it to the function cell of some symbol.

+    ; This is no macro as we might want to honour the docstring at some time;
+    ; just as with defvar/defconst.

     ((defun ,name ,args . ,body)
      (if (not (symbol? name))
        (error "expected symbol as function name" name)
     ((defun ,name ,args . ,body)
      (if (not (symbol? name))
        (error "expected symbol as function name" name)


@@ -831,6 +739,7 @@
          (define-macro! loc name object)
          (make-const loc name))))
 
          (define-macro! loc name object)
          (make-const loc name))))
 

+    ; XXX: Maybe we could implement backquotes in macros, too.

     ((,backq ,val) (guard (backquote? backq))
      (process-backquote loc val))
 
     ((,backq ,val) (guard (backquote? backq))
      (process-backquote loc val))
 

diff --git a/module/language/elisp/runtime/macro-slot.scm b/module/language/elisp/runtime/macro-slot.scm
index a9381eb..e74d749 100644 (file)
--- a/module/language/elisp/runtime/macro-slot.scm
+++ b/module/language/elisp/runtime/macro-slot.scm
@@ -28,8 +28,16 @@
 ; here.
 
 
 ; here.
 
 

-; The prog2 construct can be directly defined in terms of prog1 and progn,
-; so this is done using a macro.
+; The prog1 and prog2 constructs can easily be defined as macros using progn
+; and some lexical-let's to save the intermediate value to return at the end.
+
+(built-in-macro prog1
+  (lambda (form1 . rest)
+    (let ((temp (gensym)))
+      `(without-void-checks (,temp)
+         (lexical-let ((,temp ,form1))
+           ,@rest
+           ,temp)))))

 
 (built-in-macro prog2
   (lambda (form1 form2 . rest)
 
 (built-in-macro prog2
   (lambda (form1 form2 . rest)


@@ -47,21 +55,66 @@
     `(if ,condition nil (progn ,@elses))))
 
 
     `(if ,condition nil (progn ,@elses))))
 
 

-; Define the dotimes iteration macro.
-; As the variable has to be bound locally for elisp, this needs to go through
-; the dynamic scoping fluid system.  So we can't speed these forms up by
-; implementing them directly in the compiler with just a lexical variable
-; anyways.
-; For dolist, on the other hand, we have to bind the elisp variable to the
-; list elements but keep track of the list-tails in another one.  Therefore,
-; this can take advantage of real compilation because of circumventing the
-; fluid-system for this variable.
+; Impement the cond form as nested if's.  A special case is a (condition)
+; subform, in which case we need to return the condition itself if it is true
+; and thus save it in a local variable before testing it.
+
+(built-in-macro cond
+  (lambda (. clauses)
+    (let iterate ((tail clauses))
+      (if (null? tail)
+        'nil
+        (let ((cur (car tail))
+              (rest (iterate (cdr tail))))
+          (prim cond
+            ((prim or (not (list? cur)) (null? cur))
+             (macro-error "invalid clause in cond" cur))
+            ((null? (cdr cur))
+             (let ((var (gensym)))
+               `(without-void-checks (,var)
+                  (lexical-let ((,var ,(car cur)))
+                    (if ,var
+                      ,var
+                      ,rest)))))
+            (else
+              `(if ,(car cur)
+                 (progn ,@(cdr cur))
+                 ,rest))))))))
+
+
+; The and and or forms can also be easily defined with macros.
+
+(built-in-macro and
+  (lambda (. args)
+    (if (null? args)
+      't
+      (let iterate ((tail args))
+        (if (null? (cdr tail))
+          (car tail)
+          `(if ,(car tail)
+             ,(iterate (cdr tail))
+             nil))))))
+
+(built-in-macro or
+  (lambda (. args)
+    (let iterate ((tail args))
+      (if (null? tail)
+        'nil
+        (let ((var (gensym)))
+          `(without-void-checks (,var)
+             (lexical-let ((,var ,(car tail)))
+               (if ,var
+                 ,var
+                 ,(iterate (cdr tail))))))))))
+
+
+; Define the dotimes and dolist iteration macros.

 
 (built-in-macro dotimes
   (lambda (args . body)
 
 (built-in-macro dotimes
   (lambda (args . body)

-    (if (or (not (list? args))
-            (< (length args) 2)
-            (> (length args) 3))
+    (if (prim or (not (list? args))
+                 (< (length args) 2)
+                 (> (length args) 3))

       (macro-error "invalid dotimes arguments" args)
       (let ((var (car args))
             (count (cadr args)))
       (macro-error "invalid dotimes arguments" args)
       (let ((var (car args))
             (count (cadr args)))


@@ -75,6 +128,28 @@
                (list (caddr args))
                '()))))))
 
                (list (caddr args))
                '()))))))
 

+(built-in-macro dolist
+  (lambda (args . body)
+    (if (prim or (not (list? args))
+                 (< (length args) 2)
+                 (> (length args) 3))
+      (macro-error "invalid dolist arguments" args)
+      (let ((var (car args))
+            (iter-list (cadr args))
+            (tailvar (gensym)))
+        (if (not (symbol? var))
+          (macro-error "expected symbol as dolist variable")
+          `(let (,var)
+             (without-void-checks (,tailvar)
+               (lexical-let ((,tailvar ,iter-list))
+                 (while (not (null ,tailvar))
+                   (setq ,var (car ,tailvar))
+                   ,@body
+                   (setq ,tailvar (cdr ,tailvar)))
+                 ,@(if (= (length args) 3)
+                     (list (caddr args))
+                     '())))))))))
+

 
 ; Pop off the first element from a list or push one to it.
 
 
 ; Pop off the first element from a list or push one to it.