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