Using ftype-ref and ftype-set! in macros.

Albert Qaeda

unread,

Apr 9, 2021, 10:10:06 PM4/9/21

to chez-scheme

I'm having trouble using ftype-ref and ftype-set! inside a macro.

I'm trying to make a macro that defines a foreign struct and a constructor for it that allocs a new one and has some accessors and setters.

(trace-define-syntax (foreign-struct x)
(define (lower-case s)
    (string->symbol (string-downcase (symbol->string (syntax->datum s)))))
(syntax-case x ()
    ((_ name (var1 type1) (var2 type2) ...)
     #`(begin (define-ftype name (struct (var1 type1) (var2 type2) ...))
                     (define #,(datum->syntax #'name (lower-case #'name))
       (lambda (var1 var2 ...)
                            (let ((ptr (make-ftype-pointer name (foreign-alloc (ftype-sizeof name)))))
                  (case-lambda
            ((var) (ftype-ref name (var) ptr))    ;; error here
            ((var val) (ftype-set! name (var) ptr val))
            (() ptr)))))))))

The idea is that something like:

(foreign-struct Vector2 (x int) (y int))

would expand into:

(begin
   (define-ftype Vector2 (struct [x int] [y int]))
   (define vector2
     (lambda (x y)
       (let ([ptr (make-ftype-pointer
                    Vector2
                    (foreign-alloc (ftype-sizeof Vector2)))])
         (case-lambda
           [(var) (ftype-ref Vector2 (var) ptr)]
           [(var val) (ftype-set! Vector2 (var) ptr val)]
           [() ptr])))))

But there's the error when it gets to the ftype-ref and ftype-set! lines. I've tried variations. At one point I think I was cons things together at runtime, but hopefully someone here has a more elegant solution.

Andy Keep

unread,

Apr 9, 2021, 11:01:37 PM4/9/21

to chez-scheme

Yeah, this will not work because ftype-ref and ftype-set! are themselves macros that require the field name identifier, integer offset, or deference marks that determine the expansion to be provided at compile time. In your example, these fields are x and y, and attempting to access them the field with the run-time specified value of var breaks the expansion of the ftype-ref and ftype-set!.

You can still accomplish what you are looking for by doing run-time dispatch based on the var. I'm assuming here that var is passed as a symbol, in which case your expanded case-lambda could be:

