From 393d2cd66721b93bed149613ceb7ee4fdac408c2 Mon Sep 17 00:00:00 2001
From: Frank Duncan <frank@kank.net>
Date: Sun, 1 May 2016 15:13:09 -0500
Subject: [PATCH] Prims - Implement stop

---
 src/main/main.lisp        |  2 +-
 src/main/nvm/base.lisp    | 17 +++++++++++++++++
 src/main/nvm/nvm.lisp     | 20 ++++++++++++++++++--
 src/main/package.lisp     |  3 ++-
 src/main/transpile.lisp   |  1 +
 src/test/simpletests.lisp |  6 ++++++
 6 files changed, 45 insertions(+), 4 deletions(-)

diff --git a/src/main/main.lisp b/src/main/main.lisp
index eee8e48..3acd6e3 100644
--- a/src/main/main.lisp
+++ b/src/main/main.lisp
@@ -62,7 +62,7 @@ DESCRIPTION:
 
   RUN-COMMANDS will take NetLogo commands, put them through the various
   stages need to turn them into Common Lisp code, and run it."
- (eval (clnl-transpiler:transpile-commands (clnl-parser:parse (clnl-lexer:lex cmds)))))
+ (clnl-nvm:with-stop-handler (eval (clnl-transpiler:transpile-commands (clnl-parser:parse (clnl-lexer:lex cmds))))))
 
 (defun run-reporter (reporter)
  "RUN-REPORTER REPORTER => RESULT
diff --git a/src/main/nvm/base.lisp b/src/main/nvm/base.lisp
index 9d07e9b..fc2db58 100644
--- a/src/main/nvm/base.lisp
+++ b/src/main/nvm/base.lisp
@@ -11,6 +11,23 @@
 (defvar *ticks* nil)
 (defvar *breeds* nil)
 
+(define-condition stop nil nil)
+
+(defmacro with-stop-handler (&rest forms)
+ "MACRO WITH-STOP-HANDLER &rest FORMS => HANDLED-FORM
+
+ARGUMENTS AND VALUES:
+
+  FORMS: body to be handled
+  HANDLED-FORM: body with handling
+
+DESCRIPTION:
+
+  WITH-STOP-HANDLER is a convenience macro to handle when
+  programs issue a stop condition.  When one does, a simple
+  :stop is returned."
+ `(handler-case (progn ,@forms) (stop (s) :stop)))
+
 (defstruct turtle who color heading xcor ycor (label "") (label-color 9.9d0) (size 1d0) shape)
 (defstruct patch color xcor ycor)
 
diff --git a/src/main/nvm/nvm.lisp b/src/main/nvm/nvm.lisp
index 9ccb80d..a272a34 100644
--- a/src/main/nvm/nvm.lisp
+++ b/src/main/nvm/nvm.lisp
@@ -150,9 +150,9 @@ DESCRIPTION:
     (loop
      :for agent := (funcall iter)
      :while agent
-     :do (let ((*myself* *self*) (*self* agent)) (funcall fn)))))
+     :do (let ((*myself* *self*) (*self* agent)) (with-stop-handler (funcall fn))))))
   ((agent-p agent-or-agentset)
-   (let ((*myself* *self*) (*self* agent-or-agentset)) (funcall fn)))
+   (let ((*myself* *self*) (*self* agent-or-agentset)) (with-stop-handler (funcall fn))))
   (t
    (error "Ask requires an agentset or agent but got: ~A" agent-or-agentset))))
 
@@ -203,6 +203,22 @@ DESCRIPTION:
   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#display"
  nil)
 
+(defun stop ()
+ "STOP => RESULT
+
+ARGUMENTS AND VALUES:
+
+  RESULT: undefined
+
+DESCRIPTION:
+
+  Returns from the current stop block, which will halt the currently running
+  thing, be that the program, current ask block, or procedure.  Stop has odd
+  semantics that are best gleaned from the actual NetLogo manual.
+
+  See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#stop"
+ (error (make-condition 'stop)))
+
 (defun of (fn agent-or-agentset)
  "OF FN AGENT-OR-AGENTSET => RESULT
 
diff --git a/src/main/package.lisp b/src/main/package.lisp
index 07666e7..89a0ab3 100644
--- a/src/main/package.lisp
+++ b/src/main/package.lisp
@@ -65,7 +65,7 @@ into an ast that can be transpiled later."))
 (defpackage #:clnl-nvm
  (:use :common-lisp)
  (:shadow #:random #:count)
- (:export #:export-world #:create-world #:current-state
+ (:export #:export-world #:create-world #:current-state #:with-stop-handler
   ; API as used by transpiled NetLogo programs
   #:agent-value
   #:ask
@@ -88,6 +88,7 @@ into an ast that can be transpiled later."))
   #:set-default-shape
   #:setxy
   #:show
+  #:stop
   #:turtles
   #:tick
   #:ticks
diff --git a/src/main/transpile.lisp b/src/main/transpile.lisp
index 8cf44e7..b0fcb47 100644
--- a/src/main/transpile.lisp
+++ b/src/main/transpile.lisp
@@ -177,6 +177,7 @@ DESCRIPTION:
 (defsimpleprim :set-default-shape :command clnl-nvm:set-default-shape)
 (defsimpleprim :setxy :command clnl-nvm:setxy)
 (defsimpleprim :show :command clnl-nvm:show)
+(defsimpleprim :stop :command clnl-nvm:stop)
 (defagentvalueprim :size)
 (defsimpleprim :tick :command clnl-nvm:tick)
 (defsimpleprim :ticks :reporter clnl-nvm:ticks)
diff --git a/src/test/simpletests.lisp b/src/test/simpletests.lisp
index d85675d..3aef8e2 100644
--- a/src/test/simpletests.lisp
+++ b/src/test/simpletests.lisp
@@ -253,3 +253,9 @@
 
 (defsimplecommandtest "clear-all 1" "crt 10 ask patches [ set pcolor random 100 ] clear-all"
  "7B5DF28923D7FD72158018A876DE8ED02CFB0882")
+
+(defsimplecommandtest "stop 1" "crt 10 stop crt 10"
+ "A925E39EC022967568D238D31F70F0A375024A89")
+
+(defsimplecommandtest "stop 2" "crt 10 ask turtles [ fd 1 stop fd 1 ]"
+ "A6C980CC9843CDD211ABD9C13899010D555F3DC5")
-- 
2.25.1