(defpackage :php.parser
(:use :cl :smug :serapeum :alexandria))
(in-package :php.parser)
'(:token (<token-type> *value))
(defmacro if-token (token &body body)
(once-only (token)
`(if (and (consp ,token)
(eq (car ,token)
:token))
(progn ,@body)
(error (format nil "~s is not a token" ,token)))))
(defun get-token-type (token)
(if-token token
(cadr token)))
(defun get-token-args (token)
(if-token token
(cddr token)))
(defmethod input-empty-p ((input null))
t)
(defmethod input-empty-p ((input cons))
nil)
(defmethod input-first ((input cons))
(car input))
(defmethod input-rest ((input cons))
(cdr input))
(defun .match-lexical-element (keyword)
(.bind (.item)
(lambda (element)
(if (eq keyword
(car element))
(.identity element)
(.fail)))))
(defun .match-token (&optional type)
(.let* ((matched-token (.match-lexical-element :token)))
(if type
(if (eq type (get-token-type matched-token))
(.identity matched-token)
(.fail))
(.identity matched-token))))
(defun .match-keyword (&optional name)
(.let* ((tok (.match-token :keyword)))
(if name
(if (equal name (get-token-args tok))
(.identity tok)
(.fail))
(.identity tok))))
(defun .match-whitespace ()
(.match-lexical-element :whitespace))
(defun .match-operator (&optional op)
(.let* ((matched-op (.or (.match-token :operator)
(.match-token :punctuator)
(.match-token :paired-punctuator))))
(if (or (not op)
(equal (get-token-args matched-op)
op))
(.identity matched-op)
(.fail))))
(defun .match-punctuator (&optional sym)
(.or (.match-unpaired-punctuator sym)
(.match-paired-punctuator sym)))
(defun .match-unpaired-punctuator (&optional sym)
(.let* ((punct (.match-token :punctuator)))
(if (or (not sym)
(equal (get-token-args punct)
sym))
(.identity punct)
(.fail))))
(defun .match-paired-punctuator (&optional sym)
(.let* ((punct (.match-token :paired-punctuator)))
(if (or (not sym)
(equal (get-token-args punct)
sym))
(.identity punct)
(.fail))))
(defun .expression ()
(.item))
(defun .parenthesized-expression ()
(.prog2 (.match-paired-punctuator "(")
(.expression)
(.match-paired-punctuator ")")))
(defun .match-variable ()
(.match-token :variable))
(defun qualified-name-arguments (qualified-name-token)
(apply #'values (coerce (get-token-args qualified-name-token)
'list)))
(defun qualified-name-namespace (qualified-name-token)
(nth-value 0 (qualified-name-arguments qualified-name-token)))
(defun qualified-name-name (qualified-name-token)
(nth-value 1 (qualified-name-arguments qualified-name-token)))
(defun .match-qualified-name (&key (namespace nil namespace-p) name)
(.let* ((matched-name (.match-token :qualified-name)))
(if (or namespace-p name)
(multiple-value-bind (uw-namespace uw-name) (qualified-name-arguments matched-name)
(cond ((and namespace-p (not (equal namespace uw-namespace)))
(.fail))
((and name (not (equal name uw-name)))
(.fail))
(t (.identity matched-name))))
(.identity matched-name))))
(defun .match-name (&optional name)
(.match-qualified-name :namespace nil :name name))
(defun .match-literal ()
(.match-token :literal))
;;; Expressions
(defun .function-definition-header ()
(.progn (.match-keyword "function")))
(defun .primary-expression ()
(php.lexer::tag-result :expression
(.or (.match-variable)
(.match-qualified-name)
(.match-literal)
(.constant-expression)
;(.intrinsic)
;(.anonymous-function-creation-expression)
;(.parenthesized-expression)
)))
(defun .scalar-type ()
(.or (.match-name "bool")
(.match-name "float")
(.match-name "int")
(.match-name "string")))
; Add scalar-type / qualified-name
(defun .type-declaration ()
(.or (.match-keyword "array")
(.match-keyword "callable")
(.scalar-type)
(.match-qualified-name)))
(defun .parameter-declaration ()
(php.lexer::tag-result :parameter-declaration
(.let* ((declared-type (.optional (.type-declaration)))
(reference-marker (.optional (.match-operator "&")))
(variable-declaration (.match-variable))
(default-value (.optional
(.progn (.match-operator "=")
(.constant-expression)))))
(.identity (list variable-declaration
:type declared-type
:is-reference (and reference-marker t)
:default-value default-value)))))
(defun .variadic-parameter ()
(php.lexer::tag-result :variadic-parameter
(.let* ((declared-type (.optional (.type-declaration)))
(reference-marker (.optional (.match-operator "&")))
(variable-declaration (.progn (.match-operator "...")
(.match-variable))))
(.identity (list variable-declaration
:type declared-type
:is-reference (and reference-marker t))))))
(defun .simple-parameter-declaration-list ()
(.or (.let* ((parameters (.first
(.map 'list (.prog1 (.parameter-declaration)
(.match-unpaired-punctuator ","))
:at-least 0)))
(last-parameter (.parameter-declaration)))
(.identity (append parameters
(list last-parameter))))
(.let* ((res (.parameter-declaration)))
(.identity (list res)))))
(defun .variadic-declaration-list ()
(.let* ((normal-params (.optional (.simple-parameter-declaration-list)))
(variadic-param (.progn (.match-unpaired-punctuator ",")
(.variadic-parameter))))
(.identity (append normal-params
(list variadic-param)))))
(defun .parameter-declaration-list ()
(.or (.simple-parameter-declaration-list)
(.variadic-declaration-list)))
(defun .return-type ()
(.progn (.match-operator ":")
(.or (.match-qualified-name :name "void")
(.type-declaration))))
(defun .function-definition-header ()
(php.lexer::tag-result :function-header
(.progn (.match-keyword "function")
(.let* ((return-by-reference (.optional (.match-operator "&")))
(function-name (.match-name))
(parameters (.optional (.prog2 (.match-paired-punctuator "(")
(.parameter-declaration-list)
(.match-paired-punctuator ")"))))
(return-type (.optional (.return-type))))
(.identity
(list :function
:name function-name
:parameters parameters
:return-type return-type
:return-by-reference (not (null return-by-reference))))))))
(defun .function-definition ()
(php.lexer::tag-result :function-definition
(.let* ((header (.function-definition-header))
(body (.compound-statement)))
(.identity
(list header body)))))
(defun .array-element-initializer ()
(flet ((.element-key () (.expression))
(.element-value () (.expression)))
(.or (.let* ((key (.prog1 (.element-key)
(.match-operator "=>")))
(is-ref (.optional (.match-operator "&")))
(value (.element-value)))
(.identity (list key value :is-reference (and is-ref t))))
(.let* ((is-ref (.optional (.match-operator "&")))
(value (.element-value)))
(.identity (list value :is-reference (and is-ref t)))))))
(defun .array-initializer-list ()
(.let* ((first (.array-element-initializer))
(rest (.map 'list (.progn (.match-punctuator)
(.array-element-initializer))
:at-least 0)))
(.identity (cons first rest))))
(defun .array-initializer ()
(.optional (.array-initializer-list)))
(defun .array-creation-expression ()
(php.lexer::tag-result :array
(.let* ((opening (.or (.progn (.match-keyword "array")
(.match-paired-punctuator "("))
(.match-paired-punctuator "[")))
(list (.array-initializer))
(closing (.match-paired-punctuator
(if (string= "(" (get-token-args opening))
")"
"]"))))
closing
(.identity list))))
(defun .constant-expression ()
(.or (.array-creation-expression)
(.expression)))
(defparameter *fun-tion*
"function fib($x) {
array_merge([1,2,3], [2,3,4]);
if ($x == 0) return 1;
if ($x == 1) return 1;
if ($x > 1) return fib($x-1) + fib($x-2);
}")
(defparameter *function-tokens*
(parse (php.lexer::.input-file)
*fun-tion*))
(defparameter *uut*
(parse (php.lexer::.input-file)
"callable &$foo = array_merge([1,2,3], [4,5,6]);"))
(defvar *xml-output* (make-synonym-stream '*standard-output*))
(flet ((escape-cdata-end (string)
(string-replace-all "]]>" string "]]>]]><![CDATA[")))
(defgeneric to-xml (tag)
(:method ((tag cons))
(format *xml-output* "~&<~(~a~)>~{~a~}</~(~a~)>~%"
(car tag)
(mapcar #'(lambda (x)
(with-output-to-string (*xml-output*)
(to-xml x)))
(cdr tag))
(car tag)))
(:method ((tag integer))
(format *xml-output* "<![CDATA[~a]]>" tag))
(:method :around ((tag string))
(format *xml-output* "<![CDATA[~a]]>"
(call-next-method)))
(:method ((tag string))
(escape-cdata-end tag))))
(defmacro flip-values (form)
`(multiple-value-bind (a b) ,form
(values b a)))