CL 风格宏中的多个(定义)

发布于 2024-09-17 07:42:05 字数 2823 浏览 3 评论 0原文

我目前正在学习如何在Scheme中编写CL风格的宏(define-macro)。作为一个简单的例子,我编写了一个 struct 宏,它定义了 make-thingthing?thing-field 等函数code> 访问器等等。

现在我想将多个 define 合并到一个宏中,但实际上只使用最后一个。目前我正在使用 eval 全局定义函数(?),但一定有更好的方法......有什么想法吗?

到目前为止的代码:

;(use-modules (ice-9 pretty-print))

(define-macro (struct name key table fields)
  (for-each
    (lambda (field)
      (eval
        `(define ,(string->symbol (string-append (symbol->string name) "-" (symbol->string field)))
          (lambda (x)
            (if (,(string->symbol (string-append (symbol->string name) "?")) x)
              (cadr (assq (quote ,field) (cdr x)))
              #f)))
        (interaction-environment)))
      fields)
  (eval
    `(define ,(string->symbol (string-append (symbol->string name) "?"))
       (lambda (x)
         (and
           (list? x)
           (eq? (car x) (quote ,name))
           ,@(map (lambda (field) `(assq (quote ,field) (cdr x))) fields)
           #t)))
    (interaction-environment))
  (eval
    `(define ,(string->symbol (string-append "make-" (symbol->string name)))
       (lambda ,fields
         (list (quote ,name)
               ,@(map (lambda (field) `(list (quote ,field) ,field)) fields))))
    (interaction-environment))
  (eval
    `(define ,(string->symbol (string-append "save-" (symbol->string name)))
       (lambda (x)
         (if (,(string->symbol (string-append (symbol->string name) "?")) x)
           (call-with-output-file ; TODO: In PLT mit zusaetzlichem Parameter #:exists 'replace
             (string-append "data/" ,(symbol->string table) "/"
                            (,(string->symbol (string-append (symbol->string name) "-" (symbol->string key))) x))
             (lambda (out) (write x out)))
           #f)))
    (interaction-environment))
  `(define ,(string->symbol (string-append "get-" (symbol->string name)))
     (lambda (id)
       (let ((ret (call-with-input-file (string-append "data/" ,(symbol->string table) "/" id) read)))
         (if (,(string->symbol (string-append (symbol->string name) "?")) ret)
           ret
           #f))))
; TODO: (define (list-customers . search-words) ...)
  )

(struct customer id customers (id name name_invoice address_invoice zip_invoice city_invoice state_invoice))
;(pretty-print (macroexpand '(struct customer id customers (id name name_invoice address_invoice zip_invoice city_invoice state_invoice))))
;(newline)

(define c (make-customer "C-1001" "Doe, John" "John Doe" "Some-Street" "Some-Zip" "Some-City" "Germany"))
(write c)
(newline)
(write (customer-id c))
(newline)
(write (customer-name c))
(newline)
(save-customer c)
(write (get-customer "C-1001"))
(newline)

I'm currently learning how to write CL style macros (define-macro) in Scheme. As a simple example, I wrote a struct macro that defines functions like make-thing, thing?, thing-field accessors and so on.

Now I'd like to combine multiple defines in a single macro, but only the last one is actually used. Currently I'm using eval to define the functions globally (?), but there must be some better way... any ideas?

The code so far:

;(use-modules (ice-9 pretty-print))

(define-macro (struct name key table fields)
  (for-each
    (lambda (field)
      (eval
        `(define ,(string->symbol (string-append (symbol->string name) "-" (symbol->string field)))
          (lambda (x)
            (if (,(string->symbol (string-append (symbol->string name) "?")) x)
              (cadr (assq (quote ,field) (cdr x)))
              #f)))
        (interaction-environment)))
      fields)
  (eval
    `(define ,(string->symbol (string-append (symbol->string name) "?"))
       (lambda (x)
         (and
           (list? x)
           (eq? (car x) (quote ,name))
           ,@(map (lambda (field) `(assq (quote ,field) (cdr x))) fields)
           #t)))
    (interaction-environment))
  (eval
    `(define ,(string->symbol (string-append "make-" (symbol->string name)))
       (lambda ,fields
         (list (quote ,name)
               ,@(map (lambda (field) `(list (quote ,field) ,field)) fields))))
    (interaction-environment))
  (eval
    `(define ,(string->symbol (string-append "save-" (symbol->string name)))
       (lambda (x)
         (if (,(string->symbol (string-append (symbol->string name) "?")) x)
           (call-with-output-file ; TODO: In PLT mit zusaetzlichem Parameter #:exists 'replace
             (string-append "data/" ,(symbol->string table) "/"
                            (,(string->symbol (string-append (symbol->string name) "-" (symbol->string key))) x))
             (lambda (out) (write x out)))
           #f)))
    (interaction-environment))
  `(define ,(string->symbol (string-append "get-" (symbol->string name)))
     (lambda (id)
       (let ((ret (call-with-input-file (string-append "data/" ,(symbol->string table) "/" id) read)))
         (if (,(string->symbol (string-append (symbol->string name) "?")) ret)
           ret
           #f))))
; TODO: (define (list-customers . search-words) ...)
  )

(struct customer id customers (id name name_invoice address_invoice zip_invoice city_invoice state_invoice))
;(pretty-print (macroexpand '(struct customer id customers (id name name_invoice address_invoice zip_invoice city_invoice state_invoice))))
;(newline)

(define c (make-customer "C-1001" "Doe, John" "John Doe" "Some-Street" "Some-Zip" "Some-City" "Germany"))
(write c)
(newline)
(write (customer-id c))
(newline)
(write (customer-name c))
(newline)
(save-customer c)
(write (get-customer "C-1001"))
(newline)

如果你对这篇内容有疑问,欢迎到本站社区发帖提问 参与讨论,获取更多帮助,或者扫码二维码加入 Web 技术交流群。

扫码二维码加入Web技术交流群

发布评论

需要 登录 才能够评论, 你可以免费 注册 一个本站的账号。

评论(1

茶底世界 2024-09-24 07:42:05

这里不需要eval;使用 begin 将这些定义组合到一个列表中;即,要扩展的模板应采用以下形式:

`(begin 
   ,@(map ...)
   (define ...)
   (define ...)
   ...)

编辑:

按照OP的建议将for-each更改为map

You don't need eval here; use begin instead to group those definitions together into a list; i.e., the template to be expanded should be of the form:

`(begin 
   ,@(map ...)
   (define ...)
   (define ...)
   ...)

Edit:

Change for-each to map as suggested by OP.

~没有更多了~
我们使用 Cookies 和其他技术来定制您的体验包括您的登录状态等。通过阅读我们的 隐私政策 了解更多相关信息。 单击 接受 或继续使用网站,即表示您同意使用 Cookies 和您的相关数据。
原文