(defparameter *dynamic-prims* nil)
(defun prim-name (prim) (getf prim :name))
-(defun prim-num-args (prim) (length (getf prim :args)))
+(defun prim-precedence (prim) (getf prim :precedence))
(defun prim-args (prim) (getf prim :args))
(defun prim-structure-prim (prim) (getf prim :structure-prim))
(defun prim-is-infix (prim) (getf prim :infix))
"PARSE LEXED-AST &optional DYNAMIC-PRIMS => AST
DYNAMIC-PRIMS: DYNAMIC-PRIM*
- DYNAMIC-PRIM: (:name NAME :args ARGS :infix INFIX)
+ DYNAMIC-PRIM: (:name NAME :args ARGS :infix INFIX :precedence PRECEDENCE)
ARGS: ARG*
ARGUMENTS AND VALUES:
LEXED-AST: An ambigious ast
AST: An unambigious ast that can be transpiled
NAME: A symbol in the keyword package
- INFIX: Boolean denoting whether the prim is infix
+ INFIX: Boolean denoting whether the prim is infix, defaulting to NIL
+ PRECEDENCE: A number, usually 10 for reporters, and 0 for commands
ARG: A list of symbols denoting the type of argument
DESCRIPTION:
DYNAMIC-PRIMS that are passed in are used to avoid compilation errors on
things not statically defined by the NetLogo language, be they user defined
- procedures or generated primitives from breed declarations.
+ procedures or generated primitives from breed declarations. NAME and PRECEDENCE
+ are required for all dynamic prims.
+
+ PRECEDENCE is a number used to calculate the order of operations. Higher numbers
+ have more precedence than lower ones. Generally all commands should have the
+ lowest precedence, and all reporters should have 10 as the precedence.
The possible values for ARG are :agentset, :boolean, :number, :command-block,
or t for wildcard.
Examples are too numerous and varied, but by inserting an output between
the lexer and this code, a good idea of what goes on can be gotten."
+ (when (find nil dynamic-prims :key #'prim-name)
+ (error "All passed in prims must have a name: ~S" (find nil dynamic-prims :key #'prim-name)))
+ (when (find nil dynamic-prims :key #'prim-precedence)
+ (error "All passed in prims must have a precedence: ~S" (find nil dynamic-prims :key #'prim-precedence)))
(let
; could have defined this using the special variable, but didn't to make the
; function definition simpler, as well as the documentation.
((*dynamic-prims* dynamic-prims))
- (parse-internal lexed-ast)))
+ (remove-parened-forms (parse-internal lexed-ast))))
+
+; This is needed to clean up where we had to note parenthesis wrapped
+; things for the purpose of precedence
+(defun remove-parened-forms (parsed-ast)
+ (cond
+ ((not parsed-ast) nil)
+ ((and (listp parsed-ast) (eql :parened (car parsed-ast))) (remove-parened-forms (cadr parsed-ast)))
+ ((listp parsed-ast) (mapcar #'remove-parened-forms parsed-ast))
+ (t parsed-ast)))
-(defun parse-internal (lexed-ast &key prev-item arg-countdown)
+(defun parse-internal (lexed-ast &key prev-item prev-remaining-arg remaining-args)
(let
((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 remaining-args (eql (car remaining-args) :done-with-args))
+ (append (when prev-item (list (help-arg prev-item prev-remaining-arg))) lexed-ast))
((and prim (prim-is-infix prim))
- (parse-prim prim lexed-ast prev-item arg-countdown)) ; Special casing infix prims is cleaner
+ (parse-prim prim lexed-ast prev-item prev-remaining-arg remaining-args)) ; Special casing infix prims is cleaner
(t
(append
- (when prev-item (list prev-item))
+ (when prev-item (list (help-arg prev-item prev-remaining-arg)))
(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))))
+ :prev-remaining-arg (car remaining-args)
+ :remaining-args (cdr remaining-args)))
((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))
+ :prev-remaining-arg (car remaining-args)
+ :remaining-args (cdr remaining-args)))
+ ((and remaining-args
+ (or
+ (eql :token (car remaining-args))
+ (and
+ (listp (car remaining-args))
+ (find :token (car remaining-args))
+ (symbolp (car lexed-ast)))))
+ (parse-internal (cdr lexed-ast)
+ :prev-item (car lexed-ast)
+ :prev-remaining-arg (car remaining-args)
+ :remaining-args (cdr remaining-args)))
+ ((eql (intern "(" :keyword) (car lexed-ast)) (parse-parened-expr (cdr lexed-ast) remaining-args))
+ ((eql (intern ")" :keyword) (car lexed-ast)) (error "Closing parens has no opening parens"))
+ ((eql :let (car lexed-ast)) (parse-let (cdr lexed-ast) remaining-args))
+ ((eql :[ (car lexed-ast)) (parse-block (cdr lexed-ast) remaining-args))
(prim
(when (prim-structure-prim prim)
(error "This doesn't make sense here"))
- (parse-prim prim lexed-ast nil arg-countdown))
+ (parse-prim prim lexed-ast nil prev-remaining-arg remaining-args))
(t (error "Couldn't parse ~S" lexed-ast))))))))
-(defun parse-prim (prim lexed-ast prev-item arg-countdown)
+(defun parse-let (lexed-ast remaining-args)
+ (when (not (keywordp (car lexed-ast))) (error "Needed a keyword for let"))
(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)
- (append
- (when (prim-is-infix prim) (list prev-item))
- (butlast half-parsed-remainder (- (length half-parsed-remainder) num-args))))))))
+ ((half-parsed-remainder (parse-internal (cdr lexed-ast) :remaining-args (list t :done-with-args))))
+ (let
+ ((*dynamic-prims* (cons (list :name (car lexed-ast) :precedence 20) *dynamic-prims*)))
+ (parse-internal
+ (cdr half-parsed-remainder)
+ :remaining-args (cdr remaining-args)
+ :prev-remaining-arg (car remaining-args)
+ :prev-item (list :let (car lexed-ast) (cadr (car half-parsed-remainder)))))))
+
+(defun reconfigure-due-to-precedence (prev-item prim following-args)
+ (flet
+ ((calculate-precedence (x)
+ (or
+ (and
+ (listp x)
+ (< 1 (length prev-item))
+ (keywordp (car x))
+ (find-prim (car x))
+ (prim-precedence (find-prim (car x))))
+ 20)))
+ (cond
+ ((<= (prim-precedence prim) (calculate-precedence prev-item))
+ (cons
+ (prim-name prim)
+ (cons
+ (second (help-arg prev-item (car (prim-args prim))))
+ following-args)))
+ (t (append
+ (butlast prev-item)
+ (list
+ (reconfigure-due-to-precedence
+ (car (last prev-item))
+ prim
+ following-args)))))))
-(defun help-arg (arg-type arg)
- (case arg-type
- (:command-block
+(defun parse-prim (prim lexed-ast prev-item prev-remaining-arg remaining-args)
+ (when (not (prim-precedence prim))
+ (error "Prim must have a precedence! ~A" prim))
+ (when (and (prim-is-infix prim) (eql :token (car (prim-args prim))))
+ (error "Can't have a prim that wants a token in the first position while being infix: ~A" prim))
+ (when
+ (and
+ (< (prim-precedence prim) 20)
+ (find-if (lambda (arg) (or (eql :token arg) (and (listp arg) (find :token arg)))) (prim-args prim)))
+ (error "Can't have a prim that wants a token and has a precedence of less than 20: ~A" prim))
+ (let*
+ ((args (if (prim-is-infix prim) (cdr (prim-args prim)) (prim-args prim)))
+ (half-parsed-remainder (parse-internal (cdr lexed-ast) :remaining-args (append args (list :done-with-args))))
+ (breakpoint (or
+ (position-if (lambda (form) (or (not (listp form)) (not (eql :arg (car form))))) half-parsed-remainder)
+ (length half-parsed-remainder)))
+ (already-parsed-limbo-forms
+ (subseq half-parsed-remainder breakpoint (min (length args) (length half-parsed-remainder))))
+ (middle-forms
+ (cons
+ (if
+ (prim-is-infix prim)
+ (reconfigure-due-to-precedence prev-item prim (mapcar #'cadr (subseq half-parsed-remainder 0 breakpoint)))
+ (cons
+ (prim-name prim)
+ (mapcar #'cadr (subseq half-parsed-remainder 0 breakpoint))))
+ already-parsed-limbo-forms)))
+ (append
+ (butlast middle-forms)
+ (parse-internal
+ (nthcdr (length args) half-parsed-remainder)
+ :remaining-args (if (prim-is-infix prim) remaining-args (cdr remaining-args))
+ :prev-remaining-arg (if (prim-is-infix prim) prev-remaining-arg (car remaining-args))
+ :prev-item (car (last middle-forms))))))
+
+(defun help-arg (arg arg-type)
+ (cond
+ ((not arg-type) arg)
+ ((eql arg-type :token) (list :arg (list :token arg)))
+ ((and (listp arg-type) (find :token arg-type) (symbolp arg)) (list :arg (list :token arg)))
+ ((eql arg-type :command-block)
(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
+ (list :arg (cons :command-block (cdr arg)))))
+ ((eql arg-type :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)))
+ (list :arg (cons :reporter-block (cdr arg)))))
+ ((or
+ (eql arg-type :list)
+ (and (listp arg-type) (find :list arg-type)))
+ (list
+ :arg
+ (if (and (consp arg) (eql 'block (car arg)))
+ (cons :list-literal (cdr arg))
+ arg)))
+ ((and
+ (listp arg-type)
+ (find :command-block arg-type)
+ (consp arg)
+ (eql 'block (car arg)))
+ (list :arg (cons :command-block (cdr arg))))
+ ((and (listp arg-type) (find :optional arg-type)) arg)
+ (t (list :arg arg))))
-(defun parse-block (tokens arg-countdown)
+(defun parse-block (tokens remaining-args)
(multiple-value-bind (in-block after-block) (find-closing-bracket tokens)
(parse-internal after-block
:prev-item (cons 'block (parse-internal in-block))
- :arg-countdown (when arg-countdown (1- arg-countdown)))))
+ :prev-remaining-arg (car remaining-args)
+ :remaining-args (cdr remaining-args))))
(defun find-closing-bracket (tokens &optional (depth 0))
(cond
(find-closing-bracket (cdr tokens) (case (car tokens) (:[ (1+ depth)) (:] (1- depth)) (t depth)))
(values (cons (car tokens) in-block) after-block)))))
-(defun parse-parened-expr (tokens arg-countdown)
+(defun parse-parened-expr (tokens remaining-args)
(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)))))
+ (list :parened (car parsed-in-block)))
+ :prev-remaining-arg (car remaining-args)
+ :remaining-args (cdr remaining-args))))
(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)))
+ ((and (eql (intern ")" :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)))
+ ((eql (intern "(" :keyword) (car tokens)) (1+ depth))
+ ((eql (intern ")" :keyword) (car tokens)) (1- depth)) (t depth)))
(values (cons (car tokens) in-block) after-block)))))
-(defmacro defprim (name args &optional infix)
+(defmacro defprim (name args precedence &rest options)
`(push
- (list :name ,name :args ',args :infix ,infix)
+ (list :name ,name :args ',args :infix ,(find :infix options) :precedence ,precedence)
*prims*))
(defmacro defstructureprim (name)
; - :agentset
; - :command-block
; - :boolean
+; - :token (suspends evaluation)
; - 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 :if-else (:boolean :command-block :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 ())
+(defprim := (t t) 5 :infix)
+(defprim :!= (t t) 5 :infix)
+(defprim :- (:number :number) 7 :infix)
+(defprim :* (:number :number) 8 :infix)
+(defprim :+ (:number :number) 7 :infix)
+(defprim :/ (:number :number) 8 :infix)
+(defprim :< (:number :number) 6 :infix)
+(defprim :<= (:number :number) 6 :infix)
+(defprim :any? (:agentset) 10)
+(defprim :ask (:agentset :command-block) 0)
+(defprim :ca () 0)
+(defprim :clear-all () 0)
+(defprim :crt (:number (:command-block :optional)) 0)
+(defprim :create-turtles (:number (:command-block :optional)) 0)
+(defprim :color () 10)
+(defprim :count (:agentset) 10)
+(defprim :die () 0)
+(defprim :display () 0)
+(defprim :with (:agentset :reporter-block) 12 :infix)
+(defprim :fd (:number) 0)
+(defprim :hatch (:number (:command-block :optional)) 0)
+(defprim :let (t t) 0) ; while this has special processing, we need a prim for meta information
+(defprim :if (:boolean :command-block) 0)
+(defprim :if-else (:boolean :command-block :command-block) 0)
+(defprim :ifelse (:boolean :command-block :command-block) 0)
+(defprim :label () 10)
+(defprim :label-color () 10)
+(defprim :not (:boolean) 10)
+(defprim :nobody () 10)
+(defprim :one-of ((:agentset :list)) 10)
+(defprim :of (:reporter-block :agentset) 11 :infix)
+(defprim :patches () 10)
+(defprim :pcolor () 10)
+(defprim :random (:number) 10)
+(defprim :random-float (:number) 10)
+(defprim :random-xcor () 10)
+(defprim :random-ycor () 10)
+(defprim :round (t) 10)
+(defprim :reset-ticks () 0)
+(defprim :lt (:number) 0)
+(defprim :rt (:number) 0)
+(defprim :set (t t) 0)
+(defprim :set-default-shape (t t) 0)
+(defprim :setxy (:number :number) 0)
+(defprim :show (t) 0)
+(defprim :size () 10)
+(defprim :stop () 0)
+(defprim :tick () 0)
+(defprim :ticks () 10)
+(defprim :turtles () 10)
+(defprim :turtles-here () 10)
+(defprim :who () 10)
; colors
-(defprim :black ())
-(defprim :blue ())
-(defprim :brown ())
-(defprim :green ())
-(defprim :white ())
+(defprim :black () 10)
+(defprim :blue () 10)
+(defprim :brown () 10)
+(defprim :green () 10)
+(defprim :white () 10)
(defstructureprim :globals)
(defstructureprim :breed)
(defstructureprim :patches-own)
(defstructureprim :to)
(defstructureprim :to-report)
-
-; Placeholder prims that should be populated in dynamic prims
-
-; 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 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))