;;; cclc-old.el -- CCL compiler for Mule 2.x (0 <= x <= 3)

;;; Commentary:

;; Don't use this program for compiling CCL programs that will be
;; loaded by Mule 2.4 or newer!!  Use ccl.el in the standard
;; distrubution.

;; This program may generate a shorter and a little bit faster code
;; than ccl.el, but less reliable and less flexible (i.e, not easy to
;; add new features).

;;; Code:

(defconst ccl-operator-table
  '[if branch loop break repeat write-repeat write-read-repeat
    read read-if read-branch write end])

(let (op (i 0) (len (length ccl-operator-table)))
  (while (< i len)
    (setq op (aref ccl-operator-table i))
    (put op 'ccl-compile-function (intern (format "ccl-compile-%s" op)))
    (setq i (1+ i))))

(defconst ccl-machine-code-table
  '[set-cs set-cl set-r set-a
    jump jump-cond write-jump write-read-jump write-c-jump
    write-c-read-jump write-s-jump write-s-read-jump write-a-read-jump
    branch
    read1 read2 read-branch write1 write2 write-c write-s write-a
    end
    set-self-cs set-self-cl set-self-r set-expr-cl set-expr-r
    jump-cond-c jump-cond-r read-jump-cond-c read-jump-cond-r
    ])

