Mercurial > hg > xemacs-beta

comparison lisp/mule/ccl.el @ 5473:ac37a5f7e5be

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Merge with trunk.
author Mats Lidell <matsl@xemacs.org>
date Thu, 17 Mar 2011 23:42:59 +0100
parents 308d34e9f07d f00192e1cd49
children 4dee0387b9de
comparison
equal deleted inserted replaced
5472:e79980ee5efe 5473:ac37a5f7e5be
469 469
470 ;; Compile IF statement of the form `(if CONDITION TRUE-PART FALSE-PART)'. 470 ;; Compile IF statement of the form `(if CONDITION TRUE-PART FALSE-PART)'.
471 ;; If READ-FLAG is non-nil, this statement has the form 471 ;; If READ-FLAG is non-nil, this statement has the form
472 ;; `(read-if (REG OPERATOR ARG) TRUE-PART FALSE-PART)'. 472 ;; `(read-if (REG OPERATOR ARG) TRUE-PART FALSE-PART)'.
473 (defun ccl-compile-if (cmd &optional read-flag) 473 (defun ccl-compile-if (cmd &optional read-flag)
474 (if (and (/= (length cmd) 3) (/= (length cmd) 4)) 474 (if (and (not (<= 3 (length cmd) 4)))
475 (error "CCL: Invalid number of arguments: %s" cmd)) 475 (error "CCL: Invalid number of arguments: %s" cmd))
476 (let ((condition (nth 1 cmd)) 476 (let ((condition (nth 1 cmd))
477 (true-cmds (nth 2 cmd)) 477 (true-cmds (nth 2 cmd))
478 (false-cmds (nth 3 cmd)) 478 (false-cmds (nth 3 cmd))
479 jump-cond-address) 479 jump-cond-address)
642 (setq ccl-breaks (cdr ccl-breaks)))) 642 (setq ccl-breaks (cdr ccl-breaks))))
643 nil)))) 643 nil))))
644 644
645 ;; Compile BREAK statement. 645 ;; Compile BREAK statement.
646 (defun ccl-compile-break (cmd) 646 (defun ccl-compile-break (cmd)
647 (if (/= (length cmd) 1) 647 (if (not (eql (length cmd) 1))
648 (error "CCL: Invalid number of arguments: %s" cmd)) 648 (error "CCL: Invalid number of arguments: %s" cmd))
649 (if (null ccl-loop-head) 649 (if (null ccl-loop-head)
650 (error "CCL: No outer loop: %s" cmd)) 650 (error "CCL: No outer loop: %s" cmd))
651 (setq ccl-breaks (cons ccl-current-ic ccl-breaks)) 651 (setq ccl-breaks (cons ccl-current-ic ccl-breaks))
652 (ccl-embed-code 'jump 0 0) 652 (ccl-embed-code 'jump 0 0)
653 t) 653 t)
654 654
655 ;; Compile REPEAT statement. 655 ;; Compile REPEAT statement.
656 (defun ccl-compile-repeat (cmd) 656 (defun ccl-compile-repeat (cmd)
657 (if (/= (length cmd) 1) 657 (if (not (eql (length cmd) 1))
658 (error "CCL: Invalid number of arguments: %s" cmd)) 658 (error "CCL: Invalid number of arguments: %s" cmd))
659 (if (null ccl-loop-head) 659 (if (null ccl-loop-head)
660 (error "CCL: No outer loop: %s" cmd)) 660 (error "CCL: No outer loop: %s" cmd))
661 (ccl-embed-code 'jump 0 ccl-loop-head) 661 (ccl-embed-code 'jump 0 ccl-loop-head)
662 t) 662 t)
663 663
664 ;; Compile WRITE-REPEAT statement. 664 ;; Compile WRITE-REPEAT statement.
665 (defun ccl-compile-write-repeat (cmd) 665 (defun ccl-compile-write-repeat (cmd)
666 (if (/= (length cmd) 2) 666 (if (not (eql (length cmd) 2))
667 (error "CCL: Invalid number of arguments: %s" cmd)) 667 (error "CCL: Invalid number of arguments: %s" cmd))
668 (if (null ccl-loop-head) 668 (if (null ccl-loop-head)
669 (error "CCL: No outer loop: %s" cmd)) 669 (error "CCL: No outer loop: %s" cmd))
670 (let ((arg (nth 1 cmd))) 670 (let ((arg (nth 1 cmd)))
671 (cond ((integer-or-char-p arg) 671 (cond ((integer-or-char-p arg)
779 (error "CCL: Invalid argument: %s" cmd)))) 779 (error "CCL: Invalid argument: %s" cmd))))
780 nil) 780 nil)
781 781
782 ;; Compile CALL statement. 782 ;; Compile CALL statement.
783 (defun ccl-compile-call (cmd) 783 (defun ccl-compile-call (cmd)
784 (if (/= (length cmd) 2) 784 (if (not (eql (length cmd) 2))
785 (error "CCL: Invalid number of arguments: %s" cmd)) 785 (error "CCL: Invalid number of arguments: %s" cmd))
786 (if (not (symbolp (nth 1 cmd))) 786 (if (not (symbolp (nth 1 cmd)))
787 (error "CCL: Subroutine should be a symbol: %s" cmd)) 787 (error "CCL: Subroutine should be a symbol: %s" cmd))
788 (ccl-embed-code 'call 1 0) 788 (ccl-embed-code 'call 1 0)
789 (ccl-embed-symbol (nth 1 cmd) 'ccl-program-idx) 789 (ccl-embed-symbol (nth 1 cmd) 'ccl-program-idx)
790 nil) 790 nil)
791 791
792 ;; Compile END statement. 792 ;; Compile END statement.
793 (defun ccl-compile-end (cmd) 793 (defun ccl-compile-end (cmd)
794 (if (/= (length cmd) 1) 794 (if (not (eql (length cmd) 1))
795 (error "CCL: Invalid number of arguments: %s" cmd)) 795 (error "CCL: Invalid number of arguments: %s" cmd))
796 (ccl-embed-code 'end 0 0) 796 (ccl-embed-code 'end 0 0)
797 t) 797 t)
798 798
799 ;; Compile read-multibyte-character 799 ;; Compile read-multibyte-character
800 (defun ccl-compile-read-multibyte-character (cmd) 800 (defun ccl-compile-read-multibyte-character (cmd)
801 (if (/= (length cmd) 3) 801 (if (not (eql (length cmd) 3))
802 (error "CCL: Invalid number of arguments: %s" cmd)) 802 (error "CCL: Invalid number of arguments: %s" cmd))
803 (let ((RRR (nth 1 cmd)) 803 (let ((RRR (nth 1 cmd))
804 (rrr (nth 2 cmd))) 804 (rrr (nth 2 cmd)))
805 (ccl-check-register rrr cmd) 805 (ccl-check-register rrr cmd)
806 (ccl-check-register RRR cmd) 806 (ccl-check-register RRR cmd)
807 (ccl-embed-extended-command 'read-multibyte-character rrr RRR 0)) 807 (ccl-embed-extended-command 'read-multibyte-character rrr RRR 0))
808 nil) 808 nil)
809 809
810 ;; Compile write-multibyte-character 810 ;; Compile write-multibyte-character
811 (defun ccl-compile-write-multibyte-character (cmd) 811 (defun ccl-compile-write-multibyte-character (cmd)
812 (if (/= (length cmd) 3) 812 (if (not (eql (length cmd) 3))
813 (error "CCL: Invalid number of arguments: %s" cmd)) 813 (error "CCL: Invalid number of arguments: %s" cmd))
814 (let ((RRR (nth 1 cmd)) 814 (let ((RRR (nth 1 cmd))
815 (rrr (nth 2 cmd))) 815 (rrr (nth 2 cmd)))
816 (ccl-check-register rrr cmd) 816 (ccl-check-register rrr cmd)
817 (ccl-check-register RRR cmd) 817 (ccl-check-register RRR cmd)
818 (ccl-embed-extended-command 'write-multibyte-character rrr RRR 0)) 818 (ccl-embed-extended-command 'write-multibyte-character rrr RRR 0))
819 nil) 819 nil)
820 820
821 ;; Compile translate-character 821 ;; Compile translate-character
822 (defun ccl-compile-translate-character (cmd) 822 (defun ccl-compile-translate-character (cmd)
823 (if (/= (length cmd) 4) 823 (if (not (eql (length cmd) 4))
824 (error "CCL: Invalid number of arguments: %s" cmd)) 824 (error "CCL: Invalid number of arguments: %s" cmd))
825 (let ((Rrr (nth 1 cmd)) 825 (let ((Rrr (nth 1 cmd))
826 (RRR (nth 2 cmd)) 826 (RRR (nth 2 cmd))
827 (rrr (nth 3 cmd))) 827 (rrr (nth 3 cmd)))
828 (ccl-check-register rrr cmd) 828 (ccl-check-register rrr cmd)
836 (ccl-embed-extended-command 'translate-character rrr RRR Rrr)))) 836 (ccl-embed-extended-command 'translate-character rrr RRR Rrr))))
837 nil) 837 nil)
838 838
839 ;; Compile mule-to-unicode 839 ;; Compile mule-to-unicode
840 (defun ccl-compile-mule-to-unicode (cmd) 840 (defun ccl-compile-mule-to-unicode (cmd)
841 (if (/= (length cmd) 3) 841 (if (not (eql (length cmd) 3))
842 (error "CCL: Invalid number of arguments: %s" cmd)) 842 (error "CCL: Invalid number of arguments: %s" cmd))
843 (let ((RRR (nth 1 cmd)) 843 (let ((RRR (nth 1 cmd))
844 (rrr (nth 2 cmd))) 844 (rrr (nth 2 cmd)))
845 (ccl-check-register RRR cmd) 845 (ccl-check-register RRR cmd)
846 (ccl-check-register rrr cmd) 846 (ccl-check-register rrr cmd)
848 nil) 848 nil)
849 849
850 ;; Given a Unicode code point in register rrr, write the charset ID of the 850 ;; Given a Unicode code point in register rrr, write the charset ID of the
851 ;; corresponding character in RRR, and the Mule-CCL form of its code in rrr. 851 ;; corresponding character in RRR, and the Mule-CCL form of its code in rrr.
852 (defun ccl-compile-unicode-to-mule (cmd) 852 (defun ccl-compile-unicode-to-mule (cmd)
853 (if (/= (length cmd) 3) 853 (if (not (eql (length cmd) 3))
854 (error "CCL: Invalid number of arguments: %s" cmd)) 854 (error "CCL: Invalid number of arguments: %s" cmd))
855 (let ((rrr (nth 1 cmd)) 855 (let ((rrr (nth 1 cmd))
856 (RRR (nth 2 cmd))) 856 (RRR (nth 2 cmd)))
857 (ccl-check-register rrr cmd) 857 (ccl-check-register rrr cmd)
858 (ccl-check-register RRR cmd) 858 (ccl-check-register RRR cmd)
859 (ccl-embed-extended-command 'unicode-to-mule rrr RRR 0)) 859 (ccl-embed-extended-command 'unicode-to-mule rrr RRR 0))
860 nil) 860 nil)
861 861
862 ;; Compile lookup-integer 862 ;; Compile lookup-integer
863 (defun ccl-compile-lookup-integer (cmd) 863 (defun ccl-compile-lookup-integer (cmd)
864 (if (/= (length cmd) 4) 864 (if (not (eql (length cmd) 4))
865 (error "CCL: Invalid number of arguments: %s" cmd)) 865 (error "CCL: Invalid number of arguments: %s" cmd))
866 (let ((Rrr (nth 1 cmd)) 866 (let ((Rrr (nth 1 cmd))
867 (RRR (nth 2 cmd)) 867 (RRR (nth 2 cmd))
868 (rrr (nth 3 cmd))) 868 (rrr (nth 3 cmd)))
869 (ccl-check-register RRR cmd) 869 (ccl-check-register RRR cmd)
879 (ccl-embed-extended-command 'lookup-int rrr RRR 0)))) 879 (ccl-embed-extended-command 'lookup-int rrr RRR 0))))
880 nil) 880 nil)
881 881
882 ;; Compile lookup-character 882 ;; Compile lookup-character
883 (defun ccl-compile-lookup-character (cmd) 883 (defun ccl-compile-lookup-character (cmd)
884 (if (/= (length cmd) 4) 884 (if (not (eql (length cmd) 4))
885 (error "CCL: Invalid number of arguments: %s" cmd)) 885 (error "CCL: Invalid number of arguments: %s" cmd))
886 (let ((Rrr (nth 1 cmd)) 886 (let ((Rrr (nth 1 cmd))
887 (RRR (nth 2 cmd)) 887 (RRR (nth 2 cmd))
888 (rrr (nth 3 cmd))) 888 (rrr (nth 3 cmd)))
889 (ccl-check-register RRR cmd) 889 (ccl-check-register RRR cmd)
902 (defun ccl-compile-iterate-multiple-map (cmd) 902 (defun ccl-compile-iterate-multiple-map (cmd)
903 (ccl-compile-multiple-map-function 'iterate-multiple-map cmd) 903 (ccl-compile-multiple-map-function 'iterate-multiple-map cmd)
904 nil) 904 nil)
905 905
906 (defun ccl-compile-map-multiple (cmd) 906 (defun ccl-compile-map-multiple (cmd)
907 (if (/= (length cmd) 4) 907 (if (not (eql (length cmd) 4))
908 (error "CCL: Invalid number of arguments: %s" cmd)) 908 (error "CCL: Invalid number of arguments: %s" cmd))
909 (let (func arg) 909 (let (func arg)
910 (setq func 910 (setq func
911 (lambda (arg mp) 911 (lambda (arg mp)
912 (let ((len 0) result add) 912 (let ((len 0) result add)
928 (funcall func (nth 3 cmd) nil))) 928 (funcall func (nth 3 cmd) nil)))
929 (ccl-compile-multiple-map-function 'map-multiple arg)) 929 (ccl-compile-multiple-map-function 'map-multiple arg))
930 nil) 930 nil)
931 931
932 (defun ccl-compile-map-single (cmd) 932 (defun ccl-compile-map-single (cmd)
933 (if (/= (length cmd) 4) 933 (if (not (eql (length cmd) 4))
934 (error "CCL: Invalid number of arguments: %s" cmd)) 934 (error "CCL: Invalid number of arguments: %s" cmd))
935 (let ((RRR (nth 1 cmd)) 935 (let ((RRR (nth 1 cmd))
936 (rrr (nth 2 cmd)) 936 (rrr (nth 2 cmd))
937 (map (nth 3 cmd))) 937 (map (nth 3 cmd)))
938 (ccl-check-register rrr cmd) 938 (ccl-check-register rrr cmd)
1558 ,name) 1558 ,name)
1559 ,ccl-program))) 1559 ,ccl-program)))
1560 1560
1561 (provide 'ccl) 1561 (provide 'ccl)
1562 1562
1563 ;; ccl.el ends her 1563 ;; ccl.el ends here