bind-object   macro

(define-macro (bind-object name . slots)
  (if (= 0 (xobj_class_exists (symbol->string name)))
      (let* ((obj_type (string-append "xobj_" (symbol->string name) "_t"))
             (obj_name (string-append "xobj_" (symbol->string name)))
             (slots_ (map (lambda (s) (regex:split (symbol->string s) ":")) slots))
             (slots (append (list (list "_xobj_name" "i8*"))
                            (list (list "_xobj_parent" "xobject_t*"))
                            (list (list "_methods" "xlist_t*~<i8*,i8*>*~"))
                            slots_))
             (bindtype (list 'bind-type (string->symbol obj_type)
                             (string->symbol
                              (string-append "<" (cadr (car slots))
                                             (apply string-append
                                                    (map (lambda (k) (string-append "," (cadr k)))
                                                         (cdr slots)))
                                             ">"))))
             (constructor1 (list 'bind-func (string->symbol
                                             (string-append obj_name
                                                            "_1:[" obj_type "*]*"))
                                 `(lambda () (let ((obj (halloc)))
                                          (tset! obj 0 ,(symbol->string name))
                                          obj))))
             (constructor1poly (list 'bind-poly 'xobj_build (string->symbol (string-append obj_name "_1"))))
             (constructor2 (list 'bind-func (string->symbol
                                             (string-append obj_name
                                                            "_2:[" obj_type "*"
                                                            (apply string-append (map (lambda (kk) (string-append "," (cadr kk))) slots_))
                                                            "]*"))
                                 `(lambda ,(map (lambda (s) (string->symbol (car s))) slots_)
                                    (let ((obj (halloc)))
                                      ,(cons 'begin
                                             (cons (list 'tset! 'obj 0 (symbol->string name))
                                                   (map (lambda (s j) (list 'tset! 'obj (+ j 3) (string->symbol (car s))))
                                                        slots_
                                                        (make-list-with-proc (length slots_) (lambda (i) i)))))
                                      obj))))
             (constructor2poly (list 'bind-poly 'xobj_build (string->symbol (string-append obj_name "_2"))))
             (destructor (list 'bind-func (string->symbol
                                           (string-append obj_name "_destroy:[void," obj_type "*]*"))
                               `(lambda (obj) (free obj))))
             (destructorpoly (list 'bind-poly 'xobj_destroy (string->symbol (string-append obj_name "_destroy"))))
             (getters (map (lambda (s idx)
                             (list 'bind-func (string->symbol
                                               (string-append obj_name "_get_" (car s) ":["
                                                              (cadr s) "," obj_type "*]*"))
                                   `(lambda (obj)
                                      (tref obj ,idx))))
                           slots
                           (make-list-with-proc (length slots) (lambda (i) i))))
             (getterpolys (map (lambda (s) (list 'bind-poly
                                            (string->symbol (string-append "xobj_get_" (car s)))
                                            (string->symbol (string-append obj_name "_get_" (car s)))))
                               slots))
             (setters (map (lambda (s idx)
                             (list 'bind-func (string->symbol
                                               (string-append obj_name "_set_" (car s) ":"
                                                              "[void," obj_type "*," (cadr s) "]*"))
                                   `(lambda (obj val)
                                      (tset! obj ,idx val)
                                      void)))
                           slots
                           (make-list-with-proc (length slots) (lambda (i) i))))
             (setterpolys (map (lambda (s) (list 'bind-poly
                                            (string->symbol (string-append "xobj_set_" (car s)))
                                            (string->symbol (string-append obj_name "_set_" (car s)))))
                               slots)))
        (eval bindtype (interaction-environment))
        (eval constructor1 (interaction-environment))
        ;;(println constructor1)
        (eval constructor1poly (interaction-environment))
        (eval constructor2 (interaction-environment))
        ;;(println constructor2)
        (eval constructor2poly (interaction-environment))
        (eval destructor (interaction-environment))
        (eval destructorpoly (interaction-environment))
        (for-each (lambda (e) (eval e (interaction-environment))) getters)
        ;;(println getters)
        (for-each (lambda (e) (eval e (interaction-environment))) getterpolys)
        (for-each (lambda (e) (eval e (interaction-environment))) setters)
        (for-each (lambda (e) (eval e (interaction-environment))) setterpolys)
        ;; (println 'test: (list 'xobj_add_class (symbol->string name)))
        (eval (list 'xobj_add_class (symbol->string name)) (interaction-environment))
        1)))