lex.el

   1 (require 'emu)
   2 (require 'rx)
   3 (require 'automata)
   4 (provide 'lex)
   5
   6 (put 'lex-scan-multibyte 'lisp-indent-function 3)
   7 (put 'lex-scan-unibyte 'lisp-indent-function 3)
   8
   9 ;;;
  10
  11 (eval-and-compile
  12 ;; CCL is not so fast for this library.
  13 ;; Because it requires quadratic time for skipping string prefix.
  14 ;; However, it is bit faster than emacs-lisp on average for common case,
  15 ;; it is default if available.
  16 (defvar lex-use-ccl (fboundp 'ccl-execute-on-string))
  17 (when lex-use-ccl
  18   (require 'ccl))
  19 )
  20
  21 ;;; user interface macro
  22
  23 ;;; multibyte
  24
  25 (defvar lex-scan-multibyte-str-var (make-symbol "str"))
  26 (defvar lex-scan-multibyte-ptr-var (make-symbol "ptr"))
  27 (defvar lex-scan-multibyte-end-var (make-symbol "end"))
  28 (defvar lex-scan-multibyte-mch-var (make-symbol "mch"))
  29
  30 (defmacro lex-scan-multibyte-read (pc)
  31   `(if (< ,lex-scan-multibyte-ptr-var ,lex-scan-multibyte-end-var)
  32        (setq ,pc (sref ,lex-scan-multibyte-str-var ,lex-scan-multibyte-ptr-var)
  33              ,lex-scan-multibyte-ptr-var (char-next-index ,pc ,lex-scan-multibyte-ptr-var)
  34              ,pc (char-int ,pc))
  35      (lex-fail)))
  36
  37 (defmacro lex-scan-multibyte-save ()
  38   `(setq ,lex-scan-multibyte-mch-var ,lex-scan-multibyte-ptr-var))
  39
  40 (defmacro lex-scan-multibyte (str start end &rest clauses)
  41   (if (not start) (setq start 0))
  42   (if (not end) (setq end `(length ,lex-scan-multibyte-str-var)))
  43   (let ((id 1) (rx ()) (acts ()) tmp code
  44         (restore-code (if (symbolp start) `(setq ,start ,lex-scan-multibyte-mch-var))))
  45     (while (consp clauses)
  46       (setq rx (cons (rx-con (caar clauses) (rx-act id)) rx)
  47             acts (cons (cons id (cons restore-code (cdar clauses))) acts)
  48             id (1+ id)
  49             clauses (cdr clauses)))
  50     (setq rx (rx-alt rx)
  51           tmp (rx-categolize-char (rx-desugar rx)))
  52     `(let* ((,lex-scan-multibyte-str-var ,str)
  53             (,lex-scan-multibyte-ptr-var ,start)
  54             (,lex-scan-multibyte-end-var ,end)
  55             ,lex-scan-multibyte-mch-var)
  56        ,(lex-gen-machine (lex-automata (car tmp)) (cdr tmp) acts 'lex-scan-multibyte-read 'lex-scan-multibyte-save))))
  57
  58 ;;; unibyte
  59
  60 (defvar lex-scan-unibyte-str-var (make-symbol "str"))
  61 (defvar lex-scan-unibyte-ptr-var (make-symbol "ptr"))
  62 (defvar lex-scan-unibyte-end-var (make-symbol "end"))
  63 (defvar lex-scan-unibyte-mch-var (make-symbol "mch"))
  64
  65 (defmacro lex-scan-unibyte-read (pc)
  66   `(if (< ,lex-scan-unibyte-ptr-var ,lex-scan-unibyte-end-var)
  67        (setq ,pc (aref ,lex-scan-unibyte-str-var ,lex-scan-unibyte-ptr-var)
  68              ,lex-scan-unibyte-ptr-var (1+ ,lex-scan-unibyte-ptr-var)
  69              ,pc (char-int ,pc))
  70      (lex-fail)))
  71
  72 (defmacro lex-scan-unibyte-save ()
  73   `(setq ,lex-scan-unibyte-mch-var ,lex-scan-unibyte-ptr-var))
  74
  75 (defmacro lex-scan-unibyte (str start end &rest clauses)
  76   (if (not start) (setq start 0))
  77   (if (not end) (setq end `(length ,lex-scan-unibyte-str-var)))
  78   (let ((id 1) (rx ()) (acts ()) tmp code
  79         (restore-code (if (symbolp start) `(setq ,start ,lex-scan-unibyte-mch-var))))
  80     (while (consp clauses)
  81       (setq rx (cons (rx-con (caar clauses) (rx-act id)) rx)
  82             acts (cons (cons id (cons restore-code (cdar clauses))) acts)
  83             id (1+ id)
  84             clauses (cdr clauses)))
  85     (setq rx (rx-alt rx)
  86           tmp (rx-categolize-char (rx-desugar rx)))
  87     `(let* ((,lex-scan-unibyte-str-var ,str)
  88             (,lex-scan-unibyte-ptr-var ,start)
  89             (,lex-scan-unibyte-end-var ,end)
  90             ,lex-scan-unibyte-mch-var)
  91        ,(lex-gen-machine (lex-automata (car tmp)) (cdr tmp) acts 'lex-scan-unibyte-read 'lex-scan-unibyte-save))))
  92
  93 ;;; automata generation
  94
  95 (defun lex-automata (rx)
  96   (let* ((rx (rx-simplify rx))
  97          (stack (list rx))              ; list of rx
  98          (table (list (rx-cons* rx 0 (lex-make-box (list 'd1 'd2)))))
  99                                         ; list of (rx id . box-for-reverse-links)
 100          (states ())                    ; list of (id act trans . box-for-reverse-links)
 101                                         ;   where trans = list of (pc id . box-for-reverse-links)
 102          (next-id 1)
 103          tbl-ent box id pcs act pc trans  rx-stepped p)
 104     (while (consp stack)
 105       (setq rx (car stack)
 106             stack (cdr stack)
 107             tbl-ent (assoc rx table)
 108             id (cadr tbl-ent)
 109             box (cddr tbl-ent)
 110             pcs (rx-head-pcs rx)
 111             act (rx-head-act rx)
 112             trans ())
 113       (while (consp pcs)
 114         (setq pc (car pcs)
 115               pcs (cdr pcs)
 116               rx-stepped (rx-step rx pc)
 117               p (assoc rx-stepped table))
 118         (if p
 119             (progn
 120               (setq trans (cons (cons pc (cdr p)) trans))
 121               (lex-add-box (cddr p) id))
 122           (setq p (rx-cons* rx-stepped next-id (lex-make-box (list id)))
 123                 trans (cons (cons pc (cdr p)) trans)
 124                 table (cons p table)
 125                 next-id (1+ next-id)
 126                 stack (cons rx-stepped stack))))
 127       (setq states
 128             (cons (rx-cons* id act trans box)
 129                   states)))
 130     states))
 131
 132 ;;; automata coding
 133
 134 (defvar lex-pc-var (make-symbol "pc"))
 135 (defvar lex-act-var (make-symbol "act"))
 136 (defvar lex-escape-tag (make-symbol "esc"))
 137
 138 (defun lex-gen-machine (states cs acts read-macro save-macro)
 139   `(let (,lex-pc-var ,lex-act-var)
 140      ,(if (and lex-use-ccl
 141                (eq read-macro 'lex-scan-unibyte-read)
 142                (eq save-macro 'lex-scan-unibyte-save))
 143           (lex-gen-ccl-unibyte-automata states cs)
 144         (lex-gen-automata states cs read-macro save-macro))
 145      ,(lex-gen-action acts)))
 146
 147 (defun lex-gen-automata (states cs read-macro save-macro)
 148   `(catch ',lex-escape-tag
 149      (automata
 150       ,lex-pc-var 0
 151       ,@(mapcar
 152          (lambda (s) (lex-gen-state s cs read-macro save-macro))
 153          states))))
 154
 155 (defun lex-gen-state (s cs read-macro save-macro)
 156   (let ((id (nth 0 s))
 157         (act (nth 1 s))
 158         (trans (nth 2 s)))
 159     `(,id
 160       (progn
 161         ,@(if act
 162               `((lex-match ,(cdr act)) (,save-macro))
 163             ())
 164         ,@(if (consp trans) `((,read-macro ,lex-pc-var))))
 165       (lex-fail)
 166       ,@(mapcar
 167          (lambda (tr) `(,(let ((l (member (car tr) cs)))
 168                            (if (null (cdr l))
 169                                (natset-seg (car l))
 170                              (natset-seg (car l) (1- (cadr l)))))
 171                         ,(cadr tr)))
 172          trans))))
 173
 174 (defun lex-gen-action (acts)
 175   `(automata-branch
 176     ,lex-act-var ,(apply 'natset-single (mapcar 'car acts)) automata-never-fail
 177     ,@(mapcar
 178        (lambda (act) `(,(natset-single (car act)) nil ,@(cdr act)))
 179        acts)))
 180
 181 ;;; CCL version automata generation
 182
 183 (defun lex-gen-ccl-unibyte-automata (states cs)
 184   ;; read-macro is lex-scan-unibyte-read
 185   ;; save-macro is lex-scan-unibyte-save
 186   `(let ((status [nil nil nil nil nil nil nil nil nil]))
 187      (aset status 0 nil)                       ; r0: pc
 188      (aset status 1 0)                         ; r1: state
 189      (aset status 2 ,lex-scan-unibyte-ptr-var) ; r2: ptr
 190      (aset status 3 ,lex-scan-unibyte-ptr-var) ; r3: start
 191      (aset status 4 ,lex-scan-unibyte-end-var) ; r4: end
 192      (aset status 5 nil)                       ; r5: mch
 193      (aset status 6 0)                         ; r6: act
 194      (aset status 7 nil)                       ; r7
 195      (aset status 8 nil)                       ; ic
 196      (ccl-execute-on-string
 197       (eval-when-compile
 198         (ccl-compile
 199          ',(lex-gen-ccl-unibyte-automata-program states cs)))
 200       status
 201       ,lex-scan-unibyte-str-var)
 202      (setq ,lex-scan-unibyte-ptr-var (aref status 2))
 203      (when (< 0 (aref status 6))
 204        (setq ,lex-act-var (aref status 6)
 205              ,lex-scan-unibyte-mch-var (aref status 5)))))
 206
 207 (defun lex-gen-ccl-unibyte-automata-program (states cs)
 208   `(0
 209     ((loop
 210       (if (r3 > 0)
 211           ((r3 -= 1)
 212            (read r0)
 213            (repeat))
 214         (break)))
 215      (loop
 216       (branch r1
 217         ,@(mapcar
 218            (lambda (s) (lex-gen-ccl-unibyte-automata-state
 219                         (nth 0 s) (cdr (nth 1 s)) (nth 2 s)
 220                         cs))
 221            (sort states
 222                  (lambda (a b) (< (car a) (car b))))))))))
 223
 224 (defun lex-gen-ccl-unibyte-automata-state (id act trans cs)
 225   `(,@(when act
 226         `((r5 = r2)
 227           (r6 = ,act)))
 228     ,@(if (consp trans)
 229           `((if (r4 <= r2)
 230                 (end)
 231               ((read r0)
 232                (r2 += 1)
 233                ,(apply
 234                  'natset-gen-ccl-branch
 235                  'r0
 236                  '(end)
 237                  (mapcar
 238                   (lambda (tr) (cons
 239                                 (let ((l (member (car tr) cs)))
 240                                   (if (null (cdr l))
 241                                       (natset-seg (car l))
 242                                     (natset-seg (car l) (1- (cadr l)))))
 243                                 `((r1 = ,(cadr tr))
 244                                   (repeat))))
 245                   trans))
 246                (repeat))))
 247         '((end)))))
 248
 249 ;;; internal macros
 250
 251 (defmacro lex-match (id)
 252   `(setq ,lex-act-var ',id))
 253 (defmacro lex-fail ()
 254   `(throw ',lex-escape-tag nil))
 255
 256 ;;; utilities
 257
 258 (defun lex-make-box (val)
 259   (list val))
 260 (defalias 'lex-box-ref 'car)
 261
 262 (defun lex-add-box (box val)
 263   (if (not (member val (car box)))
 264       (setcar box (cons val (car box)))))
 265
 266 ;;; testing
 267 '(
 268
 269   (mapcar (lambda (v) (set v (intern (symbol-name (symbol-value v)))))
 270           '(lex-pc-var
 271             lex-act-var
 272             lex-escape-tag
 273             lex-scan-multibyte-str-var
 274             lex-scan-multibyte-ptr-var
 275             lex-scan-multibyte-end-var
 276             lex-scan-multibyte-mch-var
 277             lex-scan-unibyte-str-var
 278             lex-scan-unibyte-ptr-var
 279             lex-scan-unibyte-end-var
 280             lex-scan-unibyte-mch-var))
 281
 282   (lex-scan-multibyte
 283    "aaa" 0 3
 284    (?a 'a))
 285
 286 (let* ((str "abcdef\ndeefx\r\n jfdks\r")
 287        (p 15))
 288   (cons
 289    (lex-scan-unibyte str p nil
 290      (()
 291       'error)
 292      (((* [^ "\r\n"])
 293        (* (+ ?\r) [^ "\r\n"] (* [^ "\r"]))
 294        (* ?\r)
 295        (?\r ?\n [" \t"]))
 296       'line-fold)
 297      (((* [^ "\r\n"])
 298        (* (+ ?\r) [^ "\r\n"] (* [^ "\r"]))
 299        (* ?\r)
 300        (?\r ?\n))
 301       'line-crlf)
 302      (((* [^ "\r\n"])
 303        (* (+ ?\r) [^ "\r\n"] (* [^ "\r"]))
 304        (* ?\r))
 305       'line))
 306    p))
 307
 308 (ew-crlf-line-convert "abcdef\ndeefx\r\n jfdks\r"
 309   (lambda (a) (format "[L:%s]" a))
 310   (lambda (a) (format "[F:%s]" a))
 311   (lambda (a) (format "[N:%s]" a)))
 312
 313
 314 )
 315