comparison admin/unidata/unidata-gen.el @ 94071:03be13c38b12

(unidata-prop-alist): Fix typo in description of `numeric-value'. (unidata-put-character): Fix typo in error message.

94070:df7b21ec7a29

;;	  (char-code-property-register PROP FILE)
;;	where PROP is a symbol representing a character property
;;	(name, generic-category, etc), and FILE is a name of one of
;;	the following files.
;;
;;   uni-name.el, uni-cat.el, uni-comb.el, uni-bidi.el
;;	It contains a single form of this format:
;;	  (char-code-property-register PROP CHAR-TABLE)
;;	where PROP is the same as above, and CHAR-TABLE is a
;;	char-table containing property values in a compressed format.
;;
;;   When they are installed in .../lisp/international/, the file

     "Unicode numeric value (digit).
Property value is an integer.")
    (numeric-value
     8 unidata-gen-table-symbol "uni-numeric.el"
     "Unicode numeric value (numeric).
Property value is an symbol.")
    (mirrored
     9 unidata-gen-table-symbol "uni-mirrored.el"
     "Unicode bidi mirrored flag.
Property value is a symbol `Y' or `N'.")
    (old-name

      (aref vec (- char block-head))))))

(defun unidata-put-character (char val table)
  (or (characterp val)
      (not val)
      (error "Not an character nor nil: %S" val))
  (let ((current-val (aref table char)))
    (unless (eq current-val val)
      (if (stringp current-val)
	  (funcall (char-table-extra-slot table 1) char current-val table))
      (aset table char val))))

		     (setq this-val val))
		 (setq first-char (1+ first-char))))
	     this-val))
	  ((> val 0)
	   (aref val-table (1- val))))))
	
;; Return a integer-type character property value of CHAR.  VAL is the
;; current value of (aref TABLE CHAR).

