;;; -*- Mode: Lisp; Package: EDITOR -*-
;;;
;;; This file is part of xyzzy.
;;;

(provide "re-kwd")
(in-package "editor")

(export '(compile-regexp-keyword-list compile-regexp-keyword))

(defun re-kwd-attributes (l)
  (apply #'logior (mapcar #'(lambda (x)
			      (case x
				(:bold #x200000)
				(:underline #x800000)
				(:strike-out #x1000000)
				(:line 2)
				(t (error "Bad attribute: ~a" x))))
			  l)))

(defun re-kwd-index-color (l)
  (let ((fg (pop l))
	(bg (pop l)))
    (logior (cond ((null fg) 1)
		  ((and (integerp fg)
			(<= 0 fg 16))
		   (+ (ash fg 9) 1))
		  (t (error "Bad foreground color: ~a" fg)))
	    (cond ((null bg) 0)
		  ((and (integerp bg)
			(<= 0 bg 16))
		   (ash bg 17))
		  (t (error "Bad background: ~a" bg)))
	    (re-kwd-attributes l))))

(defun re-kwd-color (color)
  (or (cond ((consp color)
	     (cond ((consp (car color))
		    (mapcar #'(lambda (x)
				(unless (consp x)
				  (error "Invalid color format: ~a" x))
				(unless (and (integerp (car x))
					     (<= 0 (car x) 9))
				  (error "Bad reference number: ~a" (car x)))
				(cons (car x)
				      (cond ((null (cdr x)) nil)
					    ((eq (cdr x) 't) 0)
					    (t (re-kwd-color (cdr x))))))
			    color))
		   ((eq (car color) ':keyword)
		    (unless (consp (cadr color))
		      (logior (re-kwd-color (cadr color))
			      (re-kwd-attributes (cddr color)))))
		   ((eq (car color) ':color)
		    (re-kwd-index-color (cdr color)))
		   (t nil)))
	    (t
	     (gethash (if (and (integerp color)
			       (<= 0 color 18))
			  (char-downcase (digit-char color 19))
			(case color
			  (:string #\S)
			  (:tag #\T)
			  (:comment #\C)
			  (t color)))
		      *keyword-translate-hash-table*)))
      (error "Bad color: ~a" color)))

(defun re-kwd-context (ctx)
  (cond ((consp ctx)
	 (apply #'logior (mapcar #'re-kwd-context ctx)))
	((null ctx) 1)
	((eq ctx ':string) 2)
	((eq ctx ':tag) 4)
	((eq ctx ':comment) 8)
	((eq ctx 't) 15)
	(t (error "Bad keyword context: ~a" ctx))))

(defun compile-regexp-keyword (regexp case-fold color
			       &optional context begin end)
  (list (if (regexpp regexp)
	    regexp
	  (compile-regexp regexp case-fold))
	(re-kwd-color color)
	(re-kwd-context context)
	(let ((x (or begin 0)))
	  (or (< -10 x 10)
	      (error "BEGIN out-of-range: ~a" x))
	  x)
	(let ((x (or end 0)))
	  (or (< -10 x 10)
	      (error "END out-of-range: ~a" x))
	  x)))

(defun compile-regexp-keyword-list (list)
  (mapcar #'(lambda (x) (apply #'compile-regexp-keyword x)) list))
