;;; 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 . (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")) )