;;;; tinyclos-utils-body.scm

;;

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

(define (proplist-prop obj lis)
  (let loop ((lis lis))
    (and (pair? lis)
         (or (and (equal? obj (car lis))
                  lis)
             (loop (cddr lis)) ) ) ) )
;;

#; ;Original
(define (initialize-slots object initargs)
  (##sys#check-list initargs 'initialize-slots)
  (for-each
    (lambda (slot)
      (let* ((name   (car slot))
             (value  (fast-getl initargs name not-found-object)) )
        (unless (eq? value not-found-object)
          (slot-set! object name value))))
    (class-slots (class-of object))) )

(define (initialize-slots object initargs)
  (##sys#check-list initargs 'initialize-slots)
  (for-each
    (lambda (slot)
      (let* ((name (car slot))
             (where (proplist-prop name initargs)) )
        (when where
          (slot-set! object name (cadr where)) ) ) )
    (class-slots (class-of object))) )

;;

;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
      (let ((initlist initargs))
        (for-each
          (lambda (s)
            (let ((nam (car s)))
              (unless (proplist-prop nam initargs)
                (set! initlist (cons nam (cons (slot-ref x nam) initlist))) ) ) )
          (class-slots class))
        initlist ) ) ) )

;;

; 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) ) ) )