ut to use for instances of
;;; those classes.
;;;
(define (compute-std-cpl c get-direct-supers)
  "The standard class precedence list computation algorithm."
  (define (only-non-null lst)
    (filter (lambda (l) (not (null? l))) lst))

  (define (merge-lists reversed-partial-result inputs)
    (cond
     ((every null? inputs)
      (reverse! reversed-partial-result))
     (else
      (let* ((candidate (lambda (c)
                          (and (not (any (lambda (l)
                                           (memq c (cdr l)))
                                         inputs))
                               c)))
             (candidate-car (lambda (l)
                              (and (not (null? l))
                                   (candidate (car l)))))
             (next (any candidate-car inputs)))
        (unless next
          (goops-error "merge-lists: Inconsistent precedence graph"))
        (let ((remove-next (lambda (l)
                             (if (eq? (car l) next)
                                 (cdr l)
                                 l))))
          (merge-lists (cons next reversed-partial-result)
                       (only-non-null (map remove-next inputs))))))))
  (let ((c-direct-supers (get-direct-supers c)))
    (merge-lists (list c)
                 (only-non-null (append (map class-precedence-list
                                             c-direct-supers)
                                        (list c-direct-supers))))))

;; This version of compute-cpl is replaced with a generic function once
;; GOOPS has booted.
(define (compute-cpl class)
  (compute-std-cpl class class-direct-supers))

(define (effective-slot-definition-class class slot)
  (class-of slot))

(define (compute-effective-slot-definition class slot)
  ;; FIXME: Support slot being a list of slots, as in CLOS.
  (apply make
         (effective-slot-definition-class class slot)
         (slot-definition-options slot)))

