;;
;; Copyright (c) 2006, John P. T. Moore
;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without 
;; modification, are permitted provided that the following conditions are met:
;;
;; 1. Redistributions of source code must retain the above copyright notice, 
;;    this list of conditions and the following disclaimer.
;;
;; 2. Redistributions in binary form must reproduce the above copyright notice, 
;;    this list of conditions and the following disclaimer in the documentation 
;;    and/or other materials provided with the distribution.
;;
;; 3. Neither the decode:name of the author nor the names of its contributors may be 
;;    used to endorse or promote products derived from this software 
;;    without specific prior written permission.
;;
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 
;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 
;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 
;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE 
;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 
;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 
;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 
;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 
;; POSSIBILITY OF SUCH DAMAGE.
;;

;; foreign functions
(define c-decode-boolean
  (foreign-lambda bool "decodeBoolean" (c-pointer packed-decode)))

(define c-decode-semi-constrained-string
    (foreign-lambda c-string "decodeSemiConstrainedString" (c-pointer packed-decode) c-string))

(define c-decode-constrained-string
    (foreign-lambda c-string "decodeConstrainedString" (c-pointer packed-decode) c-string integer integer))

(define c-decode-fixed-length-string
    (foreign-lambda c-string "decodeFixedLengthString" (c-pointer packed-decode) c-string integer))
	
(define c-decode-unconstrained-integer
    (foreign-lambda integer "decodeUnconstrainedInteger" (c-pointer packed-decode)))

(define c-decode-unsigned-constrained-integer
    (foreign-lambda unsigned-integer "decodeUnsignedConstrainedInteger" (c-pointer packed-decode) unsigned-integer unsigned-integer))

(define c-decode-signed-constrained-integer
    (foreign-lambda integer "decodeSignedConstrainedInteger" (c-pointer packed-decode) integer integer))

(define c-decode-signed-semi-constrained-integer
    (foreign-lambda integer "decodeSignedSemiConstrainedInteger" (c-pointer packed-decode) integer))

(define c-decode-unsigned-semi-constrained-integer
    (foreign-lambda unsigned-integer "decodeUnsignedSemiConstrainedInteger" (c-pointer packed-decode) unsigned-integer))

(define c-decode-fixed-length-hex-string
  (foreign-lambda c-string "decodeFixedLengthHexString" (c-pointer packed-decode) c-string integer))

(define c-decode-constrained-hex-string
  (foreign-lambda c-string "decodeConstrainedHexString" (c-pointer packed-decode) c-string integer integer))

(define c-decode-semi-constrained-hex-string
  (foreign-lambda c-string "decodeSemiConstrainedHexString" (c-pointer packed-decode) c-string))

(define c-decode-fixed-length-numeric-string
  (foreign-lambda c-string "decodeFixedLengthNumericString" (c-pointer packed-decode) c-string integer))

(define c-decode-constrained-numeric-string
  (foreign-lambda c-string "decodeConstrainedNumericString" (c-pointer packed-decode) c-string integer integer))

(define c-decode-semi-constrained-numeric-string
  (foreign-lambda c-string "decodeSemiConstrainedNumericString" (c-pointer packed-decode) c-string))

(define c-decode-fixed-length-bit-string
  (foreign-lambda c-string "decodeFixedLengthBitString" (c-pointer packed-decode) c-string integer))

(define c-decode-constrained-bit-string
  (foreign-lambda c-string "decodeConstrainedBitString" (c-pointer packed-decode) c-string integer integer))

(define c-decode-semi-constrained-bit-string
  (foreign-lambda c-string "decodeSemiConstrainedBitString" (c-pointer packed-decode) c-string))

(define c-decode-fixed-length-octet-string
  (foreign-lambda c-string "decodeFixedLengthOctetString" (c-pointer packed-decode) c-string integer))

(define c-decode-constrained-octet-string
  (foreign-lambda c-string "decodeConstrainedOctetString" (c-pointer packed-decode) c-string integer integer))

(define c-decode-semi-constrained-octet-string
  (foreign-lambda c-string "decodeSemiConstrainedOctetString" (c-pointer packed-decode) c-string))

(define c-decode-enumerated
  (foreign-lambda unsigned-integer "decodeEnumerated" (c-pointer packed-decode) unsigned-integer))

(define c-decode-set-bitmap
  (foreign-lambda c-string "decodeSetBitmap" (c-pointer packed-decode) c-string integer))
	
(define c-decode-choice-index
  (foreign-lambda unsigned-integer "decodeChoiceIndex" (c-pointer packed-decode) unsigned-integer))
	
(define c-decode-sequence-of-length
  (foreign-lambda integer "decodeSequenceOfLength" (c-pointer packed-decode)))

;;; end foreign interface

(define decode:datatype cadr)
(define decode:name car)
(define decode:constraint caddr)

