code.consxy.com Git - clnl/blob - src/main/lex.lisp

   1 (defpackage #:cl-nl.lexer
   2  (:use :common-lisp)
   3  (:export :lex))
   4
   5 (in-package #:cl-nl.lexer)
   6
   7 ; I played around with using #'read for netlogo code, which would have been neat.
   8 ; However, it provides too many instances where people could inject CL code
   9 ; and I wanted to prevent that.  In the end, writing my own lexer became kind of fun.
  10
  11 (defvar *state* :initial)
  12 (defvar *states* :extension-literal)
  13 (defparameter *lexes* nil)
  14
  15 (defun as-symbol (text) (intern (string-upcase text) :keyword))
  16
  17 (defmacro deflex (state match &optional func)
  18  (let
  19   ((scanner (gensym)))
  20  `(let
  21    ((,scanner (when (stringp ,match) (cl-ppcre:create-scanner ,match))))
  22    (pushnew
  23     (list
  24      (lambda (state text)
  25       (and
  26        (eql ,state state)
  27        (or
  28         (and (symbolp text) (eql text ,match))
  29         (and ,scanner
  30              (stringp text)
  31              (multiple-value-bind (start end) (cl-ppcre:scan ,scanner text)
  32               (and start end (= 0 start) (/= 0 end)))))))
  33      (lambda (text) (second (multiple-value-list (cl-ppcre:scan ,scanner text))))
  34      ,(or func #'as-symbol))
  35     *lexes*))))
  36
  37 (defun lex (text)
  38  (if (string= "" text)
  39      (let
  40       ((lex (find-if (lambda (f) (funcall f *state* :eof)) *lexes* :key #'car)))
  41       (when lex (list (funcall (third lex) :eof))))
  42      (let
  43       ((lex (find-if (lambda (f) (funcall f *state* text)) *lexes* :key #'car)))
  44       (when (not lex) (error "Can't lex this: ~S" text))
  45       (let
  46        ((val (funcall (third lex) (subseq text 0 (funcall (cadr lex) text)))))
  47        (if val
  48           (cons val (lex (subseq text (funcall (cadr lex) text))))
  49           (lex (subseq text (funcall (cadr lex) text))))))))
  50
  51 (defun set-state (new-state)
  52  (setf *state* new-state))
  53
  54 ; This part is the actual netlogo spec
  55
  56 (defvar *string-text* "(\\\"|\\r|\\n|\\t|\\\\|\\[^\"]|[^\r\n\"\\])*")
  57 (defvar *nonnewline_white_space_char* "[ \\t\\b\\012]")
  58 (defvar *letter* "\\w")
  59 (defvar *digit* "\\d")
  60 ;(defparameter *identifier-char* "[\\w\\d_\\.?=\*!<>:#\+/%\$\^\'&-]")
  61 (defvar *identifier-char* "[\\w\\d]")
  62
  63 ;(defvar *extension-literal-depth* 0)
  64 ;(defstruct extension-literal text)
  65
  66 ;(deflex :initial "{{"
  67 ; (lambda (text)
  68 ;  (set-state :extension-literal)
  69 ;  (as-symbol text)
  70 ;  ))
  71
  72 ;(deflex :extension-literal "}}"
  73 ; (lambda (text)
  74 ;  (if (= 0 *extension-literal-depth*)
  75 ;      (progn (set-state :initial) text)
  76 ;      (progn (decf *extension-literal-depth*) (as-symbol text)))))
  77
  78 ;(deflex :extension-literal "{{"
  79 ; (lambda (text) (incf *extension-literal-depth*) text))
  80
  81 ;(deflex :extension-literal "\n|\r" (lambda () (error "End of line reached unexpectedly")))
  82 ;(deflex :extension-literal :eof (lambda () (error "end of file reached unexpectedly")))
  83 ;(deflex :extension-literal ".")
  84
  85 (deflex :initial "[,\\{\\}\\[\\]\\(\\)]" #'as-symbol)
  86 (deflex :initial *nonnewline_white_space_char* (constantly nil))
  87 (deflex :initial "\\n|\\r" (constantly nil))
  88 ;(deflex :initial ";.*[\n\r]?" nil)
  89 ;(deflex :initial (format nil "-?\.?[0-9]~A" *identifier-char*)
  90 ; (lambda (text)
  91 ;  (let
  92 ;   ((num?
  93 ;     (let
  94 ;      ((*readtable* (copy-readtable nil))
  95 ;       (*read-eval* nil))
  96 ;      (read-from-string text))))
  97 ;   (if (numberp num?) num? (error "Invalid number")))))
  98
  99 (deflex :initial (format nil "~A*" *identifier-char*) #'as-symbol)
 100 ;(deflex :initial (format nil "\"~A*\"" *string-text*))
 101 ;(deflex :initial (format nil "\"~A*" *string-text*) (lambda (text) (error "Closing double quote is missing")))
 102 ;(deflex :initial "." (lambda (text) (error "Non standard character is not allowed")))