├── .gitignore ├── LICENSE ├── README.md ├── alire.toml ├── bbs_lisp.gpr ├── bbs_lisp_noalr.gpr ├── cli ├── alire.toml ├── lispcli.adb ├── lispcli.gpr ├── lispcli_noalr.gpr ├── new_line.adb └── new_line.ads ├── doc ├── Coverage-Summary.ods ├── Tiny-Lisp.pdf └── Tiny-Lisp.tex ├── scripts ├── coverage ├── make_info └── pre-commit ├── src ├── bbs-lisp-conses.adb ├── bbs-lisp-conses.ads ├── bbs-lisp-debug.adb ├── bbs-lisp-debug.ads ├── bbs-lisp-evaluate-bool.adb ├── bbs-lisp-evaluate-bool.ads ├── bbs-lisp-evaluate-char.adb ├── bbs-lisp-evaluate-char.ads ├── bbs-lisp-evaluate-cond.adb ├── bbs-lisp-evaluate-cond.ads ├── bbs-lisp-evaluate-func.adb ├── bbs-lisp-evaluate-func.ads ├── bbs-lisp-evaluate-io.adb ├── bbs-lisp-evaluate-io.ads ├── bbs-lisp-evaluate-list.adb ├── bbs-lisp-evaluate-list.ads ├── bbs-lisp-evaluate-loops.adb ├── bbs-lisp-evaluate-loops.ads ├── bbs-lisp-evaluate-math.adb ├── bbs-lisp-evaluate-math.ads ├── bbs-lisp-evaluate-mem.adb ├── bbs-lisp-evaluate-mem.ads ├── bbs-lisp-evaluate-misc.adb ├── bbs-lisp-evaluate-misc.ads ├── bbs-lisp-evaluate-pred.adb ├── bbs-lisp-evaluate-pred.ads ├── bbs-lisp-evaluate-str.adb ├── bbs-lisp-evaluate-str.ads ├── bbs-lisp-evaluate-symb.adb ├── bbs-lisp-evaluate-symb.ads ├── bbs-lisp-evaluate-vars.adb ├── bbs-lisp-evaluate-vars.ads ├── bbs-lisp-evaluate.adb ├── bbs-lisp-evaluate.ads ├── bbs-lisp-global.ads ├── bbs-lisp-info.ads ├── bbs-lisp-memory.adb ├── bbs-lisp-memory.ads ├── bbs-lisp-parser-file.adb ├── bbs-lisp-parser-file.ads ├── bbs-lisp-parser-stdio.adb ├── bbs-lisp-parser-stdio.ads ├── bbs-lisp-parser-string.adb ├── bbs-lisp-parser-string.ads ├── bbs-lisp-parser.adb ├── bbs-lisp-parser.ads ├── bbs-lisp-stack.adb ├── bbs-lisp-stack.ads ├── bbs-lisp-strings.adb ├── bbs-lisp-strings.ads ├── bbs-lisp-symbols.adb ├── bbs-lisp-symbols.ads ├── bbs-lisp.adb ├── bbs-lisp.ads ├── math.lisp └── sample.lisp └── test ├── debug.lisp ├── primes.lisp └── test.lisp /.gitignore: -------------------------------------------------------------------------------- 1 | # Object file 2 | *.o 3 | 4 | cli/lispcli 5 | 6 | # Code coverage 7 | *.gcov 8 | *.gcda 9 | *.gcno 10 | summary-cov.txt 11 | 12 | # Ada Library Information 13 | *.ali 14 | *.stderr 15 | *.stdout 16 | *.bexch 17 | lisp 18 | lisp.exe 19 | *.db 20 | *.db-shm 21 | *.db-wal 22 | *.cgpr 23 | *.db 24 | b__lisp.ad* 25 | lib/* 26 | obj/* 27 | */lib/* 28 | */obj/* 29 | *.cswi 30 | *.lexch 31 | 32 | # Alire directories 33 | alire/* 34 | */alire/* 35 | config/* 36 | */config/* 37 | 38 | # Latex auxiliary files 39 | *.aux 40 | *.log 41 | *.synctex.gz 42 | *.toc 43 | 44 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Ada-Lisp 2 | This is a tiny Lisp interpreter written in Ada. As such, it lacks many of the features of 3 | a full Common Lisp, but can provide a simple Lisp-like programming environment. 4 | 5 | If you find it useful or interesting, drop me a note at brentseidel@gmail.com and 6 | let me know. 7 | 8 | Note that this is my first attempt at writing a programming language, so I'm sure 9 | that things could have been done better. It has been a learning experience and 10 | I'm pleased with how well that it's actually turned out. 11 | 12 | 13 | [![Alire](https://img.shields.io/endpoint?url=https://alire.ada.dev/badges/bbs_lisp.json)] 14 | (https://alire.ada.dev/crates/bbs_lisp.html) 15 | 16 | 17 | [![Alire](https://img.shields.io/endpoint?url=https://alire.ada.dev/badges/lispcli.json)] 18 | (https://alire.ada.dev/crates/lispcli.html) 19 | 20 | 21 | ## Dependencies and Building 22 | This is available using alire (alr get bbs_lisp). This will handle all 23 | of the dependencies. Alire is available from https://alire.ada.dev. 24 | 25 | If you do not with to use alire, you will need to fetch https://github.com/BrentSeidel/BBS-Ada. 26 | 27 | ## Interpreter/Compiler 28 | I am calling this an interpreter, though the boundaries are a bit fuzzy. The input text is 29 | converted into s-expressions that represent the program. The address for the builtin 30 | operations are stored in the s-expression and are then directly called when evaluated. 31 | It may be considered to be a threaded interpreter (which as nothing to do with programming 32 | threads as a method of concurrent programming). 33 | 34 | ## Goals 35 | While under initial development, this runs on a host computer (MacOs, in my case), the 36 | goal (achieved) is to get it to run on ARM based embedded systems. Many of these little 37 | ARM based boards have more computing power than the personal computers that I grew up 38 | with and it seemed like a good idea to provide some sort of interpreter that could be 39 | used to write simple programs directly on the board. I did briefly toy with the idea 40 | of a tiny BASIC interpreter, but quickly abandoned that idea in favor of Lisp. 41 | 42 | The idea is that not only can simple programs be written, but it can also be used to 43 | develop algorithms for accessing the board's hardware. Once the algorithm development is 44 | finished, they can be translated into Ada and compiled. 45 | 46 | ## Status 47 | 48 | While the only guarentee is that this contains bugs and is missing features, it 49 | is usable. I've been able to write some small programs in it both on the Mac and 50 | on the Arduino Due. It is nice to be able to change what the Arduino Due is doing 51 | without having to do a whole compile-load cycle. I have also used it for automated 52 | testing on my [SimCPU](https://github.com/BrentSeidel/Sim-CPU) project and it has 53 | worked quite well. Execution of the simulator can be scripted also allowing 54 | testing and debugging of code running on the simulator. 55 | 56 | A set of test cases have been written and code coverage checked. The 57 | tests are useful verify that code changes still work and have helped to 58 | find a number of bugs in the software. Code coverage has been checked 59 | based on the tests and the coverage is just above 90% statement coverage. 60 | 61 | ### Porting 62 | It now runs on the Arduino Due. It took a bit of work to remove all dependencies 63 | on Ada libraries that aren't available on the Arduino Due. Another feature added 64 | was the ability for the host software to add custom lisp commands. Thus, the 65 | main Arduino Due program can add custom Lisp commands for accessing the Arduino 66 | hardware. An example of this is the Ada-Lisp-Embedded repository at 67 | https://github.com/BrentSeidel/Ada-Lisp-Embedded 68 | 69 | This Lisp interpreter also builds and runs on Windows 10 as well as a Raspberry 70 | PI under Raspberian. 71 | 72 | ### Supported Data Types 73 | 1. Integers are the standard Ada integer type. 74 | 2. Strings are variable length and implemented using a linked list. 75 | 3. Booleans are either "T" (true) or "NIL" (false). 76 | 4. Characters are single ASCII characters (Unicode is not supported). 77 | 5. Lists are linked lists of elements that can be of any datatype (even other lists) 78 | 79 | ### Supported Operations 80 | 1. Basic arithmetic 81 | 2. Comparisons 82 | 3. List operations - CAR and CDR 83 | 4. DOWHILE/DOTIMES 84 | 5. User defined functions and lambda functions. 85 | 6. Local variables. 86 | 7. Hardware access. This is done by allowing the host software to add custom lisp 87 | commands. This may also be useful for embedding the lisp interpreter in other 88 | applications. 89 | 8. Peek and Poke functions for accessing memory. This is mainly for use on embedded 90 | systems. 91 | 9. Logical and bitwise logical operations AND, OR, NOT. 92 | 93 | ### Non-Supported Features 94 | There are others, but here are the main missing features. Some of these may eventually 95 | be implemented, others will never be implemented. The goal is to have a useful 96 | little language, not another port of Common Lisp. 97 | 1. Macros. This is a long term goal. I would like to implement these, but I need to 98 | figure out how first. 99 | 2. Object oriented features. This will probably never happen. 100 | 3. Closures. This will probably never happen. 101 | 4. Packages and similar large program related features. Remember *Tiny* Lisp. 102 | 103 | ### Roadmap 104 | The following updates to the language are planned. They may not be done in the 105 | order shown and other items may be added before some of these. 106 | 1. Improved error handling and general code cleanup (ongoing). 107 | 2. Convert the BBS.lisp package to a generic with the data structure sizes as 108 | parameters. This will make it easier to resize things for specific targets. 109 | 110 | ## Internals 111 | 112 | ### Memory Management 113 | Since this is intended to run on embedded systems without any memory management, the memory 114 | pools are pre-allocated and sized arrays from which objects can be allocated. Each object 115 | has a reference count and the object it freed when the number of references reaches 0. Note 116 | that reference counting is not automatic and has to be done manually. 117 | 118 | One advantage that I've discovered about reference counting is that is usually 119 | quickly makes one aware that one has done something wrong. Two types of errors 120 | are possible - prematurely dereffing an object or not dereffing an object. 121 | 122 | The memory manager is probably not thread safe, though this could be an interesting 123 | project. 124 | 125 | ### Static Tables 126 | Symbols, cons cells, and strings are allocated from statically defined arrays. This 127 | design decision was made to enable the interpreter to run on systems without any 128 | sort of dynamic memory management. Basically, I rolled my own. The size of these 129 | tables are set when compiling the interpreter and can be changed to suit your use. 130 | -------------------------------------------------------------------------------- /alire.toml: -------------------------------------------------------------------------------- 1 | name = "bbs_lisp" 2 | description = "Embedable tiny lisp interpreter" 3 | version = "0.2.1" 4 | 5 | long-description = """ 6 | This is the core of a simple tiny lisp that is intended to be embedded in 7 | other applications. It can be extended with new commands specific to 8 | the application. 9 | """ 10 | 11 | authors = ["Brent Seidel"] 12 | maintainers = ["Brent Seidel "] 13 | maintainers-logins = ["BrentSeidel"] 14 | licenses = "GPL-3.0-or-later" 15 | website = "https://github.com/BrentSeidel/Ada-Lisp" 16 | tags = ["lisp", "embedded"] 17 | 18 | [[depends-on]] 19 | bbs = "~0.1.0" 20 | -------------------------------------------------------------------------------- /bbs_lisp.gpr: -------------------------------------------------------------------------------- 1 | with "config/bbs_lisp_config.gpr"; 2 | 3 | library project bbs_lisp is 4 | 5 | for Languages use ("Ada"); 6 | for Library_Name use "Bbs-Lisp"; 7 | for Source_Dirs use ("src"); 8 | for Object_Dir use "obj"; 9 | for Library_Dir use "lib"; 10 | 11 | package Compiler is 12 | for Switches ("ada") use ("-gnata", "-gnatf", "-gnat12", "-g", "-O", "-gnatVa", "-gnatw.Xa"); 13 | end Compiler; 14 | 15 | package Prove is 16 | for Switches use ("--codepeer=on", "-j0"); 17 | end Prove; 18 | 19 | package Builder is 20 | for Switches ("ada") use ("-s", "-j0"); 21 | end Builder; 22 | 23 | end bbs_lisp; 24 | 25 | -------------------------------------------------------------------------------- /bbs_lisp_noalr.gpr: -------------------------------------------------------------------------------- 1 | with "../BBS-Ada/bbs.gpr"; 2 | 3 | library project bbs_lisp_noalr is 4 | 5 | for Languages use ("Ada"); 6 | for Library_Name use "Bbs-Lisp"; 7 | for Source_Dirs use ("src"); 8 | for Object_Dir use "obj"; 9 | for Library_Dir use "lib"; 10 | 11 | package Compiler is 12 | for Switches ("ada") use ("-gnata", "-gnatf", "-gnat12", "-g", "-O", "-gnatVa", "-gnatw.Xa"); 13 | end Compiler; 14 | 15 | package Prove is 16 | for Switches use ("--codepeer=on", "-j0"); 17 | end Prove; 18 | 19 | package Builder is 20 | for Switches ("ada") use ("-s", "-j0"); 21 | end Builder; 22 | 23 | end bbs_lisp_noalr; 24 | 25 | -------------------------------------------------------------------------------- /cli/alire.toml: -------------------------------------------------------------------------------- 1 | name = "lispcli" 2 | description = "Simple program for exploring tiny lisp" 3 | version = "0.1.1" 4 | 5 | long-description = """ 6 | This is a simple example of embedding Lisp to provide a REPL where you 7 | can try various Lisp functions. It can also be modified to test out 8 | Lisp extensions. 9 | """ 10 | 11 | authors = ["Brent Seidel"] 12 | maintainers = ["Brent Seidel "] 13 | maintainers-logins = ["BrentSeidel"] 14 | licenses = "GPL-3.0-or-later" 15 | website = "https://github.com/BrentSeidel/Ada-Lisp" 16 | tags = ["lisp"] 17 | 18 | executables = ["lispcli"] 19 | 20 | [[depends-on]] 21 | gnat = ">7.5" 22 | 23 | [[depends-on]] 24 | bbs = "~0.1.0" 25 | 26 | [[depends-on]] 27 | bbs_lisp = "~0.1.0" 28 | -------------------------------------------------------------------------------- /cli/lispcli.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Author: Brent Seidel 3 | -- Date: 31-Jul-2024 4 | -- 5 | -- This file is part of Tiny-Lisp. 6 | -- Tiny-Lisp is free software: you can redistribute it and/or modify it 7 | -- under the terms of the GNU General Public License as published by the 8 | -- Free Software Foundation, either version 3 of the License, or (at your 9 | -- option) any later version. 10 | -- 11 | -- Tiny-Lisp is distributed in the hope that it will be useful, but 12 | -- WITHOUT ANY WARRANTY; without even the implied warranty of 13 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General 14 | -- Public License for more details. 15 | -- 16 | -- You should have received a copy of the GNU General Public License along 17 | -- with Tiny-Lisp. If not, see .-- 18 | -- 19 | with Ada.Text_IO; 20 | with BBS.lisp; 21 | with BBS.lisp.info; 22 | with new_line; 23 | -- 24 | -- This is a simple shell routine to call the embedded lisp interpreter. 25 | -- 26 | procedure lispcli is 27 | begin 28 | Ada.Text_IO.Put_Line("Tiny lisp interpreter written in Ada."); 29 | Ada.Text_IO.Put_Line(BBS.lisp.info.name & " " & BBs.lisp.info.version_string & 30 | " " & BBS.lisp.info.build_date); 31 | bbs.lisp.init(Ada.Text_IO.Put_Line'Access, Ada.Text_IO.Put'Access, 32 | new_line.New_Line'Access, Ada.Text_IO.Get_Line'Access); 33 | bbs.lisp.repl; 34 | end lispcli; 35 | -------------------------------------------------------------------------------- /cli/lispcli.gpr: -------------------------------------------------------------------------------- 1 | with "config/lispcli_config.gpr"; 2 | 3 | project lispcli is 4 | 5 | for Source_Dirs use ("."); 6 | for Object_Dir use "obj"; 7 | for Main use ("lispcli.adb"); 8 | for Exec_Dir use "."; 9 | 10 | package Builder is 11 | for Switches ("ada") use ("-g", "-s", "-j0"); 12 | end Builder; 13 | 14 | package Compiler is 15 | for Switches ("ada") use ("-g", "-gnato", "-gnatp", "-fstack-check", "-gnatf", "-gnat12", "-gnata", "-gnatVa", "-gnatw.X.d.f.g.h.k.l.n.o.s.u.wadhlt", "-gnatybdfh"); 16 | end Compiler; 17 | 18 | package Binder is 19 | for Switches ("ada") use ("-E", "-r"); 20 | end Binder; 21 | 22 | package Linker is 23 | for Switches ("ada") use ("-g"); 24 | end Linker; 25 | 26 | package Prove is 27 | for Switches use ("--level=0", "--codepeer=on", "-j0"); 28 | end Prove; 29 | 30 | end lispcli; 31 | 32 | -------------------------------------------------------------------------------- /cli/lispcli_noalr.gpr: -------------------------------------------------------------------------------- 1 | with "../../BBS-Ada/bbs.gpr"; 2 | with "../bbs_lisp_noalr.gpr"; 3 | project lispcli_noalr is 4 | 5 | for Source_Dirs use ("."); 6 | for Object_Dir use "obj"; 7 | for Main use ("lispcli.adb"); 8 | for Exec_Dir use "."; 9 | 10 | package Builder is 11 | for Switches ("ada") use ("-g", "-s", "-j0"); 12 | end Builder; 13 | 14 | package Compiler is 15 | for Switches ("ada") use ("-g", "-gnato", "-gnatp", "-fstack-check", "-gnatf", "-gnat12", "-gnata", "-gnatVa", "-gnatw.X.d.f.g.h.k.l.n.o.s.u.wadhlt", "-gnatybdfh"); 16 | end Compiler; 17 | 18 | package Binder is 19 | for Switches ("ada") use ("-E", "-r"); 20 | end Binder; 21 | 22 | package Linker is 23 | for Switches ("ada") use ("-g"); 24 | end Linker; 25 | 26 | package Prove is 27 | for Switches use ("--level=0", "--codepeer=on", "-j0"); 28 | end Prove; 29 | 30 | end lispcli_noalr; 31 | 32 | -------------------------------------------------------------------------------- /cli/new_line.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Author: Brent Seidel 3 | -- Date: 31-Jul-2024 4 | -- 5 | -- This file is part of Tiny-Lisp CLI. 6 | -- Tiny-Lisp is free software: you can redistribute it and/or modify it 7 | -- under the terms of the GNU General Public License as published by the 8 | -- Free Software Foundation, either version 3 of the License, or (at your 9 | -- option) any later version. 10 | -- 11 | -- Tiny-Lisp is distributed in the hope that it will be useful, but 12 | -- WITHOUT ANY WARRANTY; without even the implied warranty of 13 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General 14 | -- Public License for more details. 15 | -- 16 | -- You should have received a copy of the GNU General Public License along 17 | -- with Tiny-Lisp. If not, see .-- 18 | -- 19 | with Ada.Text_IO; 20 | package body new_line is 21 | 22 | procedure new_line is 23 | begin 24 | Ada.Text_IO.New_Line; 25 | end; 26 | 27 | end new_line; 28 | -------------------------------------------------------------------------------- /cli/new_line.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Author: Brent Seidel 3 | -- Date: 31-Jul-2024 4 | -- 5 | -- This file is part of Tiny-Lisp CLI. 6 | -- Tiny-Lisp is free software: you can redistribute it and/or modify it 7 | -- under the terms of the GNU General Public License as published by the 8 | -- Free Software Foundation, either version 3 of the License, or (at your 9 | -- option) any later version. 10 | -- 11 | -- Tiny-Lisp is distributed in the hope that it will be useful, but 12 | -- WITHOUT ANY WARRANTY; without even the implied warranty of 13 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General 14 | -- Public License for more details. 15 | -- 16 | -- You should have received a copy of the GNU General Public License along 17 | -- with Tiny-Lisp. If not, see .-- 18 | -- 19 | -- The text_io version of newline contains an optional parameter indicating 20 | -- the number of lines to skip. The type of this parameter is defined in 21 | -- Ada.Text_IO. This makes it awkward to define a function prototype that can 22 | -- be used both when Ada.Text_IO is available and when it isn't. This is a 23 | -- crude hack to define locally a new_line that has no parameters and uses the 24 | -- Ada.Text_IO new_line with the default value. 25 | -- 26 | package new_line is 27 | procedure new_line; 28 | end new_line; 29 | -------------------------------------------------------------------------------- /doc/Coverage-Summary.ods: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BrentSeidel/Ada-Lisp/16103c334b5e02701fcc290de8cecf0a652e3558/doc/Coverage-Summary.ods -------------------------------------------------------------------------------- /doc/Tiny-Lisp.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BrentSeidel/Ada-Lisp/16103c334b5e02701fcc290de8cecf0a652e3558/doc/Tiny-Lisp.pdf -------------------------------------------------------------------------------- /scripts/coverage: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # 3 | # Script to do code coverage 4 | # 5 | # 6 | # Remove old files from the obj directory and existing coverage files 7 | # 8 | rm obj/* 9 | rm *.gcov 10 | # 11 | # Build the application for code coverage 12 | # 13 | scripts/make_info 14 | gnatmake -P ./cli/lispcli.gpr -f --create-map-file -cargs -fprofile-arcs -ftest-coverage -largs -fprofile-arcs 15 | # 16 | # Run the application with the test input 17 | # 18 | ./cli/lispcli < test/$1.lisp 19 | # 20 | # Process the code coverage results 21 | # 22 | gcov obj/*.gcda > summary-cov.txt 23 | -------------------------------------------------------------------------------- /scripts/make_info: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # 3 | # This script creates the BBS.lisp.info package file. It contains 4 | # constants for the compile time and date. For each release, update 5 | # the version string and version number here. 6 | # 7 | cat < src/bbs-lisp-info.ads 8 | package BBS.lisp.info is 9 | -- 10 | -- This file is auto generated by the pre-commit hook as well as 11 | -- the test coverage script. It should not be edited by hand. 12 | -- 13 | name : constant String := "Tiny Lisp"; 14 | timestamp : constant String := "`date`"; 15 | build_date : constant String := "`date +"%Y-%b-%d"` (`git rev-parse --abbrev-ref HEAD`)"; 16 | version_string : constant String := "Alire 00.02.00+"; 17 | version_date : constant Integer := `date +"%Y%m%d"`; -- yyyymmdd 18 | version_number : constant Integer := 3; 19 | end; 20 | EOF 21 | -------------------------------------------------------------------------------- /scripts/pre-commit: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # 3 | # First try to build the lisp software. 4 | # 5 | echo "Building software" 6 | scripts/make_info 7 | if alr build 8 | then 9 | echo "Library Build succeeded" 10 | else 11 | echo "Error occured during build - Aborting" 12 | exit 1 13 | fi 14 | cd cli 15 | if alr build 16 | then 17 | echo "CLI Build succeeded" 18 | else 19 | echo "Error occured during build - Aborting" 20 | exit 1 21 | fi 22 | cd .. 23 | # 24 | # Next run the tests and see if there are any failures 25 | # 26 | echo "Running tests" 27 | if ./cli/lispcli < test/test.lisp | grep '^...FAIL' 28 | then 29 | echo "Test failures detected" 30 | exit 1 31 | fi 32 | echo "No test failures detected" 33 | exit 0 34 | 35 | -------------------------------------------------------------------------------- /src/bbs-lisp-conses.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Author: Brent Seidel 3 | -- Date: 31-Jul-2024 4 | -- 5 | -- This file is part of Tiny-Lisp. 6 | -- Tiny-Lisp is free software: you can redistribute it and/or modify it 7 | -- under the terms of the GNU General Public License as published by the 8 | -- Free Software Foundation, either version 3 of the License, or (at your 9 | -- option) any later version. 10 | -- 11 | -- Tiny-Lisp is distributed in the hope that it will be useful, but 12 | -- WITHOUT ANY WARRANTY; without even the implied warranty of 13 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General 14 | -- Public License for more details. 15 | -- 16 | -- You should have received a copy of the GNU General Public License along 17 | -- with Tiny-Lisp. If not, see .-- 18 | -- 19 | with BBS.lisp.evaluate; 20 | with BBS.lisp.memory; 21 | package body BBS.lisp.conses is 22 | -- 23 | -- Routines for accessing the cons table 24 | -- 25 | function get_car(s : cons_index) return element_type is 26 | begin 27 | return cons_table(s).car; 28 | end; 29 | -- 30 | procedure set_car(s : cons_index; e : element_type) is 31 | begin 32 | cons_table(s).car := e; 33 | end; 34 | -- 35 | function get_cdr(s : cons_index) return element_type is 36 | begin 37 | return cons_table(s).cdr; 38 | end; 39 | -- 40 | procedure set_cdr(s : cons_index; e : element_type) is 41 | begin 42 | cons_table(s).cdr := e; 43 | end; 44 | -- 45 | function get_ref(s : cons_index) return cons_ref_count is 46 | begin 47 | return cons_table(s).ref; 48 | end; 49 | -- ------------------------------------------------------------------------ 50 | -- Memory management 51 | -- 52 | -- Ghost functions used in some proofs. 53 | -- 54 | function count_free_cons return Natural is 55 | count : Natural := 0; 56 | begin 57 | for i in cons_table'Range loop 58 | if cons_table(i).ref = 0 then 59 | count := count + 1; 60 | end if; 61 | end loop; 62 | return count; 63 | end; 64 | -- 65 | -- Reset the cons table 66 | -- 67 | procedure reset_cons_table is 68 | begin 69 | for i in cons_table'Range loop 70 | cons_table(i).ref := FREE_CONS; 71 | cons_table(i).car := NIL_ELEM; 72 | cons_table(i).cdr := NIL_ELEM; 73 | end loop; 74 | end; 75 | -- 76 | -- Find an used cons cell in the table, mark it as USED, and return the 77 | -- index in s. Return false if no such cell could be found. 78 | -- 79 | function alloc(s : out cons_index) return Boolean is 80 | begin 81 | for i in cons_table'Range loop 82 | if cons_table(i).ref = FREE_CONS then 83 | s := i; 84 | cons_table(i).ref := FREE_CONS + 1; 85 | cons_table(i).car := NIL_ELEM; 86 | cons_table(i).cdr := NIL_ELEM; 87 | return True; 88 | end if; 89 | end loop; 90 | s := NIL_CONS; 91 | return False; 92 | end; 93 | -- 94 | -- Increments the reference count of a cons cell. 95 | -- 96 | procedure ref(s : cons_index) is 97 | begin 98 | if cons_table(s).ref = FREE_CONS then 99 | error("ref cons", "Attempting to ref an unallocated cons."); 100 | end if; 101 | cons_table(s).ref := cons_table(s).ref + 1; 102 | end; 103 | -- 104 | -- Decrements the reference count of a cons cell. 105 | -- 106 | procedure deref(s : cons_index) is 107 | l : cons_index := s; 108 | e : element_type; 109 | begin 110 | while l > NIL_CONS loop 111 | msg("deref cons", "Dereffing cons at " & cons_index'Image(l) & 112 | " Ref count was " & Integer'Image(Integer(cons_table(l).ref))); 113 | if cons_table(l).ref > FREE_CONS then 114 | cons_table(l).ref := cons_table(l).ref - 1; 115 | else 116 | error("deref cons", "Attempt to deref an unreffed cons at index " 117 | & cons_index'Image(l)); 118 | end if; 119 | -- 120 | -- If the reference count goes to zero, deref the things that the cons 121 | -- points to. 122 | -- 123 | if cons_table(l).ref = FREE_CONS then 124 | BBS.lisp.memory.deref(cons_table(l).car); 125 | e := cons_table(l).cdr; 126 | cons_table(l).car := NIL_ELEM; 127 | cons_table(l).cdr := NIL_ELEM; 128 | l := BBS.lisp.evaluate.getList(e); 129 | else 130 | l := NIL_CONS; 131 | end if; 132 | end loop; 133 | end; 134 | end; 135 | -------------------------------------------------------------------------------- /src/bbs-lisp-conses.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Author: Brent Seidel 3 | -- Date: 31-Jul-2024 4 | -- 5 | -- This file is part of Tiny-Lisp. 6 | -- Tiny-Lisp is free software: you can redistribute it and/or modify it 7 | -- under the terms of the GNU General Public License as published by the 8 | -- Free Software Foundation, either version 3 of the License, or (at your 9 | -- option) any later version. 10 | -- 11 | -- Tiny-Lisp is distributed in the hope that it will be useful, but 12 | -- WITHOUT ANY WARRANTY; without even the implied warranty of 13 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General 14 | -- Public License for more details. 15 | -- 16 | -- You should have received a copy of the GNU General Public License along 17 | -- with Tiny-Lisp. If not, see .-- 18 | -- 19 | -- This package contains definitions and routines relating to cons cells for the 20 | -- tiny lisp interpreter. 21 | -- 22 | package BBS.lisp.conses is 23 | pragma Elaborate_Body; 24 | -- 25 | -- Types for cons reference counts 26 | -- 27 | type cons_ref_count is new Natural; 28 | FREE_CONS : constant cons_ref_count := cons_ref_count'First; 29 | -- 30 | -- A cons cell contains two element_type pointers that can point to either 31 | -- an atom or another cons cell. 32 | -- 33 | type cons is 34 | record 35 | ref : cons_ref_count; 36 | car : element_type; 37 | cdr : element_type; 38 | end record; 39 | -- 40 | -- Routines for accessing the cons table 41 | -- 42 | function get_car(s : cons_index) return element_type 43 | with pre => (s > NIL_CONS); 44 | pragma Pure_Function(get_car); 45 | -- 46 | procedure set_car(s : cons_index; e : element_type) 47 | with pre => (s > NIL_CONS); 48 | -- 49 | function get_cdr(s : cons_index) return element_type 50 | with pre => (s > NIL_CONS); 51 | pragma Pure_Function(get_cdr); 52 | -- 53 | procedure set_cdr(s : cons_index; e : element_type) 54 | with pre => (s > NIL_CONS); 55 | -- 56 | function get_ref(s : cons_index) return cons_ref_count 57 | with pre => (s > NIL_CONS); 58 | pragma Pure_Function(get_ref); 59 | -- ------------------------------------------------------------------------ 60 | -- Memory management 61 | -- 62 | -- Ghost functions used in some proofs. 63 | -- 64 | function count_free_cons return Natural 65 | with Ghost; 66 | -- 67 | -- Reset the cons table 68 | -- 69 | procedure reset_cons_table; 70 | -- 71 | -- Allocate a cons cell. The table is searched for an entry with 72 | -- a reference count of zero. If such an entry is found, its reference 73 | -- count is set to 1 and the output parameter is set to the index of the 74 | -- entry and True is returned. If no such value is found, False is returned 75 | -- and the output value should be ignored. 76 | -- 77 | function alloc(s : out cons_index) return Boolean 78 | with post => (if count_free_cons'Old = 0 then alloc'Result = False 79 | else alloc'Result); 80 | -- 81 | -- Increment the reference count a cons cell This is typically done 82 | -- when an additional index to the item is created. 83 | -- 84 | procedure ref(s : cons_index); 85 | -- 86 | -- Decrement the reference count of a cons cell. This is done when the 87 | -- reference is no longer needed. If the reference count reaches 0, the 88 | -- item is considered to be deallocated. In this case, if the item points 89 | -- to other items, they will be recursively dereffed. 90 | -- 91 | procedure deref(s : cons_index); 92 | private 93 | -- 94 | -- The main data tables for various kinds of data. 95 | -- 96 | -- Since this interpreter is designed to be used on embedded computers with 97 | -- no operating system and possibly no dynamic memory allocation, The 98 | -- statically allocated data structures are defined here. 99 | -- 100 | cons_table : array (cons_index'First + 1 .. cons_index'Last) of cons; 101 | 102 | end; 103 | -------------------------------------------------------------------------------- /src/bbs-lisp-debug.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Author: Brent Seidel 3 | -- Date: 31-Jul-2024 4 | -- 5 | -- This file is part of Tiny-Lisp. 6 | -- Tiny-Lisp is free software: you can redistribute it and/or modify it 7 | -- under the terms of the GNU General Public License as published by the 8 | -- Free Software Foundation, either version 3 of the License, or (at your 9 | -- option) any later version. 10 | -- 11 | -- Tiny-Lisp is distributed in the hope that it will be useful, but 12 | -- WITHOUT ANY WARRANTY; without even the implied warranty of 13 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General 14 | -- Public License for more details. 15 | -- 16 | -- You should have received a copy of the GNU General Public License along 17 | -- with Tiny-Lisp. If not, see .-- 18 | -- 19 | with BBS.lisp.conses; 20 | with BBS.lisp.evaluate; 21 | with BBS.lisp.strings; 22 | with BBS.lisp.symbols; 23 | package body BBS.lisp.debug is 24 | 25 | -- 26 | procedure dump(e : element_type) is 27 | begin 28 | case e.kind is 29 | when V_INTEGER => 30 | Put(int32'Image(e.i) & " "); 31 | when V_CHARACTER => 32 | Put("'" & e.c & "'"); 33 | when V_STRING => 34 | put(" STR: Ref: " & BBS.lisp.strings.str_ref_count'Image(BBS.lisp.strings.ref_count(e.s)) & " Value: "); 35 | print(e.s); 36 | when V_BOOLEAN => 37 | if e.b then 38 | put(" T"); 39 | else 40 | put(" NIL"); 41 | end if; 42 | when V_LIST => 43 | put(" LIST: Ref: " & BBS.lisp.conses.cons_ref_count'Image(BBS.lisp.conses.get_ref(e.l)) & " Value: "); 44 | print(e.l); 45 | when others => 46 | Put(""); 47 | end case; 48 | Put_Line(">"); 49 | end; 50 | -- 51 | procedure dump(s : cons_index) is 52 | temp : cons_index := s; 53 | begin 54 | Put("("); 55 | while temp > NIL_CONS loop 56 | if BBS.lisp.evaluate.isList(BBS.lisp.conses.get_car(temp)) then 57 | dump(BBS.lisp.evaluate.getList(BBS.lisp.conses.get_car(temp))); 58 | end if; 59 | temp := BBS.lisp.evaluate.getList(BBS.lisp.conses.get_cdr(temp)); 60 | end loop; 61 | put(")"); 62 | end; 63 | -- 64 | procedure dump(s : symbol_ptr) is 65 | begin 66 | if s.kind = ST_FIXED then 67 | put(BBS.lisp.symbols.get_name(s).all); 68 | else 69 | print(BBS.lisp.symbols.get_name(s)); 70 | end if; 71 | case BBS.lisp.symbols.get_type(s) is 72 | when SY_BUILTIN => 73 | Put(" "); 74 | when SY_SPECIAL => 75 | Put(" "); 76 | when SY_VARIABLE => 77 | dump(BBS.lisp.symbols.get_value(s)); 78 | when others => 79 | Put(" "); 80 | end case; 81 | end; 82 | end; 83 | -------------------------------------------------------------------------------- /src/bbs-lisp-debug.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Author: Brent Seidel 3 | -- Date: 31-Jul-2024 4 | -- 5 | -- This file is part of Tiny-Lisp. 6 | -- Tiny-Lisp is free software: you can redistribute it and/or modify it 7 | -- under the terms of the GNU General Public License as published by the 8 | -- Free Software Foundation, either version 3 of the License, or (at your 9 | -- option) any later version. 10 | -- 11 | -- Tiny-Lisp is distributed in the hope that it will be useful, but 12 | -- WITHOUT ANY WARRANTY; without even the implied warranty of 13 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General 14 | -- Public License for more details. 15 | -- 16 | -- You should have received a copy of the GNU General Public License along 17 | -- with Tiny-Lisp. If not, see .-- 18 | -- 19 | -- This package contains debugging routines for the lisp interpreter. In normal 20 | -- operations, these won't be used and these package can be deleted. 21 | -- 22 | package BBS.lisp.debug is 23 | pragma Elaborate_Body; 24 | 25 | procedure dump(e : element_type); 26 | procedure dump(s : cons_index); 27 | procedure dump(s : symbol_ptr); 28 | end; 29 | -------------------------------------------------------------------------------- /src/bbs-lisp-evaluate-bool.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Author: Brent Seidel 3 | -- Date: 31-Jul-2024 4 | -- 5 | -- This file is part of Tiny-Lisp. 6 | -- Tiny-Lisp is free software: you can redistribute it and/or modify it 7 | -- under the terms of the GNU General Public License as published by the 8 | -- Free Software Foundation, either version 3 of the License, or (at your 9 | -- option) any later version. 10 | -- 11 | -- Tiny-Lisp is distributed in the hope that it will be useful, but 12 | -- WITHOUT ANY WARRANTY; without even the implied warranty of 13 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General 14 | -- Public License for more details. 15 | -- 16 | -- You should have received a copy of the GNU General Public License along 17 | -- with Tiny-Lisp. If not, see .-- 18 | -- 19 | with BBS.lisp.memory; 20 | package body BBS.lisp.evaluate.bool is 21 | -- 22 | procedure eval_not(e : out element_type; s : cons_index) is 23 | p1 : element_type; -- Parameter 24 | s1 : cons_index := s; 25 | begin 26 | if s = NIL_CONS then 27 | error("eval_not", "No parameters provided."); 28 | e := make_error(ERR_NOPARAM); 29 | return; 30 | end if; 31 | p1 := first_value(s1); 32 | if p1.kind = V_ERROR then 33 | error("eval_not", "Error reported evaluating parameter."); 34 | e := p1; 35 | return; 36 | end if; 37 | if p1.kind = V_BOOLEAN then 38 | e := (kind => V_BOOLEAN, b => not p1.b); 39 | elsif p1.kind = V_INTEGER then 40 | e := (kind => V_INTEGER, i => uint32_to_int32(not int32_to_uint32(p1.i))); 41 | else 42 | error("eval_not", "Cannot perform NOT of parameter of type " & value_type'Image(p1.kind)); 43 | e := make_error(ERR_WRONGTYPE); 44 | end if; 45 | end; 46 | -- 47 | procedure eval_and(e : out element_type; s : cons_index) is 48 | accum_i : int32 := -1; 49 | accum_b : Boolean := True; 50 | int_op : Boolean := False; 51 | ptr : cons_index; 52 | temp : element_type; 53 | 54 | function accumulate(t : element_type; first : Boolean) return value_type is 55 | begin 56 | if (t.kind = V_INTEGER and first) or (t.kind = V_INTEGER and int_op) then 57 | accum_i := uint32_to_int32(int32_to_uint32(accum_i) and 58 | int32_to_uint32(t.i)); 59 | int_op := True; 60 | elsif (t.kind = V_BOOLEAN and first) or (t.kind = V_BOOLEAN and not int_op) then 61 | accum_b := accum_b and t.b; 62 | int_op := False; 63 | else 64 | error("eval_and", "Can't process " & value_type'Image(t.kind)); 65 | BBS.lisp.memory.deref(temp); 66 | return V_ERROR; 67 | end if; 68 | return V_NONE; 69 | end; 70 | -- 71 | begin 72 | if s > NIL_CONS then 73 | ptr := s; 74 | temp := first_value(ptr); 75 | if accumulate(temp, True) = V_ERROR then 76 | error("eval_and", "Error processing parameter."); 77 | e := make_error(ERR_WRONGTYPE); 78 | return; 79 | end if; 80 | if ptr > NIL_CONS then 81 | if (int_op and (accum_i /= 0)) or ((not int_op) and accum_b) then 82 | loop 83 | temp := first_value(ptr); 84 | if accumulate(temp, False) = V_ERROR then 85 | error("eval_and", "Error processing parameter."); 86 | e := make_error(ERR_WRONGTYPE); 87 | return; 88 | end if; 89 | -- 90 | -- Check for short circuiting operations 91 | -- 92 | exit when int_op and accum_i = 0; 93 | exit when (not int_op) and (not accum_b); 94 | -- 95 | -- Check for end of parameters 96 | -- 97 | exit when ptr = NIL_CONS; 98 | end loop; 99 | end if; 100 | end if; 101 | else 102 | error("eval_and", "No parameters provided."); 103 | e := make_error(ERR_NOPARAM); 104 | return; 105 | end if; 106 | if int_op then 107 | e := (kind => V_INTEGER, i => accum_i); 108 | else 109 | e := (kind => V_BOOLEAN, b => accum_b); 110 | end if; 111 | end; 112 | -- 113 | procedure eval_or(e : out element_type; s : cons_index) is 114 | accum_i : int32 := 0; 115 | accum_b : Boolean := False; 116 | int_op : Boolean := False; 117 | ptr : cons_index; 118 | temp : element_type; 119 | 120 | function accumulate(t : element_type; first : Boolean) return value_type is 121 | begin 122 | if (t.kind = V_INTEGER and first) or (t.kind = V_INTEGER and int_op) then 123 | accum_i := uint32_to_int32(int32_to_uint32(accum_i) or 124 | int32_to_uint32(t.i)); 125 | int_op := True; 126 | elsif (t.kind = V_BOOLEAN and first) or (t.kind = V_BOOLEAN and not int_op) then 127 | accum_b := accum_b or t.b; 128 | int_op := False; 129 | else 130 | error("eval_or", "Can't process " & value_type'Image(t.kind)); 131 | BBS.lisp.memory.deref(temp); 132 | return V_ERROR; 133 | end if; 134 | return V_NONE; 135 | end; 136 | -- 137 | begin 138 | if s > NIL_CONS then 139 | ptr := s; 140 | temp := first_value(ptr); 141 | if accumulate(temp, True) = V_ERROR then 142 | error("eval_or", "Error processing parameter."); 143 | e := make_error(ERR_WRONGTYPE); 144 | return; 145 | end if; 146 | if ptr > NIL_CONS then 147 | if (int_op and (accum_i /= -1)) or ((not int_op) and (not accum_b)) then 148 | loop 149 | temp := first_value(ptr); 150 | if accumulate(temp, False) = V_ERROR then 151 | error("eval_or", "Error processing parameter."); 152 | e := make_error(ERR_WRONGTYPE); 153 | return; 154 | end if; 155 | -- 156 | -- Check for short circuiting operations 157 | -- 158 | exit when int_op and accum_i = -1; 159 | exit when (not int_op) and accum_b; 160 | -- 161 | -- Check for end of parameters 162 | -- 163 | exit when ptr = NIL_CONS; 164 | end loop; 165 | end if; 166 | end if; 167 | else 168 | error("eval_or", "No parameters provided."); 169 | e := make_error(ERR_NOPARAM); 170 | return; 171 | end if; 172 | if int_op then 173 | e := (kind => V_INTEGER, i => accum_i); 174 | else 175 | e := (kind => V_BOOLEAN, b => accum_b); 176 | end if; 177 | end; 178 | -- 179 | end; 180 | -------------------------------------------------------------------------------- /src/bbs-lisp-evaluate-bool.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Author: Brent Seidel 3 | -- Date: 31-Jul-2024 4 | -- 5 | -- This file is part of Tiny-Lisp. 6 | -- Tiny-Lisp is free software: you can redistribute it and/or modify it 7 | -- under the terms of the GNU General Public License as published by the 8 | -- Free Software Foundation, either version 3 of the License, or (at your 9 | -- option) any later version. 10 | -- 11 | -- Tiny-Lisp is distributed in the hope that it will be useful, but 12 | -- WITHOUT ANY WARRANTY; without even the implied warranty of 13 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General 14 | -- Public License for more details. 15 | -- 16 | -- You should have received a copy of the GNU General Public License along 17 | -- with Tiny-Lisp. If not, see .-- 18 | -- 19 | -- This package contains operations that use either boolean types or bits of 20 | -- integers. 21 | -- 22 | package BBS.lisp.evaluate.bool is 23 | pragma Elaborate_Body; 24 | -- 25 | -- Perform a logical NOT operation. 26 | -- 27 | procedure eval_not(e : out element_type; s : cons_index); 28 | -- 29 | -- Perform a logical AND operation. 30 | -- 31 | procedure eval_and(e : out element_type; s : cons_index); 32 | -- 33 | -- Perform a logical OR operation. 34 | -- 35 | procedure eval_or(e : out element_type; s : cons_index); 36 | end; 37 | -------------------------------------------------------------------------------- /src/bbs-lisp-evaluate-char.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Author: Brent Seidel 3 | -- Date: 31-Jul-2024 4 | -- 5 | -- This file is part of Tiny-Lisp. 6 | -- Tiny-Lisp is free software: you can redistribute it and/or modify it 7 | -- under the terms of the GNU General Public License as published by the 8 | -- Free Software Foundation, either version 3 of the License, or (at your 9 | -- option) any later version. 10 | -- 11 | -- Tiny-Lisp is distributed in the hope that it will be useful, but 12 | -- WITHOUT ANY WARRANTY; without even the implied warranty of 13 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General 14 | -- Public License for more details. 15 | -- 16 | -- You should have received a copy of the GNU General Public License along 17 | -- with Tiny-Lisp. If not, see .-- 18 | -- 19 | with BBS.lisp.strings; 20 | package body BBS.lisp.evaluate.char is 21 | -- 22 | -- Given a character, return the integer code for the character. Typically 23 | -- the ASCII value. 24 | -- 25 | procedure char_code(e : out element_type; s : cons_index) is 26 | t : cons_index := s; 27 | p1 : element_type; -- Parameter 28 | begin 29 | if t = NIL_CONS then 30 | error("char_int", "No parameters provided."); 31 | e := make_error(ERR_NOPARAM); 32 | return; 33 | end if; 34 | p1 := first_value(t); 35 | if p1.kind = V_ERROR then 36 | error("char_int", "Error reported evaluating parameter."); 37 | e := p1; 38 | return; 39 | end if; 40 | if p1.kind = V_CHARACTER then 41 | e := (kind => V_INTEGER, i => Character'Pos(p1.c)); 42 | else 43 | error("char_int", "Parameter must be of character type, not " & value_type'Image(p1.kind)); 44 | e := make_error(ERR_WRONGTYPE); 45 | end if; 46 | end; 47 | -- 48 | -- Given an integer, return the character with that code or an error. 49 | -- 50 | procedure code_char(e : out element_type; s : cons_index) is 51 | t : cons_index := s; 52 | p1 : element_type; -- Parameter 53 | begin 54 | if t = NIL_CONS then 55 | error("int_char", "No parameters provided."); 56 | e := make_error(ERR_NOPARAM); 57 | return; 58 | end if; 59 | p1 := first_value(t); 60 | if p1.kind = V_ERROR then 61 | error("int_char", "Error reported evaluating parameter."); 62 | e := p1; 63 | return; 64 | end if; 65 | if p1.kind = V_INTEGER then 66 | if (p1.i >= 0) and (p1.i <= 255) then 67 | e := (kind => V_CHARACTER, c => Character'Val(p1.i)); 68 | else 69 | error("int_char", "Parameter must be in range 0-255. Value was " 70 | & Integer'Image(Integer(p1.i))); 71 | e := make_error(ERR_RANGE); 72 | end if; 73 | else 74 | error("int_char", "Parameter must be of integer type, not " & value_type'Image(p1.kind)); 75 | e := make_error(ERR_WRONGTYPE); 76 | end if; 77 | end; 78 | -- 79 | -- If character is alphabetic, convert to upper case. 80 | -- 81 | procedure char_upcase(e : out element_type; s : cons_index) is 82 | t : cons_index := s; 83 | p1 : element_type; -- Parameter 84 | begin 85 | if t = NIL_CONS then 86 | error("char_upcase", "No parameters provided."); 87 | e := make_error(ERR_NOPARAM); 88 | return; 89 | end if; 90 | p1 := first_value(t); 91 | if p1.kind = V_ERROR then 92 | error("char_upcase", "Error reported evaluating parameter."); 93 | e := p1; 94 | return; 95 | end if; 96 | if p1.kind = V_CHARACTER then 97 | e := (kind => V_CHARACTER, c => BBS.lisp.strings.To_Upper(p1.c)); 98 | else 99 | error("char_upcase", "Parameter must be of character type, not " & value_type'Image(p1.kind)); 100 | e := make_error(ERR_WRONGTYPE); 101 | end if; 102 | end; 103 | -- 104 | -- If character is alphabetic, convert to lower case. 105 | -- 106 | procedure char_downcase(e : out element_type; s : cons_index) is 107 | t : cons_index := s; 108 | p1 : element_type; -- Parameter 109 | begin 110 | if t = NIL_CONS then 111 | error("char_upcase", "No parameters provided."); 112 | e := make_error(ERR_NOPARAM); 113 | return; 114 | end if; 115 | p1 := first_value(t); 116 | if p1.kind = V_ERROR then 117 | error("char_upcase", "Error reported evaluating parameter."); 118 | e := p1; 119 | return; 120 | end if; 121 | if p1.kind = V_CHARACTER then 122 | e := (kind => V_CHARACTER, c => BBS.lisp.strings.To_Lower(p1.c)); 123 | else 124 | error("char_upcase", "Parameter must be of character type, not " & value_type'Image(p1.kind)); 125 | e := make_error(ERR_WRONGTYPE); 126 | end if; 127 | end; 128 | end; 129 | -------------------------------------------------------------------------------- /src/bbs-lisp-evaluate-char.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Author: Brent Seidel 3 | -- Date: 31-Jul-2024 4 | -- 5 | -- This file is part of Tiny-Lisp. 6 | -- Tiny-Lisp is free software: you can redistribute it and/or modify it 7 | -- under the terms of the GNU General Public License as published by the 8 | -- Free Software Foundation, either version 3 of the License, or (at your 9 | -- option) any later version. 10 | -- 11 | -- Tiny-Lisp is distributed in the hope that it will be useful, but 12 | -- WITHOUT ANY WARRANTY; without even the implied warranty of 13 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General 14 | -- Public License for more details. 15 | -- 16 | -- You should have received a copy of the GNU General Public License along 17 | -- with Tiny-Lisp. If not, see .-- 18 | -- 19 | -- This package contains operations for the character data type. 20 | -- 21 | package BBS.lisp.evaluate.char is 22 | pragma Elaborate_Body; 23 | -- 24 | -- Given a character, return the integer code for the character. Typically 25 | -- the ASCII value. 26 | -- 27 | procedure char_code(e : out element_type; s : cons_index); 28 | -- 29 | -- Given an integer, return the character with that code or an error. 30 | -- 31 | procedure code_char(e : out element_type; s : cons_index); 32 | -- 33 | -- If character is alphabetic, convert to upper case. 34 | -- 35 | procedure char_upcase(e : out element_type; s : cons_index); 36 | -- 37 | -- If character is alphabetic, convert to lower case. 38 | -- 39 | procedure char_downcase(e : out element_type; s : cons_index); 40 | end; 41 | -------------------------------------------------------------------------------- /src/bbs-lisp-evaluate-cond.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Author: Brent Seidel 3 | -- Date: 31-Jul-2024 4 | -- 5 | -- This file is part of Tiny-Lisp. 6 | -- Tiny-Lisp is free software: you can redistribute it and/or modify it 7 | -- under the terms of the GNU General Public License as published by the 8 | -- Free Software Foundation, either version 3 of the License, or (at your 9 | -- option) any later version. 10 | -- 11 | -- Tiny-Lisp is distributed in the hope that it will be useful, but 12 | -- WITHOUT ANY WARRANTY; without even the implied warranty of 13 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General 14 | -- Public License for more details. 15 | -- 16 | -- You should have received a copy of the GNU General Public License along 17 | -- with Tiny-Lisp. If not, see .-- 18 | -- 19 | with BBS.lisp.conses; 20 | with BBS.lisp.memory; 21 | with BBS.lisp.strings; 22 | package body BBS.lisp.evaluate.cond is 23 | -- 24 | -- Perform comparison operations. 25 | -- 26 | function eval_comp(s : cons_index; b : compops) return element_type is 27 | s1 : cons_index := s; 28 | t1 : element_type; 29 | t2 : element_type; 30 | begin 31 | if s = cons_index'First then 32 | error("eval_comp", "No parameters provided."); 33 | return make_error(ERR_NOPARAM); 34 | end if; 35 | t1 := first_value(s1); 36 | if s1 > NIL_CONS then 37 | t2 := first_value(s1); 38 | else 39 | error("eval_comp", "Cannot compare a single element."); 40 | BBS.lisp.memory.deref(t1); 41 | return make_error(ERR_FEWPARAM); 42 | end if; 43 | -- 44 | -- A value of V_NONE is equivalent to a boolean False. 45 | -- 46 | if t1.kind = V_NONE then 47 | t1 := ELEM_F; 48 | end if; 49 | if t2.kind = V_NONE then 50 | t2 := ELEM_F; 51 | end if; 52 | -- 53 | -- Integer comparison 54 | -- 55 | if (t1.kind = V_INTEGER) and (t2.kind = V_INTEGER) then 56 | case b is 57 | when SYM_EQ => 58 | return (kind => V_BOOLEAN, b => t1.i = t2.i); 59 | when SYM_NE => 60 | return (kind => V_BOOLEAN, b => t1.i /= t2.i); 61 | when SYM_LT => 62 | return (kind => V_BOOLEAN, b => t1.i < t2.i); 63 | when SYM_GT => 64 | return (kind => V_BOOLEAN, b => t1.i > t2.i); 65 | end case; 66 | -- 67 | -- Character comparison 68 | -- 69 | elsif (t1.kind = V_CHARACTER) and (t2.kind = V_CHARACTER) then 70 | case b is 71 | when SYM_EQ => 72 | return (kind => V_BOOLEAN, b => t1.c = t2.c); 73 | when SYM_NE => 74 | return (kind => V_BOOLEAN, b => t1.c /= t2.c); 75 | when SYM_LT => 76 | return (kind => V_BOOLEAN, b => t1.c < t2.c); 77 | when SYM_GT => 78 | return (kind => V_BOOLEAN, b => t1.c > t2.c); 79 | end case; 80 | -- 81 | -- String comparison 82 | -- 83 | elsif (t1.kind = V_STRING) and (t2.kind = V_STRING) then 84 | declare 85 | eq : comparison; 86 | begin 87 | eq := BBS.lisp.strings.compare(t1.s, t2.s); 88 | BBS.lisp.strings.deref(t1.s); 89 | BBS.lisp.strings.deref(t2.s); 90 | case b is 91 | when SYM_EQ => 92 | if eq = CMP_EQ then 93 | return (kind => V_BOOLEAN, b => True); 94 | end if; 95 | when SYM_LT => 96 | if eq = CMP_LT then 97 | return (kind => V_BOOLEAN, b => True); 98 | end if; 99 | when SYM_GT => 100 | if eq = CMP_GT then 101 | return (kind => V_BOOLEAN, b => True); 102 | end if; 103 | when SYM_NE => 104 | if eq /= CMP_EQ then 105 | return (kind => V_BOOLEAN, b => True); 106 | end if; 107 | end case; 108 | end; 109 | return (kind => V_BOOLEAN, b => False); 110 | -- 111 | -- Boolean comparison 112 | -- 113 | elsif (t1.kind = V_BOOLEAN) and (t2.kind = V_BOOLEAN) then 114 | case b is 115 | when SYM_EQ => 116 | return (kind => V_BOOLEAN, b => t1.b = t2.b); 117 | when SYM_NE => 118 | return (kind => V_BOOLEAN, b => t1.b /= t2.b); 119 | when SYM_LT => 120 | return (kind => V_BOOLEAN, b => t1.b < t2.b); 121 | when SYM_GT => 122 | return (kind => V_BOOLEAN, b => t1.b > t2.b); 123 | end case; 124 | -- 125 | -- Symbol comparison 126 | -- 127 | elsif ((t1.kind = V_QSYMBOL) or (t1.kind = V_SYMBOL)) and 128 | ((t2.kind = V_QSYMBOL) or (t2.kind = V_SYMBOL)) then 129 | declare 130 | s1 : symbol_ptr; 131 | s2 : symbol_ptr; 132 | begin 133 | if t1.kind = V_QSYMBOL then 134 | s1 := t1.qsym; 135 | else 136 | s1 := t1.sym; 137 | end if; 138 | if t2.kind = V_QSYMBOL then 139 | s2 := t2.qsym; 140 | else 141 | s2 := t2.sym; 142 | end if; 143 | case b is 144 | when SYM_EQ => 145 | return (kind => V_BOOLEAN, b => s1 = s2); 146 | when SYM_NE => 147 | return (kind => V_BOOLEAN, b => s1 /= s2); 148 | when SYM_LT => 149 | error("eval_comp", "Can only compare symbols for equality."); 150 | return make_error(ERR_WRONGTYPE); 151 | when SYM_GT => 152 | error("eval_comp", "Can only compare symbols for equality."); 153 | return make_error(ERR_WRONGTYPE); 154 | end case; 155 | end; 156 | -- 157 | -- Compare errors for equality. 158 | -- 159 | elsif (t1.kind = V_ERROR) and (t2.kind = V_ERROR) then 160 | case b is 161 | when SYM_EQ => 162 | return (kind => V_BOOLEAN, b => t1.err = t2.err); 163 | when SYM_NE => 164 | return (kind => V_BOOLEAN, b => t1.err /= t2.err); 165 | when others => 166 | error("eval_comp", "Can only compare errors for equality."); 167 | return make_error(ERR_WRONGTYPE); 168 | end case; 169 | else 170 | -- 171 | -- Other comparisons are not supported. 172 | -- 173 | error("eval_comp", "Comparison of the provided types is not supported."); 174 | put("First type is " & value_type'Image(t1.kind)); 175 | put_line(", second type is " & value_type'Image(t2.kind)); 176 | BBS.lisp.memory.deref(t1); 177 | BBS.lisp.memory.deref(t2); 178 | return make_error(ERR_WRONGTYPE); 179 | end if; 180 | end; 181 | -- 182 | -- Compare two items for equality. 183 | -- 184 | procedure eq(e : out element_type; s : cons_index) is 185 | begin 186 | e := eval_comp(s, SYM_EQ); 187 | end; 188 | -- 189 | -- Compare two items for not equality. 190 | -- 191 | procedure ne(e : out element_type; s : cons_index) is 192 | begin 193 | e := eval_comp(s, SYM_NE); 194 | end; 195 | -- 196 | -- Is first item less than the second item? 197 | -- 198 | procedure lt(e : out element_type; s : cons_index) is 199 | begin 200 | e := eval_comp(s, SYM_LT); 201 | end; 202 | -- 203 | -- Is the first item greater than the second item? 204 | -- 205 | procedure gt(e : out element_type; s : cons_index) is 206 | begin 207 | e := eval_comp(s, SYM_GT); 208 | end; 209 | -- 210 | -- Perform an IF operation. 211 | -- 212 | procedure eval_if(e : out element_type; s : cons_index) is 213 | t : element_type; 214 | s1 : cons_index := s; 215 | p1 : element_type; -- Condition 216 | p2 : element_type; -- True expression 217 | p3 : element_type; -- False expression 218 | begin 219 | if s = NIL_CONS then 220 | error("if", "No parameters provided."); 221 | e := make_error(ERR_NOPARAM); 222 | return; 223 | end if; 224 | p1 := first_value(s1); 225 | if p1.kind = V_ERROR then 226 | error("if", "Condition reported an error."); 227 | e := p1; 228 | return; 229 | end if; 230 | if s1 > NIL_CONS then 231 | p2 := BBS.lisp.conses.get_car(s1); 232 | if isList(BBS.lisp.conses.get_cdr(s1)) then 233 | s1 := getList((BBS.lisp.conses.get_cdr(s1))); 234 | p3 := BBS.lisp.conses.get_car(s1); 235 | else 236 | p3 := BBS.lisp.conses.get_cdr(s1); 237 | end if; 238 | else 239 | p2 := BBS.lisp.conses.get_cdr(s); 240 | p3 := NIL_ELEM; 241 | end if; 242 | -- 243 | -- Now p1 contains the results of evaluating the condition, p2 the 244 | -- "then" branch, and p3 the "else" branch. Decide which of p2 or p3 245 | -- to evaluate. 246 | -- 247 | t := NIL_ELEM; 248 | if isTrue(p1) then 249 | if isFunction(p2) then 250 | t := eval_dispatch(getList(p2)); 251 | if t.kind = V_ERROR then 252 | error("if", "Error in evaluating true branch"); 253 | end if; 254 | else 255 | t := indirect_elem(p2); 256 | end if; 257 | else 258 | if isFunction(p3) then 259 | t := eval_dispatch(getList(p3)); 260 | if t.kind = V_ERROR then 261 | error("if", "Error in evaluating false branch"); 262 | end if; 263 | else 264 | t := indirect_elem(p3); 265 | end if; 266 | end if; 267 | BBS.lisp.memory.deref(p1); 268 | e := t; 269 | end; 270 | -- 271 | -- Perform a COND operation. 272 | -- 273 | procedure eval_cond(e : out element_type; s : cons_index) is 274 | s1 : cons_index := s; -- Walks through the parameter list 275 | s2 : cons_index; -- Walks through each candidate 276 | p1 : element_type := NIL_ELEM; -- Candidate 277 | test : element_type; -- Condition value 278 | begin 279 | if s = NIL_CONS then 280 | error("cond", "No parameters provided."); 281 | e := make_error(ERR_NOPARAM); 282 | return; 283 | end if; 284 | -- 285 | -- Loop for each element of parameter list 286 | -- 287 | loop 288 | BBS.lisp.memory.deref(p1); 289 | p1 := first_value(s1); -- Get the next candidate 290 | if p1.kind = V_ERROR then 291 | error("cond", "Candidate reported an error."); 292 | e := p1; 293 | return; 294 | end if; 295 | s2 := getList(p1); -- Check if it is a list 296 | if s2 = NIL_CONS then 297 | error("cond", "Each candidate branch must be a list."); 298 | e := make_error(ERR_WRONGTYPE); 299 | BBS.lisp.memory.deref(p1); 300 | return; 301 | end if; 302 | test := first_value(s2); -- Check if the condition is true 303 | if test.kind = V_ERROR then 304 | error("cond", "Condition reported an error."); 305 | e := test; 306 | return; 307 | end if; 308 | if isTrue(test) then 309 | e := execute_block(s2); 310 | BBS.lisp.memory.deref(test); 311 | BBS.lisp.memory.deref(p1); 312 | return; 313 | end if; 314 | if s1 = NIL_CONS then 315 | error("cond", "No matching candidate found."); 316 | e := make_error(ERR_FEWPARAM); 317 | BBS.lisp.memory.deref(p1); 318 | return; 319 | end if; 320 | end loop; 321 | end; 322 | end; 323 | -------------------------------------------------------------------------------- /src/bbs-lisp-evaluate-cond.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Author: Brent Seidel 3 | -- Date: 31-Jul-2024 4 | -- 5 | -- This file is part of Tiny-Lisp. 6 | -- Tiny-Lisp is free software: you can redistribute it and/or modify it 7 | -- under the terms of the GNU General Public License as published by the 8 | -- Free Software Foundation, either version 3 of the License, or (at your 9 | -- option) any later version. 10 | -- 11 | -- Tiny-Lisp is distributed in the hope that it will be useful, but 12 | -- WITHOUT ANY WARRANTY; without even the implied warranty of 13 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General 14 | -- Public License for more details. 15 | -- 16 | -- You should have received a copy of the GNU General Public License along 17 | -- with Tiny-Lisp. If not, see .-- 18 | -- 19 | -- This package contains the Lisp comparison and condition functions 20 | -- 21 | package BBS.lisp.evaluate.cond is 22 | pragma Elaborate_Body; 23 | -- 24 | -- Helper function for comparisons 25 | -- 26 | function eval_comp(s : cons_index; b : compops) return element_type; 27 | -- 28 | -- Compare two items for equality. 29 | -- 30 | procedure eq(e : out element_type; s : cons_index); 31 | -- 32 | -- Compare two items for not equality. 33 | -- 34 | procedure ne(e : out element_type; s : cons_index); 35 | -- 36 | -- Is first item less than the second item? 37 | -- 38 | procedure lt(e : out element_type; s : cons_index); 39 | -- 40 | -- Is the first item greater than the second item? 41 | -- 42 | procedure gt(e : out element_type; s : cons_index); 43 | -- 44 | -- Perform an IF operation. 45 | -- 46 | procedure eval_if(e : out element_type; s : cons_index); 47 | -- 48 | -- Perform a COND operation. 49 | -- 50 | procedure eval_cond(e : out element_type; s : cons_index); 51 | end; 52 | -------------------------------------------------------------------------------- /src/bbs-lisp-evaluate-func.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Author: Brent Seidel 3 | -- Date: 31-Jul-2024 4 | -- 5 | -- This file is part of Tiny-Lisp. 6 | -- Tiny-Lisp is free software: you can redistribute it and/or modify it 7 | -- under the terms of the GNU General Public License as published by the 8 | -- Free Software Foundation, either version 3 of the License, or (at your 9 | -- option) any later version. 10 | -- 11 | -- Tiny-Lisp is distributed in the hope that it will be useful, but 12 | -- WITHOUT ANY WARRANTY; without even the implied warranty of 13 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General 14 | -- Public License for more details. 15 | -- 16 | -- You should have received a copy of the GNU General Public License along 17 | -- with Tiny-Lisp. If not, see .-- 18 | -- 19 | -- This package contains functions to support Lisp function definition and 20 | -- evaluation. 21 | -- 22 | package BBS.lisp.evaluate.func is 23 | -- 24 | -- Defines a function. The command is (defun name (parameters) body). 25 | -- name is a symbol of type LAMBDA. 26 | -- params is a list of the parameters for the function. It must be a 27 | -- list of elements that translate to symbols or tempsyms. Defun translates 28 | -- these to parameter elements. 29 | -- body is a list of the actions for the function. This needs to be 30 | -- scanned and any symbol or tempsym that matches one of the params is 31 | -- translated to point to the parameter atom in the parameter list. It 32 | -- also could concievable be a single atom or even NIL. 33 | -- 34 | procedure defun(e : out element_type; s : cons_index; p : phase); 35 | -- 36 | -- Defines a function. The command is (lambda (parameters) body). 37 | -- params is a list of the parameters for the function. It must be a 38 | -- list of elements that translate to symbols or tempsyms. Defun translates 39 | -- these to parameter elements. 40 | -- body is a list of the actions for the function. This needs to be 41 | -- scanned and any symbol or tempsym that matches one of the params is 42 | -- translated to point to the parameter atom in the parameter list. It 43 | -- also could concievable be a single atom or even NIL. 44 | -- The returned value is an variable element of type V_LAMBDA. 45 | -- 46 | procedure lambda(e : out element_type; s : cons_index; p : phase); 47 | -- 48 | -- Evaluates a lisp form. Basically this takes the first parameter and passes 49 | -- it to the evaluator. 50 | -- 51 | procedure eval_list(e : out element_type; s : cons_index); 52 | -- 53 | -- Functions for evaluating lisp functions 54 | -- 55 | function eval_function(s : cons_index; e : cons_index) return element_type; 56 | end; 57 | -------------------------------------------------------------------------------- /src/bbs-lisp-evaluate-io.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Author: Brent Seidel 3 | -- Date: 31-Jul-2024 4 | -- 5 | -- This file is part of Tiny-Lisp. 6 | -- Tiny-Lisp is free software: you can redistribute it and/or modify it 7 | -- under the terms of the GNU General Public License as published by the 8 | -- Free Software Foundation, either version 3 of the License, or (at your 9 | -- option) any later version. 10 | -- 11 | -- Tiny-Lisp is distributed in the hope that it will be useful, but 12 | -- WITHOUT ANY WARRANTY; without even the implied warranty of 13 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General 14 | -- Public License for more details. 15 | -- 16 | -- You should have received a copy of the GNU General Public License along 17 | -- with Tiny-Lisp. If not, see .-- 18 | -- 19 | with BBS.lisp.memory; 20 | with BBS.lisp.parser; 21 | with BBS.lisp.parser.string; 22 | with BBS.lisp.strings; 23 | package body BBS.lisp.evaluate.io is 24 | -- 25 | -- Parser object used for read_expr. This needs to be statically allocated 26 | -- so that the address can be taken. 27 | -- 28 | str : aliased BBS.lisp.parser.string.parser_string; 29 | -- 30 | -- Print stuff 31 | -- 32 | procedure print(e : out element_type; s : cons_index) is 33 | t : cons_index := s; 34 | car : element_type; 35 | begin 36 | while t > NIL_CONS loop 37 | car := first_value(t); 38 | print(car, True, False); 39 | end loop; 40 | e := NIL_ELEM; 41 | end; 42 | -- 43 | -- Print an integer in hexidecimal format. Sizes are byte, word, and long. 44 | -- Usage: (print-hex ) 45 | -- size = 1 for byte 46 | -- size = 2 for word 47 | -- size = 3 or others for long 48 | -- 49 | procedure print_hex(e : out element_type; s : cons_index) is 50 | t : cons_index := s; 51 | el : element_type; 52 | number : int32; 53 | size : int32 := 3; 54 | begin 55 | if s = NIL_CONS then 56 | error("print_hex", "No parameters provided."); 57 | e := make_error(ERR_NOPARAM); 58 | return; 59 | end if; 60 | el := first_value(t); 61 | if el.kind = V_INTEGER then 62 | number := el.i; 63 | else 64 | error("print_hex", "Can't process value of type " & value_type'Image(el.kind)); 65 | BBS.lisp.memory.deref(el); 66 | e := make_error(ERR_WRONGTYPE); 67 | return; 68 | end if; 69 | el := first_value(t); 70 | if el.kind = V_INTEGER then 71 | if (el.i = 1) or (el.i = 2) then 72 | size := el.i; 73 | else 74 | size := 3; 75 | end if; 76 | else 77 | size := 3; 78 | end if; 79 | case size is 80 | when 1 => -- Byte 81 | put(toHexb(number)); 82 | when 2 => -- Word 83 | put(toHexw(number)); 84 | when others => -- Long 85 | put(toHexl(number)); 86 | end case; 87 | e := NIL_ELEM; 88 | end; 89 | -- 90 | procedure fresh_line(e : out element_type; s : cons_index) is 91 | pragma Unreferenced (s); 92 | begin 93 | if not first_char_flag then 94 | New_Line; 95 | end if; 96 | e := NIL_ELEM; 97 | end; 98 | -- 99 | procedure read_line(e : out element_type; s : cons_index) is 100 | pragma Unreferenced (s); 101 | buff : String(1 .. 256); 102 | size : Natural; 103 | str : string_index; 104 | first : string_index; 105 | begin 106 | Get_Line(buff, size); 107 | if BBS.lisp.strings.alloc(str) then 108 | first := str; 109 | for ptr in buff'First .. size loop 110 | if not BBS.lisp.strings.append(str, buff(ptr)) then 111 | bbs.lisp.strings.deref(str); 112 | e := NIL_ELEM; 113 | return; 114 | end if; 115 | end loop; 116 | e := (kind => V_STRING, s => first); 117 | else 118 | e := NIL_ELEM; 119 | end if; 120 | end; 121 | -- 122 | -- Read a line from a string and parse it. 123 | -- 124 | procedure read_expr(e : out element_type; s : cons_index) is 125 | t : cons_index := s; 126 | car : element_type; 127 | begin 128 | if s > NIL_CONS then 129 | car := first_value(t); 130 | if car.kind /= V_STRING then 131 | error("read_expr", "Must have a string parameter"); 132 | e := make_error(ERR_WRONGTYPE); 133 | return; 134 | end if; 135 | else 136 | error("read_expr", "Must have a parameter"); 137 | e := make_error(ERR_NOPARAM); 138 | return; 139 | end if; 140 | -- 141 | -- Now we have a string parameter, parse it. 142 | -- 143 | str.init(car.s); 144 | if not BBS.lisp.parser.parse(str'Access, e) then 145 | error("read_expr", "Parsing failed"); 146 | BBS.lisp.memory.deref(e); 147 | e := make_error(ERR_PARSE); 148 | end if; 149 | end; 150 | -- 151 | procedure terpri(e : out element_type; s : cons_index) is 152 | pragma Unreferenced (s); 153 | begin 154 | New_Line; 155 | e := NIL_ELEM; 156 | end; 157 | -- 158 | end; 159 | -------------------------------------------------------------------------------- /src/bbs-lisp-evaluate-io.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Author: Brent Seidel 3 | -- Date: 31-Jul-2024 4 | -- 5 | -- This file is part of Tiny-Lisp. 6 | -- Tiny-Lisp is free software: you can redistribute it and/or modify it 7 | -- under the terms of the GNU General Public License as published by the 8 | -- Free Software Foundation, either version 3 of the License, or (at your 9 | -- option) any later version. 10 | -- 11 | -- Tiny-Lisp is distributed in the hope that it will be useful, but 12 | -- WITHOUT ANY WARRANTY; without even the implied warranty of 13 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General 14 | -- Public License for more details. 15 | -- 16 | -- You should have received a copy of the GNU General Public License along 17 | -- with Tiny-Lisp. If not, see .-- 18 | -- 19 | -- This package contains the console I/O routines. They are fairly basic. 20 | -- 21 | package BBS.lisp.evaluate.io is 22 | pragma Elaborate_Body; 23 | -- 24 | -- Print a list of items. 25 | -- 26 | procedure print(e : out element_type; s : cons_index) 27 | with post => (e = NIL_ELEM); 28 | -- 29 | -- Print an integer in hexidecimal format. Sizes are byte, word, and long. 30 | -- 31 | procedure print_hex(e : out element_type; s : cons_index) 32 | with post => (e = NIL_ELEM); 33 | -- 34 | -- Print a new line if not already at the beginning of a line. 35 | -- 36 | procedure fresh_line(e : out element_type; s : cons_index) 37 | with post => (e = NIL_ELEM); 38 | -- 39 | -- Read a line from input. 40 | -- 41 | procedure read_line(e : out element_type; s : cons_index); 42 | -- 43 | -- Read a line from a string and parse it. 44 | -- 45 | procedure read_expr(e : out element_type; s : cons_index); 46 | -- 47 | -- Print a new line. 48 | -- 49 | procedure terpri(e : out element_type; s : cons_index) 50 | with post => (e = NIL_ELEM); 51 | end; 52 | -------------------------------------------------------------------------------- /src/bbs-lisp-evaluate-list.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Author: Brent Seidel 3 | -- Date: 31-Jul-2024 4 | -- 5 | -- This file is part of Tiny-Lisp. 6 | -- Tiny-Lisp is free software: you can redistribute it and/or modify it 7 | -- under the terms of the GNU General Public License as published by the 8 | -- Free Software Foundation, either version 3 of the License, or (at your 9 | -- option) any later version. 10 | -- 11 | -- Tiny-Lisp is distributed in the hope that it will be useful, but 12 | -- WITHOUT ANY WARRANTY; without even the implied warranty of 13 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General 14 | -- Public License for more details. 15 | -- 16 | -- You should have received a copy of the GNU General Public License along 17 | -- with Tiny-Lisp. If not, see .-- 18 | -- 19 | with BBS.lisp.conses; 20 | with BBS.lisp.memory; 21 | package body BBS.lisp.evaluate.list is 22 | 23 | -- 24 | -- Create a list out of two elements. 25 | -- 26 | procedure cons(e : out element_type; s : cons_index) is 27 | s1 : cons_index := s; 28 | p1 : element_type; -- First parameter 29 | p2 : element_type; -- Second parameter 30 | begin 31 | if s = NIL_CONS then 32 | error("cons", "No parameters provided."); 33 | e := make_error(ERR_NOPARAM); 34 | return; 35 | end if; 36 | p1 := first_value(s1); 37 | if p1.kind = V_ERROR then 38 | error("cons", "Error reported evaluating first parameter."); 39 | e := p1; 40 | return; 41 | end if; 42 | p2 := first_value(s1); 43 | if p2.kind = V_ERROR then 44 | error("cons", "Error reported evaluating second parameter."); 45 | e := p2; 46 | return; 47 | end if; 48 | if BBS.lisp.conses.alloc(s1) then 49 | BBS.lisp.conses.set_car(s1, p1); 50 | BBS.lisp.conses.set_cdr(s1, p2); 51 | BBS.lisp.memory.ref(p1); 52 | BBS.lisp.memory.ref(p2); 53 | e := (kind => V_LIST, l => s1); 54 | else 55 | error("cons", "Unable to allocate cons cell"); 56 | e := make_error(ERR_ALLOCCONS); 57 | end if; 58 | end; 59 | -- 60 | -- Return the first entry in a list (it may be another list). 61 | -- 62 | procedure car(e : out element_type; s : cons_index) is 63 | rest : cons_index := s; 64 | first : element_type; 65 | temp : element_type; 66 | s1 : cons_index; 67 | begin 68 | first := first_value(rest); 69 | s1 := getList(first); 70 | if s1 > NIL_CONS then 71 | temp := BBS.lisp.conses.get_car(s1); 72 | BBS.lisp.memory.ref(temp); 73 | e := temp; 74 | else 75 | e := first; 76 | end if; 77 | end; 78 | -- 79 | -- Return the rest of a list 80 | -- 81 | procedure cdr(e : out element_type; s : cons_index) is 82 | rest : cons_index := s; 83 | first : element_type; 84 | temp : element_type; 85 | s1 : cons_index; 86 | begin 87 | first := first_value(rest); 88 | s1 := getList(first); 89 | if s1 > NIL_CONS then 90 | temp := BBS.lisp.conses.get_cdr(s1); 91 | BBS.lisp.memory.ref(temp); 92 | e := temp; 93 | else 94 | e := NIL_ELEM; 95 | end if; 96 | end; 97 | -- 98 | -- Create a list verbatum from the parameter list 99 | -- 100 | procedure quote(e : out element_type; s : cons_index) is 101 | begin 102 | bbs.lisp.conses.ref(s); 103 | e := makeList(s); 104 | end; 105 | -- 106 | -- Create a list by evaluating the parameters, similar to quote, but quote 107 | -- does not evaluate the parameters. 108 | -- 109 | procedure list(e : out element_type; s : cons_index) is 110 | first : element_type; 111 | rest : cons_index := s; 112 | head : cons_index; 113 | tail : cons_index; 114 | s1 : cons_index; 115 | begin 116 | if s > NIL_CONS then 117 | if BBS.lisp.conses.alloc(s1) then 118 | first := first_value(rest); 119 | if first.kind = V_ERROR then 120 | error("list", "Parameter returned an error"); 121 | e := first; 122 | return; 123 | end if; 124 | BBS.lisp.memory.ref(first); 125 | BBS.lisp.conses.set_car(s1, first); 126 | head := s1; 127 | tail := s1; 128 | else 129 | error("list", "Unable to allocate initial cons cell."); 130 | e := make_error(ERR_ALLOCCONS); 131 | return; 132 | end if; 133 | else 134 | e := NIL_ELEM; 135 | return; 136 | end if; 137 | while rest > NIL_CONS loop 138 | if BBS.lisp.conses.alloc(s1) then 139 | first := first_value(rest); 140 | if first.kind = V_ERROR then 141 | BBS.lisp.conses.deref(head); 142 | error("list", "Parameter returned an error"); 143 | e := first; 144 | return; 145 | end if; 146 | BBS.lisp.conses.set_cdr(tail, (kind => V_LIST, l => s1)); 147 | tail := s1; 148 | BBS.lisp.memory.ref(first); 149 | BBS.lisp.conses.set_car(s1, first); 150 | else 151 | BBS.lisp.conses.deref(head); 152 | error("list", "Unable to allocate cons cell"); 153 | e := make_error(ERR_ALLOCCONS); 154 | return; 155 | end if; 156 | end loop; 157 | e := (kind => V_LIST, l => head); 158 | end; 159 | -- 160 | -- Replace the CAR of a list with a value 161 | -- 162 | procedure rplaca(e : out element_type; s : cons_index) is 163 | rest : cons_index := s; 164 | first : element_type; 165 | second : element_type; 166 | s1 : cons_index; 167 | begin 168 | if s = NIL_CONS then 169 | error("rplaca", "No parameters provided."); 170 | e := make_error(ERR_NOPARAM); 171 | return; 172 | end if; 173 | first := first_value(rest); 174 | if not isList(first) then 175 | error("rplaca", "Must have a list to modify"); 176 | e := make_error(ERR_WRONGTYPE); 177 | return; 178 | end if; 179 | second := first_value(rest); 180 | s1 := getList(first); 181 | if s1 > NIL_CONS then 182 | BBS.lisp.memory.deref(BBS.lisp.conses.get_car(s1)); 183 | BBS.lisp.conses.set_car(s1, second); 184 | end if; 185 | e := first; 186 | end; 187 | -- 188 | -- Replace the CDR of a list with a value 189 | -- 190 | procedure rplacd(e : out element_type; s : cons_index) is 191 | rest : cons_index := s; 192 | first : element_type; 193 | second : element_type; 194 | s1 : cons_index; 195 | begin 196 | if s = NIL_CONS then 197 | error("rplacd", "No parameters provided."); 198 | e := make_error(ERR_NOPARAM); 199 | return; 200 | end if; 201 | first := first_value(rest); 202 | if not isList(first) then 203 | error("rplacd", "Must have a list to modify"); 204 | e := make_error(ERR_WRONGTYPE); 205 | return; 206 | end if; 207 | second := first_value(rest); 208 | s1 := getList(first); 209 | if s1 > NIL_CONS then 210 | BBS.lisp.memory.deref(BBS.lisp.conses.get_cdr(s1)); 211 | BBS.lisp.conses.set_cdr(s1, second); 212 | end if; 213 | e := first; 214 | end; 215 | -- 216 | -- Append one list to another. Not yet implemented. 217 | -- 218 | -- procedure append(e : out element_type; s : cons_index) is 219 | -- pragma Unreferenced (s); 220 | -- begin 221 | -- e := (kind => E_ERROR); 222 | -- end; 223 | -- 224 | end; 225 | -------------------------------------------------------------------------------- /src/bbs-lisp-evaluate-list.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Author: Brent Seidel 3 | -- Date: 31-Jul-2024 4 | -- 5 | -- This file is part of Tiny-Lisp. 6 | -- Tiny-Lisp is free software: you can redistribute it and/or modify it 7 | -- under the terms of the GNU General Public License as published by the 8 | -- Free Software Foundation, either version 3 of the License, or (at your 9 | -- option) any later version. 10 | -- 11 | -- Tiny-Lisp is distributed in the hope that it will be useful, but 12 | -- WITHOUT ANY WARRANTY; without even the implied warranty of 13 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General 14 | -- Public License for more details. 15 | -- 16 | -- You should have received a copy of the GNU General Public License along 17 | -- with Tiny-Lisp. If not, see .-- 18 | -- 19 | package BBS.lisp.evaluate.list is 20 | pragma Elaborate_Body; 21 | -- 22 | -- Create a list out of two elements. 23 | -- 24 | procedure cons(e : out element_type; s : cons_index); 25 | -- 26 | -- Get the first item of a list 27 | -- 28 | procedure car(e : out element_type; s : cons_index); 29 | -- 30 | -- Get the rest of a list 31 | -- 32 | procedure cdr(e : out element_type; s : cons_index); 33 | -- 34 | -- Create a list verbatum from the parameter list 35 | -- 36 | procedure quote(e : out element_type; s : cons_index); 37 | -- 38 | -- Create a list by evaluating the parameters, similar to quote, but quote 39 | -- does not evaluate the parameters. 40 | -- 41 | procedure list(e : out element_type; s : cons_index); 42 | -- 43 | -- Replace the CAR of a list with a value 44 | -- 45 | procedure rplaca(e : out element_type; s : cons_index); 46 | -- 47 | -- Replace the CDR of a list with a value 48 | -- 49 | procedure rplacd(e : out element_type; s : cons_index); 50 | -- 51 | -- Append one list to another (currently unimplemented). 52 | -- 53 | -- procedure append(e : out element_type; s : cons_index); 54 | end; 55 | -------------------------------------------------------------------------------- /src/bbs-lisp-evaluate-loops.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Author: Brent Seidel 3 | -- Date: 31-Jul-2024 4 | -- 5 | -- This file is part of Tiny-Lisp. 6 | -- Tiny-Lisp is free software: you can redistribute it and/or modify it 7 | -- under the terms of the GNU General Public License as published by the 8 | -- Free Software Foundation, either version 3 of the License, or (at your 9 | -- option) any later version. 10 | -- 11 | -- Tiny-Lisp is distributed in the hope that it will be useful, but 12 | -- WITHOUT ANY WARRANTY; without even the implied warranty of 13 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General 14 | -- Public License for more details. 15 | -- 16 | -- You should have received a copy of the GNU General Public License along 17 | -- with Tiny-Lisp. If not, see .-- 18 | -- 19 | -- This package contains the functions for Lisp loop operations. 20 | -- 21 | package BBS.lisp.evaluate.loops is 22 | -- 23 | -- Evaluate statements while a condition is true. 24 | -- 25 | procedure dowhile(e : out element_type; s : cons_index); 26 | -- 27 | -- Evaluate statements a specified number of times. 28 | -- 29 | procedure dotimes(e : out element_type; s : cons_index; p : phase); 30 | -- 31 | -- Evaluate statements for elements in a list. 32 | -- 33 | procedure dolist(e : out element_type; s : cons_index; p : phase); 34 | -- 35 | -- Create a block containing multiple statements 36 | -- 37 | procedure progn(e : out element_type; s : cons_index); 38 | -- 39 | -- Breaks out of a loop (or other exclosing block) and returns a value 40 | -- 41 | procedure return_from(e : out element_type; s : cons_index); 42 | end; 43 | -------------------------------------------------------------------------------- /src/bbs-lisp-evaluate-math.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Author: Brent Seidel 3 | -- Date: 31-Jul-2024 4 | -- 5 | -- This file is part of Tiny-Lisp. 6 | -- Tiny-Lisp is free software: you can redistribute it and/or modify it 7 | -- under the terms of the GNU General Public License as published by the 8 | -- Free Software Foundation, either version 3 of the License, or (at your 9 | -- option) any later version. 10 | -- 11 | -- Tiny-Lisp is distributed in the hope that it will be useful, but 12 | -- WITHOUT ANY WARRANTY; without even the implied warranty of 13 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General 14 | -- Public License for more details. 15 | -- 16 | -- You should have received a copy of the GNU General Public License along 17 | -- with Tiny-Lisp. If not, see .-- 18 | -- 19 | with BBS.lisp.memory; 20 | 21 | package body BBS.lisp.evaluate.math is 22 | -- 23 | -- This function evaluates the basic arithmatic operation (+, -, *, /). 24 | -- 25 | function eval_math(s : cons_index; b : mathops) return element_type is 26 | t : cons_index := s; 27 | accum : int32 := 0; 28 | el: element_type; 29 | -- 30 | -- Subfunction to do the actual evaluation. 31 | -- 32 | procedure process_value(i : int32; b : mathops) is 33 | begin 34 | case (b) is 35 | when PLUS => 36 | accum := accum + i; 37 | when MUL => 38 | accum := accum * i; 39 | when MINUS => 40 | accum := accum - i; 41 | when DIV => 42 | accum := accum / i; 43 | end case; 44 | end; 45 | 46 | begin 47 | if s = NIL_CONS then 48 | error("eval_math", "No parameters provided."); 49 | return make_error(ERR_NOPARAM); 50 | end if; 51 | el := first_value(t); 52 | if el.kind = V_INTEGER then 53 | accum := el.i; 54 | else 55 | error("eval_math", "Can't process value of type " & value_type'Image(el.kind)); 56 | BBS.lisp.memory.deref(el); 57 | return make_error(ERR_WRONGTYPE); 58 | end if; 59 | bbs.lisp.memory.deref(el); 60 | while t > NIL_CONS loop 61 | el := first_value(t); 62 | if el.kind /= V_INTEGER then 63 | error("eval_math", "Can't process value of type " & value_type'Image(el.kind)); 64 | BBS.lisp.memory.deref(el); 65 | return make_error(ERR_WRONGTYPE); 66 | end if; 67 | process_value(el.i, b); 68 | bbs.lisp.memory.deref(el); 69 | end loop; 70 | return (kind => V_INTEGER, i => accum); 71 | end; 72 | -- 73 | -- 74 | -- Perform addition 75 | -- 76 | procedure add(e : out element_type; s : cons_index) is 77 | begin 78 | e := eval_math(s, PLUS); 79 | end; 80 | -- 81 | -- Perform subtraction 82 | -- 83 | procedure sub(e : out element_type; s : cons_index) is 84 | begin 85 | e := eval_math(s, MINUS); 86 | end; 87 | -- 88 | -- Perform multiplication 89 | -- 90 | procedure mul(e : out element_type; s : cons_index) is 91 | begin 92 | e := eval_math(s, MUL); 93 | end; 94 | -- 95 | -- Perform division 96 | -- 97 | procedure div(e : out element_type; s : cons_index) is 98 | begin 99 | e := eval_math(s, DIV); 100 | end; 101 | end; 102 | -------------------------------------------------------------------------------- /src/bbs-lisp-evaluate-math.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Author: Brent Seidel 3 | -- Date: 31-Jul-2024 4 | -- 5 | -- This file is part of Tiny-Lisp. 6 | -- Tiny-Lisp is free software: you can redistribute it and/or modify it 7 | -- under the terms of the GNU General Public License as published by the 8 | -- Free Software Foundation, either version 3 of the License, or (at your 9 | -- option) any later version. 10 | -- 11 | -- Tiny-Lisp is distributed in the hope that it will be useful, but 12 | -- WITHOUT ANY WARRANTY; without even the implied warranty of 13 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General 14 | -- Public License for more details. 15 | -- 16 | -- You should have received a copy of the GNU General Public License along 17 | -- with Tiny-Lisp. If not, see .-- 18 | -- 19 | -- This package contains the various Lisp math functions. 20 | -- 21 | package BBS.lisp.evaluate.math is 22 | pragma Elaborate_Body; 23 | -- 24 | -- Perform addition 25 | -- 26 | procedure add(e : out element_type; s : cons_index); 27 | -- 28 | -- Perform subtraction 29 | -- 30 | procedure sub(e : out element_type; s : cons_index); 31 | -- 32 | -- Perform multiplication 33 | -- 34 | procedure mul(e : out element_type; s : cons_index); 35 | -- 36 | -- Perform division 37 | -- 38 | procedure div(e : out element_type; s : cons_index); 39 | 40 | private 41 | -- 42 | -- Helper function for math operations. 43 | -- 44 | function eval_math(s : cons_index; b : mathops) return element_type; 45 | end; 46 | -------------------------------------------------------------------------------- /src/bbs-lisp-evaluate-mem.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Author: Brent Seidel 3 | -- Date: 31-Jul-2024 4 | -- 5 | -- This file is part of Tiny-Lisp. 6 | -- Tiny-Lisp is free software: you can redistribute it and/or modify it 7 | -- under the terms of the GNU General Public License as published by the 8 | -- Free Software Foundation, either version 3 of the License, or (at your 9 | -- option) any later version. 10 | -- 11 | -- Tiny-Lisp is distributed in the hope that it will be useful, but 12 | -- WITHOUT ANY WARRANTY; without even the implied warranty of 13 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General 14 | -- Public License for more details. 15 | -- 16 | -- You should have received a copy of the GNU General Public License along 17 | -- with Tiny-Lisp. If not, see .-- 18 | -- 19 | with Ada.Unchecked_Conversion; 20 | package body BBS.lisp.evaluate.mem is 21 | -- 22 | -- Conversions to addresses 23 | -- 24 | function intermediate_to_p_uint8 is 25 | new Ada.Unchecked_Conversion(source => intermediate, target => p_uint8); 26 | function intermediate_to_p_uint16 is 27 | new Ada.Unchecked_Conversion(source => intermediate, target => p_uint16); 28 | function intermediate_to_p_uint32 is 29 | new Ada.Unchecked_Conversion(source => intermediate, target => p_uint32); 30 | -- 31 | -- Read memory locations returning 8, 16, or 32 bit elements from the 32 | -- location. Some systems may throw exceptions for unaligned access. 33 | -- 34 | procedure peek8(e : out element_type; s : cons_index) is 35 | rest : cons_index := s; 36 | param : element_type; 37 | addr1 : intermediate; 38 | addr : p_uint8; 39 | value : uint8; 40 | begin 41 | if s = NIL_CONS then 42 | error("peek8", "No parameters provided."); 43 | e := make_error(ERR_NOPARAM); 44 | return; 45 | end if; 46 | -- 47 | -- Get the first value 48 | -- 49 | param := first_value(rest); 50 | -- 51 | -- Check if the first value is an integer element. 52 | -- 53 | if param.kind = V_INTEGER then 54 | addr1 := intermediate(int32_to_uint32(param.i)); 55 | addr := intermediate_to_p_uint8(addr1); 56 | else 57 | error("peek8", "Address must be integer."); 58 | e := make_error(ERR_WRONGTYPE); 59 | return; 60 | end if; 61 | -- 62 | -- If the parameter is an integer and in range, then read the memory 63 | -- location and try to return the value. 64 | -- 65 | value := addr.all; 66 | e := (kind => V_INTEGER, i => int32(value)); 67 | end; 68 | -- 69 | procedure peek16(e : out element_type; s : cons_index) is 70 | rest : cons_index := s; 71 | param : element_type; 72 | addr1 : intermediate; 73 | addr : p_uint16; 74 | value : uint16; 75 | begin 76 | if s = NIL_CONS then 77 | error("peek16", "No parameters provided."); 78 | e := make_error(ERR_NOPARAM); 79 | return; 80 | end if; 81 | -- 82 | -- Get the first value 83 | -- 84 | param := first_value(rest); 85 | -- 86 | -- Check if the first value is an integer element. 87 | -- 88 | if param.kind = V_INTEGER then 89 | addr1 := intermediate(int32_to_uint32(param.i)); 90 | addr := intermediate_to_p_uint16(addr1); 91 | else 92 | error("peek16", "Address must be integer."); 93 | e := make_error(ERR_WRONGTYPE); 94 | return; 95 | end if; 96 | -- 97 | -- If the parameter is an integer and in range, then read the memory 98 | -- location and try to return the value. 99 | -- 100 | value := addr.all; 101 | e := (kind => V_INTEGER, i => int32(value)); 102 | end; 103 | -- 104 | procedure peek32(e : out element_type; s : cons_index) is 105 | rest : cons_index := s; 106 | param : element_type; 107 | addr1 : intermediate; 108 | addr : p_uint32; 109 | value : uint32; 110 | begin 111 | if s = NIL_CONS then 112 | error("peek32", "No parameters provided."); 113 | e := make_error(ERR_NOPARAM); 114 | return; 115 | end if; 116 | -- 117 | -- Get the first value 118 | -- 119 | param := first_value(rest); 120 | -- 121 | -- Check if the first value is an integer element. 122 | -- 123 | if param.kind = V_INTEGER then 124 | addr1 := intermediate(int32_to_uint32(param.i)); 125 | addr := intermediate_to_p_uint32(addr1); 126 | else 127 | error("peek32", "Address must be integer."); 128 | e := make_error(ERR_WRONGTYPE); 129 | return; 130 | end if; 131 | -- 132 | -- If the parameter is an integer and in range, then read the memory 133 | -- location and try to return the value. 134 | -- 135 | value := addr.all; 136 | e := (kind => V_INTEGER, i => uint32_to_int32(value)); 137 | end; 138 | -- 139 | -- Write 8, 16, or 32 bit elements to memory locations. Some systems may 140 | -- throw exceptions for unaligned access. 141 | -- 142 | procedure poke8(e : out element_type; s : cons_index) is 143 | rest : cons_index := s; 144 | param : element_type; 145 | addr1 : intermediate; 146 | addr : p_uint8; 147 | value : uint8; 148 | begin 149 | if s = NIL_CONS then 150 | error("poke8", "No parameters provided."); 151 | e := make_error(ERR_NOPARAM); 152 | return; 153 | end if; 154 | -- 155 | -- Get the first parameter (address) and check if it is an integer 156 | -- 157 | param := first_value(rest); 158 | if param.kind = V_INTEGER then 159 | addr1 := intermediate(int32_to_uint32(param.i)); 160 | addr := intermediate_to_p_uint8(addr1); 161 | else 162 | error("poke8", "Address must be integer."); 163 | e := make_error(ERR_WRONGTYPE); 164 | return; 165 | end if; 166 | -- 167 | -- Get the second parameter (value) 168 | -- 169 | if rest = NIL_CONS then 170 | error("poke8", "Only one parameter provided."); 171 | e := make_error(ERR_FEWPARAM); 172 | return; 173 | end if; 174 | param := first_value(rest); 175 | -- 176 | -- Check if the first value is an integer element. 177 | -- 178 | if param.kind = V_INTEGER then 179 | value := uint8(int32_to_uint32(param.i) and 16#FF#); 180 | else 181 | error("poke8", "Value must be integer."); 182 | e := make_error(ERR_WRONGTYPE); 183 | return; 184 | end if; 185 | -- 186 | -- If the parameter is an integer and in range, then write to the memory 187 | -- location. 188 | -- 189 | addr.all := value; 190 | e := (kind => V_INTEGER, i => int32(value)); 191 | end; 192 | -- 193 | procedure poke16(e : out element_type; s : cons_index) is 194 | rest : cons_index := s; 195 | param : element_type; 196 | addr1 : intermediate; 197 | addr : p_uint16; 198 | value : uint16; 199 | begin 200 | if s = NIL_CONS then 201 | error("poke16", "No parameters provided."); 202 | e := make_error(ERR_NOPARAM); 203 | return; 204 | end if; 205 | -- 206 | -- Get the first parameter (address) and check if it is an integer 207 | -- 208 | param := first_value(rest); 209 | if param.kind = V_INTEGER then 210 | addr1 := intermediate(int32_to_uint32(param.i)); 211 | addr := intermediate_to_p_uint16(addr1); 212 | else 213 | error("poke16", "Address must be integer."); 214 | e := make_error(ERR_WRONGTYPE); 215 | return; 216 | end if; 217 | -- 218 | -- Get the second parameter (value) 219 | -- 220 | if rest = NIL_CONS then 221 | error("poke16", "Only one parameter provided."); 222 | e := make_error(ERR_FEWPARAM); 223 | return; 224 | end if; 225 | param := first_value(rest); 226 | -- 227 | -- Check if the first value is an integer element. 228 | -- 229 | if param.kind = V_INTEGER then 230 | value := uint16(int32_to_uint32(param.i) and 16#FFFF#); 231 | else 232 | error("poke16", "Value must be integer."); 233 | e := make_error(ERR_WRONGTYPE); 234 | return; 235 | end if; 236 | -- 237 | -- If the parameter is an integer and in range, then write to the memory 238 | -- location. 239 | -- 240 | addr.all := value; 241 | e := (kind => V_INTEGER, i => int32(value)); 242 | end; 243 | -- 244 | procedure poke32(e : out element_type; s : cons_index) is 245 | rest : cons_index := s; 246 | param : element_type; 247 | addr1 : intermediate; 248 | addr : p_uint32; 249 | value : uint32; 250 | begin 251 | if s = NIL_CONS then 252 | error("poke32", "No parameters provided."); 253 | e := make_error(ERR_NOPARAM); 254 | return; 255 | end if; 256 | -- 257 | -- Get the first parameter (address) and check if it is an integer 258 | -- 259 | param := first_value(rest); 260 | if param.kind = V_INTEGER then 261 | addr1 := intermediate(int32_to_uint32(param.i)); 262 | addr := intermediate_to_p_uint32(addr1); 263 | else 264 | error("poke32", "Address must be integer."); 265 | e := make_error(ERR_WRONGTYPE); 266 | return; 267 | end if; 268 | -- 269 | -- Get the second parameter (value) 270 | -- 271 | if rest = NIL_CONS then 272 | error("poke32", "Only one parameter provided."); 273 | e := make_error(ERR_FEWPARAM); 274 | return; 275 | end if; 276 | param := first_value(rest); 277 | -- 278 | -- Check if the first value is an integer element. 279 | -- 280 | if param.kind = V_INTEGER then 281 | value := int32_to_uint32(param.i); 282 | else 283 | error("poke32", "Value must be integer."); 284 | e := make_error(ERR_WRONGTYPE); 285 | return; 286 | end if; 287 | -- 288 | -- If the parameter is an integer and in range, then write to the memory 289 | -- location. 290 | -- 291 | addr.all := value; 292 | e := (kind => V_INTEGER, i => int32(value)); 293 | end; 294 | -- 295 | end; 296 | -------------------------------------------------------------------------------- /src/bbs-lisp-evaluate-mem.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Author: Brent Seidel 3 | -- Date: 31-Jul-2024 4 | -- 5 | -- This file is part of Tiny-Lisp. 6 | -- Tiny-Lisp is free software: you can redistribute it and/or modify it 7 | -- under the terms of the GNU General Public License as published by the 8 | -- Free Software Foundation, either version 3 of the License, or (at your 9 | -- option) any later version. 10 | -- 11 | -- Tiny-Lisp is distributed in the hope that it will be useful, but 12 | -- WITHOUT ANY WARRANTY; without even the implied warranty of 13 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General 14 | -- Public License for more details. 15 | -- 16 | -- You should have received a copy of the GNU General Public License along 17 | -- with Tiny-Lisp. If not, see .-- 18 | -- 19 | -- This package contains routines for direct memory access operations. This 20 | -- can is intended for use on embedded systems where hardware devices can be 21 | -- accessed at fixed addresses. Here be dragons. This can be dangerous. 22 | -- 23 | package BBS.lisp.evaluate.mem 24 | with SPARK_Mode => Off 25 | is 26 | pragma Elaborate_Body; 27 | -- 28 | -- Since this package explicitly access arbitrary memory locations for read 29 | -- and write, there is no way that this can be proved, so we just turn SPARK 30 | -- mode off. 31 | -- 32 | -- Read memory locations returning 8, 16, or 32 bit elements from the 33 | -- location. Some systems may throw exceptions for unaligned access. 34 | -- 35 | procedure peek8(e : out element_type; s : cons_index); 36 | procedure peek16(e : out element_type; s : cons_index); 37 | procedure peek32(e : out element_type; s : cons_index); 38 | -- 39 | -- Write 8, 16, or 32 bit elements to memory locations. Some systems may 40 | -- throw exceptions for unaligned access. 41 | -- 42 | procedure poke8(e : out element_type; s : cons_index); 43 | procedure poke16(e : out element_type; s : cons_index); 44 | procedure poke32(e : out element_type; s : cons_index); 45 | private 46 | type uint8 is mod 2**8 47 | with size => 8; 48 | type uint16 is mod 2**16 49 | with Size => 16; 50 | type intermediate is mod 2**(Standard'Address_Size) 51 | with Size => Standard'Address_Size; 52 | -- 53 | -- uint32 is already defined. 54 | -- 55 | type p_uint8 is access uint8; 56 | type p_uint16 is access uint16; 57 | type p_uint32 is access uint32; 58 | -- 59 | -- On Arduino Due, reading memory locations: 60 | -- Addr peek8 peek16 peek32 61 | -- 1 D1 00D1 152000D1 62 | -- 2 00 2000 DB152000 63 | -- 3 20 1520 09DB1520 64 | -- 4 15 DB15 0009DB15 65 | -- 5 DB 09DB 5D0009DB 66 | -- 6 09 0009 DB5D0009 67 | -- 7 00 5D00 09DB5D00 68 | -- 8 5D DB5D 0009DB5D 69 | end; 70 | -------------------------------------------------------------------------------- /src/bbs-lisp-evaluate-misc.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Author: Brent Seidel 3 | -- Date: 31-Jul-2024 4 | -- 5 | -- This file is part of Tiny-Lisp. 6 | -- Tiny-Lisp is free software: you can redistribute it and/or modify it 7 | -- under the terms of the GNU General Public License as published by the 8 | -- Free Software Foundation, either version 3 of the License, or (at your 9 | -- option) any later version. 10 | -- 11 | -- Tiny-Lisp is distributed in the hope that it will be useful, but 12 | -- WITHOUT ANY WARRANTY; without even the implied warranty of 13 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General 14 | -- Public License for more details. 15 | -- 16 | -- You should have received a copy of the GNU General Public License along 17 | -- with Tiny-Lisp. If not, see .-- 18 | -- 19 | with Ada.Real_Time; 20 | use type Ada.Real_Time.Time; 21 | package body BBS.lisp.evaluate.misc is 22 | -- 23 | -- Turn display of messages on or off depending on the boolean value 24 | -- passed as a parameter. 25 | -- 26 | procedure msg(e : out element_type; s : cons_index) is 27 | t : cons_index := s; 28 | p1 : element_type; -- Parameter 29 | begin 30 | if s = cons_index'First then 31 | error("msg", "No parameters provided."); 32 | e := make_error(ERR_NOPARAM); 33 | return; 34 | end if; 35 | p1 := first_value(t); 36 | if p1.kind = V_ERROR then 37 | error("msg", "Error reported evaluating parameter."); 38 | e := p1; 39 | return; 40 | end if; 41 | if p1.kind = V_BOOLEAN then 42 | msg_flag := p1.b; 43 | e := NIL_ELEM; 44 | else 45 | error("msg", "Parameter must be of boolean type, not " & value_type'Image(p1.kind)); 46 | e := make_error(ERR_WRONGTYPE); 47 | end if; 48 | end; 49 | -- 50 | procedure dump(e : out element_type; s : cons_index) is 51 | pragma Unreferenced (s); 52 | begin 53 | dump_cons; 54 | dump_symbols; 55 | dump_strings; 56 | e := NIL_ELEM; 57 | end; 58 | -- 59 | -- Set the quit flag to exit the lisp interpreter 60 | -- 61 | procedure quit(e : out element_type; s : cons_index) is 62 | pragma Unreferenced (s); 63 | begin 64 | exit_flag := True; 65 | e := NIL_ELEM; 66 | end; 67 | -- 68 | -- Sleep for a specified period of time in mS. 69 | -- 70 | procedure sleep(e : out element_type; s : cons_index) is 71 | t : cons_index := s; 72 | p1 : element_type; -- Parameter 73 | begin 74 | if s = NIL_CONS then 75 | error("sleep", "No parameters provided."); 76 | e := make_error(ERR_NOPARAM); 77 | return; 78 | end if; 79 | p1 := first_value(t); 80 | if p1.kind = V_ERROR then 81 | error("sleep", "Error reported evaluating parameter."); 82 | e := p1; 83 | return; 84 | end if; 85 | if p1.kind = V_INTEGER then 86 | delay until Ada.Real_Time.Clock + Ada.Real_Time.To_Time_Span(Duration(p1.i)/1000.0); 87 | e := NIL_ELEM; 88 | else 89 | error("sleep", "Parameter must be of integer type, not " & value_type'Image(p1.kind)); 90 | e := make_error(ERR_WRONGTYPE); 91 | end if; 92 | end; 93 | -- 94 | end; 95 | -------------------------------------------------------------------------------- /src/bbs-lisp-evaluate-misc.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Author: Brent Seidel 3 | -- Date: 31-Jul-2024 4 | -- 5 | -- This file is part of Tiny-Lisp. 6 | -- Tiny-Lisp is free software: you can redistribute it and/or modify it 7 | -- under the terms of the GNU General Public License as published by the 8 | -- Free Software Foundation, either version 3 of the License, or (at your 9 | -- option) any later version. 10 | -- 11 | -- Tiny-Lisp is distributed in the hope that it will be useful, but 12 | -- WITHOUT ANY WARRANTY; without even the implied warranty of 13 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General 14 | -- Public License for more details. 15 | -- 16 | -- You should have received a copy of the GNU General Public License along 17 | -- with Tiny-Lisp. If not, see .-- 18 | -- 19 | package BBS.lisp.evaluate.misc is 20 | pragma Elaborate_Body; 21 | -- 22 | -- Functions for evaluating the various builtin functions. 23 | -- 24 | -- 25 | -- Exit the lisp interpreter. 26 | -- 27 | procedure quit(e : out element_type; s : cons_index); 28 | -- 29 | -- Dump some of the internal tables for debugging purposes. 30 | -- 31 | procedure dump(e : out element_type; s : cons_index); 32 | -- 33 | -- Turn debugging messages on or off. 34 | -- 35 | procedure msg(e : out element_type; s : cons_index); 36 | -- 37 | -- Pause for the specified number of milliseconds. 38 | -- 39 | procedure sleep(e : out element_type; s : cons_index); 40 | end; 41 | -------------------------------------------------------------------------------- /src/bbs-lisp-evaluate-pred.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Author: Brent Seidel 3 | -- Date: 31-Jul-2024 4 | -- 5 | -- This file is part of Tiny-Lisp. 6 | -- Tiny-Lisp is free software: you can redistribute it and/or modify it 7 | -- under the terms of the GNU General Public License as published by the 8 | -- Free Software Foundation, either version 3 of the License, or (at your 9 | -- option) any later version. 10 | -- 11 | -- Tiny-Lisp is distributed in the hope that it will be useful, but 12 | -- WITHOUT ANY WARRANTY; without even the implied warranty of 13 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General 14 | -- Public License for more details. 15 | -- 16 | -- You should have received a copy of the GNU General Public License along 17 | -- with Tiny-Lisp. If not, see .-- 18 | -- 19 | -- This package contains an assortment of Lisp predicates that can be used to 20 | -- get information about various objects. Most of these will be very simple 21 | -- and some of them will return constant values because Tiny-Lisp doesn't 22 | -- implement some things. 23 | -- 24 | with BBS.lisp.conses; 25 | with BBS.lisp.memory; 26 | with BBS.lisp.symbols; 27 | package body BBS.lisp.evaluate.pred is 28 | -- 29 | -- These return true of false depending on the type of data passed. 30 | -- 31 | procedure atomp(e : out element_type; s : cons_index) is 32 | begin 33 | if s = NIL_CONS then 34 | error("atomp", "No parameter provided."); 35 | e := make_error(ERR_NOPARAM); 36 | return; 37 | end if; 38 | e := (Kind => V_BOOLEAN, b => not isList(BBS.lisp.conses.get_car(s))); 39 | end; 40 | -- 41 | procedure characterp(e : out element_type; s : cons_index) is 42 | t : cons_index := s; 43 | p : element_type; 44 | begin 45 | if s = NIL_CONS then 46 | error("characterp", "No parameter provided."); 47 | e := make_error(ERR_NOPARAM); 48 | return; 49 | end if; 50 | p := first_value(t); 51 | e := (Kind => V_BOOLEAN, b => p.kind = V_CHARACTER); 52 | end; 53 | -- 54 | procedure compiled_function_p(e : out element_type; s : cons_index) is 55 | t : cons_index := s; 56 | p : element_type; 57 | begin 58 | if s = NIL_CONS then 59 | error("compiled_function_p", "No parameter provided."); 60 | e := make_error(ERR_NOPARAM); 61 | return; 62 | end if; 63 | p := first_value(t); 64 | if p.kind = V_SYMBOL then 65 | if BBS.lisp.symbols.isFixed(p.sym) then 66 | e := ELEM_T; 67 | return; 68 | end if; 69 | end if; 70 | BBS.lisp.memory.deref(p); 71 | e := ELEM_F; 72 | end; 73 | -- 74 | procedure consp(e : out element_type; s : cons_index) is 75 | begin 76 | if s = NIL_CONS then 77 | error("consp", "No parameter provided."); 78 | e := make_error(ERR_NOPARAM); 79 | return; 80 | end if; 81 | e := (Kind => V_BOOLEAN, b => isList(BBS.lisp.conses.get_car(s))); 82 | end; 83 | -- 84 | procedure errorp(e : out element_type; s : cons_index) is 85 | t : cons_index := s; 86 | p : element_type; 87 | begin 88 | if s = NIL_CONS then 89 | error("errorp", "No parameter provided."); 90 | e := make_error(ERR_NOPARAM); 91 | return; 92 | end if; 93 | p := first_value(t); 94 | e := (Kind => V_BOOLEAN, b => p.kind = V_ERROR); 95 | end; 96 | -- 97 | procedure functionp(e : out element_type; s : cons_index)is 98 | t : cons_index := s; 99 | p : element_type; 100 | begin 101 | if s = NIL_CONS then 102 | error("functionp", "No parameter provided."); 103 | e := make_error(ERR_NOPARAM); 104 | return; 105 | end if; 106 | p := first_value(t); 107 | if p.kind = V_SYMBOL then 108 | if BBS.lisp.symbols.isFunction(p.sym) then 109 | e := ELEM_T; 110 | BBS.lisp.memory.deref(p); 111 | return; 112 | end if; 113 | end if; 114 | if p.kind = V_LAMBDA then 115 | e := ELEM_T; 116 | BBS.lisp.memory.deref(p); 117 | return; 118 | end if; 119 | BBS.lisp.memory.deref(p); 120 | e := ELEM_F; 121 | end; 122 | -- 123 | procedure integerp(e : out element_type; s : cons_index) is 124 | t : cons_index := s; 125 | p : element_type; 126 | begin 127 | if s = NIL_CONS then 128 | error("integerp", "No parameter provided."); 129 | e := make_error(ERR_NOPARAM); 130 | return; 131 | end if; 132 | p := first_value(t); 133 | e := (Kind => V_BOOLEAN, b => p.kind = V_INTEGER); 134 | end; 135 | -- 136 | procedure listp(e : out element_type; s : cons_index) is 137 | p : element_type; 138 | begin 139 | if s = NIL_CONS then 140 | error("listp", "No parameter provided."); 141 | e := make_error(ERR_NOPARAM); 142 | return; 143 | end if; 144 | p := BBS.lisp.conses.get_car(s); 145 | e := (Kind => V_BOOLEAN, b => isList(p) or (p = NIL_ELEM)); 146 | end; 147 | -- 148 | procedure nullp(e : out element_type; s : cons_index) is 149 | t : cons_index := s; 150 | p : element_type; 151 | begin 152 | if s = NIL_CONS then 153 | error("nullp", "No parameter provided."); 154 | e := make_error(ERR_NOPARAM); 155 | return; 156 | end if; 157 | p := first_value(t); 158 | e := (Kind => V_BOOLEAN, b => p = NIL_ELEM); 159 | end; 160 | -- 161 | procedure numberp(e : out element_type; s : cons_index) is 162 | t : cons_index := s; 163 | p : element_type; 164 | begin 165 | if s = NIL_CONS then 166 | error("numberp", "No parameter provided."); 167 | e := make_error(ERR_NOPARAM); 168 | return; 169 | end if; 170 | p := first_value(t); 171 | e := (Kind => V_BOOLEAN, b => p.kind = V_INTEGER); 172 | end; 173 | -- 174 | procedure simple_string_p(e : out element_type; s : cons_index) is 175 | t : cons_index := s; 176 | p : element_type; 177 | begin 178 | if s = NIL_CONS then 179 | error("simple_string_p", "No parameter provided."); 180 | e := make_error(ERR_NOPARAM); 181 | return; 182 | end if; 183 | p := first_value(t); 184 | e := (Kind => V_BOOLEAN, b => p.kind = V_STRING); 185 | end; 186 | -- 187 | procedure stringp(e : out element_type; s : cons_index) is 188 | t : cons_index := s; 189 | p : element_type; 190 | begin 191 | if s = NIL_CONS then 192 | error("stringp", "No parameter provided."); 193 | e := make_error(ERR_NOPARAM); 194 | return; 195 | end if; 196 | p := first_value(t); 197 | e := (Kind => V_BOOLEAN, b => p.kind = V_STRING); 198 | end; 199 | -- 200 | procedure symbolp(e : out element_type; s : cons_index) is 201 | p : element_type; 202 | begin 203 | if s = NIL_CONS then 204 | error("symbolp", "No parameter provided."); 205 | e := make_error(ERR_NOPARAM); 206 | return; 207 | end if; 208 | p := BBS.lisp.conses.get_car(s); 209 | e := (Kind => V_BOOLEAN, b => p.kind = V_SYMBOL); 210 | end; 211 | -- 212 | -- These always return false as the data types are not implemented. There's 213 | -- actually no reason to have all of these functions coded. They can just 214 | -- use one function that returns NIL (False). 215 | -- 216 | procedure return_false(e : out element_type; s : cons_index) is 217 | pragma Unreferenced (s); 218 | begin 219 | e := ELEM_F; 220 | end; 221 | -- 222 | -- procedure arrayp(e : out element_type; s : cons_index); 223 | -- procedure bit_vector_p(e : out element_type; s : cons_index); 224 | -- procedure complexp(e : out element_type; s : cons_index); 225 | -- procedure floatp(e : out element_type; s : cons_index); 226 | -- procedure rationalp(e : out element_type; s : cons_index); 227 | -- procedure realp(e : out element_type; s : cons_index); 228 | -- procedure packagep(e : out element_type; s : cons_index); 229 | -- procedure simple_vector_p(e : out element_type; s : cons_index); 230 | -- procedure simple_bit_vector_p(e : out element_type; s : cons_index); 231 | -- procedure vectorp(e : out element_type; s : cons_index); 232 | -- 233 | end; 234 | -------------------------------------------------------------------------------- /src/bbs-lisp-evaluate-pred.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Author: Brent Seidel 3 | -- Date: 31-Jul-2024 4 | -- 5 | -- This file is part of Tiny-Lisp. 6 | -- Tiny-Lisp is free software: you can redistribute it and/or modify it 7 | -- under the terms of the GNU General Public License as published by the 8 | -- Free Software Foundation, either version 3 of the License, or (at your 9 | -- option) any later version. 10 | -- 11 | -- Tiny-Lisp is distributed in the hope that it will be useful, but 12 | -- WITHOUT ANY WARRANTY; without even the implied warranty of 13 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General 14 | -- Public License for more details. 15 | -- 16 | -- You should have received a copy of the GNU General Public License along 17 | -- with Tiny-Lisp. If not, see .-- 18 | -- 19 | -- This package contains an assortment of Lisp predicates that can be used to 20 | -- get information about various objects. Most of these will be very simple 21 | -- and some of them will return constant values because Tiny-Lisp doesn't 22 | -- implement some things. 23 | -- 24 | package BBS.lisp.evaluate.pred is 25 | -- 26 | -- These return true of false depending on the type of data passed. 27 | -- 28 | procedure atomp(e : out element_type; s : cons_index); 29 | procedure characterp(e : out element_type; s : cons_index); 30 | procedure compiled_function_p(e : out element_type; s : cons_index); 31 | procedure consp(e : out element_type; s : cons_index); 32 | procedure errorp(e : out element_type; s : cons_index); 33 | procedure functionp(e : out element_type; s : cons_index); 34 | procedure integerp(e : out element_type; s : cons_index); 35 | procedure listp(e : out element_type; s : cons_index); 36 | procedure nullp(e : out element_type; s : cons_index); 37 | procedure numberp(e : out element_type; s : cons_index); 38 | procedure simple_string_p(e : out element_type; s : cons_index); 39 | procedure stringp(e : out element_type; s : cons_index); 40 | procedure symbolp(e : out element_type; s : cons_index); 41 | -- 42 | -- These always return false as the data types are not implemented. 43 | -- 44 | procedure return_false(e : out element_type; s : cons_index); 45 | -- procedure arrayp(e : out element_type; s : cons_index); 46 | -- procedure bit_vector_p(e : out element_type; s : cons_index); 47 | -- procedure complexp(e : out element_type; s : cons_index); 48 | -- procedure floatp(e : out element_type; s : cons_index); 49 | -- procedure rationalp(e : out element_type; s : cons_index); 50 | -- procedure realp(e : out element_type; s : cons_index); 51 | -- procedure packagep(e : out element_type; s : cons_index); 52 | -- procedure simple_vector_p(e : out element_type; s : cons_index); 53 | -- procedure simple_bit_vector_p(e : out element_type; s : cons_index); 54 | -- procedure vectorp(e : out element_type; s : cons_index); 55 | 56 | end; 57 | -------------------------------------------------------------------------------- /src/bbs-lisp-evaluate-str.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Author: Brent Seidel 3 | -- Date: 31-Jul-2024 4 | -- 5 | -- This file is part of Tiny-Lisp. 6 | -- Tiny-Lisp is free software: you can redistribute it and/or modify it 7 | -- under the terms of the GNU General Public License as published by the 8 | -- Free Software Foundation, either version 3 of the License, or (at your 9 | -- option) any later version. 10 | -- 11 | -- Tiny-Lisp is distributed in the hope that it will be useful, but 12 | -- WITHOUT ANY WARRANTY; without even the implied warranty of 13 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General 14 | -- Public License for more details. 15 | -- 16 | -- You should have received a copy of the GNU General Public License along 17 | -- with Tiny-Lisp. If not, see .-- 18 | -- 19 | with BBS.lisp.conses; 20 | with BBS.lisp.memory; 21 | with BBS.lisp.strings; 22 | package body BBS.lisp.evaluate.str is 23 | -- 24 | -- Return the length of a string or list. Atoms will get a value of 1. 25 | -- A nil pointer returns a length of 0. 26 | -- 27 | procedure length(e : out element_type; s : cons_index) is 28 | t : cons_index := s; 29 | p1 : element_type; -- Parameter 30 | begin 31 | if s = NIL_CONS then 32 | error("length", "No parameters provided."); 33 | e := make_error(ERR_NOPARAM); 34 | return; 35 | end if; 36 | p1 := first_value(t); 37 | if isList(p1) then 38 | e := (kind => V_INTEGER, i => length(getList(p1))); 39 | elsif p1.kind = V_STRING then 40 | e := (kind => V_INTEGER, i => BBS.lisp.strings.length(p1.s)); 41 | elsif p1 = NIL_ELEM then 42 | e := (kind => V_INTEGER, i => 0); 43 | else 44 | e := (kind => V_INTEGER, i => 1); 45 | end if; 46 | end; 47 | -- 48 | -- Helper functions for length 49 | -- 50 | function length(s : cons_index) return int32 is 51 | t : cons_index := s; 52 | last : cons_index; 53 | c : int32 := 0; 54 | begin 55 | while t > NIL_CONS loop 56 | c := c + 1; 57 | last := t; 58 | t := getList(BBS.lisp.conses.get_cdr(t)); 59 | end loop; 60 | if BBS.lisp.conses.get_cdr(last) /= NIL_ELEM then 61 | c := c + 1; 62 | end if; 63 | return c; 64 | end; 65 | -- 66 | -- 67 | -- Return a specified character from a string. 68 | -- 69 | procedure char(e : out element_type; s : cons_index) is 70 | t : cons_index := s; 71 | p1 : element_type; -- First parameter (string) 72 | p2 : element_type; -- Second parameter (integer) 73 | str : string_index; 74 | index : Integer; 75 | begin 76 | if s = NIL_CONS then 77 | error("char", "No parameters provided."); 78 | e := make_error(ERR_NOPARAM); 79 | return; 80 | end if; 81 | -- 82 | -- Get first parameter. It should be a string 83 | -- 84 | p1 := first_value(t); 85 | if p1.kind /= V_STRING then 86 | error("char", "First parameter should be a string, not " 87 | & value_type'Image(p1.kind)); 88 | e := make_error(ERR_WRONGTYPE); 89 | return; 90 | end if; 91 | p2 := first_value(t); 92 | if p2.kind /= V_INTEGER then 93 | error("char", "Second parameter should be an integer, not " 94 | & value_type'Image(p2.kind)); 95 | e := make_error(ERR_WRONGTYPE); 96 | return; 97 | end if; 98 | str := p1.s; 99 | index := Integer(p2.i) + 1; 100 | if index < 1 then 101 | error("char", "Index out of range"); 102 | e := make_error(ERR_RANGE); 103 | return; 104 | end if; 105 | BBS.lisp.strings.cannonicalize(str, index); 106 | if str = NIL_STR then 107 | error("char", "Index out of range"); 108 | e := make_error(ERR_RANGE); 109 | return; 110 | end if; 111 | e := (kind => V_CHARACTER, c => BBS.lisp.strings.get_char_at(str, index)); 112 | end; 113 | -- 114 | -- Parse a string as an integer and return the integer value. 115 | -- 116 | procedure parse_integer(e : out element_type; s : cons_index) is 117 | t : cons_index := s; 118 | p1 : element_type; -- Parameter 119 | begin 120 | if s = NIL_CONS then 121 | error("length", "No parameters provided."); 122 | e := make_error(ERR_NOPARAM); 123 | return; 124 | end if; 125 | p1 := first_value(t); 126 | if p1.kind /= V_STRING then 127 | error("parse-integer", "Parameter must be a string, not " & 128 | value_type'Image(p1.kind)); 129 | e := make_error(ERR_WRONGTYPE); 130 | return; 131 | end if; 132 | -- 133 | -- Now that we know we have a string, try and parse it. 134 | -- 135 | e := (kind => V_INTEGER, i => BBS.lisp.strings.parse_integer(p1.s)); 136 | end; 137 | -- 138 | -- Return a substring of the original string 139 | -- 140 | procedure subseq(e : out element_type; s : cons_index) is 141 | t : cons_index := s; 142 | p1 : element_type; -- Parameter 1 (string) 143 | source : string_index; -- Source string 144 | p2 : element_type; -- Parameter 2 (starting position) 145 | start : Integer; 146 | p3 : element_type; -- Parameter 3 (ending position) (optional) 147 | stop : Integer; -- Last character, -1 means end of source string 148 | head : string_index; 149 | begin 150 | if s = NIL_CONS then 151 | error("subseq", "No parameters provided."); 152 | e := make_error(ERR_NOPARAM); 153 | return; 154 | end if; 155 | -- 156 | -- First parameter 157 | -- 158 | p1 := first_value(t); 159 | if p1.kind = V_ERROR then 160 | error("subseq", "Error reported evaluating first parameter."); 161 | e := p1; 162 | return; 163 | end if; 164 | if p1.kind /= V_STRING then 165 | error("subseq", "First parameter is not a string"); 166 | BBS.lisp.memory.deref(p1); 167 | e := make_error(ERR_WRONGTYPE); 168 | return; 169 | end if; 170 | source := p1.s; 171 | -- 172 | -- Second parameter 173 | -- 174 | p2 := first_value(t); 175 | if p2.kind = V_ERROR then 176 | error("subseq", "Error reported evaluating second parameter."); 177 | BBS.lisp.memory.deref(p1); 178 | e := p2; 179 | return; 180 | end if; 181 | if p2.kind /= V_INTEGER then 182 | error("subseq", "Second parameter is not an integer"); 183 | BBS.lisp.memory.deref(p1); 184 | e := make_error(ERR_WRONGTYPE); 185 | return; 186 | end if; 187 | start := Integer(p2.i) + 1; 188 | -- 189 | -- Third parameter (optional) 190 | -- 191 | if t > NIL_CONS then 192 | p3 := first_value(t); 193 | if p3.kind = V_ERROR then 194 | error("subseq", "Error reported evaluating third parameter."); 195 | BBS.lisp.memory.deref(p1); 196 | e := p3; 197 | return; 198 | end if; 199 | if p3.kind /= V_INTEGER then 200 | error("subseq", "Third parameter is not an integer"); 201 | BBS.lisp.memory.deref(p1); 202 | e := make_error(ERR_WRONGTYPE); 203 | return; 204 | end if; 205 | stop := Integer(p3.i); 206 | if stop < start then 207 | error("subseq", "Ending character must be greater than starting character."); 208 | BBS.lisp.memory.deref(p1); 209 | e := make_error(ERR_RANGE); 210 | return; 211 | end if; 212 | stop := stop - start + 1; -- Convert last character position to length. 213 | else 214 | stop := -1; 215 | end if; 216 | if start < 1 then 217 | error("subseq", "Starting character must not be less than 0."); 218 | BBS.lisp.memory.deref(p1); 219 | e := make_error(ERR_RANGE); 220 | return; 221 | end if; 222 | -- 223 | -- Now do the processing. Find the starting character. 224 | -- 225 | BBS.lisp.strings.cannonicalize(source, start); 226 | if source = NIL_STR then 227 | error("subseq", "Index out of range"); 228 | e := make_error(ERR_RANGE); 229 | return; 230 | end if; 231 | -- 232 | -- Now source and start are pointing at the first character. Allocate 233 | -- The first fragment of the destination. 234 | -- 235 | head := BBS.lisp.strings.substring(source, start, stop); 236 | BBS.lisp.memory.deref(p1); 237 | if head = NIL_STR then 238 | e := make_error(ERR_ALLOCSTR); 239 | else 240 | e := (kind => V_STRING, s => head); 241 | end if; 242 | end; 243 | -- 244 | -- Convert a string to upper case 245 | -- 246 | procedure string_upcase(e : out element_type; s : cons_index) is 247 | t : cons_index := s; 248 | t1 : element_type; 249 | p1 : element_type; -- Parameter 250 | begin 251 | if s = NIL_CONS then 252 | error("string_upcase", "No parameters provided."); 253 | e := make_error(ERR_NOPARAM); 254 | return; 255 | end if; 256 | p1 := first_value(t); 257 | if p1.kind = V_ERROR then 258 | error("string_upcase", "Error reported evaluating parameter."); 259 | e := p1; 260 | return; 261 | end if; 262 | if p1.kind /= V_STRING then 263 | error("string_upcase", "Parameter must be of string type, not " & value_type'Image(p1.kind)); 264 | BBS.lisp.memory.deref(p1); 265 | e := make_error(ERR_WRONGTYPE); 266 | return; 267 | end if; 268 | -- 269 | -- Now that the parameter is determined to be of the correct type, 270 | -- copy it while converting to uppercase. 271 | -- 272 | t1 := BBS.lisp.strings.copy(p1.s, BBS.lisp.strings.UPPER); 273 | if t1 = NIL_ELEM then 274 | error("string_upcase", "Error occured copying string"); 275 | end if; 276 | BBS.lisp.memory.deref(p1); 277 | e := t1; 278 | end; 279 | -- 280 | -- Convert a string to lower case 281 | -- 282 | procedure string_downcase(e : out element_type; s : cons_index) is 283 | t : cons_index := s; 284 | t1 : element_type; 285 | p1 : element_type; -- Parameter 286 | begin 287 | if s = NIL_CONS then 288 | error("string_downcase", "No parameters provided."); 289 | e := make_error(ERR_NOPARAM); 290 | return; 291 | end if; 292 | p1 := first_value(t); 293 | if p1.kind = V_ERROR then 294 | error("string_downcase", "Error reported evaluating parameter."); 295 | e := p1; 296 | return; 297 | end if; 298 | if p1.kind /= V_STRING then 299 | error("string_downcase", "Parameter must be of string type, not " & value_type'Image(p1.kind)); 300 | BBS.lisp.memory.deref(p1); 301 | e := make_error(ERR_WRONGTYPE); 302 | return; 303 | end if; 304 | -- 305 | -- Now that the parameter is determined to be of the correct type, 306 | -- copy it while converting to lowercase. 307 | -- 308 | t1 := BBS.lisp.strings.copy(p1.s, BBS.lisp.strings.LOWER); 309 | if t1 = NIL_ELEM then 310 | error("string_downcase", "Error occured copying string"); 311 | end if; 312 | BBS.lisp.memory.deref(p1); 313 | e := t1; 314 | end; 315 | -- 316 | end; 317 | -------------------------------------------------------------------------------- /src/bbs-lisp-evaluate-str.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Author: Brent Seidel 3 | -- Date: 31-Jul-2024 4 | -- 5 | -- This file is part of Tiny-Lisp. 6 | -- Tiny-Lisp is free software: you can redistribute it and/or modify it 7 | -- under the terms of the GNU General Public License as published by the 8 | -- Free Software Foundation, either version 3 of the License, or (at your 9 | -- option) any later version. 10 | -- 11 | -- Tiny-Lisp is distributed in the hope that it will be useful, but 12 | -- WITHOUT ANY WARRANTY; without even the implied warranty of 13 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General 14 | -- Public License for more details. 15 | -- 16 | -- You should have received a copy of the GNU General Public License along 17 | -- with Tiny-Lisp. If not, see .-- 18 | -- 19 | -- This package contains functions relating to processing strings. 20 | -- 21 | package BBS.lisp.evaluate.str is 22 | pragma Elaborate_Body; 23 | -- 24 | -- Return the length of a string or list. Atoms will get a value of 1. 25 | -- A NIL pointer returns a length of 0. 26 | -- 27 | procedure length(e : out element_type; s : cons_index); 28 | -- 29 | -- Return a specified character from a string. 30 | -- 31 | procedure char(e : out element_type; s : cons_index); 32 | -- 33 | -- Parse a string as an integer and return the integer value. 34 | -- 35 | procedure parse_integer(e : out element_type; s : cons_index); 36 | -- 37 | -- Return a substring of the original string 38 | -- 39 | procedure subseq(e : out element_type; s : cons_index); 40 | -- 41 | -- Convert a string to upper case 42 | -- 43 | procedure string_upcase(e : out element_type; s : cons_index); 44 | -- 45 | -- Convert a string to lower case 46 | -- 47 | procedure string_downcase(e : out element_type; s : cons_index); 48 | private 49 | -- 50 | -- Helper functions for length of a list (note that length of a string is in 51 | -- BBS.lisp.strings). 52 | -- 53 | function length(s : cons_index) return int32; 54 | end; 55 | -------------------------------------------------------------------------------- /src/bbs-lisp-evaluate-symb.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Author: Brent Seidel 3 | -- Date: 31-Jul-2024 4 | -- 5 | -- This file is part of Tiny-Lisp. 6 | -- Tiny-Lisp is free software: you can redistribute it and/or modify it 7 | -- under the terms of the GNU General Public License as published by the 8 | -- Free Software Foundation, either version 3 of the License, or (at your 9 | -- option) any later version. 10 | -- 11 | -- Tiny-Lisp is distributed in the hope that it will be useful, but 12 | -- WITHOUT ANY WARRANTY; without even the implied warranty of 13 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General 14 | -- Public License for more details. 15 | -- 16 | -- You should have received a copy of the GNU General Public License along 17 | -- with Tiny-Lisp. If not, see .-- 18 | -- 19 | with BBS.lisp.conses; 20 | with BBS.lisp.memory; 21 | with BBS.lisp.strings; 22 | package body BBS.lisp.evaluate.symb is 23 | -- 24 | -- Initialize the symbol indices. Return true if successful or false it not. 25 | -- 26 | function init_syms return Boolean is 27 | begin 28 | if not get_symb(sym_bool, "BOOLEAN") then 29 | return False; 30 | end if; 31 | if not get_symb(sym_char, "CHARACTER") then 32 | return False; 33 | end if; 34 | if not get_symb(sym_int, "INTEGER") then 35 | return False; 36 | end if; 37 | if not get_symb(sym_list, "LIST") then 38 | return False; 39 | end if; 40 | if not get_symb(sym_str, "STRING") then 41 | return False; 42 | end if; 43 | not_initialized := False; 44 | return True; 45 | end; 46 | -- 47 | -- Coerces an object of one type to another type. Available coercions are: 48 | -- character -> string 49 | -- boolean -> string 50 | -- boolean -> integer (NIL -> 0, T -> 1) 51 | -- integer -> boolean (0 -> NIL, /= 0 -> T) 52 | -- 53 | -- (coerce ) 54 | -- 55 | procedure coerce(e : out element_type; s : cons_index) is 56 | s1 : cons_index := s; 57 | t1 : element_type; 58 | t2 : element_type; 59 | str : string_index; 60 | begin 61 | if not_initialized then 62 | if not init_syms then 63 | error("coerce", "No parameters provided."); 64 | e := make_error(ERR_ALLOCSYM); 65 | return; 66 | end if; 67 | end if; 68 | if s = NIL_CONS then 69 | error("coerce", "Internal error. Should have a list."); 70 | e := make_error(ERR_NOPARAM); 71 | return; 72 | end if; 73 | -- 74 | -- Get first parameter. Note that t1 and t2 are swapped around because in 75 | -- the first version of this function, the parameters were swapped. This 76 | -- was not consistent with Common Lisp and has been changed. 77 | -- 78 | t2 := first_value(s1); 79 | if t2.kind = V_ERROR then 80 | error("coerce", "Error reported evaluating second parameter."); 81 | e := t2; 82 | return; 83 | end if; 84 | -- 85 | -- Get second parameter 86 | -- 87 | t1 := first_value(s1); 88 | if t1.kind = V_ERROR then 89 | error("coerce", "Error reported evaluating first parameter."); 90 | e := t1; 91 | return; 92 | end if; 93 | if t1.kind /= V_QSYMBOL then 94 | error("coerce", "First parameter must be a quoted symbol."); 95 | BBS.lisp.memory.deref(t1); 96 | e := make_error(ERR_WRONGTYPE); 97 | return; 98 | end if; 99 | -- 100 | -- Now do the processing 101 | -- 102 | if t1.qsym = sym_char then 103 | -- character -> character 104 | if t2.kind = V_CHARACTER then 105 | e := t2; 106 | else 107 | error("coerce", "Unable to convert " & value_type'Image(t2.kind) & 108 | " to character type."); 109 | BBS.lisp.memory.deref(t2); 110 | e := make_error(ERR_WRONGTYPE); 111 | end if; 112 | return; 113 | elsif t1.qsym = sym_int then 114 | if t2.kind = V_INTEGER then 115 | -- integer -> integer 116 | e := t2; 117 | elsif t2.kind = V_BOOLEAN then 118 | -- boolean -> integer (NIL -> 0, T -> 1) 119 | if t2.b then 120 | e := (kind => V_INTEGER, i => 1); 121 | else 122 | e := (kind => V_INTEGER, i => 0); 123 | end if; 124 | else 125 | error("coerce", "Unable to convert " & value_type'Image(t2.kind) & 126 | " to integer type."); 127 | BBS.lisp.memory.deref(t2); 128 | e := make_error(ERR_WRONGTYPE); 129 | end if; 130 | return; 131 | elsif t1.qsym = sym_bool then 132 | if t2.kind = V_BOOLEAN then 133 | -- boolean -> boolean 134 | e := t2; 135 | elsif t2.kind = V_INTEGER then 136 | -- integer -> boolean (0 -> NIL, /= 0 -> T) 137 | e := (kind => V_BOOLEAN, b => t2.i /= 0); 138 | else 139 | error("coerce", "Unable to convert " & value_type'Image(t2.kind) & 140 | " to boolean type."); 141 | BBS.lisp.memory.deref(t2); 142 | e := make_error(ERR_WRONGTYPE); 143 | end if; 144 | return; 145 | elsif t1.qsym = sym_str then 146 | if t2.kind = V_STRING then 147 | -- string -> string 148 | e := t2; 149 | elsif t2.kind = V_CHARACTER then 150 | -- character -> string 151 | if BBS.lisp.strings.str_to_lisp(str, t2.c & "") then 152 | e := (kind => V_STRING, s => str); 153 | else 154 | error("coerce", "Unable to allocate string fragment."); 155 | e := make_error(ERR_ALLOCSTR); 156 | end if; 157 | elsif t2.kind = V_BOOLEAN then 158 | -- boolean -> string 159 | if t2.b then 160 | if BBS.lisp.strings.str_to_lisp(str, "T") then 161 | e := (kind => V_STRING, s => str); 162 | else 163 | error("coerce", "Unable to allocate string fragment."); 164 | e := make_error(ERR_ALLOCSTR); 165 | end if; 166 | else 167 | if BBS.lisp.strings.str_to_lisp(str, "NIL") then 168 | e := (kind => V_STRING, s => str); 169 | else 170 | error("coerce", "Unable to allocate string fragment."); 171 | e := make_error(ERR_ALLOCSTR); 172 | end if; 173 | end if; 174 | else 175 | error("coerce", "Unable to convert " & value_type'Image(t2.kind) & 176 | " to string type."); 177 | BBS.lisp.memory.deref(t2); 178 | e := make_error(ERR_WRONGTYPE); 179 | end if; 180 | return; 181 | else 182 | error("coerce", "Unknown coercion type."); 183 | put("Type is: "); 184 | print(t1, False, True); 185 | end if; 186 | BBS.lisp.memory.deref(t2); 187 | e := make_error(ERR_WRONGTYPE); 188 | end; 189 | -- 190 | procedure concatenate(e : out element_type; s : cons_index) is 191 | s1 : cons_index := s; 192 | t1 : element_type := NIL_ELEM; 193 | t2 : element_type := NIL_ELEM; 194 | begin 195 | if not_initialized then 196 | if not init_syms then 197 | error("concatenate", "Unable to initialize symbols"); 198 | e := make_error(ERR_ALLOCSYM); 199 | return; 200 | end if; 201 | end if; 202 | if s = NIL_CONS then 203 | error("concatenate", "No parameters provided."); 204 | e := make_error(ERR_NOPARAM); 205 | return; 206 | end if; 207 | -- 208 | -- Get first parameter 209 | -- 210 | t1 := first_value(s1); 211 | if t1.kind = V_ERROR then 212 | error("concatenate", "Error reported evaluating first parameter."); 213 | e := t1; 214 | return; 215 | end if; 216 | if t1.kind /= V_QSYMBOL then 217 | error("concatenate", "First parameter must be a quoted symbol."); 218 | BBS.lisp.memory.deref(t1); 219 | e := make_error(ERR_WRONGTYPE); 220 | return; 221 | end if; 222 | if (t1.qsym /= sym_str) and (t1.qsym /= sym_list) then 223 | error("concatenate", "Can only concatenate strings and lists"); 224 | put("Unrecognized type: "); 225 | print(t1, False, True); 226 | e := make_error(ERR_WRONGTYPE); 227 | return; 228 | end if; 229 | -- 230 | -- Process strings or lists 231 | -- 232 | if t1.qsym = sym_str then 233 | -- 234 | -- Concatinate strings 235 | -- 236 | declare 237 | str_head : string_index := NIL_STR; 238 | dest_str : string_index := NIL_STR; 239 | begin 240 | if not BBS.lisp.strings.alloc(str_head) then 241 | error("concatenate", "Unable to allocate string fragment."); 242 | BBS.lisp.memory.deref(t2); 243 | e := make_error(ERR_ALLOCSTR); 244 | return; 245 | end if; 246 | dest_str := str_head; 247 | if s1 = NIL_CONS then 248 | error("concatenate", "Cannot concatenate a single element."); 249 | e := make_error(ERR_FEWPARAM); 250 | return; 251 | end if; 252 | while s1 > NIL_CONS loop 253 | -- 254 | -- Second parameter - will probably move 255 | -- 256 | t2 := first_value(s1); 257 | if t2.kind = V_ERROR then 258 | error("concatenate", "Error reported evaluating second parameter."); 259 | e := t2; 260 | return; 261 | end if; 262 | if t2.kind /= V_STRING then 263 | error("concatenate", "Unable to concatenate " & value_type'Image(t2.kind) & 264 | " to a string."); 265 | BBS.lisp.memory.deref(t2); 266 | e := make_error(ERR_WRONGTYPE); 267 | return; 268 | end if; 269 | if not BBS.lisp.strings.append(dest_str, t2.s) then 270 | error("concatenate", "Unable to allocate string fragment"); 271 | BBS.lisp.strings.deref(str_head); 272 | e := make_error(ERR_ALLOCSTR); 273 | return; 274 | end if; 275 | BBS.lisp.memory.deref(t2); 276 | end loop; 277 | e := (kind => V_STRING, s => str_head); 278 | return; 279 | end; 280 | elsif t1.qsym = sym_list then 281 | -- 282 | -- Concatinate lists 283 | -- 284 | declare 285 | cons_head : cons_index := NIL_CONS; -- Head of list being built 286 | dest_cons : cons_index := NIL_CONS; -- Current element in list being built 287 | temp_cons : cons_index := NIL_CONS; -- New cons cell to add to list 288 | src_cons : cons_index := NIL_CONS; -- Source list to copy from 289 | begin 290 | if s1 = NIL_CONS then 291 | error("concatenate", "Cannot concatenate a single element."); 292 | e := make_error(ERR_FEWPARAM); 293 | return; 294 | end if; 295 | while s1 > NIL_CONS loop 296 | t2 := first_value(s1); 297 | if t2.kind = V_ERROR then 298 | error("concatenate", "Error reported evaluating additional parameters."); 299 | e := t2; 300 | BBS.lisp.conses.deref(cons_head); 301 | return; 302 | end if; 303 | src_cons := getList(t2); 304 | if src_cons = NIL_CONS then 305 | error("concatenate", "Parameter does not evaluate to a list"); 306 | BBS.lisp.memory.deref(t2); 307 | BBS.lisp.conses.deref(cons_head); 308 | e := make_error(ERR_WRONGTYPE); 309 | return; 310 | end if; 311 | loop 312 | if not BBS.lisp.conses.alloc(temp_cons) then 313 | error("concatenate", "Unable to allocate cons cell."); 314 | BBS.lisp.conses.deref(cons_head); 315 | BBS.lisp.conses.deref(src_cons); 316 | e := make_error(ERR_ALLOCCONS); 317 | return; 318 | end if; 319 | if cons_head = NIL_CONS then 320 | cons_head := temp_cons; 321 | dest_cons := temp_cons; 322 | else 323 | -- 324 | -- Point end of list to new cons cell and update end of list. 325 | -- 326 | BBS.lisp.conses.set_cdr(dest_cons, (kind => V_LIST, l => temp_cons)); 327 | dest_cons := temp_cons; 328 | end if; 329 | -- 330 | -- Copy the value from the source list and move to the next 331 | -- element in the source. 332 | -- 333 | BBS.lisp.conses.set_car(dest_cons, BBS.lisp.conses.get_car(src_cons)); 334 | src_cons := getList(BBS.lisp.conses.get_cdr(src_cons)); 335 | if src_cons = NIL_CONS then 336 | exit; 337 | end if; 338 | end loop; 339 | BBS.lisp.memory.deref(t2); 340 | end loop; 341 | e := (kind => V_LIST, l => cons_head); 342 | return; 343 | end; 344 | end if; 345 | end; 346 | -- 347 | end; 348 | -------------------------------------------------------------------------------- /src/bbs-lisp-evaluate-symb.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Author: Brent Seidel 3 | -- Date: 31-Jul-2024 4 | -- 5 | -- This file is part of Tiny-Lisp. 6 | -- Tiny-Lisp is free software: you can redistribute it and/or modify it 7 | -- under the terms of the GNU General Public License as published by the 8 | -- Free Software Foundation, either version 3 of the License, or (at your 9 | -- option) any later version. 10 | -- 11 | -- Tiny-Lisp is distributed in the hope that it will be useful, but 12 | -- WITHOUT ANY WARRANTY; without even the implied warranty of 13 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General 14 | -- Public License for more details. 15 | -- 16 | -- You should have received a copy of the GNU General Public License along 17 | -- with Tiny-Lisp. If not, see .-- 18 | -- 19 | package BBS.lisp.evaluate.symb is 20 | pragma Elaborate_Body; 21 | -- 22 | -- Coerces an object of one type to another type. Available coercions are: 23 | -- character -> string 24 | -- boolean -> string 25 | -- boolean -> integer (NIL -> 0, T -> 1) 26 | -- integer -> boolean (0 -> NIL, /= 0 -> T) 27 | -- 28 | procedure coerce(e : out element_type; s : cons_index); 29 | -- 30 | -- Concatenate two strings or lists. 31 | -- 32 | procedure concatenate(e : out element_type; s : cons_index); 33 | 34 | private 35 | -- 36 | -- The first time one of these functions is called, populate the symbol 37 | -- indices so the symbol table doesn't have to be searched each time. 38 | -- 39 | not_initialized : Boolean := True; 40 | sym_bool : symbol_ptr := (kind => ST_NULL); 41 | sym_char : symbol_ptr := (kind => ST_NULL); 42 | sym_int : symbol_ptr := (kind => ST_NULL); 43 | sym_list : symbol_ptr := (kind => ST_NULL); 44 | sym_str : symbol_ptr := (kind => ST_NULL); 45 | -- 46 | -- Initialize the symbol indices. Return true if successful or false it not. 47 | -- 48 | function init_syms return Boolean; 49 | end; 50 | -------------------------------------------------------------------------------- /src/bbs-lisp-evaluate-vars.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Author: Brent Seidel 3 | -- Date: 31-Jul-2024 4 | -- 5 | -- This file is part of Tiny-Lisp. 6 | -- Tiny-Lisp is free software: you can redistribute it and/or modify it 7 | -- under the terms of the GNU General Public License as published by the 8 | -- Free Software Foundation, either version 3 of the License, or (at your 9 | -- option) any later version. 10 | -- 11 | -- Tiny-Lisp is distributed in the hope that it will be useful, but 12 | -- WITHOUT ANY WARRANTY; without even the implied warranty of 13 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General 14 | -- Public License for more details. 15 | -- 16 | -- You should have received a copy of the GNU General Public License along 17 | -- with Tiny-Lisp. If not, see .-- 18 | -- 19 | package BBS.lisp.evaluate.vars is 20 | -- 21 | -- This sets a symbol or stack variable to a value. The first parameter 22 | -- must evaluate to a symbol, stack variable, or temp symbol. If it is a 23 | -- temp symbol, it is converted to a perminant symbol in the symbol table. 24 | -- The assigned value is the result of evaluating the second parameter. 25 | -- 26 | procedure setq(e : out element_type; s : cons_index; p : phase); 27 | -- 28 | -- Define local variables and optionally assign values to them. 29 | -- 30 | procedure local(e : out element_type; s : cons_index; p : phase); 31 | 32 | end; 33 | -------------------------------------------------------------------------------- /src/bbs-lisp-evaluate.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Author: Brent Seidel 3 | -- Date: 31-Jul-2024 4 | -- 5 | -- This file is part of Tiny-Lisp. 6 | -- Tiny-Lisp is free software: you can redistribute it and/or modify it 7 | -- under the terms of the GNU General Public License as published by the 8 | -- Free Software Foundation, either version 3 of the License, or (at your 9 | -- option) any later version. 10 | -- 11 | -- Tiny-Lisp is distributed in the hope that it will be useful, but 12 | -- WITHOUT ANY WARRANTY; without even the implied warranty of 13 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General 14 | -- Public License for more details. 15 | -- 16 | -- You should have received a copy of the GNU General Public License along 17 | -- with Tiny-Lisp. If not, see .-- 18 | -- 19 | with BBS.lisp.conses; 20 | with BBS.lisp.global; 21 | with BBS.lisp.memory; 22 | with BBS.lisp.symbols; 23 | package body BBS.lisp.evaluate 24 | with Refined_State => (pvt_exit_block => exit_block) is 25 | -- 26 | -- Take an element_type and checks if it can be interpreted as true or false. 27 | -- 28 | function isTrue(e : element_type) return Boolean is 29 | begin 30 | if e = NIL_ELEM then 31 | return False; 32 | elsif isList(e) then 33 | if (BBS.lisp.conses.get_car(getList(e)) = NIL_ELEM) 34 | and (BBS.lisp.conses.get_cdr(getList(e)) = NIL_ELEM) then 35 | return False; 36 | end if; 37 | elsif e.kind = V_BOOLEAN then 38 | return e.b; 39 | end if; 40 | return True; 41 | end; 42 | -- 43 | -- A list can be either element type E_CONS or a value of type V_LIST. This 44 | -- checks both to see if the element is actually some sort of a list. 45 | -- 46 | function isList(e : element_type) return Boolean is 47 | begin 48 | return e.kind = V_LIST; 49 | end; 50 | -- 51 | -- If e is list type, return the index of the head of the list, otherwise 52 | -- return NIL_CONS. 53 | -- 54 | function getList(e : element_type) return cons_index is 55 | begin 56 | if e.kind = V_LIST then 57 | return e.l; 58 | end if; 59 | return NIL_CONS; 60 | end; 61 | -- 62 | -- Takes a cons index and returns a list element type. 63 | -- 64 | function makeList(s : cons_index) return element_type is 65 | begin 66 | return (kind => V_LIST, l => s); 67 | end; 68 | -- 69 | -- This checks to see if the element represents a function call. The element 70 | -- is a symbol of type either BUILTIN or LAMBDA. 71 | -- 72 | function isFunction(e : element_type) return Boolean is 73 | temp : element_type; 74 | list : cons_index; 75 | val : element_type; 76 | begin 77 | list := getList(e); 78 | if list > NIL_CONS then 79 | temp := BBS.lisp.conses.get_car(list); 80 | else 81 | temp := e; 82 | end if; 83 | if temp.kind = V_SYMBOL then 84 | return BBS.lisp.symbols.isFunction(temp.sym); 85 | elsif temp.kind = V_LAMBDA then 86 | return True; 87 | elsif temp.kind = V_STACK then 88 | val := BBS.lisp.global.stack.search_frames(temp.st_offset, temp.st_name); 89 | if val.kind = V_LAMBDA then 90 | return True; 91 | end if; 92 | if val.kind = V_SYMBOL then 93 | return BBS.lisp.symbols.isFunction(val.sym); 94 | end if; 95 | end if; 96 | return False; 97 | end; 98 | -- 99 | -- Evaluate a list of statements. 100 | -- 101 | function execute_block(s : cons_index) return element_type is 102 | statement : cons_index := s; 103 | ret_val : element_type; 104 | begin 105 | -- 106 | -- Evaluate the function 107 | -- 108 | ret_val := NIL_ELEM; 109 | while statement > NIL_CONS loop 110 | BBS.lisp.memory.deref(ret_val); 111 | if isList(BBS.lisp.conses.get_car(statement)) then 112 | ret_val := eval_dispatch(getList(BBS.lisp.conses.get_car(statement))); 113 | else 114 | ret_val := indirect_elem(BBS.lisp.conses.get_car(statement)); 115 | end if; 116 | if ret_val.kind = V_ERROR then 117 | error("block execution", "Operation returned an error"); 118 | exit; 119 | end if; 120 | if exit_block > 0 then 121 | exit; 122 | end if; 123 | statement := getList(BBS.lisp.conses.get_cdr(statement)); 124 | end loop; 125 | return ret_val; 126 | end; 127 | -- 128 | -- Set the exit_loop flag 129 | -- 130 | procedure set_exit_block(n : Natural) is 131 | begin 132 | exit_block := n; 133 | end; 134 | -- 135 | -- Decrement the exit_block flag 136 | -- 137 | procedure decrement_exit_block is 138 | begin 139 | if exit_block > 0 then 140 | exit_block := exit_block - 1; 141 | end if; 142 | end; 143 | -- 144 | -- Returns the exit_block flag 145 | -- 146 | function get_exit_block return Natural is 147 | begin 148 | return exit_block; 149 | end; 150 | -- 151 | -- The following function examines an atom. If the atom is some sort of 152 | -- variable, it returns the atom that the variable points to. If not, it 153 | -- just returns the atom. If the variable points to a list, then the 154 | -- original atom is returned. 155 | -- 156 | function indirect_elem(e : element_type) return element_type is 157 | sym : symbol_ptr; 158 | val : element_type; 159 | begin 160 | if e.kind = V_SYMBOL then 161 | sym := e.sym; 162 | if BBS.lisp.symbols.get_type(sym) = SY_VARIABLE then 163 | return BBS.lisp.symbols.get_value(sym); 164 | end if; 165 | end if; 166 | if e.kind = V_STACK then 167 | val := BBS.lisp.global.stack.search_frames(e.st_offset, e.st_name); 168 | return val; 169 | end if; 170 | return e; 171 | end; 172 | -- 173 | -- This procedure extracts the first value from an element. This value may 174 | -- be a value, a variable, or a list. If the list starts with an expression, 175 | -- it is passed to the evaluator and the results returned. The rest of the 176 | -- expression is also returned 177 | -- 178 | function first_value(s : in out cons_index) return element_type is 179 | first : element_type; 180 | begin 181 | if s = NIL_CONS then 182 | return NIL_ELEM; 183 | else 184 | first := BBS.lisp.conses.get_car(s); 185 | s := getList(BBS.lisp.conses.get_cdr(s)); 186 | if first = NIL_ELEM then 187 | null; 188 | elsif isList(first) then 189 | if isFunction(first) then 190 | first := eval_dispatch(getList(first)); 191 | else 192 | BBS.lisp.memory.ref(first); 193 | end if; 194 | else 195 | first := indirect_elem(first); 196 | BBS.lisp.memory.ref(first); 197 | end if; 198 | end if; 199 | return first; 200 | end; 201 | end; 202 | -------------------------------------------------------------------------------- /src/bbs-lisp-evaluate.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Author: Brent Seidel 3 | -- Date: 31-Jul-2024 4 | -- 5 | -- This file is part of Tiny-Lisp. 6 | -- Tiny-Lisp is free software: you can redistribute it and/or modify it 7 | -- under the terms of the GNU General Public License as published by the 8 | -- Free Software Foundation, either version 3 of the License, or (at your 9 | -- option) any later version. 10 | -- 11 | -- Tiny-Lisp is distributed in the hope that it will be useful, but 12 | -- WITHOUT ANY WARRANTY; without even the implied warranty of 13 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General 14 | -- Public License for more details. 15 | -- 16 | -- You should have received a copy of the GNU General Public License along 17 | -- with Tiny-Lisp. If not, see .-- 18 | -- 19 | -- This package contains helper functions for evaluating the various Lisp 20 | -- operatations. The actual operations are in subpackages of this one. 21 | -- 22 | package BBS.lisp.evaluate 23 | with Abstract_State => pvt_exit_block is 24 | -- 25 | -- Various utility functions 26 | -- 27 | function isTrue(e : element_type) return Boolean; 28 | function isList(e : element_type) return Boolean 29 | with Global => Null; 30 | function isFunction(e : element_type) return Boolean; 31 | function getList(e : element_type) return cons_index 32 | with post => (if not isList(e) then getList'Result = NIL_CONS else 33 | getList'Result'Valid), 34 | global => Null; 35 | function makeList(s : cons_index) return element_type 36 | with Global => Null; 37 | -- 38 | -- Execute the statements in a block and return the value of the last 39 | -- statement executed. 40 | -- 41 | function execute_block(s : cons_index) return element_type 42 | with Global => (input => (pvt_exit_flag, pvt_break_flag, pvt_msg_flag, 43 | pvt_exit_block, pvt_first_char_flag)); 44 | -- should be (In_Out => (pvt_exit_flag, pvt_break_flag, pvt_msg_flag, 45 | -- pvt_exit_loop, pvt_first_char_flag) 46 | -- 47 | -- The following function examines an atom. If the atom is some sort of 48 | -- variable, an element type pointing to the value. If not, the element 49 | -- points to the original atom. 50 | -- 51 | function indirect_elem(e : element_type) return element_type; 52 | -- 53 | -- This procedure extracts the first value from an element. This value may 54 | -- be a value, a variable, or a list. If the list starts with an expression, 55 | -- it is passed to the evaluator and the results returned. The rest of the 56 | -- expression is also returned 57 | -- 58 | function first_value(s : in out cons_index) return element_type; 59 | -- 60 | -- Set the exit_loop flag 61 | -- 62 | procedure set_exit_block(n : Natural) 63 | with Global => (Output => pvt_exit_block), 64 | Inline; 65 | -- 66 | -- Decrement the exit_block flag 67 | -- 68 | procedure decrement_exit_block 69 | with Global => (Output => pvt_exit_block); 70 | -- 71 | -- Returns the exit_block flag 72 | -- 73 | function get_exit_block return Natural 74 | with Global => (Input => pvt_exit_block), 75 | Inline; 76 | -- 77 | private 78 | -- 79 | -- Set to non-zero to break out of that many nested loops 80 | -- 81 | exit_block : Natural := 0 82 | with Part_Of => pvt_exit_block; 83 | 84 | end; 85 | -------------------------------------------------------------------------------- /src/bbs-lisp-global.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Author: Brent Seidel 3 | -- Date: 31-Jul-2024 4 | -- 5 | -- This file is part of Tiny-Lisp. 6 | -- Tiny-Lisp is free software: you can redistribute it and/or modify it 7 | -- under the terms of the GNU General Public License as published by the 8 | -- Free Software Foundation, either version 3 of the License, or (at your 9 | -- option) any later version. 10 | -- 11 | -- Tiny-Lisp is distributed in the hope that it will be useful, but 12 | -- WITHOUT ANY WARRANTY; without even the implied warranty of 13 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General 14 | -- Public License for more details. 15 | -- 16 | -- You should have received a copy of the GNU General Public License along 17 | -- with Tiny-Lisp. If not, see .-- 18 | -- 19 | -- This package contains all the global data structures for the Lisp interpreter. 20 | -- 21 | with BBS.lisp.stack; 22 | package BBS.lisp.global is 23 | stack : BBS.lisp.stack.lisp_stack(max_stack); 24 | end; 25 | -------------------------------------------------------------------------------- /src/bbs-lisp-info.ads: -------------------------------------------------------------------------------- 1 | package BBS.lisp.info is 2 | -- 3 | -- This file is auto generated by the pre-commit hook as well as 4 | -- the test coverage script. It should not be edited by hand. 5 | -- 6 | name : constant String := "Tiny Lisp"; 7 | timestamp : constant String := "Thu Feb 13 11:01:26 MST 2025"; 8 | build_date : constant String := "2025-Feb-13 (master)"; 9 | version_string : constant String := "Alire 00.02.00+"; 10 | version_date : constant Integer := 20250213; -- yyyymmdd 11 | version_number : constant Integer := 3; 12 | end; 13 | -------------------------------------------------------------------------------- /src/bbs-lisp-memory.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Author: Brent Seidel 3 | -- Date: 31-Jul-2024 4 | -- 5 | -- This file is part of Tiny-Lisp. 6 | -- Tiny-Lisp is free software: you can redistribute it and/or modify it 7 | -- under the terms of the GNU General Public License as published by the 8 | -- Free Software Foundation, either version 3 of the License, or (at your 9 | -- option) any later version. 10 | -- 11 | -- Tiny-Lisp is distributed in the hope that it will be useful, but 12 | -- WITHOUT ANY WARRANTY; without even the implied warranty of 13 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General 14 | -- Public License for more details. 15 | -- 16 | -- You should have received a copy of the GNU General Public License along 17 | -- with Tiny-Lisp. If not, see .-- 18 | -- 19 | with BBS.lisp.conses; 20 | with BBS.lisp.strings; 21 | with BBS.lisp.symbols; 22 | package body BBS.lisp.memory is 23 | -- 24 | -- 25 | -- Reset the tables 26 | -- 27 | procedure reset_tables is 28 | begin 29 | BBS.lisp.conses.reset_cons_table; 30 | BBS.lisp.symbols.reset_symbol_table; 31 | BBS.lisp.strings.reset_string_table; 32 | end; 33 | -- 34 | -- Increments the reference count of the item pointed to by an element pointer. 35 | -- 36 | procedure ref(e : element_type) is 37 | begin 38 | if e.kind = V_STRING then 39 | BBS.lisp.strings.ref(e.s); 40 | elsif e.kind = V_LIST then 41 | BBS.lisp.conses.ref(e.l); 42 | elsif e.kind = V_LAMBDA then 43 | BBS.lisp.conses.ref(e.lam); 44 | end if; 45 | end; 46 | -- 47 | -- Decrements the reference count of the item pointed to by an element pointer. 48 | -- 49 | procedure deref(e : element_type) is 50 | begin 51 | if e.kind = V_STRING then 52 | BBS.lisp.strings.deref(e.s); 53 | elsif e.kind = V_LIST then 54 | BBS.lisp.conses.deref(e.l); 55 | elsif e.kind = V_LAMBDA then 56 | BBS.lisp.conses.deref(e.lam); 57 | elsif e.kind = V_STACK then 58 | BBS.lisp.strings.deref(e.st_name); 59 | end if; 60 | end; 61 | -- 62 | end; 63 | -------------------------------------------------------------------------------- /src/bbs-lisp-memory.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Author: Brent Seidel 3 | -- Date: 31-Jul-2024 4 | -- 5 | -- This file is part of Tiny-Lisp. 6 | -- Tiny-Lisp is free software: you can redistribute it and/or modify it 7 | -- under the terms of the GNU General Public License as published by the 8 | -- Free Software Foundation, either version 3 of the License, or (at your 9 | -- option) any later version. 10 | -- 11 | -- Tiny-Lisp is distributed in the hope that it will be useful, but 12 | -- WITHOUT ANY WARRANTY; without even the implied warranty of 13 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General 14 | -- Public License for more details. 15 | -- 16 | -- You should have received a copy of the GNU General Public License along 17 | -- with Tiny-Lisp. If not, see .-- 18 | -- 19 | -- This package manages allocations in the cons and string arrays. These can 20 | -- be dynamically allocated and deallocated. Reference counting is used to 21 | -- determine if a particular entry is free or not. 22 | -- 23 | package BBS.lisp.memory is 24 | -- 25 | -- Utility functions for allocating and freeing items. Memory management 26 | -- uses a reference counting system. When references are added, the count 27 | -- should be incremented. When references are deleted or go out of scope, 28 | -- the count should be decremented. 29 | -- 30 | -- Since the tables have been moved into separate packages, this package is 31 | -- more of a dispatcher for elements. 32 | -- 33 | -- Reset some of the memory tables back to their starting state. 34 | -- 35 | procedure reset_tables; 36 | -- 37 | -- Increment the reference count of various items. This is typically done 38 | -- when an additional index to the item is created. 39 | -- 40 | procedure ref(e : element_type); 41 | -- 42 | -- Decrement the reference count for various items. This is done when the 43 | -- reference is no longer needed. If the reference count reaches 0, the 44 | -- item is considered to be deallocated. In this case, if the item points 45 | -- to other items, they will be recursively dereffed. 46 | -- 47 | procedure deref(e : element_type); 48 | -- 49 | end; 50 | -------------------------------------------------------------------------------- /src/bbs-lisp-parser-file.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Author: Brent Seidel 3 | -- Date: 31-Jul-2024 4 | -- 5 | -- This file is part of Tiny-Lisp. 6 | -- Tiny-Lisp is free software: you can redistribute it and/or modify it 7 | -- under the terms of the GNU General Public License as published by the 8 | -- Free Software Foundation, either version 3 of the License, or (at your 9 | -- option) any later version. 10 | -- 11 | -- Tiny-Lisp is distributed in the hope that it will be useful, but 12 | -- WITHOUT ANY WARRANTY; without even the implied warranty of 13 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General 14 | -- Public License for more details. 15 | -- 16 | -- You should have received a copy of the GNU General Public License along 17 | -- with Tiny-Lisp. If not, see . 18 | -- 19 | with Ada.Exceptions; 20 | with Ada.IO_Exceptions; 21 | with Ada.Strings.Unbounded.Text_IO; 22 | package body bbs.lisp.parser.file is 23 | -- 24 | -- Initializes to an input file 25 | -- 26 | procedure init(self : in out parser_file; name : String) is 27 | begin 28 | if self.valid then 29 | Ada.Text_IO.Close(self.file); 30 | end if; 31 | Ada.Text_IO.Open(self.file, Ada.Text_IO.In_File, name); 32 | self.valid := True; 33 | self.ptr := 1; 34 | exception 35 | when ADA.IO_EXCEPTIONS.NAME_ERROR => 36 | Ada.Text_IO.Put_Line("Unable to open file: " & name); 37 | self.valid := False; 38 | when e : others => 39 | Ada.Text_IO.Put_Line("Error opening file: " & name); 40 | Ada.Text_IO.Put_Line("Exception: " & Ada.Exceptions.Exception_Message(e)); 41 | self.valid := False; 42 | raise; 43 | end; 44 | -- 45 | -- Move pointer to point to the next character in the buffer 46 | -- 47 | procedure next_char(self : in out parser_file) is 48 | begin 49 | self.ptr := self.ptr + 1; 50 | end; 51 | -- 52 | -- Sets pointer to the end of the buffer 53 | -- 54 | procedure next_line(self : in out parser_file) is 55 | begin 56 | self.ptr := Ada.Strings.Unbounded.Length(self.buff) + 1; 57 | end; 58 | -- 59 | -- Read a line into the buffer 60 | -- 61 | procedure get_line(self : in out parser_file) is 62 | begin 63 | self.buff := Ada.Strings.Unbounded.Text_IO.Get_Line(self.file); 64 | self.ptr := 1; 65 | end; 66 | -- 67 | -- Request more data. This will always return True since more input 68 | -- can be read from stdio. Yes, there are exceptions, but these are on 69 | -- platforms that can throw exceptions. 70 | -- 71 | function request_more(self : in out parser_file) return Boolean is 72 | begin 73 | self.buff := Ada.Strings.Unbounded.Text_IO.Get_Line(self.file); 74 | self.ptr := 1; 75 | return True; 76 | end; 77 | -- 78 | -- Check for input end of file 79 | -- 80 | overriding 81 | function is_eof(self : in out parser_file) return Boolean is 82 | begin 83 | return Ada.Text_IO.End_Of_File(self.file); 84 | end; 85 | end; 86 | -------------------------------------------------------------------------------- /src/bbs-lisp-parser-file.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Author: Brent Seidel 3 | -- Date: 31-Jul-2024 4 | -- 5 | -- This file is part of Tiny-Lisp. 6 | -- Tiny-Lisp is free software: you can redistribute it and/or modify it 7 | -- under the terms of the GNU General Public License as published by the 8 | -- Free Software Foundation, either version 3 of the License, or (at your 9 | -- option) any later version. 10 | -- 11 | -- Tiny-Lisp is distributed in the hope that it will be useful, but 12 | -- WITHOUT ANY WARRANTY; without even the implied warranty of 13 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General 14 | -- Public License for more details. 15 | -- 16 | -- You should have received a copy of the GNU General Public License along 17 | -- with Tiny-Lisp. If not, see .-- 18 | -- 19 | -- This package contains data and routines for providing data to the parser 20 | -- routines. This is done to allow the parser to be decoupled from I/O. 21 | -- 22 | with Ada.Text_IO; 23 | with Ada.Strings.Unbounded; 24 | package bbs.lisp.parser.file is 25 | pragma Elaborate_Body; 26 | -- 27 | -- This object contains the following data: 28 | -- buff - The buffer containing the characters 29 | -- ptr - Pointer to the current character in the buffer 30 | -- last - Pointer to the last valid character in the buffer 31 | -- 32 | type parser_file is new parser_buffer with 33 | record 34 | file : Ada.Text_IO.File_Type; 35 | valid : Boolean := False; 36 | buff : Ada.Strings.Unbounded.Unbounded_String; 37 | ptr : Positive; 38 | end record; 39 | type parser_file_ptr is access all parser_file'Class; 40 | -- 41 | -- Initializes to an input file 42 | -- 43 | procedure init(self : in out parser_file; name : String); 44 | -- 45 | -- Gets the character selected by ptr. 46 | -- 47 | overriding 48 | function get_char(self : parser_file) return Character is (Ada.Strings.Unbounded.Element(self.buff, self.ptr)); 49 | -- 50 | -- Checks if the character after ptr is a digit. 51 | -- 52 | overriding 53 | function is_next_digit(self : parser_file) return Boolean is ((self.ptr <= Ada.Strings.Unbounded.Length(self.buff)) 54 | and then (isDigit(Ada.Strings.Unbounded.Element(self.buff, self.ptr + 1)))); 55 | -- 56 | -- Increment ptr to point to the next character 57 | -- 58 | overriding 59 | procedure next_char(self : in out parser_file); 60 | -- 61 | -- Tests if ptr is less than or equal to last. 62 | -- 63 | overriding 64 | function not_end(self : parser_file) return Boolean is (self.ptr <= Ada.Strings.Unbounded.Length(self.buff)); 65 | -- 66 | -- Tests if ptr is greater than last (the opposite of not_end) 67 | -- 68 | overriding 69 | function is_end(self : parser_file) return Boolean is (self.ptr > Ada.Strings.Unbounded.Length(self.buff)); 70 | -- 71 | -- Since each object only contains a single line, this sets the pointer to 72 | -- the end of the string so that is_end will return True. 73 | -- 74 | overriding 75 | procedure next_line(self : in out parser_file); 76 | -- 77 | -- Reads a line without providing a prompt. All values in the object are set. 78 | -- 79 | overriding 80 | procedure get_line(self : in out parser_file); 81 | -- 82 | -- Prints a prompt and reads a line. All values in object are set. 83 | -- 84 | overriding 85 | function request_more(self : in out parser_file) return Boolean; 86 | -- 87 | -- Check for input end of file 88 | -- 89 | overriding 90 | function is_eof(self : in out parser_file) return Boolean; 91 | private 92 | eof_char : constant Character := Character'Val(26); -- Control-Z 93 | end; 94 | -------------------------------------------------------------------------------- /src/bbs-lisp-parser-stdio.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Author: Brent Seidel 3 | -- Date: 31-Jul-2024 4 | -- 5 | -- This file is part of Tiny-Lisp. 6 | -- Tiny-Lisp is free software: you can redistribute it and/or modify it 7 | -- under the terms of the GNU General Public License as published by the 8 | -- Free Software Foundation, either version 3 of the License, or (at your 9 | -- option) any later version. 10 | -- 11 | -- Tiny-Lisp is distributed in the hope that it will be useful, but 12 | -- WITHOUT ANY WARRANTY; without even the implied warranty of 13 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General 14 | -- Public License for more details. 15 | -- 16 | -- You should have received a copy of the GNU General Public License along 17 | -- with Tiny-Lisp. If not, see . 18 | -- 19 | package body bbs.lisp.parser.stdio is 20 | -- 21 | -- Initialize the buffer object 22 | -- 23 | procedure init(self : in out parser_stdio) is 24 | begin 25 | self.ptr := self.buff'First; 26 | self.last := self.buff'First; 27 | end; 28 | -- 29 | -- Move pointer to point to the next character in the buffer 30 | -- 31 | procedure next_char(self : in out parser_stdio) is 32 | begin 33 | self.ptr := self.ptr + 1; 34 | end; 35 | -- 36 | -- Sets pointer to the end of the buffer 37 | -- 38 | procedure next_line(self : in out parser_stdio) is 39 | begin 40 | self.ptr := self.last + 1; 41 | end; 42 | -- 43 | -- Read a line into the buffer 44 | -- 45 | procedure get_line(self : in out parser_stdio) is 46 | begin 47 | Get_Line(self.buff, self.last); 48 | self.ptr := self.buff'First; 49 | end; 50 | -- 51 | -- Request more data. This will always return True since more input 52 | -- can be read from stdio. Yes, there are exceptions, but these are on 53 | -- platforms that can throw exceptions. 54 | -- 55 | function request_more(self : in out parser_stdio) return Boolean is 56 | begin 57 | Put(prompt2); 58 | Get_Line(self.buff, self.last); 59 | self.ptr := self.buff'First; 60 | return True; 61 | end; 62 | -- 63 | -- Check for input end of file 64 | -- 65 | overriding 66 | function is_eof(self : in out parser_stdio) return Boolean is 67 | begin 68 | return (self.ptr <= self.last) and then (self.buff(self.ptr + 1) = eof_char); 69 | end; 70 | end; 71 | -------------------------------------------------------------------------------- /src/bbs-lisp-parser-stdio.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Author: Brent Seidel 3 | -- Date: 31-Jul-2024 4 | -- 5 | -- This file is part of Tiny-Lisp. 6 | -- Tiny-Lisp is free software: you can redistribute it and/or modify it 7 | -- under the terms of the GNU General Public License as published by the 8 | -- Free Software Foundation, either version 3 of the License, or (at your 9 | -- option) any later version. 10 | -- 11 | -- Tiny-Lisp is distributed in the hope that it will be useful, but 12 | -- WITHOUT ANY WARRANTY; without even the implied warranty of 13 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General 14 | -- Public License for more details. 15 | -- 16 | -- You should have received a copy of the GNU General Public License along 17 | -- with Tiny-Lisp. If not, see .-- 18 | -- 19 | -- This package contains data and routines for providing data to the parser 20 | -- routines. This is done to allow the parser to be decoupled from I/O. 21 | -- 22 | package bbs.lisp.parser.stdio is 23 | pragma Elaborate_Body; 24 | -- 25 | -- This object contains the following data: 26 | -- buff - The buffer containing the characters 27 | -- ptr - Pointer to the current character in the buffer 28 | -- last - Pointer to the last valid character in the buffer 29 | -- 30 | type parser_stdio is new parser_buffer with 31 | record 32 | buff : String(1 .. 256); 33 | ptr : Natural; 34 | last : Natural; 35 | end record; 36 | type parser_stdio_ptr is access all parser_stdio'Class; 37 | -- 38 | -- Gets the character selected by ptr. 39 | -- 40 | overriding 41 | function get_char(self : parser_stdio) return Character is (self.buff(self.ptr)); 42 | -- 43 | -- Checks if the character after ptr is a digit. 44 | -- 45 | overriding 46 | function is_next_digit(self : parser_stdio) return Boolean is ((self.ptr <= self.last) 47 | and then (isDigit(self.buff(self.ptr + 1)))); 48 | -- 49 | -- Increment ptr to point to the next character 50 | -- 51 | overriding 52 | procedure next_char(self : in out parser_stdio); 53 | -- 54 | -- Tests if ptr is less than or equal to last. 55 | -- 56 | overriding 57 | function not_end(self : parser_stdio) return Boolean is (self.ptr <= self.last); 58 | -- 59 | -- Tests if ptr is greater than last (the opposite of not_end) 60 | -- 61 | overriding 62 | function is_end(self : parser_stdio) return Boolean is (self.ptr > self.last); 63 | -- 64 | -- Since each object only contains a single line, this sets the pointer to 65 | -- the end of the string so that is_end will return True. 66 | -- 67 | overriding 68 | procedure next_line(self : in out parser_stdio); 69 | -- 70 | -- Reads a line without providing a prompt. All values in the object are set. 71 | -- 72 | procedure get_line(self : in out parser_stdio); 73 | -- 74 | -- Prints a prompt and reads a line. All values in object are set. 75 | -- 76 | overriding 77 | function request_more(self : in out parser_stdio) return Boolean; 78 | -- 79 | -- Check for input end of file 80 | -- 81 | overriding 82 | function is_eof(self : in out parser_stdio) return Boolean; 83 | -- 84 | -- Initializes the object to contain valid values 85 | -- 86 | procedure init(self : in out parser_stdio); 87 | private 88 | eof_char : constant Character := Character'Val(26); -- Control-Z 89 | end; 90 | -------------------------------------------------------------------------------- /src/bbs-lisp-parser-string.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Author: Brent Seidel 3 | -- Date: 31-Jul-2024 4 | -- 5 | -- This file is part of Tiny-Lisp. 6 | -- Tiny-Lisp is free software: you can redistribute it and/or modify it 7 | -- under the terms of the GNU General Public License as published by the 8 | -- Free Software Foundation, either version 3 of the License, or (at your 9 | -- option) any later version. 10 | -- 11 | -- Tiny-Lisp is distributed in the hope that it will be useful, but 12 | -- WITHOUT ANY WARRANTY; without even the implied warranty of 13 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General 14 | -- Public License for more details. 15 | -- 16 | -- You should have received a copy of the GNU General Public License along 17 | -- with Tiny-Lisp. If not, see .-- 18 | -- 19 | package body BBS.lisp.parser.string is 20 | -- 21 | -- Initialize the buffer object 22 | -- 23 | procedure init(self : in out parser_string; s : string_index) is 24 | begin 25 | BBS.lisp.strings.init(self.s, s); 26 | end; 27 | -- 28 | -- Move pointer to point to the next character in the string 29 | -- 30 | procedure next_char(self : in out parser_string) is 31 | begin 32 | BBS.lisp.strings.next_char(self.s); 33 | end; 34 | -- 35 | -- This should advance the pointer until either an end of line character 36 | -- (ASCII 10 or 13) is reached or the end of the Lisp string is reached. 37 | -- 38 | procedure next_line(self : in out parser_string) is 39 | c : Character; 40 | begin 41 | c := BBS.lisp.strings.get_char(self.s); 42 | while self.not_end and (c /= Character'Val(10)) and (c /= Character'Val(13)) loop 43 | BBS.lisp.strings.next_char(self.s); 44 | c := BBS.lisp.strings.get_char(self.s); 45 | end loop; 46 | end; 47 | -- 48 | -- Checks if the character after ptr is a digit. 49 | -- 50 | function is_next_digit(self : parser_string) return Boolean is 51 | begin 52 | return isDigit(BBS.lisp.strings.get_next_char(self.s)); 53 | end; 54 | -- 55 | -- Gets the character selected by ptr. 56 | -- 57 | function get_char(self : parser_string) return Character is 58 | begin 59 | return BBS.lisp.strings.get_char(self.s); 60 | end; 61 | end; 62 | -------------------------------------------------------------------------------- /src/bbs-lisp-parser-string.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Author: Brent Seidel 3 | -- Date: 31-Jul-2024 4 | -- 5 | -- This file is part of Tiny-Lisp. 6 | -- Tiny-Lisp is free software: you can redistribute it and/or modify it 7 | -- under the terms of the GNU General Public License as published by the 8 | -- Free Software Foundation, either version 3 of the License, or (at your 9 | -- option) any later version. 10 | -- 11 | -- Tiny-Lisp is distributed in the hope that it will be useful, but 12 | -- WITHOUT ANY WARRANTY; without even the implied warranty of 13 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General 14 | -- Public License for more details. 15 | -- 16 | -- You should have received a copy of the GNU General Public License along 17 | -- with Tiny-Lisp. If not, see .-- 18 | -- 19 | -- This package contains data and routines for providing data to the parser 20 | -- routines. This is done to allow the parser to be decoupled from I/O. 21 | -- 22 | with BBS.lisp.strings; 23 | package BBS.lisp.parser.string is 24 | pragma Elaborate_Body; 25 | -- 26 | -- This object contains the following data: 27 | -- base - Pointer to the first fragment of the string (may not be needed) 28 | -- current - Poiner to the current string fragment 29 | -- ptr - Pointer to the current character in the string fragment. 30 | -- 31 | type parser_string is new parser_buffer with 32 | record 33 | s : BBS.lisp.strings.str_iterator; 34 | end record; 35 | type parser_string_ptr is access all parser_string'Class; 36 | -- 37 | -- Gets the character selected by ptr. 38 | -- 39 | overriding 40 | function get_char(self : parser_string) return Character; 41 | -- 42 | -- Checks if the character after ptr is a digit. 43 | -- 44 | overriding 45 | function is_next_digit(self : parser_string) return Boolean; 46 | -- 47 | -- Increment ptr to point to the next character 48 | -- 49 | overriding 50 | procedure next_char(self : in out parser_string); 51 | -- 52 | -- Tests if ptr is less than or equal to last. 53 | -- 54 | overriding 55 | function not_end(self : parser_string) return Boolean is (not BBS.lisp.strings.is_end(self.s)); 56 | -- 57 | -- Tests if ptr is greater than last (the opposite of not_end) 58 | -- 59 | overriding 60 | function is_end(self : parser_string) return Boolean is (BBS.lisp.strings.is_end(self.s)); 61 | -- 62 | -- This should advance the pointer until either an end of line character 63 | -- (ASCII 10 or 13) is reached or the end of the Lisp string is reached. 64 | -- 65 | overriding 66 | procedure next_line(self : in out parser_string); 67 | -- 68 | -- Used to request more data. This will fail when reading a Lisp string. 69 | -- 70 | overriding 71 | function request_more(self : in out parser_string) return Boolean is (False); 72 | -- 73 | -- Check for input end of file. This is the same as an end of string. 74 | -- 75 | overriding 76 | function is_eof(self : in out parser_string) return Boolean is (BBS.lisp.strings.is_end(self.s)); 77 | -- 78 | -- Nothing to do for a string 79 | -- 80 | overriding 81 | procedure get_line(self : in out parser_string) is null; 82 | -- 83 | -- Initializes the object to contain valid values 84 | -- 85 | procedure init(self : in out parser_string; s : string_index); 86 | 87 | end; 88 | -------------------------------------------------------------------------------- /src/bbs-lisp-parser.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Author: Brent Seidel 3 | -- Date: 31-Jul-2024 4 | -- 5 | -- This file is part of Tiny-Lisp. 6 | -- Tiny-Lisp is free software: you can redistribute it and/or modify it 7 | -- under the terms of the GNU General Public License as published by the 8 | -- Free Software Foundation, either version 3 of the License, or (at your 9 | -- option) any later version. 10 | -- 11 | -- Tiny-Lisp is distributed in the hope that it will be useful, but 12 | -- WITHOUT ANY WARRANTY; without even the implied warranty of 13 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General 14 | -- Public License for more details. 15 | -- 16 | -- You should have received a copy of the GNU General Public License along 17 | -- with Tiny-Lisp. If not, see . 18 | -- 19 | -- This package handles the parsing of input. Input can be a list, an atom 20 | -- of either a symbol or integer, or a comment. 21 | -- 22 | package BBS.lisp.parser is 23 | -- 24 | -- Define an abstract class for providing data to the parser 25 | -- 26 | -- type parser_buffer is abstract tagged limited null record; 27 | -- type parser_ptr is access all parser_buffer'Class; 28 | -- 29 | -- Methods that need to be provided by the parser_buffer. 30 | -- 31 | -- function get_char(self : parser_buffer) return Character is abstract; 32 | -- function is_next_digit(self : parser_buffer) return Boolean is abstract; 33 | -- procedure next_char(self : in out parser_buffer) is abstract; 34 | -- function not_end(self : parser_buffer) return Boolean is abstract; 35 | -- function is_end(self : parser_buffer) return Boolean is abstract; 36 | -- procedure next_line(self : in out parser_buffer) is abstract; 37 | -- function request_more(self : in out parser_buffer) return Boolean is abstract; 38 | -- function is_eof(self : in out parser_buffer) return Boolean is abstract; 39 | -- procedure get_line(self : in out parser_buffer) is abstract; 40 | -- 41 | -- The main parser function. Returns True if parsing is successful. 42 | -- 43 | function parse(buff : parser_ptr; e : out element_type) return Boolean; 44 | -- 45 | -- Parser utility functions 46 | -- 47 | -- Is character white space (spaces, tabs, carriage return, or line feed). 48 | -- 49 | function isWhitespace(c : Character) return Boolean is 50 | ((c = ' ') or (c = Character'Val(10)) or (c = Character'Val(13)) or 51 | c = Character'Val(9)) 52 | with Global => Null; 53 | pragma Pure_Function(isWhitespace); 54 | -- 55 | -- Is character a decimal digit? 56 | -- 57 | function isDigit(c : Character) return Boolean is (c >= '0' and c <= '9') 58 | with Global => Null; 59 | pragma Pure_Function(isDigit); 60 | -- 61 | -- Is character an alphabetic character 62 | -- 63 | function isAlpha(c : Character) return Boolean is 64 | ((c >= 'A' and c <= 'Z') or (c >= 'a' and c <= 'z')) 65 | with Global => Null; 66 | pragma Pure_Function(isAlpha); 67 | -- 68 | -- Is character a hexidecimal digit? 69 | -- 70 | function isHex(c : Character) return Boolean is 71 | ((c >= '0' and c <= '9') or (c >= 'A' and c <= 'F') or (c >= 'a' and c <= 'f')) 72 | with Global => Null; 73 | pragma Pure_Function(isHex); 74 | -- 75 | -- Return the hexidecimal digit 76 | -- 77 | function hexDigit(c : Character) return uint32 78 | with Global => Null; 79 | pragma Pure_Function(hexDigit); 80 | private 81 | -- 82 | -- Utilities to assist in parsing 83 | -- 84 | function append_to_list(head : cons_index; e : element_type) return Boolean; 85 | -- 86 | -- Subfunction for parsing lists. If the buffer ends before the end of the 87 | -- list is reached, more input is read and the parsing continues. 88 | -- buff - Buffer object to parse 89 | -- s_expr - Parsed s expression 90 | -- qfixed - The list is quoted 91 | -- 92 | function list(buff : parser_ptr; s_expr : out cons_index; 93 | qfixed : Boolean; base : Boolean) 94 | return Boolean; 95 | -- 96 | -- Subfunction for parsing symbols or temp symbols. A is an atom that points 97 | -- to either the symbol or temp symbol. Returns false if the symbol or temp 98 | -- symbol can't be found or created or if the atom can't be created. 99 | -- 100 | function symb(buff : parser_ptr; quoted : Boolean) 101 | return element_type; 102 | -- 103 | -- Subfunction for parsing integers 104 | -- 105 | procedure int(buff : parser_ptr; value : out int32) 106 | with Global => Null; 107 | -- 108 | -- Hexidecimal numbers are read in as 32 bit unsigned integers and conerted 109 | -- to signed 32 bit integers using an unchecked conversion. 110 | -- 111 | procedure hex(buff : parser_ptr; value : out int32) 112 | with Global => Null; 113 | -- 114 | -- Parse strings 115 | -- 116 | function parse_str(buff : parser_ptr; s : out string_index) return Boolean; 117 | -- 118 | -- Parse characters 119 | -- 120 | function parse_char(buff : parser_ptr; c : out Character) return Boolean 121 | with Global => Null; 122 | end; 123 | 124 | -------------------------------------------------------------------------------- /src/bbs-lisp-stack.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Author: Brent Seidel 3 | -- Date: 31-Jul-2024 4 | -- 5 | -- This file is part of Tiny-Lisp. 6 | -- Tiny-Lisp is free software: you can redistribute it and/or modify it 7 | -- under the terms of the GNU General Public License as published by the 8 | -- Free Software Foundation, either version 3 of the License, or (at your 9 | -- option) any later version. 10 | -- 11 | -- Tiny-Lisp is distributed in the hope that it will be useful, but 12 | -- WITHOUT ANY WARRANTY; without even the implied warranty of 13 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General 14 | -- Public License for more details. 15 | -- 16 | -- You should have received a copy of the GNU General Public License along 17 | -- with Tiny-Lisp. If not, see .-- 18 | -- 19 | -- This package contains functions and procedures for managing the stack for 20 | -- the Lisp interpreter. 21 | -- 22 | with BBS.lisp.strings; 23 | with BBS.lisp.memory; 24 | package body BBS.lisp.stack is 25 | -- 26 | function isFull(self : lisp_stack) return Boolean is 27 | begin 28 | return (self.sp = self.size); 29 | end; 30 | -- 31 | -- Adding items to the stack. Popping actually isn't done. Items are removed 32 | -- from the stack as part of the exit_frame. 33 | -- 34 | -- 35 | procedure push(self : in out lisp_stack; name : string_index; val : element_type; err : out Boolean) is 36 | begin 37 | if not self.isFull then 38 | BBS.lisp.strings.ref(name); 39 | BBS.lisp.memory.ref(val); 40 | self.sp := self.sp + 1; 41 | self.stack(self.sp) := (kind => ST_VALUE, st_name => name, st_value => val); 42 | err := False; 43 | else 44 | error("Push", "Stack overflow"); 45 | err := True; 46 | end if; 47 | end; 48 | -- 49 | -- Procedure for clearing stack. This is done at the command line level. 50 | -- There should be nothing on the stack at this point. Some error conditions 51 | -- may cause a return to the command line without clearing the stack. 52 | -- 53 | -- procedure reset is 54 | -- temp : stack_entry; 55 | -- begin 56 | -- while not isEmpty loop 57 | -- pop(temp); 58 | -- if temp.kind = ST_VALUE then 59 | -- BBS.lisp.memory.deref(temp.st_name); 60 | -- BBS.lisp.memory.deref(temp.st_value); 61 | -- end if; 62 | -- end loop; 63 | -- stack_pointer := EMPTY_STACK; 64 | -- frame_pointer := EMPTY_STACK; 65 | -- frame_count := 0; 66 | -- end; 67 | -- 68 | -- Operations for stack frames 69 | -- 70 | -- Start a stack frame 71 | -- 72 | procedure start_frame(self : in out lisp_stack; err : out Boolean) is 73 | begin 74 | if not self.isFull then 75 | self.fc := self.fc + 1; 76 | self.sp := self.sp + 1; 77 | self.stack(self.sp) := (kind => ST_FRAME, number => self.fc, next => self.fp); 78 | self.fp := self.sp; 79 | err := False; 80 | else 81 | error("Start_frame", "Stack overflow"); 82 | err := True; 83 | end if; 84 | end; 85 | -- 86 | -- Exit a stack frame 87 | -- 88 | procedure exit_frame(self : in out lisp_stack) is 89 | frame : constant stack_entry := self.stack(self.fp); 90 | begin 91 | if frame.kind /= ST_FRAME then 92 | error("exit_frame", "Not a stack frame."); 93 | put_line("exit_frame: Frame pointer is: " & Natural'Image(self.fp)); 94 | put_line("exit_frame: Stack entry type is: " & stack_entry_type'Image(frame.kind)); 95 | return; 96 | end if; 97 | for temp in self.fp .. self.sp loop 98 | if self.stack(temp).kind = ST_VALUE then 99 | BBS.lisp.strings.deref(self.stack(temp).st_name); 100 | BBS.lisp.memory.deref(self.stack(temp).st_value); 101 | end if; 102 | self.stack(temp) := (kind => ST_EMPTY); 103 | end loop; 104 | self.sp := self.fp - 1; 105 | self.fp := frame.next; 106 | self.fc := frame.number - 1; 107 | end; 108 | -- 109 | -- Returns the frame pointer 110 | -- 111 | function get_fp(self : lisp_stack) return Natural is 112 | begin 113 | return self.fp; 114 | end; 115 | -- 116 | -- Sets an entry on the stack 117 | -- 118 | procedure set_entry(self : in out lisp_stack; e : Natural; v : stack_entry; err : out Boolean) is 119 | begin 120 | if e <= self.sp then 121 | self.stack(e) := v; 122 | err := False; 123 | else 124 | error("set_entry", "Stack index out of range"); 125 | err := True; 126 | end if; 127 | end; 128 | -- 129 | -- Sets the value of an entry on the stack 130 | -- 131 | procedure set_value(self : in out lisp_stack; e : Natural; v : element_type; err : out Boolean) is 132 | begin 133 | if e <= self.sp then 134 | if self.stack(e).kind = ST_VALUE then 135 | self.stack(e).st_value := v; 136 | err := False; 137 | else 138 | error("set_value", "Entry is not a value type"); 139 | err := True; 140 | end if; 141 | else 142 | error("set_value", "Stack index out of range"); 143 | err := True; 144 | end if; 145 | end; 146 | -- 147 | -- Gets an entry from the stack 148 | -- 149 | function get_entry(self : in out lisp_stack; e : Natural; err : out Boolean) return stack_entry is 150 | begin 151 | if e <= self.sp then 152 | err := False; 153 | return self.stack(e); 154 | else 155 | err := True; 156 | error("get_entry", "Index out of range."); 157 | return (kind => ST_EMPTY); 158 | end if; 159 | end; 160 | -- 161 | -- procedure dump is 162 | -- e : stack_entry; 163 | -- begin 164 | -- put_line("Stack dump start"); 165 | -- Put_Line("SP: " & stack_index'Image(stack_pointer) & ", FP: " & 166 | -- stack_index'Image(frame_pointer)); 167 | -- for i in stack_index'First .. stack_index'Last loop 168 | -- e := stack(i); 169 | -- case e.kind is 170 | -- when ST_EMPTY => 171 | -- null; 172 | -- when ST_FRAME => 173 | -- put(stack_index'Image(i) & " " & stack_entry_type'Image(e.kind)); 174 | -- put(", Number => " & Natural'Image(e.number)); 175 | -- put_line(", Next => " & stack_index'Image(e.next)); 176 | -- when ST_VALUE => 177 | -- put(stack_index'Image(i) & " " & stack_entry_type'Image(e.kind)); 178 | -- put(", Name => "); 179 | -- print(e.st_name); 180 | -- put(", Value => "); 181 | -- print(e.st_value); 182 | -- new_line; 183 | ---- when others => -- Unused for now. May be used if other kinds are added. 184 | ---- put_line(stack_index'Image(i) & " Unknown stack entry kind."); 185 | -- end case; 186 | -- end loop; 187 | -- put_line("Stack dump end"); 188 | -- end; 189 | -- 190 | -- Search stack for the variable. The frame offset and name are used to 191 | -- look backwards through the stack frames for a match to the name. If 192 | -- found, the value is returned. If not found, a value of none is returned. 193 | -- 194 | -- 195 | function search_frames(self : lisp_stack; offset : Natural; name : string_index) return element_type is 196 | frame : Natural := self.fp; 197 | test : stack_entry; 198 | test_name : string_index; 199 | eq : comparison; 200 | begin 201 | while frame > Natural'First loop 202 | if frame + offset > self.size then 203 | error("search frames", "Stack pointer value out of range"); 204 | return (Kind => V_NONE); 205 | end if; 206 | test := self.stack(frame + offset); 207 | if test.kind = ST_VALUE then 208 | test_name := test.st_name; 209 | eq := BBS.lisp.strings.compare(name, test_name); 210 | if eq = CMP_EQ then 211 | return test.st_value; 212 | end if; 213 | end if; 214 | if self.stack(frame).kind = ST_FRAME then 215 | frame := self.stack(frame).next; 216 | else 217 | error("search_frames", "Did not find frame entry on stack"); 218 | put("Searching for variable <"); 219 | print(name); 220 | Put_Line(">"); 221 | frame := Natural'First; 222 | end if; 223 | end loop; 224 | return (kind => V_NONE); 225 | end; 226 | -- 227 | -- Search stack for the variable. The frame offset and name are used to 228 | -- look backwards through the stack frames for a match to the name. If 229 | -- found, the stack index of the variable is returned, if not 0 is returned. 230 | -- 231 | function search_frames(self : lisp_stack; offset : Natural; name : string_index) return Natural is 232 | frame : Natural := self.fp; 233 | test : stack_entry; 234 | test_name : string_index; 235 | eq : comparison; 236 | begin 237 | while frame > Natural'First loop 238 | if frame + offset > self.size then 239 | error("search frames", "Stack pointer value out of range"); 240 | return Natural'First; 241 | end if; 242 | test := self.stack(frame + offset); 243 | if test.kind = ST_VALUE then 244 | test_name := test.st_name; 245 | end if; 246 | if test.kind /= ST_EMPTY then 247 | eq := BBS.lisp.strings.compare(name, test_name); 248 | if eq = CMP_EQ then 249 | if test.kind = ST_VALUE then 250 | return frame + offset; 251 | else 252 | error("search_frames", "Found unexpected entry type " & stack_entry_type'Image(test.kind)); 253 | put("Searching for variable <"); 254 | print(name); 255 | Put_Line(">"); 256 | frame := Natural'First; 257 | end if; 258 | end if; 259 | end if; 260 | if self.stack(frame).kind = ST_FRAME then 261 | frame := self.stack(frame).next; 262 | else 263 | error("search_frames", "Did not find frame entry on stack"); 264 | frame := Natural'First; 265 | end if; 266 | end loop; 267 | return Natural'First; 268 | end; 269 | -- 270 | -- Searches the stack to find a variable and returns the stack index and offset 271 | -- 272 | function find_offset(self : lisp_stack; name : string_index; index : out Natural) return Natural is 273 | sp : Natural := self.sp; 274 | fp : Natural := self.fp; 275 | item : stack_entry; 276 | eq : comparison := CMP_NE; 277 | begin 278 | while sp > Natural'First loop 279 | item := self.stack(sp); 280 | case item.kind is 281 | when ST_FRAME => 282 | fp := item.next; 283 | when ST_VALUE => 284 | eq := BBS.lisp.strings.compare(name, item.st_name); 285 | when others => 286 | null; 287 | end case; 288 | exit when eq = CMP_EQ; 289 | sp := sp - 1; 290 | end loop; 291 | if eq = CMP_EQ then 292 | index := sp; 293 | return sp - fp; 294 | else 295 | index := Natural'First; 296 | return Natural'First; 297 | end if; 298 | end; 299 | -- 300 | end; 301 | -------------------------------------------------------------------------------- /src/bbs-lisp-stack.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Author: Brent Seidel 3 | -- Date: 31-Jul-2024 4 | -- 5 | -- This file is part of Tiny-Lisp. 6 | -- Tiny-Lisp is free software: you can redistribute it and/or modify it 7 | -- under the terms of the GNU General Public License as published by the 8 | -- Free Software Foundation, either version 3 of the License, or (at your 9 | -- option) any later version. 10 | -- 11 | -- Tiny-Lisp is distributed in the hope that it will be useful, but 12 | -- WITHOUT ANY WARRANTY; without even the implied warranty of 13 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General 14 | -- Public License for more details. 15 | -- 16 | -- You should have received a copy of the GNU General Public License along 17 | -- with Tiny-Lisp. If not, see .-- 18 | -- 19 | -- This package contains functions and procedures for managing the stack for 20 | -- the Lisp interpreter. 21 | -- 22 | package BBS.lisp.stack is 23 | pragma Elaborate_Body; 24 | -- 25 | -- Data types for the stack 26 | -- 27 | type stack_entry_type is (ST_EMPTY, ST_FRAME, ST_VALUE); 28 | type stack_entry(kind : stack_entry_type := ST_EMPTY) is 29 | record 30 | case kind is 31 | when ST_EMPTY => 32 | null; 33 | when ST_FRAME => 34 | number: Natural; 35 | next : Natural; 36 | when ST_VALUE => 37 | st_name : string_index; 38 | st_value : element_type; 39 | end case; 40 | end record; 41 | -- 42 | type lisp_stack(size : Natural) is tagged private; 43 | -- 44 | -- Status functions for the stack 45 | -- 46 | function isFull(self : lisp_stack) return Boolean; 47 | -- 48 | -- Adding and removing items from the stack 49 | -- 50 | procedure push(self : in out lisp_stack; name : string_index; val : element_type; err : out Boolean); 51 | -- 52 | -- Operations for stack frames. The usage is as follows: 53 | -- 1) Call start_frame before pushing items onto the stack that should be 54 | -- in the frame. 55 | -- 2) Call enter_frame once the items are all on the stack. This finalizes 56 | -- stack frame creation. 57 | -- 3) Call exit_frame to clean up the stack frame. There is no need to pop 58 | -- the items off the stack that belong to the stack frame. 59 | -- 60 | procedure start_frame(self : in out lisp_stack; err : out Boolean); 61 | procedure exit_frame(self : in out lisp_stack); 62 | -- 63 | -- Procedure for clearing stack. This is done at the command line level. 64 | -- There should be nothing on the stack at this point. Some error conditions 65 | -- may cause a return to the command line without clearing the stack. 66 | -- 67 | -- procedure reset 68 | -- with Global => (Output => (pvt_stack, pvt_sp, pvt_fp, pvt_fc)), 69 | -- Post => (isEmpty); 70 | -- 71 | -- Dump the stack for debugging purposes. Since the stack is private, this 72 | -- needs to be defined here instead of in BBS.lisp.debug. Uncomment to use. 73 | -- 74 | -- procedure dump 75 | -- with Global => (Input => (pvt_stack, pvt_sp, pvt_fp)); 76 | -- 77 | -- Search stack for the variable. The frame offset and name are used to 78 | -- look backwards through the stack frames for a match to the name. If 79 | -- found, the value is returned. If not found, an empty value is returned. 80 | -- 81 | function search_frames(self : lisp_stack; offset : Natural; name : string_index) return element_type; 82 | -- 83 | -- Search stack for the variable. The frame offset and name are used to 84 | -- look backwards through the stack frames for a match to the name. If 85 | -- found, the stack index of the variable is returned, if not 0 is returned. 86 | -- 87 | function search_frames(self : lisp_stack; offset : Natural; name : string_index) return Natural; 88 | -- 89 | -- Searches the stack to find a variable and returns the stack index and offset 90 | -- 91 | function find_offset(self : lisp_stack; name : string_index; index : out Natural) return Natural; 92 | -- 93 | -- Returns the frame pointer so that it can be private. 94 | -- 95 | function get_fp(self : lisp_stack) return Natural; 96 | -- 97 | -- Sets an entry on the stack 98 | -- 99 | procedure set_entry(self : in out lisp_stack; e : Natural; v : stack_entry; err : out Boolean); 100 | -- 101 | -- Sets the value of an entry on the stack 102 | -- 103 | procedure set_value(self : in out lisp_stack; e : Natural; v : element_type; err : out Boolean); 104 | -- 105 | -- Gets an entry from the stack 106 | -- 107 | function get_entry(self : in out lisp_stack; e : Natural; err : out Boolean) return stack_entry; 108 | -- 109 | private 110 | -- 111 | type lisp_stack_array is array (Natural range <>) of stack_entry; 112 | type lisp_stack(size : Natural) is tagged record 113 | sp : Natural; -- Stack pointer 114 | fp : Natural; -- Frame pointer 115 | fc : Natural; -- Frame counter 116 | stack : lisp_stack_array (0 .. size); 117 | end record; 118 | -- 119 | end; 120 | 121 | -------------------------------------------------------------------------------- /src/bbs-lisp-strings.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Author: Brent Seidel 3 | -- Date: 31-Jul-2024 4 | -- 5 | -- This file is part of Tiny-Lisp. 6 | -- Tiny-Lisp is free software: you can redistribute it and/or modify it 7 | -- under the terms of the GNU General Public License as published by the 8 | -- Free Software Foundation, either version 3 of the License, or (at your 9 | -- option) any later version. 10 | -- 11 | -- Tiny-Lisp is distributed in the hope that it will be useful, but 12 | -- WITHOUT ANY WARRANTY; without even the implied warranty of 13 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General 14 | -- Public License for more details. 15 | -- 16 | -- You should have received a copy of the GNU General Public License along 17 | -- with Tiny-Lisp. If not, see .-- 18 | -- 19 | -- This package contains internal functions that support operations on the 20 | -- lisp strings. 21 | -- 22 | package BBS.lisp.strings is 23 | pragma Elaborate_Body; 24 | -- 25 | -- Types for string reference counts 26 | -- 27 | type str_ref_count is new Natural; 28 | FREE_STR : constant str_ref_count := str_ref_count'First; 29 | -- 30 | -- Converts a string to upper-case in place. 31 | -- In place lowercase is never used. If it's ever needed, this routine 32 | -- can provide a template for it. 33 | -- 34 | procedure uppercase(s : string_index); 35 | -- 36 | -- type comparison is (CMP_EQ, CMP_LT, CMP_GT, CMP_NE); 37 | -- 38 | -- Compare two Lisp strings 39 | -- 40 | function compare(s1 : string_index; s2 : string_index) return comparison; 41 | -- 42 | -- Compare a Lisp string with an Ada String 43 | -- 44 | function compare(s1 : string_index; s2 : String) return comparison; 45 | -- 46 | -- Returns the length of a string in characters 47 | -- 48 | function length(s : string_index) return int32; 49 | -- 50 | -- Converts a fixed length Ada string to a Lisp string. Returns false if 51 | -- the Lisp string cannot be allocated. 52 | -- 53 | function str_to_lisp(s : out string_index; str : String) return Boolean; 54 | -- Should really be (In_Out => pvt_string_table); 55 | -- 56 | -- Converts a Lisp string to a fixed length Ada string. 57 | -- 58 | function lisp_to_str(s : string_index) return String; 59 | -- 60 | -- Functions to append to an existing string. Returns False if an error 61 | -- occurs. 62 | -- 63 | function append(s : string_index; c : Character) return Boolean; 64 | -- 65 | -- Appends the string pointed to by str to the string pointed to by dest. 66 | -- Note that dest is updated to point to the last fragment in the string. 67 | -- This can be used to efficiently append multiple strings. However, the 68 | -- pointer to the head of the destination string will need to be saved 69 | -- elsewhere. Returns False if an error occurs. 70 | -- 71 | function append(dest : in out string_index; str : string_index) return Boolean 72 | with pre => (dest /= NIL_STR); 73 | -- 74 | -- Convert a character to upper-case 75 | -- 76 | function To_Upper(c : Character) return Character 77 | with Global => Null; 78 | pragma Pure_Function(To_Upper); 79 | -- 80 | -- Convert a character to lower-case 81 | -- 82 | function To_Lower(c : Character) return Character 83 | with Global => Null; 84 | pragma Pure_Function(To_Lower); 85 | -- 86 | -- Copy helper function 87 | -- 88 | type transform is (NONE, UPPER, LOWER); 89 | function copy(s : string_index; t : transform) return element_type; 90 | -- 91 | -- Functions for character positions. 92 | -- 93 | -- Given a string index and an offset, follow the link list to find the 94 | -- fragment that contains the offset and position in that fragment. If the 95 | -- offset is beyond the end of the string, str is set to NIL_STR and 96 | -- the offset to 0. 97 | -- 98 | procedure cannonicalize(str : in out string_index; offset : in out Natural); 99 | -- 100 | -- Update a string index and offset in cannonical form to point to the next 101 | -- character in cannonical form. If not in cannonical form, or if the next 102 | -- character is past end end of the string, str is set to NIL_STR and offset 103 | -- is set to 0. 104 | -- 105 | procedure move_to_next_char(str : in out string_index; offset : in out Natural); 106 | -- 107 | -- Get a character at a cannonicalized position. This must be a valid position. 108 | -- 109 | function get_char_at(str : string_index; offset : Natural) return Character 110 | with pre => ((str /= NIL_STR) and (offset > 0)); 111 | -- 112 | -- Parse a string as an integer. Starts at the first character in the string 113 | -- and proceeds until either the end of the string fragment or an illegal 114 | -- character is found. 115 | -- 116 | function parse_integer(str : string_index) return int32 117 | with pre => (str /= NIL_STR); 118 | -- 119 | -- Get a substring of a string. An ending offset of -1 means the end of the 120 | -- source string. 121 | -- 122 | function substring(str : string_index; start_offset : Integer; len : Integer) 123 | return string_index 124 | with pre => (str /= NIL_STR); 125 | -- 126 | -- Print a string 127 | -- 128 | procedure print(s : string_index); 129 | -- 130 | -- Dump the string table 131 | -- 132 | procedure dump_strings; 133 | -- ------------------------------------------------------------------------- 134 | -- 135 | -- String iterator. This can be used for looping through the characters in 136 | -- a string. This is designed primarily to be used by BBS.lisp.parser.string. 137 | -- 138 | type str_iterator is record 139 | base : string_index; 140 | current : string_index; 141 | ptr : Natural; 142 | end record; 143 | -- 144 | -- Initializes the object to contain valid values 145 | -- 146 | procedure init(self : in out str_iterator; s : string_index); 147 | -- 148 | -- Gets the character selected by ptr. 149 | -- 150 | function get_char(self : str_iterator) return Character; 151 | -- 152 | -- Looks ahead to the next character after the current one 153 | -- 154 | function get_next_char(self : str_iterator) return Character; 155 | -- 156 | -- Increment ptr to point to the next character 157 | -- 158 | procedure next_char(self : in out str_iterator); 159 | -- 160 | -- Tests if the end of the string has been reached. 161 | -- 162 | function is_end(self : str_iterator) return Boolean; 163 | -- 164 | -- ------------------------------------------------------------------------- 165 | -- 166 | -- String memory management. 167 | -- 168 | function count_free_str return Natural 169 | with Ghost; 170 | -- 171 | -- Allocate a string 172 | -- 173 | function alloc(s : out string_index) return Boolean 174 | with post => (if count_free_str'Old = 0 then alloc'Result = False 175 | else alloc'Result); 176 | -- should really be (In_Out => pvt_string_table); 177 | -- 178 | -- Increase the reference count of a string 179 | -- 180 | procedure ref(s : string_index) 181 | with pre => (s > NIL_STR); 182 | -- 183 | -- Decrease the reference count of a string and deallocate if the count 184 | -- reaches 0. 185 | -- 186 | procedure deref(s : string_index) 187 | with pre => (s > NIL_STR); 188 | -- 189 | -- Reset string table 190 | -- 191 | procedure reset_string_table; 192 | -- 193 | -- Get the reference count for a string fragment 194 | -- 195 | function ref_count(s : string_index) return str_ref_count 196 | with pre => (s > NIL_STR); 197 | -- 198 | private 199 | -- 200 | -- Structures and definitions for handling strings 201 | -- 202 | fragment_len : constant Integer := 16; 203 | type fragment is 204 | record 205 | ref : str_ref_count; 206 | next : string_index; 207 | len : Integer range 0..fragment_len; 208 | str : String (1..fragment_len); 209 | end record; 210 | -- 211 | -- The string table. 212 | -- 213 | string_table : array (string_index'First + 1 .. string_index'Last) of fragment; 214 | 215 | end; 216 | -------------------------------------------------------------------------------- /src/bbs-lisp-symbols.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Author: Brent Seidel 3 | -- Date: 31-Jul-2024 4 | -- 5 | -- This file is part of Tiny-Lisp. 6 | -- Tiny-Lisp is free software: you can redistribute it and/or modify it 7 | -- under the terms of the GNU General Public License as published by the 8 | -- Free Software Foundation, either version 3 of the License, or (at your 9 | -- option) any later version. 10 | -- 11 | -- Tiny-Lisp is distributed in the hope that it will be useful, but 12 | -- WITHOUT ANY WARRANTY; without even the implied warranty of 13 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General 14 | -- Public License for more details. 15 | -- 16 | -- You should have received a copy of the GNU General Public License along 17 | -- with Tiny-Lisp. If not, see .-- 18 | -- 19 | with BBS.lisp.strings; 20 | package body BBS.lisp.symbols is 21 | -- 22 | -- Operations for symbols 23 | -- 24 | -- Get the type of the symbol 25 | -- 26 | function get_type(s : symbol_ptr) return symbol_type is 27 | begin 28 | if s.kind = ST_FIXED then 29 | return index(s.f).b.kind; 30 | else 31 | return symb_table(s.d).b.kind; 32 | end if; 33 | end; 34 | -- 35 | -- Check if symbol is fixed (builtin or special) 36 | -- 37 | function isFixed(s : symbol_ptr) return Boolean is 38 | t : constant symbol_type := get_type(s); 39 | begin 40 | return (t = SY_BUILTIN) or (t = SY_SPECIAL) or (s.kind = ST_FIXED); 41 | end; 42 | -- 43 | -- Check if symbol is a function (builtin, special, or user defined function) 44 | -- 45 | function isFunction(s : symbol_ptr) return Boolean is 46 | t : constant symbol_type := get_type(s); 47 | e : element_type; 48 | begin 49 | if (t = SY_BUILTIN) or (t = SY_SPECIAL) then 50 | return True; 51 | end if; 52 | if t = SY_VARIABLE then 53 | e := get_value(s); 54 | return e.kind = V_LAMBDA; 55 | end if; 56 | return False; 57 | end; 58 | -- 59 | -- If symbol is a variable, get the symbol value. 60 | -- 61 | function get_value(s : symbol_ptr) return element_type is 62 | begin 63 | if s.kind = ST_FIXED then 64 | return index(s.f).b.pv; 65 | else 66 | return symb_table(s.d).b.pv; 67 | end if; 68 | end; 69 | -- 70 | -- If symbol is a lambda, get the list. 71 | -- 72 | function get_list(s : symbol_ptr) return cons_index is 73 | b : constant sym_body := get_sym(s); 74 | e : element_type; 75 | begin 76 | if b.Kind = SY_VARIABLE then 77 | e := get_value(s); 78 | if e.kind = V_LAMBDA then 79 | return e.lam; 80 | elsif e.kind = V_LIST then 81 | return e.l; 82 | end if; 83 | end if; 84 | return NIL_CONS; 85 | end; 86 | -- 87 | -- Get a symbol's name 88 | -- 89 | function get_name(s : symbol_ptr) return string_index is 90 | begin 91 | return symb_table(s.d).name; 92 | end; 93 | -- 94 | function get_name(s : symbol_ptr) return access constant String is 95 | begin 96 | return index(s.f).name; 97 | end; 98 | -- 99 | -- Get a symbol's reference count 100 | -- 101 | function get_ref(s : symbol_ptr) return Natural is 102 | begin 103 | if s.kind = ST_FIXED then 104 | return 2; 105 | else 106 | return symb_table(s.d).ref; 107 | end if; 108 | end; 109 | -- 110 | -- Get a symbol from the symbol table 111 | -- 112 | function get_sym(s : symbol_ptr) return sym_body is 113 | begin 114 | if s.kind = ST_FIXED then 115 | return index(s.f).b; 116 | else 117 | return symb_table(s.d).b; 118 | end if; 119 | end; 120 | -- 121 | -- Set a symbol entry 122 | -- 123 | procedure set_sym(s : symbol_ptr; val : sym_body) is 124 | begin 125 | symb_table(s.d).b := val; 126 | end; 127 | -- 128 | -- Add a new symbol entry 129 | -- 130 | procedure add_sym(s : symbol_ptr; val : symbol) is 131 | begin 132 | symb_table(s.d) := val; 133 | end; 134 | -- 135 | -- Reset the symbol table 136 | -- 137 | procedure reset_symbol_table is 138 | begin 139 | for i in symb_table'Range loop 140 | symb_table(i).ref := 0; 141 | end loop; 142 | end; 143 | -- 144 | -- Search the symbol table for a name. Assume that the string is already 145 | -- uppercased. 146 | -- 147 | function find_name(s : string_index) return symbol_ptr is 148 | begin 149 | for i in index'Range loop 150 | if bbs.lisp.strings.compare(s, index(i).name.all) = CMP_EQ then 151 | return (kind => ST_FIXED, f => i); 152 | end if; 153 | end loop; 154 | return (kind => ST_NULL); 155 | end; 156 | -- 157 | end; 158 | -------------------------------------------------------------------------------- /src/math.lisp: -------------------------------------------------------------------------------- 1 | ; 2 | ; A collection of simple math functions using the tiny Lisp interpreter 3 | ; 4 | ; 5 | ; Recursive function to compute factoral of a number. 6 | ; 7 | (defun fact (n) 8 | (if (> n 1) 9 | (* n (fact (- n 1))) 10 | 1)) 11 | ; 12 | ; Return the absolute value of a number 13 | (defun abs (n) 14 | (if (> 0 n) 15 | (- 0 n) 16 | (+ 0 n))) 17 | ; 18 | ; Recursive function to compute Fibonacci numbers. 19 | ; 20 | ; This should give a workout for recursive functions. The first few values 21 | ; returned should be: 22 | ; (fib 1) => 1 23 | ; (fib 2) => 2 24 | ; (fib 3) => 3 25 | ; (fib 4) => 5 26 | ; (fib 5) => 8 27 | ; 28 | (defun fib (n) 29 | (if (< n 2) 30 | 1 31 | (+ (fib (- n 2)) (fib (- n 1))))) 32 | ; 33 | ; Iterative Fibonacci function 34 | ; 35 | (defun fibi (n) 36 | (let (temp (n1 0) (n2 1)) 37 | (dotimes (iter n) 38 | (setq temp (+ n1 n2)) 39 | (setq n1 n2) 40 | (setq n2 temp)) 41 | n2)) 42 | ; 43 | ; Compute the remainder 44 | ; 45 | (defun rem (a b) (- a (* (/ a b) b))) 46 | ; 47 | ; Squares and square roots 48 | ; 49 | (defun sqr (n) (* n n)) 50 | ; 51 | ; Integer square root of n. Returns i where i*i <= n and (i+1)*(i+1) > n. 52 | ; This assumes that n > 0. Note that this is not a particularly efficient 53 | ; algorithm. 54 | ; 55 | (defun sqrt (n) 56 | (if (< n 1) 57 | 0 58 | (if (< n 4) 59 | 1 60 | (let ((temp 2)) 61 | (dowhile (< (* temp temp) (+ n 1)) 62 | (setq temp (+ temp 1))) 63 | (- temp 1))))) 64 | ; 65 | ; Compute integer square root of n using bisection algorithm. This is not the 66 | ; best, but will be better than the one above that just counts up. 67 | ; 68 | (defun sqrt (n) 69 | (if (< n 1) 70 | 0 71 | (if (< n 4) 72 | 1 73 | (if (< n 9) 74 | 3 75 | (let ((min 1) (max (/ n 2)) (mid 0)) 76 | (dowhile (> (- max min) 1) 77 | (setq mid (/ (+ min max) 2)) 78 | (if (> mid (/ n mid)) 79 | (setq max mid) 80 | (setq min mid))) 81 | (+ 0 min)))))) 82 | ; 83 | ; Test if a number is prime. This depends on the functions rem and one of the 84 | ; sqrt functions defined above. 85 | ; 86 | (defun primep (n) 87 | (let ((prime T) (count 3) (limit (+ 1 (sqrt n)))) 88 | (if (= 0 (rem n 2)) 89 | (setq prime NIL)) 90 | (dowhile (and prime (< count limit)) 91 | (if (= 0 (rem n count)) 92 | (setq prime NIL)) 93 | (setq count (+ 2 count))) 94 | prime)) 95 | ; 96 | ; List prime numbers from 1 through n 97 | ; 98 | (defun primes (n) 99 | (let ((value 0) (is-prime NIL) (limit (+ 1 (/ n 2)))) 100 | (dotimes (x limit) 101 | (setq value (+ 1 (* 2 x))) 102 | (setq is-prime (primep value)) 103 | (if is-prime (progn (print value " is prime") (terpri)))))) 104 | ; 105 | ; Logical operations 106 | ; 107 | (defun xor (a b) (or (and a (not b)) (and (not a) b))) 108 | ; 109 | (defun nand (a b) (not (and a b))) 110 | ; 111 | (defun nor (a b) (not (or a b))) 112 | ; 113 | ; Operations on functions 114 | ; 115 | (defun sum (min max func) 116 | (let ((total 0)) 117 | (dotimes (x (+ 1 (- max min))) 118 | (setq total (+ total (func (+ x min))))) 119 | total)) 120 | 121 | -------------------------------------------------------------------------------- /src/sample.lisp: -------------------------------------------------------------------------------- 1 | ; 2 | ; Initialize stack 3 | ; 4 | ; (defvar *stack* ()) 5 | ; 6 | (defun stack-init () 7 | (setq *stack* ())) 8 | ; 9 | ; Add an element to the stack 10 | ; 11 | (defun stack-push (a) 12 | (setq *stack* (cons a *stack*))) 13 | ; 14 | ; Remove an item from the stack and return it 15 | ; 16 | (defun stack-pop () 17 | (let ((temp (car *stack*))) 18 | (setq *stack* (cdr *stack*)) 19 | temp)) 20 | ; 21 | ; Function that needs a lambda 22 | ; 23 | (defun op (a) (a 2 3)) 24 | 25 | (op (lambda (a b) (+ a b))) 26 | ; 27 | ; Interactions between functions and let variables 28 | ; 29 | (let ((a 10)) (defun test (b) (print "Sum is " (+ a b)) (terpri)) 30 | (test 5)) 31 | 32 | (test 6) 33 | 34 | (let ((a 20)) (test 7)) 35 | 36 | (let ((b 30)) (test 8)) 37 | ; 38 | ; Example of a lambda as a condition. 39 | ; 40 | (setq *value* 10) 41 | 42 | (defun test-example () 43 | (setq *value* (- *value* 1)) 44 | (< 0 *value*)) 45 | 46 | (defun test-work () 47 | (print "Value is " *value*) 48 | (terpri)) 49 | 50 | (defun test-lam (test-func work-func) 51 | (dowhile (test-func) (work-func))) 52 | 53 | (test-lam (lambda () (test-example)) (lambda () (test-work))) 54 | 55 | -------------------------------------------------------------------------------- /test/debug.lisp: -------------------------------------------------------------------------------- 1 | ; 2 | ; This is a subset of test.lisp to make it easier to debug specific 3 | ; test cases without wading through all the other results. 4 | ; 5 | ; ./lisp < debug.lisp 6 | ; 7 | ; This file is expected to change frequently as different tests are 8 | ; being developed or debugged. 9 | ; 10 | ;----------------------------------------- 11 | ; Support functions. Load these first. 12 | ; 13 | ; Initialize global counters 14 | ; 15 | (setq *PASS-COUNT* 0) 16 | (setq *FAIL-COUNT* 0) 17 | ; 18 | ; 19 | ; If two values are equal, print pass message, otherwise print fail message 20 | ; 21 | (defun verify-equal (expected actual text) 22 | (if (= expected actual) 23 | (progn (setq *PASS-COUNT* (+ *PASS-COUNT* 1)) (print "PASS: Actual ")) 24 | (progn (setq *FAIL-COUNT* (+ *FAIL-COUNT* 1)) (print "***FAIL: Actual "))) 25 | (print actual ", Expected " expected " " text) 26 | (terpri)) 27 | ; 28 | ; Check if a value is true 29 | ; 30 | (defun verify-true (act text-msg) 31 | (verify-equal T act text-msg)) 32 | ; 33 | ; Check if a value is false 34 | ; 35 | (defun verify-false (act text-msg) 36 | (verify-equal NIL act text-msg)) 37 | ; 38 | ; Print summary results 39 | ; 40 | (defun summary () 41 | (print "Test cases passed: " *PASS-COUNT*) 42 | (terpri) 43 | (print "Test cases failed: " *FAIL-COUNT*) 44 | (terpri) 45 | (print "Total test cases: " (+ *PASS-COUNT* *FAIL-COUNT*))) 46 | ;-------------------------------------------- 47 | ; 48 | ; Test the condition operation. 49 | ; 50 | (print "===> Testing cond operations") 51 | (terpri) 52 | (defun test-cond () 53 | (verify-equal ERR_FEWPARAM 54 | (cond 55 | ((= 1 2) (+ 1 2)) 56 | ((= 2 3) (+ 2 3)) 57 | ((= 3 4) (+ 3 4))) 58 | "No condition branch matches") 59 | (verify-equal ERR_WRONGTYPE 60 | (cond 61 | ((= 1 2) (+ 1 2)) 62 | 5 63 | ((= 3 4) (+ 3 4))) 64 | "Non-list element encountered") 65 | (verify-equal ERR_HARDWARE 66 | (cond 67 | ((= 1 2) (+ 1 2)) 68 | ERR_HARDWARE 69 | ((= 3 4) (+ 3 4))) 70 | "Error evaluating candidate encountered") 71 | (verify-equal ERR_HARDWARE 72 | (cond 73 | ((= 1 2) (+ 1 2)) 74 | (ERR_HARDWARE (+ 2 3)) 75 | ((= 3 4) (+ 3 4))) 76 | "Error evaluating condition encountered") 77 | (verify-equal 5 78 | (cond 79 | ((= 1 2) (+ 1 2)) 80 | ((= 3 3) (+ 1 2) (+ 2 3)) 81 | ((= 3 4) (+ 3 4))) 82 | "One item matches") 83 | (verify-equal 5 84 | (cond 85 | ((= 1 2) (+ 1 2)) 86 | ((= 3 3) (+ 2 3)) 87 | ((= 4 4) (+ 3 4))) 88 | "Two items match, only first is evaluated") 89 | ) 90 | (test-cond) 91 | (setq test-cond 0) 92 | ; 93 | ;-------------------------------------------- 94 | (print "===> Testing complete") 95 | (terpri) 96 | (summary) 97 | (exit) 98 | -------------------------------------------------------------------------------- /test/primes.lisp: -------------------------------------------------------------------------------- 1 | ; 2 | ; Test script to profile the Lisp interpreter using prime number 3 | ; generation. 4 | ; 5 | ; 6 | ; Compute the remainder 7 | ; 8 | (defun rem (a b) (- a (* (/ a b) b))) 9 | ; 10 | ; Compute integer square root of n using bisection algorithm. This is not the 11 | ; best, but will be better than the one above that just counts up. 12 | ; 13 | (defun sqrt (n) 14 | (if (< n 1) 15 | 0 16 | (if (< n 4) 17 | 1 18 | (if (< n 9) 19 | 3 20 | (let ((min 1) (max (/ n 2)) (mid 0)) 21 | (dowhile (> (- max min) 1) 22 | (setq mid (/ (+ min max) 2)) 23 | (if (> mid (/ n mid)) 24 | (setq max mid) 25 | (setq min mid))) 26 | (+ 0 min)))))) 27 | ; 28 | ; Test if a number is prime. This depends on the functions rem and one of the 29 | ; sqrt functions defined above. 30 | ; 31 | (defun primep (n) 32 | (let ((prime T) (count 3) (limit (+ 1 (sqrt n)))) 33 | (if (= 0 (rem n 2)) 34 | (setq prime NIL)) 35 | (dowhile (and prime (< count limit)) 36 | (if (= 0 (rem n count)) 37 | (setq prime NIL)) 38 | (setq count (+ 2 count))) 39 | prime)) 40 | ; 41 | ; List prime numbers from 1 through n 42 | ; 43 | (defun primes (n) 44 | (let ((value 0) (is-prime NIL) (limit (+ 1 (/ n 2)))) 45 | (dotimes (x limit) 46 | (setq value (+ 1 (* 2 x))) 47 | (setq is-prime (primep value)) 48 | (if is-prime (progn (print value " is prime") (terpri)))))) 49 | ; 50 | ; Compute prime numbers up to #xFFFFFF 51 | ; 52 | (primes #xFFFFFF) 53 | (exit) 54 | --------------------------------------------------------------------------------