mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-24 20:30:28 +02:00
The GOOPS "unbound" value is a unique pair
* libguile/goops.c (SCM_GOOPS_UNBOUND, SCM_GOOPS_UNBOUNDP): Remove internal macros. (scm_make_unbound, scm_unbound_p): Remove internal functions. (scm_sys_clear_fields_x): Add "unbound" parameter, for the init value. * module/oop/goops.scm (*unbound*): Define in Scheme as a simple heap-allocated value. (unbound?): New definition. (%allocate-instance): Pass *unbound* to %clear-fields!. (make-class, slot-definition-init-value) (slot-definition-init-form, make-closure-variable): Use *unbound* instead of (make-unbound), which is now gone. * module/oop/goops/active-slot.scm (compute-get-n-set): Use *unbound* instead of make-unbound. This module uses the GOOPS internals module; perhaps we should export make-unbound or something... * module/oop/goops/save.scm (make-unbound): Export our own make-unbound definition, for use by residualized save code. * module/language/ecmascript/base.scm (<undefined>, *undefined*): Use a unique object kind and instance for the undefined value. * libguile/vm.c (scm_i_vm_mark_stack): Fill the stack with SCM_UNSPECIFIED instead of SCM_UNBOUND.
This commit is contained in:
parent
2bcb278a30
commit
567a6d1ee7
6 changed files with 25 additions and 44 deletions
|
@ -55,9 +55,6 @@
|
||||||
#define SCM_OUT_PCLASS_INDEX SCM_I_MAX_PORT_TYPE_COUNT
|
#define SCM_OUT_PCLASS_INDEX SCM_I_MAX_PORT_TYPE_COUNT
|
||||||
#define SCM_INOUT_PCLASS_INDEX (2 * SCM_I_MAX_PORT_TYPE_COUNT)
|
#define SCM_INOUT_PCLASS_INDEX (2 * SCM_I_MAX_PORT_TYPE_COUNT)
|
||||||
|
|
||||||
#define SCM_GOOPS_UNBOUND SCM_UNBOUND
|
|
||||||
#define SCM_GOOPS_UNBOUNDP(x) (scm_is_eq (x, SCM_GOOPS_UNBOUND))
|
|
||||||
|
|
||||||
/* Objects have identity, so references to classes and instances are by
|
/* Objects have identity, so references to classes and instances are by
|
||||||
value, not by reference. Redefinition of a class or modification of
|
value, not by reference. Redefinition of a class or modification of
|
||||||
an instance causes in-place update; you can think of GOOPS as
|
an instance causes in-place update; you can think of GOOPS as
|
||||||
|
@ -149,11 +146,9 @@ SCM scm_i_smob_class[SCM_I_MAX_SMOB_TYPE_COUNT];
|
||||||
|
|
||||||
SCM scm_module_goops;
|
SCM scm_module_goops;
|
||||||
|
|
||||||
static SCM scm_make_unbound (void);
|
|
||||||
static SCM scm_unbound_p (SCM obj);
|
|
||||||
static SCM scm_sys_make_vtable_vtable (SCM layout);
|
static SCM scm_sys_make_vtable_vtable (SCM layout);
|
||||||
static SCM scm_sys_init_layout_x (SCM class, SCM layout);
|
static SCM scm_sys_init_layout_x (SCM class, SCM layout);
|
||||||
static SCM scm_sys_clear_fields_x (SCM obj);
|
static SCM scm_sys_clear_fields_x (SCM obj, SCM unbound);
|
||||||
static SCM scm_sys_goops_early_init (void);
|
static SCM scm_sys_goops_early_init (void);
|
||||||
static SCM scm_sys_goops_loaded (void);
|
static SCM scm_sys_goops_loaded (void);
|
||||||
|
|
||||||
|
@ -426,27 +421,6 @@ scm_method_procedure (SCM obj)
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
SCM_DEFINE (scm_make_unbound, "make-unbound", 0, 0, 0,
|
|
||||||
(),
|
|
||||||
"Return the unbound value.")
|
|
||||||
#define FUNC_NAME s_scm_make_unbound
|
|
||||||
{
|
|
||||||
return SCM_GOOPS_UNBOUND;
|
|
||||||
}
|
|
||||||
#undef FUNC_NAME
|
|
||||||
|
|
||||||
SCM_DEFINE (scm_unbound_p, "unbound?", 1, 0, 0,
|
|
||||||
(SCM obj),
|
|
||||||
"Return @code{#t} if @var{obj} is unbound.")
|
|
||||||
#define FUNC_NAME s_scm_unbound_p
|
|
||||||
{
|
|
||||||
return SCM_GOOPS_UNBOUNDP (obj) ? SCM_BOOL_T : SCM_BOOL_F;
|
|
||||||
}
|
|
||||||
#undef FUNC_NAME
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
SCM
|
SCM
|
||||||
|
@ -476,8 +450,8 @@ scm_slot_exists_p (SCM obj, SCM slot_name)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
SCM_DEFINE (scm_sys_clear_fields_x, "%clear-fields!", 1, 0, 0,
|
SCM_DEFINE (scm_sys_clear_fields_x, "%clear-fields!", 2, 0, 0,
|
||||||
(SCM obj),
|
(SCM obj, SCM unbound),
|
||||||
"")
|
"")
|
||||||
#define FUNC_NAME s_scm_sys_clear_fields_x
|
#define FUNC_NAME s_scm_sys_clear_fields_x
|
||||||
{
|
{
|
||||||
|
@ -493,7 +467,7 @@ SCM_DEFINE (scm_sys_clear_fields_x, "%clear-fields!", 1, 0, 0,
|
||||||
/* Set all SCM-holding slots to the GOOPS unbound value. */
|
/* Set all SCM-holding slots to the GOOPS unbound value. */
|
||||||
for (i = 0; i < n; i++)
|
for (i = 0; i < n; i++)
|
||||||
if (scm_i_symbol_ref (layout, i*2) == 'p')
|
if (scm_i_symbol_ref (layout, i*2) == 'p')
|
||||||
SCM_STRUCT_SLOT_SET (obj, i, SCM_GOOPS_UNBOUND);
|
SCM_STRUCT_SLOT_SET (obj, i, unbound);
|
||||||
|
|
||||||
return SCM_UNSPECIFIED;
|
return SCM_UNSPECIFIED;
|
||||||
}
|
}
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
|
/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 2014, 2015 Free Software Foundation, Inc.
|
||||||
*
|
*
|
||||||
* This library is free software; you can redistribute it and/or
|
* This library is free software; you can redistribute it and/or
|
||||||
* modify it under the terms of the GNU Lesser General Public License
|
* modify it under the terms of the GNU Lesser General Public License
|
||||||
|
@ -990,7 +990,7 @@ scm_i_vm_mark_stack (struct scm_vm *vp, struct GC_ms_entry *mark_stack_ptr,
|
||||||
{
|
{
|
||||||
/* This value may become dead as a result of GC,
|
/* This value may become dead as a result of GC,
|
||||||
so we can't just leave it on the stack. */
|
so we can't just leave it on the stack. */
|
||||||
*sp = SCM_UNBOUND;
|
*sp = SCM_UNSPECIFIED;
|
||||||
continue;
|
continue;
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
;;; ECMAScript for Guile
|
;;; ECMAScript for Guile
|
||||||
|
|
||||||
;; Copyright (C) 2009, 2013 Free Software Foundation, Inc.
|
;; Copyright (C) 2009, 2013, 2015 Free Software Foundation, Inc.
|
||||||
|
|
||||||
;;;; This library is free software; you can redistribute it and/or
|
;;;; This library is free software; you can redistribute it and/or
|
||||||
;;;; modify it under the terms of the GNU Lesser General Public
|
;;;; modify it under the terms of the GNU Lesser General Public
|
||||||
|
@ -35,7 +35,9 @@
|
||||||
|
|
||||||
new-object new))
|
new-object new))
|
||||||
|
|
||||||
(define *undefined* ((@@ (oop goops) make-unbound)))
|
(define-class <undefined> ())
|
||||||
|
|
||||||
|
(define *undefined* (make <undefined>))
|
||||||
(define *this* (make-fluid))
|
(define *this* (make-fluid))
|
||||||
|
|
||||||
(define-class <js-object> ()
|
(define-class <js-object> ()
|
||||||
|
|
|
@ -769,9 +769,14 @@ followed by its associated value. If @var{l} does not hold a value for
|
||||||
(scm-error 'wrong-type-arg #f "Not a keyword: ~S" (list kw) #f))
|
(scm-error 'wrong-type-arg #f "Not a keyword: ~S" (list kw) #f))
|
||||||
(if (eq? kw key) arg (lp l))))))
|
(if (eq? kw key) arg (lp l))))))
|
||||||
|
|
||||||
|
(define *unbound* (list 'unbound))
|
||||||
|
|
||||||
|
(define-inlinable (unbound? x)
|
||||||
|
(eq? x *unbound*))
|
||||||
|
|
||||||
(define (%allocate-instance class)
|
(define (%allocate-instance class)
|
||||||
(let ((obj (allocate-struct class (struct-ref class class-index-nfields))))
|
(let ((obj (allocate-struct class (struct-ref class class-index-nfields))))
|
||||||
(%clear-fields! obj)
|
(%clear-fields! obj *unbound*)
|
||||||
obj))
|
obj))
|
||||||
|
|
||||||
(define (make class . args)
|
(define (make class . args)
|
||||||
|
@ -1302,7 +1307,7 @@ followed by its associated value. If @var{l} does not hold a value for
|
||||||
head
|
head
|
||||||
(find-duplicate tail)))))
|
(find-duplicate tail)))))
|
||||||
|
|
||||||
(let* ((name (get-keyword #:name options (make-unbound)))
|
(let* ((name (get-keyword #:name options *unbound*))
|
||||||
(supers (if (not (or-map (lambda (class)
|
(supers (if (not (or-map (lambda (class)
|
||||||
(memq <object>
|
(memq <object>
|
||||||
(class-precedence-list class)))
|
(class-precedence-list class)))
|
||||||
|
@ -1947,10 +1952,10 @@ followed by its associated value. If @var{l} does not hold a value for
|
||||||
|
|
||||||
(define (slot-definition-init-value s)
|
(define (slot-definition-init-value s)
|
||||||
;; can be #f, so we can't use #f as non-value
|
;; can be #f, so we can't use #f as non-value
|
||||||
(get-keyword #:init-value (cdr s) (make-unbound)))
|
(get-keyword #:init-value (cdr s) *unbound*))
|
||||||
|
|
||||||
(define (slot-definition-init-form s)
|
(define (slot-definition-init-form s)
|
||||||
(get-keyword #:init-form (cdr s) (make-unbound)))
|
(get-keyword #:init-form (cdr s) *unbound*))
|
||||||
|
|
||||||
(define (slot-definition-init-thunk s)
|
(define (slot-definition-init-thunk s)
|
||||||
(get-keyword #:init-thunk (cdr s) #f))
|
(get-keyword #:init-thunk (cdr s) #f))
|
||||||
|
@ -2561,8 +2566,6 @@ followed by its associated value. If @var{l} does not hold a value for
|
||||||
;;; {Initialize}
|
;;; {Initialize}
|
||||||
;;;
|
;;;
|
||||||
|
|
||||||
(define *unbound* (make-unbound))
|
|
||||||
|
|
||||||
;; FIXME: This could be much more efficient.
|
;; FIXME: This could be much more efficient.
|
||||||
(define (%initialize-object obj initargs)
|
(define (%initialize-object obj initargs)
|
||||||
"Initialize the object @var{obj} with the given arguments
|
"Initialize the object @var{obj} with the given arguments
|
||||||
|
|
|
@ -38,7 +38,7 @@
|
||||||
(after-ref (get-keyword #:after-slot-ref s #f))
|
(after-ref (get-keyword #:after-slot-ref s #f))
|
||||||
(before-set! (get-keyword #:before-slot-set! s #f))
|
(before-set! (get-keyword #:before-slot-set! s #f))
|
||||||
(after-set! (get-keyword #:after-slot-set! s #f))
|
(after-set! (get-keyword #:after-slot-set! s #f))
|
||||||
(unbound (make-unbound)))
|
(unbound *unbound*))
|
||||||
(slot-set! class 'nfields (+ index 1))
|
(slot-set! class 'nfields (+ index 1))
|
||||||
(list (lambda (o)
|
(list (lambda (o)
|
||||||
(if before-ref
|
(if before-ref
|
||||||
|
@ -46,7 +46,7 @@
|
||||||
(let ((res (struct-ref o index)))
|
(let ((res (struct-ref o index)))
|
||||||
(and after-ref (not (eqv? res unbound)) (after-ref o))
|
(and after-ref (not (eqv? res unbound)) (after-ref o))
|
||||||
res)
|
res)
|
||||||
(make-unbound))
|
*unbound*)
|
||||||
(let ((res (struct-ref o index)))
|
(let ((res (struct-ref o index)))
|
||||||
(and after-ref (not (eqv? res unbound)) (after-ref o))
|
(and after-ref (not (eqv? res unbound)) (after-ref o))
|
||||||
res)))
|
res)))
|
||||||
|
|
|
@ -20,12 +20,14 @@
|
||||||
|
|
||||||
(define-module (oop goops save)
|
(define-module (oop goops save)
|
||||||
:use-module (oop goops internal)
|
:use-module (oop goops internal)
|
||||||
:re-export (make-unbound)
|
:export (make-unbound save-objects load-objects restore
|
||||||
:export (save-objects load-objects restore
|
|
||||||
enumerate! enumerate-component!
|
enumerate! enumerate-component!
|
||||||
write-readably write-component write-component-procedure
|
write-readably write-component write-component-procedure
|
||||||
literal? readable make-readable))
|
literal? readable make-readable))
|
||||||
|
|
||||||
|
(define (make-unbound)
|
||||||
|
*unbound*)
|
||||||
|
|
||||||
;;;
|
;;;
|
||||||
;;; save-objects ALIST PORT [EXCLUDED] [USES]
|
;;; save-objects ALIST PORT [EXCLUDED] [USES]
|
||||||
;;;
|
;;;
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue