[gambit-list] macro tricks

Marc Feeley feeley at iro.umontreal.ca
Thu Aug 13 08:56:54 EDT 2009


On 13-Aug-09, at 7:22 AM, lowly coder wrote:

> it looks like the stuff in lib/_eval.scm , especially with ##eval and
> the ##*cte* stuff seems like it might work; but I can't quite get it;
> anyone have experience?
>
> On Thu, Aug 13, 2009 at 4:09 AM, lowly
> coder<lowlycoder at huoyanjinjing.com> wrote:
>> (define-macro (foo)
>>  (define x 20)
>>  (define (magic-func var-name)
>>    ...)
>>
>>  (pp (magic-func 'x)))
>>
>> (foo)
>>
>>
>> Is there anyway I can define magic-func so that 20 is outputted?
>


With the code attached below, do:

(define (magic-func var-name)
   (env-ref (the-env) var-name))

Marc



(include "~~lib/_gambit#.scm")

(define (the-env) ;; get the environment at the call site
   (##continuation-capture
    (lambda (cont)
      (if (##interp-continuation? cont)
          (let (($code (##interp-continuation-code cont))
                (rte (##interp-continuation-rte cont)))
            (cons (macro-code-cte $code) rte))
          (error "the-env must be called from interpreted code")))))

(define (env-ref env var) ;; fetch variable from an environment
   (let loop1 ((c (car env))
               (r (cdr env)))
     (cond ((##cte-top? c)
            (##global-var-ref (##make-global-var var)))
           ((##cte-frame? c)
            (let loop2 ((vars (##cte-frame-vars c))
                        (i 1))
              (if (pair? vars)
                  (if (eq? var (##car vars))
                      (vector-ref r i)
                      (loop2 (cdr vars)
                             (+ i 1)))
                  (loop1 (##cte-parent-cte c)
                         (macro-rte-up r)))))
           (else
            (loop1 (##cte-parent-cte c)
                   r)))))

(define (env-set! env var val) ;; modify variable in an environment
   (let loop1 ((c (car env))
               (r (cdr env)))
     (cond ((##cte-top? c)
            (##global-var-set! (##make-global-var var) val))
           ((##cte-frame? c)
            (let loop2 ((vars (##cte-frame-vars c))
                        (i 1))
              (if (pair? vars)
                  (if (eq? var (##car vars))
                      (vector-set! r i val)
                      (loop2 (cdr vars)
                             (+ i 1)))
                  (loop1 (##cte-parent-cte c)
                         (macro-rte-up r)))))
           (else
            (loop1 (##cte-parent-cte c)
                   r)))))

;; test:

(define (f var)
   (let ((x 11))

     (define (g y) (* y y))

     (pp (env-ref (the-env) 'g))

     (pp (env-ref (the-env) var))
     (env-set! (the-env) var 22)
     (pp (env-ref (the-env) var))

     (pp (g x))))

(f 'x)




More information about the Gambit-list mailing list