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

(in-package :clxs)


;; Sign-extension functions.
;; Could probably do something clever here, but
;; for 3 functions it's probably not worth it.

(declaim (inline u8->s8))
(defun u8->s8 (value)
  (if (logbitp 7 value)
      (logior #x-80 value)
      value))

(declaim (inline u16->s16))
(defun u16->s16 (value)
  (if (logbitp 15 value)
      (logior #x-8000 value)
      value))

(declaim (inline u32->s32))
(defun u32->s32 (value)
  (if (logbitp 31 value)
      (logior #x-80000000 value)
      value))


;; Low-level buffer munging. Should probably define
;; the same for write functions as well as readers.
;; At 12 functions (24 with setters), being clever
;; here should theoretically pay off, but doesn't
;; seem to. We're being clever anyway.

;; FIXME: Better macro name than "foo".
;; FIXME: Docstrings!

(macrolet
    ((foo (i endianness little-endian)
       (labels ((byte-labels (i little-endian)
		  (funcall (if little-endian #'reverse #'identity)
			   (nthcdr (- 4 i) '(byte-3 byte-2 byte-1 byte-0))))
		(build-function-name (endian sign width)
		  (intern (concatenate 'string
				       "REQUEST-" endian sign
				       (format nil "~A" width))))
		(aref-forms (i)
		  (nthcdr (- 4 i)
			  `((aref array (+ offset ,(- i 4)))
			    (aref array (+ offset ,(- i 3)))
			    (aref array (+ offset ,(- i 2)))
			    (aref array (+ offset ,(- i 1))))))
		(build-dpb (i)
		  (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- i)))
		(build-ldb-bindings (i)
		  (nthcdr (- 4 i)
			  '((byte-3 (ldb (byte 8 24) value))
			    (byte-2 (ldb (byte 8 16) value))
			    (byte-1 (ldb (byte 8 8) value))
			    (byte-0 (ldb (byte 8 0) value))))))
	 (let ((function-name-1 (build-function-name
				 endianness "U" (* 8 i)))
	       (function-name-2 (build-function-name
				 endianness "S" (* 8 i)))
	       (sign-extend (intern (format nil "U~A->S~A" (* 8 i) (* 8 i)))))
	   `(progn
	     (declaim (inline ,function-name-1))
	     (declaim (inline ,function-name-2))
	     (declaim (inline (setf ,function-name-1)))
	     (declaim (inline (setf ,function-name-2)))
	     (defun ,function-name-1 (array offset)
	       (let ,(mapcar #'list (byte-labels i little-endian)
			     (aref-forms i))
		 ,(build-dpb i)))
	     (defun (setf ,function-name-1) (value array offset)
	       (let ,(build-ldb-bindings i)
		 ,@(mapcar #'(lambda (a b) (list 'setf a b))
			   (aref-forms i)
			   (byte-labels i little-endian))))
	     (defun ,function-name-2 (array offset)
	       (,sign-extend (,function-name-1 array offset)))
	     (defun (setf ,function-name-2) (value array offset)
	       (setf (,function-name-1 array offset) value)))))))
  (foo 1 "LE-" t)
  (foo 2 "LE-" t)
  (foo 4 "LE-" t)
  (foo 1 "BE-" nil)
  (foo 2 "BE-" nil)
  (foo 4 "BE-" nil))


;;; 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)

(defmacro define-wire-type (type base-type &key binding-form error validator)
  `(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)
  (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)
  (getf *wire-type-binding-forms* type #'identity))

(defun wire-type-default-error (type)
  (getf *wire-type-errors* type :value))

(defun wire-slot-validation (name gensym type)
  (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 endianness)
  (loop for slot in slots
	for offset in offsets
	for gensym in gensyms
	for type = (cadr slot)
	for wire-type-base-type = (string (wire-type-base-type type))
	for reader-function = (intern (concatenate 'string
						   "REQUEST-"
						   endianness
						   wire-type-base-type))
	collect `(setf ,gensym (,reader-function request ,offset))))

(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 (append value-check typep-check validator)))
      (when check-form
	`((unless ,(if (cdr check-form)
		       `(and ,check-form)
		       (car 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 slot in slot-widths
			     collect offset
			     do (incf offset slot)))
	 (little-endian-field-readers
	  (field-readers slots slot-offsets gensyms "LE-"))
	 (big-endian-field-readers
	  (field-readers slots slot-offsets gensyms "BE-"))
	 (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 nil))
    ;; parse declarations out of body.
    (do ()
	((not (eq (caar body) 'declare)))
      (setf declarations (append declarations (list (car body))))
      (setf body (cdr 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 :u8 :value 112 :error :implementation)
     (mode :u8 :typecheck '(integer 0 2)) ; error defaults to :value here
     (length :u16 :value 1 :error :length))
  (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 :U8 :VALUE 112 :ERROR :IMPLEMENTATION)
                          (MODE :U8 :TYPECHECK '(INTEGER 0 2))
                          (LENGTH :U16 :VALUE 1 :ERROR :LENGTH))
                         (SETF (CLIENT-STATE-CLOSE-DOWN-MODE CLIENT)
                                 (ELT
                                  '(:DESTROY :RETAIN-PERMANENT
                                             :RETAIN-TEMPORARY)
                                  MODE)))

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

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

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

(fnord!)

|#

;;; EOF
