;;; ccl.el --- CCL (Code Conversion Language) compiler
-;; Copyright (C) 1997, 1998, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008 Free Software Foundation, Inc.
+;; Copyright (C) 1997-1998, 2001-2011 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008
+;; 2005, 2006, 2007, 2008, 2009, 2010, 2011
;; National Institute of Advanced Industrial Science and Technology (AIST)
;; Registration Number H14PRO021
;; This file is part of GNU Emacs.
-;; GNU Emacs is free software; you can redistribute it and/or modify
+;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 3, or (at your option)
-;; any later version.
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-;; Boston, MA 02110-1301, USA.
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
(defvar ccl-current-ic 0
"The current index for `ccl-program-vector'.")
-;; Embed integer DATA in `ccl-program-vector' at `ccl-current-ic' and
-;; increment it. If IC is specified, embed DATA at IC.
(defun ccl-embed-data (data &optional ic)
+ "Embed integer DATA in `ccl-program-vector' at `ccl-current-ic' and
+increment it. If IC is specified, embed DATA at IC."
(if ic
(aset ccl-program-vector ic data)
(let ((len (length ccl-program-vector)))
(aset ccl-program-vector ccl-current-ic data)
(setq ccl-current-ic (1+ ccl-current-ic))))
-;; Embed pair of SYMBOL and PROP where (get SYMBOL PROP) should give
-;; proper index number for SYMBOL. PROP should be
-;; `translation-table-id', `translation-hash-table-id'
-;; `code-conversion-map-id', or `ccl-program-idx'.
(defun ccl-embed-symbol (symbol prop)
+ "Embed pair of SYMBOL and PROP where (get SYMBOL PROP) should give
+proper index number for SYMBOL. PROP should be
+`translation-table-id', `translation-hash-table-id'
+`code-conversion-map-id', or `ccl-program-idx'."
(ccl-embed-data (cons symbol prop)))
-;; Embed string STR of length LEN in `ccl-program-vector' at
-;; `ccl-current-ic'.
(defun ccl-embed-string (len str)
+ "Embed string STR of length LEN in `ccl-program-vector' at
+`ccl-current-ic'."
(if (> len #xFFFFF)
(error "CCL: String too long: %d" len))
(if (> (string-bytes str) len)
0)))
(setq i (+ i 3))))))
-;; Embed a relative jump address to `ccl-current-ic' in
-;; `ccl-program-vector' at IC without altering the other bit field.
(defun ccl-embed-current-address (ic)
+ "Embed a relative jump address to `ccl-current-ic' in
+`ccl-program-vector' at IC without altering the other bit field."
(let ((relative (- ccl-current-ic (1+ ic))))
(aset ccl-program-vector ic
(logior (aref ccl-program-vector ic) (ash relative 8)))))
-;; Embed CCL code for the operation OP and arguments REG and DATA in
-;; `ccl-program-vector' at `ccl-current-ic' in the following format.
-;; |----------------- integer (28-bit) ------------------|
-;; |------------ 20-bit ------------|- 3-bit --|- 5-bit -|
-;; |------------- DATA -------------|-- REG ---|-- OP ---|
-;; If REG2 is specified, embed a code in the following format.
-;; |------- 17-bit ------|- 3-bit --|- 3-bit --|- 5-bit -|
-;; |-------- DATA -------|-- REG2 --|-- REG ---|-- OP ---|
-
-;; If REG is a CCL register symbol (e.g. r0, r1...), the register
-;; number is embedded. If OP is one of unconditional jumps, DATA is
-;; changed to a relative jump address.
-
(defun ccl-embed-code (op reg data &optional reg2)
+ "Embed CCL code for the operation OP and arguments REG and DATA in
+`ccl-program-vector' at `ccl-current-ic' in the following format.
+ |----------------- integer (28-bit) ------------------|
+ |------------ 20-bit ------------|- 3-bit --|- 5-bit -|
+ |------------- DATA -------------|-- REG ---|-- OP ---|
+If REG2 is specified, embed a code in the following format.
+ |------- 17-bit ------|- 3-bit --|- 3-bit --|- 5-bit -|
+ |-------- DATA -------|-- REG2 --|-- REG ---|-- OP ---|
+
+If REG is a CCL register symbol (e.g. r0, r1...), the register
+number is embedded. If OP is one of unconditional jumps, DATA is
+changed to a relative jump address."
(if (and (> data 0) (get op 'jump-flag))
;; DATA is an absolute jump address. Make it relative to the
;; next of jump code.
(ash data 8)))))
(ccl-embed-data code)))
-;; extended ccl command format
-;; |- 14-bit -|- 3-bit --|- 3-bit --|- 3-bit --|- 5-bit -|
-;; |- EX-OP --|-- REG3 --|-- REG2 --|-- REG ---|-- OP ---|
(defun ccl-embed-extended-command (ex-op reg reg2 reg3)
+ "extended ccl command format
+ |- 14-bit -|- 3-bit --|- 3-bit --|- 3-bit --|- 5-bit -|
+ |- EX-OP --|-- REG3 --|-- REG2 --|-- REG ---|-- OP ---|"
(let ((data (logior (ash (get ex-op 'ccl-ex-code) 3)
(if (symbolp reg3)
(get reg3 'ccl-register-number)
0))))
(ccl-embed-code 'ex-cmd reg data reg2)))
-;; Just advance `ccl-current-ic' by INC.
(defun ccl-increment-ic (inc)
+ "Just advance `ccl-current-ic' by INC."
(setq ccl-current-ic (+ ccl-current-ic inc)))
-;; If non-nil, index of the start of the current loop.
-(defvar ccl-loop-head nil)
-;; If non-nil, list of absolute addresses of the breaking points of
-;; the current loop.
-(defvar ccl-breaks nil)
+(defvar ccl-loop-head nil
+ "If non-nil, index of the start of the current loop.")
+(defvar ccl-breaks nil
+ "If non-nil, list of absolute addresses of the breaking points of
+the current loop.")
;;;###autoload
(defun ccl-compile (ccl-program)
"Return the compiled code of CCL-PROGRAM as a vector of integers."
- (if (or (null (consp ccl-program))
- (null (integerp (car ccl-program)))
- (null (listp (car (cdr ccl-program)))))
- (error "CCL: Invalid CCL program: %s" ccl-program))
+ (unless (and (consp ccl-program)
+ (integerp (car ccl-program))
+ (listp (car (cdr ccl-program))))
+ (error "CCL: Invalid CCL program: %s" ccl-program))
(if (null (vectorp ccl-program-vector))
(setq ccl-program-vector (make-vector 8192 0)))
(setq ccl-loop-head nil ccl-breaks nil)
(setq i (1+ i)))
vec))
-;; Signal syntax error.
(defun ccl-syntax-error (cmd)
+ "Signal syntax error."
(error "CCL: Syntax error: %s" cmd))
-;; Check if ARG is a valid CCL register.
(defun ccl-check-register (arg cmd)
+ "Check if ARG is a valid CCL register."
(if (get arg 'ccl-register-number)
arg
(error "CCL: Invalid register %s in %s" arg cmd)))
-;; Check if ARG is a valid CCL command.
(defun ccl-check-compile-function (arg cmd)
+ "Check if ARG is a valid CCL command."
(or (get arg 'ccl-compile-function)
(error "CCL: Invalid command: %s" cmd)))
;; In the following code, most ccl-compile-XXXX functions return t if
;; they end with unconditional jump, else return nil.
-;; Compile CCL-BLOCK (see the syntax above).
(defun ccl-compile-1 (ccl-block)
+ "Compile CCL-BLOCK (see the syntax above)."
(let (unconditional-jump
cmd)
(if (or (integerp ccl-block)
(defconst ccl-max-short-const (ash 1 19))
(defconst ccl-min-short-const (ash -1 19))
-;; Compile SET statement.
(defun ccl-compile-set (cmd)
+ "Compile SET statement."
(let ((rrr (ccl-check-register (car cmd) cmd))
(right (nth 2 cmd)))
(cond ((listp right)
(ccl-embed-code 'set-register rrr 0 right))))))
nil)
-;; Compile SET statement with ASSIGNMENT_OPERATOR.
(defun ccl-compile-self-set (cmd)
+ "Compile SET statement with ASSIGNMENT_OPERATOR."
(let ((rrr (ccl-check-register (car cmd) cmd))
(right (nth 2 cmd)))
(if (listp right)
(list rrr (intern (substring (symbol-name (nth 1 cmd)) 0 -1)) right)))
nil)
-;; Compile SET statement of the form `(RRR = EXPR)'.
(defun ccl-compile-expression (rrr expr)
+ "Compile SET statement of the form `(RRR = EXPR)'."
(let ((left (car expr))
(op (get (nth 1 expr) 'ccl-arith-code))
(right (nth 2 expr)))
(logior (ash op 3) (get right 'ccl-register-number))
left)))))
-;; Compile WRITE statement with string argument.
(defun ccl-compile-write-string (str)
+ "Compile WRITE statement with string argument."
(let ((len (length str)))
(ccl-embed-code 'write-const-string 1 len)
(ccl-embed-string len str))
nil)
-;; Compile IF statement of the form `(if CONDITION TRUE-PART FALSE-PART)'.
-;; If READ-FLAG is non-nil, this statement has the form
-;; `(read-if (REG OPERATOR ARG) TRUE-PART FALSE-PART)'.
(defun ccl-compile-if (cmd &optional read-flag)
+ "Compile IF statement of the form `(if CONDITION TRUE-PART FALSE-PART)'.
+If READ-FLAG is non-nil, this statement has the form
+`(read-if (REG OPERATOR ARG) TRUE-PART FALSE-PART)'."
(if (and (/= (length cmd) 3) (/= (length cmd) 4))
(error "CCL: Invalid number of arguments: %s" cmd))
(let ((condition (nth 1 cmd))
(op (get (nth 1 condition) 'ccl-arith-code))
(arg (nth 2 condition)))
(ccl-check-register rrr cmd)
+ (or (integerp op)
+ (error "CCL: invalid operator: %s" (nth 1 condition)))
(if (integerp arg)
(progn
(ccl-embed-code (if read-flag 'read-jump-cond-expr-const
(ccl-embed-current-address end-true-part-address))))
unconditional-jump)))
-;; Compile BRANCH statement.
(defun ccl-compile-branch (cmd)
+ "Compile BRANCH statement."
(if (< (length cmd) 3)
(error "CCL: Invalid number of arguments: %s" cmd))
(ccl-compile-branch-blocks 'branch
(ccl-compile-branch-expression (nth 1 cmd) cmd)
(cdr (cdr cmd))))
-;; Compile READ statement of the form `(read-branch EXPR BLOCK0 BLOCK1 ...)'.
(defun ccl-compile-read-branch (cmd)
+ "Compile READ statement of the form `(read-branch EXPR BLOCK0 BLOCK1 ...)'."
(if (< (length cmd) 3)
(error "CCL: Invalid number of arguments: %s" cmd))
(ccl-compile-branch-blocks 'read-branch
(ccl-compile-branch-expression (nth 1 cmd) cmd)
(cdr (cdr cmd))))
-;; Compile EXPRESSION part of BRANCH statement and return register
-;; which holds a value of the expression.
(defun ccl-compile-branch-expression (expr cmd)
+ "Compile EXPRESSION part of BRANCH statement and return register
+which holds a value of the expression."
(if (listp expr)
;; EXPR has the form `(EXPR2 OP ARG)'. Compile it as SET
;; statement of the form `(r7 = (EXPR2 OP ARG))'.
'r7)
(ccl-check-register expr cmd)))
-;; Compile BLOCKs of BRANCH statement. CODE is 'branch or 'read-branch.
-;; REG is a register which holds a value of EXPRESSION part. BLOCKs
-;; is a list of CCL-BLOCKs.
(defun ccl-compile-branch-blocks (code rrr blocks)
+ "Compile BLOCKs of BRANCH statement. CODE is 'branch or 'read-branch.
+REG is a register which holds a value of EXPRESSION part. BLOCKs
+is a list of CCL-BLOCKs."
(let ((branches (length blocks))
branch-idx
jump-table-head-address
;; Branch command ends by unconditional jump if RRR is out of range.
nil)
-;; Compile LOOP statement.
(defun ccl-compile-loop (cmd)
+ "Compile LOOP statement."
(if (< (length cmd) 2)
(error "CCL: Invalid number of arguments: %s" cmd))
(let* ((ccl-loop-head ccl-current-ic)
(setq ccl-breaks (cdr ccl-breaks))))
nil))))
-;; Compile BREAK statement.
(defun ccl-compile-break (cmd)
+ "Compile BREAK statement."
(if (/= (length cmd) 1)
(error "CCL: Invalid number of arguments: %s" cmd))
(if (null ccl-loop-head)
(ccl-embed-code 'jump 0 0)
t)
-;; Compile REPEAT statement.
(defun ccl-compile-repeat (cmd)
+ "Compile REPEAT statement."
(if (/= (length cmd) 1)
(error "CCL: Invalid number of arguments: %s" cmd))
(if (null ccl-loop-head)
(ccl-embed-code 'jump 0 ccl-loop-head)
t)
-;; Compile WRITE-REPEAT statement.
(defun ccl-compile-write-repeat (cmd)
+ "Compile WRITE-REPEAT statement."
(if (/= (length cmd) 2)
(error "CCL: Invalid number of arguments: %s" cmd))
(if (null ccl-loop-head)
(ccl-embed-code 'write-register-jump arg ccl-loop-head))))
t)
-;; Compile WRITE-READ-REPEAT statement.
(defun ccl-compile-write-read-repeat (cmd)
+ "Compile WRITE-READ-REPEAT statement."
(if (or (< (length cmd) 2) (> (length cmd) 3))
(error "CCL: Invalid number of arguments: %s" cmd))
(if (null ccl-loop-head)
(ccl-embed-code 'read-jump rrr ccl-loop-head))
t)
-;; Compile READ statement.
(defun ccl-compile-read (cmd)
+ "Compile READ statement."
(if (< (length cmd) 2)
(error "CCL: Invalid number of arguments: %s" cmd))
(let* ((args (cdr cmd))
(setq args (cdr args) i (1- i)))))
nil)
-;; Compile READ-IF statement.
(defun ccl-compile-read-if (cmd)
+ "Compile READ-IF statement."
(ccl-compile-if cmd 'read))
-;; Compile WRITE statement.
(defun ccl-compile-write (cmd)
+ "Compile WRITE statement."
(if (< (length cmd) 2)
(error "CCL: Invalid number of arguments: %s" cmd))
(let ((rrr (nth 1 cmd)))
(error "CCL: Invalid argument: %s" cmd))))
nil)
-;; Compile CALL statement.
(defun ccl-compile-call (cmd)
+ "Compile CALL statement."
(if (/= (length cmd) 2)
(error "CCL: Invalid number of arguments: %s" cmd))
(if (not (symbolp (nth 1 cmd)))
(ccl-embed-symbol (nth 1 cmd) 'ccl-program-idx)
nil)
-;; Compile END statement.
(defun ccl-compile-end (cmd)
+ "Compile END statement."
(if (/= (length cmd) 1)
(error "CCL: Invalid number of arguments: %s" cmd))
(ccl-embed-code 'end 0 0)
t)
-;; Compile read-multibyte-character
(defun ccl-compile-read-multibyte-character (cmd)
+ "Compile read-multibyte-character"
(if (/= (length cmd) 3)
(error "CCL: Invalid number of arguments: %s" cmd))
(let ((RRR (nth 1 cmd))
(ccl-embed-extended-command 'read-multibyte-character rrr RRR 0))
nil)
-;; Compile write-multibyte-character
(defun ccl-compile-write-multibyte-character (cmd)
+ "Compile write-multibyte-character"
(if (/= (length cmd) 3)
(error "CCL: Invalid number of arguments: %s" cmd))
(let ((RRR (nth 1 cmd))
(ccl-embed-extended-command 'write-multibyte-character rrr RRR 0))
nil)
-;; Compile translate-character
(defun ccl-compile-translate-character (cmd)
+ "Compile translate-character."
(if (/= (length cmd) 4)
(error "CCL: Invalid number of arguments: %s" cmd))
(let ((Rrr (nth 1 cmd))
(ccl-embed-extended-command 'translate-character rrr RRR Rrr))))
nil)
-;; Compile lookup-integer
(defun ccl-compile-lookup-integer (cmd)
+ "Compile lookup-integer."
(if (/= (length cmd) 4)
(error "CCL: Invalid number of arguments: %s" cmd))
(let ((Rrr (nth 1 cmd))
(ccl-embed-extended-command 'lookup-int rrr RRR 0))))
nil)
-;; Compile lookup-character
(defun ccl-compile-lookup-character (cmd)
+ "Compile lookup-character."
(if (/= (length cmd) 4)
(error "CCL: Invalid number of arguments: %s" cmd))
(let ((Rrr (nth 1 cmd))
\f
;;; CCL dump stuff
-;; To avoid byte-compiler warning.
(defvar ccl-code)
;;;###autoload
(ccl-dump-1))
))
-;; Return a CCL code in `ccl-code' at `ccl-current-ic'.
(defun ccl-get-next-code ()
+ "Return a CCL code in `ccl-code' at `ccl-current-ic'."
(prog1
(aref ccl-code ccl-current-ic)
(setq ccl-current-ic (1+ ccl-current-ic))))
ARG := REG | integer
OPERATOR :=
- ;; Normal arithmethic operators (same meaning as C code).
+ ;; Normal arithmetic operators (same meaning as C code).
+ | - | * | / | %
- ;; Bitwize operators (same meaning as C code)
+ ;; Bitwise operators (same meaning as C code)
| & | `|' | ^
;; Shifting operators (same meaning as C code)
MAP-SET := MAP-IDs | (MAP-IDs) MAP-SET
MAP-ID := integer
"
+ (declare (doc-string 3))
`(let ((prog ,(unwind-protect
(progn
;; To make ,(charset-id CHARSET) works well.
(provide 'ccl)
-;;; arch-tag: 836bcd27-63a1-4a56-b232-1145ecf823fb
;;; ccl.el ends here