diff options
| -rw-r--r-- | module/language/elisp/bindings.scm | 35 | ||||
| -rw-r--r-- | module/language/elisp/boot.el | 241 | ||||
| -rw-r--r-- | module/language/elisp/compile-tree-il.scm | 357 | ||||
| -rw-r--r-- | module/language/elisp/lexer.scm | 5 | ||||
| -rw-r--r-- | module/language/elisp/runtime.scm | 197 | ||||
| -rw-r--r-- | module/language/elisp/spec.scm | 11 |
6 files changed, 583 insertions, 263 deletions
diff --git a/module/language/elisp/bindings.scm b/module/language/elisp/bindings.scm index 9fabddfc4..1dc296f68 100644 --- a/module/language/elisp/bindings.scm +++ b/module/language/elisp/bindings.scm @@ -61,12 +61,22 @@ (let* ((lex (lexical-bindings bindings)) (slot (hash-ref lex sym #f))) (if slot - (fluid-ref slot) + (cadr slot) #f))) (define (get-function-binding bindings symbol) (and=> (hash-ref (function-bindings bindings) symbol) - fluid-ref)) + cadr)) + +(define (with-fluids** fls vals proc) + (dynamic-wind + (lambda () + (for-each (lambda (f v) (set-cdr! f (cons v (cdr f)))) + fls vals)) + proc + (lambda () + (for-each (lambda (f) (set-cdr! f (cdr (cdr f)))) + fls)))) ;;; Establish a binding or mark a symbol as dynamically bound for the ;;; extent of calling proc. @@ -78,17 +88,14 @@ (let ((lex (lexical-bindings bindings))) (for-each (lambda (sym) (if (not (hash-ref lex sym)) - (hash-set! lex sym (make-fluid)))) + (hash-set! lex sym (list #f #f)))) syms) - (with-fluids* (map (lambda (sym) (hash-ref lex sym)) syms) - targets - proc))) + (with-fluids** (map (lambda (sym) (hash-ref lex sym)) syms) + targets + proc))) (define (with-lexical-bindings bindings syms targets proc) - (if (or (not (list? targets)) - (not (and-map symbol? targets))) - (error "invalid targets for lexical binding" targets) - (with-symbol-bindings bindings syms targets proc))) + (with-symbol-bindings bindings syms targets proc)) (define (with-dynamic-bindings bindings syms proc) (with-symbol-bindings bindings @@ -100,8 +107,8 @@ (let ((fb (function-bindings bindings))) (for-each (lambda (symbol) (if (not (hash-ref fb symbol)) - (hash-set! fb symbol (make-fluid)))) + (hash-set! fb symbol (list #f #f)))) symbols) - (with-fluids* (map (cut hash-ref fb <>) symbols) - gensyms - thunk))) + (with-fluids** (map (cut hash-ref fb <>) symbols) + gensyms + thunk))) diff --git a/module/language/elisp/boot.el b/module/language/elisp/boot.el index f55722a9a..1079357be 100644 --- a/module/language/elisp/boot.el +++ b/module/language/elisp/boot.el @@ -22,12 +22,27 @@ (defmacro @ (module symbol) `(guile-ref ,module ,symbol)) +(defmacro defun (name args &rest body) + `(let ((proc (function (lambda ,args ,@body)))) + (%funcall (@ (language elisp runtime) set-symbol-function!) + ',name + proc) + (%funcall (@ (guile) set-procedure-property!) + proc 'name ',name) + ',name)) + +(defun omega () (omega)) + (defmacro eval-and-compile (&rest body) `(progn (eval-when-compile ,@body) (progn ,@body))) (eval-and-compile + (defun eval (form) + (%funcall (@ (language elisp runtime) eval-elisp) form))) + +(eval-and-compile (defun null (object) (if object nil t)) (defun consp (object) @@ -40,6 +55,8 @@ (if list (%funcall (@ (guile) cdr) list) nil)) (defun make-symbol (name) (%funcall (@ (guile) make-symbol) name)) + (defun gensym () + (%funcall (@ (guile) gensym))) (defun signal (error-symbol data) (%funcall (@ (guile) throw) 'elisp-condition error-symbol data))) @@ -47,12 +64,15 @@ `#'(lambda ,@cdr)) (defmacro prog1 (first &rest body) - (let ((temp (make-symbol "prog1-temp"))) + (let ((temp (gensym))) `(let ((,temp ,first)) (declare (lexical ,temp)) ,@body ,temp))) +(defun interactive (&optional arg) + nil) + (defmacro prog2 (form1 form2 &rest body) `(progn ,form1 (prog1 ,form2 ,@body))) @@ -65,7 +85,7 @@ (let ((condition (car first)) (body (cdr first))) (if (null body) - (let ((temp (make-symbol "cond-temp"))) + (let ((temp (gensym))) `(let ((,temp ,condition)) (declare (lexical ,temp)) (if ,temp @@ -86,7 +106,7 @@ (defmacro or (&rest conditions) (cond ((null conditions) nil) ((null (cdr conditions)) (car conditions)) - (t (let ((temp (make-symbol "or-temp"))) + (t (let ((temp (gensym))) `(let ((,temp ,(car conditions))) (declare (lexical ,temp)) (if ,temp @@ -118,7 +138,7 @@ (loop bindings '()))) (defmacro while (test &rest body) - (let ((loop (make-symbol "loop"))) + (let ((loop (gensym))) `(labels ((,loop () (if ,test (progn ,@body (,loop)) @@ -126,10 +146,10 @@ (,loop)))) (defmacro unwind-protect (bodyform &rest unwindforms) - `(funcall (@ (guile) dynamic-wind) - #'(lambda () nil) - #'(lambda () ,bodyform) - #'(lambda () ,@unwindforms))) + `(%funcall (@ (guile) dynamic-wind) + #'(lambda () nil) + #'(lambda () ,bodyform) + #'(lambda () ,@unwindforms))) (defmacro when (cond &rest body) `(if ,cond @@ -142,7 +162,7 @@ (defun symbolp (object) (%funcall (@ (guile) symbol?) object)) -(defun functionp (object) +(defun %functionp (object) (%funcall (@ (guile) procedure?) object)) (defun symbol-function (symbol) @@ -162,10 +182,13 @@ (defun %indirect-function (object) (cond - ((functionp object) + ((%functionp object) object) + ((null object) + (signal 'void-function nil)) ((symbolp object) ;++ cycle detection - (%indirect-function (symbol-function object))) + (%indirect-function + (%funcall (@ (language elisp runtime) symbol-function) object))) ((listp object) (eval `(function ,object))) (t @@ -182,17 +205,67 @@ (%indirect-function function) arguments)) +(defun autoload-do-load (fundef &optional funname macro-only) + (and (load (cadr fundef)) + (%indirect-function funname))) + +(defun fset (symbol definition) + (funcall (@ (language elisp runtime) set-symbol-function!) + symbol + definition)) + +(defun eq (obj1 obj2) + (if obj1 + (%funcall (@ (guile) eq?) obj1 obj2) + (if obj2 nil t))) + +(defun nthcdr (n list) + (let ((i 0)) + (while (< i n) + (setq list (cdr list) + i (+ i 1))) + list)) + +(defun nth (n list) + (car (nthcdr n list))) + (defun fset (symbol definition) (funcall (@ (language elisp runtime) set-symbol-function!) symbol - (if (functionp definition) - definition + (cond + ((%funcall (@ (guile) procedure?) definition) + definition) + ((and (consp definition) + (eq (car definition) 'macro)) + (if (%funcall (@ (guile) procedure?) (cdr definition)) + definition + (cons 'macro + (funcall (@ (language elisp falias) make-falias) + (function + (lambda (&rest args) (apply (cdr definition) args))) + (cdr definition))))) + ((and (consp definition) + (eq (car definition) 'autoload)) + (if (or (eq (nth 4 definition) 'macro) + (eq (nth 4 definition) t)) + (cons 'macro + (funcall + (@ (language elisp falias) make-falias) + (function (lambda (&rest args) + (apply (cdr (autoload-do-load definition symbol nil)) args))) + definition)) + (funcall + (@ (language elisp falias) make-falias) + (function (lambda (&rest args) + (apply (autoload-do-load definition symbol nil) args))) + definition))) + (t (funcall (@ (language elisp falias) make-falias) - #'(lambda (&rest args) (apply definition args)) - definition))) + (function (lambda (&rest args) (apply definition args))) + definition)))) definition) -(defun load (file) +(defun gload (file) (funcall (@ (system base compile) compile-file) file (funcall (@ (guile) symbol->keyword) 'from) @@ -203,11 +276,6 @@ ;;; Equality predicates -(defun eq (obj1 obj2) - (if obj1 - (funcall (@ (guile) eq?) obj1 obj2) - (null obj2))) - (defun eql (obj1 obj2) (if obj1 (funcall (@ (guile) eqv?) obj1 obj2) @@ -231,13 +299,13 @@ (fset 'fboundp (@ (language elisp runtime) symbol-fbound?)) (fset 'intern (@ (guile) string->symbol)) -(defun defvaralias (new-alias base-variable &optional docstring) - (let ((fluid (funcall (@ (language elisp runtime) symbol-fluid) - base-variable))) - (funcall (@ (language elisp runtime) set-symbol-fluid!) - new-alias - fluid) - base-variable)) +;(defun defvaralias (new-alias base-variable &optional docstring) +; (let ((fluid (funcall (@ (language elisp runtime) symbol-fluid) +; base-variable))) +; (funcall (@ (language elisp runtime) set-symbol-fluid!) +; new-alias +; fluid) +; base-variable)) ;;; Numerical type predicates @@ -344,16 +412,6 @@ newcdr) (signal 'wrong-type-argument `(consp ,cell)))) -(defun nthcdr (n list) - (let ((i 0)) - (while (< i n) - (setq list (cdr list) - i (+ i 1))) - list)) - -(defun nth (n list) - (car (nthcdr n list))) - (defun %member (elt list test) (cond ((null list) nil) @@ -400,10 +458,11 @@ (defmacro dolist (spec &rest body) (apply #'(lambda (var list &optional result) - `(mapc #'(lambda (,var) - ,@body - ,result) - ,list)) + (list 'progn + (list 'mapc + (cons 'lambda (cons (list var) body)) + list) + result)) spec)) ;;; Strings @@ -582,6 +641,9 @@ (defun print (object) (funcall (@ (guile) write) object)) +(defun prin1 (object) + (funcall (@ (guile) write) object)) + (defun terpri () (funcall (@ (guile) newline))) @@ -607,11 +669,90 @@ (@ (guile) *random-state*))) (defun random (&optional limit) - (if (eq limit t) - (setq %random-state - (funcall (@ (guile) random-state-from-platform)))) - (funcall (@ (guile) random) - (if (wholenump limit) - limit - (@ (guile) most-positive-fixnum)) - %random-state)) + (if (eq limit t) + (setq %random-state + (funcall (@ (guile) random-state-from-platform)))) + (funcall (@ (guile) random) + (if (wholenump limit) + limit + (@ (guile) most-positive-fixnum)) + %random-state)) + +(defmacro save-excursion (&rest body) + `(call-with-save-excursion #'(lambda () ,@body))) + +(defmacro save-current-buffer (&rest body) + `(call-with-save-current-buffer #'(lambda () ,@body))) + +(defmacro save-restriction (&rest body) + `(call-with-save-restriction #'(lambda () ,@body))) + +(defmacro track-mouse (&rest body) + `(call-with-track-mouse #'(lambda () ,@body))) + +(defmacro setq-default (var value &rest args) + `(progn (set-default ',var ,value) + ,(if (null args) + var + `(setq-default ,@args)))) + +(defmacro catch (tag &rest body) + `(call-with-catch ,tag #'(lambda () ,@body))) + +(defmacro condition-case (var bodyform &rest args) + (if (consp args) + (let* ((handler (car args)) + (handlers (cdr args)) + (handler-conditions (car handler)) + (handler-body (cdr handler))) + `(call-with-handler ',var + ',handler-conditions + #'(lambda () ,@handler-body) + #'(lambda () + (condition-case ,var + ,bodyform + ,@handlers)))) + bodyform)) + +(defun backtrace-frame (nframes) + (let* ((stack (funcall (@ (guile) make-stack) t)) + (frame (stack-ref stack nframes)) + (proc (funcall (@ (guile) frame-procedure) frame)) + (pname (or (and (%functionp proc) + (funcall (@ (guile) procedure-name) proc)) + proc)) + (args (funcall (@ (guile) frame-arguments) frame))) + (cons t (cons pname args)))) + +(defun backtrace () + (interactive) + (let* ((stack (funcall (@ (guile) make-stack) t)) + (frame (funcall (@ (guile) stack-ref) stack 1)) + (space (funcall (@ (guile) integer->char) 32))) + (while frame + (princ (string 32 32)) + (let ((proc (funcall (@ (guile) frame-procedure) frame))) + (prin1 (or (and (%functionp proc) + (funcall (@ (guile) procedure-name) proc)) + proc))) + (prin1 (funcall (@ (guile) frame-arguments) frame)) + (terpri) + (setq frame (funcall (@ (guile) frame-previous) frame))) + nil)) + +(defun %set-eager-macroexpansion-mode (ignore) + nil) + +(defun progn (&rest args) (error "Special operator")) +(defun eval-when-compile (&rest args) (error "Special operator")) +(defun if (&rest args) (error "Special operator")) +(defun defconst (&rest args) (error "Special operator")) +(defun defvar (&rest args) (error "Special operator")) +(defun setq (&rest args) (error "Special operator")) +(defun let (&rest args) (error "Special operator")) +(defun flet (&rest args) (error "Special operator")) +(defun labels (&rest args) (error "Special operator")) +(defun let* (&rest args) (error "Special operator")) +(defun function (&rest args) (error "Special operator")) +(defun defmacro (&rest args) (error "Special operator")) +(defun quote (&rest args) (error "Special operator")) diff --git a/module/language/elisp/compile-tree-il.scm b/module/language/elisp/compile-tree-il.scm index 5d6ebc591..8da1d583c 100644 --- a/module/language/elisp/compile-tree-il.scm +++ b/module/language/elisp/compile-tree-il.scm @@ -30,6 +30,7 @@ #:use-module (srfi srfi-8) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) + #:use-module (ice-9 format) #:export (compile-tree-il compile-progn compile-eval-when-compile @@ -44,6 +45,7 @@ compile-guile-ref compile-guile-private-ref compile-guile-primitive + compile-%function compile-function compile-defmacro compile-defun @@ -61,8 +63,6 @@ (define bindings-data (make-fluid)) -(define lexical-binding (make-fluid)) - ;;; Find the source properties of some parsed expression if there are ;;; any associated with it. @@ -122,28 +122,29 @@ loc symbol (lambda (lexical) - (make-lexical-ref loc lexical lexical)) + (if (symbol? lexical) + (make-lexical-ref loc symbol lexical) + (make-call loc lexical '()))) (lambda () - (call-primitive loc - 'fluid-ref - (make-module-ref loc value-slot symbol #t))))) + (make-call loc + (make-module-ref loc runtime 'symbol-value #t) + (list (make-const loc symbol)))))) -(define (global? module symbol) - (module-variable module symbol)) +(define (global? symbol) + (module-variable value-slot symbol)) (define (ensure-globals! loc names body) - (if (and (every (cut global? (resolve-module value-slot) <>) names) + (if (and (every global? names) (every symbol-interned? names)) body (list->seq loc `(,@(map (lambda (name) - (ensure-fluid! value-slot name) + (symbol-desc name) (make-call loc - (make-module-ref loc runtime 'ensure-fluid! #t) - (list (make-const loc value-slot) - (make-const loc name)))) + (make-module-ref loc runtime 'symbol-desc #t) + (list (make-const loc name)))) names) ,body)))) @@ -152,15 +153,17 @@ loc symbol (lambda (lexical) - (make-lexical-set loc lexical lexical value)) + (if (symbol? lexical) + (make-lexical-set loc symbol lexical value) + (make-call loc lexical (list value)))) (lambda () (ensure-globals! loc (list symbol) - (call-primitive loc - 'fluid-set! - (make-module-ref loc value-slot symbol #t) - value))))) + (make-call loc + (make-module-ref loc runtime 'set-symbol-value! #t) + (list (make-const loc symbol) + value)))))) (define (access-function loc symbol handle-lexical handle-global) (cond @@ -174,7 +177,8 @@ loc symbol (lambda (gensym) (make-lexical-ref loc symbol gensym)) - (lambda () (make-module-ref loc function-slot symbol #t)))) + (lambda () + (make-module-ref loc '(elisp-functions) symbol #t)))) (define (set-function! loc symbol value) (access-function @@ -187,15 +191,12 @@ (make-module-ref loc runtime 'set-symbol-function! #t) (list (make-const loc symbol) value))))) -(define (bind-lexically? sym module decls) - (or (eq? module function-slot) - (let ((decl (assq-ref decls sym))) - (and (equal? module value-slot) - (or - (eq? decl 'lexical) - (and - (fluid-ref lexical-binding) - (not (global? (resolve-module module) sym)))))))) +(define (bind-lexically? sym decls) + (let ((decl (assq-ref decls sym))) + (or (eq? decl 'lexical) + (and + (lexical-binding?) + (not (special? sym)))))) (define (parse-let-binding loc binding) (pmatch binding @@ -234,11 +235,14 @@ (pmatch lst (((declare . ,x) . ,tail) (loop tail (append-reverse x decls) intspec doc)) - (((interactive . ,x) . ,tail) + (((interactive) . ,tail) + (guard lambda? (not intspec)) + (loop tail decls (cons 'interactive-form #nil) doc)) + (((interactive ,x) . ,tail) (guard lambda? (not intspec)) - (loop tail decls x doc)) + (loop tail decls (cons 'interactive-form x) doc)) ((,x . ,tail) - (guard lambda? (string? x) (not doc) (not (null? tail))) + (guard lambda? (or (string? x) (lisp-string? x)) (not doc) (not (null? tail))) (loop tail decls intspec x)) (else (values (append-map parse-declaration decls) @@ -257,12 +261,13 @@ ;;; optional and rest arguments. (define (parse-lambda-list lst) - (define (%match lst null optional rest symbol) + (define (%match lst null optional rest symbol list*) (pmatch lst (() (null)) ((&optional . ,tail) (optional tail)) ((&rest . ,tail) (rest tail)) ((,arg . ,tail) (guard (symbol? arg)) (symbol arg tail)) + ((,arg . ,tail) (guard (list? arg)) (list* arg tail)) (else (fail)))) (define (return rreq ropt rest) (values #t (reverse rreq) (reverse ropt) rest)) @@ -273,24 +278,28 @@ (lambda () (return rreq '() #f)) (lambda (tail) (parse-opt tail rreq '())) (lambda (tail) (parse-rest tail rreq '())) - (lambda (arg tail) (parse-req tail (cons arg rreq))))) + (lambda (arg tail) (parse-req tail (cons arg rreq))) + (lambda (arg tail) (fail)))) (define (parse-opt lst rreq ropt) (%match lst (lambda () (return rreq ropt #f)) (lambda (tail) (fail)) (lambda (tail) (parse-rest tail rreq ropt)) + (lambda (arg tail) (parse-opt tail rreq (cons (list arg) ropt))) (lambda (arg tail) (parse-opt tail rreq (cons arg ropt))))) (define (parse-rest lst rreq ropt) (%match lst (lambda () (fail)) (lambda (tail) (fail)) (lambda (tail) (fail)) - (lambda (arg tail) (parse-post-rest tail rreq ropt arg)))) + (lambda (arg tail) (parse-post-rest tail rreq ropt arg)) + (lambda (arg tail) (fail)))) (define (parse-post-rest lst rreq ropt rest) (%match lst (lambda () (return rreq ropt rest)) (lambda () (fail)) (lambda () (fail)) + (lambda (arg tail) (fail)) (lambda (arg tail) (fail)))) (parse-req lst '())) @@ -307,30 +316,30 @@ (let lp ((f f) (v v)) (if (null? f) body - (make-primcall - src 'with-fluid* - (list (make-lexical-ref #f 'fluid (car f)) - (make-lexical-ref #f 'val (car v)) - (make-lambda - src '() - (make-lambda-case - src '() #f #f #f '() '() - (lp (cdr f) (cdr v)) - #f)))))))))) + (make-call src + (make-module-ref src runtime 'bind-symbol #t) + (list (make-lexical-ref #f 'fluid (car f)) + (make-lexical-ref #f 'val (car v)) + (make-lambda + src '() + (make-lambda-case + src '() #f #f #f '() '() + (lp (cdr f) (cdr v)) + #f)))))))))) (define (compile-lambda loc meta args body) - (receive (valid? req-ids opt-ids rest-id) + (receive (valid? req-ids opts rest-id) (parse-lambda-list args) (if valid? (let* ((all-ids (append req-ids - opt-ids + (and opts (map car opts)) (or (and=> rest-id list) '()))) (all-vars (map (lambda (ignore) (gensym)) all-ids))) (let*-values (((decls intspec doc forms) (parse-lambda-body body)) ((lexical dynamic) (partition - (compose (cut bind-lexically? <> value-slot decls) + (compose (cut bind-lexically? <> decls) car) (map list all-ids all-vars))) ((lexical-ids lexical-vars) (unzip2 lexical)) @@ -360,50 +369,42 @@ tree-il (make-dynlet loc - (map (cut make-module-ref loc value-slot <> #t) - dynamic-ids) + (map (cut make-const loc <>) dynamic-ids) (map (cut make-lexical-ref loc <> <>) dynamic-ids dynamic-vars) tree-il)))) (make-simple-lambda loc - meta + (append (if intspec + (list intspec) + '()) + (if doc + (list (cons 'emacs-documentation doc)) + '()) + meta) req-ids - opt-ids - (map (const (nil-value loc)) - opt-ids) + (map car opts) + (map (lambda (x) + (if (pair? (cdr x)) + (compile-expr (car (cdr x))) + (make-const loc #nil))) + opts) rest-id all-vars full-body))))))))) (report-error "invalid function" `(lambda ,args ,@body))))) -;;; Handle the common part of defconst and defvar, that is, checking for -;;; a correct doc string and arguments as well as maybe in the future -;;; handling the docstring somehow. - -(define (handle-var-def loc sym doc) - (cond - ((not (symbol? sym)) (report-error loc "expected symbol, got" sym)) - ((> (length doc) 1) (report-error loc "too many arguments to defvar")) - ((and (not (null? doc)) (not (string? (car doc)))) - (report-error loc "expected string as third argument of defvar, got" - (car doc))) - ;; TODO: Handle doc string if present. - (else #t))) - ;;; Handle macro and special operator bindings. (define (find-operator name type) (and (symbol? name) - (module-defined? (resolve-interface function-slot) name) - (let ((op (module-ref (resolve-module function-slot) name))) + (module-defined? function-slot name) + (let ((op (module-ref function-slot name))) (if (and (pair? op) (eq? (car op) type)) (cdr op) #f)))) -;;; See if a (backquoted) expression contains any unquotes. - (define (contains-unquotes? expr) (if (pair? expr) (if (or (unquote? (car expr)) (unquote-splicing? (car expr))) @@ -474,41 +475,47 @@ (call-primitive loc 'not (call-primitive loc 'nil? (compile-expr cond))) (compile-expr then) - (compile-expr `(progn ,@else)))))) + (compile-expr `(progn ,@else)))) + (else (report-error loc "Bad if" args)))) (defspecial defconst (loc args) (pmatch args ((,sym ,value . ,doc) - (if (handle-var-def loc sym doc) - (make-seq loc - (set-variable! loc sym (compile-expr value)) - (make-const loc sym)))))) + (make-seq + loc + (make-call loc + (make-module-ref loc runtime 'proclaim-special! #t) + (list (make-const loc sym))) + (make-seq loc + (set-variable! loc sym (compile-expr value)) + (make-const loc sym)))) + (else (report-error loc "Bad defconst" args)))) (defspecial defvar (loc args) (pmatch args - ((,sym) (make-const loc sym)) + ((,sym) + (make-seq loc + (make-call loc + (make-module-ref loc runtime 'proclaim-special! #t) + (list (make-const loc sym))) + (make-const loc sym))) ((,sym ,value . ,doc) - (if (handle-var-def loc sym doc) - (make-seq - loc - (make-conditional - loc - (make-conditional - loc - (call-primitive - loc - 'module-bound? - (call-primitive loc - 'resolve-interface - (make-const loc value-slot)) - (make-const loc sym)) - (call-primitive loc - 'fluid-bound? - (make-module-ref loc value-slot sym #t)) - (make-const loc #f)) - (make-void loc) - (set-variable! loc sym (compile-expr value))) - (make-const loc sym)))))) + (make-seq + loc + (make-call loc + (make-module-ref loc runtime 'proclaim-special! #t) + (list (make-const loc sym))) + (make-seq + loc + (make-conditional + loc + (make-call loc + (make-module-ref loc runtime 'symbol-bound? #t) + (list (make-const loc sym))) + (make-void loc) + (set-variable! loc sym (compile-expr value))) + (make-const loc sym)))) + (else (report-error loc "Bad defvar" args)))) (defspecial setq (loc args) (define (car* x) (if (null? x) '() (car x))) @@ -523,7 +530,7 @@ (let ((sym (car args)) (val (compile-expr (cadr* args)))) (if (not (symbol? sym)) - (report-error loc "expected symbol in setq") + (report-error loc "expected symbol in setq" args) (cons (set-variable! loc sym val) (loop (cddr* args) @@ -536,7 +543,7 @@ (receive (decls forms) (parse-body body) (receive (lexical dynamic) (partition - (compose (cut bind-lexically? <> value-slot decls) + (compose (cut bind-lexically? <> decls) car) bindings) (let ((make-values (lambda (for) @@ -548,12 +555,7 @@ (map car dynamic) (if (null? lexical) (make-dynlet loc - (map (compose (cut make-module-ref - loc - value-slot - <> - #t) - car) + (map (compose (cut make-const loc <>) car) dynamic) (map (compose compile-expr cdr) dynamic) @@ -576,13 +578,10 @@ (make-body) (make-dynlet loc (map - (compose - (cut make-module-ref - loc - value-slot - <> - #t) - car) + (compose (cut make-const + loc + <>) + car) dynamic) (map (lambda (sym) @@ -591,7 +590,8 @@ sym sym)) dynamic-syms) - (make-body)))))))))))))))) + (make-body)))))))))))))) + (else (report-error loc "bad let args")))) (defspecial let* (loc args) (pmatch args @@ -603,7 +603,7 @@ (compile-expr `(progn ,@forms)) (let ((sym (caar tail)) (value (compile-expr (cdar tail)))) - (if (bind-lexically? sym value-slot decls) + (if (bind-lexically? sym decls) (let ((target (gensym))) (make-let loc `(,target) @@ -618,9 +618,10 @@ loc (list sym) (make-dynlet loc - (list (make-module-ref loc value-slot sym #t)) + (list (make-const loc sym)) (list value) - (iterate (cdr tail))))))))))))) + (iterate (cdr tail))))))))))) + (else (report-error loc "Bad let*" args)))) (defspecial flet (loc args) (pmatch args @@ -639,7 +640,8 @@ names gensyms (map compile-expr vals) - (compile-expr `(progn ,@forms))))))))))) + (compile-expr `(progn ,@forms))))))))) + (else (report-error loc "bad flet" args)))) (defspecial labels (loc args) (pmatch args @@ -659,7 +661,8 @@ names gensyms (map compile-expr vals) - (compile-expr `(progn ,@forms))))))))))) + (compile-expr `(progn ,@forms))))))))) + (else (report-error loc "bad labels" args)))) ;;; guile-ref allows building TreeIL's module references from within ;;; elisp as a way to access data within the Guile universe. The module @@ -669,12 +672,14 @@ (defspecial guile-ref (loc args) (pmatch args ((,module ,sym) (guard (and (list? module) (symbol? sym))) - (make-module-ref loc module sym #t)))) + (make-module-ref loc module sym #t)) + (else (report-error loc "bad guile-ref" args)))) (defspecial guile-private-ref (loc args) (pmatch args ((,module ,sym) (guard (and (list? module) (symbol? sym))) - (make-module-ref loc module sym #f)))) + (make-module-ref loc module sym #f)) + (else (report-error loc "bad guile-private-ref" args)))) ;;; guile-primitive allows to create primitive references, which are ;;; still a little faster. @@ -682,14 +687,46 @@ (defspecial guile-primitive (loc args) (pmatch args ((,sym) - (make-primitive-ref loc sym)))) + (make-primitive-ref loc sym)) + (else (report-error loc "bad guile-primitive" args)))) -(defspecial function (loc args) +(defspecial %function (loc args) (pmatch args (((lambda ,args . ,body)) (compile-lambda loc '() args body)) + (((closure ,env ,args . ,body)) + (let ((bindings (map (lambda (x) (list (car x) (cdr x))) + (filter pair? env)))) + (compile-expr + (let ((form `(let ,bindings + (declare ,@(map (lambda (x) (list 'lexical x)) + bindings)) + (function (lambda ,args + (declare + (lexical + ,@(filter-map + (lambda (x) + (cond + ((memq x '(&optional &rest)) + #f) + ((symbol? x) + x) + ((list? x) + (car x)))) + args))) + ,@body))))) + form)))) + ((,sym) (guard (symbol? sym)) + (reference-function loc sym)) + ((,x) + (make-const loc x)) + (else (report-error loc "bad function" args)))) + +(defspecial function (loc args) + (pmatch args ((,sym) (guard (symbol? sym)) - (reference-function loc sym)))) + (make-const loc sym)) + (else ((cdr compile-%function) loc args)))) (defspecial defmacro (loc args) (pmatch args @@ -714,7 +751,8 @@ (with-native-target (lambda () (compile tree-il #:from 'tree-il #:to 'value))) - tree-il))))) + tree-il))) + (else (report-error loc "bad defmacro" args)))) (defspecial defun (loc args) (pmatch args @@ -733,25 +771,54 @@ (defspecial #{`}# (loc args) (pmatch args ((,val) - (process-backquote loc val)))) + (process-backquote loc val)) + (else (report-error loc "bad backquote" args)))) (defspecial quote (loc args) (pmatch args ((,val) - (make-const loc val)))) + (make-const loc val)) + (else (report-error loc "bad quote" args)))) (defspecial %funcall (loc args) (pmatch args ((,function . ,arguments) (make-call loc (compile-expr function) - (map compile-expr arguments))))) + (map compile-expr arguments))) + (else (report-error loc "bad %funcall" args)))) (defspecial %set-lexical-binding-mode (loc args) (pmatch args ((,val) - (fluid-set! lexical-binding val) - (make-void loc)))) + (set-lexical-binding-mode val) + (make-void loc)) + (else (report-error loc "bad %set-lexical-binding-mode" args)))) + +(define special-operators (make-hash-table)) + +(for-each + (lambda (pair) (hashq-set! special-operators (car pair) (cddr pair))) + `((progn . ,compile-progn) + (eval-when-compile . ,compile-eval-when-compile) + (if . ,compile-if) + (defconst . ,compile-defconst) + (defvar . ,compile-defvar) + (setq . ,compile-setq) + (let . ,compile-let) + (flet . ,compile-flet) + (labels . ,compile-labels) + (let* . ,compile-let*) + (guile-ref . ,compile-guile-ref) + (guile-private-ref . ,compile-guile-private-ref) + (guile-primitive . ,compile-guile-primitive) + (%function . ,compile-%function) + (function . ,compile-function) + (defmacro . ,compile-defmacro) + (#{`}# . ,#{compile-`}#) + (quote . ,compile-quote) + (%funcall . ,compile-%funcall) + (%set-lexical-binding-mode . ,compile-%set-lexical-binding-mode))) ;;; Compile a compound expression to Tree-IL. @@ -759,14 +826,14 @@ (let ((operator (car expr)) (arguments (cdr expr))) (cond - ((find-operator operator 'special-operator) - => (lambda (special-operator-function) - (special-operator-function loc arguments))) ((find-operator operator 'macro) => (lambda (macro-function) (compile-expr (apply macro-function arguments)))) + ((hashq-ref special-operators operator) + => (lambda (special-operator-function) + (special-operator-function loc arguments))) (else - (compile-expr `(%funcall (function ,operator) ,@arguments)))))) + (compile-expr `(%funcall (%function ,operator) ,@arguments)))))) ;;; Compile a symbol expression. This is a variable reference or maybe ;;; some special value like nil. @@ -788,31 +855,9 @@ (compile-pair loc expr)) (else (make-const loc expr))))) -;;; Process the compiler options. -;;; FIXME: Why is '(()) passed as options by the REPL? - -(define (valid-symbol-list-arg? value) - (or (eq? value 'all) - (and (list? value) (and-map symbol? value)))) - -(define (process-options! opt) - (if (and (not (null? opt)) - (not (equal? opt '(())))) - (if (null? (cdr opt)) - (report-error #f "Invalid compiler options" opt) - (let ((key (car opt)) - (value (cadr opt))) - (case key - ((#:warnings #:to-file?) ; ignore - #f) - (else (report-error #f - "Invalid compiler option" - key))))))) - (define (compile-tree-il expr env opts) (values (with-fluids ((bindings-data (make-bindings))) - (process-options! opts) (compile-expr expr)) env env)) diff --git a/module/language/elisp/lexer.scm b/module/language/elisp/lexer.scm index 5a0e6b3ff..8152a1182 100644 --- a/module/language/elisp/lexer.scm +++ b/module/language/elisp/lexer.scm @@ -20,6 +20,7 @@ (define-module (language elisp lexer) #:use-module (ice-9 regex) + #:use-module (language elisp runtime) #:export (get-lexer get-lexer/1)) ;;; This is the lexical analyzer for the elisp reader. It is @@ -316,7 +317,9 @@ (let ((cur (read-char port))) (case cur ((#\") - (return 'string (list->string (reverse result-chars)))) + (return 'string + (make-lisp-string + (list->string (reverse result-chars))))) ((#\\) (let ((escaped (read-char port))) (case escaped diff --git a/module/language/elisp/runtime.scm b/module/language/elisp/runtime.scm index 6f6a22074..bedb15a8a 100644 --- a/module/language/elisp/runtime.scm +++ b/module/language/elisp/runtime.scm @@ -19,22 +19,39 @@ ;;; Code: (define-module (language elisp runtime) + #:use-module (ice-9 format) + #:use-module ((system base compile) + #:select (compile)) #:export (nil-value t-value value-slot-module function-slot-module elisp-bool - ensure-fluid! - symbol-fluid - set-symbol-fluid! + ensure-dynamic! + symbol-name symbol-value set-symbol-value! symbol-function set-symbol-function! + symbol-plist + set-symbol-plist! symbol-bound? symbol-fbound? + bind-symbol makunbound! - fmakunbound!) + fmakunbound! + symbol-desc + proclaim-special! + special? + emacs! + unbound + lexical-binding? + set-lexical-binding-mode + log! + eval-elisp + local-eval-elisp + make-lisp-string + lisp-string?) #:export-syntax (defspecial prim)) ;;; This module provides runtime support for the Elisp front-end. @@ -45,13 +62,21 @@ (define t-value #t) +(define make-lisp-string identity) +(define lisp-string? string?) + ;;; Modules for the binding slots. ;;; Note: Naming those value-slot and/or function-slot clashes with the ;;; submodules of these names! -(define value-slot-module '(language elisp runtime value-slot)) +(define value-slot-module (resolve-module '(elisp-symbols))) + +(define function-slot-module (resolve-module '(elisp-functions))) -(define function-slot-module '(language elisp runtime function-slot)) +(define plist-slot-module (resolve-module '(elisp-plists))) + +(define nil_ 'nil) +(define t_ 't) ;;; Routines for access to elisp dynamically bound symbols. This is ;;; used for runtime access using functions like symbol-value or set, @@ -59,75 +84,163 @@ ;;; always access the dynamic binding and can not be used for the ;;; lexical! -(define (ensure-fluid! module sym) - (let ((intf (resolve-interface module)) - (resolved (resolve-module module))) - (if (not (module-defined? intf sym)) - (let ((fluid (make-unbound-fluid))) - (module-define! resolved sym fluid) - (module-export! resolved `(,sym)))))) - -(define (symbol-fluid symbol) - (let ((module (resolve-module value-slot-module))) - (ensure-fluid! value-slot-module symbol) ;++ implicit special proclamation - (module-ref module symbol))) +(define lexical-binding #t) + +(define (lexical-binding?) + lexical-binding) + +(define (set-lexical-binding-mode x) + (set! lexical-binding x)) + +(define unbound (make-symbol "unbound")) + +(define dynamic? vector?) +(define (make-dynamic) + (vector #f 4 0 0 unbound)) +(define (dynamic-ref x) + (vector-ref x 4)) +(define (dynamic-set! x v) + (vector-set! x 4 v)) +(define (dynamic-unset! x) + (vector-set! x 4 unbound)) +(define (dynamic-bound? x) + (not (eq? (vector-ref x 4) unbound))) +(define (dynamic-bind x v thunk) + (let ((old (vector-ref x 4))) + (dynamic-wind + (lambda () (vector-set! x 4 v)) + thunk + (lambda () (vector-set! x 4 old))))) + +(define-inlinable (ensure-present! module sym thunk) + (or (module-local-variable module sym) + (let ((variable (make-variable (thunk)))) + (module-add! module sym variable) + variable))) + +(define-inlinable (ensure-desc! module sym) + (ensure-present! module + sym + (lambda () + (let ((x (make-dynamic))) + (vector-set! x 0 sym) + x)))) + +(define-inlinable (schemify symbol) + (case symbol + ((#nil) nil_) + ((#t) t_) + (else symbol))) + +(define (symbol-name symbol) + (symbol->string (schemify symbol))) + +(define (symbol-desc symbol) + (let ((symbol (schemify symbol))) + (let ((module value-slot-module)) + (variable-ref (ensure-desc! module symbol))))) + +(define (ensure-dynamic! sym) + (vector-set! (symbol-desc sym) 3 1)) -(define (set-symbol-fluid! symbol fluid) - (let ((module (resolve-module value-slot-module))) - (module-define! module symbol fluid) - (module-export! module (list symbol))) - fluid) +(define (symbol-dynamic symbol) + (ensure-dynamic! symbol) + (symbol-desc symbol)) (define (symbol-value symbol) - (fluid-ref (symbol-fluid symbol))) + (dynamic-ref (symbol-desc symbol))) (define (set-symbol-value! symbol value) - (fluid-set! (symbol-fluid symbol) value) + (dynamic-set! (symbol-desc symbol) value) value) (define (symbol-function symbol) - (let ((module (resolve-module function-slot-module))) + (set! symbol (schemify symbol)) + (ensure-present! function-slot-module symbol (lambda () #nil)) + (let ((module function-slot-module)) (module-ref module symbol))) (define (set-symbol-function! symbol value) - (let ((module (resolve-module function-slot-module))) + (set! symbol (schemify symbol)) + (ensure-present! function-slot-module symbol (lambda () #nil)) + (let ((module function-slot-module)) + (module-define! module symbol value) + (module-export! module (list symbol))) + value) + +(define (symbol-plist symbol) + (set! symbol (schemify symbol)) + (ensure-present! plist-slot-module symbol (lambda () #nil)) + (let ((module plist-slot-module)) + (module-ref module symbol))) + +(define (set-symbol-plist! symbol value) + (set! symbol (schemify symbol)) + (ensure-present! plist-slot-module symbol (lambda () #nil)) + (let ((module plist-slot-module)) (module-define! module symbol value) (module-export! module (list symbol))) value) (define (symbol-bound? symbol) + (set! symbol (schemify symbol)) (and - (module-bound? (resolve-interface value-slot-module) symbol) - (let ((var (module-variable (resolve-module value-slot-module) + (module-bound? value-slot-module symbol) + (let ((var (module-variable value-slot-module symbol))) (and (variable-bound? var) - (if (fluid? (variable-ref var)) - (fluid-bound? (variable-ref var)) + (if (dynamic? (variable-ref var)) + (dynamic-bound? (variable-ref var)) #t))))) (define (symbol-fbound? symbol) + (set! symbol (schemify symbol)) (and - (module-bound? (resolve-interface function-slot-module) symbol) + (module-bound? function-slot-module symbol) (variable-bound? - (module-variable (resolve-module function-slot-module) - symbol)))) + (module-variable function-slot-module symbol)) + (variable-ref (module-variable function-slot-module symbol)))) + +(define (bind-symbol symbol value thunk) + (dynamic-bind (symbol-desc symbol) value thunk)) (define (makunbound! symbol) - (if (module-bound? (resolve-interface value-slot-module) symbol) - (let ((var (module-variable (resolve-module value-slot-module) + (if (module-bound? value-slot-module symbol) + (let ((var (module-variable value-slot-module symbol))) - (if (and (variable-bound? var) (fluid? (variable-ref var))) - (fluid-unset! (variable-ref var)) + (if (and (variable-bound? var) (dynamic? (variable-ref var))) + (dynamic-unset! (variable-ref var)) (variable-unset! var)))) symbol) (define (fmakunbound! symbol) - (if (module-bound? (resolve-interface function-slot-module) symbol) - (variable-unset! (module-variable - (resolve-module function-slot-module) - symbol))) + (if (module-bound? function-slot-module symbol) + (variable-unset! (module-variable function-slot-module symbol))) symbol) +(define (special? sym) + (eqv? (vector-ref (symbol-desc sym) 3) 1)) + +(define (proclaim-special! sym) + (vector-set! (symbol-desc sym) 3 1) + #nil) + +(define (emacs! ref set boundp bind) + (set! symbol-value ref) + (set! set-symbol-value! set) + (set! symbol-bound? boundp) + (set! bind-symbol bind) + (set! lexical-binding? (lambda () (symbol-value 'lexical-binding))) + (set! set-lexical-binding-mode (lambda (x) (set-symbol-value! 'lexical-binding x)))) + +(define (eval-elisp form) + (compile form #:from 'elisp #:to 'value)) + +(set-symbol-value! nil_ #nil) +(set-symbol-value! t_ #t) + +(define (make-string s) s) + ;;; Define a predefined macro for use in the function-slot module. (define (make-id template-id . data) diff --git a/module/language/elisp/spec.scm b/module/language/elisp/spec.scm index 0a064b2fa..6032004c4 100644 --- a/module/language/elisp/spec.scm +++ b/module/language/elisp/spec.scm @@ -24,14 +24,25 @@ #:use-module (system base language) #:use-module (system base compile) #:use-module (system base target) + #:use-module (system vm vm) #:export (elisp)) +(save-module-excursion + (lambda () + (define-module (elisp-symbols) #:pure #:filename #f) + (define-module (elisp-functions) #:pure #:filename #f) + (define-module (elisp-plists) #:pure #:filename #f))) + (define-language elisp #:title "Emacs Lisp" #:reader (lambda (port env) (read-elisp port)) + ;;#:joiner (lambda (exps env) (cons 'progn exps)) #:printer write #:compilers `((tree-il . ,compile-tree-il))) +(set-default-vm-engine! 'debug) +(set-vm-engine! 'debug) + ;; Compile and load the Elisp boot code for the native host ;; architecture. We must specifically ask for native compilation here, ;; because this module might be loaded in a dynamic environment where |