;;; Ikarus Scheme -- A compiler for R6RS Scheme.
;;; Copyright (C) 2008,2009  Abdulaziz Ghuloum
;;; 
;;; This program is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License version 3 as
;;; published by the Free Software Foundation.
;;; 
;;; This program is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; General Public License for more details.
;;; 
;;; You should have received a copy of the GNU General Public License
;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.



(library (ikarus.pointers)
  (export pointer? integer->pointer pointer->integer 
          dlopen dlerror dlclose dlsym malloc free memcpy
          errno
          pointer-ref-c-signed-char 
          pointer-ref-c-signed-short
          pointer-ref-c-signed-int 
          pointer-ref-c-signed-long
          pointer-ref-c-signed-long-long
          pointer-ref-c-unsigned-char
          pointer-ref-c-unsigned-short 
          pointer-ref-c-unsigned-int 
          pointer-ref-c-unsigned-long
          pointer-ref-c-unsigned-long-long
          pointer-ref-c-float
          pointer-ref-c-double
          pointer-ref-c-pointer
          pointer-set-c-char!
          pointer-set-c-short!
          pointer-set-c-int!
          pointer-set-c-long!
          pointer-set-c-long-long!
          pointer-set-c-pointer!
          pointer-set-c-float!
          pointer-set-c-double! 
          make-c-callout make-c-callback)
  (import 
    (except (ikarus) 
      pointer? 
      integer->pointer pointer->integer
      dlopen dlerror dlclose dlsym malloc free memcpy))

  ;;; pointer manipulation procedures 

  (define (pointer? x)
    (foreign-call "ikrt_isapointer" x))

  (define (integer->pointer x)
    (cond
      [(fixnum? x) 
       (foreign-call "ikrt_fx_to_pointer" x)]
      [(bignum? x)
       (foreign-call "ikrt_bn_to_pointer" x)]
      [else 
       (die 'integer->pointer "not an integer" x)]))

  (define (pointer->integer x)
    (cond
      [(pointer? x) 
       (foreign-call "ikrt_pointer_to_int" x)]
      [else 
       (die 'pointer->integer "not a pointer" x)]))

  ;;; dynamic loading procedures 

  (define dlerror 
    (lambda ()
      (let ([p (foreign-call "ikrt_dlerror")])
        (and p (utf8->string p)))))

  (define dlopen 
    (let ()
      (define (open x lazy? global?)
        (foreign-call "ikrt_dlopen" x lazy? global?))
      (case-lambda 
        [()  
         (open #f #f #f)]
        [(x)
         (dlopen x #f #f)]
        [(x lazy? global?)
         (cond
           [(string? x) (open (string->utf8 x) lazy? global?)]
           [else (die 'dlopen "library name must be a string" x)])])))

  (define dlclose
    (lambda (x)
      (if (pointer? x)
          (foreign-call "ikrt_dlclose" x)
          (die 'dlclose "not a pointer" x))))

  (define dlsym
    (lambda (handle name)
      (define who 'dlsym)
      (if (pointer? handle)
          (if (string? name) 
              (foreign-call "ikrt_dlsym" handle (string->utf8 name))
              (die who "invalid symbol name" name))
          (die who "handle is not a pointer" handle))))

  ;;; explicit memory management

  (define (malloc len) 
    (if (and (fixnum? len) (fx>? len 0))
        (foreign-call "ikrt_malloc" len)
        (die 'malloc "not a positive fixnum" len)))

  (define (free x)
    (if (pointer? x)
        (foreign-call "ikrt_free" x)
        (die 'free "not a pointer" x)))

  (define (pointer+ ptr off)
    (integer->pointer (+ (pointer->integer ptr) off)))

  
  (define (memcpy dst dst-offset src src-offset count)
    (define who 'memcpy)
    (unless (and (fixnum? dst-offset) (fx>=? dst-offset 0))
      (die who "not a positive fixnum" dst-offset))
    (unless (and (fixnum? src-offset) (fx>=? src-offset 0))
      (die who "not a positive fixnum" src-offset))
    (unless (and (fixnum? count) (fx>=? count 0))
      (die who "not a postive fixnum" count))
    (cond ((and (pointer? dst) (bytevector? src))
           (unless (fx<=? (fx+ src-offset count) (bytevector-length src))
             (die who "source bytevector length exceeded"
                  (bytevector-length src) src-offset count))
           (foreign-call "ikrt_memcpy_from_bv"
                         (pointer+ dst dst-offset) src src-offset count))
          ((and (bytevector? dst) (pointer? src))
           (unless (fx<=? (fx+ dst-offset count) (bytevector-length dst))
             (die who "destination bytevector length exceeded"
                  (bytevector-length dst) dst-offset count))
           (foreign-call "ikrt_memcpy_to_bv"
                         dst dst-offset (pointer+ src src-offset) count))
          (else
           (die who "destination and source not a bytevector/pointer pair"
                dst dst))))

  ;;; getters and setters

  (define-syntax define-getter
    (syntax-rules ()
      [(_ name foreign-name) 
       (define name
         (lambda (p i)
           (if (pointer? p)
               (if (fixnum? i)
                   (foreign-call foreign-name p i)
                   (die 'name "index is not a fixnum" i))
               (die 'name "not a pointer" p))))]))

  (define-syntax define-setter
    (syntax-rules ()
      [(_ name pred? foreign-name) 
       (define name
         (lambda (p i v)
           (if (pointer? p)
               (if (fixnum? i)
                   (if (pred? v)
                       (foreign-call foreign-name p i v)
                       (die 'name 
                          (format "value must satisfy the predicate ~a" 'pred?)
                          v))
                   (die 'name "index is not a fixnum" i))
               (die 'name "not a pointer" p))))]))

  (define (int? x) (or (fixnum? x) (bignum? x)))

  (define-getter pointer-ref-c-signed-char        "ikrt_ref_char")
  (define-getter pointer-ref-c-signed-short       "ikrt_ref_short")
  (define-getter pointer-ref-c-signed-int         "ikrt_ref_int")
  (define-getter pointer-ref-c-signed-long        "ikrt_ref_long")
  (define-getter pointer-ref-c-signed-long-long   "ikrt_ref_longlong")
  (define-getter pointer-ref-c-unsigned-char      "ikrt_ref_uchar")
  (define-getter pointer-ref-c-unsigned-short     "ikrt_ref_ushort")
  (define-getter pointer-ref-c-unsigned-int       "ikrt_ref_uint")
  (define-getter pointer-ref-c-unsigned-long      "ikrt_ref_ulong")
  (define-getter pointer-ref-c-unsigned-long-long "ikrt_ref_ulonglong")
  (define-getter pointer-ref-c-float              "ikrt_ref_float")
  (define-getter pointer-ref-c-double             "ikrt_ref_double")
  (define-getter pointer-ref-c-pointer            "ikrt_ref_pointer")

  (define-setter pointer-set-c-char!      int?     "ikrt_set_char")
  (define-setter pointer-set-c-short!     int?     "ikrt_set_short")
  (define-setter pointer-set-c-int!       int?     "ikrt_set_int")
  (define-setter pointer-set-c-long!      int?     "ikrt_set_long")
  (define-setter pointer-set-c-long-long! int?     "ikrt_set_longlong")
  (define-setter pointer-set-c-float!     flonum?  "ikrt_set_float")
  (define-setter pointer-set-c-double!    flonum?  "ikrt_set_double")
  (define-setter pointer-set-c-pointer!   pointer? "ikrt_set_pointer")

  ;;; libffi interface

  (define (checker who)
    (define (checker t)
      (cond
        [(vector? t)
         (let ([t* (vector-map checker t)])
           (lambda (v)
             (and (vector? v)
                  (let ([n (vector-length v)])
                    (and (= n (vector-length t))
                         (let f ([i 0])
                           (or (= i n)
                               (and ((vector-ref t* i) (vector-ref v i))
                                    (f (+ i 1))))))))))]
        [else
         (case t
           [(unsigned-char)      int?]
           [(signed-char)        int?]
           [(unsigned-short)     int?]
           [(signed-short)       int?]
           [(unsigned-int)       int?]
           [(signed-int)         int?]
           [(unsigned-long)      int?]
           [(signed-long)        int?]
           [(unsigned-long-long) int?]
           [(signed-long-long)   int?]
           [(float)              flonum?]
           [(double)             flonum?]
           [(pointer)            pointer?]
           [else (die who "invalid type" t)])]))
    checker)
 


  (define (ffi-prep-cif who rtype argtypes)
    (define (convert x)
      (cond
        [(vector? x) (vector-map convert x)]
        [else
         (case x 
           [(void)                1]
           [(unsigned-char)       2]
           [(signed-char)         3]
           [(unsigned-short)      4]
           [(signed-short)        5]
           [(unsigned-int)        6]
           [(signed-int)          7]
           [(unsigned-long)       8]
           [(signed-long)         9]
           [(unsigned-long-long) 10]
           [(signed-long-long)   11]
           [(float)              12]
           [(double)             13]
           [(pointer)            14]
           [else (die who "invalid type" x)])]))
    (unless (list? argtypes)
      (die who "arg types is not a list" argtypes))
    (let ([argtypes-n (vector-map convert (list->vector argtypes))]
          [rtype-n (convert rtype)])
      (values (or (foreign-call "ikrt_ffi_prep_cif" rtype-n argtypes-n)
                  (if (ffi-enabled?)
                      (die who "failed to initialize" rtype argtypes)
                      (die who "FFI support is not enabled.  \
                                You need to recompile ikarus with \
                                --enable-libffi option set in order \
                                to make use of the (ikarus foreign) \
                                library.")))
              argtypes-n
              rtype-n)))

  (define (make-c-callout rtype argtypes)
    (define who 'make-c-callout)
    (let-values ([(cif argtypes-n rtype-n)
                  (ffi-prep-cif who rtype argtypes)])
      (let* ([argtypes-vec (list->vector argtypes)]
             [checkers (vector-map (checker who) argtypes-vec)])
        (lambda (cfun)
          (define data (vector cif cfun argtypes-n rtype-n))
          (unless (pointer? cfun)
            (die who "not a pointer" cfun))
          (lambda args
            (let ([argsvec (list->vector args)])
              (unless (= (vector-length argsvec) 
                         (vector-length argtypes-vec))
                (error 'callout-procedure "arg length mismatch" 
                       (vector->list argtypes-vec)
                       args))
              (vector-for-each
                (lambda (p? t x)
                  (unless (p? x)
                    (die 'callout-procedure 
                         (format "argument does not match type ~a" t)
                         x)))
                checkers argtypes-vec argsvec)
              (foreign-call "ikrt_ffi_call" data argsvec)))))))

  (define (make-c-callback rtype argtypes)
    (define who 'make-c-callback)
    (let-values ([(cif argtypes-n rtype-n)
                  (ffi-prep-cif who rtype argtypes)])
      (lambda (proc)
        (unless (procedure? proc)
          (die who "not a procedure"))
        (let ([proc 
               (cond
                 [(eq? rtype 'void) proc]
                 [else
                  (let ([p? ((checker who) rtype)])
                    (lambda args 
                      (let ([v (apply proc args)])
                        (unless (p? v)
                          (die 'callback
                             (format "returned value does not match type ~a"
                                     rtype)
                             v))
                        v)))])])
          (let ([data (vector cif proc argtypes-n rtype-n)])
            (or (foreign-call "ikrt_prepare_callback" data)
                (die who "cannot prepare foreign callback")))))))
  
  (define (ffi-enabled?) 
    (foreign-call "ikrt_has_ffi"))

  (define (errno)
    (foreign-call "ikrt_last_errno"))

  )


 
