From 708c8e6fa05d8a90d38473e8ed9e2088be9a9ade Mon Sep 17 00:00:00 2001 From: akr Date: Sun, 23 Aug 1998 07:03:38 +0000 Subject: [PATCH] * 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'. --- ChangeLog | 14 ++++++ Makefile | 7 +++ TESTPAT | 144 +++++++++++++++++++++++++++++++------------------------------ lex.el | 99 ++++++++++++++++++++++++++++-------------- 4 files changed, 160 insertions(+), 104 deletions(-) diff --git a/ChangeLog b/ChangeLog index cc8cc48..3d9b878 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,5 +1,19 @@ 1998-08-23 Tanaka Akira + * 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 + * 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 -- 1.7.10.4