Re: Making every goops object applicable

[Ludovic Courtès]

Hi,

Krister Svanlund <address@hidden> skribis:

> Apparently this works by some flag being set by <applicable-strukt> in
> libguile for the object and that flag is checked during application,
> calling the 'procedure slot if it's set with some optimization assuming
> that 'procedure is the first slot.

There’s also a vtable flag that determines whether a struct is
applicable:

  #define SCM_STRUCT_APPLICABLE_P(X)    (SCM_STRUCT_VTABLE_FLAG_IS_SET ((X), 
SCM_VTABLE_FLAG_APPLICABLE))

And indeed, the struct’s procedure is the first slot:

  #define scm_applicable_struct_index_procedure 0 /* The procedure of an 
applicable
                                                     struct. Only valid if the
                                                     struct's vtable has the
                                                     applicable flag set. */

For instance, every struct whose vtable is <applicable-struct-vtable>
(defined in struct.c) is applicable.

Then you can investigate by looking at the indices defined in struct.h:

  scheme@(guile-user)> (struct-vtable? <class>)
  $2 = #t
  scheme@(guile-user)> (struct-ref <class> 1) ; scm_vtable_index_flags
  $3 = 12291
  scheme@(guile-user)> (logand $3 4)          ; 
SCM_VTABLE_FLAG_APPLICABLE_VTABLE
  $4 = 0                                      ; → not applicable

  scheme@(guile-user)> (logand (struct-ref <applicable-struct-vtable> 1) 4)
  $7 = 4                                      ; → applicable

So you could fiddle with the flags of a class to make its instances
applicable:

  scheme@(guile-user)> (define (applicable-struct? s)
                         (logand 4 (struct-ref (struct-vtable (struct-vtable 
s)) 1)))
  scheme@(guile-user)> (applicable-struct? current-input-port)
  $27 = 4
  scheme@(guile-user)> (define (applicable-struct-procedure s) (struct-ref s 0))

  scheme@(guile-user)> (define-class <appclass> (<class>) (foo))
  scheme@(guile-user)> (struct-set! <appclass> 1 (logior (struct-ref <appclass> 
1) 4))
  $32 = 12295
  scheme@(guile-user)> (define-class <foo> ()
                         (bar #:init-value (lambda args (pk 'apply args)))
                         #:metaclass <appclass>)
  $33 = #<<appclass> <foo> 16e0d20>
  scheme@(guile-user)> (define f (make <foo>))
  scheme@(guile-user)> (applicable-struct? f)
  $34 = 4
  scheme@(guile-user)> (applicable-struct-procedure f)
  $35 = #<procedure 1863060 at <current input>:51:0 args>
  scheme@(guile-user)> (f 1 2 3)

  ;;; (apply (1 2 3))
  $36 = (1 2 3)

But there should certainly be a higher-level facility.  :-)

Thanks,
Ludo’.