;;;
;;; atoms.lisp
;;;
;;; Atom Database
;;;
;;; Copyright (C) 2005, Alastair Bridgewater.
;;;

(in-package :clxs)

(defconstant +initial-atom-table-size+ 200
  "Tuning parameter. How many atoms we can handle before we need to start adjusting the atom table. Needs to be at least (length +initial-atom-list+).")

(defparameter +initial-atom-list+
  '("PRIMARY" "SECONDARY" "ARC" "ATOM" "BITMAP"
    "CARDINAL" "COLORMAP" "CURSOR"
    "CUT_BUFFER0" "CUT_BUFFER1" "CUT_BUFFER2" "CUT_BUFFER3"
    "CUT_BUFFER4" "CUT_BUFFER5" "CUT_BUFFER6" "CUT_BUFFER7"
    "DRAWABLE" "FONT" "INTEGER" "PIXMAP" "POINT"
    "RECTANGLE" "RESOURCE_MANAGER"
    "RGB_COLOR_MAP" "RGB_BEST_MAP" "RGB_BLUE_MAP"
    "RGB_DEFAULT_MAP" "RGB_GRAY_MAP"
    "RGB_GREEN_MAP" "RGB_RED_MAP"
    "STRING" "VISUALID" "WINDOW"
    "WM_COMMAND" "WM_HINTS" "WM_CLIENT_MACHINE"
    "WM_ICON_NAME" "WM_ICON_SIZE" "WM_NAME"
    "WM_NORMAL_HINTS" "WM_SIZE_HINTS" "WM_ZOOM_HINTS"
    "MIN_SPACE" "NORM_SPACE" "MAX_SPACE" "END_SPACE"
    "SUPERSCRIPT_X" "SUPERSCRIPT_Y"
    "SUBSCRIPT_X" "SUBSCRIPT_Y"
    "UNDERLINE_POSITION" "UNDERLINE_THICKNESS"
    "STRIKEOUT_ASCENT" "STRIKEOUT_DESCENT"
    "ITALIC_ANGLE" "X_HEIGHT" "QUAD_WIDTH"
    "WEIGHT" "POINT_SIZE" "RESOLUTION" "COPYRIGHT"
    "NOTICE" "FONT_NAME" "FAMILY_NAME" "FULL_NAME"
    "CAP_HEIGHT" "WM_CLASS" "WM_TRANSIENT_FOR")
  "The list of pre-defined atoms, in order, from atom-id 1 upwards.")

(defvar *num-atoms* 0 "The number of valid atoms.")
(defvar *atom-name-table* nil "An array of atom names, as strings.")

(defun assert-atom-valid (atom-id)
  "Return NIL if ATOM-ID is a valid atom identifier, otherwise invoke the PROTOCOL-ERROR restart with :ATOM and ATOM-ID."
  (if (not (<= 1 atom-id *num-atoms*))
      (invoke-restart 'protocol-error :ATOM atom-id)))

(defun is-valid-atom (atom-id)
  "Return T if ATOM-ID is a valid atom identifier, otherwise return NIL."
  (<= 1 atom-id *num-atoms*))

(defun intern-atom (name only-if-exists)
  "Return an atom-id corresponding to NAME or 0 if such an atom doesn't exist and ONLY-IF-EXISTS is true."
  (or (dotimes (i *num-atoms*)
	(when (string= name (aref *atom-name-table* i))
	  (return (1+ i))))
      
      (when only-if-exists 0)
      
      (progn
	(vector-push-extend name *atom-name-table*)
	(incf *num-atoms*))))

(defun atom-name (atom-id)
  "Return the name of atom ATOM-ID as a string. The consequences of modifying the return value are undefined."
  (assert-atom-valid atom-id)
  (aref *atom-name-table* (1- atom-id)))

(defun reset-atom-database ()
  "Reset the atom database to its initial state (just the pre-defined atoms loaded)."
  (setf *num-atoms* (length +initial-atom-list+))
  (setf *atom-name-table* (make-array 100
				      :fill-pointer t
				      :adjustable t))
  (setf (subseq *atom-name-table* 0) +initial-atom-list+)
  nil)

(define-x-request intern-atom (:opcode 16)
    ((opcode :opcode :value 16)
     (only-if-exists :bool)
     ;; FIXME: What do we do about lengths of the form (+ m (* n o)),
     ;; for constant m and o, and no externally specified n?
     (length :length :value (+ 2 (truncate (+ name-length 3) 4)))
     (name-length :u16))
  (let* ((name (sb-ext:octets-to-string request
					:external-format :latin1
					:start 8 :end (+ 8 name-length)))
	 (atom (intern-atom name only-if-exists))
	 ;; FIXME: We shouldn't be allocating responses inline like this.
	 (response (make-array 32
			       :element-type '(unsigned-byte 8)
			       :initial-element 0)))
    ;; FIXME: SET-RESPONSE-FIELDS would be nice.
    (setf (aref response 0) 1)
    (if (eq (client-state-byte-order client) :lsb-first)
	(progn
	  (setf (request-integer response 2 2 :little-endian t)
		(client-state-request-number client))
	  (setf (request-integer response 8 4 :little-endian t)
		atom))
	(progn
	  (setf (request-integer response 2 2)
		(client-state-request-number client))
	  (setf (request-integer response 8 4)
		atom)))
    (send-packet (client-state-network-client client) response)))

(define-x-request get-atom-name (:opcode 17)
    ((opcode :opcode :value 17)
     (length :length :value 2)
     (atom :atom))
  (let* ((name (atom-name atom))
	 (response (make-array (+ 32 (logand -4 (+ 3 (length name))))
			       :element-type '(unsigned-byte 8)
			       :initial-element 0)))
    (setf (aref response 0) 1)
    (if (eq (client-state-byte-order client) :lsb-first)
	(progn
	  (setf (request-integer response 2 2 :little-endian t)
		(client-state-request-number client))
	  (setf (request-integer response 4 4 :little-endian t)
		(ash (+ 3 (length name)) -2))
	  (setf (request-integer response 8 2 :little-endian t) (length name)))
	(progn
	  (setf (request-integer response 2 2)
		(client-state-request-number client))
	  (setf (request-integer response 4 4)
		(ash (+ 3 (length name)) -2))
	  (setf (request-integer response 8 2) (length name))))
    (setf (subseq response 32)
	  (sb-ext:string-to-octets name
				   :external-format :latin1
				   :null-terminate nil))
    (send-packet (client-state-network-client client) response)))

;;; EOF