;;;; type-of.scm
;;;; Kon Lovett, Sep '09

;;"coerce.scm" Scheme Implementation of COMMON-LISP COERCE and TYPE-OF.
; Copyright (C) 1995, 2001 Aubrey Jaffer
;
;Permission to copy this software, to modify it, to redistribute it,
;to distribute modified versions, and to use it for any purpose is
;granted, subject to the following restrictions and understandings.
;
;1.  Any copy made of this software must include this copyright notice
;in full.
;
;2.  I have made no warranty or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3.  In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.

#>
/* This could be tighter & faster but also more brittle */

/*
  not the same names as used by BASICTYPE:
  "float" vs. "flonum"
  "undefined" vs. "unspecified"
  "eof" vs. "eof-object"
  "struct" vs. "record"
*/

static char *
basic_type_of( ___scheme_value obj )
{
  if (C_truep( C_fixnump( obj ) )) C_return( "fixnum" );
  if (C_truep( C_charp( obj ) )) C_return( "char" );
  if (C_truep( C_booleanp( obj ) )) C_return( "boolean" );
  if (C_truep( C_eofp( obj ) )) C_return( "eof-object" );
  if (C_truep( C_undefinedp( obj ) )) C_return( "unspecified" );
  if (C_truep( C_i_nullp( obj ) )) C_return( "null" );
  if (C_truep( C_unboundvaluep( obj ) )) C_return( "unbound" );
  if (C_truep( C_flonump( obj ) )) C_return( "flonum" );
  if (C_truep( C_stringp( obj ) )) C_return( "string" );
  if (C_truep( C_symbolp( obj ) )) C_return( "symbol" );
  if (C_truep( C_pairp( obj ) )) C_return( "pair" );
  if (C_truep( C_closurep( obj ) )) C_return( "procedure" );
  if (C_truep( C_vectorp( obj ) )) C_return( "vector" );
  if (C_truep( C_bytevectorp( obj ) )) C_return( "blob" );
  if (C_truep( C_portp( obj ) )) C_return( "port" );
  if (C_truep( C_structurep( obj ) )) C_return( "record" );
  if (C_truep( C_locativep( obj ) )) C_return( "locative" );
  if (C_truep( C_pointerp( obj ) )) C_return( "pointer" );
  if (C_truep( C_taggedpointerp( obj ) )) C_return( "tagged-pointer" );
  if (C_truep( C_swigpointerp( obj ) )) C_return( "swig-pointer" );
  if (C_truep( C_lambdainfop( obj ) )) C_return( "lambda-info" );
  C_return( "bucket" );
}

static int
basic_same_typep( ___scheme_value a,  ___scheme_value b )
{
  if (C_immediatep( a )) {
    if (C_immediatep( b )) {
      if (C_truep( C_fixnump( a ) )) C_return( C_truep( C_fixnump( b ) ) );
      if (C_truep( C_charp( a ) )) C_return( C_truep( C_charp( b ) ) );
      if (C_truep( C_booleanp( a ) )) C_return( C_truep( C_booleanp( b ) ) );
      if (C_truep( C_eofp( a ) )) C_return( C_truep( C_eofp( b ) ) );
      if (C_truep( C_unboundvaluep( a ) )) C_return( C_truep( C_unboundvaluep( b ) ) );
      if (C_truep( C_i_nullp( a ) )) C_return( C_truep( C_i_nullp( b ) ) );
      if (C_truep( C_undefinedp( a ) )) C_return( C_truep( C_undefinedp( b ) ) );
    }
    C_return( 0 );
  }
  C_return( C_truep( C_sametypep( a, b ) ) );
}
<#

(module type-of

(;export
  basic-type-of
  basic-same-type?
  type-of
  same-type?)

(import
  scheme chicken foreign
  (only lolevel record-instance-type))

(require-library
  lolevel)

;;;

;;

;;@body
;;Returns a symbol name for the type of @1.

(define basic-type-of (foreign-lambda symbol "basic_type_of" scheme-object))

;;@body
;;Returns whether same type @1 & @2.

(define basic-same-type? (foreign-lambda bool "basic_same_typep" scheme-object scheme-object))

;;

;;@body
;;Returns whether same type @1 & @2.

(define (same-type? a b)
  (and
    (basic-same-type? a b)
    (case (basic-type-of a)
      ((record) (eq? (record-instance-type a) (record-instance-type b)) )
      ((port)   (if (input-port? a) (input-port? b) (output-port? b)) )
      (else     #t ) ) ) )

;;

;;@body
;;Returns a symbol name for the type of @1.

(define (type-of obj)
  (let ((typ (basic-type-of obj)))
    (case typ
      ((symbol)   (if (keyword? obj) 'keyword 'symbol) )
      ((record)   (record-instance-type obj) )
      ((port)     (if (input-port? obj) 'input-port 'output-port) )
      (else       typ ) ) ) )

#; ;has old semantic but think wrong
(define (type-of obj)
  ; slooow
  (or
    (other-type-of obj)
    (let ((typ (basic-type-of obj)))
      (case typ
        ((symbol)         (if (keyword? obj) 'keyword 'symbol) )
        ((port)           (if (input-port? obj) 'input-port 'output-port) )
        ((record)         (record-instance-type obj) )
        ; think just wrong
        ((fixnum flonum)  'number )
        ((null pair)      'list )
        (else             typ ) ) ) ) )

;Use moremacros#typecase
#; ;original
(define (type-of obj)
  (cond
    ((boolean? obj)                   'boolean)
    ((char? obj)                      'char)
    #;((fixnum? obj)                    'fixnum)
    #;((flonum? obj)                    'flonum)
    #;((bignum? obj)                    'bignum)
    #;((ratio? obj)                     'ratio)
    #;((complex? obj)                   'complex)
    ((number? obj)                    'number)
    ((string? obj)                    'string)
    ((keyword? obj)                   'keyword)
    ((symbol? obj)                    'symbol)
    ((input-port? obj)                'port #;'input-port)
    ((output-port? obj)               'port #;'output-port)
    #;((extended-procedure? obj)        'extended-procedure)
    ((procedure? obj)                 'procedure)
    ((eof-object? obj)                'eof-object)
    ((list? obj)                      'list)
    #;((circular-list? obj)             'circular-list)
    #;((dotted-list? obj)               'dotted-list)
    ((pair? obj)                      'pair)
    ((vector? obj)                    'vector)
    ((blob? obj)                      'blob)
    #;((tagged-pointer? obj)            'tagged-pointer)
    ((pointer? obj)                   'pointer)
    ((locative? obj)                  'locative)
    #;((##sys#lambda-info? obj)         'lambda-info)
    ((record-instance? obj)           (record-instance-type obj))
    ((eq? (void) obj)                 'unspecified)
    ;FIXME will never reach here unless 'bucket
    (else
      (or
        (other-type-of obj)
        'object) ) ) )

) ;module type-of