;;;; tinyclos-utils-body.scm

  (import (only srfi-1 fold))
  (require-library srfi-1)

;;

(define (check-anypointer loc x)
  (unless (##sys#pointer? x)
    (##sys#signal-hook #:type-error loc "bad argument type - not a pointer" x) )
  x )

(define (proq obj lis)
  (let loop ((lis lis))
    (and (pair? lis)
         (or (and (eq? obj (car lis))
                  lis)
             (loop (cddr lis)) ) ) ) )

;;

;could be better
(define (make-instance/pointer ptr #!optional (class <c++-object>))
  (and ptr
       (not (##sys#null-pointer? (check-anypointer 'make-instance/pointer ptr)))
       (make class 'this ptr) ) )

;;

(define (make/copy x . initargs)
  (let ((class (class-of x)))
    (apply make
      class
      (fold
        (lambda (s ls)
          (let ((nam (car s)))
            (if (proq nam initargs) ls
              (cons nam (cons (slot-ref x nam) ls)) ) ) )
        initargs
        (class-slots class))) ) )

;;

; From '@' by Dan Muresan
(define-syntax slot@
  (syntax-rules (=)
    ((_ ?o)                 ?o)
    ((_ ?o ?slot = ?v)      (slot-set! ?o '?slot ?v))
    ((_ ?o ?slot . ?slots)  (slot@ (slot-ref ?o '?slot) . ?slots)) ) )