From 72d7364634aec6c24803deb29bdfde0fbfa6e7ad Mon Sep 17 00:00:00 2001 From: Frank Duncan Date: Sat, 23 Apr 2016 15:17:47 -0500 Subject: [PATCH] Improve parser - add wolfsheep prims, infix ability --- bin/all.lisp | 2 +- src/main/code-parse.lisp | 5 +- src/main/model.lisp | 7 +- src/main/parse.lisp | 188 +++++++++++++++++++++++++++++++++------ 4 files changed, 168 insertions(+), 34 deletions(-) diff --git a/bin/all.lisp b/bin/all.lisp index 029e6b7..fb64370 100644 --- a/bin/all.lisp +++ b/bin/all.lisp @@ -21,7 +21,7 @@ (when (not (find-package :docgen)) (asdf:load-system :docgen)) (format t "~%~c[1;33mChecking Docs~c[0m~%" #\Esc #\Esc) (when (not (docgen:pretty-print-validate-packages - :clnl :clnl-parser :clnl-random :clnl-transpiler :clnl-nvm :clnl-lexer :clnl-interface :clnl-cli :clnl-model)) + :clnl :clnl-parser :clnl-random :clnl-transpiler :clnl-nvm :clnl-lexer :clnl-interface :clnl-cli :clnl-model :clnl-code-parser)) (format t "~c[1;31mFailed doc check!~c[0m~%" #\Esc #\Esc) (sb-ext:exit :code 1)) (format t "~c[1;32m- Doc Check Passed!~c[0m~%" #\Esc #\Esc) diff --git a/src/main/code-parse.lisp b/src/main/code-parse.lisp index 182e4af..69806ca 100644 --- a/src/main/code-parse.lisp +++ b/src/main/code-parse.lisp @@ -33,7 +33,10 @@ DESCRIPTION: (defun parse-procedure (tokens) (multiple-value-bind (in-block after-block) (find-end tokens) (cons - in-block + (list + (first in-block) + (second in-block) + (clnl-parser:parse (cddr in-block))) (parse after-block)))) (defun find-end (tokens) diff --git a/src/main/model.lisp b/src/main/model.lisp index a9de7be..1927ff5 100644 --- a/src/main/model.lisp +++ b/src/main/model.lisp @@ -54,7 +54,7 @@ DESCRIPTION: (read-sections (append section (list line)))))))) (read-sections)))) (make-model - :code (format nil "~{~A~^~%~}" (nth 0 sections)) + :code (clnl-code-parser:parse (clnl-lexer:lex (format nil "~{~A~^~%~}" (nth 0 sections)))) :interface (parse-interface (nth 1 sections)) :info (nth 2 sections) :turtle-shapes (nth 3 sections) @@ -222,9 +222,6 @@ DESCRIPTION: :ymin (view-min-pycor view) :ymax (view-max-pycor view)))) -(defun parse-code (model) - (clnl-code-parser:parse (clnl-lexer:lex (model-code model)))) - ; For now, we keep the code hidden in this package (defun globals (model) "GLOBALS MODEL => GLOBALS @@ -247,7 +244,7 @@ DESCRIPTION: (intern (string-upcase (car pair)) clnl:*model-package*) (cadr pair))) (append - (clnl-code-parser:globals (parse-code model)) + (clnl-code-parser:globals (model-code model)) (remove nil (mapcar (lambda (widget) diff --git a/src/main/parse.lisp b/src/main/parse.lisp index 97588bb..eaaa3fe 100644 --- a/src/main/parse.lisp +++ b/src/main/parse.lisp @@ -29,6 +29,7 @@ (defun prim-num-args (prim) (length (getf prim :args))) (defun prim-args (prim) (getf prim :args)) (defun prim-structure-prim (prim) (getf prim :structure-prim)) +(defun prim-is-infix (prim) (getf prim :infix)) (defun find-prim (symb) (find symb *prims* :key #'prim-name)) @@ -68,31 +69,51 @@ DESCRIPTION: ((*dynamic-prims* dynamic-prims)) (parse-internal lexed-ast))) -(defun parse-internal (lexed-ast) - (cond - ((not lexed-ast) nil) - ((numberp (car lexed-ast)) (cons (coerce (car lexed-ast) 'double-float) (parse-internal (cdr lexed-ast)))) - ((eql :[ (car lexed-ast)) (parse-block (cdr lexed-ast))) - ((and (symbolp (car lexed-ast)) (find-prim (car lexed-ast))) - (let - ((prim (find-prim (car lexed-ast)))) - (when (prim-structure-prim prim) - (error "This doesn't make sense here")) - (parse-prim prim lexed-ast))) - (t (error "Couldn't parse ~S" lexed-ast)))) - -(defun parse-prim (prim lexed-ast) +(defun parse-internal (lexed-ast &key prev-item arg-countdown) (let - ((num-args (prim-num-args prim)) - (parsed-remainder (parse-internal (cdr lexed-ast)))) - (cons + ((prim (and lexed-ast (symbolp (car lexed-ast)) (find-prim (car lexed-ast))))) + (cond + ((and arg-countdown (zerop arg-countdown)) (append (when prev-item (list prev-item)) lexed-ast)) + ((and prim (prim-is-infix prim)) + (parse-prim prim lexed-ast prev-item arg-countdown)) ; Special casing infix prims is cleaner + (t + (append + (when prev-item (list prev-item)) + (cond + ((not lexed-ast) nil) + ((stringp (car lexed-ast)) + (parse-internal (cdr lexed-ast) + :prev-item (car lexed-ast) + :arg-countdown (when arg-countdown (1- arg-countdown)))) + ((numberp (car lexed-ast)) + (parse-internal (cdr lexed-ast) + :prev-item (coerce (car lexed-ast) 'double-float) + :arg-countdown (when arg-countdown (1- arg-countdown)))) + ((eql (intern "(" (find-package :keyword)) (car lexed-ast)) (parse-parened-expr (cdr lexed-ast) arg-countdown)) + ((eql (intern ")" (find-package :keyword)) (car lexed-ast)) (error "Closing parens has no opening parens")) + ((eql :[ (car lexed-ast)) (parse-block (cdr lexed-ast) arg-countdown)) + (prim + (when (prim-structure-prim prim) + (error "This doesn't make sense here")) + (parse-prim prim lexed-ast nil arg-countdown)) + (t (error "Couldn't parse ~S" lexed-ast)))))))) + +(defun parse-prim (prim lexed-ast prev-item arg-countdown) + (let* + ((num-args (- (prim-num-args prim) (if (prim-is-infix prim) 1 0))) + (half-parsed-remainder (parse-internal (cdr lexed-ast) :arg-countdown num-args))) + (parse-internal + (nthcdr num-args half-parsed-remainder) + :arg-countdown (when arg-countdown (if (prim-is-infix prim) arg-countdown (1- arg-countdown))) + :prev-item (cons (prim-name prim) (mapcar #'help-arg (prim-args prim) - (butlast parsed-remainder (- (length parsed-remainder) num-args)))) - (nthcdr num-args parsed-remainder)))) + (append + (when (prim-is-infix prim) (list prev-item)) + (butlast half-parsed-remainder (- (length half-parsed-remainder) num-args)))))))) (defun help-arg (arg-type arg) (case arg-type @@ -100,19 +121,21 @@ DESCRIPTION: (if (not (and (consp arg) (eql 'block (car arg)))) (error "Required a block, but found a ~A" arg) (cons :command-block (cdr arg)))) + (:reporter-block + (if (not (and (consp arg) (eql 'block (car arg)))) + (error "Required a block, but found a ~A" arg) + (cons :reporter-block (cdr arg)))) (:list (if (and (consp arg) (eql 'block (car arg))) (cons :list-literal (cdr arg)) arg)) (t arg))) -(defun parse-block (tokens) +(defun parse-block (tokens arg-countdown) (multiple-value-bind (in-block after-block) (find-closing-bracket tokens) - (cons - (cons - 'block - (parse-internal in-block)) - (parse-internal after-block)))) + (parse-internal after-block + :prev-item (cons 'block (parse-internal in-block)) + :arg-countdown (when arg-countdown (1- arg-countdown))))) (defun find-closing-bracket (tokens &optional (depth 0)) (cond @@ -123,9 +146,32 @@ DESCRIPTION: (find-closing-bracket (cdr tokens) (case (car tokens) (:[ (1+ depth)) (:] (1- depth)) (t depth))) (values (cons (car tokens) in-block) after-block))))) -(defmacro defprim (name args) +(defun parse-parened-expr (tokens arg-countdown) + (multiple-value-bind (in-block after-block) (find-closing-paren tokens) + (parse-internal after-block + :prev-item + (let + ((parsed-in-block (parse-internal in-block))) + (when (/= 1 (length parsed-in-block)) (error "Expected ) here")) + (car parsed-in-block)) + :arg-countdown (when arg-countdown (1- arg-countdown))))) + +(defun find-closing-paren (tokens &optional (depth 0)) + (cond + ((not tokens) (error "Failed to find a matching closing bracket")) + ((and (eql (intern ")" (find-package :keyword)) (car tokens)) (= depth 0)) (values nil (cdr tokens))) + (t (multiple-value-bind + (in-block after-block) + (find-closing-paren + (cdr tokens) + (cond + ((eql (intern "(" (find-package :keyword)) (car tokens)) (1+ depth)) + ((eql (intern ")" (find-package :keyword)) (car tokens)) (1- depth)) (t depth))) + (values (cons (car tokens) in-block) after-block))))) + +(defmacro defprim (name args &optional infix) `(push - (list :name ,name :args ',args) + (list :name ,name :args ',args :infix ,infix) *prims*)) (defmacro defstructureprim (name) @@ -138,17 +184,105 @@ DESCRIPTION: ; - :number ; - :agentset ; - :command-block +; - :boolean ; - t - any type +; +; After the arguments, :infix denotes that it's an :infix operator +; - Note: Later we should move it to have a list of optional attributes of the primitive +(defprim := (t t) :infix) +(defprim :!= (t t) :infix) +(defprim :- (:number :number) :infix) +(defprim :* (:number :number) :infix) +(defprim :+ (:number :number) :infix) +(defprim :/ (:number :number) :infix) +(defprim :< (:number :number) :infix) +(defprim :<= (:number :number) :infix) +(defprim :any? (:agentset)) (defprim :ask (:agentset :command-block)) +(defprim :clear-all ()) (defprim :crt (:number)) +(defprim :color ()) +(defprim :count ()) +(defprim :die ()) +(defprim :display ()) +(defprim :with (:reporter-block)) (defprim :fd (:number)) +(defprim :hatch (:number :command-block)) +(defprim :let (t t)) +(defprim :if (:boolean :command-block)) +(defprim :ifelse (:boolean :command-block :command-block)) +(defprim :label ()) +(defprim :label-color ()) +(defprim :not (:boolean)) +(defprim :nobody ()) +(defprim :one-of (t)) +(defprim :patches ()) +(defprim :pcolor ()) +(defprim :random (:number)) (defprim :random-float (:number)) +(defprim :random-xcor ()) +(defprim :random-ycor ()) +(defprim :round ()) +(defprim :reset-ticks ()) +(defprim :lt (:number)) +(defprim :rt (:number)) +(defprim :set (t t)) +(defprim :set-default-shape (t t)) +(defprim :setxy (:number :number)) (defprim :show (t)) +(defprim :size ()) +(defprim :stop ()) +(defprim :tick ()) (defprim :turtles ()) +; colors +(defprim :black ()) +(defprim :blue ()) +(defprim :brown ()) +(defprim :green ()) +(defprim :white ()) + (defstructureprim :globals) (defstructureprim :breed) (defstructureprim :turtles-own) (defstructureprim :patches-own) (defstructureprim :to) (defstructureprim :to-report) + +; Placeholder prims that should be populated in dynamic prims + +; Generated by globals/widgets +(defprim :grass ()) +(defprim :initial-number-sheep ()) +(defprim :initial-number-wolves ()) +(defprim :sheep-gain-from-food ()) +(defprim :wolf-gain-from-food ()) +(defprim :sheep-reproduce ()) +(defprim :wolf-reproduce ()) +(defprim :grass? ()) +(defprim :grass-regrowth-time ()) +(defprim :show-energy? ()) + +; Generated by procedures +(defprim :move ()) +(defprim :eat-grass ()) +(defprim :reproduce-sheep ()) +(defprim :reproduce-wolves ()) +(defprim :catch-sheep ()) +(defprim :death ()) +(defprim :grow-grass ()) +(defprim :display-labels ()) + +; Generated by *-own +(defprim :countdown ()) +(defprim :energy ()) + +; Generated by a let +(defprim :prey ()) + +; Generated by breeds +(defprim :sheep ()) +(defprim :wolves ()) +(defprim :create-sheep (:number :command-block)) ; look at me not have to do optionals yet +(defprim :sheep-here ()) +(defprim :create-wolves (:number :command-block)) -- 2.25.1