summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorRobin Templeton <robin@terpri.org>2014-06-02 20:01:55 -0400
committerRicardo Wurmus <rekado@elephly.net>2020-04-04 16:24:21 +0200
commite139accb530c970c989b3d53d5a8a22fd75437fc (patch)
tree6e02cd4aaedf3fff42f007c0b8843086b3713d25
parent1c7ae95c3505fe200ec6d21bdacae3105a1fcb9c (diff)
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.
-rw-r--r--module/language/elisp/bindings.scm35
-rw-r--r--module/language/elisp/boot.el241
-rw-r--r--module/language/elisp/compile-tree-il.scm357
-rw-r--r--module/language/elisp/lexer.scm5
-rw-r--r--module/language/elisp/runtime.scm197
-rw-r--r--module/language/elisp/spec.scm11
6 files changed, 583 insertions, 263 deletions
diff --git a/module/language/elisp/bindings.scm b/module/language/elisp/bindings.scm
index 9fabddfc4..1dc296f68 100644
--- a/module/language/elisp/bindings.scm
+++ b/module/language/elisp/bindings.scm
@@ -61,12 +61,22 @@
(let* ((lex (lexical-bindings bindings))
(slot (hash-ref lex sym #f)))
(if slot
- (fluid-ref slot)
+ (cadr slot)
#f)))
(define (get-function-binding bindings symbol)
(and=> (hash-ref (function-bindings bindings) symbol)
- fluid-ref))
+ cadr))
+
+(define (with-fluids** fls vals proc)
+ (dynamic-wind
+ (lambda ()
+ (for-each (lambda (f v) (set-cdr! f (cons v (cdr f))))
+ fls vals))
+ proc
+ (lambda ()
+ (for-each (lambda (f) (set-cdr! f (cdr (cdr f))))
+ fls))))
;;; Establish a binding or mark a symbol as dynamically bound for the
;;; extent of calling proc.
@@ -78,17 +88,14 @@
(let ((lex (lexical-bindings bindings)))
(for-each (lambda (sym)
(if (not (hash-ref lex sym))
- (hash-set! lex sym (make-fluid))))
+ (hash-set! lex sym (list #f #f))))
syms)
- (with-fluids* (map (lambda (sym) (hash-ref lex sym)) syms)
- targets
- proc)))
+ (with-fluids** (map (lambda (sym) (hash-ref lex sym)) syms)
+ targets
+ proc)))
(define (with-lexical-bindings bindings syms targets proc)
- (if (or (not (list? targets))
- (not (and-map symbol? targets)))
- (error "invalid targets for lexical binding" targets)
- (with-symbol-bindings bindings syms targets proc)))
+ (with-symbol-bindings bindings syms targets proc))
(define (with-dynamic-bindings bindings syms proc)
(with-symbol-bindings bindings
@@ -100,8 +107,8 @@
(let ((fb (function-bindings bindings)))
(for-each (lambda (symbol)
(if (not (hash-ref fb symbol))
- (hash-set! fb symbol (make-fluid))))
+ (hash-set! fb symbol (list #f #f))))
symbols)
- (with-fluids* (map (cut hash-ref fb <>) symbols)
- gensyms
- thunk)))
+ (with-fluids** (map (cut hash-ref fb <>) symbols)
+ gensyms
+ thunk)))
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"))
diff --git a/module/language/elisp/compile-tree-il.scm b/module/language/elisp/compile-tree-il.scm
index 5d6ebc591..8da1d583c 100644
--- a/module/language/elisp/compile-tree-il.scm
+++ b/module/language/elisp/compile-tree-il.scm
@@ -30,6 +30,7 @@
#:use-module (srfi srfi-8)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
+ #:use-module (ice-9 format)
#:export (compile-tree-il
compile-progn
compile-eval-when-compile
@@ -44,6 +45,7 @@
compile-guile-ref
compile-guile-private-ref
compile-guile-primitive
+ compile-%function
compile-function
compile-defmacro
compile-defun
@@ -61,8 +63,6 @@
(define bindings-data (make-fluid))
-(define lexical-binding (make-fluid))
-
;;; Find the source properties of some parsed expression if there are
;;; any associated with it.
@@ -122,28 +122,29 @@
loc
symbol
(lambda (lexical)
- (make-lexical-ref loc lexical lexical))
+ (if (symbol? lexical)
+ (make-lexical-ref loc symbol lexical)
+ (make-call loc lexical '())))
(lambda ()
- (call-primitive loc
- 'fluid-ref
- (make-module-ref loc value-slot symbol #t)))))
+ (make-call loc
+ (make-module-ref loc runtime 'symbol-value #t)
+ (list (make-const loc symbol))))))
-(define (global? module symbol)
- (module-variable module symbol))
+(define (global? symbol)
+ (module-variable value-slot symbol))
(define (ensure-globals! loc names body)
- (if (and (every (cut global? (resolve-module value-slot) <>) names)
+ (if (and (every global? names)
(every symbol-interned? names))
body
(list->seq
loc
`(,@(map
(lambda (name)
- (ensure-fluid! value-slot name)
+ (symbol-desc name)
(make-call loc
- (make-module-ref loc runtime 'ensure-fluid! #t)
- (list (make-const loc value-slot)
- (make-const loc name))))
+ (make-module-ref loc runtime 'symbol-desc #t)
+ (list (make-const loc name))))
names)
,body))))
@@ -152,15 +153,17 @@
loc
symbol
(lambda (lexical)
- (make-lexical-set loc lexical lexical value))
+ (if (symbol? lexical)
+ (make-lexical-set loc symbol lexical value)
+ (make-call loc lexical (list value))))
(lambda ()
(ensure-globals!
loc
(list symbol)
- (call-primitive loc
- 'fluid-set!
- (make-module-ref loc value-slot symbol #t)
- value)))))
+ (make-call loc
+ (make-module-ref loc runtime 'set-symbol-value! #t)
+ (list (make-const loc symbol)
+ value))))))
(define (access-function loc symbol handle-lexical handle-global)
(cond
@@ -174,7 +177,8 @@
loc
symbol
(lambda (gensym) (make-lexical-ref loc symbol gensym))
- (lambda () (make-module-ref loc function-slot symbol #t))))
+ (lambda ()
+ (make-module-ref loc '(elisp-functions) symbol #t))))
(define (set-function! loc symbol value)
(access-function
@@ -187,15 +191,12 @@
(make-module-ref loc runtime 'set-symbol-function! #t)
(list (make-const loc symbol) value)))))
-(define (bind-lexically? sym module decls)
- (or (eq? module function-slot)
- (let ((decl (assq-ref decls sym)))
- (and (equal? module value-slot)
- (or
- (eq? decl 'lexical)
- (and
- (fluid-ref lexical-binding)
- (not (global? (resolve-module module) sym))))))))
+(define (bind-lexically? sym decls)
+ (let ((decl (assq-ref decls sym)))
+ (or (eq? decl 'lexical)
+ (and
+ (lexical-binding?)
+ (not (special? sym))))))
(define (parse-let-binding loc binding)
(pmatch binding
@@ -234,11 +235,14 @@
(pmatch lst
(((declare . ,x) . ,tail)
(loop tail (append-reverse x decls) intspec doc))
- (((interactive . ,x) . ,tail)
+ (((interactive) . ,tail)
+ (guard lambda? (not intspec))
+ (loop tail decls (cons 'interactive-form #nil) doc))
+ (((interactive ,x) . ,tail)
(guard lambda? (not intspec))
- (loop tail decls x doc))
+ (loop tail decls (cons 'interactive-form x) doc))
((,x . ,tail)
- (guard lambda? (string? x) (not doc) (not (null? tail)))
+ (guard lambda? (or (string? x) (lisp-string? x)) (not doc) (not (null? tail)))
(loop tail decls intspec x))
(else
(values (append-map parse-declaration decls)
@@ -257,12 +261,13 @@
;;; optional and rest arguments.
(define (parse-lambda-list lst)
- (define (%match lst null optional rest symbol)
+ (define (%match lst null optional rest symbol list*)
(pmatch lst
(() (null))
((&optional . ,tail) (optional tail))
((&rest . ,tail) (rest tail))
((,arg . ,tail) (guard (symbol? arg)) (symbol arg tail))
+ ((,arg . ,tail) (guard (list? arg)) (list* arg tail))
(else (fail))))
(define (return rreq ropt rest)
(values #t (reverse rreq) (reverse ropt) rest))
@@ -273,24 +278,28 @@
(lambda () (return rreq '() #f))
(lambda (tail) (parse-opt tail rreq '()))
(lambda (tail) (parse-rest tail rreq '()))
- (lambda (arg tail) (parse-req tail (cons arg rreq)))))
+ (lambda (arg tail) (parse-req tail (cons arg rreq)))
+ (lambda (arg tail) (fail))))
(define (parse-opt lst rreq ropt)
(%match lst
(lambda () (return rreq ropt #f))
(lambda (tail) (fail))
(lambda (tail) (parse-rest tail rreq ropt))
+ (lambda (arg tail) (parse-opt tail rreq (cons (list arg) ropt)))
(lambda (arg tail) (parse-opt tail rreq (cons arg ropt)))))
(define (parse-rest lst rreq ropt)
(%match lst
(lambda () (fail))
(lambda (tail) (fail))
(lambda (tail) (fail))
- (lambda (arg tail) (parse-post-rest tail rreq ropt arg))))
+ (lambda (arg tail) (parse-post-rest tail rreq ropt arg))
+ (lambda (arg tail) (fail))))
(define (parse-post-rest lst rreq ropt rest)
(%match lst
(lambda () (return rreq ropt rest))
(lambda () (fail))
(lambda () (fail))
+ (lambda (arg tail) (fail))
(lambda (arg tail) (fail))))
(parse-req lst '()))
@@ -307,30 +316,30 @@
(let lp ((f f) (v v))
(if (null? f)
body
- (make-primcall
- src 'with-fluid*
- (list (make-lexical-ref #f 'fluid (car f))
- (make-lexical-ref #f 'val (car v))
- (make-lambda
- src '()
- (make-lambda-case
- src '() #f #f #f '() '()
- (lp (cdr f) (cdr v))
- #f))))))))))
+ (make-call src
+ (make-module-ref src runtime 'bind-symbol #t)
+ (list (make-lexical-ref #f 'fluid (car f))
+ (make-lexical-ref #f 'val (car v))
+ (make-lambda
+ src '()
+ (make-lambda-case
+ src '() #f #f #f '() '()
+ (lp (cdr f) (cdr v))
+ #f))))))))))
(define (compile-lambda loc meta args body)
- (receive (valid? req-ids opt-ids rest-id)
+ (receive (valid? req-ids opts rest-id)
(parse-lambda-list args)
(if valid?
(let* ((all-ids (append req-ids
- opt-ids
+ (and opts (map car opts))
(or (and=> rest-id list) '())))
(all-vars (map (lambda (ignore) (gensym)) all-ids)))
(let*-values (((decls intspec doc forms)
(parse-lambda-body body))
((lexical dynamic)
(partition
- (compose (cut bind-lexically? <> value-slot decls)
+ (compose (cut bind-lexically? <> decls)
car)
(map list all-ids all-vars)))
((lexical-ids lexical-vars) (unzip2 lexical))
@@ -360,50 +369,42 @@
tree-il
(make-dynlet
loc
- (map (cut make-module-ref loc value-slot <> #t)
- dynamic-ids)
+ (map (cut make-const loc <>) dynamic-ids)
(map (cut make-lexical-ref loc <> <>)
dynamic-ids
dynamic-vars)
tree-il))))
(make-simple-lambda loc
- meta
+ (append (if intspec
+ (list intspec)
+ '())
+ (if doc
+ (list (cons 'emacs-documentation doc))
+ '())
+ meta)
req-ids
- opt-ids
- (map (const (nil-value loc))
- opt-ids)
+ (map car opts)
+ (map (lambda (x)
+ (if (pair? (cdr x))
+ (compile-expr (car (cdr x)))
+ (make-const loc #nil)))
+ opts)
rest-id
all-vars
full-body)))))))))
(report-error "invalid function" `(lambda ,args ,@body)))))
-;;; Handle the common part of defconst and defvar, that is, checking for
-;;; a correct doc string and arguments as well as maybe in the future
-;;; handling the docstring somehow.
-
-(define (handle-var-def loc sym doc)
- (cond
- ((not (symbol? sym)) (report-error loc "expected symbol, got" sym))
- ((> (length doc) 1) (report-error loc "too many arguments to defvar"))
- ((and (not (null? doc)) (not (string? (car doc))))
- (report-error loc "expected string as third argument of defvar, got"
- (car doc)))
- ;; TODO: Handle doc string if present.
- (else #t)))
-
;;; Handle macro and special operator bindings.
(define (find-operator name type)
(and
(symbol? name)
- (module-defined? (resolve-interface function-slot) name)
- (let ((op (module-ref (resolve-module function-slot) name)))
+ (module-defined? function-slot name)
+ (let ((op (module-ref function-slot name)))
(if (and (pair? op) (eq? (car op) type))
(cdr op)
#f))))
-;;; See if a (backquoted) expression contains any unquotes.
-
(define (contains-unquotes? expr)
(if (pair? expr)
(if (or (unquote? (car expr)) (unquote-splicing? (car expr)))
@@ -474,41 +475,47 @@
(call-primitive loc 'not
(call-primitive loc 'nil? (compile-expr cond)))
(compile-expr then)
- (compile-expr `(progn ,@else))))))
+ (compile-expr `(progn ,@else))))
+ (else (report-error loc "Bad if" args))))
(defspecial defconst (loc args)
(pmatch args
((,sym ,value . ,doc)
- (if (handle-var-def loc sym doc)
- (make-seq loc
- (set-variable! loc sym (compile-expr value))
- (make-const loc sym))))))
+ (make-seq
+ loc
+ (make-call loc
+ (make-module-ref loc runtime 'proclaim-special! #t)
+ (list (make-const loc sym)))
+ (make-seq loc
+ (set-variable! loc sym (compile-expr value))
+ (make-const loc sym))))
+ (else (report-error loc "Bad defconst" args))))
(defspecial defvar (loc args)
(pmatch args
- ((,sym) (make-const loc sym))
+ ((,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)
- (if (handle-var-def loc sym doc)
- (make-seq
- loc
- (make-conditional
- loc
- (make-conditional
- loc
- (call-primitive
- loc
- 'module-bound?
- (call-primitive loc
- 'resolve-interface
- (make-const loc value-slot))
- (make-const loc sym))
- (call-primitive loc
- 'fluid-bound?
- (make-module-ref loc value-slot sym #t))
- (make-const loc #f))
- (make-void loc)
- (set-variable! loc sym (compile-expr value)))
- (make-const loc sym))))))
+ (make-seq
+ loc
+ (make-call loc
+ (make-module-ref loc runtime 'proclaim-special! #t)
+ (list (make-const loc sym)))
+ (make-seq
+ loc
+ (make-conditional
+ loc
+ (make-call loc
+ (make-module-ref loc runtime 'symbol-bound? #t)
+ (list (make-const loc sym)))
+ (make-void loc)
+ (set-variable! loc sym (compile-expr value)))
+ (make-const loc sym))))
+ (else (report-error loc "Bad defvar" args))))
(defspecial setq (loc args)
(define (car* x) (if (null? x) '() (car x)))
@@ -523,7 +530,7 @@
(let ((sym (car args))
(val (compile-expr (cadr* args))))
(if (not (symbol? sym))
- (report-error loc "expected symbol in setq")
+ (report-error loc "expected symbol in setq" args)
(cons
(set-variable! loc sym val)
(loop (cddr* args)
@@ -536,7 +543,7 @@
(receive (decls forms) (parse-body body)
(receive (lexical dynamic)
(partition
- (compose (cut bind-lexically? <> value-slot decls)
+ (compose (cut bind-lexically? <> decls)
car)
bindings)
(let ((make-values (lambda (for)
@@ -548,12 +555,7 @@
(map car dynamic)
(if (null? lexical)
(make-dynlet loc
- (map (compose (cut make-module-ref
- loc
- value-slot
- <>
- #t)
- car)
+ (map (compose (cut make-const loc <>) car)
dynamic)
(map (compose compile-expr cdr)
dynamic)
@@ -576,13 +578,10 @@
(make-body)
(make-dynlet loc
(map
- (compose
- (cut make-module-ref
- loc
- value-slot
- <>
- #t)
- car)
+ (compose (cut make-const
+ loc
+ <>)
+ car)
dynamic)
(map
(lambda (sym)
@@ -591,7 +590,8 @@
sym
sym))
dynamic-syms)
- (make-body))))))))))))))))
+ (make-body))))))))))))))
+ (else (report-error loc "bad let args"))))
(defspecial let* (loc args)
(pmatch args
@@ -603,7 +603,7 @@
(compile-expr `(progn ,@forms))
(let ((sym (caar tail))
(value (compile-expr (cdar tail))))
- (if (bind-lexically? sym value-slot decls)
+ (if (bind-lexically? sym decls)
(let ((target (gensym)))
(make-let loc
`(,target)
@@ -618,9 +618,10 @@
loc
(list sym)
(make-dynlet loc
- (list (make-module-ref loc value-slot sym #t))
+ (list (make-const loc sym))
(list value)
- (iterate (cdr tail)))))))))))))
+ (iterate (cdr tail)))))))))))
+ (else (report-error loc "Bad let*" args))))
(defspecial flet (loc args)
(pmatch args
@@ -639,7 +640,8 @@
names
gensyms
(map compile-expr vals)
- (compile-expr `(progn ,@forms)))))))))))
+ (compile-expr `(progn ,@forms)))))))))
+ (else (report-error loc "bad flet" args))))
(defspecial labels (loc args)
(pmatch args
@@ -659,7 +661,8 @@
names
gensyms
(map compile-expr vals)
- (compile-expr `(progn ,@forms)))))))))))
+ (compile-expr `(progn ,@forms)))))))))
+ (else (report-error loc "bad labels" args))))
;;; guile-ref allows building TreeIL's module references from within
;;; elisp as a way to access data within the Guile universe. The module
@@ -669,12 +672,14 @@
(defspecial guile-ref (loc args)
(pmatch args
((,module ,sym) (guard (and (list? module) (symbol? sym)))
- (make-module-ref loc module sym #t))))
+ (make-module-ref loc module sym #t))
+ (else (report-error loc "bad guile-ref" args))))
(defspecial guile-private-ref (loc args)
(pmatch args
((,module ,sym) (guard (and (list? module) (symbol? sym)))
- (make-module-ref loc module sym #f))))
+ (make-module-ref loc module sym #f))
+ (else (report-error loc "bad guile-private-ref" args))))
;;; guile-primitive allows to create primitive references, which are
;;; still a little faster.
@@ -682,14 +687,46 @@
(defspecial guile-primitive (loc args)
(pmatch args
((,sym)
- (make-primitive-ref loc sym))))
+ (make-primitive-ref loc sym))
+ (else (report-error loc "bad guile-primitive" args))))
-(defspecial function (loc args)
+(defspecial %function (loc args)
(pmatch args
(((lambda ,args . ,body))
(compile-lambda loc '() args body))
+ (((closure ,env ,args . ,body))
+ (let ((bindings (map (lambda (x) (list (car x) (cdr x)))
+ (filter pair? env))))
+ (compile-expr
+ (let ((form `(let ,bindings
+ (declare ,@(map (lambda (x) (list 'lexical x))
+ bindings))
+ (function (lambda ,args
+ (declare
+ (lexical
+ ,@(filter-map
+ (lambda (x)
+ (cond
+ ((memq x '(&optional &rest))
+ #f)
+ ((symbol? x)
+ x)
+ ((list? x)
+ (car x))))
+ args)))
+ ,@body)))))
+ form))))
+ ((,sym) (guard (symbol? sym))
+ (reference-function loc sym))
+ ((,x)
+ (make-const loc x))
+ (else (report-error loc "bad function" args))))
+
+(defspecial function (loc args)
+ (pmatch args
((,sym) (guard (symbol? sym))
- (reference-function loc sym))))
+ (make-const loc sym))
+ (else ((cdr compile-%function) loc args))))
(defspecial defmacro (loc args)
(pmatch args
@@ -714,7 +751,8 @@
(with-native-target
(lambda ()
(compile tree-il #:from 'tree-il #:to 'value)))
- tree-il)))))
+ tree-il)))
+ (else (report-error loc "bad defmacro" args))))
(defspecial defun (loc args)
(pmatch args
@@ -733,25 +771,54 @@
(defspecial #{`}# (loc args)
(pmatch args
((,val)
- (process-backquote loc val))))
+ (process-backquote loc val))
+ (else (report-error loc "bad backquote" args))))
(defspecial quote (loc args)
(pmatch args
((,val)
- (make-const loc val))))
+ (make-const loc val))
+ (else (report-error loc "bad quote" args))))
(defspecial %funcall (loc args)
(pmatch args
((,function . ,arguments)
(make-call loc
(compile-expr function)
- (map compile-expr arguments)))))
+ (map compile-expr arguments)))
+ (else (report-error loc "bad %funcall" args))))
(defspecial %set-lexical-binding-mode (loc args)
(pmatch args
((,val)
- (fluid-set! lexical-binding val)
- (make-void loc))))
+ (set-lexical-binding-mode val)
+ (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.
@@ -759,14 +826,14 @@
(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))))))
+ (compile-expr `(%funcall (%function ,operator) ,@arguments))))))
;;; Compile a symbol expression. This is a variable reference or maybe
;;; some special value like nil.
@@ -788,31 +855,9 @@
(compile-pair loc expr))
(else (make-const loc expr)))))
-;;; Process the compiler options.
-;;; FIXME: Why is '(()) passed as options by the REPL?
-
-(define (valid-symbol-list-arg? value)
- (or (eq? value 'all)
- (and (list? value) (and-map symbol? value))))
-
-(define (process-options! opt)
- (if (and (not (null? opt))
- (not (equal? opt '(()))))
- (if (null? (cdr opt))
- (report-error #f "Invalid compiler options" opt)
- (let ((key (car opt))
- (value (cadr opt)))
- (case key
- ((#:warnings #:to-file?) ; ignore
- #f)
- (else (report-error #f
- "Invalid compiler option"
- key)))))))
-
(define (compile-tree-il expr env opts)
(values
(with-fluids ((bindings-data (make-bindings)))
- (process-options! opts)
(compile-expr expr))
env
env))
diff --git a/module/language/elisp/lexer.scm b/module/language/elisp/lexer.scm
index 5a0e6b3ff..8152a1182 100644
--- a/module/language/elisp/lexer.scm
+++ b/module/language/elisp/lexer.scm
@@ -20,6 +20,7 @@
(define-module (language elisp lexer)
#:use-module (ice-9 regex)
+ #:use-module (language elisp runtime)
#:export (get-lexer get-lexer/1))
;;; This is the lexical analyzer for the elisp reader. It is
@@ -316,7 +317,9 @@
(let ((cur (read-char port)))
(case cur
((#\")
- (return 'string (list->string (reverse result-chars))))
+ (return 'string
+ (make-lisp-string
+ (list->string (reverse result-chars)))))
((#\\)
(let ((escaped (read-char port)))
(case escaped
diff --git a/module/language/elisp/runtime.scm b/module/language/elisp/runtime.scm
index 6f6a22074..bedb15a8a 100644
--- a/module/language/elisp/runtime.scm
+++ b/module/language/elisp/runtime.scm
@@ -19,22 +19,39 @@
;;; Code:
(define-module (language elisp runtime)
+ #:use-module (ice-9 format)
+ #:use-module ((system base compile)
+ #:select (compile))
#:export (nil-value
t-value
value-slot-module
function-slot-module
elisp-bool
- ensure-fluid!
- symbol-fluid
- set-symbol-fluid!
+ ensure-dynamic!
+ symbol-name
symbol-value
set-symbol-value!
symbol-function
set-symbol-function!
+ symbol-plist
+ set-symbol-plist!
symbol-bound?
symbol-fbound?
+ bind-symbol
makunbound!
- fmakunbound!)
+ fmakunbound!
+ symbol-desc
+ proclaim-special!
+ special?
+ emacs!
+ unbound
+ lexical-binding?
+ set-lexical-binding-mode
+ log!
+ eval-elisp
+ local-eval-elisp
+ make-lisp-string
+ lisp-string?)
#:export-syntax (defspecial prim))
;;; This module provides runtime support for the Elisp front-end.
@@ -45,13 +62,21 @@
(define t-value #t)
+(define make-lisp-string identity)
+(define lisp-string? string?)
+
;;; Modules for the binding slots.
;;; Note: Naming those value-slot and/or function-slot clashes with the
;;; submodules of these names!
-(define value-slot-module '(language elisp runtime value-slot))
+(define value-slot-module (resolve-module '(elisp-symbols)))
+
+(define function-slot-module (resolve-module '(elisp-functions)))
-(define function-slot-module '(language elisp runtime function-slot))
+(define plist-slot-module (resolve-module '(elisp-plists)))
+
+(define nil_ 'nil)
+(define t_ 't)
;;; Routines for access to elisp dynamically bound symbols. This is
;;; used for runtime access using functions like symbol-value or set,
@@ -59,75 +84,163 @@
;;; always access the dynamic binding and can not be used for the
;;; lexical!
-(define (ensure-fluid! module sym)
- (let ((intf (resolve-interface module))
- (resolved (resolve-module module)))
- (if (not (module-defined? intf sym))
- (let ((fluid (make-unbound-fluid)))
- (module-define! resolved sym fluid)
- (module-export! resolved `(,sym))))))
-
-(define (symbol-fluid symbol)
- (let ((module (resolve-module value-slot-module)))
- (ensure-fluid! value-slot-module symbol) ;++ implicit special proclamation
- (module-ref module symbol)))
+(define lexical-binding #t)
+
+(define (lexical-binding?)
+ lexical-binding)
+
+(define (set-lexical-binding-mode x)
+ (set! lexical-binding x))
+
+(define unbound (make-symbol "unbound"))
+
+(define dynamic? vector?)
+(define (make-dynamic)
+ (vector #f 4 0 0 unbound))
+(define (dynamic-ref x)
+ (vector-ref x 4))
+(define (dynamic-set! x v)
+ (vector-set! x 4 v))
+(define (dynamic-unset! x)
+ (vector-set! x 4 unbound))
+(define (dynamic-bound? x)
+ (not (eq? (vector-ref x 4) unbound)))
+(define (dynamic-bind x v thunk)
+ (let ((old (vector-ref x 4)))
+ (dynamic-wind
+ (lambda () (vector-set! x 4 v))
+ thunk
+ (lambda () (vector-set! x 4 old)))))
+
+(define-inlinable (ensure-present! module sym thunk)
+ (or (module-local-variable module sym)
+ (let ((variable (make-variable (thunk))))
+ (module-add! module sym variable)
+ variable)))
+
+(define-inlinable (ensure-desc! module sym)
+ (ensure-present! module
+ sym
+ (lambda ()
+ (let ((x (make-dynamic)))
+ (vector-set! x 0 sym)
+ x))))
+
+(define-inlinable (schemify symbol)
+ (case symbol
+ ((#nil) nil_)
+ ((#t) t_)
+ (else symbol)))
+
+(define (symbol-name symbol)
+ (symbol->string (schemify symbol)))
+
+(define (symbol-desc symbol)
+ (let ((symbol (schemify symbol)))
+ (let ((module value-slot-module))
+ (variable-ref (ensure-desc! module symbol)))))
+
+(define (ensure-dynamic! sym)
+ (vector-set! (symbol-desc sym) 3 1))
-(define (set-symbol-fluid! symbol fluid)
- (let ((module (resolve-module value-slot-module)))
- (module-define! module symbol fluid)
- (module-export! module (list symbol)))
- fluid)
+(define (symbol-dynamic symbol)
+ (ensure-dynamic! symbol)
+ (symbol-desc symbol))
(define (symbol-value symbol)
- (fluid-ref (symbol-fluid symbol)))
+ (dynamic-ref (symbol-desc symbol)))
(define (set-symbol-value! symbol value)
- (fluid-set! (symbol-fluid symbol) value)
+ (dynamic-set! (symbol-desc symbol) value)
value)
(define (symbol-function symbol)
- (let ((module (resolve-module function-slot-module)))
+ (set! symbol (schemify symbol))
+ (ensure-present! function-slot-module symbol (lambda () #nil))
+ (let ((module function-slot-module))
(module-ref module symbol)))
(define (set-symbol-function! symbol value)
- (let ((module (resolve-module function-slot-module)))
+ (set! symbol (schemify symbol))
+ (ensure-present! function-slot-module symbol (lambda () #nil))
+ (let ((module function-slot-module))
+ (module-define! module symbol value)
+ (module-export! module (list symbol)))
+ value)
+
+(define (symbol-plist symbol)
+ (set! symbol (schemify symbol))
+ (ensure-present! plist-slot-module symbol (lambda () #nil))
+ (let ((module plist-slot-module))
+ (module-ref module symbol)))
+
+(define (set-symbol-plist! symbol value)
+ (set! symbol (schemify symbol))
+ (ensure-present! plist-slot-module symbol (lambda () #nil))
+ (let ((module plist-slot-module))
(module-define! module symbol value)
(module-export! module (list symbol)))
value)
(define (symbol-bound? symbol)
+ (set! symbol (schemify symbol))
(and
- (module-bound? (resolve-interface value-slot-module) symbol)
- (let ((var (module-variable (resolve-module value-slot-module)
+ (module-bound? value-slot-module symbol)
+ (let ((var (module-variable value-slot-module
symbol)))
(and (variable-bound? var)
- (if (fluid? (variable-ref var))
- (fluid-bound? (variable-ref var))
+ (if (dynamic? (variable-ref var))
+ (dynamic-bound? (variable-ref var))
#t)))))
(define (symbol-fbound? symbol)
+ (set! symbol (schemify symbol))
(and
- (module-bound? (resolve-interface function-slot-module) symbol)
+ (module-bound? function-slot-module symbol)
(variable-bound?
- (module-variable (resolve-module function-slot-module)
- symbol))))
+ (module-variable function-slot-module symbol))
+ (variable-ref (module-variable function-slot-module symbol))))
+
+(define (bind-symbol symbol value thunk)
+ (dynamic-bind (symbol-desc symbol) value thunk))
(define (makunbound! symbol)
- (if (module-bound? (resolve-interface value-slot-module) symbol)
- (let ((var (module-variable (resolve-module value-slot-module)
+ (if (module-bound? value-slot-module symbol)
+ (let ((var (module-variable value-slot-module
symbol)))
- (if (and (variable-bound? var) (fluid? (variable-ref var)))
- (fluid-unset! (variable-ref var))
+ (if (and (variable-bound? var) (dynamic? (variable-ref var)))
+ (dynamic-unset! (variable-ref var))
(variable-unset! var))))
symbol)
(define (fmakunbound! symbol)
- (if (module-bound? (resolve-interface function-slot-module) symbol)
- (variable-unset! (module-variable
- (resolve-module function-slot-module)
- symbol)))
+ (if (module-bound? function-slot-module symbol)
+ (variable-unset! (module-variable function-slot-module symbol)))
symbol)
+(define (special? sym)
+ (eqv? (vector-ref (symbol-desc sym) 3) 1))
+
+(define (proclaim-special! sym)
+ (vector-set! (symbol-desc sym) 3 1)
+ #nil)
+
+(define (emacs! ref set boundp bind)
+ (set! symbol-value ref)
+ (set! set-symbol-value! set)
+ (set! symbol-bound? boundp)
+ (set! bind-symbol bind)
+ (set! lexical-binding? (lambda () (symbol-value 'lexical-binding)))
+ (set! set-lexical-binding-mode (lambda (x) (set-symbol-value! 'lexical-binding x))))
+
+(define (eval-elisp form)
+ (compile form #:from 'elisp #:to 'value))
+
+(set-symbol-value! nil_ #nil)
+(set-symbol-value! t_ #t)
+
+(define (make-string s) s)
+
;;; Define a predefined macro for use in the function-slot module.
(define (make-id template-id . data)
diff --git a/module/language/elisp/spec.scm b/module/language/elisp/spec.scm
index 0a064b2fa..6032004c4 100644
--- a/module/language/elisp/spec.scm
+++ b/module/language/elisp/spec.scm
@@ -24,14 +24,25 @@
#:use-module (system base language)
#:use-module (system base compile)
#:use-module (system base target)
+ #:use-module (system vm vm)
#:export (elisp))
+(save-module-excursion
+ (lambda ()
+ (define-module (elisp-symbols) #:pure #:filename #f)
+ (define-module (elisp-functions) #:pure #:filename #f)
+ (define-module (elisp-plists) #:pure #:filename #f)))
+
(define-language elisp
#:title "Emacs Lisp"
#:reader (lambda (port env) (read-elisp port))
+ ;;#:joiner (lambda (exps env) (cons 'progn exps))
#:printer write
#:compilers `((tree-il . ,compile-tree-il)))
+(set-default-vm-engine! 'debug)
+(set-vm-engine! 'debug)
+
;; Compile and load the Elisp boot code for the native host
;; architecture. We must specifically ask for native compilation here,
;; because this module might be loaded in a dynamic environment where