;;;; 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.

(module type-of (;export
  type-of
  ;;
  coerce-extend!
  coerce-composite-extension!
  coerce-extended?
  coerce-extension
  coerce-extension-remove!
  ;;
  type-of-extended?
  type-of-extend!
  type-of-extension
  type-of-composite-extension!
  type-of-remove!
  ;;
  other-coerce)

#|
; Need someway to make compiling for the full-numeric-tower & utf8 easier

  (cond-expand
    (full-numeric-tower
      (import (except scheme
                      + - * / = > < >= <=
                      number->string string->number 
                      eqv? equal?
                      exp log sin cos tan atan acos asin expt sqrt
                      quotient modulo remainder
                      numerator denominator
                      abs max min gcd lcm
                      positive? negative? odd? even? zero?
                      exact? inexact?
                      rationalize
                      floor ceiling truncate round
                      inexact->exact exact->inexact
                      number? complex? real? rational? integer?
                      make-rectangular make-polar real-part imag-part magnitude angle)
	            (except chicken add1 sub1 random randomize conj signum
                      force-finalizers
                      bitwise-and bitwise-ior bitwise-xor bitwise-not arithmetic-shift)
              numbers )
      (require-library numbers) )
    (else 
      (import scheme chicken) ) )
|#

  (import scheme chicken)
  (import (only data-structures identity)
          (only lolevel record-instance? record-instance-type)
          (only miscmacros if*)
          (only type-checks check-procedure check-symbol)
          type-extend-support)

  (require-library data-structures lolevel
                   miscmacros type-checks type-extend-support)

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

(define (type-of obj)
  (cond ((boolean? obj)           'boolean)
        ((char? obj)              'char)
        ((number? obj)            'number)
        ((string? obj)            'string)
        ((keyword? obj)           'keyword)
        ((symbol? obj)            'symbol)
        ((input-port? obj)        'port)
        ((output-port? obj)       'port)
        ((procedure? obj)         'procedure)
        ((eof-object? obj)        'eof-object)
        ((list? obj)              'list)
        ((pair? obj)              'pair)
        ((vector? obj)            'vector)
        ((record-instance? obj)   (record-instance-type obj))
        ((blob? obj)              'blob)
        ((procedure? obj)         'procedure)
        ((eq? (void) obj)         'unspecified)
        (else
          (or (other-type-of obj)
              'scheme-object) ) ) )

;;;

(define (->boolean x) (and x #t))

#; ;UNUSED
(define-syntax thunk
  (syntax-rules ()
    ((_ body ...) (lambda () body ...)) ) )

;;;

(define (other-type-of obj)
  (and-let* ((ti (typdef/object obj)))
    (typdef-type ti) ) )

(define (other-coerce obj result-type default-proc)
  (if* (typdef/type (type-of obj)) ((typdef-proc it) obj result-type default-proc)
       (default-proc)) )

(define ((composite-pred pred old-pred) obj)
  (or (pred obj) (old-pred obj)) )

(define ((composite-proc proc old-proc) obj typ err)
  (proc obj typ (lambda () (old-proc obj typ err))) )

;;; Extension

(define (coerce-extended? typ)
  (check-symbol 'coerce-extended? typ)
  (->boolean (typdef/type typ)) )

(define (coerce-extend! typ pred #!optional (proc identity))
  (check-symbol 'extend-coerce typ)
  (check-procedure 'extend-coerce pred)
  (check-procedure 'extend-coerce proc)
  (typdef-add! typ pred proc) )

(define (coerce-extension typ)
  (check-symbol 'coerce-extension typ)
  (if* (typdef/type typ) (values (typdef-pred it) (typdef-proc it))
       (values #f #f) ) )

(define (coerce-composite-extension! typ pred #!optional (proc identity))
  (check-symbol 'extend-coerce typ)
  (check-procedure 'extend-coerce pred)
  (check-procedure 'extend-coerce proc)
  (if* (typdef/type typ)
       ;then update old
       (let ((old-pred (typdef-pred it))
             (old-proc (typdef-proc it)) )
          ; don't replace when same
          (unless (and (eq? pred old-pred) (eq? proc old-proc))
            (let ((pred (if (eq? pred old-pred) pred (composite-pred pred old-pred)))
                  (proc (if (eq? proc old-proc) proc (composite-proc proc old-proc))) )
              (typdef-add! typ pred proc) ) ) )
       ;else create new
       (typdef-add! typ pred proc) ) )

(define (coerce-extension-remove! typ)
  (check-symbol 'remove-coerce-extension typ)
  (typdef-delete! typ) )

(define type-of-extended? coerce-extended?)
(define type-of-extend! coerce-extend!)
(define type-of-extension coerce-extension)
(define type-of-composite-extension! coerce-composite-extension!)
(define type-of-remove! coerce-extension-remove!)

) ;module type-of