;; Provides a procedure to try to get a symbol describing the value's
;; type. Not particularly efficient or elegant, but gets the job done.

(module get-type (get-type)
  (import scheme)
  (import (chicken base)
          (only (chicken blob) blob?)
          (only (chicken keyword) keyword?)
          (only (chicken locative) locative?)
          (only (chicken memory) pointer?)
          (only (chicken memory representation)
                record-instance?
                record-instance-type))


  ;; Returns symbol describing obj's type, or #f if type is unknown.
  (define (get-type obj)
    (cond
     ((record-instance? obj)
      (record-instance-type obj))

     ((procedure? obj) 'procedure)
     ((boolean? obj) 'boolean)
     ((eq? obj (void)) 'unspecified)

     ((list? obj) 'list)
     ((pair? obj) 'pair)
     ((vector? obj) 'vector)

     ((symbol? obj) 'symbol)
     ((keyword? obj) 'keyword)
     ((string? obj) 'string)
     ((char? obj) 'char)

     ((fixnum? obj) 'fixnum)
     ((bignum? obj) 'bignum)
     ((flonum? obj) 'flonum)
     ((ratnum? obj) 'ratnum)
     ((cplxnum? obj) 'cplxnum)
     ((number? obj) 'number)

     ((input-port? obj) 'input-port)
     ((output-port? obj) 'output-port)
     ((port? obj) 'port)
     ((eq? obj #!eof) 'eof)

     ((blob? obj) 'blob)
     ((pointer? obj) 'pointer)
     ((locative? obj) 'locative)

     (else #f))))



;; Demo / tests

(import (only (chicken format) printf)
        (only (chicken memory) address->pointer)
        (only (chicken locative) make-locative)
        get-type)

(define-record-type foo
  (make-foo)
  foo?)

(for-each
 (lambda (obj)
   (printf "~S is a ~A~N" obj (or (get-type obj) "unknown type")))
 (list (make-foo)
       (delay 'foo)

       car
       #t
       #f

       '()
       '(foo)
       '(a b . c)
       #(foo)

       'foo
       #:foo
       "foo"
       #\a

       123
       12345678901234567890
       4.5
       1/3
       1+2i

       (current-input-port)
       (current-output-port)
       #!eof

       #${1234}
       (address->pointer 123)
       (make-locative "foo")))