From b3e058b72a7434cfda5c74f6ae64dcbc81ac1b38 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Juan=20Manuel=20Tom=C3=A1s?= Date: Wed, 1 Feb 2023 03:46:11 -0300 Subject: Add type resolution for base types This implementation fails because of typedefs to typedefs to composite types. This is because composite types are not being resolved, so typedefs with one or more indirections also can't be resolved. --- cmamut.lisp | 128 ++++++++++++++++++++++++++++++++++++++++++------------------ 1 file changed, 90 insertions(+), 38 deletions(-) diff --git a/cmamut.lisp b/cmamut.lisp index a132744..bacca56 100644 --- a/cmamut.lisp +++ b/cmamut.lisp @@ -2,15 +2,19 @@ ; Ideas: ; Generate code that creates a package and puts all definitions there. -; If symbol names are unaltered we can skip connecting everything together. ; To avoid collisions the created package shouldn't import any symbols. -; Maybe use straight defuns and ffi functions to get as close as possible to the C names without much work. ; Only define functions from the target library, but get all other definitions. +; To reduce amount of names being generated, resolve all types to their base counterparts +; Separate generation, preprocessing and type resolution phases +; Preprocessing phase should handle enums, structs and unions +; Basic types are handled by type resolution phase +; Can put an error to default case in cook type to enforce type resolution ; TODO: Get constants from macro file generated by c2ffi -M ; TODO: Use c2ffi to extract the spec.json using the header file as parameter -(defvar reference-table (make-hash-table :test #'equal :size 256)) +(defvar enum-references (make-hash-table :test #'equal :size 256)) +(defvar type-associations (make-hash-table :test #'equal :size 256)) (defun get-spec () (json:from-file "~/common-lisp/cmamut/spec.json")) @@ -23,9 +27,11 @@ 'sb-alien:function) ((string= tag ":pointer") (let ((pointed-type (gethash "type" raw-type))) - (if (string= (gethash "tag" pointed-type) ":char") - 'sb-alien:c-string - (list 'sb-alien:* (cook-type pointed-type))))) + (cond ((string= (gethash "tag" pointed-type) ":char") + 'sb-alien:c-string) + ((string= (gethash "tag" pointed-type) ":void") + (list 'sb-alien:* t)) + (t (list 'sb-alien:* (cook-type pointed-type)))))) ((string= tag ":float") 'sb-alien:float) ((string= tag ":double") @@ -47,7 +53,9 @@ ((or (string= tag ":long") (string= tag ":signed-long")) 'sb-alien:long) ((string= tag ":array") - (cook-array raw-type)) + (list 'sb-alien:array + (cook-type (gethash "type" raw-type)) + (gethash "size" raw-type))) ((string= tag ":struct") (list 'sb-alien:struct (intern (gethash "name" raw-type)))) ((string= tag ":union") @@ -56,12 +64,13 @@ (cook-struct raw-type)) ((string= tag "union") (cook-union raw-type)) - (t tag)))) - -(defun cook-array (raw-array) - `(sb-alien:array - ,(cook-type (gethash "type" raw-array)) - ,(gethash "size" raw-array))) + (t + (let ((new-tag (gethash tag type-associations))) + (if new-tag + (progn + (setf (gethash "tag" raw-type) new-tag) + (cook-type raw-type)) + (error (format nil "Unknown type tag ~a" tag)))))))) (defun cook-function (raw-function &optional name-transformer) (let ((raw-params (gethash "parameters" raw-function)) @@ -82,8 +91,7 @@ (let* ((base-type (gethash "type" raw-typedef)) (new-name (gethash "name" raw-typedef))) (if (string= (gethash "tag" base-type) ":enum") - (setf (gethash (gethash "id" base-type) reference-table) - new-name) + (progn (setf (gethash (gethash "id" base-type) enum-references) new-name) nil) `(sb-alien:define-alien-type ,new-name ,(cook-type base-type))))) @@ -96,7 +104,8 @@ (list (intern (string-upcase (gethash "name" (aref raw-fields j)))) (cook-type (gethash "type" (aref raw-fields j)))))) `(sb-alien:struct - ,(intern (gethash "name" raw-struct)) + ,(when (> (length (gethash "name" raw-struct)) 0) + (intern (gethash "name" raw-struct))) ,@(queue:to-list cooked-fields)))) (defun cook-union (raw-union) @@ -107,11 +116,12 @@ (list (intern (string-upcase (gethash "name" (aref raw-fields j)))) (cook-type (gethash "type" (aref raw-fields j)))))) `(sb-alien:union - ,(intern (gethash "name" raw-union)) + ,(when (> (length (gethash "name" raw-union)) 0) + (intern (gethash "name" raw-union))) ,@(queue:to-list cooked-fields)))) (defun cook-enum (raw-enum) - (let ((name (gethash (gethash "id" raw-enum) reference-table)) + (let ((name (gethash (gethash "id" raw-enum) enum-references)) (raw-fields (gethash "fields" raw-enum)) (cooked-fields (queue:new))) (dotimes (j (length raw-fields)) @@ -124,6 +134,47 @@ nil ,@(queue:to-list cooked-fields))))) +(defun filter-base-types (raw-typedefs) + (clrhash type-associations) + (setf (gethash ":char" type-associations) t) + (setf (gethash ":short" type-associations) t) + (setf (gethash ":int" type-associations) t) + (setf (gethash ":long" type-associations) t) + (setf (gethash ":signed-char" type-associations) t) + (setf (gethash ":signed-short" type-associations) t) + (setf (gethash ":signed-int" type-associations) t) + (setf (gethash ":signed-long" type-associations) t) + (setf (gethash ":unsigned-char" type-associations) t) + (setf (gethash ":unsigned-short" type-associations) t) + (setf (gethash ":unsigned-int" type-associations) t) + (setf (gethash ":unsigned-long" type-associations) t) + (setf (gethash ":float" type-associations) t) + (setf (gethash ":double" type-associations) t) + (setf (gethash ":function-pointer" type-associations) t) + (labels ((take-deps + (deps) + (let (remaining) + (dolist (i deps) + (let ((tag (gethash "tag" (gethash "type" i)))) + (if (gethash tag type-associations) + (setf (gethash (gethash "name" i) type-associations) tag) + (push i remaining)))) + (if (= (length deps) (length remaining)) + remaining + (take-deps remaining))))) + (let ((result (take-deps raw-typedefs))) + (labels ((associate-base-type + (k v) + (let ((new-v (gethash v type-associations))) + (if (eq new-v t) + (setf (gethash k type-associations) v) + (associate-base-type k new-v))))) + (maphash (lambda (k v) + (unless (eq v t) + (associate-base-type k v))) + type-associations)) + result))) + (defstruct spec functions typedefs @@ -131,8 +182,7 @@ unions enums) -(defun prepare-spec (spec) - (clrhash reference-table) +(defun classify-definitions (spec) (let ((s (make-spec))) (dotimes (i (length spec)) (cond ((string= (gethash "tag" (aref spec i)) "function") @@ -146,20 +196,25 @@ ((string= (gethash "tag" (aref spec i)) "union") (push (aref spec i) (spec-unions s))) (t))) -; typedefs must be generated first to build the reference table - (setf (spec-typedefs s) (mapcar #'cook-typedef (spec-typedefs s))) - (setf (spec-functions s) (mapcar #'cook-function (spec-functions s))) - (setf (spec-enums s) (mapcar #'cook-enum (spec-enums s))) - (setf (spec-structs s) - (mapcar (lambda (x) - `(sb-alien:define-alien-type nil ,(cook-struct x))) - (spec-structs s))) - (setf (spec-unions s) - (mapcar (lambda (x) - `(sb-alien:define-alien-type nil ,(cook-union x))) - (spec-unions s))) s)) +(defun codegen (spec) + (clrhash enum-references) + ; typedefs must be generated first to build the reference table + (setf (spec-typedefs spec) + (remove nil (mapcar #'cook-typedef (filter-base-types (spec-typedefs spec))))) + (setf (spec-functions spec) (mapcar #'cook-function (spec-functions spec))) + (setf (spec-enums spec) (mapcar #'cook-enum (spec-enums spec))) + (setf (spec-structs spec) + (mapcar (lambda (x) + `(sb-alien:define-alien-type nil ,(cook-struct x))) + (spec-structs spec))) + (setf (spec-unions spec) + (mapcar (lambda (x) + `(sb-alien:define-alien-type nil ,(cook-union x))) + (spec-unions spec))) + spec) + (defun to-file (spec filename) (with-open-file (f filename :direction :output @@ -171,9 +226,6 @@ (*print-level* nil)) (format f "~{~s~&~}" (spec-enums spec)) (format f "~{~s~&~}" (spec-typedefs spec))))) - ;(format f "~{~s~&~}" (spec-structs spec)) - ;(format f "~{~s~&~}" (spec-unions spec)) - ;(format f "~{~s~&~}" (spec-functions spec))))) - -(defun generate (filename) - (to-file (prepare-spec (get-spec)) filename)) +;(format f "~{~s~&~}" (spec-structs spec)) +;(format f "~{~s~&~}" (spec-unions spec)) +;(format f "~{~s~&~}" (spec-functions spec))))) -- cgit v1.2.3