elisp updates

(Best-ability ChangeLog annotation added by Christopher Allan Webber.)

* module/language/elisp/bindings.scm (get-lexical-binding)
  (get-function-binding): Use cadr instead of fluid-ref on slot.
  (with-fluids**): New procedure.
  (with-symbol-bindings, with-function-bindings): Use with-fluids**.
  Also stop using "make-fluid", use "(list #f #f)" instead as default
  lexical-bindings hashtable value.
  (with-lexical-bindings): Drop the error checking for invalid targets.

* module/language/elisp/boot.el (defun, save-excursion)
  (save-current-buffer, save-restriction, track-mouse, setq-default)
  (catch, condition-case): New macros.
  (omega, eval, gensym, interactive, autoload-do-load, fset, prin1)
  (backtrace-frame, backtrace, %set-eager-macroexpansion-mode): New functions.
  (null, consp, listp, car, cdr, make-symbol, signal): Wrap in eval-and-compile.
  (prog1, cond, or, while): Update to make use of gensym.
  (unwind-protect): Switch from funcall to %funcall.
  (%functionp): Rename from functionp.
  (%indirect-function): Update to use %functionp instead of functionp.
  Add check for if object is null, signaling void-function.  Instead of
  calling symbol-function directly, call via %funcall from the module
  "(language elisp runtime)".
  (fset): Significant additions and refactoring.
  (gload): Renamed from fload.
  (defvaralias, nthcdr, nth, eq): Move functions to a different location.
  (eq): Also stop using null.
  (dolist): Remove quasiquoting, build list manually.
  (random): Fix indentation.
  (progn, eval-when-compile, if, defconst, defvar, setq, let, flet)
  (labels, let*, function, defmacro, quote): Protect as special
  operators by raising error if invoked as a function.

* module/language/elisp/compile-tree-il.scm: Import "(ice-9 format)".
  Export compile-%function.
  (lexical-binding, handle-var-def, defun, valid-symbol-list-arg?)
  (process-options!): Remove.
  (reference-variable): Adjust functions passed to access-variable.
  (global?): Drop module parameter, use value-slot instead.
  (ensure-globals!, set-variable!, parse-body-1, parse-lambda-list)
  (compile-lambda, defconst, defvar, let, let*, compile-pair): Refactor.
  (reference-function): Use '(elisp-functions) instead of function-slot.
  (bind-lexically?): Drop module parameter, simplify.
  (make-dynlet): Switch from using make-primcall to make-call.
  (find-operator): Switch from using resolve-interface/resolve-module
  to using function-slot.
  (if, defconst, defvar, let, let*, flet, labels, guile-ref)
  (guile-private-ref, guile-primitive, defmacro, `, quote, %funcall)
  (%set-lexical-binding-mode): Add error checking.
  (setq): Pass in args to report-error.
  (function): Simplified, now calling %function.
  (%function): New function, based on prior "function".  Refactor, including
  adding support for matching against a closure.
  (%set-lexical-binding-mode): Switch from using fluid-set! to
  set-lexical-binding-mode.
  (special-operators): New variable.  Build from following for-each
  statement.
  (compile-tree-il): Drop call to "process-options!"

* module/language/elisp/lexer.scm: Import "(language elisp runtime)".
  (lex): Switch from using "list->string" to "make-lisp-string".

* module/language/elisp/runtime.scm: Use modules "(ice-9 format)",
  "(system base compile)".
  Remove from export list list, removing ensure-fluid!, symbol-fluid!,
  set-symbol-fluid!.  Add to export list ensure-dynamic!, symbol-name,
  symbol-plist, set-symbol-plist!, bind-symbol, symbol-desc, proclaim-symbol!
  special? emacs! unbound, lexical-binding?, set-lexical-binding-mode,
  log!, eval-elisp, local-eval-elisp, make-lisp-string, lisp-string?
  (make-list-string, lisp-string?) New function aliases.
  (value-slot-module, function-slot-module): Adjust module resolution.
  (nil_, t_): New variables.
  (ensure-fluid!, symbol-fluid, set-symbol-fluid!): Removed.
  (lexical-binding, unbound): New variables.
  (lexical-binding?, set-lexical-binding-mode, unbound, dynamic?)
  (make-dynamic, dynamic-ref, dynamic-set!, dynamic-unset!)
  (dynamic-bound?, dynamic-bind, ensure-present!, ensure-desc!)
  (schemify, symbol-name, symbol-desc, ensure-dynamic!, symbol-dynamic)
  (set-symbol-plist!, special?, proclaim-special!, emacs!, eval-elisp)
  (make-string): New procedures.
  (symbol-value): Use dynamic-ref! instead of fluid-ref!.
  (set-symbol-value!): Use dynamic-set! instead of fluid-set!.
  (symbol-function, set-symbol-function!, symbol-bound?)
  (symbol-fbound?, makunbound!, fmakunbound!): Refactor, including
  adjusting how module resolution is being done.

* module/language/elisp/spec.scm: Import module "(system vm vm)".
  Setup elisp-symbols, elisp-functions, elisp-plists.
  Use "set-default-vm-engine!" and "set-vm-engine!" to be set to
  'debug.
  (elisp): Comment out joiner.

1 files changed, 191 insertions, 50 deletions

diff --git a/module/language/elisp/boot.el b/module/language/elisp/boot.el
index f55722a9a..1079357be 100644
--- a/module/language/elisp/boot.el
+++ b/module/language/elisp/boot.el
@@ -22,12 +22,27 @@
 (defmacro @ (module symbol)
   `(guile-ref ,module ,symbol))
 
