view tests/automated/ccl-tests.el @ 4981:4aebb0131297

Cleanups/renaming of EXTERNAL_TO_C_STRING and friends -------------------- ChangeLog entries follow: -------------------- modules/ChangeLog addition: 2010-02-05 Ben Wing <ben@xemacs.org> * postgresql/postgresql.c: * postgresql/postgresql.c (CHECK_LIVE_CONNECTION): * postgresql/postgresql.c (Fpq_connectdb): * postgresql/postgresql.c (Fpq_connect_start): * postgresql/postgresql.c (Fpq_lo_import): * postgresql/postgresql.c (Fpq_lo_export): * ldap/eldap.c (Fldap_open): * ldap/eldap.c (Fldap_search_basic): * ldap/eldap.c (Fldap_add): * ldap/eldap.c (Fldap_modify): * ldap/eldap.c (Fldap_delete): * canna/canna_api.c (Fcanna_initialize): * canna/canna_api.c (Fcanna_store_yomi): * canna/canna_api.c (Fcanna_parse): * canna/canna_api.c (Fcanna_henkan_begin): EXTERNAL_TO_C_STRING returns its argument instead of storing it in a parameter, and is renamed to EXTERNAL_TO_ITEXT. Similar things happen to related macros. See entry in src/ChangeLog. More Mule-izing of postgresql.c. Extract out common code between `pq-connectdb' and `pq-connect-start'. Fix places that signal an error string using a formatted string to instead follow the standard and have a fixed reason followed by the particular error message stored as one of the frobs. src/ChangeLog addition: 2010-02-05 Ben Wing <ben@xemacs.org> * console-msw.c (write_string_to_mswindows_debugging_output): * console-msw.c (Fmswindows_message_box): * console-x.c (x_perhaps_init_unseen_key_defaults): * console.c: * database.c (dbm_get): * database.c (dbm_put): * database.c (dbm_remove): * database.c (berkdb_get): * database.c (berkdb_put): * database.c (berkdb_remove): * database.c (Fopen_database): * device-gtk.c (gtk_init_device): * device-msw.c (msprinter_init_device_internal): * device-msw.c (msprinter_default_printer): * device-msw.c (msprinter_init_device): * device-msw.c (sync_printer_with_devmode): * device-msw.c (Fmsprinter_select_settings): * device-x.c (sanity_check_geometry_resource): * device-x.c (Dynarr_add_validified_lisp_string): * device-x.c (x_init_device): * device-x.c (Fx_put_resource): * device-x.c (Fx_valid_keysym_name_p): * device-x.c (Fx_set_font_path): * dialog-msw.c (push_lisp_string_as_unicode): * dialog-msw.c (handle_directory_dialog_box): * dialog-msw.c (handle_file_dialog_box): * dialog-x.c (dbox_descriptor_to_widget_value): * editfns.c (Fformat_time_string): * editfns.c (Fencode_time): * editfns.c (Fset_time_zone_rule): * emacs.c (make_argc_argv): * emacs.c (Fdump_emacs): * emodules.c (emodules_load): * eval.c: * eval.c (maybe_signal_error_1): * event-msw.c (Fdde_alloc_advise_item): * event-msw.c (mswindows_dde_callback): * event-msw.c (mswindows_wnd_proc): * fileio.c (report_error_with_errno): * fileio.c (Fsysnetunam): * fileio.c (Fdo_auto_save): * font-mgr.c (extract_fcapi_string): * font-mgr.c (Ffc_config_app_font_add_file): * font-mgr.c (Ffc_config_app_font_add_dir): * font-mgr.c (Ffc_config_filename): * frame-gtk.c (gtk_set_frame_text_value): * frame-gtk.c (gtk_create_widgets): * frame-msw.c (mswindows_init_frame_1): * frame-msw.c (mswindows_set_title_from_ibyte): * frame-msw.c (msprinter_init_frame_3): * frame-x.c (x_set_frame_text_value): * frame-x.c (x_set_frame_properties): * frame-x.c (start_drag_internal_1): * frame-x.c (x_cde_transfer_callback): * frame-x.c (x_create_widgets): * glyphs-eimage.c (my_jpeg_output_message): * glyphs-eimage.c (jpeg_instantiate): * glyphs-eimage.c (gif_instantiate): * glyphs-eimage.c (png_instantiate): * glyphs-eimage.c (tiff_instantiate): * glyphs-gtk.c (xbm_instantiate_1): * glyphs-gtk.c (gtk_xbm_instantiate): * glyphs-gtk.c (gtk_xpm_instantiate): * glyphs-gtk.c (gtk_xface_instantiate): * glyphs-gtk.c (cursor_font_instantiate): * glyphs-gtk.c (gtk_redisplay_widget): * glyphs-gtk.c (gtk_widget_instantiate_1): * glyphs-gtk.c (gtk_add_tab_item): * glyphs-msw.c (mswindows_xpm_instantiate): * glyphs-msw.c (bmp_instantiate): * glyphs-msw.c (mswindows_resource_instantiate): * glyphs-msw.c (xbm_instantiate_1): * glyphs-msw.c (mswindows_xbm_instantiate): * glyphs-msw.c (mswindows_xface_instantiate): * glyphs-msw.c (mswindows_redisplay_widget): * glyphs-msw.c (mswindows_widget_instantiate): * glyphs-msw.c (add_tree_item): * glyphs-msw.c (add_tab_item): * glyphs-msw.c (mswindows_combo_box_instantiate): * glyphs-msw.c (mswindows_widget_query_string_geometry): * glyphs-x.c (x_locate_pixmap_file): * glyphs-x.c (xbm_instantiate_1): * glyphs-x.c (x_xbm_instantiate): * glyphs-x.c (extract_xpm_color_names): * glyphs-x.c (x_xpm_instantiate): * glyphs-x.c (x_xface_instantiate): * glyphs-x.c (autodetect_instantiate): * glyphs-x.c (safe_XLoadFont): * glyphs-x.c (cursor_font_instantiate): * glyphs-x.c (x_redisplay_widget): * glyphs-x.c (Fchange_subwindow_property): * glyphs-x.c (x_widget_instantiate): * glyphs-x.c (x_tab_control_redisplay): * glyphs.c (pixmap_to_lisp_data): * gui-x.c (menu_separator_style_and_to_external): * gui-x.c (add_accel_and_to_external): * gui-x.c (button_item_to_widget_value): * hpplay.c (player_error_internal): * hpplay.c (play_sound_file): * hpplay.c (play_sound_data): * intl.c (Fset_current_locale): * lisp.h: * menubar-gtk.c (gtk_xemacs_set_accel_keys): * menubar-msw.c (populate_menu_add_item): * menubar-msw.c (populate_or_checksum_helper): * menubar-x.c (menu_item_descriptor_to_widget_value_1): * nt.c (init_user_info): * nt.c (get_long_basename): * nt.c (nt_get_resource): * nt.c (init_mswindows_environment): * nt.c (get_cached_volume_information): * nt.c (mswindows_readdir): * nt.c (read_unc_volume): * nt.c (mswindows_stat): * nt.c (mswindows_getdcwd): * nt.c (mswindows_executable_type): * nt.c (Fmswindows_short_file_name): * ntplay.c (nt_play_sound_file): * objects-gtk.c: * objects-gtk.c (gtk_valid_color_name_p): * objects-gtk.c (gtk_initialize_font_instance): * objects-gtk.c (gtk_font_list): * objects-msw.c (font_enum_callback_2): * objects-msw.c (parse_font_spec): * objects-x.c (x_parse_nearest_color): * objects-x.c (x_valid_color_name_p): * objects-x.c (x_initialize_font_instance): * objects-x.c (x_font_instance_truename): * objects-x.c (x_font_list): * objects-xlike-inc.c (XFUN): * objects-xlike-inc.c (xft_find_charset_font): * process-nt.c (mswindows_report_winsock_error): * process-nt.c (nt_create_process): * process-nt.c (get_internet_address): * process-nt.c (nt_open_network_stream): * process-unix.c: * process-unix.c (allocate_pty): * process-unix.c (get_internet_address): * process-unix.c (unix_canonicalize_host_name): * process-unix.c (unix_open_network_stream): * realpath.c: * select-common.h (lisp_data_to_selection_data): * select-gtk.c (symbol_to_gtk_atom): * select-gtk.c (atom_to_symbol): * select-msw.c (symbol_to_ms_cf): * select-msw.c (mswindows_register_selection_data_type): * select-x.c (symbol_to_x_atom): * select-x.c (x_atom_to_symbol): * select-x.c (hack_motif_clipboard_selection): * select-x.c (Fx_store_cutbuffer_internal): * sound.c (Fplay_sound_file): * sound.c (Fplay_sound): * sound.h (sound_perror): * sysdep.c: * sysdep.c (qxe_allocating_getcwd): * sysdep.c (qxe_execve): * sysdep.c (copy_in_passwd): * sysdep.c (qxe_getpwnam): * sysdep.c (qxe_ctime): * sysdll.c (dll_open): * sysdll.c (dll_function): * sysdll.c (dll_variable): * sysdll.c (search_linked_libs): * sysdll.c (dll_error): * sysfile.h: * sysfile.h (PATHNAME_CONVERT_OUT_TSTR): * sysfile.h (PATHNAME_CONVERT_OUT_UTF_8): * sysfile.h (PATHNAME_CONVERT_OUT): * sysfile.h (LISP_PATHNAME_CONVERT_OUT): * syswindows.h (ITEXT_TO_TSTR): * syswindows.h (LOCAL_FILE_FORMAT_TO_TSTR): * syswindows.h (TSTR_TO_LOCAL_FILE_FORMAT): * syswindows.h (LOCAL_FILE_FORMAT_TO_INTERNAL_MSWIN): * syswindows.h (LISP_LOCAL_FILE_FORMAT_MAYBE_URL_TO_TSTR): * text.h: * text.h (eicpy_ext_len): * text.h (enum new_dfc_src_type): * text.h (EXTERNAL_TO_ITEXT): * text.h (GET_STRERROR): * tooltalk.c (check_status): * tooltalk.c (Fadd_tooltalk_message_arg): * tooltalk.c (Fadd_tooltalk_pattern_attribute): * tooltalk.c (Fadd_tooltalk_pattern_arg): * win32.c (tstr_to_local_file_format): * win32.c (mswindows_lisp_error_1): * win32.c (mswindows_report_process_error): * win32.c (Fmswindows_shell_execute): * win32.c (mswindows_read_link_1): Changes involving external/internal format conversion, mostly code cleanup and renaming. 1. Eliminate the previous macros like LISP_STRING_TO_EXTERNAL that stored its result in a parameter. The new version of LISP_STRING_TO_EXTERNAL returns its result through the return value, same as the previous NEW_LISP_STRING_TO_EXTERNAL. Use the new-style macros throughout the code. 2. Rename C_STRING_TO_EXTERNAL and friends to ITEXT_TO_EXTERNAL, in keeping with overall naming rationalization involving Itext and related types. Macros involved in previous two: EXTERNAL_TO_C_STRING -> EXTERNAL_TO_ITEXT EXTERNAL_TO_C_STRING_MALLOC -> EXTERNAL_TO_ITEXT_MALLOC SIZED_EXTERNAL_TO_C_STRING -> SIZED_EXTERNAL_TO_ITEXT SIZED_EXTERNAL_TO_C_STRING_MALLOC -> SIZED_EXTERNAL_TO_ITEXT_MALLOC C_STRING_TO_EXTERNAL -> ITEXT_TO_EXTERNAL C_STRING_TO_EXTERNAL_MALLOC -> ITEXT_TO_EXTERNAL_MALLOC LISP_STRING_TO_EXTERNAL LISP_STRING_TO_EXTERNAL_MALLOC LISP_STRING_TO_TSTR C_STRING_TO_TSTR -> ITEXT_TO_TSTR TSTR_TO_C_STRING -> TSTR_TO_ITEXT The following four still return their values through parameters, since they have more than one value to return: C_STRING_TO_SIZED_EXTERNAL -> ITEXT_TO_SIZED_EXTERNAL LISP_STRING_TO_SIZED_EXTERNAL C_STRING_TO_SIZED_EXTERNAL_MALLOC -> ITEXT_TO_SIZED_EXTERNAL_MALLOC LISP_STRING_TO_SIZED_EXTERNAL_MALLOC Sometimes additional casts had to be inserted, since the old macros played strange games and completely defeated the type system of the store params. 3. Rewrite many places where direct calls to TO_EXTERNAL_FORMAT occurred with calls to one of the convenience macros listed above, or to make_extstring(). 4. Eliminate SIZED_C_STRING macros (they were hardly used, anyway) and use a direct call to TO_EXTERNAL_FORMAT or TO_INTERNAL_FORMAT. 4. Use LISP_PATHNAME_CONVERT_OUT in many places instead of something like LISP_STRING_TO_EXTERNAL(..., Qfile_name). 5. Eliminate some temporary variables that are no longer necessary now that we return a value rather than storing it into a variable. 6. Some Mule-izing in database.c. 7. Error functions: -- A bit of code cleanup in maybe_signal_error_1. -- Eliminate report_file_type_error; it's just an alias for signal_error_2 with params in a different order. -- Fix some places in the hostname-handling code that directly inserted externally-retrieved error strings into the supposed ASCII "reason" param instead of doing the right thing and sticking text descriptive of what was going on in "reason" and putting the external message in a frob. 8. Use Ascbyte instead of CIbyte in process-unix.c and maybe one or two other places. 9. Some code cleanup in copy_in_passwd() in sysdep.c. 10. Fix a real bug due to accidental variable shadowing in tstr_to_local_file_format() in win32.c.
author Ben Wing <ben@xemacs.org>
date Fri, 05 Feb 2010 11:02:24 -0600
parents 189fb67ca31a
children 0f66906b6e37
line wrap: on
line source

