Permalink
Find file
Fetching contributors…
Cannot retrieve contributors at this time
146 lines (133 sloc) 5.58 KB
(defpackage #:scan-synopsis
(:use #:cl #:iterate #:alexandria #:split-sequence))
(in-package :scan-synopsis)
(defun trim (string)
(string-trim #.(format nil " ~c" #\Newline) string))
(defun split-synopsis (synopsis)
(remove "" (mapcar #'trim (split-sequence #\; synopsis)) :test #'string=))
(defun split-signature (signature)
(let ((paren (position #\( signature)))
(let ((not-space (position-if-not (curry #'char= #\Space)
signature :from-end t :end paren)))
(let ((space (position #\Space signature :from-end t :end not-space)))
(mapcar #'trim (list (subseq signature 0 space)
(subseq signature space paren)
(subseq signature paren)))))))
(defun split-argument (arg)
(let ((pos (position-if-not #'(lambda (c)
(or (char<= #\a c #\z)
(char<= #\0 c #\9)
(char= c #\_)))
arg :from-end t)))
(if pos
(mapcar #'trim
(list (subseq arg 0 (1+ pos))
(subseq arg (1+ pos))))
(mapcar #'trim
(list arg arg)))))
(defun split-arguments (args)
(mapcar #'split-argument
(mapcar #'trim (split-sequence #\, (string-trim "()" args)))))
(defun lispify-name (name &optional (prefix-remove "") (prefix-add ""))
(assert (string= prefix-remove (subseq name 0 (length prefix-remove))))
(concatenate 'string prefix-add (substitute #\- #\_ (subseq name (length prefix-remove)))))
(defun scan-types (synopsis)
(remove-duplicates
(append (mapcar #'car (mapcar #'split-signature (split-synopsis synopsis)))
(mapcar #'car (mapcan #'split-arguments
(mapcar #'third
(mapcar #'split-signature
(split-synopsis synopsis))))))
:test #'string=))
(defun missing-types (synopsis alist)
(iter (for type in (scan-types synopsis))
(unless (assoc type alist :test #'string=)
(collect type))))
(defparameter *redland-typemap*
'(("librdf_node_type" "node-type")
("char*" "new-string" ":string")
("const char *" ":string")
("const char*" ":string")
("const char **" ":pointer")
("librdf_uri*" "uri-pointer")
("librdf_uri *" "uri-pointer")
("librdf_world *" "world-pointer")
("size_t" "size-t")
("size_t *" ":pointer")
("FILE *" ":pointer")
("librdf_node *" "node-pointer")
("librdf_node*" "node-pointer")
("librdf_node **" ":pointer")
("unsigned char*" ":string")
("unsigned char *" ":pointer")
("void" ":void")
("void *" ":pointer")
("void*" ":pointer")
("void **" ":pointer")
("int" ":int")
("unsigned int" ":uint")
("librdf_iterator*" "iterator-pointer")
("void (factorylibrdf_parser_factory*)" ":pointer")
("librdf_uri_filter_func" ":pointer")
("librdf_uri_filter_funcfilter" ":pointer")
("librdf_parser_factory*" "parser-factory-pointer")
("librdf_parser_factory *" "parser-factory-pointer")
("librdf_parser*" "parser-pointer")
("librdf_parser *" "parser-pointer")
("librdf_model *" "model-pointer")
("librdf_node **" ":pointer")
("librdf_stream*" "stream-pointer")
("librdf_stream *" "stream-pointer")
("librdf_query*" "query-pointer")
("librdf_query_results*" "query-results-pointer")
("librdf_query_results *" "query-results-pointer")
("librdf_query_factory *" "query-factory-pointer")
("librdf_query *" "query-pointer")
("librdf_query_results_formatter*" "query-results-formatter-pointer")
("librdf_query_results_formatter *" "query-results-formatter-pointer")
("const char ***" ":pointer")
("unsigned char **" ":pointer")
("raptor_iostream *" "raptor-iostream-pointer")
("librdf_serializer*" "serializer-pointer")
("librdf_serializer *" "serializer-pointer")
("librdf_serializer_factory*" "serializer-factory-pointer")
("librdf_serializer_factory *" "serializer-factory-pointer")
("librdf_statement_part" "statement-part")
("librdf_statement*" "statement-pointer")
("librdf_statement *" "statement-pointer")
("librdf_storage*" "storage-pointer")
("librdf_storage *" "storage-pointer")
("librdf_storage_factory *" "storage-factory-pointer")
("librdf_hash *" "hash-pointer")
("librdf_iterator *" "iterator-pointer")
("librdf_stream_map_handler" ":pointer")
("librdf_stream_map_free_context_handler" ":pointer")
("byte*" ":pointer")
("librdf_unichar" "unichar")
("byte *" "(:pointer byte)")
("librdf_unichar *" "(:pointer unichar)")
("int *" "(:pointer :int)")
("const byte *" "(:pointer byte)")
))
(defun map-ret-type-for-redland (ret-type)
(cadr (assoc ret-type *redland-typemap* :test #'string=)))
(defun map-arg-type-for-redland (arg-type)
(let ((types (cdr (assoc arg-type *redland-typemap* :test #'string=))))
(assert types)
(if (cdr types)
(cadr types)
(car types))))
(defun transform-redland-signature (signature)
(let ((sig (split-signature signature)))
(with-output-to-string (str)
(format str "(defcfun ")
(format str "(~a \"~a\") "
(lispify-name (second sig) "librdf_" "%")
(second sig))
(format str "~a~&" (map-ret-type-for-redland (first sig)))
(let ((args (split-arguments (third sig))))
(dolist (arg args)
(format str "~& (~a ~a)"
(lispify-name (second arg))
(map-arg-type-for-redland (first arg)))))
(format str ")~&~%"))))