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

   1 ; Copyright 2022 Frank Duncan (frank@consxy.com) under AGPL3.  See distributed LICENSE.txt.
   2 (in-package #:clnl-lexer)
   3
   4 ; I played around with using #'read for netlogo code, which would have been neat.
   5 ; However, it provides too many instances where people could inject CL code
   6 ; and I wanted to prevent that.  In the end, writing my own lexer became kind of fun.
   7
   8 (defvar *state* :initial)
   9 (defvar *states* :extension-literal)
  10 (defparameter *lexes* nil)
  11
  12 (defun as-symbol (text) (intern (string-upcase text) :keyword))
  13
  14 (defmacro deflex (state match &optional func)
  15  (let
  16   ((scanner (gensym)))
  17   `(let
  18     ((,scanner (when (stringp ,match) (cl-ppcre:create-scanner ,match))))
  19     (pushnew
  20      (list
  21       (lambda (state text)
  22        (and
  23         (eql ,state state)
  24         (or
  25          (and (symbolp text) (eql text ,match))
  26          (and
  27           ,scanner
  28           (stringp text)
  29           (multiple-value-bind (start end) (cl-ppcre:scan ,scanner text)
  30            (and start end (= 0 start) (/= 0 end)))))))
  31       (lambda (text) (second (multiple-value-list (cl-ppcre:scan ,scanner text))))
  32       ,(or func #'as-symbol))
  33      *lexes*))))
  34
  35 (defun lex (text)
  36  "LEX TEXT => AST
  37
  38 ARGUMENTS AND VALUES:
  39
  40   TEXT: Some NetLogo code
  41   AST: An ambigious AST that can later be parsed
  42
  43 DESCRIPTION:
  44
  45   LEX lexes NetLogo code.
  46
  47   LEX checks for some things, in as much as it can without knowing anything
  48   about some of the backgrounds of NetLogo.  However, it does the first pass
  49   with as much as it can."
  50  (if (string= "" text)
  51   (let
  52    ((lex (find-if (lambda (f) (funcall f *state* :eof)) *lexes* :from-end t :key #'car)))
  53    (when lex (list (funcall (third lex) :eof))))
  54   (let
  55    ((lex (find-if (lambda (f) (funcall f *state* text)) *lexes* :from-end t :key #'car)))
  56    (when (not lex) (error "Can't lex this: ~S" text))
  57    (let
  58     ((val (funcall (third lex) (subseq text 0 (funcall (cadr lex) text)))))
  59     (if val
  60      (cons val (lex (subseq text (funcall (cadr lex) text))))
  61      (lex (subseq text (funcall (cadr lex) text))))))))
  62
  63 (defun set-state (new-state)
  64  (setf *state* new-state))
  65
  66 ; This part is the actual netlogo spec
  67
  68 (defvar *string-text* "(\\\\\"|\\\\n|\\\\r|\\\\t|\\\\|[^\\r\\n\\\"])")
  69 (defvar *nonnewline_white_space_char* "[ \\t\\b\\012]")
  70 (defvar *letter* "\\w")
  71 (defvar *digit* "\\d")
  72 (defvar *identifier-char* "[\\w\\d_.?=\*!<>:#\+/%$\^'&-]")
  73
  74 ;(defvar *extension-literal-depth* 0)
  75 ;(defstruct extension-literal text)
  76
  77 ;(deflex :initial "{{"
  78 ; (lambda (text)
  79 ;  (set-state :extension-literal)
  80 ;  (as-symbol text)
  81 ;  ))
  82
  83 ;(deflex :extension-literal "}}"
  84 ; (lambda (text)
  85 ;  (if (= 0 *extension-literal-depth*)
  86 ;      (progn (set-state :initial) text)
  87 ;      (progn (decf *extension-literal-depth*) (as-symbol text)))))
  88
  89 ;(deflex :extension-literal "{{"
  90 ; (lambda (text) (incf *extension-literal-depth*) text))
  91
  92 ;(deflex :extension-literal "\n|\r" (lambda () (error "End of line reached unexpectedly")))
  93 ;(deflex :extension-literal :eof (lambda () (error "end of file reached unexpectedly")))
  94 ;(deflex :extension-literal ".")
  95
  96 (deflex :initial "[,\\{\\}\\[\\]\\(\\)]" #'as-symbol)
  97 (deflex :initial *nonnewline_white_space_char* (constantly nil))
  98 (deflex :initial "\\n|\\r" (constantly nil))
  99 (deflex :initial ";.*[\n\r]?" (constantly nil))
 100 (deflex :initial (format nil "-?\\.?[0-9]~A*" *identifier-char*)
 101  (lambda (text)
 102   (let
 103    ((num?
 104      (let
 105       ((*readtable* (copy-readtable nil))
 106        (*read-eval* nil))
 107       (read-from-string (format nil "~Ad0" text)))))
 108    (if (numberp num?) num? (error "Invalid number")))))
 109
 110 (deflex :initial (format nil "~A*" *identifier-char*) #'as-symbol)
 111 (deflex :initial (format nil "\"~A*\"" *string-text*)
 112  ; While this shouldn't let harmful strings in,
 113  ; one can't be too careful
 114  (lambda (text)
 115   (let
 116    ((*readtable* (copy-readtable nil))
 117     (*read-eval* nil))
 118    (read-from-string text))))
 119
 120 (deflex :initial (format nil "\"~A*" *string-text*)
 121  (lambda (text) (declare (ignore text)) (error "Closing double quote is missing")))
 122 ;(deflex :initial "." (lambda (text) (error "Non standard character is not allowed")))