;;; ccl-tests.el --- Testsuites on CCL ; -*- coding: iso-2022-7bit -*-

;; Copyright (C) 2000 MIYASHITA Hisashi

;; This file is part of XEmacs.

;; XEmacs 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 2, or (at your option)
;; any later version.

;; XEmacs is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with XEmacs; see the file COPYING.  If not, write to the Free
;; Software Foundation,59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Section 0.  Useful functions to construct test suites.

(defvar ccl-test-last-register-state nil)

(defun ccl-test-register-ccl-program (sym prog)
  (let ((compiled (ccl-compile prog)))
    (register-ccl-program sym compiled)
    compiled))

(defun ccl-test (prog &optional regs return-reg-idx)
  (ccl-test-register-ccl-program
   'ccl-test prog)
  (cond ((< (length regs) 8)
	 (setq ccl-test-last-register-state
	       (apply #'vector (append regs (make-list (- 8 (length regs)) 0)))))
	((> (length regs) 8)
	 (setq ccl-test-last-register-state
	       (apply #'vector (subseq regs 0 8))))
	(t
	 (setq ccl-test-last-register-state
	       (apply #'vector regs))))
  (ccl-execute
   'ccl-test
   ccl-test-last-register-state)
  (if (null return-reg-idx)
      (setq return-reg-idx 0))
  (aref ccl-test-last-register-state return-reg-idx))

(defun ccl-test-on-stream (prog string
				&optional not-check-coding-system)
  (ccl-test-register-ccl-program
   'ccl-test-decoder prog)
  (setq ccl-test-last-register-state (make-vector 9 0))
  (let ((str2
	 (ccl-execute-on-string
	  'ccl-test-decoder
	  ccl-test-last-register-state
	  string)))
    (if (not not-check-coding-system)
	(Assert (string= 
		 str2
		 (decode-coding-string
		  string 'ccl-test-coding-system))))
    str2))

(defvar ccl-test-symbol-idx 0)
(defun ccl-test-generate-symbol (idx)
  (intern (format "ccl-test-map-sym-%d" idx)))

(defun ccl-test-construct-map-structure (maps &optional idx)
  (setq ccl-test-symbol-idx (if idx idx 0))
  (let (map result sym)
    (while maps
      (setq map (car maps)
	    maps (cdr maps))
      (cond ((vectorp map)
	     (setq sym (ccl-test-generate-symbol
			ccl-test-symbol-idx)
		   ccl-test-symbol-idx
		   (1+ ccl-test-symbol-idx))
	     (register-code-conversion-map
	      sym map)
	     (set sym map)
	     (setq result (cons sym result)))

	    ((symbolp map)
	     (setq result (cons sym result)))

	    ((consp map)
	     (setq result
		   (cons (ccl-test-construct-map-structure
			  map ccl-test-symbol-idx)
			 result)))
	    (t
	     (error "Unknown data:%S" map))))
    (nreverse result)))

(defun ccl-test-map-multiple (val maps)
  (ccl-test
   `(0 ((map-multiple
	 r1 r0
	 ,(ccl-test-construct-map-structure maps))))
   (list val))
  (cons (aref ccl-test-last-register-state 0)
	(aref ccl-test-last-register-state 1)))

(defun ccl-test-iterate-multiple-map (val maps)
  (ccl-test
   `(0 ((iterate-multiple-map
	 r1 r0
	 ,@(ccl-test-construct-map-structure maps))))
   (list val))
  (cons (aref ccl-test-last-register-state 0)
	(aref ccl-test-last-register-state 1)))

(defun ccl-test-setup ()
  (define-ccl-program
    ccl-test-decoder
    '(1 (loop
          (read r0)
	  (write-repeat r0))))
  (define-ccl-program
    ccl-test-encoder
    '(1 (loop
          (read r0)
	  (write-repeat r0))))
  (or (find-coding-system 'ccl-test-coding-system)
      (make-coding-system 
       'ccl-test-coding-system
       'ccl
       "CCL TEST temporary coding-system."
       '(mnemonic "CCL-TEST"
		  eol-type lf
                  safe-charsets t
		  decode ccl-test-decoder
		  encode ccl-test-encoder))))

;;; Section 1. arithmetic operations.

(defun ccl-test-normal-expr ()
  ;; normal-expr
  (let ((r0 0) (r1 10) (r2 20) (r3 21) (r4 7))
    (Assert= (ccl-test '(0 ((r0 = ((((r1 * r2) + r3) % r4) << 2))))
			 (list r0 r1 r2 r3 r4))
	       (ash (% (+ (* r1 r2) r3) r4) 2)))

  (Assert (\= (ccl-test '(0 ((r2 = (r1 < 10))
			     (r0 = (r2 > 10))))
			'(0 5))
	   0))

  (let ((r0 0) (r1 #x10FF) (r2 #xCC) (r3 #xE0))
    (Assert= (ccl-test '(0 ((r0 = (((r1 & #xFF) ^ r2) | r3))))
			 (list r0 r1 r2 r3))
	       (logior (logxor (logand r1 #xFF) r2) r3)))

  ;; checking range of SJIS
  ;; 81(40-7E, 80-FC), 82, 9F, E0, E1, EF

  (let ((hs '(#x81 #x82 #x9F #xE0 #xE1 #xEF))
	func high low)
    (setq func
	  (lambda (high low)
	    (let (ch c1 c2)
	      (setq ch (split-char (decode-shift-jis-char
				    (cons high low))))
	      (setq c1 (nth 1 ch)
		    c2 (nth 2 ch))
	      (ccl-test '(0 ((r0 = (r1 de-sjis r2))))
			(list 0 high low))
	      (Assert (and (= c1 (aref ccl-test-last-register-state 0))
			   (= c2 (aref ccl-test-last-register-state 7))))
	      (ccl-test '(0 ((r0 = (r1 en-sjis r2))))
			(list 0 c1 c2))
	      (Assert (and (= high (aref ccl-test-last-register-state 0))
			   (= low (aref ccl-test-last-register-state 7)))))))
    (while (setq high (car hs))
      (setq hs (cdr hs))
      (setq low #x40)
      (while (<= low #x7E)
	(funcall func high low)
	(setq low (1+ low)))
      (setq low #x80)
      (while (<= low #xFC)
	(funcall func high low)
	(setq low (1+ low)))))

  ;; self-expr
  (Assert= (ccl-test '(0 ((r0 += 20)
			    (r0 *= 40)
			    (r0 -= 15)))
		       '(100))
	     (- (* (+ 100 20) 40) 15))

  ;; ref. array
  (Assert= (ccl-test '(0 ((r0 = r0 [100 101 102 103 104])))
		       '(3))
	     103))

;;; Section 2.  Simple read and write
(defun ccl-test-simple-read-and-write ()
  ;; constant
  (let* ((str "1234567890abcdefghij")
	 (dum (make-string 1 ?X)))
    (Assert
     (string= (ccl-test-on-stream
	       `(,(length str)
		 ((loop (read r0) (write ,str)))) dum)
	      str)))
  ;; register
  (let* ((str "1234567890abcdefghij"))
    (Assert
     (string= (ccl-test-on-stream `(1 ((read r0)
				       (loop
					 (write r0)
					 (read r0)
					 (repeat))))
				  str)
	      str))
    (Assert
     (string= (ccl-test-on-stream `(1 ((read r0)
				       (loop
					 (write-read-repeat r0))))
				  str)
	      str)))

  ;; expression
  (let ((str "1234567890abcdefghij")
	str2 i len)
    (setq str2 ""
	  len (length str)
	  i 0)
    (while (< i len)
      (setq str2 (concat str2 (char-to-string
			       (+ (char-to-int (aref str i)) 3))))
      (setq i (1+ i)))
    (Assert
     (string= (ccl-test-on-stream `(1 ((read r0)
				       (loop
					 (write (r0 + 3))
					 (read r0)
					 (repeat))))
				  str)
	      str2))
    (Assert
     (string= (ccl-test-on-stream `(1 ((read r0)
				       (loop
					 (r0 += 3)
			 		 (write-read-repeat r0))))
				  str)
	      str2)))


  ;; write via array
  (let* ((str (mapconcat (lambda (x) (char-to-string (int-to-char x)))
			 '(0 1 2 3 4 5 6) "")))
    (Assert
     (string= (ccl-test-on-stream
	       `(1 ((read r0)
		    (loop
		      (write r0
			     ,(vector (make-char 'japanese-jisx0208 36 34)
				      (make-char 'japanese-jisx0208 36 36)
				      (make-char 'japanese-jisx0208 36 38)
				      (make-char 'japanese-jisx0208 36 40)
				      (make-char 'japanese-jisx0208 36 42)
				      (make-char 'japanese-jisx0208 36 43)
				      (make-char 'japanese-jisx0208 36 45)
				      (make-char 'japanese-jisx0208 36 47)
				      (make-char 'japanese-jisx0208 36 49)
				      (make-char 'japanese-jisx0208 36 51)))
		      (read r0)
		      (repeat))))
	       str t)
	      (mapconcat #'char-to-string
			 (list (make-char 'japanese-jisx0208 36 34)
			       (make-char 'japanese-jisx0208 36 36)
			       (make-char 'japanese-jisx0208 36 38)
			       (make-char 'japanese-jisx0208 36 40)
			       (make-char 'japanese-jisx0208 36 42)
			       (make-char 'japanese-jisx0208 36 43)
			       (make-char 'japanese-jisx0208 36 45))
			 "")))))

;;; Section 3. read-multibyte-character, and write-multibyte-character
(defun ccl-test-read-write-multibyte-character ()
  ;; simple test.
  (let* ((str (concat "LMDXXX..."
		      (mapconcat #'char-to-string
				 (list (make-char 'japanese-jisx0208 36 36)
				       (make-char 'japanese-jisx0208 36 36)
				       (make-char 'japanese-jisx0208 50 67)
				       (make-char 'japanese-jisx0208 56 58)
				       (make-char 'japanese-jisx0208 72 104)
				       (make-char 'japanese-jisx0208 36 108)
				       (make-char 'japanese-jisx0208 36 70)
				       (make-char 'japanese-jisx0208 36 45)
				       (make-char 'japanese-jisx0208 36 63)
				       (make-char 'japanese-jisx0208 33 35))
				 "")
		      "...")))
    (Assert
     (string=
      (ccl-test-on-stream 
       `(1 ((loop
	      (read-multibyte-character r0 r1)
	      (write-multibyte-character r0 r1)
	      (repeat))))
       str t)
      str)))
  ;;
  )

;;; Section 4. CCL call
(defun ccl-test-ccl-call ()
  ;; set up
  (define-ccl-program
    ccl-test-sub1
    '(0
      ((r5 = ?z))))
  (define-ccl-program
    ccl-test-sub2
    '(0
      ((call ccl-test-sub1)
       (r0 = (r5 * 20)))))
  (define-ccl-program
    ccl-test-sub3
    '(1
      ((call ccl-test-sub2)
       (write r5)
       (write (r0 / 20)))))
  (Assert (string=
	   (ccl-test-on-stream
	    '(1 ((loop (read r0) (call ccl-test-sub3))))
	    "A")
	   "zz")))

;;; Section 5. Map-instructions
(defun ccl-test-map-instructions ()
  ;; set up
  (define-ccl-program
    ccl-test-arith-1
    '(0
      ((r0 += 1000000))))

  (define-ccl-program
    ccl-test-lambda
    '(0
      ((r0 = -3))))

  (define-ccl-program
    ccl-test-t
    '(0
      ((r0 = -2))))

  (define-ccl-program
    ccl-test-nil
    '(0
      ((r0 = -1))))

  ;; 1-level normal 1 mapping
  (Assert-equal
	   (mapcar
	    (lambda (val)
	      (ccl-test-map-multiple
	       val
	       '([100 1 2 3 4 5])))
	    '(0 99 100 101 102 103 104 105 106 107))
	   '((0 . -1) (99 . -1)
	     (1 . 0) (2 . 0) (3 . 0) (4 . 0) (5 . 0)
	     (105 . -1) (106 . -1) (107 . -1)))

  (Assert-equal
	   (mapcar
	    (lambda (val)
	      (ccl-test-iterate-multiple-map
	       val
	       '([100 1 2 3 4 5])))
	    '(0 99 100 101 102 103 104 105 106 107))
	   '((0 . -1) (99 . -1)
	     (1 . 0) (2 . 0) (3 . 0) (4 . 0) (5 . 0)
	     (105 . -1) (106 . -1) (107 . -1)))

  ;; 1-level normal 2 mappings
  (Assert-equal
	   (mapcar
	    (lambda (val)
	      (ccl-test-map-multiple
	       val
	       '([100 1 2 nil 4 5]
		 [101 12 13 14 15 16 17])))
	    '(0 99 100 101 102 103 104 105 106 107))
	   '((0 . -1) (99 . -1) (1 . 0) (2 . 0)
	     (13 . 1) (4 . 0) (5 . 0) (16 . 1) (17 . 1)
	     (107 . -1)))

  (Assert-equal
	   (mapcar
	    (lambda (val)
	      (ccl-test-iterate-multiple-map
	       val
	       '([100 1 2 3 4 5]
		 [101 12 13 14 15 16 17])))
	    '(0 99 100 101 102 103 104 105 106 107))
	   '((0 . -1) (99 . -1) (1 . 0) (2 . 0) (3 . 0)
	     (4 . 0) (5 . 0) (16 . 1) (17 . 1) (107 . -1)))


  ;; 1-level normal 7 mappings
  (Assert-equal
	   (mapcar
	    (lambda (val)
	      (ccl-test-map-multiple
	       val
	       '([100 1 2 nil 4 5]
		 [101 12 13 14 15 16 17]
		 [1000 101 102 103 nil 105 106 nil 108]
		 [1005 1006 1007 1008 1009 1010 1011 1012]
		 [10005 10006 10007 10008 10009 10010 10011 10012]
		 [20000 20000 20001 20002 nil 20004 20005 20006]
		 [20003 30000 30010 30020 30030 30040 30050 30060]
		 )))
	    '(0 99 100 101 102 103 104 105 106 107
		998 999 1000 1001 1002 1003 1004 1005 1006 1007
		9999 10000 10001 10002 10003 10004
		19999 20000 20001 20002 20003 20004
		20005 20006))
	   '((0 . -1) (99 . -1) (1 . 0) (2 . 0) (13 . 1) (4 . 0)
	     (5 . 0) (16 . 1) (17 . 1) (107 . -1) (998 . -1)
	     (999 . -1) (101 . 2) (102 . 2) (103 . 2) (1003 . -1)
	     (105 . 2) (106 . 2) (1007 . 3) (108 . 2) (9999 . -1)
	     (10000 . -1) (10001 . -1) (10002 . -1) (10003 . -1)
	     (10004 . -1) (19999 . -1) (20000 . 5) (20001 . 5)
	     (20002 . 5) (30000 . 6) (20004 . 5) (20005 . 5) (20006 . 5)))
	   
      (Assert-equal
	       (mapcar
		(lambda (val)
		  (ccl-test-iterate-multiple-map
		   val
		   '([100 1 2 nil 4 5]
		     [101 12 13 14 15 16 17]
		     [1000 101 102 103 nil 105 106 nil 108]
		     [1005 1006 1007 1008 1009 1010 1011 1012]
		     [10005 10006 10007 10008 10009 10010 10011 10012]
		     [20000 20000 20001 20002 nil 20004 20005 20006]
		     [20003 30000 30010 30020 30030 30040 30050 30060]
		     )))
		'(0 99 100 101 102 103 104 105 106 107
		    998 999 1000 1001 1002 1003 1004 1005 1006 1007
		    9999 10000 10001 10002 10003 10004
		    19999 20000 20001 20002 20003 20004
		    20005 20006))
	       '((0 . -1) (99 . -1) (1 . 0) (2 . 0) (13 . 1) (4 . 0)
		 (5 . 0) (16 . 1) (17 . 1) (107 . -1) (998 . -1)
		 (999 . -1) (101 . 2) (102 . 2) (103 . 2) (1003 . -1)
		 (105 . 2) (106 . 2) (1007 . 3) (108 . 2) (9999 . -1)
		 (10000 . -1) (10001 . -1) (10002 . -1) (10003 . -1)
		 (10004 . -1) (19999 . -1) (20000 . 5) (20001 . 5)
		 (20002 . 5)(30000 . 6)(20004 . 5)(20005 . 5)(20006 . 5)))

      ;; 1-level 7 mappings including CCL call

      (Assert-equal
	       (mapcar
		(lambda (val)
		  (ccl-test-map-multiple
		   val
		   '([100 1 2 nil 4 5]
		     [101 12 13 14 15 16 17]
		     [1000 101 ccl-test-arith-1 103 nil 105 106 ccl-test-nil 108]
		     [1005 1006 1007 1008 1009 ccl-test-lambda 1011 1012]
		     [10005 10006 10007 10008 10009 10010 10011 10012]
		     [20000 20000 20001 20002 nil 20004 20005 20006]
		     [20003 30000 30010 30020 30030 30040 30050 30060]
		     )))
		'(0 99 100 101 102 103 104 105 106 107
		    998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009
		    9999 10000 10001 10002 10003 10004
		    19999 20000 20001 20002 20003 20004
		    20005 20006))
	       '((0 . -1) (99 . -1) (1 . 0) (2 . 0) (13 . 1) (4 . 0)
		 (5 . 0) (16 . 1) (17 . 1) (107 . -1) (998 . -1)
		 (999 . -1) (101 . 2) (1001001 . 2) (103 . 2)
		 (1003 . -1) (105 . 2) (106 . 2) (1007 . 3) (108 . 2)
		 (1009 . 3) (1009 . 3) (9999 . -1) (10000 . -1)
		 (10001 . -1) (10002 . -1) (10003 . -1) (10004 . -1)
		 (19999 . -1) (20000 . 5) (20001 . 5) (20002 . 5)
		 (30000 . 6)(20004 . 5)(20005 . 5)(20006 . 5)))

      (Assert-equal
	       (mapcar
		(lambda (val)
		  (ccl-test-iterate-multiple-map
		   val
		   '([100 1 2 nil 4 5]
		     [101 12 13 14 15 16 17]
		     [1000 101 ccl-test-arith-1 103 nil 105 106 ccl-test-nil 108]
		     [1005 1006 1007 1008 1009 ccl-test-lambda 1011 1012]
		     [10005 10006 10007 10008 10009 10010 10011 10012]
		     [20000 20000 20001 20002 nil 20004 20005 20006]
		     [20003 30000 30010 30020 30030 30040 30050 30060]
		     )))
		'(0 99 100 101 102 103 104 105 106 107
		    998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009
		    9999 10000 10001 10002 10003 10004
		    19999 20000 20001 20002 20003 20004
		    20005 20006))
	       '((0 . -1) (99 . -1) (1 . 0) (2 . 0) (13 . 1) (4 . 0)
		 (5 . 0) (16 . 1) (17 . 1) (107 . -1) (998 . -1)
		 (999 . -1) (101 . 2) (1001001 . 0) (103 . 2)
		 (1003 . -1) (105 . 2) (106 . 2) (-1 . 0) (108 . 2)
		 (1009 . 3) (-3 . 0) (9999 . -1) (10000 . -1)
		 (10001 . -1) (10002 . -1) (10003 . -1) (10004 . -1)
		 (19999 . -1) (20000 . 5) (20001 . 5) (20002 . 5)
		 (30000 . 6) (20004 . 5) (20005 . 5) (20006 . 5)))

      ;; 3-level mappings
      (Assert-equal
	       (mapcar
		(lambda (val)
		  (ccl-test-map-multiple
		   val
		   '([100 1 2 nil 4 5]
		     [101 12 13 14 15 16 17]
		     [1000 101 102 103 nil 105 106 nil 108]
		     (([1005 1006 1007 1008 1009 1010 1011 1012]
		       [10005 10006 20007 20008 10009 10010 10011 10012])
		      [20000 20000 20001 20002 nil 20004 20005 20006]
		      [1006 2006 2007 2008 2009 2010]
		      ([20003 30000 30010 30020 30030 30040 30050 30060]))
		     [t t 0 1000000]
		     [1008 1108 1109 1110 1111 1112 1113])))
		'(0 99 100 101 102 103 104 105 106 107
		    998 999 1000 1001 1002 1003 1004 1005 1006 1007
		    1008 1009 1010 1011 1012 1013 1014
		    9999 10000 10001 10002 10003 10004
		    10005 10006 10007 10008 10009 10010
		    19999 20000 20001 20002 20003 20004
		    20005 20006))
	       '((0 . 11) (99 . 11) (1 . 0) (2 . 0) (13 . 1)
		 (4 . 0) (5 . 0) (16 . 1) (17 . 1) (107 . 11)
		 (998 . 11) (999 . 11) (101 . 2) (102 . 2)
		 (103 . 2) (1003 . 11) (105 . 2) (106 . 2)
		 (1006 . 11) (108 . 2) (1108 . 12) (1109 . 12)
		 (1110 . 12)  (1111 . 12) (1112 . 12) (1113 . 12)
		 (1014 . 11) (9999 . 11) (10000 . 11) (10001 . 11)
		 (10002 . 11) (10003 . 11) (10004 . 11) (10005 . 11)
		 (30040 . 10) (30050 . 10) (10008 . 11) (10009 . 11)
		 (10010 . 11) (19999 . 11) (20000 . 11) (20001 . 11)
		 (20002 . 11) (20003 . 11) (20004 . 11) (20005 . 11)
		 (20006 . 11)))


      ;; 3-level mappings including CCL call
      (Assert-equal
	       (mapcar
		(lambda (val)
		  (ccl-test-map-multiple
		   val
		   '([100 1 2 nil 4 5]
		     [101 12 13 14 15 16 17]
		     [1000 101 102 103 nil ccl-test-arith-1 106 nil 108]
		     (([1005 1006 1007 1008 1009 1010 1011 ccl-test-arith-1
			     70 71 72 73]
		       [10005 10006 20007 20008 10009 10010 10011 10012])
		      [70 ccl-test-t ccl-test-lambda ccl-test-nil ccl-test-nil]
		      [72 lambda]
		      [20000 20000 20001 20002 nil 20004 20005 20006]
		      [1006 2006 2007 2008 2009 2010]
		      ([20003 30000 30010 ccl-test-arith-1 30030 30040 
			      ccl-test-arith-1 30060]
		       [1001010 50 51 52 53 54 55]))
		     [t t 0 1000000]
		     [t ccl-test-arith-1 0 10]
		     [1008 1108 1109 1110 1111 1112 1113])))
		'(0 99 100 101 102 103 104 105 106 107
		    998 999 1000 1001 1002 1003 1004 1005 1006 1007
		    1008 1009 1010 1011 1012 1013 1014 1015 1016
		    9999 10000 10001 10002 10003 10004
		    10005 10006 10007 10008 10009 10010
		    19999 20000 20001 20002 20003 20004
		    20005 20006))
	       '((1000000 . 15) (99 . 14) (1 . 0) (2 . 0) (13 . 1)
		 (4 . 0) (5 . 0) (16 . 1) (17 . 1) (107 . 14) (998 . 14)
		 (999 . 14) (101 . 2) (102 . 2) (103 . 2) (1003 . 14)
		 (1001004 . 2) (106 . 2) (1006 . 14) (108 . 2) (1108 . 16)
		 (1109 . 16) (1110 . 16) (51 . 13) (1112 . 16) (71 . 7)
		 (72 . 8) (1015 . 14) (1016 . 14) (9999 . 14) (10000 . 14)
		 (10001 . 14) (10002 . 14) (10003 . 14) (10004 . 14)
		 (10005 . 14) (30040 . 12) (1020008 . 12) (10008 . 14)
		 (10009 . 14) (10010 . 14) (19999 . 14) (20000 . 14)
		 (20001 . 14) (20002 . 14) (20003 . 14) (20004 . 14)
		 (20005 . 14) (20006 . 14)))
      ;; All map-instruction tests ends here.
      )

(defun ccl-test-suites ()
  (ccl-test-setup)
  (ccl-test-normal-expr)
  (ccl-test-simple-read-and-write)
  (ccl-test-read-write-multibyte-character)
  (ccl-test-ccl-call)
  (ccl-test-map-instructions)
  ;; Re-initialise the coding system:
  (ccl-test-setup))

;;; start tests only when ccl-execute is enabled.
(if (fboundp 'ccl-execute)
    (ccl-test-suites))

;;; ccl-test.el ends here.