[gambit-list] Re: Doc Request

Marc Feeley feeley at iro.umontreal.ca
Mon Apr 18 00:04:34 EDT 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 ;;




More information about the Gambit-list mailing list