├── LICENSE ├── README.md ├── TinyLispComputer.brd ├── TinyLispComputer.ino └── TinyLispComputer.sch /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2016 David Johnson-Davies 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Tiny Lisp Computer 2 | A self-contained computer with its own display and keyboard, based on an ATmega328 or ATmega1284, that you can program in Lisp. 3 | For more information see: 4 | 5 | Tiny Lisp Computer (ATmega328): http://www.technoblogy.com/show?1GX1 6 | 7 | Tiny Lisp Computer 2 (ATmega1284): http://www.technoblogy.com/show?1INT 8 | 9 | Tiny Lisp Computer 2 PCB version: http://www.technoblogy.com/show?1KTO 10 | -------------------------------------------------------------------------------- /TinyLispComputer.brd: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 | 71 | 72 | 73 | 74 | 75 | 76 | 77 | 78 | 79 | 80 | 81 | 82 | 83 | 84 | 85 | 86 | 87 | 88 | 89 | 90 | 91 | 92 | 93 | 94 | 95 | 96 | 97 | 98 | 99 | 100 | 101 | 102 | 103 | 104 | 105 | 106 | 107 | 108 | 109 | 110 | 111 | 112 | 113 | 114 | 115 | 116 | 117 | 118 | 119 | 120 | 121 | 122 | 123 | 124 | 125 | 126 | 127 | 128 | 129 | 130 | 131 | 132 | 133 | 134 | 135 | 136 | 137 | 138 | 139 | 140 | 141 | 142 | 143 | 144 | 145 | 146 | 147 | 148 | 149 | SD 150 | A3 151 | A5 152 | A7 153 | SC 154 | A6 155 | A4 156 | A2 157 | A1 158 | A0 159 | 160 | 161 | 162 | 163 | 164 | 165 | 166 | 167 | 168 | 5V 169 | GND 170 | GND 171 | 5V 172 | GND 173 | 5V 174 | Tiny Lisp Computer 2 175 | GND 176 | 5V 177 | TX 178 | RX 179 | DTR 180 | D7 181 | D6 182 | D5 183 | D4 184 | 185 | 186 | 187 | <h3>SparkFun Electronics' preferred foot prints</h3> 188 | In this library you'll find resistors, capacitors, inductors, test points, jumper pads, etc.<br><br> 189 | We've spent an enormous amount of time creating and checking these footprints and parts, but it is the end user's responsibility to ensure correctness and suitablity for a given componet or application. If you enjoy using this library, please buy one of our products at www.sparkfun.com. 190 | <br><br> 191 | <b>Licensing:</b> CC v3.0 Share-Alike You are welcome to use this library for commercial purposes. For attribution, we ask that when you begin to sell your device using our footprint, you email us with a link to the product being sold. We want bragging rights that we helped (in a very small part) to create your 8th world wonder. We would like the opportunity to feature your device on our homepage. 192 | 193 | 194 | 195 | 196 | 197 | 198 | 199 | 200 | 201 | 202 | 203 | >NAME 204 | >VALUE 205 | 206 | 207 | 208 | 209 | 210 | 211 | 212 | 213 | 214 | <b>Stand Off</b><p> 215 | This is the mechanical footprint for a #4 phillips button head screw. Use the keepout ring to avoid running the screw head into surrounding components. SKU : PRT-00447 216 | 217 | 218 | 219 | 220 | 221 | 222 | 223 | 224 | 225 | 226 | 227 | 228 | 229 | 230 | 231 | 232 | 233 | 234 | 235 | 236 | 237 | 238 | 239 | 240 | 241 | 242 | 243 | 244 | 245 | 246 | 247 | 248 | 249 | 250 | 251 | 252 | 253 | >NAME 254 | >VALUE 255 | 256 | 257 | 258 | 259 | 260 | 261 | 262 | 263 | 264 | 265 | <h3>SparkFun Electronics' preferred foot prints</h3> 266 | In this library you'll find connectors and sockets- basically anything that can be plugged into or onto.<br><br> 267 | We've spent an enormous amount of time creating and checking these footprints and parts, but it is the end user's responsibility to ensure correctness and suitablity for a given componet or application. If you enjoy using this library, please buy one of our products at www.sparkfun.com. 268 | <br><br> 269 | <b>Licensing:</b> CC v3.0 Share-Alike You are welcome to use this library for commercial purposes. For attribution, we ask that when you begin to sell your device using our footprint, you email us with a link to the product being sold. We want bragging rights that we helped (in a very small part) to create your 8th world wonder. We would like the opportunity to feature your device on our homepage. 270 | 271 | 272 | 273 | 274 | 275 | 276 | 277 | 278 | 279 | 280 | >NAME 281 | >VALUE 282 | 283 | 284 | 285 | 286 | 287 | 288 | 289 | 290 | 291 | 292 | 293 | 294 | 295 | 296 | 297 | 298 | 299 | 300 | 301 | 302 | >NAME 303 | >VALUE 304 | 305 | 306 | 307 | 308 | 309 | 310 | 311 | 312 | >NAME 313 | >VALUE 314 | 315 | 316 | 317 | 318 | 319 | 320 | 321 | 322 | 323 | 324 | 325 | 326 | 327 | 328 | 329 | 330 | 331 | 332 | 333 | 334 | 335 | 336 | 337 | 338 | 339 | 340 | 341 | 342 | 343 | 344 | 345 | 346 | 347 | 348 | 349 | 350 | 351 | 352 | 353 | 354 | 355 | 356 | 357 | 358 | 359 | 360 | 361 | 362 | 363 | 364 | 365 | 366 | 367 | 368 | 369 | 370 | 371 | >NAME 372 | >VALUE 373 | 374 | 375 | 376 | 377 | 378 | 379 | 380 | 381 | 382 | 383 | 384 | 385 | 386 | 387 | 388 | 389 | 390 | 391 | 392 | 393 | 394 | 395 | 396 | 397 | 398 | 399 | 400 | 401 | 402 | 403 | 404 | 405 | 406 | 407 | 408 | 409 | 410 | 411 | 412 | 413 | 414 | 415 | 416 | 417 | 418 | 419 | 420 | 421 | 422 | 423 | 424 | 425 | 426 | 427 | 428 | 429 | 430 | 431 | 432 | 433 | 434 | 435 | 436 | 437 | 438 | 439 | 440 | 441 | 442 | 443 | 444 | 445 | 446 | 447 | 448 | >NAME 449 | >VALUE 450 | 451 | 452 | 453 | 454 | >NAME 455 | >VALUE 456 | 457 | 458 | 459 | 460 | 461 | 462 | <h3>SparkFun Electronics' preferred foot prints</h3> 463 | In this library you'll find resistors, capacitors, inductors, test points, jumper pads, etc.<br><br> 464 | We've spent an enormous amount of time creating and checking these footprints and parts, but it is the end user's responsibility to ensure correctness and suitablity for a given componet or application. If you enjoy using this library, please buy one of our products at www.sparkfun.com. 465 | <br><br> 466 | <b>Licensing:</b> CC v3.0 Share-Alike You are welcome to use this library for commercial purposes. For attribution, we ask that when you begin to sell your device using our footprint, you email us with a link to the product being sold. We want bragging rights that we helped (in a very small part) to create your 8th world wonder. We would like the opportunity to feature your device on our homepage. 467 | 468 | 469 | 470 | 471 | 472 | 473 | >NAME 474 | >VALUE 475 | 476 | 477 | 478 | 479 | 480 | 481 | 482 | 483 | 484 | 485 | 486 | 487 | 488 | 489 | 490 | 491 | 492 | 493 | 494 | 495 | 496 | 497 | 498 | 499 | 500 | 501 | 502 | 503 | 504 | 505 | 506 | 507 | 508 | 509 | 510 | 511 | 512 | 513 | 514 | 515 | 516 | 517 | 518 | 519 | 520 | 521 | 522 | 523 | 524 | 525 | 526 | 527 | 528 | 529 | 530 | 531 | 532 | 533 | 534 | 535 | 536 | 537 | 538 | >NAME 539 | >VALUE 540 | 541 | 542 | 543 | 544 | 545 | 546 | 547 | 548 | 549 | 550 | 551 | 552 | 553 | 554 | 555 | 556 | 557 | 558 | 559 | 560 | 561 | 562 | 563 | 564 | 565 | 566 | 567 | 568 | 569 | 570 | 571 | 572 | 573 | 574 | 575 | 576 | 577 | 578 | 579 | 580 | 581 | 582 | 583 | 584 | 585 | 586 | 587 | 588 | 589 | 590 | 3.2mm*5mm dimension <br> 591 | 8MHz available 592 | 593 | 594 | 595 | 596 | 597 | 598 | 599 | 600 | 601 | 602 | 603 | 604 | 605 | 606 | 607 | 608 | 609 | 610 | >NAME 611 | >VALUE 612 | 613 | 614 | 615 | 616 | 617 | 618 | 619 | <h3>SparkFun Electronics' preferred foot prints</h3> 620 | In this library you'll find anything that moves- switches, relays, buttons, potentiometers. Also, anything that goes on a board but isn't electrical in nature- screws, standoffs, etc.<br><br> 621 | We've spent an enormous amount of time creating and checking these footprints and parts, but it is the end user's responsibility to ensure correctness and suitablity for a given componet or application. If you enjoy using this library, please buy one of our products at www.sparkfun.com. 622 | <br><br> 623 | <b>Licensing:</b> Creative Commons ShareAlike 4.0 International - https://creativecommons.org/licenses/by-sa/4.0/ 624 | <br><br> 625 | You are welcome to use this library for commercial purposes. For attribution, we ask that when you begin to sell your device using our footprint, you email us with a link to the product being sold. We want bragging rights that we helped (in a very small part) to create your 8th world wonder. We would like the opportunity to feature your device on our homepage. 626 | 627 | 628 | 629 | 630 | 631 | 632 | 633 | 634 | 635 | >NAME 636 | >VALUE 637 | 638 | 639 | 640 | 641 | 642 | 643 | <b>CHIPLED</b><p> 644 | Source: http://www.osram.convergy.de/ ... LG_R971.pdf 645 | 646 | 647 | 648 | 649 | 650 | 651 | 652 | >NAME 653 | >VALUE 654 | 655 | 656 | 657 | 658 | 659 | 660 | 661 | 662 | 663 | 664 | 665 | 666 | 667 | 668 | 669 | 670 | 671 | 672 | 673 | 674 | 675 | 676 | 677 | 678 | 679 | 680 | <b>EAGLE Design Rules</b> 681 | <p> 682 | Die Standard-Design-Rules sind so gewählt, dass sie für 683 | die meisten Anwendungen passen. Sollte ihre Platine 684 | besondere Anforderungen haben, treffen Sie die erforderlichen 685 | Einstellungen hier und speichern die Design Rules unter 686 | einem neuen Namen ab. 687 | <b>EAGLE Design Rules</b> 688 | <p> 689 | The default Design Rules have been set to cover 690 | a wide range of applications. Your particular design 691 | may have different requirements, so please make the 692 | necessary adjustments and save your customized 693 | design rules under a new name. 694 | 695 | 696 | 697 | 698 | 699 | 700 | 701 | 702 | 703 | 704 | 705 | 706 | 707 | 708 | 709 | 710 | 711 | 712 | 713 | 714 | 715 | 716 | 717 | 718 | 719 | 720 | 721 | 722 | 723 | 724 | 725 | 726 | 727 | 728 | 729 | 730 | 731 | 732 | 733 | 734 | 735 | 736 | 737 | 738 | 739 | 740 | 741 | 742 | 743 | 744 | 745 | 746 | 747 | 748 | 749 | 750 | 751 | 752 | 753 | 754 | 755 | 756 | 757 | 758 | 759 | 760 | 761 | 762 | 763 | 764 | 765 | 766 | 767 | 768 | 769 | 770 | 771 | 772 | 773 | 774 | 775 | 776 | 777 | 778 | 779 | 780 | 781 | 782 | 783 | 784 | 785 | 786 | 787 | 788 | 789 | 790 | 791 | 792 | 793 | 794 | 795 | 796 | 797 | 798 | 799 | 800 | 801 | 802 | 803 | 804 | 805 | 806 | 807 | 808 | 809 | 810 | 811 | 812 | 813 | 814 | 815 | 816 | 817 | 818 | 819 | 820 | 821 | 822 | 823 | 824 | 825 | 826 | 827 | 828 | 829 | 830 | 831 | 832 | 833 | 834 | 835 | 836 | 837 | 838 | 839 | 840 | 841 | 842 | 843 | 844 | 845 | 846 | 847 | 848 | 849 | 850 | 851 | 852 | 853 | 854 | 855 | 856 | 857 | 858 | 859 | 860 | 861 | 862 | 863 | 864 | 865 | 866 | 867 | 868 | 869 | 870 | 871 | 872 | 873 | 874 | 875 | 876 | 877 | 878 | 879 | 880 | 881 | 882 | 883 | 884 | 885 | 886 | 887 | 888 | 889 | 890 | 891 | 892 | 893 | 894 | 895 | 896 | 897 | 898 | 899 | 900 | 901 | 902 | 903 | 904 | 905 | 906 | 907 | 908 | 909 | 910 | 911 | 912 | 913 | 914 | 915 | 916 | 917 | 918 | 919 | 920 | 921 | 922 | 923 | 924 | 925 | 926 | 927 | 928 | 929 | 930 | 931 | 932 | 933 | 934 | 935 | 936 | 937 | 938 | 939 | 940 | 941 | 942 | 943 | 944 | 945 | 946 | 947 | 948 | 949 | 950 | 951 | 952 | 953 | 954 | 955 | 956 | 957 | 958 | 959 | 960 | 961 | 962 | 963 | 964 | 965 | 966 | 967 | 968 | 969 | 970 | 971 | 972 | 973 | 974 | 975 | 976 | 977 | 978 | 979 | 980 | 981 | 982 | 983 | 984 | 985 | 986 | 987 | 988 | 989 | 990 | 991 | 992 | 993 | 994 | 995 | 996 | 997 | 998 | 999 | 1000 | 1001 | 1002 | 1003 | 1004 | 1005 | 1006 | 1007 | 1008 | 1009 | 1010 | 1011 | 1012 | 1013 | 1014 | 1015 | 1016 | 1017 | 1018 | 1019 | 1020 | 1021 | 1022 | 1023 | 1024 | 1025 | 1026 | 1027 | 1028 | 1029 | 1030 | 1031 | 1032 | 1033 | 1034 | 1035 | 1036 | 1037 | 1038 | 1039 | 1040 | 1041 | 1042 | 1043 | 1044 | 1045 | 1046 | 1047 | 1048 | 1049 | 1050 | 1051 | 1052 | 1053 | 1054 | 1055 | 1056 | 1057 | 1058 | 1059 | 1060 | 1061 | 1062 | 1063 | 1064 | 1065 | 1066 | 1067 | 1068 | 1069 | 1070 | 1071 | 1072 | 1073 | 1074 | 1075 | 1076 | 1077 | 1078 | 1079 | 1080 | 1081 | 1082 | 1083 | 1084 | 1085 | 1086 | 1087 | 1088 | 1089 | 1090 | 1091 | 1092 | 1093 | 1094 | 1095 | 1096 | 1097 | 1098 | 1099 | 1100 | 1101 | 1102 | 1103 | 1104 | 1105 | 1106 | 1107 | 1108 | 1109 | 1110 | 1111 | 1112 | 1113 | 1114 | 1115 | 1116 | 1117 | 1118 | 1119 | 1120 | 1121 | 1122 | 1123 | 1124 | 1125 | 1126 | 1127 | 1128 | 1129 | 1130 | 1131 | 1132 | 1133 | 1134 | 1135 | 1136 | 1137 | 1138 | 1139 | 1140 | 1141 | 1142 | 1143 | 1144 | 1145 | 1146 | 1147 | 1148 | 1149 | 1150 | 1151 | 1152 | 1153 | 1154 | 1155 | 1156 | 1157 | 1158 | 1159 | 1160 | 1161 | 1162 | 1163 | 1164 | 1165 | 1166 | 1167 | 1168 | 1169 | 1170 | 1171 | 1172 | 1173 | 1174 | 1175 | 1176 | 1177 | 1178 | 1179 | 1180 | 1181 | 1182 | 1183 | 1184 | 1185 | 1186 | 1187 | 1188 | 1189 | 1190 | 1191 | 1192 | 1193 | 1194 | 1195 | 1196 | 1197 | 1198 | 1199 | 1200 | 1201 | 1202 | 1203 | 1204 | 1205 | 1206 | 1207 | 1208 | 1209 | 1210 | 1211 | 1212 | 1213 | 1214 | 1215 | 1216 | 1217 | 1218 | 1219 | 1220 | 1221 | 1222 | 1223 | 1224 | 1225 | 1226 | 1227 | 1228 | 1229 | 1230 | 1231 | 1232 | 1233 | 1234 | 1235 | 1236 | 1237 | 1238 | 1239 | 1240 | 1241 | 1242 | 1243 | 1244 | 1245 | 1246 | 1247 | 1248 | 1249 | 1250 | 1251 | 1252 | 1253 | 1254 | 1255 | 1256 | 1257 | 1258 | 1259 | 1260 | 1261 | 1262 | 1263 | 1264 | 1265 | 1266 | 1267 | 1268 | 1269 | 1270 | 1271 | 1272 | 1273 | 1274 | 1275 | 1276 | 1277 | 1278 | 1279 | 1280 | 1281 | 1282 | 1283 | 1284 | 1285 | 1286 | 1287 | 1288 | 1289 | 1290 | 1291 | 1292 | 1293 | 1294 | 1295 | 1296 | 1297 | 1298 | 1299 | 1300 | 1301 | 1302 | 1303 | 1304 | 1305 | 1306 | 1307 | 1308 | 1309 | 1310 | 1311 | 1312 | 1313 | 1314 | 1315 | 1316 | 1317 | 1318 | 1319 | 1320 | 1321 | 1322 | 1323 | 1324 | 1325 | 1326 | 1327 | 1328 | 1329 | 1330 | 1331 | 1332 | 1333 | 1334 | 1335 | 1336 | 1337 | 1338 | 1339 | 1340 | 1341 | 1342 | 1343 | 1344 | 1345 | 1346 | 1347 | 1348 | 1349 | 1350 | 1351 | 1352 | 1353 | 1354 | 1355 | 1356 | 1357 | 1358 | 1359 | 1360 | 1361 | 1362 | 1363 | 1364 | 1365 | 1366 | 1367 | 1368 | 1369 | 1370 | 1371 | 1372 | 1373 | 1374 | 1375 | 1376 | 1377 | 1378 | 1379 | 1380 | 1381 | 1382 | 1383 | 1384 | 1385 | 1386 | 1387 | 1388 | 1389 | 1390 | 1391 | 1392 | 1393 | 1394 | 1395 | 1396 | 1397 | 1398 | 1399 | 1400 | 1401 | 1402 | 1403 | 1404 | 1405 | 1406 | 1407 | 1408 | 1409 | 1410 | 1411 | 1412 | 1413 | 1414 | 1415 | 1416 | 1417 | 1418 | 1419 | 1420 | 1421 | 1422 | 1423 | 1424 | 1425 | 1426 | 1427 | 1428 | 1429 | 1430 | 1431 | 1432 | 1433 | 1434 | 1435 | 1436 | 1437 | 1438 | 1439 | 1440 | 1441 | 1442 | 1443 | 1444 | 1445 | 1446 | 1447 | -------------------------------------------------------------------------------- /TinyLispComputer.ino: -------------------------------------------------------------------------------- 1 | /* Tiny Lisp Computer 2 - uLisp 1.5 2 | David Johnson-Davies - www.technoblogy.com - 24th January 2017 3 | 4 | Licensed under the MIT license: https://opensource.org/licenses/MIT 5 | */ 6 | 7 | #include 8 | #include 9 | 10 | // Compile options 11 | 12 | #define checkoverflow 13 | #define resetautorun 14 | // #define printfreespace 15 | #define serialmonitor 16 | #define tinylispcomputer 17 | 18 | // C Macros 19 | 20 | #define nil NULL 21 | #define car(x) (((object *) (x))->car) 22 | #define cdr(x) (((object *) (x))->cdr) 23 | 24 | #define first(x) (((object *) (x))->car) 25 | #define second(x) (car(cdr(x))) 26 | #define cddr(x) (cdr(cdr(x))) 27 | #define third(x) (car(cdr(cdr(x)))) 28 | #define fourth(x) (car(cdr(cdr(cdr(x))))) 29 | 30 | #define push(x, y) ((y) = cons((x),(y))) 31 | #define pop(y) ((y) = cdr(y)) 32 | 33 | #define numberp(x) ((x)->type == NUMBER) 34 | #define stringp(x) ((x)->type == STRING) 35 | #define streamp(x) ((x)->type == STREAM) 36 | #define listp(x) ((x) == NULL || (x)->type >= PAIR || (x)->type == ZERO) 37 | #define consp(x) (((x)->type >= PAIR || (x)->type == ZERO) && (x) != NULL) 38 | 39 | #define mark(x) (car(x) = (object *)(((unsigned int)(car(x))) | 0x8000)) 40 | #define unmark(x) (car(x) = (object *)(((unsigned int)(car(x))) & 0x7FFF)) 41 | #define marked(x) ((((unsigned int)(car(x))) & 0x8000) != 0) 42 | 43 | // 1:Show GCs 2:show symbol addresses 44 | // #define debug1 45 | // #define debug2 46 | 47 | // Constants 48 | // RAMSTART, RAMEND, and E2END are defined by the processor's ioxxx.h file 49 | 50 | const int RAMsize = RAMEND - RAMSTART + 1; 51 | const int workspacesize = (RAMsize - RAMsize/4 - 280)/4; 52 | const int EEPROMsize = E2END; 53 | 54 | const int buflen = 17; // Length of longest symbol + 1 55 | enum type {ZERO, SYMBOL, NUMBER, STRING, STREAM, PAIR }; // PAIR must be last 56 | enum token { UNUSED, BRA, KET, QUO, DOT }; 57 | enum stream { SERIALSTREAM, I2CSTREAM, SPISTREAM }; 58 | 59 | enum function { SYMBOLS, NIL, TEE, LAMBDA, LET, LETSTAR, CLOSURE, SPECIAL_FORMS, QUOTE, DEFUN, DEFVAR, 60 | SETQ, LOOP, PUSH, POP, INCF, DECF, SETF, DOLIST, DOTIMES, FORMILLIS, WITHI2C, WITHSPI, TAIL_FORMS, PROGN, 61 | RETURN, IF, COND, WHEN, UNLESS, AND, OR, FUNCTIONS, NOT, NULLFN, CONS, ATOM, LISTP, CONSP, NUMBERP, 62 | STREAMP, EQ, CAR, FIRST, CDR, REST, CAAR, CADR, SECOND, CDAR, CDDR, CAAAR, CAADR, CADAR, CADDR, THIRD, 63 | CDAAR, CDADR, CDDAR, CDDDR, LENGTH, LIST, REVERSE, NTH, ASSOC, MEMBER, APPLY, FUNCALL, APPEND, MAPC, 64 | MAPCAR, ADD, SUBTRACT, MULTIPLY, DIVIDE, MOD, ONEPLUS, ONEMINUS, ABS, RANDOM, MAX, MIN, NUMEQ, LESS, 65 | LESSEQ, GREATER, GREATEREQ, NOTEQ, PLUSP, MINUSP, ZEROP, ODDP, EVENP, STRINGP, STRINGEQ, SUBSEQ, LOGAND, 66 | LOGIOR, LOGXOR, LOGNOT, ASH, LOGBITP, READ, EVAL, GLOBALS, LOCALS, MAKUNBOUND, BREAK, PRINT, PRINC, 67 | WRITEBYTE, READBYTE, RESTARTI2C, GC, ROOM, SAVEIMAGE, LOADIMAGE, CLS, PINMODE, DIGITALREAD, DIGITALWRITE, 68 | ANALOGREAD, ANALOGWRITE, DELAY, MILLIS, NOTE, EDIT, ENDFUNCTIONS }; 69 | 70 | // Typedefs 71 | 72 | typedef struct sobject { 73 | union { 74 | struct { 75 | sobject *car; 76 | sobject *cdr; 77 | }; 78 | struct { 79 | enum type type; 80 | union { 81 | unsigned int name; 82 | int integer; 83 | }; 84 | }; 85 | }; 86 | } object; 87 | 88 | typedef object *(*fn_ptr_type)(object *, object *); 89 | 90 | typedef struct { 91 | const char *string; 92 | fn_ptr_type fptr; 93 | int min; 94 | int max; 95 | } tbl_entry_t; 96 | 97 | // Global variables 98 | 99 | jmp_buf exception; 100 | object workspace[workspacesize]; 101 | unsigned int freespace = 0; 102 | char ReturnFlag = 0; 103 | object *freelist; 104 | extern uint8_t _end; 105 | int i2cCount; 106 | 107 | object *GlobalEnv; 108 | object *GCStack = NULL; 109 | char buffer[buflen+1]; 110 | char BreakLevel = 0; 111 | char LastChar = 0; 112 | char LastPrint = 0; 113 | volatile char Escape = 0; 114 | char ExitEditor = 0; 115 | char PrintReadably = 1; 116 | 117 | // Forward references 118 | object *tee; 119 | object *tf_progn (object *form, object *env); 120 | object *eval (object *form, object *env); 121 | object *read (); 122 | void repl(object *env); 123 | void printobject (object *form); 124 | char *lookupstring (unsigned int name); 125 | int lookupfn (unsigned int name); 126 | int builtin (char* n); 127 | void Display (char c); 128 | 129 | // Set up workspace 130 | 131 | void initworkspace () { 132 | freelist = NULL; 133 | for (int i=workspacesize-1; i>=0; i--) { 134 | object *obj = &workspace[i]; 135 | car(obj) = NULL; 136 | cdr(obj) = freelist; 137 | freelist = obj; 138 | freespace++; 139 | } 140 | } 141 | 142 | object *myalloc () { 143 | if (freespace == 0) error(F("No room")); 144 | object *temp = freelist; 145 | freelist = cdr(freelist); 146 | freespace--; 147 | return temp; 148 | } 149 | 150 | inline void myfree (object *obj) { 151 | car(obj) = NULL; 152 | cdr(obj) = freelist; 153 | freelist = obj; 154 | freespace++; 155 | } 156 | 157 | // Make each type of object 158 | 159 | object *number (int n) { 160 | object *ptr = myalloc(); 161 | ptr->type = NUMBER; 162 | ptr->integer = n; 163 | return ptr; 164 | } 165 | 166 | object *cons (object *arg1, object *arg2) { 167 | object *ptr = myalloc(); 168 | ptr->car = arg1; 169 | ptr->cdr = arg2; 170 | return ptr; 171 | } 172 | 173 | object *symbol (unsigned int name) { 174 | object *ptr = myalloc(); 175 | ptr->type = SYMBOL; 176 | ptr->name = name; 177 | return ptr; 178 | } 179 | 180 | object *stream (unsigned char streamtype, unsigned char address) { 181 | object *ptr = myalloc(); 182 | ptr->type = STREAM; 183 | ptr->integer = streamtype<<8 | address; 184 | return ptr; 185 | } 186 | 187 | // Garbage collection 188 | 189 | void markobject (object *obj) { 190 | MARK: 191 | if (obj == NULL) return; 192 | if (marked(obj)) return; 193 | 194 | object* arg = car(obj); 195 | int type = obj->type; 196 | mark(obj); 197 | 198 | if (type >= PAIR || type == ZERO) { // cons 199 | markobject(arg); 200 | obj = cdr(obj); 201 | goto MARK; 202 | } 203 | 204 | if (type == STRING) { 205 | obj = cdr(obj); 206 | while (obj != NULL) { 207 | arg = car(obj); 208 | mark(obj); 209 | obj = arg; 210 | } 211 | } 212 | } 213 | 214 | void sweep () { 215 | freelist = NULL; 216 | freespace = 0; 217 | for (int i=workspacesize-1; i>=0; i--) { 218 | object *obj = &workspace[i]; 219 | if (!marked(obj)) myfree(obj); else unmark(obj); 220 | } 221 | } 222 | 223 | void gc (object *form, object *env) { 224 | #if defined(debug1) 225 | int start = freespace; 226 | #endif 227 | markobject(tee); 228 | markobject(GlobalEnv); 229 | markobject(GCStack); 230 | markobject(form); 231 | markobject(env); 232 | sweep(); 233 | #if defined(debug1) 234 | pchar('{'); 235 | pint(freespace - start); 236 | pchar('}'); 237 | #endif 238 | } 239 | 240 | // Save-image and load-image 241 | 242 | typedef struct { 243 | unsigned int eval; 244 | unsigned int datasize; 245 | unsigned int globalenv; 246 | unsigned int tee; 247 | char data[]; 248 | } struct_image; 249 | 250 | struct_image EEMEM image; 251 | 252 | void movepointer (object *from, object *to) { 253 | for (int i=0; itype) & 0x7FFF; 256 | if (marked(obj) && type >= PAIR) { 257 | if (car(obj) == (object *)((unsigned int)from | 0x8000)) 258 | car(obj) = (object *)((unsigned int)to | 0x8000); 259 | if (cdr(obj) == from) cdr(obj) = to; 260 | } 261 | } 262 | } 263 | 264 | int compactimage (object **arg) { 265 | markobject(tee); 266 | markobject(GlobalEnv); 267 | markobject(GCStack); 268 | object *firstfree = workspace; 269 | while (marked(firstfree)) firstfree++; 270 | 271 | for (int i=0; i EEPROMsize) { 293 | pfstring(F("Error: Image size too large: ")); 294 | pint(imagesize+2); pln(); 295 | GCStack = NULL; 296 | longjmp(exception, 1); 297 | } 298 | eeprom_write_word(&image.datasize, imagesize); 299 | eeprom_write_word(&image.eval, (unsigned int)arg); 300 | eeprom_write_word(&image.globalenv, (unsigned int)GlobalEnv); 301 | eeprom_write_word(&image.tee, (unsigned int)tee); 302 | eeprom_write_block(workspace, image.data, imagesize*4); 303 | return imagesize+2; 304 | } 305 | 306 | int loadimage () { 307 | unsigned int imagesize = eeprom_read_word(&image.datasize); 308 | if (imagesize == 0 || imagesize == 0xFFFF) error(F("No saved image")); 309 | GlobalEnv = (object *)eeprom_read_word(&image.globalenv); 310 | tee = (object *)eeprom_read_word(&image.tee) ; 311 | eeprom_read_block(workspace, image.data, imagesize*4); 312 | gc(NULL, NULL); 313 | return imagesize+2; 314 | } 315 | 316 | // Error handling 317 | 318 | void error (const __FlashStringHelper *string) { 319 | pfstring(F("Error: ")); 320 | pfstring(string); pln(); 321 | GCStack = NULL; 322 | longjmp(exception, 1); 323 | } 324 | 325 | void error2 (object *symbol, const __FlashStringHelper *string) { 326 | pfstring(F("Error: '")); 327 | printobject(symbol); 328 | pfstring(F("' ")); 329 | pfstring(string); pln(); 330 | GCStack = NULL; 331 | longjmp(exception, 1); 332 | } 333 | 334 | // Helper functions 335 | 336 | int toradix40 (int ch) { 337 | if (ch == 0) return 0; 338 | if (ch >= '0' && ch <= '9') return ch-'0'+30; 339 | ch = ch | 0x20; 340 | if (ch >= 'a' && ch <= 'z') return ch-'a'+1; 341 | error(F("Illegal character in symbol")); 342 | return 0; 343 | } 344 | 345 | int fromradix40 (int n) { 346 | if (n >= 1 && n <= 26) return 'a'+n-1; 347 | if (n >= 30 && n <= 39) return '0'+n-30; 348 | if (n == 27) return '-'; 349 | return 0; 350 | } 351 | 352 | int pack40 (char *buffer) { 353 | return (((toradix40(buffer[0]) * 40) + toradix40(buffer[1])) * 40 + toradix40(buffer[2])); 354 | } 355 | 356 | int digitvalue (char d) { 357 | if (d>='0' && d<='9') return d-'0'; 358 | d = d | 0x20; 359 | if (d>='a' && d<='f') return d-'a'+10; 360 | return 16; 361 | } 362 | 363 | char *name(object *obj){ 364 | buffer[3] = '\0'; 365 | if(obj->type != SYMBOL) error(F("Error in name")); 366 | unsigned int x = obj->name; 367 | if (x < ENDFUNCTIONS) return lookupstring(x); 368 | for (int n=2; n>=0; n--) { 369 | buffer[n] = fromradix40(x % 40); 370 | x = x / 40; 371 | } 372 | return buffer; 373 | } 374 | 375 | int integer(object *obj){ 376 | if(obj->type != NUMBER) error(F("not a number")); 377 | return obj->integer; 378 | } 379 | 380 | int istream(object *obj){ 381 | if(obj->type != STREAM) error(F("not a stream")); 382 | return obj->integer; 383 | } 384 | 385 | int issymbol(object *obj, unsigned int n) { 386 | return obj->type == SYMBOL && obj->name == n; 387 | } 388 | 389 | int eq (object *arg1, object *arg2) { 390 | int same_object = (arg1 == arg2); 391 | int same_symbol = (arg1->type == SYMBOL && arg2->type == SYMBOL && arg1->name == arg2->name); 392 | int same_number = (arg1->type == NUMBER && arg2->type == NUMBER && arg1->integer == arg2->integer); 393 | return (same_object || same_symbol || same_number); 394 | } 395 | 396 | // Lookup variable in environment 397 | 398 | object *value(unsigned int n, object *env) { 399 | while (env != NULL) { 400 | object *item = car(env); 401 | if(car(item)->name == n) return item; 402 | env = cdr(env); 403 | } 404 | return nil; 405 | } 406 | 407 | object *findvalue (object *var, object *env) { 408 | unsigned int varname = var->name; 409 | object *pair = value(varname, env); 410 | if (pair == NULL) pair = value(varname, GlobalEnv); 411 | if (pair == NULL) error2(var,F("unknown variable")); 412 | return pair; 413 | } 414 | 415 | object *findtwin (object *var, object *env) { 416 | while (env != NULL) { 417 | object *pair = car(env); 418 | if (car(pair) == var) return pair; 419 | env = cdr(env); 420 | } 421 | return NULL; 422 | } 423 | 424 | object *closure (int tail, object *fname, object *state, object *function, object *args, object **env) { 425 | object *params = first(function); 426 | function = cdr(function); 427 | // Push state if not already in env 428 | while (state != NULL) { 429 | object *pair = first(state); 430 | if (findtwin(car(pair), *env) == NULL) push(first(state), *env); 431 | state = cdr(state); 432 | } 433 | // Add arguments to environment 434 | while (params != NULL && args != NULL) { 435 | object *var = first(params); 436 | object *value = first(args); 437 | if (tail) { 438 | object *pair = findtwin(var, *env); 439 | if (pair != NULL) cdr(pair) = value; 440 | else push(cons(var,value), *env); 441 | } else push(cons(var,value), *env); 442 | params = cdr(params); 443 | args = cdr(args); 444 | } 445 | if (params != NULL) error2(fname, F("has too few parameters")); 446 | if (args != NULL) error2(fname, F("has too many parameters")); 447 | // Do an implicit progn 448 | return tf_progn(function, *env); 449 | } 450 | 451 | inline int listlength (object *list) { 452 | int length = 0; 453 | while (list != NULL) { 454 | list = cdr(list); 455 | length++; 456 | } 457 | return length; 458 | } 459 | 460 | inline int stringlength (object *form) { 461 | int length = 0; 462 | form = cdr(form); 463 | while (form != NULL) { 464 | int chars = form->integer; 465 | if (chars & 0xFF) length++; 466 | if (chars & 0xFF00) length++; 467 | form = car(form); 468 | } 469 | return length; 470 | } 471 | 472 | char character (object *string, int n) { 473 | object *arg = cdr(string); 474 | for (int i=0; i<(n>>1); i++) { 475 | if (arg == NULL) error(F("'subseq' index out of range")); 476 | arg = car(arg); 477 | } 478 | char ch; 479 | if (n&1) ch = (arg->integer) & 0xFF; else ch = (arg->integer)>>8 & 0xFF; 480 | if (ch == 0) error(F("'subseq' index out of range")); 481 | return ch; 482 | } 483 | 484 | object *apply (object *function, object *args, object **env) { 485 | if (function->type == SYMBOL) { 486 | unsigned int name = function->name; 487 | int nargs = listlength(args); 488 | if (name >= ENDFUNCTIONS) error2(function, F("is not a function")); 489 | if (nargslookupmax(name)) error2(function, F("has too many arguments")); 491 | return ((fn_ptr_type)lookupfn(name))(args, *env); 492 | } 493 | if (listp(function) && issymbol(car(function), LAMBDA)) { 494 | function = cdr(function); 495 | object *result = closure(1, NULL, NULL, function, args, env); 496 | return eval(result, *env); 497 | } 498 | if (listp(function) && issymbol(car(function), CLOSURE)) { 499 | function = cdr(function); 500 | object *result = closure(1, NULL, car(function), cdr(function), args, env); 501 | return eval(result, *env); 502 | } 503 | error2(function, F("illegal function")); 504 | return NULL; 505 | } 506 | 507 | // In-place operations 508 | 509 | object **place (object *args, object *env) { 510 | if (!consp(args)) return &cdr(findvalue(args, env)); 511 | object* function = first(args); 512 | if (issymbol(function, CAR) || issymbol(function, FIRST)) { 513 | object *value = eval(second(args), env); 514 | if (!listp(value)) error(F("Can't take car")); 515 | return &car(value); 516 | } 517 | if (issymbol(function, CDR) || issymbol(function, REST)) { 518 | object *value = eval(second(args), env); 519 | if (!listp(value)) error(F("Can't take cdr")); 520 | return &cdr(value); 521 | } 522 | if (issymbol(function, NTH)) { 523 | int index = integer(eval(second(args), env)); 524 | object *list = eval(third(args), env); 525 | if (!consp(list)) error(F("'nth' second argument is not a list")); 526 | while (index > 0) { 527 | list = cdr(list); 528 | if (list == NULL) error(F("'nth' index out of range")); 529 | index--; 530 | } 531 | return &car(list); 532 | } 533 | error(F("Illegal place")); 534 | return nil; 535 | } 536 | 537 | // Checked car and cdr 538 | 539 | inline object *carx (object *arg) { 540 | if (!listp(arg)) error(F("Can't take car")); 541 | if (arg == nil) return nil; 542 | return car(arg); 543 | } 544 | 545 | inline object *cdrx (object *arg) { 546 | if (!listp(arg)) error(F("Can't take cdr")); 547 | if (arg == nil) return nil; 548 | return cdr(arg); 549 | } 550 | 551 | // I2C interface 552 | 553 | #if defined(__AVR_ATmega328P__) 554 | uint8_t const TWI_SDA_PIN = 18; 555 | uint8_t const TWI_SCL_PIN = 19; 556 | #elif defined(__AVR_ATmega1280__) || defined(__AVR_ATmega2560__) 557 | uint8_t const TWI_SDA_PIN = 20; 558 | uint8_t const TWI_SCL_PIN = 21; 559 | #elif defined(__AVR_ATmega644P__) || defined(__AVR_ATmega1284P__) 560 | uint8_t const TWI_SDA_PIN = 17; 561 | uint8_t const TWI_SCL_PIN = 16; 562 | #elif defined(__AVR_ATmega32U4__) 563 | uint8_t const TWI_SDA_PIN = 6; 564 | uint8_t const TWI_SCL_PIN = 5; 565 | #endif 566 | 567 | uint32_t const F_TWI = 400000L; // Hardware I2C clock in Hz 568 | uint8_t const TWSR_MTX_DATA_ACK = 0x28; 569 | uint8_t const TWSR_MTX_ADR_ACK = 0x18; 570 | uint8_t const TWSR_MRX_ADR_ACK = 0x40; 571 | uint8_t const TWSR_START = 0x08; 572 | uint8_t const TWSR_REP_START = 0x10; 573 | uint8_t const I2C_READ = 1; 574 | uint8_t const I2C_WRITE = 0; 575 | 576 | void I2Cinit(bool enablePullup) { 577 | TWSR = 0; // no prescaler 578 | TWBR = (F_CPU/F_TWI - 16)/2; // set bit rate factor 579 | if (enablePullup) { 580 | digitalWrite(TWI_SDA_PIN, HIGH); 581 | digitalWrite(TWI_SCL_PIN, HIGH); 582 | } 583 | } 584 | 585 | uint8_t I2Cread(uint8_t last) { 586 | TWCR = 1<type != SYMBOL) error2(var, F("is not a symbol")); 629 | object *val = cons(symbol(LAMBDA), cdr(args)); 630 | object *pair = value(var->name,GlobalEnv); 631 | if (pair != NULL) { cdr(pair) = val; return var; } 632 | push(cons(var, val), GlobalEnv); 633 | return var; 634 | } 635 | 636 | object *sp_defvar (object *args, object *env) { 637 | object *var = first(args); 638 | if (var->type != SYMBOL) error2(var, F("is not a symbol")); 639 | object *val = eval(second(args), env); 640 | object *pair = value(var->name,GlobalEnv); 641 | if (pair != NULL) { cdr(pair) = val; return var; } 642 | push(cons(var, val), GlobalEnv); 643 | return var; 644 | } 645 | 646 | object *sp_setq (object *args, object *env) { 647 | object *arg = eval(second(args), env); 648 | object *pair = findvalue(first(args), env); 649 | cdr(pair) = arg; 650 | return arg; 651 | } 652 | 653 | object *sp_loop (object *args, object *env) { 654 | ReturnFlag = 0; 655 | object *start = args; 656 | for (;;) { 657 | args = start; 658 | while (args != NULL) { 659 | object *form = car(args); 660 | object *result = eval(form,env); 661 | if (ReturnFlag == 1) { 662 | ReturnFlag = 0; 663 | return result; 664 | } 665 | args = cdr(args); 666 | } 667 | } 668 | } 669 | 670 | object *sp_push (object *args, object *env) { 671 | object *item = eval(first(args), env); 672 | object **loc = place(second(args), env); 673 | push(item, *loc); 674 | return *loc; 675 | } 676 | 677 | object *sp_pop (object *args, object *env) { 678 | object **loc = place(first(args), env); 679 | object *result = car(*loc); 680 | pop(*loc); 681 | return result; 682 | } 683 | 684 | object *sp_incf (object *args, object *env) { 685 | object **loc = place(first(args), env); 686 | int increment = 1; 687 | int result = integer(*loc); 688 | args = cdr(args); 689 | if (args != NULL) increment = integer(eval(first(args), env)); 690 | #if defined(checkoverflow) 691 | if (increment < 1) { if (-32768 - increment > result) error(F("'incf' arithmetic overflow")); } 692 | else { if (32767 - increment < result) error(F("'incf' arithmetic overflow")); } 693 | #endif 694 | result = result + increment; 695 | *loc = number(result); 696 | return *loc; 697 | } 698 | 699 | object *sp_decf (object *args, object *env) { 700 | object **loc = place(first(args), env); 701 | int decrement = 1; 702 | int result = integer(*loc); 703 | args = cdr(args); 704 | if (args != NULL) decrement = integer(eval(first(args), env)); 705 | #if defined(checkoverflow) 706 | if (decrement < 1) { if (32767 + decrement < result) error(F("'decf' arithmetic overflow")); } 707 | else { if (-32768 + decrement > result) error(F("'decf' arithmetic overflow")); } 708 | #endif 709 | result = result - decrement; 710 | *loc = number(result); 711 | return *loc; 712 | } 713 | 714 | object *sp_setf (object *args, object *env) { 715 | object **loc = place(first(args), env); 716 | object *result = eval(second(args), env); 717 | *loc = result; 718 | return result; 719 | } 720 | 721 | object *sp_dolist (object *args, object *env) { 722 | object *params = first(args); 723 | object *var = first(params); 724 | object *result = nil; 725 | object *list = eval(second(params), env); 726 | if (!listp(list)) error(F("'dolist' argument is not a list")); 727 | push(list, GCStack); // Don't GC the list 728 | object *pair = cons(var,nil); 729 | push(pair,env); 730 | params = cdr(cdr(params)); 731 | if (params != NULL) result = car(params); 732 | object *forms = cdr(args); 733 | while (list != NULL) { 734 | cdr(pair) = first(list); 735 | list = cdr(list); 736 | eval(tf_progn(forms,env), env); 737 | } 738 | cdr(pair) = nil; 739 | pop(GCStack); 740 | return eval(result, env); 741 | } 742 | 743 | object *sp_dotimes (object *args, object *env) { 744 | object *params = first(args); 745 | object *var = first(params); 746 | object *result = nil; 747 | int count = integer(eval(second(params), env)); 748 | int index = 0; 749 | params = cdr(cdr(params)); 750 | if (params != NULL) result = car(params); 751 | object *pair = cons(var,number(0)); 752 | push(pair,env); 753 | object *forms = cdr(args); 754 | while (index < count) { 755 | cdr(pair) = number(index); 756 | index++; 757 | eval(tf_progn(forms,env), env); 758 | } 759 | cdr(pair) = number(index); 760 | return eval(result, env); 761 | } 762 | 763 | object *sp_formillis (object *args, object *env) { 764 | object *param = first(args); 765 | unsigned long start = millis(); 766 | unsigned long now, total = 0; 767 | if (param != NULL) total = integer(first(param)); 768 | eval(tf_progn(cdr(args),env), env); 769 | do now = millis() - start; while (now < total); 770 | if (now <= 32767) return number(now); 771 | return nil; 772 | } 773 | 774 | object *sp_withi2c (object *args, object *env) { 775 | object *params = first(args); 776 | object *var = first(params); 777 | int address = integer(eval(second(params), env)); 778 | params = cddr(params); 779 | int read = 0; // Write 780 | i2cCount = 0; 781 | if (params != NULL) { 782 | object *rw = eval(first(params), env); 783 | if (numberp(rw)) i2cCount = integer(rw); 784 | read = (rw != NULL); 785 | } 786 | I2Cinit(1); // Pullups 787 | object *pair = cons(var, (I2Cstart(address<<1 | read)) ? stream(I2CSTREAM, address) : nil); 788 | push(pair,env); 789 | object *forms = cdr(args); 790 | object *result = eval(tf_progn(forms,env), env); 791 | I2Cstop(); 792 | return result; 793 | } 794 | 795 | object *sp_withspi (object *args, object *env) { 796 | object *params = first(args); 797 | object *var = first(params); 798 | int pin = integer(eval(second(params), env)); 799 | int divider = 0, mode = 0, bitorder = 1; 800 | object *pair = cons(var, stream(SPISTREAM, pin)); 801 | push(pair,env); 802 | SPI.begin(); 803 | params = cddr(params); 804 | if (params != NULL) { 805 | int d = integer(eval(first(params), env)); 806 | if (d<1 || d>7) error(F("'with-spi' invalid divider")); 807 | if (d == 7) divider = 3; 808 | else if (d & 1) divider = (d>>1) + 4; 809 | else divider = (d>>1) - 1; 810 | params = cdr(params); 811 | if (params != NULL) { 812 | bitorder = (eval(first(params), env) == NULL); 813 | params = cdr(params); 814 | if (params != NULL) mode = integer(eval(first(params), env)); 815 | } 816 | } 817 | pinMode(pin, OUTPUT); 818 | digitalWrite(pin, LOW); 819 | SPI.setBitOrder(bitorder); 820 | SPI.setClockDivider(divider); 821 | SPI.setDataMode(mode); 822 | object *forms = cdr(args); 823 | object *result = eval(tf_progn(forms,env), env); 824 | digitalWrite(pin, HIGH); 825 | SPI.end(); 826 | return result; 827 | } 828 | 829 | // Tail-recursive forms 830 | 831 | object *tf_progn (object *args, object *env) { 832 | if (args == NULL) return nil; 833 | object *more = cdr(args); 834 | while (more != NULL) { 835 | eval(car(args), env); 836 | args = more; 837 | more = cdr(args); 838 | } 839 | return car(args); 840 | } 841 | 842 | object *tf_return (object *args, object *env) { 843 | ReturnFlag = 1; 844 | return tf_progn(args, env); 845 | } 846 | 847 | object *tf_if (object *args, object *env) { 848 | if (eval(first(args), env) != nil) return second(args); 849 | return third(args); 850 | } 851 | 852 | object *tf_cond (object *args, object *env) { 853 | while (args != NULL) { 854 | object *clause = first(args); 855 | object *test = eval(first(clause), env); 856 | object *forms = cdr(clause); 857 | if (test != nil) { 858 | if (forms == NULL) return test; else return tf_progn(forms, env); 859 | } 860 | args = cdr(args); 861 | } 862 | return nil; 863 | } 864 | 865 | object *tf_when (object *args, object *env) { 866 | if (eval(first(args), env) != nil) return tf_progn(cdr(args),env); 867 | else return nil; 868 | } 869 | 870 | object *tf_unless (object *args, object *env) { 871 | if (eval(first(args), env) != nil) return nil; 872 | else return tf_progn(cdr(args),env); 873 | } 874 | 875 | object *tf_and (object *args, object *env) { 876 | if (args == NULL) return tee; 877 | object *more = cdr(args); 878 | while (more != NULL) { 879 | if (eval(car(args), env) == NULL) return nil; 880 | args = more; 881 | more = cdr(args); 882 | } 883 | return car(args); 884 | } 885 | 886 | object *tf_or (object *args, object *env) { 887 | object *more = cdr(args); 888 | while (more != NULL) { 889 | object *result = eval(car(args), env); 890 | if (result != NULL) return result; 891 | args = more; 892 | more = cdr(args); 893 | } 894 | return car(args); 895 | } 896 | 897 | // Core functions 898 | 899 | object *fn_not (object *args, object *env) { 900 | (void) env; 901 | return (first(args) == nil) ? tee : nil; 902 | } 903 | 904 | object *fn_cons (object *args, object *env) { 905 | (void) env; 906 | return cons(first(args),second(args)); 907 | } 908 | 909 | object *fn_atom (object *args, object *env) { 910 | (void) env; 911 | object *arg1 = first(args); 912 | return consp(arg1) ? nil : tee; 913 | } 914 | 915 | object *fn_listp (object *args, object *env) { 916 | (void) env; 917 | object *arg1 = first(args); 918 | return listp(arg1) ? tee : nil; 919 | } 920 | 921 | object *fn_consp (object *args, object *env) { 922 | (void) env; 923 | object *arg1 = first(args); 924 | return consp(arg1) ? tee : nil; 925 | } 926 | 927 | object *fn_numberp (object *args, object *env) { 928 | (void) env; 929 | object *arg1 = first(args); 930 | return numberp(arg1) ? tee : nil; 931 | } 932 | 933 | object *fn_streamp (object *args, object *env) { 934 | (void) env; 935 | object *arg1 = first(args); 936 | return streamp(arg1) ? tee : nil; 937 | } 938 | 939 | object *fn_eq (object *args, object *env) { 940 | (void) env; 941 | object *arg1 = first(args); 942 | object *arg2 = second(args); 943 | return eq(arg1, arg2) ? tee : nil; 944 | } 945 | 946 | // List functions 947 | 948 | object *fn_car (object *args, object *env) { 949 | (void) env; 950 | return carx(first(args)); 951 | } 952 | 953 | object *fn_cdr (object *args, object *env) { 954 | (void) env; 955 | return cdrx(first(args)); 956 | } 957 | 958 | object *fn_caar (object *args, object *env) { 959 | (void) env; 960 | return carx(carx(first(args))); 961 | } 962 | 963 | object *fn_cadr (object *args, object *env) { 964 | (void) env; 965 | return carx(cdrx(first(args))); 966 | } 967 | 968 | object *fn_cdar (object *args, object *env) { 969 | (void) env; 970 | return cdrx(carx(first(args))); 971 | } 972 | 973 | object *fn_cddr (object *args, object *env) { 974 | (void) env; 975 | return cdrx(cdrx(first(args))); 976 | } 977 | 978 | object *fn_caaar (object *args, object *env) { 979 | (void) env; 980 | return carx(carx(carx(first(args)))); 981 | } 982 | 983 | object *fn_caadr (object *args, object *env) { 984 | (void) env; 985 | return carx(carx(cdrx(first(args)))); 986 | } 987 | 988 | object *fn_cadar (object *args, object *env) { 989 | (void) env; 990 | return carx(cdrx(carx(first(args)))); 991 | } 992 | 993 | object *fn_caddr (object *args, object *env) { 994 | (void) env; 995 | return carx(cdrx(cdrx(first(args)))); 996 | } 997 | 998 | object *fn_cdaar (object *args, object *env) { 999 | (void) env; 1000 | return cdrx(carx(carx(first(args)))); 1001 | } 1002 | 1003 | object *fn_cdadr (object *args, object *env) { 1004 | (void) env; 1005 | return cdrx(carx(cdrx(first(args)))); 1006 | } 1007 | 1008 | object *fn_cddar (object *args, object *env) { 1009 | (void) env; 1010 | return cdrx(cdrx(carx(first(args)))); 1011 | } 1012 | 1013 | object *fn_cdddr (object *args, object *env) { 1014 | (void) env; 1015 | return cdrx(cdrx(cdrx(first(args)))); 1016 | } 1017 | 1018 | object *fn_length (object *args, object *env) { 1019 | (void) env; 1020 | object *arg = first(args); 1021 | if (listp(arg)) return number(listlength(arg)); 1022 | if (!stringp(arg)) error(F("'length' argument is not a list or string")); 1023 | return number(stringlength(arg)); 1024 | } 1025 | 1026 | object *fn_list (object *args, object *env) { 1027 | (void) env; 1028 | return args; 1029 | } 1030 | 1031 | object *fn_reverse (object *args, object *env) { 1032 | (void) env; 1033 | object *list = first(args); 1034 | if (!listp(list)) error(F("'reverse' argument is not a list")); 1035 | object *result = NULL; 1036 | while (list != NULL) { 1037 | push(first(list),result); 1038 | list = cdr(list); 1039 | } 1040 | return result; 1041 | } 1042 | 1043 | object *fn_nth (object *args, object *env) { 1044 | (void) env; 1045 | int n = integer(first(args)); 1046 | object *list = second(args); 1047 | if (!listp(list)) error(F("'nth' second argument is not a list")); 1048 | while (list != NULL) { 1049 | if (n == 0) return car(list); 1050 | list = cdr(list); 1051 | n--; 1052 | } 1053 | return nil; 1054 | } 1055 | 1056 | object *fn_assoc (object *args, object *env) { 1057 | (void) env; 1058 | object *key = first(args); 1059 | object *list = second(args); 1060 | if (!listp(list)) error(F("'assoc' second argument is not a list")); 1061 | while (list != NULL) { 1062 | object *pair = first(list); 1063 | if (eq(key,car(pair))) return pair; 1064 | list = cdr(list); 1065 | } 1066 | return nil; 1067 | } 1068 | 1069 | object *fn_member (object *args, object *env) { 1070 | (void) env; 1071 | object *item = first(args); 1072 | object *list = second(args); 1073 | if (!listp(list)) error(F("'member' second argument is not a list")); 1074 | while (list != NULL) { 1075 | if (eq(item,car(list))) return list; 1076 | list = cdr(list); 1077 | } 1078 | return nil; 1079 | } 1080 | 1081 | object *fn_apply (object *args, object *env) { 1082 | object *previous = NULL; 1083 | object *last = args; 1084 | while (cdr(last) != NULL) { 1085 | previous = last; 1086 | last = cdr(last); 1087 | } 1088 | if (!listp(car(last))) error(F("'apply' last argument is not a list")); 1089 | cdr(previous) = car(last); 1090 | return apply(first(args), cdr(args), &env); 1091 | } 1092 | 1093 | object *fn_funcall (object *args, object *env) { 1094 | return apply(first(args), cdr(args), &env); 1095 | } 1096 | 1097 | object *fn_append (object *args, object *env) { 1098 | (void) env; 1099 | object *head = NULL; 1100 | object *tail = NULL; 1101 | while (args != NULL) { 1102 | object *list = first(args); 1103 | if (!listp(list)) error(F("'append' argument is not a list")); 1104 | while (list != NULL) { 1105 | object *obj = cons(first(list),NULL); 1106 | if (head == NULL) { 1107 | head = obj; 1108 | tail = obj; 1109 | } else { 1110 | cdr(tail) = obj; 1111 | tail = obj; 1112 | } 1113 | list = cdr(list); 1114 | } 1115 | args = cdr(args); 1116 | } 1117 | return head; 1118 | } 1119 | 1120 | object *fn_mapc (object *args, object *env) { 1121 | object *function = first(args); 1122 | object *list1 = second(args); 1123 | object *result = list1; 1124 | if (!listp(list1)) error(F("'mapc' second argument is not a list")); 1125 | object *list2 = cddr(args); 1126 | if (list2 != NULL) { 1127 | list2 = car(list2); 1128 | if (!listp(list2)) error(F("'mapc' third argument is not a list")); 1129 | } 1130 | if (list2 != NULL) { 1131 | while (list1 != NULL && list2 != NULL) { 1132 | apply(function, cons(car(list1),cons(car(list2),NULL)), &env); 1133 | list1 = cdr(list1); 1134 | list2 = cdr(list2); 1135 | } 1136 | } else { 1137 | while (list1 != NULL) { 1138 | apply(function, cons(car(list1),NULL), &env); 1139 | list1 = cdr(list1); 1140 | } 1141 | } 1142 | return result; 1143 | } 1144 | 1145 | object *fn_mapcar (object *args, object *env) { 1146 | object *function = first(args); 1147 | object *list1 = second(args); 1148 | if (!listp(list1)) error(F("'mapcar' second argument is not a list")); 1149 | object *list2 = cddr(args); 1150 | if (list2 != NULL) { 1151 | list2 = car(list2); 1152 | if (!listp(list2)) error(F("'mapcar' third argument is not a list")); 1153 | } 1154 | object *head = NULL; 1155 | object *tail = NULL; 1156 | if (list2 != NULL) { 1157 | while (list1 != NULL && list2 != NULL) { 1158 | object *result = apply(function, cons(car(list1),cons(car(list2),NULL)), &env); 1159 | object *obj = cons(result,NULL); 1160 | if (head == NULL) { 1161 | head = obj; 1162 | push(head,GCStack); 1163 | tail = obj; 1164 | } else { 1165 | cdr(tail) = obj; 1166 | tail = obj; 1167 | } 1168 | list1 = cdr(list1); 1169 | list2 = cdr(list2); 1170 | } 1171 | } else { 1172 | while (list1 != NULL) { 1173 | object *result = apply(function, cons(car(list1),NULL), &env); 1174 | object *obj = cons(result,NULL); 1175 | if (head == NULL) { 1176 | head = obj; 1177 | push(head,GCStack); 1178 | tail = obj; 1179 | } else { 1180 | cdr(tail) = obj; 1181 | tail = obj; 1182 | } 1183 | list1 = cdr(list1); 1184 | } 1185 | } 1186 | pop(GCStack); 1187 | return head; 1188 | } 1189 | 1190 | // Arithmetic functions 1191 | 1192 | object *fn_add (object *args, object *env) { 1193 | (void) env; 1194 | int result = 0; 1195 | while (args != NULL) { 1196 | int temp = integer(car(args)); 1197 | #if defined(checkoverflow) 1198 | if (temp < 1) { if (-32768 - temp > result) error(F("'+' arithmetic overflow")); } 1199 | else { if (32767 - temp < result) error(F("'+' arithmetic overflow")); } 1200 | #endif 1201 | result = result + temp; 1202 | args = cdr(args); 1203 | } 1204 | return number(result); 1205 | } 1206 | 1207 | object *fn_subtract (object *args, object *env) { 1208 | (void) env; 1209 | int result = integer(car(args)); 1210 | args = cdr(args); 1211 | if (args == NULL) { 1212 | #if defined(checkoverflow) 1213 | if (result == -32768) error(F("'-' arithmetic overflow")); 1214 | #endif 1215 | return number(-result); 1216 | } 1217 | while (args != NULL) { 1218 | int temp = integer(car(args)); 1219 | #if defined(checkoverflow) 1220 | if (temp < 1) { if (32767 + temp < result) error(F("'-' arithmetic overflow")); } 1221 | else { if (-32768 + temp > result) error(F("'-' arithmetic overflow")); } 1222 | #endif 1223 | result = result - temp; 1224 | args = cdr(args); 1225 | } 1226 | return number(result); 1227 | } 1228 | 1229 | object *fn_multiply (object *args, object *env) { 1230 | (void) env; 1231 | int result = 1; 1232 | while (args != NULL){ 1233 | #if defined(checkoverflow) 1234 | signed long temp = (signed long) result * integer(car(args)); 1235 | if ((temp > 32767) || (temp < -32768)) error(F("'*' arithmetic overflow")); 1236 | result = temp; 1237 | #else 1238 | result = result * integer(car(args)); 1239 | #endif 1240 | args = cdr(args); 1241 | } 1242 | return number(result); 1243 | } 1244 | 1245 | object *fn_divide (object *args, object *env) { 1246 | (void) env; 1247 | int result = integer(first(args)); 1248 | args = cdr(args); 1249 | while (args != NULL) { 1250 | int arg = integer(car(args)); 1251 | if (arg == 0) error(F("Division by zero")); 1252 | #if defined(checkoverflow) 1253 | if ((result == -32768) && (arg == -1)) error(F("'/' arithmetic overflow")); 1254 | #endif 1255 | result = result / arg; 1256 | args = cdr(args); 1257 | } 1258 | return number(result); 1259 | } 1260 | 1261 | object *fn_mod (object *args, object *env) { 1262 | (void) env; 1263 | int arg1 = integer(first(args)); 1264 | int arg2 = integer(second(args)); 1265 | if (arg2 == 0) error(F("Division by zero")); 1266 | int r = arg1 % arg2; 1267 | if ((arg1<0) != (arg2<0)) r = r + arg2; 1268 | return number(r); 1269 | } 1270 | 1271 | object *fn_oneplus (object *args, object *env) { 1272 | (void) env; 1273 | int result = integer(first(args)); 1274 | #if defined(checkoverflow) 1275 | if (result == 32767) error(F("'1+' arithmetic overflow")); 1276 | #endif 1277 | return number(result + 1); 1278 | } 1279 | 1280 | object *fn_oneminus (object *args, object *env) { 1281 | (void) env; 1282 | int result = integer(first(args)); 1283 | #if defined(checkoverflow) 1284 | if (result == -32768) error(F("'1-' arithmetic overflow")); 1285 | #endif 1286 | return number(result - 1); 1287 | } 1288 | 1289 | object *fn_abs (object *args, object *env) { 1290 | (void) env; 1291 | int result = integer(first(args)); 1292 | #if defined(checkoverflow) 1293 | if (result == -32768) error(F("'abs' arithmetic overflow")); 1294 | #endif 1295 | return number(abs(result)); 1296 | } 1297 | 1298 | object *fn_random (object *args, object *env) { 1299 | (void) env; 1300 | int arg = integer(first(args)); 1301 | return number(random(arg)); 1302 | } 1303 | 1304 | object *fn_max (object *args, object *env) { 1305 | (void) env; 1306 | int result = integer(first(args)); 1307 | args = cdr(args); 1308 | while (args != NULL) { 1309 | result = max(result,integer(car(args))); 1310 | args = cdr(args); 1311 | } 1312 | return number(result); 1313 | } 1314 | 1315 | object *fn_min (object *args, object *env) { 1316 | (void) env; 1317 | int result = integer(first(args)); 1318 | args = cdr(args); 1319 | while (args != NULL) { 1320 | result = min(result,integer(car(args))); 1321 | args = cdr(args); 1322 | } 1323 | return number(result); 1324 | } 1325 | 1326 | // Arithmetic comparisons 1327 | 1328 | object *fn_numeq (object *args, object *env) { 1329 | (void) env; 1330 | int arg1 = integer(first(args)); 1331 | args = cdr(args); 1332 | while (args != NULL) { 1333 | int arg2 = integer(first(args)); 1334 | if (!(arg1 == arg2)) return nil; 1335 | arg1 = arg2; 1336 | args = cdr(args); 1337 | } 1338 | return tee; 1339 | } 1340 | 1341 | object *fn_less (object *args, object *env) { 1342 | (void) env; 1343 | int arg1 = integer(first(args)); 1344 | args = cdr(args); 1345 | while (args != NULL) { 1346 | int arg2 = integer(first(args)); 1347 | if (!(arg1 < arg2)) return nil; 1348 | arg1 = arg2; 1349 | args = cdr(args); 1350 | } 1351 | return tee; 1352 | } 1353 | 1354 | object *fn_lesseq (object *args, object *env) { 1355 | (void) env; 1356 | int arg1 = integer(first(args)); 1357 | args = cdr(args); 1358 | while (args != NULL) { 1359 | int arg2 = integer(first(args)); 1360 | if (!(arg1 <= arg2)) return nil; 1361 | arg1 = arg2; 1362 | args = cdr(args); 1363 | } 1364 | return tee; 1365 | } 1366 | 1367 | object *fn_greater (object *args, object *env) { 1368 | (void) env; 1369 | int arg1 = integer(first(args)); 1370 | args = cdr(args); 1371 | while (args != NULL) { 1372 | int arg2 = integer(first(args)); 1373 | if (!(arg1 > arg2)) return nil; 1374 | arg1 = arg2; 1375 | args = cdr(args); 1376 | } 1377 | return tee; 1378 | } 1379 | 1380 | object *fn_greatereq (object *args, object *env) { 1381 | (void) env; 1382 | int arg1 = integer(first(args)); 1383 | args = cdr(args); 1384 | while (args != NULL) { 1385 | int arg2 = integer(first(args)); 1386 | if (!(arg1 >= arg2)) return nil; 1387 | arg1 = arg2; 1388 | args = cdr(args); 1389 | } 1390 | return tee; 1391 | } 1392 | 1393 | object *fn_noteq (object *args, object *env) { 1394 | (void) env; 1395 | while (args != NULL) { 1396 | object *nargs = args; 1397 | int arg1 = integer(first(nargs)); 1398 | nargs = cdr(nargs); 1399 | while (nargs != NULL) { 1400 | int arg2 = integer(first(nargs)); 1401 | if (arg1 == arg2) return nil; 1402 | nargs = cdr(nargs); 1403 | } 1404 | args = cdr(args); 1405 | } 1406 | return tee; 1407 | } 1408 | 1409 | object *fn_plusp (object *args, object *env) { 1410 | (void) env; 1411 | int arg = integer(first(args)); 1412 | if (arg > 0) return tee; 1413 | else return nil; 1414 | } 1415 | 1416 | object *fn_minusp (object *args, object *env) { 1417 | (void) env; 1418 | int arg = integer(first(args)); 1419 | if (arg < 0) return tee; 1420 | else return nil; 1421 | } 1422 | 1423 | object *fn_zerop (object *args, object *env) { 1424 | (void) env; 1425 | int arg = integer(first(args)); 1426 | if (arg == 0) return tee; 1427 | else return nil; 1428 | } 1429 | 1430 | object *fn_oddp (object *args, object *env) { 1431 | (void) env; 1432 | int arg = integer(first(args)); 1433 | if ((arg & 1) == 1) return tee; 1434 | else return nil; 1435 | } 1436 | 1437 | object *fn_evenp (object *args, object *env) { 1438 | (void) env; 1439 | int arg = integer(first(args)); 1440 | if ((arg & 1) == 0) return tee; 1441 | else return nil; 1442 | } 1443 | 1444 | // Strings 1445 | 1446 | object *fn_stringp (object *args, object *env) { 1447 | (void) env; 1448 | object *arg1 = first(args); 1449 | return stringp(arg1) ? tee : nil; 1450 | } 1451 | 1452 | object *fn_stringeq (object *args, object *env) { 1453 | (void) env; 1454 | object *arg1 = first(args); 1455 | if (!stringp(arg1)) error(F("'string=' first argument is not a string")); 1456 | object *arg2 = second(args); 1457 | if (!stringp(arg2)) error(F("'string=' second argument is not a string")); 1458 | arg1 = cdr(arg1); 1459 | arg2 = cdr(arg2); 1460 | while ((arg1 != NULL) || (arg2 != NULL)) { 1461 | if ((arg1 == NULL) || (arg2 == NULL) || (arg1->integer != arg2->integer)) return nil; 1462 | arg1 = car(arg1); 1463 | arg2 = car(arg2); 1464 | } 1465 | return tee; 1466 | } 1467 | 1468 | object *fn_subseq (object *args, object *env) { 1469 | (void) env; 1470 | object *arg = first(args); 1471 | if (!stringp(arg)) error(F("'subseq' first argument is not a string")); 1472 | int start = integer(second(args)); 1473 | int end; 1474 | args = cddr(args); 1475 | if (args != NULL) end = integer(car(args)); else end = stringlength(arg); 1476 | object *result = myalloc(); 1477 | result->type = STRING; 1478 | object *head = NULL; 1479 | object *tail = NULL; 1480 | int chars = 0; 1481 | for (int i=start; icar = cell; 1487 | cell->car = NULL; 1488 | cell->integer = chars; 1489 | tail = cell; 1490 | } else { 1491 | chars = chars | ch; 1492 | tail->integer = chars; 1493 | chars = 0; 1494 | } 1495 | } 1496 | result->cdr = head; 1497 | return result; 1498 | } 1499 | 1500 | // Bitwise operators 1501 | 1502 | object *fn_logand (object *args, object *env) { 1503 | (void) env; 1504 | unsigned int result = 0xFFFF; 1505 | while (args != NULL) { 1506 | result = result & integer(first(args)); 1507 | args = cdr(args); 1508 | } 1509 | return number(result); 1510 | } 1511 | 1512 | object *fn_logior (object *args, object *env) { 1513 | (void) env; 1514 | unsigned int result = 0; 1515 | while (args != NULL) { 1516 | result = result | integer(first(args)); 1517 | args = cdr(args); 1518 | } 1519 | return number(result); 1520 | } 1521 | 1522 | object *fn_logxor (object *args, object *env) { 1523 | (void) env; 1524 | unsigned int result = 0; 1525 | while (args != NULL) { 1526 | result = result ^ integer(first(args)); 1527 | args = cdr(args); 1528 | } 1529 | return number(result); 1530 | } 1531 | 1532 | object *fn_lognot (object *args, object *env) { 1533 | (void) env; 1534 | int result = integer(car(args)); 1535 | return number(~result); 1536 | } 1537 | 1538 | object *fn_ash (object *args, object *env) { 1539 | (void) env; 1540 | int value = integer(first(args)); 1541 | int count = integer(second(args)); 1542 | if (count >= 0) 1543 | return number(value << count); 1544 | else 1545 | return number(value >> abs(count)); 1546 | } 1547 | 1548 | object *fn_logbitp (object *args, object *env) { 1549 | (void) env; 1550 | int index = integer(first(args)); 1551 | int value = integer(second(args)); 1552 | return (bitRead(value, index) == 1) ? tee : nil; 1553 | } 1554 | 1555 | // System functions 1556 | 1557 | object *fn_read (object *args, object *env) { 1558 | (void) args; 1559 | (void) env; 1560 | return read(); 1561 | } 1562 | 1563 | object *fn_eval (object *args, object *env) { 1564 | return eval(first(args), env); 1565 | } 1566 | 1567 | object *fn_globals (object *args, object *env) { 1568 | (void) args; 1569 | (void) env; 1570 | object *list = GlobalEnv; 1571 | while (list != NULL) { 1572 | printobject(car(car(list))); 1573 | pln(); 1574 | list = cdr(list); 1575 | } 1576 | return nil; 1577 | } 1578 | 1579 | object *fn_locals (object *args, object *env) { 1580 | (void) args; 1581 | return env; 1582 | } 1583 | 1584 | object *fn_makunbound (object *args, object *env) { 1585 | (void) args; 1586 | (void) env; 1587 | object *key = first(args); 1588 | object *list = GlobalEnv; 1589 | object *prev = NULL; 1590 | while (list != NULL) { 1591 | object *pair = first(list); 1592 | if (eq(key,car(pair))) { 1593 | if (prev == NULL) GlobalEnv = cdr(list); 1594 | else cdr(prev) = cdr(list); 1595 | return key; 1596 | } 1597 | prev = list; 1598 | list = cdr(list); 1599 | } 1600 | error2(key, F("not found")); 1601 | return nil; 1602 | } 1603 | 1604 | object *fn_break (object *args, object *env) { 1605 | (void) args; 1606 | pln(); 1607 | pfstring(F("Break!")); pln(); 1608 | BreakLevel++; 1609 | repl(env); 1610 | BreakLevel--; 1611 | return nil; 1612 | } 1613 | 1614 | object *fn_print (object *args, object *env) { 1615 | (void) env; 1616 | pln(); 1617 | object *obj = first(args); 1618 | printobject(obj); 1619 | pchar(' '); 1620 | return obj; 1621 | } 1622 | 1623 | object *fn_princ (object *args, object *env) { 1624 | (void) env; 1625 | object *obj = first(args); 1626 | char temp = PrintReadably; 1627 | PrintReadably = 0; 1628 | printobject(obj); 1629 | PrintReadably = temp; 1630 | return obj; 1631 | } 1632 | 1633 | object *fn_writebyte (object *args, object *env) { 1634 | (void) env; 1635 | object *val = first(args); 1636 | int value = integer(val); 1637 | int stream = SERIALSTREAM<<8; 1638 | args = cdr(args); 1639 | if (args != NULL) stream = istream(first(args)); 1640 | if (stream>>8 == I2CSTREAM) return (I2Cwrite(value)) ? tee : nil; 1641 | else if (stream>>8 == SPISTREAM) return number(SPI.transfer(value)); 1642 | else if (stream == SERIALSTREAM<<8) pchar(value); 1643 | else error(F("'write-byte' unknown stream type")); 1644 | return nil; 1645 | } 1646 | 1647 | object *fn_readbyte (object *args, object *env) { 1648 | (void) env; 1649 | int stream = SERIALSTREAM<<8; 1650 | int last = 0; 1651 | if (args != NULL) stream = istream(first(args)); 1652 | args = cdr(args); 1653 | if (args != NULL) last = (first(args) != NULL); 1654 | if (stream>>8 == I2CSTREAM) { 1655 | if (i2cCount >= 0) i2cCount--; 1656 | return number(I2Cread((i2cCount == 0) || last)); 1657 | } else if (stream>>8 == SPISTREAM) return number(SPI.transfer(0)); 1658 | else if (stream == SERIALSTREAM<<8) return number(gchar()); 1659 | else error(F("'read-byte' unknown stream type")); 1660 | return nil; 1661 | } 1662 | 1663 | object *fn_restarti2c (object *args, object *env) { 1664 | (void) env; 1665 | int stream = first(args)->integer; 1666 | args = cdr(args); 1667 | int read = 0; // Write 1668 | i2cCount = 0; 1669 | if (args != NULL) { 1670 | object *rw = first(args); 1671 | if (numberp(rw)) i2cCount = integer(rw); 1672 | read = (rw != NULL); 1673 | } 1674 | int address = stream & 0xFF; 1675 | if (stream>>8 == I2CSTREAM) { 1676 | if (!I2Crestart(address<<1 | read)) error(F("'i2c-restart' failed")); 1677 | } 1678 | else error(F("'restart' not i2c")); 1679 | return tee; 1680 | } 1681 | 1682 | object *fn_gc (object *obj, object *env) { 1683 | unsigned long start = micros(); 1684 | int initial = freespace; 1685 | gc(obj, env); 1686 | pfstring(F("Space: ")); 1687 | pint(freespace - initial); 1688 | pfstring(F(" bytes, Time: ")); 1689 | pint(micros() - start); 1690 | pfstring(F(" uS")); pln(); 1691 | return nil; 1692 | } 1693 | 1694 | object *fn_room (object *args, object *env) { 1695 | (void) args; 1696 | (void) env; 1697 | return number(freespace); 1698 | } 1699 | 1700 | object *fn_saveimage (object *args, object *env) { 1701 | object *var = eval(first(args), env); 1702 | return number(saveimage(var)); 1703 | } 1704 | 1705 | object *fn_loadimage (object *args, object *env) { 1706 | (void) args; 1707 | (void) env; 1708 | return number(loadimage()); 1709 | } 1710 | 1711 | object *fn_cls(object *args, object *env) { 1712 | (void) env; 1713 | (void) args; 1714 | pchar(12); 1715 | return nil; 1716 | } 1717 | 1718 | // Arduino procedures 1719 | 1720 | object *fn_pinmode (object *args, object *env) { 1721 | (void) env; 1722 | int pin = integer(first(args)); 1723 | object *mode = second(args); 1724 | if (mode->type == NUMBER) pinMode(pin, mode->integer); 1725 | else pinMode(pin, (mode != nil)); 1726 | return nil; 1727 | } 1728 | 1729 | object *fn_digitalread (object *args, object *env) { 1730 | (void) env; 1731 | int pin = integer(first(args)); 1732 | if(digitalRead(pin) != 0) return tee; else return nil; 1733 | } 1734 | 1735 | object *fn_digitalwrite (object *args, object *env) { 1736 | (void) env; 1737 | int pin = integer(first(args)); 1738 | object *mode = second(args); 1739 | digitalWrite(pin, (mode != nil)); 1740 | return mode; 1741 | } 1742 | 1743 | object *fn_analogread (object *args, object *env) { 1744 | (void) env; 1745 | int pin = integer(first(args)); 1746 | #if defined(__AVR_ATmega328P__) 1747 | if (!(pin>=0 && pin<=5)) error(F("'analogread' invalid pin")); 1748 | #elif defined(__AVR_ATmega2560__) 1749 | if (!(pin>=0 && pin<=15)) error(F("'analogread' invalid pin")); 1750 | #endif 1751 | return number(analogRead(pin)); 1752 | } 1753 | 1754 | object *fn_analogwrite (object *args, object *env) { 1755 | (void) env; 1756 | int pin = integer(first(args)); 1757 | #if defined(__AVR_ATmega328P__) 1758 | if (!(pin>=3 && pin<=11 && pin!=4 && pin!=7 && pin!=8)) error(F("'analogwrite' invalid pin")); 1759 | #elif defined(__AVR_ATmega2560__) 1760 | if (!((pin>=2 && pin<=13) || (pin>=44 && pin <=46))) error(F("'analogwrite' invalid pin")); 1761 | #endif 1762 | object *value = second(args); 1763 | analogWrite(pin, integer(value)); 1764 | return value; 1765 | } 1766 | 1767 | object *fn_delay (object *args, object *env) { 1768 | (void) env; 1769 | object *arg1 = first(args); 1770 | delay(integer(arg1)); 1771 | return arg1; 1772 | } 1773 | 1774 | object *fn_millis (object *args, object *env) { 1775 | (void) env; 1776 | (void) args; 1777 | unsigned long temp = millis(); 1778 | #if defined(checkoverflow) 1779 | if (temp > 32767) error(F("'millis' arithmetic overflow")); 1780 | #endif 1781 | return number(temp); 1782 | } 1783 | 1784 | const uint8_t scale[] PROGMEM = {239,226,213,201,190,179,169,160,151,142,134,127}; 1785 | 1786 | object *fn_note (object *args, object *env) { 1787 | (void) env; 1788 | #if defined(__AVR_ATmega328P__) 1789 | if (args != NULL) { 1790 | int pin = integer(first(args)); 1791 | int note = integer(second(args)); 1792 | if (pin == 3) { 1793 | DDRD = DDRD | 1<6) error(F("'note' octave out of range")); 1803 | OCR2A = pgm_read_byte(&scale[note%12]) - 1; 1804 | TCCR2B = 0<6) error(F("'note' octave out of range")); 1822 | OCR2A = pgm_read_byte(&scale[note%12]) - 1; 1823 | TCCR2B = 0<6) error(F("'note' octave out of range")); 1841 | OCR2A = pgm_read_byte(&scale[note%12]) - 1; 1842 | TCCR2B = 0<type == NUMBER) || (form->type == STRING)) return form; 2185 | 2186 | if (form->type == SYMBOL) { 2187 | unsigned int name = form->name; 2188 | if (name == NIL) return nil; 2189 | object *pair = value(name, env); 2190 | if (pair != NULL) return cdr(pair); 2191 | pair = value(name, GlobalEnv); 2192 | if (pair != NULL) return cdr(pair); 2193 | else if (name <= ENDFUNCTIONS) return form; 2194 | error2(form, F("undefined")); 2195 | } 2196 | 2197 | // It's a list 2198 | object *function = car(form); 2199 | object *args = cdr(form); 2200 | 2201 | // List starts with a symbol? 2202 | if (function->type == SYMBOL) { 2203 | unsigned int name = function->name; 2204 | 2205 | if ((name == LET) || (name == LETSTAR)) { 2206 | object *assigns = first(args); 2207 | object *forms = cdr(args); 2208 | object *newenv = env; 2209 | while (assigns != NULL) { 2210 | object *assign = car(assigns); 2211 | if (consp(assign)) push(cons(first(assign),eval(second(assign),env)), newenv); 2212 | else push(cons(assign,nil), newenv); 2213 | if (name == LETSTAR) env = newenv; 2214 | assigns = cdr(assigns); 2215 | } 2216 | env = newenv; 2217 | form = tf_progn(forms,env); 2218 | TC = 1; 2219 | goto EVAL; 2220 | } 2221 | 2222 | if (name == LAMBDA) { 2223 | if (env == NULL) return form; 2224 | object *envcopy = NULL; 2225 | while (env != NULL) { 2226 | object *pair = first(env); 2227 | object *val = cdr(pair); 2228 | if (val->type == NUMBER) val = number(val->integer); 2229 | push(cons(car(pair), val), envcopy); 2230 | env = cdr(env); 2231 | } 2232 | return cons(symbol(CLOSURE), cons(envcopy,args)); 2233 | } 2234 | 2235 | if ((name > SPECIAL_FORMS) && (name < TAIL_FORMS)) { 2236 | return ((fn_ptr_type)lookupfn(name))(args, env); 2237 | } 2238 | 2239 | if ((name > TAIL_FORMS) && (name < FUNCTIONS)) { 2240 | form = ((fn_ptr_type)lookupfn(name))(args, env); 2241 | TC = 1; 2242 | goto EVAL; 2243 | } 2244 | } 2245 | 2246 | // Evaluate the parameters - result in head 2247 | object *fname = car(form); 2248 | int TCstart = TC; 2249 | object *head = cons(eval(car(form), env), NULL); 2250 | push(head, GCStack); // Don't GC the result list 2251 | object *tail = head; 2252 | form = cdr(form); 2253 | int nargs = 0; 2254 | 2255 | while (form != NULL){ 2256 | object *obj = cons(eval(car(form),env),NULL); 2257 | cdr(tail) = obj; 2258 | tail = obj; 2259 | form = cdr(form); 2260 | nargs++; 2261 | } 2262 | 2263 | function = car(head); 2264 | args = cdr(head); 2265 | 2266 | if (function->type == SYMBOL) { 2267 | unsigned int name = function->name; 2268 | if (name >= ENDFUNCTIONS) error2(fname, F("is not a function")); 2269 | if (nargslookupmax(name)) error2(fname, F("has too many arguments")); 2271 | object *result = ((fn_ptr_type)lookupfn(name))(args, env); 2272 | pop(GCStack); 2273 | return result; 2274 | } 2275 | 2276 | if (listp(function) && issymbol(car(function), LAMBDA)) { 2277 | form = closure(TCstart, fname, NULL, cdr(function), args, &env); 2278 | pop(GCStack); 2279 | TC = 1; 2280 | goto EVAL; 2281 | } 2282 | 2283 | if (listp(function) && issymbol(car(function), CLOSURE)) { 2284 | function = cdr(function); 2285 | form = closure(TCstart, fname, car(function), cdr(function), args, &env); 2286 | pop(GCStack); 2287 | TC = 1; 2288 | goto EVAL; 2289 | } 2290 | 2291 | error2(fname, F("is an illegal function")); return nil; 2292 | } 2293 | 2294 | // Input/Output 2295 | 2296 | // Print functions 2297 | 2298 | void pchar (char c) { 2299 | LastPrint = c; 2300 | #if defined (tinylispcomputer) 2301 | Display(c); 2302 | #endif 2303 | #if defined (serialmonitor) 2304 | Serial.write(c); 2305 | if (c == '\r') Serial.write('\n'); 2306 | #endif 2307 | } 2308 | 2309 | void pstring (char *s) { 2310 | while (*s) pchar(*s++); 2311 | } 2312 | 2313 | void pfstring (const __FlashStringHelper *s) { 2314 | PGM_P p = reinterpret_cast(s); 2315 | while (1) { 2316 | char c = pgm_read_byte(p++); 2317 | if (c == 0) return; 2318 | pchar(c); 2319 | } 2320 | } 2321 | 2322 | void pint (int i) { 2323 | int lead = 0; 2324 | if (i<0) pchar('-'); 2325 | for (int d=10000; d>0; d=d/10) { 2326 | int j = i/d; 2327 | if (j!=0 || lead || d==1) { pchar(abs(j)+'0'); lead=1;} 2328 | i = i - j*d; 2329 | } 2330 | } 2331 | 2332 | void pln () { 2333 | pchar('\r'); 2334 | } 2335 | 2336 | void pfl () { 2337 | if (LastPrint != '\r') pchar('\r'); 2338 | } 2339 | 2340 | void printobject(object *form){ 2341 | #if defined(debug2) 2342 | pchar('['); pint((int)form); pchar(']'); 2343 | #endif 2344 | if (form == NULL) pfstring(F("nil")); 2345 | else if (listp(form) && issymbol(car(form), CLOSURE)) pfstring(F("")); 2346 | else if (listp(form)) { 2347 | pchar('('); 2348 | printobject(car(form)); 2349 | form = cdr(form); 2350 | while (form != NULL && listp(form)) { 2351 | pchar(' '); 2352 | printobject(car(form)); 2353 | form = cdr(form); 2354 | } 2355 | if (form != NULL) { 2356 | pfstring(F(" . ")); 2357 | printobject(form); 2358 | } 2359 | pchar(')'); 2360 | } else if (form->type == NUMBER) { 2361 | pint(integer(form)); 2362 | } else if (form->type == SYMBOL) { 2363 | pstring(name(form)); 2364 | } else if (form->type == STRING) { 2365 | if (PrintReadably) pchar('"'); 2366 | form = cdr(form); 2367 | while (form != NULL) { 2368 | int chars = form->integer; 2369 | char ch = chars>>8 & 0xFF; 2370 | if (ch) pchar(ch); 2371 | pchar(chars & 0xFF); 2372 | form = car(form); 2373 | } 2374 | if (PrintReadably) pchar('"'); 2375 | } else if (form->type == STREAM) { 2376 | pfstring(F("<")); 2377 | if ((form->integer)>>8 == SPISTREAM) pfstring(F("spi")); 2378 | else if ((form->integer)>>8 == I2CSTREAM) pfstring(F("i2c")); 2379 | else pfstring(F("serial")); 2380 | pfstring(F("-stream ")); 2381 | pint(form->integer & 0xFF); 2382 | pchar('>'); 2383 | } else 2384 | error(F("Error in print.")); 2385 | } 2386 | 2387 | #if defined (tinylispcomputer) 2388 | volatile uint8_t WritePtr = 0, ReadPtr = 0; 2389 | const int KybdBufSize = 165; 2390 | char KybdBuf[KybdBufSize]; 2391 | volatile uint8_t KybdAvailable = 0; 2392 | #endif 2393 | 2394 | int gchar () { 2395 | if (LastChar) { 2396 | char temp = LastChar; 2397 | LastChar = 0; 2398 | return temp; 2399 | } 2400 | #if defined (serialmonitor) && defined (tinylispcomputer) 2401 | while (!Serial.available() && !KybdAvailable); 2402 | if (Serial.available()) { 2403 | char temp = Serial.read(); 2404 | if (temp != '\r') pchar(temp); 2405 | return temp; 2406 | } else { 2407 | if (ReadPtr != WritePtr) { 2408 | char temp = KybdBuf[ReadPtr++]; 2409 | Serial.write(temp); 2410 | return temp; 2411 | } 2412 | KybdAvailable = 0; 2413 | WritePtr = 0; 2414 | return 13; 2415 | } 2416 | #elif defined (tinylispcomputer) 2417 | while (!KybdAvailable); 2418 | if (ReadPtr != WritePtr) return KybdBuf[ReadPtr++]; 2419 | KybdAvailable = 0; 2420 | WritePtr = 0; 2421 | return '\r'; 2422 | #elif defined (serialmonitor) 2423 | while (!Serial.available()); 2424 | char temp = Serial.read(); 2425 | if (temp != '\r') pchar(temp); 2426 | return temp; 2427 | #endif 2428 | } 2429 | 2430 | object *nextitem() { 2431 | int ch = gchar(); 2432 | while(isspace(ch)) ch = gchar(); 2433 | 2434 | if (ch == ';') { 2435 | while(ch != '(') ch = gchar(); 2436 | ch = '('; 2437 | } 2438 | if (ch == '\r') ch = gchar(); 2439 | if (ch == EOF) exit(0); 2440 | 2441 | if (ch == ')') return (object *)KET; 2442 | if (ch == '(') return (object *)BRA; 2443 | if (ch == '\'') return (object *)QUO; 2444 | if (ch == '.') return (object *)DOT; 2445 | 2446 | // Parse string 2447 | if (ch == '"') { 2448 | object *obj = myalloc(); 2449 | obj->type = STRING; 2450 | ch = gchar(); 2451 | object *head = NULL; 2452 | object *tail = NULL; 2453 | int chars = 0; 2454 | while (ch != '"') { 2455 | if (ch == '\\') ch = gchar(); 2456 | if (chars == 0) { 2457 | chars = ch<<8; 2458 | object *cell = myalloc(); 2459 | if (head == NULL) head = cell; else tail->car = cell; 2460 | cell->car = NULL; 2461 | cell->integer = chars; 2462 | tail = cell; 2463 | } else { 2464 | chars = chars | ch; 2465 | tail->integer = chars; 2466 | chars = 0; 2467 | } 2468 | ch = gchar(); 2469 | } 2470 | obj->cdr = head; 2471 | return obj; 2472 | } 2473 | 2474 | // Parse variable or number 2475 | int index = 0, base = 10, sign = 1; 2476 | unsigned int result = 0; 2477 | if (ch == '+') { 2478 | buffer[index++] = ch; 2479 | ch = gchar(); 2480 | } else if (ch == '-') { 2481 | sign = -1; 2482 | buffer[index++] = ch; 2483 | ch = gchar(); 2484 | } else if (ch == '#') { 2485 | ch = gchar() | 0x20; 2486 | if (ch == 'b') base = 2; 2487 | else if (ch == 'o') base = 8; 2488 | else if (ch == 'x') base = 16; 2489 | else error(F("Illegal character after #")); 2490 | ch = gchar(); 2491 | } 2492 | int isnumber = (digitvalue(ch) ((unsigned int)32767+(1-sign)/2)) { 2509 | pln(); 2510 | error(F("Number out of range")); 2511 | } 2512 | return number(result*sign); 2513 | } 2514 | 2515 | int x = builtin(buffer); 2516 | if (x == NIL) return nil; 2517 | if (x < ENDFUNCTIONS) return symbol(x); 2518 | else return symbol(pack40(buffer)); 2519 | } 2520 | 2521 | object *readrest() { 2522 | object *item = nextitem(); 2523 | 2524 | if(item == (object *)KET) return NULL; 2525 | 2526 | if(item == (object *)DOT) { 2527 | object *arg1 = read(); 2528 | if (readrest() != NULL) error(F("Malformed list")); 2529 | return arg1; 2530 | } 2531 | 2532 | if(item == (object *)QUO) { 2533 | object *arg1 = read(); 2534 | return cons(cons(symbol(QUOTE), cons(arg1, NULL)), readrest()); 2535 | } 2536 | 2537 | if(item == (object *)BRA) item = readrest(); 2538 | return cons(item, readrest()); 2539 | } 2540 | 2541 | object *read() { 2542 | object *item = nextitem(); 2543 | if (item == (object *)BRA) return readrest(); 2544 | if (item == (object *)DOT) return read(); 2545 | if (item == (object *)QUO) return cons(symbol(QUOTE), cons(read(), NULL)); 2546 | return item; 2547 | } 2548 | 2549 | void initenv() { 2550 | GlobalEnv = NULL; 2551 | tee = symbol(TEE); 2552 | } 2553 | 2554 | #if defined (tinylispcomputer) 2555 | // Tiny Lisp Computer terminal and keyboard support 2556 | 2557 | int const SH1106 = 0; // Set to 0 for SSD1306 or 1 for SH1106 2558 | 2559 | // Support both ATmega328P and ATmega644P/ATmega1284P 2560 | #if defined(__AVR_ATmega328P__) 2561 | #define PINX PIND 2562 | #define PORTDAT PORTB 2563 | int const data = 0; 2564 | #define KEYBOARD_VECTOR INT0_vect 2565 | #elif defined(__AVR_ATmega644P__) || defined(__AVR_ATmega1284P__) 2566 | #define PINX PINC 2567 | #define PORTDAT PORTC 2568 | int const data = 4; 2569 | #define KEYBOARD_VECTOR INT2_vect 2570 | #endif 2571 | 2572 | // These are the bit positions in PORTX 2573 | int const clk = 7; 2574 | int const dc = 6; 2575 | int const cs = 5; 2576 | 2577 | // Terminal ********************************************************************************** 2578 | 2579 | // Character set - stored in program memory 2580 | const uint8_t CharMap[96][6] PROGMEM = { 2581 | { 0x00, 0x00, 0x00, 0x00, 0x00, 0x00 }, 2582 | { 0x00, 0x00, 0x5F, 0x00, 0x00, 0x00 }, 2583 | { 0x00, 0x07, 0x00, 0x07, 0x00, 0x00 }, 2584 | { 0x14, 0x7F, 0x14, 0x7F, 0x14, 0x00 }, 2585 | { 0x24, 0x2A, 0x7F, 0x2A, 0x12, 0x00 }, 2586 | { 0x23, 0x13, 0x08, 0x64, 0x62, 0x00 }, 2587 | { 0x36, 0x49, 0x56, 0x20, 0x50, 0x00 }, 2588 | { 0x00, 0x08, 0x07, 0x03, 0x00, 0x00 }, 2589 | { 0x00, 0x1C, 0x22, 0x41, 0x00, 0x00 }, 2590 | { 0x00, 0x41, 0x22, 0x1C, 0x00, 0x00 }, 2591 | { 0x2A, 0x1C, 0x7F, 0x1C, 0x2A, 0x00 }, 2592 | { 0x08, 0x08, 0x3E, 0x08, 0x08, 0x00 }, 2593 | { 0x00, 0x80, 0x70, 0x30, 0x00, 0x00 }, 2594 | { 0x08, 0x08, 0x08, 0x08, 0x08, 0x00 }, 2595 | { 0x00, 0x00, 0x60, 0x60, 0x00, 0x00 }, 2596 | { 0x20, 0x10, 0x08, 0x04, 0x02, 0x00 }, 2597 | { 0x3E, 0x51, 0x49, 0x45, 0x3E, 0x00 }, 2598 | { 0x00, 0x42, 0x7F, 0x40, 0x00, 0x00 }, 2599 | { 0x72, 0x49, 0x49, 0x49, 0x46, 0x00 }, 2600 | { 0x21, 0x41, 0x49, 0x4D, 0x33, 0x00 }, 2601 | { 0x18, 0x14, 0x12, 0x7F, 0x10, 0x00 }, 2602 | { 0x27, 0x45, 0x45, 0x45, 0x39, 0x00 }, 2603 | { 0x3C, 0x4A, 0x49, 0x49, 0x31, 0x00 }, 2604 | { 0x41, 0x21, 0x11, 0x09, 0x07, 0x00 }, 2605 | { 0x36, 0x49, 0x49, 0x49, 0x36, 0x00 }, 2606 | { 0x46, 0x49, 0x49, 0x29, 0x1E, 0x00 }, 2607 | { 0x00, 0x36, 0x36, 0x00, 0x00, 0x00 }, 2608 | { 0x00, 0x56, 0x36, 0x00, 0x00, 0x00 }, 2609 | { 0x00, 0x08, 0x14, 0x22, 0x41, 0x00 }, 2610 | { 0x14, 0x14, 0x14, 0x14, 0x14, 0x00 }, 2611 | { 0x00, 0x41, 0x22, 0x14, 0x08, 0x00 }, 2612 | { 0x02, 0x01, 0x59, 0x09, 0x06, 0x00 }, 2613 | { 0x3E, 0x41, 0x5D, 0x59, 0x4E, 0x00 }, 2614 | { 0x7C, 0x12, 0x11, 0x12, 0x7C, 0x00 }, 2615 | { 0x7F, 0x49, 0x49, 0x49, 0x36, 0x00 }, 2616 | { 0x3E, 0x41, 0x41, 0x41, 0x22, 0x00 }, 2617 | { 0x7F, 0x41, 0x41, 0x41, 0x3E, 0x00 }, 2618 | { 0x7F, 0x49, 0x49, 0x49, 0x41, 0x00 }, 2619 | { 0x7F, 0x09, 0x09, 0x09, 0x01, 0x00 }, 2620 | { 0x3E, 0x41, 0x41, 0x51, 0x73, 0x00 }, 2621 | { 0x7F, 0x08, 0x08, 0x08, 0x7F, 0x00 }, 2622 | { 0x00, 0x41, 0x7F, 0x41, 0x00, 0x00 }, 2623 | { 0x20, 0x40, 0x41, 0x3F, 0x01, 0x00 }, 2624 | { 0x7F, 0x08, 0x14, 0x22, 0x41, 0x00 }, 2625 | { 0x7F, 0x40, 0x40, 0x40, 0x40, 0x00 }, 2626 | { 0x7F, 0x02, 0x1C, 0x02, 0x7F, 0x00 }, 2627 | { 0x7F, 0x04, 0x08, 0x10, 0x7F, 0x00 }, 2628 | { 0x3E, 0x41, 0x41, 0x41, 0x3E, 0x00 }, 2629 | { 0x7F, 0x09, 0x09, 0x09, 0x06, 0x00 }, 2630 | { 0x3E, 0x41, 0x51, 0x21, 0x5E, 0x00 }, 2631 | { 0x7F, 0x09, 0x19, 0x29, 0x46, 0x00 }, 2632 | { 0x26, 0x49, 0x49, 0x49, 0x32, 0x00 }, 2633 | { 0x03, 0x01, 0x7F, 0x01, 0x03, 0x00 }, 2634 | { 0x3F, 0x40, 0x40, 0x40, 0x3F, 0x00 }, 2635 | { 0x1F, 0x20, 0x40, 0x20, 0x1F, 0x00 }, 2636 | { 0x3F, 0x40, 0x38, 0x40, 0x3F, 0x00 }, 2637 | { 0x63, 0x14, 0x08, 0x14, 0x63, 0x00 }, 2638 | { 0x03, 0x04, 0x78, 0x04, 0x03, 0x00 }, 2639 | { 0x61, 0x59, 0x49, 0x4D, 0x43, 0x00 }, 2640 | { 0x00, 0x7F, 0x41, 0x41, 0x41, 0x00 }, 2641 | { 0x02, 0x04, 0x08, 0x10, 0x20, 0x00 }, 2642 | { 0x00, 0x41, 0x41, 0x41, 0x7F, 0x00 }, 2643 | { 0x04, 0x02, 0x01, 0x02, 0x04, 0x00 }, 2644 | { 0x40, 0x40, 0x40, 0x40, 0x40, 0x00 }, 2645 | { 0x00, 0x03, 0x07, 0x08, 0x00, 0x00 }, 2646 | { 0x20, 0x54, 0x54, 0x78, 0x40, 0x00 }, 2647 | { 0x7F, 0x28, 0x44, 0x44, 0x38, 0x00 }, 2648 | { 0x38, 0x44, 0x44, 0x44, 0x28, 0x00 }, 2649 | { 0x38, 0x44, 0x44, 0x28, 0x7F, 0x00 }, 2650 | { 0x38, 0x54, 0x54, 0x54, 0x18, 0x00 }, 2651 | { 0x00, 0x08, 0x7E, 0x09, 0x02, 0x00 }, 2652 | { 0x18, 0xA4, 0xA4, 0x9C, 0x78, 0x00 }, 2653 | { 0x7F, 0x08, 0x04, 0x04, 0x78, 0x00 }, 2654 | { 0x00, 0x44, 0x7D, 0x40, 0x00, 0x00 }, 2655 | { 0x20, 0x40, 0x40, 0x3D, 0x00, 0x00 }, 2656 | { 0x7F, 0x10, 0x28, 0x44, 0x00, 0x00 }, 2657 | { 0x00, 0x41, 0x7F, 0x40, 0x00, 0x00 }, 2658 | { 0x7C, 0x04, 0x78, 0x04, 0x78, 0x00 }, 2659 | { 0x7C, 0x08, 0x04, 0x04, 0x78, 0x00 }, 2660 | { 0x38, 0x44, 0x44, 0x44, 0x38, 0x00 }, 2661 | { 0xFC, 0x18, 0x24, 0x24, 0x18, 0x00 }, 2662 | { 0x18, 0x24, 0x24, 0x18, 0xFC, 0x00 }, 2663 | { 0x7C, 0x08, 0x04, 0x04, 0x08, 0x00 }, 2664 | { 0x48, 0x54, 0x54, 0x54, 0x24, 0x00 }, 2665 | { 0x04, 0x04, 0x3F, 0x44, 0x24, 0x00 }, 2666 | { 0x3C, 0x40, 0x40, 0x20, 0x7C, 0x00 }, 2667 | { 0x1C, 0x20, 0x40, 0x20, 0x1C, 0x00 }, 2668 | { 0x3C, 0x40, 0x30, 0x40, 0x3C, 0x00 }, 2669 | { 0x44, 0x28, 0x10, 0x28, 0x44, 0x00 }, 2670 | { 0x4C, 0x90, 0x90, 0x90, 0x7C, 0x00 }, 2671 | { 0x44, 0x64, 0x54, 0x4C, 0x44, 0x00 }, 2672 | { 0x00, 0x08, 0x36, 0x41, 0x00, 0x00 }, 2673 | { 0x00, 0x00, 0x77, 0x00, 0x00, 0x00 }, 2674 | { 0x00, 0x41, 0x36, 0x08, 0x00, 0x00 }, 2675 | { 0x02, 0x01, 0x02, 0x04, 0x02, 0x00 }, 2676 | { 0xC0, 0xC0, 0xC0, 0xC0, 0xC0, 0xC0 } 2677 | }; 2678 | 2679 | // Initialisation sequence for OLED module 2680 | int const InitLen = 23; 2681 | unsigned char Init[InitLen] = { 2682 | 0xAE, // Display off 2683 | 0xD5, // Set display clock 2684 | 0x80, // Recommended value 2685 | 0xA8, // Set multiplex 2686 | 0x3F, 2687 | 0xD3, // Set display offset 2688 | 0x00, 2689 | 0x40, // Zero start line 2690 | 0x8D, // Charge pump 2691 | 0x14, 2692 | 0x20, // Memory mode 2693 | 0x02, // Page addressing 2694 | 0xA1, // 0xA0/0xA1 flip horizontally 2695 | 0xC8, // 0xC0/0xC8 flip vertically 2696 | 0xDA, // Set comp ins 2697 | 0x12, 2698 | 0x81, // Set contrast 2699 | 0x7F, 2700 | 0xD9, // Set pre charge 2701 | 0xF1, 2702 | 0xDB, // Set vcom detect 2703 | 0x40, 2704 | 0xA6 // Normal (0xA7=Inverse) 2705 | }; 2706 | 2707 | // Write a data byte to the display 2708 | void Data (uint8_t d) { 2709 | PINX = 1<>= 1) { 2711 | PINX = 1<> 4)); // Column start high 2764 | for (uint8_t col = 0; col < 6; col++) { 2765 | Data(pgm_read_byte(&CharMap[(c & 0x7F)-32][col]) ^ (c & 0x80 ? 0xFF : 0)); 2766 | } 2767 | } 2768 | 2769 | // Prints a character to display, with cursor, handling control characters 2770 | void Display (char c) { 2771 | static uint8_t Line = 0, Column = 0, Scroll = 0; 2772 | // These characters don't affect the cursor 2773 | if (c == 8) { // Backspace 2774 | if (Column == 0) { 2775 | Line--; Column = 20; 2776 | } else Column--; 2777 | return; 2778 | } 2779 | if (c == 9) { // Cursor forward 2780 | if (Column == 20) { 2781 | Line++; Column = 0; 2782 | } else Column++; 2783 | return; 2784 | } 2785 | if ((c >= 17) && (c <= 20)) { // Parentheses 2786 | if (c == 17) PlotChar('(', Line+Scroll, Column); 2787 | else if (c == 18) PlotChar('(' | 0x80, Line+Scroll, Column); 2788 | else if (c == 19) PlotChar(')', Line+Scroll, Column); 2789 | else PlotChar(')' | 0x80, Line+Scroll, Column); 2790 | return; 2791 | } 2792 | // Hide cursor 2793 | PlotChar(' ', Line+Scroll, Column); 2794 | if (c == 0x7F) { // DEL 2795 | if (Column == 0) { 2796 | Line--; Column = 20; 2797 | } else Column--; 2798 | } else if ((c & 0x7f) >= 32) { // Normal character 2799 | PlotChar(c, Line+Scroll, Column++); 2800 | if (Column > 20) { 2801 | Column = 0; 2802 | if (Line == 7) ScrollDisplay(&Scroll); else Line++; 2803 | } 2804 | // Control characters 2805 | } else if (c == 12) { // Clear display 2806 | for (uint8_t p=0; p < 8; p++) ClearLine(p); 2807 | Line = 0; Column = 0; 2808 | } else if (c == '\r') { // Return 2809 | Column = 0; 2810 | if (Line == 7) ScrollDisplay(&Scroll); else Line++; 2811 | } 2812 | // Show cursor 2813 | PlotChar(0x7F, Line+Scroll, Column); 2814 | } 2815 | 2816 | // Keyboard ********************************************************************************** 2817 | 2818 | const int KeymapSize = 132; 2819 | const int Cursor = 0x7F; 2820 | 2821 | const char Keymap[] PROGMEM = 2822 | // Without shift 2823 | " \011` q1 zsaw2 cxde43 vftr5 nbhgy6 mju78 ,kio09" 2824 | " ./l;p- \' [= \015] \\ \010 1 47 0.2568\033 +3-*9 " 2825 | // With shift 2826 | " \011~ Q! ZSAW@ CXDE$# VFTR% NBHGY^ MJU&* ?L:P_ \" {+ \015} | \010 1 47 0.2568\033 +3-*9 "; 2828 | 2829 | // Parenthesis highlighting 2830 | void Highlight (uint8_t p, uint8_t invert) { 2831 | if (p) { 2832 | for (int n=0; n < p; n++) Display(8); 2833 | Display(17 + invert); 2834 | for (int n=1; n < p; n++) Display(9); 2835 | Display(19 + invert); 2836 | Display(9); 2837 | } 2838 | } 2839 | 2840 | ISR(KEYBOARD_VECTOR) { 2841 | static uint8_t Break = 0, Modifier = 0, Shift = 0, Parenthesis = 0; 2842 | static int ScanCode = 0, ScanBit = 1; 2843 | #if defined(__AVR_ATmega328P__) 2844 | if (PIND & 1<> 1; 2853 | ScanCode = 0, ScanBit = 1; 2854 | if (s == 0xAA) return; // BAT completion code 2855 | // 2856 | if (s == 0xF0) { Break = 1; return; } 2857 | if (s == 0xE0) { Modifier = 1; return; } 2858 | if (Break) { 2859 | if ((s == 0x12) || (s == 0x59)) Shift = 0; 2860 | Break = 0; Modifier = 0; return; 2861 | } 2862 | if ((s == 0x12) || (s == 0x59)) Shift = 1; 2863 | if (Modifier) return; 2864 | char c = pgm_read_byte(&Keymap[s + KeymapSize*Shift]); 2865 | if (c == 32 && s != 0x29) return; 2866 | if (c == 27) { Escape = 1; return; } // Escape key 2867 | // Undo previous parenthesis highlight 2868 | Highlight(Parenthesis, 0); 2869 | Parenthesis = 0; 2870 | // Edit buffer 2871 | if (c == '\r') { 2872 | pchar('\r'); 2873 | KybdAvailable = 1; 2874 | ReadPtr = 0; 2875 | return; 2876 | } 2877 | if (c == 8) { // Backspace key 2878 | if (WritePtr > 0) { 2879 | WritePtr--; 2880 | Display(0x7F); 2881 | if (WritePtr) c = KybdBuf[WritePtr-1]; 2882 | } 2883 | } else if (WritePtr < KybdBufSize) { 2884 | KybdBuf[WritePtr++] = c; 2885 | Display(c); 2886 | } 2887 | // Do new parenthesis highlight 2888 | if (c == ')') { 2889 | int search = WritePtr-1, level = 0; 2890 | while (search >= 0 && Parenthesis == 0) { 2891 | c = KybdBuf[search--]; 2892 | if (c == ')') level++; 2893 | if (c == '(') { 2894 | level--; 2895 | if (level == 0) Parenthesis = WritePtr-search-1; 2896 | } 2897 | } 2898 | Highlight(Parenthesis, 1); 2899 | } 2900 | return; 2901 | } 2902 | 2903 | void InitKybd() { 2904 | #if defined(__AVR_ATmega328P__) 2905 | EICRA = 2< ")); 2948 | object *line = read(); 2949 | if (BreakLevel && line == nil) { pln(); return; } 2950 | if (line == (object *)KET) error(F("Unmatched right bracket")); 2951 | push(line, GCStack); 2952 | pfl(); 2953 | line = eval(line, env); 2954 | pfl(); 2955 | printobject(line); 2956 | pop(GCStack); 2957 | pln(); 2958 | pln(); 2959 | } 2960 | } 2961 | 2962 | void loop() { 2963 | if (!setjmp(exception)) { 2964 | #if defined(resetautorun) 2965 | object *autorun = (object *)eeprom_read_word(&image.eval); 2966 | if (autorun != NULL && (unsigned int)autorun != 0xFFFF) { 2967 | loadimage(); 2968 | apply(autorun, NULL, NULL); 2969 | } 2970 | #endif 2971 | } 2972 | repl(NULL); 2973 | } 2974 | --------------------------------------------------------------------------------