mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-15 18:20:42 +02:00
add formals',
body', and `compile-env' slots to <method>
* ice-9/boot-9.scm (compile-time-environment): Return #f instead of erroring under the interpreter, a bit more sane. * libguile/goops.c (create_standard_classes): * libguile/goops.h (scm_si_formals, scm_si_body, scm_si_compile_env): * oop/goops.scm (method, initialize): Add `formals', `body', and `compile-env' slots to <method>.
This commit is contained in:
parent
ae9ce4b786
commit
21497600d2
4 changed files with 20 additions and 6 deletions
|
@ -126,8 +126,9 @@
|
||||||
(define (compile-time-environment)
|
(define (compile-time-environment)
|
||||||
"A special function known to the compiler that, when compiled, will
|
"A special function known to the compiler that, when compiled, will
|
||||||
return a representation of the lexical environment in place at compile
|
return a representation of the lexical environment in place at compile
|
||||||
time. Useful for supporting some forms of dynamic compilation."
|
time. Useful for supporting some forms of dynamic compilation. Returns
|
||||||
(error "compile-time-environment and the interpreter do not mix"))
|
#f if called from the interpreter."
|
||||||
|
#f)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
|
@ -2420,10 +2420,14 @@ static void
|
||||||
create_standard_classes (void)
|
create_standard_classes (void)
|
||||||
{
|
{
|
||||||
SCM slots;
|
SCM slots;
|
||||||
SCM method_slots = scm_list_4 (scm_from_locale_symbol ("generic-function"),
|
SCM method_slots = scm_list_n (scm_from_locale_symbol ("generic-function"),
|
||||||
scm_from_locale_symbol ("specializers"),
|
scm_from_locale_symbol ("specializers"),
|
||||||
sym_procedure,
|
sym_procedure,
|
||||||
scm_from_locale_symbol ("code-table"));
|
scm_from_locale_symbol ("code-table"),
|
||||||
|
scm_from_locale_symbol ("formals"),
|
||||||
|
scm_from_locale_symbol ("body"),
|
||||||
|
scm_from_locale_symbol ("compile-env"),
|
||||||
|
SCM_UNDEFINED);
|
||||||
SCM amethod_slots = scm_list_1 (scm_list_3 (scm_from_locale_symbol ("slot-definition"),
|
SCM amethod_slots = scm_list_1 (scm_list_3 (scm_from_locale_symbol ("slot-definition"),
|
||||||
k_init_keyword,
|
k_init_keyword,
|
||||||
k_slot_definition));
|
k_slot_definition));
|
||||||
|
|
|
@ -151,9 +151,11 @@ typedef struct scm_t_method {
|
||||||
|
|
||||||
#define scm_si_generic_function 0 /* offset of gf slot in a <method> */
|
#define scm_si_generic_function 0 /* offset of gf slot in a <method> */
|
||||||
#define scm_si_specializers 1 /* offset of spec. slot in a <method> */
|
#define scm_si_specializers 1 /* offset of spec. slot in a <method> */
|
||||||
|
|
||||||
#define scm_si_procedure 2 /* offset of proc. slot in a <method> */
|
#define scm_si_procedure 2 /* offset of proc. slot in a <method> */
|
||||||
#define scm_si_code_table 3 /* offset of code. slot in a <method> */
|
#define scm_si_code_table 3 /* offset of code. slot in a <method> */
|
||||||
|
#define scm_si_formals 4 /* offset of form. slot in a <method> */
|
||||||
|
#define scm_si_body 5 /* offset of body slot in a <method> */
|
||||||
|
#define scm_si_compile_env 6 /* offset of comp. slot in a <method> */
|
||||||
|
|
||||||
/* C interface */
|
/* C interface */
|
||||||
SCM_API SCM scm_class_boolean;
|
SCM_API SCM scm_class_boolean;
|
||||||
|
|
|
@ -484,6 +484,9 @@
|
||||||
ls))))
|
ls))))
|
||||||
`(make <method>
|
`(make <method>
|
||||||
#:specializers (cons* ,@(specializers args))
|
#:specializers (cons* ,@(specializers args))
|
||||||
|
#:formals ',(formals args)
|
||||||
|
#:body ',body
|
||||||
|
#:compile-env (compile-time-environment)
|
||||||
#:procedure (lambda ,(formals args)
|
#:procedure (lambda ,(formals args)
|
||||||
,@(if (null? body)
|
,@(if (null? body)
|
||||||
(list *unspecified*)
|
(list *unspecified*)
|
||||||
|
@ -1427,7 +1430,11 @@
|
||||||
(slot-set! method 'specializers (get-keyword #:specializers initargs '()))
|
(slot-set! method 'specializers (get-keyword #:specializers initargs '()))
|
||||||
(slot-set! method 'procedure
|
(slot-set! method 'procedure
|
||||||
(get-keyword #:procedure initargs dummy-procedure))
|
(get-keyword #:procedure initargs dummy-procedure))
|
||||||
(slot-set! method 'code-table '()))
|
(slot-set! method 'code-table '())
|
||||||
|
(slot-set! method 'formals (get-keyword #:formals initargs '()))
|
||||||
|
(slot-set! method 'body (get-keyword #:body initargs '()))
|
||||||
|
(slot-set! method 'compile-env (get-keyword #:compile-env initargs #f)))
|
||||||
|
|
||||||
|
|
||||||
(define-method (initialize (obj <foreign-object>) initargs))
|
(define-method (initialize (obj <foreign-object>) initargs))
|
||||||
|
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue