;; These modules should be part of Chicken one day.
;; Then we can remove this file and have it auto-generated by chicken-install
(eval '(import (only chicken case-lambda fx=)))
(##sys#register-compiled-module
  'srfi-16
  (list)
  '((fx= . #%fx=))
  (list 'case-lambda)
  (list))

(eval '(import (only chicken error)))
(##sys#register-compiled-module
  'srfi-23
  (list)
  '((error . #%error))
  (list)
  (list))

(eval '(import
         (only s48-modules include-relative)
         scheme
         srfi-1
         srfi-16
         srfi-23
         hermes))
(##sys#register-compiled-module
  '_prometheus
  (list)
  '((*the-root-object* . _prometheus#*the-root-object*)
    (root-delete-slot! . _prometheus#root-delete-slot!)
    (root-add-parent-slot! . _prometheus#root-add-parent-slot!)
    (root-add-method-slot! . _prometheus#root-add-method-slot!)
    (root-add-value-slot! . _prometheus#root-add-value-slot!)
    (root-ambiguous-message-send . _prometheus#root-ambiguous-message-send)
    (root-message-not-understood . _prometheus#root-message-not-understood)
    (root-clone . _prometheus#root-clone)
    (root-set-immediate-slot-list! . _prometheus#root-set-immediate-slot-list!)
    (root-immediate-slot-list . _prometheus#root-immediate-slot-list)
    (make-prometheus-root-object . _prometheus#make-prometheus-root-object))
  (list (cons 'define-object/add-slots!
              (syntax-rules
                ()
                ((_ o) (values))
                ((_ o ((method-name . method-args) body ...) slots ...)
                 (begin
                   (o 'add-method-slot!
                      'method-name
                      (lambda method-args body ...))
                   (define-object/add-slots! o slots ...)))
                ((_ o (slot-getter slot-setter slot-value) slots ...)
                 (begin
                   (o 'add-value-slot! 'slot-getter 'slot-setter slot-value)
                   (define-object/add-slots! o slots ...)))
                ((_ o (slot-getter slot-value) slots ...)
                 (begin
                   (o 'add-value-slot! 'slot-getter slot-value)
                   (define-object/add-slots! o slots ...)))))
        (cons 'define-object
              (syntax-rules
                ()
                ((_ name
                    (creation-parent (parent-name parent-object) ...)
                    slots
                    ...)
                 (define name
                   (let ((o (creation-parent 'clone)))
                     (o 'add-parent-slot! 'parent-name parent-object)
                     ...
                     (define-object/add-slots! o slots ...)
                     o)))))
        (cons 'define-method
              (syntax-rules
                ()
                ((_ (obj 'message self resend args ...) body1 body ...)
                 (obj 'add-method-slot!
                      'message
                      (lambda (self resend args ...) body1 body ...)))))
        (cons 'make-getter-setter
              (syntax-rules
                ()
                ((make-getter-setter 'MESSAGE VALUE TYPE PURE-GETTER)
                 (make-getter-setter
                   'MESSAGE
                   VALUE
                   TYPE
                   PURE-GETTER
                   PURE-GETTER))
                ((make-getter-setter
                   'MESSAGE
                   VALUE
                   TYPE
                   PURE-GETTER
                   SETABLE-GETTER)
                 (case-lambda
                   ((self resend getter VALUE)
                    (self 'delete-slot! getter)
                    (self 'set-immediate-slot-list!
                          (alist-cons
                            getter
                            (list #f TYPE)
                            (self 'immediate-slot-list)))
                    (self 'add-message! getter PURE-GETTER (eq? TYPE 'parent)))
                   ((self resend getter setter VALUE)
                    (self 'delete-slot! getter)
                    (self 'delete-slot! setter)
                    (self 'set-immediate-slot-list!
                          (alist-cons
                            getter
                            (list setter TYPE)
                            (self 'immediate-slot-list)))
                    (self 'add-message!
                          getter
                          SETABLE-GETTER
                          (eq? TYPE 'parent))
                    (self 'add-message!
                          setter
                          (lambda (self2 resend new)
                            (if (eq? self2 self)
                              (set! VALUE new)
                              (self2 'MESSAGE getter setter new))))))))))
  (list))