(defun unidata-get-integer (char val table)
  (let ((val-table (char-table-extra-slot table 4)))

		    (setq str (concat str (string val-code val-code)))
		  (setq str (concat str (string val-code)))))
	      (set-char-table-range table (cons start limit) str))))))

    (setq val-list (nreverse (cdr val-list)))
    (set-char-table-extra-slot table 0 prop) 
    (set-char-table-extra-slot table 4 (vconcat (mapcar 'car val-list)))
    table))

(defun unidata-gen-table-symbol (prop)
  (let ((table (unidata-gen-table prop

	result)
    (when (< len1 16)
      (while (and l1 (eq (car l1) (car l2)))
	(setq beg (1+ beg)
	      l1 (cdr l1) len1 (1- len1) l2 (cdr l2) len2 (1- len2)))
      (while (and (< end len1) (< end len2) 
		  (eq (nth (- len1 end 1) l1) (nth (- len2 end 1) l2)))
	(setq end (1+ end))))
    (if (= (+ beg end) 0)
	(setq result (list -1))
      (setq result (list (+ (* beg 16) (+ beg (- len1 end))))))

;; Return a name of CHAR.  VAL is the current value of (aref TABLE
;; CHAR).

(defun unidata-get-name (char val table)
  (cond 
   ((stringp val)
    (if (> (aref val 0) 0)
	val
      (let* ((first-char (lsh (lsh char -7) 7))
	     (word-table (aref (char-table-extra-slot table 4) 0))

		      (setq tail-list (nthcdr (% diff-head 16) last-list))
		      (dotimes (i (/ diff-head 16))
			(setq word-list (nconc word-list (list (car l)))
			      l (cdr l))))))
	    (setq word-list
		  (nconc word-list 
			 (list (symbol-name
				(unidata-decode-word c word-table))))
		  i (1+ i))))
	(if (or word-list tail-list)
	    (aset vec idx (nconc word-list tail-list)))

		     (L (/ char 588))
		     ;; VIndex = (SIndex % NCount) * TCount
		     (V (/ (% char 588) 28))
		     ;; TIndex = SIndex % TCount
		     (T (% char 28)))
		 (format "HANGUL SYLLABLE %s%s%s" 
			 ;; U+110B is nil in this table.
			 (or (aref (aref jamo-name-table 0) L) "")
			 (aref (aref jamo-name-table 1) V)
			 (if (= T 0) ""
			   (aref (aref jamo-name-table 2) (1- T)))))))

		      (setq tail-list (nthcdr (% diff-head 16) last-list))
		      (dotimes (i (/ diff-head 16))
			(setq word-list (nconc word-list (list (car l)))
			      l (cdr l))))))
	    (setq word-list
		  (nconc word-list 
			 (list (or (unidata-decode-word c word-table) c)))
		  i (1+ i))))
	(if (or word-list tail-list)
	    (aset vec idx (nconc word-list tail-list)))
	(dotimes (i 128)

	(dotimes (i len)
	  (setq c (aref str i))
	  (if (= c 32)
	      (setq l (cons (intern (substring str idx i)) l)
		    idx (1+ i))
	    (if (and (= c ?-) (< idx i) 
		     (< (1+ i) len) (/= (aref str (1+ i)) 32))
		(setq l (cons '- (cons (intern (substring str idx i)) l))
		      idx (1+ i)))))
	(nreverse (cons (intern (substring str idx)) l))))))

	 (word-tables (char-table-extra-slot table 4)))
    (byte-compile 'unidata-get-decomposition)
    (byte-compile 'unidata-put-decomposition)
    (set-char-table-extra-slot table 1
			       (symbol-function 'unidata-get-decomposition))
    (set-char-table-extra-slot table 2 
			       (symbol-function 'unidata-put-decomposition))
    (set-char-table-extra-slot table 4 (car word-tables))
    table))

(defun unidata-check ()
  (dolist (elt unidata-prop-alist)
    (let* ((prop (car elt))
	   (index (unidata-prop-index prop))
	   (generator (unidata-prop-generator prop))
	   (table (progn 
		    (message "Generating %S table..." prop)
		    (funcall generator prop)))
	   (decoder (char-table-extra-slot table 1))
	   (check #x400))
      (dolist (e unidata-list)

		       (setq val1 (unidata-split-decomposition val1)))))
	    (when (>= char check)
	      (message "%S %04X" prop check)
	      (setq check (+ check #x400)))
	    (or (equal val1 val2)
		(insert (format "> %04X %S\n< %04X %S\n" 
				char val1 char val2)))
	    (sit-for 0)))))))

;; The entry function.  It generates files described in the header
;; comment of this file.

94071:03be13c38b12

;;	  (char-code-property-register PROP FILE)
;;	where PROP is a symbol representing a character property
;;	(name, generic-category, etc), and FILE is a name of one of
;;	the following files.
;;
;;   uni-name.el, uni-category.el, uni-combining.el, uni-bidi.el,
;;   uni-decomposition.el, uni-decimal.el, uni-digit.el, uni-numeric.el,
;;   uni-mirrored.el, uni-old-name.el, uni-comment.el, uni-uppercase.el,
;;   uni-lowercase.el, uni-titlecase.el
;;	They each contain a single form of this format:
;;	  (char-code-property-register PROP CHAR-TABLE)
;;	where PROP is the same as above, and CHAR-TABLE is a
;;	char-table containing property values in a compressed format.
;;
;;   When they are installed in .../lisp/international/, the file

     "Unicode numeric value (digit).
Property value is an integer.")
    (numeric-value
     8 unidata-gen-table-symbol "uni-numeric.el"
     "Unicode numeric value (numeric).
Property value is a symbol.")
    (mirrored
     9 unidata-gen-table-symbol "uni-mirrored.el"
     "Unicode bidi mirrored flag.
Property value is a symbol `Y' or `N'.")
    (old-name

      (aref vec (- char block-head))))))

(defun unidata-put-character (char val table)
  (or (characterp val)
      (not val)
      (error "Not a character nor nil: %S" val))
  (let ((current-val (aref table char)))
    (unless (eq current-val val)
      (if (stringp current-val)
	  (funcall (char-table-extra-slot table 1) char current-val table))
      (aset table char val))))

		     (setq this-val val))
		 (setq first-char (1+ first-char))))
	     this-val))
	  ((> val 0)
	   (aref val-table (1- val))))))

;; Return a integer-type character property value of CHAR.  VAL is the
;; current value of (aref TABLE CHAR).