+(defmacro defun (name args &rest body)
+  `(let ((proc (function (lambda ,args ,@body))))
+     (%funcall (@ (language elisp runtime) set-symbol-function!)
+               ',name
+               proc)
+     (%funcall (@ (guile) set-procedure-property!)
+               proc 'name ',name)
+     ',name))
+
+(defun omega () (omega))
+
 (defmacro eval-and-compile (&rest body)
   `(progn
      (eval-when-compile ,@body)
      (progn ,@body)))
 
 (eval-and-compile
+  (defun eval (form)
+    (%funcall (@ (language elisp runtime) eval-elisp) form)))
+
+(eval-and-compile
   (defun null (object)
     (if object nil t))
   (defun consp (object)
@@ -40,6 +55,8 @@
     (if list (%funcall (@ (guile) cdr) list) nil))
   (defun make-symbol (name)
     (%funcall (@ (guile) make-symbol) name))
+  (defun gensym ()
+    (%funcall (@ (guile) gensym)))
   (defun signal (error-symbol data)
     (%funcall (@ (guile) throw) 'elisp-condition error-symbol data)))
 
@@ -47,12 +64,15 @@
   `#'(lambda ,@cdr))
 
 (defmacro prog1 (first &rest body)
-  (let ((temp (make-symbol "prog1-temp")))
+  (let ((temp (gensym)))
     `(let ((,temp ,first))
        (declare (lexical ,temp))
        ,@body
        ,temp)))
 
+(defun interactive (&optional arg)
+  nil)
+
 (defmacro prog2 (form1 form2 &rest body)
   `(progn ,form1 (prog1 ,form2 ,@body)))
 
@@ -65,7 +85,7 @@
          (let ((condition (car first))
                (body (cdr first)))
            (if (null body)
-               (let ((temp (make-symbol "cond-temp")))
+               (let ((temp (gensym)))
                  `(let ((,temp ,condition))
                     (declare (lexical ,temp))
                     (if ,temp
@@ -86,7 +106,7 @@
 (defmacro or (&rest conditions)
   (cond ((null conditions) nil)
         ((null (cdr conditions)) (car conditions))
-        (t (let ((temp (make-symbol "or-temp")))
+        (t (let ((temp (gensym)))
              `(let ((,temp ,(car conditions)))
                 (declare (lexical ,temp))
                 (if ,temp
@@ -118,7 +138,7 @@
     (loop bindings '())))
 
 (defmacro while (test &rest body)
-  (let ((loop (make-symbol "loop")))
+  (let ((loop (gensym)))
     `(labels ((,loop ()
                  (if ,test
                      (progn ,@body (,loop))
@@ -126,10 +146,10 @@
        (,loop))))
 
 (defmacro unwind-protect (bodyform &rest unwindforms)
-  `(funcall (@ (guile) dynamic-wind)
-            #'(lambda () nil)
-            #'(lambda () ,bodyform)
-            #'(lambda () ,@unwindforms)))
+  `(%funcall (@ (guile) dynamic-wind)
+             #'(lambda () nil)
+             #'(lambda () ,bodyform)
+             #'(lambda () ,@unwindforms)))
 
 (defmacro when (cond &rest body)
   `(if ,cond
@@ -142,7 +162,7 @@
 (defun symbolp (object)
   (%funcall (@ (guile) symbol?) object))
 
-(defun functionp (object)
+(defun %functionp (object)
   (%funcall (@ (guile) procedure?) object))
 
 (defun symbol-function (symbol)
@@ -162,10 +182,13 @@
 
 (defun %indirect-function (object)
   (cond
-   ((functionp object)
+   ((%functionp object)
     object)
+   ((null object)
+    (signal 'void-function nil))
    ((symbolp object)                    ;++ cycle detection
-    (%indirect-function (symbol-function object)))
+    (%indirect-function
+     (%funcall (@ (language elisp runtime) symbol-function) object)))
    ((listp object)
     (eval `(function ,object)))
    (t
@@ -182,17 +205,67 @@
             (%indirect-function function)
             arguments))
 
+(defun autoload-do-load (fundef &optional funname macro-only)
+  (and (load (cadr fundef))
+       (%indirect-function funname)))
+
+(defun fset (symbol definition)
+  (funcall (@ (language elisp runtime) set-symbol-function!)
+           symbol
+           definition))
+
+(defun eq (obj1 obj2)
+  (if obj1
+      (%funcall (@ (guile) eq?) obj1 obj2)
+    (if obj2 nil t)))
+
+(defun nthcdr (n list)
+  (let ((i 0))
+    (while (< i n)
+      (setq list (cdr list)
+            i (+ i 1)))
+    list))
+
+(defun nth (n list)
+  (car (nthcdr n list)))
+
 (defun fset (symbol definition)
   (funcall (@ (language elisp runtime) set-symbol-function!)
            symbol
-           (if (functionp definition)
-               definition
+           (cond
+            ((%funcall (@ (guile) procedure?) definition)
+             definition)
+            ((and (consp definition)
+                  (eq (car definition) 'macro))
+             (if (%funcall (@ (guile) procedure?) (cdr definition))
+                 definition
+               (cons 'macro
+                     (funcall (@ (language elisp falias) make-falias)
+                              (function
+                               (lambda (&rest args) (apply (cdr definition) args)))
+                              (cdr definition)))))
+            ((and (consp definition)
+                  (eq (car definition) 'autoload))
+             (if (or (eq (nth 4 definition) 'macro)
+                     (eq (nth 4 definition) t))
+                 (cons 'macro
+                       (funcall
+                        (@ (language elisp falias) make-falias)
+                        (function (lambda (&rest args)
+                                    (apply (cdr (autoload-do-load definition symbol nil)) args)))
+                        definition))
+               (funcall
+                (@ (language elisp falias) make-falias)
+                (function (lambda (&rest args)
+                            (apply (autoload-do-load definition symbol nil) args)))
+                definition)))
+            (t
              (funcall (@ (language elisp falias) make-falias)
-                      #'(lambda (&rest args) (apply definition args))
-                      definition)))
+                      (function (lambda (&rest args) (apply definition args)))
+                      definition))))
   definition)
 
-(defun load (file)
+(defun gload (file)
   (funcall (@ (system base compile) compile-file)
            file
            (funcall (@ (guile) symbol->keyword) 'from)
@@ -203,11 +276,6 @@
 
 ;;; Equality predicates
 
-(defun eq (obj1 obj2)
-  (if obj1
-      (funcall (@ (guile) eq?) obj1 obj2)
-    (null obj2)))
-
 (defun eql (obj1 obj2)
   (if obj1
       (funcall (@ (guile) eqv?) obj1 obj2)
@@ -231,13 +299,13 @@
 (fset 'fboundp (@ (language elisp runtime) symbol-fbound?))
 (fset 'intern (@ (guile) string->symbol))
 
-(defun defvaralias (new-alias base-variable &optional docstring)
-  (let ((fluid (funcall (@ (language elisp runtime) symbol-fluid)
-                        base-variable)))
-    (funcall (@ (language elisp runtime) set-symbol-fluid!)
-             new-alias
-             fluid)
-    base-variable))
+;(defun defvaralias (new-alias base-variable &optional docstring)
+;  (let ((fluid (funcall (@ (language elisp runtime) symbol-fluid)
+;                        base-variable)))
+;    (funcall (@ (language elisp runtime) set-symbol-fluid!)
+;             new-alias
+;             fluid)
+;    base-variable))
 
 ;;; Numerical type predicates
 
@@ -344,16 +412,6 @@
         newcdr)
     (signal 'wrong-type-argument `(consp ,cell))))
 
-(defun nthcdr (n list)
-  (let ((i 0))
-    (while (< i n)
-      (setq list (cdr list)
-            i (+ i 1)))
-    list))
-
-(defun nth (n list)
-  (car (nthcdr n list)))
-
 (defun %member (elt list test)
   (cond
    ((null list) nil)
@@ -400,10 +458,11 @@
 
 (defmacro dolist (spec &rest body)
   (apply #'(lambda (var list &optional result)
-             `(mapc #'(lambda (,var)
-                        ,@body
-                        ,result)
-                    ,list))
+             (list 'progn
+                   (list 'mapc
+                         (cons 'lambda (cons (list var) body))
+                         list)
+                   result))
          spec))
 
 ;;; Strings
@@ -582,6 +641,9 @@
 (defun print (object)
   (funcall (@ (guile) write) object))
 
+(defun prin1 (object)
+  (funcall (@ (guile) write) object))
+
 (defun terpri ()
   (funcall (@ (guile) newline)))
 
@@ -607,11 +669,90 @@
                                (@ (guile) *random-state*)))
 
 (defun random (&optional limit)
-  (if (eq limit t)
-      (setq %random-state
-            (funcall (@ (guile) random-state-from-platform))))
-  (funcall (@ (guile) random)
-           (if (wholenump limit)
-               limit
-             (@ (guile) most-positive-fixnum))
-           %random-state))
+   (if (eq limit t)
+       (setq %random-state
+             (funcall (@ (guile) random-state-from-platform))))
+   (funcall (@ (guile) random)
+            (if (wholenump limit)
+                limit
+              (@ (guile) most-positive-fixnum))
+            %random-state))
+
+(defmacro save-excursion (&rest body)
+  `(call-with-save-excursion #'(lambda () ,@body)))
+
+(defmacro save-current-buffer (&rest body)
+  `(call-with-save-current-buffer #'(lambda () ,@body)))
+
+(defmacro save-restriction (&rest body)
+  `(call-with-save-restriction #'(lambda () ,@body)))
+
+(defmacro track-mouse (&rest body)
+  `(call-with-track-mouse #'(lambda () ,@body)))
+
+(defmacro setq-default (var value &rest args)
+  `(progn (set-default ',var ,value)
+          ,(if (null args)
+               var
+             `(setq-default ,@args))))
+
+(defmacro catch (tag &rest body)
+  `(call-with-catch ,tag #'(lambda () ,@body)))
+
+(defmacro condition-case (var bodyform &rest args)
+  (if (consp args)
+      (let* ((handler (car args))
+             (handlers (cdr args))
+             (handler-conditions (car handler))
+             (handler-body (cdr handler)))
+        `(call-with-handler ',var
+                            ',handler-conditions
+                            #'(lambda () ,@handler-body)
+                            #'(lambda ()
+                                (condition-case ,var
+                                    ,bodyform
+                                  ,@handlers))))
+    bodyform))
+
+(defun backtrace-frame (nframes)
+  (let* ((stack (funcall (@ (guile) make-stack) t))
+         (frame (stack-ref stack nframes))
+         (proc (funcall (@ (guile) frame-procedure) frame))
+         (pname (or (and (%functionp proc)
+                         (funcall (@ (guile) procedure-name) proc))
+                    proc))
+         (args (funcall (@ (guile) frame-arguments) frame)))
+    (cons t (cons pname args))))
+
+(defun backtrace ()
+  (interactive)
+  (let* ((stack (funcall (@ (guile) make-stack) t))
+         (frame (funcall (@ (guile) stack-ref) stack 1))
+         (space (funcall (@ (guile) integer->char) 32)))
+    (while frame
+      (princ (string 32 32))
+      (let ((proc (funcall (@ (guile) frame-procedure) frame)))
+        (prin1 (or (and (%functionp proc)
+                        (funcall (@ (guile) procedure-name) proc))
+                   proc)))
+      (prin1 (funcall (@ (guile) frame-arguments) frame))
+      (terpri)
+      (setq frame (funcall (@ (guile) frame-previous) frame)))
+    nil))
+
+(defun %set-eager-macroexpansion-mode (ignore)
+  nil)
+
+(defun progn (&rest args) (error "Special operator"))
+(defun eval-when-compile (&rest args) (error "Special operator"))
+(defun if (&rest args) (error "Special operator"))
+(defun defconst (&rest args) (error "Special operator"))
+(defun defvar (&rest args) (error "Special operator"))
+(defun setq (&rest args) (error "Special operator"))
+(defun let (&rest args) (error "Special operator"))
+(defun flet (&rest args) (error "Special operator"))
+(defun labels (&rest args) (error "Special operator"))
+(defun let* (&rest args) (error "Special operator"))
+(defun function (&rest args) (error "Special operator"))
+(defun defmacro (&rest args) (error "Special operator"))
+(defun quote (&rest args) (error "Special operator"))