Re: still is obscure to me ...

[David Pirotte]

Martin Grabmueller wrote:

> Well, it was just an untested suggestion.  I don't know much about
> GOOPS and not anything at all about your application, so it's
> difficult to say what goes wrong.  If you could narrow down the
> problem, I could maybe help, but who knows...
> 
> Regards,
>   'martin

Yes, and thanks so much: i also wanted to use macros, but they don't work,
or at least i can not make them work!

Here is a complete piece of code, if anybody can tell me why the macro does
not produce the expected result, where the function does ... ?

many thanks again,
david

;; -------------------------------

(define-module (alto db-utils test)

  ;; from distribution
  ;; :use-module (database postgres)
  :use-module (oop goops)
  ;; :use-module (ice-9 format)

  ;; from alto

  )

(export *tb-names*
        *tb-attrs*

        dbu/build-db-class-slots
        dbu/build-db-class-1
        dbu/build-db-class

        dbu/sim-pg-get-bld-classes
        )

(define *tb-attrs* '((("1" "ref" "text")
                      ("2" "nom" "text")
                      ("3" "zon" "text"))
                     (("4" "pos_x" "int4")
                      ("5" "pos_y" "int4")
                      ("6" "pos_z" "text"))
                     (("7" "img_x" "int2")
                      ("8" "img_y" "int2")
                      ("9" "img_z" "int2"))
                     ))

(define *tb-names* '("test-1" "test-2" "test-3"))

(define (dbu/build-db-class-slots table-attrs)
  (let ((slots (list 'db-oid))
        (slot-defs (list '(db-oid #:accessor db-oid
                                  #:init-keyword #:db-oid
                                  #:init-value #f))))
    (for-each (lambda (table-attr)
                (let* ((attr-name (cadr table-attr))
                       (slot (string->symbol attr-name))
                       (slot-kw (symbol->keyword slot)))
                  (set! slots (cons slot slots))
                  (set! slot-defs (cons `(,slot #:accessor ,slot
                                                #:init-keyword ,slot-kw
                                                #:init-value #f)
                                        slot-defs))))
              table-attrs)
    (values (reverse! slots)
            (reverse! slot-defs))
    ))

;(define (dbu/build-db-class-1 class-name slot-defs slot-idts)
;  (let ((defclass-form (eval `(define-class ,class-name () ,@slot-defs)))
;       (export-form (eval `(export ,class-name ,@slot-idts))))
;    defclass-form
;    export-form
;    ))

(define-macro (dbu/build-db-class-1 class-name slot-defs slot-idts)
  `(begin
     (define-class ,class-name () ,@slot-defs)
     (export class-name ,@slot-idts)))

(define (dbu/build-db-class tb-nme tb-att)
  (let ((cl-name (string->symbol (string-append "<" tb-nme ">"))))
    (call-with-values 
     (lambda () (dbu/build-db-class-slots tb-att))
     (lambda (slot-idts slot-defs)
       (dbu/build-db-class-1 cl-name slot-defs slot-idts)
       ))))

(define (dbu/sim-pg-get-bld-classes tb-names tb-attrs)
  (let ((i 0))
    (for-each (lambda (tb-name)
                (dbu/build-db-class tb-name
                                    (list-ref tb-attrs i))
                (set! i (+ i 1)))
              tb-names)))

(dbu/sim-pg-get-bld-classes  *tb-names* *tb-attrs*)