;;;; tinyclos-primitive-objects-body.scm

;;; Extended primitive class-of

; Class-of extension helpers
;
; Implemented as a map: "test" <-> "class"

; symbol
(define-inline (classmap-item-key cmi)
  (%car cmi) )

; predicate
(define-inline (classmap-item-predicate cmi)
  (%car cmi) )

; class
(define-inline (classmap-item-class cmi)
  (%cdr cmi) )

;

(define-inline (classmap-item-key-set! cmi key)
  (%set-car! cmi key) )

#; ;UNUSED - predicate treated same as tag
(define-inline (classmap-item-predicate-set! cmi key)
  (%set-car! cmi key) )

(define-inline (classmap-item-class-set! cmi class)
  (%set-cdr! cmi class) )

;

(define-inline (classmap-add! cm key class)
  (cons (cons key class) cm) )

;

(define (classmap-item?/eq cmi key)
  (eq? key (classmap-item-key cmi)) )

(define (classmap-item?/predicate cmi key)
  ((classmap-item-predicate cmi) key) )

;

(define-inline (classmap-item/eq cm key)
  (any/1 (cut classmap-item?/eq <> key) cm) )

(define-inline (classmap-item/predicate cm key)
  (any/1 (cut classmap-item?/predicate <> key) cm) )

;

(define-inline (classmap-class/eq cm key)
  (and-let* ((cmi (classmap-item/eq cm key)))
    (classmap-item-class cmi) ) )

(define-inline (classmap-class/predicate cm key)
  (and-let* ((cmi (classmap-item/predicate cm key)))
    (classmap-item-class cmi) ) )

;

(define (classmap-delete!/key cm key)
  (delete!/1 (cut classmap-item?/eq <> key) cm) )

(define (classmap-delete!/class cm class)
  (delete!/1 (lambda (cmi) (eq? class (classmap-item-class cmi))) cm) )

(define (classmap-delete! cm obj)
  (if (class? obj)
      (classmap-delete!/class cm obj)
      (classmap-delete!/key cm obj) ) )

;

(define (classmap-update!/key cm key class)
  (let ((cmi (classmap-item/eq cm key)))
    (if cmi
        (begin (classmap-item-class-set! cmi class) cm)
        (classmap-add! cm key class) ) ) )

; Primitive class-of extensions

(define +primitive-class-map+ '())

(define-inline (primitive-class-of x)
  (classmap-class/predicate +primitive-class-map+ x) )

(define (delete-primitive-class-of obj)
  (set! +primitive-class-map+
        (classmap-delete! +primitive-class-map+ obj)) )

(define (add-primitive-class-of pred class)
  (set! +primitive-class-map+
        (classmap-update!/key +primitive-class-map+ pred class)) )

; Structure class-of extensions

(define +structure-class-map+ '())

(define-inline (structure-class-of x)
  (or (primitive-class-of x)
      (classmap-class/eq +structure-class-map+ (%structure-tag x))
      <structure>) )

(define (delete-structure-class-of obj)
  (set! +structure-class-map+
        (classmap-delete! +structure-class-map+ obj)) )

(define (add-structure-class-of tag class)
  (set! +structure-class-map+
        (classmap-update!/key +structure-class-map+ tag class)) )

; Tagged-pointer class-of extensions

(define +tagged-pointer-class-map+ '())

(define-inline (tagged-pointer-class-of x)
  (or (primitive-class-of x)
      (classmap-class/eq +tagged-pointer-class-map+ (%tagged-pointer-data x))
      <tagged-pointer>) )

(define (delete-tagged-pointer-class-of obj)
  (set! +tagged-pointer-class-map+
        (classmap-delete! +tagged-pointer-class-map+ obj)) )

(define (add-tagged-pointer-class-of tag class)
  (set! +tagged-pointer-class-map+
        (classmap-update!/key +tagged-pointer-class-map+ tag class)) )

; Extended-procedure class-of extensions

(define +extended-procedure-class-map+ '())

(define-inline (procedure-class-of x)
  (or (primitive-class-of x)
      (classmap-class/predicate +extended-procedure-class-map+ (procedure-data x))
      <procedure>) )

(define (delete-extended-procedure-class-of obj)
  (set! +extended-procedure-class-map+
        (classmap-delete! +extended-procedure-class-map+ obj)) )

(define (add-extended-procedure-class-of pred class)
  (set! +extended-procedure-class-map+
        (classmap-update!/key +extended-procedure-class-map+ pred class)) )

;

(register-primitive-class-of
  (lambda (x)
    (cond ((fixnum? x)                    <exact>)
          ((null? x)                      <null>)
          ((boolean? x)                   <boolean>)
          ((char? x)                      <char>)
          ((eof-object? x)                <end-of-file>)
          ((%unspecified? x)              <void>)
          ((##sys#immediate? x)           <immediate>)
          ((flonum? x)                    <inexact>)
          ((integer? x)                   <integer>)
          ((number? x)                    <number>)
          ((symbol? x)                    <symbol>)
          ((procedure? x)                 (procedure-class-of x))
          ((vector? x)                    <vector>)
          ((pair? x)                      <pair>)
          ((string? x)                    <string>)
          ((port? x)                      (if (input-port? x) <input-port> <output-port>))
          ((##sys#bytevector? x)          <blob>)
          ((%tagged-pointer? x)           (tagged-pointer-class-of x))
          ((%swig-pointer? x)             <swig-pointer>)
          ((%pointer? x)                  <pointer>)
          ((%locative? x)                 <locative>)
          ((%structure? x)
           (case (%structure-tag x)
             ((environment)               <environment>)
             ((array)                     <array>)
             ((hash-table)                <hash-table>)
             ((queue)                     <queue>)
             ((condition)                 <condition>)
             ((condition-variable)        <condition-variable>)
             ((char-set)                  <char-set>)
             ((time)                      <time>)
             ((lock)                      <lock>)
             ((mmap)                      <mmap>)
             ((promise)                   <promise>)
             ((u8vector)                  <u8vector>)
             ((s8vector)                  <s8vector>)
             ((u16vector)                 <u16vector>)
             ((s16vector)                 <s16vector>)
             ((u32vector)                 <u32vector>)
             #;((s64vector)                 <s64vector>)
             #;((u64vector)                 <u64vector>)
             ((s32vector)                 <s32vector>)
             ((f32vector)                 <f32vector>)
             ((f64vector)                 <f64vector>)
             ((tcp-listener)              <tcp-listener>)
             ((thread)                    <thread>)
             ((mutex)                     <mutex>)
             ((continuation)              <continuation>)
             ((read-table)                <read-table>)
             ((regexp)                    <regexp>)
             (else                        (structure-class-of x) ) ) )
          ((primitive-class-of x) )
          ; punt to older definition
          (else                           #f ) ) ) )