(in-package "C-TYPES")

;;;
;;; Corman Lisp DEFUN-POINTER
;;; Similar to defun-dll, but allow the foreign function pointer to be passed
;;; as the first argument to the defined function. This should be a foreign
;;; pointer.
;;;
(defmacro defun-pointer (name param-list 
		&key (return-type :long) 
			(linkage-type :c))
	
	(setq return-type (ctypeexpand-all return-type))
	(let* ((lambda-list nil)
		   (arg-type-list (mapcar #'cadr param-list))
		   (push-forms nil)
		   (local-vars nil)
		   (stack-cleanup-forms nil)
           (func-ptr (gensym)))

		(dolist (i param-list)
			(let ((var (car i))
				  (ctype (cadr i)))
				(setq ctype (ctypeexpand-all ctype))
				(if (stringp var)
					(setf var 
						(if (equalp var "")
							(gensym)
							(intern (string-upcase var)))))
				(push var lambda-list)
				(cond
					((equal ctype '(:char *))
					 (let ((t3 (gensym)))
				 		(push `(,t3 (ct::create-c-string ,var)) local-vars)
						(push `(x86::push-arg ,t3 ,ctype) push-forms)))
					(t (push `(x86::push-arg ,var ,ctype) push-forms)))))

		(if (eq linkage-type :c)
			(setq stack-cleanup-forms `((x86::popargs ,arg-type-list))))

		`(progn
			(defun ,name ,(cons func-ptr (nreverse lambda-list))
				(let (,@local-vars)
					(x86::save-lisp-registers)
					,@push-forms
                    (x86::push-arg ,func-ptr (:void *))
   					(x86::push-foreign-stack-context)
					(x86::call-foreign-pointer)
					(x86::pop-foreign-stack-context)
					,@stack-cleanup-forms
					(x86::restore-lisp-registers)
					(x86::wrap-return-value ,return-type))))))

(in-package :x86)

;; 
;; Call a foreign function whose address is at the top of the stack.
;;
(defcodegen call-foreign-pointer (form dest)
	(declare (ignore form dest))
	(parse-assembler
		{
            pop     eax
            call    eax
		})
	t)

#|
Example:

(setf module (load-dll "msvcrt.dll"))
(setf proc (get-dll-proc-address "strlen" module))

(ct::defun-pointer strlen-ptr ((str (:char *))) :return-type :long :linkage-type :c)
(strlen-ptr proc "corman lisp")
   
|#