;;;--------------------------------------------------------------------------
;;; C types stuff.

(cl:defpackage #:c-types
  (:use #:common-lisp
	#+sbcl #:sb-mop
	#+(or cmu clisp) #:mop
	#+ecl #:clos)
  (:export #:c-type
	   #:c-declarator-priority #:maybe-parenthesize
	   #:pprint-c-type
	   #:c-type-subtype #:compount-type-declaration
	   #:qualifiable-c-type #:c-type-qualifiers #:format-qualifiers
	   #:simple-c-type #:c-type-name
	   #:c-pointer-type
	   #:tagged-c-type #:c-enum-type #:c-struct-type #:c-union-type
	   #:tagged-c-type-kind
	   #:c-array-type #:c-array-dimensions
	   #:make-argument #:argument-name #:argument-type
	   #:c-function-type #:c-function-arguments

	   #:define-c-type-syntax #:c-type-alias #:defctype
	   #:print-c-type
	   #:qualifier #:declare-qualifier
	   #:define-simple-c-type

	   #:const #:volatile #:static #:restrict
	   #:char #:unsigned-char #:uchar #:signed-char #:schar
	   #:int #:signed #:signed-int #:sint
	   #:unsigned #:unsigned-int #:uint
	   #:short #:signed-short #:short-int #:signed-short-int #:sshort
	   #:unsigned-short #:unsigned-short-int #:ushort
	   #:long #:signed-long #:long-int #:signed-long-int #:slong
	   #:unsigned-long #:unsigned-long-int #:ulong
	   #:float #:double #:long-double
	   #:pointer #:ptr
	   #:[] #:vec
	   #:fun #:func #:fn))


;;;--------------------------------------------------------------------------
;;; Convenient syntax for C types.

;; Basic machinery.

;; Qualifiers.  They have hairy syntax and need to be implemented by hand.

;; Simple types.

;; Pointers.

;; Tagged types.

;; Arrays.

;; Functions.


(progn
  (defconstant q-byte (byte 3 0))
  (defconstant q-const 1)
  (defconstant q-volatile 2)
  (defconstant q-restrict 4)

  (defconstant z-byte (byte 3 3))
  (defconstant z-unspec 0)
  (defconstant z-short 1)
  (defconstant z-long 2)
  (defconstant z-long-long 3)
  (defconstant z-double 4)
  (defconstant z-long-double 5)

  (defconstant s-byte (byte 2 6))
  (defconstant s-unspec 0)
  (defconstant s-signed 1)
  (defconstant s-unsigned 2)

  (defconstant t-byte (byte 3 8))
  (defconstant t-unspec 0)
  (defconstant t-int 1)
  (defconstant t-char 2)
  (defconstant t-float 3)
  (defconstant t-user 4))

(defun make-type-flags (size sign type &rest quals)
  (let ((flags 0))
    (dolist (qual quals)
      (setf flags (logior flags qual)))
    (setf (ldb z-byte flags) size
	  (ldb s-byte flags) sign
	  (ldb t-byte flags) type)
    flags))


(defun expand-c-type (spec)
  "Parse SPEC as a C type and return the result.

   The SPEC can be one of the following.

     * A C-TYPE object, which is returned immediately.

     * A list, (OPERATOR . ARGUMENTS), where OPERATOR is a symbol: a parser
       function associated with the OPERATOR symbol by DEFINE-C-TYPE-SYNTAX
       or some other means is invoked on the ARGUMENTS, and the result is
       returned.

     * A symbol, which is treated the same way as a singleton list would be."

  (flet ((interp (sym)
	   (or (get sym 'c-type)
	       (error "Unknown C type operator ~S." sym))))
    (etypecase spec
      (c-type spec)
      (symbol (funcall (interp spec)))
      (list (apply (interp (car spec)) (cdr spec))))))

(defmacro c-type (spec)
  "Evaluates to the type that EXPAND-C-TYPE would return.

   Currently this just quotes SPEC and calls EXPAND-C-TYPE at runtime.  Maybe
   later it will do something more clever."
  `(expand-c-type ',spec))

;; S-expression machinery.  Qualifiers have hairy syntax and need to be
;; implemented by hand.

(defun qualifier (qual &rest args)
  "Parse a qualified C type.

   The ARGS consist of a number of qualifiers and exactly one C-type
   S-expression.  The result is a qualified version of this type, with the
   given qualifiers attached."
  (if (null args)
      qual
      (let* ((things (mapcar #'expand-c-type args))
	     (quals (delete-duplicates
		     (sort (cons qual (remove-if-not #'keywordp things))
			   #'string<)))
	     (types (remove-if-not (lambda (thing) (typep thing 'c-type))
				   things)))
	(when (or (null types)
		  (not (null (cdr types))))
	  (error "Only one proper type expected in ~S." args))
	(qualify-type (car types) quals))))
(setf (get 'qualifier 'c-type) #'qualifier)

(defun declare-qualifier (qual)
  "Defines QUAL as being a type qualifier.

   When used as a C-type operator, it applies that qualifier to the type that
   is its argument."
  (let ((kw (intern (string qual) :keyword)))
    (setf (get qual 'c-type)
	  (lambda (&rest args)
	    (apply #'qualifier kw args)))))

;; Define some initial qualifiers.
(dolist (qual '(const volatile restrict))
  (declare-qualifier qual))


(define-c-type-syntax simple-c-type (name)
  "Constructs a simple C type called NAME (a string or symbol)."
  (make-simple-type (c-name-case name)))

(defmethod print-c-type :around
    (stream (type qualifiable-c-type) &optional colon atsign)
  (if (c-type-qualifiers type)
      (pprint-logical-block (stream nil :prefix "(" :suffix ")")
	(format stream "QUALIFIER~{ ~:_~:I~A~} ~:_"
		(c-type-qualifiers type))
	(call-next-method stream type colon atsign))
      (call-next-method)))
;; S-expression syntax.


(define-c-type-syntax enum (tag)
  "Construct an enumeration type named TAG."
  (make-instance 'c-enum-type :tag (c-name-case tag)))
(define-c-type-syntax struct (tag)
  "Construct a structure type named TAG."
  (make-instance 'c-struct-type :tag (c-name-case tag)))
(define-c-type-syntax union (tag)
  "Construct a union type named TAG."
  (make-instance 'c-union-type :tag (c-name-case tag)))

(defgeneric make-me-argument (message class)
  (:documentation
   "Return an ARGUMENT object for the `me' argument to MESSAGE, as
   specialized to CLASS."))

(defmethod make-me-argument
    ((message basic-message) (class sod-class))
  (make-argument "me" (make-instance 'c-pointer-type
				     :subtype (sod-class-type class))))

;;;--------------------------------------------------------------------------
;;; Keyword arguments and lambda lists.

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun transform-otherkeys-lambda-list (bvl)
    "Process a simple lambda-list BVL which might contain &OTHER-KEYS.

   &OTHER-KEYS VAR, if it appears, must appear just after the &KEY arguments
   (which must also be present); &ALLOW-OTHER-KEYS must not be present.

   The behaviour is that

     * the presence of non-listed keyword arguments is permitted, as if
       &ALLOW-OTHER-KEYS had been provided, and

     * a list of the keyword arguments other than the ones explicitly listed
       is stored in the VAR.

   The return value is a replacement BVL which binds the &OTHER-KEYS variable
   as an &AUX parameter if necessary.

   At least for now, fancy things like destructuring lambda-lists aren't
   supported.  I suspect you'll get away with a specializing lambda-list."

    (prog ((new-bvl nil)
	   (rest-var nil)
	   (keywords nil)
	   (other-keys-var nil)
	   (tail bvl))

     find-rest
       ;; Scan forwards until we find &REST or &KEY.  If we find the former,
       ;; then remember the variable name.  If we find the latter first then
       ;; there can't be a &REST argument, so we should invent one.  If we
       ;; find neither then there's nothing to do.
       (when (endp tail)
	 (go ignore))
       (let ((item (pop tail)))
	 (push item new-bvl)
	 (case item
	   (&rest (when (endp tail)
		    (error "Missing &REST argument name"))
		  (setf rest-var (pop tail))
		  (push rest-var new-bvl))
	   (&aux (go ignore))
	   (&key (unless rest-var
		   (setf rest-var (gensym "REST"))
		   (setf new-bvl (nconc (list '&key rest-var '&rest)
					(cdr new-bvl))))
		 (go scan-keywords)))
	 (go find-rest))

     scan-keywords
       ;; Read keyword argument specs one-by-one.  For each one, stash it on
       ;; the NEW-BVL list, and also parse it to extract the keyword, which
       ;; we stash in KEYWORDS.  If we don't find &OTHER-KEYS then there's
       ;; nothing for us to do.
       (when (endp tail)
	 (go ignore))
       (let ((item (pop tail)))
	 (push item new-bvl)
	 (case item
	   ((&aux &allow-other-keys) (go ignore))
	   (&other-keys (go fix-tail)))
	 (let ((keyword (if (symbolp item)
			    (intern (symbol-name item) :keyword)
			    (let ((var (car item)))
			      (if (symbolp var)
				  (intern (symbol-name var) :keyword)
				  (car var))))))
	   (push keyword keywords))
	 (go scan-keywords))

     fix-tail
       ;; We found &OTHER-KEYS.  Pick out the &OTHER-KEYS var.
       (pop new-bvl)
       (when (endp tail)
	 (error "Missing &OTHER-KEYS argument name"))
       (setf other-keys-var (pop tail))
       (push '&allow-other-keys new-bvl)

       ;; There should be an &AUX next.  If there isn't, assume there isn't
       ;; one and provide our own.  (This is safe as long as nobody else is
       ;; expecting to plumb in lambda keywords too.)
       (when (and (not (endp tail)) (eq (car tail) '&aux))
	 (pop tail))
       (push '&aux new-bvl)

       ;; Add our shiny new &AUX argument.
       (let ((keys-var (gensym "KEYS"))
	     (list-var (gensym "LIST")))
	 (push `(,other-keys-var (do ((,list-var nil)
				      (,keys-var ,rest-var (cddr ,keys-var)))
				     ((endp ,keys-var) (nreverse ,list-var))
				   (unless (member (car ,keys-var)
						   ',keywords)
				     (setf ,list-var
					   (cons (cadr ,keys-var)
						 (cons (car ,keys-var)
						       ,list-var))))))
	       new-bvl))

       ;; Done.
       (return (nreconc new-bvl tail))

     ignore
       ;; Nothing to do.  Return the unmolested lambda-list.
       (return bvl))))

(defmacro lambda-otherkeys (bvl &body body)
  "Like LAMBDA, but with a new &OTHER-KEYS lambda-list keyword."
  `(lambda ,(transform-otherkeys-lambda-list bvl) ,@body))

(defmacro defun-otherkeys (name bvl &body body)
  "Like DEFUN, but with a new &OTHER-KEYS lambda-list keyword."
  `(defun ,name ,(transform-otherkeys-lambda-list bvl) ,@body))

(defmacro defmethod-otherkeys (name &rest stuff)
  "Like DEFMETHOD, but with a new &OTHER-KEYS lambda-list keyword."
  (do ((quals nil)
       (stuff stuff (cdr stuff)))
      ((listp (car stuff))
       `(defmethod ,name ,@(nreverse quals)
	    ,(transform-otherkeys-lambda-list (car stuff))
	  ,@(cdr stuff)))
    (push (car stuff) quals)))


(defparse many ((acc init update
		 &key (new 'it) (final acc) (min nil minp) max (commitp t))
		parser &optional (sep nil sepp))
  "Parse a sequence of homogeneous items.

   The behaviour is similar to `do'.  Initially an accumulator ACC is
   established, and bound to the value of INIT.  The PARSER is then evaluated
   repeatedly.  Each time it succeeds, UPDATE is evaluated with NEW (defaults
   to `it') bound to the result of the parse, and the value returned by
   UPDATE is stored back into ACC.  If the PARSER fails, then the parse ends.

   If a SEP parser is provided, then the behaviour changes as follows.
   Before each attempt to parse a new item using PARSER, the parser SEP is
   invoked.  If SEP fails then the parse ends; if SEP succeeds, then the
   PARSER must also succeed or the overall parse will fail.

   If MAX (which will be evaluated) is not nil, then it must be a number: the
   parse ends automatically after PARSER has succeeded MAX times.  When the
   parse has ended, if the PARSER succeeded fewer than MIN (which will be
   evaluated) times then the parse fails.  Otherwise, the FINAL form (which
   defaults to simply returning ACC) is evaluated and its value becomes the
   result of the parse.  MAX defaults to nil -- i.e., no maximum; MIN
   defaults to 1 if a SEP parser is given, or 0 if not.

   Note that `many' cannot fail if MIN is zero."

  (unless minp (setf min (if sepp 1 0)))
  (with-gensyms (block value win consumedp cp i up done)
    (once-only (init min max commitp)
      (let ((counterp (or max (not (numberp min)) (> min (if sepp 1 0)))))
	`(block ,block

	   ;; Keep track of variables.  We only need an accumulator if it's
	   ;; not nil, and we don't need a counter if (a) there's no maximum,
	   ;; and either (b) the minimum is zero, or (c) the minimum is one
	   ;; and there's a separator.  In case (c), we can keep track of how
	   ;; much has been seen using control flow.
	   (let ((,consumedp nil)
		 ,@(and acc `((,acc ,init)))
		 ,@(and counterp `((,i 0))))

	     ;; Some handy functions.  `up' will update the accumulator.
	     ;; `done' will return the necessary final value.
	     (flet (,@(and acc `((,up (,new)
				   (declare (ignorable ,new))
				   (setf ,acc ,update))))
		    (,done () (return-from ,block
				(values ,final t ,consumedp))))

	       ;; If there's a separator, prime the pump by parsing a first
	       ;; item.  This makes the loop easy: it just parses a separator
	       ;; and an item each time.  And it means we don't need a
	       ;; counter in the case of a minimum of 1.
	       ,@(and sepp
		      `((multiple-value-bind (,value ,win ,cp)
			    (parse ,parser)
			  (when ,cp (setf ,consumedp t))
			  (unless ,win
			    ,(cond ((eql min 0)
				    `(,done))
				   ((and (numberp min) (plusp min))
				    `(return-from ,block
				       (values ,value nil ,consumedp)))
				   (t
				    `(if (< 0 ,min)
					 (return-from ,block
					   (values ,value nil, consumedp))
					 (,done)))))
			  ,@(and acc `((,up ,value))))
			,@(and counterp `((incf ,i)))))

	       ;; The main loop...
	       (loop

		 ;; If we've hit the maximum then stop.  But, attention, if
		 ;; we have a separator and we're not committing to parsing
		 ;; items, then check after scanning the separator, not
		 ;; before.
		 ,@(and max commitp
			`((when (and ,@(and (not (constantp max))
					    `(,max))
				     ,@(and (not (constantp commitp))
					    `(,commitp))
				     (>= ,i ,max))
			    (,done))))

		 ,@(if sepp
		       ;; We're expecting a separator.  If this fails and
		       ;; we're below minimum then we've failed altogether.
		       ;; If it succeeds then we should go on to parse an
		       ;; item.
		       `((multiple-value-bind (,value ,win ,cp) (parse ,sep)
			   ,@(and (numberp min) (<= min 1)
				  `((declare (ignore ,value))))
			   (when ,cp (setf ,consumedp t))
			   (unless ,win
			     ,(if (and (numberp min) (<= min 1))
				  `(,done)
				  `(if (>= ,i ,min)
				       (return ,final)
				       (return-from ,block
					 (values ,value nil ,consumedp))))))

			 ;; If we're not committing then now is the time to
			 ;; check for hitting the maximum number of
			 ;; repetitions.
			 ,@(and max (or (not commitp)
					(not (constantp commitp)))
				`((when (and ,@(and (not (constantp max))
						    `(,max))
					     ,@(and commitp
						    `((not ,commitp)))
					     (>= ,i ,max))
				    (,done))))

			 ;; Now parse an item.  If this fails and we're
			 ;; committed then we've blown the whole parse.  If
			 ;; it fails and we've not committed then we need to
			 ;; check the minimum.  It's getting very tempting to
			 ;; write a compiler for optimizing these
			 ;; conditionals.  (If we don't do this, we get
			 ;; annoying warnings.)
			 (multiple-value-bind (,value ,win ,cp)
			     (parse ,parser)
			   (when ,cp (setf ,consumedp t))
			   (unless ,win
			     ,(cond ((and (constantp commitp) commitp)
				     `(return-from ,block
					(values ,value nil ,consumedp)))
				    ((not commitp)
				     (if (and (numberp min) (<= min 1))
					 `(,done)
					 `(if (>= ,i ,min)
					      (,done)
					      (return-from ,block
						(values ,value nil
							,consumedp)))))
				    ((and (numberp min) (<= min 1))
				     `(if ,commitp
					  (return-from ,block
					    (values ,value nil ,consumedp))
					  (,done)))
				    (t
				     `(if (or ,commitp (< ,i ,min))
					  (return-from ,block
					    (values ,value nil ,consumedp))
					  (,done)))))
			   ,@(and acc `((,up ,value)))))

		       ;; No separator.  Just parse the value.  If it fails,
		       ;; check that we've met the minimum.
		       `((multiple-value-bind (,value ,win ,cp)
			     (parse ,parser)
			   ,@(and (eql min 0) (null acc)
				  `((declare (ignore ,value))))
			   (when ,cp (setf ,consumedp t))
			   (unless ,win
			     ,(if (eql min 0)
				  `(,done)
				  `(if (>= ,i ,min)
				       (,done)
				       (return-from ,block
					 (values ,value nil ,consumedp)))))
			  ,@(and acc `((,up ,value))))))

		 ;; Done.  Update the counter and go round again.
		 ,@(and counterp `((incf ,i)))))))))))