;;;
;;; request.lisp
;;;
;;; Request Processing
;;;
;;; Copyright (C) 2005, Alastair Bridgewater
;;;

(in-package :clxs)


;;; Low-level buffer munging.

(defun request-integer (array offset length &key little-endian sign-extend)
  "Decode an integer of LENGTH octets from ARRAY starting at OFFSET."
  (let ((value (loop
		  for i from 0 below length
		  for octet = (aref array (+ offset
					     (if little-endian
						 i
						 (- length i 1))))
		  sum (ash octet (* i 8)))))
    (if (and sign-extend
	     (logbitp (1- (* length 8)) value))
	(logior (lognot (1- (ash 1 (1- (* length 8))))) value)
	value)))

(defun (setf request-integer) (value array offset length &key little-endian sign-extend)
  (declare (ignore sign-extend))
  (loop
     for value2 = value then (ash value2 -8)
     for i from 0 below length
     do (setf (aref array (+ offset
			     (if little-endian
				 i
				 (- length i 1))))
	      (logand #xff value2)))
  value)

(define-compiler-macro request-integer (&whole form array offset length &key little-endian sign-extend)
  (if (and (member length '(1 2 4))
	   (member little-endian '(t nil))
	   (member sign-extend '(t nil)))
      `(let* (,@(loop
		   for i from 0 below length
		   for var in '(byte-0 byte-1 byte-2 byte-3)
		   collect `(,var (aref ,array (+ ,offset
						  ,(if little-endian
						       i
						       (- length i 1))))))
	      (value ,(elt '(#1=byte-0
			     #2=(dpb byte-1 (byte 8 8) #1#)
			     #3=(dpb byte-2 (byte 8 16) #2#)
			     (dpb byte-3 (byte 8 24) #3#))
			   (1- length))))
	 ,(if sign-extend
	      `(if (logbitp ,(1- (* length 8)) value)
		   (logior ,(lognot (1- (ash 1 (1- (* length 8))))) value)
		   value)
	      'value))
      form))

;; FIXME: Define compiler-macro for (setf request-integer).

;;; Request Handler Table Accessors

(defvar *request-handler-table* (make-array #x100 :initial-element nil))

(defun request-handler (opcode)
  (declare (type (unsigned-byte 8) opcode))
  (aref *request-handler-table* opcode))

(defun (setf request-handler) (handler opcode)
  (declare (type (unsigned-byte 8) opcode))
  (setf (aref *request-handler-table* opcode) handler))


;;; Request Handlers
;; This is, to date, the hairiest macrology I have written in Lisp.

(defmacro define-x-request (name (&key opcode) slots &body body)
  (unless opcode (error "No opcode passed for DEFINE-X-REQUEST ~A." name))
  (let ((function-name (intern (concatenate 'string
					    "HANDLE-X-REQUEST-"
					    (symbol-name name)))))
    `(progn
      (define-request-handler ,function-name ,slots ,@body)
      (setf (request-handler ,opcode) #',function-name))))

(defparameter *wire-base-type-widths*
  '(:u8 1 :s8 1 :u16 2 :s16 2 :u32 4 :s32 4))

(defparameter *wire-type-base-types* nil)
(defparameter *wire-type-binding-forms* nil)
(defparameter *wire-type-errors* nil)
(defparameter *wire-type-validators* nil)

(defun enum-type-p (type)
  (and (listp type)
       (eq (first type) :enum)))

(defun union-type-p (type)
  (and (listp type)
       (eq (first type) :union)))

(defmacro define-wire-type (type base-type &key binding-form error validator)
  (if (enum-type-p base-type)
      (let* ((enum-values (third base-type))
	     (lower-bound (if (first enum-values) 0 1))
	     (upper-bound (1- (length enum-values))))
	`(progn
	   (setf (getf *wire-type-base-types* ,type) ,(second base-type))
	   (setf (getf *wire-type-binding-forms* ,type)
		 (lambda (gensym)
		   `(and (<= ,',lower-bound ,gensym ,',upper-bound)
			 (elt ',',enum-values ,gensym))))
	   ,(when error `(setf (getf *wire-type-errors* ,type) ,error))
	   (setf (getf *wire-type-validators* ,type)
		 (lambda (slot gensym)
		   (declare (ignore slot))
		   `(<= ,',lower-bound ,gensym ,',upper-bound)))))
      `(progn
	 (setf (getf *wire-type-base-types* ,type) ,base-type)
	 ,(when binding-form `(setf (getf *wire-type-binding-forms* ,type) ,binding-form))
	 ,(when error `(setf (getf *wire-type-errors* ,type) ,error))
	 ,(when validator `(setf (getf *wire-type-validators* ,type) ,validator)))))

(defun wire-type-base-type (type)
  (cond
    ((enum-type-p type)
     (second type))

    ((union-type-p type)
     :u32)

    (t (let ((base-type (getf *wire-type-base-types* type)))
	 (unless base-type (error "Unknown wire type ~A." type))
	 base-type))))

(defun wire-type-width (type)
  (getf *wire-base-type-widths* (wire-type-base-type type)))

(defun wire-type-binding-form-function (type)
  (cond
    ((enum-type-p type)
     (let* ((enum-values (third type))
	    (lower-bound (if (first enum-values) 0 1))
	    (upper-bound (1- (length enum-values))))
	 (lambda (gensym)
	   `(and (<= ,lower-bound ,gensym ,upper-bound)
		 (elt ',enum-values ,gensym)))))

    ((union-type-p type)
     (let ((resource-type (find-if-not #'enum-type-p (rest type)))
	   (enum-type (find-if #'enum-type-p (rest type))))
       (lambda (gensym)
	 `(or ,(funcall (wire-type-binding-form-function enum-type) gensym)
	      ,(funcall (wire-type-binding-form-function resource-type) gensym)))))

    (t (getf *wire-type-binding-forms* type #'identity))))

(defun wire-type-default-error (type)
  (cond
    ((enum-type-p type)
     :value)

    ((union-type-p type)
     (wire-type-default-error (find-if-not #'enum-type-p (rest type))))

    (t (getf *wire-type-errors* type :value))))

(defun wire-slot-validation (name gensym type)
  (cond
    ((enum-type-p type)
     (let* ((enum-values (third type))
	    (lower-bound (if (first enum-values) 0 1))
	    (upper-bound (1- (length enum-values))))
       `(<= ,lower-bound ,gensym ,upper-bound)))

    ((union-type-p type)
     (let ((resource-type (find-if-not #'enum-type-p (rest type)))
	   (enum-type (find-if #'enum-type-p (rest type))))
       `(or ,(wire-slot-validation name gensym enum-type)
	    ,(wire-slot-validation name gensym resource-type))))

    (t (let ((validation-function (getf *wire-type-validators* type)))
	 (when validation-function (funcall validation-function name gensym))))))

(defun wire-slot-binding-form (slot gensym)
  `(,(car slot) ,(funcall (wire-type-binding-form-function
			   (cadr slot)) gensym)))

(defun field-readers (slots offsets gensyms little-endian)
  (loop for slot in slots
	for offset in offsets
	for gensym in gensyms
	for type = (cadr slot)
	for width = (wire-type-width type)
        collect `(setf ,gensym (request-integer request ,offset ,width :little-endian ,little-endian))))

(defun field-validation (slot gensym)
  (destructuring-bind (name type &key (value nil value-p) typecheck error) slot
    (unless error (setf error (wire-type-default-error type)))
    (let* ((value-check (when value-p `((= ,name ,value))))
	   (typep-check (when typecheck `((typep ,name ,typecheck))))
	   (validator (wire-slot-validation name gensym type))
	   (validator (and validator (list validator)))
	   (check-form `(and ,@value-check ,@typep-check ,@validator)))
      (when (cdr check-form)
	`((unless ,check-form
	    (protocol-error ,error ,gensym)))))))

(defmacro define-request-handler (name slots &body body)
  (let* ((gensyms (loop for slot in slots collect (gensym)))
	 (slot-widths (loop for slot in slots
			    collect (wire-type-width (cadr slot))))
	 (slot-offsets (loop with offset = 0
			     for width in slot-widths
			     ;; pad offset out to next multiple of width
			     do (setf offset (logand (+ offset (1- width))
						     (lognot (1- width))))
			     collect offset
			     do (incf offset width)))
	 (little-endian-field-readers
	  (field-readers slots slot-offsets gensyms t))
	 (big-endian-field-readers
	  (field-readers slots slot-offsets gensyms nil))
	 (field-bindings (loop for slot in slots
			       for gensym in gensyms
			       collect (wire-slot-binding-form slot gensym)))
	 (field-validations (loop for slot in slots
				  for gensym in gensyms
				  append (field-validation slot gensym)))
	 (declarations (loop while (eq (caar body) 'declare)
			     collect (pop body))))
    ;; create handler function form.
    `(defun ,name (client request)
      (let ((byte-order (client-state-byte-order client))
	    ,@gensyms)
	(if (eq byte-order :lsb-first)
	    (progn
	      ,@little-endian-field-readers)
	    (progn
	      ,@big-endian-field-readers))
	(let ,field-bindings
	  ,@declarations
	  ,@field-validations
	  (progn
	    ,@body))))))

#|
(define-x-request set-close-down-mode (:opcode 112)
    ((opcode :opcode :value 112)
     (mode :u8 :typecheck '(integer 0 2)) ; error defaults to :value here
     (length :length :value 1))
  (setf (client-state-close-down-mode client)
	(elt '(:destroy :retain-permanent :retain-temporary) mode)))

 (DEFINE-REQUEST-HANDLER HANDLE-X-REQUEST-SET-CLOSE-DOWN-MODE
                         ((OPCODE :OPCODE :VALUE 112)
                          (MODE :U8 :TYPECHECK '(INTEGER 0 2))
                          (LENGTH :LENGTH :VALUE 1))
                         (SETF (CLIENT-STATE-CLOSE-DOWN-MODE CLIENT)
                                 (ELT
                                  '(:DESTROY :RETAIN-PERMANENT
                                             :RETAIN-TEMPORARY)
                                  MODE)))

(define-x-request map-window (:opcode 8)
    ((opcode :opcode :value 8)
     (unused :u8)
     (length :length :value 2)
     (window :window))
  (declare (ignore unused))
  (map-window window))

 (DEFINE-REQUEST-HANDLER HANDLE-X-REQUEST-MAP-WINDOW
                         ((OPCODE :OPCODE :VALUE 8)
                          (UNUSED :U8) (LENGTH :LENGTH :VALUE 2)
                          (WINDOW :WINDOW))
                         (DECLARE (IGNORE UNUSED))
                         (MAP-WINDOW WINDOW))

(define-x-request intern-atom (:opcode 16)
    ((opcode :opcode :value 16)
     (unused :u8)
     (length :length :value (+ 2 (ash (+ 3 name-length) -2)))
     (name-length :u16))
  (declare (ignore unused))
  )

(fnord!)

|#

;;; EOF