* 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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