Managed to a simple Ikarus -> Objective-C interface to work. Ikarus
can now open a Cocoa window under Mac OS X. Happy Happy Joy Joy!!
This commit is contained in:
Abdulaziz Ghuloum
parent
89d9a472a5
commit
8c30f0715b
|
|
@ -0,0 +1,203 @@
|
|||
;;;
|
||||
;;;; Simple calculator in Scheme
|
||||
;;;
|
||||
;;
|
||||
;; @created "Tue Jan 6 12:47:23 2004"
|
||||
;; @modified "Mon Oct 25 11:07:24 2004"
|
||||
;; @author "Dominique Boucher"
|
||||
;; @copyright "Dominique Boucher"
|
||||
;;
|
||||
;; Simple arithmetic calculator.
|
||||
;;
|
||||
;; This program illustrates the use of the lalr-scm parser generator
|
||||
;; for Scheme. It is NOT robust, since calling a function with
|
||||
;; the wrong number of arguments may generate an error that will
|
||||
;; cause the calculator to crash.
|
||||
|
||||
|
||||
;;;
|
||||
;;;; The LALR(1) parser
|
||||
;;;
|
||||
|
||||
|
||||
(import (rnrs) (rnrs mutable-pairs) (lalr))
|
||||
|
||||
(define calc-parser
|
||||
(lalr-parser
|
||||
|
||||
;; --- Options
|
||||
;; output a parser, called calc-parser, in a separate file - calc.yy.scm,
|
||||
;(output: calc-parser "calc.yy.scm")
|
||||
;; output the LALR table to calc.out
|
||||
;(out-table: "calc.out")
|
||||
;; there should be no conflict
|
||||
(expect: 0)
|
||||
|
||||
;; --- token definitions
|
||||
(ID NUM = LPAREN RPAREN NEWLINE COMMA
|
||||
(left: + -)
|
||||
(left: * /)
|
||||
(nonassoc: uminus))
|
||||
|
||||
(lines (lines line) : (display-result $2)
|
||||
(line) : (display-result $1))
|
||||
|
||||
|
||||
;; --- rules
|
||||
(line (assign NEWLINE) : $1
|
||||
(expr NEWLINE) : $1
|
||||
(error NEWLINE) : #f)
|
||||
|
||||
(assign (ID = expr) : (add-binding $1 $3))
|
||||
|
||||
(expr (expr + expr) : (+ $1 $3)
|
||||
(expr - expr) : (- $1 $3)
|
||||
(expr * expr) : (* $1 $3)
|
||||
(expr / expr) : (/ $1 $3)
|
||||
(- expr (prec: uminus)) : (- $2)
|
||||
(ID) : (get-binding $1)
|
||||
(ID LPAREN args RPAREN) : (invoke-proc $1 $3)
|
||||
(NUM) : $1
|
||||
(LPAREN expr RPAREN) : $2)
|
||||
|
||||
(args () : '()
|
||||
(expr arg-rest) : (cons $1 $2))
|
||||
|
||||
(arg-rest (COMMA expr arg-rest) : (cons $2 $3)
|
||||
() : '())))
|
||||
|
||||
|
||||
(define (display-result v)
|
||||
(if v
|
||||
(begin
|
||||
(display "==> ")
|
||||
(display v)
|
||||
(newline))))
|
||||
|
||||
|
||||
;;;
|
||||
;;;; The lexer
|
||||
;;;
|
||||
|
||||
|
||||
(define (make-lexer errorp)
|
||||
(lambda ()
|
||||
(letrec ((skip-spaces
|
||||
(lambda ()
|
||||
(let loop ((c (peek-char)))
|
||||
(if (and (not (eof-object? c))
|
||||
(or (char=? c #\space) (char=? c #\tab)))
|
||||
(begin
|
||||
(read-char)
|
||||
(loop (peek-char)))))))
|
||||
(read-number
|
||||
(lambda (l)
|
||||
(let ((c (peek-char)))
|
||||
(if (char-numeric? c)
|
||||
(read-number (cons (read-char) l))
|
||||
(string->number (apply string (reverse l)))))))
|
||||
(read-id
|
||||
(lambda (l)
|
||||
(let ((c (peek-char)))
|
||||
(if (char-alphabetic? c)
|
||||
(read-id (cons (read-char) l))
|
||||
(string->symbol (apply string (reverse l))))))))
|
||||
|
||||
;; -- skip spaces
|
||||
(skip-spaces)
|
||||
;; -- read the next token
|
||||
(let loop ((c (read-char)))
|
||||
(cond
|
||||
((eof-object? c) '*eoi*)
|
||||
((char=? c #\newline) 'NEWLINE)
|
||||
((char=? c #\+) '+)
|
||||
((char=? c #\-) '-)
|
||||
((char=? c #\*) '*)
|
||||
((char=? c #\/) '/)
|
||||
((char=? c #\=) '=)
|
||||
((char=? c #\,) 'COMMA)
|
||||
((char=? c #\() 'LPAREN)
|
||||
((char=? c #\)) 'RPAREN)
|
||||
((char-numeric? c) (cons 'NUM (read-number (list c))))
|
||||
((char-alphabetic? c) (cons 'ID (read-id (list c))))
|
||||
(else
|
||||
(errorp "PARSE ERROR : illegal character: " c)
|
||||
(skip-spaces)
|
||||
(loop (read-char))))))))
|
||||
|
||||
|
||||
(define (read-line)
|
||||
(let loop ((c (read-char)))
|
||||
(if (and (not (eof-object? c))
|
||||
(not (char=? c #\newline)))
|
||||
(loop (read-char)))))
|
||||
|
||||
|
||||
;;;
|
||||
;;;; Environment management
|
||||
;;;
|
||||
|
||||
|
||||
(define *env* (list (cons '$$ 0)))
|
||||
|
||||
|
||||
(define (init-bindings)
|
||||
(set-cdr! *env* '())
|
||||
(add-binding 'cos cos)
|
||||
(add-binding 'sin sin)
|
||||
(add-binding 'tan tan)
|
||||
(add-binding 'expt expt)
|
||||
(add-binding 'sqrt sqrt))
|
||||
|
||||
|
||||
(define (add-binding var val)
|
||||
(set! *env* (cons (cons var val) *env*))
|
||||
val)
|
||||
|
||||
|
||||
(define (get-binding var)
|
||||
(let ((p (assq var *env*)))
|
||||
(if p
|
||||
(cdr p)
|
||||
0)))
|
||||
|
||||
|
||||
(define (invoke-proc proc-name args)
|
||||
(let ((proc (get-binding proc-name)))
|
||||
(if (procedure? proc)
|
||||
(apply proc args)
|
||||
(begin
|
||||
(display "ERROR: invalid procedure:")
|
||||
(display proc-name)
|
||||
(newline)
|
||||
0))))
|
||||
|
||||
|
||||
;;;
|
||||
;;;; The main program
|
||||
;;;
|
||||
|
||||
|
||||
(define calc
|
||||
(lambda ()
|
||||
(call-with-current-continuation
|
||||
(lambda (k)
|
||||
(display "********************************") (newline)
|
||||
(display "* Mini calculator in Scheme *") (newline)
|
||||
(display "* *") (newline)
|
||||
(display "* Enter expressions followed *") (newline)
|
||||
(display "* by [RETURN] or 'quit()' to *") (newline)
|
||||
(display "* exit. *") (newline)
|
||||
(display "********************************") (newline)
|
||||
(init-bindings)
|
||||
(add-binding 'quit k)
|
||||
(letrec ((errorp
|
||||
(lambda args
|
||||
(for-each display args) (newline)))
|
||||
(start
|
||||
(lambda ()
|
||||
(calc-parser (make-lexer errorp) errorp))))
|
||||
(start))))))
|
||||
|
||||
(calc)
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,47 @@
|
|||
#!/usr/bin/env ikarus --r6rs-script
|
||||
;;; vim:syntax=scheme
|
||||
(import (ikarus) (objc))
|
||||
|
||||
(define-framework Cocoa)
|
||||
(define-class NSAutoreleasePool)
|
||||
(define-class NSWindow)
|
||||
(define-class NSApplication)
|
||||
(define-object NSApp Cocoa)
|
||||
|
||||
|
||||
(define pool [$ [$ NSAutoreleasePool alloc] init])
|
||||
[$ NSApplication sharedApplication]
|
||||
|
||||
(define NSBorderlessWindowMask #b000000000)
|
||||
(define NSTitledWindowMask #b000000001)
|
||||
(define NSClosableWindowMask #b000000010)
|
||||
(define NSMiniaturizableWindowMask #b000000100)
|
||||
(define NSResizableWindowMask #b000001000)
|
||||
(define NSTexturedBackgroundWindowMask #b100000000)
|
||||
|
||||
(define NSBackingStoreRetained 0)
|
||||
(define NSBackingStoreNonretained 1)
|
||||
(define NSBackingStoreBuffered 2)
|
||||
|
||||
(define style
|
||||
(bitwise-ior
|
||||
NSClosableWindowMask
|
||||
NSResizableWindowMask
|
||||
NSTexturedBackgroundWindowMask
|
||||
NSTitledWindowMask
|
||||
NSMiniaturizableWindowMask))
|
||||
|
||||
(define backing NSBackingStoreBuffered)
|
||||
|
||||
(define win [$ [$ NSWindow alloc]
|
||||
initWithContentRect: '#(#(50 50) #(600 400))
|
||||
styleMask: style
|
||||
backing: backing
|
||||
defer: #f])
|
||||
|
||||
[$ win makeKeyAndOrderFront: win]
|
||||
|
||||
[$ NSApp run]
|
||||
[$ pool release]
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,454 @@
|
|||
|
||||
(library (objc)
|
||||
(export
|
||||
define-framework
|
||||
define-class
|
||||
define-object
|
||||
$)
|
||||
(import
|
||||
(ikarus)
|
||||
(ikarus system $foreign)
|
||||
(except (ypsilon-compat) format)
|
||||
)
|
||||
|
||||
(define ptrsize 4)
|
||||
|
||||
|
||||
|
||||
|
||||
(define objc
|
||||
(load-shared-object "libobjc.A.dylib"))
|
||||
(define Cocoa
|
||||
(load-shared-object "/System/Library/Frameworks/Cocoa.framework/Cocoa"))
|
||||
|
||||
|
||||
(define-syntax define-function
|
||||
(syntax-rules ()
|
||||
((_ ret name args)
|
||||
(define name
|
||||
(c-function objc "Objective C Binding" ret __stdcall name args)))))
|
||||
|
||||
|
||||
(define-function int objc_getClassList (void* int))
|
||||
(define-function void* objc_getClass (char*))
|
||||
(define-function void* sel_registerName (char*))
|
||||
(define-function void* sel_getUid (char*))
|
||||
(define-function void* class_getInstanceMethod (void* void*))
|
||||
(define-function void* class_getClassMethod (void* void*))
|
||||
(define-function void* class_nextMethodList (void* void*))
|
||||
|
||||
|
||||
|
||||
(define-record-type class (fields ptr))
|
||||
(define-record-type object (fields ptr))
|
||||
(define-record-type lazy-object (fields ptr))
|
||||
(define-record-type selector (fields ptr))
|
||||
(define-record-type method (fields ptr))
|
||||
|
||||
(define (pointer-ref addr offset)
|
||||
(assert (pointer? addr))
|
||||
(integer->pointer (pointer-ref-long addr offset)))
|
||||
|
||||
(define (char*len x)
|
||||
(let f ([i 0])
|
||||
(cond
|
||||
[(zero? (pointer-ref-uchar x i)) i]
|
||||
[else (f (+ i 1))])))
|
||||
|
||||
(define (char*->bv x)
|
||||
(let ([n (char*len x)])
|
||||
(let ([bv (make-bytevector n)])
|
||||
(let f ([i 0])
|
||||
(cond
|
||||
[(= i n) bv]
|
||||
[else
|
||||
(bytevector-u8-set! bv i (pointer-ref-uchar x i))
|
||||
(f (+ i 1))])))))
|
||||
|
||||
(define (char*->string x)
|
||||
(utf8->string (char*->bv x)))
|
||||
|
||||
(define-syntax check
|
||||
(syntax-rules ()
|
||||
[(_ who pred expr)
|
||||
(let ([t expr])
|
||||
(unless (pred t)
|
||||
(die who (format "not a ~a" 'pred) t)))]))
|
||||
|
||||
(define (class-name x)
|
||||
(check 'class-name class? x)
|
||||
(char*->string (pointer-ref (class-ptr x) (* ptrsize 2))))
|
||||
|
||||
(define (method-types x)
|
||||
(check 'method-types method? x)
|
||||
(char*->string (pointer-ref (method-ptr x) (* ptrsize 1))))
|
||||
|
||||
(define (method-pointer x)
|
||||
(check 'method-pointer method? x)
|
||||
(pointer-ref (method-ptr x) (* ptrsize 2)))
|
||||
|
||||
|
||||
(define (method-selector x)
|
||||
(check 'method-selector method? x)
|
||||
(make-selector (pointer-ref (method-ptr x) (* ptrsize 0))))
|
||||
|
||||
(define (method-name x)
|
||||
(check 'method-name method? x)
|
||||
(string-append
|
||||
(selector-name (method-selector x))
|
||||
" "
|
||||
(method-types x)))
|
||||
|
||||
|
||||
|
||||
(define CLS_METHOD_ARRAY #x100)
|
||||
|
||||
|
||||
(define (class-is? x what)
|
||||
(define alist
|
||||
'([method-array #x100]
|
||||
[no-method-array #x4000]))
|
||||
(check 'class-info class? x)
|
||||
(let ([mask
|
||||
(cond
|
||||
[(assq what alist) => cadr]
|
||||
[else (error 'class-is? "invalid what" what)])])
|
||||
(= mask (bitwise-and mask (pointer-ref-long (class-ptr x) (* ptrsize 4))))))
|
||||
|
||||
(define (class-methods x)
|
||||
(define (methods x)
|
||||
(let ([n (pointer-ref-int x ptrsize)]
|
||||
[array (integer->pointer (+ (pointer->integer x) (* 2 ptrsize)))])
|
||||
(let f ([i 0])
|
||||
(if (= i n)
|
||||
'()
|
||||
(let ([m (make-method
|
||||
(integer->pointer
|
||||
(+ (pointer->integer array)
|
||||
(* 3 ptrsize i))))])
|
||||
(cons m (f (+ i 1))))))))
|
||||
(check 'class-methods class? x)
|
||||
(when (class-is? x 'method-array)
|
||||
(error 'class-methods "BUG: not yet for method arrays"))
|
||||
(let ([iterator (malloc ptrsize)])
|
||||
(pointer-set-long iterator 0 0)
|
||||
(let f ()
|
||||
(let ([methodlist (class_nextMethodList (class-ptr x) iterator)])
|
||||
(cond
|
||||
[(nil? methodlist)
|
||||
(free iterator)
|
||||
'()]
|
||||
[else
|
||||
(let ([ls (methods methodlist)])
|
||||
(append ls (f)))])))))
|
||||
|
||||
|
||||
(define (get-class-list)
|
||||
(let ([n (objc_getClassList (integer->pointer 0) 0)])
|
||||
(if (= n 0)
|
||||
'()
|
||||
(let ([buffer (malloc (* ptrsize n))])
|
||||
(let ([n (objc_getClassList buffer n)])
|
||||
(let f ([i 0] [ac '()])
|
||||
(if (= i n)
|
||||
(begin (free buffer) ac)
|
||||
(f (+ i 1)
|
||||
(cons
|
||||
(make-class
|
||||
(integer->pointer
|
||||
(pointer-ref-long buffer (* ptrsize i))))
|
||||
ac)))))))))
|
||||
|
||||
(define (nil? x)
|
||||
(zero? (pointer->integer x)))
|
||||
|
||||
(define (get-class name)
|
||||
(check 'lookup-class string? name)
|
||||
(let ([v (objc_getClass name)])
|
||||
(cond
|
||||
[(nil? v) #f]
|
||||
[else (make-class v)])))
|
||||
|
||||
(define (get-selector name)
|
||||
(check 'lookup-selector string? name)
|
||||
(let ([v (sel_registerName name)])
|
||||
(cond
|
||||
[(nil? v) #f]
|
||||
[else (make-selector v)])))
|
||||
|
||||
(define (selector-name x)
|
||||
(check 'selector-name selector? x)
|
||||
(char*->string (selector-ptr x)))
|
||||
|
||||
(define (get-class-method class selector)
|
||||
(check 'get-class-method class? class)
|
||||
(check 'get-class-method selector? selector)
|
||||
(let ([v (class_getClassMethod
|
||||
(class-ptr class)
|
||||
(selector-ptr selector))])
|
||||
(cond
|
||||
[(nil? v) #f]
|
||||
[else (make-method v)])))
|
||||
|
||||
(define (get-instance-method x selector)
|
||||
(check 'get-instance-method object? x)
|
||||
(check 'get-instance-method selector? selector)
|
||||
(let ([class (pointer-ref (object-ptr x) 0)])
|
||||
(let ([v (class_getInstanceMethod
|
||||
class
|
||||
(selector-ptr selector))])
|
||||
(cond
|
||||
[(nil? v) #f]
|
||||
[else (make-method v)]))))
|
||||
|
||||
|
||||
(define-syntax define-class
|
||||
(syntax-rules ()
|
||||
[(_ name)
|
||||
(define name
|
||||
(or (get-class (symbol->string 'name))
|
||||
(error 'define-class "undefined class" 'name)))]))
|
||||
|
||||
(define-syntax define-selector
|
||||
(syntax-rules ()
|
||||
[(_ name)
|
||||
(define name
|
||||
(or (get-selector (symbol->string 'name))
|
||||
(error 'define-selector "undefined selector" 'name)))]))
|
||||
|
||||
(define-syntax define-class-method
|
||||
(syntax-rules ()
|
||||
[(_ name class selector)
|
||||
(define name
|
||||
(or (get-class-method class selector)
|
||||
(error 'define-class-method
|
||||
"class method not implemented"
|
||||
'name)))]))
|
||||
|
||||
|
||||
(define-class NSObject)
|
||||
(define-class NSString)
|
||||
(define-class NSAutoreleasePool)
|
||||
(define-class NSWindow)
|
||||
(define-selector alloc)
|
||||
(define-selector allocWithZone:)
|
||||
(define-selector init)
|
||||
|
||||
(define-class-method NSObject:alloc NSObject alloc)
|
||||
(define-class-method NSObject:allocWithZone: NSObject allocWithZone:)
|
||||
(define-class-method NSAutoreleasePool:alloc NSAutoreleasePool alloc)
|
||||
|
||||
|
||||
(define (class-info x)
|
||||
`([name: ,(class-name x)]
|
||||
[methods:
|
||||
,(list-sort string<?
|
||||
(map method-name (class-methods x)))]))
|
||||
|
||||
|
||||
(define-syntax define-framework
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
[(_ name) (identifier? #'name)
|
||||
(let ([str (symbol->string (syntax->datum #'name))])
|
||||
(with-syntax ([framework-name
|
||||
(string-append str ".framework/" str)])
|
||||
#'(define name
|
||||
(load-shared-object framework-name))))])))
|
||||
|
||||
(define (load-object lib name)
|
||||
(let ([ptr
|
||||
(or (dlsym (library-pointer lib) (symbol->string name))
|
||||
(error 'load-object "cannot find symbol" name))])
|
||||
(make-lazy-object ptr)))
|
||||
|
||||
(define-syntax define-object
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
[(_ name lib)
|
||||
#'(define name (load-object lib 'name))])))
|
||||
|
||||
(define (symbol->selector x)
|
||||
(or (get-selector (symbol->string x))
|
||||
(error 'symbol->selector "undefined selector" x)))
|
||||
|
||||
|
||||
(define (make-signature str)
|
||||
(define who 'make-signature)
|
||||
(let ([n (string-length str)])
|
||||
(define (scan i c)
|
||||
(cond
|
||||
[(= i n) (error who "cannot find " c)]
|
||||
[(char=? c (string-ref str i)) (+ i 1)]
|
||||
[else (scan (+ i 1) c)]))
|
||||
(define (parse i)
|
||||
(cond
|
||||
[(= i n) (error who "unterminated string")]
|
||||
[else
|
||||
(let ([c (string-ref str i)])
|
||||
(case c
|
||||
[(#\@) (values 'object (+ i 1))]
|
||||
[(#\:) (values 'selector (+ i 1))]
|
||||
[(#\v) (values 'void (+ i 1))]
|
||||
[(#\f) (values 'float (+ i 1))]
|
||||
[(#\i) (values 'int (+ i 1))]
|
||||
[(#\I) (values 'uint (+ i 1))]
|
||||
[(#\c) (values 'char (+ i 1))]
|
||||
[(#\{) ;;; struct
|
||||
(let ([i (scan (+ i 1) #\=)])
|
||||
(let-values ([(i ls)
|
||||
(let f ([i i])
|
||||
(let-values ([(x i) (parse i)])
|
||||
(cond
|
||||
[(>= i n) (error who "runaway")]
|
||||
[(char=? (string-ref str i) #\})
|
||||
(values (+ i 1) (list x))]
|
||||
[else
|
||||
(let-values ([(i ls) (f i)])
|
||||
(values i (cons x ls)))])))])
|
||||
(values (list->vector ls) i)))]
|
||||
[(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
|
||||
(values 'skip (+ i 1))]
|
||||
[else (error who "invalid char" c str)]))]))
|
||||
(define (cons/skip x y)
|
||||
(if (eq? x 'skip) y (cons x y)))
|
||||
(let f ([i 0])
|
||||
(cond
|
||||
[(= i n) '()]
|
||||
[else
|
||||
(let-values ([(x i) (parse i)])
|
||||
(cons/skip x (f i)))]))))
|
||||
|
||||
|
||||
(define (objc-type->ikarus-type x)
|
||||
(cond
|
||||
[(vector? x)
|
||||
(vector-map objc-type->ikarus-type x)]
|
||||
[else
|
||||
(case x
|
||||
[(selector) 'pointer]
|
||||
[(object) 'pointer]
|
||||
[(void) 'void]
|
||||
[(float) 'float]
|
||||
[(uint) 'uint32]
|
||||
[(int) 'sint32]
|
||||
[(char) 'sint8]
|
||||
[else (error 'objc-type->ikarus-type "invalid type" x)])]))
|
||||
|
||||
|
||||
|
||||
(define (convert-incoming t x)
|
||||
(case t
|
||||
[(object) (make-object x)]
|
||||
[(void) (void)]
|
||||
[else (error 'convert-incoming "invalid type" t)]))
|
||||
|
||||
(define (convert-outgoing t x)
|
||||
(cond
|
||||
[(vector? t)
|
||||
(cond
|
||||
[(vector? x)
|
||||
(unless (= (vector-length x) (vector-length t))
|
||||
(error 'convert-outgoing "length mismatch" x t))
|
||||
(vector-map convert-outgoing t x)]
|
||||
[else (error 'convert-output "not a vector" x)])]
|
||||
[else
|
||||
(case t
|
||||
[(selector)
|
||||
(cond
|
||||
[(selector? x) (selector-ptr x)]
|
||||
[else (error 'convert-output "not a selector" x)])]
|
||||
[(object)
|
||||
(cond
|
||||
[(object? x) (object-ptr x)]
|
||||
[(lazy-object? x)
|
||||
(pointer-ref (lazy-object-ptr x) 0)]
|
||||
[(class? x) (class-ptr x)]
|
||||
[else (error 'convert-output "cannot convert to object" x)])]
|
||||
[(float)
|
||||
(cond
|
||||
[(number? x) (inexact x)]
|
||||
[else (error 'convert-output "cannot convert to float" x)])]
|
||||
[(uint int char)
|
||||
(cond
|
||||
[(or (fixnum? x) (bignum? x)) x]
|
||||
[(boolean? x) (if x 1 0)]
|
||||
[else (error 'convert-output "cannot convert to int" x)])]
|
||||
[else (error 'convert-outgoing "invalid type" t)])]))
|
||||
|
||||
|
||||
(define (call-with-sig sig mptr args)
|
||||
(let ([rtype (car sig)] [argtypes (cdr sig)])
|
||||
(unless (= (length args) (length argtypes))
|
||||
(error 'call-with-sig "incorrect number of args" args argtypes))
|
||||
(let ([ffi (make-ffi
|
||||
(objc-type->ikarus-type rtype)
|
||||
(map objc-type->ikarus-type argtypes))])
|
||||
(let ([proc (ffi mptr)])
|
||||
(convert-incoming rtype
|
||||
(apply proc (map convert-outgoing argtypes args)))))))
|
||||
|
||||
(define (send-message x method-name . args)
|
||||
(let ([selector (symbol->selector method-name)])
|
||||
(let ([method
|
||||
(cond
|
||||
[(class? x) (get-class-method x selector)]
|
||||
[(object? x) (get-instance-method x selector)]
|
||||
[(lazy-object? x)
|
||||
(get-instance-method
|
||||
(make-object (pointer-ref (lazy-object-ptr x) 0))
|
||||
selector)]
|
||||
[else (error 'send-message "not an object" x)])])
|
||||
(unless method
|
||||
(error 'send-message "undefined method" method-name))
|
||||
(let ([sig (make-signature (method-types method))]
|
||||
[mptr (method-pointer method)])
|
||||
(call-with-sig sig mptr (cons* x selector args))))))
|
||||
|
||||
(define-syntax $
|
||||
(lambda (x)
|
||||
(define (process-rest ls)
|
||||
(syntax-case ls ()
|
||||
[() (values "" '())]
|
||||
[(kwd val . rest) (identifier? #'kwd)
|
||||
(let-values ([(sel args) (process-rest #'rest)])
|
||||
(values
|
||||
(string-append
|
||||
(symbol->string (syntax->datum #'kwd))
|
||||
sel)
|
||||
(cons #'val args)))]))
|
||||
(define (process-args ls)
|
||||
(let-values ([(sel args) (process-rest ls)])
|
||||
(cons (datum->syntax #'here (string->symbol sel)) args)))
|
||||
(syntax-case x ()
|
||||
[(_ receiver kwd)
|
||||
(identifier? #'kwd)
|
||||
#'(send-message receiver 'kwd)]
|
||||
[(_ receiver kwd/arg* ...)
|
||||
(identifier? #'kwd)
|
||||
(with-syntax ([(sel-name arg* ...)
|
||||
(process-args #'(kwd/arg* ...))])
|
||||
#'(send-message receiver 'sel-name arg* ...))])))
|
||||
|
||||
|
||||
|
||||
|
||||
;(printf "Classes: ~s\n"
|
||||
; (list-sort string<? (map class-name (get-class-list))))
|
||||
;
|
||||
;(printf "NSObject=~s\n" NSObject)
|
||||
;(printf "alloc=~s\n" alloc)
|
||||
;(printf "init=~s\n" init)
|
||||
;(printf "NSObject:alloc=~s\n" NSObject:alloc)
|
||||
;(printf "NSObject:allocWithZone=~s\n" NSObject:allocWithZone:)
|
||||
;(printf "types alloc=~s\n" (method-types NSObject:alloc))
|
||||
;(printf "types alloc=~s\n" (method-types NSAutoreleasePool:alloc))
|
||||
;(printf "types allocWithZone=~s\n" (method-types NSObject:allocWithZone:))
|
||||
;(for-each
|
||||
; (lambda (x)
|
||||
; (pretty-print (class-info x)))
|
||||
; (list NSObject NSString NSAutoreleasePool NSWindow))
|
||||
|
||||
|
||||
|
||||
) ; library
|
||||
|
|
@ -93,8 +93,11 @@
|
|||
(check = (test_D_DDD S_add_D_DDD 12.0 13.0 14.0) (+ 12.0 13.0 14.0))
|
||||
|
||||
|
||||
(define RectArea
|
||||
((make-ffi 'float '(#(#(float float) #(float float))))
|
||||
(dlsym self "test_area_F_R")))
|
||||
|
||||
|
||||
(check = (RectArea '#(#(0.0 0.0) #(10.0 10.0))) 100.0)
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
(library (ypsilon-compat)
|
||||
(export on-windows on-darwin on-linux on-freebsd on-posix
|
||||
load-shared-object c-argument c-function
|
||||
microsecond usleep
|
||||
microsecond usleep library-pointer
|
||||
(rename (ypsilon:format format)))
|
||||
(import
|
||||
(ikarus system $foreign)
|
||||
|
|
@ -19,8 +19,9 @@
|
|||
(cond
|
||||
[(eq? what #t)
|
||||
(apply printf str args)]
|
||||
[else
|
||||
(apply format str args)]))
|
||||
[(eq? what #f)
|
||||
(apply format str args)]
|
||||
[else (error 'ypsion:format "invalid what" what)]))
|
||||
|
||||
|
||||
(define (architecture-feature what)
|
||||
|
|
@ -148,7 +149,10 @@
|
|||
(define (name* . args) (error 'name* "not implemented"))
|
||||
...)]))
|
||||
|
||||
(todo check-void* )
|
||||
(define (check-void* who x)
|
||||
(cond
|
||||
[(pointer? x) x]
|
||||
[else (die who "not a void*" x)]))
|
||||
|
||||
(define-syntax convert-arg
|
||||
(lambda (x)
|
||||
|
|
@ -235,7 +239,7 @@
|
|||
(unless (library? lib) (die who "not a library" lib))
|
||||
(or (dlsym (library-pointer lib) (symbol->string name))
|
||||
(error who
|
||||
(format #f "cannot find object ~a in library ~a"
|
||||
(format "cannot find object ~a in library ~a"
|
||||
name (library-name lib)))))
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -124,20 +124,23 @@
|
|||
(define (ffi-prep-cif rtype argtypes)
|
||||
(define who 'ffi-prep-cif)
|
||||
(define (convert x)
|
||||
(case x
|
||||
[(void) 1]
|
||||
[(uint8) 2]
|
||||
[(sint8) 3]
|
||||
[(uint16) 4]
|
||||
[(sint16) 5]
|
||||
[(uint32) 6]
|
||||
[(sint32) 7]
|
||||
[(uint64) 8]
|
||||
[(sint64) 9]
|
||||
[(float) 10]
|
||||
[(double) 11]
|
||||
[(pointer) 12]
|
||||
[else (die who "invalid type" x)]))
|
||||
(cond
|
||||
[(vector? x) (vector-map convert x)]
|
||||
[else
|
||||
(case x
|
||||
[(void) 1]
|
||||
[(uint8) 2]
|
||||
[(sint8) 3]
|
||||
[(uint16) 4]
|
||||
[(sint16) 5]
|
||||
[(uint32) 6]
|
||||
[(sint32) 7]
|
||||
[(uint64) 8]
|
||||
[(sint64) 9]
|
||||
[(float) 10]
|
||||
[(double) 11]
|
||||
[(pointer) 12]
|
||||
[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))]
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
1612
|
||||
1613
|
||||
|
|
|
|||
176
src/ikarus-ffi.c
176
src/ikarus-ffi.c
|
|
@ -19,61 +19,121 @@ alloc(size_t n, int m) {
|
|||
return x;
|
||||
}
|
||||
|
||||
static ffi_type* scheme_to_ffi_type_cast(ikptr nptr);
|
||||
|
||||
static ffi_type*
|
||||
scheme_to_ffi_type_cast(int n){
|
||||
switch (n & 0xF) {
|
||||
case 1: return &ffi_type_void;
|
||||
case 2: return &ffi_type_uint8;
|
||||
case 3: return &ffi_type_sint8;
|
||||
case 4: return &ffi_type_uint16;
|
||||
case 5: return &ffi_type_sint16;
|
||||
case 6: return &ffi_type_uint32;
|
||||
case 7: return &ffi_type_sint32;
|
||||
case 8: return &ffi_type_uint64;
|
||||
case 9: return &ffi_type_sint64;
|
||||
case 10: return &ffi_type_float;
|
||||
case 11: return &ffi_type_double;
|
||||
case 12: return &ffi_type_pointer;
|
||||
default:
|
||||
fprintf(stderr, "INVALID ARG %d", n);
|
||||
exit(-1);
|
||||
scheme_to_ffi_record_type_cast(ikptr vec){
|
||||
ikptr lenptr = ref(vec, -vector_tag);
|
||||
if (! is_fixnum(lenptr)) {
|
||||
fprintf(stderr, "NOT A VECTOR 0x%016lx\n", vec);
|
||||
exit(-1);
|
||||
}
|
||||
long n = unfix(lenptr);
|
||||
ffi_type* t = alloc(sizeof(ffi_type), 1);
|
||||
ffi_type** ts = alloc(sizeof(ffi_type*), n+1);
|
||||
t->size = 0;
|
||||
t->alignment = 0;
|
||||
t->type = FFI_TYPE_STRUCT;
|
||||
t->elements = ts;
|
||||
long i;
|
||||
for(i=0; i<n; i++){
|
||||
ts[i] = scheme_to_ffi_type_cast(ref(vec, off_vector_data + i*wordsize));
|
||||
}
|
||||
ts[n] = 0;
|
||||
return t;
|
||||
}
|
||||
|
||||
static ffi_type*
|
||||
scheme_to_ffi_type_cast(ikptr nptr){
|
||||
if (tagof(nptr) == vector_tag) {
|
||||
return scheme_to_ffi_record_type_cast(nptr);
|
||||
} else if (is_fixnum(nptr)) {
|
||||
long n = unfix(nptr);
|
||||
switch (n & 0xF) {
|
||||
case 1: return &ffi_type_void;
|
||||
case 2: return &ffi_type_uint8;
|
||||
case 3: return &ffi_type_sint8;
|
||||
case 4: return &ffi_type_uint16;
|
||||
case 5: return &ffi_type_sint16;
|
||||
case 6: return &ffi_type_uint32;
|
||||
case 7: return &ffi_type_sint32;
|
||||
case 8: return &ffi_type_uint64;
|
||||
case 9: return &ffi_type_sint64;
|
||||
case 10: return &ffi_type_float;
|
||||
case 11: return &ffi_type_double;
|
||||
case 12: return &ffi_type_pointer;
|
||||
default:
|
||||
fprintf(stderr, "INVALID ARG %ld", n);
|
||||
exit(-1);
|
||||
}
|
||||
} else {
|
||||
fprintf(stderr, "INVALID ARG %ld", nptr);
|
||||
exit(-1);
|
||||
}
|
||||
}
|
||||
|
||||
static void*
|
||||
alloc_room_for_type(int n){
|
||||
ffi_type* t = scheme_to_ffi_type_cast(n);
|
||||
alloc_room_for_type(ffi_type* t){
|
||||
return alloc(t->size, 1);
|
||||
}
|
||||
|
||||
extern long extract_num(ikptr x);
|
||||
|
||||
static void scheme_to_ffi_value_cast(ffi_type*, ikptr, ikptr, void*);
|
||||
|
||||
static void
|
||||
scheme_to_ffi_value_cast(int n, ikptr p, void* r) {
|
||||
switch (n & 0xF) {
|
||||
case 1: { return; }
|
||||
case 2: // ffi_type_uint8;
|
||||
case 3:
|
||||
{ *((char*)r) = extract_num(p); return; }
|
||||
case 4: // ffi_type_uint16;
|
||||
case 5:
|
||||
{ *((short*)r) = extract_num(p); return; }
|
||||
case 6: // ffi_type_uint32;
|
||||
case 7:
|
||||
{ *((int*)r) = extract_num(p); return; }
|
||||
case 8: // ffi_type_uint64;
|
||||
case 9:
|
||||
{ *((long*)r) = extract_num(p); return; }
|
||||
case 10: //return &ffi_type_float;
|
||||
{ *((float*)r) = flonum_data(p); return; }
|
||||
case 11: //return &ffi_type_double;
|
||||
{ *((double*)r) = flonum_data(p); return; }
|
||||
case 12: //return &ffi_type_pointer;
|
||||
{ *((void**)r) = (void*)ref(p, off_pointer_data); return; }
|
||||
default:
|
||||
fprintf(stderr, "INVALID ARG %d", n);
|
||||
exit(-1);
|
||||
scheme_to_ffi_record_value_cast(ffi_type* t, ikptr nptr, ikptr p, void* r) {
|
||||
if (t->type != FFI_TYPE_STRUCT) {
|
||||
fprintf(stderr, "not a struct type\n");
|
||||
exit(-1);
|
||||
}
|
||||
ffi_type** ts = t->elements;
|
||||
char* buf = r;
|
||||
ikptr lenptr = ref(nptr, off_vector_length);
|
||||
int n = unfix(lenptr);
|
||||
int i;
|
||||
for(i=0; i<n; i++) {
|
||||
ffi_type* at = ts[i];
|
||||
ikptr argt = ref(nptr, off_vector_data + i*wordsize);
|
||||
ikptr arg = ref(p, off_vector_data + i*wordsize);
|
||||
scheme_to_ffi_value_cast(at, argt, arg, buf);
|
||||
buf += at->size;
|
||||
}
|
||||
}
|
||||
|
||||
static void
|
||||
scheme_to_ffi_value_cast(ffi_type* t, ikptr nptr, ikptr p, void* r) {
|
||||
if (tagof(nptr) == vector_tag) {
|
||||
scheme_to_ffi_record_value_cast(t, nptr, p, r);
|
||||
} else if (is_fixnum(nptr)) {
|
||||
long n = unfix(nptr);
|
||||
switch (n & 0xF) {
|
||||
case 1: { return; }
|
||||
case 2: // ffi_type_uint8;
|
||||
case 3:
|
||||
{ *((char*)r) = extract_num(p); return; }
|
||||
case 4: // ffi_type_uint16;
|
||||
case 5:
|
||||
{ *((short*)r) = extract_num(p); return; }
|
||||
case 6: // ffi_type_uint32;
|
||||
case 7:
|
||||
{ *((int*)r) = extract_num(p); return; }
|
||||
case 8: // ffi_type_uint64;
|
||||
case 9:
|
||||
{ *((long*)r) = extract_num(p); return; }
|
||||
case 10: //return &ffi_type_float;
|
||||
{ *((float*)r) = flonum_data(p); return; }
|
||||
case 11: //return &ffi_type_double;
|
||||
{ *((double*)r) = flonum_data(p); return; }
|
||||
case 12: //return &ffi_type_pointer;
|
||||
{ *((void**)r) = (void*)ref(p, off_pointer_data); return; }
|
||||
default:
|
||||
fprintf(stderr, "INVALID ARG %ld", n);
|
||||
exit(-1);
|
||||
}
|
||||
} else {
|
||||
fprintf(stderr, "INVALID TYPE 0x%016lx\n", nptr);
|
||||
exit(-1);
|
||||
}
|
||||
}
|
||||
|
||||
|
|
@ -112,10 +172,10 @@ ikrt_ffi_prep_cif(ikptr rtptr, ikptr argstptr, ikpcb* pcb) {
|
|||
int i;
|
||||
for(i=0; i<nargs; i++){
|
||||
ikptr argt = ref(argstptr, off_vector_data + i*wordsize);
|
||||
argtypes[i] = scheme_to_ffi_type_cast(unfix(argt));
|
||||
argtypes[i] = scheme_to_ffi_type_cast(argt);
|
||||
}
|
||||
argtypes[nargs] = NULL;
|
||||
ffi_type* rtype = scheme_to_ffi_type_cast(unfix(rtptr));
|
||||
ffi_type* rtype = scheme_to_ffi_type_cast(rtptr);
|
||||
ffi_status s = ffi_prep_cif(cif, abi, nargs, rtype, argtypes);
|
||||
if (s == FFI_OK) {
|
||||
ikptr r = ik_safe_alloc(pcb, pointer_size);
|
||||
|
|
@ -266,14 +326,15 @@ ikrt_ffi_call(ikptr data, ikptr argsvec, ikpcb* pcb) {
|
|||
void** avalues = alloc(sizeof(void*), n+1);
|
||||
int i;
|
||||
for(i=0; i<n; i++){
|
||||
ikptr t = ref(typevec, off_vector_data + i * wordsize);
|
||||
ffi_type* t = cif->arg_types[i];
|
||||
ikptr at = ref(typevec, off_vector_data + i * wordsize);
|
||||
ikptr v = ref(argsvec, off_vector_data + i * wordsize);
|
||||
void* p = alloc_room_for_type(unfix(t));
|
||||
void* p = alloc_room_for_type(t);
|
||||
avalues[i] = p;
|
||||
scheme_to_ffi_value_cast(unfix(t), v, p);
|
||||
scheme_to_ffi_value_cast(t, at, v, p);
|
||||
}
|
||||
avalues[n] = NULL;
|
||||
void* rvalue = alloc_room_for_type(unfix(rtype));
|
||||
void* rvalue = alloc_room_for_type(cif->rtype);
|
||||
ffi_call(cif, fn, rvalue, avalues);
|
||||
ikptr val = ffi_to_scheme_value_cast(unfix(rtype), rvalue, pcb);
|
||||
for(i=0; i<n; i++){
|
||||
|
|
@ -351,7 +412,7 @@ generic_callback(ffi_cif *cif, void *ret, void **args, void *user_data){
|
|||
#ifdef DEBUG_FFI
|
||||
fprintf(stderr, "and back with rv=0x%016lx!\n", rv);
|
||||
#endif
|
||||
scheme_to_ffi_value_cast(unfix(rtype_conv), rv, ret);
|
||||
scheme_to_ffi_value_cast(cif->rtype, rtype_conv, rv, ret);
|
||||
return;
|
||||
}
|
||||
|
||||
|
|
@ -432,6 +493,21 @@ int add_I_III(int n0, int n1, int n2) {
|
|||
|
||||
|
||||
|
||||
struct Point{
|
||||
float x;
|
||||
float y;
|
||||
};
|
||||
|
||||
struct Rect{
|
||||
struct Point tl;
|
||||
struct Point br;
|
||||
};
|
||||
|
||||
float test_area_F_R(struct Rect r) {
|
||||
float dx = r.br.x - r.tl.x;
|
||||
float dy = r.br.y - r.tl.y;
|
||||
return dx * dy;
|
||||
}
|
||||
|
||||
double test_D_D (double(*f)(double), double n0) {
|
||||
return f(n0);
|
||||
|
|
|
|||
Loading…
Reference in New Issue