(define (po:decode t p s)

  (define (decode-simple-type)
    
    (define (decode-integer)
      (let* ( (range (decode:constraint t)) (type (po:check-integer range)) )
        (case type
          ('unconstrained
           (list (decode:name t) (c-decode-unconstrained-integer p)))
          ('unsigned-semi-constrained
           (list (decode:name t) (c-decode-unsigned-semi-constrained-integer p (constraints:lb range))))
          ('unsigned-constrained
           (list (decode:name t) (c-decode-unsigned-constrained-integer p (constraints:lb range) (constraints:ub range))))
          ('signed-semi-constrained
           (list (decode:name t) (c-decode-signed-semi-constrained-integer p (constraints:lb range))))
          ('signed-constrained
           (list (decode:name t) (c-decode-signed-constrained-integer p (constraints:lb range) (constraints:ub range)))))))

    (define (decode-string)
      (let* ( (size (decode:constraint t)) (type (po:check-string size)) )
        (case type
	('semi-constrained
         (list (decode:name t) (c-decode-semi-constrained-string p s)))
        ('fixed-length
         (list (decode:name t) (c-decode-fixed-length-string p s (constraints:lb size))))
        ('constrained
         (let ((lbv (constraints:lb size)))
           (list (decode:name t) (c-decode-constrained-string p s (if (eq? lbv 'min) 0 lbv) (constraints:ub size))))))))

    (define (decode-octet-string)
      (let* ( (size (decode:constraint t)) (type (po:check-string size)) )
        (case type
          ('semi-constrained
           (list (decode:name t) (c-decode-semi-constrained-octet-string p s)))
          ('fixed-length
           (list (decode:name t) (c-decode-fixed-length-octet-string p s (constraints:lb size))))
          ('constrained
           (let ((lbv (constraints:lb size)))
             (list (decode:name t) (c-decode-constrained-octet-string p s (if (eq? lbv 'min) 0 lbv) (constraints:ub size))))))))

    (define (decode-hex-string)
      (let* ( (size (decode:constraint t)) (type (po:check-string size)) )
        (case type
          ('semi-constrained
           (list (decode:name t) (c-decode-semi-constrained-hex-string p s)))
          ('fixed-length
           (list (decode:name t) (c-decode-fixed-length-hex-string p s (constraints:lb size))))
          ('constrained
           (let ((lbv (constraints:lb size)))
             (list (decode:name t) (c-decode-constrained-hex-string p s (if (eq? lbv 'min) 0 lbv) (constraints:ub size))))))))

    (define (decode-numeric-string)
      (let* ( (size (decode:constraint t)) (type (po:check-string size)) )
        (case type
          ('semi-constrained
           (list (decode:name t) (c-decode-semi-constrained-numeric-string p s)))
          ('fixed-length
           (list (decode:name t) (c-decode-fixed-length-numeric-string p s (constraints:lb size))))
          ('constrained
           (let ((lbv (constraints:lb size)))
             (list (decode:name t) (c-decode-constrained-numeric-string p s (if (eq? lbv 'min) 0 lbv) (constraints:ub size))))))))
    
    (define (decode-bit-string)
      (let* ( (size (decode:constraint t)) (type (po:check-string size)) )
        (case type
          ('semi-constrained
           (list (decode:name t) (c-decode-semi-constrained-bit-string p s)))
          ('fixed-length
           (list (decode:name t) (c-decode-fixed-length-bit-string p s (constraints:lb size))))
          ('constrained
           (let ((lbv (constraints:lb size)))
             (list (decode:name t) (c-decode-constrained-bit-string p s (if (eq? lbv 'min) 0 lbv) (constraints:ub size))))))))

    (define (decode-boolean)
      (list (decode:name t) (c-decode-boolean p)))

    (define (decode-enumerated)
      (list (decode:name t) (list-ref (caddr t) (c-decode-enumerated p (length (caddr t))))))

    (define (decode-null)
      (list (decode:name t)))
    
    (let ((type (decode:datatype t)))
      (case type
        ('integer
         (decode-integer))
        ('boolean
         (decode-boolean))
        ('octet-string
         (decode-octet-string))
        ('hex-string
         (decode-hex-string))
        ('numeric-string
         (decode-numeric-string))
        ('bit-string
         (decode-bit-string))
        ('enumerated
         (decode-enumerated))
        ('null
         (decode-null))
        ('string
         (decode-string)))))
               
  (define (decode-complex-type)
  
    (define (decode-choice)
      (let ((index (c-decode-choice-index p (length (cddr t)))))
        (cons
         (car t)
         (list (po:decode (list-ref (cddr t) (- index 1)) p s)))))

    (define (recur-sequence seq)
      (cond ((null? seq) '())
            (else
             (cons
              (po:decode (car seq) p s)
              (recur-sequence (cdr seq)))))) 

    (define (decode-sequence-of)      
      (define (recur-sequence-of n)
	 (cond ((< n 1) '())
	       (else
		(cons
                 (recur-sequence (cddr t))
                 (recur-sequence-of (- n 1))))))
      (let ((length (c-decode-sequence-of-length p)))
        (cons (car t) (recur-sequence-of length))))
    
    
    (define (decode-sequence)
      (cons (car t) (recur-sequence (cddr t))))

    (define (decode-set)
      (define (recur-set seq bitmap)
        (cond ((null? seq) '())
              (else
               (cond ((eq? (first-string bitmap) #\0)
                      (recur-set (cdr seq) (rest-string bitmap)))
                     (else 
                      (cons
                       (po:decode (car seq) p s) 
                       (recur-set (cdr seq) (rest-string bitmap))))))))
      (let* ((bitmap-len (length (cddr t)))
             (bitmap (c-decode-set-bitmap p s bitmap-len)))
        (cons (car t) (recur-set (cddr t) bitmap))))   
    
    (let ((type (decode:datatype t)))
      (case type
        ('choice
         (decode-choice))
        ('sequence
          (decode-sequence))
        ('set
         (decode-set))
        ('sequence-of
         (decode-sequence-of)))))
  
  (if (memq (decode:datatype t) '(sequence choice sequence-of set))
      (decode-complex-type)
      (decode-simple-type)))