mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-14 01:30:19 +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

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

@ -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)))

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

@ -22,11 +22,26 @@
(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))
@ -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
(if (functionp definition)
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
(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"))

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

@ -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 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)
(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,13 +261,14 @@
;;; 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))
(nil (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))
@ -274,24 +279,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 '()))
@ -308,30 +317,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))
@ -361,50 +370,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)))
@ -475,41 +476,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)))
@ -524,7 +531,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)
@ -537,7 +544,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)
@ -549,12 +556,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)
@ -577,13 +579,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)
@ -592,7 +591,8 @@
sym
sym))
dynamic-syms)
(make-body))))))))))))))))
(make-body))))))))))))))
(else (report-error loc "bad let args"))))
(defspecial let* (loc args)
(pmatch args
@ -604,7 +604,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)
@ -619,9 +619,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
@ -640,7 +641,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
@ -660,7 +662,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
@ -670,12 +673,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.
@ -683,14 +688,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))))
(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)
(pmatch args
@ -715,44 +752,60 @@
(with-native-target
(lambda ()
(compile tree-il #:from 'tree-il #:to 'value)))
tree-il)))))
(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))))))
tree-il)))
(else (report-error loc "bad defmacro" args))))
(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.
@ -760,14 +813,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.
@ -789,31 +842,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))

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

@ -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

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

@ -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 '(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
;;; 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 lexical-binding #t)
(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?)
lexical-binding)
(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 (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 (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)

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

@ -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