(case-lambda

[(var) (case var

[(x) (ftype-ref Vector2 (x) ptr)]

[(y) (ftype-ref Vector2 (y) ptr)]

[else (errorf 'Vector2 "unrecognized var ~s" var)])]

[(var val) (case var

[(x) (ftype-set! Vector2 (x) ptr val)]

[(y) (ftype-set! Vector2 (y) ptr val)]

[else (errorf 'Vector2 "unrecognized var ~s" var)])]

[() ptr])

Also, don't forget to set the values of x and y in your constructor after you allocate the space (and also note that your foreign-alloc allocated space is not garbage collected... it is foreign so it is up to you to free it when you don't need it anymore.)

Albert Qaeda

unread,

Apr 10, 2021, 12:19:31 AM4/10/21

to chez-scheme

Thanks for the fast response Andy. Chez Scheme is great.

Yes, I forgot about initializing the fields. I need to add that.

Let me figure out how to put that in a macro and I'll re-post when I get it right.

Thanks again.

Albert Qaeda

unread,

Apr 10, 2021, 5:38:18 PM4/10/21

to chez-scheme

This monstrosity, believe it or not, almost does what I want, except for the section between lambda and case lambda. The structure of the list is not right. So there is definitely something I'm missing, some recursion or piece of knowledge about macros. I think I should be using 'with-syntax' or something. Any pointers in the right direction would be appreciated.

(trace-define-syntax (foreign-struct x)

(syntax-case x ()
    ((_ name (var1 type1) (var2 type2) ...)
     #`(begin
         (define-ftype name (struct (var1 type1) (var2 type2) ...))

(define #,(datum->syntax #'name (scheme-name (syntax->datum #'name)))

(lambda (var1 var2 ...)
(let ((ptr (make-ftype-pointer name (foreign-alloc (ftype-sizeof name)))))

               #,(let lp ((v1 #'var1) (v2 #'(var2 ...)))
                   (if (null? v2)
                       #`(ftype-set! name (#,v1) ptr val)
                       (cons #`(ftype-set! name (#,v1) ptr val)
                             (lp (car v2) (cdr v2)))))
               (case-lambda
                ((var)
                 #,(append
                    (cons* #'case #'var
                           (let lp ((v1 #'var1) (v2 #'(var2 ...)))
                             (if (null? v2)
                                 (cons (append #`(#,v1)
                                               #`((ftype-ref name (#,v1) ptr))) '())
                                 (cons (append #`(#,v1)
                                               #`((ftype-ref name (#,v1) ptr)))
                                       (lp (car v2) (cdr v2))))))
                    #`((else (error 'name "bad arg" 'val)))))
                ((var val)
                 #,(append
                    (cons* #'case #'var
                           (let lp ((v1 #'var1) (v2 #'(var2 ...)))
                             (if (null? v2)
                                 (cons (append #`(#,v1)
                                               #`((ftype-set! name (#,v1) ptr val))) '())
                                 (cons (append #`(#,v1)
                                               #`((ftype-set! name (#,v1) ptr val)))
                                       (lp (car v2) (cdr v2))))))
                    #`((else (error 'name "bad arg" 'val)))))
                (() ptr)))))))))

Jamie Taylor

unread,

Apr 10, 2021, 6:29:23 PM4/10/21

to Albert Qaeda, chez-scheme

You want the lp loop to produce multiple expressions, not just one, so you need to use the unsyntax-splicing #,@ instead. Also, the base case of the recursion needs to return a list of expressions.

(let ((ptr (make-ftype-pointer name (foreign-alloc (ftype-sizeof name)))))

#,@(let lp ((v1 #'var1) (v2 #'(var2 ...)))

(if (null? v2)

#`((ftype-set! name (#,v1) ptr val))

(cons #`(ftype-set! name (#,v1) ptr val)

(lp (car v2) (cdr v2)))))

(case-lambda

[etc]))

The code that produces is probably not what you want, since it sets all of the fields to "val" (which is not bound here).

There's also a much simpler way to do this: just let the expander do the pattern expansion for you. Here's that version, also corrected to not use an unbound "val".

(let ((ptr (make-ftype-pointer name (foreign-alloc (ftype-sizeof name)))))

(ftype-set! name (var1) ptr var1)

(ftype-set! name (var2) ptr var2)

...

(case-lambda

[etc]))

You should be able to use this technique for your case bodies as well.

(In case you are wondering why it's ok to have "var1" twice in the line like that, the first one is a name (i.e., an identifier) used by the ftype-set! syntax, while the second is an expression passed through during the expansion of ftype-set! and then resolved to the formal parameter of the lambda. It's probably a bit confusing, so if it bothers you then the typical alternative is to use generate-temporaries to make the names for the formal args.)

--
You received this message because you are subscribed to the Google Groups "chez-scheme" group.
To unsubscribe from this group and stop receiving emails from it, send an email to chez-scheme...@googlegroups.com.
To view this discussion on the web visit https://groups.google.com/d/msgid/chez-scheme/a547d8df-08e8-46f3-9973-60b13b39a78dn%40googlegroups.com.

Albert Qaeda

unread,

Apr 10, 2021, 7:25:09 PM4/10/21

to chez-scheme

Wow. Thanks so much. For some reason I didn't think you could use ... alone like that. I guess the pattern matcher is much more powerful than I gave it credit for. The scheme-name function schemeifies c-like names. It's kind of ugly, but it seems to work. The only downside is that if it outputs the same string, the constructor definition will re-define the struct definition. Anyway here is the completed code. Thanks Andy and Jamie.

(define (scheme-name sym)
(let ((str (symbol->string sym)) (in-word? #f))
    (string->symbol
     (with-output-to-string
      (lambda ()
   (write-char (char-downcase (string-ref str 0)))
   (string-for-each
   (lambda (c)
       (cond ((char-upper-case? c)
        (cond (in-word?
            (write-char (char-downcase c)))
            (else
            (write-char #\-)
            (write-char (char-downcase c))))
        (set! in-word? #t))
        ((char-numeric? c)
        (write-char #\-)
        (write-char c)
        (set! in-word? #t))
        (else
        (write-char c)
        (set! in-word? #f))))
   (substring str 1 (string-length str))))))))

(define-syntax (foreign-struct x)

(syntax-case x ()
    ((_ name (var1 type1) (var2 type2) ...)
     #`(begin (define-ftype name (struct (var1 type1) (var2 type2) ...))
              (define #,(datum->syntax #'name (scheme-name (syntax->datum #'name)))
                (lambda (var1 var2 ...)
                  (let ((ptr (make-ftype-pointer name (foreign-alloc (ftype-sizeof name)))))

                    (ftype-set! name (var1) ptr var1)
                    (ftype-set! name (var2) ptr var2)
                    ...
                    (case-lambda

                     ((var)
                      (case var
                        ((var1) (ftype-ref name (var1) ptr))
                        ((var2) (ftype-ref name (var2) ptr))
                        ...
                        (else (error 'name "bad var" var))))
                     ((var val)
                      (case var
                        ((var1) (ftype-set! name (var1) ptr val))
                        ((var2) (ftype-set! name (var2) ptr val))
                        ...
                        (else (error 'name "bad var" var))))
                     (() ptr)))))))))

Example usage.

> (foreign-struct Vector4 (x int) (y int) (z int) (w int))

> (define v (vector-4 111 222 333 444))

> (v 'x)

111

> (define vv (vector-4 1 2 3 4))

> (vv 'x)

1

> (vv 'z)

3

> (v 'x 123)

> (v 'x)

123

> (vv 'x)

1

> (vv)

#<ftype-pointer Vector4 94365151272768>

> (v)

#<ftype-pointer Vector4 94365151272736>

Reply all

Reply to author

Forward