From 1ae8c7a0199a4955708c7f5d7a286a12782b5fd2 Mon Sep 17 00:00:00 2001 From: Frank Duncan Date: Sat, 6 Jun 2015 11:32:13 -0500 Subject: [PATCH] Setting up a whole lot of testing infrastructure --- bin/diagnose-test | 21 ++++++++++++ bin/run-nl | 2 +- bin/runcmd.scala | 33 ++---------------- bin/test-mode | 4 +++ bin/test-mode.lisp | 4 +++ bin/test.lisp | 2 +- src/main/cl-nl.asd | 5 ++- src/main/lex.lisp | 22 +++++------- src/main/main.lisp | 19 ++++++----- src/main/nvm.lisp | 36 ++++++++++++++++++++ src/main/package.lisp | 24 ++++++++++++- src/main/parse.lisp | 60 ++++++++++++++++++++++++++++++++ src/main/random.lisp | 16 ++++++--- src/main/transpile.lisp | 50 +++++++++++++++++++++++++++ src/test/cl-nl-test.asd | 5 +-- src/test/main.lisp | 72 +++++++++++++++++++++++++++++++++++++-- src/test/package.lisp | 2 +- src/test/simpletests.lisp | 4 +++ 18 files changed, 316 insertions(+), 65 deletions(-) create mode 100755 bin/diagnose-test create mode 100755 bin/test-mode create mode 100644 bin/test-mode.lisp create mode 100644 src/main/nvm.lisp create mode 100644 src/main/parse.lisp create mode 100644 src/main/transpile.lisp create mode 100644 src/test/simpletests.lisp diff --git a/bin/diagnose-test b/bin/diagnose-test new file mode 100755 index 0000000..7744fe0 --- /dev/null +++ b/bin/diagnose-test @@ -0,0 +1,21 @@ +#!/bin/bash -e + +if ! [ -n "$1" ] ; then + echo "Uhm, need a test name, yo" + exit 1 +fi +TEST=$1 + +sbcl --eval "(asdf:load-system :cl-nl-test)" --eval "(quit)" &> /dev/null +COMMANDS=$(sbcl --noinform --disable-ldb --lose-on-corruption --end-runtime-options --eval "(asdf:load-system :cl-nl-test)" --eval "(cl-nl-test::test-commands \"$1\")" --eval "(quit)" 2> /dev/null | sed -n '/^----$/,$p' | tail -n +2) + +scalafile=$(mktemp -u -p .) +clfile=$(mktemp -u -p .) + +echo "$COMMANDS" | bin/runcmd.scala | sed -n '/^----$/,$p' | tail -n +2 > $scalafile +sbcl --noinform --disable-ldb --lose-on-corruption --end-runtime-options --eval "(asdf:load-system :cl-nl-test)" --eval "(cl-nl-test::diagnose-test \"$1\")" --eval "(quit)" 2> /dev/null | sed -n '/^----$/,$p' | tail -n +2 > $clfile + +vimdiff $scalafile $clfile + +rm $scalafile +rm $clfile diff --git a/bin/run-nl b/bin/run-nl index 2751c5e..c14aa97 100755 --- a/bin/run-nl +++ b/bin/run-nl @@ -1,3 +1,3 @@ #!/bin/bash -sbcl --script bin/run.lisp +rlwrap sbcl --script bin/run.lisp diff --git a/bin/runcmd.scala b/bin/runcmd.scala index eb0d463..f2487ae 100755 --- a/bin/runcmd.scala +++ b/bin/runcmd.scala @@ -30,36 +30,9 @@ workspace.openFromSource(url2String("file:resources/empty.nlogo")) val commands = io.Source.stdin.getLines.mkString("\n") +workspace.mainRNG.setSeed(15) workspace.runCompiledCommands(new api.SimpleJobOwner("test", workspace.world.mainRNG, api.AgentKind.Observer), workspace.compileCommands(commands, api.AgentKind.Observer)) -mirror.Mirrorables.allMirrorables(workspace.world).map( x => { - System.out.print("(") - System.out.print(":" + x.kind) - System.out.print(" ") - System.out.print(x.agentKey.id) - System.out.print(" (") - x.kind.Variables.values.toSeq.map( k => { - System.out.print("(:" + k + " ") - System.out.print(x.getVariable(k.id) match { - case s: java.lang.String => "\"s\"" - case d: java.lang.Double => d + "d0" - case b: java.lang.Boolean => if(b)"T" else "NIL" - case _: org.nlogo.api.ShapeList => ":SHAPELIST" - case v => v - }) - System.out.print(") ") - }) - System.out.println(")") - - }) - -/* -workspace.runCompiledCommands(new api.SimpleJobOwner("test", workspace.world.mainRNG, api.AgentKind.Observer), workspace.compileCommands("random-seed 15", api.AgentKind.Observer)) -for(_ <- 1 to 40) - System.out.println(workspace.runCompiledReporter(new api.SimpleJobOwner("test", workspace.world.mainRNG, api.AgentKind.Observer), workspace.compileReporter("random-float 30"))) - -val m = new org.nlogo.util.MersenneTwisterFast(); -m.setSeed(15); -for(_ <- 1 to 40) - System.out.println(30d * m.nextDouble())*/ +workspace.world.exportWorld(new java.io.PrintWriter(System.out, true), true) +System.out.println(org.nlogo.headless.Checksummer.calculateChecksum(workspace.world.exportWorld(_, true))) workspace.dispose diff --git a/bin/test-mode b/bin/test-mode new file mode 100755 index 0000000..8f6d956 --- /dev/null +++ b/bin/test-mode @@ -0,0 +1,4 @@ +#!/bin/bash + +sbcl --eval "(asdf:load-system :cl-nl-test)" --eval "(quit)" &> /dev/null +rlwrap sbcl --script bin/test-mode.lisp diff --git a/bin/test-mode.lisp b/bin/test-mode.lisp new file mode 100644 index 0000000..3418229 --- /dev/null +++ b/bin/test-mode.lisp @@ -0,0 +1,4 @@ +(require 'asdf) +(setf asdf:*central-registry* (list #p"deps/")) +(asdf:load-system :cl-nl-test) +(cl-nl-test:run) diff --git a/bin/test.lisp b/bin/test.lisp index 128688a..536be82 100644 --- a/bin/test.lisp +++ b/bin/test.lisp @@ -1,4 +1,4 @@ (require 'asdf) (setf asdf:*central-registry* (list #p"deps/")) (asdf:load-system :cl-nl-test) -(cl-nl-test:run-tests) +(sb-ext:quit :unix-status (if (cl-nl-test:run-all-tests) 0 1)) diff --git a/src/main/cl-nl.asd b/src/main/cl-nl.asd index 9ef24e3..924a5f6 100644 --- a/src/main/cl-nl.asd +++ b/src/main/cl-nl.asd @@ -6,6 +6,9 @@ :serial t :components ((:file "package") (:file "lex") + (:file "parse") + (:file "nvm") + (:file "transpile") (:file "random") (:file "main")) - :depends-on (:cl-ppcre)) + :depends-on (:cl-ppcre :mt19937)) diff --git a/src/main/lex.lisp b/src/main/lex.lisp index b1da848..93343e6 100644 --- a/src/main/lex.lisp +++ b/src/main/lex.lisp @@ -1,7 +1,3 @@ -(defpackage #:cl-nl.lexer - (:use :common-lisp) - (:export :lex)) - (in-package #:cl-nl.lexer) ; I played around with using #'read for netlogo code, which would have been neat. @@ -86,15 +82,15 @@ (deflex :initial *nonnewline_white_space_char* (constantly nil)) (deflex :initial "\\n|\\r" (constantly nil)) ;(deflex :initial ";.*[\n\r]?" nil) -;(deflex :initial (format nil "-?\.?[0-9]~A" *identifier-char*) -; (lambda (text) -; (let -; ((num? -; (let -; ((*readtable* (copy-readtable nil)) -; (*read-eval* nil)) -; (read-from-string text)))) -; (if (numberp num?) num? (error "Invalid number"))))) +(deflex :initial (format nil "-?\.?[0-9]~A*" *identifier-char*) + (lambda (text) + (let + ((num? + (let + ((*readtable* (copy-readtable nil)) + (*read-eval* nil)) + (read-from-string text)))) + (if (numberp num?) num? (error "Invalid number"))))) (deflex :initial (format nil "~A*" *identifier-char*) #'as-symbol) ;(deflex :initial (format nil "\"~A*\"" *string-text*)) diff --git a/src/main/main.lisp b/src/main/main.lisp index d9780ba..b9f4670 100644 --- a/src/main/main.lisp +++ b/src/main/main.lisp @@ -3,17 +3,20 @@ (defun e (ast) ast) (defun r (str) - (let - ((ast (cl-nl.lexer:lex str))) - (format t "AST for ~S became ~S~%" str ast) - ast)) + (let* + ((lexed-ast (let ((ast (cl-nl.lexer:lex str))) (format t "Via lexing, AST for ~S became ~S~%" str ast) ast)) + (parsed-ast (let ((ast (cl-nl.parser:parse lexed-ast))) (format t "Via parsing, AST for ~S became ~S~%" lexed-ast ast) ast)) + (transpiled-ast (let ((ast (cl-nl.transpiler:transpile-command-block parsed-ast))) (format t "Via transpiling, AST for ~S became ~S~%" parsed-ast ast) ast))) + (eval transpiled-ast))) (defun p (result) result) (defun run () - (loop for str = (read-line) + (loop for str = (progn (format t "> ") (force-output) (read-line)) while str - do (p (e (r str)))) + do (p (e (r str))))) - ;(format t "AH HA~%") - ) +(defun boot ()) + +(defun run-commands (cmds) + (eval (cl-nl.transpiler:transpile-command-block (cl-nl.parser:parse (cl-nl.lexer:lex cmds))))) diff --git a/src/main/nvm.lisp b/src/main/nvm.lisp new file mode 100644 index 0000000..49c5980 --- /dev/null +++ b/src/main/nvm.lisp @@ -0,0 +1,36 @@ +(in-package #:cl-nl.nvm) + +; This is the engine. Yay. + +(defun create-turtles (n) + (format t "HELLO WORLD ~A~%" n)) + +(defun export-world () + (format nil "~{~A~%~}" + (list + (format nil "~S" "RANDOM STATE") + "\"0 0 -1727483681 624 0.0 false 15 1416695020 654306947 590492850 1239419966 -173306912 1371515797 -193141397 1910712848 -761679426 -286505829 -1273731069 1002213745 559012514 1169814520 -1111719348 893200086 314759295 741630253 484862932 426311352 -842729811 -1116049220 -2066339571 2011183619 -1198525213 2029979103 131276465 -1802578703 1660227324 1419726575 882475525 -1857554151 158448328 306952458 86792981 550579309 373808166 1278488868 -219729728 665032727 210784316 -1316764714 1469363919 186801522 1856954407 1778173228 1987698672 -1031515323 1571770575 -435478664 1989754554 1747243771 138741463 398836233 1343971012 -202977039 -1904217677 -123137009 851662071 373929135 26144840 234050726 299318205 -1760708911 -217772928 809831153 -156284328 -1905260245 -1288073614 -1476451722 -1304122357 -1788366635 -110308324 -2041755771 1081440142 -465784137 1518392657 1009514718 -1147535899 -772617357 -1816579199 288845313 -490475592 -994727909 -1958204979 176244225 -1451350084 -1606656946 457774677 1495026915 -1082308731 -2140833889 1985361486 -1556302711 2002689590 1115740947 -946794373 1901311930 1836552234 1098900571 2132754919 -1226631644 1367085925 1141910236 -379834726 947733447 555891950 2006935634 1593676844 932350767 -74051334 337179565 -302335822 -912746681 84087367 317666679 641582952 2045662334 -1984410222 -701978040 -1925557488 -873109356 1558975246 -658535321 208660465 -824345709 1165086799 -394072762 1703184826 -1558418871 455414554 177173446 -1577606237 -760498165 1802757039 189985326 -493475153 2093539942 1631285806 534262807 1691212960 -458148589 1119846367 -133349082 1494909226 46266761 -2083470176 1929791102 1051510704 -422053626 -1835275120 1495038002 838055864 -931072974 1994756336 1706698929 520633869 -707759937 1286936267 69867602 1843231483 -1274589372 -1556562623 864061203 -813468124 -399934199 1871622041 1282121632 139076654 1474225360 1629167648 -1597221199 -1377238964 943250804 -1692503181 1390544197 2094626949 -1629015866 1873486343 434348818 378665167 661057889 678503676 -732793820 -2050903268 -65488496 -938089798 -435784519 -568748001 1262747594 -1203466538 -1152922012 -40696577 730846254 1569543401 -1114986420 2112365963 661891640 -1102962465 -1783087879 959406800 1598246106 397116978 -455428986 1619486278 1259887057 -581189665 2112056988 -1556633150 -754075246 -609234936 385873963 -67572532 1838757249 -1315726249 809053025 -1167325410 1580255974 1176939774 -1362118537 -1998756858 -436561294 -1113823116 634805614 -1684751545 885575707 1599442570 -271146821 -2135432835 -290328831 -970367311 14524194 -1551434925 -873037601 -1187343433 -753195947 377576667 163042901 -275903112 -895539849 302046133 -304247717 1592489899 1939222790 1169102776 -472556045 -469532505 -1984592468 -1997939553 1872695275 1353417293 1014568184 -624558379 -2057825940 -1626030235 -1922128989 1738455174 -770699963 1549382561 -639336668 759368296 -455293938 1214205736 85339445 2019832818 251300585 361660408 -478399004 640345136 -2141603842 -21007493 -1097087128 -1122801693 -1100585513 -1883755748 411963882 -318157721 -985094006 530239524 846422860 1857935893 -1322795266 -1295567225 -1100435307 -1376814160 1116475480 879826236 429817292 1835912861 1713897646 -1896944338 1298407296 1709406218 -632733571 1037820125 1965096281 -352318239 1880623188 742639540 579411760 471465757 898837663 843756266 1839059330 -1292385056 -297033636 -213770834 649218933 451699550 -2147318964 1482984701 -637371228 876711452 1705905734 -1690262978 -1762255128 -703894129 -1628035718 393347479 32862419 956002176 375291586 -1268001331 278930159 174633104 -1246053866 650911531 -1989980097 1204440666 524066353 -1024875616 741657499 -1492694924 -1897873956 2102966245 631607876 628431397 -986439957 1785879259 -1515027626 -285096583 481768568 1856236719 1092059134 1438513140 -1588071933 -1036254016 630144331 -899853580 1090055121 186079855 749016619 -1255423144 893730276 -206802857 -311343480 -566347460 535318081 2018421260 -1302000247 2028649536 -450752497 559596071 2110159311 320818611 -271354867 -605402891 -348884866 -1420933182 1887965234 733917330 -1162359538 -1298967759 369827733 1599943744 1518561309 -1319956347 -783366723 1276687217 1708506284 -1274607938 1216628138 1898250486 -1411477005 -1803514218 -1190038042 -986281865 -1464472760 -1850314825 -2001407761 1456268296 -316814827 1283490359 1272727256 1270945320 522760377 -223364214 -1217376357 857164268 875788204 -116571027 -1562583304 88982581 1864484733 -1334242943 683148613 -867237168 -76281385 47601213 -362697557 1451689955 -173273146 -1951029418 1484978626 464184974 -1783564890 -1446924459 530628085 231084108 -269411424 928982004 -1368210198 -2130716369 -1134246551 -883611680 -1507444423 1985095922 1224291467 -818571745 1480406714 -175264650 -983389991 1111443891 491149036 565745871 -1723592097 -1573255834 1669506602 -593128530 -1357522439 -1625074496 -627424188 -1621626690 -760571928 -1274563468 -573089204 -1854674454 -1337953720 1587327731 741612860 1893246575 1804372266 -2012798276 -1751489348 1493528253 1586187764 1465966706 -126150103 1488440925 -763910120 250136436 -658520430 -1092357628 1922937902 1592672092 -344799613 -1107111341 1709266121 2042461373 682021890 -178997087 -2052486206 1240327321 -631731758 2003188304 -1799267119 -1195668452 -1127458892 92865197 -1875401439 -179772496 -2055101823 -1045284206 -1835026919 -1338749556 -1996121876 -1534151219 -1740471405 1872593694 -30845915 -1184855319 -1109683293 1594452338 -297130163 -1385414219 1524751907 636147547 -362566695 2067822837 1607880248 -1359454350 -819947226 -170640752 773376247 638876268 -460580202 -1147978812 -159544038 -675672614 -1698719333 1442413660 294049713 -1518873642 -1553004378 1391079095 408802770 1160822751 1241219740 -1754558728 -1379322710 -1910001583 692714953 -1618955432 -1388843378 -611447991 706416704 -1977636017 -1673147279 488126064 750742594 -431814115 -1481699862 400139933 -1387019513 -1500733424 -274543822 -464624274 -919577829 -562312557 1345191148 620404894 -1020793228 379569682 1887881530 -344262296 -1393841063 1924445450 -1921297797 504974562 -598849200 -714777882 -2031850623 -1438873640 1032537388 1143658631 1181820170 -20741500 -1448230799 -1263568242 -1683732628 -1374941545 1621262331 242174421 557719613 -93429946 -1788181137 -1771504840 -596432358 1302724374 631371085 -1236861284 -2036923246 -889856243 -1463713596 799786589 1685588465 1715297777 -16023054 28000088 685643772 -229026639 -730878336 -1643579658 -698481524 1467045300 -628641869 -497188165 -1931408156 1727737611 -1903432896 1692935513 821745160 -910640263 176964468 26981143 -1897531033 -520784850 1161686295 954814981 -1424684207 362931480 -1876869934 274223211 214826899 1276150364 -1529727473 2083998336 238448709 -344835430 731644351 1370810814 95449535 1538595264 964850827 1419993150 145732163 -1752419880 636704620 650005511 670351407 -743310344 -1930510475 -823575710\"" + "" + (format nil "~S" "GLOBALS") + "\"min-pxcor\",\"max-pxcor\",\"min-pycor\",\"max-pycor\",\"perspective\",\"subject\",\"nextIndex\",\"directed-links\",\"ticks\"," + "\"-1\",\"1\",\"-1\",\"1\",\"0\",\"nobody\",\"0\",\"\"\"NEITHER\"\"\",\"-1\"" + "" + (format nil "~S" "TURTLES") + "\"who\",\"color\",\"heading\",\"xcor\",\"ycor\",\"shape\",\"label\",\"label-color\",\"breed\",\"hidden?\",\"size\",\"pen-size\",\"pen-mode\"" + "" + (format nil "~S" "PATCHES") + "\"pxcor\",\"pycor\",\"pcolor\",\"plabel\",\"plabel-color\"" + "\"-1\",\"1\",\"0\",\"\"\"\"\"\",\"9.9\"" + "\"0\",\"1\",\"0\",\"\"\"\"\"\",\"9.9\"" + "\"1\",\"1\",\"0\",\"\"\"\"\"\",\"9.9\"" + "\"-1\",\"0\",\"0\",\"\"\"\"\"\",\"9.9\"" + "\"0\",\"0\",\"0\",\"\"\"\"\"\",\"9.9\"" + "\"1\",\"0\",\"0\",\"\"\"\"\"\",\"9.9\"" + "\"-1\",\"-1\",\"0\",\"\"\"\"\"\",\"9.9\"" + "\"0\",\"-1\",\"0\",\"\"\"\"\"\",\"9.9\"" + "\"1\",\"-1\",\"0\",\"\"\"\"\"\",\"9.9\"" + "" + (format nil "~S" "LINKS") + "\"end1\",\"end2\",\"color\",\"label\",\"label-color\",\"hidden?\",\"breed\",\"thickness\",\"shape\",\"tie-mode\"" + "" + ))) diff --git a/src/main/package.lisp b/src/main/package.lisp index 5377283..1e6592b 100644 --- a/src/main/package.lisp +++ b/src/main/package.lisp @@ -1,2 +1,24 @@ (defpackage #:cl-nl (:use :common-lisp) - (:export :run)) + (:export :run :boot :run-commands)) + +(defpackage #:cl-nl.parser + (:use :common-lisp) + (:export :parse)) + +(defpackage #:cl-nl.random + (:use :common-lisp) + (:shadow #:export) + (:export #:set-seed #:next-int #:next-double)) + +(defpackage #:cl-nl.transpiler + (:use :common-lisp) + (:export :transpile-command-block)) + +(defpackage #:cl-nl.nvm + (:use :common-lisp) + (:export :export-world)) + +(defpackage #:cl-nl.lexer + (:use :common-lisp) + (:export :lex)) + diff --git a/src/main/parse.lisp b/src/main/parse.lisp new file mode 100644 index 0000000..ced5470 --- /dev/null +++ b/src/main/parse.lisp @@ -0,0 +1,60 @@ +(in-package #:cl-nl.parser) + +; Ok, after thinking about this a little, the parser is completely contextual +; based on what has come before. We can't do a contextless parsing, like we +; could in other languages, due to amiguity about reporters vs reporter tasks +; +; So, for instance, we could have: +; x + y => (+ x y) +; x + y => (x (task +) y) +; So the definition of "+" is completely dependent on the nature of x +; +; The goal of this parser should be to turn in the amiguous lexed ast representing +; NetLogo into an unambigious S-expression, and nothing more, so things like +; expectation of commands being the first symbol is not be necessary until later +; +; In general, the parser will: +; * Parse the structure of the lexed output first +; * Parse the structure of the individual expressions (finding ('s and ['s and doing the right thing) +; * Coalate things into an unambigious expressions +; * Then we're done, let someone else make it evaluatable +; - We don't really care if things are commands or reporters right now + +(defparameter *prims* nil) + +(defun prim-name (prim) (getf prim :name)) +(defun prim-num-args (prim) (length (getf prim :args))) + +(defun find-prim (symb) (find symb *prims* :key #'prim-name)) + +; We don't care if it's a command! +;(defun is-command (symb) +; (let +; ((prim (find-prim symb))) +; (and prim (eql :command (getf prim :type))))) + +; 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) + (cond + ((not lexed-ast) nil) + ((numberp (car lexed-ast)) (cons (coerce (car lexed-ast) 'double-float) (parse (cdr lexed-ast)))) + ((and (symbolp (car lexed-ast)) (find-prim (car lexed-ast))) + (let* + ((prim (find-prim (car lexed-ast))) + (num-args (prim-num-args prim)) + (parsed-remainder (parse (cdr lexed-ast)))) + (cons + (cons + (prim-name prim) + (butlast parsed-remainder (- (length parsed-remainder) num-args))) + (nthcdr num-args parsed-remainder)))) + (t (error "Couldn't parse ~S" lexed-ast)))) + +(defmacro defprim (name args) + `(push + (list :name ,name :args ',args) + *prims*)) + +; This list of prims will get combined with the mapping to actual code later +(defprim :crt (:number)) diff --git a/src/main/random.lisp b/src/main/random.lisp index 7fca5a1..44a1a2a 100644 --- a/src/main/random.lisp +++ b/src/main/random.lisp @@ -1,7 +1,3 @@ -(defpackage #:cl-nl.random - (:use :common-lisp) - (:export :set-seed :next-int :next-double)) - (in-package #:cl-nl.random) ; This is a wrapper around the very nice mersenne twister mt19937 to match @@ -22,3 +18,15 @@ (+ (ash (ash y -6) 27) (ash z -5)) (coerce (ash 1 53) 'double-float)) n))) + +; Oh, export world, you WILL be mine +(defun export () + (let + ((state + (map + 'list + (lambda (x) (if (logbitp (1- 32) x) (dpb x (byte 32 0) -1) x)) + (mt19937::random-state-state mt19937:*random-state*)))) + (format nil "0 ~A ~A ~A 0.0 false 1 ~{~A~^ ~}" + (first state) (second state) (third state) + (nthcdr 4 state)))) diff --git a/src/main/transpile.lisp b/src/main/transpile.lisp new file mode 100644 index 0000000..159a217 --- /dev/null +++ b/src/main/transpile.lisp @@ -0,0 +1,50 @@ +(in-package #:cl-nl.transpiler) + +; This is responsible for taking an ast and turning it into valid CL code +; targeting the nvm. Here is where start to care about commands versus reporters +; and ensuring that things are in the right place. The reason we wait until here +; is because we want to allow someone else to play with the AST before handing it off +; to us. For instance, the command center wants to add "show" to reporters, and +; the users dictate based on entry point whether they are expecting a command +; or a reporter. So monitors can say "hey, transpile this reporter" and we'll check +; to make sure it actually is. + +(defparameter *prims* nil) + +(defun prim-name (prim) (getf prim :name)) +(defun prim-type (prim) (getf prim :type)) +(defun prim-func (prim) (getf prim :func)) +(defun is-reporter (prim) (eql :reporter (getf prim :type))) +(defun is-command (prim) (eql :command (getf prim :type))) + +(defun find-prim (symb) (find symb *prims* :key #'prim-name)) + +; Let this grow, slowly but surely, eventually taking on calling context, etc. +; For now, it's just a +(defun transpile-command-block (parsed-ast) + `(progn + ,@(mapcar #'transpile-command parsed-ast))) + +(defun transpile-command (command) + (cond + ((not (listp command)) (error "Expected a statement of some sort")) + ((not (find-prim (car command))) (error "Couldn't find the command for ~S" (car command))) + ((not (is-command (find-prim (car command)))) (error "Expected command, got ~S" (car command))) + (t `(,(prim-func (find-prim (car command))) ,@(mapcar #'transpile-reporter (cdr command)))))) + +(defun transpile-reporter (reporter) + (cond + ((numberp reporter) reporter) ; The parser converts to double for us + ((symbolp reporter) reporter) ; The parser should have checked that having a symbol here is ok + ((not (listp reporter)) (error "Expected a statement of some sort")) + ((not (find-prim (car reporter))) (error "Couldn't find the reporter for ~S" (car reporter))) + ((not (is-reporter (find-prim (car reporter)))) (error "Expected reporter, got ~S" (car reporter))) + (t `(,(prim-func (find-prim (car reporter))) ,@(mapcar #'transpile-reporter (cdr reporter)))))) + +(defmacro defprim (name type nvm-func) + `(push + (list :name ,name :type ,type :func ',nvm-func) + *prims*)) + +; We count on the parser to handle arguemnts for us, when collating things. +(defprim :crt :command cl-nl.nvm::create-turtles) diff --git a/src/test/cl-nl-test.asd b/src/test/cl-nl-test.asd index 7fd1760..37fe158 100644 --- a/src/test/cl-nl-test.asd +++ b/src/test/cl-nl-test.asd @@ -5,5 +5,6 @@ :author "Frank Duncan (frank@kank.com)" :serial t :components ((:file "package") - (:file "main")) - :depends-on (:cl-nl)) + (:file "main") + (:file "simpletests")) + :depends-on (:cl-nl :ironclad)) diff --git a/src/test/main.lisp b/src/test/main.lisp index 20d404c..38ec2ed 100644 --- a/src/test/main.lisp +++ b/src/test/main.lisp @@ -1,5 +1,71 @@ (in-package #:cl-nl-test) -(defun run-tests () - (cl-nl:run) - (format t "That's how we roll~%")) +(defparameter *tests* nil) + +(defun run-and-print-test (test) + (let + ((green (format nil "~c[1;32m" #\Esc)) + (red (format nil "~c[1;31m" #\Esc)) + (result (funcall (cadr test)))) + (format t "~A- ~S ~A~c[0m~%" (if result green red) (car test) (if result "passed" "failed") #\Esc) + result)) + +(defun run-tests (tests) + (let + ((final-result t)) + (loop for test in tests + for result = (run-and-print-test test) + do (setf final-result (and final-result result))) + final-result)) + +(defun run-all-tests () + (format t "~%Here we goooooooo~%") + (run-tests *tests*)) + +(defun run-tests-matching (match) + (run-tests (remove-if-not (lambda (test-name) (cl-ppcre:scan (format nil "^~A$" match) test-name)) *tests* :key #'car))) + +(defun find-test (name) (find name *tests* :test #'string= :key #'car)) + +(defun diagnose-test (name) + (when (not (find-test name)) (error "Couldn't find test with name: ~A" name)) + (format t "----~%~A~%" (funcall (caddr (find-test name))))) + +(defun test-commands (name) + (let + ((test (find-test name))) + (when (not test) (error "Couldn't find test with name: ~A" name)) + (format t "----~%") + (format t "~A~%" (funcall (fourth test))))) + +; To be used only with the simplest of tests, just a list of commands and a checksum of the +; world after they've been run. +(defmacro defsimpletest (name commands checksum) + `(progn + ;(when (find-test ,name) (error "Test with name ~S already exists, abort, abort" ,name)) + (push + (list + ,name + (lambda () + (cl-nl:boot) + (cl-nl:run-commands ,commands) + (string= ,checksum (checksum-world))) + (lambda () + (cl-nl:boot) + (cl-nl:run-commands ,commands) + (cl-nl.nvm:export-world) + ) + (lambda () ,commands)) + *tests*))) + +(defun checksum-world () + (format nil "~{~2,'0X~}" + (map 'list #'identity + (ironclad:digest-sequence + :sha1 + (map '(vector (unsigned-byte 8)) #'char-code (cl-nl.nvm:export-world)))))) + +(defun run () + (loop for str = (progn (format t "> ") (force-output) (read-line)) + while str + do (progn (asdf:load-system :cl-nl-test) (run-tests-matching str)))) diff --git a/src/test/package.lisp b/src/test/package.lisp index 805cc88..3dfefe7 100644 --- a/src/test/package.lisp +++ b/src/test/package.lisp @@ -1,2 +1,2 @@ (defpackage #:cl-nl-test (:use :common-lisp :cl-nl) - (:export :run-tests)) + (:export :run-all-tests :run :diagnose-test)) diff --git a/src/test/simpletests.lisp b/src/test/simpletests.lisp new file mode 100644 index 0000000..6cfd668 --- /dev/null +++ b/src/test/simpletests.lisp @@ -0,0 +1,4 @@ +(in-package #:cl-nl-test) + +(defsimpletest "Nothing" "" "E1DE30F072D785E0D0B59F28B0F7853E3D3E0D8B") +;(defsimpletest "Simple crt" "crt 1" "F6D10F42CDC9F0EE28F54D9DF26729C0D8591E60 0") -- 2.25.1