(define (build-slots-list dslots cpl)
  (define (slot-memq slot slots)
    (let ((name (%slot-definition-name slot)))
      (let lp ((slots slots))
        (match slots
          (() #f)
          ((slot . slots)
           (or (eq? (%slot-definition-name slot) name) (lp slots)))))))
  (define (check-cpl slots static-slots)
    (match static-slots
      (() #t)
      ((static-slot . static-slots)
       (when (slot-memq static-slot slots)
         (scm-error 'misc-error #f
                    "statically allocated inherited field cannot be redefined: ~a"
                    (list (%slot-definition-name static-slot)) '()))
       (check-cpl slots static-slots))))
  (define (remove-duplicate-slots slots)
    (let lp ((slots (reverse slots)) (res '()) (seen '()))
      (match slots
        (() res)
        ((slot . slots)
         (let ((name (%slot-definition-name slot)))
           (if (memq name seen)
               (lp slots res seen)
               (lp slots (cons slot res) (cons name seen))))))))
  ;; For subclases of <class> and <slot>, we need to ensure that the
  ;; <class> or <slot> slots come first.
  (let ((static-slots
         (match (filter class-has-statically-allocated-slots? (cdr cpl))
           (() #f)
           ((class) (struct-ref class class-index-direct-slots))
           (classes
            (error "can't subtype multiple classes with static slot allocation"
                   classes)))))
    (when static-slots
      (check-cpl dslots static-slots))
    (let lp ((cpl (cdr cpl)) (res dslots) (static-slots '()))
      (match cpl
        (() (remove-duplicate-slots (append static-slots res)))
        ((head . cpl)
         (let ((new-slots (struct-ref head class-index-direct-slots)))
           (cond
            ((not static-slots)
             (lp cpl (append new-slots res) static-slots))
            ((class-has-statically-allocated-slots? head)
             ;; Move static slots to the head of the list.
             (lp cpl res new-slots))
            (else
             (check-cpl new-slots static-slots)
             (lp cpl (append new-slots res) static-slots)))))))))

;; Boot definition.
(define (compute-get-n-set class slot)
  (let ((index (struct-ref/unboxed class class-index-nfields)))
    (struct-set!/unboxed class class-index-nfields (1+ index))
    index))

;;; Pre-generate getters and setters for the first 20 slots.
(define-syntax define-standard-accessor-method
  (lambda (stx)
    (define num-standard-pre-cache 20)
    (syntax-case stx ()
      ((_ ((proc n) arg ...) body)
       #`(define proc
           (let ((cache (vector #,@(map (lambda (n*)
                                          #`(lambda (arg ...)
                                              (let ((n #,n*))
                                                body)))
                                        (iota num-standard-pre-cache)))))
             (lambda (n)
               (if (< n #,num-standard-pre-cache)
                   (vector-ref cache n)
                   (lambda (arg ...) body)))))))))

(define-standard-accessor-method ((bound-check-get n) o)
  (let ((x (struct-ref o n)))
    (if (unbound? x)
        (slot-unbound o)
        x)))

(define-standard-accessor-method ((standard-get n) o)
  (struct-ref o n))

(define-standard-accessor-method ((standard-set n) o v)
  (struct-set! o n v))

(define-standard-accessor-method ((unboxed-get n) o)
  (struct-ref/unboxed o n))

(define-standard-accessor-method ((unboxed-set n) o v)
  (struct-set!/unboxed o n v))

;; Boot definitions.
(define (opaque-slot? slot) #f)
(define (read-only-slot? slot) #f)
(define (unboxed-slot? slot)
  (memq (%slot-definition-name slot)
        '(flags instance-finalizer nfields %reserved-6 %reserved-7)))

(define (allocate-slots class slots)
  "Transform the computed list of direct slot definitions @var{slots}
into a corresponding list of effective slot definitions, allocating
slots as we go."
  (define (make-effective-slot-definition slot)
    ;; `compute-get-n-set' is expected to mutate `nfields' if it
    ;; allocates a field to the object.  Pretty strange, but we preserve
    ;; the behavior for backward compatibility.
    (let* ((slot (compute-effective-slot-definition class slot))
           (name (%slot-definition-name slot))
           (index (struct-ref/unboxed class class-index-nfields))
           (g-n-s (compute-get-n-set class slot))
           (size (- (struct-ref/unboxed class class-index-nfields) index)))
      (call-with-values
          (lambda ()
            (match g-n-s
              ((? integer?)
               (unless (= size 1)
                 (error "unexpected return from compute-get-n-set"))
               (cond
                ((unboxed-slot? slot)
                 (let ((get (unboxed-get g-n-s)))
                   (values get get (unboxed-set g-n-s))))
                (else
                 (values (standard-get g-n-s)
                         (if (slot-definition-init-thunk slot)
                             (standard-get g-n-s)
                             (bound-check-get g-n-s))
                         (standard-set g-n-s)))))
              (((? procedure? get) (? procedure? set))
               (values get
                       (lambda (o)
                         (let ((value (get o)))
                           (if (unbound? value)
                               (slot-unbound class o name)
                               value)))
                       set))))
        (lambda (get/raw get set)
          (let ((get (if (opaque-slot? slot)
                         (lambda (o)
                           (error "Slot is opaque" name))
                         get))
                (set (cond
                      ((opaque-slot? slot)
                       (lambda (o v)
                         (error "Slot is opaque" name)))
                      ((read-only-slot? slot)
                       (if (unboxed-slot? slot)
                           (lambda (o v)
                             (let ((v* (get/raw o)))
                               (if (zero? v*)
                                   ;; Allow initialization.
                                   (set o v)
                                   (error "Slot is read-only" name))))
                           (lambda (o v)
                             (let ((v* (get/raw o)))
                               (if (unbound? v*)
                                   ;; Allow initialization.
                                   (set o v)
                                   (error "Slot is read-only" name))))))
                      (else set))))
            (struct-set! slot slot-index-slot-ref/raw get/raw)
            (struct-set! slot slot-index-slot-ref get)
            (struct-set! slot slot-index-slot-set! set)
            (struct-set! slot slot-index-index index)
            (struct-set! slot slot-index-size size))))
      slot))
  (struct-set!/unboxed class class-index-nfields 0)
  (map-in-order make-effective-slot-definition slots))

(define (%compute-layout slots nfields is-class?)
  (define (slot-protection-and-kind slot)
    (define (subclass? class parent)
      (memq parent (class-precedence-list class)))
    (let ((type (get-keyword #:class (%slot-definition-options slot))))
      (if (and type (subclass? type <foreign-slot>))
          (values (cond
                   ((subclass? type <protected-slot>) #\p)
                   (else #\u))
                  (cond
                   ((subclass? type <hidden-slot>) #\h)
                   (else #\w)))
          (values #\p #\w))))
  (let ((layout (make-string (* nfields 2))))
    (let lp ((n 0) (slots slots))
      (match slots
        (()
         (unless (= n nfields) (error "bad nfields"))
         (when is-class?
           (let ((class-layout (struct-ref <class> class-index-layout)))
             (unless (string-prefix? (symbol->string class-layout) layout)
               (error "bad layout for class"))))
         layout)
        ((slot . slots)
         (unless (= n (%slot-definition-index slot)) (error "bad allocation"))
         (call-with-values (lambda () (slot-protection-and-kind slot))
           (lambda (protection kind)
             (let init ((n n) (size (%slot-definition-size slot)))
               (cond
                ((zero? size) (lp n slots))
                (else
                 (unless (< n nfields) (error "bad nfields"))
                 (string-set! layout (* n 2) protection)
                 (string-set! layout (1+ (* n 2)) kind)
                 (init (1+ n) (1- size))))))))))))


