From 85bc6238bfa628c84e11f9202128cad479d75524 Mon Sep 17 00:00:00 2001 From: BT Templeton Date: Tue, 12 Jul 2011 20:56:38 -0400 Subject: [PATCH] simplify elisp symbol accessors * module/language/elisp/boot.el (fset, symbol-value, symbol-function) (set, makunbound, fmakunbound, boundp, fboundp): Use procedures in `(language elisp runtime)'. (symbolp): New function. * module/language/elisp/compile-tree-il.scm (set-variable!): Use `set-symbol-function!'. * module/language/elisp/runtime.scm (reference-variable, set-variable!): Remove. (symbol-fluid, set-symbol-fluid!): New procedure. (symbol-value, set-symbol-value!, symbol-function) (set-symbol-function!, symbol-bound?, symbol-fbound?, makunbound!) (fmakunbound!): Moved from `(language elisp subrs)' and updated to avoid using `reference-variable' and `set-variable!'. * module/language/elisp/runtime/subrs.scm (symbol-value) (symbol-function, set, fset, makunbound, fmakunbound, boundp) (fboundp): Move to `(language elisp runtime)'. (apply): Use `symbol-function'. --- module/language/elisp/boot.el | 22 +++-- module/language/elisp/compile-tree-il.scm | 4 +- module/language/elisp/runtime.scm | 98 +++++++++++++++++------ module/language/elisp/runtime/subrs.scm | 67 +--------------- 4 files changed, 92 insertions(+), 99 deletions(-) diff --git a/module/language/elisp/boot.el b/module/language/elisp/boot.el index bc9d6ad12..37cac5071 100644 --- a/module/language/elisp/boot.el +++ b/module/language/elisp/boot.el @@ -31,7 +31,9 @@ (defun funcall (function &rest arguments) (apply function arguments)) (defun fset (symbol definition) - (funcall (@ (language elisp runtime subrs) fset) symbol definition)) + (funcall (@ (language elisp runtime) set-symbol-function!) + symbol + definition)) (defun null (object) (if object nil t)) (fset 'consp (@ (guile) pair?)) @@ -115,13 +117,6 @@ #'(lambda () ,bodyform) #'(lambda () ,@unwindforms))) -(fset 'symbol-value (@ (language elisp runtime subrs) symbol-value)) -(fset 'symbol-function (@ (language elisp runtime subrs) symbol-function)) -(fset 'set (@ (language elisp runtime subrs) set)) -(fset 'makunbound (@ (language elisp runtime subrs) makunbound)) -(fset 'fmakunbound (@ (language elisp runtime subrs) fmakunbound)) -(fset 'boundp (@ (language elisp runtime subrs) boundp)) -(fset 'fboundp (@ (language elisp runtime subrs) fboundp)) (fset 'eval (@ (language elisp runtime subrs) eval)) (fset' load (@ (language elisp runtime subrs) load)) @@ -133,6 +128,17 @@ (fset 'eq (@ (guile) eq?)) (fset 'equal (@ (guile) equal?)) +;;; Symbols + +(fset 'symbolp (@ (guile) symbol?)) +(fset 'symbol-value (@ (language elisp runtime) symbol-value)) +(fset 'symbol-function (@ (language elisp runtime) symbol-function)) +(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?)) + ;;; Numerical type predicates (defun floatp (object) diff --git a/module/language/elisp/compile-tree-il.scm b/module/language/elisp/compile-tree-il.scm index 730e63bb5..2c020bb90 100644 --- a/module/language/elisp/compile-tree-il.scm +++ b/module/language/elisp/compile-tree-il.scm @@ -198,8 +198,8 @@ (lambda () (make-application loc - (make-module-ref loc runtime 'set-variable! #t) - (list (make-const loc module) (make-const loc sym) value))) + (make-module-ref loc runtime 'set-symbol-function! #t) ;++ fix + (list (make-const loc sym) value))) (lambda (lexical) (make-lexical-set loc lexical lexical value)) (lambda () (mark-global! (fluid-ref bindings-data) sym module) diff --git a/module/language/elisp/runtime.scm b/module/language/elisp/runtime.scm index 8ffc94656..c3f1ab677 100644 --- a/module/language/elisp/runtime.scm +++ b/module/language/elisp/runtime.scm @@ -25,8 +25,16 @@ function-slot-module elisp-bool ensure-fluid! - reference-variable - set-variable! + symbol-fluid + set-symbol-fluid! + symbol-value + set-symbol-value! + symbol-function + set-symbol-function! + symbol-bound? + symbol-fbound? + makunbound! + fmakunbound! runtime-error macro-error) #:export-syntax (defspecial prim)) @@ -77,31 +85,73 @@ (module-define! resolved sym fluid) (module-export! resolved `(,sym)))))) -(define (reference-variable module sym) - (let ((resolved (resolve-module module))) - (cond - ((equal? module function-slot-module) - (module-ref resolved sym)) - (else - (ensure-fluid! module sym) - (fluid-ref (module-ref 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 (set-variable! module sym value) - (let ((intf (resolve-interface module)) - (resolved (resolve-module module))) - (cond - ((equal? module function-slot-module) - (cond - ((module-defined? intf sym) - (module-set! resolved sym value)) - (else - (module-define! resolved sym value) - (module-export! resolved `(,sym))))) - (else - (ensure-fluid! module sym) - (fluid-set! (module-ref resolved sym) value)))) +(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-value symbol) + (fluid-ref (symbol-fluid symbol))) + +(define (set-symbol-value! symbol value) + (fluid-set! (symbol-fluid symbol) value) value) +(define (symbol-function symbol) + (let ((module (resolve-module function-slot-module))) + (module-ref module symbol))) + +(define (set-symbol-function! symbol value) + (let ((module (resolve-module function-slot-module))) + (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))))) + +(define (symbol-fbound? symbol) + (and + (module-bound? (resolve-interface function-slot-module) symbol) + (let* ((var (module-variable (resolve-module function-slot-module) + symbol))) + (and (variable-bound? var) + (if (fluid? (variable-ref var)) + (fluid-bound? (variable-ref var)) + #t))))) + +(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) + +(define (fmakunbound! symbol) + (if (module-bound? (resolve-interface function-slot-module) symbol) + (let ((var (module-variable + (resolve-module function-slot-module) + symbol))) + (if (and (variable-bound? var) (fluid? (variable-ref var))) + (fluid-unset! (variable-ref var)) + (variable-unset! var)))) + symbol) + ;;; Define a predefined macro for use in the function-slot module. (define (make-id template-id . data) diff --git a/module/language/elisp/runtime/subrs.scm b/module/language/elisp/runtime/subrs.scm index 8d6e42531..7324af484 100644 --- a/module/language/elisp/runtime/subrs.scm +++ b/module/language/elisp/runtime/subrs.scm @@ -22,80 +22,17 @@ (define-module (language elisp runtime subrs) #:use-module (language elisp runtime) #:use-module (system base compile) - #:export (symbol-value - symbol-function - set - fset - makunbound - fmakunbound - boundp - fboundp - apply + #:export (apply eval load)) -;;; Accessing symbol bindings for symbols known only at runtime. - -(define (symbol-value sym) - (reference-variable value-slot-module sym)) - -(define (symbol-function sym) - (reference-variable function-slot-module sym)) - -(define (set sym value) - (set-variable! value-slot-module sym value)) - -(define (fset sym value) - (set-variable! function-slot-module sym value)) - -(define (makunbound sym) - (if (module-bound? (resolve-interface value-slot-module) sym) - (let ((var (module-variable (resolve-module value-slot-module) - sym))) - (if (and (variable-bound? var) (fluid? (variable-ref var))) - (fluid-unset! (variable-ref var)) - (variable-unset! var)))) - sym) - -(define (fmakunbound sym) - (if (module-bound? (resolve-interface function-slot-module) sym) - (let ((var (module-variable - (resolve-module function-slot-module) - sym))) - (if (and (variable-bound? var) (fluid? (variable-ref var))) - (fluid-unset! (variable-ref var)) - (variable-unset! var)))) - sym) - -(define (boundp sym) - (elisp-bool - (and - (module-bound? (resolve-interface value-slot-module) sym) - (let ((var (module-variable (resolve-module value-slot-module) - sym))) - (and (variable-bound? var) - (if (fluid? (variable-ref var)) - (fluid-bound? (variable-ref var)) - #t)))))) - -(define (fboundp sym) - (elisp-bool - (and - (module-bound? (resolve-interface function-slot-module) sym) - (let* ((var (module-variable (resolve-module function-slot-module) - sym))) - (and (variable-bound? var) - (if (fluid? (variable-ref var)) - (fluid-bound? (variable-ref var)) - #t)))))) - ;;; Function calls. These must take care of special cases, like using ;;; symbols or raw lambda-lists as functions! (define (apply func . args) (let ((real-func (cond ((symbol? func) - (reference-variable function-slot-module func)) + (symbol-function func)) ((list? func) (if (and (prim not (null? func)) (eq? (prim car func) 'lambda))