mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-14 09:40:20 +02:00
Code Activity

elisp updates

Browse source 
(Best-ability ChangeLog annotation added by Christine Lemmer-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.
This commit is contained in:
Robin Templeton 2014-06-02 20:01:55 -04:00 • committed by Christine Lemmer-Webber
parent ad3d498d31
commit cf5e02f1a6
No known key found for this signature in database
GPG key ID: 4BC025925FF8F4D3
6 changed files with 582 additions and 276 deletions
Download patch file Download diff file Expand all files Collapse all files

27
module/language/elisp/bindings.scm
View file

@ -61,12 +61,22 @@
(let* ((lex (lexical-bindings bindings)) (let* ((lex (lexical-bindings bindings))
(slot (hash-ref lex sym #f))) (slot (hash-ref lex sym #f)))
(if slot (if slot
(fluid-ref slot) (cadr slot)
#f))) #f)))
(define (get-function-binding bindings symbol) (define (get-function-binding bindings symbol)
(and=> (hash-ref (function-bindings 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 ;;; Establish a binding or mark a symbol as dynamically bound for the
;;; extent of calling proc. ;;; extent of calling proc.
@ -78,17 +88,14 @@
(let ((lex (lexical-bindings bindings))) (let ((lex (lexical-bindings bindings)))
(for-each (lambda (sym) (for-each (lambda (sym)
(if (not (hash-ref lex sym)) (if (not (hash-ref lex sym))
(hash-set! lex sym (make-fluid)))) (hash-set! lex sym (list #f #f))))
syms) syms)
(with-fluids* (map (lambda (sym) (hash-ref lex sym)) syms) (with-fluids** (map (lambda (sym) (hash-ref lex sym)) syms)
targets targets
proc))) proc)))
(define (with-lexical-bindings bindings syms targets proc) (define (with-lexical-bindings bindings syms targets proc)
(if (or (not (list? targets)) (with-symbol-bindings bindings syms targets proc))
(not (and-map symbol? targets)))
(error "invalid targets for lexical binding" targets)
(with-symbol-bindings bindings syms targets proc)))
(define (with-dynamic-bindings bindings syms proc) (define (with-dynamic-bindings bindings syms proc)
(with-symbol-bindings bindings (with-symbol-bindings bindings
@ -100,8 +107,8 @@
(let ((fb (function-bindings bindings))) (let ((fb (function-bindings bindings)))
(for-each (lambda (symbol) (for-each (lambda (symbol)
(if (not (hash-ref fb symbol)) (if (not (hash-ref fb symbol))
(hash-set! fb symbol (make-fluid)))) (hash-set! fb symbol (list #f #f))))
symbols) symbols)
(with-fluids* (map (cut hash-ref fb <>) symbols) (with-fluids** (map (cut hash-ref fb <>) symbols)
gensyms gensyms
thunk))) thunk)))

215
module/language/elisp/boot.el
View file

@ -22,11 +22,26 @@
(defmacro @ (module symbol) (defmacro @ (module symbol)
`(guile-ref ,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) (defmacro eval-and-compile (&rest body)
`(progn `(progn
(eval-when-compile ,@body) (eval-when-compile ,@body)
(progn ,@body))) (progn ,@body)))
(eval-and-compile
(defun eval (form)
(%funcall (@ (language elisp runtime) eval-elisp) form)))
(eval-and-compile (eval-and-compile
(defun null (object) (defun null (object)
(if object nil t)) (if object nil t))
@ -40,6 +55,8 @@
(if list (%funcall (@ (guile) cdr) list) nil)) (if list (%funcall (@ (guile) cdr) list) nil))
(defun make-symbol (name) (defun make-symbol (name)
(%funcall (@ (guile) make-symbol) name)) (%funcall (@ (guile) make-symbol) name))
(defun gensym ()
(%funcall (@ (guile) gensym)))
(defun signal (error-symbol data) (defun signal (error-symbol data)
(%funcall (@ (guile) throw) 'elisp-condition error-symbol data))) (%funcall (@ (guile) throw) 'elisp-condition error-symbol data)))
@ -47,12 +64,15 @@
`#'(lambda ,@cdr)) `#'(lambda ,@cdr))
(defmacro prog1 (first &rest body) (defmacro prog1 (first &rest body)
(let ((temp (make-symbol "prog1-temp"))) (let ((temp (gensym)))
`(let ((,temp ,first)) `(let ((,temp ,first))
(declare (lexical ,temp)) (declare (lexical ,temp))
,@body ,@body
,temp))) ,temp)))
(defun interactive (&optional arg)
nil)
(defmacro prog2 (form1 form2 &rest body) (defmacro prog2 (form1 form2 &rest body)
`(progn ,form1 (prog1 ,form2 ,@body))) `(progn ,form1 (prog1 ,form2 ,@body)))
@ -65,7 +85,7 @@
(let ((condition (car first)) (let ((condition (car first))
(body (cdr first))) (body (cdr first)))
(if (null body) (if (null body)
(let ((temp (make-symbol "cond-temp"))) (let ((temp (gensym)))
`(let ((,temp ,condition)) `(let ((,temp ,condition))
(declare (lexical ,temp)) (declare (lexical ,temp))
(if ,temp (if ,temp
@ -86,7 +106,7 @@
(defmacro or (&rest conditions) (defmacro or (&rest conditions)
(cond ((null conditions) nil) (cond ((null conditions) nil)
((null (cdr conditions)) (car conditions)) ((null (cdr conditions)) (car conditions))
(t (let ((temp (make-symbol "or-temp"))) (t (let ((temp (gensym)))
`(let ((,temp ,(car conditions))) `(let ((,temp ,(car conditions)))
(declare (lexical ,temp)) (declare (lexical ,temp))
(if ,temp (if ,temp
@ -118,7 +138,7 @@
(loop bindings '()))) (loop bindings '())))
(defmacro while (test &rest body) (defmacro while (test &rest body)
(let ((loop (make-symbol "loop"))) (let ((loop (gensym)))
`(labels ((,loop () `(labels ((,loop ()
(if ,test (if ,test
(progn ,@body (,loop)) (progn ,@body (,loop))
@ -126,7 +146,7 @@
(,loop)))) (,loop))))
(defmacro unwind-protect (bodyform &rest unwindforms) (defmacro unwind-protect (bodyform &rest unwindforms)
`(funcall (@ (guile) dynamic-wind) `(%funcall (@ (guile) dynamic-wind)
#'(lambda () nil) #'(lambda () nil)
#'(lambda () ,bodyform) #'(lambda () ,bodyform)
#'(lambda () ,@unwindforms))) #'(lambda () ,@unwindforms)))
@ -142,7 +162,7 @@
(defun symbolp (object) (defun symbolp (object)
(%funcall (@ (guile) symbol?) object)) (%funcall (@ (guile) symbol?) object))
(defun functionp (object) (defun %functionp (object)
(%funcall (@ (guile) procedure?) object)) (%funcall (@ (guile) procedure?) object))
(defun symbol-function (symbol) (defun symbol-function (symbol)
@ -162,10 +182,13 @@
(defun %indirect-function (object) (defun %indirect-function (object)
(cond (cond
((functionp object) ((%functionp object)
object) object)
((null object)
(signal 'void-function nil))
((symbolp object) ;++ cycle detection ((symbolp object) ;++ cycle detection
(%indirect-function (symbol-function object))) (%indirect-function
(%funcall (@ (language elisp runtime) symbol-function) object)))
((listp object) ((listp object)
(eval `(function ,object))) (eval `(function ,object)))
(t (t
@ -182,17 +205,67 @@
(%indirect-function function) (%indirect-function function)
arguments)) arguments))
(defun autoload-do-load (fundef &optional funname macro-only)
(and (load (cadr fundef))
(%indirect-function funname)))
(defun fset (symbol definition) (defun fset (symbol definition)
(funcall (@ (language elisp runtime) set-symbol-function!) (funcall (@ (language elisp runtime) set-symbol-function!)
symbol symbol
(if (functionp definition) 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
(cond
((%funcall (@ (guile) procedure?) definition)
definition)
((and (consp definition)
(eq (car definition) 'macro))
(if (%funcall (@ (guile) procedure?) (cdr definition))
definition definition
(cons 'macro
(funcall (@ (language elisp falias) make-falias) (funcall (@ (language elisp falias) make-falias)
#'(lambda (&rest args) (apply definition args)) (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))) definition)))
(t
(funcall (@ (language elisp falias) make-falias)
(function (lambda (&rest args) (apply definition args)))
definition))))
definition) definition)
(defun load (file) (defun gload (file)
(funcall (@ (system base compile) compile-file) (funcall (@ (system base compile) compile-file)
file file
(funcall (@ (guile) symbol->keyword) 'from) (funcall (@ (guile) symbol->keyword) 'from)
@ -203,11 +276,6 @@
;;; Equality predicates ;;; Equality predicates
(defun eq (obj1 obj2)
(if obj1
(funcall (@ (guile) eq?) obj1 obj2)
(null obj2)))
(defun eql (obj1 obj2) (defun eql (obj1 obj2)
(if obj1 (if obj1
(funcall (@ (guile) eqv?) obj1 obj2) (funcall (@ (guile) eqv?) obj1 obj2)
@ -231,13 +299,13 @@
(fset 'fboundp (@ (language elisp runtime) symbol-fbound?)) (fset 'fboundp (@ (language elisp runtime) symbol-fbound?))
(fset 'intern (@ (guile) string->symbol)) (fset 'intern (@ (guile) string->symbol))
(defun defvaralias (new-alias base-variable &optional docstring) ;(defun defvaralias (new-alias base-variable &optional docstring)
(let ((fluid (funcall (@ (language elisp runtime) symbol-fluid) ; (let ((fluid (funcall (@ (language elisp runtime) symbol-fluid)
base-variable))) ; base-variable)))
(funcall (@ (language elisp runtime) set-symbol-fluid!) ; (funcall (@ (language elisp runtime) set-symbol-fluid!)
new-alias ; new-alias
fluid) ; fluid)
base-variable)) ; base-variable))
;;; Numerical type predicates ;;; Numerical type predicates
@ -344,16 +412,6 @@
newcdr) newcdr)
(signal 'wrong-type-argument `(consp ,cell)))) (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) (defun %member (elt list test)
(cond (cond
((null list) nil) ((null list) nil)
@ -400,10 +458,11 @@
(defmacro dolist (spec &rest body) (defmacro dolist (spec &rest body)
(apply #'(lambda (var list &optional result) (apply #'(lambda (var list &optional result)
`(mapc #'(lambda (,var) (list 'progn
,@body (list 'mapc
,result) (cons 'lambda (cons (list var) body))
,list)) list)
result))
spec)) spec))
;;; Strings ;;; Strings
@ -582,6 +641,9 @@
(defun print (object) (defun print (object)
(funcall (@ (guile) write) object)) (funcall (@ (guile) write) object))
(defun prin1 (object)
(funcall (@ (guile) write) object))
(defun terpri () (defun terpri ()
(funcall (@ (guile) newline))) (funcall (@ (guile) newline)))
@ -615,3 +677,82 @@
limit limit
(@ (guile) most-positive-fixnum)) (@ (guile) most-positive-fixnum))
%random-state)) %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"))

331
module/language/elisp/compile-tree-il.scm
View file

@ -30,6 +30,7 @@
#:use-module (srfi srfi-8) #:use-module (srfi srfi-8)
#:use-module (srfi srfi-11) #:use-module (srfi srfi-11)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:use-module (ice-9 format)
#:export (compile-tree-il #:export (compile-tree-il
compile-progn compile-progn
compile-eval-when-compile compile-eval-when-compile
@ -44,6 +45,7 @@
compile-guile-ref compile-guile-ref
compile-guile-private-ref compile-guile-private-ref
compile-guile-primitive compile-guile-primitive
compile-%function
compile-function compile-function
compile-defmacro compile-defmacro
compile-defun compile-defun
@ -61,8 +63,6 @@
(define bindings-data (make-fluid)) (define bindings-data (make-fluid))
(define lexical-binding (make-fluid))
;;; Find the source properties of some parsed expression if there are ;;; Find the source properties of some parsed expression if there are
;;; any associated with it. ;;; any associated with it.
@ -122,28 +122,29 @@
loc loc
symbol symbol
(lambda (lexical) (lambda (lexical)
(make-lexical-ref loc lexical lexical)) (if (symbol? lexical)
(make-lexical-ref loc symbol lexical)
(make-call loc lexical '())))
(lambda () (lambda ()
(call-primitive loc (make-call loc
'fluid-ref (make-module-ref loc runtime 'symbol-value #t)
(make-module-ref loc value-slot symbol #t))))) (list (make-const loc symbol))))))
(define (global? module symbol) (define (global? symbol)
(module-variable module symbol)) (module-variable value-slot symbol))
(define (ensure-globals! loc names body) (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)) (every symbol-interned? names))
body body
(list->seq (list->seq
loc loc
`(,@(map `(,@(map
(lambda (name) (lambda (name)
(ensure-fluid! value-slot name) (symbol-desc name)
(make-call loc (make-call loc
(make-module-ref loc runtime 'ensure-fluid! #t) (make-module-ref loc runtime 'symbol-desc #t)
(list (make-const loc value-slot) (list (make-const loc name))))
(make-const loc name))))
names) names)
,body)))) ,body))))
@ -152,15 +153,17 @@
loc loc
symbol symbol
(lambda (lexical) (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 () (lambda ()
(ensure-globals! (ensure-globals!
loc loc
(list symbol) (list symbol)
(call-primitive loc (make-call loc
'fluid-set! (make-module-ref loc runtime 'set-symbol-value! #t)
(make-module-ref loc value-slot symbol #t) (list (make-const loc symbol)
value))))) value))))))
(define (access-function loc symbol handle-lexical handle-global) (define (access-function loc symbol handle-lexical handle-global)
(cond (cond
@ -174,7 +177,8 @@
loc loc
symbol symbol
(lambda (gensym) (make-lexical-ref loc symbol gensym)) (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) (define (set-function! loc symbol value)
(access-function (access-function
@ -187,15 +191,12 @@
(make-module-ref loc runtime 'set-symbol-function! #t) (make-module-ref loc runtime 'set-symbol-function! #t)
(list (make-const loc symbol) value))))) (list (make-const loc symbol) value)))))
(define (bind-lexically? sym module decls) (define (bind-lexically? sym decls)
(or (eq? module function-slot)
(let ((decl (assq-ref decls sym))) (let ((decl (assq-ref decls sym)))
(and (equal? module value-slot) (or (eq? decl 'lexical)
(or
(eq? decl 'lexical)
(and (and
(fluid-ref lexical-binding) (lexical-binding?)
(not (global? (resolve-module module) sym)))))))) (not (special? sym))))))
(define (parse-let-binding loc binding) (define (parse-let-binding loc binding)
(pmatch binding (pmatch binding
@ -234,11 +235,14 @@
(pmatch lst (pmatch lst
(((declare . ,x) . ,tail) (((declare . ,x) . ,tail)
(loop tail (append-reverse x decls) intspec doc)) (loop tail (append-reverse x decls) intspec doc))
(((interactive . ,x) . ,tail) (((interactive) . ,tail)
(guard lambda? (not intspec)) (guard lambda? (not intspec))
(loop tail decls x doc)) (loop tail decls (cons 'interactive-form #nil) doc))
(((interactive ,x) . ,tail)
(guard lambda? (not intspec))
(loop tail decls (cons 'interactive-form x) doc))
((,x . ,tail) ((,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)) (loop tail decls intspec x))
(else (else
(values (append-map parse-declaration decls) (values (append-map parse-declaration decls)
@ -257,13 +261,14 @@
;;; optional and rest arguments. ;;; optional and rest arguments.
(define (parse-lambda-list lst) (define (parse-lambda-list lst)
(define (%match lst null optional rest symbol) (define (%match lst null optional rest symbol list*)
(pmatch lst (pmatch lst
(() (null)) (() (null))
(nil (null)) (nil (null))
((&optional . ,tail) (optional tail)) ((&optional . ,tail) (optional tail))
((&rest . ,tail) (rest tail)) ((&rest . ,tail) (rest tail))
((,arg . ,tail) (guard (symbol? arg)) (symbol arg tail)) ((,arg . ,tail) (guard (symbol? arg)) (symbol arg tail))
((,arg . ,tail) (guard (list? arg)) (list* arg tail))
(else (fail)))) (else (fail))))
(define (return rreq ropt rest) (define (return rreq ropt rest)
(values #t (reverse rreq) (reverse ropt) rest)) (values #t (reverse rreq) (reverse ropt) rest))
@ -274,24 +279,28 @@
(lambda () (return rreq '() #f)) (lambda () (return rreq '() #f))
(lambda (tail) (parse-opt tail rreq '())) (lambda (tail) (parse-opt tail rreq '()))
(lambda (tail) (parse-rest 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) (define (parse-opt lst rreq ropt)
(%match lst (%match lst
(lambda () (return rreq ropt #f)) (lambda () (return rreq ropt #f))
(lambda (tail) (fail)) (lambda (tail) (fail))
(lambda (tail) (parse-rest tail rreq ropt)) (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))))) (lambda (arg tail) (parse-opt tail rreq (cons arg ropt)))))
(define (parse-rest lst rreq ropt) (define (parse-rest lst rreq ropt)
(%match lst (%match lst
(lambda () (fail)) (lambda () (fail))
(lambda (tail) (fail)) (lambda (tail) (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) (define (parse-post-rest lst rreq ropt rest)
(%match lst (%match lst
(lambda () (return rreq ropt rest)) (lambda () (return rreq ropt rest))
(lambda () (fail)) (lambda () (fail))
(lambda () (fail)) (lambda () (fail))
(lambda (arg tail) (fail))
(lambda (arg tail) (fail)))) (lambda (arg tail) (fail))))
(parse-req lst '())) (parse-req lst '()))
@ -308,8 +317,8 @@
(let lp ((f f) (v v)) (let lp ((f f) (v v))
(if (null? f) (if (null? f)
body body
(make-primcall (make-call src
src 'with-fluid* (make-module-ref src runtime 'bind-symbol #t)
(list (make-lexical-ref #f 'fluid (car f)) (list (make-lexical-ref #f 'fluid (car f))
(make-lexical-ref #f 'val (car v)) (make-lexical-ref #f 'val (car v))
(make-lambda (make-lambda
@ -320,18 +329,18 @@
#f)))))))))) #f))))))))))
(define (compile-lambda loc meta args body) (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) (parse-lambda-list args)
(if valid? (if valid?
(let* ((all-ids (append req-ids (let* ((all-ids (append req-ids
opt-ids (and opts (map car opts))
(or (and=> rest-id list) '()))) (or (and=> rest-id list) '())))
(all-vars (map (lambda (ignore) (gensym)) all-ids))) (all-vars (map (lambda (ignore) (gensym)) all-ids)))
(let*-values (((decls intspec doc forms) (let*-values (((decls intspec doc forms)
(parse-lambda-body body)) (parse-lambda-body body))
((lexical dynamic) ((lexical dynamic)
(partition (partition
(compose (cut bind-lexically? <> value-slot decls) (compose (cut bind-lexically? <> decls)
car) car)
(map list all-ids all-vars))) (map list all-ids all-vars)))
((lexical-ids lexical-vars) (unzip2 lexical)) ((lexical-ids lexical-vars) (unzip2 lexical))
@ -361,50 +370,42 @@
tree-il tree-il
(make-dynlet (make-dynlet
loc loc
(map (cut make-module-ref loc value-slot <> #t) (map (cut make-const loc <>) dynamic-ids)
dynamic-ids)
(map (cut make-lexical-ref loc <> <>) (map (cut make-lexical-ref loc <> <>)
dynamic-ids dynamic-ids
dynamic-vars) dynamic-vars)
tree-il)))) tree-il))))
(make-simple-lambda loc (make-simple-lambda loc
meta (append (if intspec
(list intspec)
'())
(if doc
(list (cons 'emacs-documentation doc))
'())
meta)
req-ids req-ids
opt-ids (map car opts)
(map (const (nil-value loc)) (map (lambda (x)
opt-ids) (if (pair? (cdr x))
(compile-expr (car (cdr x)))
(make-const loc #nil)))
opts)
rest-id rest-id
all-vars all-vars
full-body))))))))) full-body)))))))))
(report-error "invalid function" `(lambda ,args ,@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. ;;; Handle macro and special operator bindings.
(define (find-operator name type) (define (find-operator name type)
(and (and
(symbol? name) (symbol? name)
(module-defined? (resolve-interface function-slot) name) (module-defined? function-slot name)
(let ((op (module-ref (resolve-module function-slot) name))) (let ((op (module-ref function-slot name)))
(if (and (pair? op) (eq? (car op) type)) (if (and (pair? op) (eq? (car op) type))
(cdr op) (cdr op)
#f)))) #f))))
;;; See if a (backquoted) expression contains any unquotes.
(define (contains-unquotes? expr) (define (contains-unquotes? expr)
(if (pair? expr) (if (pair? expr)
(if (or (unquote? (car expr)) (unquote-splicing? (car expr))) (if (or (unquote? (car expr)) (unquote-splicing? (car expr)))
@ -475,41 +476,47 @@
(call-primitive loc 'not (call-primitive loc 'not
(call-primitive loc 'nil? (compile-expr cond))) (call-primitive loc 'nil? (compile-expr cond)))
(compile-expr then) (compile-expr then)
(compile-expr `(progn ,@else)))))) (compile-expr `(progn ,@else))))
(else (report-error loc "Bad if" args))))
(defspecial defconst (loc args) (defspecial defconst (loc args)
(pmatch args (pmatch args
((,sym ,value . ,doc) ((,sym ,value . ,doc)
(if (handle-var-def loc sym doc) (make-seq
loc
(make-call loc
(make-module-ref loc runtime 'proclaim-special! #t)
(list (make-const loc sym)))
(make-seq loc (make-seq loc
(set-variable! loc sym (compile-expr value)) (set-variable! loc sym (compile-expr value))
(make-const loc sym)))))) (make-const loc sym))))
(else (report-error loc "Bad defconst" args))))
(defspecial defvar (loc args) (defspecial defvar (loc args)
(pmatch 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) ((,sym ,value . ,doc)
(if (handle-var-def loc sym doc) (make-seq
loc
(make-call loc
(make-module-ref loc runtime 'proclaim-special! #t)
(list (make-const loc sym)))
(make-seq (make-seq
loc loc
(make-conditional (make-conditional
loc loc
(make-conditional (make-call loc
loc (make-module-ref loc runtime 'symbol-bound? #t)
(call-primitive (list (make-const loc sym)))
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) (make-void loc)
(set-variable! loc sym (compile-expr value))) (set-variable! loc sym (compile-expr value)))
(make-const loc sym)))))) (make-const loc sym))))
(else (report-error loc "Bad defvar" args))))
(defspecial setq (loc args) (defspecial setq (loc args)
(define (car* x) (if (null? x) '() (car x))) (define (car* x) (if (null? x) '() (car x)))
@ -524,7 +531,7 @@
(let ((sym (car args)) (let ((sym (car args))
(val (compile-expr (cadr* args)))) (val (compile-expr (cadr* args))))
(if (not (symbol? sym)) (if (not (symbol? sym))
(report-error loc "expected symbol in setq") (report-error loc "expected symbol in setq" args)
(cons (cons
(set-variable! loc sym val) (set-variable! loc sym val)
(loop (cddr* args) (loop (cddr* args)
@ -537,7 +544,7 @@
(receive (decls forms) (parse-body body) (receive (decls forms) (parse-body body)
(receive (lexical dynamic) (receive (lexical dynamic)
(partition (partition
(compose (cut bind-lexically? <> value-slot decls) (compose (cut bind-lexically? <> decls)
car) car)
bindings) bindings)
(let ((make-values (lambda (for) (let ((make-values (lambda (for)
@ -549,12 +556,7 @@
(map car dynamic) (map car dynamic)
(if (null? lexical) (if (null? lexical)
(make-dynlet loc (make-dynlet loc
(map (compose (cut make-module-ref (map (compose (cut make-const loc <>) car)
loc
value-slot
<>
#t)
car)
dynamic) dynamic)
(map (compose compile-expr cdr) (map (compose compile-expr cdr)
dynamic) dynamic)
@ -577,12 +579,9 @@
(make-body) (make-body)
(make-dynlet loc (make-dynlet loc
(map (map
(compose (compose (cut make-const
(cut make-module-ref
loc loc
value-slot <>)
<>
#t)
car) car)
dynamic) dynamic)
(map (map
@ -592,7 +591,8 @@
sym sym
sym)) sym))
dynamic-syms) dynamic-syms)
(make-body)))))))))))))))) (make-body))))))))))))))
(else (report-error loc "bad let args"))))
(defspecial let* (loc args) (defspecial let* (loc args)
(pmatch args (pmatch args
@ -604,7 +604,7 @@
(compile-expr `(progn ,@forms)) (compile-expr `(progn ,@forms))
(let ((sym (caar tail)) (let ((sym (caar tail))
(value (compile-expr (cdar tail)))) (value (compile-expr (cdar tail))))
(if (bind-lexically? sym value-slot decls) (if (bind-lexically? sym decls)
(let ((target (gensym))) (let ((target (gensym)))
(make-let loc (make-let loc
`(,target) `(,target)
@ -619,9 +619,10 @@
loc loc
(list sym) (list sym)
(make-dynlet loc (make-dynlet loc
(list (make-module-ref loc value-slot sym #t)) (list (make-const loc sym))
(list value) (list value)
(iterate (cdr tail))))))))))))) (iterate (cdr tail)))))))))))
(else (report-error loc "Bad let*" args))))
(defspecial flet (loc args) (defspecial flet (loc args)
(pmatch args (pmatch args
@ -640,7 +641,8 @@
names names
gensyms gensyms
(map compile-expr vals) (map compile-expr vals)
(compile-expr `(progn ,@forms))))))))))) (compile-expr `(progn ,@forms)))))))))
(else (report-error loc "bad flet" args))))
(defspecial labels (loc args) (defspecial labels (loc args)
(pmatch args (pmatch args
@ -660,7 +662,8 @@
names names
gensyms gensyms
(map compile-expr vals) (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 ;;; guile-ref allows building TreeIL's module references from within
;;; elisp as a way to access data within the Guile universe. The module ;;; elisp as a way to access data within the Guile universe. The module
@ -670,12 +673,14 @@
(defspecial guile-ref (loc args) (defspecial guile-ref (loc args)
(pmatch args (pmatch args
((,module ,sym) (guard (and (list? module) (symbol? sym))) ((,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) (defspecial guile-private-ref (loc args)
(pmatch args (pmatch args
((,module ,sym) (guard (and (list? module) (symbol? sym))) ((,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 ;;; guile-primitive allows to create primitive references, which are
;;; still a little faster. ;;; still a little faster.
@ -683,14 +688,46 @@
(defspecial guile-primitive (loc args) (defspecial guile-primitive (loc args)
(pmatch args (pmatch args
((,sym) ((,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 (pmatch args
(((lambda ,args . ,body)) (((lambda ,args . ,body))
(compile-lambda loc '() 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)) ((,sym) (guard (symbol? sym))
(reference-function loc 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))
(make-const loc sym))
(else ((cdr compile-%function) loc args))))
(defspecial defmacro (loc args) (defspecial defmacro (loc args)
(pmatch args (pmatch args
@ -715,44 +752,60 @@
(with-native-target (with-native-target
(lambda () (lambda ()
(compile tree-il #:from 'tree-il #:to 'value))) (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
((,name ,args . ,body)
(if (not (symbol? name))
(report-error loc "expected symbol as function name" name)
(make-seq loc
(set-function! loc
name
(compile-lambda loc
`((name . ,name))
args
body))
(make-const loc name))))))
(defspecial #{`}# (loc args) (defspecial #{`}# (loc args)
(pmatch args (pmatch args
((,val) ((,val)
(process-backquote loc val)))) (process-backquote loc val))
(else (report-error loc "bad backquote" args))))
(defspecial quote (loc args) (defspecial quote (loc args)
(pmatch args (pmatch args
((,val) ((,val)
(make-const loc val)))) (make-const loc val))
(else (report-error loc "bad quote" args))))
(defspecial %funcall (loc args) (defspecial %funcall (loc args)
(pmatch args (pmatch args
((,function . ,arguments) ((,function . ,arguments)
(make-call loc (make-call loc
(compile-expr function) (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) (defspecial %set-lexical-binding-mode (loc args)
(pmatch args (pmatch args
((,val) ((,val)
(fluid-set! lexical-binding val) (set-lexical-binding-mode val)
(make-void loc)))) (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. ;;; Compile a compound expression to Tree-IL.
@ -760,14 +813,14 @@
(let ((operator (car expr)) (let ((operator (car expr))
(arguments (cdr expr))) (arguments (cdr expr)))
(cond (cond
((find-operator operator 'special-operator)
=> (lambda (special-operator-function)
(special-operator-function loc arguments)))
((find-operator operator 'macro) ((find-operator operator 'macro)
=> (lambda (macro-function) => (lambda (macro-function)
(compile-expr (apply macro-function arguments)))) (compile-expr (apply macro-function arguments))))
((hashq-ref special-operators operator)
=> (lambda (special-operator-function)
(special-operator-function loc arguments)))
(else (else
(compile-expr `(%funcall (function ,operator) ,@arguments)))))) (compile-expr `(%funcall (%function ,operator) ,@arguments))))))
;;; Compile a symbol expression. This is a variable reference or maybe ;;; Compile a symbol expression. This is a variable reference or maybe
;;; some special value like nil. ;;; some special value like nil.
@ -789,31 +842,9 @@
(compile-pair loc expr)) (compile-pair loc expr))
(else (make-const 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) (define (compile-tree-il expr env opts)
(values (values
(with-fluids ((bindings-data (make-bindings))) (with-fluids ((bindings-data (make-bindings)))
(process-options! opts)
(compile-expr expr)) (compile-expr expr))
env env
env)) env))

5
module/language/elisp/lexer.scm
View file

@ -20,6 +20,7 @@
(define-module (language elisp lexer) (define-module (language elisp lexer)
#:use-module (ice-9 regex) #:use-module (ice-9 regex)
#:use-module (language elisp runtime)
#:export (get-lexer get-lexer/1)) #:export (get-lexer get-lexer/1))
;;; This is the lexical analyzer for the elisp reader. It is ;;; This is the lexical analyzer for the elisp reader. It is
@ -316,7 +317,9 @@
(let ((cur (read-char port))) (let ((cur (read-char port)))
(case cur (case cur
((#\") ((#\")
(return 'string (list->string (reverse result-chars)))) (return 'string
(make-lisp-string
(list->string (reverse result-chars)))))
((#\\) ((#\\)
(let ((escaped (read-char port))) (let ((escaped (read-char port)))
(case escaped (case escaped

195
module/language/elisp/runtime.scm
View file

@ -19,22 +19,39 @@
;;; Code: ;;; Code:
(define-module (language elisp runtime) (define-module (language elisp runtime)
#:use-module (ice-9 format)
#:use-module ((system base compile)
#:select (compile))
#:export (nil-value #:export (nil-value
t-value t-value
value-slot-module value-slot-module
function-slot-module function-slot-module
elisp-bool elisp-bool
ensure-fluid! ensure-dynamic!
symbol-fluid symbol-name
set-symbol-fluid!
symbol-value symbol-value
set-symbol-value! set-symbol-value!
symbol-function symbol-function
set-symbol-function! set-symbol-function!
symbol-plist
set-symbol-plist!
symbol-bound? symbol-bound?
symbol-fbound? symbol-fbound?
bind-symbol
makunbound! 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)) #:export-syntax (defspecial prim))
;;; This module provides runtime support for the Elisp front-end. ;;; This module provides runtime support for the Elisp front-end.
@ -45,13 +62,21 @@
(define t-value #t) (define t-value #t)
(define make-lisp-string identity)
(define lisp-string? string?)
;;; Modules for the binding slots. ;;; Modules for the binding slots.
;;; Note: Naming those value-slot and/or function-slot clashes with the ;;; Note: Naming those value-slot and/or function-slot clashes with the
;;; submodules of these names! ;;; 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 '(language elisp runtime function-slot)) (define function-slot-module (resolve-module '(elisp-functions)))
(define plist-slot-module (resolve-module '(elisp-plists)))
(define nil_ 'nil)
(define t_ 't)
;;; Routines for access to elisp dynamically bound symbols. This is ;;; Routines for access to elisp dynamically bound symbols. This is
;;; used for runtime access using functions like symbol-value or set, ;;; 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 ;;; always access the dynamic binding and can not be used for the
;;; lexical! ;;; lexical!
(define (ensure-fluid! module sym) (define lexical-binding #t)
(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) (define (lexical-binding?)
(let ((module (resolve-module value-slot-module))) lexical-binding)
(ensure-fluid! value-slot-module symbol) ;++ implicit special proclamation
(module-ref module symbol)))
(define (set-symbol-fluid! symbol fluid) (define (set-lexical-binding-mode x)
(let ((module (resolve-module value-slot-module))) (set! lexical-binding x))
(module-define! module symbol fluid)
(module-export! module (list symbol))) (define unbound (make-symbol "unbound"))
fluid)
(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 (symbol-dynamic symbol)
(ensure-dynamic! symbol)
(symbol-desc symbol))
(define (symbol-value symbol) (define (symbol-value symbol)
(fluid-ref (symbol-fluid symbol))) (dynamic-ref (symbol-desc symbol)))
(define (set-symbol-value! symbol value) (define (set-symbol-value! symbol value)
(fluid-set! (symbol-fluid symbol) value) (dynamic-set! (symbol-desc symbol) value)
value) value)
(define (symbol-function symbol) (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))) (module-ref module symbol)))
(define (set-symbol-function! symbol value) (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-define! module symbol value)
(module-export! module (list symbol))) (module-export! module (list symbol)))
value) value)
(define (symbol-bound? symbol) (define (symbol-bound? symbol)
(set! symbol (schemify symbol))
(and (and
(module-bound? (resolve-interface value-slot-module) symbol) (module-bound? value-slot-module symbol)
(let ((var (module-variable (resolve-module value-slot-module) (let ((var (module-variable value-slot-module
symbol))) symbol)))
(and (variable-bound? var) (and (variable-bound? var)
(if (fluid? (variable-ref var)) (if (dynamic? (variable-ref var))
(fluid-bound? (variable-ref var)) (dynamic-bound? (variable-ref var))
#t))))) #t)))))
(define (symbol-fbound? symbol) (define (symbol-fbound? symbol)
(set! symbol (schemify symbol))
(and (and
(module-bound? (resolve-interface function-slot-module) symbol) (module-bound? function-slot-module symbol)
(variable-bound? (variable-bound?
(module-variable (resolve-module function-slot-module) (module-variable function-slot-module symbol))
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) (define (makunbound! symbol)
(if (module-bound? (resolve-interface value-slot-module) symbol) (if (module-bound? value-slot-module symbol)
(let ((var (module-variable (resolve-module value-slot-module) (let ((var (module-variable value-slot-module
symbol))) symbol)))
(if (and (variable-bound? var) (fluid? (variable-ref var))) (if (and (variable-bound? var) (dynamic? (variable-ref var)))
(fluid-unset! (variable-ref var)) (dynamic-unset! (variable-ref var))
(variable-unset! var)))) (variable-unset! var))))
symbol) symbol)
(define (fmakunbound! symbol) (define (fmakunbound! symbol)
(if (module-bound? (resolve-interface function-slot-module) symbol) (if (module-bound? function-slot-module symbol)
(variable-unset! (module-variable (variable-unset! (module-variable function-slot-module symbol)))
(resolve-module function-slot-module)
symbol)))
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 a predefined macro for use in the function-slot module.
(define (make-id template-id . data) (define (make-id template-id . data)

11
module/language/elisp/spec.scm
View file

@ -24,14 +24,25 @@
#:use-module (system base language) #:use-module (system base language)
#:use-module (system base compile) #:use-module (system base compile)
#:use-module (system base target) #:use-module (system base target)
#:use-module (system vm vm)
#:export (elisp)) #: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 (define-language elisp
#:title "Emacs Lisp" #:title "Emacs Lisp"
#:reader (lambda (port env) (read-elisp port)) #:reader (lambda (port env) (read-elisp port))
;;#:joiner (lambda (exps env) (cons 'progn exps))
#:printer write #:printer write
#:compilers `((tree-il . ,compile-tree-il))) #: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 ;; Compile and load the Elisp boot code for the native host
;; architecture. We must specifically ask for native compilation here, ;; architecture. We must specifically ask for native compilation here,
;; because this module might be loaded in a dynamic environment where ;; because this module might be loaded in a dynamic environment where