prolog-parser.lisp

(require :cl-lex)
(require :yacc)
(require :arnesi)
(use-package :cl-lex)
(use-package :yacc)
(arnesi:enable-sharp-l)

(defun str->sym (str) 
  (values (intern (string-upcase str))))

(defun +? (str)
  (if (string-equal str "_")
      str
      (concatenate 'string "?" str)))

(define-string-lexer prolog-lexer
  ("[a-z]+"          (return (values :const $@)))
  ("'\\w+'"          (return (values :const $@)))
  ("_"               (return (values :variable $@)))
  ("[_A-Z][a-zA-Z]*" (return (values :variable $@)))
  ("\\d+"            (return (values :number $@)))
  ("\\("             (return (values :lparen $@)))
  ("\\)"             (return (values :rparen $@)))
  ("\\["             (return (values :lbracket $@)))
  ("\\]"             (return (values :rbracket $@)))
  ("\\|"             (return (values :bar $@)))
  (":-"              (return (values :arrow  $@)))
  ("\\?-"            (return (values :query  $@)))
  ("\\."             (return (values :dot $@)))
  ("\\,"             (return (values :comma $@))))

(define-parser prolog-parser
  (:start-symbol program)
  (:terminals (:const :variable :number :lparen :rparen :lbracket :rbracket :bar :arrow :query :dot :comma))
  
  (program
   (statements #L(append '(progn) !1)))
  (statements
   (statement #L(list !1))
   (statement statements #L(cons !1 !2)))
  (statement
   query
   define)
  (query
   (:query terms :dot #3L(cons 'gambol:??- !2)))
  (define
   (term :dot #2L(list 'gambol:*- !1))
   (term :arrow terms :dot #4L(append (list 'gambol:*- !1) !3)))
  (terms
   (term #L(list !1))
   (term :comma terms #L(cons !1 !3)))
  (term
   (const :lparen args :rparen #4L(cons !1 !3)))
  (args
   (arg #L(list !1))
   (arg :comma args #L(cons !1 !3)))
  (arg
   variable 
   const
   (:number #L(parse-integer !1))
   list)
  (list
   (:lbracket :rbracket #2L(values nil))
   (:lbracket elems :rbracket #3L(values !2))
   (:lbracket elems :bar variable :rbracket #5L(append !2 !4)))
  (elems
   (elem #L(list !1))
   (elem :comma elems #L(cons !1 !3)))
  (elem
   variable
   const)
  (variable
   (:variable #L(str->sym (+? !1))))
  (const
   (:const #L(str->sym !1))))

(defun prolog->sexp (str)
  (let ((lexer (prolog-lexer str)))
    (parse-with-lexer lexer prolog-parser)))

(defun |#P-reader| (stream sub-char numarg)
  (declare (ignore sub-char numarg))
  (let* ((pattern (coerce "@end" 'list))
	 (pointer pattern)
	 (output))
    (do ((curr (read-char stream)
	       (read-char stream)))
	((null pointer))
      (push curr output)
      (setf pointer
	    (if (char= (car pointer) curr)
                (cdr pointer)
                pattern))
      (if (null pointer)
          (return)))
    (prolog->sexp
     (coerce
      (nreverse
       (nthcdr (length pattern) output))
      'string))))

(set-dispatch-macro-character
  #\# #\P #'|#P-reader|)