new file mode 100644

@@ -0,0 +1 @@

+This is the stub README.txt for the "php_pre" project.

new file mode 100644

@@ -0,0 +1,111 @@

+(in-package :php.lexer)

+

+(eval-when (:compile-toplevel :execute :load-toplevel)

+  (ql:quickload :osicat)

+  (osicat-posix:setenv "CC" "clang") 

+  (ql:quickload :net.didierverna.clon))

+

+(net.didierverna.clon:defsynopsis (:postfix "PHP-FILE")

+  (text :contents "lex and dump the lexical structure of a php file")

+  (flag :short-name "t" :long-name "tokens-only"

+	:description "Show only tokens")

+  (flag :short-name "r" :long-name "show-remainder"

+	:description "Show leftovers after parsing")

+  (flag :short-name "h" :long-name "help"

+	:description "Show this help"))

+

+

+;; (defsynopsis (:postfix "TIMESHEETS ...")

+;;   (text :contents "A program for managing logs of hours worked")

+;;   (group (:header "Display options")

+;;          (flag :short-name "s" :long-name "status"

+;;                :description "Print a short summary of work status")

+;;          (flag :short-name "W"

+;;                :long-name "ignore-whitespace"

+;;                :description "Ignore whitespace errors in input")

+;;          (flag :short-name "i" :long-name "interactive"

+;;                :description "Run interactively"))

+;;   (group (:header "Sort options")

+;;          (flag :short-name "r"

+;;                :long-name "reverse"

+;;                :description "Reverse the sort direction")

+;;          (flag :short-name "c"

+;;                :long-name "client"

+;;                :description "Sort records by client") 

+;;          (flag :short-name "dr"

+;;                :long-name "daily-report"

+;;                :description "Print a daily report for the passed logs"))

+;;   (group (:header "Freshbooks")

+;;          (flag :long-name "post-hours"

+;;                :description "Post hours to freshbooks (requires manual setup of Freshbooks keys)"))

+;;   (group (:header "Self-test options")

+;;          (flag :long-name "dependencies"

+;;                :description "Graph the dependencies of this project")

+;;          (flag :long-name "run-tests"

+;;                :description "Run the tests")

+;;          (enum :long-name "output-style"

+;;                :description "The kind of output to produce"

+;;                :default-value :normal

+;;                :enum '(:xunit :normal)))

+;;   (group (:header "Reformat options")

+;;          (flag :long-name "reformat-file"

+;;                :short-name "f"

+;;                :description "Read the current timesheet file and dump, correcting any whitespace or formatting errors"))

+;;   (group (:header "Generic options")

+;;          (flag :short-name "v" :long-name "version"

+;;                :description "Show the program version")

+;;))

+

+;; (defun pprint-log-main ()

+;;   (net.didierverna.clon:make-context)

+;;   (tagbody

+;;     start

+;;     (restart-case

+;;       (cond

+;;         ((getopt :long-name "help") (help))

+;;         ((getopt :long-name "version") (show-version))

+;;         ((getopt :long-name "dependencies") (format t (tempores.package-grapher::graph-tempores-packages)))

+;;         ((getopt :long-name "post-hours") (let ((*print-pretty* nil))

+;;                                             (loop for item in (tempores.freshbooks::post-time-entries-main)

+;;                                                   do (format t "Posted an entry")

+;;                                                   do (plump:serialize item)

+;;                                                   finally (format t "Don't forget to archive time file."))))

+;;         ((getopt :long-name "run-tests") (tests-main (getopt :long-name "output-style")))

+;;         ((getopt :long-name "reformat-file") (reformat-main))

+;;         ((getopt :long-name "daily-report") (print-daily-report (remainder)))

+;;         (t (with-tempores-configuration ()

+;;              (pprint-log

+;;                (remainder)

+;;                :client (getopt :long-name "client")

+;;                :interactive (getopt :long-name "interactive")

+;;                :ignore-whitespace (getopt :long-name "ignore-whitespace")

+;;                :status (getopt :long-name "status")

+;;                :reverse (getopt :long-name "reverse")))))

+;;       (retry () (go start))

+;;       (abort ()))))

+

+(defun main ()

+  (net.didierverna.clon:make-context)

+  (cond

+    ((net.didierverna.clon:getopt :long-name "help") (net.didierverna.clon:help))

+    (t (let* ((*print-pretty* t)

+	      (*print-right-margin* 80)

+	      (tokens-only (net.didierverna.clon:getopt :long-name "tokens-only"))

+	      (show-remainder (net.didierverna.clon:getopt :long-name "show-remainder")))

+	 (multiple-value-bind (result leftovers)

+	     (parse (.input-file)

+		    (slurp-file (car (net.didierverna.clon:remainder))))

+	   (when tokens-only

+	     (setf result (remove-if-not (lambda (x) (eq x :token))

+					 result :key #'car))) 

+	   

+	   (print result)

+	   (when show-remainder

+	     (fresh-line)

+	     (terpri)

+	     (print leftovers)))))))

+

+(defun make-executable ()

+  (net.didierverna.clon:dump "php-lex" main

+        :compression 8

+        :purify t))

new file mode 100644

@@ -0,0 +1,5 @@

+;;;; package.lisp

+

+(defpackage #:php_pre

+  (:use #:cl #:smug))

+

new file mode 100644

@@ -0,0 +1,314 @@

+(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 "]]>]]&gt;<![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)))

new file mode 100644

@@ -0,0 +1,14 @@

+;;;; php_pre.asd

+

+(asdf:defsystem #:php_pre

+  :description "Describe php_pre here"

+  :author "Your Name <your.name@example.com>"

+  :license "Specify license here"

+  :depends-on (#:fwoar.lisputils

+               #:alexandria

+               #:smug

+               #:serapeum)

+  :serial t

+  :components ((:file "package")

+               (:file "php_pre")))

+

new file mode 100644

@@ -0,0 +1,148 @@

+;;;; php_pre.lisp

+

+(in-package #:php_pre)

+

+(defclass statement ()

+  ((statement-keyword :initarg :keyword :accessor statement-keyword)

+   (param :initarg :param :accessor param)

+   (body :initarg :body :accessor body)))

+

+(defmethod print-object ((object statement) s)

+  (print-unreadable-object (object s :type t :identity t)

+    (format s "~a (~d expressions)"

+	    (statement-keyword object)

+	    (length (body object)))))

+

+(defun make-statement (type param body)

+  (make-instance 'statement :keyword type :param param :body body))

+

+(defun .constituent ()

+  (.is #'alpha-char-p))

+

+(defun .keyword ()

+  (.first

+   (.map 'string (.constituent))))

+

+(defun .whitespace-char ()

+  (.or (.char= #\space)

+       (.is-not #'graphic-char-p)))

+

+(defun .comment ()

+  (.or (.first

+	(.prog2 (.string= "//")

+		(.word-list)

+		(.char= #\newline)

+		(.optional (.whitespace))))

+       (.first

+	(.prog2 (.string= "/*")

+		(.map 'string (.and (.not (.string= "*/"))

+				    (.item)))

+		(.string= "*/")

+		(.optional (.whitespace))))))

+

+(defun .whitespace ()

+  (.first (.map 'string (.whitespace-char))))

+

+(defun .word-terminator ()

+  (.or (.whitespace-char)

+       (.is (lambda (x)

+	      (or (char= x #\{)

+		  (char= x #\})

+		  (char= x #\})

+		  (char= x #\;))))))

+

+(defun .array-el ()

+  (.let* ((first (.first (.map 'string

+			       (.prog2 (.optional (.whitespace))

+				       (.is-not (lambda (it)

+						  (member it '(#\= #\,))))

+				       (.optional (.whitespace))))))

+	  (second (.optional (.progn (.string= "=>")

+				     (.optional (.whitespace))

+				     (.first

+				      (.map 'string

+					    (.is-not #'char= #\,))))))

+	  (divider (.optional (.char= #\,))))

+    divider

+    (.identity (cons first second))))

+

+(defun .php-array ()

+  (.let* ((begin (.char= #\[))

+	  (els (.map 'list (.array-el) :at-least 0))

+	  (end (.char= #\])))

+    (.identity (list :array begin els end))))

+

+(defun .word ()

+  (.or (.first (.concatenate 'string

+			     (.string= "'")

+			     (.map 'string (.is-not #'char= #\'))

+			     (.string= "'")))

+       (.first (.concatenate 'string

+			     (.string= "\"")

+			     (.map 'string (.is-not #'char= #\"))

+			     (.string= "\"")))

+       (.first (.map 'string (.and (.not (.word-terminator))

+				   (.item))))))

+

+(defun .word-list (&optional (word-parser '.word))

+  (.map 'list

+	(.progn (.optional (.whitespace))

+		(.first (funcall word-parser)))))

+

+(defun .line (&optional (word-parser '.word))

+  (.prog1 (.word-list)

+	  (.progn (.optional (.whitespace))

+		  (.char= #\;))))

+

+(defun .paren-word ()

+  (.map 'string (.and (.not (.or (.word-terminator)

+				 (.char= #\( )

+				 (.char= #\) )))

+		      (.item))))

+

+(defun .statement-list ()

+  (.map 'list (.or (.prog1 (.first (.word-list))

+			   (.optional (.whitespace))

+			   (.char= #\;))

+		   (.progn (.optional (.whitespace))

+			   (.first (.statement))))

+	:at-least 0))

+

+(defun .statement-start ()

+  (.let* ((type (.progn (.optional (.whitespace))

+			(.first (.keyword))))

+	  (param (.optional (.or (.prog2 (.progn (.optional (.whitespace))

+						 (.char= #\( ))

+					 (.word-list)

+					 (.progn (.optional (.whitespace))

+						 (.char= #\) )))

+				 (.word-list))))

+	  (_ (.progn (.whitespace)

+		     (.char= #\{))))

+    (.identity (cons type param))))

+

+(defun .statement ()

+  (.let* ((start (.progn (.prog1 (.map 'list

+				       (.progn (.optional (.whitespace))

+					       (.comment))

+				       :at-least 0)

+				 (.optional (.whitespace)))

+			 (.statement-start)))

+	  (statements (.progn (.whitespace)

+			      (.statement-list)))

+	  (_ (.progn (.optional (.whitespace))

+		     (.char= #\}))))

+    (destructuring-bind (type . param) start

+      (.identity (make-statement type param statements)))))

+

+(defun slurp (fn)

+  (with-open-file (s fn)

+    (let ((result (make-string (file-length s))))

+      (read-sequence result s)

+      result)))

+

+(defun .main-parser ()

+  (.map 'list (.or (.prog1 (.word-list) (.char= #\;))

+		   (.first

+		    (.progn (.optional (.whitespace))

+			    (.statement))))))