store special operators in the function slot

If the function slot of a symbol contains a pair with `special-operator'
in the car and a procedure in the cdr, the procedure is called to
compile the form to Tree-IL. This is similar to other Emacs Lisp
implementations, in which special operators are subrs.

* module/language/elisp/compile-tree-il.scm: Restructured to store
  special operator definitions in the function slot. Import `(language
  elisp runtime)' for `defspecial'. Export special operators so that
  `(language elisp runtime function-slot)' can re-export them.

  (backquote?): Removed; the backquote symbol is defined as a special
  operator, so it's no longer used in `compile-pair'.

  (is-macro?, get-macro): Replaced by `find-operator'.
  (find-operator): New procedure.

  (compile-progn, compile-if, compile-defconst, compile-defvar,
  compile-setq, compile-let, compile-lexical-let, compile-flet,
  compile-let*, compile-lexical-let*, compile-flet*,
  compile-without-void-checks, compile-with-always-lexical,
  compile-guile-ref, compile-guile-primitive, compile-while,
  compile-function, compile-defmacro, compile-defun, #{compile-`}#,
  compile-quote): New special operators with definitions taken from the
  pmatch form in `compile-pair'. There is no special operator `lambda';
  it is now a macro, as in other Elisp implementations.

  (compile-pair): Instead of directly compiling special forms, check for
  a special operator object in the function slot.

* module/language/elisp/runtime.scm: Export `defspecial'.
  (make-id): New function.
  (built-in-macro): Prefix macros with `macro-'.
  (defspecial): New syntax.

