[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