(defun unidata-get-integer (char val table)
  (let ((val-table (char-table-extra-slot table 4)))

		    (setq str (concat str (string val-code val-code)))
		  (setq str (concat str (string val-code)))))
	      (set-char-table-range table (cons start limit) str))))))

    (setq val-list (nreverse (cdr val-list)))
    (set-char-table-extra-slot table 0 prop)
    (set-char-table-extra-slot table 4 (vconcat (mapcar 'car val-list)))
    table))

(defun unidata-gen-table-symbol (prop)
  (let ((table (unidata-gen-table prop

	result)
    (when (< len1 16)
      (while (and l1 (eq (car l1) (car l2)))
	(setq beg (1+ beg)
	      l1 (cdr l1) len1 (1- len1) l2 (cdr l2) len2 (1- len2)))
      (while (and (< end len1) (< end len2)
		  (eq (nth (- len1 end 1) l1) (nth (- len2 end 1) l2)))
	(setq end (1+ end))))
    (if (= (+ beg end) 0)
	(setq result (list -1))
      (setq result (list (+ (* beg 16) (+ beg (- len1 end))))))

;; Return a name of CHAR.  VAL is the current value of (aref TABLE
;; CHAR).

(defun unidata-get-name (char val table)
  (cond
   ((stringp val)
    (if (> (aref val 0) 0)
	val
      (let* ((first-char (lsh (lsh char -7) 7))
	     (word-table (aref (char-table-extra-slot table 4) 0))

		      (setq tail-list (nthcdr (% diff-head 16) last-list))
		      (dotimes (i (/ diff-head 16))
			(setq word-list (nconc word-list (list (car l)))
			      l (cdr l))))))
	    (setq word-list
		  (nconc word-list
			 (list (symbol-name
				(unidata-decode-word c word-table))))
		  i (1+ i))))
	(if (or word-list tail-list)
	    (aset vec idx (nconc word-list tail-list)))

		     (L (/ char 588))
		     ;; VIndex = (SIndex % NCount) * TCount
		     (V (/ (% char 588) 28))
		     ;; TIndex = SIndex % TCount
		     (T (% char 28)))
		 (format "HANGUL SYLLABLE %s%s%s"
			 ;; U+110B is nil in this table.
			 (or (aref (aref jamo-name-table 0) L) "")
			 (aref (aref jamo-name-table 1) V)
			 (if (= T 0) ""
			   (aref (aref jamo-name-table 2) (1- T)))))))

		      (setq tail-list (nthcdr (% diff-head 16) last-list))
		      (dotimes (i (/ diff-head 16))
			(setq word-list (nconc word-list (list (car l)))
			      l (cdr l))))))
	    (setq word-list
		  (nconc word-list
			 (list (or (unidata-decode-word c word-table) c)))
		  i (1+ i))))
	(if (or word-list tail-list)
	    (aset vec idx (nconc word-list tail-list)))
	(dotimes (i 128)

	(dotimes (i len)
	  (setq c (aref str i))
	  (if (= c 32)
	      (setq l (cons (intern (substring str idx i)) l)
		    idx (1+ i))
	    (if (and (= c ?-) (< idx i)
		     (< (1+ i) len) (/= (aref str (1+ i)) 32))
		(setq l (cons '- (cons (intern (substring str idx i)) l))
		      idx (1+ i)))))
	(nreverse (cons (intern (substring str idx)) l))))))

	 (word-tables (char-table-extra-slot table 4)))
    (byte-compile 'unidata-get-decomposition)
    (byte-compile 'unidata-put-decomposition)
    (set-char-table-extra-slot table 1
			       (symbol-function 'unidata-get-decomposition))
    (set-char-table-extra-slot table 2
			       (symbol-function 'unidata-put-decomposition))
    (set-char-table-extra-slot table 4 (car word-tables))
    table))

(defun unidata-check ()
  (dolist (elt unidata-prop-alist)
    (let* ((prop (car elt))
	   (index (unidata-prop-index prop))
	   (generator (unidata-prop-generator prop))
	   (table (progn
		    (message "Generating %S table..." prop)
		    (funcall generator prop)))
	   (decoder (char-table-extra-slot table 1))
	   (check #x400))
      (dolist (e unidata-list)

		       (setq val1 (unidata-split-decomposition val1)))))
	    (when (>= char check)
	      (message "%S %04X" prop check)
	      (setq check (+ check #x400)))
	    (or (equal val1 val2)
		(insert (format "> %04X %S\n< %04X %S\n"
				char val1 char val2)))
	    (sit-for 0)))))))

;; The entry function.  It generates files described in the header
;; comment of this file.