; prims that are created when compiling the netlogo file
; usually via procedures or top level things like breed declarations
(defparameter *dynamic-prims* nil)
-(defvar *in-structure* nil)
(defun prim-name (prim) (getf prim :name))
(defun prim-num-args (prim) (length (getf prim :args)))
(defun prim-args (prim) (getf prim :args))
-(defun prim-in-structure (prim) (getf prim :in-structure))
+(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))
+(defun find-prim (symb)
+ (or
+ (find symb *prims* :key #'prim-name)
+ (find symb *dynamic-prims* :key #'prim-name)))
; Make this only as complicated as it needs to be, letting it grow
; as we take on more and more of the language
-(defun parse (lexed-ast &optional structure)
- "PARSE LEXED-AST &optional STRUCTURE => AST
+(defun parse (lexed-ast &optional dynamic-prims)
+ "PARSE LEXED-AST &optional DYNAMIC-PRIMS => AST
+
+ DYNAMIC-PRIMS: DYNAMIC-PRIM*
+ DYNAMIC-PRIM: (:name NAME :args ARGS :infix INFIX)
+ ARGS: ARG*
ARGUMENTS AND VALUES:
LEXED-AST: An ambigious ast
- STRUCTURE: A boolean
AST: An unambigious ast that can be transpiled
+ NAME: A symbol in the keyword package
+ INFIX: Boolean denoting whether the prim is infix
+ ARG: A list of symbols denoting the type of argument
DESCRIPTION:
PARSE takes a ambigious LEXED-AST and converts it to an unambigious one.
- When STRUCTURE is true, parse is done with the expanded indentifier set used
- in NetLogo files, as well as pulling out procedure definitions.
+ 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.
+
+ The possible values for ARG are :agentset, :boolean, :number, :command-block,
+ or t for wildcard.
The need for a parser between the lexer and the transpiler is because NetLogo
needs two passes to turn into something that can be used. This is the only entry
(let
; could have defined this using the special variable, but didn't to make the
; function definition simpler, as well as the documentation.
- ((*in-structure* structure))
+ ((*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)))
- ((eql :to (car lexed-ast)) (parse-procedure lexed-ast))
- ((and (symbolp (car lexed-ast)) (find-prim (car lexed-ast)))
- (let
- ((prim (find-prim (car lexed-ast))))
- (when (and (not *in-structure*) (prim-in-structure prim))
- (error "This doesn't make sense here"))
- (if
- (and (= (prim-num-args prim) 1) (eql :unevaluated-list (car (prim-args prim))))
- (parse-prim-with-unevaluated-list prim lexed-ast)
- (parse-prim-normally prim lexed-ast))))
- (t (error "Couldn't parse ~S" lexed-ast))))
-
-; This is a special case but left with a little wiggle room for future
-; enhancements, like code blocks
-(defun parse-prim-with-unevaluated-list (prim lexed-ast)
- (when (not (eql :[ (cadr lexed-ast)))
- (error "Expected list literal here"))
- (multiple-value-bind (in-list after-list) (find-closing-bracket (cddr lexed-ast))
- (cons
- (list (prim-name prim) (cons :list-literal in-list))
- (parse-internal after-list))))
-
-(defun parse-prim-normally (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 "(" :keyword) (car lexed-ast)) (parse-parened-expr (cdr lexed-ast) arg-countdown))
+ ((eql (intern ")" :keyword) (car lexed-ast)) (error "Closing parens has no opening parens"))
+ ((eql :let (car lexed-ast)) (parse-let (cdr lexed-ast) arg-countdown))
+ ((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-let (lexed-ast arg-countdown)
+ (when (not (keywordp (car lexed-ast))) (error "Needed a keyword for let"))
+ (let*
+ ((half-parsed-remainder (parse-internal (cdr lexed-ast) :arg-countdown 1)))
+ (let
+ ((*dynamic-prims* (cons (list :name (car lexed-ast)) *dynamic-prims*)))
+ (parse-internal
+ (cdr half-parsed-remainder)
+ :arg-countdown (when arg-countdown (1- arg-countdown))
+ :prev-item (list :let (car lexed-ast) (car half-parsed-remainder))))))
+
+(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
(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
(find-closing-bracket (cdr tokens) (case (car tokens) (:[ (1+ depth)) (:] (1- depth)) (t depth)))
(values (cons (car tokens) in-block) after-block)))))
-; Due to the non expression style syntax of procedures, this must be special cased
-(defun parse-procedure (tokens)
- (when (not *in-structure*) (error "This doesn't make sense here"))
- (multiple-value-bind (in-block after-block) (find-end tokens)
- (declare (ignore in-block))
- (cons
- (cons
- (car tokens)
- nil) ; Update this to parsing the internal of the inblock)
- (parse-internal after-block))))
+(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-end (tokens)
+(defun find-closing-paren (tokens &optional (depth 0))
(cond
- ((not tokens) (error "Failed to find end"))
- ((eql :end (car tokens)) (values nil (cdr tokens)))
- (t (multiple-value-bind (in-block after-block) (find-end (cdr tokens))
+ ((not tokens) (error "Failed to find a matching closing bracket"))
+ ((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 "(" :keyword) (car tokens)) (1+ depth))
+ ((eql (intern ")" :keyword) (car tokens)) (1- depth)) (t depth)))
(values (cons (car tokens) in-block) after-block)))))
-; Used to populate dynamic-prims
-(defun determine-procedure-definition (tokens)
- (declare (ignore tokens)))
-
-(defmacro defprim (name args)
+(defmacro defprim (name args &optional infix)
`(push
- (list :name ,name :args ',args)
+ (list :name ,name :args ',args :infix ,infix)
*prims*))
-(defmacro defstructureprim (name args)
+(defmacro defstructureprim (name)
`(push
- (list :name ,name :args ',args :in-structure t)
+ (list :name ,name :structure-prim t)
*prims*))
; This list of prims will get combined with the mapping to actual code later
; - :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)) ; keeping this here, commented out, to note that it has special processing
+(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 :of (:reporter-block :agentset) :infix)
+(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 :ticks ())
(defprim :turtles ())
+(defprim :who ())
+
+; colors
+(defprim :black ())
+(defprim :blue ())
+(defprim :brown ())
+(defprim :green ())
+(defprim :white ())
-(defstructureprim :globals (:unevaluated-list))
-(defstructureprim :breed (:unevaluated-list))
-(defstructureprim :turtles-own (:unevaluated-list))
-(defstructureprim :patches-own (:unevaluated-list))
+(defstructureprim :globals)
+(defstructureprim :breed)
+(defstructureprim :turtles-own)
+(defstructureprim :patches-own)
+(defstructureprim :to)
+(defstructureprim :to-report)
projects / clnl / blobdiff