;

18 Avr 2005


      I can't answer all your questions right now, but here's some information
on wrapping procedures created by compiled code and interpreted code.
The abstractions are a bit low-level, but can be used to build
your own abstractions.
Marc
; Here are a few internal procedures you will find useful.
;
;   (##interp-procedure? p)  returns true iff the procedure p was  
created by
;                            interpreted code (an interpreted procedure)
;
;   (##interp-procedure-code p)  returns the code pointer of interpreted
;                                procedure p (the code pointer is unique
;                                for each lambda-expression and can be  
used
;                                to identify the lambda-expression)
;
;   (##interp-procedure-rte p)  returns the run time environment of
;                               interpreted procedure p; the runtime
;                               environment contains the value of bound
;                               variables; each binding form contributes
;                               a frame to the environment; each frame
;                               is a vector and the first element points
;                               to the enclosing environment; the other
;                               elements contain bound variable values
;                               (in the order they appear in the
;                               source); for environments created by a
;                               lambda-expression the second element is
;                               a "self" reference (= the closure)
;
;   (##closure? p)  returns true iff the procedure p is a closure (note  
that
;                   an interpreted procedure is also a closure)
;
;   (##closure-code p) returns the code pointer of closure p (the code
;                      pointer is unique for each lambda-expression and
;                      can be used to identify the lambda-expression)
;
;   (##closure-ref p i) returns the value of free variable number i (>=  
1);
;                       mutable free variables are boxed; a flat closure
;                       representation is used; the variables appear in
;                       alphabetical order
;
;   (##closure-length p) returns the number of fields in closure p (=  
the
;                        number of free variables plus 1)
(define (wrap proc info)
   (lambda (arg1 arg2)
(##first-argument info) ; needed so that the compiler keeps "info"
                             ; as a free variable
(proc arg1 arg2)))
(define code-ptr-of-wrapped
   (let ((p (wrap #f #f)))
     (cond ((##interp-procedure? p)
            (##interp-procedure-code p))
           ((##closure? p)
            (##closure-code p))
           (else
            (error "neither interpreted or compiled closure")))))
(define (wrapped? p)
   (cond ((##not (##procedure? p))
          #f)
         ((##interp-procedure? p)
          (eq? (##interp-procedure-code p) code-ptr-of-wrapped))
         ((##closure? p)
          (eq? (##closure-code p) code-ptr-of-wrapped))
         (else
          #f)))
(define (wrapped-info p) ; extracts "info" of wrapped procedure p
   (cond ((##interp-procedure? p)
          (vector-ref (##interp-procedure-rte p) 3)) ; info is at index 3
         ((##closure? p)
          (##closure-ref p 1)) ; info is at index 1
         (else
          (error "neither interpreted or compiled closure"))))
; test it!  works the same compiled and interpreted...
(define f (wrap + "this is the addition procedure"))
(pp (f 10 20))        ; 30
(pp (wrapped? f))     ; #t
(pp (wrapped-info f)) ; "this is the addition procedure"
On 17-Apr-05, at 4:49 PM, Ken Dickey wrote:
...
Greetings,
I have put together a (pre-alpha/prototype) multiple-inheritance,  
multimethod
OO system for Gambit and would like to integrate it closely with  
Gambit's
native types (including foreigns).
The goal is a production quality mi/mm system.
I would appreciate any notes/docs on internals, especially,
 types (##type-type & friends)
 ffi
 namespaces
 compiled procedure representation
Aside from reading the code, I would not like to inadvertantly miss  
assumed
invariants.
In addition, any hints on the proper protocol for making wrappers for  
compiled
code would be helpful.  [I am currently using ##make-interp-procedure  
(see
krufty code below), but this is not very satisfying].
Thanks much,
-KenD
;;===========================
Gambit Version 4.0 beta 12
...
(include "oops.scm")
Oops: loaded SLOT Support Code
Oops: loaded SLOT-ACCESS Generics Code
Oops: loaded INSTANCE code
Oops: loaded CLASS bootstrap code
Oops: loaded CLASS-HIERARCHY bootstrap code
Oops: loaded DEFINE-CLASS code
Oops: loaded METHODS code
Oops: loaded GENERICS code
loaded Oops!
...
(define int-or-string (<type-union> <string> <integer>))
(define-method (m (a int-or-string)) (list 'int-or-string a))
m
...
(m 3)
(int-or-string 3)
...
(m "3")
(int-or-string "3")
...
(define-method (m (s <string>)) (list 'string (next-method)))
#<procedure #3 m>
...
(m 5)
(int-or-string 5)
...
(m "five")
(string (int-or-string "five"))
...
(define-method (m (i <integer>))
      (list 'int i (next-method (number->string i))))

#<procedure #3 m>
...
(m "five")
(string (int-or-string "five"))
...
(m 5)
(int 5 (int-or-string "5"))
...
(define-class <point> () ((x init-value: 0) (y init-value: 0)))
(define p (<point> y: 3))
(x p)
0
...
(y p)
3
...
(x-set! p 5)
#<instance #4 class: #<procedure #5 <point>>>
...
(x p)
5
...
;
======
;;; CALLABLES are procedures with slots (a.k.a. executable data  
structures)
;;;; Here used for Classes, Methods & Generic Functions.
;; A Callable is an extended Closure:
;; @@FIXME: !!! make wrapper work for compiled code !!! @@
;;   slot 0 => <type> ==> <procedure>
;;   slot 1 => $code [NB: Circular self reference]
;;   slot 2 => proc
;;   slot 3 => runtime-environment (or #f)
;;   slot 4 => tag
;;   slot 5 => 1st data slot
;;   slot 6 => 2nd data slot
;;   ...
(define %%clone-proc-plus
  (let ( (%%interp-proc-type%% (##vector-ref (eval '(lambda (x) x))  
0)) )
    (lambda (orig-proc num-slots-to-add)
      (if (not (procedure? orig-proc))
          (error "Can't clone a non-procedure" orig-proc)
          (let ( (proc
                  (if (or (not (##subtyped? orig-proc))
                          (< (##vector-length orig-proc) 4)
                          (not (eq? (##vector-ref orig-proc 0)
                                    %%interp-proc-type%%)))
                      ;;@@FIXME: debug wrapper hack for compiled code  
@@
                      (##make-interp-procedure orig-proc)  ;; @@@!!@@@  
;;
                      orig-proc))
                 )
            (let* ( (orig-length (##vector-length proc))
                    (new-length (+ num-slots-to-add orig-length))
                    (new-thing (##make-vector new-length #f))
                    (max-index (- orig-length 1))
                    )
              (##subtype-set! new-thing (##subtype proc))
              (let loop ( (index 0) )
                (##vector-set! new-thing
                               index
                               (##vector-ref proc index))
                (if (< index max-index)
                    (loop (+ index 1))
                    new-thing)))
) ) ) ) )
;; Returns (values constructor predicate make-ref make-set! bind-slot!)
(define proc->callable
   (let* ( (tag-slot (##vector-length (eval '(lambda (x) x))))
           (first-data-slot-index (+ 1 tag-slot))
         )
     (lambda (tag num-slots)
       (letrec ( (proc->thing
                  (lambda (proc)
                    (let ( (new-proc (%%clone-proc-plus proc
                                                   (+ 1 num-slots))) )
                      (##vector-set! new-proc tag-slot tag)
                      new-proc)))
                 (thing?
                  (lambda (obj)
                    (and (procedure? obj)
                         (> (##vector-length obj)  
first-data-slot-index)
                         (eq? tag (##vector-ref obj tag-slot)))))
                 (make-slot-ref
                  (lambda (name index)
                    (let ( (real-index (+ index  
first-data-slot-index)) )
                      (lambda (obj)
                        (if (and (thing? obj)
                                 (< real-index (##vector-length obj)))
                            (##vector-ref obj real-index)
                            (call-error "Cannot access" 'slot-ref name
obj))))))
                 (make-slot-set!
                  (lambda (name index)
                    (let ( (real-index (+ index  
first-data-slot-index)) )
                      (lambda (obj new-value)
                        (if (and (thing? obj)
                                 (< real-index (##vector-length obj)))
                            (##vector-set! obj real-index new-value)
                            (call-error "Cannot slot-set!" name  
obj))))))
                 (slot-bind!
                  (lambda (obj index value)
                    (let ( (real-index (+ index  
first-data-slot-index)) )
                      (if (and (thing? obj)
                               (< real-index (##vector-length obj))
                               (not (##vector-ref obj real-index))) ;;  
#f is
unbound default
                          (##vector-set! obj real-index value)
                            (call-error "Cannot slot-set!" index  
obj)))))
                 )
         (values proc->thing thing? make-slot-ref make-slot-set!  
slot-bind!)
 ) ) ) )
;
======
;; E O F ;;

Re: Doc Request

;

;