--- /dev/null
+;;; -*-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 "~:@<C-TYPE ~/sod:print-c-type/~:>" object)
+ (pprint-c-type object stream nil)))
+
+;;;----- That's all, folks --------------------------------------------------
~mdw / sod / blobdiff