Clean up generated interface a bit more, other fixes.

c-support.lisp

@@ -4,61 +4,74 @@
  Author: Nicolas Hafner <shinmera@tymoon.eu>
 |#
 
-(in-package #:org.shirakumo.fraf.steamworks.cffi)
+(in-package #:org.shirakumo.fraf.steamworks)
 
-(cl:eval-when (:compile-toplevel :load-toplevel :execute)
-  (cl:defvar *this* #.(cl:or cl:*compile-file-pathname* cl:*load-pathname*
-                             (cl:error "COMPILE-FILE or LOAD this file.")))
-  (cl:defvar *static*
-    (cl:make-pathname :name cl:NIL :type cl:NIL
-                      :defaults (cl:merge-pathnames "static/" *this*))))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defvar *this* #.(or *compile-file-pathname* *load-pathname*
+                       (error "COMPILE-FILE or LOAD this file.")))
+  (defvar *static*
+    (make-pathname :name NIL :type NIL
+                   :defaults (merge-pathnames "static/" *this*))))
 
-(cl:defmacro defcstruct* (name cl:&body slots)
-  (cl:let ((name-class (cl:intern (cl:format cl:NIL "~a-TCLASS" name) #.cl:*package*))
-           (constructor (cl:intern (cl:format cl:NIL "MAKE-~a" name) #.cl:*package*)))
-    `(cl:progn
+(defvar steam::*callback-id-map* (make-hash-table :test 'eq))
+(defvar steam::*function-callresult-map* (make-hash-table :test 'eq))
+
+(defun callback-id (callback)
+  (or (gethash callback steam::*callback-id-map*)
+      (error "Not a callback: ~s" callback)))
+
+(defun function-callresult (function)
+  (or (gethash function steam::*function-callresult-map*)
+      (error "Not a callresult function: ~s" function)))
+
+;; TODO: optimise above access through compiler-macros
+
+(defmacro steam::defcstruct* (name &body slots)
+  (let ((name-class (intern (format NIL "~a-TCLASS" name) '#:org.shirakumo.fraf.steamworks.cffi))
+        (constructor (intern (format NIL "MAKE-~a" name) '#:org.shirakumo.fraf.steamworks.cffi)))
+    `(progn
        (cffi:defcstruct (,name :class ,name-class)
          ,@slots)
-       (cl:defstruct (,name (:constructor ,constructor ,(cl:mapcar #'cl:first slots)))
-         ,@(cl:mapcar #'cl:first slots))
-       (cl:defmethod cffi:translate-from-foreign (value (type ,name-class))
+       (defstruct (,name (:constructor ,constructor ,(mapcar #'first slots)))
+         ,@(mapcar #'first slots))
+       (defmethod cffi:translate-from-foreign (value (type ,name-class))
          (,constructor
-          ,@(cl:loop for slot in slots
-                  collect `(cffi:foreign-slot-value value '(:struct ,name) ',(cl:first slot))))))))
+          ,@(loop for slot in slots
+                  collect `(cffi:foreign-slot-value value '(:struct ,name) ',(first slot))))))))
 
-(cffi:define-foreign-library steamworks
+(cffi:define-foreign-library steam::steamworks
   ((:and :darwin :x86)
    "libsteam_api.dylib"
-   :search-path #.(cl:merge-pathnames "osx32/" *static*))
+   :search-path #.(merge-pathnames "osx32/" *static*))
   ((:and :unix :x86)
    "libsteam_api.so"
-   :search-path #.(cl:merge-pathnames "linux32/" *static*))
+   :search-path #.(merge-pathnames "linux32/" *static*))
   ((:and :unix :x86-64)
    "libsteam_api.so"
-   :search-path #.(cl:merge-pathnames "linux64/" *static*))
+   :search-path #.(merge-pathnames "linux64/" *static*))
   ((:and :windows :x86)
    "steam_api.dll"
-   :search-path #.(cl:merge-pathnames "/" *static*))
+   :search-path #.(merge-pathnames "/" *static*))
   ((:and :windows :x86-64)
    "steam_api.dll"
-   :search-path #.(cl:merge-pathnames "win64/" *static*)))
+   :search-path #.(merge-pathnames "win64/" *static*)))
 
 #+windows
-(cffi:defcstruct (vtable :class vtable :conc-name vtable-)
+(cffi:defcstruct (steam::vtable :class steam::vtable :conc-name steam::vtable-)
   (result-with-info :pointer)
   (result :pointer)
   (size :pointer))
 
 #-windows
-(cffi:defcstruct (vtable :class vtable :conc-name vtable-)
+(cffi:defcstruct (steam::vtable :class steam::vtable :conc-name steam::vtable-)
   ;; void (pointer this, pointer param)
   (result :pointer)
   ;; void (pointer this, pointer param, bool failed, steam-apicall-t api-call)
   (result-with-info :pointer)
   ;; int (pointer this)
   (size :pointer))
 
-(cffi:defcstruct (callback :class callback :conc-name callback-)
+(cffi:defcstruct (steam::callback :class steam::callback :conc-name steam::callback-)
   ;; Pointer to vtable instance.
   (vtable-ptr :pointer)
   ;; Should be 2 on a game server, 0 otherwise?
@@ -72,4 +85,4 @@
   ;; Function pointer to call for callresult
   (function :pointer)
   ;; vtable alloc
-  (vtable (:struct vtable)))
+  (vtable (:struct steam::vtable)))

callback.lisp

@@ -17,7 +17,7 @@
   (let* ((handle (calloc '(:struct steam::callback)))
          (vtable (cffi:foreign-slot-pointer handle '(:struct steam::callback) 'steam::vtable)))
     (setf (steam::callback-vtable-ptr handle) vtable)
-    (setf (steam::callback-id handle) (symbol-value (struct-type callback)))
+    (setf (steam::callback-id handle) (callback-id (struct-type callback)))
     (setf (steam::callback-flags handle) (if (typep (steamworks) 'steamworks-server) 2 0))
     (setf (steam::vtable-result vtable) (cffi:callback callback))
     (setf (steam::vtable-result-with-info vtable) (cffi:callback callback-with-info))
@@ -99,7 +99,7 @@
     (cffi:with-foreign-objects ((failed :bool)
                                 (result result-type))
       (if (steam::utils-get-apicall-result
-           utils token result (cffi:foreign-type-size result-type) (symbol-value (struct-type callresult)) failed)
+           utils token result (cffi:foreign-type-size result-type) (callback-id (struct-type callresult)) failed)
           (cffi:mem-ref result result-type)
           (error "FIXME: call failed: ~a" (steam::utils-get-apicall-failure-reason utils token))))))
 
@@ -123,25 +123,25 @@
   ;;         directly.
   (let ((thunk (gensym "THUNK"))
         (instance (gensym "INSTANCE"))
-        (callresult (or (find-symbol (format NIL "~a-CALLRESULT" method) '#:steam)
-                        (error "No call result known for method ~a" method)))
+        (interval (gensym "INTERVAL"))
         (interface (if (constantp interface env)
                        `(interface ,interface T)
-                       interface))
-        (poll (etypecase poll
-                (null)
-                ((eql T) 0.01)
-                (integer poll))))
+                       interface)))
     `(flet ((,thunk (,result)
               ,@body))
        (let ((,instance (make-instance 'closure-callresult
                                        :token (call-with #',method ,interface ,@args)
-                                       :struct-type ,callresult
+                                       :struct-type (function-callresult ',method)
                                        :closure #',thunk
-                                       :register ,(null poll))))
-         ,(if poll
-              `(loop for ,result = (maybe-result ,instance)
-                     do (if ,result
-                            (,thunk ,result)
-                            (sleep ,poll)))
-              instance)))))
+                                       :register ,(null poll)))
+             (,interval (let ((,interval ,poll))
+                          (etypecase ,interval
+
+                            ((eql T) 0.01)
+                            (integer ,interval)))))
+         (if ,interval
+             (loop for ,result = (maybe-result ,instance)
+                   do (if ,result
+                          (,thunk ,result)
+                          (sleep ,interval)))
+             ,instance)))))

generator.lisp

@@ -7,6 +7,7 @@
 (defpackage #:cl-steamworks-generator
   (:nicknames #:org.shirakumo.fraf.steamworks.generator)
   (:use #:cl #:cffi)
+  (:local-nicknames (#:steam #:org.shirakumo.fraf.steamworks.cffi))
   (:export
    #:*standard-low-level-file*
    #:*extras-file*
@@ -56,12 +57,22 @@
   (and (<= (length prefix) (length string))
        (string-equal string prefix :end1 (length prefix))))
 
+(defun suffix-p (suffix string)
+  (and (<= (length suffix) (length string))
+       (string-equal string suffix :start1 (- (length string) (length suffix)))))
+
 (defun strip-prefixes (string &rest prefixes)
   (loop for prefix in prefixes
         when (prefix-p prefix string)
         do (return (subseq string (length prefix)))
         finally (return string)))
 
+(defun strip-suffixes (string &rest suffixes)
+  (loop for suffix in suffixes
+        when (suffix-p suffix string)
+        do (return (subseq string 0 (- (length string) (length suffix))))
+        finally (return string)))
+
 (defun strip-hungarian (string)
   (let ((i 0))
     (loop while (or (lower-case-p (char string i))
@@ -108,6 +119,15 @@
             finally (commit)))
     (nreverse parts)))
 
+(defun strip-function-name (name)
+  (strip-prefixes name "SteamAPI_ISteam" "SteamAPI_" "SteamInternal_" "Steam"))
+
+(defun strip-struct-name (name)
+  (strip-suffixes name "Result_t" "Response_t" "_t"))
+
+(defun strip-constant-name (name)
+  (strip-prefixes name "k_cch" "k_cwch" "k_c" "k_i"))
+
 (defun parse-typespec (specstring)
   (let ((parts (split #\Space specstring))
         (type ())
@@ -139,9 +159,9 @@
                          (let ((name (pop parts)))
                            (cond ((string= name "CSteamID") (setf type :unsigned-long))
                                  ((string= name "CGameID") (setf type :unsigned-long))
-                                 (T (setf type `(:struct ,(name name)))))))
+                                 (T (setf type `(:struct ,(name (strip-struct-name name))))))))
                         ((string= part "struct")
-                         (setf type `(:struct ,(name (pop parts)))))
+                         (setf type `(:struct ,(name (strip-struct-name (pop parts))))))
                         ((string= "_Bool" specstring)
                          (setf type :bool))
                         (T
@@ -173,7 +193,7 @@
 (defun compile-const (def)
   (if (or (find (getf def :constname) *bad-consts* :test #'string=))
       (values NIL (format NIL "Ignored const definition ~s" (getf def :constname)))
-      (let ((name (name (strip-prefixes (getf def :constname) "k_cch" "k_cwch" "k_c" "k_i"))))
+      (let ((name (name (strip-constant-name (getf def :constname)))))
         `(cl:defconstant ,name
            ,(or (ignore-errors (parse-integer (getf def :constval)))
                 `(if (boundp ',name) (symbol-value ',name) ,(getf def :constval)))
@@ -183,10 +203,19 @@
   (if (and (string= (getf def :struct) "callbackname")
            (string= (getf def :constname) "callbackid"))
       (values NIL "Ignored callback definition scanned from preprocessor directive.")
-      `(cl:defconstant ,(name (getf def :struct))
-         (+ ,(name (strip-prefixes (getf def :constname) "k_cch" "k_cwch" "k_c" "k_i"))
-            ,(parse-integer (getf def :offset)))
-         ,@(when (getf def :desc) (list (getf def :desc))))))
+      `(cl:setf (cl:gethash ',(name (strip-struct-name (getf def :struct))) steam::*callback-id-map*)
+                (+ ,(name (strip-constant-name (getf def :constname)))
+                   ,(parse-integer (getf def :offset))))))
+
+(defun compile-callresult (def)
+  (cond ((and (equal "SteamAPICall_t" (getf def :returntype))
+              (null (getf def :callresult)))
+         (values NIL (format NIL "Missing callresult declaration for method ~a::~a"
+                             (getf def :classname) (getf def :methodname))))
+        ((getf def :callresult)
+         (let ((name (format NIL "SteamAPI_~a_~a" (getf def :classname) (getf def :methodname))))
+           `(cl:setf (cl:gethash ',(name (strip-function-name name)) steam::*function-callresult-map*)
+                     ',(name (strip-struct-name (getf def :callresult))))))))
 
 (defun compile-struct (def)
   (if (or (find (getf def :struct) *bad-structs* :test #'string=)
@@ -199,7 +228,7 @@
                          :test #'search)
                    (not (find (getf def :name) *large-structs* :test #'string=)))
           (setf align 4))
-        `(org.shirakumo.fraf.steamworks.cffi::defcstruct* ,(name (getf def :struct))
+        `(steam::defcstruct* ,(name (strip-struct-name (getf def :struct)))
            ,@(when (getf def :desc) (list (getf def :desc)))
            ,@(loop with offset = 0
                    with cache = (make-hash-table :test 'equalp)
@@ -225,9 +254,6 @@
         (loop for param in (getf method :params)
               thereis (struct-type-p (getf param :paramtype))))))
 
-(defun strip-function-name (name)
-  (strip-prefixes name "SteamAPI_ISteam" "SteamAPI_" "SteamInternal_" "Steam"))
-
 (defun compile-method (def cache)
   (let ((name (format NIL "SteamAPI_~a_~a" (getf def :classname) (getf def :methodname))))
     (when (<= 0 (incf (gethash name cache -2)))
@@ -254,16 +280,6 @@
                collect (list (name (getf arg :paramname))
                              (parse-typespec (getf arg :paramtype)))))))
 
-(defun compile-callresult (def)
-  (cond ((and (equal "SteamAPICall_t" (getf def :returntype))
-              (null (getf def :callresult)))
-         (values NIL (format NIL "Missing callresult declaration for method ~a::~a"
-                             (getf def :classname) (getf def :methodname))))
-        ((getf def :callresult)
-         (let ((name (format NIL "SteamAPI_~a_~a" (getf def :classname) (getf def :methodname))))
-           `(cl:defconstant ,(name (format NIL "~a-callresult" (strip-function-name name)))
-              ',(name (getf def :callresult)))))))
-
 (defun scan-for-callbacks (content)
   (let ((results ()))
     (flet ((add-callback (struct const offset)
@@ -330,7 +346,7 @@
 
 (defun write-form (form &optional (stream *standard-output*))
   (with-standard-io-syntax
-    (let ((*package* #.(find-package '#:org.shirakumo.fraf.steamworks.cffi)))
+    (let ((*package* #.(find-package '#:steam)))
       (fresh-line stream)
       (terpri stream)
       (write form :stream stream
@@ -356,7 +372,7 @@
        The generation occurs via the machinery from generator.lisp
        You should not edit this file manually.
 |#~%")
-      (write-form `(in-package #:org.shirakumo.fraf.steamworks.cffi) stream)
+      (write-form `(in-package #:steam) stream)
       (loop for form in forms
             do (write-form form stream)))))
 
@@ -399,6 +415,6 @@
      (pathname-utils:subdirectory sdk-directory "redistributable_bin")
      (ensure-directories-exist (pathname-utils:subdirectory *this* "static")))
     (format *query-io* "~&Generating bindings...")
-    (cffi:load-foreign-library 'org.shirakumo.fraf.steamworks.cffi::steamworks)
+    (cffi:load-foreign-library 'steam::steamworks)
     (generate sdk-directory)
     (format *query-io* "~&Done. You can now use cl-steamworks!~%")))

interface.lisp

@@ -22,19 +22,20 @@
   (apply #'call-with (interface interface (steamworks)) function args))
 
 (defmacro define-interface-method (interface method call &body transform)
-  (let ((function (find-if (lambda (a) (eq (symbol-package a) (find-package '#:steam))) call))
+  (let ((function (find-if (lambda (a) (and (symbolp a) (eq (symbol-package a) (find-package '#:steam)))) call))
         (method-args (copy-list call)))
     (setf (nth (position function method-args) method-args) (list interface interface))
     `(defmethod ,method ,method-args
        (let ((result (,function (handle ,interface) ,@(apply #'remove-all (mapcar #'delist call)
                                                              function LAMBDA-LIST-KEYWORDS))))
          ,@(or transform `(result))))))
 
-(defmacro define-interface-submethod (interface sub method call)
-  (let ((function (find-if (lambda (a) (eq (symbol-package a) (find-package '#:steam))) call))
+(defmacro define-interface-submethod (interface sub method call &body transform)
+  (let ((function (find-if (lambda (a) (and (symbolp a) (eq (symbol-package a) (find-package '#:steam)))) call))
         (method-args (copy-list call)))
     (setf (nth (position function method-args) method-args) (list sub sub))
     `(defmethod ,method ,method-args
-       (,function (handle (,interface ,sub)) (handle ,sub)
-                  ,@(apply #'remove-all (mapcar #'delist call)
-                           function LAMBDA-LIST-KEYWORDS)))))
+       (let ((result (,function (handle (,interface ,sub)) (handle ,sub)
+                                ,@(apply #'remove-all (mapcar #'delist call)
+                                         function LAMBDA-LIST-KEYWORDS))))
+         ,@(or transform `(result))))))