(generate-ensure-global loc sym mod)))
,body)))
-;;; See if we should do a void-check for a given variable. That means,
-;;; check that this check is not disabled via the compiler options for
-;;; this symbol. Disabling of void check is only done for the value-slot
-;;; module!
-
-(define (want-void-check? sym module)
- (let ((disabled (fluid-ref disable-void-check)))
- (or (not (equal? module value-slot))
- (and (not (eq? disabled 'all))
- (not (memq sym disabled))))))
-
;;; Build a construct that establishes dynamic bindings for certain
;;; variables. We may want to choose between binding with fluids and
;;; with-fluids* and using just ordinary module symbols and
'fluid-ref
(make-module-ref loc module sym #t)))))
-;;; Reference a variable and error if the value is void.
-
-(define (reference-with-check loc sym module)
- (if (want-void-check? sym module)
- (let ((var (gensym)))
- (make-let
- loc
- '(value)
- `(,var)
- `(,(reference-variable loc sym module))
- (make-conditional
- loc
- (call-primitive loc
- 'eq?
- (make-module-ref loc runtime 'void #t)
- (make-lexical-ref loc 'value var))
- (runtime-error loc "variable is void:" (make-const loc sym))
- (make-lexical-ref loc 'value var))))
- (reference-variable loc sym module)))
-
;;; Generate code to set a variable. Just as with reference-variable, in
;;; case of a reference to value-slot, we want to generate a lexical set
;;; when the variable has a lexical binding.
(if (handle-var-def loc sym doc)
(make-sequence
loc
- (list (make-conditional
- loc
- (call-primitive loc
- 'eq?
- (make-module-ref loc runtime 'void #t)
- (reference-variable loc sym value-slot))
- (set-variable! loc sym value-slot (compile-expr value))
- (make-void loc))
- (make-const loc sym)))))))
+ (list
+ (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 value-slot (compile-expr value)))
+ (make-const loc sym)))))))
(defspecial setq (loc args)
(define (car* x) (if (null? x) '() (car x)))
((,bindings . ,body)
(generate-let* loc function-slot bindings body))))
-;;; Temporarily disable void checks or set symbols as always lexical
-;;; only for the lexical scope of a construct.
-
-(defspecial without-void-checks (loc args)
- (pmatch args
- ((,syms . ,body)
- (with-added-symbols loc disable-void-check syms body))))
+;;; Temporarily set symbols as always lexical only for the lexical scope
+;;; of a construct.
(defspecial with-always-lexical (loc args)
(pmatch args
(((lambda ,args . ,body))
(compile-lambda loc args body))
((,sym) (guard (symbol? sym))
- (reference-with-check loc sym function-slot))))
+ (reference-variable loc sym function-slot))))
(defspecial defmacro (loc args)
(pmatch args
(else
(make-application loc
(if (symbol? operator)
- (reference-with-check loc
- operator
- function-slot)
+ (reference-variable loc
+ operator
+ function-slot)
(compile-expr operator))
(map compile-expr arguments))))))
(case sym
((nil) (nil-value loc))
((t) (t-value loc))
- (else (reference-with-check loc sym value-slot))))
+ (else (reference-variable loc sym value-slot))))
;;; Compile a single expression to TreeIL.
(case key
((#:warnings) ; ignore
#f)
- ((#:disable-void-check)
- (if (valid-symbol-list-arg? value)
- (fluid-set! disable-void-check value)
- (report-error #f
- "Invalid value for #:disable-void-check"
- value)))
((#:always-lexical)
(if (valid-symbol-list-arg? value)
(fluid-set! always-lexical value)
;;; Code:
(define-module (language elisp runtime)
- #:export (void
- nil-value
+ #:export (nil-value
t-value
value-slot-module
function-slot-module
elisp-bool
ensure-fluid!
reference-variable
- reference-variable-with-check
set-variable!
runtime-error
macro-error)
;;; This module provides runtime support for the Elisp front-end.
-;;; The reserved value to mean (when eq?) void.
-
-(define void (list 42))
-
;;; Values for t and nil. (FIXME remove this abstraction)
(define nil-value #nil)
(let ((intf (resolve-interface module))
(resolved (resolve-module module)))
(if (not (module-defined? intf sym))
- (let ((fluid (make-fluid)))
- (fluid-set! fluid void)
+ (let ((fluid (make-undefined-fluid)))
(module-define! resolved sym fluid)
(module-export! resolved `(,sym))))))
(let ((resolved (resolve-module module)))
(fluid-ref (module-ref resolved sym))))
-(define (reference-variable-with-check module sym)
- (let ((value (reference-variable module sym)))
- (if (eq? value void)
- (runtime-error "variable is void:" sym)
- value)))
-
(define (set-variable! module sym value)
(ensure-fluid! module sym)
(let ((resolved (resolve-module module)))
(compile-let* . let*)
(compile-lexical-let* . lexical-let*)
(compile-flet* . flet*)
- (compile-without-void-checks . without-void-checks)
(compile-with-always-lexical . with-always-lexical)
(compile-guile-ref . guile-ref)
(compile-guile-primitive . guile-primitive)
let*
lexical-let*
flet*
- without-void-checks
with-always-lexical
guile-ref
guile-primitive
(built-in-macro prog1
(lambda (form1 . rest)
(let ((temp (gensym)))
- `(without-void-checks (,temp)
- (lexical-let ((,temp ,form1))
- ,@rest
- ,temp)))))
+ `(lexical-let ((,temp ,form1))
+ ,@rest
+ ,temp))))
(built-in-macro prog2
(lambda (form1 form2 . rest)
(macro-error "invalid clause in cond" cur))
((null? (cdr cur))
(let ((var (gensym)))
- `(without-void-checks (,var)
- (lexical-let ((,var ,(car cur)))
- (if ,var
- ,var
- ,rest)))))
+ `(lexical-let ((,var ,(car cur)))
+ (if ,var
+ ,var
+ ,rest))))
(else
`(if ,(car cur)
(progn ,@(cdr cur))
(if (null? tail)
x
(let ((var (gensym)))
- `(without-void-checks
- (,var)
- (lexical-let ((,var ,x))
- (if ,var
- ,var
- ,(iterate (car tail) (cdr tail)))))))))))
+ `(lexical-let ((,var ,x))
+ (if ,var
+ ,var
+ ,(iterate (car tail) (cdr tail))))))))))
;;; Define the dotimes and dolist iteration macros.
(if (not (symbol? var))
(macro-error "expected symbol as dolist variable")
`(let (,var)
- (without-void-checks (,tailvar)
- (lexical-let ((,tailvar ,iter-list))
- (while ((guile-primitive not)
- ((guile-primitive null?) ,tailvar))
- (setq ,var ((guile-primitive car) ,tailvar))
- ,@body
- (setq ,tailvar ((guile-primitive cdr) ,tailvar)))
- ,@(if (= (length args) 3)
- (list (caddr args))
- '())))))))))
+ (lexical-let ((,tailvar ,iter-list))
+ (while ((guile-primitive not)
+ ((guile-primitive null?) ,tailvar))
+ (setq ,var ((guile-primitive car) ,tailvar))
+ ,@body
+ (setq ,tailvar ((guile-primitive cdr) ,tailvar)))
+ ,@(if (= (length args) 3)
+ (list (caddr args))
+ '()))))))))
;;; Exception handling. unwind-protect and catch are implemented as
;;; macros (throw is a built-in function).
(built-in-func symbol-value
(lambda (sym)
- (reference-variable-with-check value-slot-module sym)))
+ (reference-variable value-slot-module sym)))
(built-in-func symbol-function
(lambda (sym)
- (reference-variable-with-check function-slot-module sym)))
+ (reference-variable function-slot-module sym)))
(built-in-func set
(lambda (sym value)
(built-in-func makunbound
(lambda (sym)
- (set-variable! value-slot-module sym void)
+ (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))
(built-in-func fmakunbound
(lambda (sym)
- (set-variable! function-slot-module sym void)
+ (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))
(built-in-func boundp
(lambda (sym)
- (elisp-bool (prim not
- (eq? void
- (reference-variable value-slot-module
- 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)))))))
(built-in-func fboundp
(lambda (sym)
- (elisp-bool (prim not
- (eq? void
- (reference-variable function-slot-module
- 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!
(lambda (func . args)
(let ((real-func (cond
((symbol? func)
- (reference-variable-with-check
- function-slot-module
- func))
+ (reference-variable function-slot-module func))
((list? func)
(if (and (prim not (null? func))
(eq? (prim car func) 'lambda))
(progn (setq a 1 b 2)
(and (eq (makunbound 'b) 'b)
(boundp 'a)
- (not (boundp 'b)))))
-
- (pass-if "disabled void check (all)"
- (progn (makunbound 'a) a t)
- #:opts '(#:disable-void-check all))
- (pass-if "disabled void check (symbol list)"
- (progn (makunbound 'a) a t)
- #:opts '(#:disable-void-check (x y a b)))
- (pass-if "without-void-checks"
- (progn (makunbound 'a)
- (= (without-void-checks (a) a 5) 5))))
+ (not (boundp 'b))))))
(with-test-prefix/compile "Let and Let*"
HCoop / bpt / guile.git / commitdiff