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 ;;; automata generation
  10
  11 (defun lex-automata (rx)
  12   (let* ((rx (rx-simplify rx))
  13          (stack (list rx))              ; list of rx
  14          (table (list (rx-cons* rx 0 (lex-make-box (list 'd1 'd2)))))
  15                                         ; list of (rx id . box-for-reverse-links)
  16          (states ())                    ; list of (id act trans . box-for-reverse-links)
  17                                         ;   where trans = list of (pc id . box-for-reverse-links)
  18          (next-id 1)
  19          tbl-ent box id pcs act pc trans  rx-stepped p)
  20     (while (consp stack)
  21       (setq rx (car stack)
  22             stack (cdr stack)
  23             tbl-ent (assoc rx table)
  24             id (cadr tbl-ent)
  25             box (cddr tbl-ent)
  26             pcs (rx-head-pcs rx)
  27             act (rx-head-act rx)
  28             trans ())
  29       (while (consp pcs)
  30         (setq pc (car pcs)
  31               pcs (cdr pcs)
  32               rx-stepped (rx-step rx pc)
  33               p (assoc rx-stepped table))
  34         (if p
  35             (progn
  36               (setq trans (cons (cons pc (cdr p)) trans))
  37               (lex-add-box (cddr p) id))
  38           (setq p (rx-cons* rx-stepped next-id (lex-make-box (list id)))
  39                 trans (cons (cons pc (cdr p)) trans)
  40                 table (cons p table)
  41                 next-id (1+ next-id)
  42                 stack (cons rx-stepped stack))))
  43       (setq states
  44             (cons (rx-cons* id act trans box)
  45                   states)))
  46     states))
  47
  48 ;;; automata coding
  49
  50 (defvar lex-pc-var (make-symbol "pc"))
  51 (defvar lex-act-var (make-symbol "act"))
  52 (defvar lex-escape-tag (make-symbol "esc"))
  53
  54 (defun lex-gen-machine (states cs acts read-macro save-macro)
  55   `(let (,lex-pc-var ,lex-act-var)
  56      (catch ',lex-escape-tag
  57        (automata
  58         ,lex-pc-var 0
  59         ,@(mapcar
  60            (lambda (s) (lex-gen-state s cs read-macro save-macro))
  61            states)))
  62      (automata-branch
  63       ,lex-act-var ,(apply 'natset-single (mapcar 'car acts)) automata-never-fail
  64       ,@(mapcar
  65          (lambda (act) `(,(natset-single (car act)) nil ,@(cdr act)))
  66          acts))))
  67
  68 (defun lex-gen-state (s cs read-macro save-macro)
  69   (let ((id (nth 0 s))
  70         (act (nth 1 s))
  71         (trans (nth 2 s)))
  72     `(,id
  73       (progn
  74         ,@(if act
  75               `((lex-match ,(cdr act)) (,save-macro))
  76             ())
  77         ,@(if (consp trans) `((,read-macro ,lex-pc-var))))
  78       (lex-fail)
  79       ,@(mapcar
  80          (lambda (tr) `(,(let ((l (member (car tr) cs)))
  81                            (if (null (cdr l))
  82                                (natset-seg (car l))
  83                              (natset-seg (car l) (1- (cadr l)))))
  84                         ,(cadr tr)))
  85          trans))))
  86
  87 ;;; internal macros
  88
  89 (defmacro lex-match (id)
  90   `(setq ,lex-act-var ',id))
  91 (defmacro lex-fail ()
  92   `(throw ',lex-escape-tag nil))
  93
  94 ;;; user interface macro
  95
  96 ;;; multibyte
  97
  98 (defvar lex-scan-multibyte-str-var (make-symbol "str"))
  99 (defvar lex-scan-multibyte-ptr-var (make-symbol "ptr"))
 100 (defvar lex-scan-multibyte-end-var (make-symbol "end"))
 101 (defvar lex-scan-multibyte-mch-var (make-symbol "mch"))
 102
 103 (defmacro lex-scan-multibyte-read (pc)
 104   `(if (< ,lex-scan-multibyte-ptr-var ,lex-scan-multibyte-end-var)
 105        (setq ,pc (sref ,lex-scan-multibyte-str-var ,lex-scan-multibyte-ptr-var)
 106              ,lex-scan-multibyte-ptr-var (char-next-index ,pc ,lex-scan-multibyte-ptr-var)
 107              ,pc (char-int ,pc))
 108      (lex-fail)))
 109
 110 (defmacro lex-scan-multibyte-save ()
 111   `(setq ,lex-scan-multibyte-mch-var ,lex-scan-multibyte-ptr-var))
 112
 113 (defmacro lex-scan-multibyte (str start end &rest clauses)
 114   (if (not start) (setq start 0))
 115   (if (not end) (setq end `(length ,lex-scan-multibyte-str-var)))
 116   (let ((id 1) (rx ()) (acts ()) tmp code
 117         (restore-code (if (symbolp start) `(setq ,start ,lex-scan-multibyte-mch-var))))
 118     (while (consp clauses)
 119       (setq rx (cons (rx-con (caar clauses) (rx-act id)) rx)
 120             acts (cons (cons id (cons restore-code (cdar clauses))) acts)
 121             id (1+ id)
 122             clauses (cdr clauses)))
 123     (setq rx (rx-alt rx)
 124           tmp (rx-categolize-char (rx-desugar rx)))
 125     `(let* ((,lex-scan-multibyte-str-var ,str)
 126             (,lex-scan-multibyte-ptr-var ,start)
 127             (,lex-scan-multibyte-end-var ,end)
 128             ,lex-scan-multibyte-mch-var)
 129        ,(lex-gen-machine (lex-automata (car tmp)) (cdr tmp) acts 'lex-scan-multibyte-read 'lex-scan-multibyte-save))))
 130
 131 ;;; unibyte
 132
 133 (defvar lex-scan-unibyte-str-var (make-symbol "str"))
 134 (defvar lex-scan-unibyte-ptr-var (make-symbol "ptr"))
 135 (defvar lex-scan-unibyte-end-var (make-symbol "end"))
 136 (defvar lex-scan-unibyte-mch-var (make-symbol "mch"))
 137
 138 (defmacro lex-scan-unibyte-read (pc)
 139   `(if (< ,lex-scan-unibyte-ptr-var ,lex-scan-unibyte-end-var)
 140        (setq ,pc (aref ,lex-scan-unibyte-str-var ,lex-scan-unibyte-ptr-var)
 141              ,lex-scan-unibyte-ptr-var (1+ ,lex-scan-unibyte-ptr-var)
 142              ,pc (char-int ,pc))
 143      (lex-fail)))
 144
 145 (defmacro lex-scan-unibyte-save ()
 146   `(setq ,lex-scan-unibyte-mch-var ,lex-scan-unibyte-ptr-var))
 147
 148 (defmacro lex-scan-unibyte (str start end &rest clauses)
 149   (if (not start) (setq start 0))
 150   (if (not end) (setq end `(length ,lex-scan-unibyte-str-var)))
 151   (let ((id 1) (rx ()) (acts ()) tmp code
 152         (restore-code (if (symbolp start) `(setq ,start ,lex-scan-unibyte-mch-var))))
 153     (while (consp clauses)
 154       (setq rx (cons (rx-con (caar clauses) (rx-act id)) rx)
 155             acts (cons (cons id (cons restore-code (cdar clauses))) acts)
 156             id (1+ id)
 157             clauses (cdr clauses)))
 158     (setq rx (rx-alt rx)
 159           tmp (rx-categolize-char (rx-desugar rx)))
 160     `(let* ((,lex-scan-unibyte-str-var ,str)
 161             (,lex-scan-unibyte-ptr-var ,start)
 162             (,lex-scan-unibyte-end-var ,end)
 163             ,lex-scan-unibyte-mch-var)
 164        ,(lex-gen-machine (lex-automata (car tmp)) (cdr tmp) acts 'lex-scan-unibyte-read 'lex-scan-unibyte-save))))
 165
 166 ;;; utilities
 167
 168 (defun lex-make-box (val)
 169   (list val))
 170 (defalias 'lex-box-ref 'car)
 171
 172 (defun lex-add-box (box val)
 173   (if (not (member val (car box)))
 174       (setcar box (cons val (car box)))))
 175
 176 ;;; testing
 177 '(
 178
 179   (mapcar (lambda (v) (set v (intern (symbol-name (symbol-value v)))))
 180           '(lex-pc-var
 181             lex-act-var
 182             lex-escape-tag
 183             lex-scan-multibyte-str-var
 184             lex-scan-multibyte-ptr-var
 185             lex-scan-multibyte-end-var
 186             lex-scan-multibyte-mch-var
 187             lex-scan-unibyte-str-var
 188             lex-scan-unibyte-ptr-var
 189             lex-scan-unibyte-end-var
 190             lex-scan-unibyte-mch-var))
 191
 192   (lex-scan-multibyte
 193    "aaa" 0 3
 194    (?a 'a))
 195
 196 )