LINUX.ORG.RU

Помогите сделать макрос красивым

 , ,


1

1

Сделал, чтобы Racket мог создавать функции на основании их описания из GObjectIntrospection. Сейчас смотрю на то, что получилсоь и понимаю, что «настоящий программист может написать программу на ФортранеКоммон Лиспе на любом языке».

Задача стоит так: есть описание функции в виде описаний входящих и исходящих параметров (исходящие — значит по ссылке). _fun использовать нельзя, так как массив передаётся в FFI (и если исходящий, то собирается из) двух параметров: указатель + длина.

Прошу совета как сделать правильно. Сейчас build-function строит исходный текст подстановки макроса (в стиле defmacro), а затем build-ffi подтсавляет его в datum->syntax.

Если пытаться делать без datum->syntax, то вылазят две проблемы: что делать с локальными define'ами и как генерировать имена переменных. С другой стороны, надеюсь решить проблему с именаим параметров: у меня сейчас !arg — входящий параметр, %arg — он же, преобразованный в Си, &arg — указатель на него.

(define-syntax (define-gi-definer stx)
  (syntax-case stx ()
    [(_ id) #'(define-gi-definer id id)]
    [(_ id repository)
     (with-syntax ([string-rep (->string (syntax-e #'repository))])
       (repository-require (syntax-e #'string-rep))
       #'(define-syntax (id stx)
           (syntax-case stx ()
             [(_ object) 
              (with-syntax ([string-obj (->string (syntax-e #'object))])
                (hash-ref! instance-hash (cons string-rep (syntax-e #'string-obj)) 
                           (λ () (syntax-local-lift-expression 
                                  (build-ffi stx (syntax-e #'string-rep) (syntax-e #'string-obj))))))])))]))

(define-for-syntax (build-ffi stx rep obj)
  (define res (find-gi rep obj))
  (datum->syntax stx res))

(define (find-gi repository name)
  (define info (rep:find repository name))
  (unless info
    (raise-argument-error 'find-gi "name of object in repository" name))
  (define type (g-base-info-get-type info))
  (case type
    [(constant) (const-value info)]
    [(function) (build-function info)]))

(define (build-function info)
  (define %args (args info))
  (define (in-arg? arg) (memq (g-arg-info-get-direction arg) '(in inout)))
  (define (out-arg? arg) (memq (g-arg-info-get-direction arg) '(out inout)))
  (define (array-pos arg)
    (define type (g-arg-info-get-type arg))
    (if (eq? (g-type-info-get-tag type) 'array)
        (g-type-info-get-array-length type)
        -1))
  (define res-type-symbol (tag->symbol_type
                           (g-type-info-get-tag (g-callable-info-get-return-type info))))
  (define fun-type (append (list '_fun)
                           (for/list ([arg (in-list %args)])
                             (if (out-arg? arg) '_pointer ((tag->symbol_type
                                                            (g-type-info-get-tag (g-arg-info-get-type arg))))))
                           (list '-> res-type-symbol)))
  
  (define vector-lengths (for/list ([arg (in-list %args)] 
                                    #:when (> (array-pos arg) -1))
                           (list-ref %args (array-pos arg))))
  (define in-args (filter (λ (arg) (and (not (memq arg vector-lengths)) (in-arg? arg))) %args))
  (define out-args (filter out-arg? %args))
  (define ((prefix-name prefix) arg) (string->symbol (string-append prefix (g-base-info-get-name arg))))
  (define ref-name (prefix-name "&"))
  (define init-name (prefix-name "!"))
  (define parsed-name (prefix-name "%"))
  (define fun-args (for/list ([arg (in-list %args)]) 
                     (if (out-arg? arg)
                         (ref-name arg)
                         (parsed-name arg))))
  (define (array-of type-info) (g-type-info-get-tag (g-type-info-get-param-type type-info 0)))
  (define parse-exprs
    (for/fold ([define-parsed null])
      ([in-arg (in-list in-args)])
      (define type-info (g-arg-info-get-type in-arg))
      (define tag (g-type-info-get-tag type-info))
      (if (eq? (g-type-info-get-tag type-info) 'array)
          (cons `(define ,(parsed-name in-arg) (pvector-ptr ,(init-name in-arg) ,(tag->symbol_type (array-of type-info))))
                (if (> (array-pos in-arg) -1)
                    (cons `(define ,(parsed-name (list-ref %args (array-pos in-arg))) (pvector-length ,(init-name in-arg))) define-parsed)
                    define-parsed))
          (cons `(define ,(parsed-name in-arg) ,(init-name in-arg))))))
  (define-values (total define-outs set-outs out-refs)
    (call-with-values 
     (λ ()
      (for/fold ([sum 0] [define-outs null] [set-outs null] [out-refs null]) 
        ([out-arg (in-list %args)] #:when (out-arg? out-arg))
        (define type-info (g-arg-info-get-type out-arg))
        (define tag (g-type-info-get-tag type-info))
        (values (+ sum (ctype-sizeof (tag->_type tag)))
                (cons `(define ,(ref-name out-arg) ,(if (= sum 0) 'ptr `(ptr-add ptr ,sum))) define-outs)
                (if (in-arg? out-arg) 
                    (cons `(ptr-set! ,(ref-name out-arg) ,(tag->symbol_type tag) ,(parsed-name out-arg)) set-outs)
                    set-outs)
                (cond 
                  [(eq? tag 'array) 
                   (cons `(pvector ,(tag->symbol_type (array-of type-info)) 
                                   (ptr-ref ,(ref-name out-arg))
                                   ,@(if (> (array-pos out-arg) -1)
                                         (list `(ptr-ref ,(ref-name (list-ref %args (array-pos out-arg)))))
                                         null)) out-refs)]
                  [(not (memq out-arg vector-lengths)) 
                   (cons `(ptr-ref ,(ref-name out-arg) ,(tag->symbol_type tag)) out-refs)]
                  [else out-refs]))))
     (λ (sum l1 l2 l3) (values sum (reverse l1) (reverse l2) (reverse l3)))))
  `(let ([fun (get-ffi-obj ,(g-function-info-get-symbol info) #f ,fun-type)]) 
     (lambda ,(map init-name in-args)
       ,@parse-exprs
       ,@(if (> total 0)
             (append (list `(define ptr (malloc ,total)))
                     define-outs)
             null)
       ,(if (eq? res-type-symbol '_void)
            `(fun ,@fun-args)
            `(define res (fun ,@fun-args)))
       ,(if (eq? res-type-symbol '_void)
            `(values ,@out-refs)
            `(values res ,@out-refs)))))

Пример раскрытого макроса:
(let ((fun (get-ffi-obj "gtk_init" #f (_fun _pointer _pointer -> _void))))
   (lambda (!argv)
     (define %argv (pvector-ptr !argv _string))
     (define %argc (pvector-length !argv))
     (define ptr (malloc 8))
     (define &argc ptr)
     (define &argv (ptr-add ptr 4))
     (fun &argc &argv)
     (values (pvector _string (ptr-ref &argv) (ptr-ref &argc)))))
★★★★★

Ответ на: комментарий от anonymous

Смущает количество апострофов на единицу текста. Тут на форуме один анонимус говорил, что макросы схемы лаконичней и красивей, чем CL-ные.

А у меня получается пока только ровно то же самое, только вместо `(... ,(...) ,(...)) будет #`(,,, #,(...) #,(...)), что читабельности не добавляет.

monk ★★★★★ ()
))))))])))]

лисп рулит

anonymous ()
Ответ на: комментарий от buddhist

Не заметил в исходной портянке большого количества апострофов.

`(let ([fun (get-ffi-obj ,(g-function-info-get-symbol info) #f ,fun-type)]) 
     (lambda ,(map init-name in-args)
       ,@parse-exprs
       ,@(if (> total 0)
             (append (list `(define ptr (malloc ,total)))
                     define-outs)
             null)
       ,(if (eq? res-type-symbol '_void)
            `(fun ,@fun-args)
            `(define res (fun ,@fun-args)))
       ,(if (eq? res-type-symbol '_void)
            `(values ,@out-refs)
            `(values res ,@out-refs)))))

А также по тексту `(define ,(parsed-name ...) ...), `(ptr-set! ...), `(ptr-ref ...)

По-идее должно быть что-то вроде

(with-syntax ([fun-name ....]
              [fun-type ....]
              [in-names ....]
              [parse-names ....]
              [parse-values ....]
              [out-names ....]
              [ref-names ....]
              [alloc-ref ....]
              [call-func ....]
              [outs ....]
  #'(let ([fun (get-ffi-obj fun-name #f fun-type)])
        (define-values (parse-names ...) (parse-values ...))
        (define-values (ref-names ...) (alloc-ref ...))
        (set-ptr! ref-names out-names) ...
        (call-func)
        (values outs ...)))

Там, где 4 точки (....) надо что-то написать. Проблема в том, что если call-func раскрывается в (define res ....), а outs в (values res ....), то я совсем не уверен, что гигиена позволит считать эти res одним и тем же имененм.

monk ★★★★★ ()
Вы не можете добавлять комментарии в эту тему. Тема перемещена в архив.