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 ;;