misc-code/test-parser.lisp

#-esrap (ql:quickload :esrap)

(require :esrap)

(defpackage #:test-parser
  (:use :esrap
        :cl)
  (:export :display-parse-tree))

(in-package :test-parser)

(defvar *routines* (make-hash-table))
(defvar *variables* (make-hash-table))
(defvar *arrays* (make-hash-table))

(defun not-doublequote (char)
  (not (eql #\" char)))

(defun not-integer (string)
           (when (find-if-not #'digit-char-p string)
             t))

(defrule name
    (+ (alphanumericp character))
  (:text t))

(defrule space
    (+ (or #\Space #\Tab #\Newline))
  (:constant nil))

(defrule variable
    (and "*v:" name)
  (:destructure (vv name)
                (declare (ignore vv))
                (list :variable name)))

(defrule string-char
    (or (not-doublequote character)
        (and #\\ #\")))

(defrule string
    (and #\" (* string-char) #\")
  (:destructure (q1 string q2)
                (declare (ignore q1 q2))
                (list :string (text string))))

(defrule number
    (+ (or "0" "1" "2" "3" "4" "5" "6" "7" "8" "9"))
  (:lambda (list)
    (list :number (parse-integer (text list)))))

(defrule call-routine
    (and "*r:" name  "(" (? val-list) ")")
  (:destructure (call-syntax name lpar vals rpar)
                (declare (ignore call-syntax lpar rpar))
                (list 'handle-call-routine name vals)))

(defrule val-list
    (+ (or possible-value ", "))
  (:destructure (&rest vals)
                (let ((list '(:val-list)))
                  (dolist (value vals)
                    (if (not (stringp value))
                        (push value list)))
                  (reverse list))))

(defrule possible-value
    (or string variable number call-routine builtins array array-in))

(defrule assignment
    (and (or variable array)
         (? space)
         #\=
         (? space)
         possible-value)
  (:destructure (var s1 eqlsgn s2 value)
                (declare (ignore s1 eqlsgn s2))
                (list 'handle-assignment var value)))


(defrule builtins
    (and (or "out" "in" "system" "open" "close" "return" "argument" "random") "(" val-list ")")
  (:destructure (name start vals end)
                (declare (ignore start end))
                (list
                 (cond
                   ((string= name "out")
                    'do-out)
                   ((string= name "in")
                    'do-in)
                   ((string= name "system")
                    'do-system)
                   ((string= name "open")
                    'do-open)
                   ((string= name "close")
                    'do-close)
                   ((string= name "return")
                    'do-return)
                   ((string= name "argument")
                    'do-argument)
                   ((string= name "random")
                    'do-random))
                 vals)))

(defrule arith-ops
    (or "+" "-" "*" "/" "%" "^")
  (:lambda (operator)
    (cond
      ((string= operator "+") :PLUS)
      ((string= operator "-") :SUBT)
      ((string= operator "*") :MULT)
      ((string= operator "/") :DIVD)
      ((string= operator "%") :MODU)
      ((string= operator "^") :EXPT))))


(defrule arithmetic
    (or (and (? "(") (? space) arithmetic (? space) arith-ops (? space) arithmetic (? space) (? ")"))
        (or variable number))
  (:destructure (first second &optional aritha mspace op mmspace arithb mmmspace rpar)
                (if (symbolp first)
                    (list (list first second))
                    (list :ARITH
                          op
                          aritha
                          arithb))))

(defrule index
    (and ":" possible-value ":")
  (:destructure (s val e)
                (declare (ignore s e))
                val))

(defrule array
    (and "*a:" name (? index))
  (:destructure (va name index)
                (declare (ignore va))
                (list :ARRAY name index)))

(defrule array-in
    (and "<" val-list ">")
  (:destructure (s vals e)
                (declare (ignore s e))
                (list :aval vals)))


;; rest goes here

(defrule boolean
    (and variable (? space) (or "==" "!=" ">" "<" ">=" "<=") (? space) possible-value)
  (:destructure (variable s1 type s2 value)
                (declare (ignore s1 s2))
                (list :boolean variable type value)))

(defrule bool-name
    (or "AND" "NOT" "OR" "NOR")
  (:lambda (name)
                (cond
                  ((string= name "AND")
                   :AND)
                  ((string= name "NOT")
                   :NOT)
                  ((string= name "OR")
                   :OR)
                  ((string= name "NOR")
                   :NOR))))

(defrule statement
    (and (? space)
         (or assignment call-routine builtins)
         (? space) #\; (? space))
  (:destructure (space1 statement space2 semicolon space3)
                (declare (ignore semicolon space1 space2 space3))
                statement))

(defrule block
    (* statement)
  (:destructure (&rest statements)
                (list :block statements)))

(defrule else
    (and "ELSE:" space block)
  (:destructure (name space block)
                (declare (ignore name space))
                (list :ELSE block)))

(defrule else-if
    (and "ELSE-IF" space boolean #\: block)
  (:destructure (start space bool colon block)
                (declare (ignore start space colon))
                (list :ELSEIF bool block)))

(defrule if
    (and "IF" space boolean #\: space
         block
         (* (or else else-if))
         "ENDIF")
  (:destructure (start space bool colon morespace block else-else-ifs end)
                (declare (ignore start space colon morespace end))
                (list :IF bool block else-else-ifs)))

(defrule routine
    (and "ROUTINE" (? space) name #\:
         block
         "END-ROUTINE")
  (:destructure (rtn spc1 name colon block end-rtn)
                (declare (ignore rtn spc1 colon end-rtn))
                (list :routine name block)))
(defrule program
    (* (or statement if routine)))

(defun run-string (string)
  (run-program (parse 'program string)))

(defun run-program (program-list)
  (dolist (chunk program-list)
    (let ((type (car chunk)))
      (cond
        ((eq type :call-routine)
         (handle-call-routine chunk))
        ((eq type :assignment)
         (handle-assignment chunk))
        ((eq type :builtins)
         (handle-builtins chunk))
        ((eq type :block)
         (run-program (cdr chunk)))
        ((eq type :routine)
         (handle-routine chunk))
        ((eq type :if)
         (handle-if chunk))))))

(defun handle-call-routine (list))
(defun handle-assignment (list))
(defun handle-builtins (list))
(defun handle-routine (list)
  (let ((routine-name (cadr list))
        (routine (caddr list)))
    (setf (gethash (intern routine-name) *routines*) routine)))
(defun handle-if (list))
(defun set-variable (name value))
(defun set-whole-array (name vil value))
(defun set-array-indexed (name index values))

(defun display-parse-tree (string)
  (parse 'program string))