From: akr <akr>
Date: Sun, 23 Aug 1998 07:03:38 +0000 (+0000)
Subject: * Makefile (check): New rule.
X-Git-Tag: doodle-1_9_2~29
X-Git-Url: http://git.chise.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=708c8e6fa05d8a90d38473e8ed9e2088be9a9ade;p=elisp%2Fflim.git

* Makefile (check): New rule.

* TESTPAT: Add batch testing facility.

* lex.el (lex-use-ccl): Abolished.
(lex-ccl-execute): New variable.
(lex-ccl-use-name): New variable.
(lex-gen-machine): Use `lex-ccl-execute' instead of `lex-use-ccl'.
(lex-gen-ccl-unibyte-automata): Use `lex-ccl-execute' and
`lex-ccl-use-name' for generating codes.
(lex-gen-ccl-unibyte-automata-program): Use `lex-ccl-execute'.
---

diff --git a/ChangeLog b/ChangeLog
index cc8cc48..3d9b878 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,19 @@
 1998-08-23  Tanaka Akira      <akr@jaist.ac.jp>
 
+	* Makefile (check): New rule.
+
+	* TESTPAT: Add batch testing facility.
+
+	* lex.el (lex-use-ccl): Abolished.
+	(lex-ccl-execute): New variable.
+	(lex-ccl-use-name): New variable.
+	(lex-gen-machine): Use `lex-ccl-execute' instead of `lex-use-ccl'.
+	(lex-gen-ccl-unibyte-automata): Use `lex-ccl-execute' and
+	`lex-ccl-use-name' for generating codes.
+	(lex-gen-ccl-unibyte-automata-program): Use `lex-ccl-execute'.
+
+1998-08-23  Tanaka Akira      <akr@jaist.ac.jp>
+
 	* lex.el (lex-gen-ccel-unibyte-automata-state): Jump start of loop
 	on end of states.
 
diff --git a/Makefile b/Makefile
index beba984..0882879 100644
--- a/Makefile
+++ b/Makefile
@@ -52,3 +52,10 @@ release:
 
 ew-parse.el: ew-parse.scm lalr-el.scm
 	-scm -f lalr-el.scm -f ew-parse.scm > ew-parse.out
+
+check:
+	$(EMACS) -q -batch -eval '(setq load-path (cons "." load-path))' -l ./TESTPAT -eval '(report)'
+
+benchmark:
+	$(EMACS) -q -batch -eval '(setq load-path (cons "." load-path))' -l ./BENCHMARK -eval '(report)'
+
diff --git a/TESTPAT b/TESTPAT
index 1290c99..f417c3d 100644
--- a/TESTPAT
+++ b/TESTPAT
@@ -19,71 +19,71 @@
 
 ;;; test driver
 
-;;; FLIM or FLAM
-'(progn
-(require 'mime)
-(require 'ew-line)
-
-(if (< max-specpdl-size 1000)
-  (setq max-specpdl-size 1000))
-
-(defun decode-test (src dsts &rest opts)
-  (setq src (ew-crlf-to-lf src))
-  (setq eword-lexical-analyze-cache nil)
-  (setq eword-decode-sticked-encoded-word
-    (or (memq 'permit-sticked-comment opts)
-  	(memq 'permit-sticked-special opts)))
-  (setq eword-decode-quoted-encoded-word nil)
-  (with-temp-buffer
-    (insert src "\n" mail-header-separator)
-    (eword-decode-header 'us-ascii mail-header-separator)
-    (goto-char (point-min))
-    (std11-narrow-to-header mail-header-separator)
-    (std11-field-end)
-    (let ((result (std11-unfold-string
-		   (buffer-substring (point-min) (point)))))
-      (if (member result dsts) t result))))
-
-(defun encode-test (src dsts &rest opts)
-  (setq eword-lexical-analyze-cache nil)
-  (setq eword-decode-sticked-encoded-word nil)
-  (setq eword-decode-quoted-encoded-word nil)
-  (with-temp-buffer
-    (insert src "\n" mail-header-separator)
-    (goto-char (point-min))
-    (eword-encode-header 'us-ascii)
-    (goto-char (point-min))
-    (std11-narrow-to-header mail-header-separator)
-    (std11-field-end)
-    (let ((result (buffer-substring (point-min) (point))))
-      (if (member result dsts) t result))))
-)
-
-;;; EW
-(progn
-(require 'ew-dec)
-(require 'ew-line)
-
-(defun decode-test (src dsts &rest opts)
-  (setq ew-decode-field-cache-buf nil)
-  (let ((ew-decode-sticked-encoded-word nil)
-	(ew-decode-quoted-encoded-word nil)
-	(ew-ignore-75bytes-limit (memq 'ignore-75bytes-limit opts))
-	(ew-ignore-76bytes-limit (memq 'ignore-76bytes-limit opts))
-	(ew-permit-sticked-comment (memq 'permit-sticked-comment opts))
-	(ew-permit-sticked-special (memq 'permit-sticked-special opts)))
-    (string-match "\\`[^:]*:" src)
-    (let* ((field-name (substring src
-				  (match-beginning 0)
-				  (1- (match-end 0))))
-	   (field-body (substring src (match-end 0)))
-	   (result (ew-crlf-unfold
-		    (concat field-name ":"
-			    (ew-decode-field field-name field-body)))))
-      (if (member result dsts) t result))))
-
-(defun encode-test (src dsts &rest opts)
-  nil)
+(defvar target 'doodle)
+(cond
+ ((eq target 'flim) ; FLIM or FLAM
+  (require 'mime)
+  (require 'ew-line)
+
+  (if (< max-specpdl-size 1000)
+    (setq max-specpdl-size 1000))
+
+  (defun decode-test (src dsts &rest opts)
+    (setq src (ew-crlf-to-lf src))
+    (setq eword-lexical-analyze-cache nil)
+    (setq eword-decode-sticked-encoded-word
+      (or (memq 'permit-sticked-comment opts)
+	  (memq 'permit-sticked-special opts)))
+    (setq eword-decode-quoted-encoded-word nil)
+    (with-temp-buffer
+      (insert src "\n" mail-header-separator)
+      (eword-decode-header 'us-ascii mail-header-separator)
+      (goto-char (point-min))
+      (std11-narrow-to-header mail-header-separator)
+      (std11-field-end)
+      (let ((result (std11-unfold-string
+		     (buffer-substring (point-min) (point)))))
+	(if (member result dsts) t result))))
+
+  (defun encode-test (src dsts &rest opts)
+    (setq eword-lexical-analyze-cache nil)
+    (setq eword-decode-sticked-encoded-word nil)
+    (setq eword-decode-quoted-encoded-word nil)
+    (with-temp-buffer
+      (insert src "\n" mail-header-separator)
+      (goto-char (point-min))
+      (eword-encode-header 'us-ascii)
+      (goto-char (point-min))
+      (std11-narrow-to-header mail-header-separator)
+      (std11-field-end)
+      (let ((result (buffer-substring (point-min) (point))))
+	(if (member result dsts) t result)))))
+
+ ((eq target 'doodle) ; DOODLE
+  (require 'ew-dec)
+  (require 'ew-line)
+
+  (defun decode-test (src dsts &rest opts)
+    (setq ew-decode-field-cache-buf nil)
+    (let ((ew-decode-sticked-encoded-word nil)
+	  (ew-decode-quoted-encoded-word nil)
+	  (ew-ignore-75bytes-limit (memq 'ignore-75bytes-limit opts))
+	  (ew-ignore-76bytes-limit (memq 'ignore-76bytes-limit opts))
+	  (ew-permit-sticked-comment (memq 'permit-sticked-comment opts))
+	  (ew-permit-sticked-special (memq 'permit-sticked-special opts)))
+      (string-match "\\`[^:]*:" src)
+      (let* ((field-name (substring src
+				    (match-beginning 0)
+				    (1- (match-end 0))))
+	     (field-body (substring src (match-end 0)))
+	     (result (ew-crlf-unfold
+		      (concat field-name ":"
+			      (ew-decode-field field-name field-body)))))
+	(if (member result dsts) t result))))
+
+  (defun encode-test (src dsts &rest opts)
+    nil)
+  )
 )
 
 ;;;
@@ -119,12 +119,14 @@
     res))
 
 (defun report ()
-  (insert
-    (format "\n\"Decode: %d/%d  Encode: %d/%d  Total: %d/%d\""
-      decode-succ-count decode-all-count
-      encode-succ-count encode-all-count
-      (+ decode-succ-count encode-succ-count)
-      (+ decode-all-count encode-all-count))))
+  (let ((report (format "Decode: %d/%d  Encode: %d/%d  Total: %d/%d"
+		  decode-succ-count decode-all-count
+		  encode-succ-count encode-all-count
+		  (+ decode-succ-count encode-succ-count)
+		  (+ decode-all-count encode-all-count))))
+    (if noninteractive
+      (princ (concat report "\n"))
+      (insert "\n\"" report "\""))))
 
 ;;;start-test
 
diff --git a/lex.el b/lex.el
index 2ba926b..30e1d11 100644
--- a/lex.el
+++ b/lex.el
@@ -9,12 +9,27 @@
 ;;;
 
 (eval-and-compile
-;; CCL is not so fast for this library.
-;; Because it requires quadratic time for skipping string prefix.
-;; However, it is bit faster than emacs-lisp on average for common case,
-;; it is default if available.
-(defvar lex-use-ccl (fboundp 'ccl-execute-on-string))
-(when lex-use-ccl
+
+;; As a result of profiling, CCL is slower than Emacs-Lisp, sigh...
+(setq lex-ccl-execute nil)
+
+(defvar lex-ccl-execute
+  (eval-when-compile
+    (or (when (fboundp 'ccl-execute-on-substring) 'ccl-execute-on-substring)
+	(when (fboundp 'ccl-execute-on-string) 'ccl-execute-on-string))))
+
+(defvar lex-ccl-use-name
+  (eval-when-compile
+    (and
+     lex-ccl-execute
+     (condition-case nil
+	 (progn
+	   (register-ccl-program 'test-ccl (ccl-compile '(0 (r0 = 1))))
+	   (ccl-execute-with-args 'test-ccl)
+	   t)
+       (error nil)))))
+
+(when lex-ccl-execute
   (require 'ccl))
 )
 
@@ -137,7 +152,7 @@
 
 (defun lex-gen-machine (states cs acts read-macro save-macro)
   `(let (,lex-pc-var ,lex-act-var)
-     ,(if (and lex-use-ccl
+     ,(if (and lex-ccl-execute
 	       (eq read-macro 'lex-scan-unibyte-read)
 	       (eq save-macro 'lex-scan-unibyte-save))
 	  (lex-gen-ccl-unibyte-automata states cs)
@@ -183,35 +198,53 @@
 (defun lex-gen-ccl-unibyte-automata (states cs)
   ;; read-macro is lex-scan-unibyte-read
   ;; save-macro is lex-scan-unibyte-save
-  `(let ((status [nil nil nil nil nil nil nil nil nil]))
-     (aset status 0 nil)                       ; r0: pc
-     (aset status 1 0)                         ; r1: state
-     (aset status 2 ,lex-scan-unibyte-ptr-var) ; r2: ptr
-     (aset status 3 ,lex-scan-unibyte-ptr-var) ; r3: start
-     (aset status 4 ,lex-scan-unibyte-end-var) ; r4: end
-     (aset status 5 nil)                       ; r5: mch
-     (aset status 6 0)                         ; r6: act
-     (aset status 7 nil)                       ; r7
-     (aset status 8 nil)                       ; ic
-     (ccl-execute-on-string
-      (eval-when-compile
-	(ccl-compile
-	 ',(lex-gen-ccl-unibyte-automata-program states cs)))
-      status
-      ,lex-scan-unibyte-str-var)
-     (setq ,lex-scan-unibyte-ptr-var (aref status 2))
-     (when (< 0 (aref status 6))
-       (setq ,lex-act-var (aref status 6)
-	     ,lex-scan-unibyte-mch-var (aref status 5)))))
+  (let ((name (make-symbol "ccl-prog-name"))
+	(frag-vector (make-vector 1 nil))
+		       )
+    `(let ((frag ,frag-vector)
+	   (status [nil nil nil nil nil nil nil nil nil])
+	   (prog (eval-when-compile
+		   (ccl-compile
+		    ',(lex-gen-ccl-unibyte-automata-program states cs)))))
+       (unless (aref frag 0)
+	 (register-ccl-program
+	  ',name prog)
+	 (aset frag 0 t))
+       (aset status 0 nil)                       ; r0: pc
+       (aset status 1 0)                         ; r1: state
+       (aset status 2 ,lex-scan-unibyte-ptr-var) ; r2: ptr
+       (aset status 3 ,lex-scan-unibyte-ptr-var) ; r3: start
+       (aset status 4 ,lex-scan-unibyte-end-var) ; r4: end
+       (aset status 5 nil)                       ; r5: mch
+       (aset status 6 0)                         ; r6: act
+       (aset status 7 nil)                       ; r7
+       (aset status 8 nil)                       ; ic
+       ,(if (eval-when-compile (eq lex-ccl-execute 'ccl-execute-on-string))
+	    `(ccl-execute-on-string
+	      ,(if (eval-when-compile lex-ccl-use-name) `',name `prog)
+	      status
+	      ,lex-scan-unibyte-str-var)
+	  `(ccl-execute-on-substring
+	    ,(if (eval-when-compile lex-ccl-use-name) `',name `prog)
+	    status
+	    ,lex-scan-unibyte-str-var
+	    ,lex-scan-unibyte-ptr-var
+	    ,lex-scan-unibyte-end-var))
+       (setq ,lex-scan-unibyte-ptr-var (aref status 2))
+       (when (< 0 (aref status 6))
+	 (setq ,lex-act-var (aref status 6)
+	       ,lex-scan-unibyte-mch-var (aref status 5))))))
 
 (defun lex-gen-ccl-unibyte-automata-program (states cs)
   `(0
-    ((loop
-      (if (r3 > 0)
-	  ((r3 -= 1)
-	   (read r0)
-	   (repeat))
-	(break)))
+    (,@(eval-when-compile
+	 (when (eq lex-ccl-execute 'ccl-execute-on-string)
+	   '((loop
+	      (if (r3 > 0)
+		  ((r3 -= 1)
+		   (read r0)
+		   (repeat))
+		(break))))))
      (loop
       (branch r1
         ,@(mapcar