├── INSTALL ├── version.hpp ├── undef_error.hpp ├── noncopyable.hpp ├── instructions.i ├── COPYING ├── main.cpp ├── type.hpp ├── symbol.hpp ├── number_io.hpp ├── error.hpp ├── bignum.hpp ├── inputsplitter.hpp ├── Makefile ├── symbol.cpp ├── README ├── inputsplitter.cpp ├── bignum.cpp ├── number_io.cpp ├── uscheme-init.scm └── scheme.hpp /INSTALL: -------------------------------------------------------------------------------- 1 | see README -------------------------------------------------------------------------------- /version.hpp: -------------------------------------------------------------------------------- 1 | #ifndef VERSION_HPP 2 | #define VERSION_HPP 3 | 4 | #define VERSION 0.49 5 | 6 | #endif //VERSION_HPP 7 | -------------------------------------------------------------------------------- /undef_error.hpp: -------------------------------------------------------------------------------- 1 | #ifdef ERROR_MACRO_HPP 2 | #undef ERROR_MACRO_HPP 3 | #undef S_THROW 4 | #undef S_ASSERT 5 | 6 | #ifdef S_DIE 7 | #undef S_DIE 8 | #endif 9 | 10 | #endif //ERROR_MACRO_HPP 11 | -------------------------------------------------------------------------------- /noncopyable.hpp: -------------------------------------------------------------------------------- 1 | #ifndef NONCOPYABLE_HPP 2 | #define NONCOPYABLE_HPP 3 | 4 | // stolen from boost/noncopyable.hpp 5 | 6 | class noncopyable 7 | { 8 | protected: 9 | noncopyable() {} 10 | ~noncopyable() {} 11 | private: 12 | noncopyable( const noncopyable& ); 13 | const noncopyable& operator=( const noncopyable& ); 14 | }; 15 | 16 | #endif //NONCOPYABLE_HPP 17 | -------------------------------------------------------------------------------- /instructions.i: -------------------------------------------------------------------------------- 1 | // Specification of all instructions. These are included in two 2 | // different ways, once to create the actual enum and once to 3 | // create a list of those enum values combined with their names. 4 | 5 | INSTRUCTION(return) 6 | INSTRUCTION(jump) 7 | INSTRUCTION(jump_if_false) 8 | 9 | INSTRUCTION(setup_arg_list) 10 | INSTRUCTION(add_arg) 11 | 12 | INSTRUCTION(literal) 13 | 14 | INSTRUCTION(call) 15 | INSTRUCTION(tail) 16 | INSTRUCTION(finish_lambda) 17 | INSTRUCTION(make_macro) 18 | 19 | INSTRUCTION(grow_env) 20 | INSTRUCTION(deref_env) 21 | INSTRUCTION(deref_ref) 22 | INSTRUCTION(define_ref) 23 | INSTRUCTION(set_env) 24 | INSTRUCTION(set_ref) 25 | 26 | INSTRUCTION(as_arguments) 27 | INSTRUCTION(current_continuation) 28 | INSTRUCTION(set_continuation) 29 | -------------------------------------------------------------------------------- /COPYING: -------------------------------------------------------------------------------- 1 | Copyright (c) 2004 Marijn Haverbeke 2 | 3 | This software is provided 'as-is', without any express or implied 4 | warranty. In no event will the authors be held liable for any damages 5 | arising from the use of this software. 6 | 7 | Permission is granted to anyone to use this software for any purpose, 8 | including commercial applications, and to alter it and redistribute it 9 | freely, subject to the following restrictions: 10 | 11 | 1. The origin of this software must not be misrepresented; you must not 12 | claim that you wrote the original software. If you use this software 13 | in a product, an acknowledgment in the product documentation would 14 | be appreciated but is not required. 15 | 16 | 2. Altered source versions must be plainly marked as such, and must not 17 | be misrepresented as being the original software. 18 | 19 | 3. This notice may not be removed or altered from any source 20 | distribution. 21 | 22 | Marijn Haverbeke 23 | marijn(at)haverbeke.nl 24 | -------------------------------------------------------------------------------- /main.cpp: -------------------------------------------------------------------------------- 1 | /* Copyright (c) 2004 Marijn Haverbeke 2 | * 3 | * This software is provided 'as-is', without any express or implied 4 | * warranty. In no event will the authors be held liable for any 5 | * damages arising from the use of this software. 6 | * 7 | * Permission is granted to anyone to use this software for any 8 | * purpose, including commercial applications, and to alter it and 9 | * redistribute it freely, subject to the following restrictions: 10 | * 11 | * 1. The origin of this software must not be misrepresented; you must 12 | * not claim that you wrote the original software. If you use this 13 | * software in a product, an acknowledgment in the product 14 | * documentation would be appreciated but is not required. 15 | * 16 | * 2. Altered source versions must be plainly marked as such, and must 17 | * not be misrepresented as being the original software. 18 | * 19 | * 3. This notice may not be removed or altered from any source 20 | * distribution. 21 | * 22 | * Marijn Haverbeke 23 | * marijn(at)haverbeke.nl 24 | */ 25 | 26 | #include 27 | 28 | #include "scheme.hpp" 29 | 30 | int main() 31 | { 32 | try{ 33 | uls::Interpreter in(2000); 34 | uls::Run_REPL(true); 35 | return 0; 36 | } 37 | catch (const std::exception& e){ 38 | std::cout << "Fatal error: " << e.what() << std::endl; 39 | return 1; 40 | } 41 | catch (...){ 42 | std::cout << "Fatal (unknown) error." << std::endl; 43 | return 1; 44 | } 45 | } 46 | -------------------------------------------------------------------------------- /type.hpp: -------------------------------------------------------------------------------- 1 | /* Copyright (c) 2004 Marijn Haverbeke 2 | * 3 | * This software is provided 'as-is', without any express or implied 4 | * warranty. In no event will the authors be held liable for any 5 | * damages arising from the use of this software. 6 | * 7 | * Permission is granted to anyone to use this software for any 8 | * purpose, including commercial applications, and to alter it and 9 | * redistribute it freely, subject to the following restrictions: 10 | * 11 | * 1. The origin of this software must not be misrepresented; you must 12 | * not claim that you wrote the original software. If you use this 13 | * software in a product, an acknowledgment in the product 14 | * documentation would be appreciated but is not required. 15 | * 16 | * 2. Altered source versions must be plainly marked as such, and must 17 | * not be misrepresented as being the original software. 18 | * 19 | * 3. This notice may not be removed or altered from any source 20 | * distribution. 21 | * 22 | * Marijn Haverbeke 23 | * marijn(at)haverbeke.nl 24 | */ 25 | 26 | #ifndef TYPE_HPP 27 | #define TYPE_HPP 28 | 29 | #include 30 | 31 | // Some typedefs and constant to make some bit-twiddling operations 32 | // and typenames a little less ugly. 33 | 34 | namespace uls{ 35 | 36 | typedef unsigned char byte; 37 | typedef long long int64; 38 | typedef unsigned long long uint64; 39 | const size_t byte_size = 8; 40 | const unsigned char max_byte = 0xFF; 41 | const unsigned short max_short = 0xFFFF; 42 | // TODO 64-bit fixnums 43 | const size_t max_int = 0xFFFFFFFF; 44 | 45 | } 46 | 47 | #endif //TYPE_HPP 48 | -------------------------------------------------------------------------------- /symbol.hpp: -------------------------------------------------------------------------------- 1 | /* Copyright (c) 2004 Marijn Haverbeke 2 | * 3 | * This software is provided 'as-is', without any express or implied 4 | * warranty. In no event will the authors be held liable for any 5 | * damages arising from the use of this software. 6 | * 7 | * Permission is granted to anyone to use this software for any 8 | * purpose, including commercial applications, and to alter it and 9 | * redistribute it freely, subject to the following restrictions: 10 | * 11 | * 1. The origin of this software must not be misrepresented; you must 12 | * not claim that you wrote the original software. If you use this 13 | * software in a product, an acknowledgment in the product 14 | * documentation would be appreciated but is not required. 15 | * 16 | * 2. Altered source versions must be plainly marked as such, and must 17 | * not be misrepresented as being the original software. 18 | * 19 | * 3. This notice may not be removed or altered from any source 20 | * distribution. 21 | * 22 | * Marijn Haverbeke 23 | * marijn(at)haverbeke.nl 24 | */ 25 | 26 | #ifndef SYMBOL_HPP 27 | #define SYMBOL_HPP 28 | 29 | #include 30 | 31 | // Associate integer values with strings. Get_Symbol will create a new 32 | // association if none exist for that string, Find_Symbol will return 33 | // null_symbol in that case. Note that this system never forgets 34 | // associations, this has the disadvantage that it can get memory 35 | // intensive if you generate large amounts of temporary symbols 36 | // (string->symbol and integer->symbol can do that), but the advantage 37 | // that this module is not dependant on any Interpreter and that the 38 | // symbols can be used for other purposes than scheme symbols. 39 | 40 | namespace uls{ 41 | 42 | typedef size_t Symbol; 43 | const Symbol null_symbol = 0; 44 | 45 | Symbol Get_Symbol(const std::string& word); 46 | Symbol Find_Symbol(const std::string& word); 47 | const std::string& Get_Symbol_Name(Symbol s); 48 | 49 | } 50 | 51 | #endif //SYMBOL_HPP 52 | -------------------------------------------------------------------------------- /number_io.hpp: -------------------------------------------------------------------------------- 1 | /* Copyright (c) 2004 Marijn Haverbeke 2 | * 3 | * This software is provided 'as-is', without any express or implied 4 | * warranty. In no event will the authors be held liable for any 5 | * damages arising from the use of this software. 6 | * 7 | * Permission is granted to anyone to use this software for any 8 | * purpose, including commercial applications, and to alter it and 9 | * redistribute it freely, subject to the following restrictions: 10 | * 11 | * 1. The origin of this software must not be misrepresented; you must 12 | * not claim that you wrote the original software. If you use this 13 | * software in a product, an acknowledgment in the product 14 | * documentation would be appreciated but is not required. 15 | * 16 | * 2. Altered source versions must be plainly marked as such, and must 17 | * not be misrepresented as being the original software. 18 | * 19 | * 3. This notice may not be removed or altered from any source 20 | * distribution. 21 | * 22 | * Marijn Haverbeke 23 | * marijn(at)haverbeke.nl 24 | */ 25 | 26 | #ifndef NUMBER_IO_HPP 27 | #define NUMBER_IO_HPP 28 | 29 | #include 30 | #include 31 | #include 32 | 33 | #include "type.hpp" 34 | #include "bignum.hpp" 35 | 36 | // Used to convert numbers to and from text. This was needed for two 37 | // reasons - Firstly I wanted to support a lot of radixes, and 38 | // secondly bignums needed custom i/o methods anyway. 39 | // 40 | // The reason input is done through strings and output through streams 41 | // is that this was convenient. The functions that require input in 42 | // scheme.cpp already had strings, and strings are easy to read 43 | // backwards, while the output functions worked with streams. 44 | 45 | namespace uls{ 46 | 47 | double String_To_Double(const std::string& str, size_t radix = 10); 48 | int64 String_To_Int(const std::string& str, size_t radix = 10); 49 | // Return value indicates the sign of the number, true is negative 50 | bool String_To_Array(const std::string& str, std::vector& array, size_t radix = 10); 51 | 52 | void Write_Double(std::ostream& stream, double value, size_t radix = 10); 53 | void Write_Int(std::ostream& stream, int value, size_t radix = 10); 54 | void Write_Array(std::ostream& stream, const digit* array, size_t size, bool negative, size_t radix = 10); 55 | 56 | } 57 | 58 | #endif //NUMBER_IO_HPP 59 | -------------------------------------------------------------------------------- /error.hpp: -------------------------------------------------------------------------------- 1 | /* Copyright (c) 2004 Marijn Haverbeke 2 | * 3 | * This software is provided 'as-is', without any express or implied 4 | * warranty. In no event will the authors be held liable for any 5 | * damages arising from the use of this software. 6 | * 7 | * Permission is granted to anyone to use this software for any 8 | * purpose, including commercial applications, and to alter it and 9 | * redistribute it freely, subject to the following restrictions: 10 | * 11 | * 1. The origin of this software must not be misrepresented; you must 12 | * not claim that you wrote the original software. If you use this 13 | * software in a product, an acknowledgment in the product 14 | * documentation would be appreciated but is not required. 15 | * 16 | * 2. Altered source versions must be plainly marked as such, and must 17 | * not be misrepresented as being the original software. 18 | * 19 | * 3. This notice may not be removed or altered from any source 20 | * distribution. 21 | * 22 | * Marijn Haverbeke 23 | * marijn(at)haverbeke.nl 24 | */ 25 | 26 | #ifndef ERROR_MACROS_HPP 27 | #define ERROR_MACROS_HPP 28 | 29 | #include 30 | 31 | #ifdef NDEBUG 32 | 33 | #define S_THROW(error_type, message) throw error_type(message) 34 | 35 | #define S_ASSERT(expr) 36 | 37 | #else // NDEBUG 38 | 39 | #include 40 | 41 | inline std::string Macro_Mark_String(std::string target, const char* file, int line) 42 | { 43 | std::ostringstream new_string; 44 | new_string << target << " (" << file << " at line " << line << ")"; 45 | return new_string.str(); 46 | } 47 | 48 | #define S_THROW(error_type, message) throw error_type(Macro_Mark_String(message, __FILE__, __LINE__)) 49 | 50 | #ifdef _WIN32 51 | #define S_DIE() exit(1) 52 | #else 53 | #include 54 | #define S_DIE() kill(0, SIGTERM) 55 | #endif 56 | #include 57 | #define S_ASSERT(expr) if (!(expr)){std::cout << Macro_Mark_String("Assertion (" #expr ") failed.", __FILE__, __LINE__) << std::endl;\ 58 | S_DIE();} else 59 | 60 | #endif // NDEBUG 61 | 62 | #ifndef SCHEME_ERROR_DEFINED 63 | #define SCHEME_ERROR_DEFINED 64 | namespace uls{ 65 | class Scheme_Error: public std::exception 66 | { 67 | public: 68 | Scheme_Error(const std::string& message): _message(message){} 69 | virtual ~Scheme_Error() throw(){} 70 | 71 | virtual const char* what() const throw(){return _message.c_str();} 72 | 73 | private: 74 | std::string _message; 75 | }; 76 | } 77 | #endif //SCHEME_ERROR_DEFINED 78 | 79 | #define S_CHECK(test, message) if (!(test)) throw Scheme_Error(message); else 80 | 81 | #endif //ERROR_MACROS_HPP 82 | -------------------------------------------------------------------------------- /bignum.hpp: -------------------------------------------------------------------------------- 1 | /* Copyright (c) 2004 Marijn Haverbeke 2 | * 3 | * This software is provided 'as-is', without any express or implied 4 | * warranty. In no event will the authors be held liable for any 5 | * damages arising from the use of this software. 6 | * 7 | * Permission is granted to anyone to use this software for any 8 | * purpose, including commercial applications, and to alter it and 9 | * redistribute it freely, subject to the following restrictions: 10 | * 11 | * 1. The origin of this software must not be misrepresented; you must 12 | * not claim that you wrote the original software. If you use this 13 | * software in a product, an acknowledgment in the product 14 | * documentation would be appreciated but is not required. 15 | * 16 | * 2. Altered source versions must be plainly marked as such, and must 17 | * not be misrepresented as being the original software. 18 | * 19 | * 3. This notice may not be removed or altered from any source 20 | * distribution. 21 | * 22 | * Marijn Haverbeke 23 | * marijn(at)haverbeke.nl 24 | */ 25 | 26 | #ifndef BIGNUM_HPP 27 | #define BIGNUM_HPP 28 | 29 | #include "type.hpp" 30 | 31 | // Methods for operations on bignums. The interface of passing 32 | // pointers and sizes is a little clunky but this was necessary 33 | // because there are two representations of bignums - inside cells and 34 | // as Array_Buffers. 35 | 36 | namespace uls{ 37 | 38 | // The digit type and some conts to make messing with it easier. 39 | typedef unsigned int digit; 40 | const size_t digit_size = byte_size * sizeof(digit); 41 | const uint64 digit_radix = (static_cast(1) << digit_size), digit_mask = digit_radix - 1; 42 | 43 | // Buffers to keep bignums in during calculations. 44 | digit* Allocate_Array(int size); 45 | struct Array_Buffer 46 | { 47 | explicit Array_Buffer(int s) 48 | : size(s), 49 | data(Allocate_Array(size)) 50 | {} 51 | ~Array_Buffer() 52 | { 53 | Allocate_Array(-size); 54 | } 55 | size_t size; 56 | digit* data; 57 | }; 58 | 59 | // The operations. Add and subtract allow the result buffer to be the 60 | // same as one of the source buffers, with multiply and divide this 61 | // does not work. 62 | bool Array_Zero(const digit* one, size_t s_one); 63 | bool Array_Smaller(const digit* one, size_t s_one, const digit* two, size_t s_two); 64 | void Add_Arrays(const digit* one, size_t s_one, const digit* two, size_t s_two, digit* result, size_t s_result); 65 | void Subtract_Arrays(const digit* one, size_t s_one, const digit* two, size_t s_two, digit* result, size_t s_result); 66 | void Multiply_Arrays(const digit* one, size_t s_one, const digit* two, size_t s_two, digit* result, size_t s_result); 67 | void Divide_Arrays(const digit* one, size_t s_one, const digit* two, size_t s_two, digit* quotient, size_t s_quotient, digit* remain, size_t s_remain); 68 | 69 | } 70 | 71 | #endif //BIGNUM_HPP 72 | -------------------------------------------------------------------------------- /inputsplitter.hpp: -------------------------------------------------------------------------------- 1 | /* Copyright (c) 2004 Marijn Haverbeke 2 | * 3 | * This software is provided 'as-is', without any express or implied 4 | * warranty. In no event will the authors be held liable for any 5 | * damages arising from the use of this software. 6 | * 7 | * Permission is granted to anyone to use this software for any 8 | * purpose, including commercial applications, and to alter it and 9 | * redistribute it freely, subject to the following restrictions: 10 | * 11 | * 1. The origin of this software must not be misrepresented; you must 12 | * not claim that you wrote the original software. If you use this 13 | * software in a product, an acknowledgment in the product 14 | * documentation would be appreciated but is not required. 15 | * 16 | * 2. Altered source versions must be plainly marked as such, and must 17 | * not be misrepresented as being the original software. 18 | * 19 | * 3. This notice may not be removed or altered from any source 20 | * distribution. 21 | * 22 | * Marijn Haverbeke 23 | * marijn(at)haverbeke.nl 24 | */ 25 | 26 | #ifndef INPUT_SPLITTER_HPP 27 | #define INPUT_SPLITTER_HPP 28 | 29 | #include 30 | #include 31 | #include 32 | 33 | // System to split input into element-sized strings. An abstract base 34 | // class with two implementations is provided - one for strings and 35 | // one for streams. The reason there are two implemenations is that 36 | // stream output is blocking, it just keeps looking ahead as long as 37 | // it has to for new input, while string output has to look ahead to 38 | // see if a full expression has been entered before an expression can 39 | // be read. 40 | 41 | namespace uls{ 42 | 43 | inline bool Is_Whitespace(char c) 44 | { 45 | return (c == ' ' || c == '\t' || c == '\n' || c == '\r'); 46 | } 47 | 48 | class Input_Splitter 49 | { 50 | public: 51 | virtual ~Input_Splitter(){} 52 | 53 | virtual const std::string& Current() = 0; 54 | virtual void Advance(bool allow_eof = true) = 0; 55 | }; 56 | 57 | class String_Input_Splitter: public Input_Splitter 58 | { 59 | public: 60 | String_Input_Splitter(); 61 | 62 | virtual const std::string& Current(); 63 | virtual void Advance(bool allow_eof = true); 64 | 65 | void Add_Line(const std::string& str); 66 | bool Full_Expression(); 67 | void Reset(); 68 | 69 | private: 70 | void Add_Part(const std::string& part, bool can_be_finished = true); 71 | 72 | std::deque _parts; 73 | std::string _unfinished; 74 | bool _in_string; 75 | int _open_parens; 76 | size_t _finished_part; 77 | }; 78 | 79 | class Stream_Input_Splitter: public Input_Splitter 80 | { 81 | public: 82 | Stream_Input_Splitter(std::istream& stream); 83 | 84 | virtual const std::string& Current(); 85 | virtual void Advance(bool allow_eof = true); 86 | 87 | bool Eof(){return _stream.eof();} 88 | size_t Lines_Read(){return _lines_read;} 89 | 90 | private: 91 | void Read_Part(); 92 | char Get_Char() 93 | { 94 | char retval = _stream.get(); 95 | if (retval == '\n') 96 | ++_lines_read; 97 | return retval; 98 | } 99 | 100 | std::istream& _stream; 101 | std::string _current; 102 | size_t _lines_read; 103 | bool _allow_eof; 104 | }; 105 | 106 | } 107 | 108 | #endif //INPUT_SPLITTER_HPP 109 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # Really neat mostly automatic makefile for C++ projects. By tweaking 2 | # the variables specified on top you should be able to control the 3 | # whole make process. Generates automatic dependency files, allows 4 | # combining of sources from various directories. Only works on GNU-ish 5 | # systems (g++, gnu make, and some generic unix tools are necessary). 6 | # 7 | # Author: Marijn Haverbeke 8 | 9 | TARGET = uscheme 10 | PREFIX = /usr/local 11 | TYPE = release 12 | INITFILE = uscheme-init.scm 13 | LIBFILE = libuscheme.a 14 | 15 | DIRS = . 16 | LIBS = 17 | DLIBS = 18 | 19 | MACROS = PREFIX=\"$(PREFIX)\" INIT_FILE=\"$(INITFILE)\" # WITH_DESTRUCTORS 20 | 21 | ifeq ($(TYPE),debug) 22 | LDPARAM = 23 | CCPARAM = -Wall -g 24 | MACROS += ALWAYS_COLLECT 25 | endif 26 | 27 | ifeq ($(TYPE),fast-debug) 28 | LDPARAM = 29 | CCPARAM = -Wall -g 30 | endif 31 | 32 | ifeq ($(TYPE),profile) 33 | LDPARAM = -pg /lib/libc.so.5 34 | CCPARAM = -Wall -O2 -pg 35 | MACROS += NDEBUG 36 | endif 37 | 38 | ifeq ($(TYPE), release) 39 | LDPARAM = -s 40 | CCPARAM = -Wall -O1 41 | MACROS += NDEBUG 42 | endif 43 | 44 | CCPARAM += -std=c++0x 45 | 46 | INCPATH = . 47 | LIBPATH = 48 | C++ = g++ 49 | AR = ar crs 50 | 51 | EXTRA_FILES = $(INITFILE) init-light.scm test.scm instructions.i Makefile INSTALL README COPYING 52 | STORE = .make-$(TYPE) 53 | PACKAGE_FILES = *.cpp *.hpp README INSTALL COPYING Makefile instructions.i uscheme-init.scm 54 | 55 | # Makes a list of the source (.cpp) files. 56 | SOURCE := $(foreach DIR,$(DIRS),$(wildcard $(DIR)/*.cpp)) 57 | # List of header files. 58 | HEADERS := $(foreach DIR,$(DIRS),$(wildcard $(DIR)/*.hpp)) 59 | # Makes a list of the object files that will have to be created based 60 | # on the source files that have been found and the location of the 61 | # object files that was specified in OBJPATH. 62 | OBJECTS := $(addprefix $(STORE)/, $(SOURCE:.cpp=.o)) 63 | # Same for the .d files. 64 | DFILES := $(addprefix $(STORE)/,$(SOURCE:.cpp=.d)) 65 | 66 | # Specify phony rules. 67 | .PHONY: clean backup dirs tags lib docs install 68 | 69 | # Main target. 70 | $(TARGET): dirs $(OBJECTS) 71 | @echo Linking $(TARGET). 72 | @$(C++) $(OBJECTS) -o $(TARGET) $(LDPARAM) $(foreach LIBRARY, $(LIBS),-l$(LIBRARY)) $(foreach LIB,$(LIBPATH),-L$(LIB)) $(foreach DLIBRARY, $(DLIBS),$(DLIBRARY).dll) 73 | 74 | # Rule for creating object file and .d file, the sed magic is to add 75 | # the object path at the start of the file because the files gcc 76 | # outputs assume it will be in the same dir as the source file. 77 | $(STORE)/%.o: %.cpp 78 | @echo Creating object file for $*... 79 | @$(C++) -Wp,-MMD,$(STORE)/$*.dd $(CCPARAM) $(foreach INC,$(INCPATH),-I$(INC))\ 80 | $(foreach MACRO,$(MACROS),-D$(MACRO)) -c $< -o $@ 81 | @sed -e '1s/^\(.*\)$$/$(subst /,\/,$(dir $@))\1/' $(STORE)/$*.dd > $(STORE)/$*.d 82 | @rm -f $(STORE)/$*.dd 83 | 84 | # Empty rule to prevent problems when a header is deleted. 85 | %.hpp: ; 86 | 87 | # Cleans up the objects, .d files and executables. 88 | clean: 89 | @echo Making clean. 90 | @-rm -f $(foreach DIR,$(DIRS),$(STORE)/$(DIR)/*.d $(STORE)/$(DIR)/*.o) 91 | @-rm -f $(TARGET) 92 | 93 | # Backup the source files. 94 | backup: 95 | @-if [ ! -e .backup ]; then mkdir .backup; fi; 96 | @echo Creating backup. 97 | @zip .backup/backup_`date +%d-%m-%y_%H.%M`.zip $(SOURCE) $(HEADERS) $(EXTRA_FILES) 98 | 99 | # Create necessary directories 100 | dirs: 101 | @-if [ ! -e $(STORE) ]; then mkdir $(STORE); fi; 102 | @-$(foreach DIR,$(DIRS), if [ ! -e $(STORE)/$(DIR) ]; then mkdir $(STORE)/$(DIR); fi; ) 103 | 104 | # Create tags file 105 | tags: 106 | @etags $(foreach DIR, $(DIRS), $(DIR)/*.cpp $(DIR)/*.hpp) 107 | 108 | package: 109 | @echo Creating package unlikely-$(VERSION).zip 110 | @mkdir unlikely-$(VERSION) 111 | @cp $(PACKAGE_FILES) unlikely-$(VERSION) 112 | @zip -r unlikely-$(VERSION).zip unlikely-$(VERSION)/* 113 | @rm -r unlikely-$(VERSION) 114 | 115 | # Custom targets 116 | lib: $(LIBFILE) 117 | 118 | LIBOBJECTS = $(filter-out %main.o,$(OBJECTS)) 119 | 120 | $(LIBFILE): $(LIBOBJECTS) 121 | @echo Creating library. 122 | @$(AR) $@ $(LIBOBJECTS) 123 | 124 | # Installation 125 | install: $(TARGET) $(LIBFILE) 126 | @echo Installing Unlikely Scheme. 127 | @if [ ! -e $(PREFIX)/bin ]; then mkdir -p $(PREFIX)/bin; fi; 128 | @cp $(TARGET) $(PREFIX)/bin 129 | @if [ ! -e $(PREFIX)/lib ]; then mkdir -p $(PREFIX)/lib; fi; 130 | @cp $(LIBFILE) $(PREFIX)/lib 131 | @if [ ! -e $(PREFIX)/share ]; then mkdir -p $(PREFIX)/share; fi; 132 | @cp $(INITFILE) $(PREFIX)/share 133 | @if [ ! -e $(PREFIX)/include/uscheme ]; then mkdir -p $(PREFIX)/include/uscheme; fi; 134 | @cp $(HEADERS) $(PREFIX)/include/uscheme 135 | 136 | # Includes the .d files so it knows the exact dependencies for every 137 | # source. 138 | -include $(DFILES) 139 | -------------------------------------------------------------------------------- /symbol.cpp: -------------------------------------------------------------------------------- 1 | /* Copyright (c) 2004 Marijn Haverbeke 2 | * 3 | * This software is provided 'as-is', without any express or implied 4 | * warranty. In no event will the authors be held liable for any 5 | * damages arising from the use of this software. 6 | * 7 | * Permission is granted to anyone to use this software for any 8 | * purpose, including commercial applications, and to alter it and 9 | * redistribute it freely, subject to the following restrictions: 10 | * 11 | * 1. The origin of this software must not be misrepresented; you must 12 | * not claim that you wrote the original software. If you use this 13 | * software in a product, an acknowledgment in the product 14 | * documentation would be appreciated but is not required. 15 | * 16 | * 2. Altered source versions must be plainly marked as such, and must 17 | * not be misrepresented as being the original software. 18 | * 19 | * 3. This notice may not be removed or altered from any source 20 | * distribution. 21 | * 22 | * Marijn Haverbeke 23 | * marijn(at)haverbeke.nl 24 | */ 25 | 26 | #include 27 | #include 28 | #include "error.hpp" 29 | #include "symbol.hpp" 30 | #include "type.hpp" 31 | 32 | namespace uls{ 33 | 34 | namespace{ 35 | // Symbols consist of 10 bit (the lowest 10) of hash, and the rest 36 | // of the value is an ID that is used to distinguish the symbol from 37 | // other symbols with the same hash code. Symbols and strings can 38 | // both be converted to hash numbers this way, which makes both 39 | // symbols and their names useful keys for the hash table. 40 | const size_t table_size = 521; 41 | const size_t hash_width = 10, hash_mask = 1023; 42 | 43 | inline Symbol Make_Symbol(size_t hash, size_t id) 44 | { 45 | return hash + (id << hash_width); 46 | } 47 | inline size_t Symbol_Hash(Symbol sym) 48 | { 49 | return (sym & hash_mask); 50 | } 51 | inline size_t Symbol_ID(Symbol sym) 52 | { 53 | return (sym >> hash_width); 54 | } 55 | size_t Hash_String(const std::string& str) 56 | { 57 | size_t max = std::min(str.size(), static_cast(4)); 58 | size_t accum = 0; 59 | for (size_t i = 0; i != max; ++i) 60 | accum += (str[i] << i * byte_size); 61 | return accum % table_size; 62 | } 63 | 64 | class Symbol_Table 65 | { 66 | public: 67 | Symbol_Table(); 68 | ~Symbol_Table(); 69 | 70 | Symbol Get_Symbol(const std::string& str); 71 | Symbol Has_Symbol(const std::string& str) const; 72 | const std::string& Get_Name(Symbol s) const; 73 | 74 | private: 75 | struct Entry 76 | { 77 | Entry(size_t id, const std::string& name, Entry* next) 78 | : id(id), name(name), next(next) {} 79 | size_t id; 80 | std::string name; 81 | Entry* next; 82 | }; 83 | std::vector _table; 84 | }; 85 | 86 | Symbol_Table::Symbol_Table() 87 | : _table(table_size, NULL) 88 | {} 89 | 90 | Symbol_Table::~Symbol_Table() 91 | { 92 | for (size_t i = 0; i != table_size; ++i){ 93 | for (Entry* cur = _table[i]; cur != NULL;){ 94 | Entry* temp = cur; 95 | cur = cur->next; 96 | delete temp; 97 | } 98 | } 99 | } 100 | 101 | Symbol Symbol_Table::Get_Symbol(const std::string& str) 102 | { 103 | size_t hash = Hash_String(str); 104 | size_t id = 0; 105 | for (Entry* current = _table[hash]; current != NULL; current = current->next){ 106 | if (str == current->name){ 107 | id = current->id; 108 | break; 109 | } 110 | } 111 | if (id == 0){ 112 | Entry* front = _table[hash]; 113 | id = (front == NULL) ? 1 : front->id + 1; 114 | Entry* new_entry = new Entry(id, str, front); 115 | _table[hash] = new_entry; 116 | } 117 | 118 | return Make_Symbol(hash, id); 119 | } 120 | 121 | Symbol Symbol_Table::Has_Symbol(const std::string& str) const 122 | { 123 | size_t hash = Hash_String(str); 124 | size_t id = 0; 125 | for (Entry* current = _table[hash]; current != NULL; current = current->next){ 126 | if (str == current->name){ 127 | id = current->id; 128 | break; 129 | } 130 | } 131 | if (id == 0) 132 | return null_symbol; 133 | else 134 | return Make_Symbol(hash, id); 135 | } 136 | 137 | const std::string& Symbol_Table::Get_Name(Symbol s) const 138 | { 139 | const static std::string unnamed("unnamed symbol"); 140 | size_t hash = Symbol_Hash(s); 141 | if (hash >= table_size) 142 | return unnamed; 143 | size_t id = Symbol_ID(s); 144 | 145 | for (Entry* current = _table[hash]; current != NULL; current = current->next){ 146 | if (current->id == id) 147 | return current->name; 148 | } 149 | return unnamed; 150 | } 151 | 152 | // The exists only one Symbol_Table, and this function is how the 153 | // functions below access it. 154 | Symbol_Table& Get_Table() 155 | { 156 | static Symbol_Table table; 157 | return table; 158 | } 159 | } 160 | 161 | Symbol Get_Symbol(const std::string& word) 162 | { 163 | return Get_Table().Get_Symbol(word); 164 | } 165 | 166 | Symbol Find_Symbol(const std::string& word) 167 | { 168 | return Get_Table().Has_Symbol(word); 169 | } 170 | 171 | const std::string& Get_Symbol_Name(Symbol s) 172 | { 173 | return Get_Table().Get_Name(s); 174 | } 175 | 176 | } 177 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | Unlikely Scheme Readme 2 | ---------------------- 3 | (for version .45, October 7th 2004) 4 | 5 | * Introduction 6 | 7 | Unlikely Scheme is a small scheme interpreter. It is more or less R5RS 8 | compliant, although I am sure it deviates on some obscure points that 9 | I am unaware of. Still, most 'standard' scheme code should run on it. 10 | 11 | The thing this program is supposed to do better than all the other 12 | scheme implementations is embedding in C++ applications. I wrote it to 13 | provide scheme scripting capability for a graphical application, and 14 | some care was taken to make it fit nicely in an environment other than 15 | a stdin/stdout console. The overall C++ interface is quite clean I 16 | think, it makes use of the conveniences C++ offers (destructors, 17 | exceptions, overloading, etc). Exceptions are used to signal errors, 18 | so no scary longjmp-ing happens. A part of the interface that I'm 19 | still not happy with is the 'protecting' of scheme data from the 20 | garbage collector. I used a moving garbage collection method, so apart 21 | from having to protect data from being collected, any pointer-like 22 | data can become invalid when memory is allocated unless you protect 23 | it. This is not very convenient, any better solutions are welcome. 24 | 25 | The performance of the interpreter is 'not bad'. It is (heavily 26 | depending on the kind of benchmark you pick) about a factor 3 slower 27 | than spiffy implementations like mzscheme or scheme48. At any rate 28 | this is a work in progress, if you have any useful contributions I'd 29 | love to hear about them. 30 | 31 | * License 32 | 33 | This software is released under the zlib license. Basically you can 34 | use/copy/modify it however you like as long as you do not claim you 35 | wrote it and keep the license notice with it. See COPYING. 36 | 37 | * Installation 38 | 39 | I have (hopefully more or less up-to-date) MS Windows binaries hosted 40 | at the same place as the source. For unix systems compiling with the 41 | makefile that comes with the source should not be too hard. It needs 42 | GNU make, g++ and unix stuff to work though. On windows this can be 43 | done with cygwin and/or mingw. To build the binary like this you 44 | simply type 'make install' (or maybe gmake). This will build the 45 | binary (uscheme) and the libary. By default they are installed to 46 | /usr/local, with the header files in /usr/local/include/uscheme. To 47 | build a debug version use 'make TYPE=fast-debug'. With 'TYPE=debug' 48 | you get a debug version that collects garbage on every memory 49 | allocation. This is great for finding memory errors, but it is 50 | _really_ slow. 51 | 52 | I have not tried to compile on a lot of compilers yet but as far as I 53 | know I use standard C++ everywhere. Creating a project on your 54 | favorite IDE should not be hard. Compiling all the cpp files together 55 | creates the stand alone interpreter, and for the library you leave out 56 | main.cpp. 57 | 58 | * Programming Interface 59 | 60 | This is only a short summary because I am too lazy to write a good 61 | documentation for a beta whose interface will probably change anyway. 62 | But the headers ( if you installed with the 63 | makefile) are well commented and quite simple. 64 | 65 | Initializing an interpreter happens by creating an object of the type 66 | Interpreter. You can only have one of these alive at a time. You can 67 | then load in scheme files with 68 | 69 | void Load_File(const std::string& filename) 70 | 71 | And to evaluate a string use 72 | 73 | Cell Eval_String(const std::string& str, bool handle_errors) 74 | 75 | The second argument indicates whether exceptions should be let out or 76 | handled by the interpreter. The return value is the result of 77 | evaluating the string. 78 | 79 | That should allow you to write a trivial application. For more useful 80 | stuff you'll have to know that the basic scheme data objects have the 81 | type Cell in C++. Small objects are stuffed into a single 32-bit value 82 | (symbols, characters and small integers mostly), while for bigger 83 | objects this value is a pointer to memory where the object lives. 84 | These bigger objects are where the garbage collection trouble comes 85 | in. Whenever anything gets allocated (or garbage gets collected 86 | explicitly) stuff can move, and if you have pointer data in a raw Cell 87 | you can consider it invalid. To help this problem there is another 88 | type, MCell, which encapsulates a cell and makes sure that it does not 89 | get collected and that the pointer gets updated when it is moved. 90 | 91 | The most common way of extending scheme in C++ is by adding 92 | primitives. To make a primitive you make a function that 93 | a) Returns a Cell 94 | b) Has 0 - 8 Cells as arguments 95 | 96 | You can then make a binding for it in the default top-level 97 | environment with: 98 | 99 | template 100 | void Define_Primitive(const std::string& name, 101 | Function_Type function, bool var_arg) 102 | 103 | Var_arg indicates whether the last argument matches to one argument or 104 | the list of remaining arguments. The number of arguments is 105 | automatically deduced from the type of the function pointer. 106 | 107 | It is also possible to define new types, but for now you'll have to 108 | figure out how to do that yourself. (Hint: look at Make_Type and look 109 | how pairs and vectors and such are implemented). Scheme.hpp is full of 110 | other functions that you would expect in a scheme implementation (Car, 111 | Cons, Is_Number, and so on). I chose not to declare the functions that 112 | implement the primitives in the header file, since any of them that do 113 | anything generally useful are implemented in terms of another function 114 | that IS declared in the header. 115 | 116 | Marijn Haverbeke 117 | marijn(at)haverbeke.nl 118 | -------------------------------------------------------------------------------- /inputsplitter.cpp: -------------------------------------------------------------------------------- 1 | /* Copyright (c) 2004 Marijn Haverbeke 2 | * 3 | * This software is provided 'as-is', without any express or implied 4 | * warranty. In no event will the authors be held liable for any 5 | * damages arising from the use of this software. 6 | * 7 | * Permission is granted to anyone to use this software for any 8 | * purpose, including commercial applications, and to alter it and 9 | * redistribute it freely, subject to the following restrictions: 10 | * 11 | * 1. The origin of this software must not be misrepresented; you must 12 | * not claim that you wrote the original software. If you use this 13 | * software in a product, an acknowledgment in the product 14 | * documentation would be appreciated but is not required. 15 | * 16 | * 2. Altered source versions must be plainly marked as such, and must 17 | * not be misrepresented as being the original software. 18 | * 19 | * 3. This notice may not be removed or altered from any source 20 | * distribution. 21 | * 22 | * Marijn Haverbeke 23 | * marijn(at)haverbeke.nl 24 | */ 25 | 26 | #include "inputsplitter.hpp" 27 | #include "error.hpp" 28 | 29 | namespace uls{ 30 | 31 | String_Input_Splitter::String_Input_Splitter() 32 | : _in_string(false), 33 | _open_parens(0), 34 | _finished_part(0) 35 | {} 36 | 37 | const std::string& String_Input_Splitter::Current() 38 | { 39 | S_ASSERT(!_parts.empty()); 40 | return _parts.back(); 41 | } 42 | 43 | void String_Input_Splitter::Advance(bool allow_eof) 44 | { 45 | S_ASSERT(!_parts.empty()); 46 | _parts.pop_back(); 47 | 48 | --_finished_part; 49 | S_ASSERT(_finished_part >= 0); 50 | } 51 | 52 | namespace{ 53 | size_t String_End(const std::string& str, size_t string_start) 54 | { 55 | for (size_t i = string_start + 1; i < str.size(); ++i){ 56 | if (str[i] == '"' && !(i > 0 && str[i - 1] == '\\')) 57 | return i; 58 | } 59 | return str.size(); 60 | } 61 | 62 | bool Is_Delimiter(char c) 63 | { 64 | return Is_Whitespace(c) || c == '(' || c == ')' || c == ';' || c == '#' || c == '"' || c == '\'' || c == '`' || c == ','; 65 | } 66 | 67 | size_t Next_Delimiter(const std::string& str, size_t start) 68 | { 69 | bool escaped = false; 70 | for (size_t i = start + 1; i < str.size(); ++i){ 71 | char c = str[i]; 72 | if (!escaped){ 73 | if (Is_Delimiter(str[i])) 74 | return i; 75 | escaped = c == '\\'; 76 | } 77 | else{ 78 | escaped = false; 79 | } 80 | } 81 | return str.size(); 82 | } 83 | } 84 | 85 | void String_Input_Splitter::Add_Line(const std::string& str) 86 | { 87 | size_t pos = 0; 88 | if (_in_string){ 89 | pos = String_End(str, 0); 90 | if (pos == str.size()){ 91 | _unfinished = _unfinished + str; 92 | return; 93 | } 94 | else{ 95 | ++pos; 96 | Add_Part(_unfinished + std::string(str, 0, pos)); 97 | _in_string = false; 98 | } 99 | } 100 | while (pos < str.size()){ 101 | char c = str[pos]; 102 | if (Is_Whitespace(c)){ 103 | ++pos; 104 | } 105 | else if (c == '"'){ 106 | size_t end = String_End(str, pos); 107 | if (end == str.size()){ 108 | _unfinished = std::string(str, pos); 109 | _in_string = true; 110 | return; 111 | } 112 | else{ 113 | Add_Part(std::string(str, pos, end + 1 - pos)); 114 | pos = end + 1; 115 | } 116 | } 117 | else if (c == '#' && pos < str.size() && str[pos + 1] == '('){ 118 | pos += 2; 119 | ++_open_parens; 120 | Add_Part("#("); 121 | } 122 | else if (c == '('){ 123 | ++pos; 124 | ++_open_parens; 125 | Add_Part("("); 126 | } 127 | else if (c == ')'){ 128 | ++pos; 129 | --_open_parens; 130 | Add_Part(")"); 131 | } 132 | else if (c == ',' && pos < str.size() && str[pos + 1] == '@'){ 133 | Add_Part(",@", false); 134 | pos += 2; 135 | } 136 | else if (c == ',' || c == '`' || c == '\''){ 137 | Add_Part(std::string(1, c), false); 138 | ++pos; 139 | } 140 | else if (c == ';'){ 141 | return; 142 | } 143 | else{ 144 | size_t end = Next_Delimiter(str, pos); 145 | Add_Part(std::string(str, pos, end - pos)); 146 | pos = end; 147 | } 148 | } 149 | } 150 | 151 | void String_Input_Splitter::Add_Part(const std::string& part, bool can_be_finished) 152 | { 153 | _parts.push_front(part); 154 | if (can_be_finished && _open_parens < 1) 155 | _finished_part = _parts.size(); 156 | } 157 | 158 | void String_Input_Splitter::Reset() 159 | { 160 | _parts.clear(); 161 | _open_parens = 0; 162 | _in_string = false; 163 | _finished_part = 0; 164 | } 165 | 166 | bool String_Input_Splitter::Full_Expression() 167 | { 168 | return _finished_part != 0; 169 | } 170 | 171 | Stream_Input_Splitter::Stream_Input_Splitter(std::istream& stream) 172 | : _stream(stream), 173 | _lines_read(0), 174 | _allow_eof(true) 175 | {} 176 | 177 | const std::string& Stream_Input_Splitter::Current() 178 | { 179 | if (_current.empty()) 180 | Read_Part(); 181 | return _current; 182 | } 183 | 184 | void Stream_Input_Splitter::Advance(bool allow_eof) 185 | { 186 | _current = ""; 187 | _allow_eof = allow_eof; 188 | } 189 | 190 | void Stream_Input_Splitter::Read_Part() 191 | { 192 | S_CHECK(_allow_eof || !_stream.eof(), "unfinished expression at end of file"); 193 | 194 | char c = 0; 195 | if (!_stream.eof()){ 196 | c = Get_Char(); 197 | while (Is_Whitespace(c) || c == ';'){ 198 | if (c == ';'){ 199 | while (!_stream.eof() && c != '\n') 200 | c = Get_Char(); 201 | } 202 | else{ 203 | c = Get_Char(); 204 | } 205 | } 206 | } 207 | 208 | if (_stream.eof()){ 209 | _current = "#\\eof"; 210 | } 211 | else if (c == '"'){ 212 | bool escaped = false; 213 | _current = "\""; 214 | while(true){ 215 | c = Get_Char(); 216 | S_CHECK(!_stream.eof(), "unfinished string constant"); 217 | _current += c; 218 | if (!escaped){ 219 | if (c == '"') 220 | break; 221 | escaped = c == '\\'; 222 | } 223 | else{ 224 | escaped = false; 225 | } 226 | } 227 | } 228 | else if (c == ',' && _stream.peek() == '@'){ 229 | Get_Char(); 230 | _current = ",@"; 231 | } 232 | else if (c == '#' && _stream.peek() == '('){ 233 | Get_Char(); 234 | _current = "#("; 235 | } 236 | else if (c == '(' || c == ')' || c == ',' || c == '`' || c == '\''){ 237 | _current = std::string(1, c); 238 | } 239 | else{ 240 | _current = std::string(1, c); 241 | bool escaped = false; 242 | while(true){ 243 | int next = _stream.peek(); 244 | if (next == std::istream::traits_type::eof()) 245 | break; 246 | if (!escaped){ 247 | if (Is_Delimiter(next)) 248 | break; 249 | escaped = next == '\\'; 250 | } 251 | else{ 252 | escaped = false; 253 | } 254 | 255 | Get_Char(); 256 | _current += static_cast(next); 257 | } 258 | } 259 | 260 | S_ASSERT(!_current.empty()); 261 | } 262 | 263 | } 264 | -------------------------------------------------------------------------------- /bignum.cpp: -------------------------------------------------------------------------------- 1 | /* Copyright (c) 2004 Marijn Haverbeke 2 | * 3 | * This software is provided 'as-is', without any express or implied 4 | * warranty. In no event will the authors be held liable for any 5 | * damages arising from the use of this software. 6 | * 7 | * Permission is granted to anyone to use this software for any 8 | * purpose, including commercial applications, and to alter it and 9 | * redistribute it freely, subject to the following restrictions: 10 | * 11 | * 1. The origin of this software must not be misrepresented; you must 12 | * not claim that you wrote the original software. If you use this 13 | * software in a product, an acknowledgment in the product 14 | * documentation would be appreciated but is not required. 15 | * 16 | * 2. Altered source versions must be plainly marked as such, and must 17 | * not be misrepresented as being the original software. 18 | * 19 | * 3. This notice may not be removed or altered from any source 20 | * distribution. 21 | * 22 | * Marijn Haverbeke 23 | * marijn(at)haverbeke.nl 24 | */ 25 | 26 | #include 27 | #include 28 | 29 | #include "bignum.hpp" 30 | #include "error.hpp" 31 | 32 | namespace uls{ 33 | 34 | const size_t bignum_buffer_size = 400; 35 | 36 | class Array_Manager 37 | { 38 | public: 39 | Array_Manager(); 40 | ~Array_Manager(); 41 | 42 | digit* Allocate(int size); 43 | 44 | private: 45 | void Clear_Temp_Buffers(); 46 | 47 | std::auto_ptr _buffer; 48 | std::vector _temp_buffers; 49 | size_t _used, _desired_size, _current_size; 50 | }; 51 | 52 | Array_Manager::Array_Manager() 53 | : _buffer(new digit[bignum_buffer_size]), 54 | _used(0), 55 | _desired_size(bignum_buffer_size), 56 | _current_size(bignum_buffer_size) 57 | {} 58 | 59 | Array_Manager::~Array_Manager() 60 | { 61 | Clear_Temp_Buffers(); 62 | } 63 | 64 | digit* Array_Manager::Allocate(int size) 65 | { 66 | digit* retval = _buffer.get() + _used; 67 | _used += size; 68 | if (size > 0 && _used >= _current_size){ 69 | retval = new digit[size]; 70 | _temp_buffers.push_back(retval); 71 | _desired_size = _used; 72 | } 73 | else if (_used == 0){ 74 | Clear_Temp_Buffers(); 75 | if (_desired_size > _current_size){ 76 | _buffer = std::auto_ptr(new digit[_desired_size]); 77 | _current_size = _desired_size; 78 | } 79 | } 80 | return retval; 81 | } 82 | 83 | void Array_Manager::Clear_Temp_Buffers() 84 | { 85 | while (!_temp_buffers.empty()){ 86 | delete[] _temp_buffers.back(); 87 | _temp_buffers.pop_back(); 88 | } 89 | } 90 | 91 | digit* Allocate_Array(int size) 92 | { 93 | static Array_Manager manager; 94 | return manager.Allocate(size); 95 | } 96 | 97 | bool Array_Zero(const digit* one, size_t s_one) 98 | { 99 | for (size_t i = 0; i != s_one; ++i){ 100 | if (one[i] != 0) 101 | return false; 102 | } 103 | return true; 104 | } 105 | 106 | bool Array_Smaller(const digit* one, size_t s_one, const digit* two, size_t s_two) 107 | { 108 | int s_big, s_small; 109 | const digit* big; 110 | if (s_one < s_two){ 111 | s_big = s_two - 1; 112 | s_small = s_one - 1; 113 | big = two; 114 | } 115 | else{ 116 | s_big = s_one - 1; 117 | s_small = s_two - 1; 118 | big = one; 119 | } 120 | for (int i = s_big; i != s_small; --i){ 121 | if (big[i] != 0) 122 | return (s_one < s_two); 123 | } 124 | for (int i = s_small; i != -1; --i){ 125 | if (one[i] != two[i]) 126 | return one[i] < two[i]; 127 | } 128 | return false; 129 | } 130 | 131 | void Add_Arrays(const digit* one, size_t s_one, const digit* two, size_t s_two, digit* result, size_t s_result) 132 | { 133 | size_t carry = 0; 134 | for (size_t i = 0; i != s_result; ++i){ 135 | int64 hold = carry; 136 | if (i < s_one) 137 | hold += one[i]; 138 | if (i < s_two) 139 | hold += two[i]; 140 | 141 | carry = (hold >> digit_size); 142 | result[i] = hold; 143 | } 144 | S_ASSERT(carry == 0); 145 | } 146 | 147 | void Subtract_Arrays(const digit* one, size_t s_one, const digit* two, size_t s_two, digit* result, size_t s_result) 148 | { 149 | int carry = 0; 150 | for (size_t i = 0; i != s_result; ++i){ 151 | int64 hold = carry; 152 | if (i < s_one) 153 | hold += one[i]; 154 | if (i < s_two) 155 | hold -= two[i]; 156 | 157 | if (hold < 0){ 158 | hold += digit_radix; 159 | carry = -1; 160 | } 161 | else{ 162 | carry = 0; 163 | } 164 | result[i] = hold; 165 | } 166 | S_ASSERT(carry == 0); 167 | } 168 | 169 | // Some of this bignum code is quite mind-boggling. There is a bug in 170 | // it that causes it not to work on mac systems (something to do with 171 | // the fact that those machines store bytes in a different order I 172 | // assume). I have to admit I can't quite figure it all out anymore. 173 | 174 | void Multiply_Arrays(const digit* one, size_t s_one, const digit* two, size_t s_two, digit* result, size_t s_result) 175 | { 176 | for (size_t i = 0; i != s_result; ++i) 177 | result[i] = 0; 178 | 179 | for (size_t i = 0; i != s_two; ++i){ 180 | size_t carry = 0; 181 | for (size_t j = 0; j < s_one || carry != 0; ++j){ 182 | uint64 hold = (j < s_one) ? static_cast(one[j]) * two[i] : 0; 183 | hold += carry; 184 | carry = (hold >> digit_size); 185 | 186 | size_t carry2 = hold; 187 | size_t pos = i + j; 188 | do { 189 | S_ASSERT(pos < s_result); 190 | uint64 hold2 = result[pos]; 191 | hold2 += carry2; 192 | carry2 = (hold2 >> digit_size); 193 | result[pos] = hold2; 194 | ++pos; 195 | } while (carry2 != 0); 196 | } 197 | S_ASSERT(carry == 0); 198 | } 199 | } 200 | 201 | void Divide_Arrays(const digit* one, size_t s_one, const digit* two, size_t s_two, digit* quotient, size_t s_quotient, digit* remain, size_t s_remain) 202 | { 203 | for (size_t i = 0; i != s_remain; ++i){ 204 | if (i < s_one) 205 | remain[i] = one[i]; 206 | else 207 | remain[i] = 0; 208 | } 209 | for (size_t i = 0; i != s_quotient; ++i) 210 | quotient[i] = 0; 211 | 212 | while (!Array_Smaller(remain, s_remain, two, s_two)){ 213 | size_t hidig_remain = s_remain - 1; 214 | while (remain[hidig_remain] == 0) --hidig_remain; 215 | size_t hidig_two = s_two - 1; 216 | while (two[hidig_two] == 0) --hidig_two; 217 | size_t shift = hidig_remain - hidig_two; 218 | uint64 val_remain = remain[hidig_remain]; 219 | uint64 val_two = two[hidig_two]; 220 | if (hidig_remain != 0){ 221 | val_remain = digit_radix * val_remain + remain[hidig_remain - 1]; 222 | --shift; 223 | } 224 | uint64 guess = (val_remain - 1) / val_two; 225 | if (guess > digit_mask){ 226 | guess = (guess >> digit_size); 227 | ++shift; 228 | } 229 | if (guess == 0) 230 | guess = 1; 231 | for (size_t j = 0; j != s_two; ++j){ 232 | int64 carry = guess * two[j]; 233 | size_t pos = j + shift; 234 | do { 235 | S_ASSERT(pos < s_remain); 236 | int64 hold = remain[pos]; 237 | hold -= carry; 238 | carry = 0; 239 | if (hold < 0){ 240 | carry = ((-hold) >> digit_size) + 1; 241 | hold = -((-hold) & digit_mask) + digit_radix; 242 | } 243 | remain[pos] = hold; 244 | ++pos; 245 | } while (carry != 0); 246 | } 247 | uint64 carry = guess, pos = shift; 248 | do { 249 | S_ASSERT(pos < s_quotient); 250 | uint64 hold = quotient[pos]; 251 | hold += carry; 252 | carry = (hold >> digit_size); 253 | quotient[pos] = hold; 254 | ++pos; 255 | } while (carry != 0); 256 | } 257 | } 258 | 259 | } 260 | -------------------------------------------------------------------------------- /number_io.cpp: -------------------------------------------------------------------------------- 1 | /* Copyright (c) 2004 Marijn Haverbeke 2 | * 3 | * This software is provided 'as-is', without any express or implied 4 | * warranty. In no event will the authors be held liable for any 5 | * damages arising from the use of this software. 6 | * 7 | * Permission is granted to anyone to use this software for any 8 | * purpose, including commercial applications, and to alter it and 9 | * redistribute it freely, subject to the following restrictions: 10 | * 11 | * 1. The origin of this software must not be misrepresented; you must 12 | * not claim that you wrote the original software. If you use this 13 | * software in a product, an acknowledgment in the product 14 | * documentation would be appreciated but is not required. 15 | * 16 | * 2. Altered source versions must be plainly marked as such, and must 17 | * not be misrepresented as being the original software. 18 | * 19 | * 3. This notice may not be removed or altered from any source 20 | * distribution. 21 | * 22 | * Marijn Haverbeke 23 | * marijn(at)haverbeke.nl 24 | */ 25 | 26 | #include 27 | #include 28 | 29 | #include "number_io.hpp" 30 | #include "error.hpp" 31 | 32 | // TODO : maybe add #-stuff to number reading? 33 | 34 | namespace uls{ 35 | 36 | const char* Digit_Table() 37 | { 38 | const static char table[] = {'0', '1', '2', '3', '4', '5', '6', '7', '8', '9', 'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j'}; 39 | return table; 40 | } 41 | const char zero_digit = '0', minus_digit = '-'; 42 | 43 | int Digit_To_Int(char dig, size_t radix = 10) 44 | { 45 | int retval = -1; 46 | if (dig >= '0' && dig < '0' + 10) 47 | retval = dig - '0'; 48 | else if (dig >= 'a' && dig < 'a' + 10) 49 | retval = dig - 'a' + 10; 50 | else if (dig >= 'A' && dig < 'A' + 10) 51 | retval = dig - 'A' + 10; 52 | S_CHECK(retval != -1 && retval < static_cast(radix), "invalid digit in numeric constant: " + std::string(1, dig)); 53 | return retval; 54 | } 55 | 56 | double String_To_Double(const std::string& str, size_t radix) 57 | { 58 | double number = 0; 59 | S_CHECK(str.size() > 0, "invalid floating-point constant: " + str); 60 | 61 | size_t dot = str.find('.'); 62 | size_t exp = (radix < 15) ? str.find_first_of("eE") : str.find('E'); 63 | S_CHECK(dot != str.npos || exp != str.npos, "invalid floating-point constant: " + str); 64 | bool negative = str[0] == minus_digit, read_something = false; 65 | size_t pos = negative ? 1 : 0; 66 | if (str[0] == '+') 67 | pos = 1; 68 | size_t end = dot == str.npos ? exp : dot; 69 | 70 | if (pos != end){ 71 | read_something = true; 72 | int64 integer = String_To_Int(std::string(str, pos, end - pos), radix); 73 | number += integer; 74 | } 75 | pos = end + 1; 76 | 77 | if (dot != str.npos){ 78 | end = exp == str.npos ? str.size() : exp; 79 | if (pos != end){ 80 | read_something = true; 81 | double fraction = static_cast(String_To_Int(std::string(str, pos, end - pos), radix)); 82 | size_t frac_width = end - pos; 83 | for (size_t i = frac_width; i != 0; --i) 84 | fraction /= radix; 85 | number += fraction; 86 | } 87 | pos = end + 1; 88 | } 89 | if (exp != str.npos){ 90 | int64 expo = String_To_Int(std::string(str, pos), radix); 91 | while (expo < 0){ 92 | number /= radix; 93 | ++expo; 94 | } 95 | while (expo > 0){ 96 | number *= radix; 97 | --expo; 98 | } 99 | } 100 | if (negative) 101 | number = -number; 102 | 103 | S_CHECK(read_something, "empty numeric string"); 104 | return number; 105 | } 106 | 107 | int64 String_To_Int(const std::string& str, size_t radix) 108 | { 109 | S_CHECK(str.size() != 0, "empty numeric string"); 110 | bool negative = str[0] == minus_digit; 111 | int64 number = 0, factor = 1; 112 | int end = negative ? 0 : -1; 113 | if (str[0] == '+') 114 | end = 0; 115 | S_CHECK(static_cast(str.size()) - 1 != end, "empty numeric string"); 116 | 117 | for (int i = str.size() - 1; i != end; --i){ 118 | number += factor * Digit_To_Int(str[i], radix); 119 | factor *= radix; 120 | } 121 | if (negative) 122 | number = -number; 123 | 124 | return number; 125 | } 126 | 127 | bool String_To_Array(const std::string& str, std::vector& array, size_t radix) 128 | { 129 | S_CHECK(str.size() != 0, "empty numeric string"); 130 | bool negative = str[0] == minus_digit; 131 | uint64 radix_factor = 0; 132 | for (uint64 counter = radix; counter < digit_radix; counter *= radix) 133 | ++radix_factor; 134 | 135 | size_t size = (str.size() / radix_factor) + 1; 136 | array.resize(size); 137 | Array_Buffer product(size), factor(size); 138 | for (size_t i = 1; i != size; ++i) 139 | factor.data[i] = 0; 140 | factor.data[0] = 1; 141 | digit radix_digit = radix; 142 | 143 | int end = negative ? 0 : -1; 144 | if (str[0] == '+') 145 | end = 0; 146 | S_CHECK(static_cast(str.size()) - 1 != end, "empty numeric string"); 147 | for (int i = str.size() - 1; i != end; --i){ 148 | digit current = Digit_To_Int(str[i], radix); 149 | 150 | Multiply_Arrays(¤t, 1, factor.data, size, product.data, size); 151 | Add_Arrays(product.data, size, &array[0], size, &array[0], size); 152 | Multiply_Arrays(&radix_digit, 1, factor.data, size, product.data, size); 153 | std::copy(product.data, product.data + size, factor.data); 154 | } 155 | 156 | return negative; 157 | } 158 | 159 | void Split_To_Digits(std::vector& buffer, uint64 number, size_t radix) 160 | { 161 | const char* dig = Digit_Table(); 162 | 163 | while (number != 0){ 164 | buffer.push_back(dig[number % radix]); 165 | number /= radix; 166 | } 167 | } 168 | 169 | void Write_Double(std::ostream& stream, double value, size_t radix) 170 | { 171 | const int frac_width = 16; 172 | 173 | if (value == 0){ 174 | stream << zero_digit << '.' << zero_digit; 175 | return; 176 | } 177 | if (value < 0){ 178 | stream << minus_digit; 179 | value = -value; 180 | } 181 | 182 | int exp = 0; 183 | while (value >= radix){ 184 | value /= radix; 185 | ++exp; 186 | } 187 | while (value < 1){ 188 | value *= radix; 189 | --exp; 190 | } 191 | 192 | size_t full = static_cast(value); 193 | double fraction = value - static_cast(full); 194 | 195 | S_ASSERT(full < radix); 196 | stream << Digit_Table()[full]; 197 | stream << '.'; 198 | 199 | uint64 i_frac = static_cast(fraction * std::pow(static_cast(radix), frac_width) + .5); 200 | if (i_frac == 0){ 201 | stream << zero_digit; 202 | } 203 | else{ 204 | std::vector buffer; 205 | Split_To_Digits(buffer, i_frac, radix); 206 | while (buffer.size() != static_cast(frac_width)) 207 | buffer.push_back(zero_digit); 208 | size_t last = 0; 209 | while(buffer[last] == zero_digit) 210 | ++last; 211 | for (size_t i = buffer.size(); i != last; --i) 212 | stream << buffer[i - 1]; 213 | } 214 | 215 | if (exp != 0){ 216 | char exp_char = (radix < 15) ? 'e' : 'E'; 217 | stream << exp_char; 218 | Write_Int(stream, exp, radix); 219 | } 220 | } 221 | 222 | void Write_Int(std::ostream& stream, int value, size_t radix) 223 | { 224 | if (value == 0){ 225 | stream << zero_digit; 226 | return; 227 | } 228 | if (value < 0){ 229 | stream << minus_digit; 230 | value = -value; 231 | } 232 | 233 | std::vector buffer; 234 | Split_To_Digits(buffer, value, radix); 235 | 236 | for (size_t i = buffer.size(); i != 0; --i) 237 | stream << buffer[i - 1]; 238 | } 239 | 240 | void Write_Array(std::ostream& stream, const digit* array, size_t size, bool negative, size_t radix) 241 | { 242 | if (negative) 243 | stream << minus_digit; 244 | 245 | Array_Buffer quotient(size), remainder(size), value(size); 246 | std::copy(array, array + size, value.data); 247 | 248 | if (Array_Zero(array, size)){ 249 | stream << zero_digit; 250 | return; 251 | } 252 | 253 | digit factor = radix, factor_width = 1; 254 | while (true){ 255 | uint64 temp = static_cast(factor) * radix; 256 | if (temp >= digit_radix) 257 | break; 258 | factor = temp; 259 | ++factor_width; 260 | } 261 | 262 | std::vector buffer; 263 | size_t width = 0; 264 | while (!Array_Zero(value.data, value.size)){ 265 | Divide_Arrays(value.data, size, &factor, 1, quotient.data, size, remainder.data, size); 266 | Split_To_Digits(buffer, remainder.data[0], radix); 267 | width += factor_width; 268 | while (buffer.size() != width) 269 | buffer.push_back(zero_digit); 270 | std::copy(quotient.data, quotient.data + size, value.data); 271 | } 272 | 273 | size_t end = buffer.size(); 274 | while (buffer[end - 1] == zero_digit) 275 | --end; 276 | for (size_t i = end; i != 0; --i) 277 | stream << buffer[i - 1]; 278 | } 279 | 280 | } 281 | -------------------------------------------------------------------------------- /uscheme-init.scm: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2004 Marijn Haverbeke 2 | ;; 3 | ;; This software is provided 'as-is', without any express or implied 4 | ;; warranty. In no event will the authors be held liable for any 5 | ;; damages arising from the use of this software. 6 | ;; 7 | ;; Permission is granted to anyone to use this software for any 8 | ;; purpose, including commercial applications, and to alter it and 9 | ;; redistribute it freely, subject to the following restrictions: 10 | ;; 11 | ;; 1. The origin of this software must not be misrepresented; you must 12 | ;; not claim that you wrote the original software. If you use this 13 | ;; software in a product, an acknowledgment in the product 14 | ;; documentation would be appreciated but is not required. 15 | ;; 16 | ;; 2. Altered source versions must be plainly marked as such, and must 17 | ;; not be misrepresented as being the original software. 18 | ;; 19 | ;; 3. This notice may not be removed or altered from any source 20 | ;; distribution. 21 | ;; 22 | ;; Marijn Haverbeke 23 | ;; marijn(at)haverbeke.nl 24 | 25 | ; Init file for Unlikely Scheme 26 | 27 | ; By default this is called at the start of every session, it 28 | ; initializes functions and syntax. Not everything in here is very 29 | ; neat or efficient yet. 30 | 31 | ; Standard macros. Mostly just stolen from the 5th Revised Report. 32 | 33 | (define-syntax let 34 | (syntax-rules () 35 | ((_ ((name val) ...) body1 body2 ...) 36 | ((lambda (name ...) body1 body2 ...) val ...)) 37 | ((_ tag ((name val) ...) body1 body2 ...) 38 | ((letrec ((tag (lambda (name ...) body1 body2 ...))) tag) 39 | val ...)))) 40 | 41 | (define-syntax and 42 | (syntax-rules () 43 | ((_) #t) 44 | ((_ test) test) 45 | ((_ test1 test2 ...) 46 | (if test1 (and test2 ...) #f)))) 47 | 48 | (define-syntax or 49 | (syntax-rules () 50 | ((_) #f) 51 | ((_ test) test) 52 | ((_ test1 test2 ...) 53 | (let ((or-temp-var test1)) 54 | (if or-temp-var or-temp-var (or test2 ...)))))) 55 | 56 | (define-syntax cond 57 | (syntax-rules (else =>) 58 | ((_ (else result1 result2 ...)) 59 | (begin result1 result2 ...)) 60 | ((_ (test => result)) 61 | (let ((temp test)) 62 | (if temp (result temp)))) 63 | ((_ (test => result) clause1 clause2 ...) 64 | (let ((temp test)) 65 | (if temp 66 | (result temp) 67 | (cond clause1 clause2 ...)))) 68 | ((_ (test)) test) 69 | ((_ (test) clause1 clause2 ...) 70 | (let ((temp test)) 71 | (if temp 72 | temp 73 | (cond clause1 clause2 ...)))) 74 | ((_ (test result1 result2 ...)) 75 | (if test (begin result1 result2 ...))) 76 | ((_ (test result1 result2 ...) 77 | clause1 clause2 ...) 78 | (if test 79 | (begin result1 result2 ...) 80 | (cond clause1 clause2 ...))))) 81 | 82 | (define-syntax case 83 | (syntax-rules (else) 84 | ((_ (key ...) clauses ...) 85 | (let ((atom-key (key ...))) 86 | (case atom-key clauses ...))) 87 | ((_ key (else result1 result2 ...)) 88 | (begin result1 result2 ...)) 89 | ((_ key ((atoms ...) result1 result2 ...)) 90 | (if (memv key '(atoms ...)) 91 | (begin result1 result2 ...))) 92 | ((_ key ((atoms ...) result1 result2 ...) 93 | clause clauses ...) 94 | (if (memv key '(atoms ...)) 95 | (begin result1 result2 ...) 96 | (case key clause clauses ...))))) 97 | 98 | (define-syntax let* 99 | (syntax-rules () 100 | ((_ () body1 body2 ...) 101 | ((lambda () body1 body2 ...))) 102 | ((_ ((name1 val1) (name2 val2) ...) 103 | body1 body2 ...) 104 | (let ((name1 val1)) 105 | (let* ((name2 val2) ...) 106 | body1 body2 ...))))) 107 | 108 | (define-syntax letrec 109 | (syntax-rules () 110 | ((_ ((var1 init1) ...) body ...) 111 | (letrec #\G (var1 ...) () ((var1 init1) ...) body ...)) 112 | ((_ #\G () (temp1 ...) ((var1 init1) ...) body ...) 113 | (let ((var1 #v) ...) 114 | (let ((temp1 init1) ...) 115 | (set! var1 temp1) 116 | ... 117 | (begin 118 | body ...)))) 119 | ((_ #\G (x y ...) (temp ...) ((var1 init1) ...) body ...) 120 | (letrec #\G (y ...) (newtemp temp ...) ((var1 init1) ...) body ...)))) 121 | 122 | (define-syntax do 123 | (syntax-rules () 124 | ((_ ((var init step ...) ...) 125 | (test expr ...) 126 | command ...) 127 | (letrec 128 | ((loop 129 | (lambda (var ...) 130 | (if test 131 | (begin #v expr ...) 132 | (begin command ... 133 | (loop (do #\S var step ...) ...)))))) 134 | (loop init ...))) 135 | ((_ #\S x) x) 136 | ((_ #\S x y) y))) 137 | 138 | ; From here stuff has to be initialized to report_env instead of null_env 139 | 'goto-report-env 140 | 141 | ; Check to see whether init was already loaded (the error handling and 142 | ; dynamic-wind goes haywire if it is loaded twice) 143 | (if (defined? '*init-loaded* (impl:current-env)) 144 | (raise "init file already loaded")) 145 | 146 | ; Apply is implemented using the #%as_arguments instruction. It is 147 | ; possible to write closures using instructions. The error checking on 148 | ; instructions is minimal though, stuff is likely to crash if you make 149 | ; a mistake. 150 | (define (apply function . args) 151 | (define (paste-args list) 152 | (if (null? (cdr list)) 153 | (car list) 154 | (cons (car list) (paste-args (cdr list))))) 155 | (define simple-apply (make-closure #(#%deref_env (0 . 1) #%as_arguments #%deref_env (0 . 0) #%tail) 2)) 156 | (simple-apply function (paste-args args))) 157 | 158 | ; impl:current-env is a special form that compiles to the interaction 159 | ; environment. 160 | (define (interaction-environment) 161 | (impl:current-env)) 162 | 163 | (define (eval expression environment) 164 | ((compile expression environment 'top-level))) 165 | 166 | ; Dynamic-wind system taken from http://www.cs.hmc.edu/~fleck/envision/scheme48/meeting/node7.html 167 | 168 | (define call-with-current-continuation #f) 169 | (define dynamic-wind #f) 170 | 171 | ((lambda () 172 | (define *wind-state* (cons #f '())) 173 | 174 | (define (wind-reroot! there) 175 | (if (not (eq? *wind-state* there)) 176 | (begin 177 | (wind-reroot! (cdr there)) 178 | (let ((before (caar there)) (after (cdar there))) 179 | (set-car! *wind-state* (cons after before)) 180 | (set-cdr! *wind-state* there) 181 | (set-car! there #f) 182 | (set-cdr! there '()) 183 | (set! *wind-state* there) 184 | (before))))) 185 | 186 | (define simple-call-with-current-continuation 187 | (make-closure 188 | #(#%grow_env 2 #%current_continuation #%set_env (0 . 1) #%setup_arg_list 1 #%literal #(#(#%deref_env (1 . 1) #%set_continuation 189 | #%deref_env (0 . 0) #%return) 1 continuation-wrapper) #%finish_lambda #%add_arg 0 #%deref_env (0 . 0) #%tail) 1)) 190 | 191 | (define (local-call-with-current-continuation proc) 192 | (let ((here *wind-state*)) 193 | (simple-call-with-current-continuation (lambda (cont) 194 | (proc (lambda (result) 195 | (wind-reroot! here) 196 | (cont result))))))) 197 | (define (local-dynamic-wind before during after) 198 | (let ((here *wind-state*)) 199 | (wind-reroot! (cons (cons before after) here)) 200 | (let ((result (during))) 201 | (wind-reroot! here) 202 | result))) 203 | 204 | (set! call-with-current-continuation local-call-with-current-continuation) 205 | (set! dynamic-wind local-dynamic-wind))) 206 | 207 | (define call/cc call-with-current-continuation) 208 | 209 | ; This is called when a quasiquoted expression is evaluated. 210 | (define (impl:fill-in-quasiquoted expression . values) 211 | (let loop ((expression expression) (depth 0)) 212 | (cond ((pair? expression) 213 | (cond ((eq? (car expression) 'unquote) 214 | (if (= depth 0) 215 | (let ((temp (car values))) 216 | (set! values (cdr values)) 217 | temp) 218 | (list 'unquote (loop (cadr expression) (- depth 1))))) 219 | ((eq? (car expression) 'quasiquote) 220 | (list 'quasiquote (loop (cadr expression) (+ depth 1)))) 221 | ((and (pair? (car expression)) (eq? (caar expression) 'unquote-splicing)) 222 | (if (= depth 0) 223 | (let ((temp (car values))) 224 | (set! values (cdr values)) 225 | (append temp (loop (cdr expression) depth))) 226 | (cons (list 'unquote-splicing (loop (cadar expression) (- depth 1))) (loop (cdr expression) depth)))) 227 | (else (cons (loop (car expression) depth) (loop (cdr expression) depth))))) 228 | ((vector? expression) 229 | (list->vector (loop (vector->list expression) depth))) 230 | (else expression)))) 231 | 232 | ; Promises 233 | 234 | (define (make-promise proc) 235 | (let ((result-ready? #f) (result #f)) 236 | (lambda () 237 | (if result-ready? 238 | result 239 | (let ((x (proc))) 240 | (if result-ready? 241 | result 242 | (begin (set! result-ready? #t) 243 | (set! result x) 244 | result))))))) 245 | 246 | (define-syntax delay 247 | (syntax-rules () 248 | ((delay expression) 249 | (make-promise (lambda () expression))))) 250 | 251 | (define (force object) 252 | (object)) 253 | 254 | ; Numbers 255 | 256 | (define (max x . nums) 257 | (let loop ((current x) (lst nums) (exact #t)) 258 | (cond ((null? lst) 259 | (if exact current (exact->inexact current))) 260 | ((_> current (car lst)) 261 | (loop current (cdr lst) (and exact (exact? (car lst))))) 262 | (else 263 | (loop (car lst) (cdr lst) (and exact (exact? current))))))) 264 | (define (min x . nums) 265 | (let loop ((current x) (lst nums) (exact #t)) 266 | (cond ((null? lst) (if exact current (exact->inexact current))) 267 | ((_< current (car lst)) 268 | (loop current (cdr lst) (and exact (exact? (car lst))))) 269 | (else 270 | (loop (car lst) (cdr lst) (and exact (exact? current))))))) 271 | (define (= one two . lst) 272 | (cond ((null? lst) (_= one two)) 273 | ((_= one two) (apply = two lst)) 274 | (else #f))) 275 | (define (< one two . lst) 276 | (cond ((null? lst) (_< one two)) 277 | ((_< one two) (apply < two lst)) 278 | (else #f))) 279 | (define (> one two . lst) 280 | (cond ((null? lst) (_> one two)) 281 | ((_> one two) (apply > two lst)) 282 | (else #f))) 283 | (define (<= one two . lst) 284 | (cond ((null? lst) (_<= one two)) 285 | ((_<= one two) (apply <= two lst)) 286 | (else #f))) 287 | (define (>= one two . lst) 288 | (cond ((null? lst) (_>= one two)) 289 | ((_>= one two) (apply >= two lst)) 290 | (else #f))) 291 | 292 | (define (+ . lst) 293 | (if (null? lst) 294 | 0 295 | (let add-loop ((cur (car lst)) (rest (cdr lst))) 296 | (if (null? rest) 297 | cur 298 | (add-loop (_+ cur (car rest)) (cdr rest)))))) 299 | (define (* . lst) 300 | (if (null? lst) 301 | 1 302 | (let mult-loop ((cur (car lst)) (rest (cdr lst))) 303 | (if (null? rest) 304 | cur 305 | (mult-loop (_* cur (car rest)) (cdr rest)))))) 306 | (define (- first . lst) 307 | (if (null? lst) 308 | (_- 0 first) 309 | (let minus-loop ((cur first) (rest lst)) 310 | (if (null? rest) 311 | cur 312 | (minus-loop (_- cur (car rest)) (cdr rest)))))) 313 | (define (/ first . lst) 314 | (if (null? lst) 315 | (_/ 1 first) 316 | (let div-loop ((cur first) (rest lst)) 317 | (if (null? rest) 318 | cur 319 | (div-loop (_/ cur (car rest)) (cdr rest)))))) 320 | 321 | (define (zero? num) 322 | (_= 0 num)) 323 | (define (positive? num) 324 | (_> num 0)) 325 | (define (negative? num) 326 | (_< num 0)) 327 | (define (odd? num) 328 | (_= (modulo num 2) 1)) 329 | (define (even? num) 330 | (_= (modulo num 2) 0)) 331 | 332 | (define (abs num) 333 | (if (negative? num) 334 | (- num) 335 | num)) 336 | 337 | (define (gcd . num) 338 | (define (internal-gcd a b) 339 | (if (_= a 0) 340 | b 341 | (gcd (remainder b a) a))) 342 | (cond 343 | ((null? num) 0) 344 | ((null? (cdr num)) (car num)) 345 | (else 346 | (let ((a (car num)) (b (apply gcd (cdr num)))) 347 | (internal-gcd (min (abs a) (abs b)) (max (abs a) (abs b))))))) 348 | 349 | (define (lcm . num) 350 | (define (internal-lcm a b) 351 | (* (quotient a (gcd a b)) b)) 352 | (cond 353 | ((null? num) 1) 354 | ((null? (cdr num)) (abs (car num))) 355 | (else (internal-lcm (abs (car num)) (apply lcm (cdr num)))))) 356 | 357 | ; Booleans 358 | 359 | (define (not x) (if x #f #t)) 360 | (define (boolean? x) (or (eq? x #t) (eq? x #f))) 361 | 362 | ; Pairs 363 | 364 | (define (caar x) (car (car x))) 365 | (define (cadr x) (car (cdr x))) 366 | (define (cdar x) (cdr (car x))) 367 | (define (cddr x) (cdr (cdr x))) 368 | (define (caaar x) (car (car (car x)))) 369 | (define (caadr x) (car (car (cdr x)))) 370 | (define (cadar x) (car (cdr (car x)))) 371 | (define (caddr x) (car (cdr (cdr x)))) 372 | (define (cdaar x) (cdr (car (car x)))) 373 | (define (cdadr x) (cdr (car (cdr x)))) 374 | (define (cddar x) (cdr (cdr (car x)))) 375 | (define (cdddr x) (cdr (cdr (cdr x)))) 376 | (define (caaaar x) (car (car (car (car x))))) 377 | (define (caaadr x) (car (car (car (cdr x))))) 378 | (define (caadar x) (car (car (cdr (car x))))) 379 | (define (caaddr x) (car (car (cdr (cdr x))))) 380 | (define (cadaar x) (car (cdr (car (car x))))) 381 | (define (cadadr x) (car (cdr (car (cdr x))))) 382 | (define (caddar x) (car (cdr (cdr (car x))))) 383 | (define (cadddr x) (car (cdr (cdr (cdr x))))) 384 | (define (cdaaar x) (cdr (car (car (car x))))) 385 | (define (cdaadr x) (cdr (car (car (cdr x))))) 386 | (define (cdadar x) (cdr (car (cdr (car x))))) 387 | (define (cdaddr x) (cdr (car (cdr (cdr x))))) 388 | (define (cddaar x) (cdr (cdr (car (car x))))) 389 | (define (cddadr x) (cdr (cdr (car (cdr x))))) 390 | (define (cdddar x) (cdr (cdr (cdr (car x))))) 391 | (define (cddddr x) (cdr (cdr (cdr (cdr x))))) 392 | 393 | (define (list . x) x) 394 | (define (length x) (if (null? x) 0 (+ 1 (length (cdr x))))) 395 | 396 | (define (append . x) 397 | (define (add-to-list new-part old-part) 398 | (if (null? new-part) 399 | old-part 400 | (add-to-list (cdr new-part) (cons (car new-part) old-part)))) 401 | (let loop ((remain x) (result '())) 402 | (cond ((null? remain) '()) 403 | ((null? (cdr remain)) 404 | (if (null? result) 405 | (car remain) 406 | (let ((reversed (reverse-in-place result))) 407 | (set-cdr! result (car remain)) 408 | reversed))) 409 | (else (loop (cdr remain) (add-to-list (car remain) result)))))) 410 | 411 | (define (reverse lst) 412 | (define (reverse-helper lst result) 413 | (if (null? lst) 414 | result 415 | (reverse-helper (cdr lst) (cons (car lst) result)))) 416 | (reverse-helper lst '())) 417 | 418 | (define (reverse-in-place lst) 419 | (let loop ((remain lst) (result '())) 420 | (if (null? remain) 421 | result 422 | (let ((new-remain (cdr remain))) 423 | (set-cdr! remain result) 424 | (loop new-remain remain))))) 425 | 426 | (define (list-tail lst n) 427 | (if (_= 0 n) 428 | lst 429 | (list-tail (cdr lst) (- n 1)))) 430 | 431 | (define (list-ref lst n) 432 | (car (list-tail lst n))) 433 | 434 | (define (memq value lst) 435 | (cond ((null? lst) #f) 436 | ((eq? value (car lst)) lst) 437 | (else (memq value (cdr lst))))) 438 | (define memv memq) 439 | 440 | (define (member value lst) 441 | (cond ((null? lst) #f) 442 | ((equal? value (car lst)) lst) 443 | (else (member value (cdr lst))))) 444 | 445 | (define (assq value lst) 446 | (cond ((null? lst) #f) 447 | ((eq? value (caar lst)) (car lst)) 448 | (else (assq value (cdr lst))))) 449 | (define assv assq) 450 | 451 | (define (assoc value lst) 452 | (cond ((null? lst) #f) 453 | ((equal? value (caar lst)) (car lst)) 454 | (else (assoc value (cdr lst))))) 455 | 456 | ; Characters 457 | 458 | (define (char=? one two . lst) 459 | (cond ((null? lst) (char_=? one two)) 460 | ((char_=? one two) (apply char=? two list)) 461 | (else #f))) 462 | (define (char? one two . lst) 467 | (cond ((null? lst) (char_>? one two)) 468 | ((char_>? one two) (apply char>? two list)) 469 | (else #f))) 470 | (define (char<=? one two . lst) 471 | (cond ((null? lst) (char_<=? one two)) 472 | ((char_<=? one two) (apply char<=? two list)) 473 | (else #f))) 474 | (define (char>=? one two . lst) 475 | (cond ((null? lst) (char_>=? one two)) 476 | ((char_>=? one two) (apply char>=? two list)) 477 | (else #f))) 478 | 479 | (define (char-ci=? char1 char2 . lst) (apply char=? (char-downcase char1) (char-downcase char2) (map char-downcase lst))) 480 | (define (char-ci? char1 char2 . lst) (apply char>? (char-downcase char1) (char-downcase char2) (map char-downcase lst))) 482 | (define (char-ci<=? char1 char2 . lst) (apply char<=? (char-downcase char1) (char-downcase char2) (map char-downcase lst))) 483 | (define (char-ci>=? char1 char2 . lst) (apply char>=? (char-downcase char1) (char-downcase char2) (map char-downcase lst))) 484 | 485 | (define (char-upper-case? char) (and (char-alphabetic? char) (eq? char (char-upcase char)))) 486 | (define (char-lower-case? char) (and (char-alphabetic? char) (eq? char (char-downcase char)))) 487 | 488 | ; Strings 489 | 490 | (define (string . chars) 491 | (define size (length chars)) 492 | (define str (make-string size)) 493 | (let loop ((n 0) (list chars)) 494 | (cond ((null? list) str) 495 | (else (string-set! str n (car list)) 496 | (loop (+ n 1) (cdr list)))))) 497 | 498 | (define (generic-string-compare-equal str1 str2 predicate) 499 | (define length (string-length str1)) 500 | (define (compare-strings n) 501 | (cond ((_= n length) #t) 502 | ((predicate (string-ref str1 n) (string-ref str2 n)) 503 | (compare-strings (+ n 1))) 504 | (else #f))) 505 | (and (_= length (string-length str2)) (compare-strings 0))) 506 | 507 | (define (string=? str1 str2) (generic-string-compare-equal str1 str2 eq?)) 508 | (define (string-ci=? str1 str2) (generic-string-compare-equal str1 str2 char-ci=?)) 509 | 510 | (define (generic-string-compare-diff str1 str2 char-eq char-diff length-pred) 511 | (define length-1 (string-length str1)) 512 | (define length-2 (string-length str2)) 513 | (define length-min (min length-1 length-2)) 514 | (define (compare-strings n) 515 | (cond ((_= n length-min) (length-pred length-1 length-2)) 516 | ((char-eq (string-ref str1 n) (string-ref str2 n)) (compare-strings (+ n 1))) 517 | (else (char-diff (string-ref str1 n) (string-ref str2 n))))) 518 | (compare-strings 0)) 519 | 520 | (define (string? str1 str2) (generic-string-compare-diff str1 str2 char_=? char_>? >)) 522 | (define (string<=? str1 str2) (generic-string-compare-diff str1 str2 char_=? char_<=? <=)) 523 | (define (string>=? str1 str2) (generic-string-compare-diff str1 str2 char_=? char_>=? >=)) 524 | 525 | (define (string-ci? str1 str2) (generic-string-compare-diff str1 str2 char-ci=? char-ci>? >)) 527 | (define (string-ci<=? str1 str2) (generic-string-compare-diff str1 str2 char-ci=? char-ci<=? <=)) 528 | (define (string-ci>=? str1 str2) (generic-string-compare-diff str1 str2 char-ci=? char-ci>=? >=)) 529 | 530 | (define (substring str a b) 531 | (define new-str (make-string (- b a))) 532 | (define (copy n) 533 | (cond ((_= n b) new-str) 534 | (else (string-set! new-str (- n a) (string-ref str n)) 535 | (copy (+ n 1))))) 536 | (copy a)) 537 | 538 | (define (string-append . args) 539 | (if (null? args) 540 | "" 541 | (let loop ((str (car args)) (lst (cdr args))) 542 | (if (null? lst) 543 | str 544 | (begin 545 | (define length-1 (string-length str)) 546 | (define length-2 (string-length (car lst))) 547 | (define total-length (+ length-1 length-2)) 548 | (define new-str (make-string total-length)) 549 | (let loop ((n 0)) 550 | (cond ((_= n length-1) #t) 551 | (else (string-set! new-str n (string-ref str n)) 552 | (loop (+ n 1))))) 553 | (let loop ((n length-1)) 554 | (cond ((_= n total-length) #t) 555 | (else (string-set! new-str n (string-ref (car lst) (- n length-1))) 556 | (loop (+ n 1))))) 557 | (apply string-append new-str (cdr lst))))))) 558 | 559 | (define (string->list str) 560 | (define length (string-length str)) 561 | (let loop ((n 0)) 562 | (if (_= n length) 563 | '() 564 | (cons (string-ref str n) (loop (+ n 1)))))) 565 | 566 | (define (list->string lst) 567 | (apply string lst)) 568 | 569 | (define (string-copy str) 570 | (substring str 0 (string-length str))) 571 | 572 | (define (string-fill! str value) 573 | (define size (string-length str)) 574 | (let loop ((n 0)) 575 | (cond ((_= n size) #v) 576 | (else (string-set! str n value) 577 | (loop (+ n 1)))))) 578 | 579 | ; Vectors 580 | 581 | (define (vector . lst) 582 | (define size (length lst)) 583 | (define vec (make-vector size)) 584 | (let loop ((n 0) (list lst)) 585 | (cond ((null? list) vec) 586 | (else (vector-set! vec n (car list)) 587 | (loop (+ n 1) (cdr list)))))) 588 | 589 | (define (vector=? vec1 vec2) 590 | (define (compare-vectors n) 591 | (cond ((_< n 0) #t) 592 | ((equal? (vector-ref vec1 n) (vector-ref vec2 n)) 593 | (compare-vectors (- n 1))) 594 | (else #f))) 595 | (and (_= (vector-length vec1) (vector-length vec2)) 596 | (compare-vectors (- (vector-length vec1) 1)))) 597 | 598 | (define (vector->list vec) 599 | (define length (vector-length vec)) 600 | (let loop ((n 0)) 601 | (if (_= n length) 602 | '() 603 | (cons (vector-ref vec n) (loop (+ n 1)))))) 604 | 605 | (define (list->vector lst) 606 | (apply vector lst)) 607 | 608 | (define (vector-fill! vec value) 609 | (define size (vector-length vec)) 610 | (let loop ((n 0)) 611 | (cond ((_= n size) #v) 612 | (else (vector-set! vec n value) 613 | (loop (+ n 1)))))) 614 | 615 | ; Misc 616 | 617 | (define (_map proc list) 618 | (if (null? list) 619 | '() 620 | (cons (proc (car list)) (_map proc (cdr list))))) 621 | 622 | (define (map proc . lists) 623 | (if (null? (car lists)) 624 | '() 625 | (let () 626 | (define cars (_map car lists)) 627 | (define cdrs (_map cdr lists)) 628 | (cons (apply proc cars) (apply map proc cdrs))))) 629 | 630 | (define (for-each proc . lists) 631 | (if (null? (car lists)) 632 | #v 633 | (let () 634 | (define cars (_map car lists)) 635 | (define cdrs (_map cdr lists)) 636 | (apply proc cars) 637 | (apply for-each proc cdrs)))) 638 | 639 | (define (filter predicate list) 640 | (cond ((null? list) '()) 641 | ((predicate (car list)) (cons (car list) (filter predicate (cdr list)))) 642 | (else (filter predicate (cdr list))))) 643 | 644 | (define (accumulate operation value list) 645 | (if (null? list) 646 | value 647 | (accumulate operation (operation value (car list)) (cdr list)))) 648 | 649 | ; multiple return values 650 | 651 | (define values #f) 652 | (define call-with-values #f) 653 | (let ((unique "")) 654 | (set! values (lambda vals 655 | (if (and (not (null? vals)) (null? (cdr vals))) 656 | (car vals) 657 | (cons unique vals)))) 658 | (set! call-with-values (lambda (producer receiver) 659 | (define returned (producer)) 660 | (if (and (pair? returned) (eq? (car returned) unique)) 661 | (apply receiver (cdr returned)) 662 | (receiver returned))))) 663 | 664 | ; I/O 665 | 666 | ; When called on a closed file reopen-...put-file will reopen the file 667 | ; and restore the position to what it was before it got closed. 668 | (define (call-with-input-file string proc) 669 | (let ((file (open-input-file string))) 670 | (dynamic-wind 671 | (lambda () (reopen-input-file file)) 672 | (lambda () (proc file)) 673 | (lambda () (close-input-port file))))) 674 | (define (call-with-output-file string proc) 675 | (let ((file (open-output-file string))) 676 | (dynamic-wind 677 | (lambda () (reopen-output-file file)) 678 | (lambda () (proc file)) 679 | (lambda () (close-output-port file))))) 680 | 681 | ; Interaction 682 | 683 | ; The error handling is not great yet - because of proper tail 684 | ; recursion and the unnamed-ness of most closures the stack traces are 685 | ; almost worthless. But the system is flexible and can be used to do 686 | ; most kinds of error handling. When something goes wrong the virtual 687 | ; machine is reset and impl:handle-error is called, which calls the 688 | ; top error handler on the impl:error handler stack. You can use 689 | ; continuations to return to some state after an error, if you don't 690 | ; the scheme process will finish after the handler returns. 691 | ; Use push-error-handler and pop-error-handler to change the current 692 | ; error handler. If show-instructions is called with a non-false value 693 | ; the instruction vector of the current function will be shown when an 694 | ; error occurs. 695 | (define (print-error message stack) 696 | (define (translate-function-name name) 697 | (if name 698 | name 699 | "unnamed function")) 700 | (if (not (null? stack)) 701 | (begin 702 | (display "In function:")(newline) 703 | (let loop ((lst stack)) 704 | (if (not (null? lst)) 705 | (begin 706 | (display " ")(display (translate-function-name (car lst)))(newline) 707 | (loop (cdr lst))))))) 708 | (display "Error: ")(display message)(newline)) 709 | (define impl:*error-handler* 710 | (list print-error)) 711 | (define impl:show-instructions #f) 712 | (define (show-instructions option) 713 | (set! impl:show-instructions option)) 714 | (define (impl:handle-error message stack cur-instruction instructions) 715 | (if impl:show-instructions 716 | (begin 717 | (display "In code:")(newline) 718 | (let loop ((n 0)) 719 | (if (_< n (vector-length instructions)) 720 | (begin 721 | (if (_= n cur-instruction) 722 | (display "* ") 723 | (display " ")) 724 | (display n)(display " ")(display (vector-ref instructions n))(newline) 725 | (loop (+ n 1))))))) 726 | ((car impl:*error-handler*) message stack)) 727 | 728 | (define (push-error-handler handler) 729 | (set! impl:*error-handler* (cons handler impl:*error-handler*))) 730 | (define (pop-error-handler) 731 | (if (null? (cdr impl:*error-handler*)) 732 | (raise "can not pop off last error handler") 733 | (set! impl:*error-handler* (cdr impl:*error-handler*)))) 734 | (define (current-error-handler) 735 | (car impl:*error-handler*)) 736 | 737 | ; Load a file. 738 | (define (_load filename environment) 739 | (define file (open-input-file filename)) 740 | (dynamic-wind 741 | (lambda () 742 | (reopen-input-file file) 743 | (let ((old-handler (current-error-handler))) 744 | (push-error-handler 745 | (lambda (message stack) 746 | (display "In file '")(display filename)(display "' near line ") 747 | (display (input-port-line file))(display ":")(newline) 748 | (old-handler message stack))))) 749 | (lambda () 750 | (let loop ((expr (read file))) 751 | (if (not (eof-object? expr)) 752 | (begin 753 | (eval expr environment) 754 | (loop (read file)))))) 755 | (lambda () 756 | (pop-error-handler) 757 | (close-input-port file)))) 758 | 759 | ; Read-eval-print-loop 760 | (define (run-repl environment) 761 | (define continuation #f) 762 | (define (local-handler message stack) 763 | (print-error message (reverse (cddr (reverse stack)))) 764 | (continuation #f)) 765 | (define (try thunk) 766 | (dynamic-wind 767 | (lambda () (push-error-handler local-handler)) 768 | thunk 769 | (lambda () (pop-error-handler)))) 770 | (call/cc (lambda (c) (set! continuation c))) 771 | (let loop () 772 | (display "> ") 773 | (let ((val (try read))) 774 | (if (not (eof-object? val)) 775 | (let ((result (try (lambda () (eval val environment))))) 776 | (if (not (eq? result #v)) 777 | (begin 778 | (write result) 779 | (newline))) 780 | (loop)))))) 781 | 782 | (define *init-loaded* #t) 783 | -------------------------------------------------------------------------------- /scheme.hpp: -------------------------------------------------------------------------------- 1 | /* Copyright (c) 2004 Marijn Haverbeke 2 | * 3 | * This software is provided 'as-is', without any express or implied 4 | * warranty. In no event will the authors be held liable for any 5 | * damages arising from the use of this software. 6 | * 7 | * Permission is granted to anyone to use this software for any 8 | * purpose, including commercial applications, and to alter it and 9 | * redistribute it freely, subject to the following restrictions: 10 | * 11 | * 1. The origin of this software must not be misrepresented; you must 12 | * not claim that you wrote the original software. If you use this 13 | * software in a product, an acknowledgment in the product 14 | * documentation would be appreciated but is not required. 15 | * 16 | * 2. Altered source versions must be plainly marked as such, and must 17 | * not be misrepresented as being the original software. 18 | * 19 | * 3. This notice may not be removed or altered from any source 20 | * distribution. 21 | * 22 | * Marijn Haverbeke 23 | * marijn(at)haverbeke.nl 24 | */ 25 | 26 | #ifndef SCHEME_HPP 27 | #define SCHEME_HPP 28 | 29 | #include 30 | #include 31 | #include 32 | #include 33 | #include 34 | #include 35 | 36 | #include "type.hpp" 37 | #include "noncopyable.hpp" 38 | // Various error reporting things. 39 | #include "error.hpp" 40 | // Used to split input into tokens. 41 | #include "inputsplitter.hpp" 42 | // Associate strings with numbers. 43 | #include "symbol.hpp" 44 | 45 | namespace uls{ 46 | 47 | // ,CELL 48 | 49 | // These are a bunch of patterns used to determine the type of 50 | // non-pointer cell types. The top bits of the cell indicate the type. 51 | // When the top bit is 1 it is an integer, when the top two bits are 0 52 | // it is a pointer, etc. 53 | 54 | // 1 bit patterns 55 | const uintptr_t int_pattern = 1; 56 | // 2 bit patterns 57 | const uintptr_t compound_pattern = 0; 58 | const uintptr_t fourbit_pattern = 2; 59 | // 4 bit patterns 60 | const uintptr_t symbol_pattern = 2; 61 | const uintptr_t temp_name_pattern = 6; 62 | const uintptr_t instruction_pattern = 10; 63 | const uintptr_t sixbit_pattern = 14; 64 | // 6-bit patterns 65 | const uintptr_t char_pattern = 14; 66 | const uintptr_t instuction_pattern = 30; 67 | const uintptr_t form_pattern = 46; 68 | const uintptr_t special_pattern = 62; 69 | 70 | // Some cells have their values defined right here in the enum. These 71 | // are the cells with special values and the fixnums 0 and 1 (it is 72 | // convenient to have those available like this). 73 | // 74 | // The invalid cell is used for a few different purposes, the most 75 | // important purpose is to indicate a value that has not been defined 76 | // yet. User code should not be able to create invalid cells, and 77 | // primitives should never return them. Having invalid cells running 78 | // around in user code will lead to weird results (most likely strange 79 | // errors about a variable being used before it is defined). 80 | typedef uintptr_t Cell; 81 | const Cell false_cell = ((1 << 6) | special_pattern); 82 | const Cell true_cell = ((2 << 6) | special_pattern); 83 | const Cell null_cell = ((3 << 6) | special_pattern); 84 | const Cell void_cell = ((4 << 6) | special_pattern); 85 | const Cell invalid_cell = ((5 << 6) | special_pattern); 86 | const Cell eof_cell = ((256 << 6) | char_pattern); 87 | const Cell zero_cell = int_pattern; 88 | const Cell one_cell = (1 << 1) | int_pattern; 89 | 90 | // Some helper functions for encoding and extracting values with the 91 | // top 4 or 6 bits used as type identification. 92 | inline uintptr_t Extract_Fourbit(Cell cell){ 93 | return cell >> 4; 94 | } 95 | inline Cell Encode_Fourbit(uintptr_t value, uintptr_t pattern){ 96 | return (value << 4) | pattern; 97 | } 98 | inline bool Match_Fourbit(Cell cell, uintptr_t pattern){ 99 | return (cell & 15) == pattern; 100 | } 101 | inline uintptr_t Extract_Sixbit(Cell cell){ 102 | return cell >> 6; 103 | } 104 | inline Cell Encode_Sixbit(uintptr_t value, uintptr_t pattern){ 105 | return (value << 6) | pattern; 106 | } 107 | inline bool Match_Sixbit(Cell cell, uintptr_t pattern){ 108 | return (cell & 63) == pattern; 109 | } 110 | 111 | // ,SPECIALS 112 | 113 | inline bool Is_Special(Cell cell) 114 | { 115 | return Match_Sixbit(cell, special_pattern); 116 | } 117 | 118 | // Convenience function to make a scheme-boolean out of a c boolean. 119 | inline Cell Make_Bool(bool value) 120 | { 121 | return value ? true_cell : false_cell; 122 | } 123 | 124 | // ,CELLTYPE 125 | 126 | // Cell types. A cell type is an 8 bit value identifying a compound 127 | // cell type. Non-compound cell types are identified by their patterns 128 | // (see above). All user-defined types are compound. A cell type 129 | // always has a write function associated with it to convert cells of 130 | // that type to text. 131 | typedef byte Cell_Type; 132 | const Cell_Type 133 | pair_type = 0, 134 | vector_type = 1, 135 | string_type = 2, 136 | closure_type = 3, 137 | primitive_type = 4, 138 | continuation_type = 5, 139 | inport_type = 6, 140 | outport_type = 7, 141 | rational_type = 8, 142 | real_type = 9, 143 | bignum_type = 10, 144 | macro_type = 11, 145 | simple_macro_type = 12, 146 | renamed_symbol_type = 13, 147 | namespace_type = 14, 148 | moved_cell_type = 15, // used by GC 149 | available_type = 16; 150 | 151 | // New types can be created with the Make_Type function. It is up to 152 | // the user code to keep track of this value and pass it to 153 | // Allocate_Cell when creating cells of this type. The write function 154 | // will be invoked when a cell of that type is written, displayed or 155 | // converted to a string in some other way. The third argument 156 | // indicates whether display or write was used, currently only strings 157 | // and characters write differently when display is true. 158 | 159 | #ifdef WITH_DESTRUCTORS 160 | typedef void (*Destroy_Function)(Cell cell); 161 | #endif 162 | typedef void (*Write_Function)(Cell cell, std::ostream& str, bool display); 163 | Cell_Type Make_Type(Write_Function write 164 | #ifdef WITH_DESTRUCTORS 165 | , Destroy_Function destroy = NULL 166 | #endif 167 | ); 168 | 169 | // ,CELLINFO 170 | 171 | // Used to tell the memory manager which part of a struct contains 172 | // cells, and which part contains other data. Starting from the least 173 | // significant bit, every bit describes a 32-bit part of the cell 174 | // data. 1 means it is a cell and must be examined when collecting 175 | // garbage, 0 means other data. The default mask for Allocate_Cell has 176 | // all bits set to 1, which means all fields are cells. Only the first 177 | // 8 fields can be specified like this. The rest is assumed to be 178 | // non-cell data unless all bits were 1, in which case everything is 179 | // cell data. 180 | typedef byte Pointer_Mask; 181 | 182 | // This is the header for a memory block used by a cell. The top two 183 | // are only used by the memory manager, type can be looked at by all 184 | // code (use the Get_Type function), and data contains the data for 185 | // the cell. 186 | struct Cell_Info 187 | { 188 | unsigned short size; 189 | Pointer_Mask mask; 190 | Cell_Type type; 191 | Cell data[1]; 192 | }; 193 | 194 | inline bool Is_Compound(Cell cell) 195 | { 196 | return (reinterpret_cast(cell) & 3) == 0; 197 | } 198 | 199 | inline Cell_Info& Compound_Info(Cell cell) 200 | { 201 | S_ASSERT(Is_Compound(cell)); 202 | return *reinterpret_cast(cell); 203 | } 204 | 205 | // Get a reference to the guts of a compound cell represented as a 206 | // certain type. Make sure you are actually using the right type with 207 | // the right kind of cell. 208 | template 209 | inline Data& Extract(const Cell cell) 210 | { 211 | return *reinterpret_cast(Compound_Info(cell).data); 212 | } 213 | 214 | // Get the type of a compound cell. Does not work on non-compound 215 | // cells! 216 | inline Cell_Type Get_Type(Cell cell) 217 | { 218 | return Compound_Info(cell).type; 219 | } 220 | 221 | // ,MEMMANAGER 222 | 223 | // The memory manager. Every interpreter has one of these. They are 224 | // used to allocate cells and they take care of the garbage 225 | // collection. 226 | class Mem_Manager: public noncopyable 227 | { 228 | public: 229 | Mem_Manager(size_t block_size = 500000); 230 | ~Mem_Manager(); 231 | 232 | // Allocate a cell, you might want to consider using the free 233 | // function Allocate_Cell if you know exactly how big the cell has 234 | // to be. This can trigger garbage collection. 235 | Cell Allocate(size_t size, Cell_Type type, Pointer_Mask mask = max_byte); 236 | 237 | // Discard all cells that are not pointed to by the content of 238 | // MCells and MStacks 239 | void Collect_Garbage(); 240 | 241 | // Just for debugging, checks whether a cell was missed in the last collection 242 | bool Is_Valid(Cell cell) 243 | { 244 | return !Is_Compound(cell) || Is_In_Block(cell, _live_block); 245 | } 246 | 247 | // These are used by MCell and MStack to protect their contents from 248 | // being collected. You are advised to use those classes instead of 249 | // using these functions directly. 250 | void Push_Marked(Cell* cell) 251 | { 252 | _marked.push_back(cell); 253 | } 254 | void Pop_Marked(Cell* cell) 255 | { 256 | if(_marked.back() == cell) 257 | _marked.pop_back(); 258 | else 259 | Smart_Pop_Marked(cell); 260 | } 261 | void Push_Stack(std::vector& stack) 262 | { 263 | _stacks.push_back(&stack); 264 | } 265 | void Pop_Stack() 266 | { 267 | _stacks.pop_back(); 268 | } 269 | 270 | private: 271 | void Move_Cell(Cell* cell); 272 | bool Is_In_Block(Cell cell, size_t* block) const; 273 | void Smart_Pop_Marked(Cell* cell); 274 | #ifdef WITH_DESTRUCTORS 275 | friend class Interpreter; 276 | void Call_Destructors(size_t old_block_position); 277 | void Call_All_Destructors(); 278 | #endif 279 | 280 | const size_t _block_size; 281 | size_t _block_position, _cell_header_size; 282 | size_t* _live_block, * _dead_block; 283 | 284 | std::vector _marked; 285 | std::vector*> _stacks; 286 | }; 287 | 288 | // Points to the memory manager if one is alive. You are encouraged to 289 | // just stay away from this pointer, since the top-level Allocate 290 | // functions supply a perfectly good way to allocate stuff. 291 | extern Mem_Manager* mp_; 292 | 293 | // MCell is used to contain one cell (objects of this class can be 294 | // implicitly converted from and to cells) and protect it from being 295 | // garbage collected. 296 | class MCell 297 | { 298 | public: 299 | MCell(Cell cell = null_cell) 300 | : _cell(cell) 301 | { 302 | mp_->Push_Marked(&_cell); 303 | } 304 | MCell(const MCell& other) 305 | : _cell(other._cell) 306 | { 307 | mp_->Push_Marked(&_cell); 308 | } 309 | inline ~MCell() 310 | { 311 | mp_->Pop_Marked(&_cell); 312 | } 313 | 314 | operator Cell&() {return _cell;} 315 | operator Cell() const{return _cell;} 316 | void operator=(Cell cell){_cell = cell;} 317 | void operator=(const MCell& mcell){_cell = mcell._cell;} 318 | 319 | private: 320 | Cell _cell; 321 | }; 322 | 323 | // MStack is like MCell but instead it protects a whole stack of 324 | // cells. Has a std::vector-like interface. You must not allocate 325 | // these as function statics or on the heap, they rely on being 326 | // destructed in the same order they were created. 327 | class MStack 328 | { 329 | public: 330 | MStack(){mp_->Push_Stack(_cells);} 331 | explicit MStack(size_t size) : _cells(size, null_cell){mp_->Push_Stack(_cells);} 332 | ~MStack(){mp_->Pop_Stack();} 333 | 334 | Cell& operator[](size_t n){return _cells[n];} 335 | Cell operator[](size_t n) const{return _cells[n];} 336 | void Push(Cell cell){_cells.push_back(cell);} 337 | Cell Pop(){Cell temp = _cells.back(); _cells.pop_back(); return temp;} 338 | bool Empty() const{return _cells.empty();} 339 | size_t Size() const{return _cells.size();} 340 | Cell& Back(){return _cells.back();} 341 | void Clear(){_cells.clear();} 342 | 343 | private: 344 | std::vector _cells; 345 | }; 346 | 347 | // ,TYPE MANAGER 348 | 349 | // Associates write functions with cell types. Just use Make_Type and 350 | // ignore this class. 351 | class Type_Manager: public noncopyable 352 | { 353 | public: 354 | Type_Manager(); 355 | Cell_Type Make_Type(Write_Function write 356 | #ifdef WITH_DESTRUCTORS 357 | , Destroy_Function destroy 358 | #endif 359 | ); 360 | Write_Function Get_Function(Cell_Type type){ 361 | S_ASSERT(type < _functions.size()); 362 | S_ASSERT(_functions[type] != NULL); 363 | return _functions[type]; 364 | } 365 | #ifdef WITH_DESTRUCTORS 366 | Destroy_Function Get_Destructor(Cell_Type type){ 367 | S_ASSERT(type < _destructors.size()); 368 | return _destructors[type]; 369 | } 370 | #endif 371 | 372 | private: 373 | std::vector _functions; 374 | #ifdef WITH_DESTRUCTORS 375 | std::vector _destructors; 376 | #endif 377 | Cell_Type _current; 378 | }; 379 | 380 | 381 | // ,INTERPRETER 382 | 383 | // This is what you create an instance of to start working with 384 | // scheme. Everything is public, and the only member function is the 385 | // constructor. 386 | // 387 | // The argument to the constructor gives the amount of kilobytes a 388 | // memory block must contain. The memory allocated by the mem manager 389 | // is twice this, because of the garbage collection method used. 390 | // 391 | // Messing with the variables in this struct should be rather safe. 392 | // You can call functions on the mem_manager and type_manager if you 393 | // must, change the standard input and output, messing with the 394 | // environments is probably a bad idea. 395 | struct Interpreter 396 | { 397 | explicit Interpreter(size_t memory = 2000); 398 | ~Interpreter(); 399 | 400 | Type_Manager type_manager; 401 | Mem_Manager mem_manager; 402 | 403 | MCell null_env, report_env, work_env; 404 | MCell input, output; 405 | }; 406 | 407 | // Pointer to a live Interpreter if one exists. Don't touch. 408 | extern Interpreter* ip_; 409 | 410 | // Convenient ways of allocating a cell. Use the template argument of 411 | // Allocate_Cell to specify what kind of data you want to store in the 412 | // cell (and then get access to that with Extract after it has 413 | // been allocated). 414 | inline Cell Allocate(size_t size, Cell_Type type, Pointer_Mask mask = max_byte) 415 | { 416 | return mp_->Allocate(size, type, mask); 417 | } 418 | template 419 | inline Cell Allocate_Cell(Cell_Type type, Pointer_Mask mask = max_byte) 420 | { 421 | return Allocate(sizeof(Data), type, mask); 422 | } 423 | 424 | // ,FIXNUM 425 | 426 | // Fixnums range from -max_fixnum to +max_fixnum 427 | const uintptr_t max_fixnum = (max_int >> 2); 428 | 429 | inline bool Is_Fixnum(Cell cell) 430 | { 431 | return (cell & 1) == int_pattern; 432 | } 433 | inline Cell Make_Fixnum(int value) 434 | { 435 | S_ASSERT(std::abs(value) < max_fixnum); 436 | return (value << 1) | int_pattern; 437 | } 438 | inline int Fixnum_Value(Cell cell) 439 | { 440 | S_ASSERT(Is_Fixnum(cell)); 441 | uintptr_t bits = cell >> 1; 442 | // This is needed to restore the sign, it basically takes the 443 | // almost-most-significant bit and copies it to the most significant 444 | // bit (which got trampled by the shifting) 445 | bits |= ((bits & (1 << (sizeof(int) * byte_size - 2))) << 1); 446 | return reinterpret_cast(bits); 447 | } 448 | 449 | // ,BIGNUM 450 | // Bignums internally contain: 451 | // - a sign 452 | // - a size 453 | // - a series of 32-bit values that make up the digits of the number in 454 | // radix 2^32 455 | 456 | inline bool Is_Bignum(Cell cell) 457 | { 458 | return Is_Compound(cell) && Get_Type(cell) == bignum_type; 459 | } 460 | Cell Make_Bignum(int64 value); 461 | 462 | // ,INTEGER 463 | 464 | inline bool Is_Integer(Cell cell) 465 | { 466 | return Is_Fixnum(cell) || Is_Bignum(cell); 467 | } 468 | inline Cell Make_Integer(int64 value) 469 | { 470 | uint64 abs_value = (value < 0) ? -value : value; 471 | if (abs_value >= max_fixnum) 472 | return Make_Bignum(value); 473 | else 474 | return Make_Fixnum(value); 475 | } 476 | 477 | // Bignums are tricky to work with, here are some basic numeric 478 | // operations that can be applied to them (more can be found in 479 | // ,NUMBER) 480 | bool Integer_Negative(Cell cell); 481 | bool Integer_Equal(Cell one, Cell two); 482 | bool Integer_Less(Cell one, Cell two); 483 | 484 | Cell Integer_Quotient(Cell one, Cell two); 485 | Cell Integer_Remainder(Cell one, Cell two); 486 | Cell Integer_Modulo(Cell one, Cell two); 487 | 488 | // ,RATIONAL 489 | // Rational number are implemented as two integer (fixnum or bignum) 490 | // values. They are always simplified on creation. 491 | 492 | struct Rational_Data 493 | { 494 | Cell numerator, denominator; 495 | }; 496 | 497 | inline bool Is_Rational(Cell cell) 498 | { 499 | return Is_Compound(cell) && Get_Type(cell) == rational_type; 500 | } 501 | Cell Make_Simplified_Rational(Cell numerator, Cell denominator); 502 | 503 | inline Cell& Rational_Numerator(const Cell cell) 504 | { 505 | return Extract(cell).numerator; 506 | } 507 | inline Cell& Rational_Denominator(const Cell cell) 508 | { 509 | return Extract(cell).denominator; 510 | } 511 | 512 | // ,REAL 513 | // Reals are C++ doubles wrapped up in a cell 514 | 515 | inline bool Is_Real(Cell cell) 516 | { 517 | return Is_Compound(cell) && Get_Type(cell) == real_type; 518 | } 519 | Cell Make_Real(double value); 520 | inline double Real_Value(Cell cell) 521 | { 522 | return Extract(cell); 523 | } 524 | 525 | // ,NUMBER 526 | 527 | // The Num_Type system is used to conveniently 'promote' numbers to 528 | // other number types. 529 | enum Num_Type { 530 | n_fixnum = 0, 531 | n_bignum = 1, 532 | n_rational = 2, 533 | n_real = 3 534 | }; 535 | 536 | Num_Type Number_Type(Cell cell); 537 | // Be careful with Promote_Number, promoting fixnums leads to bignums 538 | // that should be fixnums and promoting bignums leads to rationals 539 | // that have a denominator of 1 - other procedures can get confused by 540 | // such objects. 541 | Cell Promote_Number(Cell num, Num_Type type); 542 | 543 | inline bool Is_Number(Cell cell) 544 | { 545 | return Is_Integer(cell) || Is_Real(cell) || Is_Rational(cell); 546 | } 547 | 548 | // Get the double value of any type of number, can be convenient with 549 | // all those different types confusing your code. 550 | double Number_To_Double(Cell cell); 551 | 552 | // Basic operations on any kind of number cells. 553 | Cell Number_Add(Cell one, Cell two); 554 | Cell Number_Subtract(Cell one, Cell two); 555 | Cell Number_Multiply(Cell one, Cell two); 556 | Cell Number_Divide(Cell one, Cell two); 557 | 558 | // ,SYMBOL 559 | // Symbol cells, see symbol.hpp and symbol.cpp for the implementation 560 | // of the symbol table. 561 | 562 | inline bool Is_Symbol(Cell cell) 563 | { 564 | return Match_Fourbit(cell, symbol_pattern); 565 | } 566 | inline Cell Make_Symbol(Symbol symbol) 567 | { 568 | return Encode_Fourbit(symbol, symbol_pattern); 569 | } 570 | inline Cell Make_Symbol(const std::string& name) 571 | { 572 | return Make_Symbol(Get_Symbol(name)); 573 | } 574 | inline Symbol Symbol_Value(Cell cell) 575 | { 576 | return Extract_Fourbit(cell); 577 | } 578 | inline const std::string& Symbol_Name(Cell cell) 579 | { 580 | return Get_Symbol_Name(Symbol_Value(cell)); 581 | } 582 | 583 | // ,CHARACTER 584 | 585 | inline bool Is_Character(Cell cell) 586 | { 587 | return Match_Sixbit(cell, char_pattern); 588 | } 589 | inline Cell Make_Character(int c) 590 | { 591 | return Encode_Sixbit(c, char_pattern); 592 | } 593 | inline int Character_Value(Cell cell) 594 | { 595 | return Extract_Sixbit(cell); 596 | } 597 | 598 | // ,PAIR 599 | 600 | struct Pair 601 | { 602 | Cell car, cdr; 603 | }; 604 | 605 | inline bool Is_Pair(Cell cell) 606 | { 607 | return Is_Compound(cell) && Get_Type(cell) == pair_type; 608 | } 609 | 610 | // Car and Cdr are used both for getting and setting values. 611 | inline Cell& Car(const Cell cell) 612 | { 613 | S_ASSERT(Is_Pair(cell)); 614 | return Extract(cell).car; 615 | } 616 | inline Cell& Cdr(const Cell cell) 617 | { 618 | S_ASSERT(Is_Pair(cell)); 619 | return Extract(cell).cdr; 620 | } 621 | 622 | // A number of cxr variants. 623 | inline Cell& Caar(const Cell cell) 624 | { 625 | return Car(Car(cell)); 626 | } 627 | inline Cell& Cdar(const Cell cell) 628 | { 629 | return Cdr(Car(cell)); 630 | } 631 | inline Cell& Cadr(const Cell cell) 632 | { 633 | return Car(Cdr(cell)); 634 | } 635 | inline Cell& Cddr(const Cell cell) 636 | { 637 | return Cdr(Cdr(cell)); 638 | } 639 | inline Cell& Caddr(const Cell cell) 640 | { 641 | return Car(Cdr(Cdr(cell))); 642 | } 643 | inline Cell& Cdaar(const Cell cell) 644 | { 645 | return Cdr(Car(Car(cell))); 646 | } 647 | inline Cell& Cadar(const Cell cell) 648 | { 649 | return Car(Cdr(Car(cell))); 650 | } 651 | inline Cell& Cddar(const Cell cell) 652 | { 653 | return Cdr(Cdr(Car(cell))); 654 | } 655 | inline Cell& Caadr(const Cell cell) 656 | { 657 | return Car(Car(Cdr(cell))); 658 | } 659 | inline Cell& Caaar(const Cell cell) 660 | { 661 | return Car(Car(Car(cell))); 662 | } 663 | 664 | inline Cell Cons(const MCell& car, const MCell& cdr) 665 | { 666 | Cell retval = Allocate_Cell(pair_type); 667 | Car(retval) = car; 668 | Cdr(retval) = cdr; 669 | return retval; 670 | } 671 | // Only use this when car and cdr are NOT compounds 672 | inline Cell XCons(Cell car, Cell cdr) 673 | { 674 | Cell retval = Allocate_Cell(pair_type); 675 | Car(retval) = car; 676 | Cdr(retval) = cdr; 677 | return retval; 678 | } 679 | // Conses null onto a cell 680 | inline Cell Cons_Null(const MCell& car) 681 | { 682 | Cell retval = Allocate_Cell(pair_type); 683 | Car(retval) = car; 684 | Cdr(retval) = null_cell; 685 | return retval; 686 | } 687 | 688 | size_t List_Length(Cell list, const char* error = "improper list"); 689 | bool Is_Proper_List(Cell list); 690 | 691 | bool Equal(Cell one, Cell two); 692 | bool Member(Cell value, Cell list); 693 | Cell Assoc(Cell needle, Cell list); 694 | 695 | // Easy way of building a list front to end. 696 | class List_Builder 697 | { 698 | public: 699 | void Add_Element(const MCell& cell) 700 | { 701 | if (_start == null_cell){ 702 | _start = Cons(cell, _start); 703 | _tail = _start; 704 | } 705 | else{ 706 | S_ASSERT(_tail != null_cell); 707 | Cdr(_tail) = Cons_Null(cell); 708 | _tail = Cdr(_tail); 709 | } 710 | } 711 | void Add_End(Cell cell) 712 | { 713 | if (_start == null_cell){ 714 | _start = cell; 715 | } 716 | else{ 717 | S_ASSERT(_tail != null_cell); 718 | Cdr(_tail) = cell; 719 | } 720 | _tail = null_cell; 721 | } 722 | const MCell& List() 723 | { 724 | return _start; 725 | } 726 | 727 | private: 728 | MCell _start, _tail; 729 | }; 730 | 731 | // ,STRING 732 | 733 | inline bool Is_String(Cell cell) 734 | { 735 | return Is_Compound(cell) && Get_Type(cell) == string_type; 736 | } 737 | Cell Make_String(const std::string& value); 738 | std::string String_Value(Cell cell); 739 | 740 | struct String_Data 741 | { 742 | size_t size; 743 | char data[1]; 744 | }; 745 | 746 | inline size_t String_Size(Cell cell) 747 | { 748 | S_ASSERT(Is_String(cell)); 749 | return Extract(cell).size; 750 | } 751 | inline char& String_Ref(Cell cell, size_t n) 752 | { 753 | S_ASSERT(Is_String(cell)); 754 | S_ASSERT(n < String_Size(cell)); 755 | return Extract(cell).data[n]; 756 | } 757 | 758 | // ,VECTOR 759 | 760 | inline bool Is_Vector(Cell cell) 761 | { 762 | return Is_Compound(cell) && Get_Type(cell) == vector_type; 763 | } 764 | 765 | // Some different ways of constructing vectors 766 | Cell Make_Vector(size_t size, Cell fill = null_cell); 767 | Cell Make_Vector(const MStack& stack); 768 | Cell Make_Vector_From_List(Cell list); 769 | 770 | struct Vector_Data 771 | { 772 | Cell size; 773 | Cell data[1]; 774 | }; 775 | 776 | inline size_t Vector_Size(Cell cell) 777 | { 778 | S_ASSERT(Is_Vector(cell)); 779 | return Fixnum_Value(Extract(cell).size); 780 | } 781 | inline Cell& Vector_Ref(Cell cell, size_t n) 782 | { 783 | S_ASSERT(Is_Vector(cell)); 784 | return Extract(cell).data[n]; 785 | } 786 | 787 | // ,PORT 788 | 789 | inline bool Is_Inport(Cell cell) 790 | { 791 | return Is_Compound(cell) && Get_Type(cell) == inport_type; 792 | } 793 | inline bool Is_Outport(Cell cell) 794 | { 795 | return Is_Compound(cell) && Get_Type(cell) == outport_type; 796 | } 797 | 798 | // Ports made with a filename have to be closed before they are 799 | // collected or they will leak memory. 800 | Cell Make_Inport(const MCell& filename); 801 | Cell Make_Outport(const MCell& filename); 802 | Cell Make_Inport(std::istream& stream); 803 | Cell Make_Outport(std::ostream& stream); 804 | 805 | Cell Inport_Read_Char(Cell port); 806 | Cell Inport_Peek_Char(Cell port); 807 | 808 | struct Inport_Data 809 | { 810 | Cell file_name; 811 | std::istream* stream; 812 | size_t position, line; 813 | }; 814 | struct Outport_Data 815 | { 816 | Cell file_name; 817 | std::ostream* stream; 818 | }; 819 | 820 | std::istream& Inport_Stream(Cell port); 821 | std::ostream& Outport_Stream(Cell cell); 822 | size_t Inport_Line(Cell port); 823 | 824 | inline bool Inport_Is_Open(Cell cell) 825 | { 826 | S_ASSERT(Is_Inport(cell)); 827 | return Extract(cell).stream != NULL; 828 | } 829 | inline bool Outport_Is_Open(Cell cell) 830 | { 831 | S_ASSERT(Is_Outport(cell)); 832 | return Extract(cell).stream != NULL; 833 | } 834 | 835 | void Close_Inport(Cell cell); 836 | void Close_Outport(Cell cell); 837 | 838 | // ,NAMESPACE 839 | 840 | inline bool Is_Namespace(Cell cell) 841 | { 842 | return Is_Compound(cell) && Get_Type(cell) == namespace_type; 843 | } 844 | 845 | // ,CLOSURE 846 | 847 | // Closures contain compiled code, the number of arguments they take, 848 | // the environment in which they were created and optionally name. 849 | // This is not exposed in this header though, client code shouldn't 850 | // need to manipulate closures directly. 851 | inline bool Is_Closure(Cell cell) 852 | { 853 | return Is_Compound(cell) && Get_Type(cell) == closure_type; 854 | } 855 | Cell Closure_Name(Cell cell); 856 | 857 | // ,PRIMITIVE 858 | 859 | // Primitives contain a function pointer pointing to a function of one 860 | // of the 9 types shown below, a number of arguments and a name. This 861 | // looks very ugly but the advantage is that you can easily define 862 | // primitives with up to 8 arguments. The Make_Primitive will make a 863 | // primitive with the correct number of arguments based on the type of 864 | // function you pass it. If var_arg is true the last argument will 865 | // behave like z in (lambda (x y . z) ....) 866 | typedef Cell (*Primitive_Function_0) (); 867 | typedef Cell (*Primitive_Function_1) (Cell one); 868 | typedef Cell (*Primitive_Function_2) (Cell one, Cell two); 869 | typedef Cell (*Primitive_Function_3) (Cell one, Cell two, Cell three); 870 | typedef Cell (*Primitive_Function_4) (Cell one, Cell two, Cell three, Cell four); 871 | typedef Cell (*Primitive_Function_5) (Cell one, Cell two, Cell three, Cell four, Cell five); 872 | typedef Cell (*Primitive_Function_6) (Cell one, Cell two, Cell three, Cell four, Cell five, Cell six); 873 | typedef Cell (*Primitive_Function_7) (Cell one, Cell two, Cell three, Cell four, Cell five, Cell six, Cell seven); 874 | typedef Cell (*Primitive_Function_8) (Cell one, Cell two, Cell three, Cell four, Cell five, Cell six, Cell seven, Cell eight); 875 | Cell Make_Primitive(Primitive_Function_0 function, const std::string& name, bool var_arg = false); 876 | Cell Make_Primitive(Primitive_Function_1 function, const std::string& name, bool var_arg = false); 877 | Cell Make_Primitive(Primitive_Function_2 function, const std::string& name, bool var_arg = false); 878 | Cell Make_Primitive(Primitive_Function_3 function, const std::string& name, bool var_arg = false); 879 | Cell Make_Primitive(Primitive_Function_4 function, const std::string& name, bool var_arg = false); 880 | Cell Make_Primitive(Primitive_Function_5 function, const std::string& name, bool var_arg = false); 881 | Cell Make_Primitive(Primitive_Function_6 function, const std::string& name, bool var_arg = false); 882 | Cell Make_Primitive(Primitive_Function_7 function, const std::string& name, bool var_arg = false); 883 | Cell Make_Primitive(Primitive_Function_8 function, const std::string& name, bool var_arg = false); 884 | 885 | inline bool Is_Primitive(Cell cell) 886 | { 887 | return Is_Compound(cell) && Get_Type(cell) == primitive_type; 888 | } 889 | 890 | // ,SYNTAX 891 | 892 | // 'Special form' means primitive syntax here - stuff like if, lambda, 893 | // quote are special forms. 894 | inline bool Is_Special_Form(Cell cell) 895 | { 896 | return Match_Sixbit(cell, form_pattern); 897 | } 898 | // Stuff defined by syntax-rules expressions are macros 899 | inline bool Is_Macro(Cell cell) 900 | { 901 | return Is_Compound(cell) && Get_Type(cell) == macro_type; 902 | } 903 | inline bool Is_Simple_Macro(Cell cell) 904 | { 905 | return Is_Compound(cell) && Get_Type(cell) == simple_macro_type; 906 | } 907 | inline bool Is_Syntax(Cell cell) 908 | { 909 | return Is_Special_Form(cell) || Is_Macro(cell) || Is_Simple_Macro(cell); 910 | } 911 | 912 | // ,CONTINUATION 913 | 914 | // These should not show up much on the outside. The things that 915 | // call/cc returns are actually closures with a continuation inside. 916 | // The only way to directly work with these is through the 917 | // #%current_continuation and #%set_continuation instructions. 918 | inline bool Is_Continuation(Cell cell) 919 | { 920 | return Is_Compound(cell) && Get_Type(cell) == continuation_type; 921 | } 922 | 923 | // ,INTERFACE 924 | 925 | // Define a top-level symbol to have a certain value. 926 | void Define_Symbol(const MCell& name_space, const std::string& name, const MCell& value); 927 | // Convenience function for defining primitives. 928 | template 929 | inline void Define_Primitive(const std::string& name, Function_Type function, bool var_arg = false) 930 | { 931 | Define_Symbol(ip_->work_env, name, Make_Primitive(function, name, var_arg)); 932 | } 933 | 934 | // Get the value that a binding has in a namespace. Looks through 935 | // parent namespaces too. 936 | Cell Get_Value(Cell name_space, Cell symbol); 937 | 938 | // Method to output a cell to an output stream. The display argument 939 | // indicates whether this is a 'display' or a 'write' action 940 | // (influences the way strings and characters are outputted). 941 | void Write(Cell cell, std::ostream& str, bool display = false); 942 | 943 | // Some convenience functions related to Write. 944 | inline std::ostream& operator<<(std::ostream& os, Cell cell) 945 | { 946 | Write(cell, os); 947 | return os; 948 | } 949 | std::string Cell_To_String(Cell cell, bool display = false); 950 | 951 | // Read a cell from a stream. 952 | Cell Read(std::istream& stream); 953 | inline std::istream& operator>>(std::istream& is, Cell& cell) 954 | { 955 | cell = Read(is); 956 | return is; 957 | } 958 | 959 | // Starts a read-eval-print loop. This will not return until in.input 960 | // is at eof. 961 | void Run_REPL(bool welcome_message = true); 962 | // Loads a file (just executes the load function defined in init.scm 963 | // with the file as argument) 964 | void Load_File(const std::string& filename); 965 | // Evaluate a string or an expression. Only the first expression in 966 | // the given string is evaluated. 967 | Cell Eval_String(const std::string& str, const MCell& name_space, bool handle_errors = false); 968 | inline Cell Eval_String(const std::string& str, bool handle_errors = false) 969 | { 970 | return Eval_String(str, ip_->work_env, handle_errors); 971 | } 972 | Cell Eval_Expression(Cell expression, Cell name_space, bool handle_errors = false); 973 | inline Cell Eval_Expression(Cell expression, bool handle_errors = false) 974 | { 975 | return Eval_Expression(expression, ip_->work_env, handle_errors); 976 | } 977 | 978 | // A read eval print loop that does not wait for input to come from a 979 | // stream but has to be fed strings to run. The return value of 980 | // Add_Line indicates whether anything got evaluated (if the new 981 | // string did not finish a full expression it is false). 982 | class String_REPL 983 | { 984 | public: 985 | bool Add_Line(const std::string& str); 986 | 987 | private: 988 | String_Input_Splitter _input; 989 | }; 990 | 991 | // This is useful if you want to poll the output instead of have it go 992 | // into a stream, basically just attaches itself to in.output and 993 | // gives you any new output every time you call Get_New_Output. Makes 994 | // the assumption that no one else messes with in.output while it is 995 | // alive. 996 | class Output_Catcher 997 | { 998 | public: 999 | Output_Catcher(); 1000 | ~Output_Catcher(); 1001 | std::string Get_New_Output(); 1002 | 1003 | private: 1004 | std::ostringstream _stream; 1005 | MCell _old_stream; 1006 | }; 1007 | 1008 | // Pointer wrappers are a convenient way of wrapping C++ objects in 1009 | // scheme cells. Make a class (T) inherit from Pointer_Wrapper, and 1010 | // then you can call Init_Type on it somewhere in your initialization 1011 | // code, passing it the name of the constructor function for this 1012 | // type, the actual function you want to use for constructing such 1013 | // object, and optionally a specialized write function. The class 1014 | // provides a convenient function for creating the actual scheme cells 1015 | // from a pointer - Wrap_Object. The reason you still have to write 1016 | // the actual constructor function yourself is that you may want to 1017 | // have it take arguments, or behave in some special way. 1018 | #ifdef WITH_DESTRUCTORS 1019 | template 1020 | class Pointer_Wrapper 1021 | { 1022 | public: 1023 | static Cell_Type type_id; 1024 | 1025 | static void Default_Write(Cell cell, std::ostream& str, bool display) 1026 | { 1027 | str << "#"; 1028 | } 1029 | static void Destroy(Cell data) 1030 | { 1031 | delete Extract(data); 1032 | } 1033 | 1034 | template 1035 | static void Init_Type(std::string constructor_name, Function_Type create, Write_Function write = Default_Write) 1036 | { 1037 | type_id = Make_Type(write, Destroy); 1038 | Define_Primitive(constructor_name, create); 1039 | } 1040 | 1041 | static Cell Wrap_Object(T* object) 1042 | { 1043 | Cell new_cell = Allocate_Cell(type_id, 0); 1044 | Extract(new_cell) = object; 1045 | return new_cell; 1046 | } 1047 | }; 1048 | 1049 | template 1050 | Cell_Type Pointer_Wrapper::type_id = 0; 1051 | #endif 1052 | 1053 | } 1054 | 1055 | #include "undef_error.hpp" 1056 | 1057 | #endif //SCHEME_HPP 1058 | --------------------------------------------------------------------------------