(let (code (i 0) (len (length ccl-machine-code-table)))
  (while (< i len)
    (setq code (aref ccl-machine-code-table i))
    (put code 'ccl-code i)
    (put code 'ccl-dump-function (intern (format "ccl-dump-%s" code)))
    (setq i (1+ i))))

(defconst ccl-register-table '[r0 r1 r2 r3 r4 r5 r6 r7])

(let (reg (i 0) (len (length ccl-register-table)))
  (while (< i len)
    (setq reg (aref ccl-register-table i))
    (put reg 'ccl-register-number i)
    (setq i (1+ i))))

(defconst ccl-arith-table
  '[+ - * / % & | ^ << >> <8 >8 // nil nil nil < > == <= >= !=])

(let (arith (i 0) (len (length ccl-arith-table)))
  (while (< i len)
    (setq arith (aref ccl-arith-table i))
    (if arith (put arith 'ccl-arith-code i))
    (setq i (1+ i))))

(defconst ccl-self-arith-table
  '[+= -= *= /= %= &= |= ^= <<= >>= <8= >8= //=])

(let (arith (i 0) (len (length ccl-self-arith-table)))
  (while (< i len)
    (setq arith (aref ccl-self-arith-table i))
    (put arith 'ccl-self-arith-code i)
    (setq i (1+ i))))

(defvar ccl-program-vector nil)
(defvar ccl-current-ic 0)

(defun ccl-embed-const (const &optional ic)
  (if ic
      (aset ccl-program-vector ic const)
    (aset ccl-program-vector ccl-current-ic const)
    (setq ccl-current-ic (1+ ccl-current-ic))))

(defun ccl-embed-code (op reg const &optional ic)
  (let ((machine-code (logior (get op 'ccl-code)
			      (if (symbolp reg)
				  (ash (get reg 'ccl-register-number) 5)
				0)
			      (ash const 8))))
    (if ic
	(aset ccl-program-vector ic machine-code)
      (aset ccl-program-vector ccl-current-ic machine-code)
      (setq ccl-current-ic (1+ ccl-current-ic)))))

(defun ccl-embed-nop (&optional inc)
  (setq ccl-current-ic (+ ccl-current-ic (or inc 1))))

(defconst ccl-jump-opcode-alist
  (mapcar
   (function (lambda (op-pair)
	       (cons (get (car op-pair) 'ccl-code)
		     (get (cdr op-pair) 'ccl-code))))
   '((jump . jump)
     (jump-cond . jump-cond)
     (jump-cond-c . jump-cond-c)
     (jump-cond-r . jump-cond-r)
     (read-jump-cond-c . read-jump-cond-c)
     (read-jump-cond-r . read-jump-cond-r)
     (write1 . write-jump)
     (write-c . write-c-jump)
     (write-s . write-s-jump))))

(defun ccl-attach-jump-address (address ic)
  (let* ((code (aref ccl-program-vector ic))
	 (opcode (logand code 31))
	 (opcode1 (cdr (assq opcode ccl-jump-opcode-alist))))
    (if opcode1
	(aset ccl-program-vector ic
	      (logior (logand code 224) opcode1 (ash address 8)))
      (aset ccl-program-vector ic address))))

;;;###autoload
(defun ccl-program-p (obj)
  "T if OBJECT is a valid CCL compiled code."
  (and (vectorp obj)
       (let ((i 0) (len (length obj)) (flag t))
	 (if (> len 1)
	     (progn
	       (while (and flag (< i len))
		 (setq flag (integerp (aref obj i)))
		 (setq i (1+ i)))
	       flag)))))

(defvar ccl-loop-head nil)
(defvar ccl-breaks nil)
(defvar ccl-block-tail-addresses nil)

;;;###autoload
(defun ccl-compile (ccl-program)
  "Return a comiled code of CCL-PROGRAM as a vector of integer (>= 0)."
  (if (or (null (consp ccl-program))
	  (null (integerp (car ccl-program)))
	  (null (listp (car (cdr ccl-program)))))
      (error "CCL:Invalid CCL source code %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
	ccl-block-tail-addresses nil)
  (setq ccl-current-ic 0)
  (ccl-embed-const (car ccl-program))
  (ccl-embed-nop)
  (ccl-compile-1 (car (cdr ccl-program)) nil)
  (ccl-embed-const ccl-current-ic 1)
  (if (nth 2 ccl-program)
      (ccl-compile-1 (nth 2 ccl-program) 'end))
  (ccl-embed-code 'end 0 0)
  (let ((vec (make-vector ccl-current-ic 0))
	(i 0))
    (while (< i ccl-current-ic)
      (aset vec i (aref ccl-program-vector i))
      (setq i (1+ i)))
    vec))

(defun ccl-check-constant (arg cmd)
  (if (>= arg 0)
      arg
    (error "CCL: Negative constant %s not allowed: %s" arg cmd)))

(defun ccl-check-register (arg cmd)
  (if (get arg 'ccl-register-number)
      arg
    (error "CCL: Invalid register %s: %s." arg cmd)))

(defun ccl-check-reg-const (arg cmd)
  (if (integerp arg)
      (ccl-check-constant arg cmd)
    (ccl-check-register arg cmd)))

(defun ccl-check-compile-function (arg cmd)
  (or (get arg 'ccl-compile-function)
      (error "CCL: Invalid command: %s" cmd)))

(defun ccl-check-arith-code (arg cmd)
  (or (get arg 'ccl-arith-code)
      (error "CCL: Invalid arith code: %s" cmd)))

(defun ccl-compile-1 (cmd-list cont)
  (if (null cmd-list)
      (ccl-compile-continuation cont))
  (let (cmd cont1 lookahead)
    (if (or (integerp cmd-list)
	    (stringp cmd-list)
	    (and cmd-list (symbolp (car cmd-list))))
	(setq cmd-list (list cmd-list)))
    (while cmd-list
      (setq cmd (car cmd-list))
      (setq lookahead (cdr cmd-list))
      (cond ((null lookahead)
	     (setq cont1 cont))
	    ((and (listp (car lookahead))
		  (eq (car (car lookahead)) 'break))
	     (if (null ccl-loop-head)
		 (error "CCL: No outer loop: %s" (car lookahead))
	       (setq cont1 'break)
	       (setq lookahead nil)))
	    ((and (listp (car lookahead))
		  (eq (car (car lookahead)) 'repeat))
	     (if (null ccl-loop-head)
		 (error "CCL: No outer loop: %s" (car lookahead))
	       (setq cont1 (cons 'repeat ccl-loop-head))
	       (setq lookahead nil))))
      (cond ((integerp cmd)
	     (ccl-compile-set (list 'r0 '= cmd) cont1))
	    ((stringp cmd)
	     (ccl-compile-write-string (list 'write cmd) cont1))
	    ((listp cmd)
	     (if (eq (nth 1 cmd) '=)
		 (ccl-compile-set cmd cont1)
	       (if (and (symbolp (nth 1 cmd))
			(get (nth 1 cmd) 'ccl-self-arith-code))
		   (ccl-compile-self-set cmd cont1)
		 (funcall (ccl-check-compile-function (car cmd) cmd)
			  cmd cont1))))
	    (t
	     (error "CCL: Invalid command: %s" cmd)))
      (setq cmd-list lookahead))))

(defun ccl-compile-set (cmd cont)
  (let ((rrr (ccl-check-register (car cmd) cmd))
	(right (nth 2 cmd)))
    (cond ((listp right)
	   ;; cmd == (RRR = (XXX OP YYY))
	   (ccl-compile-expression rrr right))
	  ((integerp right)
	   (ccl-check-constant right cmd)
	   (if (< right 32768)		; (< right 2^15)
	       (ccl-embed-code 'set-cs rrr right)
	     (ccl-embed-code 'set-cl rrr 0)
	     (ccl-embed-const right)))
	  (t
	   (ccl-check-register right cmd)
	   (let ((ary (nth 3 cmd)))
	     (if (vectorp ary)
		 (let ((i 0) (len (length ary)))
		   (ccl-embed-code 'set-a rrr (get right 'ccl-register-number))
		   (ccl-embed-const len)
		   (while (< i len)
		     (ccl-check-constant (aref ary i) cmd)
		     (ccl-embed-const (aref ary i))
		     (setq i (1+ i))))
	       (ccl-embed-code 'set-r rrr right))))))
  (ccl-compile-continuation cont))

(defun ccl-compile-self-set (cmd cont)
  (let ((rrr (ccl-check-register (car cmd) cmd))
	(right (nth 2 cmd)))
    (if (listp right)
	;; cmd == (RRR SELF-OP= (XXX OP YYY))
	(progn
	  (ccl-compile-expression 'r7 right)
	  (setq right 'r7)))
    (ccl-compile-expression
     rrr
     (list rrr (intern (substring (symbol-name (nth 1 cmd)) 0 -1)) right)))
  (ccl-compile-continuation cont))

(defun ccl-compile-expression (rrr expr)
  (let ((left (car expr))
	(right (nth 2 expr)))
    (if (listp left)
	(progn
	  (ccl-compile-expression 'r7 left)
	  (setq left 'r7)))
    (if (eq rrr left)
	(if (integerp right)
	    (if (< right 32768)
		(ccl-embed-code 'set-self-cs rrr right)
	      (ccl-embed-code 'set-self-cl rrr 0)
	      (ccl-embed-const right))
	  (ccl-check-register right expr)
	  (ccl-embed-code 'set-self-r rrr (get right 'ccl-register-number)))
      (if (integerp right)
	  (progn
	    (ccl-embed-code 'set-expr-cl rrr (get left 'ccl-register-number))
	    (ccl-embed-const right))
	(ccl-check-register right expr)
	(ccl-embed-code 'set-expr-r rrr (get left 'ccl-register-number))
	(ccl-embed-const (get right 'ccl-register-number))))
    (ccl-check-arith-code (nth 1 expr) expr)
    (ccl-embed-const (get (nth 1 expr) 'ccl-arith-code))))

(defun ccl-compile-write-string (cmd cont)
  (if (/= (length cmd) 2)
      (error "CCL: Invalid number of arguments: %s" cmd))
  (let* ((str (nth 1 cmd))
	 (len (length str))
	 (i 0)
	 (ic0 ccl-current-ic))
    (ccl-embed-code 'write-s 0 0)
    (ccl-embed-const len)
    (while (< i len)
      (ccl-embed-const (aref str i))
      (setq i (1+ i)))
    (ccl-compile-continuation cont ic0)))

(defun ccl-compile-if (cmd cont)
  (if (and (/= (length cmd) 3) (/= (length cmd) 4))
      (error "CCL: Invalid number of arguments: %s" cmd))
  (let ((condition (nth 1 cmd))
	(true-cmds (nth 2 cmd))
	(false-cmds (nth 3 cmd))
	inner-block-tail-addresses
	ic0 ic1 ic2)
    (if (listp condition)
	;; cmd == (if (XXX OP YYY) ...)
	(if (listp (car condition))
	    ;; cmd == (if ((xxx op yyy) OP YYY) ...)
	    (progn
	      (ccl-compile-expression 'r7 (car condition))
	      (setq condition (cons 'r7 (cdr condition)))
	      (setq cmd (cons (car cmd)
			      (cons condition
				    (cdr (cdr cmd))))))))
    (setq ic0 ccl-current-ic)
    (ccl-embed-nop (if (listp condition) 3 1))
    (let (ccl-block-tail-addresses)
      (ccl-compile-1 true-cmds (or cont 'block-tail))
      (if (null false-cmds)
	  (progn
	    (setq ccl-block-tail-addresses
		  (cons ic0 ccl-block-tail-addresses))
	    (setq ic1 0))
	(setq ic1 ccl-current-ic)
	(ccl-compile-1 false-cmds cont))
      (if (symbolp condition)
	  (ccl-embed-code 'jump-cond condition ic1 ic0)
	(let ((arg (nth 2 condition)))
	  (if (integerp arg)
	      (progn
		(ccl-embed-code 'jump-cond-c (car condition) ic1 ic0)
		(ccl-embed-const arg (1+ ic0)))
	    (ccl-check-register arg cmd)
	    (ccl-embed-code 'jump-cond-r (car condition) ic1 ic0)
	    (ccl-embed-const (get arg 'ccl-register-number) (1+ ic0)))
	  (ccl-check-arith-code (nth 1 condition) cmd)
	  (ccl-embed-const (get (nth 1 condition) 'ccl-arith-code) (+ ic0 2))))
      (setq inner-block-tail-addresses ccl-block-tail-addresses))
    (ccl-fill-jump-addresses cont inner-block-tail-addresses)))

(defun ccl-compile-branch (cmd cont)
  (if (< (length cmd) 3)
      (error "CCL: Invalid number of arguments: %s" cmd))
  (if (listp (nth 1 cmd))
      (progn
	(ccl-compile-expression 'r7 (nth 1 cmd))
	(setq cmd (cons (car cmd)
			(cons 'r7 (cdr (cdr cmd)))))))
  (ccl-compile-branch-1 cmd cont))

(defun ccl-compile-read-branch (cmd cont)
  (ccl-compile-branch-1 cmd cont))

(defun ccl-compile-branch-1 (cmd cont)
  (if (< (length cmd) 3)
      (error "CCL: Invalid number of arguments: %s" cmd))
  (let ((rrr (ccl-check-register (car (cdr cmd)) cmd))
	(branches (cdr (cdr cmd)))
	inner-block-tail-addresses
	i ic0 ic1 ic2)
    (ccl-embed-code (car cmd) rrr (- (length cmd) 2))
    (setq ic0 ccl-current-ic)
    (ccl-embed-nop (1- (length cmd)))
    (let (ccl-block-tail-addresses)
      (setq i 0)
      (while branches
	(if (null (car branches))
	    (progn
	      (setq ccl-block-tail-addresses
		    (cons (+ ic0 i) ccl-block-tail-addresses))
	      (ccl-embed-const 0 (+ ic0 i)))
	  (ccl-embed-const ccl-current-ic (+ ic0 i))
	  (ccl-compile-1 (car branches)
			 (or cont
			     ;; We don't need `jump' from the last branch.
			     (and (cdr branches) 'block-tail))))
	(setq i (1+ i))
	(setq branches (cdr branches)))
      ;; This is the case `rrr' is out of range.
      (setq ccl-block-tail-addresses
	    (cons (+ ic0 i) ccl-block-tail-addresses))
      (ccl-embed-const 0 (+ ic0 i))
      (setq inner-block-tail-addresses ccl-block-tail-addresses))
    (ccl-fill-jump-addresses cont inner-block-tail-addresses)))

(defun ccl-compile-loop (cmd cont)
  (if (< (length cmd) 2)
      (error "CCL: Invalid number of arguments: %s" cmd))
  (let ((ccl-loop-head ccl-current-ic)
	inner-ccl-breaks)
    (let ((ccl-breaks nil))
      (setq cmd (cdr cmd))
      (ccl-compile-1 cmd (or cont 'break))
      (setq inner-ccl-breaks ccl-breaks))
    (ccl-fill-jump-addresses cont inner-ccl-breaks)))

(defun ccl-compile-break (cmd cont)
  (if (/= (length cmd) 1)
      (error "CCL: Invalid number of arguments: %s" cmd))
  (if (null ccl-loop-head)
      (error "CCL: No outer loop: %s" cmd))
  (setq ccl-breaks (cons ccl-current-ic ccl-breaks))
  (ccl-embed-code 'jump 0 0))

(defun ccl-compile-repeat (cmd cont)
  (if (/= (length cmd) 1)
      (error "CCL: Invalid number of arguments: %s" cmd))
  (if (null ccl-loop-head)
      (error "CCL: No outer loop: %s" cmd))
  (ccl-embed-code 'jump 0 ccl-loop-head))

(defun ccl-compile-write-repeat (cmd cont)
  (if (/= (length cmd) 2)
      (error "CCL: Invalid number of arguments: %s" cmd))
  (if (null ccl-loop-head)
      (error "CCL: No outer loop: %s" cmd))
  (let ((arg (nth 1 cmd)))
    (cond ((integerp arg)
	   (ccl-embed-code 'write-c-jump 0 ccl-loop-head)
	   (ccl-embed-const arg))
	  ((stringp arg)
	   (ccl-embed-code 'write-s-jump 0 ccl-loop-head)
	   (let ((i 0) (len (length arg)))
	     (ccl-embed-const (length arg))
	     (while (< i len)
	       (ccl-embed-const (aref arg i))
	       (setq i (1+ i)))))
	  (t
	   (ccl-check-register arg cmd)
	   (ccl-embed-code 'write-jump arg ccl-loop-head)))))

(defun ccl-compile-write-read-repeat (cmd cont)
  (if (or (< (length cmd) 2) (> (length cmd) 3))
      (error "CCL: Invalid number of arguments: %s" cmd))
  (if (null ccl-loop-head)
      (error "CCL: No outer loop: %s" cmd))
  (let ((rrr (ccl-check-register (nth 1 cmd) cmd))
	(arg (nth 2 cmd)))
    (cond ((null arg)
	   (ccl-embed-code 'write-read-jump rrr ccl-loop-head))
	  ((integerp arg)
	   (ccl-embed-code 'write-c-read-jump rrr ccl-loop-head)
	   (ccl-embed-const arg))
	  ((or (stringp arg) (vectorp arg))
	   (ccl-embed-code (if (stringp arg)
			       'write-s-read-jump
			     'write-a-read-jump)
			   rrr ccl-loop-head)
	   (let ((i 0) (len (length arg)))
	     (ccl-embed-const (length arg))
	     (while (< i len)
	       (ccl-embed-const (aref arg i))
	       (setq i (1+ i)))))
	  (t (error "CCL: Invalid argument %s: %s" arg cmd)))))

(defun ccl-compile-read (cmd cont)
  (let ((rrr (ccl-check-register (nth 1 cmd) cmd)))
    (cond ((= (length cmd) 2)
	   (ccl-embed-code 'read1 rrr 0))
	  ((= (length cmd) 3)
	   (ccl-embed-code 'read2 rrr (get (nth 2 cmd) 'ccl-register-number)))
	  (t (error "CCL: Invalid number of arguments: %s" cmd))))
  (ccl-compile-continuation cont))

(defun ccl-compile-read-if (cmd cont)
  (if (and (/= (length cmd) 3) (/= (length cmd) 4))
      (error "CCL: Invalid number of arguments: %s" cmd))
  (let* ((expr (nth 1 cmd))
	 (rrr (ccl-check-register (car expr) cmd))
	 (true-cmds (nth 2 cmd))
	 (false-cmds (nth 3 cmd))
	 inner-block-tail-addresses
	 ic0 ic1 ic2)
    (setq ic0 ccl-current-ic)
    (ccl-embed-nop 3)
    (let (ccl-block-tail-addresses)
      (ccl-compile-1 true-cmds (or cont 'block-tail))
      (if (null false-cmds)
	  (progn
	    (setq ccl-block-tail-addresses
		  (cons ic0 ccl-block-tail-addresses))
	    (setq ic1 0))
	(setq ic1 ccl-current-ic)
	(ccl-compile-1 false-cmds cont))
      (let ((arg (nth 2 expr)))
	(ccl-embed-code (if (integerp arg) 'read-jump-cond-c 'read-jump-cond-r)
			rrr ic1 ic0)
	(ccl-embed-const (if (integerp arg) arg (get arg 'ccl-register-number))
			 (1+ ic0))
	(ccl-check-arith-code (nth 1 expr) cmd)
	(ccl-embed-const (get (nth 1 expr) 'ccl-arith-code) (+ ic0 2)))
      (setq inner-block-tail-addresses ccl-block-tail-addresses))
    (ccl-fill-jump-addresses cont inner-block-tail-addresses)))

(defun ccl-compile-write (cmd cont)
  (if (and (/= (length cmd) 2) (/= (length cmd) 3))
      (error "CCL: Invalid number of arguments: %s" cmd))
  (let ((rrr (nth 1 cmd))
	(ic0 ccl-current-ic))
    (cond ((integerp rrr)
	   (ccl-embed-code 'write-c 0 0)
	   (ccl-embed-const rrr)
	   (ccl-compile-continuation cont ic0))
	  ((stringp rrr)
	   (ccl-compile-write-string (list 'write rrr) cont))
	  (t
	   (ccl-check-register rrr cmd)
	   (let ((arg (nth 2 cmd)))
	     (if arg
		 (cond ((symbolp arg)
			(ccl-check-register arg cmd)
			(ccl-embed-code 'write2 rrr
					(get arg 'ccl-register-number))
			(ccl-compile-continuation cont))
		       ((vectorp arg)
			(let ((i 0) (len (length arg)))
			  (ccl-embed-code 'write-a rrr 0)
			  (ccl-embed-const len)
			  (while (< i len)
			    (ccl-embed-const (aref arg i))
			    (setq i (1+ i))))
			(ccl-compile-continuation cont))
		       (t (error "CCL: Invalid argument %s: %s" arg cmd)))
	       (ccl-embed-code 'write1 rrr 0)
	       (ccl-compile-continuation cont ic0)))))))

(defun ccl-compile-end (cmd cont)
  (if (/= (length cmd) 1)
      (error "CCL: Invalid number of arguments: %s" cmd))
  (ccl-embed-code 'end 0 0))

(defun ccl-compile-continuation (cont &optional ic)
  (cond ((null cont))
	((eq cont 'end)
	 (ccl-embed-code 'end 0 0))
	((eq cont 'break)
	 (setq ccl-breaks (cons (or ic ccl-current-ic) ccl-breaks))
	 (if (null ic)
	     (ccl-embed-code 'jump 0 0)))
	((eq cont 'block-tail)
	 (setq ccl-block-tail-addresses
	       (cons (or ic ccl-current-ic) ccl-block-tail-addresses))
	 (if (null ic)
	     (ccl-embed-code 'jump 0 0)))
	((and (consp cont) (eq (car cont) 'repeat))
	 (if ic
	     (ccl-attach-jump-address (cdr cont) ic)
	   (ccl-embed-code 'jump 0 (cdr cont))))))

(defun ccl-fill-jump-addresses (cont ic-list)
  (cond ((null cont)
	 (while ic-list
	   (ccl-attach-jump-address ccl-current-ic (car ic-list))
	   (setq ic-list (cdr ic-list))))
	((eq cont 'end)
	 (while ic-list
	   (ccl-attach-jump-address ccl-current-ic (car ic-list))
	   (setq ic-list (cdr ic-list)))
	 (ccl-embed-code 'end 0 0))
	((eq cont 'break)
	 (setq ccl-breaks (nconc ic-list ccl-breaks)))
	((eq cont 'block-tail)
	 (setq ccl-block-tail-addresses
	       (nconc ic-list ccl-block-tail-addresses)))
	((and (consp cont) (eq (car cont) 'repeat))
	 (while ic-list
	   (ccl-attach-jump-address (cdr cont) (car ic-list))
	   (setq ic-list (cdr ic-list))))))

(provide 'ccl)

;;; cclc-old.el ends here
