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