From 4a4d36bafcce15bf2eddc30b4f5ab7ced9ad9f87 Mon Sep 17 00:00:00 2001 From: Taylan Kammer Date: Thu, 13 May 2021 12:03:37 +0200 Subject: [PATCH] In elisp, #nil and #t are symbols. --- module/language/elisp/boot.el | 6 +- module/language/elisp/runtime.scm | 97 +++++++++++++++++++++---------- 2 files changed, 69 insertions(+), 34 deletions(-) diff --git a/module/language/elisp/boot.el b/module/language/elisp/boot.el index f55722a9a..0089b7c37 100644 --- a/module/language/elisp/boot.el +++ b/module/language/elisp/boot.el @@ -140,7 +140,7 @@ ,@body)) (defun symbolp (object) - (%funcall (@ (guile) symbol?) object)) + (%funcall (@ (language elisp runtime) elisp-symbol?) object)) (defun functionp (object) (%funcall (@ (guile) procedure?) object)) @@ -222,14 +222,14 @@ ;;; `symbolp' and `symbol-function' are defined above. -(fset 'symbol-name (@ (guile) symbol->string)) +(fset 'symbol-name (@ (language elisp runtime) symbol-name)) (fset 'symbol-value (@ (language elisp runtime) symbol-value)) (fset 'set (@ (language elisp runtime) set-symbol-value!)) (fset 'makunbound (@ (language elisp runtime) makunbound!)) (fset 'fmakunbound (@ (language elisp runtime) fmakunbound!)) (fset 'boundp (@ (language elisp runtime) symbol-bound?)) (fset 'fboundp (@ (language elisp runtime) symbol-fbound?)) -(fset 'intern (@ (guile) string->symbol)) +(fset 'intern (@ (language elisp runtime) intern)) (defun defvaralias (new-alias base-variable &optional docstring) (let ((fluid (funcall (@ (language elisp runtime) symbol-fluid) diff --git a/module/language/elisp/runtime.scm b/module/language/elisp/runtime.scm index 6f6a22074..8318cc313 100644 --- a/module/language/elisp/runtime.scm +++ b/module/language/elisp/runtime.scm @@ -21,6 +21,9 @@ (define-module (language elisp runtime) #:export (nil-value t-value + elisp-symbol? + symbol-name + intern value-slot-module function-slot-module elisp-bool @@ -45,6 +48,30 @@ (define t-value #t) +;;; Elisp symbols include #nil and #t + +(define (elisp-symbol? x) + (or (symbol? x) + (eq? #nil x) + (eq? #t x))) + +(define (elisp-symbol sym) + (cond + ((symbol? sym) sym) + ((eq? sym #nil) 'nil) + ((eq? sym #t) 't) + (else (error "Not a symbol." sym)))) + +(define (symbol-name sym) + (symbol->string (elisp-symbol sym))) + +(define (intern str) + (let ((sym (string->symbol str))) + (cond + ((eq? sym 'nil) #nil) + ((eq? sym 't) #t) + (else sym)))) + ;;; Modules for the binding slots. ;;; Note: Naming those value-slot and/or function-slot clashes with the ;;; submodules of these names! @@ -68,64 +95,72 @@ (module-export! resolved `(,sym)))))) (define (symbol-fluid symbol) - (let ((module (resolve-module value-slot-module))) + (let ((module (resolve-module value-slot-module)) + (symbol (elisp-symbol symbol))) (ensure-fluid! value-slot-module symbol) ;++ implicit special proclamation (module-ref module symbol))) (define (set-symbol-fluid! symbol fluid) - (let ((module (resolve-module value-slot-module))) + (let ((module (resolve-module value-slot-module)) + (symbol (elisp-symbol symbol))) (module-define! module symbol fluid) (module-export! module (list symbol))) fluid) (define (symbol-value symbol) - (fluid-ref (symbol-fluid symbol))) + (fluid-ref (symbol-fluid (elisp-symbol symbol)))) (define (set-symbol-value! symbol value) - (fluid-set! (symbol-fluid symbol) value) + (fluid-set! (symbol-fluid (elisp-symbol symbol)) value) value) (define (symbol-function symbol) - (let ((module (resolve-module function-slot-module))) + (let ((module (resolve-module function-slot-module)) + (symbol (elisp-symbol symbol))) (module-ref module symbol))) (define (set-symbol-function! symbol value) - (let ((module (resolve-module function-slot-module))) + (let ((module (resolve-module function-slot-module)) + (symbol (elisp-symbol symbol))) (module-define! module symbol value) (module-export! module (list symbol))) value) (define (symbol-bound? symbol) - (and - (module-bound? (resolve-interface value-slot-module) symbol) - (let ((var (module-variable (resolve-module value-slot-module) - symbol))) - (and (variable-bound? var) - (if (fluid? (variable-ref var)) - (fluid-bound? (variable-ref var)) - #t))))) + (let ((symbol (elisp-symbol symbol))) + (and + (module-bound? (resolve-interface value-slot-module) symbol) + (let ((var (module-variable (resolve-module value-slot-module) + symbol))) + (and (variable-bound? var) + (if (fluid? (variable-ref var)) + (fluid-bound? (variable-ref var)) + #t)))))) (define (symbol-fbound? symbol) - (and - (module-bound? (resolve-interface function-slot-module) symbol) - (variable-bound? - (module-variable (resolve-module function-slot-module) - symbol)))) + (let ((symbol (elisp-symbol symbol))) + (and + (module-bound? (resolve-interface function-slot-module) symbol) + (variable-bound? + (module-variable (resolve-module function-slot-module) + symbol))))) (define (makunbound! symbol) - (if (module-bound? (resolve-interface value-slot-module) symbol) - (let ((var (module-variable (resolve-module value-slot-module) - symbol))) - (if (and (variable-bound? var) (fluid? (variable-ref var))) - (fluid-unset! (variable-ref var)) - (variable-unset! var)))) - symbol) + (let ((symbol (elisp-symbol symbol))) + (if (module-bound? (resolve-interface value-slot-module) symbol) + (let ((var (module-variable (resolve-module value-slot-module) + symbol))) + (if (and (variable-bound? var) (fluid? (variable-ref var))) + (fluid-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))) + (let ((symbol (elisp-symbol symbol))) + (if (module-bound? (resolve-interface function-slot-module) symbol) + (variable-unset! (module-variable + (resolve-module function-slot-module) + symbol)))) symbol) ;;; Define a predefined macro for use in the function-slot module. @@ -134,7 +169,7 @@ (let ((append-symbols (lambda (symbols) (string->symbol - (apply string-append (map symbol->string symbols)))))) + (apply string-append (map symbol-name symbols)))))) (datum->syntax template-id (append-symbols (map (lambda (datum) -- 2.30.2