* module/language/elisp/runtime/function-slot.scm: Import and re-export
  special operators. Rename imported special operators and macros to
  remove prefixes. Re-export new macro `lambda'.

* module/language/elisp/runtime/macros.scm (macro-lambda): New Elisp
  macro.

4 files changed, 332 insertions, 233 deletions

diff --git a/module/language/elisp/compile-tree-il.scm b/module/language/elisp/compile-tree-il.scm
index 7fed9aca2..ba81584e8 100644
--- a/module/language/elisp/compile-tree-il.scm
+++ b/module/language/elisp/compile-tree-il.scm
@@ -21,6 +21,7 @@
 
 (define-module (language elisp compile-tree-il)
   #:use-module (language elisp bindings)
+  #:use-module (language elisp runtime)
   #:use-module (language tree-il)
   #:use-module (system base pmatch)
   #:use-module (system base compile)
@@ -28,7 +29,28 @@
   #:use-module (srfi srfi-8)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
-  #:export (compile-tree-il))
+  #:export (compile-tree-il
+            compile-progn
+            compile-if
+            compile-defconst
+            compile-defvar
+            compile-setq
+            compile-let
+            compile-lexical-let
+            compile-flet
+            compile-let*
+            compile-lexical-let*
+            compile-flet*
+            compile-without-void-checks
+            compile-with-always-lexical
+            compile-guile-ref
+            compile-guile-primitive
+            compile-while
+            compile-function
+            compile-defmacro
+            compile-defun
+            compile-\`
+            compile-quote))
 
 ;;; Certain common parameters (like the bindings data structure or
 ;;; compiler options) are not always passed around but accessed using
@@ -78,9 +100,6 @@
 ;;; predicates checking for a symbol being the car of an
 ;;; unquote/unquote-splicing/backquote form.
 
-(define (backquote? sym)
-  (and (symbol? sym) (eq? sym '\`)))
-
 (define (unquote? sym)
   (and (symbol? sym) (eq? sym '\,)))
 
@@ -546,21 +565,17 @@
    ;; TODO: Handle doc string if present.
    (else #t)))
 
-;;; Handle macro bindings.
+;;; Handle macro and special operator bindings.
 
-(define (is-macro? sym)
+(define (find-operator sym type)
   (and
    (symbol? sym)
    (module-defined? (resolve-interface function-slot) sym)
-   (let* ((macro (module-ref (resolve-module function-slot) sym))
-          (macro (if (fluid? macro) (fluid-ref macro) macro)))
-     (and (pair? macro) (eq? (car macro) 'macro)))))
-
-(define (get-macro sym)
-  (and
-   (is-macro? sym)
-   (let ((macro (module-ref (resolve-module function-slot) sym)))
-    (cdr (if (fluid? macro) (fluid-ref macro) macro)))))
+   (let* ((op (module-ref (resolve-module function-slot) sym))
+          (op (if (fluid? op) (fluid-ref op) op)))
+     (if (and (pair? op) (eq? (car op) type))
+         (cdr op)
+         #f))))
 
 ;;; See if a (backquoted) expression contains any unquotes.
 
@@ -634,56 +649,37 @@
           (with-fluids ((fluid new))
             (make-body))))))
 
-;;; Compile a symbol expression. This is a variable reference or maybe
-;;; some special value like nil.
-
-(define (compile-symbol loc sym)
-  (case sym
-    ((nil) (nil-value loc))
-    ((t) (t-value loc))
-    (else (reference-with-check loc sym value-slot))))
-
-;;; Compile a pair-expression (that is, any structure-like construct).
-
-(define (compile-pair loc expr)
-  (pmatch expr
-    ((progn . ,forms)
-     (make-sequence loc (map compile-expr forms)))
-
-    ((if ,condition ,ifclause)
-     (make-conditional loc
-                       (compile-expr condition)
-                       (compile-expr ifclause)
-                       (nil-value loc)))
+;;; Special operators
 
-    ((if ,condition ,ifclause ,elseclause)
-     (make-conditional loc
-                       (compile-expr condition)
-                       (compile-expr ifclause)
-                       (compile-expr elseclause)))
+(defspecial progn (loc args)
+  (make-sequence loc (map compile-expr args)))
 
-    ((if ,condition ,ifclause . ,elses)
+(defspecial if (loc args)
+  (pmatch args
+    ((,cond ,then . ,else)
      (make-conditional loc
-                       (compile-expr condition)
-                       (compile-expr ifclause)
-                       (make-sequence loc (map compile-expr elses))))
-
-    ;; 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)
+                       (compile-expr cond)
+                       (compile-expr then)
+                       (if (null? else)
+                           (nil-value loc)
+                           (make-sequence loc
+                                          (map compile-expr else)))))))
+
+(defspecial defconst (loc args)
+  (pmatch args
+    ((,sym ,value . ,doc)
      (if (handle-var-def loc sym doc)
          (make-sequence loc
                         (list (set-variable! loc
                                              sym
                                              value-slot
                                              (compile-expr value))
-                              (make-const loc sym)))))
+                              (make-const loc sym)))))))
 
-    ((defvar ,sym) (make-const loc sym))
-
-    ((defvar ,sym ,value . ,doc)
+(defspecial defvar (loc args)
+  (pmatch args
+    ((,sym) (make-const loc sym))
+    ((,sym ,value . ,doc)
      (if (handle-var-def loc sym doc)
          (make-sequence
           loc
@@ -695,114 +691,117 @@
                                  (reference-variable loc sym value-slot))
                  (set-variable! loc sym value-slot (compile-expr value))
                  (make-void loc))
-                (make-const loc sym)))))
-
-    ;; Build a set form for possibly multiple values. The code is not
-    ;; formulated tail recursive because it is clearer this way and
-    ;; large lists of symbol expression pairs are very unlikely.
-
-    ((setq . ,args) (guard (not (null? args)))
-     (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)))))))))))
-
-    ;; All lets (let, flet, lexical-let and let* forms) are done using
-    ;; the generate-let/generate-let* methods.
-
-    ((let ,bindings . ,body) (guard (and (list? bindings)
-                                         (not (null? bindings))
-                                         (not (null? body))))
-     (generate-let loc value-slot bindings body))
-
-    ((lexical-let ,bindings . ,body) (guard (and (list? bindings)
-                                                 (not (null? bindings))
-                                                 (not (null? body))))
-     (generate-let loc 'lexical bindings body))
-
-    ((flet ,bindings . ,body) (guard (and (list? bindings)
-                                          (not (null? bindings))
-                                          (not (null? body))))
-     (generate-let loc function-slot bindings body))
-
-    ((let* ,bindings . ,body) (guard (and (list? bindings)
-                                          (not (null? bindings))
-                                          (not (null? body))))
-     (generate-let* loc value-slot bindings body))
-
-    ((lexical-let* ,bindings . ,body) (guard (and (list? bindings)
-                                                  (not (null? bindings))
-                                                  (not (null? body))))
-     (generate-let* loc 'lexical bindings body))
-
-    ((flet* ,bindings . ,body) (guard (and (list? bindings)
-                                           (not (null? bindings))
-                                           (not (null? body))))
-     (generate-let* loc function-slot bindings body))
-
-    ;; Temporarily disable void checks or set symbols as always lexical
-    ;; only for the lexical scope of a construct.
-
-    ((without-void-checks ,syms . ,body)
-     (with-added-symbols loc disable-void-check syms body))
-
-    ((with-always-lexical ,syms . ,body)
-     (with-added-symbols loc always-lexical syms body))
-
-    ;; guile-ref allows building TreeIL's module references from within
-    ;; elisp as a way to access data within the Guile universe. The
-    ;; module and symbol referenced are static values, just like (@
-    ;; module symbol) does!
-
-    ((guile-ref ,module ,sym) (guard (and (list? module) (symbol? sym)))
-     (make-module-ref loc module sym #t))
-
-    ;; guile-primitive allows to create primitive references, which are
-    ;; still a little faster.
-
-    ((guile-primitive ,sym) (guard (symbol? sym))
-     (make-primitive-ref loc sym))
-
-    ;; A while construct is transformed into a tail-recursive loop like
-    ;; this:
-    ;;
-    ;; (letrec ((iterate (lambda ()
-    ;;                     (if condition
-    ;;                       (begin body
-    ;;                              (iterate))
-    ;;                       #nil))))
-    ;;   (iterate))
-    ;;
-    ;; As letrec is not directly accessible from elisp, while is
-    ;; implemented here instead of with a macro.
-
-    ((while ,condition . ,body)
+                (make-const loc sym)))))))
+
+(defspecial setq (loc args)
+  (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)))))))))))
+
+(defspecial let (loc args)
+  (pmatch args
+    ((,bindings . ,body)
+     (generate-let loc value-slot bindings body))))
+
+(defspecial lexical-let (loc args)
+  (pmatch args
+    ((,bindings . ,body)
+     (generate-let loc 'lexical bindings body))))
+
+(defspecial flet (loc args)
+  (pmatch args
+    ((,bindings . ,body)
+     (generate-let loc function-slot bindings body))))
+
+(defspecial let* (loc args)
+  (pmatch args
+    ((,bindings . ,body)
+     (generate-let* loc value-slot bindings body))))
+
+(defspecial lexical-let* (loc args)
+  (pmatch args
+    ((,bindings . ,body)
+     (generate-let* loc 'lexical bindings body))))
+
+(defspecial flet* (loc args)
+  (pmatch args
+    ((,bindings . ,body)
+     (generate-let* loc function-slot bindings body))))
+
+;;; Temporarily disable void checks or set symbols as always lexical
+;;; only for the lexical scope of a construct.
+
+(defspecial without-void-checks (loc args)
+  (pmatch args
+    ((,syms . ,body)
+     (with-added-symbols loc disable-void-check syms body))))
+
+(defspecial with-always-lexical (loc args)
+  (pmatch args
+    ((,syms . ,body)
+     (with-added-symbols loc always-lexical syms body))))
+
+;;; guile-ref allows building TreeIL's module references from within
+;;; elisp as a way to access data within the Guile universe. The module
+;;; and symbol referenced are static values, just like (@ module symbol)
+;;; does!
+
+(defspecial guile-ref (loc args)
+  (pmatch args
+    ((,module ,sym) (guard (and (list? module) (symbol? sym)))
+     (make-module-ref loc module sym #t))))
+
+;;; guile-primitive allows to create primitive references, which are
+;;; still a little faster.
+
+(defspecial guile-primitive (loc args)
+  (pmatch args
+    ((,sym)
+     (make-primitive-ref loc sym))))
+
+;;; A while construct is transformed into a tail-recursive loop like
+;;; this:
+;;;
+;;; (letrec ((iterate (lambda ()
+;;;                     (if condition
+;;;                       (begin body
+;;;                              (iterate))
+;;;                       #nil))))
+;;;   (iterate))
+;;;
+;;; As letrec is not directly accessible from elisp, while is
+;;; implemented here instead of with a macro.
+
+(defspecial while (loc args)
+  (pmatch args
+    ((,condition . ,body)
      (let* ((itersym (gensym))
             (compiled-body (map compile-expr body))
             (iter-call (make-application loc
@@ -832,34 +831,16 @@
                     '(iterate)
                     (list itersym)
                     (list iter-thunk)
-                    iter-call)))
-
-    ;; Either (lambda ...) or (function (lambda ...)) denotes a
-    ;; lambda-expression that should be compiled.
-
-    ((lambda ,args . ,body)
-     (compile-lambda loc args body))
-
-    ((function (lambda ,args . ,body))
-     (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.
+                    iter-call)))))
 
-    ((defun ,name ,args . ,body)
-     (if (not (symbol? name))
-         (report-error loc "expected symbol as function name" name)
-         (make-sequence loc
-                        (list (set-variable! loc
-                                             name
-                                             function-slot
-                                             (compile-lambda loc
-                                                             args
-                                                             body))
-                              (make-const loc name)))))
+(defspecial function (loc args)
+  (pmatch args
+    (((lambda ,args . ,body))
+     (compile-lambda loc args body))))
 
-    ((defmacro ,name ,args . ,body)
+(defspecial defmacro (loc args)
+  (pmatch args
+    ((,name ,args . ,body)
      (if (not (symbol? name))
          (report-error loc "expected symbol as macro name" name)
          (let* ((tree-il
@@ -879,37 +860,61 @@
            (compile (ensuring-globals loc bindings-data tree-il)
                     #:from 'tree-il
                     #:to 'value)
-           tree-il)))
-
-    ;; XXX: Maybe we could implement backquotes in macros, too.
+           tree-il)))))
 
-    ((,backq ,val) (guard (backquote? backq))
-     (process-backquote loc val))
-
-    ;; XXX: Why do we need 'quote here instead of quote?
+(defspecial defun (loc args)
+  (pmatch args
+    ((,name ,args . ,body)
+     (if (not (symbol? name))
+         (report-error loc "expected symbol as function name" name)
+         (make-sequence loc
+                        (list (set-variable! loc
+                                             name
+                                             function-slot
+                                             (compile-lambda loc
+                                                             args
+                                                             body))
+                              (make-const loc name)))))))
 
-    (('quote ,val)
-     (make-const loc val))
+(defspecial \` (loc args)
+  (pmatch args
+    ((,val)
+     (process-backquote loc val))))
 
-    ;; Macro calls are simply expanded and recursively compiled.
+(defspecial quote (loc args)
+  (pmatch args
+    ((,val)
+     (make-const loc val))))
 
-    ((,macro . ,args) (guard (is-macro? macro))
-     (compile-expr (apply (get-macro macro) args)))
+;;; Compile a compound expression to Tree-IL.
 
-    ;; Function calls using (function args) standard notation; here, we
-    ;; have to take the function value of a symbol if it is one. It
-    ;; seems that functions in form of uncompiled lists are not
-    ;; supported in this syntax, so we don't have to care for them.
+(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))))
+     (else
+      (make-application loc
+                        (if (symbol? operator)
+                            (reference-with-check loc
+                                                  operator
+                                                  function-slot)
+                            (compile-expr operator))
+                        (map compile-expr arguments))))))
 
-    ((,func . ,args)
-     (make-application loc
-                       (if (symbol? func)
-                           (reference-with-check loc func function-slot)
-                           (compile-expr func))
-                       (map compile-expr args)))
+;;; Compile a symbol expression. This is a variable reference or maybe
+;;; some special value like nil.
 
-    (else
-     (report-error loc "unrecognized elisp" expr))))
+(define (compile-symbol loc sym)
+  (case sym
+    ((nil) (nil-value loc))
+    ((t) (t-value loc))
+    (else (reference-with-check loc sym value-slot))))
 
 ;;; Compile a single expression to TreeIL.
 
diff --git a/module/language/elisp/runtime.scm b/module/language/elisp/runtime.scm
index f8fc5f6b8..5a0bbe9e7 100644
--- a/module/language/elisp/runtime.scm
+++ b/module/language/elisp/runtime.scm
@@ -32,7 +32,7 @@
             set-variable!
             runtime-error
             macro-error)
-  #:export-syntax (built-in-func built-in-macro prim))
+  #:export-syntax (built-in-func built-in-macro defspecial prim))
 
 ;;; This module provides runtime support for the Elisp front-end.
 
@@ -110,10 +110,39 @@
        (define-public name (make-fluid))
        (fluid-set! name value)))))
 
+(define (make-id template-id . data)
+  (let ((append-symbols
+         (lambda (symbols)
+           (string->symbol
+            (apply string-append (map symbol->string symbols))))))
+    (datum->syntax template-id
+                   (append-symbols
+                    (map (lambda (datum)
+                           ((if (identifier? datum)
+                                syntax->datum
+                                identity)
+                            datum))
+                         data)))))
+
 (define-syntax built-in-macro
-  (syntax-rules ()
-    ((_ name value)
-     (define-public name (cons 'macro value)))))
+  (lambda (x)
+    (syntax-case x ()
+      ((_ name value)
+       (with-syntax ((scheme-name (make-id #'name 'macro- #'name)))
+        #'(begin
+            (define-public scheme-name (make-fluid))
+            (fluid-set! scheme-name (cons 'macro value))))))))
+
+(define-syntax defspecial
+  (lambda (x)
+    (syntax-case x ()
+      ((_ name args body ...)
+       (with-syntax ((scheme-name (make-id #'name 'compile- #'name)))
+         #'(begin
+             (define scheme-name (make-fluid))
+             (fluid-set! scheme-name
+                         (cons 'special-operator
+                               (lambda args body ...)))))))))
 
 ;;; Call a guile-primitive that may be rebound for elisp and thus needs
 ;;; absolute addressing.
diff --git a/module/language/elisp/runtime/function-slot.scm b/module/language/elisp/runtime/function-slot.scm
index 1a953922b..13e5de957 100644
--- a/module/language/elisp/runtime/function-slot.scm
+++ b/module/language/elisp/runtime/function-slot.scm
@@ -19,8 +19,83 @@
 
 (define-module (language elisp runtime function-slot)
   #:use-module (language elisp runtime subrs)
-  #:use-module (language elisp runtime macros)
+  #:use-module ((language elisp runtime macros)
+                #:select
+                ((macro-lambda . lambda)
+                 (macro-prog1 . prog1)
+                 (macro-prog2 . prog2)
+                 (macro-when . when)
+                 (macro-unless . unless)
+                 (macro-cond . cond)
+                 (macro-and . and)
+                 (macro-or . or)
+                 (macro-dotimes . dotimes)
+                 (macro-dolist . dolist)
+                 (macro-catch . catch)
+                 (macro-unwind-protect . unwind-protect)
+                 (macro-pop . pop)
+                 (macro-push . push)))
+  #:use-module ((language elisp compile-tree-il)
+                #:select
+                ((compile-progn . progn)
+                 (compile-if . if)
+                 (compile-defconst . defconst)
+                 (compile-defvar . defvar)
+                 (compile-setq . setq)
+                 (compile-let . let)
+                 (compile-lexical-let . lexical-let)
+                 (compile-flet . flet)
+                 (compile-let* . let*)
+                 (compile-lexical-let* . lexical-let*)
+                 (compile-flet* . flet*)
+                 (compile-without-void-checks . without-void-checks)
+                 (compile-with-always-lexical . with-always-lexical)
+                 (compile-guile-ref . guile-ref)
+                 (compile-guile-primitive . guile-primitive)
+                 (compile-while . while)
+                 (compile-function . function)
+                 (compile-defun . defun)
+                 (compile-defmacro . defmacro)
+                 (compile-\` . \`)
+                 (compile-quote . quote)))
   #:duplicates (last)
+  ;; special operators
+  #:re-export (progn
+               if
+               defconst
+               defvar
+               setq
+               let
+               lexical-let
+               flet
+               let*
+               lexical-let*
+               flet*
+               without-void-checks
+               with-always-lexical
+               guile-ref
+               guile-primitive
+               while
+               function
+               defun
+               defmacro
+               \`
+               quote)
+  ;; macros
+  #:re-export (lambda
+               prog1
+               prog2
+               when
+               unless
+               cond
+               and
+               or
+               dotimes
+               dolist
+               catch
+               unwind-protect
+               pop
+               push)
   ;; functions
   #:re-export (eq
                equal
@@ -83,18 +158,4 @@
                throw
                not
                eval
-               load)
-  ;; macros
-  #:re-export (prog1
-               prog2
-               when
-               unless
-               cond
-               and
-               or
-               dotimes
-               dolist
-               catch
-               unwind-protect
-               pop
-               push))
+               load))
diff --git a/module/language/elisp/runtime/macros.scm b/module/language/elisp/runtime/macros.scm
index 4d4fcd972..2858c511b 100644
--- a/module/language/elisp/runtime/macros.scm
+++ b/module/language/elisp/runtime/macros.scm
@@ -27,6 +27,10 @@
 ;;; during compilation, of course, so not really in runtime. But I think
 ;;; it fits well to the others here.
 
+(built-in-macro lambda
+  (lambda cdr
+    `(function (lambda ,@cdr))))
+
 ;;; 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.