#|-------------------- 1.1.1 |# "./coerce.setup" 917
;;;; "coerce.setup  -*- Hen -*-

(include "setup-helper")

(verify-extension-name "coerce")

(required-extension-version
  "lookup-table"              "1.11.0"
  "check-errors"              "1.5.0")

(setup-shared-extension-module 'type-extend-support (extension-version "1.1.1")
  #:compile-options '(-optimize-level 3 -debug-level 0
                      -fixnum-arithmetic
                      -no-procedure-checks -no-bound-checks -no-argc-checks))

(setup-shared-extension-module 'type-of (extension-version "1.1.1")
  #:compile-options '(-optimize-level 3
                      -fixnum-arithmetic
                      -no-procedure-checks))

(setup-shared-extension-module 'type-coerce (extension-version "1.1.1")
  #:compile-options '(-optimize-level 3
                      -fixnum-arithmetic
                      -no-procedure-checks))

(setup-shared-extension-module 'coerce (extension-version "1.1.1"))

#|-------------------- 1.1.1 |# "./coerce.meta" 475
;;;; coerce.meta  -*- Hen -*-

((egg "coerce.egg")
 (category data)
 (author "Aubrey Jaffer, for Chicken by [[kon lovett]]")
 (license "BSD")
 (doc-from-wiki)
 (synopsis "Type Identity & Coercion")
 (depends
  (setup-helper "1.2.0")
  (miscmacros "2.91")
	(lookup-table "1.11.0")
	(check-errors "1.5.0"))
 (test-depends test)
 (files "type-of.scm" "coerce.scm" "coerce.release-info" "type-coerce.scm" "coerce.meta" "coerce.setup" "type-extend-support.scm" "tests/run.scm") )

#|-------------------- 1.1.1 |# "./coerce.scm" 655
;;;; coerce.scm
;;;; Kon Lovett, Sep '09

;; Originally from "The SLIB Portable Scheme Library" by Aubrey Jaffer.

(module coerce

  (;export
    ;; Original
    coerce
    type-of
    ;; Coerce Extensions
    (case-coerce *make-case-coerce)
    case-coerce
    coerce-all
    ;; Type Domain Extension
    coerce-extended?
    coerce-extend!
    coerce-extension
    coerce-composite-extension!
    coerce-extension-remove!
    ;;
    type-of-extended?
    type-of-extend!
    type-of-extension
    type-of-composite-extension!
    type-of-remove!)

  (import scheme chicken type-coerce type-of)

  (require-library type-coerce type-of)

) ;module coerce

#|-------------------- 1.1.1 |# "./type-extend-support.scm" 879
;;;; type-extend-support.scm
;;;; Kon Lovett, Sep '09

(module type-extend-support (;export
  typdef-type
  typdef-pred
  typdef-proc
  typdef-add!
  typdef-delete!
  typdef/object
  typdef/type)

  (import scheme chicken lookup-table-synch)

  (require-library lookup-table-synch)

;;;

(define (make-typdef typ pred proc) (vector typ pred proc))
(define (typdef-type ti) (vector-ref ti 0))
(define (typdef-pred ti) (vector-ref ti 1))
(define (typdef-proc ti) (vector-ref ti 2))

;;;

(define +typdefs+ (make-dict/synch eq? 0))

(define (typdef-add! typ pred proc) (dict-set!/synch +typdefs+ typ (make-typdef typ pred proc)))
(define (typdef-delete! typ) (dict-delete!/synch +typdefs+ typ))
(define (typdef/object obj) (dict-search/synch +typdefs+ (lambda (t ti) ((typdef-pred ti) obj))))
(define (typdef/type typ) (dict-ref/synch +typdefs+ typ))

) ;module type-extend-support

#|-------------------- 1.1.1 |# "./type-coerce.scm" 10559
;;;; type-coerce.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.

;; Issues
;;
;; - Cannot know before attempt if coercion possible.
;;
;; - The coercion of a composite object to a scalar often makes little sense.
;;
;; - The coercion of a scalar object to a composite is usually just to
;; box the object with the specified composite.

(module type-coerce (;export
  make-case-coerce
  (case-coerce *make-case-coerce) *make-case-coerce
  coerce
  coerce-all)

#|
  (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 chicken
          (only data-structures alist-ref)
          (only srfi-1 every reverse!)
          (only miscmacros if*)
          (only type-checks check-procedure check-symbol check-list check-alist)
          (only type-errors signal-type-error)
          type-of)

  (require-library data-structures srfi-1
                   miscmacros type-checks type-errors type-of)

;;;

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

(define (string->vector x) (list->vector (string->list x)))
(define (vector->string x) (list->string (vector->list x)))

;;; Extension

(define ((*make-case-coerce func al) obj typ err)
  (func obj typ (lambda () (if* (alist-ref typ al eq?) (it obj) (err)))) )

;;

(define (make-case-coerce func #!optional (al '()))
  (check-procedure 'make-case-coerce func 'func)
  (check-alist 'make-case-coerce al 'alist)
  (*make-case-coerce func al) )

;;

(define-syntax case-coerce
  (er-macro-transformer
    (lambda (frm rnm cmp)
      (let ((_lambda (rnm 'lambda))
            (_case (rnm 'case))
            (_else (rnm 'else))
            (_*make-case-coerce (rnm '*make-case-coerce))
            (_typ (rnm 'typ)) )
        (let ((else-clause `(,_else (on-error))))
          (let loop ((clauses (cdr frm)) (sym-clauses '()))
            (if (null? clauses)
                `(,_*make-case-coerce
                   (,_lambda (object ,_typ on-error)
                     (,_case ,_typ ,@(reverse! sym-clauses) ,else-clause))
                   '())
                (let* ((clause (car clauses))
                       (rest (cdr clauses))
                       (tst (car clause))
                       (bdy (cdr clause)) )
                  (##sys#check-syntax 'case-coerce bdy '#(_ 1))
                  (cond ((and (symbol? tst) (cmp tst _else))
                          (set! else-clause clause)
                          (loop rest sym-clauses) )
                        (else
                          (##sys#check-syntax 'case-coerce tst '#(symbol 1))
                          (loop rest (cons clause sym-clauses)) ) ) ) ) ) ) ) ) ) )

;;@body
;;Converts and returns @1 of type @code{char}, @code{number},
;;@code{string}, @code{symbol}, @code{list}, or @code{vector} to
;;@2 (which must be one of these symbols).

(define (error-coerce obj restyp) (error 'coerce "cannot coerce" obj restyp))

(define (coerce obj restyp #!optional (default-proc error-coerce))
  (define (other->other) (other-coerce obj restyp default-proc))
  (check-symbol 'coerce restyp 'result-type)
  (when default-proc (check-procedure 'coerce default-proc 'default-proc))
  (let ((objtyp (type-of obj)))
    (cond ((eq? objtyp restyp)    obj )
          ((eq? 'boolean restyp)  (->boolean obj) )
          (else
            (case objtyp
              ((boolean)
                (case restyp
                  ((atom)     obj )
                  ((number integer)
                    (if obj 1 0) )
                  ((string)   (if obj "true" "false") )
                  ((keyword)  (string->keyword (if obj "true" "false")) )
                  ((symbol)   (string->symbol (if obj "true" "false")) )
                  ((list)     (list obj) )
                  ((vector)   (vector obj) )
                  (else       (other->other) ) ) )
              ((char)
                (case restyp
                  ((atom)     obj )
                  ((number integer)
                    (char->integer obj) )
                  ((string)   (string obj) )
                  ((keyword)  (string->keyword (number->string obj)) )
                  ((symbol)   (string->symbol (number->string obj)) )
                  ((list)     (list obj) )
                  ((vector)   (vector obj) )
                  (else       (other->other) ) ) )
              ((number)
                (case restyp
                  ((atom)     obj )
                  ((char)     (integer->char obj) )
                  ((integer)  (inexact->exact obj) )
                  ((string)   (number->string obj) )
                  ((keyword)  (string->keyword (number->string obj)) )
                  ((symbol)   (string->symbol (number->string obj)) )
                  ((list)     (string->list (number->string obj)) )
                  ((vector)   (string->vector (number->string obj)) )
                  (else       (other->other) ) ) )
              ((keyword) 
                (case restyp
                  ((atom)     obj )
                  ((char)     (coerce (keyword->string obj) 'char) )
                  ((number integer)
                    (coerce (keyword->string obj) restyp) )
                  ((string)   (keyword->string obj) )
                  ((symbol)   (string->symbol (keyword->string obj)) )
                  ((list)     (string->list (keyword->string obj)) )
                  ((vector)   (string->vector (keyword->string obj)) )
                  (else       (other->other) ) ) )
              ((symbol)
                (case restyp
                  ((atom)     obj )
                  ((char)     (coerce (symbol->string obj) 'char) )
                  ((number integer)
                    (coerce (symbol->string obj) restyp) )
                  ((string)   (symbol->string obj) )
                  ((keyword)  (string->keyword (symbol->string obj)) )
                  ((list)     (string->list (symbol->string obj)) )
                  ((vector)   (string->vector (symbol->string obj)) )
                  (else       (other->other) ) ) )
              ((string)
                (case restyp
                  ((atom)     (or (string->number obj) (string->symbol obj)) )
                  ((char)
                    (if (= 1 (string-length obj)) (string-ref obj 0)
                        (other->other)))
                  ((number integer)
                    (or (string->number obj)
                        (other->other)) )
                  ((keyword)  (string->keyword obj) )
                  ((symbol)   (string->symbol obj) )
                  ((list)     (string->list obj) )
                  ((vector)   (string->vector obj) )
                  ((blob)     (string->blob obj) )
                  (else       (other->other) ) ) )
              ((list)
                (case restyp
                  ((atom)     (coerce (list->string obj) 'atom) )
                  ((char)
                    (if (and (= 1 (length obj)) (char? (car obj)))
                        (car obj)
                        (other->other)) )
                  ((number integer)
                   (or (string->number (list->string obj))
                       (other->other)) )
                  ((string)   (list->string obj) )
                  ((keyword)  (string->keyword (list->string obj)) )
                  ((symbol)   (string->symbol (list->string obj)) )
                  ((vector)   (list->vector obj) )
                  (else       (other->other) ) ) )
              ((vector)
                (case restyp
                  ((atom)     (coerce (vector->string obj) 'atom) )
                  ((char)
                    (if (and (= 1 (vector-length obj)) (char? (vector-ref obj 0)))
                        (vector-ref obj 0)
                        (other->other)) )
                  ((number integer )
                    (or (string->number (coerce obj 'string))
                        (other->other)) )
                  ((string)   (vector->string obj) )
                  ((keyword)  (string->keyword (vector->string obj)) )
                  ((symbol)   (string->symbol (vector->string obj)) )
                  ((list)     (vector->list obj) )
                  (else       (other->other) ) ) )
              ((blob)
                (case restyp
                  ((string)   (blob->string obj))
                  (else       (other->other) ) ) )
              (else
                (other->other) ) ) ) ) ) )

;;

(define (coerce-all flst tlst #!optional default-proc)
  (check-list 'coerce-all flst "objects")
  (check-list 'coerce-all tlst "types")
  #; ;NOT NEEDED
  (unless (= (length flst) (length tlst))
    (signal-type-error 'coerce-all "list length mismatch" flst tlst) )
  (map (cut coerce <> <> default-proc) flst tlst) )

) ;module type-coerce

#|-------------------- 1.1.1 |# "./type-of.scm" 6587
;;;; 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
                pointer? tagged-pointer? locative?)
          (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)
        #;((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)                 'undefined)
        (else
          (or (other-type-of obj)
              '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 obj result-type)) )

(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