X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/bf090e021a5c20da452a4841cdfb8eb78e29544e..aa14a4cddcb96b681d5c19a2ec8bad382f43b264:/src/c-types-proto.lisp diff --git a/src/c-types-proto.lisp b/src/c-types-proto.lisp new file mode 100644 index 0000000..bc36b2e --- /dev/null +++ b/src/c-types-proto.lisp @@ -0,0 +1,267 @@ +;;; -*-lisp-*- +;;; +;;; Protocol for C type representation +;;; +;;; (c) 2009 Straylight/Edgeware +;;; + +;;;----- Licensing notice --------------------------------------------------- +;;; +;;; This file is part of the Sensble Object Design, an object system for C. +;;; +;;; SOD is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; SOD is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with SOD; if not, write to the Free Software Foundation, +;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +(cl:in-package #:sod) + +;;;-------------------------------------------------------------------------- +;;; Root classes and common access protocol. + +;; It seems more useful to put the root class here, so that we can provide +;; methods specialized on it, e.g., PRINT-OBJECT. + +(export 'c-type) +(defclass c-type () + () + (:documentation + "Base class for C type objects.")) + +(export '(qualifiable-c-type c-type-qualifiers)) +(defclass qualifiable-c-type (c-type) + ((qualifiers :initarg :qualifiers :initform nil + :type list :reader c-type-qualifiers)) + (:documentation + "Base class for C types which can be qualified.")) + +(export 'canonify-qualifiers) +(defun canonify-qualifiers (qualifiers) + "Return a canonical list of qualifiers." + (delete-duplicates (sort (copy-list qualifiers) #'string<))) + +(export 'qualify-c-type) +(defgeneric qualify-c-type (type qualifiers) + (:documentation + "Return a type like TYPE but with the specified QUALIFIERS. + + The qualifiers of the returned type are the union of the requested + QUALIFIERS and the qualifiers already applied to TYPE.")) + +(export 'c-type-subtype) +(defgeneric c-type-subtype (type) + (:documentation + "For compound types, return the base type.")) + +;;;-------------------------------------------------------------------------- +;;; Comparison protocol. + +(export 'c-type-equal-p) +(defgeneric c-type-equal-p (type-a type-b) + (:method-combination and) + (:documentation + "Answers whether two types TYPE-A and TYPE-B are structurally equal. + + Here, `structurally equal' means that they have the same qualifiers, + similarly spelt names, and structurally equal components.") + (:method and (type-a type-b) + (eql (class-of type-a) (class-of type-b)))) + +(defmethod c-type-equal-p and ((type-a qualifiable-c-type) + (type-b qualifiable-c-type)) + (equal (canonify-qualifiers (c-type-qualifiers type-a)) + (canonify-qualifiers (c-type-qualifiers type-b)))) + +;;;-------------------------------------------------------------------------- +;;; C syntax output protocol. + +(export 'pprint-c-type) +(defgeneric pprint-c-type (type stream kernel) + (:documentation + "Pretty-printer for C types. + + Print TYPE to STREAM. In the middle of the declarator, call the function + KERNEL with one argument: whether it needs a leading space.") + (:method :around (type stream kernel) + (typecase kernel + (null (pprint-c-type type stream + (lambda (stream prio spacep) + (declare (ignore stream prio spacep)) + nil))) + ((or function symbol) (call-next-method)) + (t (pprint-c-type type stream + (lambda (stream prio spacep) + (declare (ignore prio)) + (when spacep + (c-type-space stream)) + (princ kernel stream))))))) + +(export 'c-type-space) +(defun c-type-space (stream) + "Print a space and a miser-mode newline to STREAM. + + This is the right function to call in a PPRINT-C-TYPE kernel function when + the SPACEP argument is true." + (pprint-indent :block 2 stream) + (write-char #\space stream) + (pprint-newline :miser stream)) + +(defun maybe-in-parens* (stream condition thunk) + "Helper function for the MAYBE-IN-PARENS macro." + (multiple-value-bind (prefix suffix) + (if condition (values "(" ")") (values "" "")) + (pprint-logical-block (stream nil :prefix prefix :suffix suffix) + (funcall thunk stream)))) + +(export 'maybe-in-parens) +(defmacro maybe-in-parens ((stream condition) &body body) + "Evaluate BODY; if CONDITION, write parens to STREAM around it. + + This macro is useful for implementing the PPRINT-C-TYPE method on compound + types. The BODY is evaluated in the context of a logical block printing + to STREAM. If CONDITION is non-nil, then the block will have open/close + parens as its prefix and suffix; otherwise they will be empty. + + The STREAM is passed to PPRINT-LOGICAL-BLOCK, so it must be a symbol." + `(maybe-in-parens* ,stream ,condition (lambda (,stream) ,@body))) + +(export 'format-qualifiers) +(defun format-qualifiers (quals) + "Return a string listing QUALS, with a space after each." + (format nil "~{~(~A~) ~}" quals)) + +;;;-------------------------------------------------------------------------- +;;; S-expression notation protocol. + +(export 'print-c-type) +(defgeneric print-c-type (stream type &optional colon atsign) + (:documentation + "Print an abbreviated syntax for TYPE to the STREAM. + + This function is suitable for use in FORMAT's ~/.../ command.")) + +(export 'expand-c-type-spec) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defgeneric expand-c-type-spec (spec) + (:documentation + "Expand SPEC into Lisp code to construct a C type.") + (:method ((spec list)) + (expand-c-type-form (car spec) (cdr spec)))) + (defgeneric expand-c-type-form (head tail) + (:documentation + "Expand a C type list beginning with HEAD.") + (:method ((name (eql 'lisp)) tail) + `(progn ,@tail)))) + +(export 'c-type) +(defmacro c-type (spec) + "Expands to code to construct a C type, using EXPAND-C-TYPE-SPEC." + (expand-c-type-spec spec)) + +(export 'define-c-type-syntax) +(defmacro define-c-type-syntax (name bvl &rest body) + "Define a C-type syntax function. + + A function defined by BODY and with lambda-list BVL is associated with the + NAME. When EXPAND-C-TYPE sees a list (NAME . STUFF), it will call this + function with the argument list STUFF." + (with-gensyms (head tail) + (multiple-value-bind (doc decls body) (parse-body body) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (defmethod expand-c-type-form ((,head (eql ',name)) ,tail) + ,@doc + (destructuring-bind ,bvl ,tail + ,@decls + ,@body)) + ',name)))) + +(export 'c-type-alias) +(defmacro c-type-alias (original &rest aliases) + "Make ALIASES behave the same way as the ORIGINAL type." + (with-gensyms (head tail) + `(eval-when (:compile-toplevel :load-toplevel :execute) + ,@(mapcar (lambda (alias) + `(defmethod expand-c-type-form + ((,head (eql ',alias)) ,tail) + (expand-c-type-form ',original ,tail))) + aliases) + ',aliases))) + +(export 'defctype) +(defmacro defctype (names value) + "Define NAMES all to describe the C-type VALUE. + + NAMES can be a symbol (treated as a singleton list), or a list of symbols. + The VALUE is a C type S-expression, acceptable to EXPAND-C-TYPE. It will + be expanded once at run-time." + (let* ((names (if (listp names) names (list names))) + (namevar (gensym "NAME")) + (typevar (symbolicate 'c-type- (car names)))) + `(progn + (defparameter ,typevar ,(expand-c-type-spec value)) + (eval-when (:compile-toplevel :load-toplevel :execute) + ,@(mapcar (lambda (name) + `(defmethod expand-c-type-spec ((,namevar (eql ',name))) + ',typevar)) + names)) + 'names))) + +(export 'c-name-case) +(defun c-name-case (name) + "Convert NAME to suitable case. + + Strings are returned as-is; symbols are squashed to lower-case and hyphens + are replaced by underscores." + (typecase name + (symbol (with-output-to-string (out) + (loop for ch across (symbol-name name) + do (cond ((alpha-char-p ch) + (write-char (char-downcase ch) out)) + ((or (digit-char-p ch) + (char= ch #\_)) + (write-char ch out)) + ((char= ch #\-) + (write-char #\_ out)) + (t + (error "Bad character in C name ~S." name)))))) + (t name))) + +;;;-------------------------------------------------------------------------- +;;; Function arguments. + +(export '(argument argumentp make-argument argument-name argument-type)) +(defstruct (argument (:constructor make-argument (name type)) + (:predicate argumentp)) + "Simple structure representing a function argument." + name + type) + +(export 'commentify-argument-name) +(defgeneric commentify-argument-name (name) + (:documentation + "Produce a `commentified' version of the argument. + + The default behaviour is that temporary argument names are simply omitted + (NIL is returned); otherwise, `/*...*/' markers are wrapped around the + printable representation of the argument.") + (:method ((name null)) nil) + (:method ((name t)) (format nil "/*~A*/" name))) + +;;;-------------------------------------------------------------------------- +;;; Printing objects. + +(defmethod print-object ((object c-type) stream) + (if *print-escape* + (format stream "~:@" object) + (pprint-c-type object stream nil))) + +;;;----- That's all, folks --------------------------------------------------